From 740f901b48a31e81622e75d3179f7be7c05be15d Mon Sep 17 00:00:00 2001 From: "Viral B. Shah" Date: Thu, 25 Apr 2013 10:17:37 +0530 Subject: [PATCH] Remove slatec since we do not use it. --- slatec/Make.files | 6 - slatec/aaaaaa.f | 71 - slatec/acosh.f | 39 - slatec/ai.f | 90 - slatec/aie.f | 133 -- slatec/albeta.f | 63 - slatec/algams.f | 38 - slatec/ali.f | 35 - slatec/alngam.f | 70 - slatec/alnrel.f | 78 - slatec/asinh.f | 74 - slatec/asyik.f | 144 -- slatec/asyjy.f | 491 ----- slatec/atanh.f | 72 - slatec/avint.f | 178 -- slatec/bakvec.f | 105 - slatec/balanc.f | 190 -- slatec/balbak.f | 101 - slatec/bandr.f | 288 --- slatec/bandv.f | 352 ---- slatec/bcrh.f | 33 - slatec/bdiff.f | 36 - slatec/besi.f | 462 ---- slatec/besi0.f | 71 - slatec/besi0e.f | 129 -- slatec/besi1.f | 76 - slatec/besi1e.f | 137 -- slatec/besj.f | 504 ----- slatec/besj0.f | 136 -- slatec/besj1.f | 138 -- slatec/besk.f | 277 --- slatec/besk0.f | 76 - slatec/besk0e.f | 119 -- slatec/besk1.f | 80 - slatec/besk1e.f | 124 -- slatec/beskes.f | 77 - slatec/besknu.f | 388 ---- slatec/besks.f | 50 - slatec/besy.f | 200 -- slatec/besy0.f | 141 -- slatec/besy1.f | 145 -- slatec/besynu.f | 353 ---- slatec/beta.f | 51 - slatec/betai.f | 118 -- slatec/bfqad.f | 134 -- slatec/bi.f | 130 -- slatec/bie.f | 206 -- slatec/binom.f | 73 - slatec/bint4.f | 238 --- slatec/bintk.f | 187 -- slatec/bisect.f | 284 --- slatec/bkias.f | 260 --- slatec/bkisr.f | 86 - slatec/bksol.f | 45 - slatec/blktr1.f | 249 --- slatec/blktri.f | 264 --- slatec/bndacc.f | 271 --- slatec/bndsol.f | 255 --- slatec/bnfac.f | 137 -- slatec/bnslv.f | 79 - slatec/bqr.f | 306 --- slatec/bsgq8.f | 193 -- slatec/bskin.f | 351 ---- slatec/bspdoc.f | 296 --- slatec/bspdr.f | 106 - slatec/bspev.f | 138 -- slatec/bsplvd.f | 70 - slatec/bsplvn.f | 47 - slatec/bsppp.f | 95 - slatec/bspvd.f | 163 -- slatec/bspvn.f | 124 -- slatec/bsqad.f | 144 -- slatec/bsrh.f | 33 - slatec/bvalu.f | 165 -- slatec/bvder.f | 102 - slatec/bvpor.f | 294 --- slatec/bvsup.f | 694 ------ slatec/c0lgmc.f | 42 - slatec/c1merg.f | 68 - slatec/c9lgmc.f | 89 - slatec/c9ln2r.f | 73 - slatec/cacai.f | 101 - slatec/cacon.f | 160 -- slatec/cacos.f | 30 - slatec/cacosh.f | 29 - slatec/cairy.f | 342 --- slatec/carg.f | 31 - slatec/casin.f | 66 - slatec/casinh.f | 29 - slatec/casyi.f | 136 -- slatec/catan.f | 76 - slatec/catan2.f | 47 - slatec/catanh.f | 29 - slatec/caxpy.f | 73 - slatec/cbabk2.f | 108 - slatec/cbal.f | 207 -- slatec/cbesh.f | 331 --- slatec/cbesi.f | 261 --- slatec/cbesj.f | 259 --- slatec/cbesk.f | 281 --- slatec/cbesy.f | 236 --- slatec/cbeta.f | 49 - slatec/cbinu.f | 115 - slatec/cbiry.f | 319 --- slatec/cbknu.f | 466 ----- slatec/cblkt1.f | 251 --- slatec/cblktr.f | 267 --- slatec/cbrt.f | 54 - slatec/cbuni.f | 169 -- slatec/cbunk.f | 47 - slatec/ccbrt.f | 31 - slatec/cchdc.f | 253 --- slatec/cchdd.f | 202 -- slatec/cchex.f | 267 --- slatec/cchud.f | 160 -- slatec/ccmpb.f | 109 - slatec/ccopy.f | 71 - slatec/ccosh.f | 29 - slatec/ccot.f | 50 - slatec/cdcdot.f | 71 - slatec/cdcor.f | 194 -- slatec/cdcst.f | 106 - slatec/cdiv.f | 33 - slatec/cdntl.f | 183 -- slatec/cdntp.f | 54 - slatec/cdotc.f | 73 - slatec/cdotu.f | 72 - slatec/cdpsc.f | 40 - slatec/cdpst.f | 283 --- slatec/cdriv1.f | 367 ---- slatec/cdriv2.f | 409 ---- slatec/cdriv3.f | 1577 -------------- slatec/cdscl.f | 38 - slatec/cdstp.f | 460 ---- slatec/cdzro.f | 135 -- slatec/cexprl.f | 53 - slatec/cfftb.f | 88 - slatec/cfftb1.f | 131 -- slatec/cfftf.f | 90 - slatec/cfftf1.f | 133 -- slatec/cffti.f | 64 - slatec/cffti1.f | 114 - slatec/cfod.f | 132 -- slatec/cg.f | 97 - slatec/cgamma.f | 28 - slatec/cgamr.f | 36 - slatec/cgbco.f | 282 --- slatec/cgbdi.f | 89 - slatec/cgbfa.f | 190 -- slatec/cgbmv.f | 329 --- slatec/cgbsl.f | 149 -- slatec/cgeco.f | 211 -- slatec/cgedi.f | 143 -- slatec/cgeev.f | 187 -- slatec/cgefa.f | 120 -- slatec/cgefs.f | 168 -- slatec/cgeir.f | 198 -- slatec/cgemm.f | 421 ---- slatec/cgemv.f | 288 --- slatec/cgerc.f | 165 -- slatec/cgeru.f | 165 -- slatec/cgesl.f | 131 -- slatec/cgtsl.f | 134 -- slatec/ch.f | 108 - slatec/changes | 10 - slatec/chbmv.f | 317 --- slatec/chemm.f | 311 --- slatec/chemv.f | 272 --- slatec/cher.f | 220 -- slatec/cher2.f | 257 --- slatec/cher2k.f | 370 ---- slatec/cherk.f | 327 --- slatec/chfcm.f | 151 -- slatec/chfdv.f | 165 -- slatec/chfev.f | 155 -- slatec/chfie.f | 108 - slatec/chico.f | 264 --- slatec/chidi.f | 234 --- slatec/chiev.f | 202 -- slatec/chifa.f | 242 --- slatec/chisl.f | 187 -- slatec/chkder.f | 158 -- slatec/chkpr4.f | 70 - slatec/chkprm.f | 81 - slatec/chksn4.f | 59 - slatec/chksng.f | 66 - slatec/chpco.f | 305 --- slatec/chpdi.f | 261 --- slatec/chpfa.f | 284 --- slatec/chpmv.f | 277 --- slatec/chpr.f | 224 -- slatec/chpr2.f | 258 --- slatec/chpsl.f | 196 -- slatec/chu.f | 166 -- slatec/cinvit.f | 301 --- slatec/ckscl.f | 112 - slatec/clbeta.f | 38 - slatec/clngam.f | 92 - slatec/clnrel.f | 46 - slatec/clog10.f | 31 - slatec/cmgnbn.f | 366 ---- slatec/cmlri.f | 166 -- slatec/cmpcsg.f | 68 - slatec/cmposd.f | 334 --- slatec/cmposn.f | 563 ----- slatec/cmposp.f | 130 -- slatec/cmptr3.f | 113 - slatec/cmptrx.f | 73 - slatec/cnbco.f | 280 --- slatec/cnbdi.f | 86 - slatec/cnbfa.f | 183 -- slatec/cnbfs.f | 251 --- slatec/cnbir.f | 284 --- slatec/cnbsl.f | 149 -- slatec/combak.f | 115 - slatec/comhes.f | 142 -- slatec/comlr.f | 231 -- slatec/comlr2.f | 383 ---- slatec/compb.f | 109 - slatec/comqr.f | 249 --- slatec/comqr2.f | 426 ---- slatec/cortb.f | 125 -- slatec/corth.f | 159 -- slatec/cosdg.f | 37 - slatec/cosgen.f | 67 - slatec/cosqb.f | 85 - slatec/cosqb1.f | 57 - slatec/cosqf.f | 83 - slatec/cosqf1.f | 55 - slatec/cosqi.f | 61 - slatec/cost.f | 112 - slatec/costi.f | 66 - slatec/cot.f | 99 - slatec/cpadd.f | 164 -- slatec/cpbco.f | 267 --- slatec/cpbdi.f | 83 - slatec/cpbfa.f | 107 - slatec/cpbsl.f | 97 - slatec/cpevl.f | 74 - slatec/cpevlr.f | 31 - slatec/cpoco.f | 212 -- slatec/cpodi.f | 136 -- slatec/cpofa.f | 81 - slatec/cpofs.f | 168 -- slatec/cpoir.f | 207 -- slatec/cposl.f | 86 - slatec/cppco.f | 237 --- slatec/cppdi.f | 142 -- slatec/cppfa.f | 100 - slatec/cppsl.f | 81 - slatec/cpqr79.f | 110 - slatec/cproc.f | 112 - slatec/cprocp.f | 134 -- slatec/cprod.f | 114 - slatec/cprodp.f | 138 -- slatec/cpsi.f | 110 - slatec/cptsl.f | 106 - slatec/cpzero.f | 140 -- slatec/cqrdc.f | 229 -- slatec/cqrsl.f | 291 --- slatec/crati.f | 111 - slatec/crotg.f | 60 - slatec/cs1s2.f | 55 - slatec/cscal.f | 68 - slatec/cscale.f | 74 - slatec/cseri.f | 164 -- slatec/csevl.f | 65 - slatec/cshch.f | 36 - slatec/csico.f | 265 --- slatec/csidi.f | 210 -- slatec/csifa.f | 240 --- slatec/csinh.f | 30 - slatec/csisl.f | 188 -- slatec/cspco.f | 305 --- slatec/cspdi.f | 238 --- slatec/cspfa.f | 280 --- slatec/cspsl.f | 197 -- slatec/csroot.f | 33 - slatec/csrot.f | 85 - slatec/csscal.f | 69 - slatec/csvdc.f | 513 ----- slatec/cswap.f | 76 - slatec/csymm.f | 303 --- slatec/csyr2k.f | 331 --- slatec/csyrk.f | 299 --- slatec/ctan.f | 50 - slatec/ctanh.f | 29 - slatec/ctbmv.f | 385 ---- slatec/ctbsv.f | 388 ---- slatec/ctpmv.f | 345 --- slatec/ctpsv.f | 348 ---- slatec/ctrco.f | 179 -- slatec/ctrdi.f | 149 -- slatec/ctrmm.f | 399 ---- slatec/ctrmv.f | 328 --- slatec/ctrsl.f | 150 -- slatec/ctrsm.f | 421 ---- slatec/ctrsv.f | 331 --- slatec/cuchk.f | 42 - slatec/cunhj.f | 658 ------ slatec/cuni1.f | 178 -- slatec/cuni2.f | 225 -- slatec/cunik.f | 198 -- slatec/cunk1.f | 353 ---- slatec/cunk2.f | 403 ---- slatec/cuoik.f | 170 -- slatec/cv.f | 124 -- slatec/cwrsk.f | 86 - slatec/d1mach.f | 502 ----- slatec/d1merg.f | 63 - slatec/d1mpyq.f | 100 - slatec/d1updt.f | 212 -- slatec/d9aimp.f | 482 ----- slatec/d9atn1.f | 109 - slatec/d9b0mp.f | 247 --- slatec/d9b1mp.f | 249 --- slatec/d9chu.f | 97 - slatec/d9gmic.f | 98 - slatec/d9gmit.f | 91 - slatec/d9knus.f | 252 --- slatec/d9lgic.f | 54 - slatec/d9lgit.f | 67 - slatec/d9lgmc.f | 76 - slatec/d9ln2r.f | 167 -- slatec/d9pak.f | 69 - slatec/d9upak.f | 44 - slatec/dacosh.f | 40 - slatec/dai.f | 100 - slatec/daie.f | 220 -- slatec/dasinh.f | 89 - slatec/dasum.f | 80 - slatec/dasyik.f | 145 -- slatec/dasyjy.f | 493 ----- slatec/datanh.f | 83 - slatec/davint.f | 214 -- slatec/daws.f | 153 -- slatec/daxpy.f | 92 - slatec/dbcg.f | 377 ---- slatec/dbdiff.f | 37 - slatec/dbesi.f | 467 ----- slatec/dbesi0.f | 78 - slatec/dbesi1.f | 83 - slatec/dbesj.f | 508 ----- slatec/dbesj0.f | 73 - slatec/dbesj1.f | 82 - slatec/dbesk.f | 280 --- slatec/dbesk0.f | 83 - slatec/dbesk1.f | 86 - slatec/dbesks.f | 50 - slatec/dbesy.f | 203 -- slatec/dbesy0.f | 78 - slatec/dbesy1.f | 84 - slatec/dbeta.f | 53 - slatec/dbetai.f | 120 -- slatec/dbfqad.f | 137 -- slatec/dbhin.f | 286 --- slatec/dbi.f | 148 -- slatec/dbie.f | 322 --- slatec/dbinom.f | 75 - slatec/dbint4.f | 241 --- slatec/dbintk.f | 189 -- slatec/dbkias.f | 261 --- slatec/dbkisr.f | 87 - slatec/dbksol.f | 50 - slatec/dbndac.f | 270 --- slatec/dbndsl.f | 254 --- slatec/dbnfac.f | 139 -- slatec/dbnslv.f | 81 - slatec/dbocls.f | 1147 ---------- slatec/dbols.f | 837 -------- slatec/dbolsm.f | 1188 ----------- slatec/dbsgq8.f | 195 -- slatec/dbsi0e.f | 208 -- slatec/dbsi1e.f | 218 -- slatec/dbsk0e.f | 164 -- slatec/dbsk1e.f | 169 -- slatec/dbskes.f | 77 - slatec/dbskin.f | 353 ---- slatec/dbsknu.f | 393 ---- slatec/dbspdr.f | 107 - slatec/dbspev.f | 137 -- slatec/dbsppp.f | 94 - slatec/dbspvd.f | 162 -- slatec/dbspvn.f | 123 -- slatec/dbsqad.f | 149 -- slatec/dbsynu.f | 358 ---- slatec/dbvalu.f | 165 -- slatec/dbvder.f | 104 - slatec/dbvpor.f | 341 --- slatec/dbvsup.f | 736 ------- slatec/dcbrt.f | 57 - slatec/dcdot.f | 63 - slatec/dcfod.f | 145 -- slatec/dcg.f | 345 --- slatec/dcgn.f | 372 ---- slatec/dcgs.f | 377 ---- slatec/dchdc.f | 251 --- slatec/dchdd.f | 202 -- slatec/dchex.f | 267 --- slatec/dchfcm.f | 152 -- slatec/dchfdv.f | 170 -- slatec/dchfev.f | 160 -- slatec/dchfie.f | 109 - slatec/dchkw.f | 112 - slatec/dchu.f | 167 -- slatec/dchud.f | 159 -- slatec/dckder.f | 159 -- slatec/dcoef.f | 197 -- slatec/dcopy.f | 93 - slatec/dcopym.f | 83 - slatec/dcosdg.f | 37 - slatec/dcot.f | 108 - slatec/dcov.f | 273 --- slatec/dcpplt.f | 198 -- slatec/dcscal.f | 98 - slatec/dcsevl.f | 65 - slatec/dcv.f | 133 -- slatec/ddaini.f | 258 --- slatec/ddajac.f | 177 -- slatec/ddanrm.f | 46 - slatec/ddaslv.f | 61 - slatec/ddassl.f | 1604 -------------- slatec/ddastp.f | 613 ------ slatec/ddatrp.f | 65 - slatec/ddaws.f | 229 -- slatec/ddawts.f | 43 - slatec/ddcor.f | 193 -- slatec/ddcst.f | 106 - slatec/ddeabm.f | 688 ------ slatec/ddebdf.f | 933 --------- slatec/dderkf.f | 698 ------- slatec/ddes.f | 430 ---- slatec/ddntl.f | 182 -- slatec/ddntp.f | 53 - slatec/ddoglg.f | 183 -- slatec/ddot.f | 89 - slatec/ddpsc.f | 40 - slatec/ddpst.f | 287 --- slatec/ddriv1.f | 365 ---- slatec/ddriv2.f | 411 ---- slatec/ddriv3.f | 1528 -------------- slatec/ddscl.f | 37 - slatec/ddstp.f | 459 ---- slatec/ddzro.f | 134 -- slatec/de1.f | 459 ---- slatec/deabm.f | 671 ------ slatec/debdf.f | 925 -------- slatec/defc.f | 268 --- slatec/defcmn.f | 236 --- slatec/defe4.f | 73 - slatec/defehl.f | 91 - slatec/defer.f | 76 - slatec/dei.f | 35 - slatec/denorm.f | 116 -- slatec/derf.f | 83 - slatec/derfc.f | 226 -- slatec/derkf.f | 688 ------ slatec/derkfs.f | 592 ------ slatec/des.f | 433 ---- slatec/dexbvp.f | 117 -- slatec/dexint.f | 336 --- slatec/dexprl.f | 55 - slatec/dfac.f | 77 - slatec/dfc.f | 412 ---- slatec/dfcmn.f | 395 ---- slatec/dfdjc1.f | 155 -- slatec/dfdjc3.f | 116 -- slatec/dfehl.f | 107 - slatec/dfspvd.f | 73 - slatec/dfspvn.f | 50 - slatec/dfulmt.f | 86 - slatec/dfzero.f | 225 -- slatec/dgami.f | 46 - slatec/dgamic.f | 129 -- slatec/dgamit.f | 119 -- slatec/dgamlm.f | 62 - slatec/dgamln.f | 198 -- slatec/dgamma.f | 153 -- slatec/dgamr.f | 44 - slatec/dgamrn.f | 107 - slatec/dgaus8.f | 201 -- slatec/dgbco.f | 278 --- slatec/dgbdi.f | 86 - slatec/dgbfa.f | 187 -- slatec/dgbmv.f | 307 --- slatec/dgbsl.f | 149 -- slatec/dgeco.f | 207 -- slatec/dgedi.f | 141 -- slatec/dgefa.f | 117 -- slatec/dgefs.f | 165 -- slatec/dgemm.f | 319 --- slatec/dgemv.f | 268 --- slatec/dger.f | 164 -- slatec/dgesl.f | 131 -- slatec/dglss.f | 146 -- slatec/dgmres.f | 553 ----- slatec/dgtsl.f | 132 -- slatec/dh12.f | 143 -- slatec/dhels.f | 98 - slatec/dheqr.f | 178 -- slatec/dhfti.f | 331 --- slatec/dhkseq.f | 159 -- slatec/dhstrt.f | 350 ---- slatec/dhvnrm.f | 36 - slatec/dintp.f | 141 -- slatec/dintrv.f | 118 -- slatec/dintyd.f | 112 - slatec/dir.f | 332 --- slatec/djairy.f | 346 --- slatec/dlbeta.f | 62 - slatec/dlgams.f | 37 - slatec/dli.f | 34 - slatec/dllsia.f | 315 --- slatec/dllti2.f | 168 -- slatec/dlngam.f | 73 - slatec/dlnrel.f | 98 - slatec/dlpdoc.f | 460 ---- slatec/dlpdp.f | 208 -- slatec/dlsei.f | 735 ------- slatec/dlsi.f | 338 --- slatec/dlsod.f | 473 ----- slatec/dlssud.f | 318 --- slatec/dmacon.f | 35 - slatec/dmgsbv.f | 309 --- slatec/dmout.f | 185 -- slatec/dmpar.f | 271 --- slatec/dnbco.f | 273 --- slatec/dnbdi.f | 83 - slatec/dnbfa.f | 179 -- slatec/dnbfs.f | 250 --- slatec/dnbsl.f | 149 -- slatec/dnls1.f | 1018 --------- slatec/dnls1e.f | 536 ----- slatec/dnrm2.f | 162 -- slatec/dnsq.f | 752 ------- slatec/dnsqe.f | 380 ---- slatec/dogleg.f | 181 -- slatec/dohtrl.f | 58 - slatec/domn.f | 364 ---- slatec/dorth.f | 125 -- slatec/dorthr.f | 204 -- slatec/dp1vlu.f | 151 -- slatec/dpbco.f | 263 --- slatec/dpbdi.f | 82 - slatec/dpbfa.f | 106 - slatec/dpbsl.f | 97 - slatec/dpchbs.f | 217 -- slatec/dpchce.f | 247 --- slatec/dpchci.f | 185 -- slatec/dpchcm.f | 237 --- slatec/dpchcs.f | 237 --- slatec/dpchdf.f | 108 - slatec/dpchfd.f | 324 --- slatec/dpchfe.f | 310 --- slatec/dpchia.f | 269 --- slatec/dpchic.f | 347 --- slatec/dpchid.f | 195 -- slatec/dpchim.f | 283 --- slatec/dpchkt.f | 96 - slatec/dpchng.f | 257 --- slatec/dpchsp.f | 392 ---- slatec/dpchst.f | 59 - slatec/dpchsw.f | 197 -- slatec/dpcoef.f | 78 - slatec/dpfqad.f | 133 -- slatec/dpigmr.f | 439 ---- slatec/dpincw.f | 135 -- slatec/dpinit.f | 231 -- slatec/dpintm.f | 105 - slatec/dpjac.f | 227 -- slatec/dplint.f | 63 - slatec/dplpce.f | 184 -- slatec/dplpdm.f | 113 - slatec/dplpfe.f | 164 -- slatec/dplpfl.f | 157 -- slatec/dplpmn.f | 988 --------- slatec/dplpmu.f | 433 ---- slatec/dplpup.f | 214 -- slatec/dpnnzr.f | 260 --- slatec/dpoch.f | 102 - slatec/dpoch1.f | 160 -- slatec/dpoco.f | 208 -- slatec/dpodi.f | 136 -- slatec/dpofa.f | 83 - slatec/dpofs.f | 164 -- slatec/dpolcf.f | 96 - slatec/dpolft.f | 357 ---- slatec/dpolvl.f | 207 -- slatec/dpopt.f | 379 ---- slatec/dposl.f | 86 - slatec/dppco.f | 234 --- slatec/dppdi.f | 142 -- slatec/dpperm.f | 85 - slatec/dppfa.f | 101 - slatec/dppgq8.f | 197 -- slatec/dppqad.f | 111 - slatec/dppsl.f | 81 - slatec/dppval.f | 104 - slatec/dprvec.f | 34 - slatec/dprwpg.f | 79 - slatec/dprwvr.f | 65 - slatec/dpsi.f | 163 -- slatec/dpsifn.f | 368 ---- slatec/dpsixn.f | 122 -- slatec/dpsort.f | 269 --- slatec/dptsl.f | 106 - slatec/dqag.f | 193 -- slatec/dqage.f | 351 ---- slatec/dqagi.f | 204 -- slatec/dqagie.f | 463 ---- slatec/dqagp.f | 237 --- slatec/dqagpe.f | 561 ----- slatec/dqags.f | 200 -- slatec/dqagse.f | 455 ---- slatec/dqawc.f | 190 -- slatec/dqawce.f | 338 --- slatec/dqawf.f | 243 --- slatec/dqawfe.f | 374 ---- slatec/dqawo.f | 237 --- slatec/dqawoe.f | 542 ----- slatec/dqaws.f | 212 -- slatec/dqawse.f | 381 ---- slatec/dqc25c.f | 169 -- slatec/dqc25f.f | 362 ---- slatec/dqc25s.f | 345 --- slatec/dqcheb.f | 160 -- slatec/dqdota.f | 89 - slatec/dqdoti.f | 90 - slatec/dqelg.f | 196 -- slatec/dqform.f | 103 - slatec/dqk15.f | 185 -- slatec/dqk15i.f | 198 -- slatec/dqk15w.f | 190 -- slatec/dqk21.f | 193 -- slatec/dqk31.f | 202 -- slatec/dqk41.f | 218 -- slatec/dqk51.f | 231 -- slatec/dqk61.f | 241 --- slatec/dqmomo.f | 137 -- slatec/dqnc79.f | 275 --- slatec/dqng.f | 386 ---- slatec/dqpsrt.f | 142 -- slatec/dqrdc.f | 223 -- slatec/dqrfac.f | 172 -- slatec/dqrsl.f | 289 --- slatec/dqrslv.f | 201 -- slatec/dqwgtc.f | 30 - slatec/dqwgtf.f | 35 - slatec/dqwgts.f | 40 - slatec/drc.f | 333 --- slatec/drc3jj.f | 428 ---- slatec/drc3jm.f | 423 ---- slatec/drc6j.f | 439 ---- slatec/drd.f | 411 ---- slatec/dreadp.f | 44 - slatec/dreort.f | 230 -- slatec/drf.f | 340 --- slatec/drj.f | 405 ---- slatec/drkfab.f | 249 --- slatec/drkfs.f | 726 ------- slatec/drlcal.f | 116 -- slatec/drot.f | 89 - slatec/drotg.f | 108 - slatec/drotm.f | 150 -- slatec/drotmg.f | 209 -- slatec/drsco.f | 47 - slatec/ds2lt.f | 139 -- slatec/ds2y.f | 209 -- slatec/dsbmv.f | 310 --- slatec/dscal.f | 80 - slatec/dsd2s.f | 151 -- slatec/dsdbcg.f | 272 --- slatec/dsdcg.f | 276 --- slatec/dsdcgn.f | 275 --- slatec/dsdcgs.f | 286 --- slatec/dsdgmr.f | 386 ---- slatec/dsdi.f | 88 - slatec/dsdomn.f | 263 --- slatec/dsdot.f | 74 - slatec/dsds.f | 125 -- slatec/dsdscl.f | 195 -- slatec/dsgs.f | 287 --- slatec/dsiccg.f | 315 --- slatec/dsico.f | 261 --- slatec/dsics.f | 342 --- slatec/dsidi.f | 229 -- slatec/dsifa.f | 237 --- slatec/dsilur.f | 307 --- slatec/dsilus.f | 361 ---- slatec/dsindg.f | 36 - slatec/dsisl.f | 187 -- slatec/dsjac.f | 263 --- slatec/dsli.f | 61 - slatec/dsli2.f | 139 -- slatec/dsllti.f | 63 - slatec/dslubc.f | 323 --- slatec/dslucn.f | 322 --- slatec/dslucs.f | 317 --- slatec/dslugm.f | 431 ---- slatec/dslui.f | 73 - slatec/dslui2.f | 205 -- slatec/dslui4.f | 204 -- slatec/dsluom.f | 323 --- slatec/dsluti.f | 71 - slatec/dslvs.f | 103 - slatec/dsmmi2.f | 239 --- slatec/dsmmti.f | 72 - slatec/dsmtv.f | 153 -- slatec/dsmv.f | 151 -- slatec/dsort.f | 324 --- slatec/dsos.f | 273 --- slatec/dsoseq.f | 501 ----- slatec/dsossl.f | 67 - slatec/dspco.f | 301 --- slatec/dspdi.f | 256 --- slatec/dspenc.f | 140 -- slatec/dspfa.f | 277 --- slatec/dsplp.f | 1683 --------------- slatec/dspmv.f | 269 --- slatec/dspr.f | 205 -- slatec/dspr2.f | 236 --- slatec/dspsl.f | 196 -- slatec/dsteps.f | 577 ----- slatec/dstod.f | 695 ------ slatec/dstor1.f | 80 - slatec/dstway.f | 86 - slatec/dsuds.f | 125 -- slatec/dsvco.f | 46 - slatec/dsvdc.f | 487 ----- slatec/dswap.f | 102 - slatec/dsymm.f | 300 --- slatec/dsymv.f | 268 --- slatec/dsyr.f | 204 -- slatec/dsyr2.f | 237 --- slatec/dsyr2k.f | 333 --- slatec/dsyrk.f | 299 --- slatec/dtbmv.f | 349 ---- slatec/dtbsv.f | 353 ---- slatec/dtin.f | 187 -- slatec/dtout.f | 154 -- slatec/dtpmv.f | 306 --- slatec/dtpsv.f | 309 --- slatec/dtrco.f | 175 -- slatec/dtrdi.f | 147 -- slatec/dtrmm.f | 361 ---- slatec/dtrmv.f | 293 --- slatec/dtrsl.f | 146 -- slatec/dtrsm.f | 384 ---- slatec/dtrsv.f | 296 --- slatec/du11ls.f | 296 --- slatec/du11us.f | 293 --- slatec/du12ls.f | 159 -- slatec/du12us.f | 156 -- slatec/dulsia.f | 323 --- slatec/dusrmt.f | 70 - slatec/dvecs.f | 69 - slatec/dvnrms.f | 36 - slatec/dvout.f | 137 -- slatec/dwnlit.f | 288 --- slatec/dwnlsm.f | 650 ------ slatec/dwnlt1.f | 64 - slatec/dwnlt2.f | 59 - slatec/dwnlt3.f | 44 - slatec/dwnnls.f | 327 --- slatec/dwritp.f | 44 - slatec/dwupdt.f | 123 -- slatec/dx.f | 98 - slatec/dx4.f | 98 - slatec/dxadd.f | 171 -- slatec/dxadj.f | 77 - slatec/dxc210.f | 113 - slatec/dxcon.f | 167 -- slatec/dxlcal.f | 185 -- slatec/dxlegf.f | 228 -- slatec/dxnrmp.f | 269 --- slatec/dxpmu.f | 69 - slatec/dxpmup.f | 76 - slatec/dxpnrm.f | 89 - slatec/dxpqnu.f | 193 -- slatec/dxpsi.f | 59 - slatec/dxqmu.f | 83 - slatec/dxqnu.f | 124 -- slatec/dxred.f | 85 - slatec/dxset.f | 331 --- slatec/dy.f | 99 - slatec/dy4.f | 99 - slatec/dyairy.f | 394 ---- slatec/e1.f | 295 --- slatec/efc.f | 268 --- slatec/efcmn.f | 236 --- slatec/ei.f | 34 - slatec/eisdoc.f | 279 --- slatec/elmbak.f | 106 - slatec/elmhes.f | 121 -- slatec/eltran.f | 102 - slatec/enorm.f | 117 -- slatec/erf.f | 73 - slatec/erfc.f | 156 -- slatec/exbvp.f | 104 - slatec/exint.f | 330 --- slatec/exprel.f | 53 - slatec/ezfft1.f | 89 - slatec/ezfftb.f | 119 -- slatec/ezfftf.f | 96 - slatec/ezffti.f | 47 - slatec/fac.f | 72 - slatec/fc.f | 411 ---- slatec/fcmn.f | 394 ---- slatec/fdjac1.f | 155 -- slatec/fdjac3.f | 114 - slatec/fdump.f | 31 - slatec/fftdoc.f | 66 - slatec/figi.f | 100 - slatec/figi2.f | 109 - slatec/fulmat.f | 85 - slatec/fundoc.f | 218 -- slatec/fzero.f | 223 -- slatec/gami.f | 45 - slatec/gamic.f | 127 -- slatec/gamit.f | 112 - slatec/gamlim.f | 61 - slatec/gamln.f | 198 -- slatec/gamma.f | 138 -- slatec/gamr.f | 42 - slatec/gamrn.f | 105 - slatec/gaus8.f | 195 -- slatec/genbun.f | 368 ---- slatec/guide | 2768 ------------------------ slatec/h12.f | 118 -- slatec/hfti.f | 288 --- slatec/hkseq.f | 158 -- slatec/hpperm.f | 95 - slatec/hpsort.f | 340 --- slatec/hqr.f | 245 --- slatec/hqr2.f | 434 ---- slatec/hstart.f | 328 --- slatec/hstcrt.f | 416 ---- slatec/hstcs1.f | 193 -- slatec/hstcsp.f | 446 ---- slatec/hstcyl.f | 461 ---- slatec/hstplr.f | 498 ----- slatec/hstssp.f | 583 ------ slatec/htrib3.f | 117 -- slatec/htribk.f | 121 -- slatec/htrid3.f | 190 -- slatec/htridi.f | 185 -- slatec/hvnrm.f | 31 - slatec/hw3crt.f | 627 ------ slatec/hwscrt.f | 466 ----- slatec/hwscs1.f | 264 --- slatec/hwscsp.f | 405 ---- slatec/hwscyl.f | 499 ----- slatec/hwsplr.f | 561 ----- slatec/hwsss1.f | 343 --- slatec/hwsssp.f | 400 ---- slatec/i1mach.f | 888 -------- slatec/i1merg.f | 60 - slatec/icamax.f | 88 - slatec/icopy.f | 86 - slatec/idamax.f | 82 - slatec/idloc.f | 74 - slatec/imtql1.f | 151 -- slatec/imtql2.f | 190 -- slatec/imtqlv.f | 185 -- slatec/indxa.f | 25 - slatec/indxb.f | 40 - slatec/indxc.f | 25 - slatec/initds.f | 54 - slatec/inits.f | 53 - slatec/intrv.f | 117 -- slatec/intyd.f | 99 - slatec/invit.f | 433 ---- slatec/inxca.f | 25 - slatec/inxcb.f | 38 - slatec/inxcc.f | 25 - slatec/iploc.f | 76 - slatec/ipperm.f | 83 - slatec/ipsort.f | 270 --- slatec/isamax.f | 82 - slatec/isdbcg.f | 239 --- slatec/isdcg.f | 229 -- slatec/isdcgn.f | 264 --- slatec/isdcgs.f | 261 --- slatec/isdgmr.f | 402 ---- slatec/isdir.f | 212 -- slatec/isdomn.f | 239 --- slatec/isort.f | 323 --- slatec/issbcg.f | 237 --- slatec/isscg.f | 227 -- slatec/isscgn.f | 263 --- slatec/isscgs.f | 257 --- slatec/issgmr.f | 400 ---- slatec/issir.f | 211 -- slatec/issomn.f | 236 --- slatec/iswap.f | 99 - slatec/ivout.f | 137 -- slatec/j4save.f | 65 - slatec/jairy.f | 344 --- slatec/la05ad.f | 516 ----- slatec/la05as.f | 513 ----- slatec/la05bd.f | 131 -- slatec/la05bs.f | 131 -- slatec/la05cd.f | 415 ---- slatec/la05cs.f | 416 ---- slatec/la05ed.f | 83 - slatec/la05es.f | 83 - slatec/llsia.f | 312 --- slatec/lmpar.f | 267 --- slatec/lpdp.f | 199 -- slatec/lsame.f | 101 - slatec/lsei.f | 733 ------- slatec/lsi.f | 336 --- slatec/lsod.f | 409 ---- slatec/lssods.f | 303 --- slatec/lssuds.f | 273 --- slatec/macon.f | 36 - slatec/mc20ad.f | 95 - slatec/mc20as.f | 95 - slatec/mgsbv.f | 260 --- slatec/minfit.f | 357 ---- slatec/minso4.f | 64 - slatec/minsol.f | 64 - slatec/mpadd.f | 27 - slatec/mpadd2.f | 95 - slatec/mpadd3.f | 116 -- slatec/mpblas.f | 78 - slatec/mpcdm.f | 92 - slatec/mpchk.f | 66 - slatec/mpcmd.f | 62 - slatec/mpdivi.f | 139 -- slatec/mperr.f | 41 - slatec/mpmaxr.f | 39 - slatec/mpmlp.f | 27 - slatec/mpmul.f | 98 - slatec/mpmul2.f | 114 - slatec/mpmuli.f | 28 - slatec/mpnzr.f | 105 - slatec/mpovfl.f | 44 - slatec/mpstr.f | 35 - slatec/mpunfl.f | 32 - slatec/numxer.f | 31 - slatec/ohtrol.f | 52 - slatec/ohtror.f | 52 - slatec/ortbak.f | 110 - slatec/orthes.f | 133 -- slatec/ortho4.f | 60 - slatec/orthog.f | 60 - slatec/orthol.f | 187 -- slatec/orthor.f | 185 -- slatec/ortran.f | 111 - slatec/passb.f | 146 -- slatec/passb2.f | 56 - slatec/passb3.f | 89 - slatec/passb4.f | 100 - slatec/passb5.f | 143 -- slatec/passf.f | 147 -- slatec/passf2.f | 56 - slatec/passf3.f | 89 - slatec/passf4.f | 100 - slatec/passf5.f | 143 -- slatec/pchbs.f | 216 -- slatec/pchce.f | 246 --- slatec/pchci.f | 184 -- slatec/pchcm.f | 236 --- slatec/pchcs.f | 235 --- slatec/pchdf.f | 106 - slatec/pchdoc.f | 213 -- slatec/pchfd.f | 320 --- slatec/pchfe.f | 308 --- slatec/pchia.f | 265 --- slatec/pchic.f | 341 --- slatec/pchid.f | 190 -- slatec/pchim.f | 280 --- slatec/pchkt.f | 95 - slatec/pchngs.f | 257 --- slatec/pchsp.f | 388 ---- slatec/pchst.f | 57 - slatec/pchsw.f | 192 -- slatec/pcoef.f | 78 - slatec/pfqad.f | 129 -- slatec/pgsf.f | 30 - slatec/pimach.f | 27 - slatec/pinitm.f | 105 - slatec/pjac.f | 184 -- slatec/pnnzrs.f | 259 --- slatec/poch.f | 98 - slatec/poch1.f | 145 -- slatec/pois3d.f | 333 --- slatec/poisd2.f | 331 --- slatec/poisn2.f | 559 ----- slatec/poisp2.f | 126 -- slatec/poistg.f | 354 ---- slatec/polcof.f | 94 - slatec/polfit.f | 352 ---- slatec/polint.f | 62 - slatec/polyvl.f | 203 -- slatec/pos3d1.f | 194 -- slatec/postg2.f | 542 ----- slatec/ppadd.f | 164 -- slatec/ppgq8.f | 193 -- slatec/ppgsf.f | 24 - slatec/pppsf.f | 24 - slatec/ppqad.f | 110 - slatec/ppsgf.f | 24 - slatec/ppspf.f | 24 - slatec/ppval.f | 103 - slatec/proc.f | 106 - slatec/procp.f | 123 -- slatec/prod.f | 103 - slatec/prodp.f | 119 -- slatec/prvec.f | 30 - slatec/prwpge.f | 79 - slatec/prwvir.f | 65 - slatec/psgf.f | 30 - slatec/psi.f | 127 -- slatec/psifn.f | 368 ---- slatec/psixn.f | 124 -- slatec/pvalue.f | 148 -- slatec/pythag.f | 39 - slatec/qag.f | 193 -- slatec/qage.f | 353 ---- slatec/qagi.f | 204 -- slatec/qagie.f | 469 ----- slatec/qagp.f | 236 --- slatec/qagpe.f | 569 ----- slatec/qags.f | 200 -- slatec/qagse.f | 459 ---- slatec/qawc.f | 190 -- slatec/qawce.f | 340 --- slatec/qawf.f | 244 --- slatec/qawfe.f | 376 ---- slatec/qawo.f | 236 --- slatec/qawoe.f | 547 ----- slatec/qaws.f | 212 -- slatec/qawse.f | 384 ---- slatec/qc25c.f | 170 -- slatec/qc25f.f | 359 ---- slatec/qc25s.f | 346 --- slatec/qcheb.f | 160 -- slatec/qelg.f | 196 -- slatec/qform.f | 102 - slatec/qk15.f | 172 -- slatec/qk15i.f | 200 -- slatec/qk15w.f | 193 -- slatec/qk21.f | 182 -- slatec/qk31.f | 184 -- slatec/qk41.f | 195 -- slatec/qk51.f | 202 -- slatec/qk61.f | 212 -- slatec/qmomo.f | 139 -- slatec/qnc79.f | 272 --- slatec/qng.f | 348 ---- slatec/qpdoc.f | 491 ----- slatec/qpsrt.f | 147 -- slatec/qrfac.f | 170 -- slatec/qrsolv.f | 198 -- slatec/qs2i1d.f | 253 --- slatec/qs2i1r.f | 251 --- slatec/qwgtc.f | 30 - slatec/qwgtf.f | 34 - slatec/qwgts.f | 40 - slatec/qzhes.f | 224 -- slatec/qzit.f | 387 ---- slatec/qzval.f | 310 --- slatec/qzvec.f | 278 --- slatec/r1mach.f | 419 ---- slatec/r1mpyq.f | 98 - slatec/r1updt.f | 209 -- slatec/r9aimp.f | 226 -- slatec/r9atn1.f | 87 - slatec/r9chu.f | 95 - slatec/r9gmic.f | 92 - slatec/r9gmit.f | 84 - slatec/r9knus.f | 220 -- slatec/r9lgic.f | 53 - slatec/r9lgit.f | 61 - slatec/r9lgmc.f | 66 - slatec/r9ln2r.f | 124 -- slatec/r9pak.f | 67 - slatec/r9upak.f | 40 - slatec/radb2.f | 61 - slatec/radb3.f | 85 - slatec/radb4.f | 109 - slatec/radb5.f | 132 -- slatec/radbg.f | 189 -- slatec/radf2.f | 61 - slatec/radf3.f | 83 - slatec/radf4.f | 105 - slatec/radf5.f | 128 -- slatec/radfg.f | 194 -- slatec/rand.f | 122 -- slatec/ratqr.f | 269 --- slatec/rc.f | 336 --- slatec/rc3jj.f | 427 ---- slatec/rc3jm.f | 422 ---- slatec/rc6j.f | 439 ---- slatec/rd.f | 408 ---- slatec/rebak.f | 90 - slatec/rebakb.f | 90 - slatec/reduc.f | 140 -- slatec/reduc2.f | 142 -- slatec/reort.f | 179 -- slatec/rf.f | 335 --- slatec/rfftb.f | 96 - slatec/rfftb1.f | 143 -- slatec/rfftf.f | 97 - slatec/rfftf1.f | 144 -- slatec/rffti.f | 62 - slatec/rffti1.f | 110 - slatec/rg.f | 106 - slatec/rgauss.f | 43 - slatec/rgg.f | 111 - slatec/rj.f | 409 ---- slatec/rkfab.f | 168 -- slatec/rpqr79.f | 103 - slatec/rpzero.f | 60 - slatec/rs.f | 90 - slatec/rsb.f | 112 - slatec/rsco.f | 45 - slatec/rsg.f | 96 - slatec/rsgab.f | 96 - slatec/rsgba.f | 96 - slatec/rsp.f | 111 - slatec/rst.f | 97 - slatec/rt.f | 102 - slatec/runif.f | 79 - slatec/rwupdt.f | 120 -- slatec/s1merg.f | 66 - slatec/sasum.f | 79 - slatec/saxpy.f | 92 - slatec/sbcg.f | 375 ---- slatec/sbhin.f | 286 --- slatec/sbocls.f | 1146 ---------- slatec/sbols.f | 837 -------- slatec/sbolsm.f | 1185 ----------- slatec/scasum.f | 71 - slatec/scg.f | 343 --- slatec/scgn.f | 371 ---- slatec/scgs.f | 374 ---- slatec/schdc.f | 249 --- slatec/schdd.f | 201 -- slatec/schex.f | 266 --- slatec/schkw.f | 112 - slatec/schud.f | 158 -- slatec/sclosm.f | 33 - slatec/scnrm2.f | 171 -- slatec/scoef.f | 166 -- slatec/scopy.f | 93 - slatec/scopym.f | 84 - slatec/scov.f | 264 --- slatec/scpplt.f | 196 -- slatec/sdaini.f | 256 --- slatec/sdajac.f | 176 -- slatec/sdanrm.f | 46 - slatec/sdaslv.f | 61 - slatec/sdassl.f | 1598 -------------- slatec/sdastp.f | 611 ------ slatec/sdatrp.f | 65 - slatec/sdawts.f | 43 - slatec/sdcor.f | 192 -- slatec/sdcst.f | 105 - slatec/sdntl.f | 181 -- slatec/sdntp.f | 53 - slatec/sdot.f | 89 - slatec/sdpsc.f | 40 - slatec/sdpst.f | 286 --- slatec/sdriv1.f | 362 ---- slatec/sdriv2.f | 408 ---- slatec/sdriv3.f | 1526 -------------- slatec/sdscl.f | 37 - slatec/sdsdot.f | 78 - slatec/sdstp.f | 458 ---- slatec/sdzro.f | 134 -- slatec/sepeli.f | 516 ----- slatec/sepx4.f | 451 ---- slatec/sgbco.f | 278 --- slatec/sgbdi.f | 85 - slatec/sgbfa.f | 187 -- slatec/sgbmv.f | 307 --- slatec/sgbsl.f | 149 -- slatec/sgeco.f | 207 -- slatec/sgedi.f | 140 -- slatec/sgeev.f | 184 -- slatec/sgefa.f | 117 -- slatec/sgefs.f | 164 -- slatec/sgeir.f | 198 -- slatec/sgemm.f | 319 --- slatec/sgemv.f | 268 --- slatec/sger.f | 164 -- slatec/sgesl.f | 131 -- slatec/sglss.f | 144 -- slatec/sgmres.f | 550 ----- slatec/sgtsl.f | 131 -- slatec/shels.f | 98 - slatec/sheqr.f | 178 -- slatec/sindg.f | 37 - slatec/sinqb.f | 86 - slatec/sinqf.f | 86 - slatec/sinqi.f | 48 - slatec/sint.f | 107 - slatec/sinti.f | 65 - slatec/sintrp.f | 135 -- slatec/sir.f | 332 --- slatec/sllti2.f | 168 -- slatec/slpdoc.f | 459 ---- slatec/slvs.f | 87 - slatec/smout.f | 161 -- slatec/snbco.f | 273 --- slatec/snbdi.f | 82 - slatec/snbfa.f | 179 -- slatec/snbfs.f | 249 --- slatec/snbir.f | 284 --- slatec/snbsl.f | 149 -- slatec/snls1.f | 1023 --------- slatec/snls1e.f | 544 ----- slatec/snrm2.f | 161 -- slatec/snsq.f | 737 ------- slatec/snsqe.f | 382 ---- slatec/sods.f | 117 -- slatec/somn.f | 362 ---- slatec/sopenm.f | 37 - slatec/sorth.f | 125 -- slatec/sos.f | 270 --- slatec/soseqs.f | 412 ---- slatec/sossol.f | 64 - slatec/spbco.f | 262 --- slatec/spbdi.f | 82 - slatec/spbfa.f | 106 - slatec/spbsl.f | 97 - slatec/speli4.f | 330 --- slatec/spelip.f | 327 --- slatec/spenc.f | 117 -- slatec/spigmr.f | 434 ---- slatec/spincw.f | 133 -- slatec/spinit.f | 229 -- slatec/splp.f | 1680 --------------- slatec/splpce.f | 181 -- slatec/splpdm.f | 112 - slatec/splpfe.f | 159 -- slatec/splpfl.f | 157 -- slatec/splpmn.f | 988 --------- slatec/splpmu.f | 432 ---- slatec/splpup.f | 214 -- slatec/spoco.f | 208 -- slatec/spodi.f | 136 -- slatec/spofa.f | 81 - slatec/spofs.f | 163 -- slatec/spoir.f | 198 -- slatec/spopt.f | 379 ---- slatec/sposl.f | 86 - slatec/sppco.f | 234 --- slatec/sppdi.f | 142 -- slatec/spperm.f | 84 - slatec/sppfa.f | 100 - slatec/sppsl.f | 81 - slatec/spsort.f | 268 --- slatec/sptsl.f | 106 - slatec/sqrdc.f | 223 -- slatec/sqrsl.f | 288 --- slatec/sreadp.f | 44 - slatec/srlcal.f | 115 - slatec/srot.f | 89 - slatec/srotg.f | 106 - slatec/srotm.f | 148 -- slatec/srotmg.f | 205 -- slatec/ss2lt.f | 138 -- slatec/ss2y.f | 208 -- slatec/ssbmv.f | 310 --- slatec/sscal.f | 80 - slatec/ssd2s.f | 150 -- slatec/ssdbcg.f | 270 --- slatec/ssdcg.f | 276 --- slatec/ssdcgn.f | 273 --- slatec/ssdcgs.f | 285 --- slatec/ssdgmr.f | 385 ---- slatec/ssdi.f | 88 - slatec/ssdomn.f | 262 --- slatec/ssds.f | 124 -- slatec/ssdscl.f | 194 -- slatec/ssgs.f | 285 --- slatec/ssiccg.f | 313 --- slatec/ssico.f | 260 --- slatec/ssics.f | 340 --- slatec/ssidi.f | 228 -- slatec/ssiev.f | 113 - slatec/ssifa.f | 237 --- slatec/ssilur.f | 305 --- slatec/ssilus.f | 360 ---- slatec/ssisl.f | 187 -- slatec/ssjac.f | 263 --- slatec/ssli.f | 61 - slatec/ssli2.f | 139 -- slatec/ssllti.f | 63 - slatec/sslubc.f | 321 --- slatec/sslucn.f | 320 --- slatec/sslucs.f | 315 --- slatec/sslugm.f | 430 ---- slatec/sslui.f | 73 - slatec/sslui2.f | 204 -- slatec/sslui4.f | 203 -- slatec/ssluom.f | 322 --- slatec/ssluti.f | 71 - slatec/ssmmi2.f | 238 --- slatec/ssmmti.f | 72 - slatec/ssmtv.f | 152 -- slatec/ssmv.f | 150 -- slatec/ssort.f | 323 --- slatec/sspco.f | 301 --- slatec/sspdi.f | 256 --- slatec/sspev.f | 120 -- slatec/sspfa.f | 277 --- slatec/sspmv.f | 269 --- slatec/sspr.f | 205 -- slatec/sspr2.f | 236 --- slatec/sspsl.f | 196 -- slatec/ssvdc.f | 487 ----- slatec/sswap.f | 102 - slatec/ssymm.f | 300 --- slatec/ssymv.f | 268 --- slatec/ssyr.f | 204 -- slatec/ssyr2.f | 237 --- slatec/ssyr2k.f | 333 --- slatec/ssyrk.f | 299 --- slatec/stbmv.f | 349 ---- slatec/stbsv.f | 353 ---- slatec/steps.f | 568 ----- slatec/stin.f | 186 -- slatec/stod.f | 478 ----- slatec/stor1.f | 65 - slatec/stout.f | 153 -- slatec/stpmv.f | 306 --- slatec/stpsv.f | 309 --- slatec/strco.f | 174 -- slatec/strdi.f | 145 -- slatec/strmm.f | 361 ---- slatec/strmv.f | 293 --- slatec/strsl.f | 146 -- slatec/strsm.f | 385 ---- slatec/strsv.f | 296 --- slatec/stway.f | 72 - slatec/suds.f | 123 -- slatec/svco.f | 45 - slatec/svd.f | 381 ---- slatec/svecs.f | 53 - slatec/svout.f | 137 -- slatec/swritp.f | 44 - slatec/sxlcal.f | 183 -- slatec/tevlc.f | 177 -- slatec/tevls.f | 177 -- slatec/tinvit.f | 280 --- slatec/toc | 5098 --------------------------------------------- slatec/tql1.f | 167 -- slatec/tql2.f | 203 -- slatec/tqlrat.f | 165 -- slatec/trbak1.f | 101 - slatec/trbak3.f | 107 - slatec/tred1.f | 142 -- slatec/tred2.f | 166 -- slatec/tred3.f | 140 -- slatec/tri3.f | 112 - slatec/tridib.f | 306 --- slatec/tridq.f | 41 - slatec/tris4.f | 57 - slatec/trisp.f | 57 - slatec/trix.f | 68 - slatec/tsturm.f | 405 ---- slatec/u11ls.f | 292 --- slatec/u11us.f | 291 --- slatec/u12ls.f | 157 -- slatec/u12us.f | 154 -- slatec/ulsia.f | 320 --- slatec/usrmat.f | 69 - slatec/vnwrms.f | 42 - slatec/wnlit.f | 287 --- slatec/wnlsm.f | 638 ------ slatec/wnlt1.f | 63 - slatec/wnlt2.f | 58 - slatec/wnlt3.f | 43 - slatec/wnnls.f | 325 --- slatec/xadd.f | 171 -- slatec/xadj.f | 77 - slatec/xc210.f | 113 - slatec/xcon.f | 167 -- slatec/xerbla.f | 55 - slatec/xerclr.f | 31 - slatec/xercnt.f | 60 - slatec/xerdmp.f | 29 - slatec/xerhlt.f | 39 - slatec/xermax.f | 39 - slatec/xermsg.f | 364 ---- slatec/xerprn.f | 228 -- slatec/xerror.f | 22 - slatec/xersve.f | 155 -- slatec/xgetf.f | 30 - slatec/xgetua.f | 51 - slatec/xgetun.f | 38 - slatec/xlegf.f | 228 -- slatec/xnrmp.f | 269 --- slatec/xpmu.f | 69 - slatec/xpmup.f | 76 - slatec/xpnrm.f | 89 - slatec/xpqnu.f | 193 -- slatec/xpsi.f | 59 - slatec/xqmu.f | 83 - slatec/xqnu.f | 124 -- slatec/xred.f | 85 - slatec/xset.f | 330 --- slatec/xsetf.f | 60 - slatec/xsetua.f | 59 - slatec/xsetun.f | 36 - slatec/yairy.f | 393 ---- slatec/zabs.f | 41 - slatec/zacai.f | 111 - slatec/zacon.f | 215 -- slatec/zairy.f | 404 ---- slatec/zasyi.f | 177 -- slatec/zbesh.f | 351 ---- slatec/zbesi.f | 276 --- slatec/zbesj.f | 276 --- slatec/zbesk.f | 286 --- slatec/zbesy.f | 254 --- slatec/zbinu.f | 121 -- slatec/zbiry.f | 377 ---- slatec/zbknu.f | 580 ------ slatec/zbuni.f | 186 -- slatec/zbunk.f | 46 - slatec/zdiv.f | 32 - slatec/zexp.f | 28 - slatec/zkscl.f | 134 -- slatec/zlog.f | 54 - slatec/zmlri.f | 217 -- slatec/zmlt.f | 27 - slatec/zrati.f | 143 -- slatec/zs1s2.f | 62 - slatec/zseri.f | 202 -- slatec/zshch.f | 32 - slatec/zsqrt.f | 57 - slatec/zuchk.f | 40 - slatec/zunhj.f | 726 ------- slatec/zuni1.f | 215 -- slatec/zuni2.f | 278 --- slatec/zunik.f | 223 -- slatec/zunk1.f | 437 ---- slatec/zunk2.f | 516 ----- slatec/zuoik.f | 207 -- slatec/zwrsk.f | 107 - 1446 files changed, 306811 deletions(-) delete mode 100644 slatec/Make.files delete mode 100644 slatec/aaaaaa.f delete mode 100644 slatec/acosh.f delete mode 100644 slatec/ai.f delete mode 100644 slatec/aie.f delete mode 100644 slatec/albeta.f delete mode 100644 slatec/algams.f delete mode 100644 slatec/ali.f delete mode 100644 slatec/alngam.f delete mode 100644 slatec/alnrel.f delete mode 100644 slatec/asinh.f delete mode 100644 slatec/asyik.f delete mode 100644 slatec/asyjy.f delete mode 100644 slatec/atanh.f delete mode 100644 slatec/avint.f delete mode 100644 slatec/bakvec.f delete mode 100644 slatec/balanc.f delete mode 100644 slatec/balbak.f delete mode 100644 slatec/bandr.f delete mode 100644 slatec/bandv.f delete mode 100644 slatec/bcrh.f delete mode 100644 slatec/bdiff.f delete mode 100644 slatec/besi.f delete mode 100644 slatec/besi0.f delete mode 100644 slatec/besi0e.f delete mode 100644 slatec/besi1.f delete mode 100644 slatec/besi1e.f delete mode 100644 slatec/besj.f delete mode 100644 slatec/besj0.f delete mode 100644 slatec/besj1.f delete mode 100644 slatec/besk.f delete mode 100644 slatec/besk0.f delete mode 100644 slatec/besk0e.f delete mode 100644 slatec/besk1.f delete mode 100644 slatec/besk1e.f delete mode 100644 slatec/beskes.f delete mode 100644 slatec/besknu.f delete mode 100644 slatec/besks.f delete mode 100644 slatec/besy.f delete mode 100644 slatec/besy0.f delete mode 100644 slatec/besy1.f delete mode 100644 slatec/besynu.f delete mode 100644 slatec/beta.f delete mode 100644 slatec/betai.f delete mode 100644 slatec/bfqad.f delete mode 100644 slatec/bi.f delete mode 100644 slatec/bie.f delete mode 100644 slatec/binom.f delete mode 100644 slatec/bint4.f delete mode 100644 slatec/bintk.f delete mode 100644 slatec/bisect.f delete mode 100644 slatec/bkias.f delete mode 100644 slatec/bkisr.f delete mode 100644 slatec/bksol.f delete mode 100644 slatec/blktr1.f delete mode 100644 slatec/blktri.f delete mode 100644 slatec/bndacc.f delete mode 100644 slatec/bndsol.f delete mode 100644 slatec/bnfac.f delete mode 100644 slatec/bnslv.f delete mode 100644 slatec/bqr.f delete mode 100644 slatec/bsgq8.f delete mode 100644 slatec/bskin.f delete mode 100644 slatec/bspdoc.f delete mode 100644 slatec/bspdr.f delete mode 100644 slatec/bspev.f delete mode 100644 slatec/bsplvd.f delete mode 100644 slatec/bsplvn.f delete mode 100644 slatec/bsppp.f delete mode 100644 slatec/bspvd.f delete mode 100644 slatec/bspvn.f delete mode 100644 slatec/bsqad.f delete mode 100644 slatec/bsrh.f delete mode 100644 slatec/bvalu.f delete mode 100644 slatec/bvder.f delete mode 100644 slatec/bvpor.f delete mode 100644 slatec/bvsup.f delete mode 100644 slatec/c0lgmc.f delete mode 100644 slatec/c1merg.f delete mode 100644 slatec/c9lgmc.f delete mode 100644 slatec/c9ln2r.f delete mode 100644 slatec/cacai.f delete mode 100644 slatec/cacon.f delete mode 100644 slatec/cacos.f delete mode 100644 slatec/cacosh.f delete mode 100644 slatec/cairy.f delete mode 100644 slatec/carg.f delete mode 100644 slatec/casin.f delete mode 100644 slatec/casinh.f delete mode 100644 slatec/casyi.f delete mode 100644 slatec/catan.f delete mode 100644 slatec/catan2.f delete mode 100644 slatec/catanh.f delete mode 100644 slatec/caxpy.f delete mode 100644 slatec/cbabk2.f delete mode 100644 slatec/cbal.f delete mode 100644 slatec/cbesh.f delete mode 100644 slatec/cbesi.f delete mode 100644 slatec/cbesj.f delete mode 100644 slatec/cbesk.f delete mode 100644 slatec/cbesy.f delete mode 100644 slatec/cbeta.f delete mode 100644 slatec/cbinu.f delete mode 100644 slatec/cbiry.f delete mode 100644 slatec/cbknu.f delete mode 100644 slatec/cblkt1.f delete mode 100644 slatec/cblktr.f delete mode 100644 slatec/cbrt.f delete mode 100644 slatec/cbuni.f delete mode 100644 slatec/cbunk.f delete mode 100644 slatec/ccbrt.f delete mode 100644 slatec/cchdc.f delete mode 100644 slatec/cchdd.f delete mode 100644 slatec/cchex.f delete mode 100644 slatec/cchud.f delete mode 100644 slatec/ccmpb.f delete mode 100644 slatec/ccopy.f delete mode 100644 slatec/ccosh.f delete mode 100644 slatec/ccot.f delete mode 100644 slatec/cdcdot.f delete mode 100644 slatec/cdcor.f delete mode 100644 slatec/cdcst.f delete mode 100644 slatec/cdiv.f delete mode 100644 slatec/cdntl.f delete mode 100644 slatec/cdntp.f delete mode 100644 slatec/cdotc.f delete mode 100644 slatec/cdotu.f delete mode 100644 slatec/cdpsc.f delete mode 100644 slatec/cdpst.f delete mode 100644 slatec/cdriv1.f delete mode 100644 slatec/cdriv2.f delete mode 100644 slatec/cdriv3.f delete mode 100644 slatec/cdscl.f delete mode 100644 slatec/cdstp.f delete mode 100644 slatec/cdzro.f delete mode 100644 slatec/cexprl.f delete mode 100644 slatec/cfftb.f delete mode 100644 slatec/cfftb1.f delete mode 100644 slatec/cfftf.f delete mode 100644 slatec/cfftf1.f delete mode 100644 slatec/cffti.f delete mode 100644 slatec/cffti1.f delete mode 100644 slatec/cfod.f delete mode 100644 slatec/cg.f delete mode 100644 slatec/cgamma.f delete mode 100644 slatec/cgamr.f delete mode 100644 slatec/cgbco.f delete mode 100644 slatec/cgbdi.f delete mode 100644 slatec/cgbfa.f delete mode 100644 slatec/cgbmv.f delete mode 100644 slatec/cgbsl.f delete mode 100644 slatec/cgeco.f delete mode 100644 slatec/cgedi.f delete mode 100644 slatec/cgeev.f delete mode 100644 slatec/cgefa.f delete mode 100644 slatec/cgefs.f delete mode 100644 slatec/cgeir.f delete mode 100644 slatec/cgemm.f delete mode 100644 slatec/cgemv.f delete mode 100644 slatec/cgerc.f delete mode 100644 slatec/cgeru.f delete mode 100644 slatec/cgesl.f delete mode 100644 slatec/cgtsl.f delete mode 100644 slatec/ch.f delete mode 100644 slatec/changes delete mode 100644 slatec/chbmv.f delete mode 100644 slatec/chemm.f delete mode 100644 slatec/chemv.f delete mode 100644 slatec/cher.f delete mode 100644 slatec/cher2.f delete mode 100644 slatec/cher2k.f delete mode 100644 slatec/cherk.f delete mode 100644 slatec/chfcm.f delete mode 100644 slatec/chfdv.f delete mode 100644 slatec/chfev.f delete mode 100644 slatec/chfie.f delete mode 100644 slatec/chico.f delete mode 100644 slatec/chidi.f delete mode 100644 slatec/chiev.f delete mode 100644 slatec/chifa.f delete mode 100644 slatec/chisl.f delete mode 100644 slatec/chkder.f delete mode 100644 slatec/chkpr4.f delete mode 100644 slatec/chkprm.f delete mode 100644 slatec/chksn4.f delete mode 100644 slatec/chksng.f delete mode 100644 slatec/chpco.f delete mode 100644 slatec/chpdi.f delete mode 100644 slatec/chpfa.f delete mode 100644 slatec/chpmv.f delete mode 100644 slatec/chpr.f delete mode 100644 slatec/chpr2.f delete mode 100644 slatec/chpsl.f delete mode 100644 slatec/chu.f delete mode 100644 slatec/cinvit.f delete mode 100644 slatec/ckscl.f delete mode 100644 slatec/clbeta.f delete mode 100644 slatec/clngam.f delete mode 100644 slatec/clnrel.f delete mode 100644 slatec/clog10.f delete mode 100644 slatec/cmgnbn.f delete mode 100644 slatec/cmlri.f delete mode 100644 slatec/cmpcsg.f delete mode 100644 slatec/cmposd.f delete mode 100644 slatec/cmposn.f delete mode 100644 slatec/cmposp.f delete mode 100644 slatec/cmptr3.f delete mode 100644 slatec/cmptrx.f delete mode 100644 slatec/cnbco.f delete mode 100644 slatec/cnbdi.f delete mode 100644 slatec/cnbfa.f delete mode 100644 slatec/cnbfs.f delete mode 100644 slatec/cnbir.f delete mode 100644 slatec/cnbsl.f delete mode 100644 slatec/combak.f delete mode 100644 slatec/comhes.f delete mode 100644 slatec/comlr.f delete mode 100644 slatec/comlr2.f delete mode 100644 slatec/compb.f delete mode 100644 slatec/comqr.f delete mode 100644 slatec/comqr2.f delete mode 100644 slatec/cortb.f delete mode 100644 slatec/corth.f delete mode 100644 slatec/cosdg.f delete mode 100644 slatec/cosgen.f delete mode 100644 slatec/cosqb.f delete mode 100644 slatec/cosqb1.f delete mode 100644 slatec/cosqf.f delete mode 100644 slatec/cosqf1.f delete mode 100644 slatec/cosqi.f delete mode 100644 slatec/cost.f delete mode 100644 slatec/costi.f delete mode 100644 slatec/cot.f delete mode 100644 slatec/cpadd.f delete mode 100644 slatec/cpbco.f delete mode 100644 slatec/cpbdi.f delete mode 100644 slatec/cpbfa.f delete mode 100644 slatec/cpbsl.f delete mode 100644 slatec/cpevl.f delete mode 100644 slatec/cpevlr.f delete mode 100644 slatec/cpoco.f delete mode 100644 slatec/cpodi.f delete mode 100644 slatec/cpofa.f delete mode 100644 slatec/cpofs.f delete mode 100644 slatec/cpoir.f delete mode 100644 slatec/cposl.f delete mode 100644 slatec/cppco.f delete mode 100644 slatec/cppdi.f delete mode 100644 slatec/cppfa.f delete mode 100644 slatec/cppsl.f delete mode 100644 slatec/cpqr79.f delete mode 100644 slatec/cproc.f delete mode 100644 slatec/cprocp.f delete mode 100644 slatec/cprod.f delete mode 100644 slatec/cprodp.f delete mode 100644 slatec/cpsi.f delete mode 100644 slatec/cptsl.f delete mode 100644 slatec/cpzero.f delete mode 100644 slatec/cqrdc.f delete mode 100644 slatec/cqrsl.f delete mode 100644 slatec/crati.f delete mode 100644 slatec/crotg.f delete mode 100644 slatec/cs1s2.f delete mode 100644 slatec/cscal.f delete mode 100644 slatec/cscale.f delete mode 100644 slatec/cseri.f delete mode 100644 slatec/csevl.f delete mode 100644 slatec/cshch.f delete mode 100644 slatec/csico.f delete mode 100644 slatec/csidi.f delete mode 100644 slatec/csifa.f delete mode 100644 slatec/csinh.f delete mode 100644 slatec/csisl.f delete mode 100644 slatec/cspco.f delete mode 100644 slatec/cspdi.f delete mode 100644 slatec/cspfa.f delete mode 100644 slatec/cspsl.f delete mode 100644 slatec/csroot.f delete mode 100644 slatec/csrot.f delete mode 100644 slatec/csscal.f delete mode 100644 slatec/csvdc.f delete mode 100644 slatec/cswap.f delete mode 100644 slatec/csymm.f delete mode 100644 slatec/csyr2k.f delete mode 100644 slatec/csyrk.f delete mode 100644 slatec/ctan.f delete mode 100644 slatec/ctanh.f delete mode 100644 slatec/ctbmv.f delete mode 100644 slatec/ctbsv.f delete mode 100644 slatec/ctpmv.f delete mode 100644 slatec/ctpsv.f delete mode 100644 slatec/ctrco.f delete mode 100644 slatec/ctrdi.f delete mode 100644 slatec/ctrmm.f delete mode 100644 slatec/ctrmv.f delete mode 100644 slatec/ctrsl.f delete mode 100644 slatec/ctrsm.f delete mode 100644 slatec/ctrsv.f delete mode 100644 slatec/cuchk.f delete mode 100644 slatec/cunhj.f delete mode 100644 slatec/cuni1.f delete mode 100644 slatec/cuni2.f delete mode 100644 slatec/cunik.f delete mode 100644 slatec/cunk1.f delete mode 100644 slatec/cunk2.f delete mode 100644 slatec/cuoik.f delete mode 100644 slatec/cv.f delete mode 100644 slatec/cwrsk.f delete mode 100644 slatec/d1mach.f delete mode 100644 slatec/d1merg.f delete mode 100644 slatec/d1mpyq.f delete mode 100644 slatec/d1updt.f delete mode 100644 slatec/d9aimp.f delete mode 100644 slatec/d9atn1.f delete mode 100644 slatec/d9b0mp.f delete mode 100644 slatec/d9b1mp.f delete mode 100644 slatec/d9chu.f delete mode 100644 slatec/d9gmic.f delete mode 100644 slatec/d9gmit.f delete mode 100644 slatec/d9knus.f delete mode 100644 slatec/d9lgic.f delete mode 100644 slatec/d9lgit.f delete mode 100644 slatec/d9lgmc.f delete mode 100644 slatec/d9ln2r.f delete mode 100644 slatec/d9pak.f delete mode 100644 slatec/d9upak.f delete mode 100644 slatec/dacosh.f delete mode 100644 slatec/dai.f delete mode 100644 slatec/daie.f delete mode 100644 slatec/dasinh.f delete mode 100644 slatec/dasum.f delete mode 100644 slatec/dasyik.f delete mode 100644 slatec/dasyjy.f delete mode 100644 slatec/datanh.f delete mode 100644 slatec/davint.f delete mode 100644 slatec/daws.f delete mode 100644 slatec/daxpy.f delete mode 100644 slatec/dbcg.f delete mode 100644 slatec/dbdiff.f delete mode 100644 slatec/dbesi.f delete mode 100644 slatec/dbesi0.f delete mode 100644 slatec/dbesi1.f delete mode 100644 slatec/dbesj.f delete mode 100644 slatec/dbesj0.f delete mode 100644 slatec/dbesj1.f delete mode 100644 slatec/dbesk.f delete mode 100644 slatec/dbesk0.f delete mode 100644 slatec/dbesk1.f delete mode 100644 slatec/dbesks.f delete mode 100644 slatec/dbesy.f delete mode 100644 slatec/dbesy0.f delete mode 100644 slatec/dbesy1.f delete mode 100644 slatec/dbeta.f delete mode 100644 slatec/dbetai.f delete mode 100644 slatec/dbfqad.f delete mode 100644 slatec/dbhin.f delete mode 100644 slatec/dbi.f delete mode 100644 slatec/dbie.f delete mode 100644 slatec/dbinom.f delete mode 100644 slatec/dbint4.f delete mode 100644 slatec/dbintk.f delete mode 100644 slatec/dbkias.f delete mode 100644 slatec/dbkisr.f delete mode 100644 slatec/dbksol.f delete mode 100644 slatec/dbndac.f delete mode 100644 slatec/dbndsl.f delete mode 100644 slatec/dbnfac.f delete mode 100644 slatec/dbnslv.f delete mode 100644 slatec/dbocls.f delete mode 100644 slatec/dbols.f delete mode 100644 slatec/dbolsm.f delete mode 100644 slatec/dbsgq8.f delete mode 100644 slatec/dbsi0e.f delete mode 100644 slatec/dbsi1e.f delete mode 100644 slatec/dbsk0e.f delete mode 100644 slatec/dbsk1e.f delete mode 100644 slatec/dbskes.f delete mode 100644 slatec/dbskin.f delete mode 100644 slatec/dbsknu.f delete mode 100644 slatec/dbspdr.f delete mode 100644 slatec/dbspev.f delete mode 100644 slatec/dbsppp.f delete mode 100644 slatec/dbspvd.f delete mode 100644 slatec/dbspvn.f delete mode 100644 slatec/dbsqad.f delete mode 100644 slatec/dbsynu.f delete mode 100644 slatec/dbvalu.f delete mode 100644 slatec/dbvder.f delete mode 100644 slatec/dbvpor.f delete mode 100644 slatec/dbvsup.f delete mode 100644 slatec/dcbrt.f delete mode 100644 slatec/dcdot.f delete mode 100644 slatec/dcfod.f delete mode 100644 slatec/dcg.f delete mode 100644 slatec/dcgn.f delete mode 100644 slatec/dcgs.f delete mode 100644 slatec/dchdc.f delete mode 100644 slatec/dchdd.f delete mode 100644 slatec/dchex.f delete mode 100644 slatec/dchfcm.f delete mode 100644 slatec/dchfdv.f delete mode 100644 slatec/dchfev.f delete mode 100644 slatec/dchfie.f delete mode 100644 slatec/dchkw.f delete mode 100644 slatec/dchu.f delete mode 100644 slatec/dchud.f delete mode 100644 slatec/dckder.f delete mode 100644 slatec/dcoef.f delete mode 100644 slatec/dcopy.f delete mode 100644 slatec/dcopym.f delete mode 100644 slatec/dcosdg.f delete mode 100644 slatec/dcot.f delete mode 100644 slatec/dcov.f delete mode 100644 slatec/dcpplt.f delete mode 100644 slatec/dcscal.f delete mode 100644 slatec/dcsevl.f delete mode 100644 slatec/dcv.f delete mode 100644 slatec/ddaini.f delete mode 100644 slatec/ddajac.f delete mode 100644 slatec/ddanrm.f delete mode 100644 slatec/ddaslv.f delete mode 100644 slatec/ddassl.f delete mode 100644 slatec/ddastp.f delete mode 100644 slatec/ddatrp.f delete mode 100644 slatec/ddaws.f delete mode 100644 slatec/ddawts.f delete mode 100644 slatec/ddcor.f delete mode 100644 slatec/ddcst.f delete mode 100644 slatec/ddeabm.f delete mode 100644 slatec/ddebdf.f delete mode 100644 slatec/dderkf.f delete mode 100644 slatec/ddes.f delete mode 100644 slatec/ddntl.f delete mode 100644 slatec/ddntp.f delete mode 100644 slatec/ddoglg.f delete mode 100644 slatec/ddot.f delete mode 100644 slatec/ddpsc.f delete mode 100644 slatec/ddpst.f delete mode 100644 slatec/ddriv1.f delete mode 100644 slatec/ddriv2.f delete mode 100644 slatec/ddriv3.f delete mode 100644 slatec/ddscl.f delete mode 100644 slatec/ddstp.f delete mode 100644 slatec/ddzro.f delete mode 100644 slatec/de1.f delete mode 100644 slatec/deabm.f delete mode 100644 slatec/debdf.f delete mode 100644 slatec/defc.f delete mode 100644 slatec/defcmn.f delete mode 100644 slatec/defe4.f delete mode 100644 slatec/defehl.f delete mode 100644 slatec/defer.f delete mode 100644 slatec/dei.f delete mode 100644 slatec/denorm.f delete mode 100644 slatec/derf.f delete mode 100644 slatec/derfc.f delete mode 100644 slatec/derkf.f delete mode 100644 slatec/derkfs.f delete mode 100644 slatec/des.f delete mode 100644 slatec/dexbvp.f delete mode 100644 slatec/dexint.f delete mode 100644 slatec/dexprl.f delete mode 100644 slatec/dfac.f delete mode 100644 slatec/dfc.f delete mode 100644 slatec/dfcmn.f delete mode 100644 slatec/dfdjc1.f delete mode 100644 slatec/dfdjc3.f delete mode 100644 slatec/dfehl.f delete mode 100644 slatec/dfspvd.f delete mode 100644 slatec/dfspvn.f delete mode 100644 slatec/dfulmt.f delete mode 100644 slatec/dfzero.f delete mode 100644 slatec/dgami.f delete mode 100644 slatec/dgamic.f delete mode 100644 slatec/dgamit.f delete mode 100644 slatec/dgamlm.f delete mode 100644 slatec/dgamln.f delete mode 100644 slatec/dgamma.f delete mode 100644 slatec/dgamr.f delete mode 100644 slatec/dgamrn.f delete mode 100644 slatec/dgaus8.f delete mode 100644 slatec/dgbco.f delete mode 100644 slatec/dgbdi.f delete mode 100644 slatec/dgbfa.f delete mode 100644 slatec/dgbmv.f delete mode 100644 slatec/dgbsl.f delete mode 100644 slatec/dgeco.f delete mode 100644 slatec/dgedi.f delete mode 100644 slatec/dgefa.f delete mode 100644 slatec/dgefs.f delete mode 100644 slatec/dgemm.f delete mode 100644 slatec/dgemv.f delete mode 100644 slatec/dger.f delete mode 100644 slatec/dgesl.f delete mode 100644 slatec/dglss.f delete mode 100644 slatec/dgmres.f delete mode 100644 slatec/dgtsl.f delete mode 100644 slatec/dh12.f delete mode 100644 slatec/dhels.f delete mode 100644 slatec/dheqr.f delete mode 100644 slatec/dhfti.f delete mode 100644 slatec/dhkseq.f delete mode 100644 slatec/dhstrt.f delete mode 100644 slatec/dhvnrm.f delete mode 100644 slatec/dintp.f delete mode 100644 slatec/dintrv.f delete mode 100644 slatec/dintyd.f delete mode 100644 slatec/dir.f delete mode 100644 slatec/djairy.f delete mode 100644 slatec/dlbeta.f delete mode 100644 slatec/dlgams.f delete mode 100644 slatec/dli.f delete mode 100644 slatec/dllsia.f delete mode 100644 slatec/dllti2.f delete mode 100644 slatec/dlngam.f delete mode 100644 slatec/dlnrel.f delete mode 100644 slatec/dlpdoc.f delete mode 100644 slatec/dlpdp.f delete mode 100644 slatec/dlsei.f delete mode 100644 slatec/dlsi.f delete mode 100644 slatec/dlsod.f delete mode 100644 slatec/dlssud.f delete mode 100644 slatec/dmacon.f delete mode 100644 slatec/dmgsbv.f delete mode 100644 slatec/dmout.f delete mode 100644 slatec/dmpar.f delete mode 100644 slatec/dnbco.f delete mode 100644 slatec/dnbdi.f delete mode 100644 slatec/dnbfa.f delete mode 100644 slatec/dnbfs.f delete mode 100644 slatec/dnbsl.f delete mode 100644 slatec/dnls1.f delete mode 100644 slatec/dnls1e.f delete mode 100644 slatec/dnrm2.f delete mode 100644 slatec/dnsq.f delete mode 100644 slatec/dnsqe.f delete mode 100644 slatec/dogleg.f delete mode 100644 slatec/dohtrl.f delete mode 100644 slatec/domn.f delete mode 100644 slatec/dorth.f delete mode 100644 slatec/dorthr.f delete mode 100644 slatec/dp1vlu.f delete mode 100644 slatec/dpbco.f delete mode 100644 slatec/dpbdi.f delete mode 100644 slatec/dpbfa.f delete mode 100644 slatec/dpbsl.f delete mode 100644 slatec/dpchbs.f delete mode 100644 slatec/dpchce.f delete mode 100644 slatec/dpchci.f delete mode 100644 slatec/dpchcm.f delete mode 100644 slatec/dpchcs.f delete mode 100644 slatec/dpchdf.f delete mode 100644 slatec/dpchfd.f delete mode 100644 slatec/dpchfe.f delete mode 100644 slatec/dpchia.f delete mode 100644 slatec/dpchic.f delete mode 100644 slatec/dpchid.f delete mode 100644 slatec/dpchim.f delete mode 100644 slatec/dpchkt.f delete mode 100644 slatec/dpchng.f delete mode 100644 slatec/dpchsp.f delete mode 100644 slatec/dpchst.f delete mode 100644 slatec/dpchsw.f delete mode 100644 slatec/dpcoef.f delete mode 100644 slatec/dpfqad.f delete mode 100644 slatec/dpigmr.f delete mode 100644 slatec/dpincw.f delete mode 100644 slatec/dpinit.f delete mode 100644 slatec/dpintm.f delete mode 100644 slatec/dpjac.f delete mode 100644 slatec/dplint.f delete mode 100644 slatec/dplpce.f delete mode 100644 slatec/dplpdm.f delete mode 100644 slatec/dplpfe.f delete mode 100644 slatec/dplpfl.f delete mode 100644 slatec/dplpmn.f delete mode 100644 slatec/dplpmu.f delete mode 100644 slatec/dplpup.f delete mode 100644 slatec/dpnnzr.f delete mode 100644 slatec/dpoch.f delete mode 100644 slatec/dpoch1.f delete mode 100644 slatec/dpoco.f delete mode 100644 slatec/dpodi.f delete mode 100644 slatec/dpofa.f delete mode 100644 slatec/dpofs.f delete mode 100644 slatec/dpolcf.f delete mode 100644 slatec/dpolft.f delete mode 100644 slatec/dpolvl.f delete mode 100644 slatec/dpopt.f delete mode 100644 slatec/dposl.f delete mode 100644 slatec/dppco.f delete mode 100644 slatec/dppdi.f delete mode 100644 slatec/dpperm.f delete mode 100644 slatec/dppfa.f delete mode 100644 slatec/dppgq8.f delete mode 100644 slatec/dppqad.f delete mode 100644 slatec/dppsl.f delete mode 100644 slatec/dppval.f delete mode 100644 slatec/dprvec.f delete mode 100644 slatec/dprwpg.f delete mode 100644 slatec/dprwvr.f delete mode 100644 slatec/dpsi.f delete mode 100644 slatec/dpsifn.f delete mode 100644 slatec/dpsixn.f delete mode 100644 slatec/dpsort.f delete mode 100644 slatec/dptsl.f delete mode 100644 slatec/dqag.f delete mode 100644 slatec/dqage.f delete mode 100644 slatec/dqagi.f delete mode 100644 slatec/dqagie.f delete mode 100644 slatec/dqagp.f delete mode 100644 slatec/dqagpe.f delete mode 100644 slatec/dqags.f delete mode 100644 slatec/dqagse.f delete mode 100644 slatec/dqawc.f delete mode 100644 slatec/dqawce.f delete mode 100644 slatec/dqawf.f delete mode 100644 slatec/dqawfe.f delete mode 100644 slatec/dqawo.f delete mode 100644 slatec/dqawoe.f delete mode 100644 slatec/dqaws.f delete mode 100644 slatec/dqawse.f delete mode 100644 slatec/dqc25c.f delete mode 100644 slatec/dqc25f.f delete mode 100644 slatec/dqc25s.f delete mode 100644 slatec/dqcheb.f delete mode 100644 slatec/dqdota.f delete mode 100644 slatec/dqdoti.f delete mode 100644 slatec/dqelg.f delete mode 100644 slatec/dqform.f delete mode 100644 slatec/dqk15.f delete mode 100644 slatec/dqk15i.f delete mode 100644 slatec/dqk15w.f delete mode 100644 slatec/dqk21.f delete mode 100644 slatec/dqk31.f delete mode 100644 slatec/dqk41.f delete mode 100644 slatec/dqk51.f delete mode 100644 slatec/dqk61.f delete mode 100644 slatec/dqmomo.f delete mode 100644 slatec/dqnc79.f delete mode 100644 slatec/dqng.f delete mode 100644 slatec/dqpsrt.f delete mode 100644 slatec/dqrdc.f delete mode 100644 slatec/dqrfac.f delete mode 100644 slatec/dqrsl.f delete mode 100644 slatec/dqrslv.f delete mode 100644 slatec/dqwgtc.f delete mode 100644 slatec/dqwgtf.f delete mode 100644 slatec/dqwgts.f delete mode 100644 slatec/drc.f delete mode 100644 slatec/drc3jj.f delete mode 100644 slatec/drc3jm.f delete mode 100644 slatec/drc6j.f delete mode 100644 slatec/drd.f delete mode 100644 slatec/dreadp.f delete mode 100644 slatec/dreort.f delete mode 100644 slatec/drf.f delete mode 100644 slatec/drj.f delete mode 100644 slatec/drkfab.f delete mode 100644 slatec/drkfs.f delete mode 100644 slatec/drlcal.f delete mode 100644 slatec/drot.f delete mode 100644 slatec/drotg.f delete mode 100644 slatec/drotm.f delete mode 100644 slatec/drotmg.f delete mode 100644 slatec/drsco.f delete mode 100644 slatec/ds2lt.f delete mode 100644 slatec/ds2y.f delete mode 100644 slatec/dsbmv.f delete mode 100644 slatec/dscal.f delete mode 100644 slatec/dsd2s.f delete mode 100644 slatec/dsdbcg.f delete mode 100644 slatec/dsdcg.f delete mode 100644 slatec/dsdcgn.f delete mode 100644 slatec/dsdcgs.f delete mode 100644 slatec/dsdgmr.f delete mode 100644 slatec/dsdi.f delete mode 100644 slatec/dsdomn.f delete mode 100644 slatec/dsdot.f delete mode 100644 slatec/dsds.f delete mode 100644 slatec/dsdscl.f delete mode 100644 slatec/dsgs.f delete mode 100644 slatec/dsiccg.f delete mode 100644 slatec/dsico.f delete mode 100644 slatec/dsics.f delete mode 100644 slatec/dsidi.f delete mode 100644 slatec/dsifa.f delete mode 100644 slatec/dsilur.f delete mode 100644 slatec/dsilus.f delete mode 100644 slatec/dsindg.f delete mode 100644 slatec/dsisl.f delete mode 100644 slatec/dsjac.f delete mode 100644 slatec/dsli.f delete mode 100644 slatec/dsli2.f delete mode 100644 slatec/dsllti.f delete mode 100644 slatec/dslubc.f delete mode 100644 slatec/dslucn.f delete mode 100644 slatec/dslucs.f delete mode 100644 slatec/dslugm.f delete mode 100644 slatec/dslui.f delete mode 100644 slatec/dslui2.f delete mode 100644 slatec/dslui4.f delete mode 100644 slatec/dsluom.f delete mode 100644 slatec/dsluti.f delete mode 100644 slatec/dslvs.f delete mode 100644 slatec/dsmmi2.f delete mode 100644 slatec/dsmmti.f delete mode 100644 slatec/dsmtv.f delete mode 100644 slatec/dsmv.f delete mode 100644 slatec/dsort.f delete mode 100644 slatec/dsos.f delete mode 100644 slatec/dsoseq.f delete mode 100644 slatec/dsossl.f delete mode 100644 slatec/dspco.f delete mode 100644 slatec/dspdi.f delete mode 100644 slatec/dspenc.f delete mode 100644 slatec/dspfa.f delete mode 100644 slatec/dsplp.f delete mode 100644 slatec/dspmv.f delete mode 100644 slatec/dspr.f delete mode 100644 slatec/dspr2.f delete mode 100644 slatec/dspsl.f delete mode 100644 slatec/dsteps.f delete mode 100644 slatec/dstod.f delete mode 100644 slatec/dstor1.f delete mode 100644 slatec/dstway.f delete mode 100644 slatec/dsuds.f delete mode 100644 slatec/dsvco.f delete mode 100644 slatec/dsvdc.f delete mode 100644 slatec/dswap.f delete mode 100644 slatec/dsymm.f delete mode 100644 slatec/dsymv.f delete mode 100644 slatec/dsyr.f delete mode 100644 slatec/dsyr2.f delete mode 100644 slatec/dsyr2k.f delete mode 100644 slatec/dsyrk.f delete mode 100644 slatec/dtbmv.f delete mode 100644 slatec/dtbsv.f delete mode 100644 slatec/dtin.f delete mode 100644 slatec/dtout.f delete mode 100644 slatec/dtpmv.f delete mode 100644 slatec/dtpsv.f delete mode 100644 slatec/dtrco.f delete mode 100644 slatec/dtrdi.f delete mode 100644 slatec/dtrmm.f delete mode 100644 slatec/dtrmv.f delete mode 100644 slatec/dtrsl.f delete mode 100644 slatec/dtrsm.f delete mode 100644 slatec/dtrsv.f delete mode 100644 slatec/du11ls.f delete mode 100644 slatec/du11us.f delete mode 100644 slatec/du12ls.f delete mode 100644 slatec/du12us.f delete mode 100644 slatec/dulsia.f delete mode 100644 slatec/dusrmt.f delete mode 100644 slatec/dvecs.f delete mode 100644 slatec/dvnrms.f delete mode 100644 slatec/dvout.f delete mode 100644 slatec/dwnlit.f delete mode 100644 slatec/dwnlsm.f delete mode 100644 slatec/dwnlt1.f delete mode 100644 slatec/dwnlt2.f delete mode 100644 slatec/dwnlt3.f delete mode 100644 slatec/dwnnls.f delete mode 100644 slatec/dwritp.f delete mode 100644 slatec/dwupdt.f delete mode 100644 slatec/dx.f delete mode 100644 slatec/dx4.f delete mode 100644 slatec/dxadd.f delete mode 100644 slatec/dxadj.f delete mode 100644 slatec/dxc210.f delete mode 100644 slatec/dxcon.f delete mode 100644 slatec/dxlcal.f delete mode 100644 slatec/dxlegf.f delete mode 100644 slatec/dxnrmp.f delete mode 100644 slatec/dxpmu.f delete mode 100644 slatec/dxpmup.f delete mode 100644 slatec/dxpnrm.f delete mode 100644 slatec/dxpqnu.f delete mode 100644 slatec/dxpsi.f delete mode 100644 slatec/dxqmu.f delete mode 100644 slatec/dxqnu.f delete mode 100644 slatec/dxred.f delete mode 100644 slatec/dxset.f delete mode 100644 slatec/dy.f delete mode 100644 slatec/dy4.f delete mode 100644 slatec/dyairy.f delete mode 100644 slatec/e1.f delete mode 100644 slatec/efc.f delete mode 100644 slatec/efcmn.f delete mode 100644 slatec/ei.f delete mode 100644 slatec/eisdoc.f delete mode 100644 slatec/elmbak.f delete mode 100644 slatec/elmhes.f delete mode 100644 slatec/eltran.f delete mode 100644 slatec/enorm.f delete mode 100644 slatec/erf.f delete mode 100644 slatec/erfc.f delete mode 100644 slatec/exbvp.f delete mode 100644 slatec/exint.f delete mode 100644 slatec/exprel.f delete mode 100644 slatec/ezfft1.f delete mode 100644 slatec/ezfftb.f delete mode 100644 slatec/ezfftf.f delete mode 100644 slatec/ezffti.f delete mode 100644 slatec/fac.f delete mode 100644 slatec/fc.f delete mode 100644 slatec/fcmn.f delete mode 100644 slatec/fdjac1.f delete mode 100644 slatec/fdjac3.f delete mode 100644 slatec/fdump.f delete mode 100644 slatec/fftdoc.f delete mode 100644 slatec/figi.f delete mode 100644 slatec/figi2.f delete mode 100644 slatec/fulmat.f delete mode 100644 slatec/fundoc.f delete mode 100644 slatec/fzero.f delete mode 100644 slatec/gami.f delete mode 100644 slatec/gamic.f delete mode 100644 slatec/gamit.f delete mode 100644 slatec/gamlim.f delete mode 100644 slatec/gamln.f delete mode 100644 slatec/gamma.f delete mode 100644 slatec/gamr.f delete mode 100644 slatec/gamrn.f delete mode 100644 slatec/gaus8.f delete mode 100644 slatec/genbun.f delete mode 100644 slatec/guide delete mode 100644 slatec/h12.f delete mode 100644 slatec/hfti.f delete mode 100644 slatec/hkseq.f delete mode 100644 slatec/hpperm.f delete mode 100644 slatec/hpsort.f delete mode 100644 slatec/hqr.f delete mode 100644 slatec/hqr2.f delete mode 100644 slatec/hstart.f delete mode 100644 slatec/hstcrt.f delete mode 100644 slatec/hstcs1.f delete mode 100644 slatec/hstcsp.f delete mode 100644 slatec/hstcyl.f delete mode 100644 slatec/hstplr.f delete mode 100644 slatec/hstssp.f delete mode 100644 slatec/htrib3.f delete mode 100644 slatec/htribk.f delete mode 100644 slatec/htrid3.f delete mode 100644 slatec/htridi.f delete mode 100644 slatec/hvnrm.f delete mode 100644 slatec/hw3crt.f delete mode 100644 slatec/hwscrt.f delete mode 100644 slatec/hwscs1.f delete mode 100644 slatec/hwscsp.f delete mode 100644 slatec/hwscyl.f delete mode 100644 slatec/hwsplr.f delete mode 100644 slatec/hwsss1.f delete mode 100644 slatec/hwsssp.f delete mode 100644 slatec/i1mach.f delete mode 100644 slatec/i1merg.f delete mode 100644 slatec/icamax.f delete mode 100644 slatec/icopy.f delete mode 100644 slatec/idamax.f delete mode 100644 slatec/idloc.f delete mode 100644 slatec/imtql1.f delete mode 100644 slatec/imtql2.f delete mode 100644 slatec/imtqlv.f delete mode 100644 slatec/indxa.f delete mode 100644 slatec/indxb.f delete mode 100644 slatec/indxc.f delete mode 100644 slatec/initds.f delete mode 100644 slatec/inits.f delete mode 100644 slatec/intrv.f delete mode 100644 slatec/intyd.f delete mode 100644 slatec/invit.f delete mode 100644 slatec/inxca.f delete mode 100644 slatec/inxcb.f delete mode 100644 slatec/inxcc.f delete mode 100644 slatec/iploc.f delete mode 100644 slatec/ipperm.f delete mode 100644 slatec/ipsort.f delete mode 100644 slatec/isamax.f delete mode 100644 slatec/isdbcg.f delete mode 100644 slatec/isdcg.f delete mode 100644 slatec/isdcgn.f delete mode 100644 slatec/isdcgs.f delete mode 100644 slatec/isdgmr.f delete mode 100644 slatec/isdir.f delete mode 100644 slatec/isdomn.f delete mode 100644 slatec/isort.f delete mode 100644 slatec/issbcg.f delete mode 100644 slatec/isscg.f delete mode 100644 slatec/isscgn.f delete mode 100644 slatec/isscgs.f delete mode 100644 slatec/issgmr.f delete mode 100644 slatec/issir.f delete mode 100644 slatec/issomn.f delete mode 100644 slatec/iswap.f delete mode 100644 slatec/ivout.f delete mode 100644 slatec/j4save.f delete mode 100644 slatec/jairy.f delete mode 100644 slatec/la05ad.f delete mode 100644 slatec/la05as.f delete mode 100644 slatec/la05bd.f delete mode 100644 slatec/la05bs.f delete mode 100644 slatec/la05cd.f delete mode 100644 slatec/la05cs.f delete mode 100644 slatec/la05ed.f delete mode 100644 slatec/la05es.f delete mode 100644 slatec/llsia.f delete mode 100644 slatec/lmpar.f delete mode 100644 slatec/lpdp.f delete mode 100644 slatec/lsame.f delete mode 100644 slatec/lsei.f delete mode 100644 slatec/lsi.f delete mode 100644 slatec/lsod.f delete mode 100644 slatec/lssods.f delete mode 100644 slatec/lssuds.f delete mode 100644 slatec/macon.f delete mode 100644 slatec/mc20ad.f delete mode 100644 slatec/mc20as.f delete mode 100644 slatec/mgsbv.f delete mode 100644 slatec/minfit.f delete mode 100644 slatec/minso4.f delete mode 100644 slatec/minsol.f delete mode 100644 slatec/mpadd.f delete mode 100644 slatec/mpadd2.f delete mode 100644 slatec/mpadd3.f delete mode 100644 slatec/mpblas.f delete mode 100644 slatec/mpcdm.f delete mode 100644 slatec/mpchk.f delete mode 100644 slatec/mpcmd.f delete mode 100644 slatec/mpdivi.f delete mode 100644 slatec/mperr.f delete mode 100644 slatec/mpmaxr.f delete mode 100644 slatec/mpmlp.f delete mode 100644 slatec/mpmul.f delete mode 100644 slatec/mpmul2.f delete mode 100644 slatec/mpmuli.f delete mode 100644 slatec/mpnzr.f delete mode 100644 slatec/mpovfl.f delete mode 100644 slatec/mpstr.f delete mode 100644 slatec/mpunfl.f delete mode 100644 slatec/numxer.f delete mode 100644 slatec/ohtrol.f delete mode 100644 slatec/ohtror.f delete mode 100644 slatec/ortbak.f delete mode 100644 slatec/orthes.f delete mode 100644 slatec/ortho4.f delete mode 100644 slatec/orthog.f delete mode 100644 slatec/orthol.f delete mode 100644 slatec/orthor.f delete mode 100644 slatec/ortran.f delete mode 100644 slatec/passb.f delete mode 100644 slatec/passb2.f delete mode 100644 slatec/passb3.f delete mode 100644 slatec/passb4.f delete mode 100644 slatec/passb5.f delete mode 100644 slatec/passf.f delete mode 100644 slatec/passf2.f delete mode 100644 slatec/passf3.f delete mode 100644 slatec/passf4.f delete mode 100644 slatec/passf5.f delete mode 100644 slatec/pchbs.f delete mode 100644 slatec/pchce.f delete mode 100644 slatec/pchci.f delete mode 100644 slatec/pchcm.f delete mode 100644 slatec/pchcs.f delete mode 100644 slatec/pchdf.f delete mode 100644 slatec/pchdoc.f delete mode 100644 slatec/pchfd.f delete mode 100644 slatec/pchfe.f delete mode 100644 slatec/pchia.f delete mode 100644 slatec/pchic.f delete mode 100644 slatec/pchid.f delete mode 100644 slatec/pchim.f delete mode 100644 slatec/pchkt.f delete mode 100644 slatec/pchngs.f delete mode 100644 slatec/pchsp.f delete mode 100644 slatec/pchst.f delete mode 100644 slatec/pchsw.f delete mode 100644 slatec/pcoef.f delete mode 100644 slatec/pfqad.f delete mode 100644 slatec/pgsf.f delete mode 100644 slatec/pimach.f delete mode 100644 slatec/pinitm.f delete mode 100644 slatec/pjac.f delete mode 100644 slatec/pnnzrs.f delete mode 100644 slatec/poch.f delete mode 100644 slatec/poch1.f delete mode 100644 slatec/pois3d.f delete mode 100644 slatec/poisd2.f delete mode 100644 slatec/poisn2.f delete mode 100644 slatec/poisp2.f delete mode 100644 slatec/poistg.f delete mode 100644 slatec/polcof.f delete mode 100644 slatec/polfit.f delete mode 100644 slatec/polint.f delete mode 100644 slatec/polyvl.f delete mode 100644 slatec/pos3d1.f delete mode 100644 slatec/postg2.f delete mode 100644 slatec/ppadd.f delete mode 100644 slatec/ppgq8.f delete mode 100644 slatec/ppgsf.f delete mode 100644 slatec/pppsf.f delete mode 100644 slatec/ppqad.f delete mode 100644 slatec/ppsgf.f delete mode 100644 slatec/ppspf.f delete mode 100644 slatec/ppval.f delete mode 100644 slatec/proc.f delete mode 100644 slatec/procp.f delete mode 100644 slatec/prod.f delete mode 100644 slatec/prodp.f delete mode 100644 slatec/prvec.f delete mode 100644 slatec/prwpge.f delete mode 100644 slatec/prwvir.f delete mode 100644 slatec/psgf.f delete mode 100644 slatec/psi.f delete mode 100644 slatec/psifn.f delete mode 100644 slatec/psixn.f delete mode 100644 slatec/pvalue.f delete mode 100644 slatec/pythag.f delete mode 100644 slatec/qag.f delete mode 100644 slatec/qage.f delete mode 100644 slatec/qagi.f delete mode 100644 slatec/qagie.f delete mode 100644 slatec/qagp.f delete mode 100644 slatec/qagpe.f delete mode 100644 slatec/qags.f delete mode 100644 slatec/qagse.f delete mode 100644 slatec/qawc.f delete mode 100644 slatec/qawce.f delete mode 100644 slatec/qawf.f delete mode 100644 slatec/qawfe.f delete mode 100644 slatec/qawo.f delete mode 100644 slatec/qawoe.f delete mode 100644 slatec/qaws.f delete mode 100644 slatec/qawse.f delete mode 100644 slatec/qc25c.f delete mode 100644 slatec/qc25f.f delete mode 100644 slatec/qc25s.f delete mode 100644 slatec/qcheb.f delete mode 100644 slatec/qelg.f delete mode 100644 slatec/qform.f delete mode 100644 slatec/qk15.f delete mode 100644 slatec/qk15i.f delete mode 100644 slatec/qk15w.f delete mode 100644 slatec/qk21.f delete mode 100644 slatec/qk31.f delete mode 100644 slatec/qk41.f delete mode 100644 slatec/qk51.f delete mode 100644 slatec/qk61.f delete mode 100644 slatec/qmomo.f delete mode 100644 slatec/qnc79.f delete mode 100644 slatec/qng.f delete mode 100644 slatec/qpdoc.f delete mode 100644 slatec/qpsrt.f delete mode 100644 slatec/qrfac.f delete mode 100644 slatec/qrsolv.f delete mode 100644 slatec/qs2i1d.f delete mode 100644 slatec/qs2i1r.f delete mode 100644 slatec/qwgtc.f delete mode 100644 slatec/qwgtf.f delete mode 100644 slatec/qwgts.f delete mode 100644 slatec/qzhes.f delete mode 100644 slatec/qzit.f delete mode 100644 slatec/qzval.f delete mode 100644 slatec/qzvec.f delete mode 100644 slatec/r1mach.f delete mode 100644 slatec/r1mpyq.f delete mode 100644 slatec/r1updt.f delete mode 100644 slatec/r9aimp.f delete mode 100644 slatec/r9atn1.f delete mode 100644 slatec/r9chu.f delete mode 100644 slatec/r9gmic.f delete mode 100644 slatec/r9gmit.f delete mode 100644 slatec/r9knus.f delete mode 100644 slatec/r9lgic.f delete mode 100644 slatec/r9lgit.f delete mode 100644 slatec/r9lgmc.f delete mode 100644 slatec/r9ln2r.f delete mode 100644 slatec/r9pak.f delete mode 100644 slatec/r9upak.f delete mode 100644 slatec/radb2.f delete mode 100644 slatec/radb3.f delete mode 100644 slatec/radb4.f delete mode 100644 slatec/radb5.f delete mode 100644 slatec/radbg.f delete mode 100644 slatec/radf2.f delete mode 100644 slatec/radf3.f delete mode 100644 slatec/radf4.f delete mode 100644 slatec/radf5.f delete mode 100644 slatec/radfg.f delete mode 100644 slatec/rand.f delete mode 100644 slatec/ratqr.f delete mode 100644 slatec/rc.f delete mode 100644 slatec/rc3jj.f delete mode 100644 slatec/rc3jm.f delete mode 100644 slatec/rc6j.f delete mode 100644 slatec/rd.f delete mode 100644 slatec/rebak.f delete mode 100644 slatec/rebakb.f delete mode 100644 slatec/reduc.f delete mode 100644 slatec/reduc2.f delete mode 100644 slatec/reort.f delete mode 100644 slatec/rf.f delete mode 100644 slatec/rfftb.f delete mode 100644 slatec/rfftb1.f delete mode 100644 slatec/rfftf.f delete mode 100644 slatec/rfftf1.f delete mode 100644 slatec/rffti.f delete mode 100644 slatec/rffti1.f delete mode 100644 slatec/rg.f delete mode 100644 slatec/rgauss.f delete mode 100644 slatec/rgg.f delete mode 100644 slatec/rj.f delete mode 100644 slatec/rkfab.f delete mode 100644 slatec/rpqr79.f delete mode 100644 slatec/rpzero.f delete mode 100644 slatec/rs.f delete mode 100644 slatec/rsb.f delete mode 100644 slatec/rsco.f delete mode 100644 slatec/rsg.f delete mode 100644 slatec/rsgab.f delete mode 100644 slatec/rsgba.f delete mode 100644 slatec/rsp.f delete mode 100644 slatec/rst.f delete mode 100644 slatec/rt.f delete mode 100644 slatec/runif.f delete mode 100644 slatec/rwupdt.f delete mode 100644 slatec/s1merg.f delete mode 100644 slatec/sasum.f delete mode 100644 slatec/saxpy.f delete mode 100644 slatec/sbcg.f delete mode 100644 slatec/sbhin.f delete mode 100644 slatec/sbocls.f delete mode 100644 slatec/sbols.f delete mode 100644 slatec/sbolsm.f delete mode 100644 slatec/scasum.f delete mode 100644 slatec/scg.f delete mode 100644 slatec/scgn.f delete mode 100644 slatec/scgs.f delete mode 100644 slatec/schdc.f delete mode 100644 slatec/schdd.f delete mode 100644 slatec/schex.f delete mode 100644 slatec/schkw.f delete mode 100644 slatec/schud.f delete mode 100644 slatec/sclosm.f delete mode 100644 slatec/scnrm2.f delete mode 100644 slatec/scoef.f delete mode 100644 slatec/scopy.f delete mode 100644 slatec/scopym.f delete mode 100644 slatec/scov.f delete mode 100644 slatec/scpplt.f delete mode 100644 slatec/sdaini.f delete mode 100644 slatec/sdajac.f delete mode 100644 slatec/sdanrm.f delete mode 100644 slatec/sdaslv.f delete mode 100644 slatec/sdassl.f delete mode 100644 slatec/sdastp.f delete mode 100644 slatec/sdatrp.f delete mode 100644 slatec/sdawts.f delete mode 100644 slatec/sdcor.f delete mode 100644 slatec/sdcst.f delete mode 100644 slatec/sdntl.f delete mode 100644 slatec/sdntp.f delete mode 100644 slatec/sdot.f delete mode 100644 slatec/sdpsc.f delete mode 100644 slatec/sdpst.f delete mode 100644 slatec/sdriv1.f delete mode 100644 slatec/sdriv2.f delete mode 100644 slatec/sdriv3.f delete mode 100644 slatec/sdscl.f delete mode 100644 slatec/sdsdot.f delete mode 100644 slatec/sdstp.f delete mode 100644 slatec/sdzro.f delete mode 100644 slatec/sepeli.f delete mode 100644 slatec/sepx4.f delete mode 100644 slatec/sgbco.f delete mode 100644 slatec/sgbdi.f delete mode 100644 slatec/sgbfa.f delete mode 100644 slatec/sgbmv.f delete mode 100644 slatec/sgbsl.f delete mode 100644 slatec/sgeco.f delete mode 100644 slatec/sgedi.f delete mode 100644 slatec/sgeev.f delete mode 100644 slatec/sgefa.f delete mode 100644 slatec/sgefs.f delete mode 100644 slatec/sgeir.f delete mode 100644 slatec/sgemm.f delete mode 100644 slatec/sgemv.f delete mode 100644 slatec/sger.f delete mode 100644 slatec/sgesl.f delete mode 100644 slatec/sglss.f delete mode 100644 slatec/sgmres.f delete mode 100644 slatec/sgtsl.f delete mode 100644 slatec/shels.f delete mode 100644 slatec/sheqr.f delete mode 100644 slatec/sindg.f delete mode 100644 slatec/sinqb.f delete mode 100644 slatec/sinqf.f delete mode 100644 slatec/sinqi.f delete mode 100644 slatec/sint.f delete mode 100644 slatec/sinti.f delete mode 100644 slatec/sintrp.f delete mode 100644 slatec/sir.f delete mode 100644 slatec/sllti2.f delete mode 100644 slatec/slpdoc.f delete mode 100644 slatec/slvs.f delete mode 100644 slatec/smout.f delete mode 100644 slatec/snbco.f delete mode 100644 slatec/snbdi.f delete mode 100644 slatec/snbfa.f delete mode 100644 slatec/snbfs.f delete mode 100644 slatec/snbir.f delete mode 100644 slatec/snbsl.f delete mode 100644 slatec/snls1.f delete mode 100644 slatec/snls1e.f delete mode 100644 slatec/snrm2.f delete mode 100644 slatec/snsq.f delete mode 100644 slatec/snsqe.f delete mode 100644 slatec/sods.f delete mode 100644 slatec/somn.f delete mode 100644 slatec/sopenm.f delete mode 100644 slatec/sorth.f delete mode 100644 slatec/sos.f delete mode 100644 slatec/soseqs.f delete mode 100644 slatec/sossol.f delete mode 100644 slatec/spbco.f delete mode 100644 slatec/spbdi.f delete mode 100644 slatec/spbfa.f delete mode 100644 slatec/spbsl.f delete mode 100644 slatec/speli4.f delete mode 100644 slatec/spelip.f delete mode 100644 slatec/spenc.f delete mode 100644 slatec/spigmr.f delete mode 100644 slatec/spincw.f delete mode 100644 slatec/spinit.f delete mode 100644 slatec/splp.f delete mode 100644 slatec/splpce.f delete mode 100644 slatec/splpdm.f delete mode 100644 slatec/splpfe.f delete mode 100644 slatec/splpfl.f delete mode 100644 slatec/splpmn.f delete mode 100644 slatec/splpmu.f delete mode 100644 slatec/splpup.f delete mode 100644 slatec/spoco.f delete mode 100644 slatec/spodi.f delete mode 100644 slatec/spofa.f delete mode 100644 slatec/spofs.f delete mode 100644 slatec/spoir.f delete mode 100644 slatec/spopt.f delete mode 100644 slatec/sposl.f delete mode 100644 slatec/sppco.f delete mode 100644 slatec/sppdi.f delete mode 100644 slatec/spperm.f delete mode 100644 slatec/sppfa.f delete mode 100644 slatec/sppsl.f delete mode 100644 slatec/spsort.f delete mode 100644 slatec/sptsl.f delete mode 100644 slatec/sqrdc.f delete mode 100644 slatec/sqrsl.f delete mode 100644 slatec/sreadp.f delete mode 100644 slatec/srlcal.f delete mode 100644 slatec/srot.f delete mode 100644 slatec/srotg.f delete mode 100644 slatec/srotm.f delete mode 100644 slatec/srotmg.f delete mode 100644 slatec/ss2lt.f delete mode 100644 slatec/ss2y.f delete mode 100644 slatec/ssbmv.f delete mode 100644 slatec/sscal.f delete mode 100644 slatec/ssd2s.f delete mode 100644 slatec/ssdbcg.f delete mode 100644 slatec/ssdcg.f delete mode 100644 slatec/ssdcgn.f delete mode 100644 slatec/ssdcgs.f delete mode 100644 slatec/ssdgmr.f delete mode 100644 slatec/ssdi.f delete mode 100644 slatec/ssdomn.f delete mode 100644 slatec/ssds.f delete mode 100644 slatec/ssdscl.f delete mode 100644 slatec/ssgs.f delete mode 100644 slatec/ssiccg.f delete mode 100644 slatec/ssico.f delete mode 100644 slatec/ssics.f delete mode 100644 slatec/ssidi.f delete mode 100644 slatec/ssiev.f delete mode 100644 slatec/ssifa.f delete mode 100644 slatec/ssilur.f delete mode 100644 slatec/ssilus.f delete mode 100644 slatec/ssisl.f delete mode 100644 slatec/ssjac.f delete mode 100644 slatec/ssli.f delete mode 100644 slatec/ssli2.f delete mode 100644 slatec/ssllti.f delete mode 100644 slatec/sslubc.f delete mode 100644 slatec/sslucn.f delete mode 100644 slatec/sslucs.f delete mode 100644 slatec/sslugm.f delete mode 100644 slatec/sslui.f delete mode 100644 slatec/sslui2.f delete mode 100644 slatec/sslui4.f delete mode 100644 slatec/ssluom.f delete mode 100644 slatec/ssluti.f delete mode 100644 slatec/ssmmi2.f delete mode 100644 slatec/ssmmti.f delete mode 100644 slatec/ssmtv.f delete mode 100644 slatec/ssmv.f delete mode 100644 slatec/ssort.f delete mode 100644 slatec/sspco.f delete mode 100644 slatec/sspdi.f delete mode 100644 slatec/sspev.f delete mode 100644 slatec/sspfa.f delete mode 100644 slatec/sspmv.f delete mode 100644 slatec/sspr.f delete mode 100644 slatec/sspr2.f delete mode 100644 slatec/sspsl.f delete mode 100644 slatec/ssvdc.f delete mode 100644 slatec/sswap.f delete mode 100644 slatec/ssymm.f delete mode 100644 slatec/ssymv.f delete mode 100644 slatec/ssyr.f delete mode 100644 slatec/ssyr2.f delete mode 100644 slatec/ssyr2k.f delete mode 100644 slatec/ssyrk.f delete mode 100644 slatec/stbmv.f delete mode 100644 slatec/stbsv.f delete mode 100644 slatec/steps.f delete mode 100644 slatec/stin.f delete mode 100644 slatec/stod.f delete mode 100644 slatec/stor1.f delete mode 100644 slatec/stout.f delete mode 100644 slatec/stpmv.f delete mode 100644 slatec/stpsv.f delete mode 100644 slatec/strco.f delete mode 100644 slatec/strdi.f delete mode 100644 slatec/strmm.f delete mode 100644 slatec/strmv.f delete mode 100644 slatec/strsl.f delete mode 100644 slatec/strsm.f delete mode 100644 slatec/strsv.f delete mode 100644 slatec/stway.f delete mode 100644 slatec/suds.f delete mode 100644 slatec/svco.f delete mode 100644 slatec/svd.f delete mode 100644 slatec/svecs.f delete mode 100644 slatec/svout.f delete mode 100644 slatec/swritp.f delete mode 100644 slatec/sxlcal.f delete mode 100644 slatec/tevlc.f delete mode 100644 slatec/tevls.f delete mode 100644 slatec/tinvit.f delete mode 100644 slatec/toc delete mode 100644 slatec/tql1.f delete mode 100644 slatec/tql2.f delete mode 100644 slatec/tqlrat.f delete mode 100644 slatec/trbak1.f delete mode 100644 slatec/trbak3.f delete mode 100644 slatec/tred1.f delete mode 100644 slatec/tred2.f delete mode 100644 slatec/tred3.f delete mode 100644 slatec/tri3.f delete mode 100644 slatec/tridib.f delete mode 100644 slatec/tridq.f delete mode 100644 slatec/tris4.f delete mode 100644 slatec/trisp.f delete mode 100644 slatec/trix.f delete mode 100644 slatec/tsturm.f delete mode 100644 slatec/u11ls.f delete mode 100644 slatec/u11us.f delete mode 100644 slatec/u12ls.f delete mode 100644 slatec/u12us.f delete mode 100644 slatec/ulsia.f delete mode 100644 slatec/usrmat.f delete mode 100644 slatec/vnwrms.f delete mode 100644 slatec/wnlit.f delete mode 100644 slatec/wnlsm.f delete mode 100644 slatec/wnlt1.f delete mode 100644 slatec/wnlt2.f delete mode 100644 slatec/wnlt3.f delete mode 100644 slatec/wnnls.f delete mode 100644 slatec/xadd.f delete mode 100644 slatec/xadj.f delete mode 100644 slatec/xc210.f delete mode 100644 slatec/xcon.f delete mode 100644 slatec/xerbla.f delete mode 100644 slatec/xerclr.f delete mode 100644 slatec/xercnt.f delete mode 100644 slatec/xerdmp.f delete mode 100644 slatec/xerhlt.f delete mode 100644 slatec/xermax.f delete mode 100644 slatec/xermsg.f delete mode 100644 slatec/xerprn.f delete mode 100644 slatec/xerror.f delete mode 100644 slatec/xersve.f delete mode 100644 slatec/xgetf.f delete mode 100644 slatec/xgetua.f delete mode 100644 slatec/xgetun.f delete mode 100644 slatec/xlegf.f delete mode 100644 slatec/xnrmp.f delete mode 100644 slatec/xpmu.f delete mode 100644 slatec/xpmup.f delete mode 100644 slatec/xpnrm.f delete mode 100644 slatec/xpqnu.f delete mode 100644 slatec/xpsi.f delete mode 100644 slatec/xqmu.f delete mode 100644 slatec/xqnu.f delete mode 100644 slatec/xred.f delete mode 100644 slatec/xset.f delete mode 100644 slatec/xsetf.f delete mode 100644 slatec/xsetua.f delete mode 100644 slatec/xsetun.f delete mode 100644 slatec/yairy.f delete mode 100644 slatec/zabs.f delete mode 100644 slatec/zacai.f delete mode 100644 slatec/zacon.f delete mode 100644 slatec/zairy.f delete mode 100644 slatec/zasyi.f delete mode 100644 slatec/zbesh.f delete mode 100644 slatec/zbesi.f delete mode 100644 slatec/zbesj.f delete mode 100644 slatec/zbesk.f delete mode 100644 slatec/zbesy.f delete mode 100644 slatec/zbinu.f delete mode 100644 slatec/zbiry.f delete mode 100644 slatec/zbknu.f delete mode 100644 slatec/zbuni.f delete mode 100644 slatec/zbunk.f delete mode 100644 slatec/zdiv.f delete mode 100644 slatec/zexp.f delete mode 100644 slatec/zkscl.f delete mode 100644 slatec/zlog.f delete mode 100644 slatec/zmlri.f delete mode 100644 slatec/zmlt.f delete mode 100644 slatec/zrati.f delete mode 100644 slatec/zs1s2.f delete mode 100644 slatec/zseri.f delete mode 100644 slatec/zshch.f delete mode 100644 slatec/zsqrt.f delete mode 100644 slatec/zuchk.f delete mode 100644 slatec/zunhj.f delete mode 100644 slatec/zuni1.f delete mode 100644 slatec/zuni2.f delete mode 100644 slatec/zunik.f delete mode 100644 slatec/zunk1.f delete mode 100644 slatec/zunk2.f delete mode 100644 slatec/zuoik.f delete mode 100644 slatec/zwrsk.f diff --git a/slatec/Make.files b/slatec/Make.files deleted file mode 100644 index ffbdfe6..0000000 --- a/slatec/Make.files +++ /dev/null @@ -1,6 +0,0 @@ -$(CUR_SRCS) += d1mach.f zabs.f zasyi.f zbesk.f zbknu.f zexp.f zmlt.f zshch.f zuni1.f zunk2.f \ - dgamln.f zacai.f zbesh.f zbesy.f zbuni.f zkscl.f zrati.f zsqrt.f zuni2.f zuoik.f \ - i1mach.f zacon.f zbesi.f zbinu.f zbunk.f zlog.f zs1s2.f zuchk.f zunik.f zwrsk.f \ - xerror.f zairy.f zbesj.f zbiry.f zdiv.f zmlri.f zseri.f zunhj.f zunk1.f \ - xermsg.f fdump.f j4save.f xercnt.f xerhlt.f xerprn.f xersve.f xgetua.f - diff --git a/slatec/aaaaaa.f b/slatec/aaaaaa.f deleted file mode 100644 index ef2a541..0000000 --- a/slatec/aaaaaa.f +++ /dev/null @@ -1,71 +0,0 @@ -*DECK AAAAAA - SUBROUTINE AAAAAA (VER) -C***BEGIN PROLOGUE AAAAAA -C***PURPOSE SLATEC Common Mathematical Library disclaimer and version. -C***LIBRARY SLATEC -C***CATEGORY Z -C***TYPE ALL (AAAAAA-A) -C***KEYWORDS DISCLAIMER, DOCUMENTATION, VERSION -C***AUTHOR SLATEC Common Mathematical Library Committee -C***DESCRIPTION -C -C The SLATEC Common Mathematical Library is issued by the following -C -C Air Force Weapons Laboratory, Albuquerque -C Lawrence Livermore National Laboratory, Livermore -C Los Alamos National Laboratory, Los Alamos -C National Institute of Standards and Technology, Washington -C National Energy Research Supercomputer Center, Livermore -C Oak Ridge National Laboratory, Oak Ridge -C Sandia National Laboratories, Albuquerque -C Sandia National Laboratories, Livermore -C -C All questions concerning the distribution of the library should be -C directed to the NATIONAL ENERGY SOFTWARE CENTER, 9700 Cass Ave., -C Argonne, Illinois 60439, and not to the authors of the subprograms. -C -C * * * * * Notice * * * * * -C -C This material was prepared as an account of work sponsored by the -C United States Government. Neither the United States, nor the -C Department of Energy, nor the Department of Defense, nor any of -C their employees, nor any of their contractors, subcontractors, or -C their employees, makes any warranty, expressed or implied, or -C assumes any legal liability or responsibility for the accuracy, -C completeness, or usefulness of any information, apparatus, product, -C or process disclosed, or represents that its use would not infringe -C upon privately owned rights. -C -C *Usage: -C -C CHARACTER * 16 VER -C -C CALL AAAAAA (VER) -C -C *Arguments: -C -C VER:OUT will contain the version number of the SLATEC CML. -C -C *Description: -C -C This routine contains the SLATEC Common Mathematical Library -C disclaimer and can be used to return the library version number. -C -C***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro -C and Lee Walton, Guide to the SLATEC Common Mathema- -C tical Library, April 10, 1990. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 800424 DATE WRITTEN -C 890414 REVISION DATE from Version 3.2 -C 890713 Routine modified to return version number. (WRB) -C 900330 Prologue converted to Version 4.0 format. (BAB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 921215 Updated for Version 4.0. (WRB) -C 930701 Updated for Version 4.1. (WRB) -C***END PROLOGUE AAAAAA - CHARACTER * (*) VER -C***FIRST EXECUTABLE STATEMENT AAAAAA - VER = ' 4.1' - RETURN - END diff --git a/slatec/acosh.f b/slatec/acosh.f deleted file mode 100644 index acfd00c..0000000 --- a/slatec/acosh.f +++ /dev/null @@ -1,39 +0,0 @@ -*DECK ACOSH - FUNCTION ACOSH (X) -C***BEGIN PROLOGUE ACOSH -C***PURPOSE Compute the arc hyperbolic cosine. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4C -C***TYPE SINGLE PRECISION (ACOSH-S, DACOSH-D, CACOSH-C) -C***KEYWORDS ACOSH, ARC HYPERBOLIC COSINE, ELEMENTARY FUNCTIONS, FNLIB, -C INVERSE HYPERBOLIC COSINE -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C ACOSH(X) computes the arc hyperbolic cosine of X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE ACOSH - SAVE ALN2,XMAX - DATA ALN2 / 0.6931471805 5994530942E0/ - DATA XMAX /0./ -C***FIRST EXECUTABLE STATEMENT ACOSH - IF (XMAX.EQ.0.) XMAX = 1.0/SQRT(R1MACH(3)) -C - IF (X .LT. 1.0) CALL XERMSG ('SLATEC', 'ACOSH', 'X LESS THAN 1', - + 1, 2) -C - IF (X.LT.XMAX) ACOSH = LOG (X + SQRT(X*X-1.0)) - IF (X.GE.XMAX) ACOSH = ALN2 + LOG(X) -C - RETURN - END diff --git a/slatec/ai.f b/slatec/ai.f deleted file mode 100644 index 15c34b0..0000000 --- a/slatec/ai.f +++ /dev/null @@ -1,90 +0,0 @@ -*DECK AI - FUNCTION AI (X) -C***BEGIN PROLOGUE AI -C***PURPOSE Evaluate the Airy function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10D -C***TYPE SINGLE PRECISION (AI-S, DAI-D) -C***KEYWORDS AIRY FUNCTION, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C AI(X) computes the Airy function Ai(X) -C Series for AIF on the interval -1.00000D+00 to 1.00000D+00 -C with weighted error 1.09E-19 -C log weighted error 18.96 -C significant figures required 17.76 -C decimal places required 19.44 -C -C Series for AIG on the interval -1.00000D+00 to 1.00000D+00 -C with weighted error 1.51E-17 -C log weighted error 16.82 -C significant figures required 15.19 -C decimal places required 17.27 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED AIE, CSEVL, INITS, R1MACH, R9AIMP, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920618 Removed space from variable names. (RWC, WRB) -C***END PROLOGUE AI - DIMENSION AIFCS(9), AIGCS(8) - LOGICAL FIRST - SAVE AIFCS, AIGCS, NAIF, NAIG, X3SML, XMAX, FIRST - DATA AIFCS( 1) / -.0379713584 9666999750E0 / - DATA AIFCS( 2) / .0591918885 3726363857E0 / - DATA AIFCS( 3) / .0009862928 0577279975E0 / - DATA AIFCS( 4) / .0000068488 4381907656E0 / - DATA AIFCS( 5) / .0000000259 4202596219E0 / - DATA AIFCS( 6) / .0000000000 6176612774E0 / - DATA AIFCS( 7) / .0000000000 0010092454E0 / - DATA AIFCS( 8) / .0000000000 0000012014E0 / - DATA AIFCS( 9) / .0000000000 0000000010E0 / - DATA AIGCS( 1) / .0181523655 8116127E0 / - DATA AIGCS( 2) / .0215725631 6601076E0 / - DATA AIGCS( 3) / .0002567835 6987483E0 / - DATA AIGCS( 4) / .0000014265 2141197E0 / - DATA AIGCS( 5) / .0000000045 7211492E0 / - DATA AIGCS( 6) / .0000000000 0952517E0 / - DATA AIGCS( 7) / .0000000000 0001392E0 / - DATA AIGCS( 8) / .0000000000 0000001E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT AI - IF (FIRST) THEN - NAIF = INITS (AIFCS, 9, 0.1*R1MACH(3)) - NAIG = INITS (AIGCS, 8, 0.1*R1MACH(3)) -C - X3SML = R1MACH(3)**0.3334 - XMAXT = (-1.5*LOG(R1MACH(1)))**0.6667 - XMAX = XMAXT - XMAXT*LOG(XMAXT)/ - * (4.0*SQRT(XMAXT)+1.0) - 0.01 - ENDIF - FIRST = .FALSE. -C - IF (X.GE.(-1.0)) GO TO 20 - CALL R9AIMP (X, XM, THETA) - AI = XM * COS(THETA) - RETURN -C - 20 IF (X.GT.1.0) GO TO 30 - Z = 0.0 - IF (ABS(X).GT.X3SML) Z = X**3 - AI = 0.375 + (CSEVL (Z, AIFCS, NAIF) - X*(0.25 + - 1 CSEVL (Z, AIGCS, NAIG)) ) - RETURN -C - 30 IF (X.GT.XMAX) GO TO 40 - AI = AIE(X) * EXP(-2.0*X*SQRT(X)/3.0) - RETURN -C - 40 AI = 0.0 - CALL XERMSG ('SLATEC', 'AI', 'X SO BIG AI UNDERFLOWS', 1, 1) - RETURN -C - END diff --git a/slatec/aie.f b/slatec/aie.f deleted file mode 100644 index e01177d..0000000 --- a/slatec/aie.f +++ /dev/null @@ -1,133 +0,0 @@ -*DECK AIE - FUNCTION AIE (X) -C***BEGIN PROLOGUE AIE -C***PURPOSE Calculate the Airy function for a negative argument and an -C exponentially scaled Airy function for a non-negative -C argument. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10D -C***TYPE SINGLE PRECISION (AIE-S, DAIE-D) -C***KEYWORDS EXPONENTIALLY SCALED AIRY FUNCTION, FNLIB, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C AIE(X) computes the exponentially scaled Airy function for -C non-negative X. It evaluates AI(X) for X .LE. 0.0 and -C EXP(ZETA)*AI(X) for X .GE. 0.0 where ZETA = (2.0/3.0)*(X**1.5). -C -C Series for AIF on the interval -1.00000D+00 to 1.00000D+00 -C with weighted error 1.09E-19 -C log weighted error 18.96 -C significant figures required 17.76 -C decimal places required 19.44 -C -C Series for AIG on the interval -1.00000D+00 to 1.00000D+00 -C with weighted error 1.51E-17 -C log weighted error 16.82 -C significant figures required 15.19 -C decimal places required 17.27 -C -C Series for AIP on the interval 0. to 1.00000D+00 -C with weighted error 5.10E-17 -C log weighted error 16.29 -C significant figures required 14.41 -C decimal places required 17.06 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, INITS, R1MACH, R9AIMP -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890206 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920618 Removed space from variable names. (RWC, WRB) -C***END PROLOGUE AIE - DIMENSION AIFCS(9), AIGCS(8), AIPCS(34) - LOGICAL FIRST - SAVE AIFCS, AIGCS, AIPCS, NAIF, NAIG, - 1 NAIP, X3SML, X32SML, XBIG, FIRST - DATA AIFCS( 1) / -.0379713584 9666999750E0 / - DATA AIFCS( 2) / .0591918885 3726363857E0 / - DATA AIFCS( 3) / .0009862928 0577279975E0 / - DATA AIFCS( 4) / .0000068488 4381907656E0 / - DATA AIFCS( 5) / .0000000259 4202596219E0 / - DATA AIFCS( 6) / .0000000000 6176612774E0 / - DATA AIFCS( 7) / .0000000000 0010092454E0 / - DATA AIFCS( 8) / .0000000000 0000012014E0 / - DATA AIFCS( 9) / .0000000000 0000000010E0 / - DATA AIGCS( 1) / .0181523655 8116127E0 / - DATA AIGCS( 2) / .0215725631 6601076E0 / - DATA AIGCS( 3) / .0002567835 6987483E0 / - DATA AIGCS( 4) / .0000014265 2141197E0 / - DATA AIGCS( 5) / .0000000045 7211492E0 / - DATA AIGCS( 6) / .0000000000 0952517E0 / - DATA AIGCS( 7) / .0000000000 0001392E0 / - DATA AIGCS( 8) / .0000000000 0000001E0 / - DATA AIPCS( 1) / -.0187519297 793868E0 / - DATA AIPCS( 2) / -.0091443848 250055E0 / - DATA AIPCS( 3) / .0009010457 337825E0 / - DATA AIPCS( 4) / -.0001394184 127221E0 / - DATA AIPCS( 5) / .0000273815 815785E0 / - DATA AIPCS( 6) / -.0000062750 421119E0 / - DATA AIPCS( 7) / .0000016064 844184E0 / - DATA AIPCS( 8) / -.0000004476 392158E0 / - DATA AIPCS( 9) / .0000001334 635874E0 / - DATA AIPCS(10) / -.0000000420 735334E0 / - DATA AIPCS(11) / .0000000139 021990E0 / - DATA AIPCS(12) / -.0000000047 831848E0 / - DATA AIPCS(13) / .0000000017 047897E0 / - DATA AIPCS(14) / -.0000000006 268389E0 / - DATA AIPCS(15) / .0000000002 369824E0 / - DATA AIPCS(16) / -.0000000000 918641E0 / - DATA AIPCS(17) / .0000000000 364278E0 / - DATA AIPCS(18) / -.0000000000 147475E0 / - DATA AIPCS(19) / .0000000000 060851E0 / - DATA AIPCS(20) / -.0000000000 025552E0 / - DATA AIPCS(21) / .0000000000 010906E0 / - DATA AIPCS(22) / -.0000000000 004725E0 / - DATA AIPCS(23) / .0000000000 002076E0 / - DATA AIPCS(24) / -.0000000000 000924E0 / - DATA AIPCS(25) / .0000000000 000417E0 / - DATA AIPCS(26) / -.0000000000 000190E0 / - DATA AIPCS(27) / .0000000000 000087E0 / - DATA AIPCS(28) / -.0000000000 000040E0 / - DATA AIPCS(29) / .0000000000 000019E0 / - DATA AIPCS(30) / -.0000000000 000009E0 / - DATA AIPCS(31) / .0000000000 000004E0 / - DATA AIPCS(32) / -.0000000000 000002E0 / - DATA AIPCS(33) / .0000000000 000001E0 / - DATA AIPCS(34) / -.0000000000 000000E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT AIE - IF (FIRST) THEN - ETA = 0.1*R1MACH(3) - NAIF = INITS (AIFCS, 9, ETA) - NAIG = INITS (AIGCS, 8, ETA) - NAIP = INITS (AIPCS, 34, ETA) -C - X3SML = ETA**0.3333 - X32SML = 1.3104*X3SML**2 - XBIG = R1MACH(2)**0.6666 - ENDIF - FIRST = .FALSE. -C - IF (X.GE.(-1.0)) GO TO 20 - CALL R9AIMP (X, XM, THETA) - AIE = XM * COS(THETA) - RETURN -C - 20 IF (X.GT.1.0) GO TO 30 - Z = 0.0 - IF (ABS(X).GT.X3SML) Z = X**3 - AIE = 0.375 + (CSEVL (Z, AIFCS, NAIF) - X*(0.25 + - 1 CSEVL (Z, AIGCS, NAIG)) ) - IF (X.GT.X32SML) AIE = AIE * EXP(2.0*X*SQRT(X)/3.0) - RETURN -C - 30 SQRTX = SQRT(X) - Z = -1.0 - IF (X.LT.XBIG) Z = 2.0/(X*SQRTX) - 1.0 - AIE = (.28125 + CSEVL (Z, AIPCS, NAIP))/SQRT(SQRTX) - RETURN -C - END diff --git a/slatec/albeta.f b/slatec/albeta.f deleted file mode 100644 index 4ed6aca..0000000 --- a/slatec/albeta.f +++ /dev/null @@ -1,63 +0,0 @@ -*DECK ALBETA - FUNCTION ALBETA (A, B) -C***BEGIN PROLOGUE ALBETA -C***PURPOSE Compute the natural logarithm of the complete Beta -C function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7B -C***TYPE SINGLE PRECISION (ALBETA-S, DLBETA-D, CLBETA-C) -C***KEYWORDS FNLIB, LOGARITHM OF THE COMPLETE BETA FUNCTION, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C ALBETA computes the natural log of the complete beta function. -C -C Input Parameters: -C A real and positive -C B real and positive -C -C***REFERENCES (NONE) -C***ROUTINES CALLED ALNGAM, ALNREL, GAMMA, R9LGMC, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900727 Added EXTERNAL statement. (WRB) -C***END PROLOGUE ALBETA - EXTERNAL GAMMA - SAVE SQ2PIL - DATA SQ2PIL / 0.9189385332 0467274 E0 / -C***FIRST EXECUTABLE STATEMENT ALBETA - P = MIN (A, B) - Q = MAX (A, B) -C - IF (P .LE. 0.0) CALL XERMSG ('SLATEC', 'ALBETA', - + 'BOTH ARGUMENTS MUST BE GT ZERO', 1, 2) - IF (P.GE.10.0) GO TO 30 - IF (Q.GE.10.0) GO TO 20 -C -C P AND Q ARE SMALL. -C - ALBETA = LOG(GAMMA(P) * (GAMMA(Q)/GAMMA(P+Q)) ) - RETURN -C -C P IS SMALL, BUT Q IS BIG. -C - 20 CORR = R9LGMC(Q) - R9LGMC(P+Q) - ALBETA = ALNGAM(P) + CORR + P - P*LOG(P+Q) + - 1 (Q-0.5)*ALNREL(-P/(P+Q)) - RETURN -C -C P AND Q ARE BIG. -C - 30 CORR = R9LGMC(P) + R9LGMC(Q) - R9LGMC(P+Q) - ALBETA = -0.5*LOG(Q) + SQ2PIL + CORR + (P-0.5)*LOG(P/(P+Q)) - 1 + Q*ALNREL(-P/(P+Q)) - RETURN -C - END diff --git a/slatec/algams.f b/slatec/algams.f deleted file mode 100644 index 230d78a..0000000 --- a/slatec/algams.f +++ /dev/null @@ -1,38 +0,0 @@ -*DECK ALGAMS - SUBROUTINE ALGAMS (X, ALGAM, SGNGAM) -C***BEGIN PROLOGUE ALGAMS -C***PURPOSE Compute the logarithm of the absolute value of the Gamma -C function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7A -C***TYPE SINGLE PRECISION (ALGAMS-S, DLGAMS-D) -C***KEYWORDS ABSOLUTE VALUE OF THE LOGARITHM OF THE GAMMA FUNCTION, -C FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluates the logarithm of the absolute value of the gamma -C function. -C X - input argument -C ALGAM - result -C SGNGAM - is set to the sign of GAMMA(X) and will -C be returned at +1.0 or -1.0. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED ALNGAM -C***REVISION HISTORY (YYMMDD) -C 770701 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***END PROLOGUE ALGAMS -C***FIRST EXECUTABLE STATEMENT ALGAMS - ALGAM = ALNGAM(X) - SGNGAM = 1.0 - IF (X.GT.0.0) RETURN -C - INT = MOD (-AINT(X), 2.0) + 0.1 - IF (INT.EQ.0) SGNGAM = -1.0 -C - RETURN - END diff --git a/slatec/ali.f b/slatec/ali.f deleted file mode 100644 index eba9ad9..0000000 --- a/slatec/ali.f +++ /dev/null @@ -1,35 +0,0 @@ -*DECK ALI - FUNCTION ALI (X) -C***BEGIN PROLOGUE ALI -C***PURPOSE Compute the logarithmic integral. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C5 -C***TYPE SINGLE PRECISION (ALI-S, DLI-D) -C***KEYWORDS FNLIB, LOGARITHMIC INTEGRAL, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C ALI(X) computes the logarithmic integral; i.e., the -C integral from 0.0 to X of (1.0/ln(t))dt. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED EI, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE ALI -C***FIRST EXECUTABLE STATEMENT ALI - IF (X .LE. 0.0) CALL XERMSG ('SLATEC', 'ALI', - + 'LOG INTEGRAL UNDEFINED FOR X LE 0', 1, 2) - IF (X .EQ. 1.0) CALL XERMSG ('SLATEC', 'ALI', - + 'LOG INTEGRAL UNDEFINED FOR X = 1', 2, 2) -C - ALI = EI (LOG(X) ) -C - RETURN - END diff --git a/slatec/alngam.f b/slatec/alngam.f deleted file mode 100644 index 7ba410b..0000000 --- a/slatec/alngam.f +++ /dev/null @@ -1,70 +0,0 @@ -*DECK ALNGAM - FUNCTION ALNGAM (X) -C***BEGIN PROLOGUE ALNGAM -C***PURPOSE Compute the logarithm of the absolute value of the Gamma -C function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7A -C***TYPE SINGLE PRECISION (ALNGAM-S, DLNGAM-D, CLNGAM-C) -C***KEYWORDS ABSOLUTE VALUE, COMPLETE GAMMA FUNCTION, FNLIB, LOGARITHM, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C ALNGAM(X) computes the logarithm of the absolute value of the -C gamma function at X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED GAMMA, R1MACH, R9LGMC, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900727 Added EXTERNAL statement. (WRB) -C***END PROLOGUE ALNGAM - LOGICAL FIRST - EXTERNAL GAMMA - SAVE SQ2PIL, SQPI2L, PI, XMAX, DXREL, FIRST - DATA SQ2PIL / 0.9189385332 0467274E0/ - DATA SQPI2L / 0.2257913526 4472743E0/ - DATA PI / 3.1415926535 8979324E0/ - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT ALNGAM - IF (FIRST) THEN - XMAX = R1MACH(2)/LOG(R1MACH(2)) - DXREL = SQRT (R1MACH(4)) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.10.0) GO TO 20 -C -C LOG (ABS (GAMMA(X))) FOR ABS(X) .LE. 10.0 -C - ALNGAM = LOG (ABS (GAMMA(X))) - RETURN -C -C LOG (ABS (GAMMA(X))) FOR ABS(X) .GT. 10.0 -C - 20 IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'ALNGAM', - + 'ABS(X) SO BIG ALNGAM OVERFLOWS', 2, 2) -C - IF (X.GT.0.) ALNGAM = SQ2PIL + (X-0.5)*LOG(X) - X + R9LGMC(Y) - IF (X.GT.0.) RETURN -C - SINPIY = ABS (SIN(PI*Y)) - IF (SINPIY .EQ. 0.) CALL XERMSG ('SLATEC', 'ALNGAM', - + 'X IS A NEGATIVE INTEGER', 3, 2) -C - IF (ABS((X-AINT(X-0.5))/X) .LT. DXREL) CALL XERMSG ('SLATEC', - + 'ALNGAM', 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR ' // - + 'NEGATIVE INTEGER', 1, 1) -C - ALNGAM = SQPI2L + (X-0.5)*LOG(Y) - X - LOG(SINPIY) - R9LGMC(Y) - RETURN -C - END diff --git a/slatec/alnrel.f b/slatec/alnrel.f deleted file mode 100644 index 1617189..0000000 --- a/slatec/alnrel.f +++ /dev/null @@ -1,78 +0,0 @@ -*DECK ALNREL - FUNCTION ALNREL (X) -C***BEGIN PROLOGUE ALNREL -C***PURPOSE Evaluate ln(1+X) accurate in the sense of relative error. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4B -C***TYPE SINGLE PRECISION (ALNREL-S, DLNREL-D, CLNREL-C) -C***KEYWORDS ELEMENTARY FUNCTIONS, FNLIB, LOGARITHM -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C ALNREL(X) evaluates ln(1+X) accurately in the sense of relative -C error when X is very small. This routine must be used to -C maintain relative error accuracy whenever X is small and -C accurately known. -C -C Series for ALNR on the interval -3.75000D-01 to 3.75000D-01 -C with weighted error 1.93E-17 -C log weighted error 16.72 -C significant figures required 16.44 -C decimal places required 17.40 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE ALNREL - DIMENSION ALNRCS(23) - LOGICAL FIRST - SAVE ALNRCS, NLNREL, XMIN, FIRST - DATA ALNRCS( 1) / 1.0378693562 743770E0 / - DATA ALNRCS( 2) / -.1336430150 4908918E0 / - DATA ALNRCS( 3) / .0194082491 35520563E0 / - DATA ALNRCS( 4) / -.0030107551 12753577E0 / - DATA ALNRCS( 5) / .0004869461 47971548E0 / - DATA ALNRCS( 6) / -.0000810548 81893175E0 / - DATA ALNRCS( 7) / .0000137788 47799559E0 / - DATA ALNRCS( 8) / -.0000023802 21089435E0 / - DATA ALNRCS( 9) / .0000004164 04162138E0 / - DATA ALNRCS(10) / -.0000000735 95828378E0 / - DATA ALNRCS(11) / .0000000131 17611876E0 / - DATA ALNRCS(12) / -.0000000023 54670931E0 / - DATA ALNRCS(13) / .0000000004 25227732E0 / - DATA ALNRCS(14) / -.0000000000 77190894E0 / - DATA ALNRCS(15) / .0000000000 14075746E0 / - DATA ALNRCS(16) / -.0000000000 02576907E0 / - DATA ALNRCS(17) / .0000000000 00473424E0 / - DATA ALNRCS(18) / -.0000000000 00087249E0 / - DATA ALNRCS(19) / .0000000000 00016124E0 / - DATA ALNRCS(20) / -.0000000000 00002987E0 / - DATA ALNRCS(21) / .0000000000 00000554E0 / - DATA ALNRCS(22) / -.0000000000 00000103E0 / - DATA ALNRCS(23) / .0000000000 00000019E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT ALNREL - IF (FIRST) THEN - NLNREL = INITS (ALNRCS, 23, 0.1*R1MACH(3)) - XMIN = -1.0 + SQRT(R1MACH(4)) - ENDIF - FIRST = .FALSE. -C - IF (X .LE. (-1.0)) CALL XERMSG ('SLATEC', 'ALNREL', 'X IS LE -1', - + 2, 2) - IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'ALNREL', - + 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR -1', 1, 1) -C - IF (ABS(X).LE.0.375) ALNREL = X*(1. - - 1 X*CSEVL (X/.375, ALNRCS, NLNREL)) - IF (ABS(X).GT.0.375) ALNREL = LOG (1.0+X) -C - RETURN - END diff --git a/slatec/asinh.f b/slatec/asinh.f deleted file mode 100644 index 7a62d59..0000000 --- a/slatec/asinh.f +++ /dev/null @@ -1,74 +0,0 @@ -*DECK ASINH - FUNCTION ASINH (X) -C***BEGIN PROLOGUE ASINH -C***PURPOSE Compute the arc hyperbolic sine. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4C -C***TYPE SINGLE PRECISION (ASINH-S, DASINH-D, CASINH-C) -C***KEYWORDS ARC HYPERBOLIC SINE, ASINH, ELEMENTARY FUNCTIONS, FNLIB, -C INVERSE HYPERBOLIC SINE -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C ASINH(X) computes the arc hyperbolic sine of X. -C -C Series for ASNH on the interval 0. to 1.00000D+00 -C with weighted error 2.19E-17 -C log weighted error 16.66 -C significant figures required 15.60 -C decimal places required 17.31 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, INITS, R1MACH -C***REVISION HISTORY (YYMMDD) -C 770401 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***END PROLOGUE ASINH - DIMENSION ASNHCS(20) - LOGICAL FIRST - SAVE ALN2, ASNHCS, NTERMS, XMAX, SQEPS, FIRST - DATA ALN2 /0.6931471805 5994530942E0/ - DATA ASNHCS( 1) / -.1282003991 1738186E0 / - DATA ASNHCS( 2) / -.0588117611 89951768E0 / - DATA ASNHCS( 3) / .0047274654 32212481E0 / - DATA ASNHCS( 4) / -.0004938363 16265361E0 / - DATA ASNHCS( 5) / .0000585062 07058557E0 / - DATA ASNHCS( 6) / -.0000074669 98328931E0 / - DATA ASNHCS( 7) / .0000010011 69358355E0 / - DATA ASNHCS( 8) / -.0000001390 35438587E0 / - DATA ASNHCS( 9) / .0000000198 23169483E0 / - DATA ASNHCS(10) / -.0000000028 84746841E0 / - DATA ASNHCS(11) / .0000000004 26729654E0 / - DATA ASNHCS(12) / -.0000000000 63976084E0 / - DATA ASNHCS(13) / .0000000000 09699168E0 / - DATA ASNHCS(14) / -.0000000000 01484427E0 / - DATA ASNHCS(15) / .0000000000 00229037E0 / - DATA ASNHCS(16) / -.0000000000 00035588E0 / - DATA ASNHCS(17) / .0000000000 00005563E0 / - DATA ASNHCS(18) / -.0000000000 00000874E0 / - DATA ASNHCS(19) / .0000000000 00000138E0 / - DATA ASNHCS(20) / -.0000000000 00000021E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT ASINH - IF (FIRST) THEN - NTERMS = INITS (ASNHCS, 20, 0.1*R1MACH(3)) - SQEPS = SQRT (R1MACH(3)) - XMAX = 1.0/SQEPS - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.1.0) GO TO 20 -C - ASINH = X - IF (Y.GT.SQEPS) ASINH = X*(1.0 + CSEVL (2.*X*X-1., ASNHCS,NTERMS)) - RETURN -C - 20 IF (Y.LT.XMAX) ASINH = LOG (Y + SQRT(Y**2+1.)) - IF (Y.GE.XMAX) ASINH = ALN2 + LOG(Y) - ASINH = SIGN (ASINH, X) -C - RETURN - END diff --git a/slatec/asyik.f b/slatec/asyik.f deleted file mode 100644 index 911c8a7..0000000 --- a/slatec/asyik.f +++ /dev/null @@ -1,144 +0,0 @@ -*DECK ASYIK - SUBROUTINE ASYIK (X, FNU, KODE, FLGIK, RA, ARG, IN, Y) -C***BEGIN PROLOGUE ASYIK -C***SUBSIDIARY -C***PURPOSE Subsidiary to BESI and BESK -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (ASYIK-S, DASYIK-D) -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C ASYIK computes Bessel functions I and K -C for arguments X.GT.0.0 and orders FNU.GE.35 -C on FLGIK = 1 and FLGIK = -1 respectively. -C -C INPUT -C -C X - argument, X.GT.0.0E0 -C FNU - order of first Bessel function -C KODE - a parameter to indicate the scaling option -C KODE=1 returns Y(I)= I/SUB(FNU+I-1)/(X), I=1,IN -C or Y(I)= K/SUB(FNU+I-1)/(X), I=1,IN -C on FLGIK = 1.0E0 or FLGIK = -1.0E0 -C KODE=2 returns Y(I)=EXP(-X)*I/SUB(FNU+I-1)/(X), I=1,IN -C or Y(I)=EXP( X)*K/SUB(FNU+I-1)/(X), I=1,IN -C on FLGIK = 1.0E0 or FLGIK = -1.0E0 -C FLGIK - selection parameter for I or K function -C FLGIK = 1.0E0 gives the I function -C FLGIK = -1.0E0 gives the K function -C RA - SQRT(1.+Z*Z), Z=X/FNU -C ARG - argument of the leading exponential -C IN - number of functions desired, IN=1 or 2 -C -C OUTPUT -C -C Y - a vector whose first in components contain the sequence -C -C Abstract -C ASYIK implements the uniform asymptotic expansion of -C the I and K Bessel functions for FNU.GE.35 and real -C X.GT.0.0E0. The forms are identical except for a change -C in sign of some of the terms. This change in sign is -C accomplished by means of the flag FLGIK = 1 or -1. -C -C***SEE ALSO BESI, BESK -C***ROUTINES CALLED R1MACH -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910408 Updated the AUTHOR section. (WRB) -C***END PROLOGUE ASYIK -C - INTEGER IN, J, JN, K, KK, KODE, L - REAL AK,AP,ARG,C, COEF,CON,ETX,FLGIK,FN, FNU,GLN,RA,S1,S2, - 1 T, TOL, T2, X, Y, Z - REAL R1MACH - DIMENSION Y(*), C(65), CON(2) - SAVE CON, C - DATA CON(1), CON(2) / - 1 3.98942280401432678E-01, 1.25331413731550025E+00/ - DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), - 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), - 2 C(19), C(20), C(21), C(22), C(23), C(24)/ - 3 -2.08333333333333E-01, 1.25000000000000E-01, - 4 3.34201388888889E-01, -4.01041666666667E-01, - 5 7.03125000000000E-02, -1.02581259645062E+00, - 6 1.84646267361111E+00, -8.91210937500000E-01, - 7 7.32421875000000E-02, 4.66958442342625E+00, - 8 -1.12070026162230E+01, 8.78912353515625E+00, - 9 -2.36408691406250E+00, 1.12152099609375E-01, - 1 -2.82120725582002E+01, 8.46362176746007E+01, - 2 -9.18182415432400E+01, 4.25349987453885E+01, - 3 -7.36879435947963E+00, 2.27108001708984E-01, - 4 2.12570130039217E+02, -7.65252468141182E+02, - 5 1.05999045252800E+03, -6.99579627376133E+02/ - DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), - 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), - 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ - 3 2.18190511744212E+02, -2.64914304869516E+01, - 4 5.72501420974731E-01, -1.91945766231841E+03, - 5 8.06172218173731E+03, -1.35865500064341E+04, - 6 1.16553933368645E+04, -5.30564697861340E+03, - 7 1.20090291321635E+03, -1.08090919788395E+02, - 8 1.72772750258446E+00, 2.02042913309661E+04, - 9 -9.69805983886375E+04, 1.92547001232532E+05, - 1 -2.03400177280416E+05, 1.22200464983017E+05, - 2 -4.11926549688976E+04, 7.10951430248936E+03, - 3 -4.93915304773088E+02, 6.07404200127348E+00, - 4 -2.42919187900551E+05, 1.31176361466298E+06, - 5 -2.99801591853811E+06, 3.76327129765640E+06/ - DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), - 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), - 2 C(65)/ - 3 -2.81356322658653E+06, 1.26836527332162E+06, - 4 -3.31645172484564E+05, 4.52187689813627E+04, - 5 -2.49983048181121E+03, 2.43805296995561E+01, - 6 3.28446985307204E+06, -1.97068191184322E+07, - 7 5.09526024926646E+07, -7.41051482115327E+07, - 8 6.63445122747290E+07, -3.75671766607634E+07, - 9 1.32887671664218E+07, -2.78561812808645E+06, - 1 3.08186404612662E+05, -1.38860897537170E+04, - 2 1.10017140269247E+02/ -C***FIRST EXECUTABLE STATEMENT ASYIK - TOL = R1MACH(3) - TOL = MAX(TOL,1.0E-15) - FN = FNU - Z = (3.0E0-FLGIK)/2.0E0 - KK = INT(Z) - DO 50 JN=1,IN - IF (JN.EQ.1) GO TO 10 - FN = FN - FLGIK - Z = X/FN - RA = SQRT(1.0E0+Z*Z) - GLN = LOG((1.0E0+RA)/Z) - ETX = KODE - 1 - T = RA*(1.0E0-ETX) + ETX/(Z+RA) - ARG = FN*(T-GLN)*FLGIK - 10 COEF = EXP(ARG) - T = 1.0E0/RA - T2 = T*T - T = T/FN - T = SIGN(T,FLGIK) - S2 = 1.0E0 - AP = 1.0E0 - L = 0 - DO 30 K=2,11 - L = L + 1 - S1 = C(L) - DO 20 J=2,K - L = L + 1 - S1 = S1*T2 + C(L) - 20 CONTINUE - AP = AP*T - AK = AP*S1 - S2 = S2 + AK - IF (MAX(ABS(AK),ABS(AP)) .LT. TOL) GO TO 40 - 30 CONTINUE - 40 CONTINUE - T = ABS(T) - Y(JN) = S2*COEF*SQRT(T)*CON(KK) - 50 CONTINUE - RETURN - END diff --git a/slatec/asyjy.f b/slatec/asyjy.f deleted file mode 100644 index fa51a8b..0000000 --- a/slatec/asyjy.f +++ /dev/null @@ -1,491 +0,0 @@ -*DECK ASYJY - SUBROUTINE ASYJY (FUNJY, X, FNU, FLGJY, IN, Y, WK, IFLW) -C***BEGIN PROLOGUE ASYJY -C***SUBSIDIARY -C***PURPOSE Subsidiary to BESJ and BESY -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (ASYJY-S, DASYJY-D) -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C ASYJY computes Bessel functions J and Y -C for arguments X.GT.0.0 and orders FNU.GE.35.0 -C on FLGJY = 1 and FLGJY = -1 respectively -C -C INPUT -C -C FUNJY - external function JAIRY or YAIRY -C X - argument, X.GT.0.0E0 -C FNU - order of the first Bessel function -C FLGJY - selection flag -C FLGJY = 1.0E0 gives the J function -C FLGJY = -1.0E0 gives the Y function -C IN - number of functions desired, IN = 1 or 2 -C -C OUTPUT -C -C Y - a vector whose first in components contain the sequence -C IFLW - a flag indicating underflow or overflow -C return variables for BESJ only -C WK(1) = 1 - (X/FNU)**2 = W**2 -C WK(2) = SQRT(ABS(WK(1))) -C WK(3) = ABS(WK(2) - ATAN(WK(2))) or -C ABS(LN((1 + WK(2))/(X/FNU)) - WK(2)) -C = ABS((2/3)*ZETA**(3/2)) -C WK(4) = FNU*WK(3) -C WK(5) = (1.5*WK(3)*FNU)**(1/3) = SQRT(ZETA)*FNU**(1/3) -C WK(6) = SIGN(1.,W**2)*WK(5)**2 = SIGN(1.,W**2)*ZETA*FNU**(2/3) -C WK(7) = FNU**(1/3) -C -C Abstract -C ASYJY implements the uniform asymptotic expansion of -C the J and Y Bessel functions for FNU.GE.35 and real -C X.GT.0.0E0. The forms are identical except for a change -C in sign of some of the terms. This change in sign is -C accomplished by means of the flag FLGJY = 1 or -1. On -C FLGJY = 1 the AIRY functions AI(X) and DAI(X) are -C supplied by the external function JAIRY, and on -C FLGJY = -1 the AIRY functions BI(X) and DBI(X) are -C supplied by the external function YAIRY. -C -C***SEE ALSO BESJ, BESY -C***ROUTINES CALLED I1MACH, R1MACH -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891009 Removed unreferenced variable. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910408 Updated the AUTHOR section. (WRB) -C***END PROLOGUE ASYJY - INTEGER I, IFLW, IN, J, JN,JR,JU,K, KB,KLAST,KMAX,KP1, KS, KSP1, - * KSTEMP, L, LR, LRP1, ISETA, ISETB - INTEGER I1MACH - REAL ABW2, AKM, ALFA, ALFA1, ALFA2, AP, AR, ASUM, AZ, - * BETA, BETA1, BETA2, BETA3, BR, BSUM, C, CON1, CON2, - * CON548,CR,CRZ32, DFI,ELIM, DR,FI, FLGJY, FN, FNU, - * FN2, GAMA, PHI, RCZ, RDEN, RELB, RFN2, RTZ, RZDEN, - * SA, SB, SUMA, SUMB, S1, TA, TAU, TB, TFN, TOL, TOLS, T2, UPOL, - * WK, X, XX, Y, Z, Z32 - REAL R1MACH - DIMENSION Y(*), WK(*), C(65) - DIMENSION ALFA(26,4), BETA(26,5) - DIMENSION ALFA1(26,2), ALFA2(26,2) - DIMENSION BETA1(26,2), BETA2(26,2), BETA3(26,1) - DIMENSION GAMA(26), KMAX(5), AR(8), BR(10), UPOL(10) - DIMENSION CR(10), DR(10) - EQUIVALENCE (ALFA(1,1),ALFA1(1,1)) - EQUIVALENCE (ALFA(1,3),ALFA2(1,1)) - EQUIVALENCE (BETA(1,1),BETA1(1,1)) - EQUIVALENCE (BETA(1,3),BETA2(1,1)) - EQUIVALENCE (BETA(1,5),BETA3(1,1)) - SAVE TOLS, CON1, CON2, CON548, AR, BR, C, ALFA1, ALFA2, - 1 BETA1, BETA2, BETA3, GAMA - DATA TOLS /-6.90775527898214E+00/ - DATA CON1,CON2,CON548/ - 1 6.66666666666667E-01, 3.33333333333333E-01, 1.04166666666667E-01/ - DATA AR(1), AR(2), AR(3), AR(4), AR(5), AR(6), AR(7), - A AR(8) / 8.35503472222222E-02, 1.28226574556327E-01, - 1 2.91849026464140E-01, 8.81627267443758E-01, 3.32140828186277E+00, - 2 1.49957629868626E+01, 7.89230130115865E+01, 4.74451538868264E+02/ - DATA BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), BR(8), - A BR(9), BR(10) /-1.45833333333333E-01,-9.87413194444444E-02, - 1-1.43312053915895E-01,-3.17227202678414E-01,-9.42429147957120E-01, - 2-3.51120304082635E+00,-1.57272636203680E+01,-8.22814390971859E+01, - 3-4.92355370523671E+02,-3.31621856854797E+03/ - DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), - 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), - 2 C(19), C(20), C(21), C(22), C(23), C(24)/ - 3 -2.08333333333333E-01, 1.25000000000000E-01, - 4 3.34201388888889E-01, -4.01041666666667E-01, - 5 7.03125000000000E-02, -1.02581259645062E+00, - 6 1.84646267361111E+00, -8.91210937500000E-01, - 7 7.32421875000000E-02, 4.66958442342625E+00, - 8 -1.12070026162230E+01, 8.78912353515625E+00, - 9 -2.36408691406250E+00, 1.12152099609375E-01, - A -2.82120725582002E+01, 8.46362176746007E+01, - B -9.18182415432400E+01, 4.25349987453885E+01, - C -7.36879435947963E+00, 2.27108001708984E-01, - D 2.12570130039217E+02, -7.65252468141182E+02, - E 1.05999045252800E+03, -6.99579627376133E+02/ - DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), - 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), - 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ - 3 2.18190511744212E+02, -2.64914304869516E+01, - 4 5.72501420974731E-01, -1.91945766231841E+03, - 5 8.06172218173731E+03, -1.35865500064341E+04, - 6 1.16553933368645E+04, -5.30564697861340E+03, - 7 1.20090291321635E+03, -1.08090919788395E+02, - 8 1.72772750258446E+00, 2.02042913309661E+04, - 9 -9.69805983886375E+04, 1.92547001232532E+05, - A -2.03400177280416E+05, 1.22200464983017E+05, - B -4.11926549688976E+04, 7.10951430248936E+03, - C -4.93915304773088E+02, 6.07404200127348E+00, - D -2.42919187900551E+05, 1.31176361466298E+06, - E -2.99801591853811E+06, 3.76327129765640E+06/ - DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), - 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), - 2 C(65)/ - 3 -2.81356322658653E+06, 1.26836527332162E+06, - 4 -3.31645172484564E+05, 4.52187689813627E+04, - 5 -2.49983048181121E+03, 2.43805296995561E+01, - 6 3.28446985307204E+06, -1.97068191184322E+07, - 7 5.09526024926646E+07, -7.41051482115327E+07, - 8 6.63445122747290E+07, -3.75671766607634E+07, - 9 1.32887671664218E+07, -2.78561812808645E+06, - A 3.08186404612662E+05, -1.38860897537170E+04, - B 1.10017140269247E+02/ - DATA ALFA1(1,1), ALFA1(2,1), ALFA1(3,1), ALFA1(4,1), ALFA1(5,1), - 1 ALFA1(6,1), ALFA1(7,1), ALFA1(8,1), ALFA1(9,1), ALFA1(10,1), - 2 ALFA1(11,1),ALFA1(12,1),ALFA1(13,1),ALFA1(14,1),ALFA1(15,1), - 3 ALFA1(16,1),ALFA1(17,1),ALFA1(18,1),ALFA1(19,1),ALFA1(20,1), - 4 ALFA1(21,1),ALFA1(22,1),ALFA1(23,1),ALFA1(24,1),ALFA1(25,1), - 5 ALFA1(26,1) /-4.44444444444444E-03,-9.22077922077922E-04, - 6-8.84892884892885E-05, 1.65927687832450E-04, 2.46691372741793E-04, - 7 2.65995589346255E-04, 2.61824297061501E-04, 2.48730437344656E-04, - 8 2.32721040083232E-04, 2.16362485712365E-04, 2.00738858762752E-04, - 9 1.86267636637545E-04, 1.73060775917876E-04, 1.61091705929016E-04, - 1 1.50274774160908E-04, 1.40503497391270E-04, 1.31668816545923E-04, - 2 1.23667445598253E-04, 1.16405271474738E-04, 1.09798298372713E-04, - 3 1.03772410422993E-04, 9.82626078369363E-05, 9.32120517249503E-05, - 4 8.85710852478712E-05, 8.42963105715700E-05, 8.03497548407791E-05/ - DATA ALFA1(1,2), ALFA1(2,2), ALFA1(3,2), ALFA1(4,2), ALFA1(5,2), - 1 ALFA1(6,2), ALFA1(7,2), ALFA1(8,2), ALFA1(9,2), ALFA1(10,2), - 2 ALFA1(11,2),ALFA1(12,2),ALFA1(13,2),ALFA1(14,2),ALFA1(15,2), - 3 ALFA1(16,2),ALFA1(17,2),ALFA1(18,2),ALFA1(19,2),ALFA1(20,2), - 4 ALFA1(21,2),ALFA1(22,2),ALFA1(23,2),ALFA1(24,2),ALFA1(25,2), - 5 ALFA1(26,2) / 6.93735541354589E-04, 2.32241745182922E-04, - 6-1.41986273556691E-05,-1.16444931672049E-04,-1.50803558053049E-04, - 7-1.55121924918096E-04,-1.46809756646466E-04,-1.33815503867491E-04, - 8-1.19744975684254E-04,-1.06184319207974E-04,-9.37699549891194E-05, - 9-8.26923045588193E-05,-7.29374348155221E-05,-6.44042357721016E-05, - 1-5.69611566009369E-05,-5.04731044303562E-05,-4.48134868008883E-05, - 2-3.98688727717599E-05,-3.55400532972042E-05,-3.17414256609022E-05, - 3-2.83996793904175E-05,-2.54522720634871E-05,-2.28459297164725E-05, - 4-2.05352753106481E-05,-1.84816217627666E-05,-1.66519330021394E-05/ - DATA ALFA2(1,1), ALFA2(2,1), ALFA2(3,1), ALFA2(4,1), ALFA2(5,1), - 1 ALFA2(6,1), ALFA2(7,1), ALFA2(8,1), ALFA2(9,1), ALFA2(10,1), - 2 ALFA2(11,1),ALFA2(12,1),ALFA2(13,1),ALFA2(14,1),ALFA2(15,1), - 3 ALFA2(16,1),ALFA2(17,1),ALFA2(18,1),ALFA2(19,1),ALFA2(20,1), - 4 ALFA2(21,1),ALFA2(22,1),ALFA2(23,1),ALFA2(24,1),ALFA2(25,1), - 5 ALFA2(26,1) /-3.54211971457744E-04,-1.56161263945159E-04, - 6 3.04465503594936E-05, 1.30198655773243E-04, 1.67471106699712E-04, - 7 1.70222587683593E-04, 1.56501427608595E-04, 1.36339170977445E-04, - 8 1.14886692029825E-04, 9.45869093034688E-05, 7.64498419250898E-05, - 9 6.07570334965197E-05, 4.74394299290509E-05, 3.62757512005344E-05, - 1 2.69939714979225E-05, 1.93210938247939E-05, 1.30056674793963E-05, - 2 7.82620866744497E-06, 3.59257485819352E-06, 1.44040049814252E-07, - 3-2.65396769697939E-06,-4.91346867098486E-06,-6.72739296091248E-06, - 4-8.17269379678658E-06,-9.31304715093561E-06,-1.02011418798016E-05/ - DATA ALFA2(1,2), ALFA2(2,2), ALFA2(3,2), ALFA2(4,2), ALFA2(5,2), - 1 ALFA2(6,2), ALFA2(7,2), ALFA2(8,2), ALFA2(9,2), ALFA2(10,2), - 2 ALFA2(11,2),ALFA2(12,2),ALFA2(13,2),ALFA2(14,2),ALFA2(15,2), - 3 ALFA2(16,2),ALFA2(17,2),ALFA2(18,2),ALFA2(19,2),ALFA2(20,2), - 4 ALFA2(21,2),ALFA2(22,2),ALFA2(23,2),ALFA2(24,2),ALFA2(25,2), - 5 ALFA2(26,2) / 3.78194199201773E-04, 2.02471952761816E-04, - 6-6.37938506318862E-05,-2.38598230603006E-04,-3.10916256027362E-04, - 7-3.13680115247576E-04,-2.78950273791323E-04,-2.28564082619141E-04, - 8-1.75245280340847E-04,-1.25544063060690E-04,-8.22982872820208E-05, - 9-4.62860730588116E-05,-1.72334302366962E-05, 5.60690482304602E-06, - 1 2.31395443148287E-05, 3.62642745856794E-05, 4.58006124490189E-05, - 2 5.24595294959114E-05, 5.68396208545815E-05, 5.94349820393104E-05, - 3 6.06478527578422E-05, 6.08023907788436E-05, 6.01577894539460E-05, - 4 5.89199657344698E-05, 5.72515823777593E-05, 5.52804375585853E-05/ - DATA BETA1(1,1), BETA1(2,1), BETA1(3,1), BETA1(4,1), BETA1(5,1), - 1 BETA1(6,1), BETA1(7,1), BETA1(8,1), BETA1(9,1), BETA1(10,1), - 2 BETA1(11,1),BETA1(12,1),BETA1(13,1),BETA1(14,1),BETA1(15,1), - 3 BETA1(16,1),BETA1(17,1),BETA1(18,1),BETA1(19,1),BETA1(20,1), - 4 BETA1(21,1),BETA1(22,1),BETA1(23,1),BETA1(24,1),BETA1(25,1), - 5 BETA1(26,1) / 1.79988721413553E-02, 5.59964911064388E-03, - 6 2.88501402231133E-03, 1.80096606761054E-03, 1.24753110589199E-03, - 7 9.22878876572938E-04, 7.14430421727287E-04, 5.71787281789705E-04, - 8 4.69431007606482E-04, 3.93232835462917E-04, 3.34818889318298E-04, - 9 2.88952148495752E-04, 2.52211615549573E-04, 2.22280580798883E-04, - 1 1.97541838033063E-04, 1.76836855019718E-04, 1.59316899661821E-04, - 2 1.44347930197334E-04, 1.31448068119965E-04, 1.20245444949303E-04, - 3 1.10449144504599E-04, 1.01828770740567E-04, 9.41998224204238E-05, - 4 8.74130545753834E-05, 8.13466262162801E-05, 7.59002269646219E-05/ - DATA BETA1(1,2), BETA1(2,2), BETA1(3,2), BETA1(4,2), BETA1(5,2), - 1 BETA1(6,2), BETA1(7,2), BETA1(8,2), BETA1(9,2), BETA1(10,2), - 2 BETA1(11,2),BETA1(12,2),BETA1(13,2),BETA1(14,2),BETA1(15,2), - 3 BETA1(16,2),BETA1(17,2),BETA1(18,2),BETA1(19,2),BETA1(20,2), - 4 BETA1(21,2),BETA1(22,2),BETA1(23,2),BETA1(24,2),BETA1(25,2), - 5 BETA1(26,2) /-1.49282953213429E-03,-8.78204709546389E-04, - 6-5.02916549572035E-04,-2.94822138512746E-04,-1.75463996970783E-04, - 7-1.04008550460816E-04,-5.96141953046458E-05,-3.12038929076098E-05, - 8-1.26089735980230E-05,-2.42892608575730E-07, 8.05996165414274E-06, - 9 1.36507009262147E-05, 1.73964125472926E-05, 1.98672978842134E-05, - 1 2.14463263790823E-05, 2.23954659232457E-05, 2.28967783814713E-05, - 2 2.30785389811178E-05, 2.30321976080909E-05, 2.28236073720349E-05, - 3 2.25005881105292E-05, 2.20981015361991E-05, 2.16418427448104E-05, - 4 2.11507649256221E-05, 2.06388749782171E-05, 2.01165241997082E-05/ - DATA BETA2(1,1), BETA2(2,1), BETA2(3,1), BETA2(4,1), BETA2(5,1), - 1 BETA2(6,1), BETA2(7,1), BETA2(8,1), BETA2(9,1), BETA2(10,1), - 2 BETA2(11,1),BETA2(12,1),BETA2(13,1),BETA2(14,1),BETA2(15,1), - 3 BETA2(16,1),BETA2(17,1),BETA2(18,1),BETA2(19,1),BETA2(20,1), - 4 BETA2(21,1),BETA2(22,1),BETA2(23,1),BETA2(24,1),BETA2(25,1), - 5 BETA2(26,1) / 5.52213076721293E-04, 4.47932581552385E-04, - 6 2.79520653992021E-04, 1.52468156198447E-04, 6.93271105657044E-05, - 7 1.76258683069991E-05,-1.35744996343269E-05,-3.17972413350427E-05, - 8-4.18861861696693E-05,-4.69004889379141E-05,-4.87665447413787E-05, - 9-4.87010031186735E-05,-4.74755620890087E-05,-4.55813058138628E-05, - 1-4.33309644511266E-05,-4.09230193157750E-05,-3.84822638603221E-05, - 2-3.60857167535411E-05,-3.37793306123367E-05,-3.15888560772110E-05, - 3-2.95269561750807E-05,-2.75978914828336E-05,-2.58006174666884E-05, - 4-2.41308356761280E-05,-2.25823509518346E-05,-2.11479656768913E-05/ - DATA BETA2(1,2), BETA2(2,2), BETA2(3,2), BETA2(4,2), BETA2(5,2), - 1 BETA2(6,2), BETA2(7,2), BETA2(8,2), BETA2(9,2), BETA2(10,2), - 2 BETA2(11,2),BETA2(12,2),BETA2(13,2),BETA2(14,2),BETA2(15,2), - 3 BETA2(16,2),BETA2(17,2),BETA2(18,2),BETA2(19,2),BETA2(20,2), - 4 BETA2(21,2),BETA2(22,2),BETA2(23,2),BETA2(24,2),BETA2(25,2), - 5 BETA2(26,2) /-4.74617796559960E-04,-4.77864567147321E-04, - 6-3.20390228067038E-04,-1.61105016119962E-04,-4.25778101285435E-05, - 7 3.44571294294968E-05, 7.97092684075675E-05, 1.03138236708272E-04, - 8 1.12466775262204E-04, 1.13103642108481E-04, 1.08651634848774E-04, - 9 1.01437951597662E-04, 9.29298396593364E-05, 8.40293133016090E-05, - 1 7.52727991349134E-05, 6.69632521975731E-05, 5.92564547323195E-05, - 2 5.22169308826976E-05, 4.58539485165361E-05, 4.01445513891487E-05, - 3 3.50481730031328E-05, 3.05157995034347E-05, 2.64956119950516E-05, - 4 2.29363633690998E-05, 1.97893056664022E-05, 1.70091984636413E-05/ - DATA BETA3(1,1), BETA3(2,1), BETA3(3,1), BETA3(4,1), BETA3(5,1), - 1 BETA3(6,1), BETA3(7,1), BETA3(8,1), BETA3(9,1), BETA3(10,1), - 2 BETA3(11,1),BETA3(12,1),BETA3(13,1),BETA3(14,1),BETA3(15,1), - 3 BETA3(16,1),BETA3(17,1),BETA3(18,1),BETA3(19,1),BETA3(20,1), - 4 BETA3(21,1),BETA3(22,1),BETA3(23,1),BETA3(24,1),BETA3(25,1), - 5 BETA3(26,1) / 7.36465810572578E-04, 8.72790805146194E-04, - 6 6.22614862573135E-04, 2.85998154194304E-04, 3.84737672879366E-06, - 7-1.87906003636972E-04,-2.97603646594555E-04,-3.45998126832656E-04, - 8-3.53382470916038E-04,-3.35715635775049E-04,-3.04321124789040E-04, - 9-2.66722723047613E-04,-2.27654214122820E-04,-1.89922611854562E-04, - 1-1.55058918599094E-04,-1.23778240761874E-04,-9.62926147717644E-05, - 2-7.25178327714425E-05,-5.22070028895634E-05,-3.50347750511901E-05, - 3-2.06489761035552E-05,-8.70106096849767E-06, 1.13698686675100E-06, - 4 9.16426474122779E-06, 1.56477785428873E-05, 2.08223629482467E-05/ - DATA GAMA(1), GAMA(2), GAMA(3), GAMA(4), GAMA(5), - 1 GAMA(6), GAMA(7), GAMA(8), GAMA(9), GAMA(10), - 2 GAMA(11), GAMA(12), GAMA(13), GAMA(14), GAMA(15), - 3 GAMA(16), GAMA(17), GAMA(18), GAMA(19), GAMA(20), - 4 GAMA(21), GAMA(22), GAMA(23), GAMA(24), GAMA(25), - 5 GAMA(26) / 6.29960524947437E-01, 2.51984209978975E-01, - 6 1.54790300415656E-01, 1.10713062416159E-01, 8.57309395527395E-02, - 7 6.97161316958684E-02, 5.86085671893714E-02, 5.04698873536311E-02, - 8 4.42600580689155E-02, 3.93720661543510E-02, 3.54283195924455E-02, - 9 3.21818857502098E-02, 2.94646240791158E-02, 2.71581677112934E-02, - 1 2.51768272973862E-02, 2.34570755306079E-02, 2.19508390134907E-02, - 2 2.06210828235646E-02, 1.94388240897881E-02, 1.83810633800683E-02, - 3 1.74293213231963E-02, 1.65685837786612E-02, 1.57865285987918E-02, - 4 1.50729501494096E-02, 1.44193250839955E-02, 1.38184805735342E-02/ -C***FIRST EXECUTABLE STATEMENT ASYJY - TA = R1MACH(3) - TOL = MAX(TA,1.0E-15) - TB = R1MACH(5) - JU = I1MACH(12) - IF(FLGJY.EQ.1.0E0) GO TO 6 - JR = I1MACH(11) - ELIM = -2.303E0*TB*(JU+JR) - GO TO 7 - 6 CONTINUE - ELIM = -2.303E0*(TB*JU+3.0E0) - 7 CONTINUE - FN = FNU - IFLW = 0 - DO 170 JN=1,IN - XX = X/FN - WK(1) = 1.0E0 - XX*XX - ABW2 = ABS(WK(1)) - WK(2) = SQRT(ABW2) - WK(7) = FN**CON2 - IF (ABW2.GT.0.27750E0) GO TO 80 -C -C ASYMPTOTIC EXPANSION -C CASES NEAR X=FN, ABS(1.-(X/FN)**2).LE.0.2775 -C COEFFICIENTS OF ASYMPTOTIC EXPANSION BY SERIES -C -C ZETA AND TRUNCATION FOR A(ZETA) AND B(ZETA) SERIES -C -C KMAX IS TRUNCATION INDEX FOR A(ZETA) AND B(ZETA) SERIES=MAX(2,SA) -C - SA = 0.0E0 - IF (ABW2.EQ.0.0E0) GO TO 10 - SA = TOLS/LOG(ABW2) - 10 SB = SA - DO 20 I=1,5 - AKM = MAX(SA,2.0E0) - KMAX(I) = INT(AKM) - SA = SA + SB - 20 CONTINUE - KB = KMAX(5) - KLAST = KB - 1 - SA = GAMA(KB) - DO 30 K=1,KLAST - KB = KB - 1 - SA = SA*WK(1) + GAMA(KB) - 30 CONTINUE - Z = WK(1)*SA - AZ = ABS(Z) - RTZ = SQRT(AZ) - WK(3) = CON1*AZ*RTZ - WK(4) = WK(3)*FN - WK(5) = RTZ*WK(7) - WK(6) = -WK(5)*WK(5) - IF(Z.LE.0.0E0) GO TO 35 - IF(WK(4).GT.ELIM) GO TO 75 - WK(6) = -WK(6) - 35 CONTINUE - PHI = SQRT(SQRT(SA+SA+SA+SA)) -C -C B(ZETA) FOR S=0 -C - KB = KMAX(5) - KLAST = KB - 1 - SB = BETA(KB,1) - DO 40 K=1,KLAST - KB = KB - 1 - SB = SB*WK(1) + BETA(KB,1) - 40 CONTINUE - KSP1 = 1 - FN2 = FN*FN - RFN2 = 1.0E0/FN2 - RDEN = 1.0E0 - ASUM = 1.0E0 - RELB = TOL*ABS(SB) - BSUM = SB - DO 60 KS=1,4 - KSP1 = KSP1 + 1 - RDEN = RDEN*RFN2 -C -C A(ZETA) AND B(ZETA) FOR S=1,2,3,4 -C - KSTEMP = 5 - KS - KB = KMAX(KSTEMP) - KLAST = KB - 1 - SA = ALFA(KB,KS) - SB = BETA(KB,KSP1) - DO 50 K=1,KLAST - KB = KB - 1 - SA = SA*WK(1) + ALFA(KB,KS) - SB = SB*WK(1) + BETA(KB,KSP1) - 50 CONTINUE - TA = SA*RDEN - TB = SB*RDEN - ASUM = ASUM + TA - BSUM = BSUM + TB - IF (ABS(TA).LE.TOL .AND. ABS(TB).LE.RELB) GO TO 70 - 60 CONTINUE - 70 CONTINUE - BSUM = BSUM/(FN*WK(7)) - GO TO 160 -C - 75 CONTINUE - IFLW = 1 - RETURN -C - 80 CONTINUE - UPOL(1) = 1.0E0 - TAU = 1.0E0/WK(2) - T2 = 1.0E0/WK(1) - IF (WK(1).GE.0.0E0) GO TO 90 -C -C CASES FOR (X/FN).GT.SQRT(1.2775) -C - WK(3) = ABS(WK(2)-ATAN(WK(2))) - WK(4) = WK(3)*FN - RCZ = -CON1/WK(4) - Z32 = 1.5E0*WK(3) - RTZ = Z32**CON2 - WK(5) = RTZ*WK(7) - WK(6) = -WK(5)*WK(5) - GO TO 100 - 90 CONTINUE -C -C CASES FOR (X/FN).LT.SQRT(0.7225) -C - WK(3) = ABS(LOG((1.0E0+WK(2))/XX)-WK(2)) - WK(4) = WK(3)*FN - RCZ = CON1/WK(4) - IF(WK(4).GT.ELIM) GO TO 75 - Z32 = 1.5E0*WK(3) - RTZ = Z32**CON2 - WK(7) = FN**CON2 - WK(5) = RTZ*WK(7) - WK(6) = WK(5)*WK(5) - 100 CONTINUE - PHI = SQRT((RTZ+RTZ)*TAU) - TB = 1.0E0 - ASUM = 1.0E0 - TFN = TAU/FN - RDEN=1.0E0/FN - RFN2=RDEN*RDEN - RDEN=1.0E0 - UPOL(2) = (C(1)*T2+C(2))*TFN - CRZ32 = CON548*RCZ - BSUM = UPOL(2) + CRZ32 - RELB = TOL*ABS(BSUM) - AP = TFN - KS = 0 - KP1 = 2 - RZDEN = RCZ - L = 2 - ISETA=0 - ISETB=0 - DO 140 LR=2,8,2 -C -C COMPUTE TWO U POLYNOMIALS FOR NEXT A(ZETA) AND B(ZETA) -C - LRP1 = LR + 1 - DO 120 K=LR,LRP1 - KS = KS + 1 - KP1 = KP1 + 1 - L = L + 1 - S1 = C(L) - DO 110 J=2,KP1 - L = L + 1 - S1 = S1*T2 + C(L) - 110 CONTINUE - AP = AP*TFN - UPOL(KP1) = AP*S1 - CR(KS) = BR(KS)*RZDEN - RZDEN = RZDEN*RCZ - DR(KS) = AR(KS)*RZDEN - 120 CONTINUE - SUMA = UPOL(LRP1) - SUMB = UPOL(LR+2) + UPOL(LRP1)*CRZ32 - JU = LRP1 - DO 130 JR=1,LR - JU = JU - 1 - SUMA = SUMA + CR(JR)*UPOL(JU) - SUMB = SUMB + DR(JR)*UPOL(JU) - 130 CONTINUE - RDEN=RDEN*RFN2 - TB = -TB - IF (WK(1).GT.0.0E0) TB = ABS(TB) - IF (RDEN.LT.TOL) GO TO 131 - ASUM = ASUM + SUMA*TB - BSUM = BSUM + SUMB*TB - GO TO 140 - 131 IF(ISETA.EQ.1) GO TO 132 - IF(ABS(SUMA).LT.TOL) ISETA=1 - ASUM=ASUM+SUMA*TB - 132 IF(ISETB.EQ.1) GO TO 133 - IF(ABS(SUMB).LT.RELB) ISETB=1 - BSUM=BSUM+SUMB*TB - 133 IF(ISETA.EQ.1 .AND. ISETB.EQ.1) GO TO 150 - 140 CONTINUE - 150 TB = WK(5) - IF (WK(1).GT.0.0E0) TB = -TB - BSUM = BSUM/TB -C - 160 CONTINUE - CALL FUNJY(WK(6), WK(5), WK(4), FI, DFI) - TA=1.0E0/TOL - TB=R1MACH(1)*TA*1.0E+3 - IF(ABS(FI).GT.TB) GO TO 165 - FI=FI*TA - DFI=DFI*TA - PHI=PHI*TOL - 165 CONTINUE - Y(JN) = FLGJY*PHI*(FI*ASUM+DFI*BSUM)/WK(7) - FN = FN - FLGJY - 170 CONTINUE - RETURN - END diff --git a/slatec/atanh.f b/slatec/atanh.f deleted file mode 100644 index 083d6c1..0000000 --- a/slatec/atanh.f +++ /dev/null @@ -1,72 +0,0 @@ -*DECK ATANH - FUNCTION ATANH (X) -C***BEGIN PROLOGUE ATANH -C***PURPOSE Compute the arc hyperbolic tangent. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4C -C***TYPE SINGLE PRECISION (ATANH-S, DATANH-D, CATANH-C) -C***KEYWORDS ARC HYPERBOLIC TANGENT, ATANH, ELEMENTARY FUNCTIONS, -C FNLIB, INVERSE HYPERBOLIC TANGENT -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C ATANH(X) computes the arc hyperbolic tangent of X. -C -C Series for ATNH on the interval 0. to 2.50000D-01 -C with weighted error 6.70E-18 -C log weighted error 17.17 -C significant figures required 16.01 -C decimal places required 17.76 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE ATANH - DIMENSION ATNHCS(15) - LOGICAL FIRST - SAVE ATNHCS, NTERMS, DXREL, SQEPS, FIRST - DATA ATNHCS( 1) / .0943951023 93195492E0 / - DATA ATNHCS( 2) / .0491984370 55786159E0 / - DATA ATNHCS( 3) / .0021025935 22455432E0 / - DATA ATNHCS( 4) / .0001073554 44977611E0 / - DATA ATNHCS( 5) / .0000059782 67249293E0 / - DATA ATNHCS( 6) / .0000003505 06203088E0 / - DATA ATNHCS( 7) / .0000000212 63743437E0 / - DATA ATNHCS( 8) / .0000000013 21694535E0 / - DATA ATNHCS( 9) / .0000000000 83658755E0 / - DATA ATNHCS(10) / .0000000000 05370503E0 / - DATA ATNHCS(11) / .0000000000 00348665E0 / - DATA ATNHCS(12) / .0000000000 00022845E0 / - DATA ATNHCS(13) / .0000000000 00001508E0 / - DATA ATNHCS(14) / .0000000000 00000100E0 / - DATA ATNHCS(15) / .0000000000 00000006E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT ATANH - IF (FIRST) THEN - NTERMS = INITS (ATNHCS, 15, 0.1*R1MACH(3)) - DXREL = SQRT (R1MACH(4)) - SQEPS = SQRT (3.0*R1MACH(3)) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y .GE. 1.0) CALL XERMSG ('SLATEC', 'ATANH', 'ABS(X) GE 1', 2, - + 2) -C - IF (1.0-Y .LT. DXREL) CALL XERMSG ('SLATEC', 'ATANH', - + 'ANSWER LT HALF PRECISION BECAUSE ABS(X) TOO NEAR 1', 1, 1) -C - ATANH = X - IF (Y.GT.SQEPS .AND. Y.LE.0.5) ATANH = X*(1.0 + CSEVL (8.*X*X-1., - 1 ATNHCS, NTERMS)) - IF (Y.GT.0.5) ATANH = 0.5*LOG((1.0+X)/(1.0-X)) -C - RETURN - END diff --git a/slatec/avint.f b/slatec/avint.f deleted file mode 100644 index 78b5e76..0000000 --- a/slatec/avint.f +++ /dev/null @@ -1,178 +0,0 @@ -*DECK AVINT - SUBROUTINE AVINT (X, Y, N, XLO, XUP, ANS, IERR) -C***BEGIN PROLOGUE AVINT -C***PURPOSE Integrate a function tabulated at arbitrarily spaced -C abscissas using overlapping parabolas. -C***LIBRARY SLATEC -C***CATEGORY H2A1B2 -C***TYPE SINGLE PRECISION (AVINT-S, DAVINT-D) -C***KEYWORDS INTEGRATION, QUADRATURE, TABULATED DATA -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C AVINT integrates a function tabulated at arbitrarily spaced -C abscissas. The limits of integration need not coincide -C with the tabulated abscissas. -C -C A method of overlapping parabolas fitted to the data is used -C provided that there are at least 3 abscissas between the -C limits of integration. AVINT also handles two special cases. -C If the limits of integration are equal, AVINT returns a result -C of zero regardless of the number of tabulated values. -C If there are only two function values, AVINT uses the -C trapezoid rule. -C -C Description of Parameters -C The user must dimension all arrays appearing in the call list -C X(N), Y(N). -C -C Input-- -C X - real array of abscissas, which must be in increasing -C order. -C Y - real array of functional values. i.e., Y(I)=FUNC(X(I)). -C N - the integer number of function values supplied. -C N .GE. 2 unless XLO = XUP. -C XLO - real lower limit of integration. -C XUP - real upper limit of integration. -C Must have XLO .LE. XUP. -C -C Output-- -C ANS - computed approximate value of integral -C IERR - a status code -C --normal code -C =1 means the requested integration was performed. -C --abnormal codes -C =2 means XUP was less than XLO. -C =3 means the number of X(I) between XLO and XUP -C (inclusive) was less than 3 and neither of the two -C special cases described in the Abstract occurred. -C No integration was performed. -C =4 means the restriction X(I+1) .GT. X(I) was violated. -C =5 means the number N of function values was .LT. 2. -C ANS is set to zero if IERR=2,3,4,or 5. -C -C AVINT is documented completely in SC-M-69-335 -C Original program from "Numerical Integration" by Davis & -C Rabinowitz. -C Adaptation and modifications for Sandia Mathematical Program -C Library by Rondall E. Jones. -C -C***REFERENCES R. E. Jones, Approximate integrator of functions -C tabulated at arbitrarily spaced abscissas, -C Report SC-M-69-335, Sandia Laboratories, 1969. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 690901 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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE AVINT -C - DOUBLE PRECISION R3,RP5,SUM,SYL,SYL2,SYL3,SYU,SYU2,SYU3,X1,X2,X3 - 1,X12,X13,X23,TERM1,TERM2,TERM3,A,B,C,CA,CB,CC - DIMENSION X(*),Y(*) -C***FIRST EXECUTABLE STATEMENT AVINT - IERR=1 - ANS =0.0 - IF (XLO-XUP) 3,100,200 - 3 IF (N.LT.2) GO TO 215 - DO 5 I=2,N - IF (X(I).LE.X(I-1)) GO TO 210 - IF (X(I).GT.XUP) GO TO 6 - 5 CONTINUE - 6 CONTINUE - IF (N.GE.3) GO TO 9 -C -C SPECIAL N=2 CASE - SLOPE = (Y(2)-Y(1))/(X(2)-X(1)) - FL = Y(1) + SLOPE*(XLO-X(1)) - FR = Y(2) + SLOPE*(XUP-X(2)) - ANS = 0.5*(FL+FR)*(XUP-XLO) - RETURN - 9 CONTINUE - IF (X(N-2).LT.XLO) GO TO 205 - IF (X(3).GT.XUP) GO TO 205 - I = 1 - 10 IF (X(I).GE.XLO) GO TO 15 - I = I+1 - GO TO 10 - 15 INLFT = I - I = N - 20 IF (X(I).LE.XUP) GO TO 25 - I = I-1 - GO TO 20 - 25 INRT = I - IF ((INRT-INLFT).LT.2) GO TO 205 - ISTART = INLFT - IF (INLFT.EQ.1) ISTART = 2 - ISTOP = INRT - IF (INRT.EQ.N) ISTOP = N-1 -C - R3 = 3.0D0 - RP5= 0.5D0 - SUM = 0.0 - SYL = XLO - SYL2= SYL*SYL - SYL3= SYL2*SYL -C - DO 50 I=ISTART,ISTOP - X1 = X(I-1) - X2 = X(I) - X3 = X(I+1) - X12 = X1-X2 - X13 = X1-X3 - X23 = X2-X3 - TERM1 = DBLE(Y(I-1))/(X12*X13) - TERM2 =-DBLE(Y(I)) /(X12*X23) - TERM3 = DBLE(Y(I+1))/(X13*X23) - A = TERM1+TERM2+TERM3 - B = -(X2+X3)*TERM1 - (X1+X3)*TERM2 - (X1+X2)*TERM3 - C = X2*X3*TERM1 + X1*X3*TERM2 + X1*X2*TERM3 - IF (I-ISTART) 30,30,35 - 30 CA = A - CB = B - CC = C - GO TO 40 - 35 CA = 0.5*(A+CA) - CB = 0.5*(B+CB) - CC = 0.5*(C+CC) - 40 SYU = X2 - SYU2= SYU*SYU - SYU3= SYU2*SYU - SUM = SUM + CA*(SYU3-SYL3)/R3 + CB*RP5*(SYU2-SYL2) + CC*(SYU-SYL) - CA = A - CB = B - CC = C - SYL = SYU - SYL2= SYU2 - SYL3= SYU3 - 50 CONTINUE - SYU = XUP - ANS = SUM + CA*(SYU**3-SYL3)/R3 + CB*RP5*(SYU**2-SYL2) - 1 + CC*(SYU-SYL) - 100 RETURN - 200 IERR=2 - CALL XERMSG ('SLATEC', 'AVINT', - + 'THE UPPER LIMIT OF INTEGRATION WAS NOT GREATER THAN THE ' // - + 'LOWER LIMIT.', 4, 1) - RETURN - 205 IERR=3 - CALL XERMSG ('SLATEC', 'AVINT', - + 'THERE WERE LESS THAN THREE FUNCTION VALUES BETWEEN THE ' // - + 'LIMITS OF INTEGRATION.', 4, 1) - RETURN - 210 IERR=4 - CALL XERMSG ('SLATEC', 'AVINT', - + 'THE ABSCISSAS WERE NOT STRICTLY INCREASING. MUST HAVE ' // - + 'X(I-1) .LT. X(I) FOR ALL I.', 4, 1) - RETURN - 215 IERR=5 - CALL XERMSG ('SLATEC', 'AVINT', - + 'LESS THAN TWO FUNCTION VALUES WERE SUPPLIED.', 4, 1) - RETURN - END diff --git a/slatec/bakvec.f b/slatec/bakvec.f deleted file mode 100644 index fb08297..0000000 --- a/slatec/bakvec.f +++ /dev/null @@ -1,105 +0,0 @@ -*DECK BAKVEC - SUBROUTINE BAKVEC (NM, N, T, E, M, Z, IERR) -C***BEGIN PROLOGUE BAKVEC -C***PURPOSE Form the eigenvectors of a certain real non-symmetric -C tridiagonal matrix from a symmetric tridiagonal matrix -C output from FIGI. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C4 -C***TYPE SINGLE PRECISION (BAKVEC-S) -C***KEYWORDS EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine forms the eigenvectors of a NONSYMMETRIC -C TRIDIAGONAL matrix by back transforming those of the -C corresponding symmetric matrix determined by FIGI. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, T and Z, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix T. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C T contains the nonsymmetric matrix. Its subdiagonal is -C stored in the last N-1 positions of the first column, -C its diagonal in the N positions of the second column, -C and its superdiagonal in the first N-1 positions of -C the third column. T(1,1) and T(N,3) are arbitrary. -C T is a two-dimensional REAL array, dimensioned T(NM,3). -C -C E contains the subdiagonal elements of the symmetric -C matrix in its last N-1 positions. E(1) is arbitrary. -C E is a one-dimensional REAL array, dimensioned E(N). -C -C M is the number of eigenvectors to be back transformed. -C M is an INTEGER variable. -C -C Z contains the eigenvectors to be back transformed -C in its first M columns. Z is a two-dimensional REAL -C array, dimensioned Z(NM,M). -C -C On OUTPUT -C -C T is unaltered. -C -C E is destroyed. -C -C Z contains the transformed eigenvectors in its first M columns. -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C 2*N+I if E(I) is zero with T(I,1) or T(I-1,3) non-zero. -C In this case, the symmetric matrix is not similar -C to the original matrix, and the eigenvectors -C cannot be found by this program. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE BAKVEC -C - INTEGER I,J,M,N,NM,IERR - REAL T(NM,3),E(*),Z(NM,*) -C -C***FIRST EXECUTABLE STATEMENT BAKVEC - IERR = 0 - IF (M .EQ. 0) GO TO 1001 - E(1) = 1.0E0 - IF (N .EQ. 1) GO TO 1001 -C - DO 100 I = 2, N - IF (E(I) .NE. 0.0E0) GO TO 80 - IF (T(I,1) .NE. 0.0E0 .OR. T(I-1,3) .NE. 0.0E0) GO TO 1000 - E(I) = 1.0E0 - GO TO 100 - 80 E(I) = E(I-1) * E(I) / T(I-1,3) - 100 CONTINUE -C - DO 120 J = 1, M -C - DO 120 I = 2, N - Z(I,J) = Z(I,J) * E(I) - 120 CONTINUE -C - GO TO 1001 -C .......... SET ERROR -- EIGENVECTORS CANNOT BE -C FOUND BY THIS PROGRAM .......... - 1000 IERR = 2 * N + I - 1001 RETURN - END diff --git a/slatec/balanc.f b/slatec/balanc.f deleted file mode 100644 index 9d254a5..0000000 --- a/slatec/balanc.f +++ /dev/null @@ -1,190 +0,0 @@ -*DECK BALANC - SUBROUTINE BALANC (NM, N, A, LOW, IGH, SCALE) -C***BEGIN PROLOGUE BALANC -C***PURPOSE Balance a real general matrix and isolate eigenvalues -C whenever possible. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C1A -C***TYPE SINGLE PRECISION (BALANC-S, CBAL-C) -C***KEYWORDS EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure BALANCE, -C NUM. MATH. 13, 293-304(1969) by Parlett and Reinsch. -C HANDBOOK FOR AUTO. COMP., Vol.II-LINEAR ALGEBRA, 315-326(1971). -C -C This subroutine balances a REAL matrix and isolates -C eigenvalues whenever possible. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameter, A, as declared in the calling program -C dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix A. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C A contains the input matrix to be balanced. A is a -C two-dimensional REAL array, dimensioned A(NM,N). -C -C On OUTPUT -C -C A contains the balanced matrix. -C -C LOW and IGH are two INTEGER variables such that A(I,J) -C is equal to zero if -C (1) I is greater than J and -C (2) J=1,...,LOW-1 or I=IGH+1,...,N. -C -C SCALE contains information determining the permutations and -C scaling factors used. SCALE is a one-dimensional REAL array, -C dimensioned SCALE(N). -C -C Suppose that the principal submatrix in rows LOW through IGH -C has been balanced, that P(J) denotes the index interchanged -C with J during the permutation step, and that the elements -C of the diagonal matrix used are denoted by D(I,J). Then -C SCALE(J) = P(J), for J = 1,...,LOW-1 -C = D(J,J), J = LOW,...,IGH -C = P(J) J = IGH+1,...,N. -C The order in which the interchanges are made is N to IGH+1, -C then 1 TO LOW-1. -C -C Note that 1 is returned for IGH if IGH is zero formally. -C -C The ALGOL procedure EXC contained in BALANCE appears in -C BALANC in line. (Note that the ALGOL roles of identifiers -C K,L have been reversed.) -C -C Questions and comments should be directed to B. S. Garbow, -C Applied Mathematics Division, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE BALANC -C - INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC - REAL A(NM,*),SCALE(*) - REAL C,F,G,R,S,B2,RADIX - LOGICAL NOCONV -C -C***FIRST EXECUTABLE STATEMENT BALANC - RADIX = 16 -C - B2 = RADIX * RADIX - K = 1 - L = N - GO TO 100 -C .......... IN-LINE PROCEDURE FOR ROW AND -C COLUMN EXCHANGE .......... - 20 SCALE(M) = J - IF (J .EQ. M) GO TO 50 -C - DO 30 I = 1, L - F = A(I,J) - A(I,J) = A(I,M) - A(I,M) = F - 30 CONTINUE -C - DO 40 I = K, N - F = A(J,I) - A(J,I) = A(M,I) - A(M,I) = F - 40 CONTINUE -C - 50 GO TO (80,130), IEXC -C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE -C AND PUSH THEM DOWN .......... - 80 IF (L .EQ. 1) GO TO 280 - L = L - 1 -C .......... FOR J=L STEP -1 UNTIL 1 DO -- .......... - 100 DO 120 JJ = 1, L - J = L + 1 - JJ -C - DO 110 I = 1, L - IF (I .EQ. J) GO TO 110 - IF (A(J,I) .NE. 0.0E0) GO TO 120 - 110 CONTINUE -C - M = L - IEXC = 1 - GO TO 20 - 120 CONTINUE -C - GO TO 140 -C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE -C AND PUSH THEM LEFT .......... - 130 K = K + 1 -C - 140 DO 170 J = K, L -C - DO 150 I = K, L - IF (I .EQ. J) GO TO 150 - IF (A(I,J) .NE. 0.0E0) GO TO 170 - 150 CONTINUE -C - M = K - IEXC = 2 - GO TO 20 - 170 CONTINUE -C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L .......... - DO 180 I = K, L - 180 SCALE(I) = 1.0E0 -C .......... ITERATIVE LOOP FOR NORM REDUCTION .......... - 190 NOCONV = .FALSE. -C - DO 270 I = K, L - C = 0.0E0 - R = 0.0E0 -C - DO 200 J = K, L - IF (J .EQ. I) GO TO 200 - C = C + ABS(A(J,I)) - R = R + ABS(A(I,J)) - 200 CONTINUE -C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW .......... - IF (C .EQ. 0.0E0 .OR. R .EQ. 0.0E0) GO TO 270 - G = R / RADIX - F = 1.0E0 - S = C + R - 210 IF (C .GE. G) GO TO 220 - F = F * RADIX - C = C * B2 - GO TO 210 - 220 G = R * RADIX - 230 IF (C .LT. G) GO TO 240 - F = F / RADIX - C = C / B2 - GO TO 230 -C .......... NOW BALANCE .......... - 240 IF ((C + R) / F .GE. 0.95E0 * S) GO TO 270 - G = 1.0E0 / F - SCALE(I) = SCALE(I) * F - NOCONV = .TRUE. -C - DO 250 J = K, N - 250 A(I,J) = A(I,J) * G -C - DO 260 J = 1, L - 260 A(J,I) = A(J,I) * F -C - 270 CONTINUE -C - IF (NOCONV) GO TO 190 -C - 280 LOW = K - IGH = L - RETURN - END diff --git a/slatec/balbak.f b/slatec/balbak.f deleted file mode 100644 index 3e3c8a6..0000000 --- a/slatec/balbak.f +++ /dev/null @@ -1,101 +0,0 @@ -*DECK BALBAK - SUBROUTINE BALBAK (NM, N, LOW, IGH, SCALE, M, Z) -C***BEGIN PROLOGUE BALBAK -C***PURPOSE Form the eigenvectors of a real general matrix from the -C eigenvectors of matrix output from BALANC. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C4 -C***TYPE SINGLE PRECISION (BALBAK-S, CBABK2-C) -C***KEYWORDS EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure BALBAK, -C NUM. MATH. 13, 293-304(1969) by Parlett and Reinsch. -C HANDBOOK FOR AUTO. COMP., Vol.II-LINEAR ALGEBRA, 315-326(1971). -C -C This subroutine forms the eigenvectors of a REAL GENERAL -C matrix by back transforming those of the corresponding -C balanced matrix determined by BALANC. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameter, Z, as declared in the calling program -C dimension statement. NM is an INTEGER variable. -C -C N is the number of components of the vectors in matrix Z. -C N is an INTEGER variable. N must be less than or equal -C to NM. -C -C LOW and IGH are INTEGER variables determined by BALANC. -C -C SCALE contains information determining the permutations and -C scaling factors used by BALANC. SCALE is a one-dimensional -C REAL array, dimensioned SCALE(N). -C -C M is the number of columns of Z to be back transformed. -C M is an INTEGER variable. -C -C Z contains the real and imaginary parts of the eigen- -C vectors to be back transformed in its first M columns. -C Z is a two-dimensional REAL array, dimensioned Z(NM,M). -C -C On OUTPUT -C -C Z contains the real and imaginary parts of the -C transformed eigenvectors in its first M columns. -C -C Questions and comments should be directed to B. S. Garbow, -C Applied Mathematics Division, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE BALBAK -C - INTEGER I,J,K,M,N,II,NM,IGH,LOW - REAL SCALE(*),Z(NM,*) - REAL S -C -C***FIRST EXECUTABLE STATEMENT BALBAK - IF (M .EQ. 0) GO TO 200 - IF (IGH .EQ. LOW) GO TO 120 -C - DO 110 I = LOW, IGH - S = SCALE(I) -C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED -C IF THE FOREGOING STATEMENT IS REPLACED BY -C S=1.0E0/SCALE(I). .......... - DO 100 J = 1, M - 100 Z(I,J) = Z(I,J) * S -C - 110 CONTINUE -C ......... FOR I=LOW-1 STEP -1 UNTIL 1, -C IGH+1 STEP 1 UNTIL N DO -- .......... - 120 DO 140 II = 1, N - I = II - IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140 - IF (I .LT. LOW) I = LOW - II - K = SCALE(I) - IF (K .EQ. I) GO TO 140 -C - DO 130 J = 1, M - S = Z(I,J) - Z(I,J) = Z(K,J) - Z(K,J) = S - 130 CONTINUE -C - 140 CONTINUE -C - 200 RETURN - END diff --git a/slatec/bandr.f b/slatec/bandr.f deleted file mode 100644 index ee924c3..0000000 --- a/slatec/bandr.f +++ /dev/null @@ -1,288 +0,0 @@ -*DECK BANDR - SUBROUTINE BANDR (NM, N, MB, A, D, E, E2, MATZ, Z) -C***BEGIN PROLOGUE BANDR -C***PURPOSE Reduce a real symmetric band matrix to symmetric -C tridiagonal matrix and, optionally, accumulate -C orthogonal similarity transformations. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C1B1 -C***TYPE SINGLE PRECISION (BANDR-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure BANDRD, -C NUM. MATH. 12, 231-241(1968) by Schwarz. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 273-283(1971). -C -C This subroutine reduces a REAL SYMMETRIC BAND matrix -C to a symmetric tridiagonal matrix using and optionally -C accumulating orthogonal similarity transformations. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, A and Z, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix A. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C MB is the (half) band width of the matrix, defined as the -C number of adjacent diagonals, including the principal -C diagonal, required to specify the non-zero portion of the -C lower triangle of the matrix. MB is less than or equal -C to N. MB is an INTEGER variable. -C -C A contains the lower triangle of the real symmetric band -C matrix. Its lowest subdiagonal is stored in the last -C N+1-MB positions of the first column, its next subdiagonal -C in the last N+2-MB positions of the second column, further -C subdiagonals similarly, and finally its principal diagonal -C in the N positions of the last column. Contents of storage -C locations not part of the matrix are arbitrary. A is a -C two-dimensional REAL array, dimensioned A(NM,MB). -C -C MATZ should be set to .TRUE. if the transformation matrix is -C to be accumulated, and to .FALSE. otherwise. MATZ is a -C LOGICAL variable. -C -C On OUTPUT -C -C A has been destroyed, except for its last two columns which -C contain a copy of the tridiagonal matrix. -C -C D contains the diagonal elements of the tridiagonal matrix. -C D is a one-dimensional REAL array, dimensioned D(N). -C -C E contains the subdiagonal elements of the tridiagonal -C matrix in its last N-1 positions. E(1) is set to zero. -C E is a one-dimensional REAL array, dimensioned E(N). -C -C E2 contains the squares of the corresponding elements of E. -C E2 may coincide with E if the squares are not needed. -C E2 is a one-dimensional REAL array, dimensioned E2(N). -C -C Z contains the orthogonal transformation matrix produced in -C the reduction if MATZ has been set to .TRUE. Otherwise, Z -C is not referenced. Z is a two-dimensional REAL array, -C dimensioned Z(NM,N). -C -C Questions and comments should be directed to B. S. Garbow, -C Applied Mathematics Division, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE BANDR -C - INTEGER J,K,L,N,R,I1,I2,J1,J2,KR,MB,MR,M1,NM,N2,R1,UGL,MAXL,MAXR - REAL A(NM,*),D(*),E(*),E2(*),Z(NM,*) - REAL G,U,B1,B2,C2,F1,F2,S2,DMIN,DMINRT - LOGICAL MATZ -C -C***FIRST EXECUTABLE STATEMENT BANDR - DMIN = 2.0E0**(-64) - DMINRT = 2.0E0**(-32) -C .......... INITIALIZE DIAGONAL SCALING MATRIX .......... - DO 30 J = 1, N - 30 D(J) = 1.0E0 -C - IF (.NOT. MATZ) GO TO 60 -C - DO 50 J = 1, N -C - DO 40 K = 1, N - 40 Z(J,K) = 0.0E0 -C - Z(J,J) = 1.0E0 - 50 CONTINUE -C - 60 M1 = MB - 1 - IF (M1 - 1) 900, 800, 70 - 70 N2 = N - 2 -C - DO 700 K = 1, N2 - MAXR = MIN(M1,N-K) -C .......... FOR R=MAXR STEP -1 UNTIL 2 DO -- .......... - DO 600 R1 = 2, MAXR - R = MAXR + 2 - R1 - KR = K + R - MR = MB - R - G = A(KR,MR) - A(KR-1,1) = A(KR-1,MR+1) - UGL = K -C - DO 500 J = KR, N, M1 - J1 = J - 1 - J2 = J1 - 1 - IF (G .EQ. 0.0E0) GO TO 600 - B1 = A(J1,1) / G - B2 = B1 * D(J1) / D(J) - S2 = 1.0E0 / (1.0E0 + B1 * B2) - IF (S2 .GE. 0.5E0 ) GO TO 450 - B1 = G / A(J1,1) - B2 = B1 * D(J) / D(J1) - C2 = 1.0E0 - S2 - D(J1) = C2 * D(J1) - D(J) = C2 * D(J) - F1 = 2.0E0 * A(J,M1) - F2 = B1 * A(J1,MB) - A(J,M1) = -B2 * (B1 * A(J,M1) - A(J,MB)) - F2 + A(J,M1) - A(J1,MB) = B2 * (B2 * A(J,MB) + F1) + A(J1,MB) - A(J,MB) = B1 * (F2 - F1) + A(J,MB) -C - DO 200 L = UGL, J2 - I2 = MB - J + L - U = A(J1,I2+1) + B2 * A(J,I2) - A(J,I2) = -B1 * A(J1,I2+1) + A(J,I2) - A(J1,I2+1) = U - 200 CONTINUE -C - UGL = J - A(J1,1) = A(J1,1) + B2 * G - IF (J .EQ. N) GO TO 350 - MAXL = MIN(M1,N-J1) -C - DO 300 L = 2, MAXL - I1 = J1 + L - I2 = MB - L - U = A(I1,I2) + B2 * A(I1,I2+1) - A(I1,I2+1) = -B1 * A(I1,I2) + A(I1,I2+1) - A(I1,I2) = U - 300 CONTINUE -C - I1 = J + M1 - IF (I1 .GT. N) GO TO 350 - G = B2 * A(I1,1) - 350 IF (.NOT. MATZ) GO TO 500 -C - DO 400 L = 1, N - U = Z(L,J1) + B2 * Z(L,J) - Z(L,J) = -B1 * Z(L,J1) + Z(L,J) - Z(L,J1) = U - 400 CONTINUE -C - GO TO 500 -C - 450 U = D(J1) - D(J1) = S2 * D(J) - D(J) = S2 * U - F1 = 2.0E0 * A(J,M1) - F2 = B1 * A(J,MB) - U = B1 * (F2 - F1) + A(J1,MB) - A(J,M1) = B2 * (B1 * A(J,M1) - A(J1,MB)) + F2 - A(J,M1) - A(J1,MB) = B2 * (B2 * A(J1,MB) + F1) + A(J,MB) - A(J,MB) = U -C - DO 460 L = UGL, J2 - I2 = MB - J + L - U = B2 * A(J1,I2+1) + A(J,I2) - A(J,I2) = -A(J1,I2+1) + B1 * A(J,I2) - A(J1,I2+1) = U - 460 CONTINUE -C - UGL = J - A(J1,1) = B2 * A(J1,1) + G - IF (J .EQ. N) GO TO 480 - MAXL = MIN(M1,N-J1) -C - DO 470 L = 2, MAXL - I1 = J1 + L - I2 = MB - L - U = B2 * A(I1,I2) + A(I1,I2+1) - A(I1,I2+1) = -A(I1,I2) + B1 * A(I1,I2+1) - A(I1,I2) = U - 470 CONTINUE -C - I1 = J + M1 - IF (I1 .GT. N) GO TO 480 - G = A(I1,1) - A(I1,1) = B1 * A(I1,1) - 480 IF (.NOT. MATZ) GO TO 500 -C - DO 490 L = 1, N - U = B2 * Z(L,J1) + Z(L,J) - Z(L,J) = -Z(L,J1) + B1 * Z(L,J) - Z(L,J1) = U - 490 CONTINUE -C - 500 CONTINUE -C - 600 CONTINUE -C - IF (MOD(K,64) .NE. 0) GO TO 700 -C .......... RESCALE TO AVOID UNDERFLOW OR OVERFLOW .......... - DO 650 J = K, N - IF (D(J) .GE. DMIN) GO TO 650 - MAXL = MAX(1,MB+1-J) -C - DO 610 L = MAXL, M1 - 610 A(J,L) = DMINRT * A(J,L) -C - IF (J .EQ. N) GO TO 630 - MAXL = MIN(M1,N-J) -C - DO 620 L = 1, MAXL - I1 = J + L - I2 = MB - L - A(I1,I2) = DMINRT * A(I1,I2) - 620 CONTINUE -C - 630 IF (.NOT. MATZ) GO TO 645 -C - DO 640 L = 1, N - 640 Z(L,J) = DMINRT * Z(L,J) -C - 645 A(J,MB) = DMIN * A(J,MB) - D(J) = D(J) / DMIN - 650 CONTINUE -C - 700 CONTINUE -C .......... FORM SQUARE ROOT OF SCALING MATRIX .......... - 800 DO 810 J = 2, N - 810 E(J) = SQRT(D(J)) -C - IF (.NOT. MATZ) GO TO 840 -C - DO 830 J = 1, N -C - DO 820 K = 2, N - 820 Z(J,K) = E(K) * Z(J,K) -C - 830 CONTINUE -C - 840 U = 1.0E0 -C - DO 850 J = 2, N - A(J,M1) = U * E(J) * A(J,M1) - U = E(J) - E2(J) = A(J,M1) ** 2 - A(J,MB) = D(J) * A(J,MB) - D(J) = A(J,MB) - E(J) = A(J,M1) - 850 CONTINUE -C - D(1) = A(1,MB) - E(1) = 0.0E0 - E2(1) = 0.0E0 - GO TO 1001 -C - 900 DO 950 J = 1, N - D(J) = A(J,MB) - E(J) = 0.0E0 - E2(J) = 0.0E0 - 950 CONTINUE -C - 1001 RETURN - END diff --git a/slatec/bandv.f b/slatec/bandv.f deleted file mode 100644 index a0ac621..0000000 --- a/slatec/bandv.f +++ /dev/null @@ -1,352 +0,0 @@ -*DECK BANDV - SUBROUTINE BANDV (NM, N, MBW, A, E21, M, W, Z, IERR, NV, RV, RV6) -C***BEGIN PROLOGUE BANDV -C***PURPOSE Form the eigenvectors of a real symmetric band matrix -C associated with a set of ordered approximate eigenvalues -C by inverse iteration. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C3 -C***TYPE SINGLE PRECISION (BANDV-S) -C***KEYWORDS EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine finds those eigenvectors of a REAL SYMMETRIC -C BAND matrix corresponding to specified eigenvalues, using inverse -C iteration. The subroutine may also be used to solve systems -C of linear equations with a symmetric or non-symmetric band -C coefficient matrix. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, A and Z, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix A. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C MBW is the number of columns of the array A used to store the -C band matrix. If the matrix is symmetric, MBW is its (half) -C band width, denoted MB and defined as the number of adjacent -C diagonals, including the principal diagonal, required to -C specify the non-zero portion of the lower triangle of the -C matrix. If the subroutine is being used to solve systems -C of linear equations and the coefficient matrix is not -C symmetric, it must however have the same number of adjacent -C diagonals above the main diagonal as below, and in this -C case, MBW=2*MB-1. MBW is an INTEGER variable. MB must not -C be greater than N. -C -C A contains the lower triangle of the symmetric band input -C matrix stored as an N by MB array. Its lowest subdiagonal -C is stored in the last N+1-MB positions of the first column, -C its next subdiagonal in the last N+2-MB positions of the -C second column, further subdiagonals similarly, and finally -C its principal diagonal in the N positions of column MB. -C If the subroutine is being used to solve systems of linear -C equations and the coefficient matrix is not symmetric, A is -C N by 2*MB-1 instead with lower triangle as above and with -C its first superdiagonal stored in the first N-1 positions of -C column MB+1, its second superdiagonal in the first N-2 -C positions of column MB+2, further superdiagonals similarly, -C and finally its highest superdiagonal in the first N+1-MB -C positions of the last column. Contents of storage locations -C not part of the matrix are arbitrary. A is a two-dimensional -C REAL array, dimensioned A(NM,MBW). -C -C E21 specifies the ordering of the eigenvalues and contains -C 0.0E0 if the eigenvalues are in ascending order, or -C 2.0E0 if the eigenvalues are in descending order. -C If the subroutine is being used to solve systems of linear -C equations, E21 should be set to 1.0E0 if the coefficient -C matrix is symmetric and to -1.0E0 if not. E21 is a REAL -C variable. -C -C M is the number of specified eigenvalues or the number of -C systems of linear equations. M is an INTEGER variable. -C -C W contains the M eigenvalues in ascending or descending order. -C If the subroutine is being used to solve systems of linear -C equations (A-W(J)*I)*X(J)=B(J), where I is the identity -C matrix, W(J) should be set accordingly, for J=1,2,...,M. -C W is a one-dimensional REAL array, dimensioned W(M). -C -C Z contains the constant matrix columns (B(J),J=1,2,...,M), if -C the subroutine is used to solve systems of linear equations. -C Z is a two-dimensional REAL array, dimensioned Z(NM,M). -C -C NV must be set to the dimension of the array parameter RV -C as declared in the calling program dimension statement. -C NV is an INTEGER variable. -C -C On OUTPUT -C -C A and W are unaltered. -C -C Z contains the associated set of orthogonal eigenvectors. -C Any vector which fails to converge is set to zero. If the -C subroutine is used to solve systems of linear equations, -C Z contains the solution matrix columns (X(J),J=1,2,...,M). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C -J if the eigenvector corresponding to the J-th -C eigenvalue fails to converge, or if the J-th -C system of linear equations is nearly singular. -C -C RV and RV6 are temporary storage arrays. If the subroutine -C is being used to solve systems of linear equations, the -C determinant (up to sign) of A-W(M)*I is available, upon -C return, as the product of the first N elements of RV. -C RV and RV6 are one-dimensional REAL arrays. Note that RV -C is dimensioned RV(NV), where NV must be at least N*(2*MB-1). -C RV6 is dimensioned RV6(N). -C -C Questions and comments should be directed to B. S. Garbow, -C Applied Mathematics Division, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE BANDV -C - INTEGER I,J,K,M,N,R,II,IJ,JJ,KJ,MB,M1,NM,NV,IJ1,ITS,KJ1,MBW,M21 - INTEGER IERR,MAXJ,MAXK,GROUP - REAL A(NM,*),W(*),Z(NM,*),RV(*),RV6(*) - REAL U,V,UK,XU,X0,X1,E21,EPS2,EPS3,EPS4,NORM,ORDER,S -C -C***FIRST EXECUTABLE STATEMENT BANDV - IERR = 0 - IF (M .EQ. 0) GO TO 1001 - MB = MBW - IF (E21 .LT. 0.0E0) MB = (MBW + 1) / 2 - M1 = MB - 1 - M21 = M1 + MB - ORDER = 1.0E0 - ABS(E21) -C .......... FIND VECTORS BY INVERSE ITERATION .......... - DO 920 R = 1, M - ITS = 1 - X1 = W(R) - IF (R .NE. 1) GO TO 100 -C .......... COMPUTE NORM OF MATRIX .......... - NORM = 0.0E0 -C - DO 60 J = 1, MB - JJ = MB + 1 - J - KJ = JJ + M1 - IJ = 1 - S = 0.0E0 -C - DO 40 I = JJ, N - S = S + ABS(A(I,J)) - IF (E21 .GE. 0.0E0) GO TO 40 - S = S + ABS(A(IJ,KJ)) - IJ = IJ + 1 - 40 CONTINUE -C - NORM = MAX(NORM,S) - 60 CONTINUE -C - IF (E21 .LT. 0.0E0) NORM = 0.5E0 * NORM -C .......... EPS2 IS THE CRITERION FOR GROUPING, -C EPS3 REPLACES ZERO PIVOTS AND EQUAL -C ROOTS ARE MODIFIED BY EPS3, -C EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW .......... - IF (NORM .EQ. 0.0E0) NORM = 1.0E0 - EPS2 = 1.0E-3 * NORM * ABS(ORDER) - EPS3 = NORM - 70 EPS3 = 0.5E0*EPS3 - IF (NORM + EPS3 .GT. NORM) GO TO 70 - UK = SQRT(REAL(N)) - EPS3 = UK * EPS3 - EPS4 = UK * EPS3 - 80 GROUP = 0 - GO TO 120 -C .......... LOOK FOR CLOSE OR COINCIDENT ROOTS .......... - 100 IF (ABS(X1-X0) .GE. EPS2) GO TO 80 - GROUP = GROUP + 1 - IF (ORDER * (X1 - X0) .LE. 0.0E0) X1 = X0 + ORDER * EPS3 -C .......... EXPAND MATRIX, SUBTRACT EIGENVALUE, -C AND INITIALIZE VECTOR .......... - 120 DO 200 I = 1, N - IJ = I + MIN(0,I-M1) * N - KJ = IJ + MB * N - IJ1 = KJ + M1 * N - IF (M1 .EQ. 0) GO TO 180 -C - DO 150 J = 1, M1 - IF (IJ .GT. M1) GO TO 125 - IF (IJ .GT. 0) GO TO 130 - RV(IJ1) = 0.0E0 - IJ1 = IJ1 + N - GO TO 130 - 125 RV(IJ) = A(I,J) - 130 IJ = IJ + N - II = I + J - IF (II .GT. N) GO TO 150 - JJ = MB - J - IF (E21 .GE. 0.0E0) GO TO 140 - II = I - JJ = MB + J - 140 RV(KJ) = A(II,JJ) - KJ = KJ + N - 150 CONTINUE -C - 180 RV(IJ) = A(I,MB) - X1 - RV6(I) = EPS4 - IF (ORDER .EQ. 0.0E0) RV6(I) = Z(I,R) - 200 CONTINUE -C - IF (M1 .EQ. 0) GO TO 600 -C .......... ELIMINATION WITH INTERCHANGES .......... - DO 580 I = 1, N - II = I + 1 - MAXK = MIN(I+M1-1,N) - MAXJ = MIN(N-I,M21-2) * N -C - DO 360 K = I, MAXK - KJ1 = K - J = KJ1 + N - JJ = J + MAXJ -C - DO 340 KJ = J, JJ, N - RV(KJ1) = RV(KJ) - KJ1 = KJ - 340 CONTINUE -C - RV(KJ1) = 0.0E0 - 360 CONTINUE -C - IF (I .EQ. N) GO TO 580 - U = 0.0E0 - MAXK = MIN(I+M1,N) - MAXJ = MIN(N-II,M21-2) * N -C - DO 450 J = I, MAXK - IF (ABS(RV(J)) .LT. ABS(U)) GO TO 450 - U = RV(J) - K = J - 450 CONTINUE -C - J = I + N - JJ = J + MAXJ - IF (K .EQ. I) GO TO 520 - KJ = K -C - DO 500 IJ = I, JJ, N - V = RV(IJ) - RV(IJ) = RV(KJ) - RV(KJ) = V - KJ = KJ + N - 500 CONTINUE -C - IF (ORDER .NE. 0.0E0) GO TO 520 - V = RV6(I) - RV6(I) = RV6(K) - RV6(K) = V - 520 IF (U .EQ. 0.0E0) GO TO 580 -C - DO 560 K = II, MAXK - V = RV(K) / U - KJ = K -C - DO 540 IJ = J, JJ, N - KJ = KJ + N - RV(KJ) = RV(KJ) - V * RV(IJ) - 540 CONTINUE -C - IF (ORDER .EQ. 0.0E0) RV6(K) = RV6(K) - V * RV6(I) - 560 CONTINUE -C - 580 CONTINUE -C .......... BACK SUBSTITUTION -C FOR I=N STEP -1 UNTIL 1 DO -- .......... - 600 DO 630 II = 1, N - I = N + 1 - II - MAXJ = MIN(II,M21) - IF (MAXJ .EQ. 1) GO TO 620 - IJ1 = I - J = IJ1 + N - JJ = J + (MAXJ - 2) * N -C - DO 610 IJ = J, JJ, N - IJ1 = IJ1 + 1 - RV6(I) = RV6(I) - RV(IJ) * RV6(IJ1) - 610 CONTINUE -C - 620 V = RV(I) - IF (ABS(V) .GE. EPS3) GO TO 625 -C .......... SET ERROR -- NEARLY SINGULAR LINEAR SYSTEM .......... - IF (ORDER .EQ. 0.0E0) IERR = -R - V = SIGN(EPS3,V) - 625 RV6(I) = RV6(I) / V - 630 CONTINUE -C - XU = 1.0E0 - IF (ORDER .EQ. 0.0E0) GO TO 870 -C .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS -C MEMBERS OF GROUP .......... - IF (GROUP .EQ. 0) GO TO 700 -C - DO 680 JJ = 1, GROUP - J = R - GROUP - 1 + JJ - XU = 0.0E0 -C - DO 640 I = 1, N - 640 XU = XU + RV6(I) * Z(I,J) -C - DO 660 I = 1, N - 660 RV6(I) = RV6(I) - XU * Z(I,J) -C - 680 CONTINUE -C - 700 NORM = 0.0E0 -C - DO 720 I = 1, N - 720 NORM = NORM + ABS(RV6(I)) -C - IF (NORM .GE. 0.1E0) GO TO 840 -C .......... IN-LINE PROCEDURE FOR CHOOSING -C A NEW STARTING VECTOR .......... - IF (ITS .GE. N) GO TO 830 - ITS = ITS + 1 - XU = EPS4 / (UK + 1.0E0) - RV6(1) = EPS4 -C - DO 760 I = 2, N - 760 RV6(I) = XU -C - RV6(ITS) = RV6(ITS) - EPS4 * UK - GO TO 600 -C .......... SET ERROR -- NON-CONVERGED EIGENVECTOR .......... - 830 IERR = -R - XU = 0.0E0 - GO TO 870 -C .......... NORMALIZE SO THAT SUM OF SQUARES IS -C 1 AND EXPAND TO FULL ORDER .......... - 840 U = 0.0E0 -C - DO 860 I = 1, N - 860 U = U + RV6(I)**2 -C - XU = 1.0E0 / SQRT(U) -C - 870 DO 900 I = 1, N - 900 Z(I,R) = RV6(I) * XU -C - X0 = X1 - 920 CONTINUE -C - 1001 RETURN - END diff --git a/slatec/bcrh.f b/slatec/bcrh.f deleted file mode 100644 index a4a0206..0000000 --- a/slatec/bcrh.f +++ /dev/null @@ -1,33 +0,0 @@ -*DECK BCRH - FUNCTION BCRH (XLL, XRR, IZ, C, A, BH, F, SGN) -C***BEGIN PROLOGUE BCRH -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBLKTR -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (BCRH-S, BSRH-S) -C***AUTHOR (UNKNOWN) -C***SEE ALSO CBLKTR -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS CCBLK -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE BCRH - DIMENSION A(*) ,C(*) ,BH(*) - COMMON /CCBLK/ NPP ,K ,EPS ,CNV , - 1 NM ,NCMPLX ,IK -C***FIRST EXECUTABLE STATEMENT BCRH - XL = XLL - XR = XRR - DX = .5*ABS(XR-XL) - 101 X = .5*(XL+XR) - IF (SGN*F(X,IZ,C,A,BH)) 103,105,102 - 102 XR = X - GO TO 104 - 103 XL = X - 104 DX = .5*DX - IF (DX-CNV) 105,105,101 - 105 BCRH = .5*(XL+XR) - RETURN - END diff --git a/slatec/bdiff.f b/slatec/bdiff.f deleted file mode 100644 index c481451..0000000 --- a/slatec/bdiff.f +++ /dev/null @@ -1,36 +0,0 @@ -*DECK BDIFF - SUBROUTINE BDIFF (L, V) -C***BEGIN PROLOGUE BDIFF -C***SUBSIDIARY -C***PURPOSE Subsidiary to BSKIN -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (BDIFF-S, DBDIFF-D) -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C BDIFF computes the sum of B(L,K)*V(K)*(-1)**K where B(L,K) -C are the binomial coefficients. Truncated sums are computed by -C setting last part of the V vector to zero. On return, the binomial -C sum is in V(L). -C -C***SEE ALSO BSKIN -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 820601 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE BDIFF - INTEGER I, J, K, L - REAL V - DIMENSION V(*) -C***FIRST EXECUTABLE STATEMENT BDIFF - IF (L.EQ.1) RETURN - DO 20 J=2,L - K = L - DO 10 I=J,L - V(K) = V(K-1) - V(K) - K = K - 1 - 10 CONTINUE - 20 CONTINUE - RETURN - END diff --git a/slatec/besi.f b/slatec/besi.f deleted file mode 100644 index 70287b3..0000000 --- a/slatec/besi.f +++ /dev/null @@ -1,462 +0,0 @@ -*DECK BESI - SUBROUTINE BESI (X, ALPHA, KODE, N, Y, NZ) -C***BEGIN PROLOGUE BESI -C***PURPOSE Compute an N member sequence of I Bessel functions -C I/SUB(ALPHA+K-1)/(X), K=1,...,N or scaled Bessel functions -C EXP(-X)*I/SUB(ALPHA+K-1)/(X), K=1,...,N for non-negative -C ALPHA and X. -C***LIBRARY SLATEC -C***CATEGORY C10B3 -C***TYPE SINGLE PRECISION (BESI-S, DBESI-D) -C***KEYWORDS I BESSEL FUNCTION, SPECIAL FUNCTIONS -C***AUTHOR Amos, D. E., (SNLA) -C Daniel, S. L., (SNLA) -C***DESCRIPTION -C -C Abstract -C BESI computes an N member sequence of I Bessel functions -C I/sub(ALPHA+K-1)/(X), K=1,...,N or scaled Bessel functions -C EXP(-X)*I/sub(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA -C and X. A combination of the power series, the asymptotic -C expansion for X to infinity, and the uniform asymptotic -C expansion for NU to infinity are applied over subdivisions of -C the (NU,X) plane. For values not covered by one of these -C formulae, the order is incremented by an integer so that one -C of these formulae apply. Backward recursion is used to reduce -C orders by integer values. The asymptotic expansion for X to -C infinity is used only when the entire sequence (specifically -C the last member) lies within the region covered by the -C expansion. Leading terms of these expansions are used to test -C for over or underflow where appropriate. If a sequence is -C requested and the last member would underflow, the result is -C set to zero and the next lower order tried, etc., until a -C member comes on scale or all are set to zero. An overflow -C cannot occur with scaling. -C -C Description of Arguments -C -C Input -C X - X .GE. 0.0E0 -C ALPHA - order of first member of the sequence, -C ALPHA .GE. 0.0E0 -C KODE - a parameter to indicate the scaling option -C KODE=1 returns -C Y(K)= I/sub(ALPHA+K-1)/(X), -C K=1,...,N -C KODE=2 returns -C Y(K)=EXP(-X)*I/sub(ALPHA+K-1)/(X), -C K=1,...,N -C N - number of members in the sequence, N .GE. 1 -C -C Output -C Y - a vector whose first N components contain -C values for I/sub(ALPHA+K-1)/(X) or scaled -C values for EXP(-X)*I/sub(ALPHA+K-1)/(X), -C K=1,...,N depending on KODE -C NZ - number of components of Y set to zero due to -C underflow, -C NZ=0 , normal return, computation completed -C NZ .NE. 0, last NZ components of Y set to zero, -C Y(K)=0.0E0, K=N-NZ+1,...,N. -C -C Error Conditions -C Improper input arguments - a fatal error -C Overflow with KODE=1 - a fatal error -C Underflow - a non-fatal error (NZ .NE. 0) -C -C***REFERENCES D. E. Amos, S. L. Daniel and M. K. Weston, CDC 6600 -C subroutines IBESS and JBESS for Bessel functions -C I(NU,X) and J(NU,X), X .GE. 0, NU .GE. 0, ACM -C Transactions on Mathematical Software 3, (1977), -C pp. 76-92. -C F. W. J. Olver, Tables of Bessel Functions of Moderate -C or Large Orders, NPL Mathematical Tables 6, Her -C Majesty's Stationery Office, London, 1962. -C***ROUTINES CALLED ALNGAM, ASYIK, I1MACH, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 750101 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE BESI -C - INTEGER I, IALP, IN, INLIM, IS, I1, K, KK, KM, KODE, KT, - 1 N, NN, NS, NZ - INTEGER I1MACH - REAL AIN, AK, AKM, ALPHA, ANS, AP, ARG, ATOL, TOLLN, DFN, - 1 DTM, DX, EARG, ELIM, ETX, FLGIK,FN, FNF, FNI,FNP1,FNU,GLN,RA, - 2 RTTPI, S, SX, SXO2, S1, S2, T, TA, TB, TEMP, TFN, TM, TOL, - 3 TRX, T2, X, XO2, XO2L, Y, Z - REAL R1MACH, ALNGAM - DIMENSION Y(*), TEMP(3) - SAVE RTTPI, INLIM - DATA RTTPI / 3.98942280401433E-01/ - DATA INLIM / 80 / -C***FIRST EXECUTABLE STATEMENT BESI - NZ = 0 - KT = 1 -C I1MACH(15) REPLACES I1MACH(12) IN A DOUBLE PRECISION CODE -C I1MACH(14) REPLACES I1MACH(11) IN A DOUBLE PRECISION CODE - RA = R1MACH(3) - TOL = MAX(RA,1.0E-15) - I1 = -I1MACH(12) - GLN = R1MACH(5) - ELIM = 2.303E0*(I1*GLN-3.0E0) -C TOLLN = -LN(TOL) - I1 = I1MACH(11)+1 - TOLLN = 2.303E0*GLN*I1 - TOLLN = MIN(TOLLN,34.5388E0) - IF (N-1) 590, 10, 20 - 10 KT = 2 - 20 NN = N - IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 570 - IF (X) 600, 30, 80 - 30 IF (ALPHA) 580, 40, 50 - 40 Y(1) = 1.0E0 - IF (N.EQ.1) RETURN - I1 = 2 - GO TO 60 - 50 I1 = 1 - 60 DO 70 I=I1,N - Y(I) = 0.0E0 - 70 CONTINUE - RETURN - 80 CONTINUE - IF (ALPHA.LT.0.0E0) GO TO 580 -C - IALP = INT(ALPHA) - FNI = IALP + N - 1 - FNF = ALPHA - IALP - DFN = FNI + FNF - FNU = DFN - IN = 0 - XO2 = X*0.5E0 - SXO2 = XO2*XO2 - ETX = KODE - 1 - SX = ETX*X -C -C DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X -C TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE -C APPLIED. -C - IF (SXO2.LE.(FNU+1.0E0)) GO TO 90 - IF (X.LE.12.0E0) GO TO 110 - FN = 0.55E0*FNU*FNU - FN = MAX(17.0E0,FN) - IF (X.GE.FN) GO TO 430 - ANS = MAX(36.0E0-FNU,0.0E0) - NS = INT(ANS) - FNI = FNI + NS - DFN = FNI + FNF - FN = DFN - IS = KT - KM = N - 1 + NS - IF (KM.GT.0) IS = 3 - GO TO 120 - 90 FN = FNU - FNP1 = FN + 1.0E0 - XO2L = LOG(XO2) - IS = KT - IF (X.LE.0.5E0) GO TO 230 - NS = 0 - 100 FNI = FNI + NS - DFN = FNI + FNF - FN = DFN - FNP1 = FN + 1.0E0 - IS = KT - IF (N-1+NS.GT.0) IS = 3 - GO TO 230 - 110 XO2L = LOG(XO2) - NS = INT(SXO2-FNU) - GO TO 100 - 120 CONTINUE -C -C OVERFLOW TEST ON UNIFORM ASYMPTOTIC EXPANSION -C - IF (KODE.EQ.2) GO TO 130 - IF (ALPHA.LT.1.0E0) GO TO 150 - Z = X/ALPHA - RA = SQRT(1.0E0+Z*Z) - GLN = LOG((1.0E0+RA)/Z) - T = RA*(1.0E0-ETX) + ETX/(Z+RA) - ARG = ALPHA*(T-GLN) - IF (ARG.GT.ELIM) GO TO 610 - IF (KM.EQ.0) GO TO 140 - 130 CONTINUE -C -C UNDERFLOW TEST ON UNIFORM ASYMPTOTIC EXPANSION -C - Z = X/FN - RA = SQRT(1.0E0+Z*Z) - GLN = LOG((1.0E0+RA)/Z) - T = RA*(1.0E0-ETX) + ETX/(Z+RA) - ARG = FN*(T-GLN) - 140 IF (ARG.LT.(-ELIM)) GO TO 280 - GO TO 190 - 150 IF (X.GT.ELIM) GO TO 610 - GO TO 130 -C -C UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY -C - 160 IF (KM.NE.0) GO TO 170 - Y(1) = TEMP(3) - RETURN - 170 TEMP(1) = TEMP(3) - IN = NS - KT = 1 - I1 = 0 - 180 CONTINUE - IS = 2 - FNI = FNI - 1.0E0 - DFN = FNI + FNF - FN = DFN - IF(I1.EQ.2) GO TO 350 - Z = X/FN - RA = SQRT(1.0E0+Z*Z) - GLN = LOG((1.0E0+RA)/Z) - T = RA*(1.0E0-ETX) + ETX/(Z+RA) - ARG = FN*(T-GLN) - 190 CONTINUE - I1 = ABS(3-IS) - I1 = MAX(I1,1) - FLGIK = 1.0E0 - CALL ASYIK(X,FN,KODE,FLGIK,RA,ARG,I1,TEMP(IS)) - GO TO (180, 350, 510), IS -C -C SERIES FOR (X/2)**2.LE.NU+1 -C - 230 CONTINUE - GLN = ALNGAM(FNP1) - ARG = FN*XO2L - GLN - SX - IF (ARG.LT.(-ELIM)) GO TO 300 - EARG = EXP(ARG) - 240 CONTINUE - S = 1.0E0 - IF (X.LT.TOL) GO TO 260 - AK = 3.0E0 - T2 = 1.0E0 - T = 1.0E0 - S1 = FN - DO 250 K=1,17 - S2 = T2 + S1 - T = T*SXO2/S2 - S = S + T - IF (ABS(T).LT.TOL) GO TO 260 - T2 = T2 + AK - AK = AK + 2.0E0 - S1 = S1 + FN - 250 CONTINUE - 260 CONTINUE - TEMP(IS) = S*EARG - GO TO (270, 350, 500), IS - 270 EARG = EARG*FN/XO2 - FNI = FNI - 1.0E0 - DFN = FNI + FNF - FN = DFN - IS = 2 - GO TO 240 -C -C SET UNDERFLOW VALUE AND UPDATE PARAMETERS -C - 280 Y(NN) = 0.0E0 - NN = NN - 1 - FNI = FNI - 1.0E0 - DFN = FNI + FNF - FN = DFN - IF (NN-1) 340, 290, 130 - 290 KT = 2 - IS = 2 - GO TO 130 - 300 Y(NN) = 0.0E0 - NN = NN - 1 - FNP1 = FN - FNI = FNI - 1.0E0 - DFN = FNI + FNF - FN = DFN - IF (NN-1) 340, 310, 320 - 310 KT = 2 - IS = 2 - 320 IF (SXO2.LE.FNP1) GO TO 330 - GO TO 130 - 330 ARG = ARG - XO2L + LOG(FNP1) - IF (ARG.LT.(-ELIM)) GO TO 300 - GO TO 230 - 340 NZ = N - NN - RETURN -C -C BACKWARD RECURSION SECTION -C - 350 CONTINUE - NZ = N - NN - 360 CONTINUE - IF(KT.EQ.2) GO TO 420 - S1 = TEMP(1) - S2 = TEMP(2) - TRX = 2.0E0/X - DTM = FNI - TM = (DTM+FNF)*TRX - IF (IN.EQ.0) GO TO 390 -C BACKWARD RECUR TO INDEX ALPHA+NN-1 - DO 380 I=1,IN - S = S2 - S2 = TM*S2 + S1 - S1 = S - DTM = DTM - 1.0E0 - TM = (DTM+FNF)*TRX - 380 CONTINUE - Y(NN) = S1 - IF (NN.EQ.1) RETURN - Y(NN-1) = S2 - IF (NN.EQ.2) RETURN - GO TO 400 - 390 CONTINUE -C BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA - Y(NN) = S1 - Y(NN-1) = S2 - IF (NN.EQ.2) RETURN - 400 K = NN + 1 - DO 410 I=3,NN - K = K - 1 - Y(K-2) = TM*Y(K-1) + Y(K) - DTM = DTM - 1.0E0 - TM = (DTM+FNF)*TRX - 410 CONTINUE - RETURN - 420 Y(1) = TEMP(2) - RETURN -C -C ASYMPTOTIC EXPANSION FOR X TO INFINITY -C - 430 CONTINUE - EARG = RTTPI/SQRT(X) - IF (KODE.EQ.2) GO TO 440 - IF (X.GT.ELIM) GO TO 610 - EARG = EARG*EXP(X) - 440 ETX = 8.0E0*X - IS = KT - IN = 0 - FN = FNU - 450 DX = FNI + FNI - TM = 0.0E0 - IF (FNI.EQ.0.0E0 .AND. ABS(FNF).LT.TOL) GO TO 460 - TM = 4.0E0*FNF*(FNI+FNI+FNF) - 460 CONTINUE - DTM = DX*DX - S1 = ETX - TRX = DTM - 1.0E0 - DX = -(TRX+TM)/ETX - T = DX - S = 1.0E0 + DX - ATOL = TOL*ABS(S) - S2 = 1.0E0 - AK = 8.0E0 - DO 470 K=1,25 - S1 = S1 + ETX - S2 = S2 + AK - DX = DTM - S2 - AP = DX + TM - T = -T*AP/S1 - S = S + T - IF (ABS(T).LE.ATOL) GO TO 480 - AK = AK + 8.0E0 - 470 CONTINUE - 480 TEMP(IS) = S*EARG - IF(IS.EQ.2) GO TO 360 - IS = 2 - FNI = FNI - 1.0E0 - DFN = FNI + FNF - FN = DFN - GO TO 450 -C -C BACKWARD RECURSION WITH NORMALIZATION BY -C ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES. -C - 500 CONTINUE -C COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION - AKM = MAX(3.0E0-FN,0.0E0) - KM = INT(AKM) - TFN = FN + KM - TA = (GLN+TFN-0.9189385332E0-0.0833333333E0/TFN)/(TFN+0.5E0) - TA = XO2L - TA - TB = -(1.0E0-1.0E0/TFN)/TFN - AIN = TOLLN/(-TA+SQRT(TA*TA-TOLLN*TB)) + 1.5E0 - IN = INT(AIN) - IN = IN + KM - GO TO 520 - 510 CONTINUE -C COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION - T = 1.0E0/(FN*RA) - AIN = TOLLN/(GLN+SQRT(GLN*GLN+T*TOLLN)) + 1.5E0 - IN = INT(AIN) - IF (IN.GT.INLIM) GO TO 160 - 520 CONTINUE - TRX = 2.0E0/X - DTM = FNI + IN - TM = (DTM+FNF)*TRX - TA = 0.0E0 - TB = TOL - KK = 1 - 530 CONTINUE -C -C BACKWARD RECUR UNINDEXED -C - DO 540 I=1,IN - S = TB - TB = TM*TB + TA - TA = S - DTM = DTM - 1.0E0 - TM = (DTM+FNF)*TRX - 540 CONTINUE -C NORMALIZATION - IF (KK.NE.1) GO TO 550 - TA = (TA/TB)*TEMP(3) - TB = TEMP(3) - KK = 2 - IN = NS - IF (NS.NE.0) GO TO 530 - 550 Y(NN) = TB - NZ = N - NN - IF (NN.EQ.1) RETURN - TB = TM*TB + TA - K = NN - 1 - Y(K) = TB - IF (NN.EQ.2) RETURN - DTM = DTM - 1.0E0 - TM = (DTM+FNF)*TRX - KM = K - 1 -C -C BACKWARD RECUR INDEXED -C - DO 560 I=1,KM - Y(K-1) = TM*Y(K) + Y(K+1) - DTM = DTM - 1.0E0 - TM = (DTM+FNF)*TRX - K = K - 1 - 560 CONTINUE - RETURN -C -C -C - 570 CONTINUE - CALL XERMSG ('SLATEC', 'BESI', - + 'SCALING OPTION, KODE, NOT 1 OR 2.', 2, 1) - RETURN - 580 CONTINUE - CALL XERMSG ('SLATEC', 'BESI', 'ORDER, ALPHA, LESS THAN ZERO.', - + 2, 1) - RETURN - 590 CONTINUE - CALL XERMSG ('SLATEC', 'BESI', 'N LESS THAN ONE.', 2, 1) - RETURN - 600 CONTINUE - CALL XERMSG ('SLATEC', 'BESI', 'X LESS THAN ZERO.', 2, 1) - RETURN - 610 CONTINUE - CALL XERMSG ('SLATEC', 'BESI', - + 'OVERFLOW, X TOO LARGE FOR KODE = 1.', 6, 1) - RETURN - END diff --git a/slatec/besi0.f b/slatec/besi0.f deleted file mode 100644 index 731ccb0..0000000 --- a/slatec/besi0.f +++ /dev/null @@ -1,71 +0,0 @@ -*DECK BESI0 - FUNCTION BESI0 (X) -C***BEGIN PROLOGUE BESI0 -C***PURPOSE Compute the hyperbolic Bessel function of the first kind -C of order zero. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10B1 -C***TYPE SINGLE PRECISION (BESI0-S, DBESI0-D) -C***KEYWORDS FIRST KIND, FNLIB, HYPERBOLIC BESSEL FUNCTION, -C MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C BESI0(X) computes the modified (hyperbolic) Bessel function -C of the first kind of order zero and real argument X. -C -C Series for BI0 on the interval 0. to 9.00000D+00 -C with weighted error 2.46E-18 -C log weighted error 17.61 -C significant figures required 17.90 -C decimal places required 18.15 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED BESI0E, CSEVL, INITS, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE BESI0 - DIMENSION BI0CS(12) - LOGICAL FIRST - SAVE BI0CS, NTI0, XSML, XMAX, FIRST - DATA BI0CS( 1) / -.0766054725 2839144951E0 / - DATA BI0CS( 2) / 1.9273379539 93808270E0 / - DATA BI0CS( 3) / .2282644586 920301339E0 / - DATA BI0CS( 4) / .0130489146 6707290428E0 / - DATA BI0CS( 5) / .0004344270 9008164874E0 / - DATA BI0CS( 6) / .0000094226 5768600193E0 / - DATA BI0CS( 7) / .0000001434 0062895106E0 / - DATA BI0CS( 8) / .0000000016 1384906966E0 / - DATA BI0CS( 9) / .0000000000 1396650044E0 / - DATA BI0CS(10) / .0000000000 0009579451E0 / - DATA BI0CS(11) / .0000000000 0000053339E0 / - DATA BI0CS(12) / .0000000000 0000000245E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT BESI0 - IF (FIRST) THEN - NTI0 = INITS (BI0CS, 12, 0.1*R1MACH(3)) - XSML = SQRT (4.5*R1MACH(3)) - XMAX = LOG (R1MACH(2)) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.3.0) GO TO 20 -C - BESI0 = 1.0 - IF (Y.GT.XSML) BESI0 = 2.75 + CSEVL (Y*Y/4.5-1.0, BI0CS, NTI0) - RETURN -C - 20 IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'BESI0', - + 'ABS(X) SO BIG I0 OVERFLOWS', 1, 2) -C - BESI0 = EXP(Y) * BESI0E(X) -C - RETURN - END diff --git a/slatec/besi0e.f b/slatec/besi0e.f deleted file mode 100644 index 64b76cd..0000000 --- a/slatec/besi0e.f +++ /dev/null @@ -1,129 +0,0 @@ -*DECK BESI0E - FUNCTION BESI0E (X) -C***BEGIN PROLOGUE BESI0E -C***PURPOSE Compute the exponentially scaled modified (hyperbolic) -C Bessel function of the first kind of order zero. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10B1 -C***TYPE SINGLE PRECISION (BESI0E-S, DBSI0E-D) -C***KEYWORDS EXPONENTIALLY SCALED, FIRST KIND, FNLIB, -C HYPERBOLIC BESSEL FUNCTION, MODIFIED BESSEL FUNCTION, -C ORDER ZERO, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C BESI0E(X) calculates the exponentially scaled modified (hyperbolic) -C Bessel function of the first kind of order zero for real argument X; -C i.e., EXP(-ABS(X))*I0(X). -C -C -C Series for BI0 on the interval 0. to 9.00000D+00 -C with weighted error 2.46E-18 -C log weighted error 17.61 -C significant figures required 17.90 -C decimal places required 18.15 -C -C -C Series for AI0 on the interval 1.25000D-01 to 3.33333D-01 -C with weighted error 7.87E-17 -C log weighted error 16.10 -C significant figures required 14.69 -C decimal places required 16.76 -C -C -C Series for AI02 on the interval 0. to 1.25000D-01 -C with weighted error 3.79E-17 -C log weighted error 16.42 -C significant figures required 14.86 -C decimal places required 17.09 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, INITS, R1MACH -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890313 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE BESI0E - DIMENSION BI0CS(12), AI0CS(21), AI02CS(22) - LOGICAL FIRST - SAVE BI0CS, AI0CS, AI02CS, NTI0, NTAI0, NTAI02, XSML, FIRST - DATA BI0CS( 1) / -.0766054725 2839144951E0 / - DATA BI0CS( 2) / 1.9273379539 93808270E0 / - DATA BI0CS( 3) / .2282644586 920301339E0 / - DATA BI0CS( 4) / .0130489146 6707290428E0 / - DATA BI0CS( 5) / .0004344270 9008164874E0 / - DATA BI0CS( 6) / .0000094226 5768600193E0 / - DATA BI0CS( 7) / .0000001434 0062895106E0 / - DATA BI0CS( 8) / .0000000016 1384906966E0 / - DATA BI0CS( 9) / .0000000000 1396650044E0 / - DATA BI0CS(10) / .0000000000 0009579451E0 / - DATA BI0CS(11) / .0000000000 0000053339E0 / - DATA BI0CS(12) / .0000000000 0000000245E0 / - DATA AI0CS( 1) / .0757599449 4023796E0 / - DATA AI0CS( 2) / .0075913808 1082334E0 / - DATA AI0CS( 3) / .0004153131 3389237E0 / - DATA AI0CS( 4) / .0000107007 6463439E0 / - DATA AI0CS( 5) / -.0000079011 7997921E0 / - DATA AI0CS( 6) / -.0000007826 1435014E0 / - DATA AI0CS( 7) / .0000002783 8499429E0 / - DATA AI0CS( 8) / .0000000082 5247260E0 / - DATA AI0CS( 9) / -.0000000120 4463945E0 / - DATA AI0CS(10) / .0000000015 5964859E0 / - DATA AI0CS(11) / .0000000002 2925563E0 / - DATA AI0CS(12) / -.0000000001 1916228E0 / - DATA AI0CS(13) / .0000000000 1757854E0 / - DATA AI0CS(14) / .0000000000 0112822E0 / - DATA AI0CS(15) / -.0000000000 0114684E0 / - DATA AI0CS(16) / .0000000000 0027155E0 / - DATA AI0CS(17) / -.0000000000 0002415E0 / - DATA AI0CS(18) / -.0000000000 0000608E0 / - DATA AI0CS(19) / .0000000000 0000314E0 / - DATA AI0CS(20) / -.0000000000 0000071E0 / - DATA AI0CS(21) / .0000000000 0000007E0 / - DATA AI02CS( 1) / .0544904110 1410882E0 / - DATA AI02CS( 2) / .0033691164 7825569E0 / - DATA AI02CS( 3) / .0000688975 8346918E0 / - DATA AI02CS( 4) / .0000028913 7052082E0 / - DATA AI02CS( 5) / .0000002048 9185893E0 / - DATA AI02CS( 6) / .0000000226 6668991E0 / - DATA AI02CS( 7) / .0000000033 9623203E0 / - DATA AI02CS( 8) / .0000000004 9406022E0 / - DATA AI02CS( 9) / .0000000000 1188914E0 / - DATA AI02CS(10) / -.0000000000 3149915E0 / - DATA AI02CS(11) / -.0000000000 1321580E0 / - DATA AI02CS(12) / -.0000000000 0179419E0 / - DATA AI02CS(13) / .0000000000 0071801E0 / - DATA AI02CS(14) / .0000000000 0038529E0 / - DATA AI02CS(15) / .0000000000 0001539E0 / - DATA AI02CS(16) / -.0000000000 0004151E0 / - DATA AI02CS(17) / -.0000000000 0000954E0 / - DATA AI02CS(18) / .0000000000 0000382E0 / - DATA AI02CS(19) / .0000000000 0000176E0 / - DATA AI02CS(20) / -.0000000000 0000034E0 / - DATA AI02CS(21) / -.0000000000 0000027E0 / - DATA AI02CS(22) / .0000000000 0000003E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT BESI0E - IF (FIRST) THEN - NTI0 = INITS (BI0CS, 12, 0.1*R1MACH(3)) - NTAI0 = INITS (AI0CS, 21, 0.1*R1MACH(3)) - NTAI02 = INITS (AI02CS, 22, 0.1*R1MACH(3)) - XSML = SQRT (4.5*R1MACH(3)) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.3.0) GO TO 20 -C - BESI0E = 1.0 - X - IF (Y.GT.XSML) BESI0E = EXP(-Y) * ( 2.75 + - 1 CSEVL (Y*Y/4.5-1.0, BI0CS, NTI0) ) - RETURN -C - 20 IF (Y.LE.8.) BESI0E = (.375 + CSEVL ((48./Y-11.)/5., AI0CS, NTAI0) - 1 ) / SQRT(Y) - IF (Y.GT.8.) BESI0E = (.375 + CSEVL (16./Y-1., AI02CS, NTAI02)) - 1 / SQRT(Y) -C - RETURN - END diff --git a/slatec/besi1.f b/slatec/besi1.f deleted file mode 100644 index b30475d..0000000 --- a/slatec/besi1.f +++ /dev/null @@ -1,76 +0,0 @@ -*DECK BESI1 - FUNCTION BESI1 (X) -C***BEGIN PROLOGUE BESI1 -C***PURPOSE Compute the modified (hyperbolic) Bessel function of the -C first kind of order one. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10B1 -C***TYPE SINGLE PRECISION (BESI1-S, DBESI1-D) -C***KEYWORDS FIRST KIND, FNLIB, HYPERBOLIC BESSEL FUNCTION, -C MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C BESI1(X) calculates the modified (hyperbolic) Bessel function -C of the first kind of order one for real argument X. -C -C Series for BI1 on the interval 0. to 9.00000D+00 -C with weighted error 2.40E-17 -C log weighted error 16.62 -C significant figures required 16.23 -C decimal places required 17.14 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED BESI1E, CSEVL, INITS, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE BESI1 - DIMENSION BI1CS(11) - LOGICAL FIRST - SAVE BI1CS, NTI1, XMIN, XSML, XMAX, FIRST - DATA BI1CS( 1) / -.0019717132 61099859E0 / - DATA BI1CS( 2) / .4073488766 7546481E0 / - DATA BI1CS( 3) / .0348389942 99959456E0 / - DATA BI1CS( 4) / .0015453945 56300123E0 / - DATA BI1CS( 5) / .0000418885 21098377E0 / - DATA BI1CS( 6) / .0000007649 02676483E0 / - DATA BI1CS( 7) / .0000000100 42493924E0 / - DATA BI1CS( 8) / .0000000000 99322077E0 / - DATA BI1CS( 9) / .0000000000 00766380E0 / - DATA BI1CS(10) / .0000000000 00004741E0 / - DATA BI1CS(11) / .0000000000 00000024E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT BESI1 - IF (FIRST) THEN - NTI1 = INITS (BI1CS, 11, 0.1*R1MACH(3)) - XMIN = 2.0*R1MACH(1) - XSML = SQRT (4.5*R1MACH(3)) - XMAX = LOG (R1MACH(2)) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.3.0) GO TO 20 -C - BESI1 = 0.0 - IF (Y.EQ.0.0) RETURN -C - IF (Y .LE. XMIN) CALL XERMSG ('SLATEC', 'BESI1', - + 'ABS(X) SO SMALL I1 UNDERFLOWS', 1, 1) - IF (Y.GT.XMIN) BESI1 = 0.5*X - IF (Y.GT.XSML) BESI1 = X * (.875 + CSEVL(Y*Y/4.5-1., BI1CS, NTI1)) - RETURN -C - 20 IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'BESI1', - + 'ABS(X) SO BIG I1 OVERFLOWS', 2, 2) -C - BESI1 = EXP(Y) * BESI1E(X) -C - RETURN - END diff --git a/slatec/besi1e.f b/slatec/besi1e.f deleted file mode 100644 index 3b67844..0000000 --- a/slatec/besi1e.f +++ /dev/null @@ -1,137 +0,0 @@ -*DECK BESI1E - FUNCTION BESI1E (X) -C***BEGIN PROLOGUE BESI1E -C***PURPOSE Compute the exponentially scaled modified (hyperbolic) -C Bessel function of the first kind of order one. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10B1 -C***TYPE SINGLE PRECISION (BESI1E-S, DBSI1E-D) -C***KEYWORDS EXPONENTIALLY SCALED, FIRST KIND, FNLIB, -C HYPERBOLIC BESSEL FUNCTION, MODIFIED BESSEL FUNCTION, -C ORDER ONE, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C BESI1E(X) calculates the exponentially scaled modified (hyperbolic) -C Bessel function of the first kind of order one for real argument X; -C i.e., EXP(-ABS(X))*I1(X). -C -C Series for BI1 on the interval 0. to 9.00000D+00 -C with weighted error 2.40E-17 -C log weighted error 16.62 -C significant figures required 16.23 -C decimal places required 17.14 -C -C Series for AI1 on the interval 1.25000D-01 to 3.33333D-01 -C with weighted error 6.98E-17 -C log weighted error 16.16 -C significant figures required 14.53 -C decimal places required 16.82 -C -C Series for AI12 on the interval 0. to 1.25000D-01 -C with weighted error 3.55E-17 -C log weighted error 16.45 -C significant figures required 14.69 -C decimal places required 17.12 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 DATE WRITTEN -C 890210 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920618 Removed space from variable names. (RWC, WRB) -C***END PROLOGUE BESI1E - DIMENSION BI1CS(11), AI1CS(21), AI12CS(22) - LOGICAL FIRST - SAVE BI1CS, AI1CS, AI12CS, NTI1, NTAI1, NTAI12, XMIN, XSML, FIRST - DATA BI1CS( 1) / -.0019717132 61099859E0 / - DATA BI1CS( 2) / .4073488766 7546481E0 / - DATA BI1CS( 3) / .0348389942 99959456E0 / - DATA BI1CS( 4) / .0015453945 56300123E0 / - DATA BI1CS( 5) / .0000418885 21098377E0 / - DATA BI1CS( 6) / .0000007649 02676483E0 / - DATA BI1CS( 7) / .0000000100 42493924E0 / - DATA BI1CS( 8) / .0000000000 99322077E0 / - DATA BI1CS( 9) / .0000000000 00766380E0 / - DATA BI1CS(10) / .0000000000 00004741E0 / - DATA BI1CS(11) / .0000000000 00000024E0 / - DATA AI1CS( 1) / -.0284674418 1881479E0 / - DATA AI1CS( 2) / -.0192295323 1443221E0 / - DATA AI1CS( 3) / -.0006115185 8579437E0 / - DATA AI1CS( 4) / -.0000206997 1253350E0 / - DATA AI1CS( 5) / .0000085856 1914581E0 / - DATA AI1CS( 6) / .0000010494 9824671E0 / - DATA AI1CS( 7) / -.0000002918 3389184E0 / - DATA AI1CS( 8) / -.0000000155 9378146E0 / - DATA AI1CS( 9) / .0000000131 8012367E0 / - DATA AI1CS(10) / -.0000000014 4842341E0 / - DATA AI1CS(11) / -.0000000002 9085122E0 / - DATA AI1CS(12) / .0000000001 2663889E0 / - DATA AI1CS(13) / -.0000000000 1664947E0 / - DATA AI1CS(14) / -.0000000000 0166665E0 / - DATA AI1CS(15) / .0000000000 0124260E0 / - DATA AI1CS(16) / -.0000000000 0027315E0 / - DATA AI1CS(17) / .0000000000 0002023E0 / - DATA AI1CS(18) / .0000000000 0000730E0 / - DATA AI1CS(19) / -.0000000000 0000333E0 / - DATA AI1CS(20) / .0000000000 0000071E0 / - DATA AI1CS(21) / -.0000000000 0000006E0 / - DATA AI12CS( 1) / .0285762350 1828014E0 / - DATA AI12CS( 2) / -.0097610974 9136147E0 / - DATA AI12CS( 3) / -.0001105889 3876263E0 / - DATA AI12CS( 4) / -.0000038825 6480887E0 / - DATA AI12CS( 5) / -.0000002512 2362377E0 / - DATA AI12CS( 6) / -.0000000263 1468847E0 / - DATA AI12CS( 7) / -.0000000038 3538039E0 / - DATA AI12CS( 8) / -.0000000005 5897433E0 / - DATA AI12CS( 9) / -.0000000000 1897495E0 / - DATA AI12CS(10) / .0000000000 3252602E0 / - DATA AI12CS(11) / .0000000000 1412580E0 / - DATA AI12CS(12) / .0000000000 0203564E0 / - DATA AI12CS(13) / -.0000000000 0071985E0 / - DATA AI12CS(14) / -.0000000000 0040836E0 / - DATA AI12CS(15) / -.0000000000 0002101E0 / - DATA AI12CS(16) / .0000000000 0004273E0 / - DATA AI12CS(17) / .0000000000 0001041E0 / - DATA AI12CS(18) / -.0000000000 0000382E0 / - DATA AI12CS(19) / -.0000000000 0000186E0 / - DATA AI12CS(20) / .0000000000 0000033E0 / - DATA AI12CS(21) / .0000000000 0000028E0 / - DATA AI12CS(22) / -.0000000000 0000003E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT BESI1E - IF (FIRST) THEN - NTI1 = INITS (BI1CS, 11, 0.1*R1MACH(3)) - NTAI1 = INITS (AI1CS, 21, 0.1*R1MACH(3)) - NTAI12 = INITS (AI12CS, 22, 0.1*R1MACH(3)) -C - XMIN = 2.0*R1MACH(1) - XSML = SQRT (4.5*R1MACH(3)) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.3.0) GO TO 20 -C - BESI1E = 0.0 - IF (Y.EQ.0.0) RETURN -C - IF (Y .LE. XMIN) CALL XERMSG ('SLATEC', 'BESI1E', - + 'ABS(X) SO SMALL I1 UNDERFLOWS', 1, 1) - IF (Y.GT.XMIN) BESI1E = 0.5*X - IF (Y.GT.XSML) BESI1E = X * (.875 + CSEVL(Y*Y/4.5-1., BI1CS,NTI1)) - BESI1E = EXP(-Y) * BESI1E - RETURN -C - 20 IF (Y.LE.8.) BESI1E = (.375 + CSEVL ((48./Y-11.)/5., AI1CS, NTAI1) - 1 ) / SQRT(Y) - IF (Y.GT.8.) BESI1E = (.375 + CSEVL (16./Y-1.0, AI12CS, NTAI12)) - 1 / SQRT(Y) - BESI1E = SIGN (BESI1E, X) -C - RETURN - END diff --git a/slatec/besj.f b/slatec/besj.f deleted file mode 100644 index 712fc5b..0000000 --- a/slatec/besj.f +++ /dev/null @@ -1,504 +0,0 @@ -*DECK BESJ - SUBROUTINE BESJ (X, ALPHA, N, Y, NZ) -C***BEGIN PROLOGUE BESJ -C***PURPOSE Compute an N member sequence of J Bessel functions -C J/SUB(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA -C and X. -C***LIBRARY SLATEC -C***CATEGORY C10A3 -C***TYPE SINGLE PRECISION (BESJ-S, DBESJ-D) -C***KEYWORDS J BESSEL FUNCTION, SPECIAL FUNCTIONS -C***AUTHOR Amos, D. E., (SNLA) -C Daniel, S. L., (SNLA) -C Weston, M. K., (SNLA) -C***DESCRIPTION -C -C Abstract -C BESJ computes an N member sequence of J Bessel functions -C J/sub(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA and X. -C A combination of the power series, the asymptotic expansion -C for X to infinity and the uniform asymptotic expansion for -C NU to infinity are applied over subdivisions of the (NU,X) -C plane. For values of (NU,X) not covered by one of these -C formulae, the order is incremented or decremented by integer -C values into a region where one of the formulae apply. Backward -C recursion is applied to reduce orders by integer values except -C where the entire sequence lies in the oscillatory region. In -C this case forward recursion is stable and values from the -C asymptotic expansion for X to infinity start the recursion -C when it is efficient to do so. Leading terms of the series -C and uniform expansion are tested for underflow. If a sequence -C is requested and the last member would underflow, the result -C is set to zero and the next lower order tried, etc., until a -C member comes on scale or all members are set to zero. -C Overflow cannot occur. -C -C Description of Arguments -C -C Input -C X - X .GE. 0.0E0 -C ALPHA - order of first member of the sequence, -C ALPHA .GE. 0.0E0 -C N - number of members in the sequence, N .GE. 1 -C -C Output -C Y - a vector whose first N components contain -C values for J/sub(ALPHA+K-1)/(X), K=1,...,N -C NZ - number of components of Y set to zero due to -C underflow, -C NZ=0 , normal return, computation completed -C NZ .NE. 0, last NZ components of Y set to zero, -C Y(K)=0.0E0, K=N-NZ+1,...,N. -C -C Error Conditions -C Improper input arguments - a fatal error -C Underflow - a non-fatal error (NZ .NE. 0) -C -C***REFERENCES D. E. Amos, S. L. Daniel and M. K. Weston, CDC 6600 -C subroutines IBESS and JBESS for Bessel functions -C I(NU,X) and J(NU,X), X .GE. 0, NU .GE. 0, ACM -C Transactions on Mathematical Software 3, (1977), -C pp. 76-92. -C F. W. J. Olver, Tables of Bessel Functions of Moderate -C or Large Orders, NPL Mathematical Tables 6, Her -C Majesty's Stationery Office, London, 1962. -C***ROUTINES CALLED ALNGAM, ASYJY, I1MACH, JAIRY, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 750101 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE BESJ - EXTERNAL JAIRY - INTEGER I,IALP,IDALP,IFLW,IN,INLIM,IS,I1,I2,K,KK,KM,KT,N,NN, - 1 NS,NZ - INTEGER I1MACH - REAL AK,AKM,ALPHA,ANS,AP,ARG,COEF,DALPHA,DFN,DTM,EARG, - 1 ELIM1,ETX,FIDAL,FLGJY,FN,FNF,FNI,FNP1,FNU,FNULIM, - 2 GLN,PDF,PIDT,PP,RDEN,RELB,RTTP,RTWO,RTX,RZDEN, - 3 S,SA,SB,SXO2,S1,S2,T,TA,TAU,TB,TEMP,TFN,TM,TOL, - 4 TOLLN,TRX,TX,T1,T2,WK,X,XO2,XO2L,Y,RTOL,SLIM - SAVE RTWO, PDF, RTTP, PIDT, PP, INLIM, FNULIM - REAL R1MACH, ALNGAM - DIMENSION Y(*), TEMP(3), FNULIM(2), PP(4), WK(7) - DATA RTWO,PDF,RTTP,PIDT / 1.34839972492648E+00, - 1 7.85398163397448E-01, 7.97884560802865E-01, 1.57079632679490E+00/ - DATA PP(1), PP(2), PP(3), PP(4) / 8.72909153935547E+00, - 1 2.65693932265030E-01, 1.24578576865586E-01, 7.70133747430388E-04/ - DATA INLIM / 150 / - DATA FNULIM(1), FNULIM(2) / 100.0E0, 60.0E0 / -C***FIRST EXECUTABLE STATEMENT BESJ - NZ = 0 - KT = 1 - NS=0 -C I1MACH(14) REPLACES I1MACH(11) IN A DOUBLE PRECISION CODE -C I1MACH(15) REPLACES I1MACH(12) IN A DOUBLE PRECISION CODE - TA = R1MACH(3) - TOL = MAX(TA,1.0E-15) - I1 = I1MACH(11) + 1 - I2 = I1MACH(12) - TB = R1MACH(5) - ELIM1 = -2.303E0*(I2*TB+3.0E0) - RTOL=1.0E0/TOL - SLIM=R1MACH(1)*1.0E+3*RTOL -C TOLLN = -LN(TOL) - TOLLN = 2.303E0*TB*I1 - TOLLN = MIN(TOLLN,34.5388E0) - IF (N-1) 720, 10, 20 - 10 KT = 2 - 20 NN = N - IF (X) 730, 30, 80 - 30 IF (ALPHA) 710, 40, 50 - 40 Y(1) = 1.0E0 - IF (N.EQ.1) RETURN - I1 = 2 - GO TO 60 - 50 I1 = 1 - 60 DO 70 I=I1,N - Y(I) = 0.0E0 - 70 CONTINUE - RETURN - 80 CONTINUE - IF (ALPHA.LT.0.0E0) GO TO 710 -C - IALP = INT(ALPHA) - FNI = IALP + N - 1 - FNF = ALPHA - IALP - DFN = FNI + FNF - FNU = DFN - XO2 = X*0.5E0 - SXO2 = XO2*XO2 -C -C DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X -C TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE -C APPLIED. -C - IF (SXO2.LE.(FNU+1.0E0)) GO TO 90 - TA = MAX(20.0E0,FNU) - IF (X.GT.TA) GO TO 120 - IF (X.GT.12.0E0) GO TO 110 - XO2L = LOG(XO2) - NS = INT(SXO2-FNU) + 1 - GO TO 100 - 90 FN = FNU - FNP1 = FN + 1.0E0 - XO2L = LOG(XO2) - IS = KT - IF (X.LE.0.50E0) GO TO 330 - NS = 0 - 100 FNI = FNI + NS - DFN = FNI + FNF - FN = DFN - FNP1 = FN + 1.0E0 - IS = KT - IF (N-1+NS.GT.0) IS = 3 - GO TO 330 - 110 ANS = MAX(36.0E0-FNU,0.0E0) - NS = INT(ANS) - FNI = FNI + NS - DFN = FNI + FNF - FN = DFN - IS = KT - IF (N-1+NS.GT.0) IS = 3 - GO TO 130 - 120 CONTINUE - RTX = SQRT(X) - TAU = RTWO*RTX - TA = TAU + FNULIM(KT) - IF (FNU.LE.TA) GO TO 480 - FN = FNU - IS = KT -C -C UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY -C - 130 CONTINUE - I1 = ABS(3-IS) - I1 = MAX(I1,1) - FLGJY = 1.0E0 - CALL ASYJY(JAIRY,X,FN,FLGJY,I1,TEMP(IS),WK,IFLW) - IF(IFLW.NE.0) GO TO 380 - GO TO (320, 450, 620), IS - 310 TEMP(1) = TEMP(3) - KT = 1 - 320 IS = 2 - FNI = FNI - 1.0E0 - DFN = FNI + FNF - FN = DFN - IF(I1.EQ.2) GO TO 450 - GO TO 130 -C -C SERIES FOR (X/2)**2.LE.NU+1 -C - 330 CONTINUE - GLN = ALNGAM(FNP1) - ARG = FN*XO2L - GLN - IF (ARG.LT.(-ELIM1)) GO TO 400 - EARG = EXP(ARG) - 340 CONTINUE - S = 1.0E0 - IF (X.LT.TOL) GO TO 360 - AK = 3.0E0 - T2 = 1.0E0 - T = 1.0E0 - S1 = FN - DO 350 K=1,17 - S2 = T2 + S1 - T = -T*SXO2/S2 - S = S + T - IF (ABS(T).LT.TOL) GO TO 360 - T2 = T2 + AK - AK = AK + 2.0E0 - S1 = S1 + FN - 350 CONTINUE - 360 CONTINUE - TEMP(IS) = S*EARG - GO TO (370, 450, 610), IS - 370 EARG = EARG*FN/XO2 - FNI = FNI - 1.0E0 - DFN = FNI + FNF - FN = DFN - IS = 2 - GO TO 340 -C -C SET UNDERFLOW VALUE AND UPDATE PARAMETERS -C UNDERFLOW CAN ONLY OCCUR FOR NS=0 SINCE THE ORDER MUST BE -C LARGER THAN 36. THEREFORE, NS NEED NOT BE CONSIDERED. -C - 380 Y(NN) = 0.0E0 - NN = NN - 1 - FNI = FNI - 1.0E0 - DFN = FNI + FNF - FN = DFN - IF (NN-1) 440, 390, 130 - 390 KT = 2 - IS = 2 - GO TO 130 - 400 Y(NN) = 0.0E0 - NN = NN - 1 - FNP1 = FN - FNI = FNI - 1.0E0 - DFN = FNI + FNF - FN = DFN - IF (NN-1) 440, 410, 420 - 410 KT = 2 - IS = 2 - 420 IF (SXO2.LE.FNP1) GO TO 430 - GO TO 130 - 430 ARG = ARG - XO2L + LOG(FNP1) - IF (ARG.LT.(-ELIM1)) GO TO 400 - GO TO 330 - 440 NZ = N - NN - RETURN -C -C BACKWARD RECURSION SECTION -C - 450 CONTINUE - IF(NS.NE.0) GO TO 451 - NZ = N - NN - IF (KT.EQ.2) GO TO 470 -C BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA - Y(NN) = TEMP(1) - Y(NN-1) = TEMP(2) - IF (NN.EQ.2) RETURN - 451 CONTINUE - TRX = 2.0E0/X - DTM = FNI - TM = (DTM+FNF)*TRX - AK=1.0E0 - TA=TEMP(1) - TB=TEMP(2) - IF(ABS(TA).GT.SLIM) GO TO 455 - TA=TA*RTOL - TB=TB*RTOL - AK=TOL - 455 CONTINUE - KK=2 - IN=NS-1 - IF(IN.EQ.0) GO TO 690 - IF(NS.NE.0) GO TO 670 - K=NN-2 - DO 460 I=3,NN - S=TB - TB=TM*TB-TA - TA=S - Y(K)=TB*AK - K=K-1 - DTM = DTM - 1.0E0 - TM = (DTM+FNF)*TRX - 460 CONTINUE - RETURN - 470 Y(1) = TEMP(2) - RETURN -C -C ASYMPTOTIC EXPANSION FOR X TO INFINITY WITH FORWARD RECURSION IN -C OSCILLATORY REGION X.GT.MAX(20, NU), PROVIDED THE LAST MEMBER -C OF THE SEQUENCE IS ALSO IN THE REGION. -C - 480 CONTINUE - IN = INT(ALPHA-TAU+2.0E0) - IF (IN.LE.0) GO TO 490 - IDALP = IALP - IN - 1 - KT = 1 - GO TO 500 - 490 CONTINUE - IDALP = IALP - IN = 0 - 500 IS = KT - FIDAL = IDALP - DALPHA = FIDAL + FNF - ARG = X - PIDT*DALPHA - PDF - SA = SIN(ARG) - SB = COS(ARG) - COEF = RTTP/RTX - ETX = 8.0E0*X - 510 CONTINUE - DTM = FIDAL + FIDAL - DTM = DTM*DTM - TM = 0.0E0 - IF (FIDAL.EQ.0.0E0 .AND. ABS(FNF).LT.TOL) GO TO 520 - TM = 4.0E0*FNF*(FIDAL+FIDAL+FNF) - 520 CONTINUE - TRX = DTM - 1.0E0 - T2 = (TRX+TM)/ETX - S2 = T2 - RELB = TOL*ABS(T2) - T1 = ETX - S1 = 1.0E0 - FN = 1.0E0 - AK = 8.0E0 - DO 530 K=1,13 - T1 = T1 + ETX - FN = FN + AK - TRX = DTM - FN - AP = TRX + TM - T2 = -T2*AP/T1 - S1 = S1 + T2 - T1 = T1 + ETX - AK = AK + 8.0E0 - FN = FN + AK - TRX = DTM - FN - AP = TRX + TM - T2 = T2*AP/T1 - S2 = S2 + T2 - IF (ABS(T2).LE.RELB) GO TO 540 - AK = AK + 8.0E0 - 530 CONTINUE - 540 TEMP(IS) = COEF*(S1*SB-S2*SA) - IF(IS.EQ.2) GO TO 560 - FIDAL = FIDAL + 1.0E0 - DALPHA = FIDAL + FNF - IS = 2 - TB = SA - SA = -SB - SB = TB - GO TO 510 -C -C FORWARD RECURSION SECTION -C - 560 IF (KT.EQ.2) GO TO 470 - S1 = TEMP(1) - S2 = TEMP(2) - TX = 2.0E0/X - TM = DALPHA*TX - IF (IN.EQ.0) GO TO 580 -C -C FORWARD RECUR TO INDEX ALPHA -C - DO 570 I=1,IN - S = S2 - S2 = TM*S2 - S1 - TM = TM + TX - S1 = S - 570 CONTINUE - IF (NN.EQ.1) GO TO 600 - S = S2 - S2 = TM*S2 - S1 - TM = TM + TX - S1 = S - 580 CONTINUE -C -C FORWARD RECUR FROM INDEX ALPHA TO ALPHA+N-1 -C - Y(1) = S1 - Y(2) = S2 - IF (NN.EQ.2) RETURN - DO 590 I=3,NN - Y(I) = TM*Y(I-1) - Y(I-2) - TM = TM + TX - 590 CONTINUE - RETURN - 600 Y(1) = S2 - RETURN -C -C BACKWARD RECURSION WITH NORMALIZATION BY -C ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES. -C - 610 CONTINUE -C COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION - AKM = MAX(3.0E0-FN,0.0E0) - KM = INT(AKM) - TFN = FN + KM - TA = (GLN+TFN-0.9189385332E0-0.0833333333E0/TFN)/(TFN+0.5E0) - TA = XO2L - TA - TB = -(1.0E0-1.5E0/TFN)/TFN - AKM = TOLLN/(-TA+SQRT(TA*TA-TOLLN*TB)) + 1.5E0 - IN = KM + INT(AKM) - GO TO 660 - 620 CONTINUE -C COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION - GLN = WK(3) + WK(2) - IF (WK(6).GT.30.0E0) GO TO 640 - RDEN = (PP(4)*WK(6)+PP(3))*WK(6) + 1.0E0 - RZDEN = PP(1) + PP(2)*WK(6) - TA = RZDEN/RDEN - IF (WK(1).LT.0.10E0) GO TO 630 - TB = GLN/WK(5) - GO TO 650 - 630 TB=(1.259921049E0+(0.1679894730E0+0.0887944358E0*WK(1))*WK(1)) - 1 /WK(7) - GO TO 650 - 640 CONTINUE - TA = 0.5E0*TOLLN/WK(4) - TA=((0.0493827160E0*TA-0.1111111111E0)*TA+0.6666666667E0)*TA*WK(6) - IF (WK(1).LT.0.10E0) GO TO 630 - TB = GLN/WK(5) - 650 IN = INT(TA/TB+1.5E0) - IF (IN.GT.INLIM) GO TO 310 - 660 CONTINUE - DTM = FNI + IN - TRX = 2.0E0/X - TM = (DTM+FNF)*TRX - TA = 0.0E0 - TB = TOL - KK = 1 - AK=1.0E0 - 670 CONTINUE -C -C BACKWARD RECUR UNINDEXED AND SCALE WHEN MAGNITUDES ARE CLOSE TO -C UNDERFLOW LIMITS (LESS THAN SLIM=R1MACH(1)*1.0E+3/TOL) -C - DO 680 I=1,IN - S = TB - TB = TM*TB - TA - TA = S - DTM = DTM - 1.0E0 - TM = (DTM+FNF)*TRX - 680 CONTINUE -C NORMALIZATION - IF (KK.NE.1) GO TO 690 - S=TEMP(3) - SA=TA/TB - TA=S - TB=S - IF(ABS(S).GT.SLIM) GO TO 685 - TA=TA*RTOL - TB=TB*RTOL - AK=TOL - 685 CONTINUE - TA=TA*SA - KK = 2 - IN = NS - IF (NS.NE.0) GO TO 670 - 690 Y(NN) = TB*AK - NZ = N - NN - IF (NN.EQ.1) RETURN - K = NN - 1 - S=TB - TB = TM*TB - TA - TA=S - Y(K)=TB*AK - IF (NN.EQ.2) RETURN - DTM = DTM - 1.0E0 - TM = (DTM+FNF)*TRX - K=NN-2 -C -C BACKWARD RECUR INDEXED -C - DO 700 I=3,NN - S=TB - TB = TM*TB - TA - TA=S - Y(K)=TB*AK - DTM = DTM - 1.0E0 - TM = (DTM+FNF)*TRX - K = K - 1 - 700 CONTINUE - RETURN -C -C -C - 710 CONTINUE - CALL XERMSG ('SLATEC', 'BESJ', 'ORDER, ALPHA, LESS THAN ZERO.', - + 2, 1) - RETURN - 720 CONTINUE - CALL XERMSG ('SLATEC', 'BESJ', 'N LESS THAN ONE.', 2, 1) - RETURN - 730 CONTINUE - CALL XERMSG ('SLATEC', 'BESJ', 'X LESS THAN ZERO.', 2, 1) - RETURN - END diff --git a/slatec/besj0.f b/slatec/besj0.f deleted file mode 100644 index 0b4d642..0000000 --- a/slatec/besj0.f +++ /dev/null @@ -1,136 +0,0 @@ -*DECK BESJ0 - FUNCTION BESJ0 (X) -C***BEGIN PROLOGUE BESJ0 -C***PURPOSE Compute the Bessel function of the first kind of order -C zero. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10A1 -C***TYPE SINGLE PRECISION (BESJ0-S, DBESJ0-D) -C***KEYWORDS BESSEL FUNCTION, FIRST KIND, FNLIB, ORDER ZERO, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C BESJ0(X) calculates the Bessel function of the first kind of -C order zero for real argument X. -C -C Series for BJ0 on the interval 0. to 1.60000D+01 -C with weighted error 7.47E-18 -C log weighted error 17.13 -C significant figures required 16.98 -C decimal places required 17.68 -C -C Series for BM0 on the interval 0. to 6.25000D-02 -C with weighted error 4.98E-17 -C log weighted error 16.30 -C significant figures required 14.97 -C decimal places required 16.96 -C -C Series for BTH0 on the interval 0. to 6.25000D-02 -C with weighted error 3.67E-17 -C log weighted error 16.44 -C significant figures required 15.53 -C decimal places required 17.13 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 DATE WRITTEN -C 890210 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE BESJ0 - DIMENSION BJ0CS(13), BM0CS(21), BTH0CS(24) - LOGICAL FIRST - SAVE BJ0CS, BM0CS, BTH0CS, PI4, NTJ0, NTM0, NTTH0, XSML, XMAX, - 1 FIRST - DATA BJ0CS( 1) / .1002541619 68939137E0 / - DATA BJ0CS( 2) / -.6652230077 64405132E0 / - DATA BJ0CS( 3) / .2489837034 98281314E0 / - DATA BJ0CS( 4) / -.0332527231 700357697E0 / - DATA BJ0CS( 5) / .0023114179 304694015E0 / - DATA BJ0CS( 6) / -.0000991127 741995080E0 / - DATA BJ0CS( 7) / .0000028916 708643998E0 / - DATA BJ0CS( 8) / -.0000000612 108586630E0 / - DATA BJ0CS( 9) / .0000000009 838650793E0 / - DATA BJ0CS(10) / -.0000000000 124235515E0 / - DATA BJ0CS(11) / .0000000000 001265433E0 / - DATA BJ0CS(12) / -.0000000000 000010619E0 / - DATA BJ0CS(13) / .0000000000 000000074E0 / - DATA BM0CS( 1) / .0928496163 7381644E0 / - DATA BM0CS( 2) / -.0014298770 7403484E0 / - DATA BM0CS( 3) / .0000283057 9271257E0 / - DATA BM0CS( 4) / -.0000014330 0611424E0 / - DATA BM0CS( 5) / .0000001202 8628046E0 / - DATA BM0CS( 6) / -.0000000139 7113013E0 / - DATA BM0CS( 7) / .0000000020 4076188E0 / - DATA BM0CS( 8) / -.0000000003 5399669E0 / - DATA BM0CS( 9) / .0000000000 7024759E0 / - DATA BM0CS(10) / -.0000000000 1554107E0 / - DATA BM0CS(11) / .0000000000 0376226E0 / - DATA BM0CS(12) / -.0000000000 0098282E0 / - DATA BM0CS(13) / .0000000000 0027408E0 / - DATA BM0CS(14) / -.0000000000 0008091E0 / - DATA BM0CS(15) / .0000000000 0002511E0 / - DATA BM0CS(16) / -.0000000000 0000814E0 / - DATA BM0CS(17) / .0000000000 0000275E0 / - DATA BM0CS(18) / -.0000000000 0000096E0 / - DATA BM0CS(19) / .0000000000 0000034E0 / - DATA BM0CS(20) / -.0000000000 0000012E0 / - DATA BM0CS(21) / .0000000000 0000004E0 / - DATA BTH0CS( 1) / -.2463916377 4300119E0 / - DATA BTH0CS( 2) / .0017370983 07508963E0 / - DATA BTH0CS( 3) / -.0000621836 33402968E0 / - DATA BTH0CS( 4) / .0000043680 50165742E0 / - DATA BTH0CS( 5) / -.0000004560 93019869E0 / - DATA BTH0CS( 6) / .0000000621 97400101E0 / - DATA BTH0CS( 7) / -.0000000103 00442889E0 / - DATA BTH0CS( 8) / .0000000019 79526776E0 / - DATA BTH0CS( 9) / -.0000000004 28198396E0 / - DATA BTH0CS(10) / .0000000001 02035840E0 / - DATA BTH0CS(11) / -.0000000000 26363898E0 / - DATA BTH0CS(12) / .0000000000 07297935E0 / - DATA BTH0CS(13) / -.0000000000 02144188E0 / - DATA BTH0CS(14) / .0000000000 00663693E0 / - DATA BTH0CS(15) / -.0000000000 00215126E0 / - DATA BTH0CS(16) / .0000000000 00072659E0 / - DATA BTH0CS(17) / -.0000000000 00025465E0 / - DATA BTH0CS(18) / .0000000000 00009229E0 / - DATA BTH0CS(19) / -.0000000000 00003448E0 / - DATA BTH0CS(20) / .0000000000 00001325E0 / - DATA BTH0CS(21) / -.0000000000 00000522E0 / - DATA BTH0CS(22) / .0000000000 00000210E0 / - DATA BTH0CS(23) / -.0000000000 00000087E0 / - DATA BTH0CS(24) / .0000000000 00000036E0 / - DATA PI4 / 0.7853981633 9744831E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT BESJ0 - IF (FIRST) THEN - NTJ0 = INITS (BJ0CS, 13, 0.1*R1MACH(3)) - NTM0 = INITS (BM0CS, 21, 0.1*R1MACH(3)) - NTTH0 = INITS (BTH0CS, 24, 0.1*R1MACH(3)) -C - XSML = SQRT (8.0*R1MACH(3)) - XMAX = 1.0/R1MACH(4) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.4.0) GO TO 20 -C - BESJ0 = 1.0 - IF (Y.GT.XSML) BESJ0 = CSEVL (.125*Y*Y-1., BJ0CS, NTJ0) - RETURN -C - 20 IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'BESJ0', - + 'NO PRECISION BECAUSE ABS(X) IS TOO BIG', 1, 2) -C - Z = 32.0/Y**2 - 1.0 - AMPL = (0.75 + CSEVL (Z, BM0CS, NTM0)) / SQRT(Y) - THETA = Y - PI4 + CSEVL (Z, BTH0CS, NTTH0) / Y - BESJ0 = AMPL * COS (THETA) -C - RETURN - END diff --git a/slatec/besj1.f b/slatec/besj1.f deleted file mode 100644 index 06c485a..0000000 --- a/slatec/besj1.f +++ /dev/null @@ -1,138 +0,0 @@ -*DECK BESJ1 - FUNCTION BESJ1 (X) -C***BEGIN PROLOGUE BESJ1 -C***PURPOSE Compute the Bessel function of the first kind of order one. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10A1 -C***TYPE SINGLE PRECISION (BESJ1-S, DBESJ1-D) -C***KEYWORDS BESSEL FUNCTION, FIRST KIND, FNLIB, ORDER ONE, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C BESJ1(X) calculates the Bessel function of the first kind of -C order one for real argument X. -C -C Series for BJ1 on the interval 0. to 1.60000D+01 -C with weighted error 4.48E-17 -C log weighted error 16.35 -C significant figures required 15.77 -C decimal places required 16.89 -C -C Series for BM1 on the interval 0. to 6.25000D-02 -C with weighted error 5.61E-17 -C log weighted error 16.25 -C significant figures required 14.97 -C decimal places required 16.91 -C -C Series for BTH1 on the interval 0. to 6.25000D-02 -C with weighted error 4.10E-17 -C log weighted error 16.39 -C significant figures required 15.96 -C decimal places required 17.08 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 780601 DATE WRITTEN -C 890210 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE BESJ1 - DIMENSION BJ1CS(12), BM1CS(21), BTH1CS(24) - LOGICAL FIRST - SAVE BJ1CS, BM1CS, BTH1CS, PI4, NTJ1, NTM1, NTTH1, - 1 XSML, XMIN, XMAX, FIRST - DATA BJ1CS( 1) / -.1172614151 3332787E0 / - DATA BJ1CS( 2) / -.2536152183 0790640E0 / - DATA BJ1CS( 3) / .0501270809 84469569E0 / - DATA BJ1CS( 4) / -.0046315148 09625081E0 / - DATA BJ1CS( 5) / .0002479962 29415914E0 / - DATA BJ1CS( 6) / -.0000086789 48686278E0 / - DATA BJ1CS( 7) / .0000002142 93917143E0 / - DATA BJ1CS( 8) / -.0000000039 36093079E0 / - DATA BJ1CS( 9) / .0000000000 55911823E0 / - DATA BJ1CS(10) / -.0000000000 00632761E0 / - DATA BJ1CS(11) / .0000000000 00005840E0 / - DATA BJ1CS(12) / -.0000000000 00000044E0 / - DATA BM1CS( 1) / .1047362510 931285E0 / - DATA BM1CS( 2) / .0044244389 3702345E0 / - DATA BM1CS( 3) / -.0000566163 9504035E0 / - DATA BM1CS( 4) / .0000023134 9417339E0 / - DATA BM1CS( 5) / -.0000001737 7182007E0 / - DATA BM1CS( 6) / .0000000189 3209930E0 / - DATA BM1CS( 7) / -.0000000026 5416023E0 / - DATA BM1CS( 8) / .0000000004 4740209E0 / - DATA BM1CS( 9) / -.0000000000 8691795E0 / - DATA BM1CS(10) / .0000000000 1891492E0 / - DATA BM1CS(11) / -.0000000000 0451884E0 / - DATA BM1CS(12) / .0000000000 0116765E0 / - DATA BM1CS(13) / -.0000000000 0032265E0 / - DATA BM1CS(14) / .0000000000 0009450E0 / - DATA BM1CS(15) / -.0000000000 0002913E0 / - DATA BM1CS(16) / .0000000000 0000939E0 / - DATA BM1CS(17) / -.0000000000 0000315E0 / - DATA BM1CS(18) / .0000000000 0000109E0 / - DATA BM1CS(19) / -.0000000000 0000039E0 / - DATA BM1CS(20) / .0000000000 0000014E0 / - DATA BM1CS(21) / -.0000000000 0000005E0 / - DATA BTH1CS( 1) / .7406014102 6313850E0 / - DATA BTH1CS( 2) / -.0045717556 59637690E0 / - DATA BTH1CS( 3) / .0001198185 10964326E0 / - DATA BTH1CS( 4) / -.0000069645 61891648E0 / - DATA BTH1CS( 5) / .0000006554 95621447E0 / - DATA BTH1CS( 6) / -.0000000840 66228945E0 / - DATA BTH1CS( 7) / .0000000133 76886564E0 / - DATA BTH1CS( 8) / -.0000000024 99565654E0 / - DATA BTH1CS( 9) / .0000000005 29495100E0 / - DATA BTH1CS(10) / -.0000000001 24135944E0 / - DATA BTH1CS(11) / .0000000000 31656485E0 / - DATA BTH1CS(12) / -.0000000000 08668640E0 / - DATA BTH1CS(13) / .0000000000 02523758E0 / - DATA BTH1CS(14) / -.0000000000 00775085E0 / - DATA BTH1CS(15) / .0000000000 00249527E0 / - DATA BTH1CS(16) / -.0000000000 00083773E0 / - DATA BTH1CS(17) / .0000000000 00029205E0 / - DATA BTH1CS(18) / -.0000000000 00010534E0 / - DATA BTH1CS(19) / .0000000000 00003919E0 / - DATA BTH1CS(20) / -.0000000000 00001500E0 / - DATA BTH1CS(21) / .0000000000 00000589E0 / - DATA BTH1CS(22) / -.0000000000 00000237E0 / - DATA BTH1CS(23) / .0000000000 00000097E0 / - DATA BTH1CS(24) / -.0000000000 00000040E0 / - DATA PI4 / 0.7853981633 9744831E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT BESJ1 - IF (FIRST) THEN - NTJ1 = INITS (BJ1CS, 12, 0.1*R1MACH(3)) - NTM1 = INITS (BM1CS, 21, 0.1*R1MACH(3)) - NTTH1 = INITS (BTH1CS, 24, 0.1*R1MACH(3)) -C - XSML = SQRT (8.0*R1MACH(3)) - XMIN = 2.0*R1MACH(1) - XMAX = 1.0/R1MACH(4) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.4.0) GO TO 20 -C - BESJ1 = 0. - IF (Y.EQ.0.0) RETURN - IF (Y .LE. XMIN) CALL XERMSG ('SLATEC', 'BESJ1', - + 'ABS(X) SO SMALL J1 UNDERFLOWS', 1, 1) - IF (Y.GT.XMIN) BESJ1 = 0.5*X - IF (Y.GT.XSML) BESJ1 = X * (.25 + CSEVL(.125*Y*Y-1., BJ1CS, NTJ1)) - RETURN -C - 20 IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'BESJ1', - + 'NO PRECISION BECAUSE ABS(X) IS TOO BIG', 2, 2) - Z = 32.0/Y**2 - 1.0 - AMPL = (0.75 + CSEVL (Z, BM1CS, NTM1)) / SQRT(Y) - THETA = Y - 3.0*PI4 + CSEVL (Z, BTH1CS, NTTH1) / Y - BESJ1 = SIGN (AMPL, X) * COS (THETA) -C - RETURN - END diff --git a/slatec/besk.f b/slatec/besk.f deleted file mode 100644 index 9d12383..0000000 --- a/slatec/besk.f +++ /dev/null @@ -1,277 +0,0 @@ -*DECK BESK - SUBROUTINE BESK (X, FNU, KODE, N, Y, NZ) -C***BEGIN PROLOGUE BESK -C***PURPOSE Implement forward recursion on the three term recursion -C relation for a sequence of non-negative order Bessel -C functions K/SUB(FNU+I-1)/(X), or scaled Bessel functions -C EXP(X)*K/SUB(FNU+I-1)/(X), I=1,...,N for real, positive -C X and non-negative orders FNU. -C***LIBRARY SLATEC -C***CATEGORY C10B3 -C***TYPE SINGLE PRECISION (BESK-S, DBESK-D) -C***KEYWORDS K BESSEL FUNCTION, SPECIAL FUNCTIONS -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C BESK implements forward recursion on the three term -C recursion relation for a sequence of non-negative order Bessel -C functions K/sub(FNU+I-1)/(X), or scaled Bessel functions -C EXP(X)*K/sub(FNU+I-1)/(X), I=1,...,N for real X .GT. 0.0E0 and -C non-negative orders FNU. If FNU .LT. NULIM, orders FNU and -C FNU+1 are obtained from BESKNU to start the recursion. If -C FNU .GE. NULIM, the uniform asymptotic expansion is used for -C orders FNU and FNU+1 to start the recursion. NULIM is 35 or -C 70 depending on whether N=1 or N .GE. 2. Under and overflow -C tests are made on the leading term of the asymptotic expansion -C before any extensive computation is done. -C -C Description of Arguments -C -C Input -C X - X .GT. 0.0E0 -C FNU - order of the initial K function, FNU .GE. 0.0E0 -C KODE - a parameter to indicate the scaling option -C KODE=1 returns Y(I)= K/sub(FNU+I-1)/(X), -C I=1,...,N -C KODE=2 returns Y(I)=EXP(X)*K/sub(FNU+I-1)/(X), -C I=1,...,N -C N - number of members in the sequence, N .GE. 1 -C -C Output -C y - a vector whose first n components contain values -C for the sequence -C Y(I)= K/sub(FNU+I-1)/(X), I=1,...,N or -C Y(I)=EXP(X)*K/sub(FNU+I-1)/(X), I=1,...,N -C depending on KODE -C NZ - number of components of Y set to zero due to -C underflow with KODE=1, -C NZ=0 , normal return, computation completed -C NZ .NE. 0, first NZ components of Y set to zero -C due to underflow, Y(I)=0.0E0, I=1,...,NZ -C -C Error Conditions -C Improper input arguments - a fatal error -C Overflow - a fatal error -C Underflow with KODE=1 - a non-fatal error (NZ .NE. 0) -C -C***REFERENCES F. W. J. Olver, Tables of Bessel Functions of Moderate -C or Large Orders, NPL Mathematical Tables 6, Her -C Majesty's Stationery Office, London, 1962. -C N. M. Temme, On the numerical evaluation of the modified -C Bessel function of the third kind, Journal of -C Computational Physics 19, (1975), pp. 324-337. -C***ROUTINES CALLED ASYIK, BESK0, BESK0E, BESK1, BESK1E, BESKNU, -C I1MACH, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790201 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE BESK -C - INTEGER I, J, K, KODE, MZ, N, NB, ND, NN, NUD, NULIM, NZ - INTEGER I1MACH - REAL CN, DNU, ELIM, ETX, FLGIK,FN, FNN, FNU,GLN,GNU,RTZ,S,S1,S2, - 1 T, TM, TRX, W, X, XLIM, Y, ZN - REAL BESK0, BESK1, BESK1E, BESK0E, R1MACH - DIMENSION W(2), NULIM(2), Y(*) - SAVE NULIM - DATA NULIM(1),NULIM(2) / 35 , 70 / -C***FIRST EXECUTABLE STATEMENT BESK - NN = -I1MACH(12) - ELIM = 2.303E0*(NN*R1MACH(5)-3.0E0) - XLIM = R1MACH(1)*1.0E+3 - IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 280 - IF (FNU.LT.0.0E0) GO TO 290 - IF (X.LE.0.0E0) GO TO 300 - IF (X.LT.XLIM) GO TO 320 - IF (N.LT.1) GO TO 310 - ETX = KODE - 1 -C -C ND IS A DUMMY VARIABLE FOR N -C GNU IS A DUMMY VARIABLE FOR FNU -C NZ = NUMBER OF UNDERFLOWS ON KODE=1 -C - ND = N - NZ = 0 - NUD = INT(FNU) - DNU = FNU - NUD - GNU = FNU - NN = MIN(2,ND) - FN = FNU + N - 1 - FNN = FN - IF (FN.LT.2.0E0) GO TO 150 -C -C OVERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION) -C FOR THE LAST ORDER, FNU+N-1.GE.NULIM -C - ZN = X/FN - IF (ZN.EQ.0.0E0) GO TO 320 - RTZ = SQRT(1.0E0+ZN*ZN) - GLN = LOG((1.0E0+RTZ)/ZN) - T = RTZ*(1.0E0-ETX) + ETX/(ZN+RTZ) - CN = -FN*(T-GLN) - IF (CN.GT.ELIM) GO TO 320 - IF (NUD.LT.NULIM(NN)) GO TO 30 - IF (NN.EQ.1) GO TO 20 - 10 CONTINUE -C -C UNDERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION) -C FOR THE FIRST ORDER, FNU.GE.NULIM -C - FN = GNU - ZN = X/FN - RTZ = SQRT(1.0E0+ZN*ZN) - GLN = LOG((1.0E0+RTZ)/ZN) - T = RTZ*(1.0E0-ETX) + ETX/(ZN+RTZ) - CN = -FN*(T-GLN) - 20 CONTINUE - IF (CN.LT.-ELIM) GO TO 230 -C -C ASYMPTOTIC EXPANSION FOR ORDERS FNU AND FNU+1.GE.NULIM -C - FLGIK = -1.0E0 - CALL ASYIK(X,GNU,KODE,FLGIK,RTZ,CN,NN,Y) - IF (NN.EQ.1) GO TO 240 - TRX = 2.0E0/X - TM = (GNU+GNU+2.0E0)/X - GO TO 130 -C - 30 CONTINUE - IF (KODE.EQ.2) GO TO 40 -C -C UNDERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION IN X) -C FOR ORDER DNU -C - IF (X.GT.ELIM) GO TO 230 - 40 CONTINUE - IF (DNU.NE.0.0E0) GO TO 80 - IF (KODE.EQ.2) GO TO 50 - S1 = BESK0(X) - GO TO 60 - 50 S1 = BESK0E(X) - 60 CONTINUE - IF (NUD.EQ.0 .AND. ND.EQ.1) GO TO 120 - IF (KODE.EQ.2) GO TO 70 - S2 = BESK1(X) - GO TO 90 - 70 S2 = BESK1E(X) - GO TO 90 - 80 CONTINUE - NB = 2 - IF (NUD.EQ.0 .AND. ND.EQ.1) NB = 1 - CALL BESKNU(X, DNU, KODE, NB, W, NZ) - S1 = W(1) - IF (NB.EQ.1) GO TO 120 - S2 = W(2) - 90 CONTINUE - TRX = 2.0E0/X - TM = (DNU+DNU+2.0E0)/X -C FORWARD RECUR FROM DNU TO FNU+1 TO GET Y(1) AND Y(2) - IF (ND.EQ.1) NUD = NUD - 1 - IF (NUD.GT.0) GO TO 100 - IF (ND.GT.1) GO TO 120 - S1 = S2 - GO TO 120 - 100 CONTINUE - DO 110 I=1,NUD - S = S2 - S2 = TM*S2 + S1 - S1 = S - TM = TM + TRX - 110 CONTINUE - IF (ND.EQ.1) S1 = S2 - 120 CONTINUE - Y(1) = S1 - IF (ND.EQ.1) GO TO 240 - Y(2) = S2 - 130 CONTINUE - IF (ND.EQ.2) GO TO 240 -C FORWARD RECUR FROM FNU+2 TO FNU+N-1 - DO 140 I=3,ND - Y(I) = TM*Y(I-1) + Y(I-2) - TM = TM + TRX - 140 CONTINUE - GO TO 240 -C - 150 CONTINUE -C UNDERFLOW TEST FOR KODE=1 - IF (KODE.EQ.2) GO TO 160 - IF (X.GT.ELIM) GO TO 230 - 160 CONTINUE -C OVERFLOW TEST - IF (FN.LE.1.0E0) GO TO 170 - IF (-FN*(LOG(X)-0.693E0).GT.ELIM) GO TO 320 - 170 CONTINUE - IF (DNU.EQ.0.0E0) GO TO 180 - CALL BESKNU(X, FNU, KODE, ND, Y, MZ) - GO TO 240 - 180 CONTINUE - J = NUD - IF (J.EQ.1) GO TO 210 - J = J + 1 - IF (KODE.EQ.2) GO TO 190 - Y(J) = BESK0(X) - GO TO 200 - 190 Y(J) = BESK0E(X) - 200 IF (ND.EQ.1) GO TO 240 - J = J + 1 - 210 IF (KODE.EQ.2) GO TO 220 - Y(J) = BESK1(X) - GO TO 240 - 220 Y(J) = BESK1E(X) - GO TO 240 -C -C UPDATE PARAMETERS ON UNDERFLOW -C - 230 CONTINUE - NUD = NUD + 1 - ND = ND - 1 - IF (ND.EQ.0) GO TO 240 - NN = MIN(2,ND) - GNU = GNU + 1.0E0 - IF (FNN.LT.2.0E0) GO TO 230 - IF (NUD.LT.NULIM(NN)) GO TO 230 - GO TO 10 - 240 CONTINUE - NZ = N - ND - IF (NZ.EQ.0) RETURN - IF (ND.EQ.0) GO TO 260 - DO 250 I=1,ND - J = N - I + 1 - K = ND - I + 1 - Y(J) = Y(K) - 250 CONTINUE - 260 CONTINUE - DO 270 I=1,NZ - Y(I) = 0.0E0 - 270 CONTINUE - RETURN -C -C -C - 280 CONTINUE - CALL XERMSG ('SLATEC', 'BESK', 'SCALING OPTION, KODE, NOT 1 OR 2' - + , 2, 1) - RETURN - 290 CONTINUE - CALL XERMSG ('SLATEC', 'BESK', 'ORDER, FNU, LESS THAN ZERO', 2, - + 1) - RETURN - 300 CONTINUE - CALL XERMSG ('SLATEC', 'BESK', 'X LESS THAN OR EQUAL TO ZERO', 2, - + 1) - RETURN - 310 CONTINUE - CALL XERMSG ('SLATEC', 'BESK', 'N LESS THAN ONE', 2, 1) - RETURN - 320 CONTINUE - CALL XERMSG ('SLATEC', 'BESK', - + 'OVERFLOW, FNU OR N TOO LARGE OR X TOO SMALL', 6, 1) - RETURN - END diff --git a/slatec/besk0.f b/slatec/besk0.f deleted file mode 100644 index e213890..0000000 --- a/slatec/besk0.f +++ /dev/null @@ -1,76 +0,0 @@ -*DECK BESK0 - FUNCTION BESK0 (X) -C***BEGIN PROLOGUE BESK0 -C***PURPOSE Compute the modified (hyperbolic) Bessel function of the -C third kind of order zero. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10B1 -C***TYPE SINGLE PRECISION (BESK0-S, DBESK0-D) -C***KEYWORDS FNLIB, HYPERBOLIC BESSEL FUNCTION, -C MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS, -C THIRD KIND -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C BESK0(X) calculates the modified (hyperbolic) Bessel function -C of the third kind of order zero for real argument X .GT. 0.0. -C -C Series for BK0 on the interval 0. to 4.00000D+00 -C with weighted error 3.57E-19 -C log weighted error 18.45 -C significant figures required 17.99 -C decimal places required 18.97 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED BESI0, BESK0E, CSEVL, INITS, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE BESK0 - DIMENSION BK0CS(11) - LOGICAL FIRST - SAVE BK0CS, NTK0, XSML, XMAX, FIRST - DATA BK0CS( 1) / -.0353273932 3390276872E0 / - DATA BK0CS( 2) / .3442898999 246284869E0 / - DATA BK0CS( 3) / .0359799365 1536150163E0 / - DATA BK0CS( 4) / .0012646154 1144692592E0 / - DATA BK0CS( 5) / .0000228621 2103119451E0 / - DATA BK0CS( 6) / .0000002534 7910790261E0 / - DATA BK0CS( 7) / .0000000019 0451637722E0 / - DATA BK0CS( 8) / .0000000000 1034969525E0 / - DATA BK0CS( 9) / .0000000000 0004259816E0 / - DATA BK0CS(10) / .0000000000 0000013744E0 / - DATA BK0CS(11) / .0000000000 0000000035E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT BESK0 - IF (FIRST) THEN - NTK0 = INITS (BK0CS, 11, 0.1*R1MACH(3)) - XSML = SQRT (4.0*R1MACH(3)) - XMAXT = -LOG(R1MACH(1)) - XMAX = XMAXT - 0.5*XMAXT*LOG(XMAXT)/(XMAXT+0.5) - 0.01 - ENDIF - FIRST = .FALSE. -C - IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'BESK0', - + 'X IS ZERO OR NEGATIVE', 2, 2) - IF (X.GT.2.) GO TO 20 -C - Y = 0. - IF (X.GT.XSML) Y = X*X - BESK0 = -LOG(0.5*X)*BESI0(X) - .25 + CSEVL (.5*Y-1., BK0CS, NTK0) - RETURN -C - 20 BESK0 = 0. - IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'BESK0', - + 'X SO BIG K0 UNDERFLOWS', 1, 1) - IF (X.GT.XMAX) RETURN -C - BESK0 = EXP(-X) * BESK0E(X) -C - RETURN - END diff --git a/slatec/besk0e.f b/slatec/besk0e.f deleted file mode 100644 index 879665b..0000000 --- a/slatec/besk0e.f +++ /dev/null @@ -1,119 +0,0 @@ -*DECK BESK0E - FUNCTION BESK0E (X) -C***BEGIN PROLOGUE BESK0E -C***PURPOSE Compute the exponentially scaled modified (hyperbolic) -C Bessel function of the third kind of order zero. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10B1 -C***TYPE SINGLE PRECISION (BESK0E-S, DBSK0E-D) -C***KEYWORDS EXPONENTIALLY SCALED, FNLIB, HYPERBOLIC BESSEL FUNCTION, -C MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS, -C THIRD KIND -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C BESK0E(X) computes the exponentially scaled modified (hyperbolic) -C Bessel function of third kind of order zero for real argument -C X .GT. 0.0, i.e., EXP(X)*K0(X). -C -C Series for BK0 on the interval 0. to 4.00000D+00 -C with weighted error 3.57E-19 -C log weighted error 18.45 -C significant figures required 17.99 -C decimal places required 18.97 -C -C Series for AK0 on the interval 1.25000D-01 to 5.00000D-01 -C with weighted error 5.34E-17 -C log weighted error 16.27 -C significant figures required 14.92 -C decimal places required 16.89 -C -C Series for AK02 on the interval 0. to 1.25000D-01 -C with weighted error 2.34E-17 -C log weighted error 16.63 -C significant figures required 14.67 -C decimal places required 17.20 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED BESI0, CSEVL, INITS, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE BESK0E - DIMENSION BK0CS(11), AK0CS(17), AK02CS(14) - LOGICAL FIRST - SAVE BK0CS, AK0CS, AK02CS, NTK0, NTAK0, NTAK02, XSML, FIRST - DATA BK0CS( 1) / -.0353273932 3390276872E0 / - DATA BK0CS( 2) / .3442898999 246284869E0 / - DATA BK0CS( 3) / .0359799365 1536150163E0 / - DATA BK0CS( 4) / .0012646154 1144692592E0 / - DATA BK0CS( 5) / .0000228621 2103119451E0 / - DATA BK0CS( 6) / .0000002534 7910790261E0 / - DATA BK0CS( 7) / .0000000019 0451637722E0 / - DATA BK0CS( 8) / .0000000000 1034969525E0 / - DATA BK0CS( 9) / .0000000000 0004259816E0 / - DATA BK0CS(10) / .0000000000 0000013744E0 / - DATA BK0CS(11) / .0000000000 0000000035E0 / - DATA AK0CS( 1) / -.0764394790 3327941E0 / - DATA AK0CS( 2) / -.0223565260 5699819E0 / - DATA AK0CS( 3) / .0007734181 1546938E0 / - DATA AK0CS( 4) / -.0000428100 6688886E0 / - DATA AK0CS( 5) / .0000030817 0017386E0 / - DATA AK0CS( 6) / -.0000002639 3672220E0 / - DATA AK0CS( 7) / .0000000256 3713036E0 / - DATA AK0CS( 8) / -.0000000027 4270554E0 / - DATA AK0CS( 9) / .0000000003 1694296E0 / - DATA AK0CS(10) / -.0000000000 3902353E0 / - DATA AK0CS(11) / .0000000000 0506804E0 / - DATA AK0CS(12) / -.0000000000 0068895E0 / - DATA AK0CS(13) / .0000000000 0009744E0 / - DATA AK0CS(14) / -.0000000000 0001427E0 / - DATA AK0CS(15) / .0000000000 0000215E0 / - DATA AK0CS(16) / -.0000000000 0000033E0 / - DATA AK0CS(17) / .0000000000 0000005E0 / - DATA AK02CS( 1) / -.0120186982 6307592E0 / - DATA AK02CS( 2) / -.0091748526 9102569E0 / - DATA AK02CS( 3) / .0001444550 9317750E0 / - DATA AK02CS( 4) / -.0000040136 1417543E0 / - DATA AK02CS( 5) / .0000001567 8318108E0 / - DATA AK02CS( 6) / -.0000000077 7011043E0 / - DATA AK02CS( 7) / .0000000004 6111825E0 / - DATA AK02CS( 8) / -.0000000000 3158592E0 / - DATA AK02CS( 9) / .0000000000 0243501E0 / - DATA AK02CS(10) / -.0000000000 0020743E0 / - DATA AK02CS(11) / .0000000000 0001925E0 / - DATA AK02CS(12) / -.0000000000 0000192E0 / - DATA AK02CS(13) / .0000000000 0000020E0 / - DATA AK02CS(14) / -.0000000000 0000002E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT BESK0E - IF (FIRST) THEN - NTK0 = INITS (BK0CS, 11, 0.1*R1MACH(3)) - NTAK0 = INITS (AK0CS, 17, 0.1*R1MACH(3)) - NTAK02 = INITS (AK02CS, 14, 0.1*R1MACH(3)) - XSML = SQRT (4.0*R1MACH(3)) - ENDIF - FIRST = .FALSE. -C - IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'BESK0E', - + 'X IS ZERO OR NEGATIVE', 2, 2) - IF (X.GT.2.) GO TO 20 -C - Y = 0. - IF (X.GT.XSML) Y = X*X - BESK0E = EXP(X) * (-LOG(0.5*X)*BESI0(X) - 1 - .25 + CSEVL (.5*Y-1., BK0CS, NTK0) ) - RETURN -C - 20 IF (X.LE.8.) BESK0E = (1.25 + CSEVL ((16./X-5.)/3., AK0CS, NTAK0)) - 1 / SQRT(X) - IF (X.GT.8.) BESK0E = (1.25 + CSEVL (16./X-1., AK02CS, NTAK02)) - 1 / SQRT(X) -C - RETURN - END diff --git a/slatec/besk1.f b/slatec/besk1.f deleted file mode 100644 index 46d685d..0000000 --- a/slatec/besk1.f +++ /dev/null @@ -1,80 +0,0 @@ -*DECK BESK1 - FUNCTION BESK1 (X) -C***BEGIN PROLOGUE BESK1 -C***PURPOSE Compute the modified (hyperbolic) Bessel function of the -C third kind of order one. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10B1 -C***TYPE SINGLE PRECISION (BESK1-S, DBESK1-D) -C***KEYWORDS FNLIB, HYPERBOLIC BESSEL FUNCTION, -C MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS, -C THIRD KIND -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C BESK1(X) computes the modified (hyperbolic) Bessel function of third -C kind of order one for real argument X, where X .GT. 0. -C -C Series for BK1 on the interval 0. to 4.00000D+00 -C with weighted error 7.02E-18 -C log weighted error 17.15 -C significant figures required 16.73 -C decimal places required 17.67 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED BESI1, BESK1E, CSEVL, INITS, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE BESK1 - DIMENSION BK1CS(11) - LOGICAL FIRST - SAVE BK1CS, NTK1, XMIN, XSML, XMAX, FIRST - DATA BK1CS( 1) / .0253002273 389477705E0 / - DATA BK1CS( 2) / -.3531559607 76544876E0 / - DATA BK1CS( 3) / -.1226111808 22657148E0 / - DATA BK1CS( 4) / -.0069757238 596398643E0 / - DATA BK1CS( 5) / -.0001730288 957513052E0 / - DATA BK1CS( 6) / -.0000024334 061415659E0 / - DATA BK1CS( 7) / -.0000000221 338763073E0 / - DATA BK1CS( 8) / -.0000000001 411488392E0 / - DATA BK1CS( 9) / -.0000000000 006666901E0 / - DATA BK1CS(10) / -.0000000000 000024274E0 / - DATA BK1CS(11) / -.0000000000 000000070E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT BESK1 - IF (FIRST) THEN - NTK1 = INITS (BK1CS, 11, 0.1*R1MACH(3)) - XMIN = EXP (MAX(LOG(R1MACH(1)), -LOG(R1MACH(2))) + .01) - XSML = SQRT (4.0*R1MACH(3)) - XMAXT = -LOG(R1MACH(1)) - XMAX = XMAXT - 0.5*XMAXT*LOG(XMAXT)/(XMAXT+0.5) - ENDIF - FIRST = .FALSE. -C - IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'BESK1', - + 'X IS ZERO OR NEGATIVE', 2, 2) - IF (X.GT.2.0) GO TO 20 -C - IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'BESK1', - + 'X SO SMALL K1 OVERFLOWS', 3, 2) - Y = 0. - IF (X.GT.XSML) Y = X*X - BESK1 = LOG(0.5*X)*BESI1(X) + - 1 (0.75 + CSEVL (.5*Y-1., BK1CS, NTK1))/X - RETURN -C - 20 BESK1 = 0. - IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'BESK1', - + 'X SO BIG K1 UNDERFLOWS', 1, 1) - IF (X.GT.XMAX) RETURN -C - BESK1 = EXP(-X) * BESK1E(X) -C - RETURN - END diff --git a/slatec/besk1e.f b/slatec/besk1e.f deleted file mode 100644 index 114b682..0000000 --- a/slatec/besk1e.f +++ /dev/null @@ -1,124 +0,0 @@ -*DECK BESK1E - FUNCTION BESK1E (X) -C***BEGIN PROLOGUE BESK1E -C***PURPOSE Compute the exponentially scaled modified (hyperbolic) -C Bessel function of the third kind of order one. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10B1 -C***TYPE SINGLE PRECISION (BESK1E-S, DBSK1E-D) -C***KEYWORDS EXPONENTIALLY SCALED, FNLIB, HYPERBOLIC BESSEL FUNCTION, -C MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS, -C THIRD KIND -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C BESK1E(X) computes the exponentially scaled modified (hyperbolic) -C Bessel function of third kind of order one for real argument -C X .GT. 0.0, i.e., EXP(X)*K1(X). -C -C Series for BK1 on the interval 0. to 4.00000D+00 -C with weighted error 7.02E-18 -C log weighted error 17.15 -C significant figures required 16.73 -C decimal places required 17.67 -C -C Series for AK1 on the interval 1.25000D-01 to 5.00000D-01 -C with weighted error 6.06E-17 -C log weighted error 16.22 -C significant figures required 15.41 -C decimal places required 16.83 -C -C Series for AK12 on the interval 0. to 1.25000D-01 -C with weighted error 2.58E-17 -C log weighted error 16.59 -C significant figures required 15.22 -C decimal places required 17.16 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED BESI1, CSEVL, INITS, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE BESK1E - DIMENSION BK1CS(11), AK1CS(17), AK12CS(14) - LOGICAL FIRST - SAVE BK1CS, AK1CS, AK12CS, NTK1, NTAK1, NTAK12, XMIN, XSML, - 1 FIRST - DATA BK1CS( 1) / .0253002273 389477705E0 / - DATA BK1CS( 2) / -.3531559607 76544876E0 / - DATA BK1CS( 3) / -.1226111808 22657148E0 / - DATA BK1CS( 4) / -.0069757238 596398643E0 / - DATA BK1CS( 5) / -.0001730288 957513052E0 / - DATA BK1CS( 6) / -.0000024334 061415659E0 / - DATA BK1CS( 7) / -.0000000221 338763073E0 / - DATA BK1CS( 8) / -.0000000001 411488392E0 / - DATA BK1CS( 9) / -.0000000000 006666901E0 / - DATA BK1CS(10) / -.0000000000 000024274E0 / - DATA BK1CS(11) / -.0000000000 000000070E0 / - DATA AK1CS( 1) / .2744313406 973883E0 / - DATA AK1CS( 2) / .0757198995 3199368E0 / - DATA AK1CS( 3) / -.0014410515 5647540E0 / - DATA AK1CS( 4) / .0000665011 6955125E0 / - DATA AK1CS( 5) / -.0000043699 8470952E0 / - DATA AK1CS( 6) / .0000003540 2774997E0 / - DATA AK1CS( 7) / -.0000000331 1163779E0 / - DATA AK1CS( 8) / .0000000034 4597758E0 / - DATA AK1CS( 9) / -.0000000003 8989323E0 / - DATA AK1CS(10) / .0000000000 4720819E0 / - DATA AK1CS(11) / -.0000000000 0604783E0 / - DATA AK1CS(12) / .0000000000 0081284E0 / - DATA AK1CS(13) / -.0000000000 0011386E0 / - DATA AK1CS(14) / .0000000000 0001654E0 / - DATA AK1CS(15) / -.0000000000 0000248E0 / - DATA AK1CS(16) / .0000000000 0000038E0 / - DATA AK1CS(17) / -.0000000000 0000006E0 / - DATA AK12CS( 1) / .0637930834 3739001E0 / - DATA AK12CS( 2) / .0283288781 3049721E0 / - DATA AK12CS( 3) / -.0002475370 6739052E0 / - DATA AK12CS( 4) / .0000057719 7245160E0 / - DATA AK12CS( 5) / -.0000002068 9392195E0 / - DATA AK12CS( 6) / .0000000097 3998344E0 / - DATA AK12CS( 7) / -.0000000005 5853361E0 / - DATA AK12CS( 8) / .0000000000 3732996E0 / - DATA AK12CS( 9) / -.0000000000 0282505E0 / - DATA AK12CS(10) / .0000000000 0023720E0 / - DATA AK12CS(11) / -.0000000000 0002176E0 / - DATA AK12CS(12) / .0000000000 0000215E0 / - DATA AK12CS(13) / -.0000000000 0000022E0 / - DATA AK12CS(14) / .0000000000 0000002E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT BESK1E - IF (FIRST) THEN - NTK1 = INITS (BK1CS, 11, 0.1*R1MACH(3)) - NTAK1 = INITS (AK1CS, 17, 0.1*R1MACH(3)) - NTAK12 = INITS (AK12CS, 14, 0.1*R1MACH(3)) -C - XMIN = EXP (MAX(LOG(R1MACH(1)), -LOG(R1MACH(2))) + .01) - XSML = SQRT (4.0*R1MACH(3)) - ENDIF - FIRST = .FALSE. -C - IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'BESK1E', - + 'X IS ZERO OR NEGATIVE', 2, 2) - IF (X.GT.2.0) GO TO 20 -C - IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'BESK1E', - + 'X SO SMALL K1 OVERFLOWS', 3, 2) - Y = 0. - IF (X.GT.XSML) Y = X*X - BESK1E = EXP(X) * (LOG(0.5*X)*BESI1(X) + - 1 (0.75 + CSEVL (.5*Y-1., BK1CS, NTK1))/X ) - RETURN -C - 20 IF (X.LE.8.) BESK1E = (1.25 + CSEVL ((16./X-5.)/3., AK1CS, NTAK1)) - 1 / SQRT(X) - IF (X.GT.8.) BESK1E = (1.25 + CSEVL (16./X-1., AK12CS, NTAK12)) - 1 / SQRT(X) -C - RETURN - END diff --git a/slatec/beskes.f b/slatec/beskes.f deleted file mode 100644 index e5a2d57..0000000 --- a/slatec/beskes.f +++ /dev/null @@ -1,77 +0,0 @@ -*DECK BESKES - SUBROUTINE BESKES (XNU, X, NIN, BKE) -C***BEGIN PROLOGUE BESKES -C***PURPOSE Compute a sequence of exponentially scaled modified Bessel -C functions of the third kind of fractional order. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10B3 -C***TYPE SINGLE PRECISION (BESKES-S, DBSKES-D) -C***KEYWORDS EXPONENTIALLY SCALED, FNLIB, FRACTIONAL ORDER, -C MODIFIED BESSEL FUNCTION, SEQUENCE OF BESSEL FUNCTIONS, -C SPECIAL FUNCTIONS, THIRD KIND -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C BESKES computes a sequence of exponentially scaled -C (i.e., multipled by EXP(X)) modified Bessel -C functions of the third kind of order XNU + I at X, where X .GT. 0, -C XNU lies in (-1,1), and I = 0, 1, ... , NIN - 1, if NIN is positive -C and I = 0, -1, ... , NIN + 1, if NIN is negative. On return, the -C vector BKE(.) contains the results at X for order starting at XNU. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH, R9KNUS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 890911 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE BESKES - DIMENSION BKE(*) - SAVE ALNBIG - DATA ALNBIG / 0. / -C***FIRST EXECUTABLE STATEMENT BESKES - IF (ALNBIG.EQ.0.) ALNBIG = LOG (R1MACH(2)) -C - V = ABS(XNU) - N = ABS(NIN) -C - IF (V .GE. 1.) CALL XERMSG ('SLATEC', 'BESKES', - + 'ABS(XNU) MUST BE LT 1', 2, 2) - IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'BESKES', 'X IS LE 0', 3, - + 2) - IF (N .EQ. 0) CALL XERMSG ('SLATEC', 'BESKES', - + 'N THE NUMBER IN THE SEQUENCE IS 0', 4, 2) -C - CALL R9KNUS (V, X, BKE(1), BKNU1, ISWTCH) - IF (N.EQ.1) RETURN -C - VINCR = SIGN (1.0, REAL(NIN)) - DIRECT = VINCR - IF (XNU.NE.0.) DIRECT = VINCR*SIGN(1.0,XNU) - IF (ISWTCH .EQ. 1 .AND. DIRECT .GT. 0.) CALL XERMSG ('SLATEC', - + 'BESKES', 'X SO SMALL BESSEL K-SUB-XNU+1 OVERFLOWS', 5, 2) - BKE(2) = BKNU1 -C - IF (DIRECT.LT.0.) CALL R9KNUS (ABS(XNU+VINCR), X, BKE(2), BKNU1, - 1 ISWTCH) - IF (N.EQ.2) RETURN -C - VEND = ABS(XNU+NIN) - 1.0 - IF ((VEND-0.5)*LOG(VEND)+0.27-VEND*(LOG(X)-.694) .GT. ALNBIG) - 1CALL XERMSG ( 'SLATEC', 'BESKES', - 2'X SO SMALL OR ABS(NU) SO BIG THAT BESSEL K-SUB-NU OVERFLOWS', - 35, 2) -C - V = XNU - DO 10 I=3,N - V = V + VINCR - BKE(I) = 2.0*V*BKE(I-1)/X + BKE(I-2) - 10 CONTINUE -C - RETURN - END diff --git a/slatec/besknu.f b/slatec/besknu.f deleted file mode 100644 index 4d0e163..0000000 --- a/slatec/besknu.f +++ /dev/null @@ -1,388 +0,0 @@ -*DECK BESKNU - SUBROUTINE BESKNU (X, FNU, KODE, N, Y, NZ) -C***BEGIN PROLOGUE BESKNU -C***SUBSIDIARY -C***PURPOSE Subsidiary to BESK -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (BESKNU-S, DBSKNU-D) -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C BESKNU computes N member sequences of K Bessel functions -C K/SUB(FNU+I-1)/(X), I=1,N for non-negative orders FNU and -C positive X. Equations of the references are implemented on -C small orders DNU for K/SUB(DNU)/(X) and K/SUB(DNU+1)/(X). -C Forward recursion with the three term recursion relation -C generates higher orders FNU+I-1, I=1,...,N. The parameter -C KODE permits K/SUB(FNU+I-1)/(X) values or scaled values -C EXP(X)*K/SUB(FNU+I-1)/(X), I=1,N to be returned. -C -C To start the recursion FNU is normalized to the interval -C -0.5.LE.DNU.LT.0.5. A special form of the power series is -C implemented on 0.LT.X.LE.X1 while the Miller algorithm for the -C K Bessel function in terms of the confluent hypergeometric -C function U(FNU+0.5,2*FNU+1,X) is implemented on X1.LT.X.LE.X2. -C For X.GT.X2, the asymptotic expansion for large X is used. -C When FNU is a half odd integer, a special formula for -C DNU=-0.5 and DNU+1.0=0.5 is used to start the recursion. -C -C BESKNU assumes that a significant digit SINH(X) function is -C available. -C -C Description of Arguments -C -C Input -C X - X.GT.0.0E0 -C FNU - Order of initial K function, FNU.GE.0.0E0 -C N - Number of members of the sequence, N.GE.1 -C KODE - A parameter to indicate the scaling option -C KODE= 1 returns -C Y(I)= K/SUB(FNU+I-1)/(X) -C I=1,...,N -C = 2 returns -C Y(I)=EXP(X)*K/SUB(FNU+I-1)/(X) -C I=1,...,N -C -C Output -C Y - A vector whose first N components contain values -C for the sequence -C Y(I)= K/SUB(FNU+I-1)/(X), I=1,...,N or -C Y(I)=EXP(X)*K/SUB(FNU+I-1)/(X), I=1,...,N -C depending on KODE -C NZ - Number of components set to zero due to -C underflow, -C NZ= 0 , Normal return -C NZ.NE.0 , First NZ components of Y set to zero -C due to underflow, Y(I)=0.0E0,I=1,...,NZ -C -C Error Conditions -C Improper input arguments - a fatal error -C Overflow - a fatal error -C Underflow with KODE=1 - a non-fatal error (NZ.NE.0) -C -C***SEE ALSO BESK -C***REFERENCES N. M. Temme, On the numerical evaluation of the modified -C Bessel function of the third kind, Journal of -C Computational Physics 19, (1975), pp. 324-337. -C***ROUTINES CALLED GAMMA, I1MACH, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790201 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900328 Added TYPE section. (WRB) -C 900727 Added EXTERNAL statement. (WRB) -C 910408 Updated the AUTHOR and REFERENCES sections. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE BESKNU -C - INTEGER I, IFLAG, INU, J, K, KK, KODE, KODED, N, NN, NZ - INTEGER I1MACH - REAL A, AK, A1, A2, B, BK, CC, CK, COEF, CX, DK, DNU, DNU2, ELIM, - 1 ETEST, EX, F, FC, FHS, FK, FKS, FLRX, FMU, FNU, G1, G2, P, PI, - 2 PT, P1, P2, Q, RTHPI, RX, S, SMU, SQK, ST, S1, S2, TM, TOL, T1, - 3 T2, X, X1, X2, Y - REAL GAMMA, R1MACH - DIMENSION A(160), B(160), Y(*), CC(8) - EXTERNAL GAMMA - SAVE X1, X2, PI, RTHPI, CC - DATA X1, X2 / 2.0E0, 17.0E0 / - DATA PI,RTHPI / 3.14159265358979E+00, 1.25331413731550E+00/ - DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8) - 1 / 5.77215664901533E-01,-4.20026350340952E-02, - 2-4.21977345555443E-02, 7.21894324666300E-03,-2.15241674114900E-04, - 3-2.01348547807000E-05, 1.13302723200000E-06, 6.11609500000000E-09/ -C***FIRST EXECUTABLE STATEMENT BESKNU - KK = -I1MACH(12) - ELIM = 2.303E0*(KK*R1MACH(5)-3.0E0) - AK = R1MACH(3) - TOL = MAX(AK,1.0E-15) - IF (X.LE.0.0E0) GO TO 350 - IF (FNU.LT.0.0E0) GO TO 360 - IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 370 - IF (N.LT.1) GO TO 380 - NZ = 0 - IFLAG = 0 - KODED = KODE - RX = 2.0E0/X - INU = INT(FNU+0.5E0) - DNU = FNU - INU - IF (ABS(DNU).EQ.0.5E0) GO TO 120 - DNU2 = 0.0E0 - IF (ABS(DNU).LT.TOL) GO TO 10 - DNU2 = DNU*DNU - 10 CONTINUE - IF (X.GT.X1) GO TO 120 -C -C SERIES FOR X.LE.X1 -C - A1 = 1.0E0 - DNU - A2 = 1.0E0 + DNU - T1 = 1.0E0/GAMMA(A1) - T2 = 1.0E0/GAMMA(A2) - IF (ABS(DNU).GT.0.1E0) GO TO 40 -C SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) - S = CC(1) - AK = 1.0E0 - DO 20 K=2,8 - AK = AK*DNU2 - TM = CC(K)*AK - S = S + TM - IF (ABS(TM).LT.TOL) GO TO 30 - 20 CONTINUE - 30 G1 = -S - GO TO 50 - 40 CONTINUE - G1 = (T1-T2)/(DNU+DNU) - 50 CONTINUE - G2 = (T1+T2)*0.5E0 - SMU = 1.0E0 - FC = 1.0E0 - FLRX = LOG(RX) - FMU = DNU*FLRX - IF (DNU.EQ.0.0E0) GO TO 60 - FC = DNU*PI - FC = FC/SIN(FC) - IF (FMU.NE.0.0E0) SMU = SINH(FMU)/FMU - 60 CONTINUE - F = FC*(G1*COSH(FMU)+G2*FLRX*SMU) - FC = EXP(FMU) - P = 0.5E0*FC/T2 - Q = 0.5E0/(FC*T1) - AK = 1.0E0 - CK = 1.0E0 - BK = 1.0E0 - S1 = F - S2 = P - IF (INU.GT.0 .OR. N.GT.1) GO TO 90 - IF (X.LT.TOL) GO TO 80 - CX = X*X*0.25E0 - 70 CONTINUE - F = (AK*F+P+Q)/(BK-DNU2) - P = P/(AK-DNU) - Q = Q/(AK+DNU) - CK = CK*CX/AK - T1 = CK*F - S1 = S1 + T1 - BK = BK + AK + AK + 1.0E0 - AK = AK + 1.0E0 - S = ABS(T1)/(1.0E0+ABS(S1)) - IF (S.GT.TOL) GO TO 70 - 80 CONTINUE - Y(1) = S1 - IF (KODED.EQ.1) RETURN - Y(1) = S1*EXP(X) - RETURN - 90 CONTINUE - IF (X.LT.TOL) GO TO 110 - CX = X*X*0.25E0 - 100 CONTINUE - F = (AK*F+P+Q)/(BK-DNU2) - P = P/(AK-DNU) - Q = Q/(AK+DNU) - CK = CK*CX/AK - T1 = CK*F - S1 = S1 + T1 - T2 = CK*(P-AK*F) - S2 = S2 + T2 - BK = BK + AK + AK + 1.0E0 - AK = AK + 1.0E0 - S = ABS(T1)/(1.0E0+ABS(S1)) + ABS(T2)/(1.0E0+ABS(S2)) - IF (S.GT.TOL) GO TO 100 - 110 CONTINUE - S2 = S2*RX - IF (KODED.EQ.1) GO TO 170 - F = EXP(X) - S1 = S1*F - S2 = S2*F - GO TO 170 - 120 CONTINUE - COEF = RTHPI/SQRT(X) - IF (KODED.EQ.2) GO TO 130 - IF (X.GT.ELIM) GO TO 330 - COEF = COEF*EXP(-X) - 130 CONTINUE - IF (ABS(DNU).EQ.0.5E0) GO TO 340 - IF (X.GT.X2) GO TO 280 -C -C MILLER ALGORITHM FOR X1.LT.X.LE.X2 -C - ETEST = COS(PI*DNU)/(PI*X*TOL) - FKS = 1.0E0 - FHS = 0.25E0 - FK = 0.0E0 - CK = X + X + 2.0E0 - P1 = 0.0E0 - P2 = 1.0E0 - K = 0 - 140 CONTINUE - K = K + 1 - FK = FK + 1.0E0 - AK = (FHS-DNU2)/(FKS+FK) - BK = CK/(FK+1.0E0) - PT = P2 - P2 = BK*P2 - AK*P1 - P1 = PT - A(K) = AK - B(K) = BK - CK = CK + 2.0E0 - FKS = FKS + FK + FK + 1.0E0 - FHS = FHS + FK + FK - IF (ETEST.GT.FK*P1) GO TO 140 - KK = K - S = 1.0E0 - P1 = 0.0E0 - P2 = 1.0E0 - DO 150 I=1,K - PT = P2 - P2 = (B(KK)*P2-P1)/A(KK) - P1 = PT - S = S + P2 - KK = KK - 1 - 150 CONTINUE - S1 = COEF*(P2/S) - IF (INU.GT.0 .OR. N.GT.1) GO TO 160 - GO TO 200 - 160 CONTINUE - S2 = S1*(X+DNU+0.5E0-P1/P2)/X -C -C FORWARD RECURSION ON THE THREE TERM RECURSION RELATION -C - 170 CONTINUE - CK = (DNU+DNU+2.0E0)/X - IF (N.EQ.1) INU = INU - 1 - IF (INU.GT.0) GO TO 180 - IF (N.GT.1) GO TO 200 - S1 = S2 - GO TO 200 - 180 CONTINUE - DO 190 I=1,INU - ST = S2 - S2 = CK*S2 + S1 - S1 = ST - CK = CK + RX - 190 CONTINUE - IF (N.EQ.1) S1 = S2 - 200 CONTINUE - IF (IFLAG.EQ.1) GO TO 220 - Y(1) = S1 - IF (N.EQ.1) RETURN - Y(2) = S2 - IF (N.EQ.2) RETURN - DO 210 I=3,N - Y(I) = CK*Y(I-1) + Y(I-2) - CK = CK + RX - 210 CONTINUE - RETURN -C IFLAG=1 CASES - 220 CONTINUE - S = -X + LOG(S1) - Y(1) = 0.0E0 - NZ = 1 - IF (S.LT.-ELIM) GO TO 230 - Y(1) = EXP(S) - NZ = 0 - 230 CONTINUE - IF (N.EQ.1) RETURN - S = -X + LOG(S2) - Y(2) = 0.0E0 - NZ = NZ + 1 - IF (S.LT.-ELIM) GO TO 240 - NZ = NZ - 1 - Y(2) = EXP(S) - 240 CONTINUE - IF (N.EQ.2) RETURN - KK = 2 - IF (NZ.LT.2) GO TO 260 - DO 250 I=3,N - KK = I - ST = S2 - S2 = CK*S2 + S1 - S1 = ST - CK = CK + RX - S = -X + LOG(S2) - NZ = NZ + 1 - Y(I) = 0.0E0 - IF (S.LT.-ELIM) GO TO 250 - Y(I) = EXP(S) - NZ = NZ - 1 - GO TO 260 - 250 CONTINUE - RETURN - 260 CONTINUE - IF (KK.EQ.N) RETURN - S2 = S2*CK + S1 - CK = CK + RX - KK = KK + 1 - Y(KK) = EXP(-X+LOG(S2)) - IF (KK.EQ.N) RETURN - KK = KK + 1 - DO 270 I=KK,N - Y(I) = CK*Y(I-1) + Y(I-2) - CK = CK + RX - 270 CONTINUE - RETURN -C -C ASYMPTOTIC EXPANSION FOR LARGE X, X.GT.X2 -C -C IFLAG=0 MEANS NO UNDERFLOW OCCURRED -C IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH -C KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD -C RECURSION - 280 CONTINUE - NN = 2 - IF (INU.EQ.0 .AND. N.EQ.1) NN = 1 - DNU2 = DNU + DNU - FMU = 0.0E0 - IF (ABS(DNU2).LT.TOL) GO TO 290 - FMU = DNU2*DNU2 - 290 CONTINUE - EX = X*8.0E0 - S2 = 0.0E0 - DO 320 K=1,NN - S1 = S2 - S = 1.0E0 - AK = 0.0E0 - CK = 1.0E0 - SQK = 1.0E0 - DK = EX - DO 300 J=1,30 - CK = CK*(FMU-SQK)/DK - S = S + CK - DK = DK + EX - AK = AK + 8.0E0 - SQK = SQK + AK - IF (ABS(CK).LT.TOL) GO TO 310 - 300 CONTINUE - 310 S2 = S*COEF - FMU = FMU + 8.0E0*DNU + 4.0E0 - 320 CONTINUE - IF (NN.GT.1) GO TO 170 - S1 = S2 - GO TO 200 - 330 CONTINUE - KODED = 2 - IFLAG = 1 - GO TO 120 -C -C FNU=HALF ODD INTEGER CASE -C - 340 CONTINUE - S1 = COEF - S2 = COEF - GO TO 170 -C -C - 350 CALL XERMSG ('SLATEC', 'BESKNU', 'X NOT GREATER THAN ZERO', 2, 1) - RETURN - 360 CALL XERMSG ('SLATEC', 'BESKNU', 'FNU NOT ZERO OR POSITIVE', 2, - + 1) - RETURN - 370 CALL XERMSG ('SLATEC', 'BESKNU', 'KODE NOT 1 OR 2', 2, 1) - RETURN - 380 CALL XERMSG ('SLATEC', 'BESKNU', 'N NOT GREATER THAN 0', 2, 1) - RETURN - END diff --git a/slatec/besks.f b/slatec/besks.f deleted file mode 100644 index 4bf973b..0000000 --- a/slatec/besks.f +++ /dev/null @@ -1,50 +0,0 @@ -*DECK BESKS - SUBROUTINE BESKS (XNU, X, NIN, BK) -C***BEGIN PROLOGUE BESKS -C***PURPOSE Compute a sequence of modified Bessel functions of the -C third kind of fractional order. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10B3 -C***TYPE SINGLE PRECISION (BESKS-S, DBESKS-D) -C***KEYWORDS FNLIB, FRACTIONAL ORDER, MODIFIED BESSEL FUNCTION, -C SEQUENCE OF BESSEL FUNCTIONS, SPECIAL FUNCTIONS, -C THIRD KIND -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C BESKS computes a sequence of modified Bessel functions of the third -C kind of order XNU + I at X, where X .GT. 0, XNU lies in (-1,1), -C and I = 0, 1, ... , NIN - 1, if NIN is positive and I = 0, 1, ... , -C NIN + 1, if NIN is negative. On return, the vector BK(.) Contains -C the results at X for order starting at XNU. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED BESKES, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE BESKS - DIMENSION BK(*) - SAVE XMAX - DATA XMAX / 0.0 / -C***FIRST EXECUTABLE STATEMENT BESKS - IF (XMAX.EQ.0.0) XMAX = -LOG (R1MACH(1)) -C - IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'BESKS', - + 'X SO BIG BESSEL K UNDERFLOWS', 1, 2) -C - CALL BESKES (XNU, X, NIN, BK) -C - EXPXI = EXP (-X) - N = ABS (NIN) - DO 20 I=1,N - BK(I) = EXPXI * BK(I) - 20 CONTINUE -C - RETURN - END diff --git a/slatec/besy.f b/slatec/besy.f deleted file mode 100644 index e36e14b..0000000 --- a/slatec/besy.f +++ /dev/null @@ -1,200 +0,0 @@ -*DECK BESY - SUBROUTINE BESY (X, FNU, N, Y) -C***BEGIN PROLOGUE BESY -C***PURPOSE Implement forward recursion on the three term recursion -C relation for a sequence of non-negative order Bessel -C functions Y/SUB(FNU+I-1)/(X), I=1,...,N for real, positive -C X and non-negative orders FNU. -C***LIBRARY SLATEC -C***CATEGORY C10A3 -C***TYPE SINGLE PRECISION (BESY-S, DBESY-D) -C***KEYWORDS SPECIAL FUNCTIONS, Y BESSEL FUNCTION -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C BESY implements forward recursion on the three term -C recursion relation for a sequence of non-negative order Bessel -C functions Y/sub(FNU+I-1)/(X), I=1,N for real X .GT. 0.0E0 and -C non-negative orders FNU. If FNU .LT. NULIM, orders FNU and -C FNU+1 are obtained from BESYNU which computes by a power -C series for X .LE. 2, the K Bessel function of an imaginary -C argument for 2 .LT. X .LE. 20 and the asymptotic expansion for -C X .GT. 20. -C -C If FNU .GE. NULIM, the uniform asymptotic expansion is coded -C in ASYJY for orders FNU and FNU+1 to start the recursion. -C NULIM is 70 or 100 depending on whether N=1 or N .GE. 2. An -C overflow test is made on the leading term of the asymptotic -C expansion before any extensive computation is done. -C -C Description of Arguments -C -C Input -C X - X .GT. 0.0E0 -C FNU - order of the initial Y function, FNU .GE. 0.0E0 -C N - number of members in the sequence, N .GE. 1 -C -C Output -C Y - a vector whose first N components contain values -C for the sequence Y(I)=Y/sub(FNU+I-1)/(X), I=1,N. -C -C Error Conditions -C Improper input arguments - a fatal error -C Overflow - a fatal error -C -C***REFERENCES F. W. J. Olver, Tables of Bessel Functions of Moderate -C or Large Orders, NPL Mathematical Tables 6, Her -C Majesty's Stationery Office, London, 1962. -C N. M. Temme, On the numerical evaluation of the modified -C Bessel function of the third kind, Journal of -C Computational Physics 19, (1975), pp. 324-337. -C N. M. Temme, On the numerical evaluation of the ordinary -C Bessel function of the second kind, Journal of -C Computational Physics 21, (1976), pp. 343-350. -C***ROUTINES CALLED ASYJY, BESY0, BESY1, BESYNU, I1MACH, R1MACH, -C XERMSG, YAIRY -C***REVISION HISTORY (YYMMDD) -C 800501 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE BESY -C - EXTERNAL YAIRY - INTEGER I, IFLW, J, N, NB, ND, NN, NUD, NULIM - INTEGER I1MACH - REAL AZN,CN,DNU,ELIM,FLGJY,FN,FNU,RAN,S,S1,S2,TM,TRX, - 1 W,WK,W2N,X,XLIM,XXN,Y - REAL BESY0, BESY1, R1MACH - DIMENSION W(2), NULIM(2), Y(*), WK(7) - SAVE NULIM - DATA NULIM(1),NULIM(2) / 70 , 100 / -C***FIRST EXECUTABLE STATEMENT BESY - NN = -I1MACH(12) - ELIM = 2.303E0*(NN*R1MACH(5)-3.0E0) - XLIM = R1MACH(1)*1.0E+3 - IF (FNU.LT.0.0E0) GO TO 140 - IF (X.LE.0.0E0) GO TO 150 - IF (X.LT.XLIM) GO TO 170 - IF (N.LT.1) GO TO 160 -C -C ND IS A DUMMY VARIABLE FOR N -C - ND = N - NUD = INT(FNU) - DNU = FNU - NUD - NN = MIN(2,ND) - FN = FNU + N - 1 - IF (FN.LT.2.0E0) GO TO 100 -C -C OVERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION) -C FOR THE LAST ORDER, FNU+N-1.GE.NULIM -C - XXN = X/FN - W2N = 1.0E0-XXN*XXN - IF(W2N.LE.0.0E0) GO TO 10 - RAN = SQRT(W2N) - AZN = LOG((1.0E0+RAN)/XXN) - RAN - CN = FN*AZN - IF(CN.GT.ELIM) GO TO 170 - 10 CONTINUE - IF (NUD.LT.NULIM(NN)) GO TO 20 -C -C ASYMPTOTIC EXPANSION FOR ORDERS FNU AND FNU+1.GE.NULIM -C - FLGJY = -1.0E0 - CALL ASYJY(YAIRY,X,FNU,FLGJY,NN,Y,WK,IFLW) - IF(IFLW.NE.0) GO TO 170 - IF (NN.EQ.1) RETURN - TRX = 2.0E0/X - TM = (FNU+FNU+2.0E0)/X - GO TO 80 -C - 20 CONTINUE - IF (DNU.NE.0.0E0) GO TO 30 - S1 = BESY0(X) - IF (NUD.EQ.0 .AND. ND.EQ.1) GO TO 70 - S2 = BESY1(X) - GO TO 40 - 30 CONTINUE - NB = 2 - IF (NUD.EQ.0 .AND. ND.EQ.1) NB = 1 - CALL BESYNU(X, DNU, NB, W) - S1 = W(1) - IF (NB.EQ.1) GO TO 70 - S2 = W(2) - 40 CONTINUE - TRX = 2.0E0/X - TM = (DNU+DNU+2.0E0)/X -C FORWARD RECUR FROM DNU TO FNU+1 TO GET Y(1) AND Y(2) - IF (ND.EQ.1) NUD = NUD - 1 - IF (NUD.GT.0) GO TO 50 - IF (ND.GT.1) GO TO 70 - S1 = S2 - GO TO 70 - 50 CONTINUE - DO 60 I=1,NUD - S = S2 - S2 = TM*S2 - S1 - S1 = S - TM = TM + TRX - 60 CONTINUE - IF (ND.EQ.1) S1 = S2 - 70 CONTINUE - Y(1) = S1 - IF (ND.EQ.1) RETURN - Y(2) = S2 - 80 CONTINUE - IF (ND.EQ.2) RETURN -C FORWARD RECUR FROM FNU+2 TO FNU+N-1 - DO 90 I=3,ND - Y(I) = TM*Y(I-1) - Y(I-2) - TM = TM + TRX - 90 CONTINUE - RETURN -C - 100 CONTINUE -C OVERFLOW TEST - IF (FN.LE.1.0E0) GO TO 110 - IF (-FN*(LOG(X)-0.693E0).GT.ELIM) GO TO 170 - 110 CONTINUE - IF (DNU.EQ.0.0E0) GO TO 120 - CALL BESYNU(X, FNU, ND, Y) - RETURN - 120 CONTINUE - J = NUD - IF (J.EQ.1) GO TO 130 - J = J + 1 - Y(J) = BESY0(X) - IF (ND.EQ.1) RETURN - J = J + 1 - 130 CONTINUE - Y(J) = BESY1(X) - IF (ND.EQ.1) RETURN - TRX = 2.0E0/X - TM = TRX - GO TO 80 -C -C -C - 140 CONTINUE - CALL XERMSG ('SLATEC', 'BESY', 'ORDER, FNU, LESS THAN ZERO', 2, - + 1) - RETURN - 150 CONTINUE - CALL XERMSG ('SLATEC', 'BESY', 'X LESS THAN OR EQUAL TO ZERO', 2, - + 1) - RETURN - 160 CONTINUE - CALL XERMSG ('SLATEC', 'BESY', 'N LESS THAN ONE', 2, 1) - RETURN - 170 CONTINUE - CALL XERMSG ('SLATEC', 'BESY', - + 'OVERFLOW, FNU OR N TOO LARGE OR X TOO SMALL', 6, 1) - RETURN - END diff --git a/slatec/besy0.f b/slatec/besy0.f deleted file mode 100644 index e533d78..0000000 --- a/slatec/besy0.f +++ /dev/null @@ -1,141 +0,0 @@ -*DECK BESY0 - FUNCTION BESY0 (X) -C***BEGIN PROLOGUE BESY0 -C***PURPOSE Compute the Bessel function of the second kind of order -C zero. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10A1 -C***TYPE SINGLE PRECISION (BESY0-S, DBESY0-D) -C***KEYWORDS BESSEL FUNCTION, FNLIB, ORDER ZERO, SECOND KIND, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C BESY0(X) calculates the Bessel function of the second kind -C of order zero for real argument X. -C -C Series for BY0 on the interval 0. to 1.60000D+01 -C with weighted error 1.20E-17 -C log weighted error 16.92 -C significant figures required 16.15 -C decimal places required 17.48 -C -C Series for BM0 on the interval 0. to 6.25000D-02 -C with weighted error 4.98E-17 -C log weighted error 16.30 -C significant figures required 14.97 -C decimal places required 16.96 -C -C Series for BTH0 on the interval 0. to 6.25000D-02 -C with weighted error 3.67E-17 -C log weighted error 16.44 -C significant figures required 15.53 -C decimal places required 17.13 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED BESJ0, CSEVL, INITS, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE BESY0 - DIMENSION BY0CS(13), BM0CS(21), BTH0CS(24) - LOGICAL FIRST - SAVE BY0CS, BM0CS, BTH0CS, TWODPI, PI4, - 1 NTY0, NTM0, NTTH0, XSML, XMAX, FIRST - DATA BY0CS( 1) / -.0112778393 92865573E0 / - DATA BY0CS( 2) / -.1283452375 6042035E0 / - DATA BY0CS( 3) / -.1043788479 9794249E0 / - DATA BY0CS( 4) / .0236627491 83969695E0 / - DATA BY0CS( 5) / -.0020903916 47700486E0 / - DATA BY0CS( 6) / .0001039754 53939057E0 / - DATA BY0CS( 7) / -.0000033697 47162423E0 / - DATA BY0CS( 8) / .0000000772 93842676E0 / - DATA BY0CS( 9) / -.0000000013 24976772E0 / - DATA BY0CS(10) / .0000000000 17648232E0 / - DATA BY0CS(11) / -.0000000000 00188105E0 / - DATA BY0CS(12) / .0000000000 00001641E0 / - DATA BY0CS(13) / -.0000000000 00000011E0 / - DATA BM0CS( 1) / .0928496163 7381644E0 / - DATA BM0CS( 2) / -.0014298770 7403484E0 / - DATA BM0CS( 3) / .0000283057 9271257E0 / - DATA BM0CS( 4) / -.0000014330 0611424E0 / - DATA BM0CS( 5) / .0000001202 8628046E0 / - DATA BM0CS( 6) / -.0000000139 7113013E0 / - DATA BM0CS( 7) / .0000000020 4076188E0 / - DATA BM0CS( 8) / -.0000000003 5399669E0 / - DATA BM0CS( 9) / .0000000000 7024759E0 / - DATA BM0CS(10) / -.0000000000 1554107E0 / - DATA BM0CS(11) / .0000000000 0376226E0 / - DATA BM0CS(12) / -.0000000000 0098282E0 / - DATA BM0CS(13) / .0000000000 0027408E0 / - DATA BM0CS(14) / -.0000000000 0008091E0 / - DATA BM0CS(15) / .0000000000 0002511E0 / - DATA BM0CS(16) / -.0000000000 0000814E0 / - DATA BM0CS(17) / .0000000000 0000275E0 / - DATA BM0CS(18) / -.0000000000 0000096E0 / - DATA BM0CS(19) / .0000000000 0000034E0 / - DATA BM0CS(20) / -.0000000000 0000012E0 / - DATA BM0CS(21) / .0000000000 0000004E0 / - DATA BTH0CS( 1) / -.2463916377 4300119E0 / - DATA BTH0CS( 2) / .0017370983 07508963E0 / - DATA BTH0CS( 3) / -.0000621836 33402968E0 / - DATA BTH0CS( 4) / .0000043680 50165742E0 / - DATA BTH0CS( 5) / -.0000004560 93019869E0 / - DATA BTH0CS( 6) / .0000000621 97400101E0 / - DATA BTH0CS( 7) / -.0000000103 00442889E0 / - DATA BTH0CS( 8) / .0000000019 79526776E0 / - DATA BTH0CS( 9) / -.0000000004 28198396E0 / - DATA BTH0CS(10) / .0000000001 02035840E0 / - DATA BTH0CS(11) / -.0000000000 26363898E0 / - DATA BTH0CS(12) / .0000000000 07297935E0 / - DATA BTH0CS(13) / -.0000000000 02144188E0 / - DATA BTH0CS(14) / .0000000000 00663693E0 / - DATA BTH0CS(15) / -.0000000000 00215126E0 / - DATA BTH0CS(16) / .0000000000 00072659E0 / - DATA BTH0CS(17) / -.0000000000 00025465E0 / - DATA BTH0CS(18) / .0000000000 00009229E0 / - DATA BTH0CS(19) / -.0000000000 00003448E0 / - DATA BTH0CS(20) / .0000000000 00001325E0 / - DATA BTH0CS(21) / -.0000000000 00000522E0 / - DATA BTH0CS(22) / .0000000000 00000210E0 / - DATA BTH0CS(23) / -.0000000000 00000087E0 / - DATA BTH0CS(24) / .0000000000 00000036E0 / - DATA TWODPI / 0.6366197723 6758134E0 / - DATA PI4 / 0.7853981633 9744831E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT BESY0 - IF (FIRST) THEN - NTY0 = INITS (BY0CS, 13, 0.1*R1MACH(3)) - NTM0 = INITS (BM0CS, 21, 0.1*R1MACH(3)) - NTTH0 = INITS (BTH0CS, 24, 0.1*R1MACH(3)) -C - XSML = SQRT (4.0*R1MACH(3)) - XMAX = 1.0/R1MACH(4) - ENDIF - FIRST = .FALSE. -C - IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'BESY0', - + 'X IS ZERO OR NEGATIVE', 1, 2) - IF (X.GT.4.0) GO TO 20 -C - Y = 0. - IF (X.GT.XSML) Y = X*X - BESY0 = TWODPI*LOG(0.5*X)*BESJ0(X) + .375 + CSEVL (.125*Y-1., - 1 BY0CS, NTY0) - RETURN -C - 20 IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'BESY0', - + 'NO PRECISION BECAUSE X IS BIG', 2, 2) -C - Z = 32.0/X**2 - 1.0 - AMPL = (0.75 + CSEVL (Z, BM0CS, NTM0)) / SQRT(X) - THETA = X - PI4 + CSEVL (Z, BTH0CS, NTTH0) / X - BESY0 = AMPL * SIN (THETA) -C - RETURN - END diff --git a/slatec/besy1.f b/slatec/besy1.f deleted file mode 100644 index fc38efb..0000000 --- a/slatec/besy1.f +++ /dev/null @@ -1,145 +0,0 @@ -*DECK BESY1 - FUNCTION BESY1 (X) -C***BEGIN PROLOGUE BESY1 -C***PURPOSE Compute the Bessel function of the second kind of order -C one. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10A1 -C***TYPE SINGLE PRECISION (BESY1-S, DBESY1-D) -C***KEYWORDS BESSEL FUNCTION, FNLIB, ORDER ONE, SECOND KIND, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C BESY1(X) calculates the Bessel function of the second kind of -C order one for real argument X. -C -C Series for BY1 on the interval 0. to 1.60000D+01 -C with weighted error 1.87E-18 -C log weighted error 17.73 -C significant figures required 17.83 -C decimal places required 18.30 -C -C Series for BM1 on the interval 0. to 6.25000D-02 -C with weighted error 5.61E-17 -C log weighted error 16.25 -C significant figures required 14.97 -C decimal places required 16.91 -C -C Series for BTH1 on the interval 0. to 6.25000D-02 -C with weighted error 4.10E-17 -C log weighted error 16.39 -C significant figures required 15.96 -C decimal places required 17.08 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED BESJ1, CSEVL, INITS, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE BESY1 - DIMENSION BY1CS(14), BM1CS(21), BTH1CS(24) - LOGICAL FIRST - SAVE BY1CS, BM1CS, BTH1CS, TWODPI, PI4, - 1 NTY1, NTM1, NTTH1, XMIN, XSML, XMAX, FIRST - DATA BY1CS( 1) / .0320804710 0611908629E0 / - DATA BY1CS( 2) / 1.2627078974 33500450E0 / - DATA BY1CS( 3) / .0064999618 9992317500E0 / - DATA BY1CS( 4) / -.0893616452 8860504117E0 / - DATA BY1CS( 5) / .0132508812 2175709545E0 / - DATA BY1CS( 6) / -.0008979059 1196483523E0 / - DATA BY1CS( 7) / .0000364736 1487958306E0 / - DATA BY1CS( 8) / -.0000010013 7438166600E0 / - DATA BY1CS( 9) / .0000000199 4539657390E0 / - DATA BY1CS(10) / -.0000000003 0230656018E0 / - DATA BY1CS(11) / .0000000000 0360987815E0 / - DATA BY1CS(12) / -.0000000000 0003487488E0 / - DATA BY1CS(13) / .0000000000 0000027838E0 / - DATA BY1CS(14) / -.0000000000 0000000186E0 / - DATA BM1CS( 1) / .1047362510 931285E0 / - DATA BM1CS( 2) / .0044244389 3702345E0 / - DATA BM1CS( 3) / -.0000566163 9504035E0 / - DATA BM1CS( 4) / .0000023134 9417339E0 / - DATA BM1CS( 5) / -.0000001737 7182007E0 / - DATA BM1CS( 6) / .0000000189 3209930E0 / - DATA BM1CS( 7) / -.0000000026 5416023E0 / - DATA BM1CS( 8) / .0000000004 4740209E0 / - DATA BM1CS( 9) / -.0000000000 8691795E0 / - DATA BM1CS(10) / .0000000000 1891492E0 / - DATA BM1CS(11) / -.0000000000 0451884E0 / - DATA BM1CS(12) / .0000000000 0116765E0 / - DATA BM1CS(13) / -.0000000000 0032265E0 / - DATA BM1CS(14) / .0000000000 0009450E0 / - DATA BM1CS(15) / -.0000000000 0002913E0 / - DATA BM1CS(16) / .0000000000 0000939E0 / - DATA BM1CS(17) / -.0000000000 0000315E0 / - DATA BM1CS(18) / .0000000000 0000109E0 / - DATA BM1CS(19) / -.0000000000 0000039E0 / - DATA BM1CS(20) / .0000000000 0000014E0 / - DATA BM1CS(21) / -.0000000000 0000005E0 / - DATA BTH1CS( 1) / .7406014102 6313850E0 / - DATA BTH1CS( 2) / -.0045717556 59637690E0 / - DATA BTH1CS( 3) / .0001198185 10964326E0 / - DATA BTH1CS( 4) / -.0000069645 61891648E0 / - DATA BTH1CS( 5) / .0000006554 95621447E0 / - DATA BTH1CS( 6) / -.0000000840 66228945E0 / - DATA BTH1CS( 7) / .0000000133 76886564E0 / - DATA BTH1CS( 8) / -.0000000024 99565654E0 / - DATA BTH1CS( 9) / .0000000005 29495100E0 / - DATA BTH1CS(10) / -.0000000001 24135944E0 / - DATA BTH1CS(11) / .0000000000 31656485E0 / - DATA BTH1CS(12) / -.0000000000 08668640E0 / - DATA BTH1CS(13) / .0000000000 02523758E0 / - DATA BTH1CS(14) / -.0000000000 00775085E0 / - DATA BTH1CS(15) / .0000000000 00249527E0 / - DATA BTH1CS(16) / -.0000000000 00083773E0 / - DATA BTH1CS(17) / .0000000000 00029205E0 / - DATA BTH1CS(18) / -.0000000000 00010534E0 / - DATA BTH1CS(19) / .0000000000 00003919E0 / - DATA BTH1CS(20) / -.0000000000 00001500E0 / - DATA BTH1CS(21) / .0000000000 00000589E0 / - DATA BTH1CS(22) / -.0000000000 00000237E0 / - DATA BTH1CS(23) / .0000000000 00000097E0 / - DATA BTH1CS(24) / -.0000000000 00000040E0 / - DATA TWODPI / 0.6366197723 6758134E0 / - DATA PI4 / 0.7853981633 9744831E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT BESY1 - IF (FIRST) THEN - NTY1 = INITS (BY1CS, 14, 0.1*R1MACH(3)) - NTM1 = INITS (BM1CS, 21, 0.1*R1MACH(3)) - NTTH1 = INITS (BTH1CS, 24, 0.1*R1MACH(3)) -C - XMIN = 1.571*EXP ( MAX(LOG(R1MACH(1)), -LOG(R1MACH(2)))+.01) - XSML = SQRT (4.0*R1MACH(3)) - XMAX = 1.0/R1MACH(4) - ENDIF - FIRST = .FALSE. -C - IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'BESY1', - + 'X IS ZERO OR NEGATIVE', 1, 2) - IF (X.GT.4.0) GO TO 20 -C - IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'BESY1', - + 'X SO SMALL Y1 OVERFLOWS', 3, 2) - Y = 0. - IF (X.GT.XSML) Y = X*X - BESY1 = TWODPI*LOG(0.5*X)*BESJ1(X) + - 1 (0.5 + CSEVL (.125*Y-1., BY1CS, NTY1))/X - RETURN -C - 20 IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'BESY1', - + 'NO PRECISION BECAUSE X IS BIG', 2, 2) -C - Z = 32.0/X**2 - 1.0 - AMPL = (0.75 + CSEVL (Z, BM1CS, NTM1)) / SQRT(X) - THETA = X - 3.0*PI4 + CSEVL (Z, BTH1CS, NTTH1) / X - BESY1 = AMPL * SIN (THETA) -C - RETURN - END diff --git a/slatec/besynu.f b/slatec/besynu.f deleted file mode 100644 index 95c61c1..0000000 --- a/slatec/besynu.f +++ /dev/null @@ -1,353 +0,0 @@ -*DECK BESYNU - SUBROUTINE BESYNU (X, FNU, N, Y) -C***BEGIN PROLOGUE BESYNU -C***SUBSIDIARY -C***PURPOSE Subsidiary to BESY -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (BESYNU-S, DBSYNU-D) -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C BESYNU computes N member sequences of Y Bessel functions -C Y/SUB(FNU+I-1)/(X), I=1,N for non-negative orders FNU and -C positive X. Equations of the references are implemented on -C small orders DNU for Y/SUB(DNU)/(X) and Y/SUB(DNU+1)/(X). -C Forward recursion with the three term recursion relation -C generates higher orders FNU+I-1, I=1,...,N. -C -C To start the recursion FNU is normalized to the interval -C -0.5.LE.DNU.LT.0.5. A special form of the power series is -C implemented on 0.LT.X.LE.X1 while the Miller algorithm for the -C K Bessel function in terms of the confluent hypergeometric -C function U(FNU+0.5,2*FNU+1,I*X) is implemented on X1.LT.X.LE.X -C Here I is the complex number SQRT(-1.). -C For X.GT.X2, the asymptotic expansion for large X is used. -C When FNU is a half odd integer, a special formula for -C DNU=-0.5 and DNU+1.0=0.5 is used to start the recursion. -C -C BESYNU assumes that a significant digit SINH(X) function is -C available. -C -C Description of Arguments -C -C Input -C X - X.GT.0.0E0 -C FNU - Order of initial Y function, FNU.GE.0.0E0 -C N - Number of members of the sequence, N.GE.1 -C -C Output -C Y - A vector whose first N components contain values -C for the sequence Y(I)=Y/SUB(FNU+I-1), I=1,N. -C -C Error Conditions -C Improper input arguments - a fatal error -C Overflow - a fatal error -C -C***SEE ALSO BESY -C***REFERENCES N. M. Temme, On the numerical evaluation of the ordinary -C Bessel function of the second kind, Journal of -C Computational Physics 21, (1976), pp. 343-350. -C N. M. Temme, On the numerical evaluation of the modified -C Bessel function of the third kind, Journal of -C Computational Physics 19, (1975), pp. 324-337. -C***ROUTINES CALLED GAMMA, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800501 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900328 Added TYPE section. (WRB) -C 900727 Added EXTERNAL statement. (WRB) -C 910408 Updated the AUTHOR and REFERENCES sections. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE BESYNU -C - INTEGER I, INU, J, K, KK, N, NN - REAL A, AK, ARG, A1, A2, BK, CB, CBK, CC, CCK, CK, COEF, CPT, - 1 CP1, CP2, CS, CS1, CS2, CX, DNU, DNU2, ETEST, ETX, F, FC, FHS, - 2 FK, FKS, FLRX, FMU, FN, FNU, FX, G, G1, G2, HPI, P, PI, PT, Q, - 3 RB, RBK, RCK, RELB, RPT, RP1, RP2, RS, RS1, RS2, RTHPI, RX, S, - 4 SA, SB, SMU, SS, ST, S1, S2, TB, TM, TOL, T1, T2, X, X1, X2, Y - DIMENSION A(120), RB(120), CB(120), Y(*), CC(8) - REAL GAMMA, R1MACH - EXTERNAL GAMMA - SAVE X1, X2, PI, RTHPI, HPI, CC - DATA X1, X2 / 3.0E0, 20.0E0 / - DATA PI,RTHPI / 3.14159265358979E+00, 7.97884560802865E-01/ - DATA HPI / 1.57079632679490E+00/ - DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8) - 1 / 5.77215664901533E-01,-4.20026350340952E-02, - 2-4.21977345555443E-02, 7.21894324666300E-03,-2.15241674114900E-04, - 3-2.01348547807000E-05, 1.13302723200000E-06, 6.11609500000000E-09/ -C***FIRST EXECUTABLE STATEMENT BESYNU - AK = R1MACH(3) - TOL = MAX(AK,1.0E-15) - IF (X.LE.0.0E0) GO TO 270 - IF (FNU.LT.0.0E0) GO TO 280 - IF (N.LT.1) GO TO 290 - RX = 2.0E0/X - INU = INT(FNU+0.5E0) - DNU = FNU - INU - IF (ABS(DNU).EQ.0.5E0) GO TO 260 - DNU2 = 0.0E0 - IF (ABS(DNU).LT.TOL) GO TO 10 - DNU2 = DNU*DNU - 10 CONTINUE - IF (X.GT.X1) GO TO 120 -C -C SERIES FOR X.LE.X1 -C - A1 = 1.0E0 - DNU - A2 = 1.0E0 + DNU - T1 = 1.0E0/GAMMA(A1) - T2 = 1.0E0/GAMMA(A2) - IF (ABS(DNU).GT.0.1E0) GO TO 40 -C SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) - S = CC(1) - AK = 1.0E0 - DO 20 K=2,8 - AK = AK*DNU2 - TM = CC(K)*AK - S = S + TM - IF (ABS(TM).LT.TOL) GO TO 30 - 20 CONTINUE - 30 G1 = -(S+S) - GO TO 50 - 40 CONTINUE - G1 = (T1-T2)/DNU - 50 CONTINUE - G2 = T1 + T2 - SMU = 1.0E0 - FC = 1.0E0/PI - FLRX = LOG(RX) - FMU = DNU*FLRX - TM = 0.0E0 - IF (DNU.EQ.0.0E0) GO TO 60 - TM = SIN(DNU*HPI)/DNU - TM = (DNU+DNU)*TM*TM - FC = DNU/SIN(DNU*PI) - IF (FMU.NE.0.0E0) SMU = SINH(FMU)/FMU - 60 CONTINUE - F = FC*(G1*COSH(FMU)+G2*FLRX*SMU) - FX = EXP(FMU) - P = FC*T1*FX - Q = FC*T2/FX - G = F + TM*Q - AK = 1.0E0 - CK = 1.0E0 - BK = 1.0E0 - S1 = G - S2 = P - IF (INU.GT.0 .OR. N.GT.1) GO TO 90 - IF (X.LT.TOL) GO TO 80 - CX = X*X*0.25E0 - 70 CONTINUE - F = (AK*F+P+Q)/(BK-DNU2) - P = P/(AK-DNU) - Q = Q/(AK+DNU) - G = F + TM*Q - CK = -CK*CX/AK - T1 = CK*G - S1 = S1 + T1 - BK = BK + AK + AK + 1.0E0 - AK = AK + 1.0E0 - S = ABS(T1)/(1.0E0+ABS(S1)) - IF (S.GT.TOL) GO TO 70 - 80 CONTINUE - Y(1) = -S1 - RETURN - 90 CONTINUE - IF (X.LT.TOL) GO TO 110 - CX = X*X*0.25E0 - 100 CONTINUE - F = (AK*F+P+Q)/(BK-DNU2) - P = P/(AK-DNU) - Q = Q/(AK+DNU) - G = F + TM*Q - CK = -CK*CX/AK - T1 = CK*G - S1 = S1 + T1 - T2 = CK*(P-AK*G) - S2 = S2 + T2 - BK = BK + AK + AK + 1.0E0 - AK = AK + 1.0E0 - S = ABS(T1)/(1.0E0+ABS(S1)) + ABS(T2)/(1.0E0+ABS(S2)) - IF (S.GT.TOL) GO TO 100 - 110 CONTINUE - S2 = -S2*RX - S1 = -S1 - GO TO 160 - 120 CONTINUE - COEF = RTHPI/SQRT(X) - IF (X.GT.X2) GO TO 210 -C -C MILLER ALGORITHM FOR X1.LT.X.LE.X2 -C - ETEST = COS(PI*DNU)/(PI*X*TOL) - FKS = 1.0E0 - FHS = 0.25E0 - FK = 0.0E0 - RCK = 2.0E0 - CCK = X + X - RP1 = 0.0E0 - CP1 = 0.0E0 - RP2 = 1.0E0 - CP2 = 0.0E0 - K = 0 - 130 CONTINUE - K = K + 1 - FK = FK + 1.0E0 - AK = (FHS-DNU2)/(FKS+FK) - PT = FK + 1.0E0 - RBK = RCK/PT - CBK = CCK/PT - RPT = RP2 - CPT = CP2 - RP2 = RBK*RPT - CBK*CPT - AK*RP1 - CP2 = CBK*RPT + RBK*CPT - AK*CP1 - RP1 = RPT - CP1 = CPT - RB(K) = RBK - CB(K) = CBK - A(K) = AK - RCK = RCK + 2.0E0 - FKS = FKS + FK + FK + 1.0E0 - FHS = FHS + FK + FK - PT = MAX(ABS(RP1),ABS(CP1)) - FC = (RP1/PT)**2 + (CP1/PT)**2 - PT = PT*SQRT(FC)*FK - IF (ETEST.GT.PT) GO TO 130 - KK = K - RS = 1.0E0 - CS = 0.0E0 - RP1 = 0.0E0 - CP1 = 0.0E0 - RP2 = 1.0E0 - CP2 = 0.0E0 - DO 140 I=1,K - RPT = RP2 - CPT = CP2 - RP2 = (RB(KK)*RPT-CB(KK)*CPT-RP1)/A(KK) - CP2 = (CB(KK)*RPT+RB(KK)*CPT-CP1)/A(KK) - RP1 = RPT - CP1 = CPT - RS = RS + RP2 - CS = CS + CP2 - KK = KK - 1 - 140 CONTINUE - PT = MAX(ABS(RS),ABS(CS)) - FC = (RS/PT)**2 + (CS/PT)**2 - PT = PT*SQRT(FC) - RS1 = (RP2*(RS/PT)+CP2*(CS/PT))/PT - CS1 = (CP2*(RS/PT)-RP2*(CS/PT))/PT - FC = HPI*(DNU-0.5E0) - X - P = COS(FC) - Q = SIN(FC) - S1 = (CS1*Q-RS1*P)*COEF - IF (INU.GT.0 .OR. N.GT.1) GO TO 150 - Y(1) = S1 - RETURN - 150 CONTINUE - PT = MAX(ABS(RP2),ABS(CP2)) - FC = (RP2/PT)**2 + (CP2/PT)**2 - PT = PT*SQRT(FC) - RPT = DNU + 0.5E0 - (RP1*(RP2/PT)+CP1*(CP2/PT))/PT - CPT = X - (CP1*(RP2/PT)-RP1*(CP2/PT))/PT - CS2 = CS1*CPT - RS1*RPT - RS2 = RPT*CS1 + RS1*CPT - S2 = (RS2*Q+CS2*P)*COEF/X -C -C FORWARD RECURSION ON THE THREE TERM RECURSION RELATION -C - 160 CONTINUE - CK = (DNU+DNU+2.0E0)/X - IF (N.EQ.1) INU = INU - 1 - IF (INU.GT.0) GO TO 170 - IF (N.GT.1) GO TO 190 - S1 = S2 - GO TO 190 - 170 CONTINUE - DO 180 I=1,INU - ST = S2 - S2 = CK*S2 - S1 - S1 = ST - CK = CK + RX - 180 CONTINUE - IF (N.EQ.1) S1 = S2 - 190 CONTINUE - Y(1) = S1 - IF (N.EQ.1) RETURN - Y(2) = S2 - IF (N.EQ.2) RETURN - DO 200 I=3,N - Y(I) = CK*Y(I-1) - Y(I-2) - CK = CK + RX - 200 CONTINUE - RETURN -C -C ASYMPTOTIC EXPANSION FOR LARGE X, X.GT.X2 -C - 210 CONTINUE - NN = 2 - IF (INU.EQ.0 .AND. N.EQ.1) NN = 1 - DNU2 = DNU + DNU - FMU = 0.0E0 - IF (ABS(DNU2).LT.TOL) GO TO 220 - FMU = DNU2*DNU2 - 220 CONTINUE - ARG = X - HPI*(DNU+0.5E0) - SA = SIN(ARG) - SB = COS(ARG) - ETX = 8.0E0*X - DO 250 K=1,NN - S1 = S2 - T2 = (FMU-1.0E0)/ETX - SS = T2 - RELB = TOL*ABS(T2) - T1 = ETX - S = 1.0E0 - FN = 1.0E0 - AK = 0.0E0 - DO 230 J=1,13 - T1 = T1 + ETX - AK = AK + 8.0E0 - FN = FN + AK - T2 = -T2*(FMU-FN)/T1 - S = S + T2 - T1 = T1 + ETX - AK = AK + 8.0E0 - FN = FN + AK - T2 = T2*(FMU-FN)/T1 - SS = SS + T2 - IF (ABS(T2).LE.RELB) GO TO 240 - 230 CONTINUE - 240 S2 = COEF*(S*SA+SS*SB) - FMU = FMU + 8.0E0*DNU + 4.0E0 - TB = SA - SA = -SB - SB = TB - 250 CONTINUE - IF (NN.GT.1) GO TO 160 - S1 = S2 - GO TO 190 -C -C FNU=HALF ODD INTEGER CASE -C - 260 CONTINUE - COEF = RTHPI/SQRT(X) - S1 = COEF*SIN(X) - S2 = -COEF*COS(X) - GO TO 160 -C -C - 270 CALL XERMSG ('SLATEC', 'BESYNU', 'X NOT GREATER THAN ZERO', 2, 1) - RETURN - 280 CALL XERMSG ('SLATEC', 'BESYNU', 'FNU NOT ZERO OR POSITIVE', 2, - + 1) - RETURN - 290 CALL XERMSG ('SLATEC', 'BESYNU', 'N NOT GREATER THAN 0', 2, 1) - RETURN - END diff --git a/slatec/beta.f b/slatec/beta.f deleted file mode 100644 index a8fee97..0000000 --- a/slatec/beta.f +++ /dev/null @@ -1,51 +0,0 @@ -*DECK BETA - FUNCTION BETA (A, B) -C***BEGIN PROLOGUE BETA -C***PURPOSE Compute the complete Beta function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7B -C***TYPE SINGLE PRECISION (BETA-S, DBETA-D, CBETA-C) -C***KEYWORDS COMPLETE BETA FUNCTION, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C BETA computes the complete beta function. -C -C Input Parameters: -C A real and positive -C B real and positive -C -C***REFERENCES (NONE) -C***ROUTINES CALLED ALBETA, GAMLIM, GAMMA, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900727 Added EXTERNAL statement. (WRB) -C***END PROLOGUE BETA - EXTERNAL GAMMA - SAVE XMAX, ALNSML - DATA XMAX, ALNSML /0., 0./ -C***FIRST EXECUTABLE STATEMENT BETA - IF (ALNSML.NE.0.0) GO TO 10 - CALL GAMLIM (XMIN, XMAX) - ALNSML = LOG(R1MACH(1)) -C - 10 IF (A .LE. 0. .OR. B .LE. 0.) CALL XERMSG ('SLATEC', 'BETA', - + 'BOTH ARGUMENTS MUST BE GT 0', 2, 2) -C - IF (A+B.LT.XMAX) BETA = GAMMA(A) * GAMMA(B) / GAMMA(A+B) - IF (A+B.LT.XMAX) RETURN -C - BETA = ALBETA (A, B) - IF (BETA .LT. ALNSML) CALL XERMSG ('SLATEC', 'BETA', - + 'A AND/OR B SO BIG BETA UNDERFLOWS', 1, 2) -C - BETA = EXP (BETA) -C - RETURN - END diff --git a/slatec/betai.f b/slatec/betai.f deleted file mode 100644 index 1d281da..0000000 --- a/slatec/betai.f +++ /dev/null @@ -1,118 +0,0 @@ -*DECK BETAI - REAL FUNCTION BETAI (X, PIN, QIN) -C***BEGIN PROLOGUE BETAI -C***PURPOSE Calculate the incomplete Beta function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7F -C***TYPE SINGLE PRECISION (BETAI-S, DBETAI-D) -C***KEYWORDS FNLIB, INCOMPLETE BETA FUNCTION, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C BETAI calculates the REAL incomplete beta function. -C -C The incomplete beta function ratio is the probability that a -C random variable from a beta distribution having parameters PIN and -C QIN will be less than or equal to X. -C -C -- Input Arguments -- All arguments are REAL. -C X upper limit of integration. X must be in (0,1) inclusive. -C PIN first beta distribution parameter. PIN must be .GT. 0.0. -C QIN second beta distribution parameter. QIN must be .GT. 0.0. -C -C***REFERENCES Nancy E. Bosten and E. L. Battiste, Remark on Algorithm -C 179, Communications of the ACM 17, 3 (March 1974), -C pp. 156. -C***ROUTINES CALLED ALBETA, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920528 DESCRIPTION and REFERENCES sections revised. (WRB) -C***END PROLOGUE BETAI - LOGICAL FIRST - SAVE EPS, ALNEPS, SML, ALNSML, FIRST - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT BETAI - IF (FIRST) THEN - EPS = R1MACH(3) - ALNEPS = LOG(EPS) - SML = R1MACH(1) - ALNSML = LOG(SML) - ENDIF - FIRST = .FALSE. -C - IF (X .LT. 0. .OR. X .GT. 1.0) CALL XERMSG ('SLATEC', 'BETAI', - + 'X IS NOT IN THE RANGE (0,1)', 1, 2) - IF (PIN .LE. 0. .OR. QIN .LE. 0.) CALL XERMSG ('SLATEC', 'BETAI', - + 'P AND/OR Q IS LE ZERO', 2, 2) -C - Y = X - P = PIN - Q = QIN - IF (Q.LE.P .AND. X.LT.0.8) GO TO 20 - IF (X.LT.0.2) GO TO 20 - Y = 1.0 - Y - P = QIN - Q = PIN -C - 20 IF ((P+Q)*Y/(P+1.).LT.EPS) GO TO 80 -C -C EVALUATE THE INFINITE SUM FIRST. -C TERM WILL EQUAL Y**P/BETA(PS,P) * (1.-PS)I * Y**I / FAC(I) -C - PS = Q - AINT(Q) - IF (PS.EQ.0.) PS = 1.0 - XB = P*LOG(Y) - ALBETA(PS, P) - LOG(P) - BETAI = 0.0 - IF (XB.LT.ALNSML) GO TO 40 -C - BETAI = EXP (XB) - TERM = BETAI*P - IF (PS.EQ.1.0) GO TO 40 -C - N = MAX (ALNEPS/LOG(Y), 4.0E0) - DO 30 I=1,N - TERM = TERM*(I-PS)*Y/I - BETAI = BETAI + TERM/(P+I) - 30 CONTINUE -C -C NOW EVALUATE THE FINITE SUM, MAYBE. -C - 40 IF (Q.LE.1.0) GO TO 70 -C - XB = P*LOG(Y) + Q*LOG(1.0-Y) - ALBETA(P,Q) - LOG(Q) - IB = MAX (XB/ALNSML, 0.0E0) - TERM = EXP (XB - IB*ALNSML) - C = 1.0/(1.0-Y) - P1 = Q*C/(P+Q-1.) -C - FINSUM = 0.0 - N = Q - IF (Q.EQ.REAL(N)) N = N - 1 - DO 50 I=1,N - IF (P1.LE.1.0 .AND. TERM/EPS.LE.FINSUM) GO TO 60 - TERM = (Q-I+1)*C*TERM/(P+Q-I) -C - IF (TERM.GT.1.0) IB = IB - 1 - IF (TERM.GT.1.0) TERM = TERM*SML -C - IF (IB.EQ.0) FINSUM = FINSUM + TERM - 50 CONTINUE -C - 60 BETAI = BETAI + FINSUM - 70 IF (Y.NE.X .OR. P.NE.PIN) BETAI = 1.0 - BETAI - BETAI = MAX (MIN (BETAI, 1.0), 0.0) - RETURN -C - 80 BETAI = 0.0 - XB = P*LOG(MAX(Y,SML)) - LOG(P) - ALBETA(P,Q) - IF (XB.GT.ALNSML .AND. Y.NE.0.) BETAI = EXP (XB) - IF (Y.NE.X .OR. P.NE.PIN) BETAI = 1.0 - BETAI - RETURN -C - END diff --git a/slatec/bfqad.f b/slatec/bfqad.f deleted file mode 100644 index eed8db1..0000000 --- a/slatec/bfqad.f +++ /dev/null @@ -1,134 +0,0 @@ -*DECK BFQAD - SUBROUTINE BFQAD (F, T, BCOEF, N, K, ID, X1, X2, TOL, QUAD, IERR, - + WORK) -C***BEGIN PROLOGUE BFQAD -C***PURPOSE Compute the integral of a product of a function and a -C derivative of a B-spline. -C***LIBRARY SLATEC -C***CATEGORY H2A2A1, E3, K6 -C***TYPE SINGLE PRECISION (BFQAD-S, DBFQAD-D) -C***KEYWORDS INTEGRAL OF B-SPLINE, QUADRATURE -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C BFQAD computes the integral on (X1,X2) of a product of a -C function F and the ID-th derivative of a K-th order B-spline, -C using the B-representation (T,BCOEF,N,K). (X1,X2) must be -C a subinterval of T(K) .LE. X .le. T(N+1). An integration -C routine BSGQ8 (a modification -C of GAUS8), integrates the product on sub- -C intervals of (X1,X2) formed by included (distinct) knots. -C -C Description of Arguments -C Input -C F - external function of one argument for the -C integrand BF(X)=F(X)*BVALU(T,BCOEF,N,K,ID,X,INBV, -C WORK) -C T - knot array of length N+K -C BCOEF - coefficient array of length N -C N - length of coefficient array -C K - order of B-spline, K .GE. 1 -C ID - order of the spline derivative, 0 .LE. ID .LE. K-1 -C ID=0 gives the spline function -C X1,X2 - end points of quadrature interval in -C T(K) .LE. X .LE. T(N+1) -C TOL - desired accuracy for the quadrature, suggest -C 10.*STOL .LT. TOL .LE. 0.1 where STOL is the single -C precision unit roundoff for the machine = R1MACH(4) -C -C Output -C QUAD - integral of BF(X) on (X1,X2) -C IERR - a status code -C IERR=1 normal return -C 2 some quadrature on (X1,X2) does not meet -C the requested tolerance. -C WORK - work vector of length 3*K -C -C Error Conditions -C X1 or X2 not in T(K) .LE. X .LE. T(N+1) is a fatal error. -C TOL not greater than the single precision unit roundoff or -C less than 0.1 is a fatal error. -C Some quadrature fails to meet the requested tolerance. -C -C***REFERENCES D. E. Amos, Quadrature subroutines for splines and -C B-splines, Report SAND79-1825, Sandia Laboratories, -C December 1979. -C***ROUTINES CALLED BSGQ8, INTRV, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800901 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE BFQAD -C -C - INTEGER ID, IERR, IFLG, ILO, IL1, IL2, K, LEFT, MFLAG, N, NPK, NP1 - REAL A,AA,ANS,B,BB,BCOEF,Q,QUAD,T,TA,TB,TOL,WORK,WTOL, X1, - 1 X2 - REAL R1MACH, F - DIMENSION T(*), BCOEF(*), WORK(*) - EXTERNAL F -C***FIRST EXECUTABLE STATEMENT BFQAD - IERR = 1 - QUAD = 0.0E0 - IF(K.LT.1) GO TO 100 - IF(N.LT.K) GO TO 105 - IF(ID.LT.0 .OR. ID.GE.K) GO TO 110 - WTOL = R1MACH(4) - IF (TOL.LT.WTOL .OR. TOL.GT.0.1E0) GO TO 30 - AA = MIN(X1,X2) - BB = MAX(X1,X2) - IF (AA.LT.T(K)) GO TO 20 - NP1 = N + 1 - IF (BB.GT.T(NP1)) GO TO 20 - IF (AA.EQ.BB) RETURN - NPK = N + K -C - ILO = 1 - CALL INTRV(T, NPK, AA, ILO, IL1, MFLAG) - CALL INTRV(T, NPK, BB, ILO, IL2, MFLAG) - IF (IL2.GE.NP1) IL2 = N - INBV = 1 - Q = 0.0E0 - DO 10 LEFT=IL1,IL2 - TA = T(LEFT) - TB = T(LEFT+1) - IF (TA.EQ.TB) GO TO 10 - A = MAX(AA,TA) - B = MIN(BB,TB) - CALL BSGQ8(F,T,BCOEF,N,K,ID,A,B,INBV,TOL,ANS,IFLG,WORK) - IF (IFLG.GT.1) IERR = 2 - Q = Q + ANS - 10 CONTINUE - IF (X1.GT.X2) Q = -Q - QUAD = Q - RETURN -C -C - 20 CONTINUE - CALL XERMSG ('SLATEC', 'BFQAD', - + 'X1 OR X2 OR BOTH DO NOT SATISFY T(K).LE.X.LE.T(N+1)', 2, 1) - RETURN - 30 CONTINUE - CALL XERMSG ('SLATEC', 'BFQAD', - + 'TOL IS LESS THAN THE SINGLE PRECISION TOLERANCE OR ' // - + 'GREATER THAN 0.1', 2, 1) - RETURN - 100 CONTINUE - CALL XERMSG ('SLATEC', 'BFQAD', 'K DOES NOT SATISFY K.GE.1', 2, - + 1) - RETURN - 105 CONTINUE - CALL XERMSG ('SLATEC', 'BFQAD', 'N DOES NOT SATISFY N.GE.K', 2, - + 1) - RETURN - 110 CONTINUE - CALL XERMSG ('SLATEC', 'BFQAD', - + 'ID DOES NOT SATISFY 0 .LE. ID .LT. K', 2, 1) - RETURN - END diff --git a/slatec/bi.f b/slatec/bi.f deleted file mode 100644 index 2aff250..0000000 --- a/slatec/bi.f +++ /dev/null @@ -1,130 +0,0 @@ -*DECK BI - FUNCTION BI (X) -C***BEGIN PROLOGUE BI -C***PURPOSE Evaluate the Bairy function (the Airy function of the -C second kind). -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10D -C***TYPE SINGLE PRECISION (BI-S, DBI-D) -C***KEYWORDS BAIRY FUNCTION, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C BI(X) calculates the Airy function of the second kind for real -C argument X. -C -C Series for BIF on the interval -1.00000D+00 to 1.00000D+00 -C with weighted error 1.88E-19 -C log weighted error 18.72 -C significant figures required 17.74 -C decimal places required 19.20 -C -C Series for BIG on the interval -1.00000D+00 to 1.00000D+00 -C with weighted error 2.61E-17 -C log weighted error 16.58 -C significant figures required 15.17 -C decimal places required 17.03 -C -C Series for BIF2 on the interval 1.00000D+00 to 8.00000D+00 -C with weighted error 1.11E-17 -C log weighted error 16.95 -C approx significant figures required 16.5 -C decimal places required 17.45 -C -C Series for BIG2 on the interval 1.00000D+00 to 8.00000D+00 -C with weighted error 1.19E-18 -C log weighted error 17.92 -C approx significant figures required 17.2 -C decimal places required 18.42 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED BIE, CSEVL, INITS, R1MACH, R9AIMP, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE BI - DIMENSION BIFCS(9), BIGCS(8), BIF2CS(10), BIG2CS(10) - LOGICAL FIRST - SAVE BIFCS, BIGCS, BIF2CS, BIG2CS, NBIF, NBIG, NBIF2, - 1 NBIG2, X3SML, XMAX, FIRST - DATA BIFCS( 1) / -.0167302164 7198664948E0 / - DATA BIFCS( 2) / .1025233583 424944561E0 / - DATA BIFCS( 3) / .0017083092 5073815165E0 / - DATA BIFCS( 4) / .0000118625 4546774468E0 / - DATA BIFCS( 5) / .0000000449 3290701779E0 / - DATA BIFCS( 6) / .0000000001 0698207143E0 / - DATA BIFCS( 7) / .0000000000 0017480643E0 / - DATA BIFCS( 8) / .0000000000 0000020810E0 / - DATA BIFCS( 9) / .0000000000 0000000018E0 / - DATA BIGCS( 1) / .0224662232 4857452E0 / - DATA BIGCS( 2) / .0373647754 5301955E0 / - DATA BIGCS( 3) / .0004447621 8957212E0 / - DATA BIGCS( 4) / .0000024708 0756363E0 / - DATA BIGCS( 5) / .0000000079 1913533E0 / - DATA BIGCS( 6) / .0000000000 1649807E0 / - DATA BIGCS( 7) / .0000000000 0002411E0 / - DATA BIGCS( 8) / .0000000000 0000002E0 / - DATA BIF2CS( 1) / 0.0998457269 3816041E0 / - DATA BIF2CS( 2) / .4786249778 63005538E0 / - DATA BIF2CS( 3) / .0251552119 604330118E0 / - DATA BIF2CS( 4) / .0005820693 885232645E0 / - DATA BIF2CS( 5) / .0000074997 659644377E0 / - DATA BIF2CS( 6) / .0000000613 460287034E0 / - DATA BIF2CS( 7) / .0000000003 462753885E0 / - DATA BIF2CS( 8) / .0000000000 014288910E0 / - DATA BIF2CS( 9) / .0000000000 000044962E0 / - DATA BIF2CS(10) / .0000000000 000000111E0 / - DATA BIG2CS( 1) / .0333056621 45514340E0 / - DATA BIG2CS( 2) / .1613092151 23197068E0 / - DATA BIG2CS( 3) / .0063190073 096134286E0 / - DATA BIG2CS( 4) / .0001187904 568162517E0 / - DATA BIG2CS( 5) / .0000013045 345886200E0 / - DATA BIG2CS( 6) / .0000000093 741259955E0 / - DATA BIG2CS( 7) / .0000000000 474580188E0 / - DATA BIG2CS( 8) / .0000000000 001783107E0 / - DATA BIG2CS( 9) / .0000000000 000005167E0 / - DATA BIG2CS(10) / .0000000000 000000011E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT BI - IF (FIRST) THEN - ETA = 0.1*R1MACH(3) - NBIF = INITS (BIFCS , 9, ETA) - NBIG = INITS (BIGCS , 8, ETA) - NBIF2 = INITS (BIF2CS, 10, ETA) - NBIG2 = INITS (BIG2CS, 10, ETA) -C - X3SML = ETA**0.3333 - XMAX = (1.5*LOG(R1MACH(2)))**0.6666 - ENDIF - FIRST = .FALSE. -C - IF (X.GE.(-1.0)) GO TO 20 - CALL R9AIMP (X, XM, THETA) - BI = XM * SIN(THETA) - RETURN -C - 20 IF (X.GT.1.0) GO TO 30 - Z = 0.0 - IF (ABS(X).GT.X3SML) Z = X**3 - BI = 0.625 + CSEVL (Z, BIFCS, NBIF) + X*(0.4375 + - 1 CSEVL (Z, BIGCS, NBIG)) - RETURN -C - 30 IF (X.GT.2.0) GO TO 40 - Z = (2.0*X**3 - 9.0) / 7.0 - BI = 1.125 + CSEVL (Z, BIF2CS, NBIF2) + X*(0.625 + - 1 CSEVL (Z, BIG2CS, NBIG2)) - RETURN -C - 40 IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'BI', - + 'X SO BIG THAT BI OVERFLOWS', 1, 2) -C - BI = BIE(X) * EXP(2.0*X*SQRT(X)/3.0) - RETURN -C - END diff --git a/slatec/bie.f b/slatec/bie.f deleted file mode 100644 index 0ecf641..0000000 --- a/slatec/bie.f +++ /dev/null @@ -1,206 +0,0 @@ -*DECK BIE - FUNCTION BIE (X) -C***BEGIN PROLOGUE BIE -C***PURPOSE Calculate the Bairy function for a negative argument and an -C exponentially scaled Bairy function for a non-negative -C argument. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10D -C***TYPE SINGLE PRECISION (BIE-S, DBIE-D) -C***KEYWORDS BAIRY FUNCTION, EXPONENTIALLY SCALED, FNLIB, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate BI(X) for X .LE. 0 and BI(X)*EXP(ZETA) where -C ZETA = 2/3 * X**(3/2) for X .GE. 0.0 -C -C Series for BIF on the interval -1.00000D+00 to 1.00000D+00 -C with weighted error 1.88E-19 -C log weighted error 18.72 -C significant figures required 17.74 -C decimal places required 19.20 -C -C Series for BIG on the interval -1.00000D+00 to 1.00000D+00 -C with weighted error 2.61E-17 -C log weighted error 16.58 -C significant figures required 15.17 -C decimal places required 17.03 -C -C Series for BIF2 on the interval 1.00000D+00 to 8.00000D+00 -C with weighted error 1.11E-17 -C log weighted error 16.95 -C approx significant figures required 16.5 -C decimal places required 17.45 -C -C Series for BIG2 on the interval 1.00000D+00 to 8.00000D+00 -C with weighted error 1.19E-18 -C log weighted error 17.92 -C approx significant figures required 17.2 -C decimal places required 18.42 -C -C Series for BIP on the interval 1.25000D-01 to 3.53553D-01 -C with weighted error 1.91E-17 -C log weighted error 16.72 -C significant figures required 15.35 -C decimal places required 17.41 -C -C Series for BIP2 on the interval 0. to 1.25000D-01 -C with weighted error 1.05E-18 -C log weighted error 17.98 -C significant figures required 16.74 -C decimal places required 18.71 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, INITS, R1MACH, R9AIMP -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890206 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE BIE - LOGICAL FIRST - DIMENSION BIFCS(9), BIGCS(8), BIF2CS(10), BIG2CS(10), BIPCS(24), - 1 BIP2CS(29) - SAVE BIFCS, BIGCS, BIF2CS, BIG2CS, BIPCS, BIP2CS, ATR, BTR, - 1 NBIF, NBIG, NBIF2, NBIG2, NBIP, NBIP2, X3SML, X32SML, XBIG, FIRST - DATA BIFCS( 1) / -.0167302164 7198664948E0 / - DATA BIFCS( 2) / .1025233583 424944561E0 / - DATA BIFCS( 3) / .0017083092 5073815165E0 / - DATA BIFCS( 4) / .0000118625 4546774468E0 / - DATA BIFCS( 5) / .0000000449 3290701779E0 / - DATA BIFCS( 6) / .0000000001 0698207143E0 / - DATA BIFCS( 7) / .0000000000 0017480643E0 / - DATA BIFCS( 8) / .0000000000 0000020810E0 / - DATA BIFCS( 9) / .0000000000 0000000018E0 / - DATA BIGCS( 1) / .0224662232 4857452E0 / - DATA BIGCS( 2) / .0373647754 5301955E0 / - DATA BIGCS( 3) / .0004447621 8957212E0 / - DATA BIGCS( 4) / .0000024708 0756363E0 / - DATA BIGCS( 5) / .0000000079 1913533E0 / - DATA BIGCS( 6) / .0000000000 1649807E0 / - DATA BIGCS( 7) / .0000000000 0002411E0 / - DATA BIGCS( 8) / .0000000000 0000002E0 / - DATA BIF2CS( 1) / 0.0998457269 3816041E0 / - DATA BIF2CS( 2) / .4786249778 63005538E0 / - DATA BIF2CS( 3) / .0251552119 604330118E0 / - DATA BIF2CS( 4) / .0005820693 885232645E0 / - DATA BIF2CS( 5) / .0000074997 659644377E0 / - DATA BIF2CS( 6) / .0000000613 460287034E0 / - DATA BIF2CS( 7) / .0000000003 462753885E0 / - DATA BIF2CS( 8) / .0000000000 014288910E0 / - DATA BIF2CS( 9) / .0000000000 000044962E0 / - DATA BIF2CS(10) / .0000000000 000000111E0 / - DATA BIG2CS( 1) / .0333056621 45514340E0 / - DATA BIG2CS( 2) / .1613092151 23197068E0 / - DATA BIG2CS( 3) / .0063190073 096134286E0 / - DATA BIG2CS( 4) / .0001187904 568162517E0 / - DATA BIG2CS( 5) / .0000013045 345886200E0 / - DATA BIG2CS( 6) / .0000000093 741259955E0 / - DATA BIG2CS( 7) / .0000000000 474580188E0 / - DATA BIG2CS( 8) / .0000000000 001783107E0 / - DATA BIG2CS( 9) / .0000000000 000005167E0 / - DATA BIG2CS(10) / .0000000000 000000011E0 / - DATA BIPCS( 1) / -.0832204747 7943447E0 / - DATA BIPCS( 2) / .0114611892 7371174E0 / - DATA BIPCS( 3) / .0004289644 0718911E0 / - DATA BIPCS( 4) / -.0001490663 9379950E0 / - DATA BIPCS( 5) / -.0000130765 9726787E0 / - DATA BIPCS( 6) / .0000063275 9839610E0 / - DATA BIPCS( 7) / -.0000004222 6696982E0 / - DATA BIPCS( 8) / -.0000001914 7186298E0 / - DATA BIPCS( 9) / .0000000645 3106284E0 / - DATA BIPCS(10) / -.0000000078 4485467E0 / - DATA BIPCS(11) / -.0000000009 6077216E0 / - DATA BIPCS(12) / .0000000007 0004713E0 / - DATA BIPCS(13) / -.0000000001 7731789E0 / - DATA BIPCS(14) / .0000000000 2272089E0 / - DATA BIPCS(15) / .0000000000 0165404E0 / - DATA BIPCS(16) / -.0000000000 0185171E0 / - DATA BIPCS(17) / .0000000000 0059576E0 / - DATA BIPCS(18) / -.0000000000 0012194E0 / - DATA BIPCS(19) / .0000000000 0001334E0 / - DATA BIPCS(20) / .0000000000 0000172E0 / - DATA BIPCS(21) / -.0000000000 0000145E0 / - DATA BIPCS(22) / .0000000000 0000049E0 / - DATA BIPCS(23) / -.0000000000 0000011E0 / - DATA BIPCS(24) / .0000000000 0000001E0 / - DATA BIP2CS( 1) / -.1135967375 85988679E0 / - DATA BIP2CS( 2) / .0041381473 947881595E0 / - DATA BIP2CS( 3) / .0001353470 622119332E0 / - DATA BIP2CS( 4) / .0000104273 166530153E0 / - DATA BIP2CS( 5) / .0000013474 954767849E0 / - DATA BIP2CS( 6) / .0000001696 537405438E0 / - DATA BIP2CS( 7) / -.0000000100 965008656E0 / - DATA BIP2CS( 8) / -.0000000167 291194937E0 / - DATA BIP2CS( 9) / -.0000000045 815364485E0 / - DATA BIP2CS(10) / .0000000003 736681366E0 / - DATA BIP2CS(11) / .0000000005 766930320E0 / - DATA BIP2CS(12) / .0000000000 621812650E0 / - DATA BIP2CS(13) / -.0000000000 632941202E0 / - DATA BIP2CS(14) / -.0000000000 149150479E0 / - DATA BIP2CS(15) / .0000000000 078896213E0 / - DATA BIP2CS(16) / .0000000000 024960513E0 / - DATA BIP2CS(17) / -.0000000000 012130075E0 / - DATA BIP2CS(18) / -.0000000000 003740493E0 / - DATA BIP2CS(19) / .0000000000 002237727E0 / - DATA BIP2CS(20) / .0000000000 000474902E0 / - DATA BIP2CS(21) / -.0000000000 000452616E0 / - DATA BIP2CS(22) / -.0000000000 000030172E0 / - DATA BIP2CS(23) / .0000000000 000091058E0 / - DATA BIP2CS(24) / -.0000000000 000009814E0 / - DATA BIP2CS(25) / -.0000000000 000016429E0 / - DATA BIP2CS(26) / .0000000000 000005533E0 / - DATA BIP2CS(27) / .0000000000 000002175E0 / - DATA BIP2CS(28) / -.0000000000 000001737E0 / - DATA BIP2CS(29) / -.0000000000 000000010E0 / - DATA ATR / 8.750690570 8484345 E0 / - DATA BTR / -2.093836321 356054 E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT BIE - IF (FIRST) THEN - ETA = 0.1*R1MACH(3) - NBIF = INITS (BIFCS, 9, ETA) - NBIG = INITS (BIGCS, 8, ETA) - NBIF2 = INITS (BIF2CS, 10, ETA) - NBIG2 = INITS (BIG2CS, 10, ETA) - NBIP = INITS (BIPCS , 24, ETA) - NBIP2 = INITS (BIP2CS, 29, ETA) -C - X3SML = ETA**0.3333 - X32SML = 1.3104*X3SML**2 - XBIG = R1MACH(2)**0.6666 - ENDIF - FIRST = .FALSE. -C - IF (X.GE.(-1.0)) GO TO 20 - CALL R9AIMP (X, XM, THETA) - BIE = XM * SIN(THETA) - RETURN -C - 20 IF (X.GT.1.0) GO TO 30 - Z = 0.0 - IF (ABS(X).GT.X3SML) Z = X**3 - BIE = 0.625 + CSEVL (Z, BIFCS, NBIF) + X*(0.4375 + - 1 CSEVL (Z, BIGCS, NBIG)) - IF (X.GT.X32SML) BIE = BIE * EXP(-2.0*X*SQRT(X)/3.0) - RETURN -C - 30 IF (X.GT.2.0) GO TO 40 - Z = (2.0*X**3 - 9.0) / 7.0 - BIE = EXP(-2.0*X*SQRT(X)/3.0) * (1.125 + CSEVL (Z, BIF2CS, NBIF2) - 1 + X*(0.625 + CSEVL (Z, BIG2CS, NBIG2)) ) - RETURN -C - 40 IF (X.GT.4.0) GO TO 50 - SQRTX = SQRT(X) - Z = ATR/(X*SQRTX) + BTR - BIE = (0.625 + CSEVL (Z, BIPCS, NBIP)) / SQRT(SQRTX) - RETURN -C - 50 SQRTX = SQRT(X) - Z = -1.0 - IF (X.LT.XBIG) Z = 16.0/(X*SQRTX) - 1.0 - BIE = (0.625 + CSEVL (Z, BIP2CS, NBIP2))/SQRT(SQRTX) - RETURN -C - END diff --git a/slatec/binom.f b/slatec/binom.f deleted file mode 100644 index 0491c70..0000000 --- a/slatec/binom.f +++ /dev/null @@ -1,73 +0,0 @@ -*DECK BINOM - FUNCTION BINOM (N, M) -C***BEGIN PROLOGUE BINOM -C***PURPOSE Compute the binomial coefficients. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C1 -C***TYPE SINGLE PRECISION (BINOM-S, DBINOM-D) -C***KEYWORDS BINOMIAL COEFFICIENTS, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C BINOM(N,M) calculates the binomial coefficient (N!)/((M!)*(N-M)!). -C -C***REFERENCES (NONE) -C***ROUTINES CALLED ALNREL, R1MACH, R9LGMC, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE BINOM - LOGICAL FIRST - SAVE SQ2PIL, BILNMX, FINTMX, FIRST - DATA SQ2PIL / 0.9189385332 0467274E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT BINOM - IF (FIRST) THEN - BILNMX = LOG (R1MACH(2)) - FINTMX = 0.9/R1MACH(3) - ENDIF - FIRST = .FALSE. -C - IF (N .LT. 0 .OR. M .LT. 0) CALL XERMSG ('SLATEC', 'BINOM', - + 'N OR M LT ZERO', 1, 2) - IF (N .LT. M) CALL XERMSG ('SLATEC', 'BINOM', 'N LT M', 2, 2) -C - K = MIN (M, N-M) - IF (K.GT.20) GO TO 30 - IF (K*LOG(AMAX0(N,1)).GT.BILNMX) GO TO 30 -C - BINOM = 1. - IF (K.EQ.0) RETURN -C - DO 20 I=1,K - BINOM = BINOM * REAL(N-I+1)/I - 20 CONTINUE -C - IF (BINOM.LT.FINTMX) BINOM = AINT (BINOM+0.5) - RETURN -C -C IF K.LT.9, APPROX IS NOT VALID AND ANSWER IS CLOSE TO THE OVERFLOW LIM - 30 IF (K .LT. 9) CALL XERMSG ('SLATEC', 'BINOM', - + 'RESULT OVERFLOWS BECAUSE N AND/OR M TOO BIG', 3, 2) -C - XN = N + 1 - XK = K + 1 - XNK = N - K + 1 -C - CORR = R9LGMC(XN) - R9LGMC(XK) - R9LGMC(XNK) - BINOM = XK*LOG(XNK/XK) - XN*ALNREL(-(XK-1.)/XN) - 1 - 0.5*LOG(XN*XNK/XK) + 1.0 - SQ2PIL + CORR -C - IF (BINOM .GT. BILNMX) CALL XERMSG ('SLATEC', 'BINOM', - + 'RESULT OVERFLOWS BECAUSE N AND/OR M TOO BIG', 3, 2) -C - BINOM = EXP (BINOM) - IF (BINOM.LT.FINTMX) BINOM = AINT (BINOM+0.5) -C - RETURN - END diff --git a/slatec/bint4.f b/slatec/bint4.f deleted file mode 100644 index aec9548..0000000 --- a/slatec/bint4.f +++ /dev/null @@ -1,238 +0,0 @@ -*DECK BINT4 - SUBROUTINE BINT4 (X, Y, NDATA, IBCL, IBCR, FBCL, FBCR, KNTOPT, T, - + BCOEF, N, K, W) -C***BEGIN PROLOGUE BINT4 -C***PURPOSE Compute the B-representation of a cubic spline -C which interpolates given data. -C***LIBRARY SLATEC -C***CATEGORY E1A -C***TYPE SINGLE PRECISION (BINT4-S, DBINT4-D) -C***KEYWORDS B-SPLINE, CUBIC SPLINES, DATA FITTING, INTERPOLATION -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C BINT4 computes the B representation (T,BCOEF,N,K) of a -C cubic spline (K=4) which interpolates data (X(I)),Y(I))), -C I=1,NDATA. Parameters IBCL, IBCR, FBCL, FBCR allow the -C specification of the spline first or second derivative at -C both X(1) and X(NDATA). When this data is not specified -C by the problem, it is common practice to use a natural -C spline by setting second derivatives at X(1) and X(NDATA) -C to zero (IBCL=IBCR=2,FBCL=FBCR=0.0). The spline is defined on -C T(4) .LE. X .LE. T(N+1) with (ordered) interior knots at X(I)) -C values where N=NDATA+2. The knots T(1), T(2), T(3) lie to -C the left of T(4)=X(1) and the knots T(N+2), T(N+3), T(N+4) -C lie to the right of T(N+1)=X(NDATA) in increasing order. If -C no extrapolation outside (X(1),X(NDATA)) is anticipated, the -C knots T(1)=T(2)=T(3)=T(4)=X(1) and T(N+2)=T(N+3)=T(N+4)= -C T(N+1)=X(NDATA) can be specified by KNTOPT=1. KNTOPT=2 -C selects a knot placement for T(1), T(2), T(3) to make the -C first 7 knots symmetric about T(4)=X(1) and similarly for -C T(N+2), T(N+3), T(N+4) about T(N+1)=X(NDATA). KNTOPT=3 -C allows the user to make his own selection, in increasing -C order, for T(1), T(2), T(3) to the left of X(1) and T(N+2), -C T(N+3), T(N+4) to the right of X(NDATA) in the work array -C W(1) through W(6). In any case, the interpolation on -C T(4) .LE. X .LE. T(N+1) by using function BVALU is unique -C for given boundary conditions. -C -C Description of Arguments -C Input -C X - X vector of abscissae of length NDATA, distinct -C and in increasing order -C Y - Y vector of ordinates of length NDATA -C NDATA - number of data points, NDATA .GE. 2 -C IBCL - selection parameter for left boundary condition -C IBCL = 1 constrain the first derivative at -C X(1) to FBCL -C = 2 constrain the second derivative at -C X(1) to FBCL -C IBCR - selection parameter for right boundary condition -C IBCR = 1 constrain first derivative at -C X(NDATA) to FBCR -C IBCR = 2 constrain second derivative at -C X(NDATA) to FBCR -C FBCL - left boundary values governed by IBCL -C FBCR - right boundary values governed by IBCR -C KNTOPT - knot selection parameter -C KNTOPT = 1 sets knot multiplicity at T(4) and -C T(N+1) to 4 -C = 2 sets a symmetric placement of knots -C about T(4) and T(N+1) -C = 3 sets TNP)=WNP) and T(N+1+I)=w(3+I),I=1,3 -C where WNP),I=1,6 is supplied by the user -C W - work array of dimension at least 5*(NDATA+2) -C if KNTOPT=3, then W(1),W(2),W(3) are knot values to -C the left of X(1) and W(4),W(5),W(6) are knot -C values to the right of X(NDATA) in increasing -C order to be supplied by the user -C -C Output -C T - knot array of length N+4 -C BCOEF - B-spline coefficient array of length N -C N - number of coefficients, N=NDATA+2 -C K - order of spline, K=4 -C -C Error Conditions -C Improper input is a fatal error -C Singular system of equations is a fatal error -C -C***REFERENCES D. E. Amos, Computation with splines and B-splines, -C Report SAND78-1968, Sandia Laboratories, March 1979. -C Carl de Boor, Package for calculating with B-splines, -C SIAM Journal on Numerical Analysis 14, 3 (June 1977), -C pp. 441-472. -C Carl de Boor, A Practical Guide to Splines, Applied -C Mathematics Series 27, Springer-Verlag, New York, -C 1978. -C***ROUTINES CALLED BNFAC, BNSLV, BSPVD, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800901 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE BINT4 -C - INTEGER I, IBCL, IBCR, IFLAG, ILB, ILEFT, IT, IUB, IW, IWP, J, - 1 JW, K, KNTOPT, N, NDATA, NDM, NP, NWROW - REAL BCOEF,FBCL,FBCR,T, TOL,TXN,TX1,VNIKX,W,WDTOL,WORK,X, XL, - 1 Y - REAL R1MACH - DIMENSION X(*), Y(*), T(*), BCOEF(*), W(5,*), VNIKX(4,4), WORK(15) -C***FIRST EXECUTABLE STATEMENT BINT4 - WDTOL = R1MACH(4) - TOL = SQRT(WDTOL) - IF (NDATA.LT.2) GO TO 200 - NDM = NDATA - 1 - DO 10 I=1,NDM - IF (X(I).GE.X(I+1)) GO TO 210 - 10 CONTINUE - IF (IBCL.LT.1 .OR. IBCL.GT.2) GO TO 220 - IF (IBCR.LT.1 .OR. IBCR.GT.2) GO TO 230 - IF (KNTOPT.LT.1 .OR. KNTOPT.GT.3) GO TO 240 - K = 4 - N = NDATA + 2 - NP = N + 1 - DO 20 I=1,NDATA - T(I+3) = X(I) - 20 CONTINUE - GO TO (30, 50, 90), KNTOPT -C SET UP KNOT ARRAY WITH MULTIPLICITY 4 AT X(1) AND X(NDATA) - 30 CONTINUE - DO 40 I=1,3 - T(4-I) = X(1) - T(NP+I) = X(NDATA) - 40 CONTINUE - GO TO 110 -C SET UP KNOT ARRAY WITH SYMMETRIC PLACEMENT ABOUT END POINTS - 50 CONTINUE - IF (NDATA.GT.3) GO TO 70 - XL = (X(NDATA)-X(1))/3.0E0 - DO 60 I=1,3 - T(4-I) = T(5-I) - XL - T(NP+I) = T(NP+I-1) + XL - 60 CONTINUE - GO TO 110 - 70 CONTINUE - TX1 = X(1) + X(1) - TXN = X(NDATA) + X(NDATA) - DO 80 I=1,3 - T(4-I) = TX1 - X(I+1) - T(NP+I) = TXN - X(NDATA-I) - 80 CONTINUE - GO TO 110 -C SET UP KNOT ARRAY LESS THAN X(1) AND GREATER THAN X(NDATA) TO BE -C SUPPLIED BY USER IN WORK LOCATIONS W(1) THROUGH W(6) WHEN KNTOPT=3 - 90 CONTINUE - DO 100 I=1,3 - T(4-I) = W(4-I,1) - JW = MAX(1,I-1) - IW = MOD(I+2,5)+1 - T(NP+I) = W(IW,JW) - IF (T(4-I).GT.T(5-I)) GO TO 250 - IF (T(NP+I).LT.T(NP+I-1)) GO TO 250 - 100 CONTINUE - 110 CONTINUE -C - DO 130 I=1,5 - DO 120 J=1,N - W(I,J) = 0.0E0 - 120 CONTINUE - 130 CONTINUE -C SET UP LEFT INTERPOLATION POINT AND LEFT BOUNDARY CONDITION FOR -C RIGHT LIMITS - IT = IBCL + 1 - CALL BSPVD(T, K, IT, X(1), K, 4, VNIKX, WORK) - IW = 0 - IF (ABS(VNIKX(3,1)).LT.TOL) IW = 1 - DO 140 J=1,3 - W(J+1,4-J) = VNIKX(4-J,IT) - W(J,4-J) = VNIKX(4-J,1) - 140 CONTINUE - BCOEF(1) = Y(1) - BCOEF(2) = FBCL -C SET UP INTERPOLATION EQUATIONS FOR POINTS I=2 TO I=NDATA-1 - ILEFT = 4 - IF (NDM.LT.2) GO TO 170 - DO 160 I=2,NDM - ILEFT = ILEFT + 1 - CALL BSPVD(T, K, 1, X(I), ILEFT, 4, VNIKX, WORK) - DO 150 J=1,3 - W(J+1,3+I-J) = VNIKX(4-J,1) - 150 CONTINUE - BCOEF(I+1) = Y(I) - 160 CONTINUE -C SET UP RIGHT INTERPOLATION POINT AND RIGHT BOUNDARY CONDITION FOR -C LEFT LIMITS(ILEFT IS ASSOCIATED WITH T(N)=X(NDATA-1)) - 170 CONTINUE - IT = IBCR + 1 - CALL BSPVD(T, K, IT, X(NDATA), ILEFT, 4, VNIKX, WORK) - JW = 0 - IF (ABS(VNIKX(2,1)).LT.TOL) JW = 1 - DO 180 J=1,3 - W(J+1,3+NDATA-J) = VNIKX(5-J,IT) - W(J+2,3+NDATA-J) = VNIKX(5-J,1) - 180 CONTINUE - BCOEF(N-1) = FBCR - BCOEF(N) = Y(NDATA) -C SOLVE SYSTEM OF EQUATIONS - ILB = 2 - JW - IUB = 2 - IW - NWROW = 5 - IWP = IW + 1 - CALL BNFAC(W(IWP,1), NWROW, N, ILB, IUB, IFLAG) - IF (IFLAG.EQ.2) GO TO 190 - CALL BNSLV(W(IWP,1), NWROW, N, ILB, IUB, BCOEF) - RETURN -C -C - 190 CONTINUE - CALL XERMSG ('SLATEC', 'BINT4', - + 'THE SYSTEM OF EQUATIONS IS SINGULAR', 2, 1) - RETURN - 200 CONTINUE - CALL XERMSG ('SLATEC', 'BINT4', 'NDATA IS LESS THAN 2', 2, 1) - RETURN - 210 CONTINUE - CALL XERMSG ('SLATEC', 'BINT4', - + 'X VALUES ARE NOT DISTINCT OR NOT ORDERED', 2, 1) - RETURN - 220 CONTINUE - CALL XERMSG ('SLATEC', 'BINT4', 'IBCL IS NOT 1 OR 2', 2, 1) - RETURN - 230 CONTINUE - CALL XERMSG ('SLATEC', 'BINT4', 'IBCR IS NOT 1 OR 2', 2, 1) - RETURN - 240 CONTINUE - CALL XERMSG ('SLATEC', 'BINT4', 'KNTOPT IS NOT 1, 2, OR 3', 2, 1) - RETURN - 250 CONTINUE - CALL XERMSG ('SLATEC', 'BINT4', - + 'KNOT INPUT THROUGH W ARRAY IS NOT ORDERED PROPERLY', 2, 1) - RETURN - END diff --git a/slatec/bintk.f b/slatec/bintk.f deleted file mode 100644 index 6039f25..0000000 --- a/slatec/bintk.f +++ /dev/null @@ -1,187 +0,0 @@ -*DECK BINTK - SUBROUTINE BINTK (X, Y, T, N, K, BCOEF, Q, WORK) -C***BEGIN PROLOGUE BINTK -C***PURPOSE Compute the B-representation of a spline which interpolates -C given data. -C***LIBRARY SLATEC -C***CATEGORY E1A -C***TYPE SINGLE PRECISION (BINTK-S, DBINTK-D) -C***KEYWORDS B-SPLINE, DATA FITTING, INTERPOLATION -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Written by Carl de Boor and modified by D. E. Amos -C -C Abstract -C -C BINTK is the SPLINT routine of the reference. -C -C BINTK produces the B-spline coefficients, BCOEF, of the -C B-spline of order K with knots T(I), I=1,...,N+K, which -C takes on the value Y(I) at X(I), I=1,...,N. The spline or -C any of its derivatives can be evaluated by calls to BVALU. -C The I-th equation of the linear system A*BCOEF = B for the -C coefficients of the interpolant enforces interpolation at -C X(I)), I=1,...,N. Hence, B(I) = Y(I), all I, and A is -C a band matrix with 2K-1 bands if A is invertible. The matrix -C A is generated row by row and stored, diagonal by diagonal, -C in the rows of Q, with the main diagonal going into row K. -C The banded system is then solved by a call to BNFAC (which -C constructs the triangular factorization for A and stores it -C again in Q), followed by a call to BNSLV (which then -C obtains the solution BCOEF by substitution). BNFAC does no -C pivoting, since the total positivity of the matrix A makes -C this unnecessary. The linear system to be solved is -C (theoretically) invertible if and only if -C T(I) .LT. X(I)) .LT. T(I+K), all I. -C Equality is permitted on the left for I=1 and on the right -C for I=N when K knots are used at X(1) or X(N). Otherwise, -C violation of this condition is certain to lead to an error. -C -C Description of Arguments -C Input -C X - vector of length N containing data point abscissa -C in strictly increasing order. -C Y - corresponding vector of length N containing data -C point ordinates. -C T - knot vector of length N+K -C since T(1),..,T(K) .LE. X(1) and T(N+1),..,T(N+K) -C .GE. X(N), this leaves only N-K knots (not nec- -C essarily X(I)) values) interior to (X(1),X(N)) -C N - number of data points, N .GE. K -C K - order of the spline, K .GE. 1 -C -C Output -C BCOEF - a vector of length N containing the B-spline -C coefficients -C Q - a work vector of length (2*K-1)*N, containing -C the triangular factorization of the coefficient -C matrix of the linear system being solved. The -C coefficients for the interpolant of an -C additional data set (X(I)),YY(I)), I=1,...,N -C with the same abscissa can be obtained by loading -C YY into BCOEF and then executing -C CALL BNSLV (Q,2K-1,N,K-1,K-1,BCOEF) -C WORK - work vector of length 2*K -C -C Error Conditions -C Improper input is a fatal error -C Singular system of equations is a fatal error -C -C***REFERENCES D. E. Amos, Computation with splines and B-splines, -C Report SAND78-1968, Sandia Laboratories, March 1979. -C Carl de Boor, Package for calculating with B-splines, -C SIAM Journal on Numerical Analysis 14, 3 (June 1977), -C pp. 441-472. -C Carl de Boor, A Practical Guide to Splines, Applied -C Mathematics Series 27, Springer-Verlag, New York, -C 1978. -C***ROUTINES CALLED BNFAC, BNSLV, BSPVN, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800901 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE BINTK -C - INTEGER IFLAG, IWORK, K, N, I, ILP1MX, J, JJ, KM1, KPKM2, LEFT, - 1 LENQ, NP1 - REAL BCOEF(*), Y(*), Q(*), T(*), X(*), XI, WORK(*) -C DIMENSION Q(2*K-1,N), T(N+K) -C***FIRST EXECUTABLE STATEMENT BINTK - IF(K.LT.1) GO TO 100 - IF(N.LT.K) GO TO 105 - JJ = N - 1 - IF(JJ.EQ.0) GO TO 6 - DO 5 I=1,JJ - IF(X(I).GE.X(I+1)) GO TO 110 - 5 CONTINUE - 6 CONTINUE - NP1 = N + 1 - KM1 = K - 1 - KPKM2 = 2*KM1 - LEFT = K -C ZERO OUT ALL ENTRIES OF Q - LENQ = N*(K+KM1) - DO 10 I=1,LENQ - Q(I) = 0.0E0 - 10 CONTINUE -C -C *** LOOP OVER I TO CONSTRUCT THE N INTERPOLATION EQUATIONS - DO 50 I=1,N - XI = X(I) - ILP1MX = MIN(I+K,NP1) -C *** FIND LEFT IN THE CLOSED INTERVAL (I,I+K-1) SUCH THAT -C T(LEFT) .LE. X(I) .LT. T(LEFT+1) -C MATRIX IS SINGULAR IF THIS IS NOT POSSIBLE - LEFT = MAX(LEFT,I) - IF (XI.LT.T(LEFT)) GO TO 80 - 20 IF (XI.LT.T(LEFT+1)) GO TO 30 - LEFT = LEFT + 1 - IF (LEFT.LT.ILP1MX) GO TO 20 - LEFT = LEFT - 1 - IF (XI.GT.T(LEFT+1)) GO TO 80 -C *** THE I-TH EQUATION ENFORCES INTERPOLATION AT XI, HENCE -C A(I,J) = B(J,K,T)(XI), ALL J. ONLY THE K ENTRIES WITH J = -C LEFT-K+1,...,LEFT ACTUALLY MIGHT BE NONZERO. THESE K NUMBERS -C ARE RETURNED, IN BCOEF (USED FOR TEMP. STORAGE HERE), BY THE -C FOLLOWING - 30 CALL BSPVN(T, K, K, 1, XI, LEFT, BCOEF, WORK, IWORK) -C WE THEREFORE WANT BCOEF(J) = B(LEFT-K+J)(XI) TO GO INTO -C A(I,LEFT-K+J), I.E., INTO Q(I-(LEFT+J)+2*K,(LEFT+J)-K) SINCE -C A(I+J,J) IS TO GO INTO Q(I+K,J), ALL I,J, IF WE CONSIDER Q -C AS A TWO-DIM. ARRAY , WITH 2*K-1 ROWS (SEE COMMENTS IN -C BNFAC). IN THE PRESENT PROGRAM, WE TREAT Q AS AN EQUIVALENT -C ONE-DIMENSIONAL ARRAY (BECAUSE OF FORTRAN RESTRICTIONS ON -C DIMENSION STATEMENTS) . WE THEREFORE WANT BCOEF(J) TO GO INTO -C ENTRY -C I -(LEFT+J) + 2*K + ((LEFT+J) - K-1)*(2*K-1) -C = I-LEFT+1 + (LEFT -K)*(2*K-1) + (2*K-2)*J -C OF Q . - JJ = I - LEFT + 1 + (LEFT-K)*(K+KM1) - DO 40 J=1,K - JJ = JJ + KPKM2 - Q(JJ) = BCOEF(J) - 40 CONTINUE - 50 CONTINUE -C -C ***OBTAIN FACTORIZATION OF A , STORED AGAIN IN Q. - CALL BNFAC(Q, K+KM1, N, KM1, KM1, IFLAG) - GO TO (60, 90), IFLAG -C *** SOLVE A*BCOEF = Y BY BACKSUBSTITUTION - 60 DO 70 I=1,N - BCOEF(I) = Y(I) - 70 CONTINUE - CALL BNSLV(Q, K+KM1, N, KM1, KM1, BCOEF) - RETURN -C -C - 80 CONTINUE - CALL XERMSG ('SLATEC', 'BINTK', - + 'SOME ABSCISSA WAS NOT IN THE SUPPORT OF THE CORRESPONDING ' // - + 'BASIS FUNCTION AND THE SYSTEM IS SINGULAR.', 2, 1) - RETURN - 90 CONTINUE - CALL XERMSG ('SLATEC', 'BINTK', - + 'THE SYSTEM OF SOLVER DETECTS A SINGULAR SYSTEM ALTHOUGH ' // - + 'THE THEORETICAL CONDITIONS FOR A SOLUTION WERE SATISFIED.', - + 8, 1) - RETURN - 100 CONTINUE - CALL XERMSG ('SLATEC', 'BINTK', 'K DOES NOT SATISFY K.GE.1', 2, - + 1) - RETURN - 105 CONTINUE - CALL XERMSG ('SLATEC', 'BINTK', 'N DOES NOT SATISFY N.GE.K', 2, - + 1) - RETURN - 110 CONTINUE - CALL XERMSG ('SLATEC', 'BINTK', - + 'X(I) DOES NOT SATISFY X(I).LT.X(I+1) FOR SOME I', 2, 1) - RETURN - END diff --git a/slatec/bisect.f b/slatec/bisect.f deleted file mode 100644 index 0389142..0000000 --- a/slatec/bisect.f +++ /dev/null @@ -1,284 +0,0 @@ -*DECK BISECT - SUBROUTINE BISECT (N, EPS1, D, E, E2, LB, UB, MM, M, W, IND, IERR, - + RV4, RV5) -C***BEGIN PROLOGUE BISECT -C***PURPOSE Compute the eigenvalues of a symmetric tridiagonal matrix -C in a given interval using Sturm sequencing. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4A5, D4C2A -C***TYPE SINGLE PRECISION (BISECT-S) -C***KEYWORDS EIGENVALUES, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the bisection technique -C in the ALGOL procedure TRISTURM by Peters and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). -C -C This subroutine finds those eigenvalues of a TRIDIAGONAL -C SYMMETRIC matrix which lie in a specified interval, -C using bisection. -C -C On INPUT -C -C N is the order of the matrix. N is an INTEGER variable. -C -C EPS1 is an absolute error tolerance for the computed -C eigenvalues. If the input EPS1 is non-positive, -C it is reset for each submatrix to a default value, -C namely, minus the product of the relative machine -C precision and the 1-norm of the submatrix. -C EPS1 is a REAL variable. -C -C D contains the diagonal elements of the input matrix. -C D is a one-dimensional REAL array, dimensioned D(N). -C -C E contains the subdiagonal elements of the input matrix -C in its last N-1 positions. E(1) is arbitrary. -C E is a one-dimensional REAL array, dimensioned E(N). -C -C E2 contains the squares of the corresponding elements of E. -C E2(1) is arbitrary. E2 is a one-dimensional REAL array, -C dimensioned E2(N). -C -C LB and UB define the interval to be searched for eigenvalues. -C If LB is not less than UB, no eigenvalues will be found. -C LB and UB are REAL variables. -C -C MM should be set to an upper bound for the number of -C eigenvalues in the interval. WARNING - If more than -C MM eigenvalues are determined to lie in the interval, -C an error return is made with no eigenvalues found. -C MM is an INTEGER variable. -C -C On OUTPUT -C -C EPS1 is unaltered unless it has been reset to its -C (last) default value. -C -C D and E are unaltered. -C -C Elements of E2, corresponding to elements of E regarded -C as negligible, have been replaced by zero causing the -C matrix to split into a direct sum of submatrices. -C E2(1) is also set to zero. -C -C M is the number of eigenvalues determined to lie in (LB,UB). -C M is an INTEGER variable. -C -C W contains the M eigenvalues in ascending order. -C W is a one-dimensional REAL array, dimensioned W(MM). -C -C IND contains in its first M positions the submatrix indices -C associated with the corresponding eigenvalues in W -- -C 1 for eigenvalues belonging to the first submatrix from -C the top, 2 for those belonging to the second submatrix, etc. -C IND is an one-dimensional INTEGER array, dimensioned IND(MM). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C 3*N+1 if M exceeds MM. In this case, M contains the -C number of eigenvalues determined to lie in -C (LB,UB). -C -C RV4 and RV5 are one-dimensional REAL arrays used for temporary -C storage, dimensioned RV4(N) and RV5(N). -C -C The ALGOL procedure STURMCNT contained in TRISTURM -C appears in BISECT in-line. -C -C Note that subroutine TQL1 or IMTQL1 is generally faster than -C BISECT, if more than N/4 eigenvalues are to be found. -C -C Questions and comments should be directed to B. S. Garbow, -C Applied Mathematics Division, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED R1MACH -C***REVISION HISTORY (YYMMDD) -C 760101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE BISECT -C - INTEGER I,J,K,L,M,N,P,Q,R,S,II,MM,M1,M2,TAG,IERR,ISTURM - REAL D(*),E(*),E2(*),W(*),RV4(*),RV5(*) - REAL U,V,LB,T1,T2,UB,XU,X0,X1,EPS1,MACHEP,S1,S2 - INTEGER IND(*) - LOGICAL FIRST -C - SAVE FIRST, MACHEP - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT BISECT - IF (FIRST) THEN - MACHEP = R1MACH(4) - ENDIF - FIRST = .FALSE. -C - IERR = 0 - TAG = 0 - T1 = LB - T2 = UB -C .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES .......... - DO 40 I = 1, N - IF (I .EQ. 1) GO TO 20 - S1 = ABS(D(I)) + ABS(D(I-1)) - S2 = S1 + ABS(E(I)) - IF (S2 .GT. S1) GO TO 40 - 20 E2(I) = 0.0E0 - 40 CONTINUE -C .......... DETERMINE THE NUMBER OF EIGENVALUES -C IN THE INTERVAL .......... - P = 1 - Q = N - X1 = UB - ISTURM = 1 - GO TO 320 - 60 M = S - X1 = LB - ISTURM = 2 - GO TO 320 - 80 M = M - S - IF (M .GT. MM) GO TO 980 - Q = 0 - R = 0 -C .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING -C INTERVAL BY THE GERSCHGORIN BOUNDS .......... - 100 IF (R .EQ. M) GO TO 1001 - TAG = TAG + 1 - P = Q + 1 - XU = D(P) - X0 = D(P) - U = 0.0E0 -C - DO 120 Q = P, N - X1 = U - U = 0.0E0 - V = 0.0E0 - IF (Q .EQ. N) GO TO 110 - U = ABS(E(Q+1)) - V = E2(Q+1) - 110 XU = MIN(D(Q)-(X1+U),XU) - X0 = MAX(D(Q)+(X1+U),X0) - IF (V .EQ. 0.0E0) GO TO 140 - 120 CONTINUE -C - 140 X1 = MAX(ABS(XU),ABS(X0)) * MACHEP - IF (EPS1 .LE. 0.0E0) EPS1 = -X1 - IF (P .NE. Q) GO TO 180 -C .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL .......... - IF (T1 .GT. D(P) .OR. D(P) .GE. T2) GO TO 940 - M1 = P - M2 = P - RV5(P) = D(P) - GO TO 900 - 180 X1 = X1 * (Q-P+1) - LB = MAX(T1,XU-X1) - UB = MIN(T2,X0+X1) - X1 = LB - ISTURM = 3 - GO TO 320 - 200 M1 = S + 1 - X1 = UB - ISTURM = 4 - GO TO 320 - 220 M2 = S - IF (M1 .GT. M2) GO TO 940 -C .......... FIND ROOTS BY BISECTION .......... - X0 = UB - ISTURM = 5 -C - DO 240 I = M1, M2 - RV5(I) = UB - RV4(I) = LB - 240 CONTINUE -C .......... LOOP FOR K-TH EIGENVALUE -C FOR K=M2 STEP -1 UNTIL M1 DO -- -C (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) .......... - K = M2 - 250 XU = LB -C .......... FOR I=K STEP -1 UNTIL M1 DO -- .......... - DO 260 II = M1, K - I = M1 + K - II - IF (XU .GE. RV4(I)) GO TO 260 - XU = RV4(I) - GO TO 280 - 260 CONTINUE -C - 280 IF (X0 .GT. RV5(K)) X0 = RV5(K) -C .......... NEXT BISECTION STEP .......... - 300 X1 = (XU + X0) * 0.5E0 - S1 = 2.0E0*(ABS(XU) + ABS(X0) + ABS(EPS1)) - S2 = S1 + ABS(X0 - XU) - IF (S2 .EQ. S1) GO TO 420 -C .......... IN-LINE PROCEDURE FOR STURM SEQUENCE .......... - 320 S = P - 1 - U = 1.0E0 -C - DO 340 I = P, Q - IF (U .NE. 0.0E0) GO TO 325 - V = ABS(E(I)) / MACHEP - IF (E2(I) .EQ. 0.0E0) V = 0.0E0 - GO TO 330 - 325 V = E2(I) / U - 330 U = D(I) - X1 - V - IF (U .LT. 0.0E0) S = S + 1 - 340 CONTINUE -C - GO TO (60,80,200,220,360), ISTURM -C .......... REFINE INTERVALS .......... - 360 IF (S .GE. K) GO TO 400 - XU = X1 - IF (S .GE. M1) GO TO 380 - RV4(M1) = X1 - GO TO 300 - 380 RV4(S+1) = X1 - IF (RV5(S) .GT. X1) RV5(S) = X1 - GO TO 300 - 400 X0 = X1 - GO TO 300 -C .......... K-TH EIGENVALUE FOUND .......... - 420 RV5(K) = X1 - K = K - 1 - IF (K .GE. M1) GO TO 250 -C .......... ORDER EIGENVALUES TAGGED WITH THEIR -C SUBMATRIX ASSOCIATIONS .......... - 900 S = R - R = R + M2 - M1 + 1 - J = 1 - K = M1 -C - DO 920 L = 1, R - IF (J .GT. S) GO TO 910 - IF (K .GT. M2) GO TO 940 - IF (RV5(K) .GE. W(L)) GO TO 915 -C - DO 905 II = J, S - I = L + S - II - W(I+1) = W(I) - IND(I+1) = IND(I) - 905 CONTINUE -C - 910 W(L) = RV5(K) - IND(L) = TAG - K = K + 1 - GO TO 920 - 915 J = J + 1 - 920 CONTINUE -C - 940 IF (Q .LT. N) GO TO 100 - GO TO 1001 -C .......... SET ERROR -- UNDERESTIMATE OF NUMBER OF -C EIGENVALUES IN INTERVAL .......... - 980 IERR = 3 * N + 1 - 1001 LB = T1 - UB = T2 - RETURN - END diff --git a/slatec/bkias.f b/slatec/bkias.f deleted file mode 100644 index 7258140..0000000 --- a/slatec/bkias.f +++ /dev/null @@ -1,260 +0,0 @@ -*DECK BKIAS - SUBROUTINE BKIAS (X, N, KTRMS, T, ANS, IND, MS, GMRN, H, IERR) -C***BEGIN PROLOGUE BKIAS -C***SUBSIDIARY -C***PURPOSE Subsidiary to BSKIN -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (BKIAS-S, DBKIAS-D) -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C BKIAS computes repeated integrals of the K0 Bessel function -C by the asymptotic expansion -C -C***SEE ALSO BSKIN -C***ROUTINES CALLED BDIFF, GAMRN, HKSEQ, R1MACH -C***REVISION HISTORY (YYMMDD) -C 820601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE BKIAS - INTEGER I, II, IND, J, JMI, JN, K, KK, KM, KTRMS, MM, MP, MS, N, - * IERR - REAL ANS, B, BND, DEN1, DEN2, DEN3, ER, ERR, FJ, FK, FLN, FM1, - * GMRN, G1, GS, H, HN, HRTPI, RAT, RG1, RXP, RZ, RZX, S, SS, SUMI, - * SUMJ, T, TOL, V, W, X, XP, Z - REAL GAMRN, R1MACH - DIMENSION B(120), XP(16), S(31), H(*), V(52), W(52), T(50), - * BND(15) - SAVE B, BND, HRTPI -C----------------------------------------------------------------------- -C COEFFICIENTS OF POLYNOMIAL P(J-1,X), J=1,15 -C----------------------------------------------------------------------- - DATA B(1), B(2), B(3), B(4), B(5), B(6), B(7), B(8), B(9), B(10), - * B(11), B(12), B(13), B(14), B(15), B(16), B(17), B(18), B(19), - * B(20), B(21), B(22), B(23), B(24) /1.00000000000000000E+00, - * 1.00000000000000000E+00,-2.00000000000000000E+00, - * 1.00000000000000000E+00,-8.00000000000000000E+00, - * 6.00000000000000000E+00,1.00000000000000000E+00, - * -2.20000000000000000E+01,5.80000000000000000E+01, - * -2.40000000000000000E+01,1.00000000000000000E+00, - * -5.20000000000000000E+01,3.28000000000000000E+02, - * -4.44000000000000000E+02,1.20000000000000000E+02, - * 1.00000000000000000E+00,-1.14000000000000000E+02, - * 1.45200000000000000E+03,-4.40000000000000000E+03, - * 3.70800000000000000E+03,-7.20000000000000000E+02, - * 1.00000000000000000E+00,-2.40000000000000000E+02, - * 5.61000000000000000E+03/ - DATA B(25), B(26), B(27), B(28), B(29), B(30), B(31), B(32), - * B(33), B(34), B(35), B(36), B(37), B(38), B(39), B(40), B(41), - * B(42), B(43), B(44), B(45), B(46), B(47), B(48) - * /-3.21200000000000000E+04,5.81400000000000000E+04, - * -3.39840000000000000E+04,5.04000000000000000E+03, - * 1.00000000000000000E+00,-4.94000000000000000E+02, - * 1.99500000000000000E+04,-1.95800000000000000E+05, - * 6.44020000000000000E+05,-7.85304000000000000E+05, - * 3.41136000000000000E+05,-4.03200000000000000E+04, - * 1.00000000000000000E+00,-1.00400000000000000E+03, - * 6.72600000000000000E+04,-1.06250000000000000E+06, - * 5.76550000000000000E+06,-1.24400640000000000E+07, - * 1.10262960000000000E+07,-3.73392000000000000E+06, - * 3.62880000000000000E+05,1.00000000000000000E+00, - * -2.02600000000000000E+03,2.18848000000000000E+05/ - DATA B(49), B(50), B(51), B(52), B(53), B(54), B(55), B(56), - * B(57), B(58), B(59), B(60), B(61), B(62), B(63), B(64), B(65), - * B(66), B(67), B(68), B(69), B(70), B(71), B(72) - * /-5.32616000000000000E+06,4.47650000000000000E+07, - * -1.55357384000000000E+08,2.38904904000000000E+08, - * -1.62186912000000000E+08,4.43390400000000000E+07, - * -3.62880000000000000E+06,1.00000000000000000E+00, - * -4.07200000000000000E+03,6.95038000000000000E+05, - * -2.52439040000000000E+07,3.14369720000000000E+08, - * -1.64838430400000000E+09,4.00269508800000000E+09, - * -4.64216395200000000E+09,2.50748121600000000E+09, - * -5.68356480000000000E+08,3.99168000000000000E+07, - * 1.00000000000000000E+00,-8.16600000000000000E+03, - * 2.17062600000000000E+06,-1.14876376000000000E+08, - * 2.05148277600000000E+09,-1.55489607840000000E+10/ - DATA B(73), B(74), B(75), B(76), B(77), B(78), B(79), B(80), - * B(81), B(82), B(83), B(84), B(85), B(86), B(87), B(88), B(89), - * B(90), B(91), B(92), B(93), B(94), B(95), B(96) - * /5.60413987840000000E+10,-1.01180433024000000E+11, - * 9.21997902240000000E+10,-4.07883018240000000E+10, - * 7.82771904000000000E+09,-4.79001600000000000E+08, - * 1.00000000000000000E+00,-1.63560000000000000E+04, - * 6.69969600000000000E+06,-5.07259276000000000E+08, - * 1.26698177760000000E+10,-1.34323420224000000E+11, - * 6.87720046384000000E+11,-1.81818864230400000E+12, - * 2.54986547342400000E+12,-1.88307966182400000E+12, - * 6.97929436800000000E+11,-1.15336085760000000E+11, - * 6.22702080000000000E+09,1.00000000000000000E+00, - * -3.27380000000000000E+04,2.05079880000000000E+07, - * -2.18982980800000000E+09,7.50160522280000000E+10/ - DATA B(97), B(98), B(99), B(100), B(101), B(102), B(103), B(104), - * B(105), B(106), B(107), B(108), B(109), B(110), B(111), B(112), - * B(113), B(114), B(115), B(116), B(117), B(118) - * /-1.08467651241600000E+12,7.63483214939200000E+12, - * -2.82999100661120000E+13,5.74943734645920000E+13, - * -6.47283751398720000E+13,3.96895780558080000E+13, - * -1.25509040179200000E+13,1.81099255680000000E+12, - * -8.71782912000000000E+10,1.00000000000000000E+00, - * -6.55040000000000000E+04,6.24078900000000000E+07, - * -9.29252692000000000E+09,4.29826006340000000E+11, - * -8.30844432796800000E+12,7.83913848313120000E+13, - * -3.94365587815520000E+14,1.11174747256968000E+15, - * -1.79717122069056000E+15,1.66642448627145600E+15, - * -8.65023253219584000E+14,2.36908271543040000E+14/ - DATA B(119), B(120) /-3.01963769856000000E+13, - * 1.30767436800000000E+12/ -C----------------------------------------------------------------------- -C BOUNDS B(M,K) , K=M-3 -C----------------------------------------------------------------------- - DATA BND(1), BND(2), BND(3), BND(4), BND(5), BND(6), BND(7), - * BND(8), BND(9), BND(10), BND(11), BND(12), BND(13), BND(14), - * BND(15) /1.0E0,1.0E0,1.0E0,1.0E0,3.10E0,5.18E0,11.7E0,29.8E0, - * 90.4E0,297.0E0,1070.0E0,4290.0E0,18100.0E0,84700.0E0,408000.0E0/ - DATA HRTPI /8.86226925452758014E-01/ -C -C***FIRST EXECUTABLE STATEMENT BKIAS - IERR=0 - TOL = MAX(R1MACH(4),1.0E-18) - FLN = N - RZ = 1.0E0/(X+FLN) - RZX = X*RZ - Z = 0.5E0*(X+FLN) - IF (IND.GT.1) GO TO 10 - GMRN = GAMRN(Z) - 10 CONTINUE - GS = HRTPI*GMRN - G1 = GS + GS - RG1 = 1.0E0/G1 - GMRN = (RZ+RZ)/GMRN - IF (IND.GT.1) GO TO 70 -C----------------------------------------------------------------------- -C EVALUATE ERROR FOR M=MS -C----------------------------------------------------------------------- - HN = 0.5E0*FLN - DEN2 = KTRMS + KTRMS + N - DEN3 = DEN2 - 2.0E0 - DEN1 = X + DEN2 - ERR = RG1*(X+X)/(DEN1-1.0E0) - IF (N.EQ.0) GO TO 20 - RAT = 1.0E0/(FLN*FLN) - 20 CONTINUE - IF (KTRMS.EQ.0) GO TO 30 - FJ = KTRMS - RAT = 0.25E0/(HRTPI*DEN3*SQRT(FJ)) - 30 CONTINUE - ERR = ERR*RAT - FJ = -3.0E0 - DO 50 J=1,15 - IF (J.LE.5) ERR = ERR/DEN1 - FM1 = MAX(1.0E0,FJ) - FJ = FJ + 1.0E0 - ER = BND(J)*ERR - IF (KTRMS.EQ.0) GO TO 40 - ER = ER/FM1 - IF (ER.LT.TOL) GO TO 60 - IF (J.GE.5) ERR = ERR/DEN3 - GO TO 50 - 40 CONTINUE - ER = ER*(1.0E0+HN/FM1) - IF (ER.LT.TOL) GO TO 60 - IF (J.GE.5) ERR = ERR/FLN - 50 CONTINUE - GO TO 200 - 60 CONTINUE - MS = J - 70 CONTINUE - MM = MS + MS - MP = MM + 1 -C----------------------------------------------------------------------- -C H(K)=(-Z)**(K)*(PSI(K-1,Z)-PSI(K-1,Z+0.5))/GAMMA(K) , K=1,2,...,MM -C----------------------------------------------------------------------- - IF (IND.GT.1) GO TO 80 - CALL HKSEQ(Z, MM, H, IERR) - GO TO 100 - 80 CONTINUE - RAT = Z/(Z-0.5E0) - RXP = RAT - DO 90 I=1,MM - H(I) = RXP*(1.0E0-H(I)) - RXP = RXP*RAT - 90 CONTINUE - 100 CONTINUE -C----------------------------------------------------------------------- -C SCALED S SEQUENCE -C----------------------------------------------------------------------- - S(1) = 1.0E0 - FK = 1.0E0 - DO 120 K=2,MP - SS = 0.0E0 - KM = K - 1 - I = KM - DO 110 J=1,KM - SS = SS + S(J)*H(I) - I = I - 1 - 110 CONTINUE - S(K) = SS/FK - FK = FK + 1.0E0 - 120 CONTINUE -C----------------------------------------------------------------------- -C SCALED S-TILDA SEQUENCE -C----------------------------------------------------------------------- - IF (KTRMS.EQ.0) GO TO 160 - FK = 0.0E0 - SS = 0.0E0 - RG1 = RG1/Z - DO 130 K=1,KTRMS - V(K) = Z/(Z+FK) - W(K) = T(K)*V(K) - SS = SS + W(K) - FK = FK + 1.0E0 - 130 CONTINUE - S(1) = S(1) - SS*RG1 - DO 150 I=2,MP - SS = 0.0E0 - DO 140 K=1,KTRMS - W(K) = W(K)*V(K) - SS = SS + W(K) - 140 CONTINUE - S(I) = S(I) - SS*RG1 - 150 CONTINUE - 160 CONTINUE -C----------------------------------------------------------------------- -C SUM ON J -C----------------------------------------------------------------------- - SUMJ = 0.0E0 - JN = 1 - RXP = 1.0E0 - XP(1) = 1.0E0 - DO 190 J=1,MS - JN = JN + J - 1 - XP(J+1) = XP(J)*RZX - RXP = RXP*RZ -C----------------------------------------------------------------------- -C SUM ON I -C----------------------------------------------------------------------- - SUMI = 0.0E0 - II = JN - DO 180 I=1,J - JMI = J - I + 1 - KK = J + I + 1 - DO 170 K=1,JMI - V(K) = S(KK)*XP(K) - KK = KK + 1 - 170 CONTINUE - CALL BDIFF(JMI, V) - SUMI = SUMI + B(II)*V(JMI)*XP(I+1) - II = II + 1 - 180 CONTINUE - SUMJ = SUMJ + SUMI*RXP - 190 CONTINUE - ANS = GS*(S(1)-SUMJ) - RETURN - 200 CONTINUE - IERR=2 - RETURN - END diff --git a/slatec/bkisr.f b/slatec/bkisr.f deleted file mode 100644 index 2915bb8..0000000 --- a/slatec/bkisr.f +++ /dev/null @@ -1,86 +0,0 @@ -*DECK BKISR - SUBROUTINE BKISR (X, N, SUM, IERR) -C***BEGIN PROLOGUE BKISR -C***SUBSIDIARY -C***PURPOSE Subsidiary to BSKIN -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (BKISR-S, DBKISR-D) -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C BKISR computes repeated integrals of the K0 Bessel function -C by the series for N=0,1, and 2. -C -C***SEE ALSO BSKIN -C***ROUTINES CALLED PSIXN, R1MACH -C***REVISION HISTORY (YYMMDD) -C 820601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE BKISR - INTEGER I, IERR, K, KK, KKN, K1, N, NP - REAL AK, ATOL, BK, C, FK, FN, HX, HXS, POL, PR, SUM, TKP, TOL, - * TRM, X, XLN - REAL PSIXN, R1MACH - DIMENSION C(2) - SAVE C -C - DATA C(1), C(2) /1.57079632679489662E+00,1.0E0/ -C***FIRST EXECUTABLE STATEMENT BKISR - IERR=0 - TOL = MAX(R1MACH(4),1.0E-18) - IF (X.LT.TOL) GO TO 50 - PR = 1.0E0 - POL = 0.0E0 - IF (N.EQ.0) GO TO 20 - DO 10 I=1,N - POL = -POL*X + C(I) - PR = PR*X/I - 10 CONTINUE - 20 CONTINUE - HX = X*0.5E0 - HXS = HX*HX - XLN = LOG(HX) - NP = N + 1 - TKP = 3.0E0 - FK = 2.0E0 - FN = N - BK = 4.0E0 - AK = 2.0E0/((FN+1.0E0)*(FN+2.0E0)) - SUM = AK*(PSIXN(N+3)-PSIXN(3)+PSIXN(2)-XLN) - ATOL = SUM*TOL*0.75E0 - DO 30 K=2,20 - AK = AK*(HXS/BK)*((TKP+1.0E0)/(TKP+FN+1.0E0))*(TKP/(TKP+FN)) - K1 = K + 1 - KK = K1 + K - KKN = KK + N - TRM = (PSIXN(K1)+PSIXN(KKN)-PSIXN(KK)-XLN)*AK - SUM = SUM + TRM - IF (ABS(TRM).LE.ATOL) GO TO 40 - TKP = TKP + 2.0E0 - BK = BK + TKP - FK = FK + 1.0E0 - 30 CONTINUE - GO TO 80 - 40 CONTINUE - SUM = (SUM*HXS+PSIXN(NP)-XLN)*PR - IF (N.EQ.1) SUM = -SUM - SUM = POL + SUM - RETURN -C----------------------------------------------------------------------- -C SMALL X CASE, X.LT.WORD TOLERANCE -C----------------------------------------------------------------------- - 50 CONTINUE - IF (N.GT.0) GO TO 60 - HX = X*0.5E0 - SUM = PSIXN(1) - LOG(HX) - RETURN - 60 CONTINUE - SUM = C(N) - RETURN - 80 CONTINUE - IERR=2 - RETURN - END diff --git a/slatec/bksol.f b/slatec/bksol.f deleted file mode 100644 index 144b926..0000000 --- a/slatec/bksol.f +++ /dev/null @@ -1,45 +0,0 @@ -*DECK BKSOL - SUBROUTINE BKSOL (N, A, X) -C***BEGIN PROLOGUE BKSOL -C***SUBSIDIARY -C***PURPOSE Subsidiary to BVSUP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (BKSOL-S, DBKSOL-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C ********************************************************************** -C Solution of an upper triangular linear system by -C back-substitution -C -C The matrix A is assumed to be stored in a linear -C array proceeding in a row-wise manner. The -C vector X contains the given constant vector on input -C and contains the solution on return. -C The actual diagonal of A is unity while a diagonal -C scaling matrix is stored there. -C ********************************************************************** -C -C***SEE ALSO BVSUP -C***ROUTINES CALLED SDOT -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE BKSOL -C - DIMENSION A(*),X(*) -C -C***FIRST EXECUTABLE STATEMENT BKSOL - M=(N*(N+1))/2 - X(N)=X(N)*A(M) - IF (N .EQ. 1) GO TO 20 - NM1=N-1 - DO 10 K=1,NM1 - J=N-K - M=M-K-1 - 10 X(J)=X(J)*A(M) - SDOT(K,A(M+1),1,X(J+1),1) -C - 20 RETURN - END diff --git a/slatec/blktr1.f b/slatec/blktr1.f deleted file mode 100644 index a78ce0c..0000000 --- a/slatec/blktr1.f +++ /dev/null @@ -1,249 +0,0 @@ -*DECK BLKTR1 - SUBROUTINE BLKTR1 (N, AN, BN, CN, M, AM, BM, CM, IDIMY, Y, B, W1, - + W2, W3, WD, WW, WU, PRDCT, CPRDCT) -C***BEGIN PROLOGUE BLKTR1 -C***SUBSIDIARY -C***PURPOSE Subsidiary to BLKTRI -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (BLKTR1-S, CBLKT1-C) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C BLKTR1 solves the linear system set up by BLKTRI. -C -C B contains the roots of all the B polynomials. -C W1,W2,W3,WD,WW,WU are all working arrays. -C PRDCT is either PRODP or PROD depending on whether the boundary -C conditions in the M direction are periodic or not. -C CPRDCT is either CPRODP or CPROD which are the complex versions -C of PRODP and PROD. These are called in the event that some -C of the roots of the B sub P polynomial are complex. -C -C***SEE ALSO BLKTRI -C***ROUTINES CALLED INDXA, INDXB, INDXC -C***COMMON BLOCKS CBLKT -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE BLKTR1 -C - DIMENSION AN(*) ,BN(*) ,CN(*) ,AM(*) , - 1 BM(*) ,CM(*) ,B(*) ,W1(*) , - 2 W2(*) ,W3(*) ,WD(*) ,WW(*) , - 3 WU(*) ,Y(IDIMY,*) - COMMON /CBLKT/ NPP ,K ,EPS ,CNV , - 1 NM ,NCMPLX ,IK -C***FIRST EXECUTABLE STATEMENT BLKTR1 - KDO = K-1 - DO 109 L=1,KDO - IR = L-1 - I2 = 2**IR - I1 = I2/2 - I3 = I2+I1 - I4 = I2+I2 - IRM1 = IR-1 - CALL INDXB (I2,IR,IM2,NM2) - CALL INDXB (I1,IRM1,IM3,NM3) - CALL INDXB (I3,IRM1,IM1,NM1) - CALL PRDCT (NM2,B(IM2),NM3,B(IM3),NM1,B(IM1),0,DUM,Y(1,I2),W3, - 1 M,AM,BM,CM,WD,WW,WU) - IF = 2**K - DO 108 I=I4,IF,I4 - IF (I-NM) 101,101,108 - 101 IPI1 = I+I1 - IPI2 = I+I2 - IPI3 = I+I3 - CALL INDXC (I,IR,IDXC,NC) - IF (I-IF) 102,108,108 - 102 CALL INDXA (I,IR,IDXA,NA) - CALL INDXB (I-I1,IRM1,IM1,NM1) - CALL INDXB (IPI2,IR,IP2,NP2) - CALL INDXB (IPI1,IRM1,IP1,NP1) - CALL INDXB (IPI3,IRM1,IP3,NP3) - CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W3,W1,M,AM, - 1 BM,CM,WD,WW,WU) - IF (IPI2-NM) 105,105,103 - 103 DO 104 J=1,M - W3(J) = 0. - W2(J) = 0. - 104 CONTINUE - GO TO 106 - 105 CALL PRDCT (NP2,B(IP2),NP1,B(IP1),NP3,B(IP3),0,DUM, - 1 Y(1,IPI2),W3,M,AM,BM,CM,WD,WW,WU) - CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),W3,W2,M,AM, - 1 BM,CM,WD,WW,WU) - 106 DO 107 J=1,M - Y(J,I) = W1(J)+W2(J)+Y(J,I) - 107 CONTINUE - 108 CONTINUE - 109 CONTINUE - IF (NPP) 132,110,132 -C -C THE PERIODIC CASE IS TREATED USING THE CAPACITANCE MATRIX METHOD -C - 110 IF = 2**K - I = IF/2 - I1 = I/2 - CALL INDXB (I-I1,K-2,IM1,NM1) - CALL INDXB (I+I1,K-2,IP1,NP1) - CALL INDXB (I,K-1,IZ,NZ) - CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,Y(1,I),W1,M,AM, - 1 BM,CM,WD,WW,WU) - IZR = I - DO 111 J=1,M - W2(J) = W1(J) - 111 CONTINUE - DO 113 LL=2,K - L = K-LL+1 - IR = L-1 - I2 = 2**IR - I1 = I2/2 - I = I2 - CALL INDXC (I,IR,IDXC,NC) - CALL INDXB (I,IR,IZ,NZ) - CALL INDXB (I-I1,IR-1,IM1,NM1) - CALL INDXB (I+I1,IR-1,IP1,NP1) - CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),W1,W1,M,AM,BM, - 1 CM,WD,WW,WU) - DO 112 J=1,M - W1(J) = Y(J,I)+W1(J) - 112 CONTINUE - CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W1,W1,M,AM, - 1 BM,CM,WD,WW,WU) - 113 CONTINUE - DO 118 LL=2,K - L = K-LL+1 - IR = L-1 - I2 = 2**IR - I1 = I2/2 - I4 = I2+I2 - IFD = IF-I2 - DO 117 I=I2,IFD,I4 - IF (I-I2-IZR) 117,114,117 - 114 IF (I-NM) 115,115,118 - 115 CALL INDXA (I,IR,IDXA,NA) - CALL INDXB (I,IR,IZ,NZ) - CALL INDXB (I-I1,IR-1,IM1,NM1) - CALL INDXB (I+I1,IR-1,IP1,NP1) - CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W2,W2,M,AM, - 1 BM,CM,WD,WW,WU) - DO 116 J=1,M - W2(J) = Y(J,I)+W2(J) - 116 CONTINUE - CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W2,W2,M, - 1 AM,BM,CM,WD,WW,WU) - IZR = I - IF (I-NM) 117,119,117 - 117 CONTINUE - 118 CONTINUE - 119 DO 120 J=1,M - Y(J,NM+1) = Y(J,NM+1)-CN(NM+1)*W1(J)-AN(NM+1)*W2(J) - 120 CONTINUE - CALL INDXB (IF/2,K-1,IM1,NM1) - CALL INDXB (IF,K-1,IP,NP) - IF (NCMPLX) 121,122,121 - 121 CALL CPRDCT (NM+1,B(IP),NM1,B(IM1),0,DUM,0,DUM,Y(1,NM+1), - 1 Y(1,NM+1),M,AM,BM,CM,W1,W3,WW) - GO TO 123 - 122 CALL PRDCT (NM+1,B(IP),NM1,B(IM1),0,DUM,0,DUM,Y(1,NM+1), - 1 Y(1,NM+1),M,AM,BM,CM,WD,WW,WU) - 123 DO 124 J=1,M - W1(J) = AN(1)*Y(J,NM+1) - W2(J) = CN(NM)*Y(J,NM+1) - Y(J,1) = Y(J,1)-W1(J) - Y(J,NM) = Y(J,NM)-W2(J) - 124 CONTINUE - DO 126 L=1,KDO - IR = L-1 - I2 = 2**IR - I4 = I2+I2 - I1 = I2/2 - I = I4 - CALL INDXA (I,IR,IDXA,NA) - CALL INDXB (I-I2,IR,IM2,NM2) - CALL INDXB (I-I2-I1,IR-1,IM3,NM3) - CALL INDXB (I-I1,IR-1,IM1,NM1) - CALL PRDCT (NM2,B(IM2),NM3,B(IM3),NM1,B(IM1),0,DUM,W1,W1,M,AM, - 1 BM,CM,WD,WW,WU) - CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W1,W1,M,AM,BM, - 1 CM,WD,WW,WU) - DO 125 J=1,M - Y(J,I) = Y(J,I)-W1(J) - 125 CONTINUE - 126 CONTINUE -C - IZR = NM - DO 131 L=1,KDO - IR = L-1 - I2 = 2**IR - I1 = I2/2 - I3 = I2+I1 - I4 = I2+I2 - IRM1 = IR-1 - DO 130 I=I4,IF,I4 - IPI1 = I+I1 - IPI2 = I+I2 - IPI3 = I+I3 - IF (IPI2-IZR) 127,128,127 - 127 IF (I-IZR) 130,131,130 - 128 CALL INDXC (I,IR,IDXC,NC) - CALL INDXB (IPI2,IR,IP2,NP2) - CALL INDXB (IPI1,IRM1,IP1,NP1) - CALL INDXB (IPI3,IRM1,IP3,NP3) - CALL PRDCT (NP2,B(IP2),NP1,B(IP1),NP3,B(IP3),0,DUM,W2,W2,M, - 1 AM,BM,CM,WD,WW,WU) - CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),W2,W2,M,AM, - 1 BM,CM,WD,WW,WU) - DO 129 J=1,M - Y(J,I) = Y(J,I)-W2(J) - 129 CONTINUE - IZR = I - GO TO 131 - 130 CONTINUE - 131 CONTINUE -C -C BEGIN BACK SUBSTITUTION PHASE -C - 132 DO 144 LL=1,K - L = K-LL+1 - IR = L-1 - IRM1 = IR-1 - I2 = 2**IR - I1 = I2/2 - I4 = I2+I2 - IFD = IF-I2 - DO 143 I=I2,IFD,I4 - IF (I-NM) 133,133,143 - 133 IMI1 = I-I1 - IMI2 = I-I2 - IPI1 = I+I1 - IPI2 = I+I2 - CALL INDXA (I,IR,IDXA,NA) - CALL INDXC (I,IR,IDXC,NC) - CALL INDXB (I,IR,IZ,NZ) - CALL INDXB (IMI1,IRM1,IM1,NM1) - CALL INDXB (IPI1,IRM1,IP1,NP1) - IF (I-I2) 134,134,136 - 134 DO 135 J=1,M - W1(J) = 0. - 135 CONTINUE - GO TO 137 - 136 CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),Y(1,IMI2), - 1 W1,M,AM,BM,CM,WD,WW,WU) - 137 IF (IPI2-NM) 140,140,138 - 138 DO 139 J=1,M - W2(J) = 0. - 139 CONTINUE - GO TO 141 - 140 CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),Y(1,IPI2), - 1 W2,M,AM,BM,CM,WD,WW,WU) - 141 DO 142 J=1,M - W1(J) = Y(J,I)+W1(J)+W2(J) - 142 CONTINUE - CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W1,Y(1,I), - 1 M,AM,BM,CM,WD,WW,WU) - 143 CONTINUE - 144 CONTINUE - RETURN - END diff --git a/slatec/blktri.f b/slatec/blktri.f deleted file mode 100644 index 4f709b6..0000000 --- a/slatec/blktri.f +++ /dev/null @@ -1,264 +0,0 @@ -*DECK BLKTRI - SUBROUTINE BLKTRI (IFLG, NP, N, AN, BN, CN, MP, M, AM, BM, CM, - + IDIMY, Y, IERROR, W) -C***BEGIN PROLOGUE BLKTRI -C***PURPOSE Solve a block tridiagonal system of linear equations -C (usually resulting from the discretization of separable -C two-dimensional elliptic equations). -C***LIBRARY SLATEC (FISHPACK) -C***CATEGORY I2B4B -C***TYPE SINGLE PRECISION (BLKTRI-S, CBLKTR-C) -C***KEYWORDS ELLIPTIC PDE, FISHPACK, TRIDIAGONAL LINEAR SYSTEM -C***AUTHOR Adams, J., (NCAR) -C Swarztrauber, P. N., (NCAR) -C Sweet, R., (NCAR) -C***DESCRIPTION -C -C Subroutine BLKTRI Solves a System of Linear Equations of the Form -C -C AN(J)*X(I,J-1) + AM(I)*X(I-1,J) + (BN(J)+BM(I))*X(I,J) -C -C + CN(J)*X(I,J+1) + CM(I)*X(I+1,J) = Y(I,J) -C -C for I = 1,2,...,M and J = 1,2,...,N. -C -C I+1 and I-1 are evaluated modulo M and J+1 and J-1 modulo N, i.e., -C -C X(I,0) = X(I,N), X(I,N+1) = X(I,1), -C X(0,J) = X(M,J), X(M+1,J) = X(1,J). -C -C These equations usually result from the discretization of -C separable elliptic equations. Boundary conditions may be -C Dirichlet, Neumann, or Periodic. -C -C -C * * * * * * * * * * ON INPUT * * * * * * * * * * -C -C IFLG -C = 0 Initialization only. Certain quantities that depend on NP, -C N, AN, BN, and CN are computed and stored in the work -C array W. -C = 1 The quantities that were computed in the initialization are -C used to obtain the solution X(I,J). -C -C NOTE A call with IFLG=0 takes approximately one half the time -C as a call with IFLG = 1 . However, the -C initialization does not have to be repeated unless NP, N, -C AN, BN, or CN change. -C -C NP -C = 0 If AN(1) and CN(N) are not zero, which corresponds to -C periodic boundary conditions. -C = 1 If AN(1) and CN(N) are zero. -C -C N -C The number of unknowns in the J-direction. N must be greater -C than 4. The operation count is proportional to MNlog2(N), hence -C N should be selected less than or equal to M. -C -C AN,BN,CN -C One-dimensional arrays of length N that specify the coefficients -C in the linear equations given above. -C -C MP -C = 0 If AM(1) and CM(M) are not zero, which corresponds to -C periodic boundary conditions. -C = 1 If AM(1) = CM(M) = 0 . -C -C M -C The number of unknowns in the I-direction. M must be greater -C than 4. -C -C AM,BM,CM -C One-dimensional arrays of length M that specify the coefficients -C in the linear equations given above. -C -C IDIMY -C The row (or first) dimension of the two-dimensional array Y as -C it appears in the program calling BLKTRI. This parameter is -C used to specify the variable dimension of Y. IDIMY must be at -C least M. -C -C Y -C A two-dimensional array that specifies the values of the right -C side of the linear system of equations given above. Y must be -C dimensioned at least M*N. -C -C W -C A one-dimensional array that must be provided by the user for -C work space. -C If NP=1 define K=INT(log2(N))+1 and set L=2**(K+1) then -C W must have dimension (K-2)*L+K+5+MAX(2N,6M) -C -C If NP=0 define K=INT(log2(N-1))+1 and set L=2**(K+1) then -C W must have dimension (K-2)*L+K+5+2N+MAX(2N,6M) -C -C **IMPORTANT** For purposes of checking, the required dimension -C of W is computed by BLKTRI and stored in W(1) -C in floating point format. -C -C * * * * * * * * * * On Output * * * * * * * * * * -C -C Y -C Contains the solution X. -C -C IERROR -C An error flag that indicates invalid input parameters. Except -C for number zero, a solution is not attempted. -C -C = 0 No error. -C = 1 M is less than 5. -C = 2 N is less than 5. -C = 3 IDIMY is less than M. -C = 4 BLKTRI failed while computing results that depend on the -C coefficient arrays AN, BN, CN. Check these arrays. -C = 5 AN(J)*CN(J-1) is less than 0 for some J. Possible reasons -C for this condition are -C 1. The arrays AN and CN are not correct. -C 2. Too large a grid spacing was used in the discretization -C of the elliptic equation. -C 3. The linear equations resulted from a partial -C differential equation which was not elliptic. -C -C W -C Contains intermediate values that must not be destroyed if -C BLKTRI will be called again with IFLG=1. W(1) contains the -C number of locations required by W in floating point format. -C -C *Long Description: -C -C * * * * * * * Program Specifications * * * * * * * * * * * * -C -C Dimension of AN(N),BN(N),CN(N),AM(M),BM(M),CM(M),Y(IDIMY,N) -C Arguments W(See argument list) -C -C Latest June 1979 -C Revision -C -C Required BLKTRI,BLKTRI,PROD,PRODP,CPROD,CPRODP,COMPB,INDXA, -C Subprograms INDXB,INDXC,PPADD,PSGF,PPSGF,PPSPF,BSRH,TEVLS, -C R1MACH -C -C Special The Algorithm may fail if ABS(BM(I)+BN(J)) is less -C Conditions than ABS(AM(I))+ABS(AN(J))+ABS(CM(I))+ABS(CN(J)) -C for some I and J. The Algorithm will also fail if -C AN(J)*CN(J-1) is less than zero for some J. -C See the description of the output parameter IERROR. -C -C Common CBLKT -C Blocks -C -C I/O None -C -C Precision Single -C -C Specialist Paul Swarztrauber -C -C Language FORTRAN -C -C History Version 1 September 1973 -C Version 2 April 1976 -C Version 3 June 1979 -C -C Algorithm Generalized Cyclic Reduction (See Reference below) -C -C Space -C Required Control Data 7600 -C -C Portability American National Standards Institute Fortran. -C The machine accuracy is set using function R1MACH. -C -C Required None -C Resident -C Routines -C -C References Swarztrauber,P. and R. Sweet, 'Efficient FORTRAN -C Subprograms For The Solution Of Elliptic Equations' -C NCAR TN/IA-109, July, 1975, 138 PP. -C -C Swarztrauber P. ,'A Direct Method For The Discrete -C Solution Of Separable Elliptic Equations', S.I.A.M. -C J. Numer. Anal.,11(1974) PP. 1136-1150. -C -C***REFERENCES P. N. Swarztrauber and R. Sweet, Efficient Fortran -C subprograms for the solution of elliptic equations, -C NCAR TN/IA-109, July 1975, 138 pp. -C P. N. Swarztrauber, A direct method for the discrete -C solution of separable elliptic equations, SIAM Journal -C on Numerical Analysis 11, (1974), pp. 1136-1150. -C***ROUTINES CALLED BLKTR1, COMPB, CPROD, CPRODP, PROD, PRODP -C***COMMON BLOCKS CBLKT -C***REVISION HISTORY (YYMMDD) -C 801001 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 BLKTRI -C - DIMENSION AN(*) ,BN(*) ,CN(*) ,AM(*) , - 1 BM(*) ,CM(*) ,Y(IDIMY,*) ,W(*) - EXTERNAL PROD ,PRODP ,CPROD ,CPRODP - COMMON /CBLKT/ NPP ,K ,EPS ,CNV , - 1 NM ,NCMPLX ,IK -C***FIRST EXECUTABLE STATEMENT BLKTRI - NM = N - IERROR = 0 - IF (M-5) 101,102,102 - 101 IERROR = 1 - GO TO 119 - 102 IF (NM-3) 103,104,104 - 103 IERROR = 2 - GO TO 119 - 104 IF (IDIMY-M) 105,106,106 - 105 IERROR = 3 - GO TO 119 - 106 NH = N - NPP = NP - IF (NPP) 107,108,107 - 107 NH = NH+1 - 108 IK = 2 - K = 1 - 109 IK = IK+IK - K = K+1 - IF (NH-IK) 110,110,109 - 110 NL = IK - IK = IK+IK - NL = NL-1 - IWAH = (K-2)*IK+K+6 - IF (NPP) 111,112,111 -C -C DIVIDE W INTO WORKING SUB ARRAYS -C - 111 IW1 = IWAH - IWBH = IW1+NM - W(1) = IW1-1+MAX(2*NM,6*M) - GO TO 113 - 112 IWBH = IWAH+NM+NM - IW1 = IWBH - W(1) = IW1-1+MAX(2*NM,6*M) - NM = NM-1 -C -C SUBROUTINE COMP B COMPUTES THE ROOTS OF THE B POLYNOMIALS -C - 113 IF (IERROR) 119,114,119 - 114 IW2 = IW1+M - IW3 = IW2+M - IWD = IW3+M - IWW = IWD+M - IWU = IWW+M - IF (IFLG) 116,115,116 - 115 CALL COMPB (NL,IERROR,AN,BN,CN,W(2),W(IWAH),W(IWBH)) - GO TO 119 - 116 IF (MP) 117,118,117 -C -C SUBROUTINE BLKTR1 SOLVES THE LINEAR SYSTEM -C - 117 CALL BLKTR1 (NL,AN,BN,CN,M,AM,BM,CM,IDIMY,Y,W(2),W(IW1),W(IW2), - 1 W(IW3),W(IWD),W(IWW),W(IWU),PROD,CPROD) - GO TO 119 - 118 CALL BLKTR1 (NL,AN,BN,CN,M,AM,BM,CM,IDIMY,Y,W(2),W(IW1),W(IW2), - 1 W(IW3),W(IWD),W(IWW),W(IWU),PRODP,CPRODP) - 119 CONTINUE - RETURN - END diff --git a/slatec/bndacc.f b/slatec/bndacc.f deleted file mode 100644 index df0d593..0000000 --- a/slatec/bndacc.f +++ /dev/null @@ -1,271 +0,0 @@ -*DECK BNDACC - SUBROUTINE BNDACC (G, MDG, NB, IP, IR, MT, JT) -C***BEGIN PROLOGUE BNDACC -C***PURPOSE Compute the LU factorization of a banded matrices using -C sequential accumulation of rows of the data matrix. -C Exactly one right-hand side vector is permitted. -C***LIBRARY SLATEC -C***CATEGORY D9 -C***TYPE SINGLE PRECISION (BNDACC-S, DBNDAC-D) -C***KEYWORDS BANDED MATRIX, CURVE FITTING, LEAST SQUARES -C***AUTHOR Lawson, C. L., (JPL) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C These subroutines solve the least squares problem Ax = b for -C banded matrices A using sequential accumulation of rows of the -C data matrix. Exactly one right-hand side vector is permitted. -C -C These subroutines are intended for the type of least squares -C systems that arise in applications such as curve or surface -C fitting of data. The least squares equations are accumulated and -C processed using only part of the data. This requires a certain -C user interaction during the solution of Ax = b. -C -C Specifically, suppose the data matrix (A B) is row partitioned -C into Q submatrices. Let (E F) be the T-th one of these -C submatrices where E = (0 C 0). Here the dimension of E is MT by N -C and the dimension of C is MT by NB. The value of NB is the -C bandwidth of A. The dimensions of the leading block of zeros in E -C are MT by JT-1. -C -C The user of the subroutine BNDACC provides MT,JT,C and F for -C T=1,...,Q. Not all of this data must be supplied at once. -C -C Following the processing of the various blocks (E F), the matrix -C (A B) has been transformed to the form (R D) where R is upper -C triangular and banded with bandwidth NB. The least squares -C system Rx = d is then easily solved using back substitution by -C executing the statement CALL BNDSOL(1,...). The sequence of -C values for JT must be nondecreasing. This may require some -C preliminary interchanges of rows and columns of the matrix A. -C -C The primary reason for these subroutines is that the total -C processing can take place in a working array of dimension MU by -C NB+1. An acceptable value for MU is -C -C MU = MAX(MT + N + 1), -C -C where N is the number of unknowns. -C -C Here the maximum is taken over all values of MT for T=1,...,Q. -C Notice that MT can be taken to be a small as one, showing that -C MU can be as small as N+2. The subprogram BNDACC processes the -C rows more efficiently if MU is large enough so that each new -C block (C F) has a distinct value of JT. -C -C The four principle parts of these algorithms are obtained by the -C following call statements -C -C CALL BNDACC(...) Introduce new blocks of data. -C -C CALL BNDSOL(1,...)Compute solution vector and length of -C residual vector. -C -C CALL BNDSOL(2,...)Given any row vector H solve YR = H for the -C row vector Y. -C -C CALL BNDSOL(3,...)Given any column vector W solve RZ = W for -C the column vector Z. -C -C The dots in the above call statements indicate additional -C arguments that will be specified in the following paragraphs. -C -C The user must dimension the array appearing in the call list.. -C G(MDG,NB+1) -C -C Description of calling sequence for BNDACC.. -C -C The entire set of parameters for BNDACC are -C -C Input.. -C -C G(*,*) The working array into which the user will -C place the MT by NB+1 block (C F) in rows IR -C through IR+MT-1, columns 1 through NB+1. -C See descriptions of IR and MT below. -C -C MDG The number of rows in the working array -C G(*,*). The value of MDG should be .GE. MU. -C The value of MU is defined in the abstract -C of these subprograms. -C -C NB The bandwidth of the data matrix A. -C -C IP Set by the user to the value 1 before the -C first call to BNDACC. Its subsequent value -C is controlled by BNDACC to set up for the -C next call to BNDACC. -C -C IR Index of the row of G(*,*) where the user is -C to place the new block of data (C F). Set by -C the user to the value 1 before the first call -C to BNDACC. Its subsequent value is controlled -C by BNDACC. A value of IR .GT. MDG is considered -C an error. -C -C MT,JT Set by the user to indicate respectively the -C number of new rows of data in the block and -C the index of the first nonzero column in that -C set of rows (E F) = (0 C 0 F) being processed. -C -C Output.. -C -C G(*,*) The working array which will contain the -C processed rows of that part of the data -C matrix which has been passed to BNDACC. -C -C IP,IR The values of these arguments are advanced by -C BNDACC to be ready for storing and processing -C a new block of data in G(*,*). -C -C Description of calling sequence for BNDSOL.. -C -C The user must dimension the arrays appearing in the call list.. -C -C G(MDG,NB+1), X(N) -C -C The entire set of parameters for BNDSOL are -C -C Input.. -C -C MODE Set by the user to one of the values 1, 2, or -C 3. These values respectively indicate that -C the solution of AX = B, YR = H or RZ = W is -C required. -C -C G(*,*),MDG, These arguments all have the same meaning and -C NB,IP,IR contents as following the last call to BNDACC. -C -C X(*) With mode=2 or 3 this array contains, -C respectively, the right-side vectors H or W of -C the systems YR = H or RZ = W. -C -C N The number of variables in the solution -C vector. If any of the N diagonal terms are -C zero the subroutine BNDSOL prints an -C appropriate message. This condition is -C considered an error. -C -C Output.. -C -C X(*) This array contains the solution vectors X, -C Y or Z of the systems AX = B, YR = H or -C RZ = W depending on the value of MODE=1, -C 2 or 3. -C -C RNORM If MODE=1 RNORM is the Euclidean length of the -C residual vector AX-B. When MODE=2 or 3 RNORM -C is set to zero. -C -C Remarks.. -C -C To obtain the upper triangular matrix and transformed right-hand -C side vector D so that the super diagonals of R form the columns -C of G(*,*), execute the following Fortran statements. -C -C NBP1=NB+1 -C -C DO 10 J=1, NBP1 -C -C 10 G(IR,J) = 0.E0 -C -C MT=1 -C -C JT=N+1 -C -C CALL BNDACC(G,MDG,NB,IP,IR,MT,JT) -C -C***REFERENCES C. L. Lawson and R. J. Hanson, Solving Least Squares -C Problems, Prentice-Hall, Inc., 1974, Chapter 27. -C***ROUTINES CALLED H12, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790101 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE BNDACC - DIMENSION G(MDG,*) -C***FIRST EXECUTABLE STATEMENT BNDACC - ZERO=0. -C -C ALG. STEPS 1-4 ARE PERFORMED EXTERNAL TO THIS SUBROUTINE. -C - NBP1=NB+1 - IF (MT.LE.0.OR.NB.LE.0) RETURN -C - IF(.NOT.MDG.LT.IR) GO TO 5 - NERR=1 - IOPT=2 - CALL XERMSG ('SLATEC', 'BNDACC', 'MDG.LT.IR, PROBABLE ERROR.', - + NERR, IOPT) - RETURN - 5 CONTINUE -C -C ALG. STEP 5 - IF (JT.EQ.IP) GO TO 70 -C ALG. STEPS 6-7 - IF (JT.LE.IR) GO TO 30 -C ALG. STEPS 8-9 - DO 10 I=1,MT - IG1=JT+MT-I - IG2=IR+MT-I - DO 10 J=1,NBP1 - G(IG1,J)=G(IG2,J) - 10 CONTINUE -C ALG. STEP 10 - IE=JT-IR - DO 20 I=1,IE - IG=IR+I-1 - DO 20 J=1,NBP1 - G(IG,J)=ZERO - 20 CONTINUE -C ALG. STEP 11 - IR=JT -C ALG. STEP 12 - 30 MU=MIN(NB-1,IR-IP-1) - IF (MU.EQ.0) GO TO 60 -C ALG. STEP 13 - DO 50 L=1,MU -C ALG. STEP 14 - K=MIN(L,JT-IP) -C ALG. STEP 15 - LP1=L+1 - IG=IP+L - DO 40 I=LP1,NB - JG=I-K - G(IG,JG)=G(IG,I) - 40 CONTINUE -C ALG. STEP 16 - DO 50 I=1,K - JG=NBP1-I - G(IG,JG)=ZERO - 50 CONTINUE -C ALG. STEP 17 - 60 IP=JT -C ALG. STEPS 18-19 - 70 MH=IR+MT-IP - KH=MIN(NBP1,MH) -C ALG. STEP 20 - DO 80 I=1,KH - CALL H12 (1,I,MAX(I+1,IR-IP+1),MH,G(IP,I),1,RHO, - 1 G(IP,I+1),1,MDG,NBP1-I) - 80 CONTINUE -C ALG. STEP 21 - IR=IP+KH -C ALG. STEP 22 - IF (KH.LT.NBP1) GO TO 100 -C ALG. STEP 23 - DO 90 I=1,NB - G(IR-1,I)=ZERO - 90 CONTINUE -C ALG. STEP 24 - 100 CONTINUE -C ALG. STEP 25 - RETURN - END diff --git a/slatec/bndsol.f b/slatec/bndsol.f deleted file mode 100644 index 681b450..0000000 --- a/slatec/bndsol.f +++ /dev/null @@ -1,255 +0,0 @@ -*DECK BNDSOL - SUBROUTINE BNDSOL (MODE, G, MDG, NB, IP, IR, X, N, RNORM) -C***BEGIN PROLOGUE BNDSOL -C***PURPOSE Solve the least squares problem for a banded matrix using -C sequential accumulation of rows of the data matrix. -C Exactly one right-hand side vector is permitted. -C***LIBRARY SLATEC -C***CATEGORY D9 -C***TYPE SINGLE PRECISION (BNDSOL-S, DBNDSL-D) -C***KEYWORDS BANDED MATRIX, CURVE FITTING, LEAST SQUARES -C***AUTHOR Lawson, C. L., (JPL) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C These subroutines solve the least squares problem Ax = b for -C banded matrices A using sequential accumulation of rows of the -C data matrix. Exactly one right-hand side vector is permitted. -C -C These subroutines are intended for the type of least squares -C systems that arise in applications such as curve or surface -C fitting of data. The least squares equations are accumulated and -C processed using only part of the data. This requires a certain -C user interaction during the solution of Ax = b. -C -C Specifically, suppose the data matrix (A B) is row partitioned -C into Q submatrices. Let (E F) be the T-th one of these -C submatrices where E = (0 C 0). Here the dimension of E is MT by N -C and the dimension of C is MT by NB. The value of NB is the -C bandwidth of A. The dimensions of the leading block of zeros in E -C are MT by JT-1. -C -C The user of the subroutine BNDACC provides MT,JT,C and F for -C T=1,...,Q. Not all of this data must be supplied at once. -C -C Following the processing of the various blocks (E F), the matrix -C (A B) has been transformed to the form (R D) where R is upper -C triangular and banded with bandwidth NB. The least squares -C system Rx = d is then easily solved using back substitution by -C executing the statement CALL BNDSOL(1,...). The sequence of -C values for JT must be nondecreasing. This may require some -C preliminary interchanges of rows and columns of the matrix A. -C -C The primary reason for these subroutines is that the total -C processing can take place in a working array of dimension MU by -C NB+1. An acceptable value for MU is -C -C MU = MAX(MT + N + 1), -C -C where N is the number of unknowns. -C -C Here the maximum is taken over all values of MT for T=1,...,Q. -C Notice that MT can be taken to be a small as one, showing that -C MU can be as small as N+2. The subprogram BNDACC processes the -C rows more efficiently if MU is large enough so that each new -C block (C F) has a distinct value of JT. -C -C The four principle parts of these algorithms are obtained by the -C following call statements -C -C CALL BNDACC(...) Introduce new blocks of data. -C -C CALL BNDSOL(1,...)Compute solution vector and length of -C residual vector. -C -C CALL BNDSOL(2,...)Given any row vector H solve YR = H for the -C row vector Y. -C -C CALL BNDSOL(3,...)Given any column vector W solve RZ = W for -C the column vector Z. -C -C The dots in the above call statements indicate additional -C arguments that will be specified in the following paragraphs. -C -C The user must dimension the array appearing in the call list.. -C G(MDG,NB+1) -C -C Description of calling sequence for BNDACC.. -C -C The entire set of parameters for BNDACC are -C -C Input.. -C -C G(*,*) The working array into which the user will -C place the MT by NB+1 block (C F) in rows IR -C through IR+MT-1, columns 1 through NB+1. -C See descriptions of IR and MT below. -C -C MDG The number of rows in the working array -C G(*,*). The value of MDG should be .GE. MU. -C The value of MU is defined in the abstract -C of these subprograms. -C -C NB The bandwidth of the data matrix A. -C -C IP Set by the user to the value 1 before the -C first call to BNDACC. Its subsequent value -C is controlled by BNDACC to set up for the -C next call to BNDACC. -C -C IR Index of the row of G(*,*) where the user is -C the user to the value 1 before the first call -C to BNDACC. Its subsequent value is controlled -C by BNDACC. A value of IR .GT. MDG is considered -C an error. -C -C MT,JT Set by the user to indicate respectively the -C number of new rows of data in the block and -C the index of the first nonzero column in that -C set of rows (E F) = (0 C 0 F) being processed. -C Output.. -C -C G(*,*) The working array which will contain the -C processed rows of that part of the data -C matrix which has been passed to BNDACC. -C -C IP,IR The values of these arguments are advanced by -C BNDACC to be ready for storing and processing -C a new block of data in G(*,*). -C -C Description of calling sequence for BNDSOL.. -C -C The user must dimension the arrays appearing in the call list.. -C -C G(MDG,NB+1), X(N) -C -C The entire set of parameters for BNDSOL are -C -C Input.. -C -C MODE Set by the user to one of the values 1, 2, or -C 3. These values respectively indicate that -C the solution of AX = B, YR = H or RZ = W is -C required. -C -C G(*,*),MDG, These arguments all have the same meaning and -C NB,IP,IR contents as following the last call to BNDACC. -C -C X(*) With mode=2 or 3 this array contains, -C respectively, the right-side vectors H or W of -C the systems YR = H or RZ = W. -C -C N The number of variables in the solution -C vector. If any of the N diagonal terms are -C zero the subroutine BNDSOL prints an -C appropriate message. This condition is -C considered an error. -C -C Output.. -C -C X(*) This array contains the solution vectors X, -C Y or Z of the systems AX = B, YR = H or -C RZ = W depending on the value of MODE=1, -C 2 or 3. -C -C RNORM If MODE=1 RNORM is the Euclidean length of the -C residual vector AX-B. When MODE=2 or 3 RNORM -C is set to zero. -C -C Remarks.. -C -C To obtain the upper triangular matrix and transformed right-hand -C side vector D so that the super diagonals of R form the columns -C of G(*,*), execute the following Fortran statements. -C -C NBP1=NB+1 -C -C DO 10 J=1, NBP1 -C -C 10 G(IR,J) = 0.E0 -C -C MT=1 -C -C JT=N+1 -C -C CALL BNDACC(G,MDG,NB,IP,IR,MT,JT) -C -C***REFERENCES C. L. Lawson and R. J. Hanson, Solving Least Squares -C Problems, Prentice-Hall, Inc., 1974, Chapter 27. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 790101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE BNDSOL - DIMENSION G(MDG,*),X(*) -C***FIRST EXECUTABLE STATEMENT BNDSOL - ZERO=0. -C - RNORM=ZERO - GO TO (10,90,50), MODE -C ********************* MODE = 1 -C ALG. STEP 26 - 10 DO 20 J=1,N - X(J)=G(J,NB+1) - 20 CONTINUE - RSQ=ZERO - NP1=N+1 - IRM1=IR-1 - IF (NP1.GT.IRM1) GO TO 40 - DO 30 J=NP1,IRM1 - RSQ=RSQ+G(J,NB+1)**2 - 30 CONTINUE - RNORM=SQRT(RSQ) - 40 CONTINUE -C ********************* MODE = 3 -C ALG. STEP 27 - 50 DO 80 II=1,N - I=N+1-II -C ALG. STEP 28 - S=ZERO - L=MAX(0,I-IP) -C ALG. STEP 29 - IF (I.EQ.N) GO TO 70 -C ALG. STEP 30 - IE=MIN(N+1-I,NB) - DO 60 J=2,IE - JG=J+L - IX=I-1+J - S=S+G(I,JG)*X(IX) - 60 CONTINUE -C ALG. STEP 31 - 70 IF (G(I,L+1)) 80,130,80 - 80 X(I)=(X(I)-S)/G(I,L+1) -C ALG. STEP 32 - RETURN -C ********************* MODE = 2 - 90 DO 120 J=1,N - S=ZERO - IF (J.EQ.1) GO TO 110 - I1=MAX(1,J-NB+1) - I2=J-1 - DO 100 I=I1,I2 - L=J-I+1+MAX(0,I-IP) - S=S+X(I)*G(I,L) - 100 CONTINUE - 110 L=MAX(0,J-IP) - IF (G(J,L+1)) 120,130,120 - 120 X(J)=(X(J)-S)/G(J,L+1) - RETURN -C - 130 CONTINUE - NERR=1 - IOPT=2 - CALL XERMSG ('SLATEC', 'BNDSOL', - + 'A ZERO DIAGONAL TERM IS IN THE N BY N UPPER TRIANGULAR ' // - + 'MATRIX.', NERR, IOPT) - RETURN - END diff --git a/slatec/bnfac.f b/slatec/bnfac.f deleted file mode 100644 index 82c7ea7..0000000 --- a/slatec/bnfac.f +++ /dev/null @@ -1,137 +0,0 @@ -*DECK BNFAC - SUBROUTINE BNFAC (W, NROWW, NROW, NBANDL, NBANDU, IFLAG) -C***BEGIN PROLOGUE BNFAC -C***SUBSIDIARY -C***PURPOSE Subsidiary to BINT4 and BINTK -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (BNFAC-S, DBNFAC-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C BNFAC is the BANFAC routine from -C * A Practical Guide to Splines * by C. de Boor -C -C Returns in W the lu-factorization (without pivoting) of the banded -C matrix A of order NROW with (NBANDL + 1 + NBANDU) bands or diag- -C onals in the work array W . -C -C ***** I N P U T ****** -C W.....Work array of size (NROWW,NROW) containing the interesting -C part of a banded matrix A , with the diagonals or bands of A -C stored in the rows of W , while columns of A correspond to -C columns of W . This is the storage mode used in LINPACK and -C results in efficient innermost loops. -C Explicitly, A has NBANDL bands below the diagonal -C + 1 (main) diagonal -C + NBANDU bands above the diagonal -C and thus, with MIDDLE = NBANDU + 1, -C A(I+J,J) is in W(I+MIDDLE,J) for I=-NBANDU,...,NBANDL -C J=1,...,NROW . -C For example, the interesting entries of A (1,2)-banded matrix -C of order 9 would appear in the first 1+1+2 = 4 rows of W -C as follows. -C 13 24 35 46 57 68 79 -C 12 23 34 45 56 67 78 89 -C 11 22 33 44 55 66 77 88 99 -C 21 32 43 54 65 76 87 98 -C -C All other entries of W not identified in this way with an en- -C try of A are never referenced . -C NROWW.....Row dimension of the work array W . -C must be .GE. NBANDL + 1 + NBANDU . -C NBANDL.....Number of bands of A below the main diagonal -C NBANDU.....Number of bands of A above the main diagonal . -C -C ***** O U T P U T ****** -C IFLAG.....Integer indicating success( = 1) or failure ( = 2) . -C If IFLAG = 1, then -C W.....contains the LU-factorization of A into a unit lower triangu- -C lar matrix L and an upper triangular matrix U (both banded) -C and stored in customary fashion over the corresponding entries -C of A . This makes it possible to solve any particular linear -C system A*X = B for X by A -C CALL BNSLV ( W, NROWW, NROW, NBANDL, NBANDU, B ) -C with the solution X contained in B on return . -C If IFLAG = 2, then -C one of NROW-1, NBANDL,NBANDU failed to be nonnegative, or else -C one of the potential pivots was found to be zero indicating -C that A does not have an LU-factorization. This implies that -C A is singular in case it is totally positive . -C -C ***** M E T H O D ****** -C Gauss elimination W I T H O U T pivoting is used. The routine is -C intended for use with matrices A which do not require row inter- -C changes during factorization, especially for the T O T A L L Y -C P O S I T I V E matrices which occur in spline calculations. -C The routine should not be used for an arbitrary banded matrix. -C -C***SEE ALSO BINT4, BINTK -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 800901 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE BNFAC -C - INTEGER IFLAG, NBANDL, NBANDU, NROW, NROWW, I, IPK, J, JMAX, K, - 1 KMAX, MIDDLE, MIDMK, NROWM1 - REAL W(NROWW,*), FACTOR, PIVOT -C -C***FIRST EXECUTABLE STATEMENT BNFAC - IFLAG = 1 - MIDDLE = NBANDU + 1 -C W(MIDDLE,.) CONTAINS THE MAIN DIAGONAL OF A . - NROWM1 = NROW - 1 - IF (NROWM1) 120, 110, 10 - 10 IF (NBANDL.GT.0) GO TO 30 -C A IS UPPER TRIANGULAR. CHECK THAT DIAGONAL IS NONZERO . - DO 20 I=1,NROWM1 - IF (W(MIDDLE,I).EQ.0.0E0) GO TO 120 - 20 CONTINUE - GO TO 110 - 30 IF (NBANDU.GT.0) GO TO 60 -C A IS LOWER TRIANGULAR. CHECK THAT DIAGONAL IS NONZERO AND -C DIVIDE EACH COLUMN BY ITS DIAGONAL . - DO 50 I=1,NROWM1 - PIVOT = W(MIDDLE,I) - IF (PIVOT.EQ.0.0E0) GO TO 120 - JMAX = MIN(NBANDL,NROW-I) - DO 40 J=1,JMAX - W(MIDDLE+J,I) = W(MIDDLE+J,I)/PIVOT - 40 CONTINUE - 50 CONTINUE - RETURN -C -C A IS NOT JUST A TRIANGULAR MATRIX. CONSTRUCT LU FACTORIZATION - 60 DO 100 I=1,NROWM1 -C W(MIDDLE,I) IS PIVOT FOR I-TH STEP . - PIVOT = W(MIDDLE,I) - IF (PIVOT.EQ.0.0E0) GO TO 120 -C JMAX IS THE NUMBER OF (NONZERO) ENTRIES IN COLUMN I -C BELOW THE DIAGONAL . - JMAX = MIN(NBANDL,NROW-I) -C DIVIDE EACH ENTRY IN COLUMN I BELOW DIAGONAL BY PIVOT . - DO 70 J=1,JMAX - W(MIDDLE+J,I) = W(MIDDLE+J,I)/PIVOT - 70 CONTINUE -C KMAX IS THE NUMBER OF (NONZERO) ENTRIES IN ROW I TO -C THE RIGHT OF THE DIAGONAL . - KMAX = MIN(NBANDU,NROW-I) -C SUBTRACT A(I,I+K)*(I-TH COLUMN) FROM (I+K)-TH COLUMN -C (BELOW ROW I ) . - DO 90 K=1,KMAX - IPK = I + K - MIDMK = MIDDLE - K - FACTOR = W(MIDMK,IPK) - DO 80 J=1,JMAX - W(MIDMK+J,IPK) = W(MIDMK+J,IPK) - W(MIDDLE+J,I)*FACTOR - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE -C CHECK THE LAST DIAGONAL ENTRY . - 110 IF (W(MIDDLE,NROW).NE.0.0E0) RETURN - 120 IFLAG = 2 - RETURN - END diff --git a/slatec/bnslv.f b/slatec/bnslv.f deleted file mode 100644 index a695e89..0000000 --- a/slatec/bnslv.f +++ /dev/null @@ -1,79 +0,0 @@ -*DECK BNSLV - SUBROUTINE BNSLV (W, NROWW, NROW, NBANDL, NBANDU, B) -C***BEGIN PROLOGUE BNSLV -C***SUBSIDIARY -C***PURPOSE Subsidiary to BINT4 and BINTK -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (BNSLV-S, DBNSLV-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C BNSLV is the BANSLV routine from -C * A Practical Guide to Splines * by C. de Boor -C -C Companion routine to BNFAC . It returns the solution X of the -C linear system A*X = B in place of B , given the LU-factorization -C for A in the work array W from BNFAC. -C -C ***** I N P U T ****** -C W, NROWW,NROW,NBANDL,NBANDU.....Describe the LU-factorization of a -C banded matrix A of order NROW as constructed in BNFAC . -C For details, see BNFAC . -C B.....Right side of the system to be solved . -C -C ***** O U T P U T ****** -C B.....Contains the solution X , of order NROW . -C -C ***** M E T H O D ****** -C (With A = L*U, as stored in W,) the unit lower triangular system -C L(U*X) = B is solved for Y = U*X, and Y stored in B . Then the -C upper triangular system U*X = Y is solved for X . The calcul- -C ations are so arranged that the innermost loops stay within columns. -C -C***SEE ALSO BINT4, BINTK -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 800901 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE BNSLV -C - INTEGER NBANDL, NBANDU, NROW, NROWW, I, J, JMAX, MIDDLE, NROWM1 - REAL W(NROWW,*), B(*) -C***FIRST EXECUTABLE STATEMENT BNSLV - MIDDLE = NBANDU + 1 - IF (NROW.EQ.1) GO TO 80 - NROWM1 = NROW - 1 - IF (NBANDL.EQ.0) GO TO 30 -C FORWARD PASS -C FOR I=1,2,...,NROW-1, SUBTRACT RIGHT SIDE(I)*(I-TH COLUMN -C OF L ) FROM RIGHT SIDE (BELOW I-TH ROW) . - DO 20 I=1,NROWM1 - JMAX = MIN(NBANDL,NROW-I) - DO 10 J=1,JMAX - B(I+J) = B(I+J) - B(I)*W(MIDDLE+J,I) - 10 CONTINUE - 20 CONTINUE -C BACKWARD PASS -C FOR I=NROW,NROW-1,...,1, DIVIDE RIGHT SIDE(I) BY I-TH DIAG- -C ONAL ENTRY OF U, THEN SUBTRACT RIGHT SIDE(I)*(I-TH COLUMN -C OF U) FROM RIGHT SIDE (ABOVE I-TH ROW). - 30 IF (NBANDU.GT.0) GO TO 50 -C A IS LOWER TRIANGULAR . - DO 40 I=1,NROW - B(I) = B(I)/W(1,I) - 40 CONTINUE - RETURN - 50 I = NROW - 60 B(I) = B(I)/W(MIDDLE,I) - JMAX = MIN(NBANDU,I-1) - DO 70 J=1,JMAX - B(I-J) = B(I-J) - B(I)*W(MIDDLE-J,I) - 70 CONTINUE - I = I - 1 - IF (I.GT.1) GO TO 60 - 80 B(1) = B(1)/W(MIDDLE,1) - RETURN - END diff --git a/slatec/bqr.f b/slatec/bqr.f deleted file mode 100644 index ee76ee1..0000000 --- a/slatec/bqr.f +++ /dev/null @@ -1,306 +0,0 @@ -*DECK BQR - SUBROUTINE BQR (NM, N, MB, A, T, R, IERR, NV, RV) -C***BEGIN PROLOGUE BQR -C***PURPOSE Compute some of the eigenvalues of a real symmetric -C matrix using the QR method with shifts of origin. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4A6 -C***TYPE SINGLE PRECISION (BQR-S) -C***KEYWORDS EIGENVALUES, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure BQR, -C NUM. MATH. 16, 85-92(1970) by Martin, Reinsch, and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 266-272(1971). -C -C This subroutine finds the eigenvalue of smallest (usually) -C magnitude of a REAL SYMMETRIC BAND matrix using the -C QR algorithm with shifts of origin. Consecutive calls -C can be made to find further eigenvalues. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameter, A, as declared in the calling program -C dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix A. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C MB is the (half) band width of the matrix, defined as the -C number of adjacent diagonals, including the principal -C diagonal, required to specify the non-zero portion of the -C lower triangle of the matrix. MB is an INTEGER variable. -C MB must be less than or equal to N on first call. -C -C A contains the lower triangle of the symmetric band input -C matrix stored as an N by MB array. Its lowest subdiagonal -C is stored in the last N+1-MB positions of the first column, -C its next subdiagonal in the last N+2-MB positions of the -C second column, further subdiagonals similarly, and finally -C its principal diagonal in the N positions of the last column. -C Contents of storages not part of the matrix are arbitrary. -C On a subsequent call, its output contents from the previous -C call should be passed. A is a two-dimensional REAL array, -C dimensioned A(NM,MB). -C -C T specifies the shift (of eigenvalues) applied to the diagonal -C of A in forming the input matrix. What is actually determined -C is the eigenvalue of A+TI (I is the identity matrix) nearest -C to T. On a subsequent call, the output value of T from the -C previous call should be passed if the next nearest eigenvalue -C is sought. T is a REAL variable. -C -C R should be specified as zero on the first call, and as its -C output value from the previous call on a subsequent call. -C It is used to determine when the last row and column of -C the transformed band matrix can be regarded as negligible. -C R is a REAL variable. -C -C NV must be set to the dimension of the array parameter RV -C as declared in the calling program dimension statement. -C NV is an INTEGER variable. -C -C On OUTPUT -C -C A contains the transformed band matrix. The matrix A+TI -C derived from the output parameters is similar to the -C input A+TI to within rounding errors. Its last row and -C column are null (if IERR is zero). -C -C T contains the computed eigenvalue of A+TI (if IERR is zero), -C where I is the identity matrix. -C -C R contains the maximum of its input value and the norm of the -C last column of the input matrix A. -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C J if the J-th eigenvalue has not been -C determined after a total of 30 iterations. -C -C RV is a one-dimensional REAL array of dimension NV which is -C at least (2*MB**2+4*MB-3), used for temporary storage. The -C first (3*MB-2) locations correspond to the ALGOL array B, -C the next (2*MB-1) locations correspond to the ALGOL array H, -C and the final (2*MB**2-MB) locations correspond to the MB -C by (2*MB-1) ALGOL array U. -C -C NOTE. For a subsequent call, N should be replaced by N-1, but -C MB should not be altered even when it exceeds the current N. -C -C Calls PYTHAG(A,B) for SQRT(A**2 + B**2). -C -C Questions and comments should be directed to B. S. Garbow, -C Applied Mathematics Division, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED PYTHAG -C***REVISION HISTORY (YYMMDD) -C 760101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE BQR -C - INTEGER I,J,K,L,M,N,II,IK,JK,JM,KJ,KK,KM,LL,MB,MK,MN,MZ - INTEGER M1,M2,M3,M4,NI,NM,NV,ITS,KJ1,M21,M31,IERR,IMULT - REAL A(NM,*),RV(*) - REAL F,G,Q,R,S,T,SCALE - REAL PYTHAG -C -C***FIRST EXECUTABLE STATEMENT BQR - IERR = 0 - M1 = MIN(MB,N) - M = M1 - 1 - M2 = M + M - M21 = M2 + 1 - M3 = M21 + M - M31 = M3 + 1 - M4 = M31 + M2 - MN = M + N - MZ = MB - M1 - ITS = 0 -C .......... TEST FOR CONVERGENCE .......... - 40 G = A(N,MB) - IF (M .EQ. 0) GO TO 360 - F = 0.0E0 -C - DO 50 K = 1, M - MK = K + MZ - F = F + ABS(A(N,MK)) - 50 CONTINUE -C - IF (ITS .EQ. 0 .AND. F .GT. R) R = F - IF (R + F .LE. R) GO TO 360 - IF (ITS .EQ. 30) GO TO 1000 - ITS = ITS + 1 -C .......... FORM SHIFT FROM BOTTOM 2 BY 2 MINOR .......... - IF (F .GT. 0.25E0 * R .AND. ITS .LT. 5) GO TO 90 - F = A(N,MB-1) - IF (F .EQ. 0.0E0) GO TO 70 - Q = (A(N-1,MB) - G) / (2.0E0 * F) - S = PYTHAG(Q,1.0E0) - G = G - F / (Q + SIGN(S,Q)) - 70 T = T + G -C - DO 80 I = 1, N - 80 A(I,MB) = A(I,MB) - G -C - 90 DO 100 K = M31, M4 - 100 RV(K) = 0.0E0 -C - DO 350 II = 1, MN - I = II - M - NI = N - II - IF (NI .LT. 0) GO TO 230 -C .......... FORM COLUMN OF SHIFTED MATRIX A-G*I .......... - L = MAX(1,2-I) -C - DO 110 K = 1, M3 - 110 RV(K) = 0.0E0 -C - DO 120 K = L, M1 - KM = K + M - MK = K + MZ - RV(KM) = A(II,MK) - 120 CONTINUE -C - LL = MIN(M,NI) - IF (LL .EQ. 0) GO TO 135 -C - DO 130 K = 1, LL - KM = K + M21 - IK = II + K - MK = MB - K - RV(KM) = A(IK,MK) - 130 CONTINUE -C .......... PRE-MULTIPLY WITH HOUSEHOLDER REFLECTIONS .......... - 135 LL = M2 - IMULT = 0 -C .......... MULTIPLICATION PROCEDURE .......... - 140 KJ = M4 - M1 -C - DO 170 J = 1, LL - KJ = KJ + M1 - JM = J + M3 - IF (RV(JM) .EQ. 0.0E0) GO TO 170 - F = 0.0E0 -C - DO 150 K = 1, M1 - KJ = KJ + 1 - JK = J + K - 1 - F = F + RV(KJ) * RV(JK) - 150 CONTINUE -C - F = F / RV(JM) - KJ = KJ - M1 -C - DO 160 K = 1, M1 - KJ = KJ + 1 - JK = J + K - 1 - RV(JK) = RV(JK) - RV(KJ) * F - 160 CONTINUE -C - KJ = KJ - M1 - 170 CONTINUE -C - IF (IMULT .NE. 0) GO TO 280 -C .......... HOUSEHOLDER REFLECTION .......... - F = RV(M21) - S = 0.0E0 - RV(M4) = 0.0E0 - SCALE = 0.0E0 -C - DO 180 K = M21, M3 - 180 SCALE = SCALE + ABS(RV(K)) -C - IF (SCALE .EQ. 0.0E0) GO TO 210 -C - DO 190 K = M21, M3 - 190 S = S + (RV(K)/SCALE)**2 -C - S = SCALE * SCALE * S - G = -SIGN(SQRT(S),F) - RV(M21) = G - RV(M4) = S - F * G - KJ = M4 + M2 * M1 + 1 - RV(KJ) = F - G -C - DO 200 K = 2, M1 - KJ = KJ + 1 - KM = K + M2 - RV(KJ) = RV(KM) - 200 CONTINUE -C .......... SAVE COLUMN OF TRIANGULAR FACTOR R .......... - 210 DO 220 K = L, M1 - KM = K + M - MK = K + MZ - A(II,MK) = RV(KM) - 220 CONTINUE -C - 230 L = MAX(1,M1+1-I) - IF (I .LE. 0) GO TO 300 -C .......... PERFORM ADDITIONAL STEPS .......... - DO 240 K = 1, M21 - 240 RV(K) = 0.0E0 -C - LL = MIN(M1,NI+M1) -C .......... GET ROW OF TRIANGULAR FACTOR R .......... - DO 250 KK = 1, LL - K = KK - 1 - KM = K + M1 - IK = I + K - MK = MB - K - RV(KM) = A(IK,MK) - 250 CONTINUE -C .......... POST-MULTIPLY WITH HOUSEHOLDER REFLECTIONS .......... - LL = M1 - IMULT = 1 - GO TO 140 -C .......... STORE COLUMN OF NEW A MATRIX .......... - 280 DO 290 K = L, M1 - MK = K + MZ - A(I,MK) = RV(K) - 290 CONTINUE -C .......... UPDATE HOUSEHOLDER REFLECTIONS .......... - 300 IF (L .GT. 1) L = L - 1 - KJ1 = M4 + L * M1 -C - DO 320 J = L, M2 - JM = J + M3 - RV(JM) = RV(JM+1) -C - DO 320 K = 1, M1 - KJ1 = KJ1 + 1 - KJ = KJ1 - M1 - RV(KJ) = RV(KJ1) - 320 CONTINUE -C - 350 CONTINUE -C - GO TO 40 -C .......... CONVERGENCE .......... - 360 T = T + G -C - DO 380 I = 1, N - 380 A(I,MB) = A(I,MB) - G -C - DO 400 K = 1, M1 - MK = K + MZ - A(N,MK) = 0.0E0 - 400 CONTINUE -C - GO TO 1001 -C .......... SET ERROR -- NO CONVERGENCE TO -C EIGENVALUE AFTER 30 ITERATIONS .......... - 1000 IERR = N - 1001 RETURN - END diff --git a/slatec/bsgq8.f b/slatec/bsgq8.f deleted file mode 100644 index 78f93d7..0000000 --- a/slatec/bsgq8.f +++ /dev/null @@ -1,193 +0,0 @@ -*DECK BSGQ8 - SUBROUTINE BSGQ8 (FUN, XT, BC, N, KK, ID, A, B, INBV, ERR, ANS, - + IERR, WORK) -C***BEGIN PROLOGUE BSGQ8 -C***SUBSIDIARY -C***PURPOSE Subsidiary to BFQAD -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (BSGQ8-S, DBSGQ8-D) -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C BSGQ8, a modification of GAUS8, integrates the -C product of FUN(X) by the ID-th derivative of a spline -C BVALU(XT,BC,N,KK,ID,X,INBV,WORK) between limits A and B. -C -C Description of Arguments -C -C INPUT-- -C FUN - Name of external function of one argument which -C multiplies BVALU. -C XT - Knot array for BVALU -C BC - B-coefficient array for BVALU -C N - Number of B-coefficients for BVALU -C KK - Order of the spline, KK.GE.1 -C ID - Order of the spline derivative, 0.LE.ID.LE.KK-1 -C A - Lower limit of integral -C B - Upper limit of integral (may be less than A) -C INBV- Initialization parameter for BVALU -C ERR - Is a requested pseudorelative error tolerance. Normally -C pick a value of ABS(ERR).LT.1E-3. ANS will normally -C have no more error than ABS(ERR) times the integral of -C the absolute value of FUN(X)*BVALU(XT,BC,N,KK,X,ID, -C INBV,WORK). -C -C -C OUTPUT-- -C ERR - Will be an estimate of the absolute error in ANS if the -C input value of ERR was negative. (ERR is unchanged if -C the input value of ERR was nonnegative.) The estimated -C error is solely for information to the user and should -C not be used as a correction to the computed integral. -C ANS - Computed value of integral -C IERR- A status code -C --Normal Codes -C 1 ANS most likely meets requested error tolerance, -C or A=B. -C -1 A and B are too nearly equal to allow normal -C integration. ANS is set to zero. -C --Abnormal Code -C 2 ANS probably does not meet requested error tolerance. -C WORK- Work vector of length 3*K for BVALU -C -C***SEE ALSO BFQAD -C***ROUTINES CALLED BVALU, I1MACH, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800901 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900328 Added TYPE section. (WRB) -C 910408 Updated the AUTHOR section. (WRB) -C***END PROLOGUE BSGQ8 -C - INTEGER ID, IERR, INBV, K, KK, KML, KMX, L, LMN, LMX, LR, MXL, - 1 N, NBITS, NIB, NLMN, NLMX - INTEGER I1MACH - REAL A, AA, AE, ANIB, ANS, AREA, B, BC, C, CE, EE, EF, EPS, ERR, - 1 EST,GL,GLR,GR,HH,SQ2,TOL,VL,VR,WORK,W1, W2, W3, W4, XT, X1, - 2 X2, X3, X4, X, H - REAL R1MACH, BVALU, G8, FUN - DIMENSION XT(*), BC(*) - DIMENSION AA(30), HH(30), LR(30), VL(30), GR(30) - SAVE X1, X2, X3, X4, W1, W2, W3, W4, SQ2, NLMN, KMX, KML - DATA X1, X2, X3, X4/ - 1 1.83434642495649805E-01, 5.25532409916328986E-01, - 2 7.96666477413626740E-01, 9.60289856497536232E-01/ - DATA W1, W2, W3, W4/ - 1 3.62683783378361983E-01, 3.13706645877887287E-01, - 2 2.22381034453374471E-01, 1.01228536290376259E-01/ - DATA SQ2/1.41421356E0/ - DATA NLMN/1/,KMX/5000/,KML/6/ - G8(X,H)=H*((W1*(FUN(X-X1*H)*BVALU(XT,BC,N,KK,ID,X-X1*H,INBV,WORK)+ - 1 FUN(X+X1*H)*BVALU(XT,BC,N,KK,ID,X+X1*H,INBV,WORK)) - 2 +W2*(FUN(X-X2*H)*BVALU(XT,BC,N,KK,ID,X-X2*H,INBV,WORK)+ - 3 FUN(X+X2*H)*BVALU(XT,BC,N,KK,ID,X+X2*H,INBV,WORK))) - 4 +(W3*(FUN(X-X3*H)*BVALU(XT,BC,N,KK,ID,X-X3*H,INBV,WORK)+ - 5 FUN(X+X3*H)*BVALU(XT,BC,N,KK,ID,X+X3*H,INBV,WORK)) - 6 +W4*(FUN(X-X4*H)*BVALU(XT,BC,N,KK,ID,X-X4*H,INBV,WORK)+ - 7 FUN(X+X4*H)*BVALU(XT,BC,N,KK,ID,X+X4*H,INBV,WORK)))) -C -C INITIALIZE -C -C***FIRST EXECUTABLE STATEMENT BSGQ8 - K = I1MACH(11) - ANIB = R1MACH(5)*K/0.30102000E0 - NBITS = INT(ANIB) - NLMX = (NBITS*5)/8 - ANS = 0.0E0 - IERR = 1 - CE = 0.0E0 - IF (A.EQ.B) GO TO 140 - LMX = NLMX - LMN = NLMN - IF (B.EQ.0.0E0) GO TO 10 - IF (SIGN(1.0E0,B)*A.LE.0.0E0) GO TO 10 - C = ABS(1.0E0-A/B) - IF (C.GT.0.1E0) GO TO 10 - IF (C.LE.0.0E0) GO TO 140 - ANIB = 0.5E0 - LOG(C)/0.69314718E0 - NIB = INT(ANIB) - LMX = MIN(NLMX,NBITS-NIB-7) - IF (LMX.LT.1) GO TO 130 - LMN = MIN(LMN,LMX) - 10 TOL = MAX(ABS(ERR),2.0E0**(5-NBITS))/2.0E0 - IF (ERR.EQ.0.0E0) TOL = SQRT(R1MACH(4)) - EPS = TOL - HH(1) = (B-A)/4.0E0 - AA(1) = A - LR(1) = 1 - L = 1 - EST = G8(AA(L)+2.0E0*HH(L),2.0E0*HH(L)) - K = 8 - AREA = ABS(EST) - EF = 0.5E0 - MXL = 0 -C -C COMPUTE REFINED ESTIMATES, ESTIMATE THE ERROR, ETC. -C - 20 GL = G8(AA(L)+HH(L),HH(L)) - GR(L) = G8(AA(L)+3.0E0*HH(L),HH(L)) - K = K + 16 - AREA = AREA + (ABS(GL)+ABS(GR(L))-ABS(EST)) - GLR = GL + GR(L) - EE = ABS(EST-GLR)*EF - AE = MAX(EPS*AREA,TOL*ABS(GLR)) - IF (EE-AE) 40, 40, 50 - 30 MXL = 1 - 40 CE = CE + (EST-GLR) - IF (LR(L)) 60, 60, 80 -C -C CONSIDER THE LEFT HALF OF THIS LEVEL -C - 50 IF (K.GT.KMX) LMX = KML - IF (L.GE.LMX) GO TO 30 - L = L + 1 - EPS = EPS*0.5E0 - EF = EF/SQ2 - HH(L) = HH(L-1)*0.5E0 - LR(L) = -1 - AA(L) = AA(L-1) - EST = GL - GO TO 20 -C -C PROCEED TO RIGHT HALF AT THIS LEVEL -C - 60 VL(L) = GLR - 70 EST = GR(L-1) - LR(L) = 1 - AA(L) = AA(L) + 4.0E0*HH(L) - GO TO 20 -C -C RETURN ONE LEVEL -C - 80 VR = GLR - 90 IF (L.LE.1) GO TO 120 - L = L - 1 - EPS = EPS*2.0E0 - EF = EF*SQ2 - IF (LR(L)) 100, 100, 110 - 100 VL(L) = VL(L+1) + VR - GO TO 70 - 110 VR = VL(L+1) + VR - GO TO 90 -C -C EXIT -C - 120 ANS = VR - IF ((MXL.EQ.0) .OR. (ABS(CE).LE.2.0E0*TOL*AREA)) GO TO 140 - IERR = 2 - CALL XERMSG ('SLATEC', 'BSGQ8', - + 'ANS IS PROBABLY INSUFFICIENTLY ACCURATE.', 3, 1) - GO TO 140 - 130 IERR = -1 - CALL XERMSG ('SLATEC', 'BSGQ8', - + 'A AND B ARE TOO NEARLY EQUAL TO ALLOW NORMAL INTEGRATION. ' // - + ' ANS IS SET TO ZERO AND IERR TO -1.', 1, -1) - 140 CONTINUE - IF (ERR.LT.0.0E0) ERR = CE - RETURN - END diff --git a/slatec/bskin.f b/slatec/bskin.f deleted file mode 100644 index b7ac6b5..0000000 --- a/slatec/bskin.f +++ /dev/null @@ -1,351 +0,0 @@ -*DECK BSKIN - SUBROUTINE BSKIN (X, N, KODE, M, Y, NZ, IERR) -C***BEGIN PROLOGUE BSKIN -C***PURPOSE Compute repeated integrals of the K-zero Bessel function. -C***LIBRARY SLATEC -C***CATEGORY C10F -C***TYPE SINGLE PRECISION (BSKIN-S, DBSKIN-D) -C***KEYWORDS BICKLEY FUNCTIONS, EXPONENTIAL INTEGRAL, -C INTEGRALS OF BESSEL FUNCTIONS, K-ZERO BESSEL FUNCTION -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C The following definitions are used in BSKIN: -C -C Definition 1 -C KI(0,X) = K-zero Bessel function. -C -C Definition 2 -C KI(N,X) = Bickley Function -C = integral from X to infinity of KI(N-1,t)dt -C for X .ge. 0 and N = 1,2,... -C ____________________________________________________________________ -C BSKIN computes sequences of Bickley functions (repeated integrals -C of the K0 Bessel function); i.e. for fixed X and N and K=1,..., -C BSKIN computes the M-member sequence -C -C Y(K) = KI(N+K-1,X) for KODE=1 -C or -C Y(K) = EXP(X)*KI(N+K-1,X) for KODE=2, -C -C for N.ge.0 and X.ge.0 (N and X cannot be zero simultaneously). -C -C INPUT -C X - Argument, X .ge. 0.0E0 -C N - Order of first member of the sequence N .ge. 0 -C KODE - Selection parameter -C KODE = 1 returns Y(K)= KI(N+K-1,X), K=1,M -C = 2 returns Y(K)=EXP(X)*KI(N+K-1,X), K=1,M -C M - Number of members in the sequence, M.ge.1 -C -C OUTPUT -C Y - A vector of dimension at least M containing the -C sequence selected by KODE. -C NZ - Underflow flag -C NZ = 0 means computation completed -C = M means an exponential underflow occurred on -C KODE=1. Y(K)=0.0E0, K=1,...,M is returned -C IERR - Error flag -C IERR = 0, Normal return, computation completed. -C = 1, Input error, no computation. -C = 2, Error, no computation. The -C termination condition was not met. -C -C The nominal computational accuracy is the maximum of unit -C roundoff (=R1MACH(4)) and 1.0e-18 since critical constants -C are given to only 18 digits. -C -C DBSKIN is the double precision version of BSKIN. -C -C *Long Description: -C -C Numerical recurrence on -C -C (L-1)*KI(L,X) = X(KI(L-3,X) - KI(L-1,X)) + (L-2)*KI(L-2,X) -C -C is stable where recurrence is carried forward or backward -C away from INT(X+0.5). The power series for indices 0,1 and 2 -C on 0.le.X.le. 2 starts a stable recurrence for indices -C greater than 2. If N is sufficiently large (N.gt.NLIM), the -C uniform asymptotic expansion for N to INFINITY is more -C economical. On X.gt.2 the recursion is started by evaluating -C the uniform expansion for the three members whose indices are -C closest to INT(X+0.5) within the set N,...,N+M-1. Forward -C recurrence, backward recurrence or both, complete the -C sequence depending on the relation of INT(X+0.5) to the -C indices N,...,N+M-1. -C -C***REFERENCES D. E. Amos, Uniform asymptotic expansions for -C exponential integrals E(N,X) and Bickley functions -C KI(N,X), ACM Transactions on Mathematical Software, -C 1983. -C D. E. Amos, A portable Fortran subroutine for the -C Bickley functions KI(N,X), Algorithm 609, ACM -C Transactions on Mathematical Software, 1983. -C***ROUTINES CALLED BKIAS, BKISR, EXINT, GAMRN, I1MACH, R1MACH -C***REVISION HISTORY (YYMMDD) -C 820601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891009 Removed unreferenced statement label. (WRB) -C 891009 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 BSKIN - INTEGER I, ICASE, IERR, IL, I1M, K, KK, KODE, KTRMS, M, - * M3, N, NE, NFLG, NL, NLIM, NN, NP, NS, NT, NZ - INTEGER I1MACH - REAL A, ENLIM, EXI, FN, GR, H, HN, HRTPI, SS, TOL, T1, T2, W, X, - * XLIM, XNLIM, XP, Y, YS, YSS - REAL GAMRN, R1MACH - DIMENSION EXI(102), A(50), YS(3), YSS(3), H(31), Y(*) - SAVE A, HRTPI -C----------------------------------------------------------------------- -C COEFFICIENTS IN SERIES OF EXPONENTIAL INTEGRALS -C----------------------------------------------------------------------- - DATA A(1), A(2), A(3), A(4), A(5), A(6), A(7), A(8), A(9), A(10), - * A(11), A(12), A(13), A(14), A(15), A(16), A(17), A(18), A(19), - * A(20), A(21), A(22), A(23), A(24) /1.00000000000000000E+00, - * 5.00000000000000000E-01,3.75000000000000000E-01, - * 3.12500000000000000E-01,2.73437500000000000E-01, - * 2.46093750000000000E-01,2.25585937500000000E-01, - * 2.09472656250000000E-01,1.96380615234375000E-01, - * 1.85470581054687500E-01,1.76197052001953125E-01, - * 1.68188095092773438E-01,1.61180257797241211E-01, - * 1.54981017112731934E-01,1.49445980787277222E-01, - * 1.44464448094367981E-01,1.39949934091418982E-01, - * 1.35833759559318423E-01,1.32060599571559578E-01, - * 1.28585320635465905E-01,1.25370687619579257E-01, - * 1.22385671247684513E-01,1.19604178719328047E-01, - * 1.17004087877603524E-01/ - DATA A(25), A(26), A(27), A(28), A(29), A(30), A(31), A(32), - * A(33), A(34), A(35), A(36), A(37), A(38), A(39), A(40), A(41), - * A(42), A(43), A(44), A(45), A(46), A(47), A(48) - * /1.14566502713486784E-01,1.12275172659217048E-01, - * 1.10116034723462874E-01,1.08076848895250599E-01, - * 1.06146905164978267E-01,1.04316786110409676E-01, - * 1.02578173008569515E-01,1.00923686347140974E-01, - * 9.93467537479668965E-02,9.78414999033007314E-02, - * 9.64026543164874854E-02,9.50254735405376642E-02, - * 9.37056752969190855E-02,9.24393823875012600E-02, - * 9.12230747245078224E-02,9.00535481254756708E-02, - * 8.89278787739072249E-02,8.78433924473961612E-02, - * 8.67976377754033498E-02,8.57883629175498224E-02, - * 8.48134951571231199E-02,8.38711229887106408E-02, - * 8.29594803475290034E-02,8.20769326842574183E-02/ - DATA A(49), A(50) /8.12219646354630702E-02,8.03931690779583449E-02 - * / -C----------------------------------------------------------------------- -C SQRT(PI)/2 -C----------------------------------------------------------------------- - DATA HRTPI /8.86226925452758014E-01/ -C -C***FIRST EXECUTABLE STATEMENT BSKIN - IERR = 0 - NZ=0 - IF (X.LT.0.0E0) IERR=1 - IF (N.LT.0) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (M.LT.1) IERR=1 - IF (X.EQ.0.0E0 .AND. N.EQ.0) IERR=1 - IF (IERR.NE.0) RETURN - IF (X.EQ.0.0E0) GO TO 300 - I1M = -I1MACH(12) - T1 = 2.3026E0*R1MACH(5)*I1M - XLIM = T1 - 3.228086E0 - T2 = T1 + N + M - 1 - IF (T2.GT.1000.0E0) XLIM = T1 - 0.5E0*(LOG(T2)-0.451583E0) - IF (X.GT.XLIM .AND. KODE.EQ.1) GO TO 320 - TOL = MAX(R1MACH(4),1.0E-18) - I1M = I1MACH(11) -C----------------------------------------------------------------------- -C LN(NLIM) = 0.125*LN(EPS), NLIM = 2*KTRMS+N -C----------------------------------------------------------------------- - XNLIM = 0.287823E0*(I1M-1)*R1MACH(5) - ENLIM = EXP(XNLIM) - NLIM = INT(ENLIM) + 2 - NLIM = MIN(100,NLIM) - NLIM = MAX(20,NLIM) - M3 = MIN(M,3) - NL = N + M - 1 - IF (X.GT.2.0E0) GO TO 130 - IF (N.GT.NLIM) GO TO 280 -C----------------------------------------------------------------------- -C COMPUTATION BY SERIES FOR 0.LE.X.LE.2 -C----------------------------------------------------------------------- - NFLG = 0 - NN = N - IF (NL.LE.2) GO TO 60 - M3 = 3 - NN = 0 - NFLG = 1 - 60 CONTINUE - XP = 1.0E0 - IF (KODE.EQ.2) XP = EXP(X) - DO 80 I=1,M3 - CALL BKISR(X, NN, W, IERR) - IF(IERR.NE.0) RETURN - W = W*XP - IF (NN.LT.N) GO TO 70 - KK = NN - N + 1 - Y(KK) = W - 70 CONTINUE - YS(I) = W - NN = NN + 1 - 80 CONTINUE - IF (NFLG.EQ.0) RETURN - NS = NN - XP = 1.0E0 - 90 CONTINUE -C----------------------------------------------------------------------- -C FORWARD RECURSION SCALED BY EXP(X) ON ICASE=0,1,2 -C----------------------------------------------------------------------- - FN = NS - 1 - IL = NL - NS + 1 - IF (IL.LE.0) RETURN - DO 110 I=1,IL - T1 = YS(2) - T2 = YS(3) - YS(3) = (X*(YS(1)-YS(3))+(FN-1.0E0)*YS(2))/FN - YS(2) = T2 - YS(1) = T1 - FN = FN + 1.0E0 - IF (NS.LT.N) GO TO 100 - KK = NS - N + 1 - Y(KK) = YS(3)*XP - 100 CONTINUE - NS = NS + 1 - 110 CONTINUE - RETURN -C----------------------------------------------------------------------- -C COMPUTATION BY ASYMPTOTIC EXPANSION FOR X.GT.2 -C----------------------------------------------------------------------- - 130 CONTINUE - W = X + 0.5E0 - NT = INT(W) - IF (NL.GT.NT) GO TO 270 -C----------------------------------------------------------------------- -C CASE NL.LE.NT, ICASE=0 -C----------------------------------------------------------------------- - ICASE = 0 - NN = NL - NFLG = MIN(M-M3,1) - 140 CONTINUE - KK = (NLIM-NN)/2 - KTRMS = MAX(0,KK) - NS = NN + 1 - NP = NN - M3 + 1 - XP = 1.0E0 - IF (KODE.EQ.1) XP = EXP(-X) - DO 150 I=1,M3 - KK = I - CALL BKIAS(X, NP, KTRMS, A, W, KK, NE, GR, H, IERR) - IF(IERR.NE.0) RETURN - YS(I) = W - NP = NP + 1 - 150 CONTINUE -C----------------------------------------------------------------------- -C SUM SERIES OF EXPONENTIAL INTEGRALS BACKWARD -C----------------------------------------------------------------------- - IF (KTRMS.EQ.0) GO TO 160 - NE = KTRMS + KTRMS + 1 - NP = NN - M3 + 2 - CALL EXINT(X, NP, 2, NE, TOL, EXI, NZ, IERR) - IF(NZ.NE.0) GO TO 320 - IF(IERR.EQ.2) RETURN - 160 CONTINUE - DO 190 I=1,M3 - SS = 0.0E0 - IF (KTRMS.EQ.0) GO TO 180 - KK = I + KTRMS + KTRMS - 2 - IL = KTRMS - DO 170 K=1,KTRMS - SS = SS + A(IL)*EXI(KK) - KK = KK - 2 - IL = IL - 1 - 170 CONTINUE - 180 CONTINUE - YS(I) = YS(I) + SS - 190 CONTINUE - IF (ICASE.EQ.1) GO TO 200 - IF (NFLG.NE.0) GO TO 220 - 200 CONTINUE - DO 210 I=1,M3 - Y(I) = YS(I)*XP - 210 CONTINUE - IF (ICASE.EQ.1 .AND. NFLG.EQ.1) GO TO 90 - RETURN - 220 CONTINUE -C----------------------------------------------------------------------- -C BACKWARD RECURSION SCALED BY EXP(X) ICASE=0,2 -C----------------------------------------------------------------------- - KK = NN - N + 1 - K = M3 - DO 230 I=1,M3 - Y(KK) = YS(K)*XP - YSS(I) = YS(I) - KK = KK - 1 - K = K - 1 - 230 CONTINUE - IL = KK - IF (IL.LE.0) GO TO 250 - FN = NN - 3 - DO 240 I=1,IL - T1 = YS(2) - T2 = YS(1) - YS(1) = YS(2) + ((FN+2.0E0)*YS(3)-(FN+1.0E0)*YS(1))/X - YS(2) = T2 - YS(3) = T1 - Y(KK) = YS(1)*XP - KK = KK - 1 - FN = FN - 1.0E0 - 240 CONTINUE - 250 CONTINUE - IF (ICASE.NE.2) RETURN - DO 260 I=1,M3 - YS(I) = YSS(I) - 260 CONTINUE - GO TO 90 - 270 CONTINUE - IF (N.LT.NT) GO TO 290 -C----------------------------------------------------------------------- -C ICASE=1, NT.LE.N.LE.NL WITH FORWARD RECURSION -C----------------------------------------------------------------------- - 280 CONTINUE - NN = N + M3 - 1 - NFLG = MIN(M-M3,1) - ICASE = 1 - GO TO 140 -C----------------------------------------------------------------------- -C ICASE=2, N.LT.NT.LT.NL WITH BOTH FORWARD AND BACKWARD RECURSION -C----------------------------------------------------------------------- - 290 CONTINUE - NN = NT + 1 - NFLG = MIN(M-M3,1) - ICASE = 2 - GO TO 140 -C----------------------------------------------------------------------- -C X=0 CASE -C----------------------------------------------------------------------- - 300 CONTINUE - FN = N - HN = 0.5E0*FN - GR = GAMRN(HN) - Y(1) = HRTPI*GR - IF (M.EQ.1) RETURN - Y(2) = HRTPI/(HN*GR) - IF (M.EQ.2) RETURN - DO 310 K=3,M - Y(K) = FN*Y(K-2)/(FN+1.0E0) - FN = FN + 1.0E0 - 310 CONTINUE - RETURN -C----------------------------------------------------------------------- -C UNDERFLOW ON KODE=1, X.GT.XLIM -C----------------------------------------------------------------------- - 320 CONTINUE - NZ=M - DO 330 I=1,M - Y(I) = 0.0E0 - 330 CONTINUE - RETURN - END diff --git a/slatec/bspdoc.f b/slatec/bspdoc.f deleted file mode 100644 index 4efd247..0000000 --- a/slatec/bspdoc.f +++ /dev/null @@ -1,296 +0,0 @@ -*DECK BSPDOC - SUBROUTINE BSPDOC -C***BEGIN PROLOGUE BSPDOC -C***PURPOSE Documentation for BSPLINE, a package of subprograms for -C working with piecewise polynomial functions -C in B-representation. -C***LIBRARY SLATEC -C***CATEGORY E, E1A, K, Z -C***TYPE ALL (BSPDOC-A) -C***KEYWORDS B-SPLINE, DOCUMENTATION, SPLINES -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C BSPDOC is a non-executable, B-spline documentary routine. -C The narrative describes a B-spline and the routines -C necessary to manipulate B-splines at a fairly high level. -C The basic package described herein is that of reference -C 5 with names altered to prevent duplication and conflicts -C with routines from reference 3. The call lists used here -C are also different. Work vectors were added to ensure -C portability and proper execution in an overlay environ- -C ment. These work arrays can be used for other purposes -C except as noted in BSPVN. While most of the original -C routines in reference 5 were restricted to orders 20 -C or less, this restriction was removed from all routines -C except the quadrature routine BSQAD. (See the section -C below on differentiation and integration for details.) -C -C The subroutines referenced below are single precision -C routines. Corresponding double precision versions are also -C part of the package, and these are referenced by prefixing -C a D in front of the single precision name. For example, -C BVALU and DBVALU are the single and double precision -C versions for evaluating a B-spline or any of its deriva- -C tives in the B-representation. -C -C ****Description of B-Splines**** -C -C A collection of polynomials of fixed degree K-1 defined on a -C subdivision (X(I),X(I+1)), I=1,...,M-1 of (A,B) with X(1)=A, -C X(M)=B is called a B-spline of order K. If the spline has K-2 -C continuous derivatives on (A,B), then the B-spline is simply -C called a spline of order K. Each of the M-1 polynomial pieces -C has K coefficients, making a total of K(M-1) parameters. This -C B-spline and its derivatives have M-2 jumps at the subdivision -C points X(I), I=2,...,M-1. Continuity requirements at these -C subdivision points add constraints and reduce the number of free -C parameters. If a B-spline is continuous at each of the M-2 sub- -C division points, there are K(M-1)-(M-2) free parameters; if in -C addition the B-spline has continuous first derivatives, there -C are K(M-1)-2(M-2) free parameters, etc., until we get to a -C spline where we have K(M-1)-(K-1)(M-2) = M+K-2 free parameters. -C Thus, the principle is that increasing the continuity of -C derivatives decreases the number of free parameters and -C conversely. -C -C The points at which the polynomials are tied together by the -C continuity conditions are called knots. If two knots are -C allowed to come together at some X(I), then we say that we -C have a knot of multiplicity 2 there, and the knot values are -C the X(I) value. If we reverse the procedure of the first -C paragraph, we find that adding a knot to increase multiplicity -C increases the number of free parameters and, according to the -C principle above, we thereby introduce a discontinuity in what -C was the highest continuous derivative at that knot. Thus, the -C number of free parameters is N = NU+K-2 where NU is the sum -C of multiplicities at the X(I) values with X(1) and X(M) of -C multiplicity 1 (NU = M if all knots are simple, i.e., for a -C spline, all knots have multiplicity 1.) Each knot can have a -C multiplicity of at most K. A B-spline is commonly written in the -C B-representation -C -C Y(X) = sum( A(I)*B(I,X), I=1 , N) -C -C to show the explicit dependence of the spline on the free -C parameters or coefficients A(I)=BCOEF(I) and basis functions -C B(I,X). These basis functions are themselves special B-splines -C which are zero except on (at most) K adjoining intervals where -C each B(I,X) is positive and, in most cases, hat or bell- -C shaped. In order for the nonzero part of B(1,X) to be a spline -C covering (X(1),X(2)), it is necessary to put K-1 knots to the -C left of A and similarly for B(N,X) to the right of B. Thus, the -C total number of knots for this representation is NU+2K-2 = N+K. -C These knots are carried in an array T(*) dimensioned by at least -C N+K. From the construction, A=T(K) and B=T(N+1) and the spline is -C defined on T(K).LE.X.LE.T(N+1). The nonzero part of each basis -C function lies in the Interval (T(I),T(I+K)). In many problems -C where extrapolation beyond A or B is not anticipated, it is common -C practice to set T(1)=T(2)=...=T(K)=A and T(N+1)=T(N+2)=...= -C T(N+K)=B. In summary, since T(K) and T(N+1) as well as -C interior knots can have multiplicity K, the number of free -C parameters N = sum of multiplicities - K. The fact that each -C B(I,X) function is nonzero over at most K intervals means that -C for a given X value, there are at most K nonzero terms of the -C sum. This leads to banded matrices in linear algebra problems, -C and references 3 and 6 take advantage of this in con- -C structing higher level routines to achieve speed and avoid -C ill-conditioning. -C -C ****Basic Routines**** -C -C The basic routines which most casual users will need are those -C concerned with direct evaluation of splines or B-splines. -C Since the B-representation, denoted by (T,BCOEF,N,K), is -C preferred because of numerical stability, the knots T(*), the -C B-spline coefficients BCOEF(*), the number of coefficients N, -C and the order K of the polynomial pieces (of degree K-1) are -C usually given. While the knot array runs from T(1) to T(N+K), -C the B-spline is normally defined on the interval T(K).LE.X.LE. -C T(N+1). To evaluate the B-spline or any of its derivatives -C on this interval, one can use -C -C Y = BVALU(T,BCOEF,N,K,ID,X,INBV,WORK) -C -C where ID is an integer for the ID-th derivative, 0.LE.ID.LE.K-1. -C ID=0 gives the zero-th derivative or B-spline value at X. -C If X.LT.T(K) or X.GT.T(N+1), whether by mistake or the result -C of round off accumulation in incrementing X, BVALU gives a -C diagnostic. INBV is an initialization parameter which is set -C to 1 on the first call. Distinct splines require distinct -C INBV parameters. WORK is a scratch vector of length at least -C 3*K. -C -C When more conventional communication is needed for publication, -C physical interpretation, etc., the B-spline coefficients can -C be converted to piecewise polynomial (PP) coefficients. Thus, -C the breakpoints (distinct knots) XI(*), the number of -C polynomial pieces LXI, and the (right) derivatives C(*,J) at -C each breakpoint XI(J) are needed to define the Taylor -C expansion to the right of XI(J) on each interval XI(J).LE. -C X.LT.XI(J+1), J=1,LXI where XI(1)=A and XI(LXI+1)=B. -C These are obtained from the (T,BCOEF,N,K) representation by -C -C CALL BSPPP(T,BCOEF,N,K,LDC,C,XI,LXI,WORK) -C -C where LDC.GE.K is the leading dimension of the matrix C and -C WORK is a scratch vector of length at least K*(N+3). -C Then the PP-representation (C,XI,LXI,K) of Y(X), denoted -C by Y(J,X) on each interval XI(J).LE.X.LT.XI(J+1), is -C -C Y(J,X) = sum( C(I,J)*((X-XI(J))**(I-1))/factorial(I-1), I=1,K) -C -C for J=1,...,LXI. One must view this conversion from the B- -C to the PP-representation with some skepticism because the -C conversion may lose significant digits when the B-spline -C varies in an almost discontinuous fashion. To evaluate -C the B-spline or any of its derivatives using the PP- -C representation, one uses -C -C Y = PPVAL(LDC,C,XI,LXI,K,ID,X,INPPV) -C -C where ID and INPPV have the same meaning and usage as ID and -C INBV in BVALU. -C -C To determine to what extent the conversion process loses -C digits, compute the relative error ABS((Y1-Y2)/Y2) over -C the X interval with Y1 from PPVAL and Y2 from BVALU. A -C major reason for considering PPVAL is that evaluation is -C much faster than that from BVALU. -C -C Recall that when multiple knots are encountered, jump type -C discontinuities in the B-spline or its derivatives occur -C at these knots, and we need to know that BVALU and PPVAL -C return right limiting values at these knots except at -C X=B where left limiting values are returned. These values -C are used for the Taylor expansions about left end points of -C breakpoint intervals. That is, the derivatives C(*,J) are -C right derivatives. Note also that a computed X value which, -C mathematically, would be a knot value may differ from the knot -C by a round off error. When this happens in evaluating a dis- -C continuous B-spline or some discontinuous derivative, the -C value at the knot and the value at X can be radically -C different. In this case, setting X to a T or XI value makes -C the computation precise. For left limiting values at knots -C other than X=B, see the prologues to BVALU and other -C routines. -C -C ****Interpolation**** -C -C BINTK is used to generate B-spline parameters (T,BCOEF,N,K) -C which will interpolate the data by calls to BVALU. A similar -C interpolation can also be done for cubic splines using BINT4 -C or the code in reference 7. If the PP-representation is given, -C one can evaluate this representation at an appropriate number of -C abscissas to create data then use BINTK or BINT4 to generate -C the B-representation. -C -C ****Differentiation and Integration**** -C -C Derivatives of B-splines are obtained from BVALU or PPVAL. -C Integrals are obtained from BSQAD using the B-representation -C (T,BCOEF,N,K) and PPQAD using the PP-representation (C,XI,LXI, -C K). More complicated integrals involving the product of a -C of a function F and some derivative of a B-spline can be -C evaluated with BFQAD or PFQAD using the B- or PP- represen- -C tations respectively. All quadrature routines, except for PPQAD, -C are limited in accuracy to 18 digits or working precision, -C whichever is smaller. PPQAD is limited to working precision -C only. In addition, the order K for BSQAD is limited to 20 or -C less. If orders greater than 20 are required, use BFQAD with -C F(X) = 1. -C -C ****Extrapolation**** -C -C Extrapolation outside the interval (A,B) can be accomplished -C easily by the PP-representation using PPVAL. However, -C caution should be exercised, especially when several knots -C are located at A or B or when the extrapolation is carried -C significantly beyond A or B. On the other hand, direct -C evaluation with BVALU outside A=T(K).LE.X.LE.T(N+1)=B -C produces an error message, and some manipulation of the knots -C and coefficients are needed to extrapolate with BVALU. This -C process is described in reference 6. -C -C ****Curve Fitting and Smoothing**** -C -C Unless one has many accurate data points, direct inter- -C polation is not recommended for summarizing data. The -C results are often not in accordance with intuition since the -C fitted curve tends to oscillate through the set of points. -C Monotone splines (reference 7) can help curb this undulating -C tendency but constrained least squares is more likely to give an -C acceptable fit with fewer parameters. Subroutine FC, des- -C cribed in reference 6, is recommended for this purpose. The -C output from this fitting process is the B-representation. -C -C **** Routines in the B-Spline Package **** -C -C Single Precision Routines -C -C The subroutines referenced below are SINGLE PRECISION -C routines. Corresponding DOUBLE PRECISION versions are also -C part of the package and these are referenced by prefixing -C a D in front of the single precision name. For example, -C BVALU and DBVALU are the SINGLE and DOUBLE PRECISION -C versions for evaluating a B-spline or any of its deriva- -C tives in the B-representation. -C -C BINT4 - interpolates with splines of order 4 -C BINTK - interpolates with splines of order k -C BSQAD - integrates the B-representation on subintervals -C PPQAD - integrates the PP-representation -C BFQAD - integrates the product of a function F and any spline -C derivative in the B-representation -C PFQAD - integrates the product of a function F and any spline -C derivative in the PP-representation -C BVALU - evaluates the B-representation or a derivative -C PPVAL - evaluates the PP-representation or a derivative -C INTRV - gets the largest index of the knot to the left of x -C BSPPP - converts from B- to PP-representation -C BSPVD - computes nonzero basis functions and derivatives at x -C BSPDR - sets up difference array for BSPEV -C BSPEV - evaluates the B-representation and derivatives -C BSPVN - called by BSPEV, BSPVD, BSPPP and BINTK for function and -C derivative evaluations -C Auxiliary Routines -C -C BSGQ8,PPGQ8,BNSLV,BNFAC,XERMSG,DBSGQ8,DPPGQ8,DBNSLV,DBNFAC -C -C Machine Dependent Routines -C -C I1MACH, R1MACH, D1MACH -C -C***REFERENCES 1. D. E. Amos, Computation with splines and -C B-splines, Report SAND78-1968, Sandia -C Laboratories, March 1979. -C 2. D. E. Amos, Quadrature subroutines for splines and -C B-splines, Report SAND79-1825, Sandia Laboratories, -C December 1979. -C 3. Carl de Boor, A Practical Guide to Splines, Applied -C Mathematics Series 27, Springer-Verlag, New York, -C 1978. -C 4. Carl de Boor, On calculating with B-Splines, Journal -C of Approximation Theory 6, (1972), pp. 50-62. -C 5. Carl de Boor, Package for calculating with B-splines, -C SIAM Journal on Numerical Analysis 14, 3 (June 1977), -C pp. 441-472. -C 6. R. J. Hanson, Constrained least squares curve fitting -C to discrete data using B-splines, a users guide, -C Report SAND78-1291, Sandia Laboratories, December -C 1978. -C 7. F. N. Fritsch and R. E. Carlson, Monotone piecewise -C cubic interpolation, SIAM Journal on Numerical Ana- -C lysis 17, 2 (April 1980), pp. 238-246. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 810223 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900723 PURPOSE section revised. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE BSPDOC -C***FIRST EXECUTABLE STATEMENT BSPDOC - RETURN - END diff --git a/slatec/bspdr.f b/slatec/bspdr.f deleted file mode 100644 index cfb0f3a..0000000 --- a/slatec/bspdr.f +++ /dev/null @@ -1,106 +0,0 @@ -*DECK BSPDR - SUBROUTINE BSPDR (T, A, N, K, NDERIV, AD) -C***BEGIN PROLOGUE BSPDR -C***PURPOSE Use the B-representation to construct a divided difference -C table preparatory to a (right) derivative calculation. -C***LIBRARY SLATEC -C***CATEGORY E3 -C***TYPE SINGLE PRECISION (BSPDR-S, DBSPDR-D) -C***KEYWORDS B-SPLINE, DATA FITTING, DIFFERENTIATION OF SPLINES, -C INTERPOLATION -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Written by Carl de Boor and modified by D. E. Amos -C -C Abstract -C BSPDR is the BSPLDR routine of the reference. -C -C BSPDR uses the B-representation (T,A,N,K) to construct a -C divided difference table ADIF preparatory to a (right) -C derivative calculation in BSPEV. The lower triangular matrix -C ADIF is stored in vector AD by columns. The arrays are -C related by -C -C ADIF(I,J) = AD(I-J+1 + (2*N-J+2)*(J-1)/2) -C -C I = J,N , J = 1,NDERIV . -C -C Description of Arguments -C Input -C T - knot vector of length N+K -C A - B-spline coefficient vector of length N -C N - number of B-spline coefficients -C N = sum of knot multiplicities-K -C K - order of the spline, K .GE. 1 -C NDERIV - number of derivatives, 1 .LE. NDERIV .LE. K. -C NDERIV=1 gives the zero-th derivative = function -C value -C -C Output -C AD - table of differences in a vector of length -C (2*N-NDERIV+1)*NDERIV/2 for input to BSPEV -C -C Error Conditions -C Improper input is a fatal error -C -C***REFERENCES Carl de Boor, Package for calculating with B-splines, -C SIAM Journal on Numerical Analysis 14, 3 (June 1977), -C pp. 441-472. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 800901 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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE BSPDR -C - INTEGER I, ID, II, IPKMID, JJ, JM, K, KMID, N, NDERIV - REAL A, AD, DIFF, FKMID, T -C DIMENSION T(N+K), AD((2*N-NDERIV+1)*NDERIV/2) - DIMENSION T(*), A(*), AD(*) -C***FIRST EXECUTABLE STATEMENT BSPDR - IF(K.LT.1) GO TO 100 - IF(N.LT.K) GO TO 105 - IF(NDERIV.LT.1 .OR. NDERIV.GT.K) GO TO 110 - DO 10 I=1,N - AD(I) = A(I) - 10 CONTINUE - IF (NDERIV.EQ.1) RETURN - KMID = K - JJ = N - JM = 0 - DO 30 ID=2,NDERIV - KMID = KMID - 1 - FKMID = KMID - II = 1 - DO 20 I=ID,N - IPKMID = I + KMID - DIFF = T(IPKMID) - T(I) - IF (DIFF.NE.0.0E0) AD(II+JJ) = (AD(II+JM+1)-AD(II+JM))/ - 1 DIFF*FKMID - II = II + 1 - 20 CONTINUE - JM = JJ - JJ = JJ + N - ID + 1 - 30 CONTINUE - RETURN -C -C - 100 CONTINUE - CALL XERMSG ('SLATEC', 'BSPDR', 'K DOES NOT SATISFY K.GE.1', 2, - + 1) - RETURN - 105 CONTINUE - CALL XERMSG ('SLATEC', 'BSPDR', 'N DOES NOT SATISFY N.GE.K', 2, - + 1) - RETURN - 110 CONTINUE - CALL XERMSG ('SLATEC', 'BSPDR', - + 'NDERIV DOES NOT SATISFY 1.LE.NDERIV.LE.K', 2, 1) - RETURN - END diff --git a/slatec/bspev.f b/slatec/bspev.f deleted file mode 100644 index 6a29a5d..0000000 --- a/slatec/bspev.f +++ /dev/null @@ -1,138 +0,0 @@ -*DECK BSPEV - SUBROUTINE BSPEV (T, AD, N, K, NDERIV, X, INEV, SVALUE, WORK) -C***BEGIN PROLOGUE BSPEV -C***PURPOSE Calculate the value of the spline and its derivatives from -C the B-representation. -C***LIBRARY SLATEC -C***CATEGORY E3, K6 -C***TYPE SINGLE PRECISION (BSPEV-S, DBSPEV-D) -C***KEYWORDS B-SPLINE, DATA FITTING, INTERPOLATION, SPLINES -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Written by Carl de Boor and modified by D. E. Amos -C -C Abstract -C BSPEV is the BSPLEV routine of the reference. -C -C BSPEV calculates the value of the spline and its derivatives -C at X from the B-representation (T,A,N,K) and returns them -C in SVALUE(I),I=1,NDERIV, T(K) .LE. X .LE. T(N+1). AD(I) can -C be the B-spline coefficients A(I), I=1,N if NDERIV=1. Other- -C wise AD must be computed before hand by a call to BSPDR (T,A, -C N,K,NDERIV,AD). If X=T(I),I=K,N, right limiting values are -C obtained. -C -C To compute left derivatives or left limiting values at a -C knot T(I), replace N by I-1 and set X=T(I), I=K+1,N+1. -C -C BSPEV calls INTRV, BSPVN -C -C Description of Arguments -C Input -C T - knot vector of length N+K -C AD - vector of length (2*N-NDERIV+1)*NDERIV/2 containing -C the difference table from BSPDR. -C N - number of B-spline coefficients -C N = sum of knot multiplicities-K -C K - order of the B-spline, K .GE. 1 -C NDERIV - number of derivatives, 1 .LE. NDERIV .LE. K. -C NDERIV=1 gives the zero-th derivative = function -C value -C X - argument, T(K) .LE. X .LE. T(N+1) -C INEV - an initialization parameter which must be set -C to 1 the first time BSPEV is called. -C -C Output -C INEV - INEV contains information for efficient process- -C ing after the initial call and INEV must not -C be changed by the user. Distinct splines require -C distinct INEV parameters. -C SVALUE - vector of length NDERIV containing the spline -C value in SVALUE(1) and the NDERIV-1 derivatives -C in the remaining components. -C WORK - work vector of length 3*K -C -C Error Conditions -C Improper input is a fatal error. -C -C***REFERENCES Carl de Boor, Package for calculating with B-splines, -C SIAM Journal on Numerical Analysis 14, 3 (June 1977), -C pp. 441-472. -C***ROUTINES CALLED BSPVN, INTRV, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800901 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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE BSPEV -C - INTEGER I,ID,INEV,IWORK,JJ,K,KP1,KP1MN,L,LEFT,LL,MFLAG, - 1 N, NDERIV - REAL AD, SVALUE, SUM, T, WORK, X -C DIMENSION T(N+K) - DIMENSION T(*), AD(*), SVALUE(*), WORK(*) -C***FIRST EXECUTABLE STATEMENT BSPEV - IF(K.LT.1) GO TO 100 - IF(N.LT.K) GO TO 105 - IF(NDERIV.LT.1 .OR. NDERIV.GT.K) GO TO 115 - ID = NDERIV - CALL INTRV(T, N+1, X, INEV, I, MFLAG) - IF (X.LT.T(K)) GO TO 110 - IF (MFLAG.EQ.0) GO TO 30 - IF (X.GT.T(I)) GO TO 110 - 20 IF (I.EQ.K) GO TO 120 - I = I - 1 - IF (X.EQ.T(I)) GO TO 20 -C -C *I* HAS BEEN FOUND IN (K,N) SO THAT T(I) .LE. X .LT. T(I+1) -C (OR .LE. T(I+1), IF T(I) .LT. T(I+1) = T(N+1) ). - 30 KP1MN = K + 1 - ID - KP1 = K + 1 - CALL BSPVN(T, KP1MN, K, 1, X, I, WORK(1),WORK(KP1),IWORK) - JJ = (N+N-ID+2)*(ID-1)/2 -C ADIF(LEFTPL,ID) = AD(LEFTPL-ID+1 + (2*N-ID+2)*(ID-1)/2) -C LEFTPL = LEFT + L - 40 LEFT = I - KP1MN - SUM = 0.0E0 - LL = LEFT + JJ + 2 - ID - DO 50 L=1,KP1MN - SUM = SUM + WORK(L)*AD(LL) - LL = LL + 1 - 50 CONTINUE - SVALUE(ID) = SUM - ID = ID - 1 - IF (ID.EQ.0) GO TO 60 - JJ = JJ-(N-ID+1) - KP1MN = KP1MN + 1 - CALL BSPVN(T, KP1MN, K, 2, X, I, WORK(1), WORK(KP1),IWORK) - GO TO 40 -C - 60 RETURN -C -C - 100 CONTINUE - CALL XERMSG ('SLATEC', 'BSPEV', 'K DOES NOT SATISFY K.GE.1', 2, - + 1) - RETURN - 105 CONTINUE - CALL XERMSG ('SLATEC', 'BSPEV', 'N DOES NOT SATISFY N.GE.K', 2, - + 1) - RETURN - 110 CONTINUE - CALL XERMSG ('SLATEC', 'BSPEV', 'X IS NOT IN T(K).LE.X.LE.T(N+1)' - + , 2, 1) - RETURN - 115 CONTINUE - CALL XERMSG ('SLATEC', 'BSPEV', - + 'NDERIV DOES NOT SATISFY 1.LE.NDERIV.LE.K', 2, 1) - RETURN - 120 CONTINUE - CALL XERMSG ('SLATEC', 'BSPEV', - + 'A LEFT LIMITING VALUE CANNOT BE OBTAINED AT T(K)', 2, 1) - RETURN - END diff --git a/slatec/bsplvd.f b/slatec/bsplvd.f deleted file mode 100644 index 2464244..0000000 --- a/slatec/bsplvd.f +++ /dev/null @@ -1,70 +0,0 @@ -*DECK BSPLVD - SUBROUTINE BSPLVD (T, K, X, ILEFT, VNIKX, NDERIV) -C***BEGIN PROLOGUE BSPLVD -C***SUBSIDIARY -C***PURPOSE Subsidiary to FC -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (BSPLVD-S, DFSPVD-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Calculates value and deriv.s of all B-splines which do not vanish at X -C -C Fill VNIKX(J,IDERIV), J=IDERIV, ... ,K with nonzero values of -C B-splines of order K+1-IDERIV , IDERIV=NDERIV, ... ,1, by repeated -C calls to BSPLVN -C -C***SEE ALSO FC -C***ROUTINES CALLED BSPLVN -C***REVISION HISTORY (YYMMDD) -C 780801 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE BSPLVD - DIMENSION T(*),VNIKX(K,*) - DIMENSION A(20,20) -C***FIRST EXECUTABLE STATEMENT BSPLVD - CALL BSPLVN(T,K+1-NDERIV,1,X,ILEFT,VNIKX(NDERIV,NDERIV)) - IF (NDERIV .LE. 1) GO TO 99 - IDERIV = NDERIV - DO 15 I=2,NDERIV - IDERVM = IDERIV-1 - DO 11 J=IDERIV,K - 11 VNIKX(J-1,IDERVM) = VNIKX(J,IDERIV) - IDERIV = IDERVM - CALL BSPLVN(T,0,2,X,ILEFT,VNIKX(IDERIV,IDERIV)) - 15 CONTINUE -C - DO 20 I=1,K - DO 19 J=1,K - 19 A(I,J) = 0. - 20 A(I,I) = 1. - KMD = K - DO 40 M=2,NDERIV - KMD = KMD-1 - FKMD = KMD - I = ILEFT - J = K - 21 JM1 = J-1 - IPKMD = I + KMD - DIFF = T(IPKMD) - T(I) - IF (JM1 .EQ. 0) GO TO 26 - IF (DIFF .EQ. 0.) GO TO 25 - DO 24 L=1,J - 24 A(L,J) = (A(L,J) - A(L,J-1))/DIFF*FKMD - 25 J = JM1 - I = I - 1 - GO TO 21 - 26 IF (DIFF .EQ. 0.) GO TO 30 - A(1,1) = A(1,1)/DIFF*FKMD -C - 30 DO 40 I=1,K - V = 0. - JLOW = MAX(I,M) - DO 35 J=JLOW,K - 35 V = A(I,J)*VNIKX(J,M) + V - 40 VNIKX(I,M) = V - 99 RETURN - END diff --git a/slatec/bsplvn.f b/slatec/bsplvn.f deleted file mode 100644 index 3854a73..0000000 --- a/slatec/bsplvn.f +++ /dev/null @@ -1,47 +0,0 @@ -*DECK BSPLVN - SUBROUTINE BSPLVN (T, JHIGH, INDEX, X, ILEFT, VNIKX) -C***BEGIN PROLOGUE BSPLVN -C***SUBSIDIARY -C***PURPOSE Subsidiary to FC -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (BSPLVN-S, DFSPVN-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Calculates the value of all possibly nonzero B-splines at *X* of -C order MAX(JHIGH,(J+1)(INDEX-1)) on *T*. -C -C***SEE ALSO FC -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 780801 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE BSPLVN - DIMENSION T(*),VNIKX(*) - DIMENSION DELTAM(20),DELTAP(20) - SAVE J, DELTAM, DELTAP - DATA J/1/,(DELTAM(I),I=1,20),(DELTAP(I),I=1,20)/40*0./ -C***FIRST EXECUTABLE STATEMENT BSPLVN - GO TO (10,20),INDEX - 10 J = 1 - VNIKX(1) = 1. - IF (J .GE. JHIGH) GO TO 99 -C - 20 IPJ = ILEFT+J - DELTAP(J) = T(IPJ) - X - IMJP1 = ILEFT-J+1 - DELTAM(J) = X - T(IMJP1) - VMPREV = 0. - JP1 = J+1 - DO 26 L=1,J - JP1ML = JP1-L - VM = VNIKX(L)/(DELTAP(L) + DELTAM(JP1ML)) - VNIKX(L) = VM*DELTAP(L) + VMPREV - 26 VMPREV = VM*DELTAM(JP1ML) - VNIKX(JP1) = VMPREV - J = JP1 - IF (J .LT. JHIGH) GO TO 20 -C - 99 RETURN - END diff --git a/slatec/bsppp.f b/slatec/bsppp.f deleted file mode 100644 index 8d0bc14..0000000 --- a/slatec/bsppp.f +++ /dev/null @@ -1,95 +0,0 @@ -*DECK BSPPP - SUBROUTINE BSPPP (T, A, N, K, LDC, C, XI, LXI, WORK) -C***BEGIN PROLOGUE BSPPP -C***PURPOSE Convert the B-representation of a B-spline to the piecewise -C polynomial (PP) form. -C***LIBRARY SLATEC -C***CATEGORY E3, K6 -C***TYPE SINGLE PRECISION (BSPPP-S, DBSPPP-D) -C***KEYWORDS B-SPLINE, PIECEWISE POLYNOMIAL -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Written by Carl de Boor and modified by D. E. Amos -C -C Abstract -C BSPPP is the BSPLPP routine of the reference. -C -C BSPPP converts the B-representation (T,A,N,K) to the -C piecewise polynomial (PP) form (C,XI,LXI,K) for use with -C PPVAL. Here XI(*), the break point array of length LXI, is -C the knot array T(*) with multiplicities removed. The columns -C of the matrix C(I,J) contain the right Taylor derivatives -C for the polynomial expansion about XI(J) for the intervals -C XI(J) .LE. X .LE. XI(J+1), I=1,K, J=1,LXI. Function PPVAL -C makes this evaluation at a specified point X in -C XI(1) .LE. X .LE. XI(LXI(1) .LE. X .LE. XI+1) -C -C Description of Arguments -C Input -C T - knot vector of length N+K -C A - B-spline coefficient vector of length N -C N - number of B-spline coefficients -C N = sum of knot multiplicities-K -C K - order of the B-spline, K .GE. 1 -C LDC - leading dimension of C, LDC .GE. K -C -C Output -C C - matrix of dimension at least (K,LXI) containing -C right derivatives at break points -C XI - XI break point vector of length LXI+1 -C LXI - number of break points, LXI .LE. N-K+1 -C WORK - work vector of length K*(N+3) -C -C Error Conditions -C Improper input is a fatal error -C -C***REFERENCES Carl de Boor, Package for calculating with B-splines, -C SIAM Journal on Numerical Analysis 14, 3 (June 1977), -C pp. 441-472. -C***ROUTINES CALLED BSPDR, BSPEV, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800901 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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE BSPPP -C - INTEGER ILEFT, INEV, K, LDC, LXI, N, NK - REAL A, C, T, WORK, XI -C DIMENSION T(N+K),XI(LXI+1),C(LDC,*) -C HERE, * = THE FINAL VALUE OF THE OUTPUT PARAMETER LXI. - DIMENSION T(*), A(*), WORK(*), XI(*), C(LDC,*) -C***FIRST EXECUTABLE STATEMENT BSPPP - IF(K.LT.1) GO TO 100 - IF(N.LT.K) GO TO 105 - IF(LDC.LT.K) GO TO 110 - CALL BSPDR(T, A, N, K, K, WORK) - LXI = 0 - XI(1) = T(K) - INEV = 1 - NK = N*K + 1 - DO 10 ILEFT=K,N - IF (T(ILEFT+1).EQ.T(ILEFT)) GO TO 10 - LXI = LXI + 1 - XI(LXI+1) = T(ILEFT+1) - CALL BSPEV(T,WORK(1),N,K, K,XI(LXI),INEV,C(1,LXI),WORK(NK)) - 10 CONTINUE - RETURN - 100 CONTINUE - CALL XERMSG ('SLATEC', 'BSPPP', 'K DOES NOT SATISFY K.GE.1', 2, - + 1) - RETURN - 105 CONTINUE - CALL XERMSG ('SLATEC', 'BSPPP', 'N DOES NOT SATISFY N.GE.K', 2, - + 1) - RETURN - 110 CONTINUE - CALL XERMSG ('SLATEC', 'BSPPP', 'LDC DOES NOT SATISFY LDC.GE.K', - + 2, 1) - RETURN - END diff --git a/slatec/bspvd.f b/slatec/bspvd.f deleted file mode 100644 index 26d68ce..0000000 --- a/slatec/bspvd.f +++ /dev/null @@ -1,163 +0,0 @@ -*DECK BSPVD - SUBROUTINE BSPVD (T, K, NDERIV, X, ILEFT, LDVNIK, VNIKX, WORK) -C***BEGIN PROLOGUE BSPVD -C***PURPOSE Calculate the value and all derivatives of order less than -C NDERIV of all basis functions which do not vanish at X. -C***LIBRARY SLATEC -C***CATEGORY E3, K6 -C***TYPE SINGLE PRECISION (BSPVD-S, DBSPVD-D) -C***KEYWORDS DIFFERENTIATION OF B-SPLINE, EVALUATION OF B-SPLINE -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Written by Carl de Boor and modified by D. E. Amos -C -C Abstract -C BSPVD is the BSPLVD routine of the reference. -C -C BSPVD calculates the value and all derivatives of order -C less than NDERIV of all basis functions which do not -C (possibly) vanish at X. ILEFT is input such that -C T(ILEFT) .LE. X .LT. T(ILEFT+1). A call to INTRV(T,N+1,X, -C ILO,ILEFT,MFLAG) will produce the proper ILEFT. The output of -C BSPVD is a matrix VNIKX(I,J) of dimension at least (K,NDERIV) -C whose columns contain the K nonzero basis functions and -C their NDERIV-1 right derivatives at X, I=1,K, J=1,NDERIV. -C These basis functions have indices ILEFT-K+I, I=1,K, -C K .LE. ILEFT .LE. N. The nonzero part of the I-th basis -C function lies in (T(I),T(I+K)), I=1,N. -C -C If X=T(ILEFT+1) then VNIKX contains left limiting values -C (left derivatives) at T(ILEFT+1). In particular, ILEFT = N -C produces left limiting values at the right end point -C X=T(N+1). To obtain left limiting values at T(I), I=K+1,N+1, -C set X= next lower distinct knot, call INTRV to get ILEFT, -C set X=T(I), and then call BSPVD. -C -C Description of Arguments -C Input -C T - knot vector of length N+K, where -C N = number of B-spline basis functions -C N = sum of knot multiplicities-K -C K - order of the B-spline, K .GE. 1 -C NDERIV - number of derivatives = NDERIV-1, -C 1 .LE. NDERIV .LE. K -C X - argument of basis functions, -C T(K) .LE. X .LE. T(N+1) -C ILEFT - largest integer such that -C T(ILEFT) .LE. X .LT. T(ILEFT+1) -C LDVNIK - leading dimension of matrix VNIKX -C -C Output -C VNIKX - matrix of dimension at least (K,NDERIV) contain- -C ing the nonzero basis functions at X and their -C derivatives columnwise. -C WORK - a work vector of length (K+1)*(K+2)/2 -C -C Error Conditions -C Improper input is a fatal error -C -C***REFERENCES Carl de Boor, Package for calculating with B-splines, -C SIAM Journal on Numerical Analysis 14, 3 (June 1977), -C pp. 441-472. -C***ROUTINES CALLED BSPVN, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800901 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE BSPVD -C - INTEGER I,IDERIV,ILEFT,IPKMD,J,JJ,JLOW,JM,JP1MID,K,KMD, KP1, L, - 1 LDUMMY, M, MHIGH, NDERIV - REAL FACTOR, FKMD, T, V, VNIKX, WORK, X -C DIMENSION T(ILEFT+K), WORK((K+1)*(K+2)/2) -C A(I,J) = WORK(I+J*(J+1)/2), I=1,J+1 J=1,K-1 -C A(I,K) = W0RK(I+K*(K-1)/2) I=1.K -C WORK(1) AND WORK((K+1)*(K+2)/2) ARE NOT USED. - DIMENSION T(*), VNIKX(LDVNIK,*), WORK(*) -C***FIRST EXECUTABLE STATEMENT BSPVD - IF(K.LT.1) GO TO 200 - IF(NDERIV.LT.1 .OR. NDERIV.GT.K) GO TO 205 - IF(LDVNIK.LT.K) GO TO 210 - IDERIV = NDERIV - KP1 = K + 1 - JJ = KP1 - IDERIV - CALL BSPVN(T, JJ, K, 1, X, ILEFT, VNIKX, WORK, IWORK) - IF (IDERIV.EQ.1) GO TO 100 - MHIGH = IDERIV - DO 20 M=2,MHIGH - JP1MID = 1 - DO 10 J=IDERIV,K - VNIKX(J,IDERIV) = VNIKX(JP1MID,1) - JP1MID = JP1MID + 1 - 10 CONTINUE - IDERIV = IDERIV - 1 - JJ = KP1 - IDERIV - CALL BSPVN(T, JJ, K, 2, X, ILEFT, VNIKX, WORK, IWORK) - 20 CONTINUE -C - JM = KP1*(KP1+1)/2 - DO 30 L = 1,JM - WORK(L) = 0.0E0 - 30 CONTINUE -C A(I,I) = WORK(I*(I+3)/2) = 1.0 I = 1,K - L = 2 - J = 0 - DO 40 I = 1,K - J = J + L - WORK(J) = 1.0E0 - L = L + 1 - 40 CONTINUE - KMD = K - DO 90 M=2,MHIGH - KMD = KMD - 1 - FKMD = KMD - I = ILEFT - J = K - JJ = J*(J+1)/2 - JM = JJ - J - DO 60 LDUMMY=1,KMD - IPKMD = I + KMD - FACTOR = FKMD/(T(IPKMD)-T(I)) - DO 50 L=1,J - WORK(L+JJ) = (WORK(L+JJ)-WORK(L+JM))*FACTOR - 50 CONTINUE - I = I - 1 - J = J - 1 - JJ = JM - JM = JM - J - 60 CONTINUE -C - DO 80 I=1,K - V = 0.0E0 - JLOW = MAX(I,M) - JJ = JLOW*(JLOW+1)/2 - DO 70 J=JLOW,K - V = WORK(I+JJ)*VNIKX(J,M) + V - JJ = JJ + J + 1 - 70 CONTINUE - VNIKX(I,M) = V - 80 CONTINUE - 90 CONTINUE - 100 RETURN -C -C - 200 CONTINUE - CALL XERMSG ('SLATEC', 'BSPVD', 'K DOES NOT SATISFY K.GE.1', 2, - + 1) - RETURN - 205 CONTINUE - CALL XERMSG ('SLATEC', 'BSPVD', - + 'NDERIV DOES NOT SATISFY 1.LE.NDERIV.LE.K', 2, 1) - RETURN - 210 CONTINUE - CALL XERMSG ('SLATEC', 'BSPVD', - + 'LDVNIK DOES NOT SATISFY LDVNIK.GE.K', 2, 1) - RETURN - END diff --git a/slatec/bspvn.f b/slatec/bspvn.f deleted file mode 100644 index 95cda25..0000000 --- a/slatec/bspvn.f +++ /dev/null @@ -1,124 +0,0 @@ -*DECK BSPVN - SUBROUTINE BSPVN (T, JHIGH, K, INDEX, X, ILEFT, VNIKX, WORK, - + IWORK) -C***BEGIN PROLOGUE BSPVN -C***PURPOSE Calculate the value of all (possibly) nonzero basis -C functions at X. -C***LIBRARY SLATEC -C***CATEGORY E3, K6 -C***TYPE SINGLE PRECISION (BSPVN-S, DBSPVN-D) -C***KEYWORDS EVALUATION OF B-SPLINE -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Written by Carl de Boor and modified by D. E. Amos -C -C Abstract -C BSPVN is the BSPLVN routine of the reference. -C -C BSPVN calculates the value of all (possibly) nonzero basis -C functions at X of order MAX(JHIGH,(J+1)*(INDEX-1)), where -C T(K) .LE. X .LE. T(N+1) and J=IWORK is set inside the routine -C on the first call when INDEX=1. ILEFT is such that T(ILEFT) -C .LE. X .LT. T(ILEFT+1). A call to INTRV(T,N+1,X,ILO,ILEFT, -C MFLAG) produces the proper ILEFT. BSPVN calculates using the -C basic algorithm needed in BSPVD. If only basis functions are -C desired, setting JHIGH=K and INDEX=1 can be faster than -C calling BSPVD, but extra coding is required for derivatives -C (INDEX=2) and BSPVD is set up for this purpose. -C -C Left limiting values are set up as described in BSPVD. -C -C Description of Arguments -C Input -C T - knot vector of length N+K, where -C N = number of B-spline basis functions -C N = sum of knot multiplicities-K -C JHIGH - order of B-spline, 1 .LE. JHIGH .LE. K -C K - highest possible order -C INDEX - INDEX = 1 gives basis functions of order JHIGH -C = 2 denotes previous entry with WORK, IWORK -C values saved for subsequent calls to -C BSPVN. -C X - argument of basis functions, -C T(K) .LE. X .LE. T(N+1) -C ILEFT - largest integer such that -C T(ILEFT) .LE. X .LT. T(ILEFT+1) -C -C Output -C VNIKX - vector of length K for spline values. -C WORK - a work vector of length 2*K -C IWORK - a work parameter. Both WORK and IWORK contain -C information necessary to continue for INDEX = 2. -C When INDEX = 1 exclusively, these are scratch -C variables and can be used for other purposes. -C -C Error Conditions -C Improper input is a fatal error. -C -C***REFERENCES Carl de Boor, Package for calculating with B-splines, -C SIAM Journal on Numerical Analysis 14, 3 (June 1977), -C pp. 441-472. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 800901 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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE BSPVN -C - INTEGER ILEFT, IMJP1, INDEX, IPJ, IWORK, JHIGH, JP1, JP1ML, K, L - REAL T, VM, VMPREV, VNIKX, WORK, X -C DIMENSION T(ILEFT+JHIGH) - DIMENSION T(*), VNIKX(*), WORK(*) -C CONTENT OF J, DELTAM, DELTAP IS EXPECTED UNCHANGED BETWEEN CALLS. -C WORK(I) = DELTAP(I), WORK(K+I) = DELTAM(I), I = 1,K -C***FIRST EXECUTABLE STATEMENT BSPVN - IF(K.LT.1) GO TO 90 - IF(JHIGH.GT.K .OR. JHIGH.LT.1) GO TO 100 - IF(INDEX.LT.1 .OR. INDEX.GT.2) GO TO 105 - IF(X.LT.T(ILEFT) .OR. X.GT.T(ILEFT+1)) GO TO 110 - GO TO (10, 20), INDEX - 10 IWORK = 1 - VNIKX(1) = 1.0E0 - IF (IWORK.GE.JHIGH) GO TO 40 -C - 20 IPJ = ILEFT + IWORK - WORK(IWORK) = T(IPJ) - X - IMJP1 = ILEFT - IWORK + 1 - WORK(K+IWORK) = X - T(IMJP1) - VMPREV = 0.0E0 - JP1 = IWORK + 1 - DO 30 L=1,IWORK - JP1ML = JP1 - L - VM = VNIKX(L)/(WORK(L)+WORK(K+JP1ML)) - VNIKX(L) = VM*WORK(L) + VMPREV - VMPREV = VM*WORK(K+JP1ML) - 30 CONTINUE - VNIKX(JP1) = VMPREV - IWORK = JP1 - IF (IWORK.LT.JHIGH) GO TO 20 -C - 40 RETURN -C -C - 90 CONTINUE - CALL XERMSG ('SLATEC', 'BSPVN', 'K DOES NOT SATISFY K.GE.1', 2, - + 1) - RETURN - 100 CONTINUE - CALL XERMSG ('SLATEC', 'BSPVN', - + 'JHIGH DOES NOT SATISFY 1.LE.JHIGH.LE.K', 2, 1) - RETURN - 105 CONTINUE - CALL XERMSG ('SLATEC', 'BSPVN', 'INDEX IS NOT 1 OR 2', 2, 1) - RETURN - 110 CONTINUE - CALL XERMSG ('SLATEC', 'BSPVN', - + 'X DOES NOT SATISFY T(ILEFT).LE.X.LE.T(ILEFT+1)', 2, 1) - RETURN - END diff --git a/slatec/bsqad.f b/slatec/bsqad.f deleted file mode 100644 index 9ffbe1d..0000000 --- a/slatec/bsqad.f +++ /dev/null @@ -1,144 +0,0 @@ -*DECK BSQAD - SUBROUTINE BSQAD (T, BCOEF, N, K, X1, X2, BQUAD, WORK) -C***BEGIN PROLOGUE BSQAD -C***PURPOSE Compute the integral of a K-th order B-spline using the -C B-representation. -C***LIBRARY SLATEC -C***CATEGORY H2A2A1, E3, K6 -C***TYPE SINGLE PRECISION (BSQAD-S, DBSQAD-D) -C***KEYWORDS INTEGRAL OF B-SPLINES, QUADRATURE -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C BSQAD computes the integral on (X1,X2) of a K-th order -C B-spline using the B-representation (T,BCOEF,N,K). Orders -C K as high as 20 are permitted by applying a 2, 6, or 10 -C point Gauss formula on subintervals of (X1,X2) which are -C formed by included (distinct) knots. -C -C If orders K greater than 20 are needed, use BFQAD with -C F(X) = 1. -C -C Description of Arguments -C Input -C T - knot array of length N+K -C BCOEF - B-spline coefficient array of length N -C N - length of coefficient array -C K - order of B-spline, 1 .LE. K .LE. 20 -C X1,X2 - end points of quadrature interval in -C T(K) .LE. X .LE. T(N+1) -C -C Output -C BQUAD - integral of the B-spline over (X1,X2) -C WORK - work vector of length 3*K -C -C Error Conditions -C Improper input is a fatal error -C -C***REFERENCES D. E. Amos, Quadrature subroutines for splines and -C B-splines, Report SAND79-1825, Sandia Laboratories, -C December 1979. -C***ROUTINES CALLED BVALU, INTRV, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800901 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE BSQAD -C - INTEGER I,IL1,IL2,ILO,INBV, JF,K,LEFT,M,MF,MFLAG,N, NPK, NP1 - REAL A, AA, B, BB, BCOEF, BMA, BPA, BQUAD, C1, GPTS, GWTS, GX, Q, - 1 SUM, T, TA, TB, WORK, X1, X2, Y1, Y2 - REAL BVALU - DIMENSION T(*), BCOEF(*), GPTS(9), GWTS(9), SUM(5), WORK(*) -C - SAVE GPTS, GWTS - DATA GPTS(1), GPTS(2), GPTS(3), GPTS(4), GPTS(5), GPTS(6), - 1 GPTS(7), GPTS(8), GPTS(9)/ - 2 5.77350269189625764E-01, 2.38619186083196909E-01, - 3 6.61209386466264514E-01, 9.32469514203152028E-01, - 4 1.48874338981631211E-01, 4.33395394129247191E-01, - 5 6.79409568299024406E-01, 8.65063366688984511E-01, - 6 9.73906528517171720E-01/ - DATA GWTS(1), GWTS(2), GWTS(3), GWTS(4), GWTS(5), GWTS(6), - 1 GWTS(7), GWTS(8), GWTS(9)/ - 2 1.00000000000000000E+00, 4.67913934572691047E-01, - 3 3.60761573048138608E-01, 1.71324492379170345E-01, - 4 2.95524224714752870E-01, 2.69266719309996355E-01, - 5 2.19086362515982044E-01, 1.49451349150580593E-01, - 6 6.66713443086881376E-02/ -C -C***FIRST EXECUTABLE STATEMENT BSQAD - BQUAD = 0.0E0 - IF(K.LT.1 .OR. K.GT.20) GO TO 65 - IF(N.LT.K) GO TO 70 - AA = MIN(X1,X2) - BB = MAX(X1,X2) - IF (AA.LT.T(K)) GO TO 60 - NP1 = N + 1 - IF (BB.GT.T(NP1)) GO TO 60 - IF (AA.EQ.BB) RETURN - NPK = N + K -C SELECTION OF 2, 6, OR 10 POINT GAUSS FORMULA - JF = 0 - MF = 1 - IF (K.LE.4) GO TO 10 - JF = 1 - MF = 3 - IF (K.LE.12) GO TO 10 - JF = 4 - MF = 5 - 10 CONTINUE -C - DO 20 I=1,MF - SUM(I) = 0.0E0 - 20 CONTINUE - ILO = 1 - INBV = 1 - CALL INTRV(T, NPK, AA, ILO, IL1, MFLAG) - CALL INTRV(T, NPK, BB, ILO, IL2, MFLAG) - IF (IL2.GE.NP1) IL2 = N - DO 40 LEFT=IL1,IL2 - TA = T(LEFT) - TB = T(LEFT+1) - IF (TA.EQ.TB) GO TO 40 - A = MAX(AA,TA) - B = MIN(BB,TB) - BMA = 0.5E0*(B-A) - BPA = 0.5E0*(B+A) - DO 30 M=1,MF - C1 = BMA*GPTS(JF+M) - GX = -C1 + BPA - Y2 = BVALU(T,BCOEF,N,K,0,GX,INBV,WORK) - GX = C1 + BPA - Y1 = BVALU(T,BCOEF,N,K,0,GX,INBV,WORK) - SUM(M) = SUM(M) + (Y1+Y2)*BMA - 30 CONTINUE - 40 CONTINUE - Q = 0.0E0 - DO 50 M=1,MF - Q = Q + GWTS(JF+M)*SUM(M) - 50 CONTINUE - IF (X1.GT.X2) Q = -Q - BQUAD = Q - RETURN -C -C - 60 CONTINUE - CALL XERMSG ('SLATEC', 'BSQAD', - + 'X1 OR X2 OR BOTH DO NOT SATISFY T(K).LE.X.LE.T(N+1)', 2, 1) - RETURN - 65 CONTINUE - CALL XERMSG ('SLATEC', 'BSQAD', 'K DOES NOT SATISFY 1.LE.K.LE.20' - + , 2, 1) - RETURN - 70 CONTINUE - CALL XERMSG ('SLATEC', 'BSQAD', 'N DOES NOT SATISFY N.GE.K', 2, - + 1) - RETURN - END diff --git a/slatec/bsrh.f b/slatec/bsrh.f deleted file mode 100644 index 513eb55..0000000 --- a/slatec/bsrh.f +++ /dev/null @@ -1,33 +0,0 @@ -*DECK BSRH - FUNCTION BSRH (XLL, XRR, IZ, C, A, BH, F, SGN) -C***BEGIN PROLOGUE BSRH -C***SUBSIDIARY -C***PURPOSE Subsidiary to BLKTRI -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (BCRH-S, BSRH-S) -C***AUTHOR (UNKNOWN) -C***SEE ALSO BLKTRI -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS CBLKT -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE BSRH - DIMENSION A(*) ,C(*) ,BH(*) - COMMON /CBLKT/ NPP ,K ,EPS ,CNV , - 1 NM ,NCMPLX ,IK -C***FIRST EXECUTABLE STATEMENT BSRH - XL = XLL - XR = XRR - DX = .5*ABS(XR-XL) - 101 X = .5*(XL+XR) - IF (SGN*F(X,IZ,C,A,BH)) 103,105,102 - 102 XR = X - GO TO 104 - 103 XL = X - 104 DX = .5*DX - IF (DX-CNV) 105,105,101 - 105 BSRH = .5*(XL+XR) - RETURN - END diff --git a/slatec/bvalu.f b/slatec/bvalu.f deleted file mode 100644 index c427812..0000000 --- a/slatec/bvalu.f +++ /dev/null @@ -1,165 +0,0 @@ -*DECK BVALU - FUNCTION BVALU (T, A, N, K, IDERIV, X, INBV, WORK) -C***BEGIN PROLOGUE BVALU -C***PURPOSE Evaluate the B-representation of a B-spline at X for the -C function value or any of its derivatives. -C***LIBRARY SLATEC -C***CATEGORY E3, K6 -C***TYPE SINGLE PRECISION (BVALU-S, DBVALU-D) -C***KEYWORDS DIFFERENTIATION OF B-SPLINE, EVALUATION OF B-SPLINE -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Written by Carl de Boor and modified by D. E. Amos -C -C Abstract -C BVALU is the BVALUE function of the reference. -C -C BVALU evaluates the B-representation (T,A,N,K) of a B-spline -C at X for the function value on IDERIV = 0 or any of its -C derivatives on IDERIV = 1,2,...,K-1. Right limiting values -C (right derivatives) are returned except at the right end -C point X=T(N+1) where left limiting values are computed. The -C spline is defined on T(K) .LE. X .LE. T(N+1). BVALU returns -C a fatal error message when X is outside of this interval. -C -C To compute left derivatives or left limiting values at a -C knot T(I), replace N by I-1 and set X=T(I), I=K+1,N+1. -C -C BVALU calls INTRV -C -C Description of Arguments -C Input -C T - knot vector of length N+K -C A - B-spline coefficient vector of length N -C N - number of B-spline coefficients -C N = sum of knot multiplicities-K -C K - order of the B-spline, K .GE. 1 -C IDERIV - order of the derivative, 0 .LE. IDERIV .LE. K-1 -C IDERIV=0 returns the B-spline value -C X - argument, T(K) .LE. X .LE. T(N+1) -C INBV - an initialization parameter which must be set -C to 1 the first time BVALU is called. -C -C Output -C INBV - INBV contains information for efficient process- -C ing after the initial call and INBV must not -C be changed by the user. Distinct splines require -C distinct INBV parameters. -C WORK - work vector of length 3*K. -C BVALU - value of the IDERIV-th derivative at X -C -C Error Conditions -C An improper input is a fatal error -C -C***REFERENCES Carl de Boor, Package for calculating with B-splines, -C SIAM Journal on Numerical Analysis 14, 3 (June 1977), -C pp. 441-472. -C***ROUTINES CALLED INTRV, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800901 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE BVALU -C - INTEGER I,IDERIV,IDERP1,IHI,IHMKMJ,ILO,IMK,IMKPJ, INBV, IPJ, - 1 IP1, IP1MJ, J, JJ, J1, J2, K, KMIDER, KMJ, KM1, KPK, MFLAG, N - REAL A, FKMJ, T, WORK, X -C DIMENSION T(N+K), WORK(3*K) - DIMENSION T(*), A(*), WORK(*) -C***FIRST EXECUTABLE STATEMENT BVALU - BVALU = 0.0E0 - IF(K.LT.1) GO TO 102 - IF(N.LT.K) GO TO 101 - IF(IDERIV.LT.0 .OR. IDERIV.GE.K) GO TO 110 - KMIDER = K - IDERIV -C -C *** FIND *I* IN (K,N) SUCH THAT T(I) .LE. X .LT. T(I+1) -C (OR, .LE. T(I+1) IF T(I) .LT. T(I+1) = T(N+1)). - KM1 = K - 1 - CALL INTRV(T, N+1, X, INBV, I, MFLAG) - IF (X.LT.T(K)) GO TO 120 - IF (MFLAG.EQ.0) GO TO 20 - IF (X.GT.T(I)) GO TO 130 - 10 IF (I.EQ.K) GO TO 140 - I = I - 1 - IF (X.EQ.T(I)) GO TO 10 -C -C *** DIFFERENCE THE COEFFICIENTS *IDERIV* TIMES -C WORK(I) = AJ(I), WORK(K+I) = DP(I), WORK(K+K+I) = DM(I), I=1.K -C - 20 IMK = I - K - DO 30 J=1,K - IMKPJ = IMK + J - WORK(J) = A(IMKPJ) - 30 CONTINUE - IF (IDERIV.EQ.0) GO TO 60 - DO 50 J=1,IDERIV - KMJ = K - J - FKMJ = KMJ - DO 40 JJ=1,KMJ - IHI = I + JJ - IHMKMJ = IHI - KMJ - WORK(JJ) = (WORK(JJ+1)-WORK(JJ))/(T(IHI)-T(IHMKMJ))*FKMJ - 40 CONTINUE - 50 CONTINUE -C -C *** COMPUTE VALUE AT *X* IN (T(I),(T(I+1)) OF IDERIV-TH DERIVATIVE, -C GIVEN ITS RELEVANT B-SPLINE COEFF. IN AJ(1),...,AJ(K-IDERIV). - 60 IF (IDERIV.EQ.KM1) GO TO 100 - IP1 = I + 1 - KPK = K + K - J1 = K + 1 - J2 = KPK + 1 - DO 70 J=1,KMIDER - IPJ = I + J - WORK(J1) = T(IPJ) - X - IP1MJ = IP1 - J - WORK(J2) = X - T(IP1MJ) - J1 = J1 + 1 - J2 = J2 + 1 - 70 CONTINUE - IDERP1 = IDERIV + 1 - DO 90 J=IDERP1,KM1 - KMJ = K - J - ILO = KMJ - DO 80 JJ=1,KMJ - WORK(JJ) = (WORK(JJ+1)*WORK(KPK+ILO)+WORK(JJ) - 1 *WORK(K+JJ))/(WORK(KPK+ILO)+WORK(K+JJ)) - ILO = ILO - 1 - 80 CONTINUE - 90 CONTINUE - 100 BVALU = WORK(1) - RETURN -C -C - 101 CONTINUE - CALL XERMSG ('SLATEC', 'BVALU', 'N DOES NOT SATISFY N.GE.K', 2, - + 1) - RETURN - 102 CONTINUE - CALL XERMSG ('SLATEC', 'BVALU', 'K DOES NOT SATISFY K.GE.1', 2, - + 1) - RETURN - 110 CONTINUE - CALL XERMSG ('SLATEC', 'BVALU', - + 'IDERIV DOES NOT SATISFY 0.LE.IDERIV.LT.K', 2, 1) - RETURN - 120 CONTINUE - CALL XERMSG ('SLATEC', 'BVALU', - + 'X IS N0T GREATER THAN OR EQUAL TO T(K)', 2, 1) - RETURN - 130 CONTINUE - CALL XERMSG ('SLATEC', 'BVALU', - + 'X IS NOT LESS THAN OR EQUAL TO T(N+1)', 2, 1) - RETURN - 140 CONTINUE - CALL XERMSG ('SLATEC', 'BVALU', - + 'A LEFT LIMITING VALUE CANNOT BE OBTAINED AT T(K)', 2, 1) - RETURN - END diff --git a/slatec/bvder.f b/slatec/bvder.f deleted file mode 100644 index 5204d2b..0000000 --- a/slatec/bvder.f +++ /dev/null @@ -1,102 +0,0 @@ -*DECK BVDER - SUBROUTINE BVDER (X, Y, YP, G, IPAR) -C***BEGIN PROLOGUE BVDER -C***SUBSIDIARY -C***PURPOSE Subsidiary to BVSUP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (BVDER-S, DBVDER-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C ********************************************************************** -C NFC = Number of base solution vectors -C -C NCOMP = Number of components per solution vector -C -C 1 -- Nonzero particular solution -C INHOMO = -C 2 or 3 -- Zero particular solution -C -C 0 -- Inhomogeneous vector term G(X) identically zero -C IGOFX = -C 1 -- Inhomogeneous vector term G(X) not identically zero -C -C G = Inhomogeneous vector term G(X) -C -C XSAV = Previous value of X -C -C C = Normalization factor for the particular solution -C -C 0 ( if NEQIVP = 0 ) -C IVP = -C Number of differential equations integrated due to -C the original boundary value problem ( if NEQIVP .GT. 0 ) -C -C NOFST - For problems with auxiliary initial value equations, -C NOFST communicates to the routine FMAT how to access -C the dependent variables corresponding to this initial -C value problem. For example, during any call to FMAT, -C the first dependent variable for the initial value -C problem is in position Y(NOFST + 1). -C See example in SAND77-1328. -C ********************************************************************** -C -C***SEE ALSO BVSUP -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS ML8SZ, MLIVP -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890921 Realigned order of variables in certain COMMON blocks. -C (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910701 Corrected ROUTINES CALLED section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C 920618 Minor restructuring of code. (RWC, WRB) -C***END PROLOGUE BVDER - DIMENSION Y(*),YP(*),G(*) -C -C ********************************************************************** -C - COMMON /ML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMP,NFC -C -C ********************************************************************** -C The COMMON block below is used to communicate with the user -C supplied subroutine FMAT. The user should not alter this -C COMMON block. -C - COMMON /MLIVP/ NOFST -C ********************************************************************** -C -C***FIRST EXECUTABLE STATEMENT BVDER - IF (IVP .GT. 0) CALL UIVP(X,Y(IVP+1),YP(IVP+1)) - NOFST = IVP - NA = 1 - DO 10 K=1,NFC - CALL FMAT(X,Y(NA),YP(NA)) - NOFST = NOFST - NCOMP - NA = NA + NCOMP - 10 CONTINUE -C - IF (INHOMO .NE. 1) RETURN - CALL FMAT(X,Y(NA),YP(NA)) -C - IF (IGOFX .EQ. 0) RETURN - IF (X .NE. XSAV) THEN - IF (IVP .EQ. 0) CALL GVEC(X,G) - IF (IVP .GT. 0) CALL UVEC(X,Y(IVP+1),G) - XSAV = X - ENDIF -C -C If the user has chosen not to normalize the particular -C solution, then C is defined in BVPOR to be 1.0 -C -C The following loop is just -C CALL SAXPY (NCOMP, 1.0E0/C, G, 1, YP(NA), 1) -C - DO 20 J=1,NCOMP - L = NA + J - 1 - YP(L) = YP(L) + G(J)/C - 20 CONTINUE - RETURN - END diff --git a/slatec/bvpor.f b/slatec/bvpor.f deleted file mode 100644 index f06ee8f..0000000 --- a/slatec/bvpor.f +++ /dev/null @@ -1,294 +0,0 @@ -*DECK BVPOR - SUBROUTINE BVPOR (Y, NROWY, NCOMP, XPTS, NXPTS, A, NROWA, ALPHA, - + NIC, B, NROWB, BETA, NFC, IFLAG, Z, MXNON, P, NTP, IP, W, NIV, - + YHP, U, V, COEF, S, STOWA, G, WORK, IWORK, NFCC) -C***BEGIN PROLOGUE BVPOR -C***SUBSIDIARY -C***PURPOSE Subsidiary to BVSUP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (BVPOR-S, DBVPOR-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C ********************************************************************** -C INPUT to BVPOR (items not defined in BVSUP comments) -C ********************************************************************** -C -C NOPG = 0 -- Orthonormalization points not pre-assigned -C = 1 -- Orthonormalization points pre-assigned -C -C MXNON = Maximum number of orthogonalizations allowed. -C -C NDISK = 0 -- IN-CORE storage -C = 1 -- DISK storage. Value of NTAPE in data statement -C is set to 13. If another value is desired, -C the data statement must be changed. -C -C INTEG = Type of integrator and associated test to be used -C to determine when to orthonormalize. -C -C 1 -- Use GRAM-SCHMIDT test and DERKF -C 2 -- Use GRAM-SCHMIDT test and DEABM -C -C TOL = Tolerance for allowable error in orthogonalization test. -C -C NPS = 0 Normalize particular solution to unit length at each -C point of orthonormalization. -C = 1 Do not normalize particular solution. -C -C NTP = Must be .GE. NFC*(NFC+1)/2. -C -C -C NFCC = 2*NFC for special treatment of a complex valued problem -C -C ICOCO = 0 Skip final computations (superposition coefficients -C and ,hence, boundary problem solution) -C = 1 Calculate superposition coefficients and obtain -C solution to the boundary value problem -C -C ********************************************************************** -C OUTPUT from BVPOR -C ********************************************************************** -C -C Y(NROWY,NXPTS) = Solution at specified output points. -C -C MXNON = Number of orthonormalizations performed by BVPOR. -C -C Z(MXNON+1) = Locations of orthonormalizations performed by BVPOR. -C -C NIV = Number of independent vectors returned from MGSBV. Normally -C this parameter will be meaningful only when MGSBV returns with -C MFLAG = 2. -C -C ********************************************************************** -C -C The following variables are in the argument list because of -C variable dimensioning. In general, they contain no information of -C use to the user. The amount of storage set aside by the user must -C be greater than or equal to that indicated by the dimension -C statements. For the DISK storage mode, NON = 0 and KPTS = 1, -C while for the IN-CORE storage mode, NON = MXNON and KPTS = NXPTS. -C -C P(NTP,NON+1) -C IP(NFCC,NON+1) -C YHP(NCOMP,NFC+1) plus an additional column of the length NEQIVP -C U(NCOMP,NFC,KPTS) -C V(NCOMP,KPTS) -C W(NFCC,NON+1) -C COEF(NFCC) -C S(NFC+1) -C STOWA(NCOMP*(NFC+1)+NEQIVP+1) -C G(NCOMP) -C WORK(KKKWS) -C IWORK(LLLIWS) -C -C ********************************************************************** -C Subroutines used by BVPOR -C LSSUDS -- Solves an underdetermined system of linear -C equations. This routine is used to get a full -C set of initial conditions for integration. -C Called by BVPOR -C -C SVECS -- Obtains starting vectors for special treatment -C of complex valued problems , called by BVPOR -C -C RKFAB -- Routine which conducts integration using DERKF or -C DEABM -C -C STWAY -- Storage for backup capability, called by -C BVPOR and REORT -C -C STOR1 -- Storage at output points, called by BVPOR, -C RKFAB, REORT and STWAY. -C -C SDOT -- Single precision vector inner product routine, -C called by BVPOR, SCOEF, LSSUDS, MGSBV, -C BKSOL, REORT and PRVEC. -C ** NOTE ** -C A considerable improvement in speed can be achieved if a -C machine language version is used for SDOT. -C -C SCOEF -- Computes the superposition constants from the -C boundary conditions at Xfinal. -C -C BKSOL -- Solves an upper triangular set of linear equations. -C -C ********************************************************************** -C -C***SEE ALSO BVSUP -C***ROUTINES CALLED BKSOL, LSSUDS, RKFAB, SCOEF, SDOT, STOR1, STWAY, -C SVECS -C***COMMON BLOCKS ML15TO, ML18JR, ML8SZ -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 890921 Realigned order of variables in certain COMMON blocks. -C (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE BVPOR -C - DIMENSION Y(NROWY,*),A(NROWA,*),ALPHA(*),B(NROWB,*), - 1 BETA(*),P(NTP,*),IP(NFCC,*), - 2 U(NCOMP,NFC,*),V(NCOMP,*),W(NFCC,*), - 3 COEF(*),Z(*),YHP(NCOMP,*),XPTS(*),S(*), - 4 WORK(*),IWORK(*),STOWA(*),G(*) -C -C ********************************************************************** -C - COMMON /ML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMPD,NFCD - COMMON /ML15TO/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP, - 1 KNSWOT,KOP,LOTJP,MNSWOT,NSWOT - COMMON /ML18JR/ AE,RE,TOL,NXPTSD,NICD,NOPG,MXNOND,NDISK,NTAPE, - 1 NEQ,INDPVT,INTEG,NPS,NTPD,NEQIVP,NUMORT,NFCCD, - 2 ICOCO -C -C ********************************************************************** -C -C***FIRST EXECUTABLE STATEMENT BVPOR - NFCP1 = NFC + 1 - NUMORT = 0 - C = 1.0 -C -C ********************************************************************** -C CALCULATE INITIAL CONDITIONS WHICH SATISFY -C A*YH(XINITIAL)=0 AND A*YP(XINITIAL)=ALPHA. -C WHEN NFC .NE. NFCC LSSUDS DEFINES VALUES YHP IN A MATRIX OF SIZE -C (NFCC+1)*NCOMP AND ,HENCE, OVERFLOWS THE STORAGE ALLOCATION INTO -C THE U ARRAY. HOWEVER, THIS IS OKAY SINCE PLENTY OF SPACE IS -C AVAILABLE IN U AND IT HAS NOT YET BEEN USED. -C - NDW = NROWA * NCOMP - KWS = NDW + NIC + 1 - KWD = KWS + NIC - KWT = KWD + NIC - KWC = KWT + NIC - IFLAG = 0 - CALL LSSUDS(A,YHP(1,NFCC+1),ALPHA,NIC,NCOMP,NROWA,YHP,NCOMP, - 1 IFLAG,1,IRA,0,WORK(1),WORK(NDW+1),IWORK,WORK(KWS), - 2 WORK(KWD),WORK(KWT),ISFLG,WORK(KWC)) - IF (IFLAG .EQ. 1) GO TO 3 - IFLAG=-4 - GO TO 250 - 3 IF (NFC .NE. NFCC) CALL SVECS(NCOMP,NFC,YHP,WORK,IWORK, - 1 INHOMO,IFLAG) - IF (IFLAG .EQ. 1) GO TO 5 - IFLAG=-5 - GO TO 250 -C -C ********************************************************************** -C DETERMINE THE NUMBER OF DIFFERENTIAL EQUATIONS TO BE INTEGRATED, -C INITIALIZE VARIABLES FOR AUXILIARY INITIAL VALUE PROBLEM AND -C STORE INITIAL CONDITIONS. -C - 5 NEQ = NCOMP * NFC - IF (INHOMO .EQ. 1) NEQ = NEQ + NCOMP - IVP = 0 - IF (NEQIVP .EQ. 0) GO TO 10 - IVP = NEQ - NEQ = NEQ + NEQIVP - NFCP2 = NFCP1 - IF (INHOMO .EQ. 1) NFCP2 = NFCP1 + 1 - DO 7 K = 1,NEQIVP - 7 YHP(K,NFCP2) = ALPHA(NIC+K) - 10 CALL STOR1(U,YHP,V,YHP(1,NFCP1),0,NDISK,NTAPE) -C -C ********************************************************************** -C SET UP DATA FOR THE ORTHONORMALIZATION TESTING PROCEDURE AND -C SAVE INITIAL CONDITIONS IN CASE A RESTART IS NECESSARY. -C - NSWOT=1 - KNSWOT=0 - LOTJP=1 - TND=LOG10(10.*TOL) - PWCND=LOG10(SQRT(TOL)) - X=XBEG - PX=X - XOT=XEND - XOP=X - KOP=1 - CALL STWAY(U,V,YHP,0,STOWA) -C -C ********************************************************************** -C ******** FORWARD INTEGRATION OF ALL INITIAL VALUE EQUATIONS ********** -C ********************************************************************** -C - CALL RKFAB(NCOMP,XPTS,NXPTS,NFC,IFLAG,Z,MXNON,P,NTP,IP, - 1 YHP,NIV,U,V,W,S,STOWA,G,WORK,IWORK,NFCC) - IF (IFLAG .NE. 0 .OR. ICOCO .EQ. 0) GO TO 250 -C -C ********************************************************************** -C **************** BACKWARD SWEEP TO OBTAIN SOLUTION ******************* -C ********************************************************************** -C -C CALCULATE SUPERPOSITION COEFFICIENTS AT XFINAL. -C -C FOR THE DISK STORAGE VERSION, IT IS NOT NECESSARY TO READ U AND V -C AT THE LAST OUTPUT POINT, SINCE THE LOCAL COPY OF EACH STILL EXISTS. -C - KOD = 1 - IF (NDISK .EQ. 0) KOD = NXPTS - I1=1+NFCC*NFCC - I2=I1+NFCC - CALL SCOEF(U(1,1,KOD),V(1,KOD),NCOMP,NROWB,NFC,NIC,B,BETA,COEF, - 1 INHOMO,RE,AE,WORK,WORK(I1),WORK(I2),IWORK,IFLAG,NFCC) -C -C ********************************************************************** -C CALCULATE SOLUTION AT OUTPUT POINTS BY RECURRING BACKWARDS. -C AS WE RECUR BACKWARDS FROM XFINAL TO XINITIAL WE MUST CALCULATE -C NEW SUPERPOSITION COEFFICIENTS EACH TIME WE CROSS A POINT OF -C ORTHONORMALIZATION. -C - K = NUMORT - NCOMP2=NCOMP/2 - IC=1 - IF (NFC .NE. NFCC) IC=2 - DO 200 J = 1,NXPTS - KPTS = NXPTS - J + 1 - KOD = KPTS - IF (NDISK .EQ. 1) KOD = 1 - 135 IF (K .EQ. 0) GO TO 170 - IF (XEND.GT.XBEG .AND. XPTS(KPTS).GE.Z(K)) GO TO 170 - IF (XEND.LT.XBEG .AND. XPTS(KPTS).LE.Z(K)) GO TO 170 - NON = K - IF (NDISK .EQ. 0) GO TO 136 - NON = 1 - BACKSPACE NTAPE - READ (NTAPE) (IP(I,1), I = 1,NFCC),(P(I,1), I = 1,NTP) - BACKSPACE NTAPE - 136 IF (INHOMO .NE. 1) GO TO 150 - IF (NDISK .EQ. 0) GO TO 138 - BACKSPACE NTAPE - READ (NTAPE) (W(I,1), I = 1,NFCC) - BACKSPACE NTAPE - 138 DO 140 N = 1,NFCC - 140 COEF(N) = COEF(N) - W(N,NON) - 150 CALL BKSOL(NFCC,P(1,NON),COEF) - DO 155 M = 1,NFCC - 155 WORK(M) = COEF(M) - DO 160 M = 1,NFCC - L = IP(M,NON) - 160 COEF(L) = WORK(M) - K = K - 1 - GO TO 135 - 170 IF (NDISK .EQ. 0) GO TO 175 - BACKSPACE NTAPE - READ (NTAPE) (V(I,1), I = 1,NCOMP), - 1 ((U(I,M,1), I = 1,NCOMP), M = 1,NFC) - BACKSPACE NTAPE - 175 DO 180 N = 1,NCOMP - 180 Y(N,KPTS) = V(N,KOD) + SDOT(NFC,U(N,1,KOD),NCOMP,COEF,IC) - IF (NFC .EQ. NFCC) GO TO 200 - DO 190 N=1,NCOMP2 - NN=NCOMP2+N - Y(N,KPTS)=Y(N,KPTS) - SDOT(NFC,U(NN,1,KOD),NCOMP,COEF(2),2) - 190 Y(NN,KPTS)=Y(NN,KPTS) + SDOT(NFC,U(N,1,KOD),NCOMP,COEF(2),2) - 200 CONTINUE -C -C ********************************************************************** -C - 250 MXNON = NUMORT - RETURN - END diff --git a/slatec/bvsup.f b/slatec/bvsup.f deleted file mode 100644 index 71e6c4a..0000000 --- a/slatec/bvsup.f +++ /dev/null @@ -1,694 +0,0 @@ -*DECK BVSUP - SUBROUTINE BVSUP (Y, NROWY, NCOMP, XPTS, NXPTS, A, NROWA, ALPHA, - + NIC, B, NROWB, BETA, NFC, IGOFX, RE, AE, IFLAG, WORK, NDW, - + IWORK, NDIW, NEQIVP) -C***BEGIN PROLOGUE BVSUP -C***PURPOSE Solve a linear two-point boundary value problem using -C superposition coupled with an orthonormalization procedure -C and a variable-step integration scheme. -C***LIBRARY SLATEC -C***CATEGORY I1B1 -C***TYPE SINGLE PRECISION (BVSUP-S, DBVSUP-D) -C***KEYWORDS ORTHONORMALIZATION, SHOOTING, -C TWO-POINT BOUNDARY VALUE PROBLEM -C***AUTHOR Scott, M. R., (SNLA) -C Watts, H. A., (SNLA) -C***DESCRIPTION -C -C ********************************************************************** -C Subroutine BVSUP solves a LINEAR two-point boundary-value problem -C of the form -C dY/dX = MATRIX(X,U)*Y(X) + G(X,U) -C A*Y(Xinitial) = ALPHA , B*Y(Xfinal) = BETA -C -C Coupled with the solution of the initial value problem -C -C dU/dX = F(X,U) -C U(Xinitial) = ETA -C -C ********************************************************************** -C Abstract -C The method of solution uses superposition coupled with an -C orthonormalization procedure and a variable-step integration -C scheme. Each time the superposition solutions start to -C lose their numerical linear independence, the vectors are -C reorthonormalized before integration proceeds. The underlying -C principle of the algorithm is then to piece together the -C intermediate (orthogonalized) solutions, defined on the various -C subintervals, to obtain the desired solutions. -C -C ********************************************************************** -C INPUT to BVSUP -C ********************************************************************** -C -C NROWY = Actual row dimension of Y in calling program. -C NROWY must be .GE. NCOMP -C -C NCOMP = Number of components per solution vector. -C NCOMP is equal to number of original differential -C equations. NCOMP = NIC + NFC. -C -C XPTS = Desired output points for solution. They must be monotonic. -C Xinitial = XPTS(1) -C Xfinal = XPTS(NXPTS) -C -C NXPTS = Number of output points -C -C A(NROWA,NCOMP) = Boundary condition matrix at Xinitial, -C must be contained in (NIC,NCOMP) sub-matrix. -C -C NROWA = Actual row dimension of A in calling program, -C NROWA must be .GE. NIC. -C -C ALPHA(NIC+NEQIVP) = Boundary conditions at Xinitial. -C If NEQIVP .GT. 0 (see below), the boundary -C conditions at Xinitial for the initial value -C equations must be stored starting in -C position (NIC + 1) of ALPHA. -C Thus, ALPHA(NIC+K) = ETA(K). -C -C NIC = Number of boundary conditions at Xinitial. -C -C B(NROWB,NCOMP) = Boundary condition matrix at Xfinal, -C must be contained in (NFC,NCOMP) sub-matrix. -C -C NROWB = Actual row dimension of B in calling program, -C NROWB must be .GE. NFC. -C -C BETA(NFC) = Boundary conditions at Xfinal. -C -C NFC = Number of boundary conditions at Xfinal -C -C IGOFX =0 -- The inhomogeneous term G(X) is identically zero. -C =1 -- The inhomogeneous term G(X) is not identically zero. -C (if IGOFX=1, then subroutine GVEC (or UVEC) must be -C supplied). -C -C RE = Relative error tolerance used by the integrator -C (see one of the integrators) -C -C AE = Absolute error tolerance used by the integrator -C (see one of the integrators) -C **NOTE- RE and AE should not both be zero. -C -C IFLAG = A status parameter used principally for output. -C However, for efficient solution of problems which -C are originally defined as complex valued (but -C converted to real systems to use this code), the -C user must set IFLAG=13 on input. See the comment below -C for more information on solving such problems. -C -C WORK(NDW) = Floating point array used for internal storage. -C -C NDW = Actual dimension of WORK array allocated by user. -C An estimate for NDW can be computed from the following -C NDW = 130 + NCOMP**2 * (6 + NXPTS/2 + expected number of -C orthonormalizations/8) -C For the DISK or TAPE storage mode, -C NDW = 6 * NCOMP**2 + 10 * NCOMP + 130 -C However, when the ADAMS integrator is to be used, the estimates are -C NDW = 130 + NCOMP**2 * (13 + NXPTS/2 + expected number of -C orthonormalizations/8) -C and NDW = 13 * NCOMP**2 + 22 * NCOMP + 130 , respectively. -C -C IWORK(NDIW) = Integer array used for internal storage. -C -C NDIW = Actual dimension of IWORK array allocated by user. -C An estimate for NDIW can be computed from the following -C NDIW = 68 + NCOMP * (1 + expected number of -C orthonormalizations) -C **NOTE -- The amount of storage required is problem dependent and may -C be difficult to predict in advance. Experience has shown -C that for most problems 20 or fewer orthonormalizations -C should suffice. If the problem cannot be completed with the -C allotted storage, then a message will be printed which -C estimates the amount of storage necessary. In any case, the -C user can examine the IWORK array for the actual storage -C requirements, as described in the output information below. -C -C NEQIVP = Number of auxiliary initial value equations being added -C to the boundary value problem. -C **NOTE -- Occasionally the coefficients MATRIX and/or G may be -C functions which depend on the independent variable X and -C on U, the solution of an auxiliary initial value problem. -C In order to avoid the difficulties associated with -C interpolation, the auxiliary equations may be solved -C simultaneously with the given boundary value problem. -C This initial value problem may be LINEAR or NONLINEAR. -C See SAND77-1328 for an example. -C -C -C The user must supply subroutines FMAT, GVEC, UIVP and UVEC, when -C needed (they MUST be so named), to evaluate the derivatives -C as follows -C -C A. FMAT must be supplied. -C -C SUBROUTINE FMAT(X,Y,YP) -C X = Independent variable (input to FMAT) -C Y = Dependent variable vector (input to FMAT) -C YP = dY/dX = Derivative vector (output from FMAT) -C -C Compute the derivatives for the HOMOGENEOUS problem -C YP(I) = dY(I)/dX = MATRIX(X) * Y(I) , I = 1,...,NCOMP -C -C When (NEQIVP .GT. 0) and MATRIX is dependent on U as -C well as on X, the following common statement must be -C included in FMAT -C COMMON /MLIVP/ NOFST -C For convenience, the U vector is stored at the bottom -C of the Y array. Thus, during any call to FMAT, -C U(I) is referenced by Y(NOFST + I). -C -C -C Subroutine BVDER calls FMAT NFC times to evaluate the -C homogeneous equations and, if necessary, it calls FMAT once -C in evaluating the particular solution. Since X remains -C unchanged in this sequence of calls it is possible to -C realize considerable computational savings for complicated -C and expensive evaluations of the MATRIX entries. To do this -C the user merely passes a variable, say XS, via COMMON where -C XS is defined in the main program to be any value except -C the initial X. Then the non-constant elements of MATRIX(X) -C appearing in the differential equations need only be -C computed if X is unequal to XS, whereupon XS is reset to X. -C -C -C B. If NEQIVP .GT. 0 , UIVP must also be supplied. -C -C SUBROUTINE UIVP(X,U,UP) -C X = Independent variable (input to UIVP) -C U = Dependent variable vector (input to UIVP) -C UP = dU/dX = Derivative vector (output from UIVP) -C -C Compute the derivatives for the auxiliary initial value eqs -C UP(I) = dU(I)/dX, I = 1,...,NEQIVP. -C -C Subroutine BVDER calls UIVP once to evaluate the -C derivatives for the auxiliary initial value equations. -C -C -C C. If NEQIVP = 0 and IGOFX = 1 , GVEC must be supplied. -C -C SUBROUTINE GVEC(X,G) -C X = Independent variable (input to GVEC) -C G = Vector of inhomogeneous terms G(X) (output from GVEC) -C -C Compute the inhomogeneous terms G(X) -C G(I) = G(X) values for I = 1,...,NCOMP. -C -C Subroutine BVDER calls GVEC in evaluating the particular -C solution provided G(X) is NOT identically zero. Thus, when -C IGOFX=0, the user need NOT write a GVEC subroutine. Also, -C the user does not have to bother with the computational -C savings scheme for GVEC as this is automatically achieved -C via the BVDER subroutine. -C -C -C D. If NEQIVP .GT. 0 and IGOFX = 1 , UVEC must be supplied. -C -C SUBROUTINE UVEC(X,U,G) -C X = Independent variable (input to UVEC) -C U = Dependent variable vector from the auxiliary initial -C value problem (input to UVEC) -C G = Array of inhomogeneous terms G(X,U)(output from UVEC) -C -C Compute the inhomogeneous terms G(X,U) -C G(I) = G(X,U) values for I = 1,...,NCOMP. -C -C Subroutine BVDER calls UVEC in evaluating the particular -C solution provided G(X,U) is NOT identically zero. Thus, -C when IGOFX=0, the user need NOT write a UVEC subroutine. -C -C -C -C The following is optional input to BVSUP to give the user more -C flexibility in use of the code. See SAND75-0198 , SAND77-1328 , -C SAND77-1690,SAND78-0522, and SAND78-1501 for more information. -C -C ****CAUTION -- The user MUST zero out IWORK(1),...,IWORK(15) -C prior to calling BVSUP. These locations define optional -C input and MUST be zero UNLESS set to special values by -C the user as described below. -C -C IWORK(1) -- Number of orthonormalization points. -C A value need be set only if IWORK(11) = 1 -C -C IWORK(9) -- Integrator and orthonormalization parameter -C (default value is 1) -C 1 = RUNGE-KUTTA-FEHLBERG code using GRAM-SCHMIDT test. -C 2 = ADAMS code using GRAM-SCHMIDT TEST. -C -C IWORK(11) -- Orthonormalization points parameter -C (default value is 0) -C 0 - Orthonormalization points not pre-assigned. -C 1 - Orthonormalization points pre-assigned in -C the first IWORK(1) positions of WORK. -C -C IWORK(12) -- Storage parameter -C (default value is 0) -C 0 - All storage IN CORE -C LUN - Homogeneous and inhomogeneous solutions at -C output points and orthonormalization information -C are stored on DISK. The logical unit number to be -C used for DISK I/O (NTAPE) is set to IWORK(12). -C -C WORK(1),... -- Pre-assigned orthonormalization points, stored -C monotonically, corresponding to the direction -C of integration. -C -C -C -C ****************************** -C *** COMPLEX VALUED PROBLEM *** -C ****************************** -C **NOTE*** -C Suppose the original boundary value problem is NC equations -C of the form -C dW/dX = MAT(X,U)*W(X) + H(X,U) -C R*W(Xinitial)=GAMMA , S*W(Xfinal)=DELTA -C -C where all variables are complex valued. The BVSUP code can be -C used by converting to a real system of size 2*NC. To solve the -C larger dimensioned problem efficiently, the user must initialize -C IFLAG=13 on input and order the vector components according to -C Y(1)=real(W(1)),...,Y(NC)=real(W(NC)),Y(NC+1)=imag(W(1)),...., -C Y(2*NC)=imag(W(NC)). Then define -C ........................... -C . real(MAT) -imag(MAT) . -C MATRIX = . . -C . imag(MAT) real(MAT) . -C ........................... -C -C The matrices A,B and vectors G,ALPHA,BETA must be defined -C similarly. Further details can be found in SAND78-1501. -C -C -C ********************************************************************** -C OUTPUT from BVSUP -C ********************************************************************** -C -C Y(NROWY,NXPTS) = Solution at specified output points. -C -C IFLAG output values -C =-5 Algorithm ,for obtaining starting vectors for the -C special complex problem structure, was unable to obtain -C the initial vectors satisfying the necessary -C independence criteria. -C =-4 Rank of boundary condition matrix A is less than NIC, -C as determined by LSSUDS. -C =-2 Invalid input parameters. -C =-1 Insufficient number of storage locations allocated for -C WORK or IWORK. -C -C =0 Indicates successful solution -C -C =1 A computed solution is returned but UNIQUENESS of the -C solution of the boundary-value problem is questionable. -C For an eigenvalue problem, this should be treated as a -C successful execution since this is the expected mode -C of return. -C =2 A computed solution is returned but the EXISTENCE of the -C solution to the boundary-value problem is questionable. -C =3 A nontrivial solution approximation is returned although -C the boundary condition matrix B*Y(Xfinal) is found to be -C nonsingular (to the desired accuracy level) while the -C right hand side vector is zero. To eliminate this type -C of return, the accuracy of the eigenvalue parameter -C must be improved. -C ***NOTE- We attempt to diagnose the correct problem behavior -C and report possible difficulties by the appropriate -C error flag. However, the user should probably resolve -C the problem using smaller error tolerances and/or -C perturbations in the boundary conditions or other -C parameters. This will often reveal the correct -C interpretation for the problem posed. -C -C =13 Maximum number of orthonormalizations attained before -C reaching Xfinal. -C =20-flag from integrator (DERKF or DEABM) values can range -C from 21 to 25. -C =30 Solution vectors form a dependent set. -C -C WORK(1),...,WORK(IWORK(1)) = Orthonormalization points -C determined by BVPOR. -C -C IWORK(1) = Number of orthonormalizations performed by BVPOR. -C -C IWORK(2) = Maximum number of orthonormalizations allowed as -C calculated from storage allocated by user. -C -C IWORK(3),IWORK(4),IWORK(5),IWORK(6) Give information about -C actual storage requirements for WORK and IWORK -C arrays. In particular, -C required storage for WORK array is -C IWORK(3) + IWORK(4)*(expected number of orthonormalizations) -C -C required storage for IWORK array is -C IWORK(5) + IWORK(6)*(expected number of orthonormalizations) -C -C IWORK(8) = Final value of exponent parameter used in tolerance -C test for orthonormalization. -C -C IWORK(16) = Number of independent vectors returned from MGSBV. -C It is only of interest when IFLAG=30 is obtained. -C -C IWORK(17) = Numerically estimated rank of the boundary -C condition matrix defined from B*Y(Xfinal) -C -C ********************************************************************** -C -C Necessary machine constants are defined in the function -C routine R1MACH. The user must make sure that the values -C set in R1MACH are relevant to the computer being used. -C -C ********************************************************************** -C -C***REFERENCES M. R. Scott and H. A. Watts, SUPORT - a computer code -C for two-point boundary-value problems via -C orthonormalization, SIAM Journal of Numerical -C Analysis 14, (1977), pp. 40-70. -C B. L. Darlow, M. R. Scott and H. A. Watts, Modifications -C of SUPORT, a linear boundary value problem solver -C Part I - pre-assigning orthonormalization points, -C auxiliary initial value problem, disk or tape storage, -C Report SAND77-1328, Sandia Laboratories, Albuquerque, -C New Mexico, 1977. -C B. L. Darlow, M. R. Scott and H. A. Watts, Modifications -C of SUPORT, a linear boundary value problem solver -C Part II - inclusion of an Adams integrator, Report -C SAND77-1690, Sandia Laboratories, Albuquerque, -C New Mexico, 1977. -C M. E. Lord and H. A. Watts, Modifications of SUPORT, -C a linear boundary value problem solver Part III - -C orthonormalization improvements, Report SAND78-0522, -C Sandia Laboratories, Albuquerque, New Mexico, 1978. -C H. A. Watts, M. R. Scott and M. E. Lord, Computational -C solution of complex*16 valued boundary problems, -C Report SAND78-1501, Sandia Laboratories, -C Albuquerque, New Mexico, 1978. -C***ROUTINES CALLED EXBVP, MACON, XERMSG -C***COMMON BLOCKS ML15TO, ML17BW, ML18JR, ML5MCO, ML8SZ -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 890921 Realigned order of variables in certain COMMON blocks. -C (WRB) -C 890921 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE BVSUP -C ********************************************************************** -C -C - DIMENSION Y(NROWY,*),A(NROWA,*),ALPHA(*),B(NROWB,*), - 1 BETA(*),WORK(*),IWORK(*),XPTS(*) - CHARACTER*8 XERN1, XERN2, XERN3, XERN4 -C -C ********************************************************************** -C THE COMMON BLOCK BELOW IS USED TO COMMUNICATE WITH SUBROUTINE -C BVDER. THE USER SHOULD NOT ALTER OR USE THIS COMMON BLOCK IN THE -C CALLING PROGRAM. -C - COMMON /ML8SZ/ C,XSAV,IGOFXD,INHOMO,IVP,NCOMPD,NFCD -C -C ********************************************************************** -C THESE COMMON BLOCKS AID IN REDUCING THE NUMBER OF SUBROUTINE -C ARGUMENTS PREVALENT IN THIS MODULAR STRUCTURE -C - COMMON /ML18JR/ AED,RED,TOL,NXPTSD,NICD,NOPG,MXNON,NDISK,NTAPE, - 1 NEQ,INDPVT,INTEG,NPS,NTP,NEQIVD,NUMORT,NFCC, - 2 ICOCO - COMMON /ML17BW/ KKKZPW,NEEDW,NEEDIW,K1,K2,K3,K4,K5,K6,K7,K8,K9, - 1 K10,K11,L1,L2,KKKINT,LLLINT -C -C ********************************************************************** -C THIS COMMON BLOCK IS USED IN SUBROUTINES BVSUP,BVPOR,RKFAB, -C REORT, AND STWAY. IT CONTAINS INFORMATION NECESSARY -C FOR THE ORTHONORMALIZATION TESTING PROCEDURE AND A BACKUP -C RESTARTING CAPABILITY. -C - COMMON /ML15TO/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP, - 1 KNSWOT,KOP,LOTJP,MNSWOT,NSWOT -C -C ********************************************************************** -C THIS COMMON BLOCK CONTAINS THE MACHINE DEPENDENT PARAMETERS -C USED BY THE CODE -C - COMMON /ML5MCO/ URO,SRU,EPS,SQOVFL,TWOU,FOURU,LPAR -C -C ********************************************************************** -C SET UP MACHINE DEPENDENT CONSTANTS. -C -C***FIRST EXECUTABLE STATEMENT BVSUP - CALL MACON -C -C ********************************************************************** -C TEST FOR INVALID INPUT -C - IF (NROWY .LT. NCOMP) GO TO 20 - IF (NCOMP .NE. NIC+NFC) GO TO 20 - IF (NXPTS .LT. 2) GO TO 20 - IF (NIC .LE. 0) GO TO 20 - IF (NROWA .LT. NIC) GO TO 20 - IF (NFC .LE. 0) GO TO 20 - IF (NROWB .LT. NFC) GO TO 20 - IF (IGOFX .LT. 0 .OR. IGOFX .GT. 1) GO TO 20 - IF (RE .LT. 0.0) GO TO 20 - IF (AE .LT. 0.0) GO TO 20 - IF (RE .EQ. 0.0 .AND. AE .EQ. 0.0) GO TO 20 - IS = 1 - IF (XPTS(NXPTS) .LT. XPTS(1)) IS = 2 - NXPTSM = NXPTS - 1 - DO 13 K = 1,NXPTSM - IF (IS .EQ. 2) GO TO 12 - IF (XPTS(K+1) .LE. XPTS(K)) GO TO 20 - GO TO 13 - 12 IF (XPTS(K) .LE. XPTS(K+1)) GO TO 20 - 13 CONTINUE - GO TO 30 - 20 IFLAG = -2 - RETURN - 30 CONTINUE -C -C ********************************************************************** -C CHECK FOR DISK STORAGE -C - KPTS = NXPTS - NDISK = 0 - IF (IWORK(12) .EQ. 0) GO TO 35 - NTAPE = IWORK(12) - KPTS = 1 - NDISK = 1 - 35 CONTINUE -C -C ********************************************************************** -C SET INTEG PARAMETER ACCORDING TO CHOICE OF INTEGRATOR. -C - INTEG = 1 - IF (IWORK(9) .EQ. 2) INTEG = 2 -C -C ********************************************************************** -C COMPUTE INHOMO -C - IF (IGOFX .EQ. 1) GO TO 43 - DO 40 J = 1,NIC - IF (ALPHA(J) .NE. 0.0) GO TO 43 - 40 CONTINUE - DO 41 J = 1,NFC - IF (BETA(J) .NE. 0.0) GO TO 42 - 41 CONTINUE - INHOMO = 3 - GO TO 45 - 42 INHOMO = 2 - GO TO 45 - 43 INHOMO = 1 - 45 CONTINUE -C -C ********************************************************************** -C TO TAKE ADVANTAGE OF THE SPECIAL STRUCTURE WHEN SOLVING A -C COMPLEX VALUED PROBLEM,WE INTRODUCE NFCC=NFC WHILE CHANGING -C THE INTERNAL VALUE OF NFC -C - NFCC=NFC - IF (IFLAG .EQ. 13) NFC=NFC/2 -C -C ********************************************************************** -C DETERMINE NECESSARY STORAGE REQUIREMENTS -C -C FOR BASIC ARRAYS IN BVPOR - KKKYHP = NCOMP*(NFC+1) + NEQIVP - KKKU = NCOMP*NFC*KPTS - KKKV = NCOMP*KPTS - KKKCOE = NFCC - KKKS = NFC+1 - KKKSTO = NCOMP*(NFC+1) + NEQIVP + 1 - KKKG = NCOMP -C -C FOR ORTHONORMALIZATION RELATED MATTERS - NTP = (NFCC*(NFCC+1))/2 - KKKZPW = 1 + NTP + NFCC - LLLIP = NFCC -C -C FOR ADDITIONAL REQUIRED WORK SPACE -C (LSSUDS) - KKKSUD = 4*NIC + (NROWA+1)*NCOMP - LLLSUD = NIC -C (SVECS) - KKKSVC = 1 + 4*NFCC + 2*NFCC**2 - LLLSVC = 2*NFCC -C - NDEQ=NCOMP*NFC+NEQIVP - IF (INHOMO .EQ. 1) NDEQ=NDEQ+NCOMP - GO TO (51,52),INTEG -C (DERKF) - 51 KKKINT = 33 + 7*NDEQ - LLLINT = 34 - GO TO 55 -C (DEABM) - 52 KKKINT = 130 + 21*NDEQ - LLLINT = 51 -C -C (COEF) - 55 KKKCOF = 5*NFCC + NFCC**2 - LLLCOF = 3 + NFCC -C - KKKWS = MAX(KKKSUD,KKKSVC,KKKINT,KKKCOF) - LLLIWS = MAX(LLLSUD,LLLSVC,LLLINT,LLLCOF) -C - NEEDW = KKKYHP + KKKU + KKKV + KKKCOE + KKKS + KKKSTO + KKKG + - 1 KKKZPW + KKKWS - NEEDIW = 17 + LLLIP + LLLIWS -C ********************************************************************** -C COMPUTE THE NUMBER OF POSSIBLE ORTHONORMALIZATIONS WITH THE -C ALLOTTED STORAGE -C - IWORK(3) = NEEDW - IWORK(4) = KKKZPW - IWORK(5) = NEEDIW - IWORK(6) = LLLIP - NRTEMP = NDW - NEEDW - NITEMP = NDIW - NEEDIW - IF (NRTEMP .LT. 0) GO TO 70 - IF (NITEMP .GE. 0) GO TO 75 -C - 70 IFLAG = -1 - IF (NDISK .NE. 1) THEN - WRITE (XERN1, '(I8)') NEEDW - WRITE (XERN2, '(I8)') KKKZPW - WRITE (XERN3, '(I8)') NEEDIW - WRITE (XERN4, '(I8)') LLLIP - CALL XERMSG ('SLATEC', 'BVSUP', - * 'REQUIRED STORAGE FOR WORK ARRAY IS ' // XERN1 // ' + ' // - * XERN2 // '*(EXPECTED NUMBER OF ORTHONORMALIZATIONS) $$' // - * 'REQUIRED STORAGE FOR IWORK ARRAY IS ' // XERN3 // ' + ' // - * XERN4 // '*(EXPECTED NUMBER OF ORTHONORMALIZATIONS)', 1, 0) - ELSE - WRITE (XERN1, '(I8)') NEEDW - WRITE (XERN2, '(I8)') NEEDIW - CALL XERMSG ('SLATEC', 'BVSUP', - * 'REQUIRED STORAGE FOR WORK ARRAY IS ' // XERN1 // - * ' + NUMBER OF ORTHONOMALIZATIONS. $$' // - * 'REQUIRED STORAGE FOR IWORK ARRAY IS ' // XERN2, 1, 0) - ENDIF - RETURN -C - 75 IF (NDISK .EQ. 0) GO TO 77 - NON = 0 - MXNON = NRTEMP - GO TO 78 -C - 77 MXNONR = NRTEMP / KKKZPW - MXNONI = NITEMP / LLLIP - MXNON = MIN(MXNONR,MXNONI) - NON = MXNON -C - 78 IWORK(2) = MXNON -C -C ********************************************************************** -C CHECK FOR PRE-ASSIGNED ORTHONORMALIZATION POINTS -C - NOPG = 0 - IF (IWORK(11) .NE. 1) GO TO 85 - IF (MXNON .LT. IWORK(1)) GO TO 70 - NOPG = 1 - MXNON = IWORK(1) - WORK(MXNON+1) = 2. * XPTS(NXPTS) - XPTS(1) - 85 CONTINUE -C -C ********************************************************************** -C ALLOCATE STORAGE FROM WORK AND IWORK ARRAYS -C -C (Z) - K1 = 1 + (MXNON+1) -C (P) - K2 = K1 + NTP*(NON+1) -C (W) - K3 = K2 + NFCC*(NON+1) -C (YHP) - K4 = K3 + KKKYHP -C (U) - K5 = K4 + KKKU -C (V) - K6 = K5 + KKKV -C (COEF) - K7 = K6 + KKKCOE -C (S) - K8 = K7 + KKKS -C (STOWA) - K9 = K8 + KKKSTO -C (G) - K10 = K9 + KKKG - K11 = K10 + KKKWS -C REQUIRED ADDITIONAL REAL WORK SPACE STARTS AT WORK(K10) -C AND EXTENDS TO WORK(K11-1) -C -C FIRST 17 LOCATIONS OF IWORK ARE USED FOR OPTIONAL -C INPUT AND OUTPUT ITEMS -C (IP) - L1 = 18 + NFCC*(NON+1) - L2 = L1 + LLLIWS -C REQUIRED INTEGER WORK SPACE STARTS AT IWORK(L1) -C AND EXTENDS TO IWORK(L2-1) -C -C ********************************************************************** -C SET INDICATOR FOR NORMALIZATION OF PARTICULAR SOLUTION -C - NPS = 0 - IF (IWORK(10) .EQ. 1) NPS = 1 -C -C ********************************************************************** -C SET PIVOTING PARAMETER -C - INDPVT=0 - IF (IWORK(15) .EQ. 1) INDPVT=1 -C -C ********************************************************************** -C SET OTHER COMMON BLOCK PARAMETERS -C - NFCD = NFC - NCOMPD = NCOMP - IGOFXD = IGOFX - NXPTSD = NXPTS - NICD = NIC - RED = RE - AED = AE - NEQIVD = NEQIVP - MNSWOT = 20 - IF (IWORK(13) .EQ. -1) MNSWOT=MAX(1,IWORK(14)) - XBEG=XPTS(1) - XEND=XPTS(NXPTS) - XSAV=XEND - ICOCO=1 - IF (INHOMO .EQ. 3 .AND. NOPG .EQ. 1) WORK(MXNON+1)=XEND -C -C ********************************************************************** -C - CALL EXBVP(Y,NROWY,XPTS,A,NROWA,ALPHA,B,NROWB,BETA,IFLAG,WORK, - 1 IWORK) - NFC=NFCC - IWORK(17)=IWORK(L1) - RETURN - END diff --git a/slatec/c0lgmc.f b/slatec/c0lgmc.f deleted file mode 100644 index 88a7647..0000000 --- a/slatec/c0lgmc.f +++ /dev/null @@ -1,42 +0,0 @@ -*DECK C0LGMC - COMPLEX FUNCTION C0LGMC (Z) -C***BEGIN PROLOGUE C0LGMC -C***PURPOSE Evaluate (Z+0.5)*LOG((Z+1.)/Z) - 1.0 with relative -C accuracy. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7A -C***TYPE COMPLEX (C0LGMC-C) -C***KEYWORDS FNLIB, GAMMA FUNCTION, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate (Z+0.5)*LOG((Z+1.0)/Z) - 1.0 with relative error accuracy -C Let Q = 1.0/Z so that -C (Z+0.5)*LOG(1+1/Z) - 1 = (Z+0.5)*(LOG(1+Q) - Q + Q*Q/2) - Q*Q/4 -C = (Z+0.5)*Q**3*C9LN2R(Q) - Q**2/4, -C where C9LN2R is (LOG(1+Q) - Q + 0.5*Q**2) / Q**3. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED C9LN2R, R1MACH -C***REVISION HISTORY (YYMMDD) -C 780401 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***END PROLOGUE C0LGMC - COMPLEX Z, Q, C9LN2R - SAVE RBIG - DATA RBIG / 0.0 / -C***FIRST EXECUTABLE STATEMENT C0LGMC - IF (RBIG.EQ.0.0) RBIG = 1.0/R1MACH(3) -C - CABSZ = ABS(Z) - IF (CABSZ.GT.RBIG) C0LGMC = -(Z+0.5)*LOG(Z) - Z - IF (CABSZ.GT.RBIG) RETURN -C - Q = 1.0/Z - IF (CABSZ.LE.1.23) C0LGMC = (Z+0.5)*LOG(1.0+Q) - 1.0 - IF (CABSZ.GT.1.23) C0LGMC = ((1.+.5*Q)*C9LN2R(Q) - .25) * Q**2 -C - RETURN - END diff --git a/slatec/c1merg.f b/slatec/c1merg.f deleted file mode 100644 index 1f94cbc..0000000 --- a/slatec/c1merg.f +++ /dev/null @@ -1,68 +0,0 @@ -*DECK C1MERG - SUBROUTINE C1MERG (TCOS, I1, M1, I2, M2, I3) -C***BEGIN PROLOGUE C1MERG -C***SUBSIDIARY -C***PURPOSE Merge two strings of complex numbers. Each string is -C ascending by the real part. -C***LIBRARY SLATEC -C***TYPE COMPLEX (S1MERG-S, D1MERG-D, C1MERG-C, I1MERG-I) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This subroutine merges two ascending strings of numbers in the -C array TCOS. The first string is of length M1 and starts at -C TCOS(I1+1). The second string is of length M2 and starts at -C TCOS(I2+1). The merged string goes into TCOS(I3+1). The ordering -C is on the real part. -C -C***SEE ALSO CMGNBN -C***ROUTINES CALLED CCOPY -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 910408 Modified to use IF-THEN-ELSE. Make it look like MERGE -C which was modified earlier due to compiler problems on -C the IBM RS6000. (RWC) -C 920130 Code name changed from CMPMRG to C1MERG. (WRB) -C***END PROLOGUE C1MERG - INTEGER I1, I2, I3, M1, M2 - COMPLEX TCOS(*) -C - INTEGER J1, J2, J3 -C -C***FIRST EXECUTABLE STATEMENT C1MERG - IF (M1.EQ.0 .AND. M2.EQ.0) RETURN -C - IF (M1.EQ.0 .AND. M2.NE.0) THEN - CALL CCOPY (M2, TCOS(I2+1), 1, TCOS(I3+1), 1) - RETURN - ENDIF -C - IF (M1.NE.0 .AND. M2.EQ.0) THEN - CALL CCOPY (M1, TCOS(I1+1), 1, TCOS(I3+1), 1) - RETURN - ENDIF -C - J1 = 1 - J2 = 1 - J3 = 1 -C - 10 IF (REAL(TCOS(J1+I1)) .LE. REAL(TCOS(I2+J2))) THEN - TCOS(I3+J3) = TCOS(I1+J1) - J1 = J1+1 - IF (J1 .GT. M1) THEN - CALL CCOPY (M2-J2+1, TCOS(I2+J2), 1, TCOS(I3+J3+1), 1) - RETURN - ENDIF - ELSE - TCOS(I3+J3) = TCOS(I2+J2) - J2 = J2+1 - IF (J2 .GT. M2) THEN - CALL CCOPY (M1-J1+1, TCOS(I1+J1), 1, TCOS(I3+J3+1), 1) - RETURN - ENDIF - ENDIF - J3 = J3+1 - GO TO 10 - END diff --git a/slatec/c9lgmc.f b/slatec/c9lgmc.f deleted file mode 100644 index 2639b56..0000000 --- a/slatec/c9lgmc.f +++ /dev/null @@ -1,89 +0,0 @@ -*DECK C9LGMC - COMPLEX FUNCTION C9LGMC (ZIN) -C***BEGIN PROLOGUE C9LGMC -C***SUBSIDIARY -C***PURPOSE Compute the log gamma correction factor so that -C LOG(CGAMMA(Z)) = 0.5*LOG(2.*PI) + (Z-0.5)*LOG(Z) - Z -C + C9LGMC(Z). -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7A -C***TYPE COMPLEX (R9LGMC-S, D9LGMC-D, C9LGMC-C) -C***KEYWORDS COMPLETE GAMMA FUNCTION, CORRECTION TERM, FNLIB, -C LOG GAMMA, LOGARITHM, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Compute the LOG GAMMA correction term for large ABS(Z) when REAL(Z) -C .GE. 0.0 and for large ABS(AIMAG(Y)) when REAL(Z) .LT. 0.0. We find -C C9LGMC so that -C LOG(Z) = 0.5*LOG(2.*PI) + (Z-0.5)*LOG(Z) - Z + C9LGMC(Z) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 780401 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE C9LGMC - COMPLEX ZIN, Z, Z2INV - DIMENSION BERN(11) - LOGICAL FIRST - SAVE BERN, NTERM, BOUND, XBIG, XMAX, FIRST - DATA BERN( 1) / .08333333333 3333333E0 / - DATA BERN( 2) / -.002777777777 7777778E0 / - DATA BERN( 3) / .0007936507936 5079365E0 / - DATA BERN( 4) / -.0005952380952 3809524E0 / - DATA BERN( 5) / .0008417508417 5084175E0 / - DATA BERN( 6) / -.001917526917 5269175E0 / - DATA BERN( 7) / .006410256410 2564103E0 / - DATA BERN( 8) / -.02955065359 4771242E0 / - DATA BERN( 9) / .1796443723 6883057E0 / - DATA BERN(10) / -1.392432216 9059011E0 / - DATA BERN(11) / 13.40286404 4168392E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT C9LGMC - IF (FIRST) THEN - NTERM = -0.30*LOG(R1MACH(3)) - BOUND = 0.1170*NTERM*(0.1*R1MACH(3))**(-1./(2*NTERM-1)) - XBIG = 1.0/SQRT(R1MACH(3)) - XMAX = EXP (MIN(LOG(R1MACH(2)/12.0), -LOG(12.*R1MACH(1))) ) - ENDIF - FIRST = .FALSE. -C - Z = ZIN - X = REAL (Z) - Y = AIMAG(Z) - CABSZ = ABS(Z) -C - IF (X .LT. 0.0 .AND. ABS(Y) .LT. BOUND) CALL XERMSG ('SLATEC', - + 'C9LGMC', 'NOT VALID FOR NEGATIVE REAL(Z) AND SMALL ' // - + 'ABS(AIMAG(Z))', 2, 2) - IF (CABSZ .LT. BOUND) CALL XERMSG ('SLATEC', 'C9LGMC', - + 'NOT VALID FOR SMALL ABS(Z)', 3, 2) -C - IF (CABSZ.GE.XMAX) GO TO 50 -C - IF (CABSZ.GE.XBIG) C9LGMC = 1.0/(12.0*Z) - IF (CABSZ.GE.XBIG) RETURN -C - Z2INV = 1.0/Z**2 - C9LGMC = (0.0, 0.0) - DO 40 I=1,NTERM - NDX = NTERM + 1 - I - C9LGMC = BERN(NDX) + C9LGMC*Z2INV - 40 CONTINUE -C - C9LGMC = C9LGMC/Z - RETURN -C - 50 C9LGMC = (0.0, 0.0) - CALL XERMSG ('SLATEC', 'C9LGMC', 'Z SO BIG C9LGMC UNDERFLOWS', 1, - + 1) - RETURN -C - END diff --git a/slatec/c9ln2r.f b/slatec/c9ln2r.f deleted file mode 100644 index 18cda4d..0000000 --- a/slatec/c9ln2r.f +++ /dev/null @@ -1,73 +0,0 @@ -*DECK C9LN2R - COMPLEX FUNCTION C9LN2R (Z) -C***BEGIN PROLOGUE C9LN2R -C***SUBSIDIARY -C***PURPOSE Evaluate LOG(1+Z) from second order relative accuracy so -C that LOG(1+Z) = Z - Z**2/2 + Z**3*C9LN2R(Z). -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4B -C***TYPE COMPLEX (R9LN2R-S, D9LN2R-D, C9LN2R-C) -C***KEYWORDS ELEMENTARY FUNCTIONS, FNLIB, LOGARITHM, SECOND ORDER -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate LOG(1+Z) from 2-nd order with relative error accuracy so -C that LOG(1+Z) = Z - Z**2/2 + Z**3*C9LN2R(Z). -C -C Now LOG(1+Z) = 0.5*LOG(1+2*X+ABS(Z)**2) + I*CARG(1+Z), -C where X = REAL(Z) and Y = AIMAG(Z). -C We find -C Z**3 * C9LN2R(Z) = -X*ABS(Z)**2 - 0.25*ABS(Z)**4 -C + (2*X+ABS(Z)**2)**3 * R9LN2R(2*X+ABS(Z)**2) -C + I * (CARG(1+Z) + (X-1)*Y) -C The imaginary part must be evaluated carefully as -C (ATAN(Y/(1+X)) - Y/(1+X)) + Y/(1+X) - (1-X)*Y -C = (Y/(1+X))**3 * R9ATN1(Y/(1+X)) + X**2*Y/(1+X) -C -C Now we divide through by Z**3 carefully. Write -C 1/Z**3 = (X-I*Y)/ABS(Z)**3 * (1/ABS(Z)**3) -C then C9LN2R(Z) = ((X-I*Y)/ABS(Z))**3 * (-X/ABS(Z) - ABS(Z)/4 -C + 0.5*((2*X+ABS(Z)**2)/ABS(Z))**3 * R9LN2R(2*X+ABS(Z)**2) -C + I*Y/(ABS(Z)*(1+X)) * ((X/ABS(Z))**2 + -C + (Y/(ABS(Z)*(1+X)))**2 * R9ATN1(Y/(1+X)) ) ) -C -C If we let XZ = X/ABS(Z) and YZ = Y/ABS(Z) we may write -C C9LN2R(Z) = (XZ-I*YZ)**3 * (-XZ - ABS(Z)/4 -C + 0.5*(2*XZ+ABS(Z))**3 * R9LN2R(2*X+ABS(Z)**2) -C + I*YZ/(1+X) * (XZ**2 + (YZ/(1+X))**2*R9ATN1(Y/(1+X)) )) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R9ATN1, R9LN2R -C***REVISION HISTORY (YYMMDD) -C 780401 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 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE C9LN2R - COMPLEX Z -C***FIRST EXECUTABLE STATEMENT C9LN2R - X = REAL (Z) - Y = AIMAG (Z) -C - CABSZ = ABS(Z) - IF (CABSZ.GT.0.8125) GO TO 20 -C - C9LN2R = CMPLX (1.0/3.0, 0.0) - IF (CABSZ.EQ.0.0) RETURN -C - XZ = X/CABSZ - YZ = Y/CABSZ -C - ARG = 2.0*XZ + CABSZ - RPART = 0.5*ARG**3*R9LN2R(CABSZ*ARG) - XZ - 0.25*CABSZ - Y1X = YZ/(1.0+X) - AIPART = Y1X * (XZ**2 + Y1X**2*R9ATN1(CABSZ*Y1X) ) -C - C9LN2R = CMPLX(XZ,-YZ)**3 * CMPLX(RPART,AIPART) - RETURN -C - 20 C9LN2R = (LOG(1.0+Z) - Z*(1.0-0.5*Z)) / Z**3 - RETURN -C - END diff --git a/slatec/cacai.f b/slatec/cacai.f deleted file mode 100644 index b12b057..0000000 --- a/slatec/cacai.f +++ /dev/null @@ -1,101 +0,0 @@ -*DECK CACAI - SUBROUTINE CACAI (Z, FNU, KODE, MR, N, Y, NZ, RL, TOL, ELIM, ALIM) -C***BEGIN PROLOGUE CACAI -C***SUBSIDIARY -C***PURPOSE Subsidiary to CAIRY -C***LIBRARY SLATEC -C***TYPE ALL (CACAI-A, ZACAI-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C CACAI APPLIES THE ANALYTIC CONTINUATION FORMULA -C -C K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) -C MP=PI*MR*CMPLX(0.0,1.0) -C -C TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT -C HALF Z PLANE FOR USE WITH CAIRY WHERE FNU=1/3 OR 2/3 AND N=1. -C CACAI IS THE SAME AS CACON WITH THE PARTS FOR LARGER ORDERS AND -C RECURRENCE REMOVED. A RECURSIVE CALL TO CACON CAN RESULT IF CACON -C IS CALLED FROM CAIRY. -C -C***SEE ALSO CAIRY -C***ROUTINES CALLED CASYI, CBKNU, CMLRI, CS1S2, CSERI, R1MACH -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CACAI - COMPLEX CSGN, CSPN, C1, C2, Y, Z, ZN, CY - REAL ALIM, ARG, ASCLE, AZ, CPN, DFNU, ELIM, FMR, FNU, PI, RL, - * SGN, SPN, TOL, YY, R1MACH - INTEGER INU, IUF, KODE, MR, N, NN, NW, NZ - DIMENSION Y(N), CY(2) - DATA PI / 3.14159265358979324E0 / -C***FIRST EXECUTABLE STATEMENT CACAI - NZ = 0 - ZN = -Z - AZ = ABS(Z) - NN = N - DFNU = FNU + (N-1) - IF (AZ.LE.2.0E0) GO TO 10 - IF (AZ*AZ*0.25E0.GT.DFNU+1.0E0) GO TO 20 - 10 CONTINUE -C----------------------------------------------------------------------- -C POWER SERIES FOR THE I FUNCTION -C----------------------------------------------------------------------- - CALL CSERI(ZN, FNU, KODE, NN, Y, NW, TOL, ELIM, ALIM) - GO TO 40 - 20 CONTINUE - IF (AZ.LT.RL) GO TO 30 -C----------------------------------------------------------------------- -C ASYMPTOTIC EXPANSION FOR LARGE Z FOR THE I FUNCTION -C----------------------------------------------------------------------- - CALL CASYI(ZN, FNU, KODE, NN, Y, NW, RL, TOL, ELIM, ALIM) - IF (NW.LT.0) GO TO 70 - GO TO 40 - 30 CONTINUE -C----------------------------------------------------------------------- -C MILLER ALGORITHM NORMALIZED BY THE SERIES FOR THE I FUNCTION -C----------------------------------------------------------------------- - CALL CMLRI(ZN, FNU, KODE, NN, Y, NW, TOL) - IF(NW.LT.0) GO TO 70 - 40 CONTINUE -C----------------------------------------------------------------------- -C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION -C----------------------------------------------------------------------- - CALL CBKNU(ZN, FNU, KODE, 1, CY, NW, TOL, ELIM, ALIM) - IF (NW.NE.0) GO TO 70 - FMR = MR - SGN = -SIGN(PI,FMR) - CSGN = CMPLX(0.0E0,SGN) - IF (KODE.EQ.1) GO TO 50 - YY = -AIMAG(ZN) - CPN = COS(YY) - SPN = SIN(YY) - CSGN = CSGN*CMPLX(CPN,SPN) - 50 CONTINUE -C----------------------------------------------------------------------- -C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE -C WHEN FNU IS LARGE -C----------------------------------------------------------------------- - INU = FNU - ARG = (FNU-INU)*SGN - CPN = COS(ARG) - SPN = SIN(ARG) - CSPN = CMPLX(CPN,SPN) - IF (MOD(INU,2).EQ.1) CSPN = -CSPN - C1 = CY(1) - C2 = Y(1) - IF (KODE.EQ.1) GO TO 60 - IUF = 0 - ASCLE = 1.0E+3*R1MACH(1)/TOL - CALL CS1S2(ZN, C1, C2, NW, ASCLE, ALIM, IUF) - NZ = NZ + NW - 60 CONTINUE - Y(1) = CSPN*C1 + CSGN*C2 - RETURN - 70 CONTINUE - NZ = -1 - IF(NW.EQ.(-2)) NZ=-2 - RETURN - END diff --git a/slatec/cacon.f b/slatec/cacon.f deleted file mode 100644 index 66b192d..0000000 --- a/slatec/cacon.f +++ /dev/null @@ -1,160 +0,0 @@ -*DECK CACON - SUBROUTINE CACON (Z, FNU, KODE, MR, N, Y, NZ, RL, FNUL, TOL, ELIM, - + ALIM) -C***BEGIN PROLOGUE CACON -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBESH and CBESK -C***LIBRARY SLATEC -C***TYPE ALL (CACON-A, ZACON-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C CACON APPLIES THE ANALYTIC CONTINUATION FORMULA -C -C K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) -C MP=PI*MR*CMPLX(0.0,1.0) -C -C TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT -C HALF Z PLANE -C -C***SEE ALSO CBESH, CBESK -C***ROUTINES CALLED CBINU, CBKNU, CS1S2, R1MACH -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CACON - COMPLEX CK, CONE, CS, CSCL, CSCR, CSGN, CSPN, CSS, CSR, C1, C2, - * RZ, SC1, SC2, ST, S1, S2, Y, Z, ZN, CY - REAL ALIM, ARG, ASCLE, AS2, BSCLE, BRY, CPN, C1I, C1M, C1R, ELIM, - * FMR, FNU, FNUL, PI, RL, SGN, SPN, TOL, YY, R1MACH - INTEGER I, INU, IUF, KFLAG, KODE, MR, N, NN, NW, NZ - DIMENSION Y(N), CY(2), CSS(3), CSR(3), BRY(3) - DATA PI / 3.14159265358979324E0 / - DATA CONE / (1.0E0,0.0E0) / -C***FIRST EXECUTABLE STATEMENT CACON - NZ = 0 - ZN = -Z - NN = N - CALL CBINU(ZN, FNU, KODE, NN, Y, NW, RL, FNUL, TOL, ELIM, ALIM) - IF (NW.LT.0) GO TO 80 -C----------------------------------------------------------------------- -C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION -C----------------------------------------------------------------------- - NN = MIN(2,N) - CALL CBKNU(ZN, FNU, KODE, NN, CY, NW, TOL, ELIM, ALIM) - IF (NW.NE.0) GO TO 80 - S1 = CY(1) - FMR = MR - SGN = -SIGN(PI,FMR) - CSGN = CMPLX(0.0E0,SGN) - IF (KODE.EQ.1) GO TO 10 - YY = -AIMAG(ZN) - CPN = COS(YY) - SPN = SIN(YY) - CSGN = CSGN*CMPLX(CPN,SPN) - 10 CONTINUE -C----------------------------------------------------------------------- -C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE -C WHEN FNU IS LARGE -C----------------------------------------------------------------------- - INU = FNU - ARG = (FNU-INU)*SGN - CPN = COS(ARG) - SPN = SIN(ARG) - CSPN = CMPLX(CPN,SPN) - IF (MOD(INU,2).EQ.1) CSPN = -CSPN - IUF = 0 - C1 = S1 - C2 = Y(1) - ASCLE = 1.0E+3*R1MACH(1)/TOL - IF (KODE.EQ.1) GO TO 20 - CALL CS1S2(ZN, C1, C2, NW, ASCLE, ALIM, IUF) - NZ = NZ + NW - SC1 = C1 - 20 CONTINUE - Y(1) = CSPN*C1 + CSGN*C2 - IF (N.EQ.1) RETURN - CSPN = -CSPN - S2 = CY(2) - C1 = S2 - C2 = Y(2) - IF (KODE.EQ.1) GO TO 30 - CALL CS1S2(ZN, C1, C2, NW, ASCLE, ALIM, IUF) - NZ = NZ + NW - SC2 = C1 - 30 CONTINUE - Y(2) = CSPN*C1 + CSGN*C2 - IF (N.EQ.2) RETURN - CSPN = -CSPN - RZ = CMPLX(2.0E0,0.0E0)/ZN - CK = CMPLX(FNU+1.0E0,0.0E0)*RZ -C----------------------------------------------------------------------- -C SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON K FUNCTIONS -C----------------------------------------------------------------------- - CSCL = CMPLX(1.0E0/TOL,0.0E0) - CSCR = CMPLX(TOL,0.0E0) - CSS(1) = CSCL - CSS(2) = CONE - CSS(3) = CSCR - CSR(1) = CSCR - CSR(2) = CONE - CSR(3) = CSCL - BRY(1) = ASCLE - BRY(2) = 1.0E0/ASCLE - BRY(3) = R1MACH(2) - AS2 = ABS(S2) - KFLAG = 2 - IF (AS2.GT.BRY(1)) GO TO 40 - KFLAG = 1 - GO TO 50 - 40 CONTINUE - IF (AS2.LT.BRY(2)) GO TO 50 - KFLAG = 3 - 50 CONTINUE - BSCLE = BRY(KFLAG) - S1 = S1*CSS(KFLAG) - S2 = S2*CSS(KFLAG) - CS = CSR(KFLAG) - DO 70 I=3,N - ST = S2 - S2 = CK*S2 + S1 - S1 = ST - C1 = S2*CS - ST = C1 - C2 = Y(I) - IF (KODE.EQ.1) GO TO 60 - IF (IUF.LT.0) GO TO 60 - CALL CS1S2(ZN, C1, C2, NW, ASCLE, ALIM, IUF) - NZ = NZ + NW - SC1 = SC2 - SC2 = C1 - IF (IUF.NE.3) GO TO 60 - IUF = -4 - S1 = SC1*CSS(KFLAG) - S2 = SC2*CSS(KFLAG) - ST = SC2 - 60 CONTINUE - Y(I) = CSPN*C1 + CSGN*C2 - CK = CK + RZ - CSPN = -CSPN - IF (KFLAG.GE.3) GO TO 70 - C1R = REAL(C1) - C1I = AIMAG(C1) - C1R = ABS(C1R) - C1I = ABS(C1I) - C1M = MAX(C1R,C1I) - IF (C1M.LE.BSCLE) GO TO 70 - KFLAG = KFLAG + 1 - BSCLE = BRY(KFLAG) - S1 = S1*CS - S2 = ST - S1 = S1*CSS(KFLAG) - S2 = S2*CSS(KFLAG) - CS = CSR(KFLAG) - 70 CONTINUE - RETURN - 80 CONTINUE - NZ = -1 - IF(NW.EQ.(-2)) NZ=-2 - RETURN - END diff --git a/slatec/cacos.f b/slatec/cacos.f deleted file mode 100644 index 334bb7f..0000000 --- a/slatec/cacos.f +++ /dev/null @@ -1,30 +0,0 @@ -*DECK CACOS - COMPLEX FUNCTION CACOS (Z) -C***BEGIN PROLOGUE CACOS -C***PURPOSE Compute the complex arc cosine. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4A -C***TYPE COMPLEX (CACOS-C) -C***KEYWORDS ARC COSINE, ELEMENTARY FUNCTIONS, FNLIB, TRIGONOMETRIC -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C CACOS(Z) calculates the complex trigonometric arc cosine of Z. -C The result is in units of radians, and the real part is in the -C first or second quadrant. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CASIN -C***REVISION HISTORY (YYMMDD) -C 770401 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CACOS - COMPLEX Z, CASIN - SAVE PI2 - DATA PI2 /1.5707963267 9489661923E0/ -C***FIRST EXECUTABLE STATEMENT CACOS - CACOS = PI2 - CASIN (Z) -C - RETURN - END diff --git a/slatec/cacosh.f b/slatec/cacosh.f deleted file mode 100644 index 1a8744b..0000000 --- a/slatec/cacosh.f +++ /dev/null @@ -1,29 +0,0 @@ -*DECK CACOSH - COMPLEX FUNCTION CACOSH (Z) -C***BEGIN PROLOGUE CACOSH -C***PURPOSE Compute the arc hyperbolic cosine. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4C -C***TYPE COMPLEX (ACOSH-S, DACOSH-D, CACOSH-C) -C***KEYWORDS ACOSH, ARC HYPERBOLIC COSINE, ELEMENTARY FUNCTIONS, FNLIB, -C INVERSE HYPERBOLIC COSINE -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C CACOSH(Z) calculates the complex arc hyperbolic cosine of Z. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CACOS -C***REVISION HISTORY (YYMMDD) -C 770401 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CACOSH - COMPLEX Z, CI, CACOS - SAVE CI - DATA CI /(0.,1.)/ -C***FIRST EXECUTABLE STATEMENT CACOSH - CACOSH = CI*CACOS(Z) -C - RETURN - END diff --git a/slatec/cairy.f b/slatec/cairy.f deleted file mode 100644 index 4fe2f7e..0000000 --- a/slatec/cairy.f +++ /dev/null @@ -1,342 +0,0 @@ -*DECK CAIRY - SUBROUTINE CAIRY (Z, ID, KODE, AI, NZ, IERR) -C***BEGIN PROLOGUE CAIRY -C***PURPOSE Compute the Airy function Ai(z) or its derivative dAi/dz -C for complex argument z. A scaling option is available -C to help avoid underflow and overflow. -C***LIBRARY SLATEC -C***CATEGORY C10D -C***TYPE COMPLEX (CAIRY-C, ZAIRY-C) -C***KEYWORDS AIRY FUNCTION, BESSEL FUNCTION OF ORDER ONE THIRD, -C BESSEL FUNCTION OF ORDER TWO THIRDS -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C On KODE=1, CAIRY computes the complex Airy function Ai(z) -C or its derivative dAi/dz on ID=0 or ID=1 respectively. On -C KODE=2, a scaling option exp(zeta)*Ai(z) or exp(zeta)*dAi/dz -C is provided to remove the exponential decay in -pi/31 and from power series when abs(z)<=1. -C -C In most complex variable computation, one must evaluate ele- -C mentary functions. When the magnitude of Z is large, losses -C of significance by argument reduction occur. Consequently, if -C the magnitude of ZETA=(2/3)*Z**(3/2) exceeds U1=SQRT(0.5/UR), -C then losses exceeding half precision are likely and an error -C flag IERR=3 is triggered where UR=R1MACH(4)=UNIT ROUNDOFF. -C Also, if the magnitude of ZETA is larger than U2=0.5/UR, then -C all significance is lost and IERR=4. In order to use the INT -C function, ZETA must be further restricted not to exceed -C U3=I1MACH(9)=LARGEST INTEGER. Thus, the magnitude of ZETA -C must be restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, -C and U3 are approximately 2.0E+3, 4.2E+6, 2.1E+9 in single -C precision and 4.7E+7, 2.3E+15, 2.1E+9 in double precision. -C This makes U2 limiting is single precision and U3 limiting -C in double precision. This means that the magnitude of Z -C cannot exceed approximately 3.4E+4 in single precision and -C 2.1E+6 in double precision. This also means that one can -C expect to retain, in the worst cases on 32-bit machines, -C no digits in single precision and only 6 digits in double -C precision. -C -C The approximate relative error in the magnitude of a complex -C Bessel function can be expressed as P*10**S where P=MAX(UNIT -C ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- -C sents the increase in error due to argument reduction in the -C elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), -C ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF -C ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may -C have only absolute accuracy. This is most likely to occur -C when one component (in magnitude) is larger than the other by -C several orders of magnitude. If one component is 10**K larger -C than the other, then one can expect only MAX(ABS(LOG10(P))-K, -C 0) significant digits; or, stated another way, when K exceeds -C the exponent of P, no significant digits remain in the smaller -C component. However, the phase angle retains absolute accuracy -C because, in complex arithmetic with precision P, the smaller -C component will not (as a rule) decrease below P times the -C magnitude of the larger component. In these extreme cases, -C the principal phase angle is on the order of +P, -P, PI/2-P, -C or -PI/2+P. -C -C***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- -C matical Functions, National Bureau of Standards -C Applied Mathematics Series 55, U. S. Department -C of Commerce, Tenth Printing (1972) or later. -C 2. D. E. Amos, Computation of Bessel Functions of -C Complex Argument and Large Order, Report SAND83-0643, -C Sandia National Laboratories, Albuquerque, NM, May -C 1983. -C 3. D. E. Amos, A Subroutine Package for Bessel Functions -C of a Complex Argument and Nonnegative Order, Report -C SAND85-1018, Sandia National Laboratory, Albuquerque, -C NM, May 1985. -C 4. D. E. Amos, A portable package for Bessel functions -C of a complex argument and nonnegative order, ACM -C Transactions on Mathematical Software, 12 (September -C 1986), pp. 265-273. -C -C***ROUTINES CALLED CACAI, CBKNU, I1MACH, R1MACH -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 890801 REVISION DATE from Version 3.2 -C 910415 Prologue converted to Version 4.0 format. (BAB) -C 920128 Category corrected. (WRB) -C 920811 Prologue revised. (DWL) -C***END PROLOGUE CAIRY - COMPLEX AI, CONE, CSQ, CY, S1, S2, TRM1, TRM2, Z, ZTA, Z3 - REAL AA, AD, AK, ALIM, ATRM, AZ, AZ3, BK, CK, COEF, C1, C2, DIG, - * DK, D1, D2, ELIM, FID, FNU, RL, R1M5, SFAC, TOL, TTH, ZI, ZR, - * Z3I, Z3R, R1MACH, BB, ALAZ - INTEGER ID, IERR, IFLAG, K, KODE, K1, K2, MR, NN, NZ, I1MACH - DIMENSION CY(1) - DATA TTH, C1, C2, COEF /6.66666666666666667E-01, - * 3.55028053887817240E-01,2.58819403792806799E-01, - * 1.83776298473930683E-01/ - DATA CONE / (1.0E0,0.0E0) / -C***FIRST EXECUTABLE STATEMENT CAIRY - IERR = 0 - NZ=0 - IF (ID.LT.0 .OR. ID.GT.1) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (IERR.NE.0) RETURN - AZ = ABS(Z) - TOL = MAX(R1MACH(4),1.0E-18) - FID = ID - IF (AZ.GT.1.0E0) GO TO 60 -C----------------------------------------------------------------------- -C POWER SERIES FOR ABS(Z).LE.1. -C----------------------------------------------------------------------- - S1 = CONE - S2 = CONE - IF (AZ.LT.TOL) GO TO 160 - AA = AZ*AZ - IF (AA.LT.TOL/AZ) GO TO 40 - TRM1 = CONE - TRM2 = CONE - ATRM = 1.0E0 - Z3 = Z*Z*Z - AZ3 = AZ*AA - AK = 2.0E0 + FID - BK = 3.0E0 - FID - FID - CK = 4.0E0 - FID - DK = 3.0E0 + FID + FID - D1 = AK*DK - D2 = BK*CK - AD = MIN(D1,D2) - AK = 24.0E0 + 9.0E0*FID - BK = 30.0E0 - 9.0E0*FID - Z3R = REAL(Z3) - Z3I = AIMAG(Z3) - DO 30 K=1,25 - TRM1 = TRM1*CMPLX(Z3R/D1,Z3I/D1) - S1 = S1 + TRM1 - TRM2 = TRM2*CMPLX(Z3R/D2,Z3I/D2) - S2 = S2 + TRM2 - ATRM = ATRM*AZ3/AD - D1 = D1 + AK - D2 = D2 + BK - AD = MIN(D1,D2) - IF (ATRM.LT.TOL*AD) GO TO 40 - AK = AK + 18.0E0 - BK = BK + 18.0E0 - 30 CONTINUE - 40 CONTINUE - IF (ID.EQ.1) GO TO 50 - AI = S1*CMPLX(C1,0.0E0) - Z*S2*CMPLX(C2,0.0E0) - IF (KODE.EQ.1) RETURN - ZTA = Z*CSQRT(Z)*CMPLX(TTH,0.0E0) - AI = AI*CEXP(ZTA) - RETURN - 50 CONTINUE - AI = -S2*CMPLX(C2,0.0E0) - IF (AZ.GT.TOL) AI = AI + Z*Z*S1*CMPLX(C1/(1.0E0+FID),0.0E0) - IF (KODE.EQ.1) RETURN - ZTA = Z*CSQRT(Z)*CMPLX(TTH,0.0E0) - AI = AI*CEXP(ZTA) - RETURN -C----------------------------------------------------------------------- -C CASE FOR ABS(Z).GT.1.0 -C----------------------------------------------------------------------- - 60 CONTINUE - FNU = (1.0E0+FID)/3.0E0 -C----------------------------------------------------------------------- -C SET PARAMETERS RELATED TO MACHINE CONSTANTS. -C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. -C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. -C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND -C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR -C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. -C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. -C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). -C----------------------------------------------------------------------- - K1 = I1MACH(12) - K2 = I1MACH(13) - R1M5 = R1MACH(5) - K = MIN(ABS(K1),ABS(K2)) - ELIM = 2.303E0*(K*R1M5-3.0E0) - K1 = I1MACH(11) - 1 - AA = R1M5*K1 - DIG = MIN(AA,18.0E0) - AA = AA*2.303E0 - ALIM = ELIM + MAX(-AA,-41.45E0) - RL = 1.2E0*DIG + 3.0E0 - ALAZ=ALOG(AZ) -C----------------------------------------------------------------------- -C TEST FOR RANGE -C----------------------------------------------------------------------- - AA=0.5E0/TOL - BB=I1MACH(9)*0.5E0 - AA=MIN(AA,BB) - AA=AA**TTH - IF (AZ.GT.AA) GO TO 260 - AA=SQRT(AA) - IF (AZ.GT.AA) IERR=3 - CSQ=CSQRT(Z) - ZTA=Z*CSQ*CMPLX(TTH,0.0E0) -C----------------------------------------------------------------------- -C RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL -C----------------------------------------------------------------------- - IFLAG = 0 - SFAC = 1.0E0 - ZI = AIMAG(Z) - ZR = REAL(Z) - AK = AIMAG(ZTA) - IF (ZR.GE.0.0E0) GO TO 70 - BK = REAL(ZTA) - CK = -ABS(BK) - ZTA = CMPLX(CK,AK) - 70 CONTINUE - IF (ZI.NE.0.0E0) GO TO 80 - IF (ZR.GT.0.0E0) GO TO 80 - ZTA = CMPLX(0.0E0,AK) - 80 CONTINUE - AA = REAL(ZTA) - IF (AA.GE.0.0E0 .AND. ZR.GT.0.0E0) GO TO 100 - IF (KODE.EQ.2) GO TO 90 -C----------------------------------------------------------------------- -C OVERFLOW TEST -C----------------------------------------------------------------------- - IF (AA.GT.(-ALIM)) GO TO 90 - AA = -AA + 0.25E0*ALAZ - IFLAG = 1 - SFAC = TOL - IF (AA.GT.ELIM) GO TO 240 - 90 CONTINUE -C----------------------------------------------------------------------- -C CBKNU AND CACAI RETURN EXP(ZTA)*K(FNU,ZTA) ON KODE=2 -C----------------------------------------------------------------------- - MR = 1 - IF (ZI.LT.0.0E0) MR = -1 - CALL CACAI(ZTA, FNU, KODE, MR, 1, CY, NN, RL, TOL, ELIM, ALIM) - IF (NN.LT.0) GO TO 250 - NZ = NZ + NN - GO TO 120 - 100 CONTINUE - IF (KODE.EQ.2) GO TO 110 -C----------------------------------------------------------------------- -C UNDERFLOW TEST -C----------------------------------------------------------------------- - IF (AA.LT.ALIM) GO TO 110 - AA = -AA - 0.25E0*ALAZ - IFLAG = 2 - SFAC = 1.0E0/TOL - IF (AA.LT.(-ELIM)) GO TO 180 - 110 CONTINUE - CALL CBKNU(ZTA, FNU, KODE, 1, CY, NZ, TOL, ELIM, ALIM) - 120 CONTINUE - S1 = CY(1)*CMPLX(COEF,0.0E0) - IF (IFLAG.NE.0) GO TO 140 - IF (ID.EQ.1) GO TO 130 - AI = CSQ*S1 - RETURN - 130 AI = -Z*S1 - RETURN - 140 CONTINUE - S1 = S1*CMPLX(SFAC,0.0E0) - IF (ID.EQ.1) GO TO 150 - S1 = S1*CSQ - AI = S1*CMPLX(1.0E0/SFAC,0.0E0) - RETURN - 150 CONTINUE - S1 = -S1*Z - AI = S1*CMPLX(1.0E0/SFAC,0.0E0) - RETURN - 160 CONTINUE - AA = 1.0E+3*R1MACH(1) - S1 = CMPLX(0.0E0,0.0E0) - IF (ID.EQ.1) GO TO 170 - IF (AZ.GT.AA) S1 = CMPLX(C2,0.0E0)*Z - AI = CMPLX(C1,0.0E0) - S1 - RETURN - 170 CONTINUE - AI = -CMPLX(C2,0.0E0) - AA = SQRT(AA) - IF (AZ.GT.AA) S1 = Z*Z*CMPLX(0.5E0,0.0E0) - AI = AI + S1*CMPLX(C1,0.0E0) - RETURN - 180 CONTINUE - NZ = 1 - AI = CMPLX(0.0E0,0.0E0) - RETURN - 240 CONTINUE - NZ = 0 - IERR=2 - RETURN - 250 CONTINUE - IF(NN.EQ.(-1)) GO TO 240 - NZ=0 - IERR=5 - RETURN - 260 CONTINUE - IERR=4 - NZ=0 - RETURN - END diff --git a/slatec/carg.f b/slatec/carg.f deleted file mode 100644 index f6e44aa..0000000 --- a/slatec/carg.f +++ /dev/null @@ -1,31 +0,0 @@ -*DECK CARG - FUNCTION CARG (Z) -C***BEGIN PROLOGUE CARG -C***PURPOSE Compute the argument of a complex number. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY A4A -C***TYPE COMPLEX (CARG-C) -C***KEYWORDS ARGUMENT OF A COMPLEX NUMBER, ELEMENTARY FUNCTIONS, FNLIB -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C CARG(Z) calculates the argument of the complex number Z. Note -C that CARG returns a real result. If Z = X+iY, then CARG is ATAN(Y/X), -C except when both X and Y are zero, in which case the result -C will be zero. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 770401 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CARG - COMPLEX Z -C***FIRST EXECUTABLE STATEMENT CARG - CARG = 0.0 - IF (REAL(Z).NE.0. .OR. AIMAG(Z).NE.0.) CARG = - 1 ATAN2 (AIMAG(Z), REAL(Z)) -C - RETURN - END diff --git a/slatec/casin.f b/slatec/casin.f deleted file mode 100644 index 53cdce8..0000000 --- a/slatec/casin.f +++ /dev/null @@ -1,66 +0,0 @@ -*DECK CASIN - COMPLEX FUNCTION CASIN (ZINP) -C***BEGIN PROLOGUE CASIN -C***PURPOSE Compute the complex arc sine. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4A -C***TYPE COMPLEX (CASIN-C) -C***KEYWORDS ARC SINE, ELEMENTARY FUNCTIONS, FNLIB, TRIGONOMETRIC -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C CASIN(ZINP) calculates the complex trigonometric arc sine of ZINP. -C The result is in units of radians, and the real part is in the first -C or fourth quadrant. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH -C***REVISION HISTORY (YYMMDD) -C 770701 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***END PROLOGUE CASIN - COMPLEX ZINP, Z, Z2, SQZP1, CI - LOGICAL FIRST - SAVE PI2, PI, CI, NTERMS, RMIN, FIRST - DATA PI2 /1.5707963267 9489661923E0/ - DATA PI /3.1415926535 8979324E0/ - DATA CI /(0.,1.)/ - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT CASIN - IF (FIRST) THEN -C NTERMS = LOG(EPS)/LOG(RMAX) WHERE RMAX = 0.1 - NTERMS = -0.4343*LOG(R1MACH(3)) - RMIN = SQRT (6.0*R1MACH(3)) - ENDIF - FIRST = .FALSE. -C - Z = ZINP - R = ABS (Z) - IF (R.GT.0.1) GO TO 30 -C - CASIN = Z - IF (R.LT.RMIN) RETURN -C - CASIN = (0.0, 0.0) - Z2 = Z*Z - DO 20 I=1,NTERMS - TWOI = 2*(NTERMS-I) + 1 - CASIN = 1.0/TWOI + TWOI*CASIN*Z2/(TWOI+1.0) - 20 CONTINUE - CASIN = Z*CASIN - RETURN -C - 30 IF (REAL(ZINP).LT.0.0) Z = -ZINP -C - SQZP1 = SQRT (Z+1.0) - IF (AIMAG(SQZP1).LT.0.) SQZP1 = -SQZP1 - CASIN = PI2 - CI * LOG (Z + SQZP1*SQRT(Z-1.0)) -C - IF (REAL(CASIN).GT.PI2) CASIN = PI - CASIN - IF (REAL(CASIN).LE.(-PI2)) CASIN = -PI - CASIN - IF (REAL(ZINP).LT.0.) CASIN = -CASIN -C - RETURN - END diff --git a/slatec/casinh.f b/slatec/casinh.f deleted file mode 100644 index 1c00b62..0000000 --- a/slatec/casinh.f +++ /dev/null @@ -1,29 +0,0 @@ -*DECK CASINH - COMPLEX FUNCTION CASINH (Z) -C***BEGIN PROLOGUE CASINH -C***PURPOSE Compute the arc hyperbolic sine. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4C -C***TYPE COMPLEX (ASINH-S, DASINH-D, CASINH-C) -C***KEYWORDS ARC HYPERBOLIC SINE, ASINH, ELEMENTARY FUNCTIONS, FNLIB, -C INVERSE HYPERBOLIC SINE -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C CASINH(Z) calculates the complex arc hyperbolic sine of Z. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CASIN -C***REVISION HISTORY (YYMMDD) -C 770401 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CASINH - COMPLEX Z, CI, CASIN - SAVE CI - DATA CI /(0.,1.)/ -C***FIRST EXECUTABLE STATEMENT CASINH - CASINH = -CI*CASIN (CI*Z) -C - RETURN - END diff --git a/slatec/casyi.f b/slatec/casyi.f deleted file mode 100644 index fdb2ee2..0000000 --- a/slatec/casyi.f +++ /dev/null @@ -1,136 +0,0 @@ -*DECK CASYI - SUBROUTINE CASYI (Z, FNU, KODE, N, Y, NZ, RL, TOL, ELIM, ALIM) -C***BEGIN PROLOGUE CASYI -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBESI and CBESK -C***LIBRARY SLATEC -C***TYPE ALL (CASYI-A, ZASYI-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C CASYI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY -C MEANS OF THE ASYMPTOTIC EXPANSION FOR LARGE ABS(Z) IN THE -C REGION ABS(Z).GT.MAX(RL,FNU*FNU/2). NZ=0 IS A NORMAL RETURN. -C NZ.LT.0 INDICATES AN OVERFLOW ON KODE=1. -C -C***SEE ALSO CBESI, CBESK -C***ROUTINES CALLED R1MACH -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CASYI - COMPLEX AK1, CK, CONE, CS1, CS2, CZ, CZERO, DK, EZ, P1, RZ, S2, - * Y, Z - REAL AA, ACZ, AEZ, AK, ALIM, ARG, ARM, ATOL, AZ, BB, BK, DFNU, - * DNU2, ELIM, FDN, FNU, PI, RL, RTPI, RTR1, S, SGN, SQK, TOL, X, - * YY, R1MACH - INTEGER I, IB, IL, INU, J, JL, K, KODE, KODED, M, N, NN, NZ - DIMENSION Y(N) - DATA PI, RTPI /3.14159265358979324E0 , 0.159154943091895336E0 / - DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) / -C***FIRST EXECUTABLE STATEMENT CASYI - NZ = 0 - AZ = ABS(Z) - X = REAL(Z) - ARM = 1.0E+3*R1MACH(1) - RTR1 = SQRT(ARM) - IL = MIN(2,N) - DFNU = FNU + (N-IL) -C----------------------------------------------------------------------- -C OVERFLOW TEST -C----------------------------------------------------------------------- - AK1 = CMPLX(RTPI,0.0E0)/Z - AK1 = CSQRT(AK1) - CZ = Z - IF (KODE.EQ.2) CZ = Z - CMPLX(X,0.0E0) - ACZ = REAL(CZ) - IF (ABS(ACZ).GT.ELIM) GO TO 80 - DNU2 = DFNU + DFNU - KODED = 1 - IF ((ABS(ACZ).GT.ALIM) .AND. (N.GT.2)) GO TO 10 - KODED = 0 - AK1 = AK1*CEXP(CZ) - 10 CONTINUE - FDN = 0.0E0 - IF (DNU2.GT.RTR1) FDN = DNU2*DNU2 - EZ = Z*CMPLX(8.0E0,0.0E0) -C----------------------------------------------------------------------- -C WHEN Z IS IMAGINARY, THE ERROR TEST MUST BE MADE RELATIVE TO THE -C FIRST RECIPROCAL POWER SINCE THIS IS THE LEADING TERM OF THE -C EXPANSION FOR THE IMAGINARY PART. -C----------------------------------------------------------------------- - AEZ = 8.0E0*AZ - S = TOL/AEZ - JL = RL+RL + 2 - YY = AIMAG(Z) - P1 = CZERO - IF (YY.EQ.0.0E0) GO TO 20 -C----------------------------------------------------------------------- -C CALCULATE EXP(PI*(0.5+FNU+N-IL)*I) TO MINIMIZE LOSSES OF -C SIGNIFICANCE WHEN FNU OR N IS LARGE -C----------------------------------------------------------------------- - INU = FNU - ARG = (FNU-INU)*PI - INU = INU + N - IL - AK = -SIN(ARG) - BK = COS(ARG) - IF (YY.LT.0.0E0) BK = -BK - P1 = CMPLX(AK,BK) - IF (MOD(INU,2).EQ.1) P1 = -P1 - 20 CONTINUE - DO 50 K=1,IL - SQK = FDN - 1.0E0 - ATOL = S*ABS(SQK) - SGN = 1.0E0 - CS1 = CONE - CS2 = CONE - CK = CONE - AK = 0.0E0 - AA = 1.0E0 - BB = AEZ - DK = EZ - DO 30 J=1,JL - CK = CK*CMPLX(SQK,0.0E0)/DK - CS2 = CS2 + CK - SGN = -SGN - CS1 = CS1 + CK*CMPLX(SGN,0.0E0) - DK = DK + EZ - AA = AA*ABS(SQK)/BB - BB = BB + AEZ - AK = AK + 8.0E0 - SQK = SQK - AK - IF (AA.LE.ATOL) GO TO 40 - 30 CONTINUE - GO TO 90 - 40 CONTINUE - S2 = CS1 - IF (X+X.LT.ELIM) S2 = S2 + P1*CS2*CEXP(-Z-Z) - FDN = FDN + 8.0E0*DFNU + 4.0E0 - P1 = -P1 - M = N - IL + K - Y(M) = S2*AK1 - 50 CONTINUE - IF (N.LE.2) RETURN - NN = N - K = NN - 2 - AK = K - RZ = (CONE+CONE)/Z - IB = 3 - DO 60 I=IB,NN - Y(K) = CMPLX(AK+FNU,0.0E0)*RZ*Y(K+1) + Y(K+2) - AK = AK - 1.0E0 - K = K - 1 - 60 CONTINUE - IF (KODED.EQ.0) RETURN - CK = CEXP(CZ) - DO 70 I=1,NN - Y(I) = Y(I)*CK - 70 CONTINUE - RETURN - 80 CONTINUE - NZ = -1 - RETURN - 90 CONTINUE - NZ=-2 - RETURN - END diff --git a/slatec/catan.f b/slatec/catan.f deleted file mode 100644 index 4cdf33b..0000000 --- a/slatec/catan.f +++ /dev/null @@ -1,76 +0,0 @@ -*DECK CATAN - COMPLEX FUNCTION CATAN (Z) -C***BEGIN PROLOGUE CATAN -C***PURPOSE Compute the complex arc tangent. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4A -C***TYPE COMPLEX (CATAN-C) -C***KEYWORDS ARC TANGENT, ELEMENTARY FUNCTIONS, FNLIB, TRIGONOMETRIC -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C CATAN(Z) calculates the complex trigonometric arc tangent of Z. -C The result is in units of radians, and the real part is in the first -C or fourth quadrant. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770801 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE CATAN - COMPLEX Z, Z2 - LOGICAL FIRST - SAVE PI2, NTERMS, SQEPS, RMIN, RMAX, FIRST - DATA PI2 / 1.5707963267 9489661923E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT CATAN - IF (FIRST) THEN -C NTERMS = LOG(EPS)/LOG(RBND) WHERE RBND = 0.1 - NTERMS = -0.4343*LOG(R1MACH(3)) + 1.0 - SQEPS = SQRT(R1MACH(4)) - RMIN = SQRT (3.0*R1MACH(3)) - RMAX = 1.0/R1MACH(3) - ENDIF - FIRST = .FALSE. -C - R = ABS(Z) - IF (R.GT.0.1) GO TO 30 -C - CATAN = Z - IF (R.LT.RMIN) RETURN -C - CATAN = (0.0, 0.0) - Z2 = Z*Z - DO 20 I=1,NTERMS - TWOI = 2*(NTERMS-I) + 1 - CATAN = 1.0/TWOI - Z2*CATAN - 20 CONTINUE - CATAN = Z*CATAN - RETURN -C - 30 IF (R.GT.RMAX) GO TO 50 - X = REAL(Z) - Y = AIMAG(Z) - R2 = R*R - IF (R2 .EQ. 1.0 .AND. X .EQ. 0.0) CALL XERMSG ('SLATEC', 'CATAN', - + 'Z IS +I OR -I', 2, 2) - IF (ABS(R2-1.0).GT.SQEPS) GO TO 40 - IF (ABS(CMPLX(1.0, 0.0)+Z*Z) .LT. SQEPS) CALL XERMSG ('SLATEC', - + 'CATAN', 'ANSWER LT HALF PRECISION, Z**2 CLOSE TO -1', 1, 1) -C - 40 XANS = 0.5*ATAN2(2.0*X, 1.0-R2) - YANS = 0.25*LOG((R2+2.0*Y+1.0)/(R2-2.0*Y+1.0)) - CATAN = CMPLX (XANS, YANS) - RETURN -C - 50 CATAN = CMPLX (PI2, 0.) - IF (REAL(Z).LT.0.0) CATAN = CMPLX(-PI2,0.0) - RETURN -C - END diff --git a/slatec/catan2.f b/slatec/catan2.f deleted file mode 100644 index 57197f8..0000000 --- a/slatec/catan2.f +++ /dev/null @@ -1,47 +0,0 @@ -*DECK CATAN2 - COMPLEX FUNCTION CATAN2 (CSN, CCS) -C***BEGIN PROLOGUE CATAN2 -C***PURPOSE Compute the complex arc tangent in the proper quadrant. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4A -C***TYPE COMPLEX (CATAN2-C) -C***KEYWORDS ARC TANGENT, ELEMENTARY FUNCTIONS, FNLIB, POLAR ANGEL, -C QUADRANT, TRIGONOMETRIC -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C CATAN2(CSN,CCS) calculates the complex trigonometric arc -C tangent of the ratio CSN/CCS and returns a result whose real -C part is in the correct quadrant (within a multiple of 2*PI). The -C result is in units of radians and the real part is between -PI -C and +PI. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CATAN, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE CATAN2 - COMPLEX CSN, CCS, CATAN - SAVE PI - DATA PI / 3.1415926535 8979323846E0 / -C***FIRST EXECUTABLE STATEMENT CATAN2 - IF (ABS(CCS).EQ.0.) GO TO 10 -C - CATAN2 = CATAN (CSN/CCS) - IF (REAL(CCS).LT.0.) CATAN2 = CATAN2 + PI - IF (REAL(CATAN2).GT.PI) CATAN2 = CATAN2 - 2.0*PI - RETURN -C - 10 IF (ABS(CSN) .EQ. 0.) CALL XERMSG ('SLATEC', 'CATAN2', - + 'CALLED WITH BOTH ARGUMENTS ZERO', 1, 2) -C - CATAN2 = CMPLX (SIGN(0.5*PI,REAL(CSN)), 0.0) -C - RETURN - END diff --git a/slatec/catanh.f b/slatec/catanh.f deleted file mode 100644 index 5e1745f..0000000 --- a/slatec/catanh.f +++ /dev/null @@ -1,29 +0,0 @@ -*DECK CATANH - COMPLEX FUNCTION CATANH (Z) -C***BEGIN PROLOGUE CATANH -C***PURPOSE Compute the arc hyperbolic tangent. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4C -C***TYPE COMPLEX (ATANH-S, DATANH-D, CATANH-C) -C***KEYWORDS ARC HYPERBOLIC TANGENT, ATANH, ELEMENTARY FUNCTIONS, -C FNLIB, INVERSE HYPERBOLIC TANGENT -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C CATANH(Z) calculates the complex arc hyperbolic tangent of Z. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CATAN -C***REVISION HISTORY (YYMMDD) -C 770401 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CATANH - COMPLEX Z, CI, CATAN - SAVE CI - DATA CI /(0.,1.)/ -C***FIRST EXECUTABLE STATEMENT CATANH - CATANH = -CI*CATAN(CI*Z) -C - RETURN - END diff --git a/slatec/caxpy.f b/slatec/caxpy.f deleted file mode 100644 index 648e788..0000000 --- a/slatec/caxpy.f +++ /dev/null @@ -1,73 +0,0 @@ -*DECK CAXPY - SUBROUTINE CAXPY (N, CA, CX, INCX, CY, INCY) -C***BEGIN PROLOGUE CAXPY -C***PURPOSE Compute a constant times a vector plus a vector. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A7 -C***TYPE COMPLEX (SAXPY-S, DAXPY-D, CAXPY-C) -C***KEYWORDS BLAS, LINEAR ALGEBRA, TRIAD, 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 CA complex scalar multiplier -C CX complex vector with N elements -C INCX storage spacing between elements of CX -C CY complex vector with N elements -C INCY storage spacing between elements of CY -C -C --Output-- -C CY complex result (unchanged if N .LE. 0) -C -C Overwrite complex CY with complex CA*CX + CY. -C For I = 0 to N-1, replace CY(LY+I*INCY) with CA*CX(LX+I*INCX) + -C CY(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 861211 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 920801 Removed variable CANORM. (RWC, WRB) -C***END PROLOGUE CAXPY - COMPLEX CX(*), CY(*), CA -C***FIRST EXECUTABLE STATEMENT CAXPY - IF (N.LE.0 .OR. CA.EQ.(0.0E0,0.0E0)) 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 - CY(KY) = CY(KY) + CA*CX(KX) - 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 - CY(I) = CA*CX(I) + CY(I) - 30 CONTINUE - RETURN - END diff --git a/slatec/cbabk2.f b/slatec/cbabk2.f deleted file mode 100644 index e421915..0000000 --- a/slatec/cbabk2.f +++ /dev/null @@ -1,108 +0,0 @@ -*DECK CBABK2 - SUBROUTINE CBABK2 (NM, N, LOW, IGH, SCALE, M, ZR, ZI) -C***BEGIN PROLOGUE CBABK2 -C***PURPOSE Form the eigenvectors of a complex general matrix from the -C eigenvectors of matrix output from CBAL. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C4 -C***TYPE COMPLEX (BALBAK-S, CBABK2-C) -C***KEYWORDS EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure -C CBABK2, which is a complex version of BALBAK, -C NUM. MATH. 13, 293-304(1969) by Parlett and Reinsch. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). -C -C This subroutine forms the eigenvectors of a COMPLEX GENERAL -C matrix by back transforming those of the corresponding -C balanced matrix determined by CBAL. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, ZR and ZI, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix Z=(ZR,ZI). N is an INTEGER -C variable. N must be less than or equal to NM. -C -C LOW and IGH are INTEGER variables determined by CBAL. -C -C SCALE contains information determining the permutations and -C scaling factors used by CBAL. SCALE is a one-dimensional -C REAL array, dimensioned SCALE(N). -C -C M is the number of eigenvectors to be back transformed. -C M is an INTEGER variable. -C -C ZR and ZI contain the real and imaginary parts, respectively, -C of the eigenvectors to be back transformed in their first -C M columns. ZR and ZI are two-dimensional REAL arrays, -C dimensioned ZR(NM,M) and ZI(NM,M). -C -C On OUTPUT -C -C ZR and ZI contain the real and imaginary parts, -C respectively, of the transformed eigenvectors -C in their first M columns. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CBABK2 -C - INTEGER I,J,K,M,N,II,NM,IGH,LOW - REAL SCALE(*),ZR(NM,*),ZI(NM,*) - REAL S -C -C***FIRST EXECUTABLE STATEMENT CBABK2 - IF (M .EQ. 0) GO TO 200 - IF (IGH .EQ. LOW) GO TO 120 -C - DO 110 I = LOW, IGH - S = SCALE(I) -C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED -C IF THE FOREGOING STATEMENT IS REPLACED BY -C S=1.0E0/SCALE(I). .......... - DO 100 J = 1, M - ZR(I,J) = ZR(I,J) * S - ZI(I,J) = ZI(I,J) * S - 100 CONTINUE -C - 110 CONTINUE -C .......... FOR I=LOW-1 STEP -1 UNTIL 1, -C IGH+1 STEP 1 UNTIL N DO -- .......... - 120 DO 140 II = 1, N - I = II - IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140 - IF (I .LT. LOW) I = LOW - II - K = SCALE(I) - IF (K .EQ. I) GO TO 140 -C - DO 130 J = 1, M - S = ZR(I,J) - ZR(I,J) = ZR(K,J) - ZR(K,J) = S - S = ZI(I,J) - ZI(I,J) = ZI(K,J) - ZI(K,J) = S - 130 CONTINUE -C - 140 CONTINUE -C - 200 RETURN - END diff --git a/slatec/cbal.f b/slatec/cbal.f deleted file mode 100644 index 70c07af..0000000 --- a/slatec/cbal.f +++ /dev/null @@ -1,207 +0,0 @@ -*DECK CBAL - SUBROUTINE CBAL (NM, N, AR, AI, LOW, IGH, SCALE) -C***BEGIN PROLOGUE CBAL -C***PURPOSE Balance a complex general matrix and isolate eigenvalues -C whenever possible. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C1A -C***TYPE COMPLEX (BALANC-S, CBAL-C) -C***KEYWORDS EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure -C CBALANCE, which is a complex version of BALANCE, -C NUM. MATH. 13, 293-304(1969) by Parlett and Reinsch. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). -C -C This subroutine balances a COMPLEX matrix and isolates -C eigenvalues whenever possible. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, AR and AI, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix A=(AR,AI). N is an INTEGER -C variable. N must be less than or equal to NM. -C -C AR and AI contain the real and imaginary parts, -C respectively, of the complex matrix to be balanced. -C AR and AI are two-dimensional REAL arrays, dimensioned -C AR(NM,N) and AI(NM,N). -C -C On OUTPUT -C -C AR and AI contain the real and imaginary parts, -C respectively, of the balanced matrix. -C -C LOW and IGH are two INTEGER variables such that AR(I,J) -C and AI(I,J) are equal to zero if -C (1) I is greater than J and -C (2) J=1,...,LOW-1 or I=IGH+1,...,N. -C -C SCALE contains information determining the permutations and -C scaling factors used. SCALE is a one-dimensional REAL array, -C dimensioned SCALE(N). -C -C Suppose that the principal submatrix in rows LOW through IGH -C has been balanced, that P(J) denotes the index interchanged -C with J during the permutation step, and that the elements -C of the diagonal matrix used are denoted by D(I,J). Then -C SCALE(J) = P(J), for J = 1,...,LOW-1 -C = D(J,J) J = LOW,...,IGH -C = P(J) J = IGH+1,...,N. -C The order in which the interchanges are made is N to IGH+1, -C then 1 to LOW-1. -C -C Note that 1 is returned for IGH if IGH is zero formally. -C -C The ALGOL procedure EXC contained in CBALANCE appears in -C CBAL in line. (Note that the ALGOL roles of identifiers -C K,L have been reversed.) -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CBAL -C - INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC - REAL AR(NM,*),AI(NM,*),SCALE(*) - REAL C,F,G,R,S,B2,RADIX - LOGICAL NOCONV -C -C THE FOLLOWING PORTABLE VALUE OF RADIX WORKS WELL ENOUGH -C FOR ALL MACHINES WHOSE BASE IS A POWER OF TWO. -C -C***FIRST EXECUTABLE STATEMENT CBAL - RADIX = 16 -C - B2 = RADIX * RADIX - K = 1 - L = N - GO TO 100 -C .......... IN-LINE PROCEDURE FOR ROW AND -C COLUMN EXCHANGE .......... - 20 SCALE(M) = J - IF (J .EQ. M) GO TO 50 -C - DO 30 I = 1, L - F = AR(I,J) - AR(I,J) = AR(I,M) - AR(I,M) = F - F = AI(I,J) - AI(I,J) = AI(I,M) - AI(I,M) = F - 30 CONTINUE -C - DO 40 I = K, N - F = AR(J,I) - AR(J,I) = AR(M,I) - AR(M,I) = F - F = AI(J,I) - AI(J,I) = AI(M,I) - AI(M,I) = F - 40 CONTINUE -C - 50 GO TO (80,130), IEXC -C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE -C AND PUSH THEM DOWN .......... - 80 IF (L .EQ. 1) GO TO 280 - L = L - 1 -C .......... FOR J=L STEP -1 UNTIL 1 DO -- .......... - 100 DO 120 JJ = 1, L - J = L + 1 - JJ -C - DO 110 I = 1, L - IF (I .EQ. J) GO TO 110 - IF (AR(J,I) .NE. 0.0E0 .OR. AI(J,I) .NE. 0.0E0) GO TO 120 - 110 CONTINUE -C - M = L - IEXC = 1 - GO TO 20 - 120 CONTINUE -C - GO TO 140 -C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE -C AND PUSH THEM LEFT .......... - 130 K = K + 1 -C - 140 DO 170 J = K, L -C - DO 150 I = K, L - IF (I .EQ. J) GO TO 150 - IF (AR(I,J) .NE. 0.0E0 .OR. AI(I,J) .NE. 0.0E0) GO TO 170 - 150 CONTINUE -C - M = K - IEXC = 2 - GO TO 20 - 170 CONTINUE -C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L .......... - DO 180 I = K, L - 180 SCALE(I) = 1.0E0 -C .......... ITERATIVE LOOP FOR NORM REDUCTION .......... - 190 NOCONV = .FALSE. -C - DO 270 I = K, L - C = 0.0E0 - R = 0.0E0 -C - DO 200 J = K, L - IF (J .EQ. I) GO TO 200 - C = C + ABS(AR(J,I)) + ABS(AI(J,I)) - R = R + ABS(AR(I,J)) + ABS(AI(I,J)) - 200 CONTINUE -C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW .......... - IF (C .EQ. 0.0E0 .OR. R .EQ. 0.0E0) GO TO 270 - G = R / RADIX - F = 1.0E0 - S = C + R - 210 IF (C .GE. G) GO TO 220 - F = F * RADIX - C = C * B2 - GO TO 210 - 220 G = R * RADIX - 230 IF (C .LT. G) GO TO 240 - F = F / RADIX - C = C / B2 - GO TO 230 -C .......... NOW BALANCE .......... - 240 IF ((C + R) / F .GE. 0.95E0 * S) GO TO 270 - G = 1.0E0 / F - SCALE(I) = SCALE(I) * F - NOCONV = .TRUE. -C - DO 250 J = K, N - AR(I,J) = AR(I,J) * G - AI(I,J) = AI(I,J) * G - 250 CONTINUE -C - DO 260 J = 1, L - AR(J,I) = AR(J,I) * F - AI(J,I) = AI(J,I) * F - 260 CONTINUE -C - 270 CONTINUE -C - IF (NOCONV) GO TO 190 -C - 280 LOW = K - IGH = L - RETURN - END diff --git a/slatec/cbesh.f b/slatec/cbesh.f deleted file mode 100644 index 448d9db..0000000 --- a/slatec/cbesh.f +++ /dev/null @@ -1,331 +0,0 @@ -*DECK CBESH - SUBROUTINE CBESH (Z, FNU, KODE, M, N, CY, NZ, IERR) -C***BEGIN PROLOGUE CBESH -C***PURPOSE Compute a sequence of the Hankel functions H(m,a,z) -C for superscript m=1 or 2, real nonnegative orders a=b, -C b+1,... where b>0, and nonzero complex argument z. A -C scaling option is available to help avoid overflow. -C***LIBRARY SLATEC -C***CATEGORY C10A4 -C***TYPE COMPLEX (CBESH-C, ZBESH-C) -C***KEYWORDS BESSEL FUNCTIONS OF COMPLEX ARGUMENT, -C BESSEL FUNCTIONS OF THE THIRD KIND, H BESSEL FUNCTIONS, -C HANKEL FUNCTIONS -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C On KODE=1, CBESH computes an N member sequence of complex -C Hankel (Bessel) functions CY(L)=H(M,FNU+L-1,Z) for super- -C script M=1 or 2, real nonnegative orders FNU+L-1, L=1,..., -C N, and complex nonzero Z in the cut plane -pi=0 -C KODE - A parameter to indicate the scaling option -C KODE=1 returns -C CY(L)=H(M,FNU+L-1,Z), L=1,...,N -C =2 returns -C CY(L)=H(M,FNU+L-1,Z)*exp(-(3-2M)*Z*i), -C L=1,...,N -C M - Superscript of Hankel function, M=1 or 2 -C N - Number of terms in the sequence, N>=1 -C -C Output -C CY - Result vector of type COMPLEX -C NZ - Number of underflows set to zero -C NZ=0 Normal return -C NZ>0 CY(L)=0 for NZ values of L (if M=1 and -C Im(Z)>0 or if M=2 and Im(Z)<0, then -C CY(L)=0 for L=1,...,NZ; in the com- -C plementary half planes, the underflows -C may not be in an uninterrupted sequence) -C IERR - Error flag -C IERR=0 Normal return - COMPUTATION COMPLETED -C IERR=1 Input error - NO COMPUTATION -C IERR=2 Overflow - NO COMPUTATION -C (abs(Z) too small and/or FNU+N-1 -C too large) -C IERR=3 Precision warning - COMPUTATION COMPLETED -C (Result has half precision or less -C because abs(Z) or FNU+N-1 is large) -C IERR=4 Precision error - NO COMPUTATION -C (Result has no precision because -C abs(Z) or FNU+N-1 is too large) -C IERR=5 Algorithmic error - NO COMPUTATION -C (Termination condition not met) -C -C *Long Description: -C -C The computation is carried out by the formula -C -C H(m,a,z) = (1/t)*exp(-a*t)*K(a,z*exp(-t)) -C t = (3-2*m)*i*pi/2 -C -C where the K Bessel function is computed as described in the -C prologue to CBESK. -C -C Exponential decay of H(m,a,z) occurs in the upper half z -C plane for m=1 and the lower half z plane for m=2. Exponential -C growth occurs in the complementary half planes. Scaling -C by exp(-(3-2*m)*z*i) removes the exponential behavior in the -C whole z plane as z goes to infinity. -C -C For negative orders, the formula -C -C H(m,-a,z) = H(m,a,z)*exp((3-2*m)*a*pi*i) -C -C can be used. -C -C In most complex variable computation, one must evaluate ele- -C mentary functions. When the magnitude of Z or FNU+N-1 is -C large, losses of significance by argument reduction occur. -C Consequently, if either one exceeds U1=SQRT(0.5/UR), then -C losses exceeding half precision are likely and an error flag -C IERR=3 is triggered where UR=R1MACH(4)=UNIT ROUNDOFF. Also, -C if either is larger than U2=0.5/UR, then all significance is -C lost and IERR=4. In order to use the INT function, arguments -C must be further restricted not to exceed the largest machine -C integer, U3=I1MACH(9). Thus, the magnitude of Z and FNU+N-1 -C is restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, and -C U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision -C and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision. This -C makes U2 limiting in single precision and U3 limiting in -C double precision. This means that one can expect to retain, -C in the worst cases on IEEE machines, no digits in single pre- -C cision and only 6 digits in double precision. Similar con- -C siderations hold for other machines. -C -C The approximate relative error in the magnitude of a complex -C Bessel function can be expressed as P*10**S where P=MAX(UNIT -C ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- -C sents the increase in error due to argument reduction in the -C elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), -C ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF -C ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may -C have only absolute accuracy. This is most likely to occur -C when one component (in magnitude) is larger than the other by -C several orders of magnitude. If one component is 10**K larger -C than the other, then one can expect only MAX(ABS(LOG10(P))-K, -C 0) significant digits; or, stated another way, when K exceeds -C the exponent of P, no significant digits remain in the smaller -C component. However, the phase angle retains absolute accuracy -C because, in complex arithmetic with precision P, the smaller -C component will not (as a rule) decrease below P times the -C magnitude of the larger component. In these extreme cases, -C the principal phase angle is on the order of +P, -P, PI/2-P, -C or -PI/2+P. -C -C***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- -C matical Functions, National Bureau of Standards -C Applied Mathematics Series 55, U. S. Department -C of Commerce, Tenth Printing (1972) or later. -C 2. D. E. Amos, Computation of Bessel Functions of -C Complex Argument, Report SAND83-0086, Sandia National -C Laboratories, Albuquerque, NM, May 1983. -C 3. D. E. Amos, Computation of Bessel Functions of -C Complex Argument and Large Order, Report SAND83-0643, -C Sandia National Laboratories, Albuquerque, NM, May -C 1983. -C 4. D. E. Amos, A Subroutine Package for Bessel Functions -C of a Complex Argument and Nonnegative Order, Report -C SAND85-1018, Sandia National Laboratory, Albuquerque, -C NM, May 1985. -C 5. D. E. Amos, A portable package for Bessel functions -C of a complex argument and nonnegative order, ACM -C Transactions on Mathematical Software, 12 (September -C 1986), pp. 265-273. -C -C***ROUTINES CALLED CACON, CBKNU, CBUNK, CUOIK, I1MACH, R1MACH -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 890801 REVISION DATE from Version 3.2 -C 910415 Prologue converted to Version 4.0 format. (BAB) -C 920128 Category corrected. (WRB) -C 920811 Prologue revised. (DWL) -C***END PROLOGUE CBESH -C - COMPLEX CY, Z, ZN, ZT, CSGN - REAL AA, ALIM, ALN, ARG, AZ, CPN, DIG, ELIM, FMM, FN, FNU, FNUL, - * HPI, RHPI, RL, R1M5, SGN, SPN, TOL, UFL, XN, XX, YN, YY, R1MACH, - * BB, ASCLE, RTOL, ATOL - INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, M, - * MM, MR, N, NN, NUF, NW, NZ, I1MACH - DIMENSION CY(N) -C - DATA HPI /1.57079632679489662E0/ -C -C***FIRST EXECUTABLE STATEMENT CBESH - NZ=0 - XX = REAL(Z) - YY = AIMAG(Z) - IERR = 0 - IF (XX.EQ.0.0E0 .AND. YY.EQ.0.0E0) IERR=1 - IF (FNU.LT.0.0E0) IERR=1 - IF (M.LT.1 .OR. M.GT.2) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (N.LT.1) IERR=1 - IF (IERR.NE.0) RETURN - NN = N -C----------------------------------------------------------------------- -C SET PARAMETERS RELATED TO MACHINE CONSTANTS. -C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. -C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. -C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND -C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR -C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. -C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. -C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). -C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU -C----------------------------------------------------------------------- - TOL = MAX(R1MACH(4),1.0E-18) - K1 = I1MACH(12) - K2 = I1MACH(13) - R1M5 = R1MACH(5) - K = MIN(ABS(K1),ABS(K2)) - ELIM = 2.303E0*(K*R1M5-3.0E0) - K1 = I1MACH(11) - 1 - AA = R1M5*K1 - DIG = MIN(AA,18.0E0) - AA = AA*2.303E0 - ALIM = ELIM + MAX(-AA,-41.45E0) - FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) - RL = 1.2E0*DIG + 3.0E0 - FN = FNU + (NN-1) - MM = 3 - M - M - FMM = MM - ZN = Z*CMPLX(0.0E0,-FMM) - XN = REAL(ZN) - YN = AIMAG(ZN) - AZ = ABS(Z) -C----------------------------------------------------------------------- -C TEST FOR RANGE -C----------------------------------------------------------------------- - AA = 0.5E0/TOL - BB=I1MACH(9)*0.5E0 - AA=MIN(AA,BB) - IF(AZ.GT.AA) GO TO 240 - IF(FN.GT.AA) GO TO 240 - AA=SQRT(AA) - IF(AZ.GT.AA) IERR=3 - IF(FN.GT.AA) IERR=3 -C----------------------------------------------------------------------- -C OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE -C----------------------------------------------------------------------- - UFL = R1MACH(1)*1.0E+3 - IF (AZ.LT.UFL) GO TO 220 - IF (FNU.GT.FNUL) GO TO 90 - IF (FN.LE.1.0E0) GO TO 70 - IF (FN.GT.2.0E0) GO TO 60 - IF (AZ.GT.TOL) GO TO 70 - ARG = 0.5E0*AZ - ALN = -FN*ALOG(ARG) - IF (ALN.GT.ELIM) GO TO 220 - GO TO 70 - 60 CONTINUE - CALL CUOIK(ZN, FNU, KODE, 2, NN, CY, NUF, TOL, ELIM, ALIM) - IF (NUF.LT.0) GO TO 220 - NZ = NZ + NUF - NN = NN - NUF -C----------------------------------------------------------------------- -C HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK -C IF NUF=NN, THEN CY(I)=CZERO FOR ALL I -C----------------------------------------------------------------------- - IF (NN.EQ.0) GO TO 130 - 70 CONTINUE - IF ((XN.LT.0.0E0) .OR. (XN.EQ.0.0E0 .AND. YN.LT.0.0E0 .AND. - * M.EQ.2)) GO TO 80 -C----------------------------------------------------------------------- -C RIGHT HALF PLANE COMPUTATION, XN.GE.0. .AND. (XN.NE.0. .OR. -C YN.GE.0. .OR. M=1) -C----------------------------------------------------------------------- - CALL CBKNU(ZN, FNU, KODE, NN, CY, NZ, TOL, ELIM, ALIM) - GO TO 110 -C----------------------------------------------------------------------- -C LEFT HALF PLANE COMPUTATION -C----------------------------------------------------------------------- - 80 CONTINUE - MR = -MM - CALL CACON(ZN, FNU, KODE, MR, NN, CY, NW, RL, FNUL, TOL, ELIM, - * ALIM) - IF (NW.LT.0) GO TO 230 - NZ=NW - GO TO 110 - 90 CONTINUE -C----------------------------------------------------------------------- -C UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL -C----------------------------------------------------------------------- - MR = 0 - IF ((XN.GE.0.0E0) .AND. (XN.NE.0.0E0 .OR. YN.GE.0.0E0 .OR. - * M.NE.2)) GO TO 100 - MR = -MM - IF (XN.EQ.0.0E0 .AND. YN.LT.0.0E0) ZN = -ZN - 100 CONTINUE - CALL CBUNK(ZN, FNU, KODE, MR, NN, CY, NW, TOL, ELIM, ALIM) - IF (NW.LT.0) GO TO 230 - NZ = NZ + NW - 110 CONTINUE -C----------------------------------------------------------------------- -C H(M,FNU,Z) = -FMM*(I/HPI)*(ZT**FNU)*K(FNU,-Z*ZT) -C -C ZT=EXP(-FMM*HPI*I) = CMPLX(0.0,-FMM), FMM=3-2*M, M=1,2 -C----------------------------------------------------------------------- - SGN = SIGN(HPI,-FMM) -C----------------------------------------------------------------------- -C CALCULATE EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE -C WHEN FNU IS LARGE -C----------------------------------------------------------------------- - INU = FNU - INUH = INU/2 - IR = INU - 2*INUH - ARG = (FNU-(INU-IR))*SGN - RHPI = 1.0E0/SGN - CPN = RHPI*COS(ARG) - SPN = RHPI*SIN(ARG) -C ZN = CMPLX(-SPN,CPN) - CSGN = CMPLX(-SPN,CPN) -C IF (MOD(INUH,2).EQ.1) ZN = -ZN - IF (MOD(INUH,2).EQ.1) CSGN = -CSGN - ZT = CMPLX(0.0E0,-FMM) - RTOL = 1.0E0/TOL - ASCLE = UFL*RTOL - DO 120 I=1,NN -C CY(I) = CY(I)*ZN -C ZN = ZN*ZT - ZN=CY(I) - AA=REAL(ZN) - BB=AIMAG(ZN) - ATOL=1.0E0 - IF (MAX(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 125 - ZN = ZN*CMPLX(RTOL,0.0E0) - ATOL = TOL - 125 CONTINUE - ZN = ZN*CSGN - CY(I) = ZN*CMPLX(ATOL,0.0E0) - CSGN = CSGN*ZT - 120 CONTINUE - RETURN - 130 CONTINUE - IF (XN.LT.0.0E0) GO TO 220 - RETURN - 220 CONTINUE - IERR=2 - NZ=0 - RETURN - 230 CONTINUE - IF(NW.EQ.(-1)) GO TO 220 - NZ=0 - IERR=5 - RETURN - 240 CONTINUE - NZ=0 - IERR=4 - RETURN - END diff --git a/slatec/cbesi.f b/slatec/cbesi.f deleted file mode 100644 index f99bd30..0000000 --- a/slatec/cbesi.f +++ /dev/null @@ -1,261 +0,0 @@ -*DECK CBESI - SUBROUTINE CBESI (Z, FNU, KODE, N, CY, NZ, IERR) -C***BEGIN PROLOGUE CBESI -C***PURPOSE Compute a sequence of the Bessel functions I(a,z) for -C complex argument z and real nonnegative orders a=b,b+1, -C b+2,... where b>0. A scaling option is available to -C help avoid overflow. -C***LIBRARY SLATEC -C***CATEGORY C10B4 -C***TYPE COMPLEX (CBESI-C, ZBESI-C) -C***KEYWORDS BESSEL FUNCTIONS OF COMPLEX ARGUMENT, I BESSEL FUNCTIONS, -C MODIFIED BESSEL FUNCTIONS -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C On KODE=1, CBESI computes an N-member sequence of complex -C Bessel functions CY(L)=I(FNU+L-1,Z) for real nonnegative -C orders FNU+L-1, L=1,...,N and complex Z in the cut plane -C -pi=0 -C KODE - A parameter to indicate the scaling option -C KODE=1 returns -C CY(L)=I(FNU+L-1,Z), L=1,...,N -C =2 returns -C CY(L)=exp(-abs(X))*I(FNU+L-1,Z), L=1,...,N -C where X=Re(Z) -C N - Number of terms in the sequence, N>=1 -C -C Output -C CY - Result vector of type COMPLEX -C NZ - Number of underflows set to zero -C NZ=0 Normal return -C NZ>0 CY(L)=0, L=N-NZ+1,...,N -C IERR - Error flag -C IERR=0 Normal return - COMPUTATION COMPLETED -C IERR=1 Input error - NO COMPUTATION -C IERR=2 Overflow - NO COMPUTATION -C (Re(Z) too large on KODE=1) -C IERR=3 Precision warning - COMPUTATION COMPLETED -C (Result has half precision or less -C because abs(Z) or FNU+N-1 is large) -C IERR=4 Precision error - NO COMPUTATION -C (Result has no precision because -C abs(Z) or FNU+N-1 is too large) -C IERR=5 Algorithmic error - NO COMPUTATION -C (Termination condition not met) -C -C *Long Description: -C -C The computation of I(a,z) is carried out by the power series -C for small abs(z), the asymptotic expansion for large abs(z), -C the Miller algorithm normalized by the Wronskian and a -C Neumann series for intermediate magnitudes of z, and the -C uniform asymptotic expansions for I(a,z) and J(a,z) for -C large orders a. Backward recurrence is used to generate -C sequences or reduce orders when necessary. -C -C The calculations above are done in the right half plane and -C continued into the left half plane by the formula -C -C I(a,z*exp(t)) = exp(t*a)*I(a,z), Re(z)>0 -C t = i*pi or -i*pi -C -C For negative orders, the formula -C -C I(-a,z) = I(a,z) + (2/pi)*sin(pi*a)*K(a,z) -C -C can be used. However, for large orders close to integers the -C the function changes radically. When a is a large positive -C integer, the magnitude of I(-a,z)=I(a,z) is a large -C negative power of ten. But when a is not an integer, -C K(a,z) dominates in magnitude with a large positive power of -C ten and the most that the second term can be reduced is by -C unit roundoff from the coefficient. Thus, wide changes can -C occur within unit roundoff of a large integer for a. Here, -C large means a>abs(z). -C -C In most complex variable computation, one must evaluate ele- -C mentary functions. When the magnitude of Z or FNU+N-1 is -C large, losses of significance by argument reduction occur. -C Consequently, if either one exceeds U1=SQRT(0.5/UR), then -C losses exceeding half precision are likely and an error flag -C IERR=3 is triggered where UR=R1MACH(4)=UNIT ROUNDOFF. Also, -C if either is larger than U2=0.5/UR, then all significance is -C lost and IERR=4. In order to use the INT function, arguments -C must be further restricted not to exceed the largest machine -C integer, U3=I1MACH(9). Thus, the magnitude of Z and FNU+N-1 -C is restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, and -C U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision -C and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision. This -C makes U2 limiting in single precision and U3 limiting in -C double precision. This means that one can expect to retain, -C in the worst cases on IEEE machines, no digits in single pre- -C cision and only 6 digits in double precision. Similar con- -C siderations hold for other machines. -C -C The approximate relative error in the magnitude of a complex -C Bessel function can be expressed as P*10**S where P=MAX(UNIT -C ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- -C sents the increase in error due to argument reduction in the -C elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), -C ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF -C ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may -C have only absolute accuracy. This is most likely to occur -C when one component (in magnitude) is larger than the other by -C several orders of magnitude. If one component is 10**K larger -C than the other, then one can expect only MAX(ABS(LOG10(P))-K, -C 0) significant digits; or, stated another way, when K exceeds -C the exponent of P, no significant digits remain in the smaller -C component. However, the phase angle retains absolute accuracy -C because, in complex arithmetic with precision P, the smaller -C component will not (as a rule) decrease below P times the -C magnitude of the larger component. In these extreme cases, -C the principal phase angle is on the order of +P, -P, PI/2-P, -C or -PI/2+P. -C -C***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- -C matical Functions, National Bureau of Standards -C Applied Mathematics Series 55, U. S. Department -C of Commerce, Tenth Printing (1972) or later. -C 2. D. E. Amos, Computation of Bessel Functions of -C Complex Argument, Report SAND83-0086, Sandia National -C Laboratories, Albuquerque, NM, May 1983. -C 3. D. E. Amos, Computation of Bessel Functions of -C Complex Argument and Large Order, Report SAND83-0643, -C Sandia National Laboratories, Albuquerque, NM, May -C 1983. -C 4. D. E. Amos, A Subroutine Package for Bessel Functions -C of a Complex Argument and Nonnegative Order, Report -C SAND85-1018, Sandia National Laboratory, Albuquerque, -C NM, May 1985. -C 5. D. E. Amos, A portable package for Bessel functions -C of a complex argument and nonnegative order, ACM -C Transactions on Mathematical Software, 12 (September -C 1986), pp. 265-273. -C -C***ROUTINES CALLED CBINU, I1MACH, R1MACH -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 890801 REVISION DATE from Version 3.2 -C 910415 Prologue converted to Version 4.0 format. (BAB) -C 920128 Category corrected. (WRB) -C 920811 Prologue revised. (DWL) -C***END PROLOGUE CBESI - COMPLEX CONE, CSGN, CY, Z, ZN - REAL AA, ALIM, ARG, DIG, ELIM, FNU, FNUL, PI, RL, R1M5, S1, S2, - * TOL, XX, YY, R1MACH, AZ, FN, BB, ASCLE, RTOL, ATOL - INTEGER I, IERR, INU, K, KODE, K1, K2, N, NN, NZ, I1MACH - DIMENSION CY(N) - DATA PI /3.14159265358979324E0/ - DATA CONE / (1.0E0,0.0E0) / -C -C***FIRST EXECUTABLE STATEMENT CBESI - IERR = 0 - NZ=0 - IF (FNU.LT.0.0E0) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (N.LT.1) IERR=1 - IF (IERR.NE.0) RETURN - XX = REAL(Z) - YY = AIMAG(Z) -C----------------------------------------------------------------------- -C SET PARAMETERS RELATED TO MACHINE CONSTANTS. -C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. -C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. -C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND -C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR -C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. -C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. -C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). -C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. -C----------------------------------------------------------------------- - TOL = MAX(R1MACH(4),1.0E-18) - K1 = I1MACH(12) - K2 = I1MACH(13) - R1M5 = R1MACH(5) - K = MIN(ABS(K1),ABS(K2)) - ELIM = 2.303E0*(K*R1M5-3.0E0) - K1 = I1MACH(11) - 1 - AA = R1M5*K1 - DIG = MIN(AA,18.0E0) - AA = AA*2.303E0 - ALIM = ELIM + MAX(-AA,-41.45E0) - RL = 1.2E0*DIG + 3.0E0 - FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) - AZ = ABS(Z) -C----------------------------------------------------------------------- -C TEST FOR RANGE -C----------------------------------------------------------------------- - AA = 0.5E0/TOL - BB=I1MACH(9)*0.5E0 - AA=MIN(AA,BB) - IF(AZ.GT.AA) GO TO 140 - FN=FNU+(N-1) - IF(FN.GT.AA) GO TO 140 - AA=SQRT(AA) - IF(AZ.GT.AA) IERR=3 - IF(FN.GT.AA) IERR=3 - ZN = Z - CSGN = CONE - IF (XX.GE.0.0E0) GO TO 40 - ZN = -Z -C----------------------------------------------------------------------- -C CALCULATE CSGN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE -C WHEN FNU IS LARGE -C----------------------------------------------------------------------- - INU = FNU - ARG = (FNU-INU)*PI - IF (YY.LT.0.0E0) ARG = -ARG - S1 = COS(ARG) - S2 = SIN(ARG) - CSGN = CMPLX(S1,S2) - IF (MOD(INU,2).EQ.1) CSGN = -CSGN - 40 CONTINUE - CALL CBINU(ZN, FNU, KODE, N, CY, NZ, RL, FNUL, TOL, ELIM, ALIM) - IF (NZ.LT.0) GO TO 120 - IF (XX.GE.0.0E0) RETURN -C----------------------------------------------------------------------- -C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE -C----------------------------------------------------------------------- - NN = N - NZ - IF (NN.EQ.0) RETURN - RTOL = 1.0E0/TOL - ASCLE = R1MACH(1)*RTOL*1.0E+3 - DO 50 I=1,NN -C CY(I) = CY(I)*CSGN - ZN=CY(I) - AA=REAL(ZN) - BB=AIMAG(ZN) - ATOL=1.0E0 - IF (MAX(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 55 - ZN = ZN*CMPLX(RTOL,0.0E0) - ATOL = TOL - 55 CONTINUE - ZN = ZN*CSGN - CY(I) = ZN*CMPLX(ATOL,0.0E0) - CSGN = -CSGN - 50 CONTINUE - RETURN - 120 CONTINUE - IF(NZ.EQ.(-2)) GO TO 130 - NZ = 0 - IERR=2 - RETURN - 130 CONTINUE - NZ=0 - IERR=5 - RETURN - 140 CONTINUE - NZ=0 - IERR=4 - RETURN - END diff --git a/slatec/cbesj.f b/slatec/cbesj.f deleted file mode 100644 index 6c4a5c9..0000000 --- a/slatec/cbesj.f +++ /dev/null @@ -1,259 +0,0 @@ -*DECK CBESJ - SUBROUTINE CBESJ (Z, FNU, KODE, N, CY, NZ, IERR) -C***BEGIN PROLOGUE CBESJ -C***PURPOSE Compute a sequence of the Bessel functions J(a,z) for -C complex argument z and real nonnegative orders a=b,b+1, -C b+2,... where b>0. A scaling option is available to -C help avoid overflow. -C***LIBRARY SLATEC -C***CATEGORY C10A4 -C***TYPE COMPLEX (CBESJ-C, ZBESJ-C) -C***KEYWORDS BESSEL FUNCTIONS OF COMPLEX ARGUMENT, -C BESSEL FUNCTIONS OF THE FIRST KIND, J BESSEL FUNCTIONS -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C On KODE=1, CBESJ computes an N member sequence of complex -C Bessel functions CY(L)=J(FNU+L-1,Z) for real nonnegative -C orders FNU+L-1, L=1,...,N and complex Z in the cut plane -C -pi=0 -C KODE - A parameter to indicate the scaling option -C KODE=1 returns -C CY(L)=J(FNU+L-1,Z), L=1,...,N -C =2 returns -C CY(L)=J(FNU+L-1,Z)*exp(-abs(Y)), L=1,...,N -C where Y=Im(Z) -C N - Number of terms in the sequence, N>=1 -C -C Output -C CY - Result vector of type COMPLEX -C NZ - Number of underflows set to zero -C NZ=0 Normal return -C NZ>0 CY(L)=0, L=N-NZ+1,...,N -C IERR - Error flag -C IERR=0 Normal return - COMPUTATION COMPLETED -C IERR=1 Input error - NO COMPUTATION -C IERR=2 Overflow - NO COMPUTATION -C (Im(Z) too large on KODE=1) -C IERR=3 Precision warning - COMPUTATION COMPLETED -C (Result has half precision or less -C because abs(Z) or FNU+N-1 is large) -C IERR=4 Precision error - NO COMPUTATION -C (Result has no precision because -C abs(Z) or FNU+N-1 is too large) -C IERR=5 Algorithmic error - NO COMPUTATION -C (Termination condition not met) -C -C *Long Description: -C -C The computation is carried out by the formulae -C -C J(a,z) = exp( a*pi*i/2)*I(a,-i*z), Im(z)>=0 -C -C J(a,z) = exp(-a*pi*i/2)*I(a, i*z), Im(z)<0 -C -C where the I Bessel function is computed as described in the -C prologue to CBESI. -C -C For negative orders, the formula -C -C J(-a,z) = J(a,z)*cos(a*pi) - Y(a,z)*sin(a*pi) -C -C can be used. However, for large orders close to integers, the -C the function changes radically. When a is a large positive -C integer, the magnitude of J(-a,z)=J(a,z)*cos(a*pi) is a -C large negative power of ten. But when a is not an integer, -C Y(a,z) dominates in magnitude with a large positive power of -C ten and the most that the second term can be reduced is by -C unit roundoff from the coefficient. Thus, wide changes can -C occur within unit roundoff of a large integer for a. Here, -C large means a>abs(z). -C -C In most complex variable computation, one must evaluate ele- -C mentary functions. When the magnitude of Z or FNU+N-1 is -C large, losses of significance by argument reduction occur. -C Consequently, if either one exceeds U1=SQRT(0.5/UR), then -C losses exceeding half precision are likely and an error flag -C IERR=3 is triggered where UR=R1MACH(4)=UNIT ROUNDOFF. Also, -C if either is larger than U2=0.5/UR, then all significance is -C lost and IERR=4. In order to use the INT function, arguments -C must be further restricted not to exceed the largest machine -C integer, U3=I1MACH(9). Thus, the magnitude of Z and FNU+N-1 -C is restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, and -C U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision -C and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision. This -C makes U2 limiting in single precision and U3 limiting in -C double precision. This means that one can expect to retain, -C in the worst cases on IEEE machines, no digits in single pre- -C cision and only 6 digits in double precision. Similar con- -C siderations hold for other machines. -C -C The approximate relative error in the magnitude of a complex -C Bessel function can be expressed as P*10**S where P=MAX(UNIT -C ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- -C sents the increase in error due to argument reduction in the -C elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), -C ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF -C ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may -C have only absolute accuracy. This is most likely to occur -C when one component (in magnitude) is larger than the other by -C several orders of magnitude. If one component is 10**K larger -C than the other, then one can expect only MAX(ABS(LOG10(P))-K, -C 0) significant digits; or, stated another way, when K exceeds -C the exponent of P, no significant digits remain in the smaller -C component. However, the phase angle retains absolute accuracy -C because, in complex arithmetic with precision P, the smaller -C component will not (as a rule) decrease below P times the -C magnitude of the larger component. In these extreme cases, -C the principal phase angle is on the order of +P, -P, PI/2-P, -C or -PI/2+P. -C -C***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- -C matical Functions, National Bureau of Standards -C Applied Mathematics Series 55, U. S. Department -C of Commerce, Tenth Printing (1972) or later. -C 2. D. E. Amos, Computation of Bessel Functions of -C Complex Argument, Report SAND83-0086, Sandia National -C Laboratories, Albuquerque, NM, May 1983. -C 3. D. E. Amos, Computation of Bessel Functions of -C Complex Argument and Large Order, Report SAND83-0643, -C Sandia National Laboratories, Albuquerque, NM, May -C 1983. -C 4. D. E. Amos, A Subroutine Package for Bessel Functions -C of a Complex Argument and Nonnegative Order, Report -C SAND85-1018, Sandia National Laboratory, Albuquerque, -C NM, May 1985. -C 5. D. E. Amos, A portable package for Bessel functions -C of a complex argument and nonnegative order, ACM -C Transactions on Mathematical Software, 12 (September -C 1986), pp. 265-273. -C -C***ROUTINES CALLED CBINU, I1MACH, R1MACH -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 890801 REVISION DATE from Version 3.2 -C 910415 Prologue converted to Version 4.0 format. (BAB) -C 920128 Category corrected. (WRB) -C 920811 Prologue revised. (DWL) -C***END PROLOGUE CBESJ -C - COMPLEX CI, CSGN, CY, Z, ZN - REAL AA, ALIM, ARG, DIG, ELIM, FNU, FNUL, HPI, RL, R1, R1M5, R2, - * TOL, YY, R1MACH, AZ, FN, BB, ASCLE, RTOL, ATOL - INTEGER I, IERR, INU, INUH, IR, KODE, K1, K2, N, NL, NZ, I1MACH, K - DIMENSION CY(N) - DATA HPI /1.57079632679489662E0/ -C -C***FIRST EXECUTABLE STATEMENT CBESJ - IERR = 0 - NZ=0 - IF (FNU.LT.0.0E0) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (N.LT.1) IERR=1 - IF (IERR.NE.0) RETURN -C----------------------------------------------------------------------- -C SET PARAMETERS RELATED TO MACHINE CONSTANTS. -C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. -C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. -C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND -C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR -C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. -C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. -C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). -C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. -C----------------------------------------------------------------------- - TOL = MAX(R1MACH(4),1.0E-18) - K1 = I1MACH(12) - K2 = I1MACH(13) - R1M5 = R1MACH(5) - K = MIN(ABS(K1),ABS(K2)) - ELIM = 2.303E0*(K*R1M5-3.0E0) - K1 = I1MACH(11) - 1 - AA = R1M5*K1 - DIG = MIN(AA,18.0E0) - AA = AA*2.303E0 - ALIM = ELIM + MAX(-AA,-41.45E0) - RL = 1.2E0*DIG + 3.0E0 - FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) - CI = CMPLX(0.0E0,1.0E0) - YY = AIMAG(Z) - AZ = ABS(Z) -C----------------------------------------------------------------------- -C TEST FOR RANGE -C----------------------------------------------------------------------- - AA = 0.5E0/TOL - BB=I1MACH(9)*0.5E0 - AA=MIN(AA,BB) - FN=FNU+(N-1) - IF(AZ.GT.AA) GO TO 140 - IF(FN.GT.AA) GO TO 140 - AA=SQRT(AA) - IF(AZ.GT.AA) IERR=3 - IF(FN.GT.AA) IERR=3 -C----------------------------------------------------------------------- -C CALCULATE CSGN=EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE -C WHEN FNU IS LARGE -C----------------------------------------------------------------------- - INU = FNU - INUH = INU/2 - IR = INU - 2*INUH - ARG = (FNU-(INU-IR))*HPI - R1 = COS(ARG) - R2 = SIN(ARG) - CSGN = CMPLX(R1,R2) - IF (MOD(INUH,2).EQ.1) CSGN = -CSGN -C----------------------------------------------------------------------- -C ZN IS IN THE RIGHT HALF PLANE -C----------------------------------------------------------------------- - ZN = -Z*CI - IF (YY.GE.0.0E0) GO TO 40 - ZN = -ZN - CSGN = CONJG(CSGN) - CI = CONJG(CI) - 40 CONTINUE - CALL CBINU(ZN, FNU, KODE, N, CY, NZ, RL, FNUL, TOL, ELIM, ALIM) - IF (NZ.LT.0) GO TO 120 - NL = N - NZ - IF (NL.EQ.0) RETURN - RTOL = 1.0E0/TOL - ASCLE = R1MACH(1)*RTOL*1.0E+3 - DO 50 I=1,NL -C CY(I)=CY(I)*CSGN - ZN=CY(I) - AA=REAL(ZN) - BB=AIMAG(ZN) - ATOL=1.0E0 - IF (MAX(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 55 - ZN = ZN*CMPLX(RTOL,0.0E0) - ATOL = TOL - 55 CONTINUE - ZN = ZN*CSGN - CY(I) = ZN*CMPLX(ATOL,0.0E0) - CSGN = CSGN*CI - 50 CONTINUE - RETURN - 120 CONTINUE - IF(NZ.EQ.(-2)) GO TO 130 - NZ = 0 - IERR = 2 - RETURN - 130 CONTINUE - NZ=0 - IERR=5 - RETURN - 140 CONTINUE - NZ=0 - IERR=4 - RETURN - END diff --git a/slatec/cbesk.f b/slatec/cbesk.f deleted file mode 100644 index 7d21b4c..0000000 --- a/slatec/cbesk.f +++ /dev/null @@ -1,281 +0,0 @@ -*DECK CBESK - SUBROUTINE CBESK (Z, FNU, KODE, N, CY, NZ, IERR) -C***BEGIN PROLOGUE CBESK -C***PURPOSE Compute a sequence of the Bessel functions K(a,z) for -C complex argument z and real nonnegative orders a=b,b+1, -C b+2,... where b>0. A scaling option is available to -C help avoid overflow. -C***LIBRARY SLATEC -C***CATEGORY C10B4 -C***TYPE COMPLEX (CBESK-C, ZBESK-C) -C***KEYWORDS BESSEL FUNCTIONS OF COMPLEX ARGUMENT, K BESSEL FUNCTIONS, -C MODIFIED BESSEL FUNCTIONS -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C On KODE=1, CBESK computes an N member sequence of complex -C Bessel functions CY(L)=K(FNU+L-1,Z) for real nonnegative -C orders FNU+L-1, L=1,...,N and complex Z.NE.0 in the cut -C plane -pi=0 -C KODE - A parameter to indicate the scaling option -C KODE=1 returns -C CY(L)=K(FNU+L-1,Z), L=1,...,N -C =2 returns -C CY(L)=K(FNU+L-1,Z)*EXP(Z), L=1,...,N -C N - Number of terms in the sequence, N>=1 -C -C Output -C CY - Result vector of type COMPLEX -C NZ - Number of underflows set to zero -C NZ=0 Normal return -C NZ>0 CY(L)=0 for NZ values of L (if Re(Z)>0 -C then CY(L)=0 for L=1,...,NZ; in the -C complementary half plane the underflows -C may not be in an uninterrupted sequence) -C IERR - Error flag -C IERR=0 Normal return - COMPUTATION COMPLETED -C IERR=1 Input error - NO COMPUTATION -C IERR=2 Overflow - NO COMPUTATION -C (abs(Z) too small and/or FNU+N-1 -C too large) -C IERR=3 Precision warning - COMPUTATION COMPLETED -C (Result has half precision or less -C because abs(Z) or FNU+N-1 is large) -C IERR=4 Precision error - NO COMPUTATION -C (Result has no precision because -C abs(Z) or FNU+N-1 is too large) -C IERR=5 Algorithmic error - NO COMPUTATION -C (Termination condition not met) -C -C *Long Description: -C -C Equations of the reference are implemented to compute K(a,z) -C for small orders a and a+1 in the right half plane Re(z)>=0. -C Forward recurrence generates higher orders. The formula -C -C K(a,z*exp((t)) = exp(-t)*K(a,z) - t*I(a,z), Re(z)>0 -C t = i*pi or -i*pi -C -C continues K to the left half plane. -C -C For large orders, K(a,z) is computed by means of its uniform -C asymptotic expansion. -C -C For negative orders, the formula -C -C K(-a,z) = K(a,z) -C -C can be used. -C -C CBESK assumes that a significant digit sinh function is -C available. -C -C In most complex variable computation, one must evaluate ele- -C mentary functions. When the magnitude of Z or FNU+N-1 is -C large, losses of significance by argument reduction occur. -C Consequently, if either one exceeds U1=SQRT(0.5/UR), then -C losses exceeding half precision are likely and an error flag -C IERR=3 is triggered where UR=R1MACH(4)=UNIT ROUNDOFF. Also, -C if either is larger than U2=0.5/UR, then all significance is -C lost and IERR=4. In order to use the INT function, arguments -C must be further restricted not to exceed the largest machine -C integer, U3=I1MACH(9). Thus, the magnitude of Z and FNU+N-1 -C is restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, and -C U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision -C and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision. This -C makes U2 limiting in single precision and U3 limiting in -C double precision. This means that one can expect to retain, -C in the worst cases on IEEE machines, no digits in single pre- -C cision and only 6 digits in double precision. Similar con- -C siderations hold for other machines. -C -C The approximate relative error in the magnitude of a complex -C Bessel function can be expressed as P*10**S where P=MAX(UNIT -C ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- -C sents the increase in error due to argument reduction in the -C elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), -C ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF -C ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may -C have only absolute accuracy. This is most likely to occur -C when one component (in magnitude) is larger than the other by -C several orders of magnitude. If one component is 10**K larger -C than the other, then one can expect only MAX(ABS(LOG10(P))-K, -C 0) significant digits; or, stated another way, when K exceeds -C the exponent of P, no significant digits remain in the smaller -C component. However, the phase angle retains absolute accuracy -C because, in complex arithmetic with precision P, the smaller -C component will not (as a rule) decrease below P times the -C magnitude of the larger component. In these extreme cases, -C the principal phase angle is on the order of +P, -P, PI/2-P, -C or -PI/2+P. -C -C***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- -C matical Functions, National Bureau of Standards -C Applied Mathematics Series 55, U. S. Department -C of Commerce, Tenth Printing (1972) or later. -C 2. D. E. Amos, Computation of Bessel Functions of -C Complex Argument, Report SAND83-0086, Sandia National -C Laboratories, Albuquerque, NM, May 1983. -C 3. D. E. Amos, Computation of Bessel Functions of -C Complex Argument and Large Order, Report SAND83-0643, -C Sandia National Laboratories, Albuquerque, NM, May -C 1983. -C 4. D. E. Amos, A Subroutine Package for Bessel Functions -C of a Complex Argument and Nonnegative Order, Report -C SAND85-1018, Sandia National Laboratory, Albuquerque, -C NM, May 1985. -C 5. D. E. Amos, A portable package for Bessel functions -C of a complex argument and nonnegative order, ACM -C Transactions on Mathematical Software, 12 (September -C 1986), pp. 265-273. -C -C***ROUTINES CALLED CACON, CBKNU, CBUNK, CUOIK, I1MACH, R1MACH -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 890801 REVISION DATE from Version 3.2 -C 910415 Prologue converted to Version 4.0 format. (BAB) -C 920128 Category corrected. (WRB) -C 920811 Prologue revised. (DWL) -C***END PROLOGUE CBESK -C - COMPLEX CY, Z - REAL AA, ALIM, ALN, ARG, AZ, DIG, ELIM, FN, FNU, FNUL, RL, R1M5, - * TOL, UFL, XX, YY, R1MACH, BB - INTEGER IERR, K, KODE, K1, K2, MR, N, NN, NUF, NW, NZ, I1MACH - DIMENSION CY(N) -C***FIRST EXECUTABLE STATEMENT CBESK - IERR = 0 - NZ=0 - XX = REAL(Z) - YY = AIMAG(Z) - IF (YY.EQ.0.0E0 .AND. XX.EQ.0.0E0) IERR=1 - IF (FNU.LT.0.0E0) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (N.LT.1) IERR=1 - IF (IERR.NE.0) RETURN - NN = N -C----------------------------------------------------------------------- -C SET PARAMETERS RELATED TO MACHINE CONSTANTS. -C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. -C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. -C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND -C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR -C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. -C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. -C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). -C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU -C----------------------------------------------------------------------- - TOL = MAX(R1MACH(4),1.0E-18) - K1 = I1MACH(12) - K2 = I1MACH(13) - R1M5 = R1MACH(5) - K = MIN(ABS(K1),ABS(K2)) - ELIM = 2.303E0*(K*R1M5-3.0E0) - K1 = I1MACH(11) - 1 - AA = R1M5*K1 - DIG = MIN(AA,18.0E0) - AA = AA*2.303E0 - ALIM = ELIM + MAX(-AA,-41.45E0) - FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) - RL = 1.2E0*DIG + 3.0E0 - AZ = ABS(Z) - FN = FNU + (NN-1) -C----------------------------------------------------------------------- -C TEST FOR RANGE -C----------------------------------------------------------------------- - AA = 0.5E0/TOL - BB=I1MACH(9)*0.5E0 - AA=MIN(AA,BB) - IF(AZ.GT.AA) GO TO 210 - IF(FN.GT.AA) GO TO 210 - AA=SQRT(AA) - IF(AZ.GT.AA) IERR=3 - IF(FN.GT.AA) IERR=3 -C----------------------------------------------------------------------- -C OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE -C----------------------------------------------------------------------- -C UFL = EXP(-ELIM) - UFL = R1MACH(1)*1.0E+3 - IF (AZ.LT.UFL) GO TO 180 - IF (FNU.GT.FNUL) GO TO 80 - IF (FN.LE.1.0E0) GO TO 60 - IF (FN.GT.2.0E0) GO TO 50 - IF (AZ.GT.TOL) GO TO 60 - ARG = 0.5E0*AZ - ALN = -FN*ALOG(ARG) - IF (ALN.GT.ELIM) GO TO 180 - GO TO 60 - 50 CONTINUE - CALL CUOIK(Z, FNU, KODE, 2, NN, CY, NUF, TOL, ELIM, ALIM) - IF (NUF.LT.0) GO TO 180 - NZ = NZ + NUF - NN = NN - NUF -C----------------------------------------------------------------------- -C HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK -C IF NUF=NN, THEN CY(I)=CZERO FOR ALL I -C----------------------------------------------------------------------- - IF (NN.EQ.0) GO TO 100 - 60 CONTINUE - IF (XX.LT.0.0E0) GO TO 70 -C----------------------------------------------------------------------- -C RIGHT HALF PLANE COMPUTATION, REAL(Z).GE.0. -C----------------------------------------------------------------------- - CALL CBKNU(Z, FNU, KODE, NN, CY, NW, TOL, ELIM, ALIM) - IF (NW.LT.0) GO TO 200 - NZ=NW - RETURN -C----------------------------------------------------------------------- -C LEFT HALF PLANE COMPUTATION -C PI/2.LT.ARG(Z).LE.PI AND -PI.LT.ARG(Z).LT.-PI/2. -C----------------------------------------------------------------------- - 70 CONTINUE - IF (NZ.NE.0) GO TO 180 - MR = 1 - IF (YY.LT.0.0E0) MR = -1 - CALL CACON(Z, FNU, KODE, MR, NN, CY, NW, RL, FNUL, TOL, ELIM, - * ALIM) - IF (NW.LT.0) GO TO 200 - NZ=NW - RETURN -C----------------------------------------------------------------------- -C UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL -C----------------------------------------------------------------------- - 80 CONTINUE - MR = 0 - IF (XX.GE.0.0E0) GO TO 90 - MR = 1 - IF (YY.LT.0.0E0) MR = -1 - 90 CONTINUE - CALL CBUNK(Z, FNU, KODE, MR, NN, CY, NW, TOL, ELIM, ALIM) - IF (NW.LT.0) GO TO 200 - NZ = NZ + NW - RETURN - 100 CONTINUE - IF (XX.LT.0.0E0) GO TO 180 - RETURN - 180 CONTINUE - NZ = 0 - IERR=2 - RETURN - 200 CONTINUE - IF(NW.EQ.(-1)) GO TO 180 - NZ=0 - IERR=5 - RETURN - 210 CONTINUE - NZ=0 - IERR=4 - RETURN - END diff --git a/slatec/cbesy.f b/slatec/cbesy.f deleted file mode 100644 index 66c2bc4..0000000 --- a/slatec/cbesy.f +++ /dev/null @@ -1,236 +0,0 @@ -*DECK CBESY - SUBROUTINE CBESY (Z, FNU, KODE, N, CY, NZ, CWRK, IERR) -C***BEGIN PROLOGUE CBESY -C***PURPOSE Compute a sequence of the Bessel functions Y(a,z) for -C complex argument z and real nonnegative orders a=b,b+1, -C b+2,... where b>0. A scaling option is available to -C help avoid overflow. -C***LIBRARY SLATEC -C***CATEGORY C10A4 -C***TYPE COMPLEX (CBESY-C, ZBESY-C) -C***KEYWORDS BESSEL FUNCTIONS OF COMPLEX ARGUMENT, -C BESSEL FUNCTIONS OF SECOND KIND, WEBER'S FUNCTION, -C Y BESSEL FUNCTIONS -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C On KODE=1, CBESY computes an N member sequence of complex -C Bessel functions CY(L)=Y(FNU+L-1,Z) for real nonnegative -C orders FNU+L-1, L=1,...,N and complex Z in the cut plane -C -pi=0 -C KODE - A parameter to indicate the scaling option -C KODE=1 returns -C CY(L)=Y(FNU+L-1,Z), L=1,...,N -C =2 returns -C CY(L)=Y(FNU+L-1,Z)*exp(-abs(Y)), L=1,...,N -C where Y=Im(Z) -C N - Number of terms in the sequence, N>=1 -C CWRK - A work vector of type COMPLEX and dimension N -C -C Output -C CY - Result vector of type COMPLEX -C NZ - Number of underflows set to zero -C NZ=0 Normal return -C NZ>0 CY(L)=0 for NZ values of L, usually on -C KODE=2 (the underflows may not be in an -C uninterrupted sequence) -C IERR - Error flag -C IERR=0 Normal return - COMPUTATION COMPLETED -C IERR=1 Input error - NO COMPUTATION -C IERR=2 Overflow - NO COMPUTATION -C (abs(Z) too small and/or FNU+N-1 -C too large) -C IERR=3 Precision warning - COMPUTATION COMPLETED -C (Result has half precision or less -C because abs(Z) or FNU+N-1 is large) -C IERR=4 Precision error - NO COMPUTATION -C (Result has no precision because -C abs(Z) or FNU+N-1 is too large) -C IERR=5 Algorithmic error - NO COMPUTATION -C (Termination condition not met) -C -C *Long Description: -C -C The computation is carried out by the formula -C -C Y(a,z) = (H(1,a,z) - H(2,a,z))/(2*i) -C -C where the Hankel functions are computed as described in CBESH. -C -C For negative orders, the formula -C -C Y(-a,z) = Y(a,z)*cos(a*pi) + J(a,z)*sin(a*pi) -C -C can be used. However, for large orders close to half odd -C integers the function changes radically. When a is a large -C positive half odd integer, the magnitude of Y(-a,z)=J(a,z)* -C sin(a*pi) is a large negative power of ten. But when a is -C not a half odd integer, Y(a,z) dominates in magnitude with a -C large positive power of ten and the most that the second term -C can be reduced is by unit roundoff from the coefficient. -C Thus, wide changes can occur within unit roundoff of a large -C half odd integer. Here, large means a>abs(z). -C -C In most complex variable computation, one must evaluate ele- -C mentary functions. When the magnitude of Z or FNU+N-1 is -C large, losses of significance by argument reduction occur. -C Consequently, if either one exceeds U1=SQRT(0.5/UR), then -C losses exceeding half precision are likely and an error flag -C IERR=3 is triggered where UR=R1MACH(4)=UNIT ROUNDOFF. Also, -C if either is larger than U2=0.5/UR, then all significance is -C lost and IERR=4. In order to use the INT function, arguments -C must be further restricted not to exceed the largest machine -C integer, U3=I1MACH(9). Thus, the magnitude of Z and FNU+N-1 -C is restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, and -C U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision -C and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision. This -C makes U2 limiting in single precision and U3 limiting in -C double precision. This means that one can expect to retain, -C in the worst cases on IEEE machines, no digits in single pre- -C cision and only 6 digits in double precision. Similar con- -C siderations hold for other machines. -C -C The approximate relative error in the magnitude of a complex -C Bessel function can be expressed as P*10**S where P=MAX(UNIT -C ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- -C sents the increase in error due to argument reduction in the -C elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), -C ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF -C ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may -C have only absolute accuracy. This is most likely to occur -C when one component (in magnitude) is larger than the other by -C several orders of magnitude. If one component is 10**K larger -C than the other, then one can expect only MAX(ABS(LOG10(P))-K, -C 0) significant digits; or, stated another way, when K exceeds -C the exponent of P, no significant digits remain in the smaller -C component. However, the phase angle retains absolute accuracy -C because, in complex arithmetic with precision P, the smaller -C component will not (as a rule) decrease below P times the -C magnitude of the larger component. In these extreme cases, -C the principal phase angle is on the order of +P, -P, PI/2-P, -C or -PI/2+P. -C -C***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- -C matical Functions, National Bureau of Standards -C Applied Mathematics Series 55, U. S. Department -C of Commerce, Tenth Printing (1972) or later. -C 2. D. E. Amos, Computation of Bessel Functions of -C Complex Argument, Report SAND83-0086, Sandia National -C Laboratories, Albuquerque, NM, May 1983. -C 3. D. E. Amos, Computation of Bessel Functions of -C Complex Argument and Large Order, Report SAND83-0643, -C Sandia National Laboratories, Albuquerque, NM, May -C 1983. -C 4. D. E. Amos, A Subroutine Package for Bessel Functions -C of a Complex Argument and Nonnegative Order, Report -C SAND85-1018, Sandia National Laboratory, Albuquerque, -C NM, May 1985. -C 5. D. E. Amos, A portable package for Bessel functions -C of a complex argument and nonnegative order, ACM -C Transactions on Mathematical Software, 12 (September -C 1986), pp. 265-273. -C -C***ROUTINES CALLED CBESH, I1MACH, R1MACH -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 890801 REVISION DATE from Version 3.2 -C 910415 Prologue converted to Version 4.0 format. (BAB) -C 920128 Category corrected. (WRB) -C 920811 Prologue revised. (DWL) -C***END PROLOGUE CBESY -C - COMPLEX CWRK, CY, C1, C2, EX, HCI, Z, ZU, ZV - REAL ELIM, EY, FNU, R1, R2, TAY, XX, YY, R1MACH, R1M5, ASCLE, - * RTOL, ATOL, TOL, AA, BB - INTEGER I, IERR, K, KODE, K1, K2, N, NZ, NZ1, NZ2, I1MACH - DIMENSION CY(N), CWRK(N) -C***FIRST EXECUTABLE STATEMENT CBESY - XX = REAL(Z) - YY = AIMAG(Z) - IERR = 0 - NZ=0 - IF (XX.EQ.0.0E0 .AND. YY.EQ.0.0E0) IERR=1 - IF (FNU.LT.0.0E0) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (N.LT.1) IERR=1 - IF (IERR.NE.0) RETURN - HCI = CMPLX(0.0E0,0.5E0) - CALL CBESH(Z, FNU, KODE, 1, N, CY, NZ1, IERR) - IF (IERR.NE.0.AND.IERR.NE.3) GO TO 170 - CALL CBESH(Z, FNU, KODE, 2, N, CWRK, NZ2, IERR) - IF (IERR.NE.0.AND.IERR.NE.3) GO TO 170 - NZ = MIN(NZ1,NZ2) - IF (KODE.EQ.2) GO TO 60 - DO 50 I=1,N - CY(I) = HCI*(CWRK(I)-CY(I)) - 50 CONTINUE - RETURN - 60 CONTINUE - TOL = MAX(R1MACH(4),1.0E-18) - K1 = I1MACH(12) - K2 = I1MACH(13) - K = MIN(ABS(K1),ABS(K2)) - R1M5 = R1MACH(5) -C----------------------------------------------------------------------- -C ELIM IS THE APPROXIMATE EXPONENTIAL UNDER- AND OVERFLOW LIMIT -C----------------------------------------------------------------------- - ELIM = 2.303E0*(K*R1M5-3.0E0) - R1 = COS(XX) - R2 = SIN(XX) - EX = CMPLX(R1,R2) - EY = 0.0E0 - TAY = ABS(YY+YY) - IF (TAY.LT.ELIM) EY = EXP(-TAY) - IF (YY.LT.0.0E0) GO TO 90 - C1 = EX*CMPLX(EY,0.0E0) - C2 = CONJG(EX) - 70 CONTINUE - NZ = 0 - RTOL = 1.0E0/TOL - ASCLE = R1MACH(1)*RTOL*1.0E+3 - DO 80 I=1,N -C CY(I) = HCI*(C2*CWRK(I)-C1*CY(I)) - ZV = CWRK(I) - AA=REAL(ZV) - BB=AIMAG(ZV) - ATOL=1.0E0 - IF (MAX(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 75 - ZV = ZV*CMPLX(RTOL,0.0E0) - ATOL = TOL - 75 CONTINUE - ZV = ZV*C2*HCI - ZV = ZV*CMPLX(ATOL,0.0E0) - ZU=CY(I) - AA=REAL(ZU) - BB=AIMAG(ZU) - ATOL=1.0E0 - IF (MAX(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 85 - ZU = ZU*CMPLX(RTOL,0.0E0) - ATOL = TOL - 85 CONTINUE - ZU = ZU*C1*HCI - ZU = ZU*CMPLX(ATOL,0.0E0) - CY(I) = ZV - ZU - IF (CY(I).EQ.CMPLX(0.0E0,0.0E0) .AND. EY.EQ.0.0E0) NZ = NZ + 1 - 80 CONTINUE - RETURN - 90 CONTINUE - C1 = EX - C2 = CONJG(EX)*CMPLX(EY,0.0E0) - GO TO 70 - 170 CONTINUE - NZ = 0 - RETURN - END diff --git a/slatec/cbeta.f b/slatec/cbeta.f deleted file mode 100644 index 84ec3af..0000000 --- a/slatec/cbeta.f +++ /dev/null @@ -1,49 +0,0 @@ -*DECK CBETA - COMPLEX FUNCTION CBETA (A, B) -C***BEGIN PROLOGUE CBETA -C***PURPOSE Compute the complete Beta function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7B -C***TYPE COMPLEX (BETA-S, DBETA-D, CBETA-C) -C***KEYWORDS COMPLETE BETA FUNCTION, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C CBETA computes the complete beta function of complex parameters A -C and B. -C Input Parameters: -C A complex and the real part of A positive -C B complex and the real part of B positive -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CGAMMA, CLBETA, GAMLIM, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890206 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900727 Added EXTERNAL statement. (WRB) -C***END PROLOGUE CBETA - COMPLEX A, B, CGAMMA, CLBETA - EXTERNAL CGAMMA - SAVE XMAX - DATA XMAX / 0.0 / -C***FIRST EXECUTABLE STATEMENT CBETA - IF (XMAX.EQ.0.0) THEN - CALL GAMLIM (XMIN, XMAXT) - XMAX = XMAXT - ENDIF -C - IF (REAL(A) .LE. 0.0 .OR. REAL(B) .LE. 0.0) CALL XERMSG ('SLATEC', - + 'CBETA', 'REAL PART OF BOTH ARGUMENTS MUST BE GT 0', 1, 2) -C - IF (REAL(A)+REAL(B).LT.XMAX) CBETA = CGAMMA(A) * (CGAMMA(B)/ - 1 CGAMMA(A+B) ) - IF (REAL(A)+REAL(B).LT.XMAX) RETURN -C - CBETA = EXP (CLBETA(A, B)) -C - RETURN - END diff --git a/slatec/cbinu.f b/slatec/cbinu.f deleted file mode 100644 index 8f0e830..0000000 --- a/slatec/cbinu.f +++ /dev/null @@ -1,115 +0,0 @@ -*DECK CBINU - SUBROUTINE CBINU (Z, FNU, KODE, N, CY, NZ, RL, FNUL, TOL, ELIM, - + ALIM) -C***BEGIN PROLOGUE CBINU -C***SUBSIDIARY -C***PURPOSE Subsidiary to CAIRY, CBESH, CBESI, CBESJ, CBESK and CBIRY -C***LIBRARY SLATEC -C***TYPE ALL (CBINU-A, ZBINU-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C CBINU COMPUTES THE I FUNCTION IN THE RIGHT HALF Z PLANE -C -C***SEE ALSO CAIRY, CBESH, CBESI, CBESJ, CBESK, CBIRY -C***ROUTINES CALLED CASYI, CBUNI, CMLRI, CSERI, CUOIK, CWRSK -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CBINU - COMPLEX CW, CY, CZERO, Z - REAL ALIM, AZ, DFNU, ELIM, FNU, FNUL, RL, TOL - INTEGER I, INW, KODE, N, NLAST, NN, NUI, NW, NZ - DIMENSION CY(N), CW(2) - DATA CZERO / (0.0E0,0.0E0) / -C***FIRST EXECUTABLE STATEMENT CBINU - NZ = 0 - AZ = ABS(Z) - NN = N - DFNU = FNU + (N-1) - IF (AZ.LE.2.0E0) GO TO 10 - IF (AZ*AZ*0.25E0.GT.DFNU+1.0E0) GO TO 20 - 10 CONTINUE -C----------------------------------------------------------------------- -C POWER SERIES -C----------------------------------------------------------------------- - CALL CSERI(Z, FNU, KODE, NN, CY, NW, TOL, ELIM, ALIM) - INW = ABS(NW) - NZ = NZ + INW - NN = NN - INW - IF (NN.EQ.0) RETURN - IF (NW.GE.0) GO TO 120 - DFNU = FNU + (NN-1) - 20 CONTINUE - IF (AZ.LT.RL) GO TO 40 - IF (DFNU.LE.1.0E0) GO TO 30 - IF (AZ+AZ.LT.DFNU*DFNU) GO TO 50 -C----------------------------------------------------------------------- -C ASYMPTOTIC EXPANSION FOR LARGE Z -C----------------------------------------------------------------------- - 30 CONTINUE - CALL CASYI(Z, FNU, KODE, NN, CY, NW, RL, TOL, ELIM, ALIM) - IF (NW.LT.0) GO TO 130 - GO TO 120 - 40 CONTINUE - IF (DFNU.LE.1.0E0) GO TO 70 - 50 CONTINUE -C----------------------------------------------------------------------- -C OVERFLOW AND UNDERFLOW TEST ON I SEQUENCE FOR MILLER ALGORITHM -C----------------------------------------------------------------------- - CALL CUOIK(Z, FNU, KODE, 1, NN, CY, NW, TOL, ELIM, ALIM) - IF (NW.LT.0) GO TO 130 - NZ = NZ + NW - NN = NN - NW - IF (NN.EQ.0) RETURN - DFNU = FNU+(NN-1) - IF (DFNU.GT.FNUL) GO TO 110 - IF (AZ.GT.FNUL) GO TO 110 - 60 CONTINUE - IF (AZ.GT.RL) GO TO 80 - 70 CONTINUE -C----------------------------------------------------------------------- -C MILLER ALGORITHM NORMALIZED BY THE SERIES -C----------------------------------------------------------------------- - CALL CMLRI(Z, FNU, KODE, NN, CY, NW, TOL) - IF(NW.LT.0) GO TO 130 - GO TO 120 - 80 CONTINUE -C----------------------------------------------------------------------- -C MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- -C OVERFLOW TEST ON K FUNCTIONS USED IN WRONSKIAN -C----------------------------------------------------------------------- - CALL CUOIK(Z, FNU, KODE, 2, 2, CW, NW, TOL, ELIM, ALIM) - IF (NW.GE.0) GO TO 100 - NZ = NN - DO 90 I=1,NN - CY(I) = CZERO - 90 CONTINUE - RETURN - 100 CONTINUE - IF (NW.GT.0) GO TO 130 - CALL CWRSK(Z, FNU, KODE, NN, CY, NW, CW, TOL, ELIM, ALIM) - IF (NW.LT.0) GO TO 130 - GO TO 120 - 110 CONTINUE -C----------------------------------------------------------------------- -C INCREMENT FNU+NN-1 UP TO FNUL, COMPUTE AND RECUR BACKWARD -C----------------------------------------------------------------------- - NUI = FNUL-DFNU + 1 - NUI = MAX(NUI,0) - CALL CBUNI(Z, FNU, KODE, NN, CY, NW, NUI, NLAST, FNUL, TOL, ELIM, - * ALIM) - IF (NW.LT.0) GO TO 130 - NZ = NZ + NW - IF (NLAST.EQ.0) GO TO 120 - NN = NLAST - GO TO 60 - 120 CONTINUE - RETURN - 130 CONTINUE - NZ = -1 - IF(NW.EQ.(-2)) NZ=-2 - RETURN - END diff --git a/slatec/cbiry.f b/slatec/cbiry.f deleted file mode 100644 index 7ab03bb..0000000 --- a/slatec/cbiry.f +++ /dev/null @@ -1,319 +0,0 @@ -*DECK CBIRY - SUBROUTINE CBIRY (Z, ID, KODE, BI, IERR) -C***BEGIN PROLOGUE CBIRY -C***PURPOSE Compute the Airy function Bi(z) or its derivative dBi/dz -C for complex argument z. A scaling option is available -C to help avoid overflow. -C***LIBRARY SLATEC -C***CATEGORY C10D -C***TYPE COMPLEX (CBIRY-C, ZBIRY-C) -C***KEYWORDS AIRY FUNCTION, BESSEL FUNCTION OF ORDER ONE THIRD, -C BESSEL FUNCTION OF ORDER TWO THIRDS -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C On KODE=1, CBIRY computes the complex Airy function Bi(z) -C or its derivative dBi/dz on ID=0 or ID=1 respectively. -C On KODE=2, a scaling option exp(abs(Re(zeta)))*Bi(z) or -C exp(abs(Re(zeta)))*dBi/dz is provided to remove the -C exponential behavior in both the left and right half planes -C where zeta=(2/3)*z**(3/2). -C -C The Airy functions Bi(z) and dBi/dz are analytic in the -C whole z-plane, and the scaling option does not destroy this -C property. -C -C Input -C Z - Argument of type COMPLEX -C ID - Order of derivative, ID=0 or ID=1 -C KODE - A parameter to indicate the scaling option -C KODE=1 returns -C BI=Bi(z) on ID=0 -C BI=dBi/dz on ID=1 -C at z=Z -C =2 returns -C BI=exp(abs(Re(zeta)))*Bi(z) on ID=0 -C BI=exp(abs(Re(zeta)))*dBi/dz on ID=1 -C at z=Z where zeta=(2/3)*z**(3/2) -C -C Output -C BI - Result of type COMPLEX -C IERR - Error flag -C IERR=0 Normal return - COMPUTATION COMPLETED -C IERR=1 Input error - NO COMPUTATION -C IERR=2 Overflow - NO COMPUTATION -C (Re(Z) too large with KODE=1) -C IERR=3 Precision warning - COMPUTATION COMPLETED -C (Result has less than half precision) -C IERR=4 Precision error - NO COMPUTATION -C (Result has no precision) -C IERR=5 Algorithmic error - NO COMPUTATION -C (Termination condition not met) -C -C *Long Description: -C -C Bi(z) and dBi/dz are computed from I Bessel functions by -C -C Bi(z) = c*sqrt(z)*( I(-1/3,zeta) + I(1/3,zeta) ) -C dBi/dz = c* z *( I(-2/3,zeta) + I(2/3,zeta) ) -C c = 1/sqrt(3) -C zeta = (2/3)*z**(3/2) -C -C when abs(z)>1 and from power series when abs(z)<=1. -C -C In most complex variable computation, one must evaluate ele- -C mentary functions. When the magnitude of Z is large, losses -C of significance by argument reduction occur. Consequently, if -C the magnitude of ZETA=(2/3)*Z**(3/2) exceeds U1=SQRT(0.5/UR), -C then losses exceeding half precision are likely and an error -C flag IERR=3 is triggered where UR=R1MACH(4)=UNIT ROUNDOFF. -C Also, if the magnitude of ZETA is larger than U2=0.5/UR, then -C all significance is lost and IERR=4. In order to use the INT -C function, ZETA must be further restricted not to exceed -C U3=I1MACH(9)=LARGEST INTEGER. Thus, the magnitude of ZETA -C must be restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, -C and U3 are approximately 2.0E+3, 4.2E+6, 2.1E+9 in single -C precision and 4.7E+7, 2.3E+15, 2.1E+9 in double precision. -C This makes U2 limiting is single precision and U3 limiting -C in double precision. This means that the magnitude of Z -C cannot exceed approximately 3.4E+4 in single precision and -C 2.1E+6 in double precision. This also means that one can -C expect to retain, in the worst cases on 32-bit machines, -C no digits in single precision and only 6 digits in double -C precision. -C -C The approximate relative error in the magnitude of a complex -C Bessel function can be expressed as P*10**S where P=MAX(UNIT -C ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- -C sents the increase in error due to argument reduction in the -C elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), -C ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF -C ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may -C have only absolute accuracy. This is most likely to occur -C when one component (in magnitude) is larger than the other by -C several orders of magnitude. If one component is 10**K larger -C than the other, then one can expect only MAX(ABS(LOG10(P))-K, -C 0) significant digits; or, stated another way, when K exceeds -C the exponent of P, no significant digits remain in the smaller -C component. However, the phase angle retains absolute accuracy -C because, in complex arithmetic with precision P, the smaller -C component will not (as a rule) decrease below P times the -C magnitude of the larger component. In these extreme cases, -C the principal phase angle is on the order of +P, -P, PI/2-P, -C or -PI/2+P. -C -C***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- -C matical Functions, National Bureau of Standards -C Applied Mathematics Series 55, U. S. Department -C of Commerce, Tenth Printing (1972) or later. -C 2. D. E. Amos, Computation of Bessel Functions of -C Complex Argument and Large Order, Report SAND83-0643, -C Sandia National Laboratories, Albuquerque, NM, May -C 1983. -C 3. D. E. Amos, A Subroutine Package for Bessel Functions -C of a Complex Argument and Nonnegative Order, Report -C SAND85-1018, Sandia National Laboratory, Albuquerque, -C NM, May 1985. -C 4. D. E. Amos, A portable package for Bessel functions -C of a complex argument and nonnegative order, ACM -C Transactions on Mathematical Software, 12 (September -C 1986), pp. 265-273. -C -C***ROUTINES CALLED CBINU, I1MACH, R1MACH -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 890801 REVISION DATE from Version 3.2 -C 910415 Prologue converted to Version 4.0 format. (BAB) -C 920128 Category corrected. (WRB) -C 920811 Prologue revised. (DWL) -C***END PROLOGUE CBIRY - COMPLEX BI, CONE, CSQ, CY, S1, S2, TRM1, TRM2, Z, ZTA, Z3 - REAL AA, AD, AK, ALIM, ATRM, AZ, AZ3, BB, BK, CK, COEF, C1, C2, - * DIG, DK, D1, D2, ELIM, FID, FMR, FNU, FNUL, PI, RL, R1M5, SFAC, - * TOL, TTH, ZI, ZR, Z3I, Z3R, R1MACH - INTEGER ID, IERR, K, KODE, K1, K2, NZ, I1MACH - DIMENSION CY(2) - DATA TTH, C1, C2, COEF, PI /6.66666666666666667E-01, - * 6.14926627446000736E-01,4.48288357353826359E-01, - * 5.77350269189625765E-01,3.14159265358979324E+00/ - DATA CONE / (1.0E0,0.0E0) / -C***FIRST EXECUTABLE STATEMENT CBIRY - IERR = 0 - NZ=0 - IF (ID.LT.0 .OR. ID.GT.1) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (IERR.NE.0) RETURN - AZ = ABS(Z) - TOL = MAX(R1MACH(4),1.0E-18) - FID = ID - IF (AZ.GT.1.0E0) GO TO 60 -C----------------------------------------------------------------------- -C POWER SERIES FOR ABS(Z).LE.1. -C----------------------------------------------------------------------- - S1 = CONE - S2 = CONE - IF (AZ.LT.TOL) GO TO 110 - AA = AZ*AZ - IF (AA.LT.TOL/AZ) GO TO 40 - TRM1 = CONE - TRM2 = CONE - ATRM = 1.0E0 - Z3 = Z*Z*Z - AZ3 = AZ*AA - AK = 2.0E0 + FID - BK = 3.0E0 - FID - FID - CK = 4.0E0 - FID - DK = 3.0E0 + FID + FID - D1 = AK*DK - D2 = BK*CK - AD = MIN(D1,D2) - AK = 24.0E0 + 9.0E0*FID - BK = 30.0E0 - 9.0E0*FID - Z3R = REAL(Z3) - Z3I = AIMAG(Z3) - DO 30 K=1,25 - TRM1 = TRM1*CMPLX(Z3R/D1,Z3I/D1) - S1 = S1 + TRM1 - TRM2 = TRM2*CMPLX(Z3R/D2,Z3I/D2) - S2 = S2 + TRM2 - ATRM = ATRM*AZ3/AD - D1 = D1 + AK - D2 = D2 + BK - AD = MIN(D1,D2) - IF (ATRM.LT.TOL*AD) GO TO 40 - AK = AK + 18.0E0 - BK = BK + 18.0E0 - 30 CONTINUE - 40 CONTINUE - IF (ID.EQ.1) GO TO 50 - BI = S1*CMPLX(C1,0.0E0) + Z*S2*CMPLX(C2,0.0E0) - IF (KODE.EQ.1) RETURN - ZTA = Z*CSQRT(Z)*CMPLX(TTH,0.0E0) - AA = REAL(ZTA) - AA = -ABS(AA) - BI = BI*CMPLX(EXP(AA),0.0E0) - RETURN - 50 CONTINUE - BI = S2*CMPLX(C2,0.0E0) - IF (AZ.GT.TOL) BI = BI + Z*Z*S1*CMPLX(C1/(1.0E0+FID),0.0E0) - IF (KODE.EQ.1) RETURN - ZTA = Z*CSQRT(Z)*CMPLX(TTH,0.0E0) - AA = REAL(ZTA) - AA = -ABS(AA) - BI = BI*CMPLX(EXP(AA),0.0E0) - RETURN -C----------------------------------------------------------------------- -C CASE FOR ABS(Z).GT.1.0 -C----------------------------------------------------------------------- - 60 CONTINUE - FNU = (1.0E0+FID)/3.0E0 -C----------------------------------------------------------------------- -C SET PARAMETERS RELATED TO MACHINE CONSTANTS. -C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. -C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. -C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND -C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR -C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. -C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. -C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). -C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. -C----------------------------------------------------------------------- - K1 = I1MACH(12) - K2 = I1MACH(13) - R1M5 = R1MACH(5) - K = MIN(ABS(K1),ABS(K2)) - ELIM = 2.303E0*(K*R1M5-3.0E0) - K1 = I1MACH(11) - 1 - AA = R1M5*K1 - DIG = MIN(AA,18.0E0) - AA = AA*2.303E0 - ALIM = ELIM + MAX(-AA,-41.45E0) - RL = 1.2E0*DIG + 3.0E0 - FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) -C----------------------------------------------------------------------- -C TEST FOR RANGE -C----------------------------------------------------------------------- - AA=0.5E0/TOL - BB=I1MACH(9)*0.5E0 - AA=MIN(AA,BB) - AA=AA**TTH - IF (AZ.GT.AA) GO TO 190 - AA=SQRT(AA) - IF (AZ.GT.AA) IERR=3 - CSQ=CSQRT(Z) - ZTA=Z*CSQ*CMPLX(TTH,0.0E0) -C----------------------------------------------------------------------- -C RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL -C----------------------------------------------------------------------- - SFAC = 1.0E0 - ZI = AIMAG(Z) - ZR = REAL(Z) - AK = AIMAG(ZTA) - IF (ZR.GE.0.0E0) GO TO 70 - BK = REAL(ZTA) - CK = -ABS(BK) - ZTA = CMPLX(CK,AK) - 70 CONTINUE - IF (ZI.EQ.0.0E0 .AND. ZR.LE.0.0E0) ZTA = CMPLX(0.0E0,AK) - AA = REAL(ZTA) - IF (KODE.EQ.2) GO TO 80 -C----------------------------------------------------------------------- -C OVERFLOW TEST -C----------------------------------------------------------------------- - BB = ABS(AA) - IF (BB.LT.ALIM) GO TO 80 - BB = BB + 0.25E0*ALOG(AZ) - SFAC = TOL - IF (BB.GT.ELIM) GO TO 170 - 80 CONTINUE - FMR = 0.0E0 - IF (AA.GE.0.0E0 .AND. ZR.GT.0.0E0) GO TO 90 - FMR = PI - IF (ZI.LT.0.0E0) FMR = -PI - ZTA = -ZTA - 90 CONTINUE -C----------------------------------------------------------------------- -C AA=FACTOR FOR ANALYTIC CONTINUATION OF I(FNU,ZTA) -C KODE=2 RETURNS EXP(-ABS(XZTA))*I(FNU,ZTA) FROM CBINU -C----------------------------------------------------------------------- - CALL CBINU(ZTA, FNU, KODE, 1, CY, NZ, RL, FNUL, TOL, ELIM, ALIM) - IF (NZ.LT.0) GO TO 180 - AA = FMR*FNU - Z3 = CMPLX(SFAC,0.0E0) - S1 = CY(1)*CMPLX(COS(AA),SIN(AA))*Z3 - FNU = (2.0E0-FID)/3.0E0 - CALL CBINU(ZTA, FNU, KODE, 2, CY, NZ, RL, FNUL, TOL, ELIM, ALIM) - CY(1) = CY(1)*Z3 - CY(2) = CY(2)*Z3 -C----------------------------------------------------------------------- -C BACKWARD RECUR ONE STEP FOR ORDERS -1/3 OR -2/3 -C----------------------------------------------------------------------- - S2 = CY(1)*CMPLX(FNU+FNU,0.0E0)/ZTA + CY(2) - AA = FMR*(FNU-1.0E0) - S1 = (S1+S2*CMPLX(COS(AA),SIN(AA)))*CMPLX(COEF,0.0E0) - IF (ID.EQ.1) GO TO 100 - S1 = CSQ*S1 - BI = S1*CMPLX(1.0E0/SFAC,0.0E0) - RETURN - 100 CONTINUE - S1 = Z*S1 - BI = S1*CMPLX(1.0E0/SFAC,0.0E0) - RETURN - 110 CONTINUE - AA = C1*(1.0E0-FID) + FID*C2 - BI = CMPLX(AA,0.0E0) - RETURN - 170 CONTINUE - NZ=0 - IERR=2 - RETURN - 180 CONTINUE - IF(NZ.EQ.(-1)) GO TO 170 - NZ=0 - IERR=5 - RETURN - 190 CONTINUE - IERR=4 - NZ=0 - RETURN - END diff --git a/slatec/cbknu.f b/slatec/cbknu.f deleted file mode 100644 index 03ff0a1..0000000 --- a/slatec/cbknu.f +++ /dev/null @@ -1,466 +0,0 @@ -*DECK CBKNU - SUBROUTINE CBKNU (Z, FNU, KODE, N, Y, NZ, TOL, ELIM, ALIM) -C***BEGIN PROLOGUE CBKNU -C***SUBSIDIARY -C***PURPOSE Subsidiary to CAIRY, CBESH, CBESI and CBESK -C***LIBRARY SLATEC -C***TYPE ALL (CBKNU-A, ZBKNU-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C CBKNU COMPUTES THE K BESSEL FUNCTION IN THE RIGHT HALF Z PLANE -C -C***SEE ALSO CAIRY, CBESH, CBESI, CBESK -C***ROUTINES CALLED CKSCL, CSHCH, CUCHK, GAMLN, I1MACH, R1MACH -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CBKNU -C - COMPLEX CCH, CK, COEF, CONE, CRSC, CS, CSCL, CSH, CSR, CSS, CTWO, - * CZ, CZERO, F, FMU, P, PT, P1, P2, Q, RZ, SMU, ST, S1, S2, Y, Z, - * ZD, CELM, CY - REAL AA, AK, ALIM, ASCLE, A1, A2, BB, BK, BRY, CAZ, CC, DNU, - * DNU2, ELIM, ETEST, FC, FHS, FK, FKS, FNU, FPI, G1, G2, HPI, PI, - * P2I, P2M, P2R, RK, RTHPI, R1, S, SPI, TM, TOL, TTH, T1, T2, XX, - * YY, GAMLN, R1MACH, HELIM, ELM, XD, YD, ALAS, AS - INTEGER I, IDUM, IFLAG, INU, K, KFLAG, KK, KMAX, KODE, KODED, N, - * NZ, I1MACH, NW, J, IC, INUB - DIMENSION BRY(3), CC(8), CSS(3), CSR(3), Y(N), CY(2) -C - DATA KMAX / 30 / - DATA R1 / 2.0E0 / - DATA CZERO,CONE,CTWO /(0.0E0,0.0E0),(1.0E0,0.0E0),(2.0E0,0.0E0)/ -C - DATA PI, RTHPI, SPI ,HPI, FPI, TTH / - 1 3.14159265358979324E0, 1.25331413731550025E0, - 2 1.90985931710274403E0, 1.57079632679489662E0, - 3 1.89769999331517738E0, 6.66666666666666666E-01/ -C - DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8)/ - 1 5.77215664901532861E-01, -4.20026350340952355E-02, - 2 -4.21977345555443367E-02, 7.21894324666309954E-03, - 3 -2.15241674114950973E-04, -2.01348547807882387E-05, - 4 1.13302723198169588E-06, 6.11609510448141582E-09/ -C -C***FIRST EXECUTABLE STATEMENT CBKNU - XX = REAL(Z) - YY = AIMAG(Z) - CAZ = ABS(Z) - CSCL = CMPLX(1.0E0/TOL,0.0E0) - CRSC = CMPLX(TOL,0.0E0) - CSS(1) = CSCL - CSS(2) = CONE - CSS(3) = CRSC - CSR(1) = CRSC - CSR(2) = CONE - CSR(3) = CSCL - BRY(1) = 1.0E+3*R1MACH(1)/TOL - BRY(2) = 1.0E0/BRY(1) - BRY(3) = R1MACH(2) - NZ = 0 - IFLAG = 0 - KODED = KODE - RZ = CTWO/Z - INU = FNU+0.5E0 - DNU = FNU - INU - IF (ABS(DNU).EQ.0.5E0) GO TO 110 - DNU2 = 0.0E0 - IF (ABS(DNU).GT.TOL) DNU2 = DNU*DNU - IF (CAZ.GT.R1) GO TO 110 -C----------------------------------------------------------------------- -C SERIES FOR ABS(Z).LE.R1 -C----------------------------------------------------------------------- - FC = 1.0E0 - SMU = CLOG(RZ) - FMU = SMU*CMPLX(DNU,0.0E0) - CALL CSHCH(FMU, CSH, CCH) - IF (DNU.EQ.0.0E0) GO TO 10 - FC = DNU*PI - FC = FC/SIN(FC) - SMU = CSH*CMPLX(1.0E0/DNU,0.0E0) - 10 CONTINUE - A2 = 1.0E0 + DNU -C----------------------------------------------------------------------- -C GAM(1-Z)*GAM(1+Z)=PI*Z/SIN(PI*Z), T1=1/GAM(1-DNU), T2=1/GAM(1+DNU) -C----------------------------------------------------------------------- - T2 = EXP(-GAMLN(A2,IDUM)) - T1 = 1.0E0/(T2*FC) - IF (ABS(DNU).GT.0.1E0) GO TO 40 -C----------------------------------------------------------------------- -C SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) -C----------------------------------------------------------------------- - AK = 1.0E0 - S = CC(1) - DO 20 K=2,8 - AK = AK*DNU2 - TM = CC(K)*AK - S = S + TM - IF (ABS(TM).LT.TOL) GO TO 30 - 20 CONTINUE - 30 G1 = -S - GO TO 50 - 40 CONTINUE - G1 = (T1-T2)/(DNU+DNU) - 50 CONTINUE - G2 = 0.5E0*(T1+T2)*FC - G1 = G1*FC - F = CMPLX(G1,0.0E0)*CCH + SMU*CMPLX(G2,0.0E0) - PT = CEXP(FMU) - P = CMPLX(0.5E0/T2,0.0E0)*PT - Q = CMPLX(0.5E0/T1,0.0E0)/PT - S1 = F - S2 = P - AK = 1.0E0 - A1 = 1.0E0 - CK = CONE - BK = 1.0E0 - DNU2 - IF (INU.GT.0 .OR. N.GT.1) GO TO 80 -C----------------------------------------------------------------------- -C GENERATE K(FNU,Z), 0.0D0 .LE. FNU .LT. 0.5D0 AND N=1 -C----------------------------------------------------------------------- - IF (CAZ.LT.TOL) GO TO 70 - CZ = Z*Z*CMPLX(0.25E0,0.0E0) - T1 = 0.25E0*CAZ*CAZ - 60 CONTINUE - F = (F*CMPLX(AK,0.0E0)+P+Q)*CMPLX(1.0E0/BK,0.0E0) - P = P*CMPLX(1.0E0/(AK-DNU),0.0E0) - Q = Q*CMPLX(1.0E0/(AK+DNU),0.0E0) - RK = 1.0E0/AK - CK = CK*CZ*CMPLX(RK,0.0) - S1 = S1 + CK*F - A1 = A1*T1*RK - BK = BK + AK + AK + 1.0E0 - AK = AK + 1.0E0 - IF (A1.GT.TOL) GO TO 60 - 70 CONTINUE - Y(1) = S1 - IF (KODED.EQ.1) RETURN - Y(1) = S1*CEXP(Z) - RETURN -C----------------------------------------------------------------------- -C GENERATE K(DNU,Z) AND K(DNU+1,Z) FOR FORWARD RECURRENCE -C----------------------------------------------------------------------- - 80 CONTINUE - IF (CAZ.LT.TOL) GO TO 100 - CZ = Z*Z*CMPLX(0.25E0,0.0E0) - T1 = 0.25E0*CAZ*CAZ - 90 CONTINUE - F = (F*CMPLX(AK,0.0E0)+P+Q)*CMPLX(1.0E0/BK,0.0E0) - P = P*CMPLX(1.0E0/(AK-DNU),0.0E0) - Q = Q*CMPLX(1.0E0/(AK+DNU),0.0E0) - RK = 1.0E0/AK - CK = CK*CZ*CMPLX(RK,0.0E0) - S1 = S1 + CK*F - S2 = S2 + CK*(P-F*CMPLX(AK,0.0E0)) - A1 = A1*T1*RK - BK = BK + AK + AK + 1.0E0 - AK = AK + 1.0E0 - IF (A1.GT.TOL) GO TO 90 - 100 CONTINUE - KFLAG = 2 - BK = REAL(SMU) - A1 = FNU + 1.0E0 - AK = A1*ABS(BK) - IF (AK.GT.ALIM) KFLAG = 3 - P2 = S2*CSS(KFLAG) - S2 = P2*RZ - S1 = S1*CSS(KFLAG) - IF (KODED.EQ.1) GO TO 210 - F = CEXP(Z) - S1 = S1*F - S2 = S2*F - GO TO 210 -C----------------------------------------------------------------------- -C IFLAG=0 MEANS NO UNDERFLOW OCCURRED -C IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH -C KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD -C RECURSION -C----------------------------------------------------------------------- - 110 CONTINUE - COEF = CMPLX(RTHPI,0.0E0)/CSQRT(Z) - KFLAG = 2 - IF (KODED.EQ.2) GO TO 120 - IF (XX.GT.ALIM) GO TO 290 -C BLANK LINE - A1 = EXP(-XX)*REAL(CSS(KFLAG)) - PT = CMPLX(A1,0.0E0)*CMPLX(COS(YY),-SIN(YY)) - COEF = COEF*PT - 120 CONTINUE - IF (ABS(DNU).EQ.0.5E0) GO TO 300 -C----------------------------------------------------------------------- -C MILLER ALGORITHM FOR ABS(Z).GT.R1 -C----------------------------------------------------------------------- - AK = COS(PI*DNU) - AK = ABS(AK) - IF (AK.EQ.0.0E0) GO TO 300 - FHS = ABS(0.25E0-DNU2) - IF (FHS.EQ.0.0E0) GO TO 300 -C----------------------------------------------------------------------- -C COMPUTE R2=F(E). IF ABS(Z).GE.R2, USE FORWARD RECURRENCE TO -C DETERMINE THE BACKWARD INDEX K. R2=F(E) IS A STRAIGHT LINE ON -C 12.LE.E.LE.60. E IS COMPUTED FROM 2**(-E)=B**(1-I1MACH(11))= -C TOL WHERE B IS THE BASE OF THE ARITHMETIC. -C----------------------------------------------------------------------- - T1 = (I1MACH(11)-1)*R1MACH(5)*3.321928094E0 - T1 = MAX(T1,12.0E0) - T1 = MIN(T1,60.0E0) - T2 = TTH*T1 - 6.0E0 - IF (XX.NE.0.0E0) GO TO 130 - T1 = HPI - GO TO 140 - 130 CONTINUE - T1 = ATAN(YY/XX) - T1 = ABS(T1) - 140 CONTINUE - IF (T2.GT.CAZ) GO TO 170 -C----------------------------------------------------------------------- -C FORWARD RECURRENCE LOOP WHEN ABS(Z).GE.R2 -C----------------------------------------------------------------------- - ETEST = AK/(PI*CAZ*TOL) - FK = 1.0E0 - IF (ETEST.LT.1.0E0) GO TO 180 - FKS = 2.0E0 - RK = CAZ + CAZ + 2.0E0 - A1 = 0.0E0 - A2 = 1.0E0 - DO 150 I=1,KMAX - AK = FHS/FKS - BK = RK/(FK+1.0E0) - TM = A2 - A2 = BK*A2 - AK*A1 - A1 = TM - RK = RK + 2.0E0 - FKS = FKS + FK + FK + 2.0E0 - FHS = FHS + FK + FK - FK = FK + 1.0E0 - TM = ABS(A2)*FK - IF (ETEST.LT.TM) GO TO 160 - 150 CONTINUE - GO TO 310 - 160 CONTINUE - FK = FK + SPI*T1*SQRT(T2/CAZ) - FHS = ABS(0.25E0-DNU2) - GO TO 180 - 170 CONTINUE -C----------------------------------------------------------------------- -C COMPUTE BACKWARD INDEX K FOR ABS(Z).LT.R2 -C----------------------------------------------------------------------- - A2 = SQRT(CAZ) - AK = FPI*AK/(TOL*SQRT(A2)) - AA = 3.0E0*T1/(1.0E0+CAZ) - BB = 14.7E0*T1/(28.0E0+CAZ) - AK = (ALOG(AK)+CAZ*COS(AA)/(1.0E0+0.008E0*CAZ))/COS(BB) - FK = 0.12125E0*AK*AK/CAZ + 1.5E0 - 180 CONTINUE - K = FK -C----------------------------------------------------------------------- -C BACKWARD RECURRENCE LOOP FOR MILLER ALGORITHM -C----------------------------------------------------------------------- - FK = K - FKS = FK*FK - P1 = CZERO - P2 = CMPLX(TOL,0.0E0) - CS = P2 - DO 190 I=1,K - A1 = FKS - FK - A2 = (FKS+FK)/(A1+FHS) - RK = 2.0E0/(FK+1.0E0) - T1 = (FK+XX)*RK - T2 = YY*RK - PT = P2 - P2 = (P2*CMPLX(T1,T2)-P1)*CMPLX(A2,0.0E0) - P1 = PT - CS = CS + P2 - FKS = A1 - FK + 1.0E0 - FK = FK - 1.0E0 - 190 CONTINUE -C----------------------------------------------------------------------- -C COMPUTE (P2/CS)=(P2/ABS(CS))*(CONJG(CS)/ABS(CS)) FOR BETTER -C SCALING -C----------------------------------------------------------------------- - TM = ABS(CS) - PT = CMPLX(1.0E0/TM,0.0E0) - S1 = PT*P2 - CS = CONJG(CS)*PT - S1 = COEF*S1*CS - IF (INU.GT.0 .OR. N.GT.1) GO TO 200 - ZD = Z - IF(IFLAG.EQ.1) GO TO 270 - GO TO 240 - 200 CONTINUE -C----------------------------------------------------------------------- -C COMPUTE P1/P2=(P1/ABS(P2)*CONJG(P2)/ABS(P2) FOR SCALING -C----------------------------------------------------------------------- - TM = ABS(P2) - PT = CMPLX(1.0E0/TM,0.0E0) - P1 = PT*P1 - P2 = CONJG(P2)*PT - PT = P1*P2 - S2 = S1*(CONE+(CMPLX(DNU+0.5E0,0.0E0)-PT)/Z) -C----------------------------------------------------------------------- -C FORWARD RECURSION ON THE THREE TERM RECURSION RELATION WITH -C SCALING NEAR EXPONENT EXTREMES ON KFLAG=1 OR KFLAG=3 -C----------------------------------------------------------------------- - 210 CONTINUE - CK = CMPLX(DNU+1.0E0,0.0E0)*RZ - IF (N.EQ.1) INU = INU - 1 - IF (INU.GT.0) GO TO 220 - IF (N.EQ.1) S1=S2 - ZD = Z - IF(IFLAG.EQ.1) GO TO 270 - GO TO 240 - 220 CONTINUE - INUB = 1 - IF (IFLAG.EQ.1) GO TO 261 - 225 CONTINUE - P1 = CSR(KFLAG) - ASCLE = BRY(KFLAG) - DO 230 I=INUB,INU - ST = S2 - S2 = CK*S2 + S1 - S1 = ST - CK = CK + RZ - IF (KFLAG.GE.3) GO TO 230 - P2 = S2*P1 - P2R = REAL(P2) - P2I = AIMAG(P2) - P2R = ABS(P2R) - P2I = ABS(P2I) - P2M = MAX(P2R,P2I) - IF (P2M.LE.ASCLE) GO TO 230 - KFLAG = KFLAG + 1 - ASCLE = BRY(KFLAG) - S1 = S1*P1 - S2 = P2 - S1 = S1*CSS(KFLAG) - S2 = S2*CSS(KFLAG) - P1 = CSR(KFLAG) - 230 CONTINUE - IF (N.EQ.1) S1 = S2 - 240 CONTINUE - Y(1) = S1*CSR(KFLAG) - IF (N.EQ.1) RETURN - Y(2) = S2*CSR(KFLAG) - IF (N.EQ.2) RETURN - KK = 2 - 250 CONTINUE - KK = KK + 1 - IF (KK.GT.N) RETURN - P1 = CSR(KFLAG) - ASCLE = BRY(KFLAG) - DO 260 I=KK,N - P2 = S2 - S2 = CK*S2 + S1 - S1 = P2 - CK = CK + RZ - P2 = S2*P1 - Y(I) = P2 - IF (KFLAG.GE.3) GO TO 260 - P2R = REAL(P2) - P2I = AIMAG(P2) - P2R = ABS(P2R) - P2I = ABS(P2I) - P2M = MAX(P2R,P2I) - IF (P2M.LE.ASCLE) GO TO 260 - KFLAG = KFLAG + 1 - ASCLE = BRY(KFLAG) - S1 = S1*P1 - S2 = P2 - S1 = S1*CSS(KFLAG) - S2 = S2*CSS(KFLAG) - P1 = CSR(KFLAG) - 260 CONTINUE - RETURN -C----------------------------------------------------------------------- -C IFLAG=1 CASES, FORWARD RECURRENCE ON SCALED VALUES ON UNDERFLOW -C----------------------------------------------------------------------- - 261 CONTINUE - HELIM = 0.5E0*ELIM - ELM = EXP(-ELIM) - CELM = CMPLX(ELM,0.0) - ASCLE = BRY(1) - ZD = Z - XD = XX - YD = YY - IC = -1 - J = 2 - DO 262 I=1,INU - ST = S2 - S2 = CK*S2+S1 - S1 = ST - CK = CK+RZ - AS = ABS(S2) - ALAS = ALOG(AS) - P2R = -XD+ALAS - IF(P2R.LT.(-ELIM)) GO TO 263 - P2 = -ZD+CLOG(S2) - P2R = REAL(P2) - P2I = AIMAG(P2) - P2M = EXP(P2R)/TOL - P1 = CMPLX(P2M,0.0E0)*CMPLX(COS(P2I),SIN(P2I)) - CALL CUCHK(P1,NW,ASCLE,TOL) - IF(NW.NE.0) GO TO 263 - J=3-J - CY(J) = P1 - IF(IC.EQ.(I-1)) GO TO 264 - IC = I - GO TO 262 - 263 CONTINUE - IF(ALAS.LT.HELIM) GO TO 262 - XD = XD-ELIM - S1 = S1*CELM - S2 = S2*CELM - ZD = CMPLX(XD,YD) - 262 CONTINUE - IF(N.EQ.1) S1 = S2 - GO TO 270 - 264 CONTINUE - KFLAG = 1 - INUB = I+1 - S2 = CY(J) - J = 3 - J - S1 = CY(J) - IF(INUB.LE.INU) GO TO 225 - IF(N.EQ.1) S1 = S2 - GO TO 240 - 270 CONTINUE - Y(1) = S1 - IF (N.EQ.1) GO TO 280 - Y(2) = S2 - 280 CONTINUE - ASCLE = BRY(1) - CALL CKSCL(ZD, FNU, N, Y, NZ, RZ, ASCLE, TOL, ELIM) - INU = N - NZ - IF (INU.LE.0) RETURN - KK = NZ + 1 - S1 = Y(KK) - Y(KK) = S1*CSR(1) - IF (INU.EQ.1) RETURN - KK = NZ + 2 - S2 = Y(KK) - Y(KK) = S2*CSR(1) - IF (INU.EQ.2) RETURN - T2 = FNU + (KK-1) - CK = CMPLX(T2,0.0E0)*RZ - KFLAG = 1 - GO TO 250 - 290 CONTINUE -C----------------------------------------------------------------------- -C SCALE BY EXP(Z), IFLAG = 1 CASES -C----------------------------------------------------------------------- - KODED = 2 - IFLAG = 1 - KFLAG = 2 - GO TO 120 -C----------------------------------------------------------------------- -C FNU=HALF ODD INTEGER CASE, DNU=-0.5 -C----------------------------------------------------------------------- - 300 CONTINUE - S1 = COEF - S2 = COEF - GO TO 210 - 310 CONTINUE - NZ=-2 - RETURN - END diff --git a/slatec/cblkt1.f b/slatec/cblkt1.f deleted file mode 100644 index eadbbff..0000000 --- a/slatec/cblkt1.f +++ /dev/null @@ -1,251 +0,0 @@ -*DECK CBLKT1 - SUBROUTINE CBLKT1 (N, AN, BN, CN, M, AM, BM, CM, IDIMY, Y, B, W1, - + W2, W3, WD, WW, WU, PRDCT, CPRDCT) -C***BEGIN PROLOGUE CBLKT1 -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBLKTR -C***LIBRARY SLATEC -C***TYPE COMPLEX (BLKTR1-S, CBLKT1-C) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C CBLKT1 solves the linear system of routine CBLKTR. -C -C B contains the roots of all the B polynomials. -C W1,W2,W3,WD,WW,WU are all working arrays. -C PRDCT is either PROCP or PROC depending on whether the boundary -C conditions in the M direction are periodic or not. -C CPRDCT is either CPROCP or CPROC which are called if some of the zeros -C of the B polynomials are complex. -C -C***SEE ALSO CBLKTR -C***ROUTINES CALLED INXCA, INXCB, INXCC -C***COMMON BLOCKS CCBLK -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE CBLKT1 -C - DIMENSION AN(*) ,BN(*) ,CN(*) ,AM(*) , - 1 BM(*) ,CM(*) ,B(*) ,W1(*) , - 2 W2(*) ,W3(*) ,WD(*) ,WW(*) , - 3 WU(*) ,Y(IDIMY,*) - COMMON /CCBLK/ NPP ,K ,EPS ,CNV , - 1 NM ,NCMPLX ,IK - COMPLEX AM ,BM ,CM ,Y , - 1 W1 ,W2 ,W3 ,WD , - 2 WW ,WU -C***FIRST EXECUTABLE STATEMENT CBLKT1 - KDO = K-1 - DO 109 L=1,KDO - IR = L-1 - I2 = 2**IR - I1 = I2/2 - I3 = I2+I1 - I4 = I2+I2 - IRM1 = IR-1 - CALL INXCB (I2,IR,IM2,NM2) - CALL INXCB (I1,IRM1,IM3,NM3) - CALL INXCB (I3,IRM1,IM1,NM1) - CALL PRDCT (NM2,B(IM2),NM3,B(IM3),NM1,B(IM1),0,DUM,Y(1,I2),W3, - 1 M,AM,BM,CM,WD,WW,WU) - IF = 2**K - DO 108 I=I4,IF,I4 - IF (I-NM) 101,101,108 - 101 IPI1 = I+I1 - IPI2 = I+I2 - IPI3 = I+I3 - CALL INXCC (I,IR,IDXC,NC) - IF (I-IF) 102,108,108 - 102 CALL INXCA (I,IR,IDXA,NA) - CALL INXCB (I-I1,IRM1,IM1,NM1) - CALL INXCB (IPI2,IR,IP2,NP2) - CALL INXCB (IPI1,IRM1,IP1,NP1) - CALL INXCB (IPI3,IRM1,IP3,NP3) - CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W3,W1,M,AM, - 1 BM,CM,WD,WW,WU) - IF (IPI2-NM) 105,105,103 - 103 DO 104 J=1,M - W3(J) = (0.,0.) - W2(J) = (0.,0.) - 104 CONTINUE - GO TO 106 - 105 CALL PRDCT (NP2,B(IP2),NP1,B(IP1),NP3,B(IP3),0,DUM, - 1 Y(1,IPI2),W3,M,AM,BM,CM,WD,WW,WU) - CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),W3,W2,M,AM, - 1 BM,CM,WD,WW,WU) - 106 DO 107 J=1,M - Y(J,I) = W1(J)+W2(J)+Y(J,I) - 107 CONTINUE - 108 CONTINUE - 109 CONTINUE - IF (NPP) 132,110,132 -C -C THE PERIODIC CASE IS TREATED USING THE CAPACITANCE MATRIX METHOD -C - 110 IF = 2**K - I = IF/2 - I1 = I/2 - CALL INXCB (I-I1,K-2,IM1,NM1) - CALL INXCB (I+I1,K-2,IP1,NP1) - CALL INXCB (I,K-1,IZ,NZ) - CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,Y(1,I),W1,M,AM, - 1 BM,CM,WD,WW,WU) - IZR = I - DO 111 J=1,M - W2(J) = W1(J) - 111 CONTINUE - DO 113 LL=2,K - L = K-LL+1 - IR = L-1 - I2 = 2**IR - I1 = I2/2 - I = I2 - CALL INXCC (I,IR,IDXC,NC) - CALL INXCB (I,IR,IZ,NZ) - CALL INXCB (I-I1,IR-1,IM1,NM1) - CALL INXCB (I+I1,IR-1,IP1,NP1) - CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),W1,W1,M,AM,BM, - 1 CM,WD,WW,WU) - DO 112 J=1,M - W1(J) = Y(J,I)+W1(J) - 112 CONTINUE - CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W1,W1,M,AM, - 1 BM,CM,WD,WW,WU) - 113 CONTINUE - DO 118 LL=2,K - L = K-LL+1 - IR = L-1 - I2 = 2**IR - I1 = I2/2 - I4 = I2+I2 - IFD = IF-I2 - DO 117 I=I2,IFD,I4 - IF (I-I2-IZR) 117,114,117 - 114 IF (I-NM) 115,115,118 - 115 CALL INXCA (I,IR,IDXA,NA) - CALL INXCB (I,IR,IZ,NZ) - CALL INXCB (I-I1,IR-1,IM1,NM1) - CALL INXCB (I+I1,IR-1,IP1,NP1) - CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W2,W2,M,AM, - 1 BM,CM,WD,WW,WU) - DO 116 J=1,M - W2(J) = Y(J,I)+W2(J) - 116 CONTINUE - CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W2,W2,M, - 1 AM,BM,CM,WD,WW,WU) - IZR = I - IF (I-NM) 117,119,117 - 117 CONTINUE - 118 CONTINUE - 119 DO 120 J=1,M - Y(J,NM+1) = Y(J,NM+1)-CN(NM+1)*W1(J)-AN(NM+1)*W2(J) - 120 CONTINUE - CALL INXCB (IF/2,K-1,IM1,NM1) - CALL INXCB (IF,K-1,IP,NP) - IF (NCMPLX) 121,122,121 - 121 CALL CPRDCT (NM+1,B(IP),NM1,B(IM1),0,DUM,0,DUM,Y(1,NM+1), - 1 Y(1,NM+1),M,AM,BM,CM,W1,W3,WW) - GO TO 123 - 122 CALL PRDCT (NM+1,B(IP),NM1,B(IM1),0,DUM,0,DUM,Y(1,NM+1), - 1 Y(1,NM+1),M,AM,BM,CM,WD,WW,WU) - 123 DO 124 J=1,M - W1(J) = AN(1)*Y(J,NM+1) - W2(J) = CN(NM)*Y(J,NM+1) - Y(J,1) = Y(J,1)-W1(J) - Y(J,NM) = Y(J,NM)-W2(J) - 124 CONTINUE - DO 126 L=1,KDO - IR = L-1 - I2 = 2**IR - I4 = I2+I2 - I1 = I2/2 - I = I4 - CALL INXCA (I,IR,IDXA,NA) - CALL INXCB (I-I2,IR,IM2,NM2) - CALL INXCB (I-I2-I1,IR-1,IM3,NM3) - CALL INXCB (I-I1,IR-1,IM1,NM1) - CALL PRDCT (NM2,B(IM2),NM3,B(IM3),NM1,B(IM1),0,DUM,W1,W1,M,AM, - 1 BM,CM,WD,WW,WU) - CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W1,W1,M,AM,BM, - 1 CM,WD,WW,WU) - DO 125 J=1,M - Y(J,I) = Y(J,I)-W1(J) - 125 CONTINUE - 126 CONTINUE -C - IZR = NM - DO 131 L=1,KDO - IR = L-1 - I2 = 2**IR - I1 = I2/2 - I3 = I2+I1 - I4 = I2+I2 - IRM1 = IR-1 - DO 130 I=I4,IF,I4 - IPI1 = I+I1 - IPI2 = I+I2 - IPI3 = I+I3 - IF (IPI2-IZR) 127,128,127 - 127 IF (I-IZR) 130,131,130 - 128 CALL INXCC (I,IR,IDXC,NC) - CALL INXCB (IPI2,IR,IP2,NP2) - CALL INXCB (IPI1,IRM1,IP1,NP1) - CALL INXCB (IPI3,IRM1,IP3,NP3) - CALL PRDCT (NP2,B(IP2),NP1,B(IP1),NP3,B(IP3),0,DUM,W2,W2,M, - 1 AM,BM,CM,WD,WW,WU) - CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),W2,W2,M,AM, - 1 BM,CM,WD,WW,WU) - DO 129 J=1,M - Y(J,I) = Y(J,I)-W2(J) - 129 CONTINUE - IZR = I - GO TO 131 - 130 CONTINUE - 131 CONTINUE -C -C BEGIN BACK SUBSTITUTION PHASE -C - 132 DO 144 LL=1,K - L = K-LL+1 - IR = L-1 - IRM1 = IR-1 - I2 = 2**IR - I1 = I2/2 - I4 = I2+I2 - IFD = IF-I2 - DO 143 I=I2,IFD,I4 - IF (I-NM) 133,133,143 - 133 IMI1 = I-I1 - IMI2 = I-I2 - IPI1 = I+I1 - IPI2 = I+I2 - CALL INXCA (I,IR,IDXA,NA) - CALL INXCC (I,IR,IDXC,NC) - CALL INXCB (I,IR,IZ,NZ) - CALL INXCB (IMI1,IRM1,IM1,NM1) - CALL INXCB (IPI1,IRM1,IP1,NP1) - IF (I-I2) 134,134,136 - 134 DO 135 J=1,M - W1(J) = (0.,0.) - 135 CONTINUE - GO TO 137 - 136 CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),Y(1,IMI2), - 1 W1,M,AM,BM,CM,WD,WW,WU) - 137 IF (IPI2-NM) 140,140,138 - 138 DO 139 J=1,M - W2(J) = (0.,0.) - 139 CONTINUE - GO TO 141 - 140 CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),Y(1,IPI2), - 1 W2,M,AM,BM,CM,WD,WW,WU) - 141 DO 142 J=1,M - W1(J) = Y(J,I)+W1(J)+W2(J) - 142 CONTINUE - CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W1,Y(1,I), - 1 M,AM,BM,CM,WD,WW,WU) - 143 CONTINUE - 144 CONTINUE - RETURN - END diff --git a/slatec/cblktr.f b/slatec/cblktr.f deleted file mode 100644 index 033165d..0000000 --- a/slatec/cblktr.f +++ /dev/null @@ -1,267 +0,0 @@ -*DECK CBLKTR - SUBROUTINE CBLKTR (IFLG, NP, N, AN, BN, CN, MP, M, AM, BM, CM, - + IDIMY, Y, IERROR, W) -C***BEGIN PROLOGUE CBLKTR -C***PURPOSE Solve a block tridiagonal system of linear equations -C (usually resulting from the discretization of separable -C two-dimensional elliptic equations). -C***LIBRARY SLATEC (FISHPACK) -C***CATEGORY I2B4B -C***TYPE COMPLEX (BLKTRI-S, CBLKTR-C) -C***KEYWORDS ELLIPTIC PDE, FISHPACK, TRIDIAGONAL LINEAR SYSTEM -C***AUTHOR Adams, J., (NCAR) -C Swarztrauber, P. N., (NCAR) -C Sweet, R., (NCAR) -C***DESCRIPTION -C -C Subroutine CBLKTR is a complex version of subroutine BLKTRI. -C Both subroutines solve a system of linear equations of the form -C -C AN(J)*X(I,J-1) + AM(I)*X(I-1,J) + (BN(J)+BM(I))*X(I,J) -C -C + CN(J)*X(I,J+1) + CM(I)*X(I+1,J) = Y(I,J) -C -C For I = 1,2,...,M and J = 1,2,...,N. -C -C I+1 and I-1 are evaluated modulo M and J+1 and J-1 modulo N, i.e., -C -C X(I,0) = X(I,N), X(I,N+1) = X(I,1), -C X(0,J) = X(M,J), X(M+1,J) = X(1,J). -C -C These equations usually result from the discretization of -C separable elliptic equations. Boundary conditions may be -C Dirichlet, Neumann, or periodic. -C -C -C * * * * * * * * * * On INPUT * * * * * * * * * * -C -C IFLG -C = 0 Initialization only. Certain quantities that depend on NP, -C N, AN, BN, and CN are computed and stored in the work -C array W. -C = 1 The quantities that were computed in the initialization are -C used to obtain the solution X(I,J). -C -C NOTE A call with IFLG=0 takes approximately one half the time -C time as a call with IFLG = 1. However, the -C initialization does not have to be repeated unless NP, N, -C AN, BN, or CN change. -C -C NP -C = 0 If AN(1) and CN(N) are not zero, which corresponds to -C periodic boundary conditions. -C = 1 If AN(1) and CN(N) are zero. -C -C N -C The number of unknowns in the J-direction. N must be greater -C than 4. The operation count is proportional to MNlog2(N), hence -C N should be selected less than or equal to M. -C -C AN,BN,CN -C Real one-dimensional arrays of length N that specify the -C coefficients in the linear equations given above. -C -C MP -C = 0 If AM(1) and CM(M) are not zero, which corresponds to -C periodic boundary conditions. -C = 1 If AM(1) = CM(M) = 0 . -C -C M -C The number of unknowns in the I-direction. M must be greater -C than 4. -C -C AM,BM,CM -C Complex one-dimensional arrays of length M that specify the -C coefficients in the linear equations given above. -C -C IDIMY -C The row (or first) dimension of the two-dimensional array Y as -C it appears in the program calling BLKTRI. This parameter is -C used to specify the variable dimension of Y. IDIMY must be at -C least M. -C -C Y -C A complex two-dimensional array that specifies the values of -C the right side of the linear system of equations given above. -C Y must be dimensioned Y(IDIMY,N) with IDIMY .GE. M. -C -C W -C A one-dimensional array that must be provided by the user for -C work space. -C If NP=1 define K=INT(log2(N))+1 and set L=2**(K+1) then -C W must have dimension (K-2)*L+K+5+MAX(2N,12M) -C -C If NP=0 define K=INT(log2(N-1))+1 and set L=2**(K+1) then -C W must have dimension (K-2)*L+K+5+2N+MAX(2N,12M) -C -C **IMPORTANT** For purposes of checking, the required dimension -C of W is computed by BLKTRI and stored in W(1) -C in floating point format. -C -C * * * * * * * * * * On Output * * * * * * * * * * -C -C Y -C Contains the solution X. -C -C IERROR -C An error flag that indicates invalid input parameters. Except -C for number zero, a solution is not attempted. -C -C = 0 No error. -C = 1 M is less than 5. -C = 2 N is less than 5. -C = 3 IDIMY is less than M. -C = 4 BLKTRI failed while computing results that depend on the -C coefficient arrays AN, BN, CN. Check these arrays. -C = 5 AN(J)*CN(J-1) is less than 0 for some J. Possible reasons -C for this condition are -C 1. The arrays AN and CN are not correct. -C 2. Too large a grid spacing was used in the discretization -C of the elliptic equation. -C 3. The linear equations resulted from a partial -C differential equation which was not elliptic. -C -C W -C Contains intermediate values that must not be destroyed if -C CBLKTR will be called again with IFLG=1. W(1) contains the -C number of locations required by W in floating point format. -C -C *Long Description: -C -C * * * * * * * Program Specifications * * * * * * * * * * * * -C -C Dimension of AN(N),BN(N),CN(N),AM(M),BM(M),CM(M),Y(IDIMY,N) -C Arguments W(see argument list) -C -C Latest June 1979 -C Revision -C -C Required CBLKTR,CBLKT1,PROC,PROCP,CPROC,CPROCP,CCMPB,INXCA, -C Subprograms INXCB,INXCC,CPADD,PGSF,PPGSF,PPPSF,BCRH,TEVLC, -C R1MACH -C -C Special The algorithm may fail if ABS(BM(I)+BN(J)) is less -C Conditions than ABS(AM(I))+ABS(AN(J))+ABS(CM(I))+ABS(CN(J)) -C for some I and J. The algorithm will also fail if -C AN(J)*CN(J-1) is less than zero for some J. -C See the description of the output parameter IERROR. -C -C Common CCBLK -C Blocks -C -C I/O NONE -C -C Precision Single -C -C Specialist Paul Swarztrauber -C -C Language FORTRAN -C -C History CBLKTR is a complex version of BLKTRI (version 3) -C -C Algorithm Generalized Cyclic Reduction (see reference below) -C -C Space -C Required CONTROL DATA 7600 -C -C Portability American National Standards Institute FORTRAN. -C The machine accuracy is set using function R1MACH. -C -C Required NONE -C Resident -C Routines -C -C References Swarztrauber,P. and R. SWEET, 'Efficient Fortran -C Subprograms for the solution of elliptic equations' -C NCAR TN/IA-109, July, 1975, 138 PP. -C -C SWARZTRAUBER P. ,'A Direct Method for The Discrete -C Solution of Separable Elliptic Equations', SIAM -C J. Numer. Anal.,11(1974) PP. 1136-1150. -C -C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -C -C***REFERENCES P. N. Swarztrauber and R. Sweet, Efficient Fortran -C subprograms for the solution of elliptic equations, -C NCAR TN/IA-109, July 1975, 138 pp. -C P. N. Swarztrauber, A direct method for the discrete -C solution of separable elliptic equations, SIAM Journal -C on Numerical Analysis 11, (1974), pp. 1136-1150. -C***ROUTINES CALLED CBLKT1, CCMPB, CPROC, CPROCP, PROC, PROCP -C***COMMON BLOCKS CCBLK -C***REVISION HISTORY (YYMMDD) -C 801001 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 CBLKTR -C - DIMENSION AN(*) ,BN(*) ,CN(*) ,AM(*) , - 1 BM(*) ,CM(*) ,Y(IDIMY,*) ,W(*) - EXTERNAL PROC ,PROCP ,CPROC ,CPROCP - COMMON /CCBLK/ NPP ,K ,EPS ,CNV , - 1 NM ,NCMPLX ,IK - COMPLEX AM ,BM ,CM ,Y -C***FIRST EXECUTABLE STATEMENT CBLKTR - NM = N - M2 = M+M - IERROR = 0 - IF (M-5) 101,102,102 - 101 IERROR = 1 - GO TO 119 - 102 IF (NM-3) 103,104,104 - 103 IERROR = 2 - GO TO 119 - 104 IF (IDIMY-M) 105,106,106 - 105 IERROR = 3 - GO TO 119 - 106 NH = N - NPP = NP - IF (NPP) 107,108,107 - 107 NH = NH+1 - 108 IK = 2 - K = 1 - 109 IK = IK+IK - K = K+1 - IF (NH-IK) 110,110,109 - 110 NL = IK - IK = IK+IK - NL = NL-1 - IWAH = (K-2)*IK+K+6 - IF (NPP) 111,112,111 -C -C DIVIDE W INTO WORKING SUB ARRAYS -C - 111 IW1 = IWAH - IWBH = IW1+NM - W(1) = IW1-1+MAX(2*NM,12*M) - GO TO 113 - 112 IWBH = IWAH+NM+NM - IW1 = IWBH - W(1) = IW1-1+MAX(2*NM,12*M) - NM = NM-1 -C -C SUBROUTINE CCMPB COMPUTES THE ROOTS OF THE B POLYNOMIALS -C - 113 IF (IERROR) 119,114,119 - 114 IW2 = IW1+M2 - IW3 = IW2+M2 - IWD = IW3+M2 - IWW = IWD+M2 - IWU = IWW+M2 - IF (IFLG) 116,115,116 - 115 CALL CCMPB (NL,IERROR,AN,BN,CN,W(2),W(IWAH),W(IWBH)) - GO TO 119 - 116 IF (MP) 117,118,117 -C -C SUBROUTINE CBLKT1 SOLVES THE LINEAR SYSTEM -C - 117 CALL CBLKT1 (NL,AN,BN,CN,M,AM,BM,CM,IDIMY,Y,W(2),W(IW1),W(IW2), - 1 W(IW3),W(IWD),W(IWW),W(IWU),PROC,CPROC) - GO TO 119 - 118 CALL CBLKT1 (NL,AN,BN,CN,M,AM,BM,CM,IDIMY,Y,W(2),W(IW1),W(IW2), - 1 W(IW3),W(IWD),W(IWW),W(IWU),PROCP,CPROCP) - 119 CONTINUE - RETURN - END diff --git a/slatec/cbrt.f b/slatec/cbrt.f deleted file mode 100644 index 980863d..0000000 --- a/slatec/cbrt.f +++ /dev/null @@ -1,54 +0,0 @@ -*DECK CBRT - FUNCTION CBRT (X) -C***BEGIN PROLOGUE CBRT -C***PURPOSE Compute the cube root. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C2 -C***TYPE SINGLE PRECISION (CBRT-S, DCBRT-D, CCBRT-C) -C***KEYWORDS CUBE ROOT, ELEMENTARY FUNCTIONS, FNLIB, ROOTS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C CBRT(X) calculates the cube root of X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH, R9PAK, R9UPAK -C***REVISION HISTORY (YYMMDD) -C 770601 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***END PROLOGUE CBRT - DIMENSION CBRT2(5) - SAVE CBRT2, NITER - DATA CBRT2(1) / 0.6299605249 4743658E0 / - DATA CBRT2(2) / 0.7937005259 8409974E0 / - DATA CBRT2(3) / 1.0E0 / - DATA CBRT2(4) / 1.2599210498 9487316E0 / - DATA CBRT2(5) / 1.5874010519 6819947E0 / - DATA NITER / 0 / -C***FIRST EXECUTABLE STATEMENT CBRT - IF (NITER.EQ.0) NITER = 1.443*LOG(-.106*LOG(0.1*R1MACH(3))) + 1. -C - CBRT = 0.0 - IF (X.EQ.0.) RETURN -C - CALL R9UPAK (ABS(X), Y, N) - IXPNT = N/3 - IREM = N - 3*IXPNT + 3 -C -C THE APPROXIMATION BELOW IS A GENERALIZED CHEBYSHEV SERIES CONVERTED -C TO POLYNOMIAL FORM. THE APPROX IS NEARLY BEST IN THE SENSE OF -C RELATIVE ERROR WITH 4.085 DIGITS ACCURACY. -C - CBRT = .439581E0 + Y*(.928549E0 + Y*(-.512653E0 + Y*.144586E0)) -C - DO 10 ITER=1,NITER - CBRTSQ = CBRT*CBRT - CBRT = CBRT + (Y-CBRT*CBRTSQ)/(3.0*CBRTSQ) - 10 CONTINUE -C - CBRT = R9PAK (CBRT2(IREM)*SIGN(CBRT,X), IXPNT) - RETURN -C - END diff --git a/slatec/cbuni.f b/slatec/cbuni.f deleted file mode 100644 index 629851c..0000000 --- a/slatec/cbuni.f +++ /dev/null @@ -1,169 +0,0 @@ -*DECK CBUNI - SUBROUTINE CBUNI (Z, FNU, KODE, N, Y, NZ, NUI, NLAST, FNUL, TOL, - + ELIM, ALIM) -C***BEGIN PROLOGUE CBUNI -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBESI and CBESK -C***LIBRARY SLATEC -C***TYPE ALL (CBUNI-A, ZBUNI-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C CBUNI COMPUTES THE I BESSEL FUNCTION FOR LARGE ABS(Z).GT. -C FNUL AND FNU+N-1.LT.FNUL. THE ORDER IS INCREASED FROM -C FNU+N-1 GREATER THAN FNUL BY ADDING NUI AND COMPUTING -C ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR I(FNU,Z) -C ON IFORM=1 AND THE EXPANSION FOR J(FNU,Z) ON IFORM=2 -C -C***SEE ALSO CBESI, CBESK -C***ROUTINES CALLED CUNI1, CUNI2, R1MACH -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CBUNI - COMPLEX CSCL, CSCR, CY, RZ, ST, S1, S2, Y, Z - REAL ALIM, AX, AY, DFNU, ELIM, FNU, FNUI, FNUL, GNU, TOL, XX, YY, - * ASCLE, BRY, STR, STI, STM, R1MACH - INTEGER I, IFLAG, IFORM, K, KODE, N, NL, NLAST, NUI, NW, NZ - DIMENSION Y(N), CY(2), BRY(3) -C***FIRST EXECUTABLE STATEMENT CBUNI - NZ = 0 - XX = REAL(Z) - YY = AIMAG(Z) - AX = ABS(XX)*1.7321E0 - AY = ABS(YY) - IFORM = 1 - IF (AY.GT.AX) IFORM = 2 - IF (NUI.EQ.0) GO TO 60 - FNUI = NUI - DFNU = FNU + (N-1) - GNU = DFNU + FNUI - IF (IFORM.EQ.2) GO TO 10 -C----------------------------------------------------------------------- -C ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN -C -PI/3.LE.ARG(Z).LE.PI/3 -C----------------------------------------------------------------------- - CALL CUNI1(Z, GNU, KODE, 2, CY, NW, NLAST, FNUL, TOL, ELIM, ALIM) - GO TO 20 - 10 CONTINUE -C----------------------------------------------------------------------- -C ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU -C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I -C AND HPI=PI/2 -C----------------------------------------------------------------------- - CALL CUNI2(Z, GNU, KODE, 2, CY, NW, NLAST, FNUL, TOL, ELIM, ALIM) - 20 CONTINUE - IF (NW.LT.0) GO TO 50 - IF (NW.NE.0) GO TO 90 - AY = ABS(CY(1)) -C---------------------------------------------------------------------- -C SCALE BACKWARD RECURRENCE, BRY(3) IS DEFINED BUT NEVER USED -C---------------------------------------------------------------------- - BRY(1) = 1.0E+3*R1MACH(1)/TOL - BRY(2) = 1.0E0/BRY(1) - BRY(3) = BRY(2) - IFLAG = 2 - ASCLE = BRY(2) - AX = 1.0E0 - CSCL = CMPLX(AX,0.0E0) - IF (AY.GT.BRY(1)) GO TO 21 - IFLAG = 1 - ASCLE = BRY(1) - AX = 1.0E0/TOL - CSCL = CMPLX(AX,0.0E0) - GO TO 25 - 21 CONTINUE - IF (AY.LT.BRY(2)) GO TO 25 - IFLAG = 3 - ASCLE = BRY(3) - AX = TOL - CSCL = CMPLX(AX,0.0E0) - 25 CONTINUE - AY = 1.0E0/AX - CSCR = CMPLX(AY,0.0E0) - S1 = CY(2)*CSCL - S2 = CY(1)*CSCL - RZ = CMPLX(2.0E0,0.0E0)/Z - DO 30 I=1,NUI - ST = S2 - S2 = CMPLX(DFNU+FNUI,0.0E0)*RZ*S2 + S1 - S1 = ST - FNUI = FNUI - 1.0E0 - IF (IFLAG.GE.3) GO TO 30 - ST = S2*CSCR - STR = REAL(ST) - STI = AIMAG(ST) - STR = ABS(STR) - STI = ABS(STI) - STM = MAX(STR,STI) - IF (STM.LE.ASCLE) GO TO 30 - IFLAG = IFLAG+1 - ASCLE = BRY(IFLAG) - S1 = S1*CSCR - S2 = ST - AX = AX*TOL - AY = 1.0E0/AX - CSCL = CMPLX(AX,0.0E0) - CSCR = CMPLX(AY,0.0E0) - S1 = S1*CSCL - S2 = S2*CSCL - 30 CONTINUE - Y(N) = S2*CSCR - IF (N.EQ.1) RETURN - NL = N - 1 - FNUI = NL - K = NL - DO 40 I=1,NL - ST = S2 - S2 = CMPLX(FNU+FNUI,0.0E0)*RZ*S2 + S1 - S1 = ST - ST = S2*CSCR - Y(K) = ST - FNUI = FNUI - 1.0E0 - K = K - 1 - IF (IFLAG.GE.3) GO TO 40 - STR = REAL(ST) - STI = AIMAG(ST) - STR = ABS(STR) - STI = ABS(STI) - STM = MAX(STR,STI) - IF (STM.LE.ASCLE) GO TO 40 - IFLAG = IFLAG+1 - ASCLE = BRY(IFLAG) - S1 = S1*CSCR - S2 = ST - AX = AX*TOL - AY = 1.0E0/AX - CSCL = CMPLX(AX,0.0E0) - CSCR = CMPLX(AY,0.0E0) - S1 = S1*CSCL - S2 = S2*CSCL - 40 CONTINUE - RETURN - 50 CONTINUE - NZ = -1 - IF(NW.EQ.(-2)) NZ=-2 - RETURN - 60 CONTINUE - IF (IFORM.EQ.2) GO TO 70 -C----------------------------------------------------------------------- -C ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN -C -PI/3.LE.ARG(Z).LE.PI/3 -C----------------------------------------------------------------------- - CALL CUNI1(Z, FNU, KODE, N, Y, NW, NLAST, FNUL, TOL, ELIM, ALIM) - GO TO 80 - 70 CONTINUE -C----------------------------------------------------------------------- -C ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU -C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I -C AND HPI=PI/2 -C----------------------------------------------------------------------- - CALL CUNI2(Z, FNU, KODE, N, Y, NW, NLAST, FNUL, TOL, ELIM, ALIM) - 80 CONTINUE - IF (NW.LT.0) GO TO 50 - NZ = NW - RETURN - 90 CONTINUE - NLAST = N - RETURN - END diff --git a/slatec/cbunk.f b/slatec/cbunk.f deleted file mode 100644 index 346d53f..0000000 --- a/slatec/cbunk.f +++ /dev/null @@ -1,47 +0,0 @@ -*DECK CBUNK - SUBROUTINE CBUNK (Z, FNU, KODE, MR, N, Y, NZ, TOL, ELIM, ALIM) -C***BEGIN PROLOGUE CBUNK -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBESH and CBESK -C***LIBRARY SLATEC -C***TYPE ALL (CBUNK-A, ZBUNK-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C CBUNK COMPUTES THE K BESSEL FUNCTION FOR FNU.GT.FNUL. -C ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR K(FNU,Z) -C IN CUNK1 AND THE EXPANSION FOR H(2,FNU,Z) IN CUNK2 -C -C***SEE ALSO CBESH, CBESK -C***ROUTINES CALLED CUNK1, CUNK2 -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CBUNK - COMPLEX Y, Z - REAL ALIM, AX, AY, ELIM, FNU, TOL, XX, YY - INTEGER KODE, MR, N, NZ - DIMENSION Y(N) -C***FIRST EXECUTABLE STATEMENT CBUNK - NZ = 0 - XX = REAL(Z) - YY = AIMAG(Z) - AX = ABS(XX)*1.7321E0 - AY = ABS(YY) - IF (AY.GT.AX) GO TO 10 -C----------------------------------------------------------------------- -C ASYMPTOTIC EXPANSION FOR K(FNU,Z) FOR LARGE FNU APPLIED IN -C -PI/3.LE.ARG(Z).LE.PI/3 -C----------------------------------------------------------------------- - CALL CUNK1(Z, FNU, KODE, MR, N, Y, NZ, TOL, ELIM, ALIM) - GO TO 20 - 10 CONTINUE -C----------------------------------------------------------------------- -C ASYMPTOTIC EXPANSION FOR H(2,FNU,Z*EXP(M*HPI)) FOR LARGE FNU -C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I -C AND HPI=PI/2 -C----------------------------------------------------------------------- - CALL CUNK2(Z, FNU, KODE, MR, N, Y, NZ, TOL, ELIM, ALIM) - 20 CONTINUE - RETURN - END diff --git a/slatec/ccbrt.f b/slatec/ccbrt.f deleted file mode 100644 index 7d98ed1..0000000 --- a/slatec/ccbrt.f +++ /dev/null @@ -1,31 +0,0 @@ -*DECK CCBRT - COMPLEX FUNCTION CCBRT (Z) -C***BEGIN PROLOGUE CCBRT -C***PURPOSE Compute the cube root. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C2 -C***TYPE COMPLEX (CBRT-S, DCBRT-D, CCBRT-C) -C***KEYWORDS CUBE ROOT, ELEMENTARY FUNCTIONS, FNLIB, ROOTS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C CCBRT(Z) calculates the complex cube root of Z. The principal root -C for which -PI .LT. arg(Z) .LE. +PI is returned. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CARG, CBRT -C***REVISION HISTORY (YYMMDD) -C 770401 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***END PROLOGUE CCBRT - COMPLEX Z -C***FIRST EXECUTABLE STATEMENT CCBRT - THETA = CARG(Z) / 3.0 - R = CBRT (ABS(Z)) -C - CCBRT = CMPLX (R*COS(THETA), R*SIN(THETA)) -C - RETURN - END diff --git a/slatec/cchdc.f b/slatec/cchdc.f deleted file mode 100644 index 1cab82d..0000000 --- a/slatec/cchdc.f +++ /dev/null @@ -1,253 +0,0 @@ -*DECK CCHDC - SUBROUTINE CCHDC (A, LDA, P, WORK, JPVT, JOB, INFO) -C***BEGIN PROLOGUE CCHDC -C***PURPOSE Compute the Cholesky decomposition of a positive definite -C matrix. A pivoting option allows the user to estimate the -C condition number of a positive definite matrix or determine -C the rank of a positive semidefinite matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2D1B -C***TYPE COMPLEX (SCHDC-S, DCHDC-D, CCHDC-C) -C***KEYWORDS CHOLESKY DECOMPOSITION, LINEAR ALGEBRA, LINPACK, MATRIX, -C POSITIVE DEFINITE -C***AUTHOR Dongarra, J., (ANL) -C Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C CCHDC computes the Cholesky decomposition of a positive definite -C matrix. A pivoting option allows the user to estimate the -C condition of a positive definite matrix or determine the rank -C of a positive semidefinite matrix. -C -C On Entry -C -C A COMPLEX(LDA,P). -C A contains the matrix whose decomposition is to -C be computed. Only the upper half of A need be stored. -C The lower part of The array A is not referenced. -C -C LDA INTEGER. -C LDA is the leading dimension of the array A. -C -C P INTEGER. -C P is the order of the matrix. -C -C WORK COMPLEX. -C WORK is a work array. -C -C JPVT INTEGER(P). -C JPVT contains integers that control the selection -C of the pivot elements, if pivoting has been requested. -C Each diagonal element A(K,K) -C is placed in one of three classes according to the -C value of JPVT(K)). -C -C If JPVT(K)) .GT. 0, then X(K) is an initial -C element. -C -C If JPVT(K)) .EQ. 0, then X(K) is a free element. -C -C If JPVT(K)) .LT. 0, then X(K) is a final element. -C -C Before the decomposition is computed, initial elements -C are moved by symmetric row and column interchanges to -C the beginning of the array A and final -C elements to the end. Both initial and final elements -C are frozen in place during the computation and only -C free elements are moved. At the K-th stage of the -C reduction, if A(K,K) is occupied by a free element -C it is interchanged with the largest free element -C A(L,L) with L .GE. K. JPVT is not referenced if -C JOB .EQ. 0. -C -C JOB INTEGER. -C JOB is an integer that initiates column pivoting. -C IF JOB .EQ. 0, no pivoting is done. -C IF JOB .NE. 0, pivoting is done. -C -C On Return -C -C A A contains in its upper half the Cholesky factor -C of the matrix A as it has been permuted by pivoting. -C -C JPVT JPVT(J) contains the index of the diagonal element -C of A that was moved into the J-th position, -C provided pivoting was requested. -C -C INFO contains the index of the last positive diagonal -C element of the Cholesky factor. -C -C For positive definite matrices INFO = P is the normal return. -C For pivoting with positive semidefinite matrices INFO will -C in general be less than P. However, INFO may be greater than -C the rank of A, since rounding error can cause an otherwise zero -C element to be positive. Indefinite systems will always cause -C INFO to be less than P. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CSWAP -C***REVISION HISTORY (YYMMDD) -C 790319 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CCHDC - INTEGER LDA,P,JPVT(*),JOB,INFO - COMPLEX A(LDA,*),WORK(*) -C - INTEGER PU,PL,PLP1,J,JP,JT,K,KB,KM1,KP1,L,MAXL - COMPLEX TEMP - REAL MAXDIA - LOGICAL SWAPK,NEGK -C***FIRST EXECUTABLE STATEMENT CCHDC - PL = 1 - PU = 0 - INFO = P - IF (JOB .EQ. 0) GO TO 160 -C -C PIVOTING HAS BEEN REQUESTED. REARRANGE THE -C THE ELEMENTS ACCORDING TO JPVT. -C - DO 70 K = 1, P - SWAPK = JPVT(K) .GT. 0 - NEGK = JPVT(K) .LT. 0 - JPVT(K) = K - IF (NEGK) JPVT(K) = -JPVT(K) - IF (.NOT.SWAPK) GO TO 60 - IF (K .EQ. PL) GO TO 50 - CALL CSWAP(PL-1,A(1,K),1,A(1,PL),1) - TEMP = A(K,K) - A(K,K) = A(PL,PL) - A(PL,PL) = TEMP - A(PL,K) = CONJG(A(PL,K)) - PLP1 = PL + 1 - IF (P .LT. PLP1) GO TO 40 - DO 30 J = PLP1, P - IF (J .GE. K) GO TO 10 - TEMP = CONJG(A(PL,J)) - A(PL,J) = CONJG(A(J,K)) - A(J,K) = TEMP - GO TO 20 - 10 CONTINUE - IF (J .EQ. K) GO TO 20 - TEMP = A(K,J) - A(K,J) = A(PL,J) - A(PL,J) = TEMP - 20 CONTINUE - 30 CONTINUE - 40 CONTINUE - JPVT(K) = JPVT(PL) - JPVT(PL) = K - 50 CONTINUE - PL = PL + 1 - 60 CONTINUE - 70 CONTINUE - PU = P - IF (P .LT. PL) GO TO 150 - DO 140 KB = PL, P - K = P - KB + PL - IF (JPVT(K) .GE. 0) GO TO 130 - JPVT(K) = -JPVT(K) - IF (PU .EQ. K) GO TO 120 - CALL CSWAP(K-1,A(1,K),1,A(1,PU),1) - TEMP = A(K,K) - A(K,K) = A(PU,PU) - A(PU,PU) = TEMP - A(K,PU) = CONJG(A(K,PU)) - KP1 = K + 1 - IF (P .LT. KP1) GO TO 110 - DO 100 J = KP1, P - IF (J .GE. PU) GO TO 80 - TEMP = CONJG(A(K,J)) - A(K,J) = CONJG(A(J,PU)) - A(J,PU) = TEMP - GO TO 90 - 80 CONTINUE - IF (J .EQ. PU) GO TO 90 - TEMP = A(K,J) - A(K,J) = A(PU,J) - A(PU,J) = TEMP - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE - JT = JPVT(K) - JPVT(K) = JPVT(PU) - JPVT(PU) = JT - 120 CONTINUE - PU = PU - 1 - 130 CONTINUE - 140 CONTINUE - 150 CONTINUE - 160 CONTINUE - DO 270 K = 1, P -C -C REDUCTION LOOP. -C - MAXDIA = REAL(A(K,K)) - KP1 = K + 1 - MAXL = K -C -C DETERMINE THE PIVOT ELEMENT. -C - IF (K .LT. PL .OR. K .GE. PU) GO TO 190 - DO 180 L = KP1, PU - IF (REAL(A(L,L)) .LE. MAXDIA) GO TO 170 - MAXDIA = REAL(A(L,L)) - MAXL = L - 170 CONTINUE - 180 CONTINUE - 190 CONTINUE -C -C QUIT IF THE PIVOT ELEMENT IS NOT POSITIVE. -C - IF (MAXDIA .GT. 0.0E0) GO TO 200 - INFO = K - 1 - GO TO 280 - 200 CONTINUE - IF (K .EQ. MAXL) GO TO 210 -C -C START THE PIVOTING AND UPDATE JPVT. -C - KM1 = K - 1 - CALL CSWAP(KM1,A(1,K),1,A(1,MAXL),1) - A(MAXL,MAXL) = A(K,K) - A(K,K) = CMPLX(MAXDIA,0.0E0) - JP = JPVT(MAXL) - JPVT(MAXL) = JPVT(K) - JPVT(K) = JP - A(K,MAXL) = CONJG(A(K,MAXL)) - 210 CONTINUE -C -C REDUCTION STEP. PIVOTING IS CONTAINED ACROSS THE ROWS. -C - WORK(K) = CMPLX(SQRT(REAL(A(K,K))),0.0E0) - A(K,K) = WORK(K) - IF (P .LT. KP1) GO TO 260 - DO 250 J = KP1, P - IF (K .EQ. MAXL) GO TO 240 - IF (J .GE. MAXL) GO TO 220 - TEMP = CONJG(A(K,J)) - A(K,J) = CONJG(A(J,MAXL)) - A(J,MAXL) = TEMP - GO TO 230 - 220 CONTINUE - IF (J .EQ. MAXL) GO TO 230 - TEMP = A(K,J) - A(K,J) = A(MAXL,J) - A(MAXL,J) = TEMP - 230 CONTINUE - 240 CONTINUE - A(K,J) = A(K,J)/WORK(K) - WORK(J) = CONJG(A(K,J)) - TEMP = -A(K,J) - CALL CAXPY(J-K,TEMP,WORK(KP1),1,A(KP1,J),1) - 250 CONTINUE - 260 CONTINUE - 270 CONTINUE - 280 CONTINUE - RETURN - END diff --git a/slatec/cchdd.f b/slatec/cchdd.f deleted file mode 100644 index 8b86517..0000000 --- a/slatec/cchdd.f +++ /dev/null @@ -1,202 +0,0 @@ -*DECK CCHDD - SUBROUTINE CCHDD (R, LDR, P, X, Z, LDZ, NZ, Y, RHO, C, S, INFO) -C***BEGIN PROLOGUE CCHDD -C***PURPOSE Downdate an augmented Cholesky decomposition or the -C triangular factor of an augmented QR decomposition. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D7B -C***TYPE COMPLEX (SCHDD-S, DCHDD-D, CCHDD-C) -C***KEYWORDS CHOLESKY DECOMPOSITION, DOWNDATE, LINEAR ALGEBRA, LINPACK, -C MATRIX -C***AUTHOR Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C CCHDD downdates an augmented Cholesky decomposition or the -C triangular factor of an augmented QR decomposition. -C Specifically, given an upper triangular matrix R of order P, a -C row vector X, a column vector Z, and a scalar Y, CCHDD -C determines a unitary matrix U and a scalar ZETA such that -C -C (R Z ) (RR ZZ) -C U * ( ) = ( ) , -C (0 ZETA) ( X Y) -C -C where RR is upper triangular. If R and Z have been obtained -C from the factorization of a least squares problem, then -C RR and ZZ are the factors corresponding to the problem -C with the observation (X,Y) removed. In this case, if RHO -C is the norm of the residual vector, then the norm of -C the residual vector of the downdated problem is -C SQRT(RHO**2 - ZETA**2). CCHDD will simultaneously downdate -C several triplets (Z,Y,RHO) along with R. -C For a less terse description of what CCHDD does and how -C it may be applied, see the LINPACK Guide. -C -C The matrix U is determined as the product U(1)*...*U(P) -C where U(I) is a rotation in the (P+1,I)-plane of the -C form -C -C ( C(I) -CONJG(S(I)) ) -C ( ) . -C ( S(I) C(I) ) -C -C the rotations are chosen so that C(I) is real. -C -C The user is warned that a given downdating problem may -C be impossible to accomplish or may produce -C inaccurate results. For example, this can happen -C if X is near a vector whose removal will reduce the -C rank of R. Beware. -C -C On Entry -C -C R COMPLEX(LDR,P), where LDR .GE. P. -C R contains the upper triangular matrix -C that is to be downdated. The part of R -C below the diagonal is not referenced. -C -C LDR INTEGER. -C LDR is the leading dimension of the array R. -C -C p INTEGER. -C P is the order of the matrix R. -C -C X COMPLEX(P). -C X contains the row vector that is to -C be removed from R. X is not altered by CCHDD. -C -C Z COMPLEX(LDZ,NZ), where LDZ .GE. P. -C Z is an array of NZ P-vectors which -C are to be downdated along with R. -C -C LDZ INTEGER. -C LDZ is the leading dimension of the array Z. -C -C NZ INTEGER. -C NZ is the number of vectors to be downdated -C NZ may be zero, in which case Z, Y, and RHO -C are not referenced. -C -C Y COMPLEX(NZ). -C Y contains the scalars for the downdating -C of the vectors Z. Y is not altered by CCHDD. -C -C RHO REAL(NZ). -C RHO contains the norms of the residual -C vectors that are to be downdated. -C -C On Return -C -C R -C Z contain the downdated quantities. -C RHO -C -C C REAL(P). -C C contains the cosines of the transforming -C rotations. -C -C S COMPLEX(P). -C S contains the sines of the transforming -C rotations. -C -C INFO INTEGER. -C INFO is set as follows. -C -C INFO = 0 if the entire downdating -C was successful. -C -C INFO =-1 if R could not be downdated. -C in this case, all quantities -C are left unaltered. -C -C INFO = 1 if some RHO could not be -C downdated. The offending RHO's are -C set to -1. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CDOTC, SCNRM2 -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CCHDD - INTEGER LDR,P,LDZ,NZ,INFO - COMPLEX R(LDR,*),X(*),Z(LDZ,*),Y(*),S(*) - REAL RHO(*),C(*) -C - INTEGER I,II,J - REAL A,ALPHA,AZETA,NORM,SCNRM2 - COMPLEX CDOTC,T,ZETA,B,XX -C -C SOLVE THE SYSTEM CTRANS(R)*A = X, PLACING THE RESULT -C IN THE ARRAY S. -C -C***FIRST EXECUTABLE STATEMENT CCHDD - INFO = 0 - S(1) = CONJG(X(1))/CONJG(R(1,1)) - IF (P .LT. 2) GO TO 20 - DO 10 J = 2, P - S(J) = CONJG(X(J)) - CDOTC(J-1,R(1,J),1,S,1) - S(J) = S(J)/CONJG(R(J,J)) - 10 CONTINUE - 20 CONTINUE - NORM = SCNRM2(P,S,1) - IF (NORM .LT. 1.0E0) GO TO 30 - INFO = -1 - GO TO 120 - 30 CONTINUE - ALPHA = SQRT(1.0E0-NORM**2) -C -C DETERMINE THE TRANSFORMATIONS. -C - DO 40 II = 1, P - I = P - II + 1 - SCALE = ALPHA + ABS(S(I)) - A = ALPHA/SCALE - B = S(I)/SCALE - NORM = SQRT(A**2+REAL(B)**2+AIMAG(B)**2) - C(I) = A/NORM - S(I) = CONJG(B)/NORM - ALPHA = SCALE*NORM - 40 CONTINUE -C -C APPLY THE TRANSFORMATIONS TO R. -C - DO 60 J = 1, P - XX = (0.0E0,0.0E0) - DO 50 II = 1, J - I = J - II + 1 - T = C(I)*XX + S(I)*R(I,J) - R(I,J) = C(I)*R(I,J) - CONJG(S(I))*XX - XX = T - 50 CONTINUE - 60 CONTINUE -C -C IF REQUIRED, DOWNDATE Z AND RHO. -C - IF (NZ .LT. 1) GO TO 110 - DO 100 J = 1, NZ - ZETA = Y(J) - DO 70 I = 1, P - Z(I,J) = (Z(I,J) - CONJG(S(I))*ZETA)/C(I) - ZETA = C(I)*ZETA - S(I)*Z(I,J) - 70 CONTINUE - AZETA = ABS(ZETA) - IF (AZETA .LE. RHO(J)) GO TO 80 - INFO = 1 - RHO(J) = -1.0E0 - GO TO 90 - 80 CONTINUE - RHO(J) = RHO(J)*SQRT(1.0E0-(AZETA/RHO(J))**2) - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE - RETURN - END diff --git a/slatec/cchex.f b/slatec/cchex.f deleted file mode 100644 index e79a659..0000000 --- a/slatec/cchex.f +++ /dev/null @@ -1,267 +0,0 @@ -*DECK CCHEX - SUBROUTINE CCHEX (R, LDR, P, K, L, Z, LDZ, NZ, C, S, JOB) -C***BEGIN PROLOGUE CCHEX -C***PURPOSE Update the Cholesky factorization A=TRANS(R)*R of a -C positive definite matrix A of order P under diagonal -C permutations of the form TRANS(E)*A*E, where E is a -C permutation matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D7B -C***TYPE COMPLEX (SCHEX-S, DCHEX-D, CCHEX-C) -C***KEYWORDS CHOLESKY DECOMPOSITION, EXCHANGE, LINEAR ALGEBRA, LINPACK, -C MATRIX, POSITIVE DEFINITE -C***AUTHOR Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C CCHEX updates the Cholesky factorization -C -C A = CTRANS(R)*R -C -C of a positive definite matrix A of order P under diagonal -C permutations of the form -C -C TRANS(E)*A*E -C -C where E is a permutation matrix. Specifically, given -C an upper triangular matrix R and a permutation matrix -C E (which is specified by K, L, and JOB), CCHEX determines -C a unitary matrix U such that -C -C U*R*E = RR, -C -C where RR is upper triangular. At the users option, the -C transformation U will be multiplied into the array Z. -C If A = CTRANS(X)*X, so that R is the triangular part of the -C QR factorization of X, then RR is the triangular part of the -C QR factorization of X*E, i.e. X with its columns permuted. -C For a less terse description of what CCHEX does and how -C it may be applied, see the LINPACK Guide. -C -C The matrix Q is determined as the product U(L-K)*...*U(1) -C of plane rotations of the form -C -C ( C(I) S(I) ) -C ( ) , -C ( -CONJG(S(I)) C(I) ) -C -C where C(I) is real. The rows these rotations operate on -C are described below. -C -C There are two types of permutations, which are determined -C by the value of JOB. -C -C 1. Right circular shift (JOB = 1). -C -C The columns are rearranged in the following order. -C -C 1,...,K-1,L,K,K+1,...,L-1,L+1,...,P. -C -C U is the product of L-K rotations U(I), where U(I) -C acts in the (L-I,L-I+1)-plane. -C -C 2. Left circular shift (JOB = 2). -C The columns are rearranged in the following order -C -C 1,...,K-1,K+1,K+2,...,L,K,L+1,...,P. -C -C U is the product of L-K rotations U(I), where U(I) -C acts in the (K+I-1,K+I)-plane. -C -C On Entry -C -C R COMPLEX(LDR,P), where LDR .GE. P. -C R contains the upper triangular factor -C that is to be updated. Elements of R -C below the diagonal are not referenced. -C -C LDR INTEGER. -C LDR is the leading dimension of the array R. -C -C P INTEGER. -C P is the order of the matrix R. -C -C K INTEGER. -C K is the first column to be permuted. -C -C L INTEGER. -C L is the last column to be permuted. -C L must be strictly greater than K. -C -C Z COMPLEX(LDZ,NZ), where LDZ .GE. P. -C Z is an array of NZ P-vectors into which the -C transformation U is multiplied. Z is -C not referenced if NZ = 0. -C -C LDZ INTEGER. -C LDZ is the leading dimension of the array Z. -C -C NZ INTEGER. -C NZ is the number of columns of the matrix Z. -C -C JOB INTEGER. -C JOB determines the type of permutation. -C JOB = 1 right circular shift. -C JOB = 2 left circular shift. -C -C On Return -C -C R contains the updated factor. -C -C Z contains the updated matrix Z. -C -C C REAL(P). -C C contains the cosines of the transforming rotations. -C -C S COMPLEX(P). -C S contains the sines of the transforming rotations. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CROTG -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CCHEX - INTEGER LDR,P,K,L,LDZ,NZ,JOB - COMPLEX R(LDR,*),Z(LDZ,*),S(*) - REAL C(*) -C - INTEGER I,II,IL,IU,J,JJ,KM1,KP1,LMK,LM1 - COMPLEX T -C -C INITIALIZE -C -C***FIRST EXECUTABLE STATEMENT CCHEX - KM1 = K - 1 - KP1 = K + 1 - LMK = L - K - LM1 = L - 1 -C -C PERFORM THE APPROPRIATE TASK. -C - GO TO (10,130), JOB -C -C RIGHT CIRCULAR SHIFT. -C - 10 CONTINUE -C -C REORDER THE COLUMNS. -C - DO 20 I = 1, L - II = L - I + 1 - S(I) = R(II,L) - 20 CONTINUE - DO 40 JJ = K, LM1 - J = LM1 - JJ + K - DO 30 I = 1, J - R(I,J+1) = R(I,J) - 30 CONTINUE - R(J+1,J+1) = (0.0E0,0.0E0) - 40 CONTINUE - IF (K .EQ. 1) GO TO 60 - DO 50 I = 1, KM1 - II = L - I + 1 - R(I,K) = S(II) - 50 CONTINUE - 60 CONTINUE -C -C CALCULATE THE ROTATIONS. -C - T = S(1) - DO 70 I = 1, LMK - CALL CROTG(S(I+1),T,C(I),S(I)) - T = S(I+1) - 70 CONTINUE - R(K,K) = T - DO 90 J = KP1, P - IL = MAX(1,L-J+1) - DO 80 II = IL, LMK - I = L - II - T = C(II)*R(I,J) + S(II)*R(I+1,J) - R(I+1,J) = C(II)*R(I+1,J) - CONJG(S(II))*R(I,J) - R(I,J) = T - 80 CONTINUE - 90 CONTINUE -C -C IF REQUIRED, APPLY THE TRANSFORMATIONS TO Z. -C - IF (NZ .LT. 1) GO TO 120 - DO 110 J = 1, NZ - DO 100 II = 1, LMK - I = L - II - T = C(II)*Z(I,J) + S(II)*Z(I+1,J) - Z(I+1,J) = C(II)*Z(I+1,J) - CONJG(S(II))*Z(I,J) - Z(I,J) = T - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE - GO TO 260 -C -C LEFT CIRCULAR SHIFT -C - 130 CONTINUE -C -C REORDER THE COLUMNS -C - DO 140 I = 1, K - II = LMK + I - S(II) = R(I,K) - 140 CONTINUE - DO 160 J = K, LM1 - DO 150 I = 1, J - R(I,J) = R(I,J+1) - 150 CONTINUE - JJ = J - KM1 - S(JJ) = R(J+1,J+1) - 160 CONTINUE - DO 170 I = 1, K - II = LMK + I - R(I,L) = S(II) - 170 CONTINUE - DO 180 I = KP1, L - R(I,L) = (0.0E0,0.0E0) - 180 CONTINUE -C -C REDUCTION LOOP. -C - DO 220 J = K, P - IF (J .EQ. K) GO TO 200 -C -C APPLY THE ROTATIONS. -C - IU = MIN(J-1,L-1) - DO 190 I = K, IU - II = I - K + 1 - T = C(II)*R(I,J) + S(II)*R(I+1,J) - R(I+1,J) = C(II)*R(I+1,J) - CONJG(S(II))*R(I,J) - R(I,J) = T - 190 CONTINUE - 200 CONTINUE - IF (J .GE. L) GO TO 210 - JJ = J - K + 1 - T = S(JJ) - CALL CROTG(R(J,J),T,C(JJ),S(JJ)) - 210 CONTINUE - 220 CONTINUE -C -C APPLY THE ROTATIONS TO Z. -C - IF (NZ .LT. 1) GO TO 250 - DO 240 J = 1, NZ - DO 230 I = K, LM1 - II = I - KM1 - T = C(II)*Z(I,J) + S(II)*Z(I+1,J) - Z(I+1,J) = C(II)*Z(I+1,J) - CONJG(S(II))*Z(I,J) - Z(I,J) = T - 230 CONTINUE - 240 CONTINUE - 250 CONTINUE - 260 CONTINUE - RETURN - END diff --git a/slatec/cchud.f b/slatec/cchud.f deleted file mode 100644 index 2607c93..0000000 --- a/slatec/cchud.f +++ /dev/null @@ -1,160 +0,0 @@ -*DECK CCHUD - SUBROUTINE CCHUD (R, LDR, P, X, Z, LDZ, NZ, Y, RHO, C, S) -C***BEGIN PROLOGUE CCHUD -C***PURPOSE Update an augmented Cholesky decomposition of the -C triangular part of an augmented QR decomposition. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D7B -C***TYPE COMPLEX (SCHUD-S, DCHUD-D, CCHUD-C) -C***KEYWORDS CHOLESKY DECOMPOSITION, LINEAR ALGEBRA, LINPACK, MATRIX, -C UPDATE -C***AUTHOR Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C CCHUD updates an augmented Cholesky decomposition of the -C triangular part of an augmented QR decomposition. Specifically, -C given an upper triangular matrix R of order P, a row vector -C X, a column vector Z, and a scalar Y, CCHUD determines a -C unitary matrix U and a scalar ZETA such that -C -C -C (R Z) (RR ZZ ) -C U * ( ) = ( ) , -C (X Y) ( 0 ZETA) -C -C where RR is upper triangular. If R and Z have been -C obtained from the factorization of a least squares -C problem, then RR and ZZ are the factors corresponding to -C the problem with the observation (X,Y) appended. In this -C case, if RHO is the norm of the residual vector, then the -C norm of the residual vector of the updated problem is -C SQRT(RHO**2 + ZETA**2). CCHUD will simultaneously update -C several triplets (Z,Y,RHO). -C -C For a less terse description of what CCHUD does and how -C it may be applied see the LINPACK Guide. -C -C The matrix U is determined as the product U(P)*...*U(1), -C where U(I) is a rotation in the (I,P+1) plane of the -C form -C -C ( (CI) S(I) ) -C ( ) . -C ( -CONJG(S(I)) (CI) ) -C -C The rotations are chosen so that C(I) is real. -C -C On Entry -C -C R COMPLEX(LDR,P), where LDR .GE. P. -C R contains the upper triangular matrix -C that is to be updated. The part of R -C below the diagonal is not referenced. -C -C LDR INTEGER. -C LDR is the leading dimension of the array R. -C -C P INTEGER. -C P is the order of the matrix R. -C -C X COMPLEX(P). -C X contains the row to be added to R. X is -C not altered by CCHUD. -C -C Z COMPLEX(LDZ,NZ), where LDZ .GE. P. -C Z is an array containing NZ P-vectors to -C be updated with R. -C -C LDZ INTEGER. -C LDZ is the leading dimension of the array Z. -C -C NZ INTEGER. -C NZ is the number of vectors to be updated -C NZ may be zero, in which case Z, Y, and RHO -C are not referenced. -C -C Y COMPLEX(NZ). -C Y contains the scalars for updating the vectors -C Z. Y is not altered by CCHUD. -C -C RHO REAL(NZ). -C RHO contains the norms of the residual -C vectors that are to be updated. If RHO(J) -C is negative, it is left unaltered. -C -C On Return -C -C RC -C RHO contain the updated quantities. -C Z -C -C C REAL(P). -C C contains the cosines of the transforming -C rotations. -C -C S COMPLEX(P). -C S contains the sines of the transforming -C rotations. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CROTG -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CCHUD - INTEGER LDR,P,LDZ,NZ - REAL RHO(*),C(*) - COMPLEX R(LDR,*),X(*),Z(LDZ,*),Y(*),S(*) -C - INTEGER I,J,JM1 - REAL AZETA,SCALE - COMPLEX T,XJ,ZETA -C -C UPDATE R. -C -C***FIRST EXECUTABLE STATEMENT CCHUD - DO 30 J = 1, P - XJ = X(J) -C -C APPLY THE PREVIOUS ROTATIONS. -C - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 20 - DO 10 I = 1, JM1 - T = C(I)*R(I,J) + S(I)*XJ - XJ = C(I)*XJ - CONJG(S(I))*R(I,J) - R(I,J) = T - 10 CONTINUE - 20 CONTINUE -C -C COMPUTE THE NEXT ROTATION. -C - CALL CROTG(R(J,J),XJ,C(J),S(J)) - 30 CONTINUE -C -C IF REQUIRED, UPDATE Z AND RHO. -C - IF (NZ .LT. 1) GO TO 70 - DO 60 J = 1, NZ - ZETA = Y(J) - DO 40 I = 1, P - T = C(I)*Z(I,J) + S(I)*ZETA - ZETA = C(I)*ZETA - CONJG(S(I))*Z(I,J) - Z(I,J) = T - 40 CONTINUE - AZETA = ABS(ZETA) - IF (AZETA .EQ. 0.0E0 .OR. RHO(J) .LT. 0.0E0) GO TO 50 - SCALE = AZETA + RHO(J) - RHO(J) = SCALE*SQRT((AZETA/SCALE)**2+(RHO(J)/SCALE)**2) - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE - RETURN - END diff --git a/slatec/ccmpb.f b/slatec/ccmpb.f deleted file mode 100644 index 3cf4ba3..0000000 --- a/slatec/ccmpb.f +++ /dev/null @@ -1,109 +0,0 @@ -*DECK CCMPB - SUBROUTINE CCMPB (N, IERROR, AN, BN, CN, B, AH, BH) -C***BEGIN PROLOGUE CCMPB -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBLKTR -C***LIBRARY SLATEC -C***TYPE COMPLEX (COMPB-S, CCMPB-C) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C CCMPB computes the roots of the B polynomials using subroutine -C TEVLC which is a modification the EISPACK program TQLRAT. -C IERROR is set to 4 if either TEVLC fails or if A(J+1)*C(J) is -C less than zero for some J. AH,BH are temporary work arrays. -C -C***SEE ALSO CBLKTR -C***ROUTINES CALLED CPADD, INXCB, R1MACH, TEVLC -C***COMMON BLOCKS CCBLK -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE CCMPB -C - DIMENSION AN(*) ,BN(*) ,CN(*) ,B(*) , - 1 AH(*) ,BH(*) - COMMON /CCBLK/ NPP ,K ,EPS ,CNV , - 1 NM ,NCMPLX ,IK -C***FIRST EXECUTABLE STATEMENT CCMPB - EPS = R1MACH(4) - BNORM = ABS(BN(1)) - DO 102 J=2,NM - BNORM = MAX(BNORM,ABS(BN(J))) - ARG = AN(J)*CN(J-1) - IF (ARG) 119,101,101 - 101 B(J) = SIGN(SQRT(ARG),AN(J)) - 102 CONTINUE - CNV = EPS*BNORM - IF = 2**K - KDO = K-1 - DO 108 L=1,KDO - IR = L-1 - I2 = 2**IR - I4 = I2+I2 - IPL = I4-1 - IFD = IF-I4 - DO 107 I=I4,IFD,I4 - CALL INXCB (I,L,IB,NB) - IF (NB) 108,108,103 - 103 JS = I-IPL - JF = JS+NB-1 - LS = 0 - DO 104 J=JS,JF - LS = LS+1 - BH(LS) = BN(J) - AH(LS) = B(J) - 104 CONTINUE - CALL TEVLC (NB,BH,AH,IERROR) - IF (IERROR) 118,105,118 - 105 LH = IB-1 - DO 106 J=1,NB - LH = LH+1 - B(LH) = -BH(J) - 106 CONTINUE - 107 CONTINUE - 108 CONTINUE - DO 109 J=1,NM - B(J) = -BN(J) - 109 CONTINUE - IF (NPP) 117,110,117 - 110 NMP = NM+1 - NB = NM+NMP - DO 112 J=1,NB - L1 = MOD(J-1,NMP)+1 - L2 = MOD(J+NM-1,NMP)+1 - ARG = AN(L1)*CN(L2) - IF (ARG) 119,111,111 - 111 BH(J) = SIGN(SQRT(ARG),-AN(L1)) - AH(J) = -BN(L1) - 112 CONTINUE - CALL TEVLC (NB,AH,BH,IERROR) - IF (IERROR) 118,113,118 - 113 CALL INXCB (IF,K-1,J2,LH) - CALL INXCB (IF/2,K-1,J1,LH) - J2 = J2+1 - LH = J2 - N2M2 = J2+NM+NM-2 - 114 D1 = ABS(B(J1)-B(J2-1)) - D2 = ABS(B(J1)-B(J2)) - D3 = ABS(B(J1)-B(J2+1)) - IF ((D2 .LT. D1) .AND. (D2 .LT. D3)) GO TO 115 - B(LH) = B(J2) - J2 = J2+1 - LH = LH+1 - IF (J2-N2M2) 114,114,116 - 115 J2 = J2+1 - J1 = J1+1 - IF (J2-N2M2) 114,114,116 - 116 B(LH) = B(N2M2+1) - CALL INXCB (IF,K-1,J1,J2) - J2 = J1+NMP+NMP - CALL CPADD (NM+1,IERROR,AN,CN,B(J1),B(J1),B(J2)) - 117 RETURN - 118 IERROR = 4 - RETURN - 119 IERROR = 5 - RETURN - END diff --git a/slatec/ccopy.f b/slatec/ccopy.f deleted file mode 100644 index 85e7fcc..0000000 --- a/slatec/ccopy.f +++ /dev/null @@ -1,71 +0,0 @@ -*DECK CCOPY - SUBROUTINE CCOPY (N, CX, INCX, CY, INCY) -C***BEGIN PROLOGUE CCOPY -C***PURPOSE Copy a vector. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A5 -C***TYPE COMPLEX (SCOPY-S, DCOPY-D, CCOPY-C, ICOPY-I) -C***KEYWORDS BLAS, COPY, 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 CX complex vector with N elements -C INCX storage spacing between elements of CX -C CY complex vector with N elements -C INCY storage spacing between elements of CY -C -C --Output-- -C CY copy of vector CX (unchanged if N .LE. 0) -C -C Copy complex CX to complex CY. -C For I = 0 to N-1, copy CX(LX+I*INCX) to CY(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 CCOPY - COMPLEX CX(*),CY(*) -C***FIRST EXECUTABLE STATEMENT CCOPY - 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 - CY(KY) = CX(KX) - KX = KX + INCX - KY = KY + INCY - 10 CONTINUE - RETURN -C -C Code for equal, positive increments. -C - 20 NS = N*INCX - DO 30 I = 1,NS,INCX - CY(I) = CX(I) - 30 CONTINUE - RETURN - END diff --git a/slatec/ccosh.f b/slatec/ccosh.f deleted file mode 100644 index c56d067..0000000 --- a/slatec/ccosh.f +++ /dev/null @@ -1,29 +0,0 @@ -*DECK CCOSH - COMPLEX FUNCTION CCOSH (Z) -C***BEGIN PROLOGUE CCOSH -C***PURPOSE Compute the complex hyperbolic cosine. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4C -C***TYPE COMPLEX (CCOSH-C) -C***KEYWORDS ELEMENTARY FUNCTIONS, FNLIB, HYPERBOLIC COSINE -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C CCOSH(Z) calculates the complex hyperbolic cosine of Z. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 770401 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***END PROLOGUE CCOSH - COMPLEX Z, CI - SAVE CI - DATA CI /(0.,1.)/ -C***FIRST EXECUTABLE STATEMENT CCOSH - CCOSH = COS (CI*Z) -C - RETURN - END diff --git a/slatec/ccot.f b/slatec/ccot.f deleted file mode 100644 index 7fff1c6..0000000 --- a/slatec/ccot.f +++ /dev/null @@ -1,50 +0,0 @@ -*DECK CCOT - COMPLEX FUNCTION CCOT (Z) -C***BEGIN PROLOGUE CCOT -C***PURPOSE Compute the cotangent. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4A -C***TYPE COMPLEX (COT-S, DCOT-D, CCOT-C) -C***KEYWORDS COTANGENT, ELEMENTARY FUNCTIONS, FNLIB, TRIGONOMETRIC -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C CCOT(Z) calculates the complex trigonometric cotangent of Z. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH, XERCLR, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE CCOT - COMPLEX Z - SAVE SQEPS - DATA SQEPS /0./ -C***FIRST EXECUTABLE STATEMENT CCOT - IF (SQEPS.EQ.0.) SQEPS = SQRT (R1MACH(4)) -C - X2 = 2.0*REAL(Z) - Y2 = 2.0*AIMAG(Z) -C - SN2X = SIN (X2) - CALL XERCLR -C - DEN = COSH(Y2) - COS(X2) - IF (DEN .EQ. 0.) CALL XERMSG ('SLATEC', 'CCOT', - + 'COT IS SINGULAR FOR INPUT Z (X IS 0 OR PI AND Y IS 0)', 2, 2) -C - IF (ABS(DEN).GT.MAX(ABS(X2),1.)*SQEPS) GO TO 10 - CALL XERCLR - CALL XERMSG ('SLATEC', 'CCOT', - + 'ANSWER LT HALF PRECISION, ABS(X) TOO BIG OR X TOO NEAR ' // - + '0 OR PI', 1, 1) -C - 10 CCOT = CMPLX (SN2X/DEN, -SINH(Y2)/DEN) -C - RETURN - END diff --git a/slatec/cdcdot.f b/slatec/cdcdot.f deleted file mode 100644 index a67b80c..0000000 --- a/slatec/cdcdot.f +++ /dev/null @@ -1,71 +0,0 @@ -*DECK CDCDOT - COMPLEX FUNCTION CDCDOT (N, CB, CX, INCX, CY, INCY) -C***BEGIN PROLOGUE CDCDOT -C***PURPOSE Compute the inner product of two vectors with extended -C precision accumulation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A4 -C***TYPE COMPLEX (SDSDOT-S, CDCDOT-C) -C***KEYWORDS BLAS, DOT PRODUCT, INNER PRODUCT, 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 CB complex scalar to be added to inner product -C CX complex vector with N elements -C INCX storage spacing between elements of CX -C CY complex vector with N elements -C INCY storage spacing between elements of CY -C -C --Output-- -C CDCDOT complex dot product (CB if N .LE. 0) -C -C Returns complex result with dot product accumulated in D.P. -C CDCDOT = CB + sum for I = 0 to N-1 of CX(LX+I*INCY)*CY(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 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 920310 Corrected definition of LX in DESCRIPTION. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CDCDOT - INTEGER N, INCX, INCY, I, KX, KY - COMPLEX CX(*), CY(*), CB - DOUBLE PRECISION DSDOTR, DSDOTI, DT1, DT2, DT3, DT4 -C***FIRST EXECUTABLE STATEMENT CDCDOT - DSDOTR = DBLE(REAL(CB)) - DSDOTI = DBLE(AIMAG(CB)) - IF (N .LE. 0) GO TO 10 - KX = 1 - KY = 1 - IF(INCX.LT.0) KX = 1+(1-N)*INCX - IF(INCY.LT.0) KY = 1+(1-N)*INCY - DO 5 I = 1,N - DT1 = DBLE(REAL(CX(KX))) - DT2 = DBLE(REAL(CY(KY))) - DT3 = DBLE(AIMAG(CX(KX))) - DT4 = DBLE(AIMAG(CY(KY))) - DSDOTR = DSDOTR+(DT1*DT2)-(DT3*DT4) - DSDOTI = DSDOTI+(DT1*DT4)+(DT3*DT2) - KX = KX+INCX - KY = KY+INCY - 5 CONTINUE - 10 CDCDOT = CMPLX(REAL(DSDOTR),REAL(DSDOTI)) - RETURN - END diff --git a/slatec/cdcor.f b/slatec/cdcor.f deleted file mode 100644 index 236cc0c..0000000 --- a/slatec/cdcor.f +++ /dev/null @@ -1,194 +0,0 @@ -*DECK CDCOR - SUBROUTINE CDCOR (DFDY, EL, FA, H, IERROR, IMPL, IPVT, MATDIM, - 8 MITER, ML, MU, N, NDE, NQ, T, USERS, Y, YH, YWT, EVALFA, SAVE1, - 8 SAVE2, A, D, JSTATE) -C***BEGIN PROLOGUE CDCOR -C***SUBSIDIARY -C***PURPOSE Subroutine CDCOR computes corrections to the Y array. -C***LIBRARY SLATEC (SDRIVE) -C***TYPE COMPLEX (SDCOR-S, DDCOR-D, CDCOR-C) -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***DESCRIPTION -C -C In the case of functional iteration, update Y directly from the -C result of the last call to F. -C In the case of the chord method, compute the corrector error and -C solve the linear system with that as right hand side and DFDY as -C coefficient matrix, using the LU decomposition if MITER is 1, 2, 4, -C or 5. -C -C***ROUTINES CALLED CGBSL, CGESL, SCNRM2 -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE CDCOR - INTEGER I, IERROR, IFLAG, IMPL, J, JSTATE, MATDIM, MITER, ML, MU, - 8 MW, N, NDE, NQ - COMPLEX A(MATDIM,*), DFDY(MATDIM,*), SAVE1(*), SAVE2(*), Y(*), - 8 YH(N,*), YWT(*) - REAL D, EL(13,12), H, SCNRM2, T - INTEGER IPVT(*) - LOGICAL EVALFA -C***FIRST EXECUTABLE STATEMENT CDCOR - IF (MITER .EQ. 0) THEN - IF (IERROR .EQ. 1 .OR. IERROR .EQ. 5) THEN - DO 100 I = 1,N - 100 SAVE1(I) = (H*SAVE2(I) - YH(I,2) - SAVE1(I))/YWT(I) - ELSE - DO 102 I = 1,N - SAVE1(I) = (H*SAVE2(I) - YH(I,2) - SAVE1(I))/ - 8 MAX(ABS(Y(I)), ABS(YWT(I))) - 102 CONTINUE - END IF - D = SCNRM2(N, SAVE1, 1)/SQRT(REAL(N)) - DO 105 I = 1,N - 105 SAVE1(I) = H*SAVE2(I) - YH(I,2) - ELSE IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN - IF (IMPL .EQ. 0) THEN - DO 130 I = 1,N - 130 SAVE2(I) = H*SAVE2(I) - YH(I,2) - SAVE1(I) - ELSE IF (IMPL .EQ. 1) THEN - IF (EVALFA) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - ELSE - EVALFA = .TRUE. - END IF - DO 150 I = 1,N - 150 SAVE2(I) = H*SAVE2(I) - DO 160 J = 1,N - DO 160 I = 1,N - 160 SAVE2(I) = SAVE2(I) - A(I,J)*(YH(J,2) + SAVE1(J)) - ELSE IF (IMPL .EQ. 2) THEN - IF (EVALFA) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - ELSE - EVALFA = .TRUE. - END IF - DO 180 I = 1,N - 180 SAVE2(I) = H*SAVE2(I) - A(I,1)*(YH(I,2) + SAVE1(I)) - ELSE IF (IMPL .EQ. 3) THEN - IF (EVALFA) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - ELSE - EVALFA = .TRUE. - END IF - DO 140 I = 1,N - 140 SAVE2(I) = H*SAVE2(I) - DO 170 J = 1,NDE - DO 170 I = 1,NDE - 170 SAVE2(I) = SAVE2(I) - A(I,J)*(YH(J,2) + SAVE1(J)) - END IF - CALL CGESL (DFDY, MATDIM, N, IPVT, SAVE2, 0) - IF (IERROR .EQ. 1 .OR. IERROR .EQ. 5) THEN - DO 200 I = 1,N - SAVE1(I) = SAVE1(I) + SAVE2(I) - 200 SAVE2(I) = SAVE2(I)/YWT(I) - ELSE - DO 205 I = 1,N - SAVE1(I) = SAVE1(I) + SAVE2(I) - 205 SAVE2(I) = SAVE2(I)/MAX(ABS(Y(I)), ABS(YWT(I))) - END IF - D = SCNRM2(N, SAVE2, 1)/SQRT(REAL(N)) - ELSE IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN - IF (IMPL .EQ. 0) THEN - DO 230 I = 1,N - 230 SAVE2(I) = H*SAVE2(I) - YH(I,2) - SAVE1(I) - ELSE IF (IMPL .EQ. 1) THEN - IF (EVALFA) THEN - CALL FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - ELSE - EVALFA = .TRUE. - END IF - DO 250 I = 1,N - 250 SAVE2(I) = H*SAVE2(I) - MW = ML + 1 + MU - DO 260 J = 1,N - DO 260 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) - SAVE2(I+J-MW) = SAVE2(I+J-MW) - 8 - A(I,J)*(YH(J,2) + SAVE1(J)) - 260 CONTINUE - ELSE IF (IMPL .EQ. 2) THEN - IF (EVALFA) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - ELSE - EVALFA = .TRUE. - END IF - DO 280 I = 1,N - 280 SAVE2(I) = H*SAVE2(I) - A(I,1)*(YH(I,2) + SAVE1(I)) - ELSE IF (IMPL .EQ. 3) THEN - IF (EVALFA) THEN - CALL FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - ELSE - EVALFA = .TRUE. - END IF - DO 270 I = 1,N - 270 SAVE2(I) = H*SAVE2(I) - MW = ML + 1 + MU - DO 290 J = 1,NDE - DO 290 I = MAX(ML+1, MW+1-J), MIN(MW+NDE-J, MW+ML) - SAVE2(I+J-MW) = SAVE2(I+J-MW) - 8 - A(I,J)*(YH(J,2) + SAVE1(J)) - 290 CONTINUE - END IF - CALL CGBSL (DFDY, MATDIM, N, ML, MU, IPVT, SAVE2, 0) - IF (IERROR .EQ. 1 .OR. IERROR .EQ. 5) THEN - DO 300 I = 1,N - SAVE1(I) = SAVE1(I) + SAVE2(I) - 300 SAVE2(I) = SAVE2(I)/YWT(I) - ELSE - DO 305 I = 1,N - SAVE1(I) = SAVE1(I) + SAVE2(I) - 305 SAVE2(I) = SAVE2(I)/MAX(ABS(Y(I)), ABS(YWT(I))) - END IF - D = SCNRM2(N, SAVE2, 1)/SQRT(REAL(N)) - ELSE IF (MITER .EQ. 3) THEN - IFLAG = 2 - CALL USERS (Y, YH(1,2), YWT, SAVE1, SAVE2, T, H, EL(1,NQ), IMPL, - 8 N, NDE, IFLAG) - IF (N .EQ. 0) THEN - JSTATE = 10 - RETURN - END IF - IF (IERROR .EQ. 1 .OR. IERROR .EQ. 5) THEN - DO 320 I = 1,N - SAVE1(I) = SAVE1(I) + SAVE2(I) - 320 SAVE2(I) = SAVE2(I)/YWT(I) - ELSE - DO 325 I = 1,N - SAVE1(I) = SAVE1(I) + SAVE2(I) - 325 SAVE2(I) = SAVE2(I)/MAX(ABS(Y(I)), ABS(YWT(I))) - END IF - D = SCNRM2(N, SAVE2, 1)/SQRT(REAL(N)) - END IF - RETURN - END diff --git a/slatec/cdcst.f b/slatec/cdcst.f deleted file mode 100644 index 0b9ed5b..0000000 --- a/slatec/cdcst.f +++ /dev/null @@ -1,106 +0,0 @@ -*DECK CDCST - SUBROUTINE CDCST (MAXORD, MINT, ISWFLG, EL, TQ) -C***BEGIN PROLOGUE CDCST -C***SUBSIDIARY -C***PURPOSE CDCST sets coefficients used by the core integrator CDSTP. -C***LIBRARY SLATEC (SDRIVE) -C***TYPE COMPLEX (SDCST-S, DDCST-D, CDCST-C) -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***DESCRIPTION -C -C CDCST is called by CDNTL. The array EL determines the basic method. -C The array TQ is involved in adjusting the step size in relation -C to truncation error. EL and TQ depend upon MINT, and are calculated -C for orders 1 to MAXORD(.LE. 12). For each order NQ, the coefficients -C EL are calculated from the generating polynomial: -C L(T) = EL(1,NQ) + EL(2,NQ)*T + ... + EL(NQ+1,NQ)*T**NQ. -C For the implicit Adams methods, L(T) is given by -C dL/dT = (1+T)*(2+T)* ... *(NQ-1+T)/K, L(-1) = 0, -C where K = factorial(NQ-1). -C For the Gear methods, -C L(T) = (1+T)*(2+T)* ... *(NQ+T)/K, -C where K = factorial(NQ)*(1 + 1/2 + ... + 1/NQ). -C For each order NQ, there are three components of TQ. -C -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE CDCST - REAL EL(13,12), FACTRL(12), GAMMA(14), SUM, TQ(3,12) - INTEGER I, ISWFLG, J, MAXORD, MINT, MXRD -C***FIRST EXECUTABLE STATEMENT CDCST - FACTRL(1) = 1.E0 - DO 10 I = 2,MAXORD - 10 FACTRL(I) = I*FACTRL(I-1) -C Compute Adams coefficients - IF (MINT .EQ. 1) THEN - GAMMA(1) = 1.E0 - DO 40 I = 1,MAXORD+1 - SUM = 0.E0 - DO 30 J = 1,I - 30 SUM = SUM - GAMMA(J)/(I-J+2) - 40 GAMMA(I+1) = SUM - EL(1,1) = 1.E0 - EL(2,1) = 1.E0 - EL(2,2) = 1.E0 - EL(3,2) = 1.E0 - DO 60 J = 3,MAXORD - EL(2,J) = FACTRL(J-1) - DO 50 I = 3,J - 50 EL(I,J) = (J-1)*EL(I,J-1) + EL(I-1,J-1) - 60 EL(J+1,J) = 1.E0 - DO 80 J = 2,MAXORD - EL(1,J) = EL(1,J-1) + GAMMA(J) - EL(2,J) = 1.E0 - DO 80 I = 3,J+1 - 80 EL(I,J) = EL(I,J)/((I-1)*FACTRL(J-1)) - DO 100 J = 1,MAXORD - TQ(1,J) = -1.E0/(FACTRL(J)*GAMMA(J)) - TQ(2,J) = -1.E0/GAMMA(J+1) - 100 TQ(3,J) = -1.E0/GAMMA(J+2) -C Compute Gear coefficients - ELSE IF (MINT .EQ. 2) THEN - EL(1,1) = 1.E0 - EL(2,1) = 1.E0 - DO 130 J = 2,MAXORD - EL(1,J) = FACTRL(J) - DO 120 I = 2,J - 120 EL(I,J) = J*EL(I,J-1) + EL(I-1,J-1) - 130 EL(J+1,J) = 1.E0 - SUM = 1.E0 - DO 150 J = 2,MAXORD - SUM = SUM + 1.E0/J - DO 150 I = 1,J+1 - 150 EL(I,J) = EL(I,J)/(FACTRL(J)*SUM) - DO 170 J = 1,MAXORD - IF (J .GT. 1) TQ(1,J) = 1.E0/FACTRL(J-1) - TQ(2,J) = (J+1)/EL(1,J) - 170 TQ(3,J) = (J+2)/EL(1,J) - END IF -C Compute constants used in the stiffness test. -C These are the ratio of TQ(2,NQ) for the Gear -C methods to those for the Adams methods. - IF (ISWFLG .EQ. 3) THEN - MXRD = MIN(MAXORD, 5) - IF (MINT .EQ. 2) THEN - GAMMA(1) = 1.E0 - DO 190 I = 1,MXRD - SUM = 0.E0 - DO 180 J = 1,I - 180 SUM = SUM - GAMMA(J)/(I-J+2) - 190 GAMMA(I+1) = SUM - END IF - SUM = 1.E0 - DO 200 I = 2,MXRD - SUM = SUM + 1.E0/I - 200 EL(1+I,1) = -(I+1)*SUM*GAMMA(I+1) - END IF - RETURN - END diff --git a/slatec/cdiv.f b/slatec/cdiv.f deleted file mode 100644 index 357e207..0000000 --- a/slatec/cdiv.f +++ /dev/null @@ -1,33 +0,0 @@ -*DECK CDIV - SUBROUTINE CDIV (AR, AI, BR, BI, CR, CI) -C***BEGIN PROLOGUE CDIV -C***SUBSIDIARY -C***PURPOSE Compute the complex quotient of two complex numbers. -C***LIBRARY SLATEC -C***TYPE COMPLEX (CDIV-C) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Complex division, (CR,CI) = (AR,AI)/(BR,BI) -C -C***SEE ALSO EISDOC -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 811101 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE CDIV - REAL AR,AI,BR,BI,CR,CI -C - REAL S,ARS,AIS,BRS,BIS -C***FIRST EXECUTABLE STATEMENT CDIV - S = ABS(BR) + ABS(BI) - ARS = AR/S - AIS = AI/S - BRS = BR/S - BIS = BI/S - S = BRS**2 + BIS**2 - CR = (ARS*BRS + AIS*BIS)/S - CI = (AIS*BRS - ARS*BIS)/S - RETURN - END diff --git a/slatec/cdntl.f b/slatec/cdntl.f deleted file mode 100644 index a5a545d..0000000 --- a/slatec/cdntl.f +++ /dev/null @@ -1,183 +0,0 @@ -*DECK CDNTL - SUBROUTINE CDNTL (EPS, F, FA, HMAX, HOLD, IMPL, JTASK, MATDIM, - 8 MAXORD, MINT, MITER, ML, MU, N, NDE, SAVE1, T, UROUND, USERS, - 8 Y, YWT, H, MNTOLD, MTROLD, NFE, RC, YH, A, CONVRG, EL, FAC, - 8 IER, IPVT, NQ, NWAIT, RH, RMAX, SAVE2, TQ, TREND, ISWFLG, - 8 JSTATE) -C***BEGIN PROLOGUE CDNTL -C***SUBSIDIARY -C***PURPOSE Subroutine CDNTL is called to set parameters on the first -C call to CDSTP, on an internal restart, or when the user has -C altered MINT, MITER, and/or H. -C***LIBRARY SLATEC (SDRIVE) -C***TYPE COMPLEX (SDNTL-S, DDNTL-D, CDNTL-C) -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***DESCRIPTION -C -C On the first call, the order is set to 1 and the initial derivatives -C are calculated. RMAX is the maximum ratio by which H can be -C increased in one step. It is initially RMINIT to compensate -C for the small initial H, but then is normally equal to RMNORM. -C If a failure occurs (in corrector convergence or error test), RMAX -C is set at RMFAIL for the next increase. -C If the caller has changed MINT, or if JTASK = 0, CDCST is called -C to set the coefficients of the method. If the caller has changed H, -C YH must be rescaled. If H or MINT has been changed, NWAIT is -C reset to NQ + 2 to prevent further increases in H for that many -C steps. Also, RC is reset. RC is the ratio of new to old values of -C the coefficient L(0)*H. If the caller has changed MITER, RC is -C set to 0 to force the partials to be updated, if partials are used. -C -C***ROUTINES CALLED CDCST, CDSCL, CGBFA, CGBSL, CGEFA, CGESL, SCNRM2 -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE CDNTL - INTEGER I, IFLAG, IMPL, INFO, ISWFLG, JSTATE, JTASK, MATDIM, - 8 MAXORD, MINT, MITER, ML, MNTOLD, MTROLD, MU, N, NDE, NFE, - 8 NQ, NWAIT - COMPLEX A(MATDIM,*), FAC(*), SAVE1(*), SAVE2(*), Y(*), YH(N,*), - 8 YWT(*) - REAL EL(13,12), EPS, H, HMAX, HOLD, OLDL0, RC, RH, RMAX, - 8 RMINIT, SCNRM2, SUM, T, TQ(3,12), TREND, UROUND - INTEGER IPVT(*) - LOGICAL CONVRG, IER - PARAMETER(RMINIT = 10000.E0) -C***FIRST EXECUTABLE STATEMENT CDNTL - IER = .FALSE. - IF (JTASK .GE. 0) THEN - IF (JTASK .EQ. 0) THEN - CALL CDCST (MAXORD, MINT, ISWFLG, EL, TQ) - RMAX = RMINIT - END IF - RC = 0.E0 - CONVRG = .FALSE. - TREND = 1.E0 - NQ = 1 - NWAIT = 3 - CALL F (N, T, Y, SAVE2) - IF (N .EQ. 0) THEN - JSTATE = 6 - RETURN - END IF - NFE = NFE + 1 - IF (IMPL .NE. 0) THEN - IF (MITER .EQ. 3) THEN - IFLAG = 0 - CALL USERS (Y, YH, YWT, SAVE1, SAVE2, T, H, EL, IMPL, N, - 8 NDE, IFLAG) - IF (IFLAG .EQ. -1) THEN - IER = .TRUE. - RETURN - END IF - IF (N .EQ. 0) THEN - JSTATE = 10 - RETURN - END IF - ELSE IF (IMPL .EQ. 1) THEN - IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - CALL CGEFA (A, MATDIM, N, IPVT, INFO) - IF (INFO .NE. 0) THEN - IER = .TRUE. - RETURN - END IF - CALL CGESL (A, MATDIM, N, IPVT, SAVE2, 0) - ELSE IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN - CALL FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - CALL CGBFA (A, MATDIM, N, ML, MU, IPVT, INFO) - IF (INFO .NE. 0) THEN - IER = .TRUE. - RETURN - END IF - CALL CGBSL (A, MATDIM, N, ML, MU, IPVT, SAVE2, 0) - END IF - ELSE IF (IMPL .EQ. 2) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - DO 150 I = 1,NDE - IF (A(I,1) .EQ. 0.E0) THEN - IER = .TRUE. - RETURN - ELSE - SAVE2(I) = SAVE2(I)/A(I,1) - END IF - 150 CONTINUE - DO 155 I = NDE+1,N - 155 A(I,1) = 0.E0 - ELSE IF (IMPL .EQ. 3) THEN - IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - CALL CGEFA (A, MATDIM, NDE, IPVT, INFO) - IF (INFO .NE. 0) THEN - IER = .TRUE. - RETURN - END IF - CALL CGESL (A, MATDIM, NDE, IPVT, SAVE2, 0) - ELSE IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN - CALL FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - CALL CGBFA (A, MATDIM, NDE, ML, MU, IPVT, INFO) - IF (INFO .NE. 0) THEN - IER = .TRUE. - RETURN - END IF - CALL CGBSL (A, MATDIM, NDE, ML, MU, IPVT, SAVE2, 0) - END IF - END IF - END IF - DO 170 I = 1,NDE - 170 SAVE1(I) = SAVE2(I)/MAX(1.E0, ABS(YWT(I))) - SUM = SCNRM2(NDE, SAVE1, 1)/SQRT(REAL(NDE)) - IF (SUM .GT. EPS/ABS(H)) H = SIGN(EPS/SUM, H) - DO 180 I = 1,N - 180 YH(I,2) = H*SAVE2(I) - IF (MITER .EQ. 2 .OR. MITER .EQ. 5 .OR. ISWFLG .EQ. 3) THEN - DO 20 I = 1,N - 20 FAC(I) = SQRT(UROUND) - END IF - ELSE - IF (MITER .NE. MTROLD) THEN - MTROLD = MITER - RC = 0.E0 - CONVRG = .FALSE. - END IF - IF (MINT .NE. MNTOLD) THEN - MNTOLD = MINT - OLDL0 = EL(1,NQ) - CALL CDCST (MAXORD, MINT, ISWFLG, EL, TQ) - RC = RC*EL(1,NQ)/OLDL0 - NWAIT = NQ + 2 - END IF - IF (H .NE. HOLD) THEN - NWAIT = NQ + 2 - RH = H/HOLD - CALL CDSCL (HMAX, N, NQ, RMAX, HOLD, RC, RH, YH) - END IF - END IF - RETURN - END diff --git a/slatec/cdntp.f b/slatec/cdntp.f deleted file mode 100644 index 8039894..0000000 --- a/slatec/cdntp.f +++ /dev/null @@ -1,54 +0,0 @@ -*DECK CDNTP - SUBROUTINE CDNTP (H, K, N, NQ, T, TOUT, YH, Y) -C***BEGIN PROLOGUE CDNTP -C***SUBSIDIARY -C***PURPOSE Subroutine CDNTP interpolates the K-th derivative of Y at -C TOUT, using the data in the YH array. If K has a value -C greater than NQ, the NQ-th derivative is calculated. -C***LIBRARY SLATEC (SDRIVE) -C***TYPE COMPLEX (SDNTP-S, DDNTP-D, CDNTP-C) -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE CDNTP - INTEGER I, J, JJ, K, KK, KUSED, N, NQ - COMPLEX Y(*), YH(N,*) - REAL FACTOR, H, R, T, TOUT -C***FIRST EXECUTABLE STATEMENT CDNTP - IF (K .EQ. 0) THEN - DO 10 I = 1,N - 10 Y(I) = YH(I,NQ+1) - R = ((TOUT - T)/H) - DO 20 JJ = 1,NQ - J = NQ + 1 - JJ - DO 20 I = 1,N - 20 Y(I) = YH(I,J) + R*Y(I) - ELSE - KUSED = MIN(K, NQ) - FACTOR = 1.E0 - DO 40 KK = 1,KUSED - 40 FACTOR = FACTOR*(NQ+1-KK) - DO 50 I = 1,N - 50 Y(I) = FACTOR*YH(I,NQ+1) - R = ((TOUT - T)/H) - DO 80 JJ = KUSED+1,NQ - J = KUSED + 1 + NQ - JJ - FACTOR = 1.E0 - DO 60 KK = 1,KUSED - 60 FACTOR = FACTOR*(J-KK) - DO 70 I = 1,N - 70 Y(I) = FACTOR*YH(I,J) + R*Y(I) - 80 CONTINUE - DO 100 I = 1,N - 100 Y(I) = Y(I)*H**(-KUSED) - END IF - RETURN - END diff --git a/slatec/cdotc.f b/slatec/cdotc.f deleted file mode 100644 index b7e9f32..0000000 --- a/slatec/cdotc.f +++ /dev/null @@ -1,73 +0,0 @@ -*DECK CDOTC - COMPLEX FUNCTION CDOTC (N, CX, INCX, CY, INCY) -C***BEGIN PROLOGUE CDOTC -C***PURPOSE Dot product of two complex vectors using the complex -C conjugate of the first vector. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A4 -C***TYPE COMPLEX (CDOTC-C) -C***KEYWORDS BLAS, INNER PRODUCT, 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 CX complex vector with N elements -C INCX storage spacing between elements of CX -C CY complex vector with N elements -C INCY storage spacing between elements of CY -C -C --Output-- -C CDOTC complex result (zero if N .LE. 0) -C -C Returns the dot product of complex CX and CY, using CONJUGATE(CX) -C CDOTC = SUM for I = 0 to N-1 of CONJ(CX(LX+I*INCX))*CY(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 CDOTC - COMPLEX CX(*),CY(*) -C***FIRST EXECUTABLE STATEMENT CDOTC - CDOTC = (0.0,0.0) - 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 - CDOTC = CDOTC + CONJG(CX(KX))*CY(KY) - KX = KX + INCX - KY = KY + INCY - 10 CONTINUE - RETURN -C -C Code for equal, positive increments. -C - 20 NS = N*INCX - DO 30 I = 1,NS,INCX - CDOTC = CDOTC + CONJG(CX(I))*CY(I) - 30 CONTINUE - RETURN - END diff --git a/slatec/cdotu.f b/slatec/cdotu.f deleted file mode 100644 index cb001f8..0000000 --- a/slatec/cdotu.f +++ /dev/null @@ -1,72 +0,0 @@ -*DECK CDOTU - COMPLEX FUNCTION CDOTU (N, CX, INCX, CY, INCY) -C***BEGIN PROLOGUE CDOTU -C***PURPOSE Compute the inner product of two vectors. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A4 -C***TYPE COMPLEX (SDOT-S, DDOT-D, CDOTU-C) -C***KEYWORDS BLAS, INNER PRODUCT, 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 CX complex vector with N elements -C INCX storage spacing between elements of CX -C CY complex vector with N elements -C INCY storage spacing between elements of CY -C -C --Output-- -C CDOTU complex result (zero if N .LE. 0) -C -C Returns the dot product of complex CX and CY, no conjugation -C CDOTU = SUM for I = 0 to N-1 of CX(LX+I*INCX) * CY(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 CDOTU - COMPLEX CX(*),CY(*) -C***FIRST EXECUTABLE STATEMENT CDOTU - CDOTU = (0.0,0.0) - 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 - CDOTU = CDOTU + CX(KX)*CY(KY) - KX = KX + INCX - KY = KY + INCY - 10 CONTINUE - RETURN -C -C Code for equal, positive increments. -C - 20 NS = N*INCX - DO 30 I = 1,NS,INCX - CDOTU = CDOTU + CX(I)*CY(I) - 30 CONTINUE - RETURN - END diff --git a/slatec/cdpsc.f b/slatec/cdpsc.f deleted file mode 100644 index 564d683..0000000 --- a/slatec/cdpsc.f +++ /dev/null @@ -1,40 +0,0 @@ -*DECK CDPSC - SUBROUTINE CDPSC (KSGN, N, NQ, YH) -C***BEGIN PROLOGUE CDPSC -C***SUBSIDIARY -C***PURPOSE Subroutine CDPSC computes the predicted YH values by -C effectively multiplying the YH array by the Pascal triangle -C matrix when KSGN is +1, and performs the inverse function -C when KSGN is -1. -C***LIBRARY SLATEC (SDRIVE) -C***TYPE COMPLEX (SDPSC-S, DDPSC-D, CDPSC-C) -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE CDPSC - INTEGER I, J, J1, J2, KSGN, N, NQ - COMPLEX YH(N,*) -C***FIRST EXECUTABLE STATEMENT CDPSC - IF (KSGN .GT. 0) THEN - DO 10 J1 = 1,NQ - DO 10 J2 = J1,NQ - J = NQ - J2 + J1 - DO 10 I = 1,N - 10 YH(I,J) = YH(I,J) + YH(I,J+1) - ELSE - DO 30 J1 = 1,NQ - DO 30 J2 = J1,NQ - J = NQ - J2 + J1 - DO 30 I = 1,N - 30 YH(I,J) = YH(I,J) - YH(I,J+1) - END IF - RETURN - END diff --git a/slatec/cdpst.f b/slatec/cdpst.f deleted file mode 100644 index b466ff7..0000000 --- a/slatec/cdpst.f +++ /dev/null @@ -1,283 +0,0 @@ -*DECK CDPST - SUBROUTINE CDPST (EL, F, FA, H, IMPL, JACOBN, MATDIM, MITER, ML, - 8 MU, N, NDE, NQ, SAVE2, T, USERS, Y, YH, YWT, UROUND, NFE, NJE, - 8 A, DFDY, FAC, IER, IPVT, SAVE1, ISWFLG, BND, JSTATE) -C***BEGIN PROLOGUE CDPST -C***SUBSIDIARY -C***PURPOSE Subroutine CDPST evaluates the Jacobian matrix of the right -C hand side of the differential equations. -C***LIBRARY SLATEC (SDRIVE) -C***TYPE COMPLEX (SDPST-S, DDPST-D, CDPST-C) -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***DESCRIPTION -C -C If MITER is 1, 2, 4, or 5, the matrix -C P = I - L(0)*H*Jacobian is stored in DFDY and subjected to LU -C decomposition, with the results also stored in DFDY. -C -C***ROUTINES CALLED CGBFA, CGEFA, SCNRM2 -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE CDPST - INTEGER I, IFLAG, IMAX, IMPL, INFO, ISWFLG, J, J2, JSTATE, K, - 8 MATDIM, MITER, ML, MU, MW, N, NDE, NFE, NJE, NQ - COMPLEX A(MATDIM,*), CFCTR, DFDY(MATDIM,*), DY, FAC(*), SAVE1(*), - 8 SAVE2(*), Y(*), YH(N,*), YJ, YS, YWT(*) - REAL BL, BND, BP, BR, BU, DFDYMX, DIFF, EL(13,12), FACMAX, FACMIN, - 8 FACTOR, H, SCALE, SCNRM2, T, UROUND, ZMAX, ZMIN - INTEGER IPVT(*) - LOGICAL IER - PARAMETER(FACMAX = .5E0, BU = 0.5E0) -C***FIRST EXECUTABLE STATEMENT CDPST - NJE = NJE + 1 - IER = .FALSE. - IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN - IF (MITER .EQ. 1) THEN - CALL JACOBN (N, T, Y, DFDY, MATDIM, ML, MU) - IF (N .EQ. 0) THEN - JSTATE = 8 - RETURN - END IF - IF (ISWFLG .EQ. 3) BND = SCNRM2(N*N, DFDY, 1) - FACTOR = -EL(1,NQ)*H - DO 110 J = 1,N - DO 110 I = 1,N - 110 DFDY(I,J) = FACTOR*DFDY(I,J) - ELSE IF (MITER .EQ. 2) THEN - BR = UROUND**(.875E0) - BL = UROUND**(.75E0) - BP = UROUND**(-.15E0) - FACMIN = UROUND**(.78E0) - DO 170 J = 1,N - IF (ABS(Y(J)) .GT. ABS(YWT(J))) THEN - YS = Y(J) - ELSE - YS = YWT(J) - END IF - 120 DY = FAC(J)*YS - IF (DY .EQ. 0.E0) THEN - IF (REAL(FAC(J)) .LT. FACMAX) THEN - FAC(J) = MIN(100.E0*REAL(FAC(J)), FACMAX) - GO TO 120 - ELSE - DY = YS - END IF - END IF - DY = (Y(J) + DY) - Y(J) - YJ = Y(J) - Y(J) = Y(J) + DY - CALL F (N, T, Y, SAVE1) - IF (N .EQ. 0) THEN - JSTATE = 6 - RETURN - END IF - Y(J) = YJ - CFCTR = -EL(1,NQ)*H/DY - DO 140 I = 1,N - 140 DFDY(I,J) = (SAVE1(I) - SAVE2(I))*CFCTR -C Step 1 - DIFF = ABS(SAVE2(1) - SAVE1(1)) - IMAX = 1 - DO 150 I = 2,N - IF (ABS(SAVE2(I) - SAVE1(I)) .GT. DIFF) THEN - IMAX = I - DIFF = ABS(SAVE2(I) - SAVE1(I)) - END IF - 150 CONTINUE -C Step 2 - IF (MIN(ABS(SAVE2(IMAX)), ABS(SAVE1(IMAX))) .GT. 0.E0) THEN - SCALE = MAX(ABS(SAVE2(IMAX)), ABS(SAVE1(IMAX))) -C Step 3 - IF (DIFF .GT. BU*SCALE) THEN - FAC(J) = MAX(FACMIN, REAL(FAC(J))*.5E0) - ELSE IF (BR*SCALE .LE. DIFF .AND. DIFF .LE. BL*SCALE) THEN - FAC(J) = MIN(REAL(FAC(J))*2.E0, FACMAX) -C Step 4 - ELSE IF (DIFF .LT. BR*SCALE) THEN - FAC(J) = MIN(BP*REAL(FAC(J)), FACMAX) - END IF - END IF - 170 CONTINUE - IF (ISWFLG .EQ. 3) BND = SCNRM2(N*N, DFDY, 1)/(-EL(1,NQ)*H) - NFE = NFE + N - END IF - IF (IMPL .EQ. 0) THEN - DO 190 I = 1,N - 190 DFDY(I,I) = DFDY(I,I) + 1.E0 - ELSE IF (IMPL .EQ. 1) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - DO 210 J = 1,N - DO 210 I = 1,N - 210 DFDY(I,J) = DFDY(I,J) + A(I,J) - ELSE IF (IMPL .EQ. 2) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - DO 230 I = 1,NDE - 230 DFDY(I,I) = DFDY(I,I) + A(I,1) - ELSE IF (IMPL .EQ. 3) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - DO 220 J = 1,NDE - DO 220 I = 1,NDE - 220 DFDY(I,J) = DFDY(I,J) + A(I,J) - END IF - CALL CGEFA (DFDY, MATDIM, N, IPVT, INFO) - IF (INFO .NE. 0) IER = .TRUE. - ELSE IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN - IF (MITER .EQ. 4) THEN - CALL JACOBN (N, T, Y, DFDY(ML+1,1), MATDIM, ML, MU) - IF (N .EQ. 0) THEN - JSTATE = 8 - RETURN - END IF - FACTOR = -EL(1,NQ)*H - MW = ML + MU + 1 - DO 260 J = 1,N - DO 260 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) - 260 DFDY(I,J) = FACTOR*DFDY(I,J) - ELSE IF (MITER .EQ. 5) THEN - BR = UROUND**(.875E0) - BL = UROUND**(.75E0) - BP = UROUND**(-.15E0) - FACMIN = UROUND**(.78E0) - MW = ML + MU + 1 - J2 = MIN(MW, N) - DO 340 J = 1,J2 - DO 290 K = J,N,MW - IF (ABS(Y(K)) .GT. ABS(YWT(K))) THEN - YS = Y(K) - ELSE - YS = YWT(K) - END IF - 280 DY = FAC(K)*YS - IF (DY .EQ. 0.E0) THEN - IF (REAL(FAC(K)) .LT. FACMAX) THEN - FAC(K) = MIN(100.E0*REAL(FAC(K)), FACMAX) - GO TO 280 - ELSE - DY = YS - END IF - END IF - DY = (Y(K) + DY) - Y(K) - DFDY(MW,K) = Y(K) - 290 Y(K) = Y(K) + DY - CALL F (N, T, Y, SAVE1) - IF (N .EQ. 0) THEN - JSTATE = 6 - RETURN - END IF - DO 330 K = J,N,MW - DY = Y(K) - DFDY(MW,K) - Y(K) = DFDY(MW,K) - CFCTR = -EL(1,NQ)*H/DY - DO 300 I = MAX(ML+1, MW+1-K), MIN(MW+N-K, MW+ML) - 300 DFDY(I,K) = CFCTR*(SAVE1(I+K-MW) - SAVE2(I+K-MW)) -C Step 1 - IMAX = MAX(1, K - MU) - DIFF = ABS(SAVE2(IMAX) - SAVE1(IMAX)) - DO 310 I = MAX(1, K - MU)+1, MIN(K + ML, N) - IF (ABS(SAVE2(I) - SAVE1(I)) .GT. DIFF) THEN - IMAX = I - DIFF = ABS(SAVE2(I) - SAVE1(I)) - END IF - 310 CONTINUE -C Step 2 - IF (MIN(ABS(SAVE2(IMAX)), ABS(SAVE1(IMAX))) .GT.0.E0) THEN - SCALE = MAX(ABS(SAVE2(IMAX)), ABS(SAVE1(IMAX))) -C Step 3 - IF (DIFF .GT. BU*SCALE) THEN - FAC(J) = MAX(FACMIN, REAL(FAC(J))*.5E0) - ELSE IF (BR*SCALE .LE.DIFF .AND. DIFF .LE.BL*SCALE) THEN - FAC(J) = MIN(REAL(FAC(J))*2.E0, FACMAX) -C Step 4 - ELSE IF (DIFF .LT. BR*SCALE) THEN - FAC(K) = MIN(BP*REAL(FAC(K)), FACMAX) - END IF - END IF - 330 CONTINUE - 340 CONTINUE - NFE = NFE + J2 - END IF - IF (ISWFLG .EQ. 3) THEN - DFDYMX = 0.E0 - DO 345 J = 1,N - DO 345 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) - ZMAX = MAX(ABS(REAL(DFDY(I,J))), ABS(AIMAG(DFDY(I,J)))) - ZMIN = MIN(ABS(REAL(DFDY(I,J))), ABS(AIMAG(DFDY(I,J)))) - IF (ZMAX .NE. 0.E0) - 8 DFDYMX = MAX(DFDYMX, ZMAX*SQRT(1.E0+ (ZMIN/ZMAX)**2)) - 345 CONTINUE - BND = 0.E0 - IF (DFDYMX .NE. 0.E0) THEN - DO 350 J = 1,N - DO 350 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) - BND = BND + (REAL(DFDY(I,J))/DFDYMX)**2 + - 8 (AIMAG(DFDY(I,J))/DFDYMX)**2 - 350 CONTINUE - BND = DFDYMX*SQRT(BND)/(-EL(1,NQ)*H) - END IF - END IF - IF (IMPL .EQ. 0) THEN - DO 360 J = 1,N - 360 DFDY(MW,J) = DFDY(MW,J) + 1.E0 - ELSE IF (IMPL .EQ. 1) THEN - CALL FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - DO 380 J = 1,N - DO 380 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) - 380 DFDY(I,J) = DFDY(I,J) + A(I,J) - ELSE IF (IMPL .EQ. 2) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - DO 400 J = 1,NDE - 400 DFDY(MW,J) = DFDY(MW,J) + A(J,1) - ELSE IF (IMPL .EQ. 3) THEN - CALL FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - DO 390 J = 1,NDE - DO 390 I = MAX(ML+1, MW+1-J), MIN(MW+NDE-J, MW+ML) - 390 DFDY(I,J) = DFDY(I,J) + A(I,J) - END IF - CALL CGBFA (DFDY, MATDIM, N, ML, MU, IPVT, INFO) - IF (INFO .NE. 0) IER = .TRUE. - ELSE IF (MITER .EQ. 3) THEN - IFLAG = 1 - CALL USERS (Y, YH(1,2), YWT, SAVE1, SAVE2, T, H, EL(1,NQ), IMPL, - 8 N, NDE, IFLAG) - IF (IFLAG .EQ. -1) THEN - IER = .TRUE. - RETURN - END IF - IF (N .EQ. 0) THEN - JSTATE = 10 - RETURN - END IF - END IF - RETURN - END diff --git a/slatec/cdriv1.f b/slatec/cdriv1.f deleted file mode 100644 index 57fb024..0000000 --- a/slatec/cdriv1.f +++ /dev/null @@ -1,367 +0,0 @@ -*DECK CDRIV1 - SUBROUTINE CDRIV1 (N, T, Y, F, TOUT, MSTATE, EPS, WORK, LENW, - 8 IERFLG) -C***BEGIN PROLOGUE CDRIV1 -C***PURPOSE The function of CDRIV1 is to solve N (200 or fewer) -C ordinary differential equations of the form -C dY(I)/dT = F(Y(I),T), given the initial conditions -C Y(I) = YI. CDRIV1 allows complex-valued differential -C equations. -C***LIBRARY SLATEC (SDRIVE) -C***CATEGORY I1A2, I1A1B -C***TYPE COMPLEX (SDRIV1-S, DDRIV1-D, CDRIV1-C) -C***KEYWORDS COMPLEX VALUED, GEAR'S METHOD, INITIAL VALUE PROBLEMS, -C ODE, ORDINARY DIFFERENTIAL EQUATIONS, SDRIVE, STIFF -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***DESCRIPTION -C -C Version 92.1 -C -C I. CHOOSING THE CORRECT ROUTINE ................................... -C -C SDRIV -C DDRIV -C CDRIV -C These are the generic names for three packages for solving -C initial value problems for ordinary differential equations. -C SDRIV uses single precision arithmetic. DDRIV uses double -C precision arithmetic. CDRIV allows complex-valued -C differential equations, integrated with respect to a single, -C real, independent variable. -C -C As an aid in selecting the proper program, the following is a -C discussion of the important options or restrictions associated with -C each program: -C -C A. CDRIV1 should be tried first for those routine problems with -C no more than 200 differential equations (CDRIV2 and CDRIV3 -C have no such restriction.) Internally this routine has two -C important technical defaults: -C 1. Numerical approximation of the Jacobian matrix of the -C right hand side is used. -C 2. The stiff solver option is used. -C Most users of CDRIV1 should not have to concern themselves -C with these details. -C -C B. CDRIV2 should be considered for those problems for which -C CDRIV1 is inadequate. For example, CDRIV1 may have difficulty -C with problems having zero initial conditions and zero -C derivatives. In this case CDRIV2, with an appropriate value -C of the parameter EWT, should perform more efficiently. CDRIV2 -C provides three important additional options: -C 1. The nonstiff equation solver (as well as the stiff -C solver) is available. -C 2. The root-finding option is available. -C 3. The program can dynamically select either the non-stiff -C or the stiff methods. -C Internally this routine also defaults to the numerical -C approximation of the Jacobian matrix of the right hand side. -C -C C. CDRIV3 is the most flexible, and hence the most complex, of -C the programs. Its important additional features include: -C 1. The ability to exploit band structure in the Jacobian -C matrix. -C 2. The ability to solve some implicit differential -C equations, i.e., those having the form: -C A(Y,T)*dY/dT = F(Y,T). -C 3. The option of integrating in the one step mode. -C 4. The option of allowing the user to provide a routine -C which computes the analytic Jacobian matrix of the right -C hand side. -C 5. The option of allowing the user to provide a routine -C which does all the matrix algebra associated with -C corrections to the solution components. -C -C II. PARAMETERS .................................................... -C -C The user should use parameter names in the call sequence of CDRIV1 -C for those quantities whose value may be altered by CDRIV1. The -C parameters in the call sequence are: -C -C N = (Input) The number of differential equations, N .LE. 200 -C -C T = (Real) The independent variable. On input for the first -C call, T is the initial point. On output, T is the point -C at which the solution is given. -C -C Y = (Complex) The vector of dependent variables. Y is used as -C input on the first call, to set the initial values. On -C output, Y is the computed solution vector. This array Y -C is passed in the call sequence of the user-provided -C routine F. Thus parameters required by F can be stored in -C this array in components N+1 and above. (Note: Changes by -C the user to the first N components of this array will take -C effect only after a restart, i.e., after setting MSTATE to -C +1(-1).) -C -C F = A subroutine supplied by the user. The name must be -C declared EXTERNAL in the user's calling program. This -C subroutine is of the form: -C SUBROUTINE F (N, T, Y, YDOT) -C COMPLEX Y(*), YDOT(*) -C . -C . -C YDOT(1) = ... -C . -C . -C YDOT(N) = ... -C END (Sample) -C This computes YDOT = F(Y,T), the right hand side of the -C differential equations. Here Y is a vector of length at -C least N. The actual length of Y is determined by the -C user's declaration in the program which calls CDRIV1. -C Thus the dimensioning of Y in F, while required by FORTRAN -C convention, does not actually allocate any storage. When -C this subroutine is called, the first N components of Y are -C intermediate approximations to the solution components. -C The user should not alter these values. Here YDOT is a -C vector of length N. The user should only compute YDOT(I) -C for I from 1 to N. Normally a return from F passes -C control back to CDRIV1. However, if the user would like -C to abort the calculation, i.e., return control to the -C program which calls CDRIV1, he should set N to zero. -C CDRIV1 will signal this by returning a value of MSTATE -C equal to +5(-5). Altering the value of N in F has no -C effect on the value of N in the call sequence of CDRIV1. -C -C TOUT = (Input, Real) The point at which the solution is desired. -C -C MSTATE = An integer describing the status of integration. The user -C must initialize MSTATE to +1 or -1. If MSTATE is -C positive, the routine will integrate past TOUT and -C interpolate the solution. This is the most efficient -C mode. If MSTATE is negative, the routine will adjust its -C internal step to reach TOUT exactly (useful if a -C singularity exists beyond TOUT.) The meaning of the -C magnitude of MSTATE: -C 1 (Input) Means the first call to the routine. This -C value must be set by the user. On all subsequent -C calls the value of MSTATE should be tested by the -C user. Unless CDRIV1 is to be reinitialized, only the -C sign of MSTATE may be changed by the user. (As a -C convenience to the user who may wish to put out the -C initial conditions, CDRIV1 can be called with -C MSTATE=+1(-1), and TOUT=T. In this case the program -C will return with MSTATE unchanged, i.e., -C MSTATE=+1(-1).) -C 2 (Output) Means a successful integration. If a normal -C continuation is desired (i.e., a further integration -C in the same direction), simply advance TOUT and call -C again. All other parameters are automatically set. -C 3 (Output)(Unsuccessful) Means the integrator has taken -C 1000 steps without reaching TOUT. The user can -C continue the integration by simply calling CDRIV1 -C again. -C 4 (Output)(Unsuccessful) Means too much accuracy has -C been requested. EPS has been increased to a value -C the program estimates is appropriate. The user can -C continue the integration by simply calling CDRIV1 -C again. -C 5 (Output)(Unsuccessful) N has been set to zero in -C SUBROUTINE F. -C 6 (Output)(Successful) For MSTATE negative, T is beyond -C TOUT. The solution was obtained by interpolation. -C The user can continue the integration by simply -C advancing TOUT and calling CDRIV1 again. -C 7 (Output)(Unsuccessful) The solution could not be -C obtained. The value of IERFLG (see description -C below) for a "Recoverable" situation indicates the -C type of difficulty encountered: either an illegal -C value for a parameter or an inability to continue the -C solution. For this condition the user should take -C corrective action and reset MSTATE to +1(-1) before -C calling CDRIV1 again. Otherwise the program will -C terminate the run. -C -C EPS = (Real) On input, the requested relative accuracy in all -C solution components. On output, the adjusted relative -C accuracy if the input value was too small. The value of -C EPS should be set as large as is reasonable, because the -C amount of work done by CDRIV1 increases as EPS decreases. -C -C WORK -C LENW = (Input) -C WORK is an array of LENW complex words used -C internally for temporary storage. The user must allocate -C space for this array in the calling program by a statement -C such as -C COMPLEX WORK(...) -C The length of WORK should be at least N*N + 11*N + 300 -C and LENW should be set to the value used. The contents of -C WORK should not be disturbed between calls to CDRIV1. -C -C IERFLG = An error flag. The error number associated with a -C diagnostic message (see Section IV-A below) is the same as -C the corresponding value of IERFLG. The meaning of IERFLG: -C 0 The routine completed successfully. (No message is -C issued.) -C 3 (Warning) The number of steps required to reach TOUT -C exceeds 1000 . -C 4 (Warning) The value of EPS is too small. -C 11 (Warning) For MSTATE negative, T is beyond TOUT. -C The solution was obtained by interpolation. -C 15 (Warning) The integration step size is below the -C roundoff level of T. (The program issues this -C message as a warning but does not return control to -C the user.) -C 21 (Recoverable) N is greater than 200 . -C 22 (Recoverable) N is not positive. -C 26 (Recoverable) The magnitude of MSTATE is either 0 or -C greater than 7 . -C 27 (Recoverable) EPS is less than zero. -C 32 (Recoverable) Insufficient storage has been allocated -C for the WORK array. -C 41 (Recoverable) The integration step size has gone -C to zero. -C 42 (Recoverable) The integration step size has been -C reduced about 50 times without advancing the -C solution. The problem setup may not be correct. -C 999 (Fatal) The magnitude of MSTATE is 7 . -C -C III. USAGE ........................................................ -C -C PROGRAM SAMPLE -C EXTERNAL F -C COMPLEX ALFA -C REAL EPS, T, TOUT -C C N is the number of equations -C PARAMETER(ALFA = (1.E0, 1.E0), N = 3, -C 8 LENW = N*N + 11*N + 300) -C COMPLEX WORK(LENW), Y(N+1) -C C Initial point -C T = 0.00001E0 -C C Set initial conditions -C Y(1) = 10.E0 -C Y(2) = 0.E0 -C Y(3) = 10.E0 -C C Pass parameter -C Y(4) = ALFA -C TOUT = T -C MSTATE = 1 -C EPS = .001E0 -C 10 CALL CDRIV1 (N, T, Y, F, TOUT, MSTATE, EPS, WORK, LENW, -C 8 IERFLG) -C IF (MSTATE .GT. 2) STOP -C WRITE(*, '(5E12.3)') TOUT, (Y(I), I=1,3) -C TOUT = 10.E0*TOUT -C IF (TOUT .LT. 50.E0) GO TO 10 -C END -C -C SUBROUTINE F (N, T, Y, YDOT) -C COMPLEX ALFA, Y(*), YDOT(*) -C REAL T -C ALFA = Y(N+1) -C YDOT(1) = 1.E0 + ALFA*(Y(2) - Y(1)) - Y(1)*Y(3) -C YDOT(2) = ALFA*(Y(1) - Y(2)) - Y(2)*Y(3) -C YDOT(3) = 1.E0 - Y(3)*(Y(1) + Y(2)) -C END -C -C IV. OTHER COMMUNICATION TO THE USER ............................... -C -C A. The solver communicates to the user through the parameters -C above. In addition it writes diagnostic messages through the -C standard error handling program XERMSG. A complete description -C of XERMSG is given in "Guide to the SLATEC Common Mathematical -C Library" by Kirby W. Fong et al.. At installations which do not -C have this error handling package the short but serviceable -C routine, XERMSG, available with this package, can be used. That -C program uses the file named OUTPUT to transmit messages. -C -C B. The number of evaluations of the right hand side can be found -C in the WORK array in the location determined by: -C LENW - (N + 50) + 4 -C -C V. REMARKS ........................................................ -C -C For other information, see Section IV of the writeup for CDRIV3. -C -C***REFERENCES C. W. Gear, Numerical Initial Value Problems in -C Ordinary Differential Equations, Prentice-Hall, 1971. -C***ROUTINES CALLED CDRIV3, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE CDRIV1 - EXTERNAL F - COMPLEX WORK(*), Y(*) - REAL EPS, EWTCOM(1), HMAX, T, TOUT - INTEGER I, IDLIW, IERFLG, IERROR, IMPL, LENIW, LENW, LENWCM, - 8 LNWCHK, MINT, MITER, ML, MSTATE, MU, MXN, MXORD, MXSTEP, - 8 N, NDE, NROOT, NSTATE, NTASK - PARAMETER(MXN = 200, IDLIW = 50) - INTEGER IWORK(IDLIW+MXN) - CHARACTER INTGR1*8 - PARAMETER(NROOT = 0, IERROR = 2, MINT = 2, MITER = 2, IMPL = 0, - 8 MXORD = 5, MXSTEP = 1000) - DATA EWTCOM(1) /1.E0/ -C***FIRST EXECUTABLE STATEMENT CDRIV1 - IF (ABS(MSTATE) .EQ. 0 .OR. ABS(MSTATE) .GT. 7) THEN - WRITE(INTGR1, '(I8)') MSTATE - IERFLG = 26 - CALL XERMSG('SLATEC', 'CDRIV1', - 8 'Illegal input. The magnitude of MSTATE, '//INTGR1// - 8 ', is not in the range 1 to 6 .', IERFLG, 1) - MSTATE = SIGN(7, MSTATE) - RETURN - ELSE IF (ABS(MSTATE) .EQ. 7) THEN - IERFLG = 999 - CALL XERMSG('SLATEC', 'CDRIV1', - 8 'Illegal input. The magnitude of MSTATE is 7 .', IERFLG, 2) - RETURN - END IF - IF (N .GT. MXN) THEN - WRITE(INTGR1, '(I8)') N - IERFLG = 21 - CALL XERMSG('SLATEC', 'CDRIV1', - 8 'Illegal input. The number of equations, '//INTGR1// - 8 ', is greater than the maximum allowed: 200 .', IERFLG, 1) - MSTATE = SIGN(7, MSTATE) - RETURN - END IF - IF (MSTATE .GT. 0) THEN - NSTATE = MSTATE - NTASK = 1 - ELSE - NSTATE = - MSTATE - NTASK = 3 - END IF - HMAX = 2.E0*ABS(TOUT - T) - LENIW = N + IDLIW - LENWCM = LENW - LENIW - IF (LENWCM .LT. (N*N + 10*N + 250)) THEN - LNWCHK = N*N + 10*N + 250 + LENIW - WRITE(INTGR1, '(I8)') LNWCHK - IERFLG = 32 - CALL XERMSG('SLATEC', 'CDRIV1', - 8 'Insufficient storage allocated for the work array. '// - 8 'The required storage is at least '//INTGR1//' .', IERFLG, 1) - MSTATE = SIGN(7, MSTATE) - RETURN - END IF - IF (NSTATE .NE. 1) THEN - DO 20 I = 1,LENIW - 20 IWORK(I) = WORK(I+LENWCM) - END IF - CALL CDRIV3 (N, T, Y, F, NSTATE, TOUT, NTASK, NROOT, EPS, EWTCOM, - 8 IERROR, MINT, MITER, IMPL, ML, MU, MXORD, HMAX, WORK, - 8 LENWCM, IWORK, LENIW, F, F, NDE, MXSTEP, F, F, - 8 IERFLG) - DO 40 I = 1,LENIW - 40 WORK(I+LENWCM) = IWORK(I) - IF (NSTATE .LE. 4) THEN - MSTATE = SIGN(NSTATE, MSTATE) - ELSE IF (NSTATE .EQ. 6) THEN - MSTATE = SIGN(5, MSTATE) - ELSE IF (IERFLG .EQ. 11) THEN - MSTATE = SIGN(6, MSTATE) - ELSE IF (IERFLG .GT. 11) THEN - MSTATE = SIGN(7, MSTATE) - END IF - RETURN - END diff --git a/slatec/cdriv2.f b/slatec/cdriv2.f deleted file mode 100644 index 47c7ff2..0000000 --- a/slatec/cdriv2.f +++ /dev/null @@ -1,409 +0,0 @@ -*DECK CDRIV2 - SUBROUTINE CDRIV2 (N, T, Y, F, TOUT, MSTATE, NROOT, EPS, EWT, - 8 MINT, WORK, LENW, IWORK, LENIW, G, IERFLG) -C***BEGIN PROLOGUE CDRIV2 -C***PURPOSE The function of CDRIV2 is to solve N ordinary differential -C equations of the form dY(I)/dT = F(Y(I),T), given the -C initial conditions Y(I) = YI. The program has options to -C allow the solution of both stiff and non-stiff differential -C equations. CDRIV2 allows complex-valued differential -C equations. -C***LIBRARY SLATEC (SDRIVE) -C***CATEGORY I1A2, I1A1B -C***TYPE COMPLEX (SDRIV2-S, DDRIV2-D, CDRIV2-C) -C***KEYWORDS COMPLEX VALUED, GEAR'S METHOD, INITIAL VALUE PROBLEMS, -C ODE, ORDINARY DIFFERENTIAL EQUATIONS, SDRIVE, STIFF -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***DESCRIPTION -C -C I. PARAMETERS ..................................................... -C -C The user should use parameter names in the call sequence of CDRIV2 -C for those quantities whose value may be altered by CDRIV2. The -C parameters in the call sequence are: -C -C N = (Input) The number of differential equations. -C -C T = (Real) The independent variable. On input for the first -C call, T is the initial point. On output, T is the point -C at which the solution is given. -C -C Y = (Complex) The vector of dependent variables. Y is used as -C input on the first call, to set the initial values. On -C output, Y is the computed solution vector. This array Y -C is passed in the call sequence of the user-provided -C routines F and G. Thus parameters required by F and G can -C be stored in this array in components N+1 and above. -C (Note: Changes by the user to the first N components of -C this array will take effect only after a restart, i.e., -C after setting MSTATE to +1(-1).) -C -C F = A subroutine supplied by the user. The name must be -C declared EXTERNAL in the user's calling program. This -C subroutine is of the form: -C SUBROUTINE F (N, T, Y, YDOT) -C COMPLEX Y(*), YDOT(*) -C . -C . -C YDOT(1) = ... -C . -C . -C YDOT(N) = ... -C END (Sample) -C This computes YDOT = F(Y,T), the right hand side of the -C differential equations. Here Y is a vector of length at -C least N. The actual length of Y is determined by the -C user's declaration in the program which calls CDRIV2. -C Thus the dimensioning of Y in F, while required by FORTRAN -C convention, does not actually allocate any storage. When -C this subroutine is called, the first N components of Y are -C intermediate approximations to the solution components. -C The user should not alter these values. Here YDOT is a -C vector of length N. The user should only compute YDOT(I) -C for I from 1 to N. Normally a return from F passes -C control back to CDRIV2. However, if the user would like -C to abort the calculation, i.e., return control to the -C program which calls CDRIV2, he should set N to zero. -C CDRIV2 will signal this by returning a value of MSTATE -C equal to +6(-6). Altering the value of N in F has no -C effect on the value of N in the call sequence of CDRIV2. -C -C TOUT = (Input, Real) The point at which the solution is desired. -C -C MSTATE = An integer describing the status of integration. The user -C must initialize MSTATE to +1 or -1. If MSTATE is -C positive, the routine will integrate past TOUT and -C interpolate the solution. This is the most efficient -C mode. If MSTATE is negative, the routine will adjust its -C internal step to reach TOUT exactly (useful if a -C singularity exists beyond TOUT.) The meaning of the -C magnitude of MSTATE: -C 1 (Input) Means the first call to the routine. This -C value must be set by the user. On all subsequent -C calls the value of MSTATE should be tested by the -C user. Unless CDRIV2 is to be reinitialized, only the -C sign of MSTATE may be changed by the user. (As a -C convenience to the user who may wish to put out the -C initial conditions, CDRIV2 can be called with -C MSTATE=+1(-1), and TOUT=T. In this case the program -C will return with MSTATE unchanged, i.e., -C MSTATE=+1(-1).) -C 2 (Output) Means a successful integration. If a normal -C continuation is desired (i.e., a further integration -C in the same direction), simply advance TOUT and call -C again. All other parameters are automatically set. -C 3 (Output)(Unsuccessful) Means the integrator has taken -C 1000 steps without reaching TOUT. The user can -C continue the integration by simply calling CDRIV2 -C again. Other than an error in problem setup, the -C most likely cause for this condition is trying to -C integrate a stiff set of equations with the non-stiff -C integrator option. (See description of MINT below.) -C 4 (Output)(Unsuccessful) Means too much accuracy has -C been requested. EPS has been increased to a value -C the program estimates is appropriate. The user can -C continue the integration by simply calling CDRIV2 -C again. -C 5 (Output) A root was found at a point less than TOUT. -C The user can continue the integration toward TOUT by -C simply calling CDRIV2 again. -C 6 (Output)(Unsuccessful) N has been set to zero in -C SUBROUTINE F. -C 7 (Output)(Unsuccessful) N has been set to zero in -C FUNCTION G. See description of G below. -C 8 (Output)(Successful) For MSTATE negative, T is beyond -C TOUT. The solution was obtained by interpolation. -C The user can continue the integration by simply -C advancing TOUT and calling CDRIV2 again. -C 9 (Output)(Unsuccessful) The solution could not be -C obtained. The value of IERFLG (see description -C below) for a "Recoverable" situation indicates the -C type of difficulty encountered: either an illegal -C value for a parameter or an inability to continue the -C solution. For this condition the user should take -C corrective action and reset MSTATE to +1(-1) before -C calling CDRIV2 again. Otherwise the program will -C terminate the run. -C -C NROOT = (Input) The number of equations whose roots are desired. -C If NROOT is zero, the root search is not active. This -C option is useful for obtaining output at points which are -C not known in advance, but depend upon the solution, e.g., -C when some solution component takes on a specified value. -C The root search is carried out using the user-written -C function G (see description of G below.) CDRIV2 attempts -C to find the value of T at which one of the equations -C changes sign. CDRIV2 can find at most one root per -C equation per internal integration step, and will then -C return the solution either at TOUT or at a root, whichever -C occurs first in the direction of integration. The initial -C point is never reported as a root. The index of the -C equation whose root is being reported is stored in the -C sixth element of IWORK. -C NOTE: NROOT is never altered by this program. -C -C EPS = (Real) On input, the requested relative accuracy in all -C solution components. EPS = 0 is allowed. On output, the -C adjusted relative accuracy if the input value was too -C small. The value of EPS should be set as large as is -C reasonable, because the amount of work done by CDRIV2 -C increases as EPS decreases. -C -C EWT = (Input, Real) Problem zero, i.e., the smallest physically -C meaningful value for the solution. This is used inter- -C nally to compute an array YWT(I) = MAX(ABS(Y(I)), EWT). -C One step error estimates divided by YWT(I) are kept less -C than EPS. Setting EWT to zero provides pure relative -C error control. However, setting EWT smaller than -C necessary can adversely affect the running time. -C -C MINT = (Input) The integration method flag. -C MINT = 1 Means the Adams methods, and is used for -C non-stiff problems. -C MINT = 2 Means the stiff methods of Gear (i.e., the -C backward differentiation formulas), and is -C used for stiff problems. -C MINT = 3 Means the program dynamically selects the -C Adams methods when the problem is non-stiff -C and the Gear methods when the problem is -C stiff. -C MINT may not be changed without restarting, i.e., setting -C the magnitude of MSTATE to 1. -C -C WORK -C LENW = (Input) -C WORK is an array of LENW complex words used -C internally for temporary storage. The user must allocate -C space for this array in the calling program by a statement -C such as -C COMPLEX WORK(...) -C The length of WORK should be at least -C 16*N + 2*NROOT + 250 if MINT is 1, or -C N*N + 10*N + 2*NROOT + 250 if MINT is 2, or -C N*N + 17*N + 2*NROOT + 250 if MINT is 3, -C and LENW should be set to the value used. The contents of -C WORK should not be disturbed between calls to CDRIV2. -C -C IWORK -C LENIW = (Input) -C IWORK is an integer array of length LENIW used internally -C for temporary storage. The user must allocate space for -C this array in the calling program by a statement such as -C INTEGER IWORK(...) -C The length of IWORK should be at least -C 50 if MINT is 1, or -C N+50 if MINT is 2 or 3, -C and LENIW should be set to the value used. The contents -C of IWORK should not be disturbed between calls to CDRIV2. -C -C G = A real FORTRAN function supplied by the user -C if NROOT is not 0. In this case, the name must be -C declared EXTERNAL in the user's calling program. G is -C repeatedly called with different values of IROOT to -C obtain the value of each of the NROOT equations for which -C a root is desired. G is of the form: -C REAL FUNCTION G (N, T, Y, IROOT) -C COMPLEX Y(*) -C GO TO (10, ...), IROOT -C 10 G = ... -C . -C . -C END (Sample) -C Here, Y is a vector of length at least N, whose first N -C components are the solution components at the point T. -C The user should not alter these values. The actual length -C of Y is determined by the user's declaration in the -C program which calls CDRIV2. Thus the dimensioning of Y in -C G, while required by FORTRAN convention, does not actually -C allocate any storage. Normally a return from G passes -C control back to CDRIV2. However, if the user would like -C to abort the calculation, i.e., return control to the -C program which calls CDRIV2, he should set N to zero. -C CDRIV2 will signal this by returning a value of MSTATE -C equal to +7(-7). In this case, the index of the equation -C being evaluated is stored in the sixth element of IWORK. -C Altering the value of N in G has no effect on the value of -C N in the call sequence of CDRIV2. -C -C IERFLG = An error flag. The error number associated with a -C diagnostic message (see Section II-A below) is the same as -C the corresponding value of IERFLG. The meaning of IERFLG: -C 0 The routine completed successfully. (No message is -C issued.) -C 3 (Warning) The number of steps required to reach TOUT -C exceeds MXSTEP. -C 4 (Warning) The value of EPS is too small. -C 11 (Warning) For MSTATE negative, T is beyond TOUT. -C The solution was obtained by interpolation. -C 15 (Warning) The integration step size is below the -C roundoff level of T. (The program issues this -C message as a warning but does not return control to -C the user.) -C 22 (Recoverable) N is not positive. -C 23 (Recoverable) MINT is less than 1 or greater than 3 . -C 26 (Recoverable) The magnitude of MSTATE is either 0 or -C greater than 9 . -C 27 (Recoverable) EPS is less than zero. -C 32 (Recoverable) Insufficient storage has been allocated -C for the WORK array. -C 33 (Recoverable) Insufficient storage has been allocated -C for the IWORK array. -C 41 (Recoverable) The integration step size has gone -C to zero. -C 42 (Recoverable) The integration step size has been -C reduced about 50 times without advancing the -C solution. The problem setup may not be correct. -C 999 (Fatal) The magnitude of MSTATE is 9 . -C -C II. OTHER COMMUNICATION TO THE USER ............................... -C -C A. The solver communicates to the user through the parameters -C above. In addition it writes diagnostic messages through the -C standard error handling program XERMSG. A complete description -C of XERMSG is given in "Guide to the SLATEC Common Mathematical -C Library" by Kirby W. Fong et al.. At installations which do not -C have this error handling package the short but serviceable -C routine, XERMSG, available with this package, can be used. That -C program uses the file named OUTPUT to transmit messages. -C -C B. The first three elements of WORK and the first five elements of -C IWORK will contain the following statistical data: -C AVGH The average step size used. -C HUSED The step size last used (successfully). -C AVGORD The average order used. -C IMXERR The index of the element of the solution vector that -C contributed most to the last error test. -C NQUSED The order last used (successfully). -C NSTEP The number of steps taken since last initialization. -C NFE The number of evaluations of the right hand side. -C NJE The number of evaluations of the Jacobian matrix. -C -C III. REMARKS ...................................................... -C -C A. On any return from CDRIV2 all information necessary to continue -C the calculation is contained in the call sequence parameters, -C including the work arrays. Thus it is possible to suspend one -C problem, integrate another, and then return to the first. -C -C B. If this package is to be used in an overlay situation, the user -C must declare in the primary overlay the variables in the call -C sequence to CDRIV2. -C -C C. When the routine G is not required, difficulties associated with -C an unsatisfied external can be avoided by using the name of the -C routine which calculates the right hand side of the differential -C equations in place of G in the call sequence of CDRIV2. -C -C IV. USAGE ......................................................... -C -C PROGRAM SAMPLE -C EXTERNAL F -C PARAMETER(MINT = 1, NROOT = 0, N = ..., -C 8 LENW = 16*N + 2*NROOT + 250, LENIW = 50) -C C N is the number of equations -C COMPLEX WORK(LENW), Y(N) -C REAL EPS, EWT, T, TOUT -C INTEGER IWORK(LENIW) -C OPEN(FILE='TAPE6', UNIT=6, STATUS='NEW') -C C Initial point -C T = 0. -C C Set initial conditions -C DO 10 I = 1,N -C 10 Y(I) = ... -C TOUT = T -C EWT = ... -C MSTATE = 1 -C EPS = ... -C 20 CALL CDRIV2 (N, T, Y, F, TOUT, MSTATE, NROOT, EPS, EWT, -C 8 MINT, WORK, LENW, IWORK, LENIW, F, IERFLG) -C C Next to last argument is not -C C F if rootfinding is used. -C IF (MSTATE .GT. 2) STOP -C WRITE(6, 100) TOUT, (Y(I), I=1,N) -C TOUT = TOUT + 1. -C IF (TOUT .LE. 10.) GO TO 20 -C 100 FORMAT(...) -C END (Sample) -C -C***REFERENCES C. W. Gear, Numerical Initial Value Problems in -C Ordinary Differential Equations, Prentice-Hall, 1971. -C***ROUTINES CALLED CDRIV3, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE CDRIV2 - EXTERNAL F, G - COMPLEX WORK(*), Y(*) - REAL EPS, EWT, EWTCOM(1), G, HMAX, T, TOUT - INTEGER IWORK(*) - INTEGER IERFLG, IERROR, IMPL, LENIW, LENW, MINT, MITER, ML, - 8 MSTATE, MU, MXORD, MXSTEP, N, NDE, NROOT, NSTATE, NTASK - CHARACTER INTGR1*8 - PARAMETER(IMPL = 0, MXSTEP = 1000) -C***FIRST EXECUTABLE STATEMENT CDRIV2 - IF (ABS(MSTATE) .EQ. 9) THEN - IERFLG = 999 - CALL XERMSG('SLATEC', 'CDRIV2', - 8 'Illegal input. The magnitude of MSTATE IS 9 .', - 8 IERFLG, 2) - RETURN - ELSE IF (ABS(MSTATE) .EQ. 0 .OR. ABS(MSTATE) .GT. 9) THEN - WRITE(INTGR1, '(I8)') MSTATE - IERFLG = 26 - CALL XERMSG('SLATEC', 'CDRIV2', - 8 'Illegal input. The magnitude of MSTATE, '//INTGR1// - 8 ' is not in the range 1 to 8 .', IERFLG, 1) - MSTATE = SIGN(9, MSTATE) - RETURN - END IF - IF (MINT .LT. 1 .OR. MINT .GT. 3) THEN - WRITE(INTGR1, '(I8)') MINT - IERFLG = 23 - CALL XERMSG('SLATEC', 'CDRIV2', - 8 'Illegal input. Improper value for the integration method '// - 8 'flag, '//INTGR1//' .', IERFLG, 1) - MSTATE = SIGN(9, MSTATE) - RETURN - END IF - IF (MSTATE .GE. 0) THEN - NSTATE = MSTATE - NTASK = 1 - ELSE - NSTATE = - MSTATE - NTASK = 3 - END IF - EWTCOM(1) = EWT - IF (EWT .NE. 0.E0) THEN - IERROR = 3 - ELSE - IERROR = 2 - END IF - IF (MINT .EQ. 1) THEN - MITER = 0 - MXORD = 12 - ELSE IF (MINT .EQ. 2) THEN - MITER = 2 - MXORD = 5 - ELSE IF (MINT .EQ. 3) THEN - MITER = 2 - MXORD = 12 - END IF - HMAX = 2.E0*ABS(TOUT - T) - CALL CDRIV3 (N, T, Y, F, NSTATE, TOUT, NTASK, NROOT, EPS, EWTCOM, - 8 IERROR, MINT, MITER, IMPL, ML, MU, MXORD, HMAX, WORK, - 8 LENW, IWORK, LENIW, F, F, NDE, MXSTEP, G, F, IERFLG) - IF (NSTATE .LE. 7) THEN - MSTATE = SIGN(NSTATE, MSTATE) - ELSE IF (NSTATE .EQ. 11) THEN - MSTATE = SIGN(8, MSTATE) - ELSE IF (NSTATE .GT. 11) THEN - MSTATE = SIGN(9, MSTATE) - END IF - RETURN - END diff --git a/slatec/cdriv3.f b/slatec/cdriv3.f deleted file mode 100644 index 3704588..0000000 --- a/slatec/cdriv3.f +++ /dev/null @@ -1,1577 +0,0 @@ -*DECK CDRIV3 - SUBROUTINE CDRIV3 (N, T, Y, F, NSTATE, TOUT, NTASK, NROOT, EPS, - 8 EWT, IERROR, MINT, MITER, IMPL, ML, MU, MXORD, HMAX, WORK, - 8 LENW, IWORK, LENIW, JACOBN, FA, NDE, MXSTEP, G, USERS, IERFLG) -C***BEGIN PROLOGUE CDRIV3 -C***PURPOSE The function of CDRIV3 is to solve N ordinary differential -C equations of the form dY(I)/dT = F(Y(I),T), given the -C initial conditions Y(I) = YI. The program has options to -C allow the solution of both stiff and non-stiff differential -C equations. Other important options are available. CDRIV3 -C allows complex-valued differential equations. -C***LIBRARY SLATEC (SDRIVE) -C***CATEGORY I1A2, I1A1B -C***TYPE COMPLEX (SDRIV3-S, DDRIV3-D, CDRIV3-C) -C***KEYWORDS COMPLEX VALUED, GEAR'S METHOD, INITIAL VALUE PROBLEMS, -C ODE, ORDINARY DIFFERENTIAL EQUATIONS, SDRIVE, STIFF -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***DESCRIPTION -C -C I. ABSTRACT ....................................................... -C -C The primary function of CDRIV3 is to solve N ordinary differential -C equations of the form dY(I)/dT = F(Y(I),T), given the initial -C conditions Y(I) = YI. The program has options to allow the -C solution of both stiff and non-stiff differential equations. In -C addition, CDRIV3 may be used to solve: -C 1. The initial value problem, A*dY(I)/dT = F(Y(I),T), where A is -C a non-singular matrix depending on Y and T. -C 2. The hybrid differential/algebraic initial value problem, -C A*dY(I)/dT = F(Y(I),T), where A is a vector (whose values may -C depend upon Y and T) some of whose components will be zero -C corresponding to those equations which are algebraic rather -C than differential. -C CDRIV3 is to be called once for each output point of T. -C -C II. PARAMETERS .................................................... -C -C The user should use parameter names in the call sequence of CDRIV3 -C for those quantities whose value may be altered by CDRIV3. The -C parameters in the call sequence are: -C -C N = (Input) The number of dependent functions whose solution -C is desired. N must not be altered during a problem. -C -C T = (Real) The independent variable. On input for the first -C call, T is the initial point. On output, T is the point -C at which the solution is given. -C -C Y = (Complex) The vector of dependent variables. Y is used as -C input on the first call, to set the initial values. On -C output, Y is the computed solution vector. This array Y -C is passed in the call sequence of the user-provided -C routines F, JACOBN, FA, USERS, and G. Thus parameters -C required by those routines can be stored in this array in -C components N+1 and above. (Note: Changes by the user to -C the first N components of this array will take effect only -C after a restart, i.e., after setting NSTATE to 1 .) -C -C F = A subroutine supplied by the user. The name must be -C declared EXTERNAL in the user's calling program. This -C subroutine is of the form: -C SUBROUTINE F (N, T, Y, YDOT) -C COMPLEX Y(*), YDOT(*) -C . -C . -C YDOT(1) = ... -C . -C . -C YDOT(N) = ... -C END (Sample) -C This computes YDOT = F(Y,T), the right hand side of the -C differential equations. Here Y is a vector of length at -C least N. The actual length of Y is determined by the -C user's declaration in the program which calls CDRIV3. -C Thus the dimensioning of Y in F, while required by FORTRAN -C convention, does not actually allocate any storage. When -C this subroutine is called, the first N components of Y are -C intermediate approximations to the solution components. -C The user should not alter these values. Here YDOT is a -C vector of length N. The user should only compute YDOT(I) -C for I from 1 to N. Normally a return from F passes -C control back to CDRIV3. However, if the user would like -C to abort the calculation, i.e., return control to the -C program which calls CDRIV3, he should set N to zero. -C CDRIV3 will signal this by returning a value of NSTATE -C equal to 6 . Altering the value of N in F has no effect -C on the value of N in the call sequence of CDRIV3. -C -C NSTATE = An integer describing the status of integration. The -C meaning of NSTATE is as follows: -C 1 (Input) Means the first call to the routine. This -C value must be set by the user. On all subsequent -C calls the value of NSTATE should be tested by the -C user, but must not be altered. (As a convenience to -C the user who may wish to put out the initial -C conditions, CDRIV3 can be called with NSTATE=1, and -C TOUT=T. In this case the program will return with -C NSTATE unchanged, i.e., NSTATE=1.) -C 2 (Output) Means a successful integration. If a normal -C continuation is desired (i.e., a further integration -C in the same direction), simply advance TOUT and call -C again. All other parameters are automatically set. -C 3 (Output)(Unsuccessful) Means the integrator has taken -C MXSTEP steps without reaching TOUT. The user can -C continue the integration by simply calling CDRIV3 -C again. -C 4 (Output)(Unsuccessful) Means too much accuracy has -C been requested. EPS has been increased to a value -C the program estimates is appropriate. The user can -C continue the integration by simply calling CDRIV3 -C again. -C 5 (Output) A root was found at a point less than TOUT. -C The user can continue the integration toward TOUT by -C simply calling CDRIV3 again. -C 6 (Output)(Unsuccessful) N has been set to zero in -C SUBROUTINE F. -C 7 (Output)(Unsuccessful) N has been set to zero in -C FUNCTION G. See description of G below. -C 8 (Output)(Unsuccessful) N has been set to zero in -C SUBROUTINE JACOBN. See description of JACOBN below. -C 9 (Output)(Unsuccessful) N has been set to zero in -C SUBROUTINE FA. See description of FA below. -C 10 (Output)(Unsuccessful) N has been set to zero in -C SUBROUTINE USERS. See description of USERS below. -C 11 (Output)(Successful) For NTASK = 2 or 3, T is beyond -C TOUT. The solution was obtained by interpolation. -C The user can continue the integration by simply -C advancing TOUT and calling CDRIV3 again. -C 12 (Output)(Unsuccessful) The solution could not be -C obtained. The value of IERFLG (see description -C below) for a "Recoverable" situation indicates the -C type of difficulty encountered: either an illegal -C value for a parameter or an inability to continue the -C solution. For this condition the user should take -C corrective action and reset NSTATE to 1 before -C calling CDRIV3 again. Otherwise the program will -C terminate the run. -C -C TOUT = (Input, Real) The point at which the solution is desired. -C The position of TOUT relative to T on the first call -C determines the direction of integration. -C -C NTASK = (Input) An index specifying the manner of returning the -C solution, according to the following: -C NTASK = 1 Means CDRIV3 will integrate past TOUT and -C interpolate the solution. This is the most -C efficient mode. -C NTASK = 2 Means CDRIV3 will return the solution after -C each internal integration step, or at TOUT, -C whichever comes first. In the latter case, -C the program integrates exactly to TOUT. -C NTASK = 3 Means CDRIV3 will adjust its internal step to -C reach TOUT exactly (useful if a singularity -C exists beyond TOUT.) -C -C NROOT = (Input) The number of equations whose roots are desired. -C If NROOT is zero, the root search is not active. This -C option is useful for obtaining output at points which are -C not known in advance, but depend upon the solution, e.g., -C when some solution component takes on a specified value. -C The root search is carried out using the user-written -C function G (see description of G below.) CDRIV3 attempts -C to find the value of T at which one of the equations -C changes sign. CDRIV3 can find at most one root per -C equation per internal integration step, and will then -C return the solution either at TOUT or at a root, whichever -C occurs first in the direction of integration. The initial -C point is never reported as a root. The index of the -C equation whose root is being reported is stored in the -C sixth element of IWORK. -C NOTE: NROOT is never altered by this program. -C -C EPS = (Real) On input, the requested relative accuracy in all -C solution components. EPS = 0 is allowed. On output, the -C adjusted relative accuracy if the input value was too -C small. The value of EPS should be set as large as is -C reasonable, because the amount of work done by CDRIV3 -C increases as EPS decreases. -C -C EWT = (Input, Real) Problem zero, i.e., the smallest, nonzero, -C physically meaningful value for the solution. (Array, -C possibly of length one. See following description of -C IERROR.) Setting EWT smaller than necessary can adversely -C affect the running time. -C -C IERROR = (Input) Error control indicator. A value of 3 is -C suggested for most problems. Other choices and detailed -C explanations of EWT and IERROR are given below for those -C who may need extra flexibility. -C -C These last three input quantities EPS, EWT and IERROR -C control the accuracy of the computed solution. EWT and -C IERROR are used internally to compute an array YWT. One -C step error estimates divided by YWT(I) are kept less than -C EPS in root mean square norm. -C IERROR (Set by the user) = -C 1 Means YWT(I) = 1. (Absolute error control) -C EWT is ignored. -C 2 Means YWT(I) = ABS(Y(I)), (Relative error control) -C EWT is ignored. -C 3 Means YWT(I) = MAX(ABS(Y(I)), EWT(1)). -C 4 Means YWT(I) = MAX(ABS(Y(I)), EWT(I)). -C This choice is useful when the solution components -C have differing scales. -C 5 Means YWT(I) = EWT(I). -C If IERROR is 3, EWT need only be dimensioned one. -C If IERROR is 4 or 5, the user must dimension EWT at least -C N, and set its values. -C -C MINT = (Input) The integration method indicator. -C MINT = 1 Means the Adams methods, and is used for -C non-stiff problems. -C MINT = 2 Means the stiff methods of Gear (i.e., the -C backward differentiation formulas), and is -C used for stiff problems. -C MINT = 3 Means the program dynamically selects the -C Adams methods when the problem is non-stiff -C and the Gear methods when the problem is -C stiff. When using the Adams methods, the -C program uses a value of MITER=0; when using -C the Gear methods, the program uses the value -C of MITER provided by the user. Only a value -C of IMPL = 0 and a value of MITER = 1, 2, 4, or -C 5 is allowed for this option. The user may -C not alter the value of MINT or MITER without -C restarting, i.e., setting NSTATE to 1. -C -C MITER = (Input) The iteration method indicator. -C MITER = 0 Means functional iteration. This value is -C suggested for non-stiff problems. -C MITER = 1 Means chord method with analytic Jacobian. -C In this case, the user supplies subroutine -C JACOBN (see description below). -C MITER = 2 Means chord method with Jacobian calculated -C internally by finite differences. -C MITER = 3 Means chord method with corrections computed -C by the user-written routine USERS (see -C description of USERS below.) This option -C allows all matrix algebra and storage -C decisions to be made by the user. When using -C a value of MITER = 3, the subroutine FA is -C not required, even if IMPL is not 0. For -C further information on using this option, see -C Section IV-E below. -C MITER = 4 Means the same as MITER = 1 but the A and -C Jacobian matrices are assumed to be banded. -C MITER = 5 Means the same as MITER = 2 but the A and -C Jacobian matrices are assumed to be banded. -C -C IMPL = (Input) The implicit method indicator. -C IMPL = 0 Means solving dY(I)/dT = F(Y(I),T). -C IMPL = 1 Means solving A*dY(I)/dT = F(Y(I),T), non- -C singular A (see description of FA below.) -C Only MINT = 1 or 2, and MITER = 1, 2, 3, 4, -C or 5 are allowed for this option. -C IMPL = 2,3 Means solving certain systems of hybrid -C differential/algebraic equations (see -C description of FA below.) Only MINT = 2 and -C MITER = 1, 2, 3, 4, or 5, are allowed for -C this option. -C The value of IMPL must not be changed during a problem. -C -C ML = (Input) The lower half-bandwidth in the case of a banded -C A or Jacobian matrix. (I.e., maximum(R-C) for nonzero -C A(R,C).) -C -C MU = (Input) The upper half-bandwidth in the case of a banded -C A or Jacobian matrix. (I.e., maximum(C-R).) -C -C MXORD = (Input) The maximum order desired. This is .LE. 12 for -C the Adams methods and .LE. 5 for the Gear methods. Normal -C value is 12 and 5, respectively. If MINT is 3, the -C maximum order used will be MIN(MXORD, 12) when using the -C Adams methods, and MIN(MXORD, 5) when using the Gear -C methods. MXORD must not be altered during a problem. -C -C HMAX = (Input, Real) The maximum magnitude of the step size that -C will be used for the problem. This is useful for ensuring -C that important details are not missed. If this is not the -C case, a large value, such as the interval length, is -C suggested. -C -C WORK -C LENW = (Input) -C WORK is an array of LENW complex words used -C internally for temporary storage. The user must allocate -C space for this array in the calling program by a statement -C such as -C COMPLEX WORK(...) -C The following table gives the required minimum value for -C the length of WORK, depending on the value of IMPL and -C MITER. LENW should be set to the value used. The -C contents of WORK should not be disturbed between calls to -C CDRIV3. -C -C IMPL = 0 1 2 3 -C --------------------------------------------------------- -C MITER = 0 (MXORD+4)*N Not allowed Not allowed Not allowed -C + 2*NROOT -C + 250 -C -C 1,2 N*N + 2*N*N + N*N + N*(N + NDE) -C (MXORD+5)*N (MXORD+5)*N (MXORD+6)*N + (MXORD+5)*N -C + 2*NROOT + 2*NROOT + 2*NROOT + 2*NROOT -C + 250 + 250 + 250 + 250 -C -C 3 (MXORD+4)*N (MXORD+4)*N (MXORD+4)*N (MXORD+4)*N -C + 2*NROOT + 2*NROOT + 2*NROOT + 2*NROOT -C + 250 + 250 + 250 + 250 -C -C 4,5 (2*ML+MU+1) 2*(2*ML+MU+1) (2*ML+MU+1) (2*ML+MU+1)* -C *N + *N + *N + (N+NDE) + -C (MXORD+5)*N (MXORD+5)*N (MXORD+6)*N + (MXORD+5)*N -C + 2*NROOT + 2*NROOT + 2*NROOT + 2*NROOT -C + 250 + 250 + 250 + 250 -C --------------------------------------------------------- -C -C IWORK -C LENIW = (Input) -C IWORK is an integer array of length LENIW used internally -C for temporary storage. The user must allocate space for -C this array in the calling program by a statement such as -C INTEGER IWORK(...) -C The length of IWORK should be at least -C 50 if MITER is 0 or 3, or -C N+50 if MITER is 1, 2, 4, or 5, or MINT is 3, -C and LENIW should be set to the value used. The contents -C of IWORK should not be disturbed between calls to CDRIV3. -C -C JACOBN = A subroutine supplied by the user, if MITER is 1 or 4. -C If this is the case, the name must be declared EXTERNAL in -C the user's calling program. Given a system of N -C differential equations, it is meaningful to speak about -C the partial derivative of the I-th right hand side with -C respect to the J-th dependent variable. In general there -C are N*N such quantities. Often however the equations can -C be ordered so that the I-th differential equation only -C involves dependent variables with index near I, e.g., I+1, -C I-2. Such a system is called banded. If, for all I, the -C I-th equation depends on at most the variables -C Y(I-ML), Y(I-ML+1), ... , Y(I), Y(I+1), ... , Y(I+MU) -C then we call ML+MU+1 the bandwidth of the system. In a -C banded system many of the partial derivatives above are -C automatically zero. For the cases MITER = 1, 2, 4, and 5, -C some of these partials are needed. For the cases -C MITER = 2 and 5 the necessary derivatives are -C approximated numerically by CDRIV3, and we only ask the -C user to tell CDRIV3 the value of ML and MU if the system -C is banded. For the cases MITER = 1 and 4 the user must -C derive these partials algebraically and encode them in -C subroutine JACOBN. By computing these derivatives the -C user can often save 20-30 per cent of the computing time. -C Usually, however, the accuracy is not much affected and -C most users will probably forego this option. The optional -C user-written subroutine JACOBN has the form: -C SUBROUTINE JACOBN (N, T, Y, DFDY, MATDIM, ML, MU) -C COMPLEX Y(*), DFDY(MATDIM,*) -C . -C . -C Calculate values of DFDY -C . -C . -C END (Sample) -C Here Y is a vector of length at least N. The actual -C length of Y is determined by the user's declaration in the -C program which calls CDRIV3. Thus the dimensioning of Y in -C JACOBN, while required by FORTRAN convention, does not -C actually allocate any storage. When this subroutine is -C called, the first N components of Y are intermediate -C approximations to the solution components. The user -C should not alter these values. If the system is not -C banded (MITER=1), the partials of the I-th equation with -C respect to the J-th dependent function are to be stored in -C DFDY(I,J). Thus partials of the I-th equation are stored -C in the I-th row of DFDY. If the system is banded -C (MITER=4), then the partials of the I-th equation with -C respect to Y(J) are to be stored in DFDY(K,J), where -C K=I-J+MU+1 . Normally a return from JACOBN passes control -C back to CDRIV3. However, if the user would like to abort -C the calculation, i.e., return control to the program which -C calls CDRIV3, he should set N to zero. CDRIV3 will signal -C this by returning a value of NSTATE equal to +8(-8). -C Altering the value of N in JACOBN has no effect on the -C value of N in the call sequence of CDRIV3. -C -C FA = A subroutine supplied by the user if IMPL is not zero, and -C MITER is not 3. If so, the name must be declared EXTERNAL -C in the user's calling program. This subroutine computes -C the array A, where A*dY(I)/dT = F(Y(I),T). -C There are three cases: -C -C IMPL=1. -C Subroutine FA is of the form: -C SUBROUTINE FA (N, T, Y, A, MATDIM, ML, MU, NDE) -C COMPLEX Y(*), A(MATDIM,*) -C . -C . -C Calculate ALL values of A -C . -C . -C END (Sample) -C In this case A is assumed to be a nonsingular matrix, -C with the same structure as DFDY (see JACOBN description -C above). Programming considerations prevent complete -C generality. If MITER is 1 or 2, A is assumed to be full -C and the user must compute and store all values of -C A(I,J), I,J=1, ... ,N. If MITER is 4 or 5, A is assumed -C to be banded with lower and upper half bandwidth ML and -C MU. The left hand side of the I-th equation is a linear -C combination of dY(I-ML)/dT, dY(I-ML+1)/dT, ... , -C dY(I)/dT, ... , dY(I+MU-1)/dT, dY(I+MU)/dT. Thus in the -C I-th equation, the coefficient of dY(J)/dT is to be -C stored in A(K,J), where K=I-J+MU+1. -C NOTE: The array A will be altered between calls to FA. -C -C IMPL=2. -C Subroutine FA is of the form: -C SUBROUTINE FA (N, T, Y, A, MATDIM, ML, MU, NDE) -C COMPLEX Y(*), A(*) -C . -C . -C Calculate non-zero values of A(1),...,A(NDE) -C . -C . -C END (Sample) -C In this case it is assumed that the system is ordered by -C the user so that the differential equations appear -C first, and the algebraic equations appear last. The -C algebraic equations must be written in the form: -C 0 = F(Y(I),T). When using this option it is up to the -C user to provide initial values for the Y(I) that satisfy -C the algebraic equations as well as possible. It is -C further assumed that A is a vector of length NDE. All -C of the components of A, which may depend on T, Y(I), -C etc., must be set by the user to non-zero values. -C -C IMPL=3. -C Subroutine FA is of the form: -C SUBROUTINE FA (N, T, Y, A, MATDIM, ML, MU, NDE) -C COMPLEX Y(*), A(MATDIM,*) -C . -C . -C Calculate ALL values of A -C . -C . -C END (Sample) -C In this case A is assumed to be a nonsingular NDE by NDE -C matrix with the same structure as DFDY (see JACOBN -C description above). Programming considerations prevent -C complete generality. If MITER is 1 or 2, A is assumed -C to be full and the user must compute and store all -C values of A(I,J), I,J=1, ... ,NDE. If MITER is 4 or 5, -C A is assumed to be banded with lower and upper half -C bandwidths ML and MU. The left hand side of the I-th -C equation is a linear combination of dY(I-ML)/dT, -C dY(I-ML+1)/dT, ... , dY(I)/dT, ... , dY(I+MU-1)/dT, -C dY(I+MU)/dT. Thus in the I-th equation, the coefficient -C of dY(J)/dT is to be stored in A(K,J), where K=I-J+MU+1. -C It is assumed that the system is ordered by the user so -C that the differential equations appear first, and the -C algebraic equations appear last. The algebraic -C equations must be written in the form 0 = F(Y(I),T). -C When using this option it is up to the user to provide -C initial values for the Y(I) that satisfy the algebraic -C equations as well as possible. -C NOTE: For IMPL = 3, the array A will be altered between -C calls to FA. -C Here Y is a vector of length at least N. The actual -C length of Y is determined by the user's declaration in the -C program which calls CDRIV3. Thus the dimensioning of Y in -C FA, while required by FORTRAN convention, does not -C actually allocate any storage. When this subroutine is -C called, the first N components of Y are intermediate -C approximations to the solution components. The user -C should not alter these values. FA is always called -C immediately after calling F, with the same values of T -C and Y. Normally a return from FA passes control back to -C CDRIV3. However, if the user would like to abort the -C calculation, i.e., return control to the program which -C calls CDRIV3, he should set N to zero. CDRIV3 will signal -C this by returning a value of NSTATE equal to +9(-9). -C Altering the value of N in FA has no effect on the value -C of N in the call sequence of CDRIV3. -C -C NDE = (Input) The number of differential equations. This is -C required only for IMPL = 2 or 3, with NDE .LT. N. -C -C MXSTEP = (Input) The maximum number of internal steps allowed on -C one call to CDRIV3. -C -C G = A real FORTRAN function supplied by the user -C if NROOT is not 0. In this case, the name must be -C declared EXTERNAL in the user's calling program. G is -C repeatedly called with different values of IROOT to obtain -C the value of each of the NROOT equations for which a root -C is desired. G is of the form: -C REAL FUNCTION G (N, T, Y, IROOT) -C COMPLEX Y(*) -C GO TO (10, ...), IROOT -C 10 G = ... -C . -C . -C END (Sample) -C Here, Y is a vector of length at least N, whose first N -C components are the solution components at the point T. -C The user should not alter these values. The actual length -C of Y is determined by the user's declaration in the -C program which calls CDRIV3. Thus the dimensioning of Y in -C G, while required by FORTRAN convention, does not actually -C allocate any storage. Normally a return from G passes -C control back to CDRIV3. However, if the user would like -C to abort the calculation, i.e., return control to the -C program which calls CDRIV3, he should set N to zero. -C CDRIV3 will signal this by returning a value of NSTATE -C equal to +7(-7). In this case, the index of the equation -C being evaluated is stored in the sixth element of IWORK. -C Altering the value of N in G has no effect on the value of -C N in the call sequence of CDRIV3. -C -C USERS = A subroutine supplied by the user, if MITER is 3. -C If this is the case, the name must be declared EXTERNAL in -C the user's calling program. The routine USERS is called -C by CDRIV3 when certain linear systems must be solved. The -C user may choose any method to form, store and solve these -C systems in order to obtain the solution result that is -C returned to CDRIV3. In particular, this allows sparse -C matrix methods to be used. The call sequence for this -C routine is: -C -C SUBROUTINE USERS (Y, YH, YWT, SAVE1, SAVE2, T, H, EL, -C 8 IMPL, N, NDE, IFLAG) -C COMPLEX Y(*), YH(*), YWT(*), SAVE1(*), SAVE2(*) -C REAL T, H, EL -C -C The input variable IFLAG indicates what action is to be -C taken. Subroutine USERS should perform the following -C operations, depending on the value of IFLAG and IMPL. -C -C IFLAG = 0 -C IMPL = 0. USERS is not called. -C IMPL = 1, 2 or 3. Solve the system A*X = SAVE2, -C returning the result in SAVE2. The array SAVE1 can -C be used as a work array. For IMPL = 1, there are N -C components to the system, and for IMPL = 2 or 3, -C there are NDE components to the system. -C -C IFLAG = 1 -C IMPL = 0. Compute, decompose and store the matrix -C (I - H*EL*J), where I is the identity matrix and J -C is the Jacobian matrix of the right hand side. The -C array SAVE1 can be used as a work array. -C IMPL = 1, 2 or 3. Compute, decompose and store the -C matrix (A - H*EL*J). The array SAVE1 can be used as -C a work array. -C -C IFLAG = 2 -C IMPL = 0. Solve the system -C (I - H*EL*J)*X = H*SAVE2 - YH - SAVE1, -C returning the result in SAVE2. -C IMPL = 1, 2 or 3. Solve the system -C (A - H*EL*J)*X = H*SAVE2 - A*(YH + SAVE1) -C returning the result in SAVE2. -C The array SAVE1 should not be altered. -C If IFLAG is 0 and IMPL is 1 or 2 and the matrix A is -C singular, or if IFLAG is 1 and one of the matrices -C (I - H*EL*J), (A - H*EL*J) is singular, the INTEGER -C variable IFLAG is to be set to -1 before RETURNing. -C Normally a return from USERS passes control back to -C CDRIV3. However, if the user would like to abort the -C calculation, i.e., return control to the program which -C calls CDRIV3, he should set N to zero. CDRIV3 will signal -C this by returning a value of NSTATE equal to +10(-10). -C Altering the value of N in USERS has no effect on the -C value of N in the call sequence of CDRIV3. -C -C IERFLG = An error flag. The error number associated with a -C diagnostic message (see Section III-A below) is the same -C as the corresponding value of IERFLG. The meaning of -C IERFLG: -C 0 The routine completed successfully. (No message is -C issued.) -C 3 (Warning) The number of steps required to reach TOUT -C exceeds MXSTEP. -C 4 (Warning) The value of EPS is too small. -C 11 (Warning) For NTASK = 2 or 3, T is beyond TOUT. -C The solution was obtained by interpolation. -C 15 (Warning) The integration step size is below the -C roundoff level of T. (The program issues this -C message as a warning but does not return control to -C the user.) -C 22 (Recoverable) N is not positive. -C 23 (Recoverable) MINT is less than 1 or greater than 3 . -C 24 (Recoverable) MITER is less than 0 or greater than -C 5 . -C 25 (Recoverable) IMPL is less than 0 or greater than 3 . -C 26 (Recoverable) The value of NSTATE is less than 1 or -C greater than 12 . -C 27 (Recoverable) EPS is less than zero. -C 28 (Recoverable) MXORD is not positive. -C 29 (Recoverable) For MINT = 3, either MITER = 0 or 3, or -C IMPL = 0 . -C 30 (Recoverable) For MITER = 0, IMPL is not 0 . -C 31 (Recoverable) For MINT = 1, IMPL is 2 or 3 . -C 32 (Recoverable) Insufficient storage has been allocated -C for the WORK array. -C 33 (Recoverable) Insufficient storage has been allocated -C for the IWORK array. -C 41 (Recoverable) The integration step size has gone -C to zero. -C 42 (Recoverable) The integration step size has been -C reduced about 50 times without advancing the -C solution. The problem setup may not be correct. -C 43 (Recoverable) For IMPL greater than 0, the matrix A -C is singular. -C 999 (Fatal) The value of NSTATE is 12 . -C -C III. OTHER COMMUNICATION TO THE USER .............................. -C -C A. The solver communicates to the user through the parameters -C above. In addition it writes diagnostic messages through the -C standard error handling program XERMSG. A complete description -C of XERMSG is given in "Guide to the SLATEC Common Mathematical -C Library" by Kirby W. Fong et al.. At installations which do not -C have this error handling package the short but serviceable -C routine, XERMSG, available with this package, can be used. That -C program uses the file named OUTPUT to transmit messages. -C -C B. The first three elements of WORK and the first five elements of -C IWORK will contain the following statistical data: -C AVGH The average step size used. -C HUSED The step size last used (successfully). -C AVGORD The average order used. -C IMXERR The index of the element of the solution vector that -C contributed most to the last error test. -C NQUSED The order last used (successfully). -C NSTEP The number of steps taken since last initialization. -C NFE The number of evaluations of the right hand side. -C NJE The number of evaluations of the Jacobian matrix. -C -C IV. REMARKS ....................................................... -C -C A. Other routines used: -C CDNTP, CDZRO, CDSTP, CDNTL, CDPST, CDCOR, CDCST, -C CDPSC, and CDSCL; -C CGEFA, CGESL, CGBFA, CGBSL, and SCNRM2 (from LINPACK) -C R1MACH (from the Bell Laboratories Machine Constants Package) -C XERMSG (from the SLATEC Common Math Library) -C The last seven routines above, not having been written by the -C present authors, are not explicitly part of this package. -C -C B. On any return from CDRIV3 all information necessary to continue -C the calculation is contained in the call sequence parameters, -C including the work arrays. Thus it is possible to suspend one -C problem, integrate another, and then return to the first. -C -C C. If this package is to be used in an overlay situation, the user -C must declare in the primary overlay the variables in the call -C sequence to CDRIV3. -C -C D. Changing parameters during an integration. -C The value of NROOT, EPS, EWT, IERROR, MINT, MITER, or HMAX may -C be altered by the user between calls to CDRIV3. For example, if -C too much accuracy has been requested (the program returns with -C NSTATE = 4 and an increased value of EPS) the user may wish to -C increase EPS further. In general, prudence is necessary when -C making changes in parameters since such changes are not -C implemented until the next integration step, which is not -C necessarily the next call to CDRIV3. This can happen if the -C program has already integrated to a point which is beyond the -C new point TOUT. -C -C E. As the price for complete control of matrix algebra, the CDRIV3 -C USERS option puts all responsibility for Jacobian matrix -C evaluation on the user. It is often useful to approximate -C numerically all or part of the Jacobian matrix. However this -C must be done carefully. The FORTRAN sequence below illustrates -C the method we recommend. It can be inserted directly into -C subroutine USERS to approximate Jacobian elements in rows I1 -C to I2 and columns J1 to J2. -C COMPLEX DFDY(N,N), R, SAVE1(N), SAVE2(N), Y(N), YJ, YWT(N) -C REAL EPSJ, H, R1MACH, T, UROUND -C UROUND = R1MACH(4) -C EPSJ = SQRT(UROUND) -C DO 30 J = J1,J2 -C IF (ABS(Y(J)) .GT. ABS(YWT(J))) THEN -C R = EPSJ*Y(J) -C ELSE -C R = EPSJ*YWT(J) -C END IF -C IF (R .EQ. 0.E0) R = YWT(J) -C YJ = Y(J) -C Y(J) = Y(J) + R -C CALL F (N, T, Y, SAVE1) -C IF (N .EQ. 0) RETURN -C Y(J) = YJ -C DO 20 I = I1,I2 -C 20 DFDY(I,J) = (SAVE1(I) - SAVE2(I))/R -C 30 CONTINUE -C Many problems give rise to structured sparse Jacobians, e.g., -C block banded. It is possible to approximate them with fewer -C function evaluations than the above procedure uses; see Curtis, -C Powell and Reid, J. Inst. Maths Applics, (1974), Vol. 13, -C pp. 117-119. -C -C F. When any of the routines JACOBN, FA, G, or USERS, is not -C required, difficulties associated with unsatisfied externals can -C be avoided by using the name of the routine which calculates the -C right hand side of the differential equations in place of the -C corresponding name in the call sequence of CDRIV3. -C -C***REFERENCES C. W. Gear, Numerical Initial Value Problems in -C Ordinary Differential Equations, Prentice-Hall, 1971. -C***ROUTINES CALLED CDNTP, CDSTP, CDZRO, CGBFA, CGBSL, CGEFA, CGESL, -C R1MACH, SCNRM2, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE CDRIV3 - EXTERNAL F, JACOBN, FA, G, USERS - COMPLEX WORK(*), Y(*) - REAL AE, AVGH, AVGORD, BIG, EL(13,12), EPS, EWT(*), - 8 G, GLAST, GNOW, H, HMAX, HOLD, HSIGN, HUSED, NROUND, RC, RE, - 8 RMAX, R1MACH, SCNRM2, SIZE, SUM, T, TLAST, TOUT, TQ(3,12), - 8 TREND, TROOT, UROUND - INTEGER I, IA, IAVGH, IAVGRD, ICNVRG, IDFDY, IEL, IERFLG, IERROR, - 8 IFAC, IFLAG, IGNOW, IH, IHMAX, IHOLD, IHSIGN, IHUSED, - 8 IJROOT, IJSTPL, IJTASK, IMNT, IMNTLD, IMPL, IMTR, IMTRLD, - 8 IMTRSV, IMXERR, IMXORD, IMXRDS, INDMXR, INDPRT, INDPVT, - 8 INDTRT, INFE, INFO, INJE, INQ, INQUSE, INROOT, INRTLD, - 8 INSTEP, INWAIT, IRC, IRMAX, IROOT, IMACH1, IMACH4, ISAVE1, - 8 ISAVE2, IT, ITOUT, ITQ, ITREND, ITROOT, IWORK(*), IYH, - 8 IYWT, J, JSTATE, JTROOT, LENCHK, LENIW, LENW, LIWCHK, - 8 MATDIM, MAXORD, MINT, MITER, ML, MU, MXORD, MXSTEP, N, - 8 NDE, NDECOM, NPAR, NROOT, NSTATE, NSTEPL, NTASK - LOGICAL CONVRG - CHARACTER INTGR1*8, INTGR2*8, RL1*16, RL2*16 - PARAMETER(NROUND = 20.E0) - PARAMETER(IAVGH = 1, IHUSED = 2, IAVGRD = 3, - 8 IEL = 4, IH = 160, IHMAX = 161, IHOLD = 162, - 8 IHSIGN = 163, IRC = 164, IRMAX = 165, IT = 166, - 8 ITOUT = 167, ITQ = 168, ITREND = 204, IMACH1 = 205, - 8 IMACH4 = 206, IYH = 251, - 8 INDMXR = 1, INQUSE = 2, INSTEP = 3, INFE = 4, INJE = 5, - 8 INROOT = 6, ICNVRG = 7, IJROOT = 8, IJTASK = 9, - 8 IMNTLD = 10, IMTRLD = 11, INQ = 12, INRTLD = 13, - 8 INDTRT = 14, INWAIT = 15, IMNT = 16, IMTRSV = 17, - 8 IMTR = 18, IMXRDS = 19, IMXORD = 20, INDPRT = 21, - 8 IJSTPL = 22, INDPVT = 51) -C***FIRST EXECUTABLE STATEMENT CDRIV3 - IF (NSTATE .EQ. 12) THEN - IERFLG = 999 - CALL XERMSG('SLATEC', 'CDRIV3', - 8 'Illegal input. The value of NSTATE is 12 .', IERFLG, 2) - RETURN - ELSE IF (NSTATE .LT. 1 .OR. NSTATE .GT. 12) THEN - WRITE(INTGR1, '(I8)') NSTATE - IERFLG = 26 - CALL XERMSG('SLATEC', 'CDRIV3', - 8 'Illegal input. Improper value for NSTATE(= '//INTGR1//').', - 8 IERFLG, 1) - NSTATE = 12 - RETURN - END IF - NPAR = N - IF (EPS .LT. 0.E0) THEN - WRITE(RL1, '(E16.8)') EPS - IERFLG = 27 - CALL XERMSG('SLATEC', 'CDRIV3', - 8 'Illegal input. EPS, '//RL1//', is negative.', IERFLG, 1) - NSTATE = 12 - RETURN - END IF - IF (N .LE. 0) THEN - WRITE(INTGR1, '(I8)') N - IERFLG = 22 - CALL XERMSG('SLATEC', 'CDRIV3', - 8 'Illegal input. Number of equations, '//INTGR1// - 8 ', is not positive.', IERFLG, 1) - NSTATE = 12 - RETURN - END IF - IF (MXORD .LE. 0) THEN - WRITE(INTGR1, '(I8)') MXORD - IERFLG = 28 - CALL XERMSG('SLATEC', 'CDRIV3', - 8 'Illegal input. Maximum order, '//INTGR1// - 8 ', is not positive.', IERFLG, 1) - NSTATE = 12 - RETURN - END IF - IF (MINT .LT. 1 .OR. MINT .GT. 3) THEN - WRITE(INTGR1, '(I8)') MINT - IERFLG = 23 - CALL XERMSG('SLATEC', 'CDRIV3', - 8 'Illegal input. Improper value for the integration method '// - 8 'flag, '//INTGR1//' .', IERFLG, 1) - NSTATE = 12 - RETURN - ELSE IF (MITER .LT. 0 .OR. MITER .GT. 5) THEN - WRITE(INTGR1, '(I8)') MITER - IERFLG = 24 - CALL XERMSG('SLATEC', 'CDRIV3', - 8 'Illegal input. Improper value for MITER(= '//INTGR1//').', - 8 IERFLG, 1) - NSTATE = 12 - RETURN - ELSE IF (IMPL .LT. 0 .OR. IMPL .GT. 3) THEN - WRITE(INTGR1, '(I8)') IMPL - IERFLG = 25 - CALL XERMSG('SLATEC', 'CDRIV3', - 8 'Illegal input. Improper value for IMPL(= '//INTGR1//').', - 8 IERFLG, 1) - NSTATE = 12 - RETURN - ELSE IF (MINT .EQ. 3 .AND. - 8 (MITER .EQ. 0 .OR. MITER .EQ. 3 .OR. IMPL .NE. 0)) THEN - WRITE(INTGR1, '(I8)') MITER - WRITE(INTGR2, '(I8)') IMPL - IERFLG = 29 - CALL XERMSG('SLATEC', 'CDRIV3', - 8 'Illegal input. For MINT = 3, the value of MITER, '//INTGR1// - 8 ', and/or IMPL, '//INTGR2//', is not allowed.', IERFLG, 1) - NSTATE = 12 - RETURN - ELSE IF ((IMPL .GE. 1 .AND. IMPL .LE. 3) .AND. MITER .EQ. 0) THEN - WRITE(INTGR1, '(I8)') IMPL - IERFLG = 30 - CALL XERMSG('SLATEC', 'CDRIV3', - 8 'Illegal input. For MITER = 0, the value of IMPL, '//INTGR1// - 8 ', is not allowed.', IERFLG, 1) - NSTATE = 12 - RETURN - ELSE IF ((IMPL .EQ. 2 .OR. IMPL .EQ. 3) .AND. MINT .EQ. 1) THEN - WRITE(INTGR1, '(I8)') IMPL - IERFLG = 31 - CALL XERMSG('SLATEC', 'CDRIV3', - 8 'Illegal input. For MINT = 1, the value of IMPL, '//INTGR1// - 8 ', is not allowed.', IERFLG, 1) - NSTATE = 12 - RETURN - END IF - IF (MITER .EQ. 0 .OR. MITER .EQ. 3) THEN - LIWCHK = INDPVT - 1 - ELSE IF (MITER .EQ. 1 .OR. MITER .EQ. 2 .OR. MITER .EQ. 4 .OR. - 8 MITER .EQ. 5) THEN - LIWCHK = INDPVT + N - 1 - END IF - IF (LENIW .LT. LIWCHK) THEN - WRITE(INTGR1, '(I8)') LIWCHK - IERFLG = 33 - CALL XERMSG('SLATEC', 'CDRIV3', - 8 'Illegal input. Insufficient storage allocated for the '// - 8 'IWORK array. Based on the value of the input parameters '// - 8 'involved, the required storage is '//INTGR1//' .', IERFLG, 1) - NSTATE = 12 - RETURN - END IF -C Allocate the WORK array -C IYH is the index of YH in WORK - IF (MINT .EQ. 1 .OR. MINT .EQ. 3) THEN - MAXORD = MIN(MXORD, 12) - ELSE IF (MINT .EQ. 2) THEN - MAXORD = MIN(MXORD, 5) - END IF - IDFDY = IYH + (MAXORD + 1)*N -C IDFDY is the index of DFDY -C - IF (MITER .EQ. 0 .OR. MITER .EQ. 3) THEN - IYWT = IDFDY - ELSE IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN - IYWT = IDFDY + N*N - ELSE IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN - IYWT = IDFDY + (2*ML + MU + 1)*N - END IF -C IYWT is the index of YWT - ISAVE1 = IYWT + N -C ISAVE1 is the index of SAVE1 - ISAVE2 = ISAVE1 + N -C ISAVE2 is the index of SAVE2 - IGNOW = ISAVE2 + N -C IGNOW is the index of GNOW - ITROOT = IGNOW + NROOT -C ITROOT is the index of TROOT - IFAC = ITROOT + NROOT -C IFAC is the index of FAC - IF (MITER .EQ. 2 .OR. MITER .EQ. 5 .OR. MINT .EQ. 3) THEN - IA = IFAC + N - ELSE - IA = IFAC - END IF -C IA is the index of A - IF (IMPL .EQ. 0 .OR. MITER .EQ. 3) THEN - LENCHK = IA - 1 - ELSE IF (IMPL .EQ. 1 .AND. (MITER .EQ. 1 .OR. MITER .EQ. 2)) THEN - LENCHK = IA - 1 + N*N - ELSE IF (IMPL .EQ. 1 .AND. (MITER .EQ. 4 .OR. MITER .EQ. 5)) THEN - LENCHK = IA - 1 + (2*ML + MU + 1)*N - ELSE IF (IMPL .EQ. 2 .AND. MITER .NE. 3) THEN - LENCHK = IA - 1 + N - ELSE IF (IMPL .EQ. 3 .AND. (MITER .EQ. 1 .OR. MITER .EQ. 2)) THEN - LENCHK = IA - 1 + N*NDE - ELSE IF (IMPL .EQ. 3 .AND. (MITER .EQ. 4 .OR. MITER .EQ. 5)) THEN - LENCHK = IA - 1 + (2*ML + MU + 1)*NDE - END IF - IF (LENW .LT. LENCHK) THEN - WRITE(INTGR1, '(I8)') LENCHK - IERFLG = 32 - CALL XERMSG('SLATEC', 'CDRIV3', - 8 'Illegal input. Insufficient storage allocated for the '// - 8 'WORK array. Based on the value of the input parameters '// - 8 'involved, the required storage is '//INTGR1//' .', IERFLG, 1) - NSTATE = 12 - RETURN - END IF - IF (MITER .EQ. 0 .OR. MITER .EQ. 3) THEN - MATDIM = 1 - ELSE IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN - MATDIM = N - ELSE IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN - MATDIM = 2*ML + MU + 1 - END IF - IF (IMPL .EQ. 0 .OR. IMPL .EQ. 1) THEN - NDECOM = N - ELSE IF (IMPL .EQ. 2 .OR. IMPL .EQ. 3) THEN - NDECOM = NDE - END IF - IF (NSTATE .EQ. 1) THEN -C Initialize parameters - IF (MINT .EQ. 1 .OR. MINT .EQ. 3) THEN - IWORK(IMXORD) = MIN(MXORD, 12) - ELSE IF (MINT .EQ. 2) THEN - IWORK(IMXORD) = MIN(MXORD, 5) - END IF - IWORK(IMXRDS) = MXORD - IF (MINT .EQ. 1 .OR. MINT .EQ. 2) THEN - IWORK(IMNT) = MINT - IWORK(IMTR) = MITER - IWORK(IMNTLD) = MINT - IWORK(IMTRLD) = MITER - ELSE IF (MINT .EQ. 3) THEN - IWORK(IMNT) = 1 - IWORK(IMTR) = 0 - IWORK(IMNTLD) = IWORK(IMNT) - IWORK(IMTRLD) = IWORK(IMTR) - IWORK(IMTRSV) = MITER - END IF - WORK(IHMAX) = HMAX - UROUND = R1MACH (4) - WORK(IMACH4) = UROUND - WORK(IMACH1) = R1MACH (1) - IF (NROOT .NE. 0) THEN - RE = UROUND - AE = WORK(IMACH1) - END IF - H = (TOUT - T)*(1.E0 - 4.E0*UROUND) - H = SIGN(MIN(ABS(H), HMAX), H) - WORK(IH) = H - HSIGN = SIGN(1.E0, H) - WORK(IHSIGN) = HSIGN - IWORK(IJTASK) = 0 - AVGH = 0.E0 - AVGORD = 0.E0 - WORK(IAVGH) = 0.E0 - WORK(IHUSED) = 0.E0 - WORK(IAVGRD) = 0.E0 - IWORK(INDMXR) = 0 - IWORK(INQUSE) = 0 - IWORK(INSTEP) = 0 - IWORK(IJSTPL) = 0 - IWORK(INFE) = 0 - IWORK(INJE) = 0 - IWORK(INROOT) = 0 - WORK(IT) = T - IWORK(ICNVRG) = 0 - IWORK(INDPRT) = 0 -C Set initial conditions - DO 30 I = 1,N - 30 WORK(I+IYH-1) = Y(I) - IF (T .EQ. TOUT) RETURN - GO TO 180 - ELSE - UROUND = WORK(IMACH4) - IF (NROOT .NE. 0) THEN - RE = UROUND - AE = WORK(IMACH1) - END IF - END IF -C On a continuation, check -C that output points have -C been or will be overtaken. - IF (IWORK(ICNVRG) .EQ. 1) THEN - CONVRG = .TRUE. - ELSE - CONVRG = .FALSE. - END IF - AVGH = WORK(IAVGH) - AVGORD = WORK(IAVGRD) - HOLD = WORK(IHOLD) - RC = WORK(IRC) - RMAX = WORK(IRMAX) - TREND = WORK(ITREND) - DO 35 J = 1,12 - DO 35 I = 1,13 - 35 EL(I,J) = WORK(I+IEL+(J-1)*13-1) - DO 40 J = 1,12 - DO 40 I = 1,3 - 40 TQ(I,J) = WORK(I+ITQ+(J-1)*3-1) - T = WORK(IT) - H = WORK(IH) - HSIGN = WORK(IHSIGN) - IF (IWORK(IJTASK) .EQ. 0) GO TO 180 -C -C IWORK(IJROOT) flags unreported -C roots, and is set to the value of -C NTASK when a root was last selected. -C It is set to zero when all roots -C have been reported. IWORK(INROOT) -C contains the index and WORK(ITOUT) -C contains the value of the root last -C selected to be reported. -C IWORK(INRTLD) contains the value of -C NROOT and IWORK(INDTRT) contains -C the value of ITROOT when the array -C of roots was last calculated. - IF (NROOT .NE. 0) THEN - IF (IWORK(IJROOT) .GT. 0) THEN -C TOUT has just been reported. -C If TROOT .LE. TOUT, report TROOT. - IF (NSTATE .NE. 5) THEN - IF (TOUT*HSIGN .GE. REAL(WORK(ITOUT))*HSIGN) THEN - TROOT = WORK(ITOUT) - CALL CDNTP (H, 0, N, IWORK(INQ), T, TROOT, WORK(IYH), Y) - T = TROOT - NSTATE = 5 - IERFLG = 0 - GO TO 580 - END IF -C A root has just been reported. -C Select the next root. - ELSE - TROOT = T - IROOT = 0 - DO 50 I = 1,IWORK(INRTLD) - JTROOT = I + IWORK(INDTRT) - 1 - IF (REAL(WORK(JTROOT))*HSIGN .LE. TROOT*HSIGN) THEN -C -C Check for multiple roots. -C - IF (WORK(JTROOT) .EQ. WORK(ITOUT) .AND. - 8 I .GT. IWORK(INROOT)) THEN - IROOT = I - TROOT = WORK(JTROOT) - GO TO 60 - END IF - IF (REAL(WORK(JTROOT))*HSIGN .GT. - 8 REAL(WORK(ITOUT))*HSIGN) THEN - IROOT = I - TROOT = WORK(JTROOT) - END IF - END IF - 50 CONTINUE - 60 IWORK(INROOT) = IROOT - WORK(ITOUT) = TROOT - IWORK(IJROOT) = NTASK - IF (NTASK .EQ. 1) THEN - IF (IROOT .EQ. 0) THEN - IWORK(IJROOT) = 0 - ELSE - IF (TOUT*HSIGN .GE. TROOT*HSIGN) THEN - CALL CDNTP (H, 0, N, IWORK(INQ), T, TROOT, WORK(IYH), - 8 Y) - NSTATE = 5 - T = TROOT - IERFLG = 0 - GO TO 580 - END IF - END IF - ELSE IF (NTASK .EQ. 2 .OR. NTASK .EQ. 3) THEN -C -C If there are no more roots, or the -C user has altered TOUT to be less -C than a root, set IJROOT to zero. -C - IF (IROOT .EQ. 0 .OR. (TOUT*HSIGN .LT. TROOT*HSIGN)) THEN - IWORK(IJROOT) = 0 - ELSE - CALL CDNTP (H, 0, N, IWORK(INQ), T, TROOT, WORK(IYH), - 8 Y) - NSTATE = 5 - T = TROOT - IERFLG = 0 - GO TO 580 - END IF - END IF - END IF - END IF - END IF -C - IF (NTASK .EQ. 1) THEN - NSTATE = 2 - IF (T*HSIGN .GE. TOUT*HSIGN) THEN - CALL CDNTP (H, 0, N, IWORK(INQ), T, TOUT, WORK(IYH), Y) - T = TOUT - IERFLG = 0 - GO TO 580 - END IF - ELSE IF (NTASK .EQ. 2) THEN -C Check if TOUT has -C been reset .LT. T - IF (T*HSIGN .GT. TOUT*HSIGN) THEN - WRITE(RL1, '(E16.8)') T - WRITE(RL2, '(E16.8)') TOUT - IERFLG = 11 - CALL XERMSG('SLATEC', 'CDRIV3', - 8 'While integrating exactly to TOUT, T, '//RL1// - 8 ', was beyond TOUT, '//RL2//' . Solution obtained by '// - 8 'interpolation.', IERFLG, 0) - NSTATE = 11 - CALL CDNTP (H, 0, N, IWORK(INQ), T, TOUT, WORK(IYH), Y) - T = TOUT - GO TO 580 - END IF -C Determine if TOUT has been overtaken -C - IF (ABS(TOUT - T).LE.NROUND*UROUND*MAX(ABS(T), ABS(TOUT))) THEN - T = TOUT - NSTATE = 2 - IERFLG = 0 - GO TO 560 - END IF -C If there are no more roots -C to report, report T. - IF (NSTATE .EQ. 5) THEN - NSTATE = 2 - IERFLG = 0 - GO TO 560 - END IF - NSTATE = 2 -C See if TOUT will -C be overtaken. - IF ((T + H)*HSIGN .GT. TOUT*HSIGN) THEN - H = TOUT - T - IF ((T + H)*HSIGN .GT. TOUT*HSIGN) H = H*(1.E0 - 4.E0*UROUND) - WORK(IH) = H - IF (H .EQ. 0.E0) GO TO 670 - IWORK(IJTASK) = -1 - END IF - ELSE IF (NTASK .EQ. 3) THEN - NSTATE = 2 - IF (T*HSIGN .GT. TOUT*HSIGN) THEN - WRITE(RL1, '(E16.8)') T - WRITE(RL2, '(E16.8)') TOUT - IERFLG = 11 - CALL XERMSG('SLATEC', 'CDRIV3', - 8 'While integrating exactly to TOUT, T, '//RL1// - 8 ', was beyond TOUT, '//RL2//' . Solution obtained by '// - 8 'interpolation.', IERFLG, 0) - NSTATE = 11 - CALL CDNTP (H, 0, N, IWORK(INQ), T, TOUT, WORK(IYH), Y) - T = TOUT - GO TO 580 - END IF - IF (ABS(TOUT - T).LE.NROUND*UROUND*MAX(ABS(T), ABS(TOUT))) THEN - T = TOUT - IERFLG = 0 - GO TO 560 - END IF - IF ((T + H)*HSIGN .GT. TOUT*HSIGN) THEN - H = TOUT - T - IF ((T + H)*HSIGN .GT. TOUT*HSIGN) H = H*(1.E0 - 4.E0*UROUND) - WORK(IH) = H - IF (H .EQ. 0.E0) GO TO 670 - IWORK(IJTASK) = -1 - END IF - END IF -C Implement changes in MINT, MITER, and/or HMAX. -C - IF ((MINT .NE. IWORK(IMNTLD) .OR. MITER .NE. IWORK(IMTRLD)) .AND. - 8 MINT .NE. 3 .AND. IWORK(IMNTLD) .NE. 3) IWORK(IJTASK) = -1 - IF (HMAX .NE. WORK(IHMAX)) THEN - H = SIGN(MIN(ABS(H), HMAX), H) - IF (H .NE. WORK(IH)) THEN - IWORK(IJTASK) = -1 - WORK(IH) = H - END IF - WORK(IHMAX) = HMAX - END IF -C - 180 NSTEPL = IWORK(INSTEP) - DO 190 I = 1,N - 190 Y(I) = WORK(I+IYH-1) - IF (NROOT .NE. 0) THEN - DO 200 I = 1,NROOT - WORK(I+IGNOW-1) = G (NPAR, T, Y, I) - IF (NPAR .EQ. 0) THEN - IWORK(INROOT) = I - NSTATE = 7 - RETURN - END IF - 200 CONTINUE - END IF - IF (IERROR .EQ. 1) THEN - DO 230 I = 1,N - 230 WORK(I+IYWT-1) = 1.E0 - GO TO 410 - ELSE IF (IERROR .EQ. 5) THEN - DO 250 I = 1,N - 250 WORK(I+IYWT-1) = EWT(I) - GO TO 410 - END IF -C Reset YWT array. Looping point. - 260 IF (IERROR .EQ. 2) THEN - DO 280 I = 1,N - IF (Y(I) .EQ. 0.E0) GO TO 290 - 280 WORK(I+IYWT-1) = Y(I) - GO TO 410 - 290 IF (IWORK(IJTASK) .EQ. 0) THEN - CALL F (NPAR, T, Y, WORK(ISAVE2)) - IF (NPAR .EQ. 0) THEN - NSTATE = 6 - RETURN - END IF - IWORK(INFE) = IWORK(INFE) + 1 - IF (MITER .EQ. 3 .AND. IMPL .NE. 0) THEN - IFLAG = 0 - CALL USERS (Y, WORK(IYH), WORK(IYWT), WORK(ISAVE1), - 8 WORK(ISAVE2), T, H, REAL(WORK(IEL)), IMPL, NPAR, - 8 NDECOM, IFLAG) - IF (IFLAG .EQ. -1) GO TO 690 - IF (NPAR .EQ. 0) THEN - NSTATE = 10 - RETURN - END IF - ELSE IF (IMPL .EQ. 1) THEN - IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN - CALL FA (NPAR, T, Y, WORK(IA), MATDIM, ML, MU, NDECOM) - IF (NPAR .EQ. 0) THEN - NSTATE = 9 - RETURN - END IF - CALL CGEFA (WORK(IA), MATDIM, N, IWORK(INDPVT), INFO) - IF (INFO .NE. 0) GO TO 690 - CALL CGESL (WORK(IA), MATDIM, N, IWORK(INDPVT), - 8 WORK(ISAVE2), 0) - ELSE IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN - CALL FA (NPAR, T, Y, WORK(IA+ML), MATDIM, ML, MU, NDECOM) - IF (NPAR .EQ. 0) THEN - NSTATE = 9 - RETURN - END IF - CALL CGBFA (WORK(IA), MATDIM, N, ML, MU, IWORK(INDPVT), - 8 INFO) - IF (INFO .NE. 0) GO TO 690 - CALL CGBSL (WORK(IA), MATDIM, N, ML, MU, IWORK(INDPVT), - 8 WORK(ISAVE2), 0) - END IF - ELSE IF (IMPL .EQ. 2) THEN - CALL FA (NPAR, T, Y, WORK(IA), MATDIM, ML, MU, NDECOM) - IF (NPAR .EQ. 0) THEN - NSTATE = 9 - RETURN - END IF - DO 340 I = 1,NDECOM - IF (WORK(I+IA-1) .EQ. 0.E0) GO TO 690 - 340 WORK(I+ISAVE2-1) = WORK(I+ISAVE2-1)/WORK(I+IA-1) - ELSE IF (IMPL .EQ. 3) THEN - IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN - CALL FA (NPAR, T, Y, WORK(IA), MATDIM, ML, MU, NDECOM) - IF (NPAR .EQ. 0) THEN - NSTATE = 9 - RETURN - END IF - CALL CGEFA (WORK(IA), MATDIM, NDE, IWORK(INDPVT), INFO) - IF (INFO .NE. 0) GO TO 690 - CALL CGESL (WORK(IA), MATDIM, NDE, IWORK(INDPVT), - 8 WORK(ISAVE2), 0) - ELSE IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN - CALL FA (NPAR, T, Y, WORK(IA+ML), MATDIM, ML, MU, NDECOM) - IF (NPAR .EQ. 0) THEN - NSTATE = 9 - RETURN - END IF - CALL CGBFA (WORK(IA), MATDIM, NDE, ML, MU, IWORK(INDPVT), - 8 INFO) - IF (INFO .NE. 0) GO TO 690 - CALL CGBSL (WORK(IA), MATDIM, NDE, ML, MU, IWORK(INDPVT), - 8 WORK(ISAVE2), 0) - END IF - END IF - END IF - DO 360 J = I,N - IF (Y(J) .NE. 0.E0) THEN - WORK(J+IYWT-1) = Y(J) - ELSE - IF (IWORK(IJTASK) .EQ. 0) THEN - WORK(J+IYWT-1) = H*WORK(J+ISAVE2-1) - ELSE - WORK(J+IYWT-1) = WORK(J+IYH+N-1) - END IF - END IF - IF (WORK(J+IYWT-1) .EQ. 0.E0) WORK(J+IYWT-1) = UROUND - 360 CONTINUE - ELSE IF (IERROR .EQ. 3) THEN - DO 380 I = 1,N - 380 WORK(I+IYWT-1) = MAX(EWT(1), ABS(Y(I))) - ELSE IF (IERROR .EQ. 4) THEN - DO 400 I = 1,N - 400 WORK(I+IYWT-1) = MAX(EWT(I), ABS(Y(I))) - END IF -C - 410 DO 420 I = 1,N - 420 WORK(I+ISAVE2-1) = Y(I)/WORK(I+IYWT-1) - SUM = SCNRM2(N, WORK(ISAVE2), 1)/SQRT(REAL(N)) - SUM = MAX(1.E0, SUM) - IF (EPS .LT. SUM*UROUND) THEN - EPS = SUM*UROUND*(1.E0 + 10.E0*UROUND) - WRITE(RL1, '(E16.8)') T - WRITE(RL2, '(E16.8)') EPS - IERFLG = 4 - CALL XERMSG('SLATEC', 'CDRIV3', - 8 'At T, '//RL1//', the requested accuracy, EPS, was not '// - 8 'obtainable with the machine precision. EPS has been '// - 8 'increased to '//RL2//' .', IERFLG, 0) - NSTATE = 4 - GO TO 560 - END IF - IF (ABS(H) .GE. UROUND*ABS(T)) THEN - IWORK(INDPRT) = 0 - ELSE IF (IWORK(INDPRT) .EQ. 0) THEN - WRITE(RL1, '(E16.8)') T - WRITE(RL2, '(E16.8)') H - IERFLG = 15 - CALL XERMSG('SLATEC', 'CDRIV3', - 8 'At T, '//RL1//', the step size, '//RL2//', is smaller '// - 8 'than the roundoff level of T. This may occur if there is '// - 8 'an abrupt change in the right hand side of the '// - 8 'differential equations.', IERFLG, 0) - IWORK(INDPRT) = 1 - END IF - IF (NTASK.NE.2) THEN - IF ((IWORK(INSTEP)-NSTEPL) .EQ. MXSTEP) THEN - WRITE(RL1, '(E16.8)') T - WRITE(INTGR1, '(I8)') MXSTEP - WRITE(RL2, '(E16.8)') TOUT - IERFLG = 3 - CALL XERMSG('SLATEC', 'CDRIV3', - 8 'At T, '//RL1//', '//INTGR1//' steps have been taken '// - 8 'without reaching TOUT, '//RL2//' .', IERFLG, 0) - NSTATE = 3 - GO TO 560 - END IF - END IF -C -C CALL CDSTP (EPS, F, FA, HMAX, IMPL, IERROR, JACOBN, MATDIM, -C 8 MAXORD, MINT, MITER, ML, MU, N, NDE, YWT, UROUND, -C 8 USERS, AVGH, AVGORD, H, HUSED, JTASK, MNTOLD, MTROLD, -C 8 NFE, NJE, NQUSED, NSTEP, T, Y, YH, A, CONVRG, -C 8 DFDY, EL, FAC, HOLD, IPVT, JSTATE, JSTEPL, NQ, NWAIT, -C 8 RC, RMAX, SAVE1, SAVE2, TQ, TREND, ISWFLG, MTRSV, -C 8 MXRDSV) -C - CALL CDSTP (EPS, F, FA, HMAX, IMPL, IERROR, JACOBN, MATDIM, - 8 IWORK(IMXORD), IWORK(IMNT), IWORK(IMTR), ML, MU, NPAR, - 8 NDECOM, WORK(IYWT), UROUND, USERS, AVGH, AVGORD, H, - 8 HUSED, IWORK(IJTASK), IWORK(IMNTLD), IWORK(IMTRLD), - 8 IWORK(INFE), IWORK(INJE), IWORK(INQUSE), IWORK(INSTEP), - 8 T, Y, WORK(IYH), WORK(IA), CONVRG, WORK(IDFDY), EL, - 8 WORK(IFAC), HOLD, IWORK(INDPVT), JSTATE, IWORK(IJSTPL), - 8 IWORK(INQ), IWORK(INWAIT), RC, RMAX, WORK(ISAVE1), - 8 WORK(ISAVE2), TQ, TREND, MINT, IWORK(IMTRSV), - 8 IWORK(IMXRDS)) -C - WORK(IH) = H - WORK(IT) = T - GO TO (470, 670, 680, 690, 690, 660, 660, 660, 660, 660), JSTATE - 470 IWORK(IJTASK) = 1 -C Determine if a root has been overtaken - IF (NROOT .NE. 0) THEN - IROOT = 0 - DO 500 I = 1,NROOT - GLAST = WORK(I+IGNOW-1) - GNOW = G (NPAR, T, Y, I) - IF (NPAR .EQ. 0) THEN - IWORK(INROOT) = I - NSTATE = 7 - RETURN - END IF - WORK(I+IGNOW-1) = GNOW - IF (GLAST*GNOW .GT. 0.E0) THEN - WORK(I+ITROOT-1) = T + H - ELSE - IF (GNOW .EQ. 0.E0) THEN - WORK(I+ITROOT-1) = T - IROOT = I - ELSE - IF (GLAST .EQ. 0.E0) THEN - WORK(I+ITROOT-1) = T + H - ELSE - IF (ABS(HUSED) .GE. UROUND*ABS(T)) THEN - TLAST = T - HUSED - IROOT = I - TROOT = T - CALL CDZRO (AE, G, H, NPAR, IWORK(INQ), IROOT, RE, T, - 8 WORK(IYH), UROUND, TROOT, TLAST, - 8 GNOW, GLAST, Y) - DO 480 J = 1,N - 480 Y(J) = WORK(IYH+J-1) - IF (NPAR .EQ. 0) THEN - IWORK(INROOT) = I - NSTATE = 7 - RETURN - END IF - WORK(I+ITROOT-1) = TROOT - ELSE - WORK(I+ITROOT-1) = T - IROOT = I - END IF - END IF - END IF - END IF - 500 CONTINUE - IF (IROOT .EQ. 0) THEN - IWORK(IJROOT) = 0 -C Select the first root - ELSE - IWORK(IJROOT) = NTASK - IWORK(INRTLD) = NROOT - IWORK(INDTRT) = ITROOT - TROOT = T + H - DO 510 I = 1,NROOT - IF (REAL(WORK(I+ITROOT-1))*HSIGN .LT. TROOT*HSIGN) THEN - TROOT = WORK(I+ITROOT-1) - IROOT = I - END IF - 510 CONTINUE - IWORK(INROOT) = IROOT - WORK(ITOUT) = TROOT - IF (TROOT*HSIGN .LE. TOUT*HSIGN) THEN - CALL CDNTP (H, 0, N, IWORK(INQ), T, TROOT, WORK(IYH), Y) - NSTATE = 5 - T = TROOT - IERFLG = 0 - GO TO 580 - END IF - END IF - END IF -C Test for NTASK condition to be satisfied - NSTATE = 2 - IF (NTASK .EQ. 1) THEN - IF (T*HSIGN .LT. TOUT*HSIGN) GO TO 260 - CALL CDNTP (H, 0, N, IWORK(INQ), T, TOUT, WORK(IYH), Y) - T = TOUT - IERFLG = 0 - GO TO 580 -C TOUT is assumed to have been attained -C exactly if T is within twenty roundoff -C units of TOUT, relative to MAX(TOUT, T). -C - ELSE IF (NTASK .EQ. 2) THEN - IF (ABS(TOUT - T).LE.NROUND*UROUND*MAX(ABS(T), ABS(TOUT))) THEN - T = TOUT - ELSE - IF ((T + H)*HSIGN .GT. TOUT*HSIGN) THEN - H = TOUT - T - IF ((T + H)*HSIGN.GT.TOUT*HSIGN) H = H*(1.E0 - 4.E0*UROUND) - WORK(IH) = H - IF (H .EQ. 0.E0) GO TO 670 - IWORK(IJTASK) = -1 - END IF - END IF - ELSE IF (NTASK .EQ. 3) THEN - IF (ABS(TOUT - T).LE.NROUND*UROUND*MAX(ABS(T), ABS(TOUT))) THEN - T = TOUT - ELSE - IF ((T + H)*HSIGN .GT. TOUT*HSIGN) THEN - H = TOUT - T - IF ((T + H)*HSIGN.GT.TOUT*HSIGN) H = H*(1.E0 - 4.E0*UROUND) - WORK(IH) = H - IF (H .EQ. 0.E0) GO TO 670 - IWORK(IJTASK) = -1 - END IF - GO TO 260 - END IF - END IF - IERFLG = 0 -C All returns are made through this -C section. IMXERR is determined. - 560 DO 570 I = 1,N - 570 Y(I) = WORK(I+IYH-1) - 580 IF (CONVRG) THEN - IWORK(ICNVRG) = 1 - ELSE - IWORK(ICNVRG) = 0 - END IF - WORK(IAVGH) = AVGH - WORK(IAVGRD) = AVGORD - WORK(IHUSED) = HUSED - WORK(IHOLD) = HOLD - WORK(IRC) = RC - WORK(IRMAX) = RMAX - WORK(ITREND) = TREND - DO 582 J = 1,12 - DO 582 I = 1,13 - 582 WORK(I+IEL+(J-1)*13-1) = EL(I,J) - DO 584 J = 1,12 - DO 584 I = 1,3 - 584 WORK(I+ITQ+(J-1)*3-1) = TQ(I,J) - IF (IWORK(IJTASK) .EQ. 0) RETURN - BIG = 0.E0 - IMXERR = 1 - DO 590 I = 1,N -C SIZE = ABS(ERROR(I)/YWT(I)) - SIZE = ABS(WORK(I+ISAVE1-1)/WORK(I+IYWT-1)) - IF (BIG .LT. SIZE) THEN - BIG = SIZE - IMXERR = I - END IF - 590 CONTINUE - IWORK(INDMXR) = IMXERR - RETURN -C - 660 NSTATE = JSTATE - DO 662 I = 1,N - 662 Y(I) = WORK(I + IYH - 1) - IF (CONVRG) THEN - IWORK(ICNVRG) = 1 - ELSE - IWORK(ICNVRG) = 0 - END IF - WORK(IAVGH) = AVGH - WORK(IAVGRD) = AVGORD - WORK(IHUSED) = HUSED - WORK(IHOLD) = HOLD - WORK(IRC) = RC - WORK(IRMAX) = RMAX - WORK(ITREND) = TREND - DO 664 J = 1,12 - DO 664 I = 1,13 - 664 WORK(I+IEL+(J-1)*13-1) = EL(I,J) - DO 666 J = 1,12 - DO 666 I = 1,3 - 666 WORK(I+ITQ+(J-1)*3-1) = TQ(I,J) - RETURN -C Fatal errors are processed here -C - 670 WRITE(RL1, '(E16.8)') T - IERFLG = 41 - CALL XERMSG('SLATEC', 'CDRIV3', - 8 'At T, '//RL1//', the attempted step size has gone to '// - 8 'zero. Often this occurs if the problem setup is incorrect.', - 8 IERFLG, 1) - NSTATE = 12 - RETURN -C - 680 WRITE(RL1, '(E16.8)') T - IERFLG = 42 - CALL XERMSG('SLATEC', 'CDRIV3', - 8 'At T, '//RL1//', the step size has been reduced about 50 '// - 8 'times without advancing the solution. Often this occurs '// - 8 'if the problem setup is incorrect.', IERFLG, 1) - NSTATE = 12 - RETURN -C - 690 WRITE(RL1, '(E16.8)') T - IERFLG = 43 - CALL XERMSG('SLATEC', 'CDRIV3', - 8 'At T, '//RL1//', while solving A*YDOT = F, A is singular.', - 8 IERFLG, 1) - NSTATE = 12 - RETURN - END diff --git a/slatec/cdscl.f b/slatec/cdscl.f deleted file mode 100644 index ec52e30..0000000 --- a/slatec/cdscl.f +++ /dev/null @@ -1,38 +0,0 @@ -*DECK CDSCL - SUBROUTINE CDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) -C***BEGIN PROLOGUE CDSCL -C***SUBSIDIARY -C***PURPOSE Subroutine CDSCL rescales the YH array whenever the step -C size is changed. -C***LIBRARY SLATEC (SDRIVE) -C***TYPE COMPLEX (SDSCL-S, DDSCL-D, CDSCL-C) -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE CDSCL - INTEGER I, J, N, NQ - COMPLEX YH(N,*) - REAL H, HMAX, RC, RH, RMAX, R1 -C***FIRST EXECUTABLE STATEMENT CDSCL - IF (H .LT. 1.E0) THEN - RH = MIN(ABS(H)*RH, ABS(H)*RMAX, HMAX)/ABS(H) - ELSE - RH = MIN(RH, RMAX, HMAX/ABS(H)) - END IF - R1 = 1.E0 - DO 10 J = 1,NQ - R1 = R1*RH - DO 10 I = 1,N - 10 YH(I,J+1) = YH(I,J+1)*R1 - H = H*RH - RC = RC*RH - RETURN - END diff --git a/slatec/cdstp.f b/slatec/cdstp.f deleted file mode 100644 index d53648a..0000000 --- a/slatec/cdstp.f +++ /dev/null @@ -1,460 +0,0 @@ -*DECK CDSTP - SUBROUTINE CDSTP (EPS, F, FA, HMAX, IMPL, IERROR, JACOBN, MATDIM, - 8 MAXORD, MINT, MITER, ML, MU, N, NDE, YWT, UROUND, USERS, AVGH, - 8 AVGORD, H, HUSED, JTASK, MNTOLD, MTROLD, NFE, NJE, NQUSED, - 8 NSTEP, T, Y, YH, A, CONVRG, DFDY, EL, FAC, HOLD, IPVT, JSTATE, - 8 JSTEPL, NQ, NWAIT, RC, RMAX, SAVE1, SAVE2, TQ, TREND, ISWFLG, - 8 MTRSV, MXRDSV) -C***BEGIN PROLOGUE CDSTP -C***SUBSIDIARY -C***PURPOSE CDSTP performs one step of the integration of an initial -C value problem for a system of ordinary differential -C equations. -C***LIBRARY SLATEC (SDRIVE) -C***TYPE COMPLEX (SDSTP-S, DDSTP-D, CDSTP-C) -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***DESCRIPTION -C -C Communication with CDSTP is done with the following variables: -C -C YH An N by MAXORD+1 array containing the dependent variables -C and their scaled derivatives. MAXORD, the maximum order -C used, is currently 12 for the Adams methods and 5 for the -C Gear methods. YH(I,J+1) contains the J-th derivative of -C Y(I), scaled by H**J/factorial(J). Only Y(I), -C 1 .LE. I .LE. N, need be set by the calling program on -C the first entry. The YH array should not be altered by -C the calling program. When referencing YH as a -C 2-dimensional array, use a column length of N, as this is -C the value used in CDSTP. -C DFDY A block of locations used for partial derivatives if MITER -C is not 0. If MITER is 1 or 2 its length must be at least -C N*N. If MITER is 4 or 5 its length must be at least -C (2*ML+MU+1)*N. -C YWT An array of N locations used in convergence and error tests -C SAVE1 -C SAVE2 Arrays of length N used for temporary storage. -C IPVT An integer array of length N used by the linear system -C solvers for the storage of row interchange information. -C A A block of locations used to store the matrix A, when using -C the implicit method. If IMPL is 1, A is a MATDIM by N -C array. If MITER is 1 or 2 MATDIM is N, and if MITER is 4 -C or 5 MATDIM is 2*ML+MU+1. If IMPL is 2 its length is N. -C If IMPL is 3, A is a MATDIM by NDE array. -C JTASK An integer used on input. -C It has the following values and meanings: -C .EQ. 0 Perform the first step. This value enables -C the subroutine to initialize itself. -C .GT. 0 Take a new step continuing from the last. -C Assumes the last step was successful and -C user has not changed any parameters. -C .LT. 0 Take a new step with a new value of H and/or -C MINT and/or MITER. -C JSTATE A completion code with the following meanings: -C 1 The step was successful. -C 2 A solution could not be obtained with H .NE. 0. -C 3 A solution was not obtained in MXTRY attempts. -C 4 For IMPL .NE. 0, the matrix A is singular. -C On a return with JSTATE .GT. 1, the values of T and -C the YH array are as of the beginning of the last -C step, and H is the last step size attempted. -C -C***ROUTINES CALLED CDCOR, CDCST, CDNTL, CDPSC, CDPST, CDSCL, SCNRM2 -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE CDSTP - EXTERNAL F, JACOBN, FA, USERS - INTEGER I, IERROR, IMPL, IPVT(*), ISWFLG, ITER, J, JSTATE, JSTEPL, - 8 JTASK, MATDIM, MAXORD, MINT, MITER, ML, MNTOLD, MTROLD, - 8 MTRSV, MU, MXFAIL, MXITER, MXRDSV, MXTRY, N, NDE, NDJSTP, - 8 NFAIL, NFE, NJE, NQ, NQUSED, NSTEP, NSV, NTRY, NWAIT - COMPLEX A(MATDIM,*), DFDY(MATDIM,*), FAC(*), SAVE1(*), SAVE2(*), - 8 Y(*), YH(N,*), YWT(*) - REAL AVGH, AVGORD, BIAS1, BIAS2, BIAS3, BND, CTEST, D, DENOM, D1, - 8 EL(13,12), EPS, ERDN, ERUP, ETEST, H, HMAX, HN, HOLD, HS, - 8 HUSED, NUMER, RC, RCTEST, RH, RH1, RH2, RH3, RMAX, RMFAIL, - 8 RMNORM, SCNRM2, T, TOLD, TQ(3,12), TREND, TRSHLD, UROUND, - 8 Y0NRM - LOGICAL CONVRG, EVALFA, EVALJC, IER, SWITCH - PARAMETER(BIAS1 = 1.3E0, BIAS2 = 1.2E0, BIAS3 = 1.4E0, MXFAIL = 3, - 8 MXITER = 3, MXTRY = 50, RCTEST = .3E0, RMFAIL = 2.E0, - 8 RMNORM = 10.E0, TRSHLD = 1.E0) - PARAMETER (NDJSTP = 10) - DATA IER /.FALSE./ -C***FIRST EXECUTABLE STATEMENT CDSTP - NSV = N - BND = 0.E0 - SWITCH = .FALSE. - NTRY = 0 - TOLD = T - NFAIL = 0 - IF (JTASK .LE. 0) THEN - CALL CDNTL (EPS, F, FA, HMAX, HOLD, IMPL, JTASK, MATDIM, - 8 MAXORD, MINT, MITER, ML, MU, N, NDE, SAVE1, T, - 8 UROUND, USERS, Y, YWT, H, MNTOLD, MTROLD, NFE, RC, - 8 YH, A, CONVRG, EL, FAC, IER, IPVT, NQ, NWAIT, RH, - 8 RMAX, SAVE2, TQ, TREND, ISWFLG, JSTATE) - IF (N .EQ. 0) GO TO 440 - IF (H .EQ. 0.E0) GO TO 400 - IF (IER) GO TO 420 - END IF - 100 NTRY = NTRY + 1 - IF (NTRY .GT. MXTRY) GO TO 410 - T = T + H - CALL CDPSC (1, N, NQ, YH) - EVALJC = (((ABS(RC - 1.E0) .GT. RCTEST) .OR. - 8 (NSTEP .GE. JSTEPL + NDJSTP)) .AND. (MITER .NE. 0)) - EVALFA = .NOT. EVALJC -C - 110 ITER = 0 - DO 115 I = 1,N - 115 Y(I) = YH(I,1) - CALL F (N, T, Y, SAVE2) - IF (N .EQ. 0) THEN - JSTATE = 6 - GO TO 430 - END IF - NFE = NFE + 1 - IF (EVALJC .OR. IER) THEN - CALL CDPST (EL, F, FA, H, IMPL, JACOBN, MATDIM, MITER, ML, - 8 MU, N, NDE, NQ, SAVE2, T, USERS, Y, YH, YWT, UROUND, - 8 NFE, NJE, A, DFDY, FAC, IER, IPVT, SAVE1, ISWFLG, - 8 BND, JSTATE) - IF (N .EQ. 0) GO TO 430 - IF (IER) GO TO 160 - CONVRG = .FALSE. - RC = 1.E0 - JSTEPL = NSTEP - END IF - DO 125 I = 1,N - 125 SAVE1(I) = 0.E0 -C Up to MXITER corrector iterations are taken. -C Convergence is tested by requiring the r.m.s. -C norm of changes to be less than EPS. The sum of -C the corrections is accumulated in the vector -C SAVE1(I). It is approximately equal to the L-th -C derivative of Y multiplied by -C H**L/(factorial(L-1)*EL(L,NQ)), and is thus -C proportional to the actual errors to the lowest -C power of H present (H**L). The YH array is not -C altered in the correction loop. The norm of the -C iterate difference is stored in D. If -C ITER .GT. 0, an estimate of the convergence rate -C constant is stored in TREND, and this is used in -C the convergence test. -C - 130 CALL CDCOR (DFDY, EL, FA, H, IERROR, IMPL, IPVT, MATDIM, MITER, - 8 ML, MU, N, NDE, NQ, T, USERS, Y, YH, YWT, EVALFA, - 8 SAVE1, SAVE2, A, D, JSTATE) - IF (N .EQ. 0) GO TO 430 - IF (ISWFLG .EQ. 3 .AND. MINT .EQ. 1) THEN - IF (ITER .EQ. 0) THEN - NUMER = SCNRM2(N, SAVE1, 1) - DO 132 I = 1,N - 132 DFDY(1,I) = SAVE1(I) - Y0NRM = SCNRM2(N, YH, 1) - ELSE - DENOM = NUMER - DO 134 I = 1,N - 134 DFDY(1,I) = SAVE1(I) - DFDY(1,I) - NUMER = SCNRM2(N, DFDY, MATDIM) - IF (EL(1,NQ)*NUMER .LE. 100.E0*UROUND*Y0NRM) THEN - IF (RMAX .EQ. RMFAIL) THEN - SWITCH = .TRUE. - GO TO 170 - END IF - END IF - DO 136 I = 1,N - 136 DFDY(1,I) = SAVE1(I) - IF (DENOM .NE. 0.E0) - 8 BND = MAX(BND, NUMER/(DENOM*ABS(H)*EL(1,NQ))) - END IF - END IF - IF (ITER .GT. 0) TREND = MAX(.9E0*TREND, D/D1) - D1 = D - CTEST = MIN(2.E0*TREND, 1.E0)*D - IF (CTEST .LE. EPS) GO TO 170 - ITER = ITER + 1 - IF (ITER .LT. MXITER) THEN - DO 140 I = 1,N - 140 Y(I) = YH(I,1) + EL(1,NQ)*SAVE1(I) - CALL F (N, T, Y, SAVE2) - IF (N .EQ. 0) THEN - JSTATE = 6 - GO TO 430 - END IF - NFE = NFE + 1 - GO TO 130 - END IF -C The corrector iteration failed to converge in -C MXITER tries. If partials are involved but are -C not up to date, they are reevaluated for the next -C try. Otherwise the YH array is retracted to its -C values before prediction, and H is reduced, if -C possible. If not, a no-convergence exit is taken. - IF (CONVRG) THEN - EVALJC = .TRUE. - EVALFA = .FALSE. - GO TO 110 - END IF - 160 T = TOLD - CALL CDPSC (-1, N, NQ, YH) - NWAIT = NQ + 2 - IF (JTASK .NE. 0 .AND. JTASK .NE. 2) RMAX = RMFAIL - IF (ITER .EQ. 0) THEN - RH = .3E0 - ELSE - RH = .9E0*(EPS/CTEST)**(.2E0) - END IF - IF (RH*H .EQ. 0.E0) GO TO 400 - CALL CDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) - GO TO 100 -C The corrector has converged. CONVRG is set -C to .TRUE. if partial derivatives were used, -C to indicate that they may need updating on -C subsequent steps. The error test is made. - 170 CONVRG = (MITER .NE. 0) - IF (IERROR .EQ. 1 .OR. IERROR .EQ. 5) THEN - DO 180 I = 1,NDE - 180 SAVE2(I) = SAVE1(I)/YWT(I) - ELSE - DO 185 I = 1,NDE - 185 SAVE2(I) = SAVE1(I)/MAX(ABS(Y(I)), ABS(YWT(I))) - END IF - ETEST = SCNRM2(NDE, SAVE2, 1)/(TQ(2,NQ)*SQRT(REAL(NDE))) -C -C The error test failed. NFAIL keeps track of -C multiple failures. Restore T and the YH -C array to their previous values, and prepare -C to try the step again. Compute the optimum -C step size for this or one lower order. - IF (ETEST .GT. EPS) THEN - T = TOLD - CALL CDPSC (-1, N, NQ, YH) - NFAIL = NFAIL + 1 - IF (NFAIL .LT. MXFAIL .OR. NQ .EQ. 1) THEN - IF (JTASK .NE. 0 .AND. JTASK .NE. 2) RMAX = RMFAIL - RH2 = 1.E0/(BIAS2*(ETEST/EPS)**(1.E0/(NQ+1))) - IF (NQ .GT. 1) THEN - IF (IERROR .EQ. 1 .OR. IERROR .EQ. 5) THEN - DO 190 I = 1,NDE - 190 SAVE2(I) = YH(I,NQ+1)/YWT(I) - ELSE - DO 195 I = 1,NDE - 195 SAVE2(I) = YH(I,NQ+1)/MAX(ABS(Y(I)), ABS(YWT(I))) - END IF - ERDN = SCNRM2(NDE, SAVE2, 1)/(TQ(1,NQ)*SQRT(REAL(NDE))) - RH1 = 1.E0/MAX(1.E0, BIAS1*(ERDN/EPS)**(1.E0/NQ)) - IF (RH2 .LT. RH1) THEN - NQ = NQ - 1 - RC = RC*EL(1,NQ)/EL(1,NQ+1) - RH = RH1 - ELSE - RH = RH2 - END IF - ELSE - RH = RH2 - END IF - NWAIT = NQ + 2 - IF (RH*H .EQ. 0.E0) GO TO 400 - CALL CDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) - GO TO 100 - END IF -C Control reaches this section if the error test has -C failed MXFAIL or more times. It is assumed that the -C derivatives that have accumulated in the YH array have -C errors of the wrong order. Hence the first derivative -C is recomputed, the order is set to 1, and the step is -C retried. - NFAIL = 0 - JTASK = 2 - DO 215 I = 1,N - 215 Y(I) = YH(I,1) - CALL CDNTL (EPS, F, FA, HMAX, HOLD, IMPL, JTASK, MATDIM, - 8 MAXORD, MINT, MITER, ML, MU, N, NDE, SAVE1, T, - 8 UROUND, USERS, Y, YWT, H, MNTOLD, MTROLD, NFE, RC, - 8 YH, A, CONVRG, EL, FAC, IER, IPVT, NQ, NWAIT, RH, - 8 RMAX, SAVE2, TQ, TREND, ISWFLG, JSTATE) - RMAX = RMNORM - IF (N .EQ. 0) GO TO 440 - IF (H .EQ. 0.E0) GO TO 400 - IF (IER) GO TO 420 - GO TO 100 - END IF -C After a successful step, update the YH array. - NSTEP = NSTEP + 1 - HUSED = H - NQUSED = NQ - AVGH = ((NSTEP-1)*AVGH + H)/NSTEP - AVGORD = ((NSTEP-1)*AVGORD + NQ)/NSTEP - DO 230 J = 1,NQ+1 - DO 230 I = 1,N - 230 YH(I,J) = YH(I,J) + EL(J,NQ)*SAVE1(I) - DO 235 I = 1,N - 235 Y(I) = YH(I,1) -C If ISWFLG is 3, consider -C changing integration methods. - IF (ISWFLG .EQ. 3) THEN - IF (BND .NE. 0.E0) THEN - IF (MINT .EQ. 1 .AND. NQ .LE. 5) THEN - HN = ABS(H)/MAX(UROUND, (ETEST/EPS)**(1.E0/(NQ+1))) - HN = MIN(HN, 1.E0/(2.E0*EL(1,NQ)*BND)) - HS = ABS(H)/MAX(UROUND, - 8 (ETEST/(EPS*EL(NQ+1,1)))**(1.E0/(NQ+1))) - IF (HS .GT. 1.2E0*HN) THEN - MINT = 2 - MNTOLD = MINT - MITER = MTRSV - MTROLD = MITER - MAXORD = MIN(MXRDSV, 5) - RC = 0.E0 - RMAX = RMNORM - TREND = 1.E0 - CALL CDCST (MAXORD, MINT, ISWFLG, EL, TQ) - NWAIT = NQ + 2 - END IF - ELSE IF (MINT .EQ. 2) THEN - HS = ABS(H)/MAX(UROUND, (ETEST/EPS)**(1.E0/(NQ+1))) - HN = ABS(H)/MAX(UROUND, - 8 (ETEST*EL(NQ+1,1)/EPS)**(1.E0/(NQ+1))) - HN = MIN(HN, 1.E0/(2.E0*EL(1,NQ)*BND)) - IF (HN .GE. HS) THEN - MINT = 1 - MNTOLD = MINT - MITER = 0 - MTROLD = MITER - MAXORD = MIN(MXRDSV, 12) - RMAX = RMNORM - TREND = 1.E0 - CONVRG = .FALSE. - CALL CDCST (MAXORD, MINT, ISWFLG, EL, TQ) - NWAIT = NQ + 2 - END IF - END IF - END IF - END IF - IF (SWITCH) THEN - MINT = 2 - MNTOLD = MINT - MITER = MTRSV - MTROLD = MITER - MAXORD = MIN(MXRDSV, 5) - NQ = MIN(NQ, MAXORD) - RC = 0.E0 - RMAX = RMNORM - TREND = 1.E0 - CALL CDCST (MAXORD, MINT, ISWFLG, EL, TQ) - NWAIT = NQ + 2 - END IF -C Consider changing H if NWAIT = 1. Otherwise -C decrease NWAIT by 1. If NWAIT is then 1 and -C NQ.LT.MAXORD, then SAVE1 is saved for use in -C a possible order increase on the next step. -C - IF (JTASK .EQ. 0 .OR. JTASK .EQ. 2) THEN - RH = 1.E0/MAX(UROUND, BIAS2*(ETEST/EPS)**(1.E0/(NQ+1))) - IF (RH.GT.TRSHLD) CALL CDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) - ELSE IF (NWAIT .GT. 1) THEN - NWAIT = NWAIT - 1 - IF (NWAIT .EQ. 1 .AND. NQ .LT. MAXORD) THEN - DO 250 I = 1,NDE - 250 YH(I,MAXORD+1) = SAVE1(I) - END IF -C If a change in H is considered, an increase or decrease in -C order by one is considered also. A change in H is made -C only if it is by a factor of at least TRSHLD. Factors -C RH1, RH2, and RH3 are computed, by which H could be -C multiplied at order NQ - 1, order NQ, or order NQ + 1, -C respectively. The largest of these is determined and the -C new order chosen accordingly. If the order is to be -C increased, we compute one additional scaled derivative. -C If there is a change of order, reset NQ and the -C coefficients. In any case H is reset according to RH and -C the YH array is rescaled. - ELSE - IF (NQ .EQ. 1) THEN - RH1 = 0.E0 - ELSE - IF (IERROR .EQ. 1 .OR. IERROR .EQ. 5) THEN - DO 270 I = 1,NDE - 270 SAVE2(I) = YH(I,NQ+1)/YWT(I) - ELSE - DO 275 I = 1,NDE - 275 SAVE2(I) = YH(I,NQ+1)/MAX(ABS(Y(I)), ABS(YWT(I))) - END IF - ERDN = SCNRM2(NDE, SAVE2, 1)/(TQ(1,NQ)*SQRT(REAL(NDE))) - RH1 = 1.E0/MAX(UROUND, BIAS1*(ERDN/EPS)**(1.E0/NQ)) - END IF - RH2 = 1.E0/MAX(UROUND, BIAS2*(ETEST/EPS)**(1.E0/(NQ+1))) - IF (NQ .EQ. MAXORD) THEN - RH3 = 0.E0 - ELSE - IF (IERROR .EQ. 1 .OR. IERROR .EQ. 5) THEN - DO 290 I = 1,NDE - 290 SAVE2(I) = (SAVE1(I) - YH(I,MAXORD+1))/YWT(I) - ELSE - DO 295 I = 1,NDE - SAVE2(I) = (SAVE1(I) - YH(I,MAXORD+1))/ - 8 MAX(ABS(Y(I)), ABS(YWT(I))) - 295 CONTINUE - END IF - ERUP = SCNRM2(NDE, SAVE2, 1)/(TQ(3,NQ)*SQRT(REAL(NDE))) - RH3 = 1.E0/MAX(UROUND, BIAS3*(ERUP/EPS)**(1.E0/(NQ+2))) - END IF - IF (RH1 .GT. RH2 .AND. RH1 .GE. RH3) THEN - RH = RH1 - IF (RH .LE. TRSHLD) GO TO 380 - NQ = NQ - 1 - RC = RC*EL(1,NQ)/EL(1,NQ+1) - ELSE IF (RH2 .GE. RH1 .AND. RH2 .GE. RH3) THEN - RH = RH2 - IF (RH .LE. TRSHLD) GO TO 380 - ELSE - RH = RH3 - IF (RH .LE. TRSHLD) GO TO 380 - DO 360 I = 1,N - 360 YH(I,NQ+2) = SAVE1(I)*EL(NQ+1,NQ)/(NQ+1) - NQ = NQ + 1 - RC = RC*EL(1,NQ)/EL(1,NQ-1) - END IF - IF (ISWFLG .EQ. 3 .AND. MINT .EQ. 1) THEN - IF (BND.NE.0.E0) RH = MIN(RH, 1.E0/(2.E0*EL(1,NQ)*BND*ABS(H))) - END IF - CALL CDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) - RMAX = RMNORM - 380 NWAIT = NQ + 2 - END IF -C All returns are made through this section. H is saved -C in HOLD to allow the caller to change H on the next step - JSTATE = 1 - HOLD = H - RETURN -C - 400 JSTATE = 2 - HOLD = H - DO 405 I = 1,N - 405 Y(I) = YH(I,1) - RETURN -C - 410 JSTATE = 3 - HOLD = H - RETURN -C - 420 JSTATE = 4 - HOLD = H - RETURN -C - 430 T = TOLD - CALL CDPSC (-1, NSV, NQ, YH) - DO 435 I = 1,NSV - 435 Y(I) = YH(I,1) - 440 HOLD = H - RETURN - END diff --git a/slatec/cdzro.f b/slatec/cdzro.f deleted file mode 100644 index ed1a01a..0000000 --- a/slatec/cdzro.f +++ /dev/null @@ -1,135 +0,0 @@ -*DECK CDZRO - SUBROUTINE CDZRO (AE, F, H, N, NQ, IROOT, RE, T, YH, UROUND, B, C, - 8 FB, FC, Y) -C***BEGIN PROLOGUE CDZRO -C***SUBSIDIARY -C***PURPOSE CDZRO searches for a zero of a function F(N, T, Y, IROOT) -C between the given values B and C until the width of the -C interval (B, C) has collapsed to within a tolerance -C specified by the stopping criterion, -C ABS(B - C) .LE. 2.*(RW*ABS(B) + AE). -C***LIBRARY SLATEC (SDRIVE) -C***TYPE COMPLEX (SDZRO-S, DDZRO-D, CDZRO-C) -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***DESCRIPTION -C -C This is a special purpose version of ZEROIN, modified for use with -C the CDRIV package. -C -C Sandia Mathematical Program Library -C Mathematical Computing Services Division 5422 -C Sandia Laboratories -C P. O. Box 5800 -C Albuquerque, New Mexico 87115 -C Control Data 6600 Version 4.5, 1 November 1971 -C -C PARAMETERS -C F - Name of the external function, which returns a -C real result. This name must be in an -C EXTERNAL statement in the calling program. -C B - One end of the interval (B, C). The value returned for -C B usually is the better approximation to a zero of F. -C C - The other end of the interval (B, C). -C RE - Relative error used for RW in the stopping criterion. -C If the requested RE is less than machine precision, -C then RW is set to approximately machine precision. -C AE - Absolute error used in the stopping criterion. If the -C given interval (B, C) contains the origin, then a -C nonzero value should be chosen for AE. -C -C***REFERENCES L. F. Shampine and H. A. Watts, ZEROIN, a root-solving -C routine, SC-TM-70-631, Sept 1970. -C T. J. Dekker, Finding a zero by means of successive -C linear interpolation, Constructive Aspects of the -C Fundamental Theorem of Algebra, edited by B. Dejon -C and P. Henrici, 1969. -C***ROUTINES CALLED CDNTP -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE CDZRO - INTEGER IC, IROOT, KOUNT, N, NQ - COMPLEX Y(*), YH(N,*) - REAL A, ACBS, ACMB, AE, B, C, CMB, ER, F, FA, FB, FC, - 8 H, P, Q, RE, RW, T, TOL, UROUND -C***FIRST EXECUTABLE STATEMENT CDZRO - ER = 4.E0*UROUND - RW = MAX(RE, ER) - IC = 0 - ACBS = ABS(B - C) - A = C - FA = FC - KOUNT = 0 -C Perform interchange - 10 IF (ABS(FC) .LT. ABS(FB)) THEN - A = B - FA = FB - B = C - FB = FC - C = A - FC = FA - END IF - CMB = 0.5E0*(C - B) - ACMB = ABS(CMB) - TOL = RW*ABS(B) + AE -C Test stopping criterion - IF (ACMB .LE. TOL) RETURN - IF (KOUNT .GT. 50) RETURN -C Calculate new iterate implicitly as -C B + P/Q, where we arrange P .GE. 0. -C The implicit form is used to prevent overflow. - P = (B - A)*FB - Q = FA - FB - IF (P .LT. 0.E0) THEN - P = -P - Q = -Q - END IF -C Update A and check for satisfactory reduction -C in the size of our bounding interval. - A = B - FA = FB - IC = IC + 1 - IF (IC .GE. 4) THEN - IF (8.E0*ACMB .GE. ACBS) THEN -C Bisect - B = 0.5E0*(C + B) - GO TO 20 - END IF - IC = 0 - END IF - ACBS = ACMB -C Test for too small a change - IF (P .LE. ABS(Q)*TOL) THEN -C Increment by tolerance - B = B + SIGN(TOL, CMB) -C Root ought to be between -C B and (C + B)/2. - ELSE IF (P .LT. CMB*Q) THEN -C Interpolate - B = B + P/Q - ELSE -C Bisect - B = 0.5E0*(C + B) - END IF -C Have completed computation -C for new iterate B. - 20 CALL CDNTP (H, 0, N, NQ, T, B, YH, Y) - FB = F(N, B, Y, IROOT) - IF (N .EQ. 0) RETURN - IF (FB .EQ. 0.E0) RETURN - KOUNT = KOUNT + 1 -C -C Decide whether next step is interpolation or extrapolation -C - IF (SIGN(1.0E0, FB) .EQ. SIGN(1.0E0, FC)) THEN - C = A - FC = FA - END IF - GO TO 10 - END diff --git a/slatec/cexprl.f b/slatec/cexprl.f deleted file mode 100644 index ddd3c99..0000000 --- a/slatec/cexprl.f +++ /dev/null @@ -1,53 +0,0 @@ -*DECK CEXPRL - COMPLEX FUNCTION CEXPRL (Z) -C***BEGIN PROLOGUE CEXPRL -C***PURPOSE Calculate the relative error exponential (EXP(X)-1)/X. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4B -C***TYPE COMPLEX (EXPREL-S, DEXPRL-D, CEXPRL-C) -C***KEYWORDS ELEMENTARY FUNCTIONS, EXPONENTIAL, FIRST ORDER, FNLIB -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate (EXP(Z)-1)/Z . For small ABS(Z), we use the Taylor -C series. We could instead use the expression -C CEXPRL(Z) = (EXP(X)*EXP(I*Y)-1)/Z -C = (X*EXPREL(X) * (1 - 2*SIN(Y/2)**2) - 2*SIN(Y/2)**2 -C + I*SIN(Y)*(1+X*EXPREL(X))) / Z -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH -C***REVISION HISTORY (YYMMDD) -C 770801 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***END PROLOGUE CEXPRL - COMPLEX Z - LOGICAL FIRST - SAVE NTERMS, RBND, FIRST - DATA FIRST / .TRUE. / -C***FIRST EXECUTABLE STATEMENT CEXPRL - IF (FIRST) THEN - ALNEPS = LOG(R1MACH(3)) - XN = 3.72 - 0.3*ALNEPS - XLN = LOG((XN+1.0)/1.36) - NTERMS = XN - (XN*XLN+ALNEPS)/(XLN+1.36) + 1.5 - RBND = R1MACH(3) - ENDIF - FIRST = .FALSE. -C - R = ABS(Z) - IF (R.GT.0.5) CEXPRL = (EXP(Z) - 1.0) / Z - IF (R.GT.0.5) RETURN -C - CEXPRL = (1.0, 0.0) - IF (R.LT.RBND) RETURN -C - CEXPRL = (0.0, 0.0) - DO 20 I=1,NTERMS - CEXPRL = 1.0 + CEXPRL*Z/(NTERMS+2-I) - 20 CONTINUE -C - RETURN - END diff --git a/slatec/cfftb.f b/slatec/cfftb.f deleted file mode 100644 index 1812d0f..0000000 --- a/slatec/cfftb.f +++ /dev/null @@ -1,88 +0,0 @@ -*DECK CFFTB - SUBROUTINE CFFTB (N, C, WSAVE) -C***BEGIN PROLOGUE CFFTB -C***SUBSIDIARY -C***PURPOSE Compute the unnormalized inverse of CFFTF. -C***LIBRARY SLATEC (FFTPACK) -C***CATEGORY J1A2 -C***TYPE COMPLEX (RFFTB-S, CFFTB-C) -C***KEYWORDS FFTPACK, FOURIER TRANSFORM -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C ******************************************************************** -C * NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE * -C ******************************************************************** -C * * -C * This routine uses non-standard Fortran 77 constructs and will * -C * be removed from the library at a future date. You are * -C * requested to use CFFTB1. * -C * * -C ******************************************************************** -C -C Subroutine CFFTB computes the backward complex discrete Fourier -C transform (the Fourier synthesis). Equivalently, CFFTB computes -C a complex periodic sequence from its Fourier coefficients. -C The transform is defined below at output parameter C. -C -C A call of CFFTF followed by a call of CFFTB will multiply the -C sequence by N. -C -C The array WSAVE which is used by subroutine CFFTB must be -C initialized by calling subroutine CFFTI(N,WSAVE). -C -C Input Parameters -C -C N the length of the complex sequence C. The method is -C more efficient when N is the product of small primes. -C -C C a complex array of length N which contains the sequence -C -C WSAVE a real work array which must be dimensioned at least 4*N+15 -C in the program that calls CFFTB. The WSAVE array must be -C initialized by calling subroutine CFFTI(N,WSAVE), and a -C different WSAVE array must be used for each different -C value of N. This initialization does not have to be -C repeated so long as N remains unchanged. Thus subsequent -C transforms can be obtained faster than the first. -C The same WSAVE array can be used by CFFTF and CFFTB. -C -C Output Parameters -C -C C For J=1,...,N -C -C C(J)=the sum from K=1,...,N of -C -C C(K)*EXP(I*(J-1)*(K-1)*2*PI/N) -C -C where I=SQRT(-1) -C -C WSAVE contains initialization calculations which must not be -C destroyed between calls of subroutine CFFTF or CFFTB -C -C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel -C Computations (G. Rodrigue, ed.), Academic Press, -C 1982, pp. 51-83. -C***ROUTINES CALLED CFFTB1 -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C changing dummy array size declarations (1) to (*). -C 861211 REVISION DATE from Version 3.2 -C 881128 Modified by Dick Valent to meet prologue standards. -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900131 Routine changed from user-callable to subsidiary -C because of non-standard Fortran 77 arguments in the -C call to CFFTB1. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CFFTB - COMPLEX C - DIMENSION C(*), WSAVE(*) -C***FIRST EXECUTABLE STATEMENT CFFTB - IF (N .EQ. 1) RETURN - IW1 = N+N+1 - IW2 = IW1+N+N - CALL CFFTB1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2)) - RETURN - END diff --git a/slatec/cfftb1.f b/slatec/cfftb1.f deleted file mode 100644 index 589f441..0000000 --- a/slatec/cfftb1.f +++ /dev/null @@ -1,131 +0,0 @@ -*DECK CFFTB1 - SUBROUTINE CFFTB1 (N, C, CH, WA, IFAC) -C***BEGIN PROLOGUE CFFTB1 -C***PURPOSE Compute the unnormalized inverse of CFFTF1. -C***LIBRARY SLATEC (FFTPACK) -C***CATEGORY J1A2 -C***TYPE COMPLEX (RFFTB1-S, CFFTB1-C) -C***KEYWORDS FFTPACK, FOURIER TRANSFORM -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C Subroutine CFFTB1 computes the backward complex discrete Fourier -C transform (the Fourier synthesis). Equivalently, CFFTB1 computes -C a complex periodic sequence from its Fourier coefficients. -C The transform is defined below at output parameter C. -C -C A call of CFFTF1 followed by a call of CFFTB1 will multiply the -C sequence by N. -C -C The arrays WA and IFAC which are used by subroutine CFFTB1 must be -C initialized by calling subroutine CFFTI1 (N, WA, IFAC). -C -C Input Parameters -C -C N the length of the complex sequence C. The method is -C more efficient when N is the product of small primes. -C -C C a complex array of length N which contains the sequence -C -C CH a real work array of length at least 2*N -C -C WA a real work array which must be dimensioned at least 2*N. -C -C IFAC an integer work array which must be dimensioned at least 15. -C -C The WA and IFAC arrays must be initialized by calling -C subroutine CFFTI1 (N, WA, IFAC), and different WA and IFAC -C arrays must be used for each different value of N. This -C initialization does not have to be repeated so long as N -C remains unchanged. Thus subsequent transforms can be -C obtained faster than the first. The same WA and IFAC arrays -C can be used by CFFTF1 and CFFTB1. -C -C Output Parameters -C -C C For J=1,...,N -C -C C(J)=the sum from K=1,...,N of -C -C C(K)*EXP(I*(J-1)*(K-1)*2*PI/N) -C -C where I=SQRT(-1) -C -C NOTE: WA and IFAC contain initialization calculations which must -C not be destroyed between calls of subroutine CFFTF1 or CFFTB1 -C -C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel -C Computations (G. Rodrigue, ed.), Academic Press, -C 1982, pp. 51-83. -C***ROUTINES CALLED PASSB, PASSB2, PASSB3, PASSB4, PASSB5 -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C changing dummy array size declarations (1) to (*). -C 881128 Modified by Dick Valent to meet prologue standards. -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900131 Routine changed from subsidiary to user-callable. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CFFTB1 - DIMENSION CH(*), C(*), WA(*), IFAC(*) -C***FIRST EXECUTABLE STATEMENT CFFTB1 - NF = IFAC(2) - NA = 0 - L1 = 1 - IW = 1 - DO 116 K1=1,NF - IP = IFAC(K1+2) - L2 = IP*L1 - IDO = N/L2 - IDOT = IDO+IDO - IDL1 = IDOT*L1 - IF (IP .NE. 4) GO TO 103 - IX2 = IW+IDOT - IX3 = IX2+IDOT - IF (NA .NE. 0) GO TO 101 - CALL PASSB4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) - GO TO 102 - 101 CALL PASSB4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) - 102 NA = 1-NA - GO TO 115 - 103 IF (IP .NE. 2) GO TO 106 - IF (NA .NE. 0) GO TO 104 - CALL PASSB2 (IDOT,L1,C,CH,WA(IW)) - GO TO 105 - 104 CALL PASSB2 (IDOT,L1,CH,C,WA(IW)) - 105 NA = 1-NA - GO TO 115 - 106 IF (IP .NE. 3) GO TO 109 - IX2 = IW+IDOT - IF (NA .NE. 0) GO TO 107 - CALL PASSB3 (IDOT,L1,C,CH,WA(IW),WA(IX2)) - GO TO 108 - 107 CALL PASSB3 (IDOT,L1,CH,C,WA(IW),WA(IX2)) - 108 NA = 1-NA - GO TO 115 - 109 IF (IP .NE. 5) GO TO 112 - IX2 = IW+IDOT - IX3 = IX2+IDOT - IX4 = IX3+IDOT - IF (NA .NE. 0) GO TO 110 - CALL PASSB5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - GO TO 111 - 110 CALL PASSB5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - 111 NA = 1-NA - GO TO 115 - 112 IF (NA .NE. 0) GO TO 113 - CALL PASSB (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) - GO TO 114 - 113 CALL PASSB (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) - 114 IF (NAC .NE. 0) NA = 1-NA - 115 L1 = L2 - IW = IW+(IP-1)*IDOT - 116 CONTINUE - IF (NA .EQ. 0) RETURN - N2 = N+N - DO 117 I=1,N2 - C(I) = CH(I) - 117 CONTINUE - RETURN - END diff --git a/slatec/cfftf.f b/slatec/cfftf.f deleted file mode 100644 index 4475c4d..0000000 --- a/slatec/cfftf.f +++ /dev/null @@ -1,90 +0,0 @@ -*DECK CFFTF - SUBROUTINE CFFTF (N, C, WSAVE) -C***BEGIN PROLOGUE CFFTF -C***SUBSIDIARY -C***PURPOSE Compute the forward transform of a complex, periodic -C sequence. -C***LIBRARY SLATEC (FFTPACK) -C***CATEGORY J1A2 -C***TYPE COMPLEX (RFFTF-S, CFFTF-C) -C***KEYWORDS FFTPACK, FOURIER TRANSFORM -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C ******************************************************************** -C * NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE * -C ******************************************************************** -C * * -C * This routine uses non-standard Fortran 77 constructs and will * -C * be removed from the library at a future date. You are * -C * requested to use CFFTF1. * -C * * -C ******************************************************************** -C -C Subroutine CFFTF computes the forward complex discrete Fourier -C transform (the Fourier analysis). Equivalently, CFFTF computes -C the Fourier coefficients of a complex periodic sequence. -C The transform is defined below at output parameter C. -C -C The transform is not normalized. To obtain a normalized transform -C the output must be divided by N. Otherwise a call of CFFTF -C followed by a call of CFFTB will multiply the sequence by N. -C -C The array WSAVE which is used by subroutine CFFTF must be -C initialized by calling subroutine CFFTI(N,WSAVE). -C -C Input Parameters -C -C N the length of the complex sequence C. The method is -C more efficient when N is the product of small primes. -C -C C a complex array of length N which contains the sequence -C -C WSAVE a real work array which must be dimensioned at least 4*N+15 -C in the program that calls CFFTF. The WSAVE array must be -C initialized by calling subroutine CFFTI(N,WSAVE), and a -C different WSAVE array must be used for each different -C value of N. This initialization does not have to be -C repeated so long as N remains unchanged. Thus subsequent -C transforms can be obtained faster than the first. -C The same WSAVE array can be used by CFFTF and CFFTB. -C -C Output Parameters -C -C C For J=1,...,N -C -C C(J)=the sum from K=1,...,N of -C -C C(K)*EXP(-I*(J-1)*(K-1)*2*PI/N) -C -C where I=SQRT(-1) -C -C WSAVE contains initialization calculations which must not be -C destroyed between calls of subroutine CFFTF or CFFTB -C -C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel -C Computations (G. Rodrigue, ed.), Academic Press, -C 1982, pp. 51-83. -C***ROUTINES CALLED CFFTF1 -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C changing dummy array size declarations (1) to (*). -C 861211 REVISION DATE from Version 3.2 -C 881128 Modified by Dick Valent to meet prologue standards. -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900131 Routine changed from user-callable to subsidiary -C because of non-standard Fortran 77 arguments in the -C call to CFFTB1. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CFFTF - COMPLEX C - DIMENSION C(*), WSAVE(*) -C***FIRST EXECUTABLE STATEMENT CFFTF - IF (N .EQ. 1) RETURN - IW1 = N+N+1 - IW2 = IW1+N+N - CALL CFFTF1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2)) - RETURN - END diff --git a/slatec/cfftf1.f b/slatec/cfftf1.f deleted file mode 100644 index ae7f614..0000000 --- a/slatec/cfftf1.f +++ /dev/null @@ -1,133 +0,0 @@ -*DECK CFFTF1 - SUBROUTINE CFFTF1 (N, C, CH, WA, IFAC) -C***BEGIN PROLOGUE CFFTF1 -C***PURPOSE Compute the forward transform of a complex, periodic -C sequence. -C***LIBRARY SLATEC (FFTPACK) -C***CATEGORY J1A2 -C***TYPE COMPLEX (RFFTF1-S, CFFTF1-C) -C***KEYWORDS FFTPACK, FOURIER TRANSFORM -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C Subroutine CFFTF1 computes the forward complex discrete Fourier -C transform (the Fourier analysis). Equivalently, CFFTF1 computes -C the Fourier coefficients of a complex periodic sequence. -C The transform is defined below at output parameter C. -C -C The transform is not normalized. To obtain a normalized transform -C the output must be divided by N. Otherwise a call of CFFTF1 -C followed by a call of CFFTB1 will multiply the sequence by N. -C -C The arrays WA and IFAC which are used by subroutine CFFTB1 must be -C initialized by calling subroutine CFFTI1 (N, WA, IFAC). -C -C Input Parameters -C -C N the length of the complex sequence C. The method is -C more efficient when N is the product of small primes. -C -C C a complex array of length N which contains the sequence -C -C CH a real work array of length at least 2*N -C -C WA a real work array which must be dimensioned at least 2*N. -C -C IFAC an integer work array which must be dimensioned at least 15. -C -C The WA and IFAC arrays must be initialized by calling -C subroutine CFFTI1 (N, WA, IFAC), and different WA and IFAC -C arrays must be used for each different value of N. This -C initialization does not have to be repeated so long as N -C remains unchanged. Thus subsequent transforms can be -C obtained faster than the first. The same WA and IFAC arrays -C can be used by CFFTF1 and CFFTB1. -C -C Output Parameters -C -C C For J=1,...,N -C -C C(J)=the sum from K=1,...,N of -C -C C(K)*EXP(-I*(J-1)*(K-1)*2*PI/N) -C -C where I=SQRT(-1) -C -C NOTE: WA and IFAC contain initialization calculations which must -C not be destroyed between calls of subroutine CFFTF1 or CFFTB1 -C -C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel -C Computations (G. Rodrigue, ed.), Academic Press, -C 1982, pp. 51-83. -C***ROUTINES CALLED PASSF, PASSF2, PASSF3, PASSF4, PASSF5 -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C changing dummy array size declarations (1) to (*). -C 881128 Modified by Dick Valent to meet prologue standards. -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900131 Routine changed from subsidiary to user-callable. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CFFTF1 - DIMENSION CH(*), C(*), WA(*), IFAC(*) -C***FIRST EXECUTABLE STATEMENT CFFTF1 - NF = IFAC(2) - NA = 0 - L1 = 1 - IW = 1 - DO 116 K1=1,NF - IP = IFAC(K1+2) - L2 = IP*L1 - IDO = N/L2 - IDOT = IDO+IDO - IDL1 = IDOT*L1 - IF (IP .NE. 4) GO TO 103 - IX2 = IW+IDOT - IX3 = IX2+IDOT - IF (NA .NE. 0) GO TO 101 - CALL PASSF4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) - GO TO 102 - 101 CALL PASSF4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) - 102 NA = 1-NA - GO TO 115 - 103 IF (IP .NE. 2) GO TO 106 - IF (NA .NE. 0) GO TO 104 - CALL PASSF2 (IDOT,L1,C,CH,WA(IW)) - GO TO 105 - 104 CALL PASSF2 (IDOT,L1,CH,C,WA(IW)) - 105 NA = 1-NA - GO TO 115 - 106 IF (IP .NE. 3) GO TO 109 - IX2 = IW+IDOT - IF (NA .NE. 0) GO TO 107 - CALL PASSF3 (IDOT,L1,C,CH,WA(IW),WA(IX2)) - GO TO 108 - 107 CALL PASSF3 (IDOT,L1,CH,C,WA(IW),WA(IX2)) - 108 NA = 1-NA - GO TO 115 - 109 IF (IP .NE. 5) GO TO 112 - IX2 = IW+IDOT - IX3 = IX2+IDOT - IX4 = IX3+IDOT - IF (NA .NE. 0) GO TO 110 - CALL PASSF5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - GO TO 111 - 110 CALL PASSF5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - 111 NA = 1-NA - GO TO 115 - 112 IF (NA .NE. 0) GO TO 113 - CALL PASSF (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) - GO TO 114 - 113 CALL PASSF (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) - 114 IF (NAC .NE. 0) NA = 1-NA - 115 L1 = L2 - IW = IW+(IP-1)*IDOT - 116 CONTINUE - IF (NA .EQ. 0) RETURN - N2 = N+N - DO 117 I=1,N2 - C(I) = CH(I) - 117 CONTINUE - RETURN - END diff --git a/slatec/cffti.f b/slatec/cffti.f deleted file mode 100644 index dac1b98..0000000 --- a/slatec/cffti.f +++ /dev/null @@ -1,64 +0,0 @@ -*DECK CFFTI - SUBROUTINE CFFTI (N, WSAVE) -C***BEGIN PROLOGUE CFFTI -C***SUBSIDIARY -C***PURPOSE Initialize a work array for CFFTF and CFFTB. -C***LIBRARY SLATEC (FFTPACK) -C***CATEGORY J1A2 -C***TYPE COMPLEX (RFFTI-S, CFFTI-C) -C***KEYWORDS FFTPACK, FOURIER TRANSFORM -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C ******************************************************************** -C * NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE * -C ******************************************************************** -C * * -C * This routine uses non-standard Fortran 77 constructs and will * -C * be removed from the library at a future date. You are * -C * requested to use CFFTI1. * -C * * -C ******************************************************************** -C -C Subroutine CFFTI initializes the array WSAVE which is used in -C both CFFTF and CFFTB. The prime factorization of N together with -C a tabulation of the trigonometric functions are computed and -C stored in WSAVE. -C -C Input Parameter -C -C N the length of the sequence to be transformed -C -C Output Parameter -C -C WSAVE a work array which must be dimensioned at least 4*N+15. -C The same work array can be used for both CFFTF and CFFTB -C as long as N remains unchanged. Different WSAVE arrays -C are required for different values of N. The contents of -C WSAVE must not be changed between calls of CFFTF or CFFTB. -C -C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel -C Computations (G. Rodrigue, ed.), Academic Press, -C 1982, pp. 51-83. -C***ROUTINES CALLED CFFTI1 -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C changing dummy array size declarations (1) to (*). -C 861211 REVISION DATE from Version 3.2 -C 881128 Modified by Dick Valent to meet prologue standards. -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900131 Routine changed from user-callable to subsidiary -C because of non-standard Fortran 77 arguments in the -C call to CFFTB1. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CFFTI - DIMENSION WSAVE(*) -C***FIRST EXECUTABLE STATEMENT CFFTI - IF (N .EQ. 1) RETURN - IW1 = N+N+1 - IW2 = IW1+N+N - CALL CFFTI1 (N,WSAVE(IW1),WSAVE(IW2)) - RETURN - END diff --git a/slatec/cffti1.f b/slatec/cffti1.f deleted file mode 100644 index 6e8a9a9..0000000 --- a/slatec/cffti1.f +++ /dev/null @@ -1,114 +0,0 @@ -*DECK CFFTI1 - SUBROUTINE CFFTI1 (N, WA, IFAC) -C***BEGIN PROLOGUE CFFTI1 -C***PURPOSE Initialize a real and an integer work array for CFFTF1 and -C CFFTB1. -C***LIBRARY SLATEC (FFTPACK) -C***CATEGORY J1A2 -C***TYPE COMPLEX (RFFTI1-S, CFFTI1-C) -C***KEYWORDS FFTPACK, FOURIER TRANSFORM -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C Subroutine CFFTI1 initializes the work arrays WA and IFAC which are -C used in both CFFTF1 and CFFTB1. The prime factorization of N and a -C tabulation of the trigonometric functions are computed and stored in -C IFAC and WA, respectively. -C -C Input Parameter -C -C N the length of the sequence to be transformed -C -C Output Parameters -C -C WA a real work array which must be dimensioned at least 2*N. -C -C IFAC an integer work array which must be dimensioned at least 15. -C -C The same work arrays can be used for both CFFTF1 and CFFTB1 -C as long as N remains unchanged. Different WA and IFAC arrays -C are required for different values of N. The contents of -C WA and IFAC must not be changed between calls of CFFTF1 or -C CFFTB1. -C -C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel -C Computations (G. Rodrigue, ed.), Academic Press, -C 1982, pp. 51-83. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C (a) changing dummy array size declarations (1) to (*), -C (b) changing references to intrinsic function FLOAT -C to REAL, and -C (c) changing definition of variable TPI by using -C FORTRAN intrinsic function ATAN instead of a DATA -C statement. -C 881128 Modified by Dick Valent to meet prologue standards. -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900131 Routine changed from subsidiary to user-callable. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CFFTI1 - DIMENSION WA(*), IFAC(*), NTRYH(4) - SAVE NTRYH - DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/3,4,2,5/ -C***FIRST EXECUTABLE STATEMENT CFFTI1 - NL = N - NF = 0 - J = 0 - 101 J = J+1 - IF (J-4) 102,102,103 - 102 NTRY = NTRYH(J) - GO TO 104 - 103 NTRY = NTRY+2 - 104 NQ = NL/NTRY - NR = NL-NTRY*NQ - IF (NR) 101,105,101 - 105 NF = NF+1 - IFAC(NF+2) = NTRY - NL = NQ - IF (NTRY .NE. 2) GO TO 107 - IF (NF .EQ. 1) GO TO 107 - DO 106 I=2,NF - IB = NF-I+2 - IFAC(IB+2) = IFAC(IB+1) - 106 CONTINUE - IFAC(3) = 2 - 107 IF (NL .NE. 1) GO TO 104 - IFAC(1) = N - IFAC(2) = NF - TPI = 8.*ATAN(1.) - ARGH = TPI/N - I = 2 - L1 = 1 - DO 110 K1=1,NF - IP = IFAC(K1+2) - LD = 0 - L2 = L1*IP - IDO = N/L2 - IDOT = IDO+IDO+2 - IPM = IP-1 - DO 109 J=1,IPM - I1 = I - WA(I-1) = 1. - WA(I) = 0. - LD = LD+L1 - FI = 0. - ARGLD = LD*ARGH - DO 108 II=4,IDOT,2 - I = I+2 - FI = FI+1. - ARG = FI*ARGLD - WA(I-1) = COS(ARG) - WA(I) = SIN(ARG) - 108 CONTINUE - IF (IP .LE. 5) GO TO 109 - WA(I1-1) = WA(I-1) - WA(I1) = WA(I) - 109 CONTINUE - L1 = L2 - 110 CONTINUE - RETURN - END diff --git a/slatec/cfod.f b/slatec/cfod.f deleted file mode 100644 index 239750b..0000000 --- a/slatec/cfod.f +++ /dev/null @@ -1,132 +0,0 @@ -*DECK CFOD - SUBROUTINE CFOD (METH, ELCO, TESCO) -C***BEGIN PROLOGUE CFOD -C***SUBSIDIARY -C***PURPOSE Subsidiary to DEBDF -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (CFOD-S, DCFOD-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C CFOD defines coefficients needed in the integrator package DEBDF -C -C***SEE ALSO DEBDF -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 800901 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE CFOD -C -C -CLLL. OPTIMIZE - INTEGER METH, I, IB, NQ, NQM1, NQP1 - REAL ELCO, TESCO, AGAMQ, FNQ, FNQM1, PC, PINT, RAGQ, - 1 RQFAC, RQ1FAC, TSIGN, XPIN - DIMENSION ELCO(13,12), TESCO(3,12) -C----------------------------------------------------------------------- -C CFOD IS CALLED BY THE INTEGRATOR ROUTINE TO SET COEFFICIENTS -C NEEDED THERE. THE COEFFICIENTS FOR THE CURRENT METHOD, AS -C GIVEN BY THE VALUE OF METH, ARE SET FOR ALL ORDERS AND SAVED. -C THE MAXIMUM ORDER ASSUMED HERE IS 12 IF METH = 1 AND 5 IF METH = 2. -C (A SMALLER VALUE OF THE MAXIMUM ORDER IS ALSO ALLOWED.) -C CFOD IS CALLED ONCE AT THE BEGINNING OF THE PROBLEM, -C AND IS NOT CALLED AGAIN UNLESS AND UNTIL METH IS CHANGED. -C -C THE ELCO ARRAY CONTAINS THE BASIC METHOD COEFFICIENTS. -C THE COEFFICIENTS EL(I), 1 .LE. I .LE. NQ+1, FOR THE METHOD OF -C ORDER NQ ARE STORED IN ELCO(I,NQ). THEY ARE GIVEN BY A GENERATING -C POLYNOMIAL, I.E., -C L(X) = EL(1) + EL(2)*X + ... + EL(NQ+1)*X**NQ. -C FOR THE IMPLICIT ADAMS METHODS, L(X) IS GIVEN BY -C DL/DX = (X+1)*(X+2)*...*(X+NQ-1)/FACTORIAL(NQ-1), L(-1) = 0. -C FOR THE BDF METHODS, L(X) IS GIVEN BY -C L(X) = (X+1)*(X+2)* ... *(X+NQ)/K, -C WHERE K = FACTORIAL(NQ)*(1 + 1/2 + ... + 1/NQ). -C -C THE TESCO ARRAY CONTAINS TEST CONSTANTS USED FOR THE -C LOCAL ERROR TEST AND THE SELECTION OF STEP SIZE AND/OR ORDER. -C AT ORDER NQ, TESCO(K,NQ) IS USED FOR THE SELECTION OF STEP -C SIZE AT ORDER NQ - 1 IF K = 1, AT ORDER NQ IF K = 2, AND AT ORDER -C NQ + 1 IF K = 3. -C----------------------------------------------------------------------- - DIMENSION PC(12) -C -C***FIRST EXECUTABLE STATEMENT CFOD - GO TO (100, 200), METH -C - 100 ELCO(1,1) = 1.0E0 - ELCO(2,1) = 1.0E0 - TESCO(1,1) = 0.0E0 - TESCO(2,1) = 2.0E0 - TESCO(1,2) = 1.0E0 - TESCO(3,12) = 0.0E0 - PC(1) = 1.0E0 - RQFAC = 1.0E0 - DO 140 NQ = 2,12 -C----------------------------------------------------------------------- -C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE POLYNOMIAL -C P(X) = (X+1)*(X+2)*...*(X+NQ-1). -C INITIALLY, P(X) = 1. -C----------------------------------------------------------------------- - RQ1FAC = RQFAC - RQFAC = RQFAC/NQ - NQM1 = NQ - 1 - FNQM1 = NQM1 - NQP1 = NQ + 1 -C FORM COEFFICIENTS OF P(X)*(X+NQ-1). ---------------------------------- - PC(NQ) = 0.0E0 - DO 110 IB = 1,NQM1 - I = NQP1 - IB - 110 PC(I) = PC(I-1) + FNQM1*PC(I) - PC(1) = FNQM1*PC(1) -C COMPUTE INTEGRAL, -1 TO 0, OF P(X) AND X*P(X). ----------------------- - PINT = PC(1) - XPIN = PC(1)/2.0E0 - TSIGN = 1.0E0 - DO 120 I = 2,NQ - TSIGN = -TSIGN - PINT = PINT + TSIGN*PC(I)/I - 120 XPIN = XPIN + TSIGN*PC(I)/(I+1) -C STORE COEFFICIENTS IN ELCO AND TESCO. -------------------------------- - ELCO(1,NQ) = PINT*RQ1FAC - ELCO(2,NQ) = 1.0E0 - DO 130 I = 2,NQ - 130 ELCO(I+1,NQ) = RQ1FAC*PC(I)/I - AGAMQ = RQFAC*XPIN - RAGQ = 1.0E0/AGAMQ - TESCO(2,NQ) = RAGQ - IF(NQ.LT.12)TESCO(1,NQP1)=RAGQ*RQFAC/NQP1 - TESCO(3,NQM1) = RAGQ - 140 CONTINUE - RETURN -C - 200 PC(1) = 1.0E0 - RQ1FAC = 1.0E0 - DO 230 NQ = 1,5 -C----------------------------------------------------------------------- -C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE POLYNOMIAL -C P(X) = (X+1)*(X+2)*...*(X+NQ). -C INITIALLY, P(X) = 1. -C----------------------------------------------------------------------- - FNQ = NQ - NQP1 = NQ + 1 -C FORM COEFFICIENTS OF P(X)*(X+NQ). ------------------------------------ - PC(NQP1) = 0.0E0 - DO 210 IB = 1,NQ - I = NQ + 2 - IB - 210 PC(I) = PC(I-1) + FNQ*PC(I) - PC(1) = FNQ*PC(1) -C STORE COEFFICIENTS IN ELCO AND TESCO. -------------------------------- - DO 220 I = 1,NQP1 - 220 ELCO(I,NQ) = PC(I)/PC(2) - ELCO(2,NQ) = 1.0E0 - TESCO(1,NQ) = RQ1FAC - TESCO(2,NQ) = NQP1/ELCO(1,NQ) - TESCO(3,NQ) = (NQ+2)/ELCO(1,NQ) - RQ1FAC = RQ1FAC/FNQ - 230 CONTINUE - RETURN -C----------------------- END OF SUBROUTINE CFOD ----------------------- - END diff --git a/slatec/cg.f b/slatec/cg.f deleted file mode 100644 index f19d379..0000000 --- a/slatec/cg.f +++ /dev/null @@ -1,97 +0,0 @@ -*DECK CG - SUBROUTINE CG (NM, N, AR, AI, WR, WI, MATZ, ZR, ZI, FV1, FV2, FV3, - + IERR) -C***BEGIN PROLOGUE CG -C***PURPOSE Compute the eigenvalues and, optionally, the eigenvectors -C of a complex general matrix. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4A4 -C***TYPE COMPLEX (RG-S, CG-C) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine calls the recommended sequence of -C subroutines from the eigensystem subroutine package (EISPACK) -C to find the eigenvalues and eigenvectors (if desired) -C of a COMPLEX GENERAL matrix. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, AR, AI, ZR and ZI, as declared in the -C calling program dimension statement. NM is an INTEGER -C variable. -C -C N is the order of the matrix A=(AR,AI). N is an INTEGER -C variable. N must be less than or equal to NM. -C -C AR and AI contain the real and imaginary parts, respectively, -C of the complex general matrix. AR and AI are two-dimensional -C REAL arrays, dimensioned AR(NM,N) and AI(NM,N). -C -C MATZ is an INTEGER variable set equal to zero if only -C eigenvalues are desired. Otherwise, it is set to any -C non-zero integer for both eigenvalues and eigenvectors. -C -C On OUTPUT -C -C WR and WI contain the real and imaginary parts, respectively, -C of the eigenvalues. WR and WI are one-dimensional REAL -C arrays, dimensioned WR(N) and WI(N). -C -C ZR and ZI contain the real and imaginary parts, respectively, -C of the eigenvectors if MATZ is not zero. ZR and ZI are -C two-dimensional REAL arrays, dimensioned ZR(NM,N) and -C ZI(NM,N). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C 10*N if N is greater than NM, -C J if the J-th eigenvalue has not been -C determined after a total of 30 iterations. -C The eigenvalues should be correct for indices -C IERR+1, IERR+2, ..., N, but no eigenvectors are -C computed. -C -C FV1, FV2, and FV3 are one-dimensional REAL arrays used for -C temporary storage, dimensioned FV1(N), FV2(N), and FV3(N). -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED CBABK2, CBAL, COMQR, COMQR2, CORTH -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CG -C - INTEGER N,NM,IS1,IS2,IERR,MATZ - REAL AR(NM,*),AI(NM,*),WR(*),WI(*),ZR(NM,*),ZI(NM,*) - REAL FV1(*),FV2(*),FV3(*) -C -C***FIRST EXECUTABLE STATEMENT CG - IF (N .LE. NM) GO TO 10 - IERR = 10 * N - GO TO 50 -C - 10 CALL CBAL(NM,N,AR,AI,IS1,IS2,FV1) - CALL CORTH(NM,N,IS1,IS2,AR,AI,FV2,FV3) - IF (MATZ .NE. 0) GO TO 20 -C .......... FIND EIGENVALUES ONLY .......... - CALL COMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR) - GO TO 50 -C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... - 20 CALL COMQR2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR) - IF (IERR .NE. 0) GO TO 50 - CALL CBABK2(NM,N,IS1,IS2,FV1,N,ZR,ZI) - 50 RETURN - END diff --git a/slatec/cgamma.f b/slatec/cgamma.f deleted file mode 100644 index d4c1293..0000000 --- a/slatec/cgamma.f +++ /dev/null @@ -1,28 +0,0 @@ -*DECK CGAMMA - COMPLEX FUNCTION CGAMMA (Z) -C***BEGIN PROLOGUE CGAMMA -C***PURPOSE Compute the complete Gamma function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7A -C***TYPE COMPLEX (GAMMA-S, DGAMMA-D, CGAMMA-C) -C***KEYWORDS COMPLETE GAMMA FUNCTION, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C CGAMMA(Z) calculates the complete gamma function for COMPLEX -C argument Z. This is a preliminary version that is portable -C but not accurate. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CLNGAM -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CGAMMA - COMPLEX Z, CLNGAM -C***FIRST EXECUTABLE STATEMENT CGAMMA - CGAMMA = EXP (CLNGAM(Z)) -C - RETURN - END diff --git a/slatec/cgamr.f b/slatec/cgamr.f deleted file mode 100644 index b387759..0000000 --- a/slatec/cgamr.f +++ /dev/null @@ -1,36 +0,0 @@ -*DECK CGAMR - COMPLEX FUNCTION CGAMR (Z) -C***BEGIN PROLOGUE CGAMR -C***PURPOSE Compute the reciprocal of the Gamma function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7A -C***TYPE COMPLEX (GAMR-S, DGAMR-D, CGAMR-C) -C***KEYWORDS FNLIB, RECIPROCAL GAMMA FUNCTION, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C CGAMR(Z) calculates the reciprocal gamma function for COMPLEX -C argument Z. This is a preliminary version that is not accurate. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CLNGAM, XERCLR, XGETF, XSETF -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CGAMR - COMPLEX Z, CLNGAM -C***FIRST EXECUTABLE STATEMENT CGAMR - CGAMR = (0.0, 0.0) - X = REAL (Z) - IF (X.LE.0.0 .AND. AINT(X).EQ.X .AND. AIMAG(Z).EQ.0.0) RETURN -C - CALL XGETF (IROLD) - CALL XSETF (1) - CGAMR = CLNGAM(Z) - CALL XERCLR - CALL XSETF (IROLD) - CGAMR = EXP (-CGAMR) -C - RETURN - END diff --git a/slatec/cgbco.f b/slatec/cgbco.f deleted file mode 100644 index c19a767..0000000 --- a/slatec/cgbco.f +++ /dev/null @@ -1,282 +0,0 @@ -*DECK CGBCO - SUBROUTINE CGBCO (ABD, LDA, N, ML, MU, IPVT, RCOND, Z) -C***BEGIN PROLOGUE CGBCO -C***PURPOSE Factor a band matrix by Gaussian elimination and -C estimate the condition number of the matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2C2 -C***TYPE COMPLEX (SGBCO-S, DGBCO-D, CGBCO-C) -C***KEYWORDS BANDED, CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, -C MATRIX FACTORIZATION -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C CGBCO factors a complex band matrix by Gaussian -C elimination and estimates the condition of the matrix. -C -C If RCOND is not needed, CGBFA is slightly faster. -C To solve A*X = B , follow CGBCO by CGBSL. -C To compute INVERSE(A)*C , follow CGBCO by CGBSL. -C To compute DETERMINANT(A) , follow CGBCO by CGBDI. -C -C On Entry -C -C ABD COMPLEX(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 REAL -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 COMPLEX(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 = MAX(1, J-MU) -C I2 = MIN(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***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CDOTC, CGBFA, CSSCAL, SCASUM -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CGBCO - INTEGER LDA,N,ML,MU,IPVT(*) - COMPLEX ABD(LDA,*),Z(*) - REAL RCOND -C - COMPLEX CDOTC,EK,T,WK,WKM - REAL ANORM,S,SCASUM,SM,YNORM - INTEGER IS,INFO,J,JU,K,KB,KP1,L,LA,LM,LZ,M,MM - COMPLEX ZDUM,ZDUM1,ZDUM2,CSIGN1 - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) - CSIGN1(ZDUM1,ZDUM2) = CABS1(ZDUM1)*(ZDUM2/CABS1(ZDUM2)) -C -C COMPUTE 1-NORM OF A -C -C***FIRST EXECUTABLE STATEMENT CGBCO - ANORM = 0.0E0 - L = ML + 1 - IS = L + MU - DO 10 J = 1, N - ANORM = MAX(ANORM,SCASUM(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 CGBFA(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 CTRANS(A)*Y = E . -C CTRANS(A) IS THE CONJUGATE TRANSPOSE OF A . -C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL -C GROWTH IN THE ELEMENTS OF W WHERE CTRANS(U)*W = E . -C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. -C -C SOLVE CTRANS(U)*W = E -C - EK = (1.0E0,0.0E0) - DO 20 J = 1, N - Z(J) = (0.0E0,0.0E0) - 20 CONTINUE - M = ML + MU + 1 - JU = 0 - DO 100 K = 1, N - IF (CABS1(Z(K)) .NE. 0.0E0) EK = CSIGN1(EK,-Z(K)) - IF (CABS1(EK-Z(K)) .LE. CABS1(ABD(M,K))) GO TO 30 - S = CABS1(ABD(M,K))/CABS1(EK-Z(K)) - CALL CSSCAL(N,S,Z,1) - EK = CMPLX(S,0.0E0)*EK - 30 CONTINUE - WK = EK - Z(K) - WKM = -EK - Z(K) - S = CABS1(WK) - SM = CABS1(WKM) - IF (CABS1(ABD(M,K)) .EQ. 0.0E0) GO TO 40 - WK = WK/CONJG(ABD(M,K)) - WKM = WKM/CONJG(ABD(M,K)) - GO TO 50 - 40 CONTINUE - WK = (1.0E0,0.0E0) - WKM = (1.0E0,0.0E0) - 50 CONTINUE - KP1 = K + 1 - JU = MIN(MAX(JU,MU+IPVT(K)),N) - MM = M - IF (KP1 .GT. JU) GO TO 90 - DO 60 J = KP1, JU - MM = MM - 1 - SM = SM + CABS1(Z(J)+WKM*CONJG(ABD(MM,J))) - Z(J) = Z(J) + WK*CONJG(ABD(MM,J)) - S = S + CABS1(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*CONJG(ABD(MM,J)) - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - Z(K) = WK - 100 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) -C -C SOLVE CTRANS(L)*Y = W -C - DO 120 KB = 1, N - K = N + 1 - KB - LM = MIN(ML,N-K) - IF (K .LT. N) Z(K) = Z(K) + CDOTC(LM,ABD(M+1,K),1,Z(K+1),1) - IF (CABS1(Z(K)) .LE. 1.0E0) GO TO 110 - S = 1.0E0/CABS1(Z(K)) - CALL CSSCAL(N,S,Z,1) - 110 CONTINUE - L = IPVT(K) - T = Z(L) - Z(L) = Z(K) - Z(K) = T - 120 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) -C - YNORM = 1.0E0 -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 = MIN(ML,N-K) - IF (K .LT. N) CALL CAXPY(LM,T,ABD(M+1,K),1,Z(K+1),1) - IF (CABS1(Z(K)) .LE. 1.0E0) GO TO 130 - S = 1.0E0/CABS1(Z(K)) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM - 130 CONTINUE - 140 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE U*Z = W -C - DO 160 KB = 1, N - K = N + 1 - KB - IF (CABS1(Z(K)) .LE. CABS1(ABD(M,K))) GO TO 150 - S = CABS1(ABD(M,K))/CABS1(Z(K)) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM - 150 CONTINUE - IF (CABS1(ABD(M,K)) .NE. 0.0E0) Z(K) = Z(K)/ABD(M,K) - IF (CABS1(ABD(M,K)) .EQ. 0.0E0) Z(K) = (1.0E0,0.0E0) - LM = MIN(K,M) - 1 - LA = M - LM - LZ = K - LM - T = -Z(K) - CALL CAXPY(LM,T,ABD(LA,K),1,Z(LZ),1) - 160 CONTINUE -C MAKE ZNORM = 1.0 - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM -C - IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM - IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0 - RETURN - END diff --git a/slatec/cgbdi.f b/slatec/cgbdi.f deleted file mode 100644 index ccb0b70..0000000 --- a/slatec/cgbdi.f +++ /dev/null @@ -1,89 +0,0 @@ -*DECK CGBDI - SUBROUTINE CGBDI (ABD, LDA, N, ML, MU, IPVT, DET) -C***BEGIN PROLOGUE CGBDI -C***PURPOSE Compute the determinant of a complex band matrix using the -C factors from CGBCO or CGBFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D3C2 -C***TYPE COMPLEX (SGBDI-S, DGBDI-D, CGBDI-C) -C***KEYWORDS BANDED, DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, -C MATRIX -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C CGBDI computes the determinant of a band matrix -C using the factors computed by CGBCO or CGBFA. -C If the inverse is needed, use CGBSL N times. -C -C On Entry -C -C ABD COMPLEX(LDA, N) -C the output from CGBCO or CGBFA. -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 CGBCO or CGBFA. -C -C On Return -C -C DET COMPLEX(2) -C determinant of original matrix. -C Determinant = DET(1) * 10.0**DET(2) -C with 1.0 .LE. CABS1(DET(1)) .LT. 10.0 -C or DET(1) = 0.0 . -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CGBDI - INTEGER LDA,N,ML,MU,IPVT(*) - COMPLEX ABD(LDA,*),DET(2) -C - REAL TEN - INTEGER I,M - COMPLEX ZDUM - REAL CABS1 -C - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) -C***FIRST EXECUTABLE STATEMENT CGBDI - M = ML + MU + 1 - DET(1) = (1.0E0,0.0E0) - DET(2) = (0.0E0,0.0E0) - TEN = 10.0E0 - DO 50 I = 1, N - IF (IPVT(I) .NE. I) DET(1) = -DET(1) - DET(1) = ABD(M,I)*DET(1) - IF (CABS1(DET(1)) .EQ. 0.0E0) GO TO 60 - 10 IF (CABS1(DET(1)) .GE. 1.0E0) GO TO 20 - DET(1) = CMPLX(TEN,0.0E0)*DET(1) - DET(2) = DET(2) - (1.0E0,0.0E0) - GO TO 10 - 20 CONTINUE - 30 IF (CABS1(DET(1)) .LT. TEN) GO TO 40 - DET(1) = DET(1)/CMPLX(TEN,0.0E0) - DET(2) = DET(2) + (1.0E0,0.0E0) - GO TO 30 - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE - RETURN - END diff --git a/slatec/cgbfa.f b/slatec/cgbfa.f deleted file mode 100644 index 5710746..0000000 --- a/slatec/cgbfa.f +++ /dev/null @@ -1,190 +0,0 @@ -*DECK CGBFA - SUBROUTINE CGBFA (ABD, LDA, N, ML, MU, IPVT, INFO) -C***BEGIN PROLOGUE CGBFA -C***PURPOSE Factor a band matrix using Gaussian elimination. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2C2 -C***TYPE COMPLEX (SGBFA-S, DGBFA-D, CGBFA-C) -C***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C CGBFA factors a complex band matrix by elimination. -C -C CGBFA is usually called by CGBCO, but it can be called -C directly with a saving in time if RCOND is not needed. -C -C On Entry -C -C ABD COMPLEX(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 CGBSL will divide by zero if -C called. Use RCOND in CGBCO 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 = MAX(1, J-MU) -C I2 = MIN(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***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CSCAL, ICAMAX -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CGBFA - INTEGER LDA,N,ML,MU,IPVT(*),INFO - COMPLEX ABD(LDA,*) -C - COMPLEX T - INTEGER I,ICAMAX,I0,J,JU,JZ,J0,J1,K,KP1,L,LM,M,MM,NM1 - COMPLEX ZDUM - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) -C -C***FIRST EXECUTABLE STATEMENT CGBFA - M = ML + MU + 1 - INFO = 0 -C -C ZERO INITIAL FILL-IN COLUMNS -C - J0 = MU + 2 - J1 = MIN(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.0E0,0.0E0) - 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.0E0,0.0E0) - 40 CONTINUE - 50 CONTINUE -C -C FIND L = PIVOT INDEX -C - LM = MIN(ML,N-K) - L = ICAMAX(LM+1,ABD(M,K),1) + M - 1 - IPVT(K) = L + K - M -C -C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED -C - IF (CABS1(ABD(L,K)) .EQ. 0.0E0) 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.0E0,0.0E0)/ABD(M,K) - CALL CSCAL(LM,T,ABD(M+1,K),1) -C -C ROW ELIMINATION WITH COLUMN INDEXING -C - JU = MIN(MAX(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 CAXPY(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 (CABS1(ABD(M,N)) .EQ. 0.0E0) INFO = N - RETURN - END diff --git a/slatec/cgbmv.f b/slatec/cgbmv.f deleted file mode 100644 index 9a2422f..0000000 --- a/slatec/cgbmv.f +++ /dev/null @@ -1,329 +0,0 @@ -*DECK CGBMV - SUBROUTINE CGBMV (TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY) -C***BEGIN PROLOGUE CGBMV -C***PURPOSE Multiply a complex vector by a complex general band matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE COMPLEX (SGBMV-S, DGBMV-D, CGBMV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C CGBMV performs one of the matrix-vector operations -C -C y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or -C -C y := alpha*conjg( A' )*x + beta*y, -C -C where alpha and beta are scalars, x and y are vectors and A is an -C m by n band matrix, with kl sub-diagonals and ku super-diagonals. -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the operation to be performed as -C follows: -C -C TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -C -C TRANS = 'T' or 't' y := alpha*A'*x + beta*y. -C -C TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y. -C -C Unchanged on exit. -C -C M - INTEGER. -C On entry, M specifies the number of rows of the matrix A. -C M must be at least zero. -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the number of columns of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C KL - INTEGER. -C On entry, KL specifies the number of sub-diagonals of the -C matrix A. KL must satisfy 0 .le. KL. -C Unchanged on exit. -C -C KU - INTEGER. -C On entry, KU specifies the number of super-diagonals of the -C matrix A. KU must satisfy 0 .le. KU. -C Unchanged on exit. -C -C ALPHA - COMPLEX . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C A - COMPLEX array of DIMENSION ( LDA, n ). -C Before entry, the leading ( kl + ku + 1 ) by n part of the -C array A must contain the matrix of coefficients, supplied -C column by column, with the leading diagonal of the matrix in -C row ( ku + 1 ) of the array, the first super-diagonal -C starting at position 2 in row ku, the first sub-diagonal -C starting at position 1 in row ( ku + 2 ), and so on. -C Elements in the array A that do not correspond to elements -C in the band matrix (such as the top left ku by ku triangle) -C are not referenced. -C The following program segment will transfer a band matrix -C from conventional full matrix storage to band storage: -C -C DO 20, J = 1, N -C K = KU + 1 - J -C DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) -C A( K + I, J ) = matrix( I, J ) -C 10 CONTINUE -C 20 CONTINUE -C -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C ( kl + ku + 1 ). -C Unchanged on exit. -C -C X - COMPLEX array of DIMENSION at least -C ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -C and at least -C ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -C Before entry, the incremented array X must contain the -C vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C BETA - COMPLEX . -C On entry, BETA specifies the scalar beta. When BETA is -C supplied as zero then Y need not be set on input. -C Unchanged on exit. -C -C Y - COMPLEX array of DIMENSION at least -C ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -C and at least -C ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -C Before entry, the incremented array Y must contain the -C vector y. On exit, Y is overwritten by the updated vector y. -C -C -C INCY - INTEGER. -C On entry, INCY specifies the increment for the elements of -C Y. INCY must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE CGBMV -C .. Scalar Arguments .. - COMPLEX ALPHA, BETA - INTEGER INCX, INCY, KL, KU, LDA, M, N - CHARACTER*1 TRANS -C .. Array Arguments .. - COMPLEX A( LDA, * ), X( * ), Y( * ) -C .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -C .. Local Scalars .. - COMPLEX TEMP - INTEGER I, INFO, IX, IY, J, JX, JY, K, KUP1, KX, KY, - $ LENX, LENY - LOGICAL NOCONJ -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC CONJG, MAX, MIN -C***FIRST EXECUTABLE STATEMENT CGBMV -C -C Test the input parameters. -C - 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( 'CGBMV ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C - NOCONJ = LSAME( TRANS, 'T' ) -C -C Set LENX and LENY, the lengths of the vectors x and y, and set -C up the start points in X and Y. -C - 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 -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through the band part of A. -C -C First form y := beta*y. -C - 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 -C -C Form y := alpha*A*x + y. -C - 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 -C -C Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. -C - JY = KY - IF( INCX.EQ.1 )THEN - DO 110, J = 1, N - TEMP = ZERO - K = KUP1 - J - IF( NOCONJ )THEN - DO 90, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + A( K + I, J )*X( I ) - 90 CONTINUE - ELSE - DO 100, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + CONJG( A( K + I, J ) )*X( I ) - 100 CONTINUE - END IF - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 110 CONTINUE - ELSE - DO 140, J = 1, N - TEMP = ZERO - IX = KX - K = KUP1 - J - IF( NOCONJ )THEN - DO 120, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + A( K + I, J )*X( IX ) - IX = IX + INCX - 120 CONTINUE - ELSE - DO 130, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + CONJG( A( K + I, J ) )*X( IX ) - IX = IX + INCX - 130 CONTINUE - END IF - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - IF( J.GT.KU ) - $ KX = KX + INCX - 140 CONTINUE - END IF - END IF -C - RETURN -C -C End of CGBMV . -C - END diff --git a/slatec/cgbsl.f b/slatec/cgbsl.f deleted file mode 100644 index fd94f41..0000000 --- a/slatec/cgbsl.f +++ /dev/null @@ -1,149 +0,0 @@ -*DECK CGBSL - SUBROUTINE CGBSL (ABD, LDA, N, ML, MU, IPVT, B, JOB) -C***BEGIN PROLOGUE CGBSL -C***PURPOSE Solve the complex band system A*X=B or CTRANS(A)*X=B using -C the factors computed by CGBCO or CGBFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2C2 -C***TYPE COMPLEX (SGBSL-S, DGBSL-D, CGBSL-C) -C***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C CGBSL solves the complex band system -C A * X = B or CTRANS(A) * X = B -C using the factors computed by CGBCO or CGBFA. -C -C On Entry -C -C ABD COMPLEX(LDA, N) -C the output from CGBCO or CGBFA. -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 CGBCO or CGBFA. -C -C B COMPLEX(N) -C the right hand side vector. -C -C JOB INTEGER -C = 0 to solve A*X = B , -C = nonzero to solve CTRANS(A)*X = B , where -C CTRANS(A) is the conjugate 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 CGBCO has set RCOND .GT. 0.0 -C or CGBFA has set INFO .EQ. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL CGBCO(ABD,LDA,N,ML,MU,IPVT,RCOND,Z) -C IF (RCOND is too small) GO TO ... -C DO 10 J = 1, P -C CALL CGBSL(ABD,LDA,N,ML,MU,IPVT,C(1,J),0) -C 10 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CDOTC -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CGBSL - INTEGER LDA,N,ML,MU,IPVT(*),JOB - COMPLEX ABD(LDA,*),B(*) -C - COMPLEX CDOTC,T - INTEGER K,KB,L,LA,LB,LM,M,NM1 -C***FIRST EXECUTABLE STATEMENT CGBSL - 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 = MIN(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 CAXPY(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 = MIN(K,M) - 1 - LA = M - LM - LB = K - LM - T = -B(K) - CALL CAXPY(LM,T,ABD(LA,K),1,B(LB),1) - 40 CONTINUE - GO TO 100 - 50 CONTINUE -C -C JOB = NONZERO, SOLVE CTRANS(A) * X = B -C FIRST SOLVE CTRANS(U)*Y = B -C - DO 60 K = 1, N - LM = MIN(K,M) - 1 - LA = M - LM - LB = K - LM - T = CDOTC(LM,ABD(LA,K),1,B(LB),1) - B(K) = (B(K) - T)/CONJG(ABD(M,K)) - 60 CONTINUE -C -C NOW SOLVE CTRANS(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 = MIN(ML,N-K) - B(K) = B(K) + CDOTC(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/slatec/cgeco.f b/slatec/cgeco.f deleted file mode 100644 index 7da7dad..0000000 --- a/slatec/cgeco.f +++ /dev/null @@ -1,211 +0,0 @@ -*DECK CGECO - SUBROUTINE CGECO (A, LDA, N, IPVT, RCOND, Z) -C***BEGIN PROLOGUE CGECO -C***PURPOSE Factor a matrix using Gaussian elimination and estimate -C the condition number of the matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2C1 -C***TYPE COMPLEX (SGECO-S, DGECO-D, CGECO-C) -C***KEYWORDS CONDITION NUMBER, GENERAL MATRIX, LINEAR ALGEBRA, LINPACK, -C MATRIX FACTORIZATION -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C CGECO factors a complex matrix by Gaussian elimination -C and estimates the condition of the matrix. -C -C If RCOND is not needed, CGEFA is slightly faster. -C To solve A*X = B , follow CGECO By CGESL. -C To Compute INVERSE(A)*C , follow CGECO by CGESL. -C To compute DETERMINANT(A) , follow CGECO by CGEDI. -C To compute INVERSE(A) , follow CGECO by CGEDI. -C -C On Entry -C -C A COMPLEX(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 REAL -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 COMPLEX(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***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CDOTC, CGEFA, CSSCAL, SCASUM -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CGECO - INTEGER LDA,N,IPVT(*) - COMPLEX A(LDA,*),Z(*) - REAL RCOND -C - COMPLEX CDOTC,EK,T,WK,WKM - REAL ANORM,S,SCASUM,SM,YNORM - INTEGER INFO,J,K,KB,KP1,L - COMPLEX ZDUM,ZDUM1,ZDUM2,CSIGN1 - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) - CSIGN1(ZDUM1,ZDUM2) = CABS1(ZDUM1)*(ZDUM2/CABS1(ZDUM2)) -C -C COMPUTE 1-NORM OF A -C -C***FIRST EXECUTABLE STATEMENT CGECO - ANORM = 0.0E0 - DO 10 J = 1, N - ANORM = MAX(ANORM,SCASUM(N,A(1,J),1)) - 10 CONTINUE -C -C FACTOR -C - CALL CGEFA(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 CTRANS(A)*Y = E . -C CTRANS(A) IS THE CONJUGATE TRANSPOSE OF A . -C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL -C GROWTH IN THE ELEMENTS OF W WHERE CTRANS(U)*W = E . -C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. -C -C SOLVE CTRANS(U)*W = E -C - EK = (1.0E0,0.0E0) - DO 20 J = 1, N - Z(J) = (0.0E0,0.0E0) - 20 CONTINUE - DO 100 K = 1, N - IF (CABS1(Z(K)) .NE. 0.0E0) EK = CSIGN1(EK,-Z(K)) - IF (CABS1(EK-Z(K)) .LE. CABS1(A(K,K))) GO TO 30 - S = CABS1(A(K,K))/CABS1(EK-Z(K)) - CALL CSSCAL(N,S,Z,1) - EK = CMPLX(S,0.0E0)*EK - 30 CONTINUE - WK = EK - Z(K) - WKM = -EK - Z(K) - S = CABS1(WK) - SM = CABS1(WKM) - IF (CABS1(A(K,K)) .EQ. 0.0E0) GO TO 40 - WK = WK/CONJG(A(K,K)) - WKM = WKM/CONJG(A(K,K)) - GO TO 50 - 40 CONTINUE - WK = (1.0E0,0.0E0) - WKM = (1.0E0,0.0E0) - 50 CONTINUE - KP1 = K + 1 - IF (KP1 .GT. N) GO TO 90 - DO 60 J = KP1, N - SM = SM + CABS1(Z(J)+WKM*CONJG(A(K,J))) - Z(J) = Z(J) + WK*CONJG(A(K,J)) - S = S + CABS1(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*CONJG(A(K,J)) - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - Z(K) = WK - 100 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) -C -C SOLVE CTRANS(L)*Y = W -C - DO 120 KB = 1, N - K = N + 1 - KB - IF (K .LT. N) Z(K) = Z(K) + CDOTC(N-K,A(K+1,K),1,Z(K+1),1) - IF (CABS1(Z(K)) .LE. 1.0E0) GO TO 110 - S = 1.0E0/CABS1(Z(K)) - CALL CSSCAL(N,S,Z,1) - 110 CONTINUE - L = IPVT(K) - T = Z(L) - Z(L) = Z(K) - Z(K) = T - 120 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) -C - YNORM = 1.0E0 -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 CAXPY(N-K,T,A(K+1,K),1,Z(K+1),1) - IF (CABS1(Z(K)) .LE. 1.0E0) GO TO 130 - S = 1.0E0/CABS1(Z(K)) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM - 130 CONTINUE - 140 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE U*Z = V -C - DO 160 KB = 1, N - K = N + 1 - KB - IF (CABS1(Z(K)) .LE. CABS1(A(K,K))) GO TO 150 - S = CABS1(A(K,K))/CABS1(Z(K)) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM - 150 CONTINUE - IF (CABS1(A(K,K)) .NE. 0.0E0) Z(K) = Z(K)/A(K,K) - IF (CABS1(A(K,K)) .EQ. 0.0E0) Z(K) = (1.0E0,0.0E0) - T = -Z(K) - CALL CAXPY(K-1,T,A(1,K),1,Z(1),1) - 160 CONTINUE -C MAKE ZNORM = 1.0 - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM -C - IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM - IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0 - RETURN - END diff --git a/slatec/cgedi.f b/slatec/cgedi.f deleted file mode 100644 index 95c7369..0000000 --- a/slatec/cgedi.f +++ /dev/null @@ -1,143 +0,0 @@ -*DECK CGEDI - SUBROUTINE CGEDI (A, LDA, N, IPVT, DET, WORK, JOB) -C***BEGIN PROLOGUE CGEDI -C***PURPOSE Compute the determinant and inverse of a matrix using the -C factors computed by CGECO or CGEFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2C1, D3C1 -C***TYPE COMPLEX (SGEDI-S, DGEDI-D, CGEDI-C) -C***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C CGEDI computes the determinant and inverse of a matrix -C using the factors computed by CGECO or CGEFA. -C -C On Entry -C -C A COMPLEX(LDA, N) -C the output from CGECO or CGEFA. -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 CGECO or CGEFA. -C -C WORK COMPLEX(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 COMPLEX(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. CABS1(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 CGECO has set RCOND .GT. 0.0 or CGEFA has set -C INFO .EQ. 0 . -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CSCAL, CSWAP -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CGEDI - INTEGER LDA,N,IPVT(*),JOB - COMPLEX A(LDA,*),DET(2),WORK(*) -C - COMPLEX T - REAL TEN - INTEGER I,J,K,KB,KP1,L,NM1 - COMPLEX ZDUM - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) -C***FIRST EXECUTABLE STATEMENT CGEDI -C -C COMPUTE DETERMINANT -C - IF (JOB/10 .EQ. 0) GO TO 70 - DET(1) = (1.0E0,0.0E0) - DET(2) = (0.0E0,0.0E0) - TEN = 10.0E0 - DO 50 I = 1, N - IF (IPVT(I) .NE. I) DET(1) = -DET(1) - DET(1) = A(I,I)*DET(1) - IF (CABS1(DET(1)) .EQ. 0.0E0) GO TO 60 - 10 IF (CABS1(DET(1)) .GE. 1.0E0) GO TO 20 - DET(1) = CMPLX(TEN,0.0E0)*DET(1) - DET(2) = DET(2) - (1.0E0,0.0E0) - GO TO 10 - 20 CONTINUE - 30 IF (CABS1(DET(1)) .LT. TEN) GO TO 40 - DET(1) = DET(1)/CMPLX(TEN,0.0E0) - DET(2) = DET(2) + (1.0E0,0.0E0) - 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.0E0,0.0E0)/A(K,K) - T = -A(K,K) - CALL CSCAL(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.0E0,0.0E0) - CALL CAXPY(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.0E0,0.0E0) - 110 CONTINUE - DO 120 J = KP1, N - T = WORK(J) - CALL CAXPY(N,T,A(1,J),1,A(1,K),1) - 120 CONTINUE - L = IPVT(K) - IF (L .NE. K) CALL CSWAP(N,A(1,K),1,A(1,L),1) - 130 CONTINUE - 140 CONTINUE - 150 CONTINUE - RETURN - END diff --git a/slatec/cgeev.f b/slatec/cgeev.f deleted file mode 100644 index 68ea84d..0000000 --- a/slatec/cgeev.f +++ /dev/null @@ -1,187 +0,0 @@ -*DECK CGEEV - SUBROUTINE CGEEV (A, LDA, N, E, V, LDV, WORK, JOB, INFO) -C***BEGIN PROLOGUE CGEEV -C***PURPOSE Compute the eigenvalues and, optionally, the eigenvectors -C of a complex general matrix. -C***LIBRARY SLATEC -C***CATEGORY D4A4 -C***TYPE COMPLEX (SGEEV-S, CGEEV-C) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, GENERAL MATRIX -C***AUTHOR Kahaner, D. K., (NBS) -C Moler, C. B., (U. of New Mexico) -C Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C Abstract -C CGEEV computes the eigenvalues and, optionally, -C the eigenvectors of a general complex matrix. -C -C Call Sequence Parameters- -C (The values of parameters marked with * (star) will be changed -C by CGEEV.) -C -C A* COMPLEX(LDA,N) -C complex nonsymmetric input matrix. -C -C LDA INTEGER -C set by the user to -C the leading dimension of the complex array A. -C -C N INTEGER -C set by the user to -C the order of the matrices A and V, and -C the number of elements in E. -C -C E* COMPLEX(N) -C on return from CGEEV E contains the eigenvalues of A. -C See also INFO below. -C -C V* COMPLEX(LDV,N) -C on return from CGEEV if the user has set JOB -C = 0 V is not referenced. -C = nonzero the N eigenvectors of A are stored in the -C first N columns of V. See also INFO below. -C (If the input matrix A is nearly degenerate, V -C will be badly conditioned, i.e. have nearly -C dependent columns.) -C -C LDV INTEGER -C set by the user to -C the leading dimension of the array V if JOB is also -C set nonzero. In that case N must be .LE. LDV. -C If JOB is set to zero LDV is not referenced. -C -C WORK* REAL(3N) -C temporary storage vector. Contents changed by CGEEV. -C -C JOB INTEGER -C set by the user to -C = 0 eigenvalues only to be calculated by CGEEV. -C neither V nor LDV are referenced. -C = nonzero eigenvalues and vectors to be calculated. -C In this case A & V must be distinct arrays. -C Also, if LDA > LDV, CGEEV changes all the -C elements of A thru column N. If LDA < LDV, -C CGEEV changes all the elements of V through -C column N. If LDA = LDV only A(I,J) and V(I, -C J) for I,J = 1,...,N are changed by CGEEV. -C -C INFO* INTEGER -C on return from CGEEV the value of INFO is -C = 0 normal return, calculation successful. -C = K if the eigenvalue iteration fails to converge, -C eigenvalues K+1 through N are correct, but -C no eigenvectors were computed even if they were -C requested (JOB nonzero). -C -C Error Messages -C No. 1 recoverable N is greater than LDA -C No. 2 recoverable N is less than one. -C No. 3 recoverable JOB is nonzero and N is greater than LDV -C No. 4 warning LDA > LDV, elements of A other than the -C N by N input elements have been changed -C No. 5 warning LDA < LDV, elements of V other than the -C N by N output elements have been changed -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CBABK2, CBAL, COMQR, COMQR2, CORTH, SCOPY, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800808 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE CGEEV - INTEGER I,IHI,ILO,INFO,J,K,L,LDA,LDV,MDIM,N - REAL A(*),E(*),WORK(*),V(*) -C***FIRST EXECUTABLE STATEMENT CGEEV - IF (N .GT. LDA) CALL XERMSG ('SLATEC', 'CGEEV', 'N .GT. LDA.', 1, - + 1) - IF(N .GT. LDA) RETURN - IF (N .LT. 1) CALL XERMSG ('SLATEC', 'CGEEV', 'N .LT. 1', 2, 1) - IF(N .LT. 1) RETURN - IF(N .EQ. 1 .AND. JOB .EQ. 0) GO TO 35 - MDIM = 2 * LDA - IF(JOB .EQ. 0) GO TO 5 - IF (N .GT. LDV) CALL XERMSG ('SLATEC', 'CGEEV', - + 'JOB .NE. 0 AND N .GT. LDV.', 3, 1) - IF(N .GT. LDV) RETURN - IF(N .EQ. 1) GO TO 35 -C -C REARRANGE A IF NECESSARY WHEN LDA.GT.LDV AND JOB .NE.0 -C - MDIM = MIN(MDIM,2 * LDV) - IF (LDA .LT. LDV) CALL XERMSG ('SLATEC', 'CGEEV', - + 'LDA.LT.LDV, ELEMENTS OF V OTHER THAN THE N BY N OUTPUT ' // - + 'ELEMENTS HAVE BEEN CHANGED.', 5, 0) - IF(LDA.LE.LDV) GO TO 5 - CALL XERMSG ('SLATEC', 'CGEEV', - + 'LDA.GT.LDV, ELEMENTS OF A OTHER THAN THE N BY N INPUT ' // - + 'ELEMENTS HAVE BEEN CHANGED.', 4, 0) - L = N - 1 - DO 4 J=1,L - I = 2 * N - M = 1+J*2*LDV - K = 1+J*2*LDA - CALL SCOPY(I,A(K),1,A(M),1) - 4 CONTINUE - 5 CONTINUE -C -C SEPARATE REAL AND IMAGINARY PARTS -C - DO 6 J = 1, N - K = (J-1) * MDIM +1 - L = K + N - CALL SCOPY(N,A(K+1),2,WORK(1),1) - CALL SCOPY(N,A(K),2,A(K),1) - CALL SCOPY(N,WORK(1),1,A(L),1) - 6 CONTINUE -C -C SCALE AND ORTHOGONAL REDUCTION TO HESSENBERG. -C - CALL CBAL(MDIM,N,A(1),A(N+1),ILO,IHI,WORK(1)) - CALL CORTH(MDIM,N,ILO,IHI,A(1),A(N+1),WORK(N+1),WORK(2*N+1)) - IF(JOB .NE. 0) GO TO 10 -C -C EIGENVALUES ONLY -C - CALL COMQR(MDIM,N,ILO,IHI,A(1),A(N+1),E(1),E(N+1),INFO) - GO TO 30 -C -C EIGENVALUES AND EIGENVECTORS. -C - 10 CALL COMQR2(MDIM,N,ILO,IHI,WORK(N+1),WORK(2*N+1),A(1),A(N+1), - 1 E(1),E(N+1),V(1),V(N+1),INFO) - IF (INFO .NE. 0) GO TO 30 - CALL CBABK2(MDIM,N,ILO,IHI,WORK(1),N,V(1),V(N+1)) -C -C CONVERT EIGENVECTORS TO COMPLEX STORAGE. -C - DO 20 J = 1,N - K = (J-1) * MDIM + 1 - I = (J-1) * 2 * LDV + 1 - L = K + N - CALL SCOPY(N,V(K),1,WORK(1),1) - CALL SCOPY(N,V(L),1,V(I+1),2) - CALL SCOPY(N,WORK(1),1,V(I),2) - 20 CONTINUE -C -C CONVERT EIGENVALUES TO COMPLEX STORAGE. -C - 30 CALL SCOPY(N,E(1),1,WORK(1),1) - CALL SCOPY(N,E(N+1),1,E(2),2) - CALL SCOPY(N,WORK(1),1,E(1),2) - RETURN -C -C TAKE CARE OF N=1 CASE -C - 35 E(1) = A(1) - E(2) = A(2) - INFO = 0 - IF(JOB .EQ. 0) RETURN - V(1) = A(1) - V(2) = A(2) - RETURN - END diff --git a/slatec/cgefa.f b/slatec/cgefa.f deleted file mode 100644 index 97194ce..0000000 --- a/slatec/cgefa.f +++ /dev/null @@ -1,120 +0,0 @@ -*DECK CGEFA - SUBROUTINE CGEFA (A, LDA, N, IPVT, INFO) -C***BEGIN PROLOGUE CGEFA -C***PURPOSE Factor a matrix using Gaussian elimination. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2C1 -C***TYPE COMPLEX (SGEFA-S, DGEFA-D, CGEFA-C) -C***KEYWORDS GENERAL MATRIX, LINEAR ALGEBRA, LINPACK, -C MATRIX FACTORIZATION -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C CGEFA factors a complex matrix by Gaussian elimination. -C -C CGEFA is usually called by CGECO, but it can be called -C directly with a saving in time if RCOND is not needed. -C (Time for CGECO) = (1 + 9/N)*(Time for CGEFA) . -C -C On Entry -C -C A COMPLEX(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 CGESL or CGEDI will divide by zero -C if called. Use RCOND in CGECO for a reliable -C indication of singularity. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CSCAL, ICAMAX -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CGEFA - INTEGER LDA,N,IPVT(*),INFO - COMPLEX A(LDA,*) -C - COMPLEX T - INTEGER ICAMAX,J,K,KP1,L,NM1 - COMPLEX ZDUM - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) -C -C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING -C -C***FIRST EXECUTABLE STATEMENT CGEFA - 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 = ICAMAX(N-K+1,A(K,K),1) + K - 1 - IPVT(K) = L -C -C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED -C - IF (CABS1(A(L,K)) .EQ. 0.0E0) 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.0E0,0.0E0)/A(K,K) - CALL CSCAL(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 CAXPY(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 (CABS1(A(N,N)) .EQ. 0.0E0) INFO = N - RETURN - END diff --git a/slatec/cgefs.f b/slatec/cgefs.f deleted file mode 100644 index 44ac1d6..0000000 --- a/slatec/cgefs.f +++ /dev/null @@ -1,168 +0,0 @@ -*DECK CGEFS - SUBROUTINE CGEFS (A, LDA, N, V, ITASK, IND, WORK, IWORK) -C***BEGIN PROLOGUE CGEFS -C***PURPOSE Solve a general system of linear equations. -C***LIBRARY SLATEC -C***CATEGORY D2C1 -C***TYPE COMPLEX (SGEFS-S, DGEFS-D, CGEFS-C) -C***KEYWORDS COMPLEX LINEAR EQUATIONS, GENERAL MATRIX, -C GENERAL SYSTEM OF LINEAR EQUATIONS -C***AUTHOR Voorhees, E. A., (LANL) -C***DESCRIPTION -C -C Subroutine CGEFS solves A general NxN system of complex -C linear equations using LINPACK subroutines CGECO -C and CGESL. That is, if A is an NxN complex matrix -C and if X and B are complex N-vectors, then CGEFS -C solves the equation -C -C A*X=B. -C -C The matrix A is first factored into upper and lower tri- -C angular matrices U and L using partial pivoting. These -C factors and the pivoting information are used to find the -C solution vector X. An approximate condition number is -C calculated to provide a rough estimate of the number of -C digits of accuracy in the computed solution. -C -C If the equation A*X=B is to be solved for more than one vector -C B, the factoring of A does not need to be performed again and -C the option to only solve (ITASK .GT. 1) will be faster for -C the succeeding solutions. In this case, the contents of A, -C LDA, N and IWORK must not have been altered by the user follow- -C ing factorization (ITASK=1). IND will not be changed by CGEFS -C in this case. -C -C Argument Description *** -C -C A COMPLEX(LDA,N) -C on entry, the doubly subscripted array with dimension -C (LDA,N) which contains the coefficient matrix. -C on return, an upper triangular matrix U and the -C multipliers necessary to construct a matrix L -C so that A=L*U. -C LDA INTEGER -C the leading dimension of the array A. LDA must be great- -C er than or equal to N. (Terminal error message IND=-1) -C N INTEGER -C the order of the matrix A. The first N elements of -C the array A are the elements of the first column of -C the matrix A. N must be greater than or equal to 1. -C (Terminal error message IND=-2) -C V COMPLEX(N) -C on entry, the singly subscripted array(vector) of di- -C mension N which contains the right hand side B of a -C system of simultaneous linear equations A*X=B. -C on return, V contains the solution vector, X . -C ITASK INTEGER -C if ITASK=1, the matrix A is factored and then the -C linear equation is solved. -C if ITASK .GT. 1, the equation is solved using the existing -C factored matrix A and IWORK. -C if ITASK .LT. 1, then terminal error message IND=-3 is -C printed. -C IND INTEGER -C GT.0 IND is a rough estimate of the number of digits -C of accuracy in the solution, X. -C LT.0 see error message corresponding to IND below. -C WORK COMPLEX(N) -C a singly subscripted array of dimension at least N. -C IWORK INTEGER(N) -C a singly subscripted array of dimension at least N. -C -C Error Messages Printed *** -C -C IND=-1 terminal N is greater than LDA. -C IND=-2 terminal N is less than 1. -C IND=-3 terminal ITASK is less than 1. -C IND=-4 terminal The matrix A is computationally singular. -C A solution has not been computed. -C IND=-10 warning The solution has no apparent significance. -C The solution may be inaccurate or the matrix -C A may be poorly scaled. -C -C NOTE- The above terminal(*fatal*) error messages are -C designed to be handled by XERMSG in which -C LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 -C for warning error messages from XERMSG. Unless -C the user provides otherwise, an error message -C will be printed followed by an abort. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CGECO, CGESL, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800328 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900510 Convert XERRWV calls to XERMSG calls, cvt GOTO's to -C IF-THEN-ELSE. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CGEFS -C - INTEGER LDA,N,ITASK,IND,IWORK(*) - COMPLEX A(LDA,*),V(*),WORK(*) - REAL R1MACH - REAL RCOND - CHARACTER*8 XERN1, XERN2 -C***FIRST EXECUTABLE STATEMENT CGEFS - IF (LDA.LT.N) THEN - IND = -1 - WRITE (XERN1, '(I8)') LDA - WRITE (XERN2, '(I8)') N - CALL XERMSG ('SLATEC', 'CGEFS', 'LDA = ' // XERN1 // - * ' IS LESS THAN N = ' // XERN2, -1, 1) - RETURN - ENDIF -C - IF (N.LE.0) THEN - IND = -2 - WRITE (XERN1, '(I8)') N - CALL XERMSG ('SLATEC', 'CGEFS', 'N = ' // XERN1 // - * ' IS LESS THAN 1', -2, 1) - RETURN - ENDIF -C - IF (ITASK.LT.1) THEN - IND = -3 - WRITE (XERN1, '(I8)') ITASK - CALL XERMSG ('SLATEC', 'CGEFS', 'ITASK = ' // XERN1 // - * ' IS LESS THAN 1', -3, 1) - RETURN - ENDIF -C -C FACTOR MATRIX A INTO LU -C - IF (ITASK.EQ.1) THEN - CALL CGECO(A,LDA,N,IWORK,RCOND,WORK) -C -C CHECK FOR COMPUTATIONALLY SINGULAR MATRIX -C - IF (RCOND.EQ.0.0) THEN - IND = -4 - CALL XERMSG ('SLATEC', 'CGEFS', - * 'SINGULAR MATRIX A - NO SOLUTION', -4, 1) - RETURN - ENDIF -C -C COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) -C - IND = -LOG10(R1MACH(4)/RCOND) -C -C CHECK FOR IND GREATER THAN ZERO -C - IF (IND.LE.0) THEN - IND = -10 - CALL XERMSG ('SLATEC', 'CGEFS', - * 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) - ENDIF - ENDIF -C -C SOLVE AFTER FACTORING -C - CALL CGESL(A,LDA,N,IWORK,V,0) - RETURN - END diff --git a/slatec/cgeir.f b/slatec/cgeir.f deleted file mode 100644 index 7d93f4e..0000000 --- a/slatec/cgeir.f +++ /dev/null @@ -1,198 +0,0 @@ -*DECK CGEIR - SUBROUTINE CGEIR (A, LDA, N, V, ITASK, IND, WORK, IWORK) -C***BEGIN PROLOGUE CGEIR -C***PURPOSE Solve a general system of linear equations. Iterative -C refinement is used to obtain an error estimate. -C***LIBRARY SLATEC -C***CATEGORY D2C1 -C***TYPE COMPLEX (SGEIR-S, CGEIR-C) -C***KEYWORDS COMPLEX LINEAR EQUATIONS, GENERAL MATRIX, -C GENERAL SYSTEM OF LINEAR EQUATIONS -C***AUTHOR Voorhees, E. A., (LANL) -C***DESCRIPTION -C -C Subroutine CGEIR solves a general NxN system of complex -C linear equations using LINPACK subroutines CGEFA and CGESL. -C One pass of iterative refinement is used only to obtain an -C estimate of the accuracy. That is, if A is an NxN complex -C matrix and if X and B are complex N-vectors, then CGEIR solves -C the equation -C -C A*X=B. -C -C The matrix A is first factored into upper and lower tri- -C angular matrices U and L using partial pivoting. These -C factors and the pivoting information are used to calculate -C the solution, X. Then the residual vector is found and -C used to calculate an estimate of the relative error, IND. -C IND estimates the accuracy of the solution only when the -C input matrix and the right hand side are represented -C exactly in the computer and does not take into -C account any errors in the input data. -C -C If the equation A*X=B is to be solved for more than one vector -C B, the factoring of A does not need to be performed again and -C the option to only solve (ITASK .GT. 1) will be faster for -C the succeeding solutions. In this case, the contents of A, -C LDA, N, WORK, and IWORK must not have been altered by the -C user following factorization (ITASK=1). IND will not be -C changed by CGEIR in this case. -C -C Argument Description *** -C -C A COMPLEX(LDA,N) -C the doubly subscripted array with dimension (LDA,N) -C which contains the coefficient matrix. A is not -C altered by the routine. -C LDA INTEGER -C the leading dimension of the array A. LDA must be great- -C er than or equal to N. (Terminal error message IND=-1) -C N INTEGER -C the order of the matrix A. The first N elements of -C the array A are the elements of the first column of -C matrix A. N must be greater than or equal to 1. -C (Terminal error message IND=-2) -C V COMPLEX(N) -C on entry, the singly subscripted array(vector) of di- -C mension N which contains the right hand side B of a -C system of simultaneous linear equations A*X=B. -C on return, V contains the solution vector, X . -C ITASK INTEGER -C if ITASK=1, the matrix A is factored and then the -C linear equation is solved. -C if ITASK .GT. 1, the equation is solved using the existing -C factored matrix A (stored in work). -C if ITASK .LT. 1, then terminal error message IND=-3 is -C printed. -C IND INTEGER -C GT.0 IND is a rough estimate of the number of digits -C of accuracy in the solution, X. IND=75 means -C that the solution vector X is zero. -C LT.0 see error message corresponding to IND below. -C WORK COMPLEX(N*(N+1)) -C a singly subscripted array of dimension at least N*(N+1). -C IWORK INTEGER(N) -C a singly subscripted array of dimension at least N. -C -C Error Messages Printed *** -C -C IND=-1 terminal N is greater than LDA. -C IND=-2 terminal N is less than one. -C IND=-3 terminal ITASK is less than one. -C IND=-4 terminal The matrix A is computationally singular. -C A solution has not been computed. -C IND=-10 warning The solution has no apparent significance. -C The solution may be inaccurate or the matrix -C A may be poorly scaled. -C -C NOTE- The above terminal(*fatal*) error messages are -C designed to be handled by XERMSG in which -C LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 -C for warning error messages from XERMSG. Unless -C the user provides otherwise, an error message -C will be printed followed by an abort. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CCOPY, CDCDOT, CGEFA, CGESL, R1MACH, SCASUM, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800502 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900510 Convert XERRWV calls to XERMSG calls, cvt GOTO's to -C IF-THEN-ELSE. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CGEIR -C - INTEGER LDA,N,ITASK,IND,IWORK(*),INFO,J - COMPLEX A(LDA,*),V(*),WORK(N,*),CDCDOT - REAL SCASUM,XNORM,DNORM,R1MACH - CHARACTER*8 XERN1, XERN2 -C***FIRST EXECUTABLE STATEMENT CGEIR - IF (LDA.LT.N) THEN - IND = -1 - WRITE (XERN1, '(I8)') LDA - WRITE (XERN2, '(I8)') N - CALL XERMSG ('SLATEC', 'CGEIR', 'LDA = ' // XERN1 // - * ' IS LESS THAN N = ' // XERN2, -1, 1) - RETURN - ENDIF -C - IF (N.LE.0) THEN - IND = -2 - WRITE (XERN1, '(I8)') N - CALL XERMSG ('SLATEC', 'CGEIR', 'N = ' // XERN1 // - * ' IS LESS THAN 1', -2, 1) - RETURN - ENDIF -C - IF (ITASK.LT.1) THEN - IND = -3 - WRITE (XERN1, '(I8)') ITASK - CALL XERMSG ('SLATEC', 'CGEIR', 'ITASK = ' // XERN1 // - * ' IS LESS THAN 1', -3, 1) - RETURN - ENDIF -C - IF (ITASK.EQ.1) THEN -C MOVE MATRIX A TO WORK - DO 10 J=1,N - CALL CCOPY(N,A(1,J),1,WORK(1,J),1) - 10 CONTINUE -C -C FACTOR MATRIX A INTO LU -C - CALL CGEFA(WORK,N,N,IWORK,INFO) -C -C CHECK FOR COMPUTATIONALLY SINGULAR MATRIX -C - IF (INFO.NE.0) THEN - IND = -4 - CALL XERMSG ('SLATEC', 'CGEIR', - * 'SINGULAR MATRIX A - NO SOLUTION', -4, 1) - RETURN - ENDIF - ENDIF -C -C SOLVE WHEN FACTORING COMPLETE -C MOVE VECTOR B TO WORK -C - CALL CCOPY(N,V(1),1,WORK(1,N+1),1) - CALL CGESL(WORK,N,N,IWORK,V,0) -C -C FORM NORM OF X0 -C - XNORM = SCASUM(N,V(1),1) - IF (XNORM.EQ.0.0) THEN - IND = 75 - RETURN - ENDIF -C -C COMPUTE RESIDUAL -C - DO 40 J=1,N - WORK(J,N+1) = CDCDOT(N,-WORK(J,N+1),A(J,1),LDA,V,1) - 40 CONTINUE -C -C SOLVE A*DELTA=R -C - CALL CGESL(WORK,N,N,IWORK,WORK(1,N+1),0) -C -C FORM NORM OF DELTA -C - DNORM = SCASUM(N,WORK(1,N+1),1) -C -C COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) -C AND CHECK FOR IND GREATER THAN ZERO -C - IND = -LOG10(MAX(R1MACH(4),DNORM/XNORM)) - IF (IND.LE.0) THEN - IND = -10 - CALL XERMSG ('SLATEC', 'CGEIR', - * 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) - ENDIF - RETURN - END diff --git a/slatec/cgemm.f b/slatec/cgemm.f deleted file mode 100644 index 08f4f0d..0000000 --- a/slatec/cgemm.f +++ /dev/null @@ -1,421 +0,0 @@ -*DECK CGEMM - SUBROUTINE CGEMM (TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC) -C***BEGIN PROLOGUE CGEMM -C***PURPOSE Multiply a complex general matrix by a complex general -C matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B6 -C***TYPE COMPLEX (SGEMM-S, DGEMM-D, CGEMM-C) -C***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J., (ANL) -C Duff, I., (AERE) -C Du Croz, J., (NAG) -C Hammarling, S. (NAG) -C***DESCRIPTION -C -C CGEMM performs one of the matrix-matrix operations -C -C C := alpha*op( A )*op( B ) + beta*C, -C -C where op( X ) is one of -C -C op( X ) = X or op( X ) = X' or op( X ) = conjg( X' ), -C -C alpha and beta are scalars, and A, B and C are matrices, with op( A ) -C an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. -C -C Parameters -C ========== -C -C TRANSA - CHARACTER*1. -C On entry, TRANSA specifies the form of op( A ) to be used in -C the matrix multiplication as follows: -C -C TRANSA = 'N' or 'n', op( A ) = A. -C -C TRANSA = 'T' or 't', op( A ) = A'. -C -C TRANSA = 'C' or 'c', op( A ) = conjg( A' ). -C -C Unchanged on exit. -C -C TRANSB - CHARACTER*1. -C On entry, TRANSB specifies the form of op( B ) to be used in -C the matrix multiplication as follows: -C -C TRANSB = 'N' or 'n', op( B ) = B. -C -C TRANSB = 'T' or 't', op( B ) = B'. -C -C TRANSB = 'C' or 'c', op( B ) = conjg( B' ). -C -C Unchanged on exit. -C -C M - INTEGER. -C On entry, M specifies the number of rows of the matrix -C op( A ) and of the matrix C. M must be at least zero. -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the number of columns of the matrix -C op( B ) and the number of columns of the matrix C. N must be -C at least zero. -C Unchanged on exit. -C -C K - INTEGER. -C On entry, K specifies the number of columns of the matrix -C op( A ) and the number of rows of the matrix op( B ). K must -C be at least zero. -C Unchanged on exit. -C -C ALPHA - COMPLEX . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is -C k when TRANSA = 'N' or 'n', and is m otherwise. -C Before entry with TRANSA = 'N' or 'n', the leading m by k -C part of the array A must contain the matrix A, otherwise -C the leading k by m part of the array A must contain the -C matrix A. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. When TRANSA = 'N' or 'n' then -C LDA must be at least max( 1, m ), otherwise LDA must be at -C least max( 1, k ). -C Unchanged on exit. -C -C B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is -C n when TRANSB = 'N' or 'n', and is k otherwise. -C Before entry with TRANSB = 'N' or 'n', the leading k by n -C part of the array B must contain the matrix B, otherwise -C the leading n by k part of the array B must contain the -C matrix B. -C Unchanged on exit. -C -C LDB - INTEGER. -C On entry, LDB specifies the first dimension of B as declared -C in the calling (sub) program. When TRANSB = 'N' or 'n' then -C LDB must be at least max( 1, k ), otherwise LDB must be at -C least max( 1, n ). -C Unchanged on exit. -C -C BETA - COMPLEX . -C On entry, BETA specifies the scalar beta. When BETA is -C supplied as zero then C need not be set on input. -C Unchanged on exit. -C -C C - COMPLEX array of DIMENSION ( LDC, n ). -C Before entry, the leading m by n part of the array C must -C contain the matrix C, except when beta is zero, in which -C case C need not be set on entry. -C On exit, the array C is overwritten by the m by n matrix -C ( alpha*op( A )*op( B ) + beta*C ). -C -C LDC - INTEGER. -C On entry, LDC specifies the first dimension of C as declared -C in the calling (sub) program. LDC must be at least -C max( 1, m ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. -C A set of level 3 basic linear algebra subprograms. -C ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 890208 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE CGEMM -C .. Scalar Arguments .. - CHARACTER*1 TRANSA, TRANSB - INTEGER M, N, K, LDA, LDB, LDC - COMPLEX ALPHA, BETA -C .. Array Arguments .. - COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC CONJG, MAX -C .. Local Scalars .. - LOGICAL CONJA, CONJB, NOTA, NOTB - INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB - COMPLEX TEMP -C .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -C***FIRST EXECUTABLE STATEMENT CGEMM -C -C Set NOTA and NOTB as true if A and B respectively are not -C conjugated or transposed, set CONJA and CONJB as true if A and -C B respectively are to be transposed but not conjugated and set -C NROWA, NCOLA and NROWB as the number of rows and columns of A -C and the number of rows of B respectively. -C - NOTA = LSAME( TRANSA, 'N' ) - NOTB = LSAME( TRANSB, 'N' ) - CONJA = LSAME( TRANSA, 'C' ) - CONJB = LSAME( TRANSB, 'C' ) - IF( NOTA )THEN - NROWA = M - NCOLA = K - ELSE - NROWA = K - NCOLA = M - END IF - IF( NOTB )THEN - NROWB = K - ELSE - NROWB = N - END IF -C -C Test the input parameters. -C - INFO = 0 - IF( ( .NOT.NOTA ).AND. - $ ( .NOT.CONJA ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.NOTB ).AND. - $ ( .NOT.CONJB ).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( 'CGEMM ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C And when alpha.eq.zero. -C - 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 -C -C Start the operations. -C - IF( NOTB )THEN - IF( NOTA )THEN -C -C Form C := alpha*A*B + beta*C. -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 IF( CONJA )THEN -C -C Form C := alpha*conjg( A' )*B + beta*C. -C - DO 120, J = 1, N - DO 110, I = 1, M - TEMP = ZERO - DO 100, L = 1, K - TEMP = TEMP + CONJG( 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 - ELSE -C -C Form C := alpha*A'*B + beta*C -C - DO 150, J = 1, N - DO 140, I = 1, M - TEMP = ZERO - DO 130, L = 1, K - TEMP = TEMP + A( L, I )*B( L, J ) - 130 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 140 CONTINUE - 150 CONTINUE - END IF - ELSE IF( NOTA )THEN - IF( CONJB )THEN -C -C Form C := alpha*A*conjg( B' ) + beta*C. -C - DO 200, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 160, I = 1, M - C( I, J ) = ZERO - 160 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 170, I = 1, M - C( I, J ) = BETA*C( I, J ) - 170 CONTINUE - END IF - DO 190, L = 1, K - IF( B( J, L ).NE.ZERO )THEN - TEMP = ALPHA*CONJG( B( J, L ) ) - DO 180, I = 1, M - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 180 CONTINUE - END IF - 190 CONTINUE - 200 CONTINUE - ELSE -C -C Form C := alpha*A*B' + beta*C -C - DO 250, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 210, I = 1, M - C( I, J ) = ZERO - 210 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 220, I = 1, M - C( I, J ) = BETA*C( I, J ) - 220 CONTINUE - END IF - DO 240, L = 1, K - IF( B( J, L ).NE.ZERO )THEN - TEMP = ALPHA*B( J, L ) - DO 230, I = 1, M - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 230 CONTINUE - END IF - 240 CONTINUE - 250 CONTINUE - END IF - ELSE IF( CONJA )THEN - IF( CONJB )THEN -C -C Form C := alpha*conjg( A' )*conjg( B' ) + beta*C. -C - DO 280, J = 1, N - DO 270, I = 1, M - TEMP = ZERO - DO 260, L = 1, K - TEMP = TEMP + CONJG( A( L, I ) )*CONJG( B( J, L ) ) - 260 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 270 CONTINUE - 280 CONTINUE - ELSE -C -C Form C := alpha*conjg( A' )*B' + beta*C -C - DO 310, J = 1, N - DO 300, I = 1, M - TEMP = ZERO - DO 290, L = 1, K - TEMP = TEMP + CONJG( A( L, I ) )*B( J, L ) - 290 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 300 CONTINUE - 310 CONTINUE - END IF - ELSE - IF( CONJB )THEN -C -C Form C := alpha*A'*conjg( B' ) + beta*C -C - DO 340, J = 1, N - DO 330, I = 1, M - TEMP = ZERO - DO 320, L = 1, K - TEMP = TEMP + A( L, I )*CONJG( B( J, L ) ) - 320 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 330 CONTINUE - 340 CONTINUE - ELSE -C -C Form C := alpha*A'*B' + beta*C -C - DO 370, J = 1, N - DO 360, I = 1, M - TEMP = ZERO - DO 350, L = 1, K - TEMP = TEMP + A( L, I )*B( J, L ) - 350 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 360 CONTINUE - 370 CONTINUE - END IF - END IF -C - RETURN -C -C End of CGEMM . -C - END diff --git a/slatec/cgemv.f b/slatec/cgemv.f deleted file mode 100644 index 4885bc6..0000000 --- a/slatec/cgemv.f +++ /dev/null @@ -1,288 +0,0 @@ -*DECK CGEMV - SUBROUTINE CGEMV (TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, - $ INCY) -C***BEGIN PROLOGUE CGEMV -C***PURPOSE Multiply a complex vector by a complex general matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE COMPLEX (SGEMV-S, DGEMV-D, CGEMV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C CGEMV performs one of the matrix-vector operations -C -C y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or -C -C y := alpha*conjg( A' )*x + beta*y, -C -C where alpha and beta are scalars, x and y are vectors and A is an -C m by n matrix. -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the operation to be performed as -C follows: -C -C TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -C -C TRANS = 'T' or 't' y := alpha*A'*x + beta*y. -C -C TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y. -C -C Unchanged on exit. -C -C M - INTEGER. -C On entry, M specifies the number of rows of the matrix A. -C M must be at least zero. -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the number of columns of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - COMPLEX . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C A - COMPLEX array of DIMENSION ( LDA, n ). -C Before entry, the leading m by n part of the array A must -C contain the matrix of coefficients. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C max( 1, m ). -C Unchanged on exit. -C -C X - COMPLEX array of DIMENSION at least -C ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -C and at least -C ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -C Before entry, the incremented array X must contain the -C vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C BETA - COMPLEX . -C On entry, BETA specifies the scalar beta. When BETA is -C supplied as zero then Y need not be set on input. -C Unchanged on exit. -C -C Y - COMPLEX array of DIMENSION at least -C ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -C and at least -C ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -C Before entry with BETA non-zero, the incremented array Y -C must contain the vector y. On exit, Y is overwritten by the -C updated vector y. -C -C INCY - INTEGER. -C On entry, INCY specifies the increment for the elements of -C Y. INCY must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE CGEMV -C .. Scalar Arguments .. - COMPLEX ALPHA, BETA - INTEGER INCX, INCY, LDA, M, N - CHARACTER*1 TRANS -C .. Array Arguments .. - COMPLEX A( LDA, * ), X( * ), Y( * ) -C .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -C .. Local Scalars .. - COMPLEX TEMP - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY - LOGICAL NOCONJ -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC CONJG, MAX -C***FIRST EXECUTABLE STATEMENT CGEMV -C -C Test the input parameters. -C - 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( 'CGEMV ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C - NOCONJ = LSAME( TRANS, 'T' ) -C -C Set LENX and LENY, the lengths of the vectors x and y, and set -C up the start points in X and Y. -C - 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 -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through A. -C -C First form y := beta*y. -C - 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 -C -C Form y := alpha*A*x + y. -C - 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 -C -C Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. -C - JY = KY - IF( INCX.EQ.1 )THEN - DO 110, J = 1, N - TEMP = ZERO - IF( NOCONJ )THEN - DO 90, I = 1, M - TEMP = TEMP + A( I, J )*X( I ) - 90 CONTINUE - ELSE - DO 100, I = 1, M - TEMP = TEMP + CONJG( A( I, J ) )*X( I ) - 100 CONTINUE - END IF - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 110 CONTINUE - ELSE - DO 140, J = 1, N - TEMP = ZERO - IX = KX - IF( NOCONJ )THEN - DO 120, I = 1, M - TEMP = TEMP + A( I, J )*X( IX ) - IX = IX + INCX - 120 CONTINUE - ELSE - DO 130, I = 1, M - TEMP = TEMP + CONJG( A( I, J ) )*X( IX ) - IX = IX + INCX - 130 CONTINUE - END IF - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 140 CONTINUE - END IF - END IF -C - RETURN -C -C End of CGEMV . -C - END diff --git a/slatec/cgerc.f b/slatec/cgerc.f deleted file mode 100644 index b1ebc86..0000000 --- a/slatec/cgerc.f +++ /dev/null @@ -1,165 +0,0 @@ -*DECK CGERC - SUBROUTINE CGERC (M, N, ALPHA, X, INCX, Y, INCY, A, LDA) -C***BEGIN PROLOGUE CGERC -C***PURPOSE Perform conjugated rank 1 update of a complex general -C matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE COMPLEX (SGERC-S, DGERC-D, CGERC-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C CGERC performs the rank 1 operation -C -C A := alpha*x*conjg( y') + A, -C -C where alpha is a scalar, x is an m element vector, y is an n element -C vector and A is an m by n matrix. -C -C Parameters -C ========== -C -C M - INTEGER. -C On entry, M specifies the number of rows of the matrix A. -C M must be at least zero. -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the number of columns of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - COMPLEX . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C X - COMPLEX array of dimension at least -C ( 1 + ( m - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the m -C element vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C Y - COMPLEX array of dimension at least -C ( 1 + ( n - 1 )*abs( INCY ) ). -C Before entry, the incremented array Y must contain the n -C element vector y. -C Unchanged on exit. -C -C INCY - INTEGER. -C On entry, INCY specifies the increment for the elements of -C Y. INCY must not be zero. -C Unchanged on exit. -C -C A - COMPLEX array of DIMENSION ( LDA, n ). -C Before entry, the leading m by n part of the array A must -C contain the matrix of coefficients. On exit, A is -C overwritten by the updated matrix. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C max( 1, m ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE CGERC -C .. Scalar Arguments .. - COMPLEX ALPHA - INTEGER INCX, INCY, LDA, M, N -C .. Array Arguments .. - COMPLEX A( LDA, * ), X( * ), Y( * ) -C .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -C .. Local Scalars .. - COMPLEX TEMP - INTEGER I, INFO, IX, J, JY, KX -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC CONJG, MAX -C***FIRST EXECUTABLE STATEMENT CGERC -C -C Test the input parameters. -C - 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( 'CGERC ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through A. -C - 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*CONJG( 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*CONJG( 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 -C - RETURN -C -C End of CGERC . -C - END diff --git a/slatec/cgeru.f b/slatec/cgeru.f deleted file mode 100644 index 4e87f6e..0000000 --- a/slatec/cgeru.f +++ /dev/null @@ -1,165 +0,0 @@ -*DECK CGERU - SUBROUTINE CGERU (M, N, ALPHA, X, INCX, Y, INCY, A, LDA) -C***BEGIN PROLOGUE CGERU -C***PURPOSE Perform unconjugated rank 1 update of a complex general -C matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE COMPLEX (SGERU-S, DGERU-D, CGERU-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C CGERU performs the rank 1 operation -C -C A := alpha*x*y' + A, -C -C where alpha is a scalar, x is an m element vector, y is an n element -C vector and A is an m by n matrix. -C -C Parameters -C ========== -C -C M - INTEGER. -C On entry, M specifies the number of rows of the matrix A. -C M must be at least zero. -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the number of columns of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - COMPLEX . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C X - COMPLEX array of dimension at least -C ( 1 + ( m - 1)*abs( INCX)). -C Before entry, the incremented array X must contain the m -C element vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C Y - COMPLEX array of dimension at least -C ( 1 + ( n - 1 )*abs( INCY ) ). -C Before entry, the incremented array Y must contain the n -C element vector y. -C Unchanged on exit. -C -C INCY - INTEGER. -C On entry, INCY specifies the increment for the elements of -C Y. INCY must not be zero. -C Unchanged on exit. -C -C A - COMPLEX array of DIMENSION ( LDA, n ). -C Before entry, the leading m by n part of the array A must -C contain the matrix of coefficients. On exit, A is -C overwritten by the updated matrix. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C max( 1, m ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE CGERU -C .. Scalar Arguments .. - COMPLEX ALPHA - INTEGER INCX, INCY, LDA, M, N -C .. Array Arguments .. - COMPLEX A( LDA, * ), X( * ), Y( * ) -C .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -C .. Local Scalars .. - COMPLEX TEMP - INTEGER I, INFO, IX, J, JY, KX -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C***FIRST EXECUTABLE STATEMENT CGERU -C -C Test the input parameters. -C - 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( 'CGERU ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through A. -C - 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 -C - RETURN -C -C End of CGERU . -C - END diff --git a/slatec/cgesl.f b/slatec/cgesl.f deleted file mode 100644 index 94129ed..0000000 --- a/slatec/cgesl.f +++ /dev/null @@ -1,131 +0,0 @@ -*DECK CGESL - SUBROUTINE CGESL (A, LDA, N, IPVT, B, JOB) -C***BEGIN PROLOGUE CGESL -C***PURPOSE Solve the complex system A*X=B or CTRANS(A)*X=B using the -C factors computed by CGECO or CGEFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2C1 -C***TYPE COMPLEX (SGESL-S, DGESL-D, CGESL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C CGESL solves the complex system -C A * X = B or CTRANS(A) * X = B -C using the factors computed by CGECO or CGEFA. -C -C On Entry -C -C A COMPLEX(LDA, N) -C the output from CGECO or CGEFA. -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 CGECO or CGEFA. -C -C B COMPLEX(N) -C the right hand side vector. -C -C JOB INTEGER -C = 0 to solve A*X = B , -C = nonzero to solve CTRANS(A)*X = B where -C CTRANS(A) is the conjugate 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 CGECO has set RCOND .GT. 0.0 -C or CGEFA has set INFO .EQ. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL CGECO(A,LDA,N,IPVT,RCOND,Z) -C IF (RCOND is too small) GO TO ... -C DO 10 J = 1, P -C CALL CGESL(A,LDA,N,IPVT,C(1,J),0) -C 10 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CDOTC -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CGESL - INTEGER LDA,N,IPVT(*),JOB - COMPLEX A(LDA,*),B(*) -C - COMPLEX CDOTC,T - INTEGER K,KB,L,NM1 -C***FIRST EXECUTABLE STATEMENT CGESL - 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 CAXPY(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 CAXPY(K-1,T,A(1,K),1,B(1),1) - 40 CONTINUE - GO TO 100 - 50 CONTINUE -C -C JOB = NONZERO, SOLVE CTRANS(A) * X = B -C FIRST SOLVE CTRANS(U)*Y = B -C - DO 60 K = 1, N - T = CDOTC(K-1,A(1,K),1,B(1),1) - B(K) = (B(K) - T)/CONJG(A(K,K)) - 60 CONTINUE -C -C NOW SOLVE CTRANS(L)*X = Y -C - IF (NM1 .LT. 1) GO TO 90 - DO 80 KB = 1, NM1 - K = N - KB - B(K) = B(K) + CDOTC(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/slatec/cgtsl.f b/slatec/cgtsl.f deleted file mode 100644 index 3a33756..0000000 --- a/slatec/cgtsl.f +++ /dev/null @@ -1,134 +0,0 @@ -*DECK CGTSL - SUBROUTINE CGTSL (N, C, D, E, B, INFO) -C***BEGIN PROLOGUE CGTSL -C***PURPOSE Solve a tridiagonal linear system. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2C2A -C***TYPE COMPLEX (SGTSL-S, DGTSL-D, CGTSL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE, TRIDIAGONAL -C***AUTHOR Dongarra, J., (ANL) -C***DESCRIPTION -C -C CGTSL given a general tridiagonal matrix and a right hand -C side will find the solution. -C -C On Entry -C -C N INTEGER -C is the order of the tridiagonal matrix. -C -C C COMPLEX(N) -C is the subdiagonal of the tridiagonal matrix. -C C(2) through C(N) should contain the subdiagonal. -C On output C is destroyed. -C -C D COMPLEX(N) -C is the diagonal of the tridiagonal matrix. -C On output D is destroyed. -C -C E COMPLEX(N) -C is the superdiagonal of the tridiagonal matrix. -C E(1) through E(N-1) should contain the superdiagonal. -C On output E is destroyed. -C -C B COMPLEX(N) -C is the right hand side vector. -C -C On Return -C -C B is the solution vector. -C -C INFO INTEGER -C = 0 normal value. -C = K if the K-th element of the diagonal becomes -C exactly zero. The subroutine returns when -C this is detected. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CGTSL - INTEGER N,INFO - COMPLEX C(*),D(*),E(*),B(*) -C - INTEGER K,KB,KP1,NM1,NM2 - COMPLEX T - COMPLEX ZDUM - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) -C***FIRST EXECUTABLE STATEMENT CGTSL - INFO = 0 - C(1) = D(1) - NM1 = N - 1 - IF (NM1 .LT. 1) GO TO 40 - D(1) = E(1) - E(1) = (0.0E0,0.0E0) - E(N) = (0.0E0,0.0E0) -C - DO 30 K = 1, NM1 - KP1 = K + 1 -C -C FIND THE LARGEST OF THE TWO ROWS -C - IF (CABS1(C(KP1)) .LT. CABS1(C(K))) GO TO 10 -C -C INTERCHANGE ROW -C - T = C(KP1) - C(KP1) = C(K) - C(K) = T - T = D(KP1) - D(KP1) = D(K) - D(K) = T - T = E(KP1) - E(KP1) = E(K) - E(K) = T - T = B(KP1) - B(KP1) = B(K) - B(K) = T - 10 CONTINUE -C -C ZERO ELEMENTS -C - IF (CABS1(C(K)) .NE. 0.0E0) GO TO 20 - INFO = K - GO TO 100 - 20 CONTINUE - T = -C(KP1)/C(K) - C(KP1) = D(KP1) + T*D(K) - D(KP1) = E(KP1) + T*E(K) - E(KP1) = (0.0E0,0.0E0) - B(KP1) = B(KP1) + T*B(K) - 30 CONTINUE - 40 CONTINUE - IF (CABS1(C(N)) .NE. 0.0E0) GO TO 50 - INFO = N - GO TO 90 - 50 CONTINUE -C -C BACK SOLVE -C - NM2 = N - 2 - B(N) = B(N)/C(N) - IF (N .EQ. 1) GO TO 80 - B(NM1) = (B(NM1) - D(NM1)*B(N))/C(NM1) - IF (NM2 .LT. 1) GO TO 70 - DO 60 KB = 1, NM2 - K = NM2 - KB + 1 - B(K) = (B(K) - D(K)*B(K+1) - E(K)*B(K+2))/C(K) - 60 CONTINUE - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE -C - RETURN - END diff --git a/slatec/ch.f b/slatec/ch.f deleted file mode 100644 index cc53676..0000000 --- a/slatec/ch.f +++ /dev/null @@ -1,108 +0,0 @@ -*DECK CH - SUBROUTINE CH (NM, N, AR, AI, W, MATZ, ZR, ZI, FV1, FV2, FM1, - + IERR) -C***BEGIN PROLOGUE CH -C***PURPOSE Compute the eigenvalues and, optionally, the eigenvectors -C of a complex Hermitian matrix. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4A3 -C***TYPE COMPLEX (RS-S, CH-C) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine calls the recommended sequence of -C subroutines from the eigensystem subroutine package (EISPACK) -C to find the eigenvalues and eigenvectors (if desired) -C of a COMPLEX HERMITIAN matrix. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, AR, AI, ZR and ZI, as declared in the -C calling program dimension statement. NM is an INTEGER -C variable. -C -C N is the order of the matrix A=(AR,AI). N is an INTEGER -C variable. N must be less than or equal to NM. -C -C AR and AI contain the real and imaginary parts, respectively, -C of the complex Hermitian matrix. AR and AI are -C two-dimensional REAL arrays, dimensioned AR(NM,N) -C and AI(NM,N). -C -C MATZ is an INTEGER variable set equal to zero if only -C eigenvalues are desired. Otherwise, it is set to any -C non-zero integer for both eigenvalues and eigenvectors. -C -C On OUTPUT -C -C W contains the eigenvalues in ascending order. -C W is a one-dimensional REAL array, dimensioned W(N). -C -C ZR and ZI contain the real and imaginary parts, respectively, -C of the eigenvectors if MATZ is not zero. ZR and ZI are -C two-dimensional REAL arrays, dimensioned ZR(NM,N) and -C ZI(NM,N). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C 10*N if N is greater than NM, -C J if the J-th eigenvalue has not been -C determined after a total of 30 iterations. -C The eigenvalues should be correct for indices -C 1, 2, ..., IERR-1, but no eigenvectors are -C computed. -C -C FV1 and FV2 are one-dimensional REAL arrays used for -C temporary storage, dimensioned FV1(N) and FV2(N). -C -C FM1 is a two-dimensional REAL array used for temporary -C storage, dimensioned FM1(2,N). -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED HTRIBK, HTRIDI, TQL2, TQLRAT -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CH -C - INTEGER I,J,N,NM,IERR,MATZ - REAL AR(NM,*),AI(NM,*),W(*),ZR(NM,*),ZI(NM,*) - REAL FV1(*),FV2(*),FM1(2,*) -C -C***FIRST EXECUTABLE STATEMENT CH - IF (N .LE. NM) GO TO 10 - IERR = 10 * N - GO TO 50 -C - 10 CALL HTRIDI(NM,N,AR,AI,W,FV1,FV2,FM1) - IF (MATZ .NE. 0) GO TO 20 -C .......... FIND EIGENVALUES ONLY .......... - CALL TQLRAT(N,W,FV2,IERR) - GO TO 50 -C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... - 20 DO 40 I = 1, N -C - DO 30 J = 1, N - ZR(J,I) = 0.0E0 - 30 CONTINUE -C - ZR(I,I) = 1.0E0 - 40 CONTINUE -C - CALL TQL2(NM,N,W,FV1,ZR,IERR) - IF (IERR .NE. 0) GO TO 50 - CALL HTRIBK(NM,N,AR,AI,FM1,N,ZR,ZI) - 50 RETURN - END diff --git a/slatec/changes b/slatec/changes deleted file mode 100644 index 214eca4..0000000 --- a/slatec/changes +++ /dev/null @@ -1,10 +0,0 @@ -16Jul94 ehg@research.att.com -rd.f fixed comment for "E(K) ="; "RD(3" should have been "RD(0". - Thanks to Richard Chen for pointing this out. - -Thu Nov 18 10:16:30 EST 1999 mcmahan@cs.utk.edu -sgeir.f fixed error in driver routine sgeir.f on line 169 which said : - IF (XNORM.NE.0.0) THEN - instead of : - IF (XNORM.EQ.0.0) THEN - Thanks to Eric Thiebaut for pointing this out. diff --git a/slatec/chbmv.f b/slatec/chbmv.f deleted file mode 100644 index d27ad7d..0000000 --- a/slatec/chbmv.f +++ /dev/null @@ -1,317 +0,0 @@ -*DECK CHBMV - SUBROUTINE CHBMV (UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, - $ INCY) -C***BEGIN PROLOGUE CHBMV -C***PURPOSE Multiply a complex vector by a complex Hermitian band -C matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE COMPLEX (SHBMV-S, DHBMV-D, CHBMV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C CHBMV performs the matrix-vector operation -C -C y := alpha*A*x + beta*y, -C -C where alpha and beta are scalars, x and y are n element vectors and -C A is an n by n hermitian band matrix, with k super-diagonals. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the band matrix A is being supplied as -C follows: -C -C UPLO = 'U' or 'u' The upper triangular part of A is -C being supplied. -C -C UPLO = 'L' or 'l' The lower triangular part of A is -C being supplied. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C K - INTEGER. -C On entry, K specifies the number of super-diagonals of the -C matrix A. K must satisfy 0 .le. K. -C Unchanged on exit. -C -C ALPHA - COMPLEX . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C A - COMPLEX array of DIMENSION ( LDA, n ). -C Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -C by n part of the array A must contain the upper triangular -C band part of the hermitian matrix, supplied column by -C column, with the leading diagonal of the matrix in row -C ( k + 1 ) of the array, the first super-diagonal starting at -C position 2 in row k, and so on. The top left k by k triangle -C of the array A is not referenced. -C The following program segment will transfer the upper -C triangular part of a hermitian band matrix from conventional -C full matrix storage to band storage: -C -C DO 20, J = 1, N -C M = K + 1 - J -C DO 10, I = MAX( 1, J - K ), J -C A( M + I, J ) = matrix( I, J ) -C 10 CONTINUE -C 20 CONTINUE -C -C Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -C by n part of the array A must contain the lower triangular -C band part of the hermitian matrix, supplied column by -C column, with the leading diagonal of the matrix in row 1 of -C the array, the first sub-diagonal starting at position 1 in -C row 2, and so on. The bottom right k by k triangle of the -C array A is not referenced. -C The following program segment will transfer the lower -C triangular part of a hermitian band matrix from conventional -C full matrix storage to band storage: -C -C DO 20, J = 1, N -C M = 1 - J -C DO 10, I = J, MIN( N, J + K ) -C A( M + I, J ) = matrix( I, J ) -C 10 CONTINUE -C 20 CONTINUE -C -C Note that the imaginary parts of the diagonal elements need -C not be set and are assumed to be zero. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C ( k + 1 ). -C Unchanged on exit. -C -C X - COMPLEX array of DIMENSION at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the -C vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C BETA - COMPLEX . -C On entry, BETA specifies the scalar beta. -C Unchanged on exit. -C -C Y - COMPLEX array of DIMENSION at least -C ( 1 + ( n - 1 )*abs( INCY ) ). -C Before entry, the incremented array Y must contain the -C vector y. On exit, Y is overwritten by the updated vector y. -C -C INCY - INTEGER. -C On entry, INCY specifies the increment for the elements of -C Y. INCY must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE CHBMV -C .. Scalar Arguments .. - COMPLEX ALPHA, BETA - INTEGER INCX, INCY, K, LDA, N - CHARACTER*1 UPLO -C .. Array Arguments .. - COMPLEX A( LDA, * ), X( * ), Y( * ) -C .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -C .. Local Scalars .. - COMPLEX TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC CONJG, MAX, MIN, REAL -C***FIRST EXECUTABLE STATEMENT CHBMV -C -C Test the input parameters. -C - 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( 'CHBMV ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C Set up the start points in X and Y. -C - 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 -C -C Start the operations. In this version the elements of the array A -C are accessed sequentially with one pass through A. -C -C First form y := beta*y. -C - 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 -C -C Form y when upper triangle of A is stored. -C - 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 + CONJG( A( L + I, J ) )*X( I ) - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*REAL( 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 + CONJG( A( L + I, J ) )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*REAL( 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 -C -C Form y when lower triangle of A is stored. -C - 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*REAL( 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 + CONJG( 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*REAL( 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 + CONJG( 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 -C - RETURN -C -C End of CHBMV . -C - END diff --git a/slatec/chemm.f b/slatec/chemm.f deleted file mode 100644 index 8af3b76..0000000 --- a/slatec/chemm.f +++ /dev/null @@ -1,311 +0,0 @@ -*DECK CHEMM - SUBROUTINE CHEMM (SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, - $ C, LDC) -C***BEGIN PROLOGUE CHEMM -C***PURPOSE Multiply a complex general matrix by a complex Hermitian -C matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B6 -C***TYPE COMPLEX (SHEMM-S, DHEMM-D, CHEMM-C) -C***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J., (ANL) -C Duff, I., (AERE) -C Du Croz, J., (NAG) -C Hammarling, S. (NAG) -C***DESCRIPTION -C -C CHEMM performs one of the matrix-matrix operations -C -C C := alpha*A*B + beta*C, -C -C or -C -C C := alpha*B*A + beta*C, -C -C where alpha and beta are scalars, A is an hermitian matrix and B and -C C are m by n matrices. -C -C Parameters -C ========== -C -C SIDE - CHARACTER*1. -C On entry, SIDE specifies whether the hermitian matrix A -C appears on the left or right in the operation as follows: -C -C SIDE = 'L' or 'l' C := alpha*A*B + beta*C, -C -C SIDE = 'R' or 'r' C := alpha*B*A + beta*C, -C -C Unchanged on exit. -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the hermitian matrix A is to be -C referenced as follows: -C -C UPLO = 'U' or 'u' Only the upper triangular part of the -C hermitian matrix is to be referenced. -C -C UPLO = 'L' or 'l' Only the lower triangular part of the -C hermitian matrix is to be referenced. -C -C Unchanged on exit. -C -C M - INTEGER. -C On entry, M specifies the number of rows of the matrix C. -C M must be at least zero. -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the number of columns of the matrix C. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - COMPLEX . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is -C m when SIDE = 'L' or 'l' and is n otherwise. -C Before entry with SIDE = 'L' or 'l', the m by m part of -C the array A must contain the hermitian matrix, such that -C when UPLO = 'U' or 'u', the leading m by m upper triangular -C part of the array A must contain the upper triangular part -C of the hermitian matrix and the strictly lower triangular -C part of A is not referenced, and when UPLO = 'L' or 'l', -C the leading m by m lower triangular part of the array A -C must contain the lower triangular part of the hermitian -C matrix and the strictly upper triangular part of A is not -C referenced. -C Before entry with SIDE = 'R' or 'r', the n by n part of -C the array A must contain the hermitian matrix, such that -C when UPLO = 'U' or 'u', the leading n by n upper triangular -C part of the array A must contain the upper triangular part -C of the hermitian matrix and the strictly lower triangular -C part of A is not referenced, and when UPLO = 'L' or 'l', -C the leading n by n lower triangular part of the array A -C must contain the lower triangular part of the hermitian -C matrix and the strictly upper triangular part of A is not -C referenced. -C Note that the imaginary parts of the diagonal elements need -C not be set, they are assumed to be zero. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. When SIDE = 'L' or 'l' then -C LDA must be at least max( 1, m ), otherwise LDA must be at -C least max( 1, n ). -C Unchanged on exit. -C -C B - COMPLEX array of DIMENSION ( LDB, n ). -C Before entry, the leading m by n part of the array B must -C contain the matrix B. -C Unchanged on exit. -C -C LDB - INTEGER. -C On entry, LDB specifies the first dimension of B as declared -C in the calling (sub) program. LDB must be at least -C max( 1, m ). -C Unchanged on exit. -C -C BETA - COMPLEX . -C On entry, BETA specifies the scalar beta. When BETA is -C supplied as zero then C need not be set on input. -C Unchanged on exit. -C -C C - COMPLEX array of DIMENSION ( LDC, n ). -C Before entry, the leading m by n part of the array C must -C contain the matrix C, except when beta is zero, in which -C case C need not be set on entry. -C On exit, the array C is overwritten by the m by n updated -C matrix. -C -C LDC - INTEGER. -C On entry, LDC specifies the first dimension of C as declared -C in the calling (sub) program. LDC must be at least -C max( 1, m ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. -C A set of level 3 basic linear algebra subprograms. -C ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 890208 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE CHEMM -C .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO - INTEGER M, N, LDA, LDB, LDC - COMPLEX ALPHA, BETA -C .. Array Arguments .. - COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC CONJG, MAX, REAL -C .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, K, NROWA - COMPLEX TEMP1, TEMP2 -C .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -C***FIRST EXECUTABLE STATEMENT CHEMM -C -C Set NROWA as the number of rows of A. -C - IF( LSAME( SIDE, 'L' ) )THEN - NROWA = M - ELSE - NROWA = N - END IF - UPPER = LSAME( UPLO, 'U' ) -C -C Test the input parameters. -C - 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( 'CHEMM ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C And when alpha.eq.zero. -C - 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 -C -C Start the operations. -C - IF( LSAME( SIDE, 'L' ) )THEN -C -C Form C := alpha*A*B + beta*C. -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 )*CONJG( A( K, I ) ) - 50 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*REAL( A( I, I ) ) + - $ ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*REAL( 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 )*CONJG( A( K, I ) ) - 80 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*REAL( A( I, I ) ) + - $ ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*REAL( A( I, I ) ) + - $ ALPHA*TEMP2 - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -C -C Form C := alpha*B*A + beta*C. -C - DO 170, J = 1, N - TEMP1 = ALPHA*REAL( 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*CONJG( 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*CONJG( 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 -C - RETURN -C -C End of CHEMM . -C - END diff --git a/slatec/chemv.f b/slatec/chemv.f deleted file mode 100644 index 45259ea..0000000 --- a/slatec/chemv.f +++ /dev/null @@ -1,272 +0,0 @@ -*DECK CHEMV - SUBROUTINE CHEMV (UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) -C***BEGIN PROLOGUE CHEMV -C***PURPOSE Multiply a complex vector by a complex Hermitian matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE COMPLEX (SHEMV-S, DHEMV-D, CHEMV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C CHEMV performs the matrix-vector operation -C -C y := alpha*A*x + beta*y, -C -C where alpha and beta are scalars, x and y are n element vectors and -C A is an n by n hermitian matrix. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the array A is to be referenced as -C follows: -C -C UPLO = 'U' or 'u' Only the upper triangular part of A -C is to be referenced. -C -C UPLO = 'L' or 'l' Only the lower triangular part of A -C is to be referenced. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - COMPLEX . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C A - COMPLEX array of DIMENSION ( LDA, n ). -C Before entry with UPLO = 'U' or 'u', the leading n by n -C upper triangular part of the array A must contain the upper -C triangular part of the hermitian matrix and the strictly -C lower triangular part of A is not referenced. -C Before entry with UPLO = 'L' or 'l', the leading n by n -C lower triangular part of the array A must contain the lower -C triangular part of the hermitian matrix and the strictly -C upper triangular part of A is not referenced. -C Note that the imaginary parts of the diagonal elements need -C not be set and are assumed to be zero. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C max( 1, n ). -C Unchanged on exit. -C -C X - COMPLEX array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C BETA - COMPLEX . -C On entry, BETA specifies the scalar beta. When BETA is -C supplied as zero then Y need not be set on input. -C Unchanged on exit. -C -C Y - COMPLEX array of dimension at least -C ( 1 + ( n - 1 )*abs( INCY ) ). -C Before entry, the incremented array Y must contain the n -C element vector y. On exit, Y is overwritten by the updated -C vector y. -C -C INCY - INTEGER. -C On entry, INCY specifies the increment for the elements of -C Y. INCY must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE CHEMV -C .. Scalar Arguments .. - COMPLEX ALPHA, BETA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -C .. Array Arguments .. - COMPLEX A( LDA, * ), X( * ), Y( * ) -C .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -C .. Local Scalars .. - COMPLEX TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC CONJG, MAX, REAL -C***FIRST EXECUTABLE STATEMENT CHEMV -C -C Test the input parameters. -C - 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( 'CHEMV ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C Set up the start points in X and Y. -C - 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 -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through the triangular part -C of A. -C -C First form y := beta*y. -C - 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 -C -C Form y when A is stored in upper triangle. -C - 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 + CONJG( A( I, J ) )*X( I ) - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*REAL( 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 + CONJG( A( I, J ) )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*REAL( A( J, J ) ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - ELSE -C -C Form y when A is stored in lower triangle. -C - 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*REAL( A( J, J ) ) - DO 90, I = J + 1, N - Y( I ) = Y( I ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + CONJG( 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*REAL( 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 + CONJG( 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 -C - RETURN -C -C End of CHEMV . -C - END diff --git a/slatec/cher.f b/slatec/cher.f deleted file mode 100644 index 9ef9b59..0000000 --- a/slatec/cher.f +++ /dev/null @@ -1,220 +0,0 @@ -*DECK CHER - SUBROUTINE CHER (UPLO, N, ALPHA, X, INCX, A, LDA) -C***BEGIN PROLOGUE CHER -C***PURPOSE Perform Hermitian rank 1 update of a complex Hermitian -C matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE COMPLEX (SHER-S, DHER-D, CHER-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C CHER performs the hermitian rank 1 operation -C -C A := alpha*x*conjg( x') + A, -C -C where alpha is a real scalar, x is an n element vector and A is an -C n by n hermitian matrix. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the array A is to be referenced as -C follows: -C -C UPLO = 'U' or 'u' Only the upper triangular part of A -C is to be referenced. -C -C UPLO = 'L' or 'l' Only the lower triangular part of A -C is to be referenced. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - REAL . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C X - COMPLEX array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C A - COMPLEX array of DIMENSION ( LDA, n ). -C Before entry with UPLO = 'U' or 'u', the leading n by n -C upper triangular part of the array A must contain the upper -C triangular part of the hermitian matrix and the strictly -C lower triangular part of A is not referenced. On exit, the -C upper triangular part of the array A is overwritten by the -C upper triangular part of the updated matrix. -C Before entry with UPLO = 'L' or 'l', the leading n by n -C lower triangular part of the array A must contain the lower -C triangular part of the hermitian matrix and the strictly -C upper triangular part of A is not referenced. On exit, the -C lower triangular part of the array A is overwritten by the -C lower triangular part of the updated matrix. -C Note that the imaginary parts of the diagonal elements need -C not be set, they are assumed to be zero, and on exit they -C are set to zero. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C max( 1, n ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE CHER -C .. Scalar Arguments .. - REAL ALPHA - INTEGER INCX, LDA, N - CHARACTER*1 UPLO -C .. Array Arguments .. - COMPLEX A( LDA, * ), X( * ) -C .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -C .. Local Scalars .. - COMPLEX TEMP - INTEGER I, INFO, IX, J, JX, KX -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC CONJG, MAX, REAL -C***FIRST EXECUTABLE STATEMENT CHER -C -C Test the input parameters. -C - 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( 'CHER ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.REAL( ZERO ) ) ) - $ RETURN -C -C Set the start point in X if the increment is not unity. -C - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through the triangular part -C of A. -C - IF( LSAME( UPLO, 'U' ) )THEN -C -C Form A when A is stored in upper triangle. -C - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*CONJG( X( J ) ) - DO 10, I = 1, J - 1 - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - A( J, J ) = REAL( A( J, J ) ) + REAL( X( J )*TEMP ) - ELSE - A( J, J ) = REAL( A( J, J ) ) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*CONJG( X( JX ) ) - IX = KX - DO 30, I = 1, J - 1 - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - A( J, J ) = REAL( A( J, J ) ) + REAL( X( JX )*TEMP ) - ELSE - A( J, J ) = REAL( A( J, J ) ) - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE -C -C Form A when A is stored in lower triangle. -C - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*CONJG( X( J ) ) - A( J, J ) = REAL( A( J, J ) ) + REAL( TEMP*X( J ) ) - DO 50, I = J + 1, N - A( I, J ) = A( I, J ) + X( I )*TEMP - 50 CONTINUE - ELSE - A( J, J ) = REAL( A( J, J ) ) - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*CONJG( X( JX ) ) - A( J, J ) = REAL( A( J, J ) ) + REAL( TEMP*X( JX ) ) - IX = JX - DO 70, I = J + 1, N - IX = IX + INCX - A( I, J ) = A( I, J ) + X( IX )*TEMP - 70 CONTINUE - ELSE - A( J, J ) = REAL( A( J, J ) ) - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF -C - RETURN -C -C End of CHER . -C - END diff --git a/slatec/cher2.f b/slatec/cher2.f deleted file mode 100644 index eebcd32..0000000 --- a/slatec/cher2.f +++ /dev/null @@ -1,257 +0,0 @@ -*DECK CHER2 - SUBROUTINE CHER2 (UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA) -C***BEGIN PROLOGUE CHER2 -C***PURPOSE Perform Hermitian rank 2 update of a complex Hermitian -C matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE COMPLEX (SHER2-S, DHER2-D, CHER2-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C CHER2 performs the hermitian rank 2 operation -C -C A := alpha*x*conjg( y') + conjg( alpha)*y*conjg( x') + A, -C -C where alpha is a scalar, x and y are n element vectors and A is an n -C by n hermitian matrix. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the array A is to be referenced as -C follows: -C -C UPLO = 'U' or 'u' Only the upper triangular part of A -C is to be referenced. -C -C UPLO = 'L' or 'l' Only the lower triangular part of A -C is to be referenced. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - COMPLEX . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C X - COMPLEX array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C Y - COMPLEX array of dimension at least -C ( 1 + ( n - 1 )*abs( INCY ) ). -C Before entry, the incremented array Y must contain the n -C element vector y. -C Unchanged on exit. -C -C INCY - INTEGER. -C On entry, INCY specifies the increment for the elements of -C Y. INCY must not be zero. -C Unchanged on exit. -C -C A - COMPLEX array of DIMENSION ( LDA, n ). -C Before entry with UPLO = 'U' or 'u', the leading n by n -C upper triangular part of the array A must contain the upper -C triangular part of the hermitian matrix and the strictly -C lower triangular part of A is not referenced. On exit, the -C upper triangular part of the array A is overwritten by the -C upper triangular part of the updated matrix. -C Before entry with UPLO = 'L' or 'l', the leading n by n -C lower triangular part of the array A must contain the lower -C triangular part of the hermitian matrix and the strictly -C upper triangular part of A is not referenced. On exit, the -C lower triangular part of the array A is overwritten by the -C lower triangular part of the updated matrix. -C Note that the imaginary parts of the diagonal elements need -C not be set, they are assumed to be zero, and on exit they -C are set to zero. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C max( 1, n ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE CHER2 -C .. Scalar Arguments .. - COMPLEX ALPHA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -C .. Array Arguments .. - COMPLEX A( LDA, * ), X( * ), Y( * ) -C .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -C .. Local Scalars .. - COMPLEX TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC CONJG, MAX, REAL -C***FIRST EXECUTABLE STATEMENT CHER2 -C -C Test the input parameters. -C - 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( 'CHER2 ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -C -C Set up the start points in X and Y if the increments are not both -C unity. -C - 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 -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through the triangular part -C of A. -C - IF( LSAME( UPLO, 'U' ) )THEN -C -C Form A when A is stored in the upper triangle. -C - 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*CONJG( Y( J ) ) - TEMP2 = CONJG( ALPHA*X( J ) ) - DO 10, I = 1, J - 1 - A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 - 10 CONTINUE - A( J, J ) = REAL( A( J, J ) ) + - $ REAL( X( J )*TEMP1 + Y( J )*TEMP2 ) - ELSE - A( J, J ) = REAL( A( J, J ) ) - END IF - 20 CONTINUE - ELSE - DO 40, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*CONJG( Y( JY ) ) - TEMP2 = CONJG( ALPHA*X( JX ) ) - IX = KX - IY = KY - DO 30, I = 1, J - 1 - A( I, J ) = A( I, J ) + X( IX )*TEMP1 - $ + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - A( J, J ) = REAL( A( J, J ) ) + - $ REAL( X( JX )*TEMP1 + Y( JY )*TEMP2 ) - ELSE - A( J, J ) = REAL( A( J, J ) ) - END IF - JX = JX + INCX - JY = JY + INCY - 40 CONTINUE - END IF - ELSE -C -C Form A when A is stored in the lower triangle. -C - 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*CONJG( Y( J ) ) - TEMP2 = CONJG( ALPHA*X( J ) ) - A( J, J ) = REAL( A( J, J ) ) + - $ REAL( X( J )*TEMP1 + Y( J )*TEMP2 ) - DO 50, I = J + 1, N - A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 - 50 CONTINUE - ELSE - A( J, J ) = REAL( A( J, J ) ) - END IF - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*CONJG( Y( JY ) ) - TEMP2 = CONJG( ALPHA*X( JX ) ) - A( J, J ) = REAL( A( J, J ) ) + - $ REAL( X( JX )*TEMP1 + Y( JY )*TEMP2 ) - IX = JX - IY = JY - DO 70, I = J + 1, N - IX = IX + INCX - IY = IY + INCY - A( I, J ) = A( I, J ) + X( IX )*TEMP1 - $ + Y( IY )*TEMP2 - 70 CONTINUE - ELSE - A( J, J ) = REAL( A( J, J ) ) - END IF - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - END IF -C - RETURN -C -C End of CHER2 . -C - END diff --git a/slatec/cher2k.f b/slatec/cher2k.f deleted file mode 100644 index b177db6..0000000 --- a/slatec/cher2k.f +++ /dev/null @@ -1,370 +0,0 @@ -*DECK CHER2K - SUBROUTINE CHER2K (UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, - $ C, LDC) -C***BEGIN PROLOGUE CHER2K -C***PURPOSE Perform Hermitian rank 2k update of a complex. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B6 -C***TYPE COMPLEX (SHER2-S, DHER2-D, CHER2-C, CHER2K-C) -C***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J., (ANL) -C Duff, I., (AERE) -C Du Croz, J., (NAG) -C Hammarling, S. (NAG) -C***DESCRIPTION -C -C CHER2K performs one of the hermitian rank 2k operations -C -C C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + beta*C, -C -C or -C -C C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + beta*C, -C -C where alpha and beta are scalars with beta real, C is an n by n -C hermitian matrix and A and B are n by k matrices in the first case -C and k by n matrices in the second case. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the array C is to be referenced as -C follows: -C -C UPLO = 'U' or 'u' Only the upper triangular part of C -C is to be referenced. -C -C UPLO = 'L' or 'l' Only the lower triangular part of C -C is to be referenced. -C -C Unchanged on exit. -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the operation to be performed as -C follows: -C -C TRANS = 'N' or 'n' C := alpha*A*conjg( B' ) + -C conjg( alpha )*B*conjg( A' ) + -C beta*C. -C -C TRANS = 'C' or 'c' C := alpha*conjg( A' )*B + -C conjg( alpha )*conjg( B' )*A + -C beta*C. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix C. N must be -C at least zero. -C Unchanged on exit. -C -C K - INTEGER. -C On entry with TRANS = 'N' or 'n', K specifies the number -C of columns of the matrices A and B, and on entry with -C TRANS = 'C' or 'c', K specifies the number of rows of the -C matrices A and B. K must be at least zero. -C Unchanged on exit. -C -C ALPHA - COMPLEX . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is -C k when TRANS = 'N' or 'n', and is n otherwise. -C Before entry with TRANS = 'N' or 'n', the leading n by k -C part of the array A must contain the matrix A, otherwise -C the leading k by n part of the array A must contain the -C matrix A. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. When TRANS = 'N' or 'n' -C then LDA must be at least max( 1, n ), otherwise LDA must -C be at least max( 1, k ). -C Unchanged on exit. -C -C B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is -C k when TRANS = 'N' or 'n', and is n otherwise. -C Before entry with TRANS = 'N' or 'n', the leading n by k -C part of the array B must contain the matrix B, otherwise -C the leading k by n part of the array B must contain the -C matrix B. -C Unchanged on exit. -C -C LDB - INTEGER. -C On entry, LDB specifies the first dimension of B as declared -C in the calling (sub) program. When TRANS = 'N' or 'n' -C then LDB must be at least max( 1, n ), otherwise LDB must -C be at least max( 1, k ). -C Unchanged on exit. -C -C BETA - REAL . -C On entry, BETA specifies the scalar beta. -C Unchanged on exit. -C -C C - COMPLEX array of DIMENSION ( LDC, n ). -C Before entry with UPLO = 'U' or 'u', the leading n by n -C upper triangular part of the array C must contain the upper -C triangular part of the hermitian matrix and the strictly -C lower triangular part of C is not referenced. On exit, the -C upper triangular part of the array C is overwritten by the -C upper triangular part of the updated matrix. -C Before entry with UPLO = 'L' or 'l', the leading n by n -C lower triangular part of the array C must contain the lower -C triangular part of the hermitian matrix and the strictly -C upper triangular part of C is not referenced. On exit, the -C lower triangular part of the array C is overwritten by the -C lower triangular part of the updated matrix. -C Note that the imaginary parts of the diagonal elements need -C not be set, they are assumed to be zero, and on exit they -C are set to zero. -C -C LDC - INTEGER. -C On entry, LDC specifies the first dimension of C as declared -C in the calling (sub) program. LDC must be at least -C max( 1, n ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. -C A set of level 3 basic linear algebra subprograms. -C ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 890208 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE CHER2K -C .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDB, LDC - REAL BETA - COMPLEX ALPHA -C .. Array Arguments .. - COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC CONJG, MAX, REAL -C .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - COMPLEX TEMP1, TEMP2 -C .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -C***FIRST EXECUTABLE STATEMENT CHER2K -C -C Test the input parameters. -C - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -C - INFO = 0 - IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).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( 'CHER2K', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C And when alpha.eq.zero. -C - IF( ALPHA.EQ.ZERO )THEN - IF( UPPER )THEN - IF( BETA.EQ.REAL( 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 - 1 - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - C( J, J ) = BETA*REAL( C( J, J ) ) - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.REAL( 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 - C( J, J ) = BETA*REAL( C( J, J ) ) - DO 70, I = J + 1, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -C -C Start the operations. -C - IF( LSAME( TRANS, 'N' ) )THEN -C -C Form C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + -C C. -C - IF( UPPER )THEN - DO 130, J = 1, N - IF( BETA.EQ.REAL( ZERO ) )THEN - DO 90, I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 100, I = 1, J - 1 - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - C( J, J ) = BETA*REAL( C( J, J ) ) - END IF - DO 120, L = 1, K - IF( ( A( J, L ).NE.ZERO ).OR. - $ ( B( J, L ).NE.ZERO ) )THEN - TEMP1 = ALPHA*CONJG( B( J, L ) ) - TEMP2 = CONJG( ALPHA*A( J, L ) ) - DO 110, I = 1, J - 1 - C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + - $ B( I, L )*TEMP2 - 110 CONTINUE - C( J, J ) = REAL( C( J, J ) ) + - $ REAL( A( J, L )*TEMP1 + - $ B( J, L )*TEMP2 ) - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180, J = 1, N - IF( BETA.EQ.REAL( ZERO ) )THEN - DO 140, I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 150, I = J + 1, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - C( J, J ) = BETA*REAL( C( J, J ) ) - END IF - DO 170, L = 1, K - IF( ( A( J, L ).NE.ZERO ).OR. - $ ( B( J, L ).NE.ZERO ) )THEN - TEMP1 = ALPHA*CONJG( B( J, L ) ) - TEMP2 = CONJG( ALPHA*A( J, L ) ) - DO 160, I = J + 1, N - C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + - $ B( I, L )*TEMP2 - 160 CONTINUE - C( J, J ) = REAL( C( J, J ) ) + - $ REAL( A( J, L )*TEMP1 + - $ B( J, L )*TEMP2 ) - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -C -C Form C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + -C C. -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 + CONJG( A( L, I ) )*B( L, J ) - TEMP2 = TEMP2 + CONJG( B( L, I ) )*A( L, J ) - 190 CONTINUE - IF( I.EQ.J )THEN - IF( BETA.EQ.REAL( ZERO ) )THEN - C( J, J ) = REAL( ALPHA *TEMP1 + - $ CONJG( ALPHA )*TEMP2 ) - ELSE - C( J, J ) = BETA*REAL( C( J, J ) ) + - $ REAL( ALPHA *TEMP1 + - $ CONJG( ALPHA )*TEMP2 ) - END IF - ELSE - IF( BETA.EQ.REAL( ZERO ) )THEN - C( I, J ) = ALPHA*TEMP1 + CONJG( ALPHA )*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ ALPHA*TEMP1 + CONJG( ALPHA )*TEMP2 - END IF - 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 + CONJG( A( L, I ) )*B( L, J ) - TEMP2 = TEMP2 + CONJG( B( L, I ) )*A( L, J ) - 220 CONTINUE - IF( I.EQ.J )THEN - IF( BETA.EQ.REAL( ZERO ) )THEN - C( J, J ) = REAL( ALPHA *TEMP1 + - $ CONJG( ALPHA )*TEMP2 ) - ELSE - C( J, J ) = BETA*REAL( C( J, J ) ) + - $ REAL( ALPHA *TEMP1 + - $ CONJG( ALPHA )*TEMP2 ) - END IF - ELSE - IF( BETA.EQ.REAL( ZERO ) )THEN - C( I, J ) = ALPHA*TEMP1 + CONJG( ALPHA )*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ ALPHA*TEMP1 + CONJG( ALPHA )*TEMP2 - END IF - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -C - RETURN -C -C End of CHER2K. -C - END diff --git a/slatec/cherk.f b/slatec/cherk.f deleted file mode 100644 index 54ca938..0000000 --- a/slatec/cherk.f +++ /dev/null @@ -1,327 +0,0 @@ -*DECK CHERK - SUBROUTINE CHERK (UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC) -C***BEGIN PROLOGUE CHERK -C***PURPOSE Perform Hermitian rank k update of a complex Hermitian -C matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B6 -C***TYPE COMPLEX (SHERK-S, DHERK-D, CHERK-C) -C***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J., (ANL) -C Duff, I., (AERE) -C Du Croz, J., (NAG) -C Hammarling, S. (NAG) -C***DESCRIPTION -C -C CHERK performs one of the hermitian rank k operations -C -C C := alpha*A*conjg( A' ) + beta*C, -C -C or -C -C C := alpha*conjg( A' )*A + beta*C, -C -C where alpha and beta are real scalars, C is an n by n hermitian -C matrix and A is an n by k matrix in the first case and a k by n -C matrix in the second case. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the array C is to be referenced as -C follows: -C -C UPLO = 'U' or 'u' Only the upper triangular part of C -C is to be referenced. -C -C UPLO = 'L' or 'l' Only the lower triangular part of C -C is to be referenced. -C -C Unchanged on exit. -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the operation to be performed as -C follows: -C -C TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C. -C -C TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix C. N must be -C at least zero. -C Unchanged on exit. -C -C K - INTEGER. -C On entry with TRANS = 'N' or 'n', K specifies the number -C of columns of the matrix A, and on entry with -C TRANS = 'C' or 'c', K specifies the number of rows of the -C matrix A. K must be at least zero. -C Unchanged on exit. -C -C ALPHA - REAL . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is -C k when TRANS = 'N' or 'n', and is n otherwise. -C Before entry with TRANS = 'N' or 'n', the leading n by k -C part of the array A must contain the matrix A, otherwise -C the leading k by n part of the array A must contain the -C matrix A. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. When TRANS = 'N' or 'n' -C then LDA must be at least max( 1, n ), otherwise LDA must -C be at least max( 1, k ). -C Unchanged on exit. -C -C BETA - REAL . -C On entry, BETA specifies the scalar beta. -C Unchanged on exit. -C -C C - COMPLEX array of DIMENSION ( LDC, n ). -C Before entry with UPLO = 'U' or 'u', the leading n by n -C upper triangular part of the array C must contain the upper -C triangular part of the hermitian matrix and the strictly -C lower triangular part of C is not referenced. On exit, the -C upper triangular part of the array C is overwritten by the -C upper triangular part of the updated matrix. -C Before entry with UPLO = 'L' or 'l', the leading n by n -C lower triangular part of the array C must contain the lower -C triangular part of the hermitian matrix and the strictly -C upper triangular part of C is not referenced. On exit, the -C lower triangular part of the array C is overwritten by the -C lower triangular part of the updated matrix. -C Note that the imaginary parts of the diagonal elements need -C not be set, they are assumed to be zero, and on exit they -C are set to zero. -C -C LDC - INTEGER. -C On entry, LDC specifies the first dimension of C as declared -C in the calling (sub) program. LDC must be at least -C max( 1, n ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. -C A set of level 3 basic linear algebra subprograms. -C ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 890208 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE CHERK -C .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDC - REAL ALPHA, BETA -C .. Array Arguments .. - COMPLEX A( LDA, * ), C( LDC, * ) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC CMPLX, CONJG, MAX, REAL -C .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - REAL RTEMP - COMPLEX TEMP -C .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -C***FIRST EXECUTABLE STATEMENT CHERK -C -C Test the input parameters. -C - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -C - INFO = 0 - IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).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( 'CHERK ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C And when alpha.eq.zero. -C - 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 - 1 - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - C( J, J ) = BETA*REAL( C( J, J ) ) - 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 - C( J, J ) = BETA*REAL( C( J, J ) ) - DO 70, I = J + 1, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -C -C Start the operations. -C - IF( LSAME( TRANS, 'N' ) )THEN -C -C Form C := alpha*A*conjg( A' ) + beta*C. -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 - 1 - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - C( J, J ) = BETA*REAL( C( J, J ) ) - END IF - DO 120, L = 1, K - IF( A( J, L ).NE.CMPLX( ZERO ) )THEN - TEMP = ALPHA*CONJG( A( J, L ) ) - DO 110, I = 1, J - 1 - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 110 CONTINUE - C( J, J ) = REAL( C( J, J ) ) + - $ REAL( TEMP*A( I, L ) ) - 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 - C( J, J ) = BETA*REAL( C( J, J ) ) - DO 150, I = J + 1, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - END IF - DO 170, L = 1, K - IF( A( J, L ).NE.CMPLX( ZERO ) )THEN - TEMP = ALPHA*CONJG( A( J, L ) ) - C( J, J ) = REAL( C( J, J ) ) + - $ REAL( TEMP*A( J, L ) ) - DO 160, I = J + 1, N - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -C -C Form C := alpha*conjg( A' )*A + beta*C. -C - IF( UPPER )THEN - DO 220, J = 1, N - DO 200, I = 1, J - 1 - TEMP = ZERO - DO 190, L = 1, K - TEMP = TEMP + CONJG( 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 - RTEMP = ZERO - DO 210, L = 1, K - RTEMP = RTEMP + CONJG( A( L, J ) )*A( L, J ) - 210 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( J, J ) = ALPHA*RTEMP - ELSE - C( J, J ) = ALPHA*RTEMP + BETA*REAL( C( J, J ) ) - END IF - 220 CONTINUE - ELSE - DO 260, J = 1, N - RTEMP = ZERO - DO 230, L = 1, K - RTEMP = RTEMP + CONJG( A( L, J ) )*A( L, J ) - 230 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( J, J ) = ALPHA*RTEMP - ELSE - C( J, J ) = ALPHA*RTEMP + BETA*REAL( C( J, J ) ) - END IF - DO 250, I = J + 1, N - TEMP = ZERO - DO 240, L = 1, K - TEMP = TEMP + CONJG( A( L, I ) )*A( L, J ) - 240 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 250 CONTINUE - 260 CONTINUE - END IF - END IF -C - RETURN -C -C End of CHERK . -C - END diff --git a/slatec/chfcm.f b/slatec/chfcm.f deleted file mode 100644 index f39028c..0000000 --- a/slatec/chfcm.f +++ /dev/null @@ -1,151 +0,0 @@ -*DECK CHFCM - INTEGER FUNCTION CHFCM (D1, D2, DELTA) -C***BEGIN PROLOGUE CHFCM -C***SUBSIDIARY -C***PURPOSE Check a single cubic for monotonicity. -C***LIBRARY SLATEC (PCHIP) -C***TYPE SINGLE PRECISION (CHFCM-S, DCHFCM-D) -C***AUTHOR Fritsch, F. N., (LLNL) -C***DESCRIPTION -C -C *Usage: -C -C REAL D1, D2, DELTA -C INTEGER ISMON, CHFCM -C -C ISMON = CHFCM (D1, D2, DELTA) -C -C *Arguments: -C -C D1,D2:IN are the derivative values at the ends of an interval. -C -C DELTA:IN is the data slope over that interval. -C -C *Function Return Values: -C ISMON : indicates the monotonicity of the cubic segment: -C ISMON = -3 if function is probably decreasing; -C ISMON = -1 if function is strictly decreasing; -C ISMON = 0 if function is constant; -C ISMON = 1 if function is strictly increasing; -C ISMON = 2 if function is non-monotonic; -C ISMON = 3 if function is probably increasing. -C If ABS(ISMON)=3, the derivative values are too close to the -C boundary of the monotonicity region to declare monotonicity -C in the presence of roundoff error. -C -C *Description: -C -C CHFCM: Cubic Hermite Function -- Check Monotonicity. -C -C Called by PCHCM to determine the monotonicity properties of the -C cubic with boundary derivative values D1,D2 and chord slope DELTA. -C -C *Cautions: -C This is essentially the same as old CHFMC, except that a -C new output value, -3, was added February 1989. (Formerly, -3 -C and +3 were lumped together in the single value 3.) Codes that -C flag nonmonotonicity by "IF (ISMON.EQ.2)" need not be changed. -C Codes that check via "IF (ISMON.GE.3)" should change the test to -C "IF (IABS(ISMON).GE.3)". Codes that declare monotonicity via -C "IF (ISMON.LE.1)" should change to "IF (IABS(ISMON).LE.1)". -C -C REFER TO PCHCM -C -C***ROUTINES CALLED R1MACH -C***REVISION HISTORY (YYMMDD) -C 820518 DATE WRITTEN -C 820805 Converted to SLATEC library version. -C 831201 Changed from ISIGN to SIGN to correct bug that -C produced wrong sign when -1 .LT. DELTA .LT. 0 . -C 890206 Added SAVE statements. -C 890207 Added sign to returned value ISMON=3 and corrected -C argument description accordingly. -C 890306 Added caution about changed output. -C 890407 Changed name from CHFMC to CHFCM, as requested at the -C March 1989 SLATEC CML meeting, and made a few other -C minor modifications necessitated by this change. -C 890407 Converted to new SLATEC format. -C 890407 Modified DESCRIPTION to LDOC format. -C 891214 Moved SAVE statements. (WRB) -C***END PROLOGUE CHFCM -C -C Fortran intrinsics used: SIGN. -C Other routines used: R1MACH. -C -C ---------------------------------------------------------------------- -C -C Programming notes: -C -C TEN is actually a tuning parameter, which determines the width of -C the fuzz around the elliptical boundary. -C -C To produce a double precision version, simply: -C a. Change CHFCM to DCHFCM wherever it occurs, -C b. Change the real declarations to double precision, and -C c. Change the constants ZERO, ONE, ... to double precision. -C -C DECLARE ARGUMENTS. -C - REAL D1, D2, DELTA -C -C DECLARE LOCAL VARIABLES. -C - INTEGER ISMON, ITRUE - REAL A, B, EPS, FOUR, ONE, PHI, TEN, THREE, TWO, ZERO - SAVE ZERO, ONE, TWO, THREE, FOUR - SAVE TEN -C -C INITIALIZE. -C - DATA ZERO /0./, ONE /1.0/, TWO /2./, THREE /3./, FOUR /4./, - 1 TEN /10./ -C -C MACHINE-DEPENDENT PARAMETER -- SHOULD BE ABOUT 10*UROUND. -C***FIRST EXECUTABLE STATEMENT CHFCM - EPS = TEN*R1MACH(4) -C -C MAKE THE CHECK. -C - IF (DELTA .EQ. ZERO) THEN -C CASE OF CONSTANT DATA. - IF ((D1.EQ.ZERO) .AND. (D2.EQ.ZERO)) THEN - ISMON = 0 - ELSE - ISMON = 2 - ENDIF - ELSE -C DATA IS NOT CONSTANT -- PICK UP SIGN. - ITRUE = SIGN (ONE, DELTA) - A = D1/DELTA - B = D2/DELTA - IF ((A.LT.ZERO) .OR. (B.LT.ZERO)) THEN - ISMON = 2 - ELSE IF ((A.LE.THREE-EPS) .AND. (B.LE.THREE-EPS)) THEN -C INSIDE SQUARE (0,3)X(0,3) IMPLIES OK. - ISMON = ITRUE - ELSE IF ((A.GT.FOUR+EPS) .AND. (B.GT.FOUR+EPS)) THEN -C OUTSIDE SQUARE (0,4)X(0,4) IMPLIES NONMONOTONIC. - ISMON = 2 - ELSE -C MUST CHECK AGAINST BOUNDARY OF ELLIPSE. - A = A - TWO - B = B - TWO - PHI = ((A*A + B*B) + A*B) - THREE - IF (PHI .LT. -EPS) THEN - ISMON = ITRUE - ELSE IF (PHI .GT. EPS) THEN - ISMON = 2 - ELSE -C TO CLOSE TO BOUNDARY TO TELL, -C IN THE PRESENCE OF ROUND-OFF ERRORS. - ISMON = 3*ITRUE - ENDIF - ENDIF - ENDIF -C -C RETURN VALUE. -C - CHFCM = ISMON - RETURN -C------------- LAST LINE OF CHFCM FOLLOWS ------------------------------ - END diff --git a/slatec/chfdv.f b/slatec/chfdv.f deleted file mode 100644 index 8355e90..0000000 --- a/slatec/chfdv.f +++ /dev/null @@ -1,165 +0,0 @@ -*DECK CHFDV - SUBROUTINE CHFDV (X1, X2, F1, F2, D1, D2, NE, XE, FE, DE, NEXT, - + IERR) -C***BEGIN PROLOGUE CHFDV -C***PURPOSE Evaluate a cubic polynomial given in Hermite form and its -C first derivative at an array of points. While designed for -C use by PCHFD, it may be useful directly as an evaluator -C for a piecewise cubic Hermite function in applications, -C such as graphing, where the interval is known in advance. -C If only function values are required, use CHFEV instead. -C***LIBRARY SLATEC (PCHIP) -C***CATEGORY E3, H1 -C***TYPE SINGLE PRECISION (CHFDV-S, DCHFDV-D) -C***KEYWORDS CUBIC HERMITE DIFFERENTIATION, CUBIC HERMITE EVALUATION, -C CUBIC POLYNOMIAL EVALUATION, PCHIP -C***AUTHOR Fritsch, F. N., (LLNL) -C Lawrence Livermore National Laboratory -C P.O. Box 808 (L-316) -C Livermore, CA 94550 -C FTS 532-4275, (510) 422-4275 -C***DESCRIPTION -C -C CHFDV: Cubic Hermite Function and Derivative Evaluator -C -C Evaluates the cubic polynomial determined by function values -C F1,F2 and derivatives D1,D2 on interval (X1,X2), together with -C its first derivative, at the points XE(J), J=1(1)NE. -C -C If only function values are required, use CHFEV, instead. -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C INTEGER NE, NEXT(2), IERR -C REAL X1, X2, F1, F2, D1, D2, XE(NE), FE(NE), DE(NE) -C -C CALL CHFDV (X1,X2, F1,F2, D1,D2, NE, XE, FE, DE, NEXT, IERR) -C -C Parameters: -C -C X1,X2 -- (input) endpoints of interval of definition of cubic. -C (Error return if X1.EQ.X2 .) -C -C F1,F2 -- (input) values of function at X1 and X2, respectively. -C -C D1,D2 -- (input) values of derivative at X1 and X2, respectively. -C -C NE -- (input) number of evaluation points. (Error return if -C NE.LT.1 .) -C -C XE -- (input) real array of points at which the functions are to -C be evaluated. If any of the XE are outside the interval -C [X1,X2], a warning error is returned in NEXT. -C -C FE -- (output) real array of values of the cubic function defined -C by X1,X2, F1,F2, D1,D2 at the points XE. -C -C DE -- (output) real array of values of the first derivative of -C the same function at the points XE. -C -C NEXT -- (output) integer array indicating number of extrapolation -C points: -C NEXT(1) = number of evaluation points to left of interval. -C NEXT(2) = number of evaluation points to right of interval. -C -C IERR -- (output) error flag. -C Normal return: -C IERR = 0 (no errors). -C "Recoverable" errors: -C IERR = -1 if NE.LT.1 . -C IERR = -2 if X1.EQ.X2 . -C (Output arrays have not been changed in either case.) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 811019 DATE WRITTEN -C 820803 Minor cosmetic changes for release 1. -C 890411 Added SAVE statements (Vers. 3.2). -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE CHFDV -C Programming notes: -C -C To produce a double precision version, simply: -C a. Change CHFDV to DCHFDV wherever it occurs, -C b. Change the real declaration to double precision, and -C c. Change the constant ZERO to double precision. -C -C DECLARE ARGUMENTS. -C - INTEGER NE, NEXT(2), IERR - REAL X1, X2, F1, F2, D1, D2, XE(*), FE(*), DE(*) -C -C DECLARE LOCAL VARIABLES. -C - INTEGER I - REAL C2, C2T2, C3, C3T3, DEL1, DEL2, DELTA, H, X, XMI, XMA, ZERO - SAVE ZERO - DATA ZERO /0./ -C -C VALIDITY-CHECK ARGUMENTS. -C -C***FIRST EXECUTABLE STATEMENT CHFDV - IF (NE .LT. 1) GO TO 5001 - H = X2 - X1 - IF (H .EQ. ZERO) GO TO 5002 -C -C INITIALIZE. -C - IERR = 0 - NEXT(1) = 0 - NEXT(2) = 0 - XMI = MIN(ZERO, H) - XMA = MAX(ZERO, H) -C -C COMPUTE CUBIC COEFFICIENTS (EXPANDED ABOUT X1). -C - DELTA = (F2 - F1)/H - DEL1 = (D1 - DELTA)/H - DEL2 = (D2 - DELTA)/H -C (DELTA IS NO LONGER NEEDED.) - C2 = -(DEL1+DEL1 + DEL2) - C2T2 = C2 + C2 - C3 = (DEL1 + DEL2)/H -C (H, DEL1 AND DEL2 ARE NO LONGER NEEDED.) - C3T3 = C3+C3+C3 -C -C EVALUATION LOOP. -C - DO 500 I = 1, NE - X = XE(I) - X1 - FE(I) = F1 + X*(D1 + X*(C2 + X*C3)) - DE(I) = D1 + X*(C2T2 + X*C3T3) -C COUNT EXTRAPOLATION POINTS. - IF ( X.LT.XMI ) NEXT(1) = NEXT(1) + 1 - IF ( X.GT.XMA ) NEXT(2) = NEXT(2) + 1 -C (NOTE REDUNDANCY--IF EITHER CONDITION IS TRUE, OTHER IS FALSE.) - 500 CONTINUE -C -C NORMAL RETURN. -C - RETURN -C -C ERROR RETURNS. -C - 5001 CONTINUE -C NE.LT.1 RETURN. - IERR = -1 - CALL XERMSG ('SLATEC', 'CHFDV', - + 'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1) - RETURN -C - 5002 CONTINUE -C X1.EQ.X2 RETURN. - IERR = -2 - CALL XERMSG ('SLATEC', 'CHFDV', 'INTERVAL ENDPOINTS EQUAL', IERR, - + 1) - RETURN -C------------- LAST LINE OF CHFDV FOLLOWS ------------------------------ - END diff --git a/slatec/chfev.f b/slatec/chfev.f deleted file mode 100644 index 1e97820..0000000 --- a/slatec/chfev.f +++ /dev/null @@ -1,155 +0,0 @@ -*DECK CHFEV - SUBROUTINE CHFEV (X1, X2, F1, F2, D1, D2, NE, XE, FE, NEXT, IERR) -C***BEGIN PROLOGUE CHFEV -C***PURPOSE Evaluate a cubic polynomial given in Hermite form at an -C array of points. While designed for use by PCHFE, it may -C be useful directly as an evaluator for a piecewise cubic -C Hermite function in applications, such as graphing, where -C the interval is known in advance. -C***LIBRARY SLATEC (PCHIP) -C***CATEGORY E3 -C***TYPE SINGLE PRECISION (CHFEV-S, DCHFEV-D) -C***KEYWORDS CUBIC HERMITE EVALUATION, CUBIC POLYNOMIAL EVALUATION, -C PCHIP -C***AUTHOR Fritsch, F. N., (LLNL) -C Lawrence Livermore National Laboratory -C P.O. Box 808 (L-316) -C Livermore, CA 94550 -C FTS 532-4275, (510) 422-4275 -C***DESCRIPTION -C -C CHFEV: Cubic Hermite Function EValuator -C -C Evaluates the cubic polynomial determined by function values -C F1,F2 and derivatives D1,D2 on interval (X1,X2) at the points -C XE(J), J=1(1)NE. -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C INTEGER NE, NEXT(2), IERR -C REAL X1, X2, F1, F2, D1, D2, XE(NE), FE(NE) -C -C CALL CHFEV (X1,X2, F1,F2, D1,D2, NE, XE, FE, NEXT, IERR) -C -C Parameters: -C -C X1,X2 -- (input) endpoints of interval of definition of cubic. -C (Error return if X1.EQ.X2 .) -C -C F1,F2 -- (input) values of function at X1 and X2, respectively. -C -C D1,D2 -- (input) values of derivative at X1 and X2, respectively. -C -C NE -- (input) number of evaluation points. (Error return if -C NE.LT.1 .) -C -C XE -- (input) real array of points at which the function is to be -C evaluated. If any of the XE are outside the interval -C [X1,X2], a warning error is returned in NEXT. -C -C FE -- (output) real array of values of the cubic function defined -C by X1,X2, F1,F2, D1,D2 at the points XE. -C -C NEXT -- (output) integer array indicating number of extrapolation -C points: -C NEXT(1) = number of evaluation points to left of interval. -C NEXT(2) = number of evaluation points to right of interval. -C -C IERR -- (output) error flag. -C Normal return: -C IERR = 0 (no errors). -C "Recoverable" errors: -C IERR = -1 if NE.LT.1 . -C IERR = -2 if X1.EQ.X2 . -C (The FE-array has not been changed in either case.) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 811019 DATE WRITTEN -C 820803 Minor cosmetic changes for release 1. -C 890411 Added SAVE statements (Vers. 3.2). -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890703 Corrected category record. (WRB) -C 890703 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***END PROLOGUE CHFEV -C Programming notes: -C -C To produce a double precision version, simply: -C a. Change CHFEV to DCHFEV wherever it occurs, -C b. Change the real declaration to double precision, and -C c. Change the constant ZERO to double precision. -C -C DECLARE ARGUMENTS. -C - INTEGER NE, NEXT(2), IERR - REAL X1, X2, F1, F2, D1, D2, XE(*), FE(*) -C -C DECLARE LOCAL VARIABLES. -C - INTEGER I - REAL C2, C3, DEL1, DEL2, DELTA, H, X, XMI, XMA, ZERO - SAVE ZERO - DATA ZERO /0./ -C -C VALIDITY-CHECK ARGUMENTS. -C -C***FIRST EXECUTABLE STATEMENT CHFEV - IF (NE .LT. 1) GO TO 5001 - H = X2 - X1 - IF (H .EQ. ZERO) GO TO 5002 -C -C INITIALIZE. -C - IERR = 0 - NEXT(1) = 0 - NEXT(2) = 0 - XMI = MIN(ZERO, H) - XMA = MAX(ZERO, H) -C -C COMPUTE CUBIC COEFFICIENTS (EXPANDED ABOUT X1). -C - DELTA = (F2 - F1)/H - DEL1 = (D1 - DELTA)/H - DEL2 = (D2 - DELTA)/H -C (DELTA IS NO LONGER NEEDED.) - C2 = -(DEL1+DEL1 + DEL2) - C3 = (DEL1 + DEL2)/H -C (H, DEL1 AND DEL2 ARE NO LONGER NEEDED.) -C -C EVALUATION LOOP. -C - DO 500 I = 1, NE - X = XE(I) - X1 - FE(I) = F1 + X*(D1 + X*(C2 + X*C3)) -C COUNT EXTRAPOLATION POINTS. - IF ( X.LT.XMI ) NEXT(1) = NEXT(1) + 1 - IF ( X.GT.XMA ) NEXT(2) = NEXT(2) + 1 -C (NOTE REDUNDANCY--IF EITHER CONDITION IS TRUE, OTHER IS FALSE.) - 500 CONTINUE -C -C NORMAL RETURN. -C - RETURN -C -C ERROR RETURNS. -C - 5001 CONTINUE -C NE.LT.1 RETURN. - IERR = -1 - CALL XERMSG ('SLATEC', 'CHFEV', - + 'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1) - RETURN -C - 5002 CONTINUE -C X1.EQ.X2 RETURN. - IERR = -2 - CALL XERMSG ('SLATEC', 'CHFEV', 'INTERVAL ENDPOINTS EQUAL', IERR, - + 1) - RETURN -C------------- LAST LINE OF CHFEV FOLLOWS ------------------------------ - END diff --git a/slatec/chfie.f b/slatec/chfie.f deleted file mode 100644 index e673f81..0000000 --- a/slatec/chfie.f +++ /dev/null @@ -1,108 +0,0 @@ -*DECK CHFIE - REAL FUNCTION CHFIE (X1, X2, F1, F2, D1, D2, A, B) -C***BEGIN PROLOGUE CHFIE -C***SUBSIDIARY -C***PURPOSE Evaluates integral of a single cubic for PCHIA -C***LIBRARY SLATEC (PCHIP) -C***TYPE SINGLE PRECISION (CHFIE-S, DCHFIE-D) -C***AUTHOR Fritsch, F. N., (LLNL) -C***DESCRIPTION -C -C CHFIE: Cubic Hermite Function Integral Evaluator. -C -C Called by PCHIA to evaluate the integral of a single cubic (in -C Hermite form) over an arbitrary interval (A,B). -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C REAL X1, X2, F1, F2, D1, D2, A, B -C REAL VALUE, CHFIE -C -C VALUE = CHFIE (X1, X2, F1, F2, D1, D2, A, B) -C -C Parameters: -C -C VALUE -- (output) value of the requested integral. -C -C X1,X2 -- (input) endpoints if interval of definition of cubic. -C -C F1,F2 -- (input) function values at the ends of the interval. -C -C D1,D2 -- (input) derivative values at the ends of the interval. -C -C A,B -- (input) endpoints of interval of integration. -C -C***SEE ALSO PCHIA -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 820730 DATE WRITTEN -C 820805 Converted to SLATEC library version. -C 870813 Minor cosmetic changes. -C 890411 1. Added SAVE statements (Vers. 3.2). -C 2. Added SIX to REAL declaration. -C 890411 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 900328 Added TYPE section. (WRB) -C 910408 Updated AUTHOR section in prologue. (WRB) -C 930503 Corrected to set VALUE=0 when IERR.ne.0. (FNF) -C 930504 Eliminated IERR and changed name from CHFIV to CHFIE. (FNF) -C***END PROLOGUE CHFIE -C -C Programming notes: -C 1. There is no error return from this routine because zero is -C indeed the mathematically correct answer when X1.EQ.X2 . -C**End -C -C DECLARE ARGUMENTS. -C - REAL X1, X2, F1, F2, D1, D2, A, B -C -C DECLARE LOCAL VARIABLES. -C - REAL DTERM, FOUR, FTERM, H, HALF, PHIA1, PHIA2, PHIB1, PHIB2, - * PSIA1, PSIA2, PSIB1, PSIB2, SIX, TA1, TA2, TB1, TB2, THREE, - * TWO, UA1, UA2, UB1, UB2 - SAVE HALF, TWO, THREE, FOUR, SIX -C -C INITIALIZE. -C - DATA HALF /0.5/, TWO /2./, THREE /3./, FOUR /4./, SIX /6./ -C -C VALIDITY CHECK INPUT. -C -C***FIRST EXECUTABLE STATEMENT CHFIE - IF (X1 .EQ. X2) THEN - CHFIE = 0 - ELSE - H = X2 - X1 - TA1 = (A - X1) / H - TA2 = (X2 - A) / H - TB1 = (B - X1) / H - TB2 = (X2 - B) / H -C - UA1 = TA1**3 - PHIA1 = UA1 * (TWO - TA1) - PSIA1 = UA1 * (THREE*TA1 - FOUR) - UA2 = TA2**3 - PHIA2 = UA2 * (TWO - TA2) - PSIA2 = -UA2 * (THREE*TA2 - FOUR) -C - UB1 = TB1**3 - PHIB1 = UB1 * (TWO - TB1) - PSIB1 = UB1 * (THREE*TB1 - FOUR) - UB2 = TB2**3 - PHIB2 = UB2 * (TWO - TB2) - PSIB2 = -UB2 * (THREE*TB2 - FOUR) -C - FTERM = F1*(PHIA2 - PHIB2) + F2*(PHIB1 - PHIA1) - DTERM = ( D1*(PSIA2 - PSIB2) + D2*(PSIB1 - PSIA1) )*(H/SIX) -C - CHFIE = (HALF*H) * (FTERM + DTERM) - ENDIF -C - RETURN -C------------- LAST LINE OF CHFIE FOLLOWS ------------------------------ - END diff --git a/slatec/chico.f b/slatec/chico.f deleted file mode 100644 index f86dadc..0000000 --- a/slatec/chico.f +++ /dev/null @@ -1,264 +0,0 @@ -*DECK CHICO - SUBROUTINE CHICO (A, LDA, N, KPVT, RCOND, Z) -C***BEGIN PROLOGUE CHICO -C***PURPOSE Factor a complex Hermitian matrix by elimination with sym- -C metric pivoting and estimate the condition of the matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2D1A -C***TYPE COMPLEX (SSICO-S, DSICO-D, CHICO-C, CSICO-C) -C***KEYWORDS CONDITION NUMBER, HERMITIAN, LINEAR ALGEBRA, LINPACK, -C MATRIX FACTORIZATION -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C CHICO factors a complex Hermitian matrix by elimination with -C symmetric pivoting and estimates the condition of the matrix. -C -C If RCOND is not needed, CHIFA is slightly faster. -C To solve A*X = B , follow CHICO by CHISL. -C To compute INVERSE(A)*C , follow CHICO by CHISL. -C To compute INVERSE(A) , follow CHICO by CHIDI. -C To compute DETERMINANT(A) , follow CHICO by CHIDI. -C To compute INERTIA(A), follow CHICO by CHIDI. -C -C On Entry -C -C A COMPLEX(LDA, N) -C the Hermitian matrix to be factored. -C Only the diagonal and upper triangle are used. -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 Output -C -C A a block diagonal matrix and the multipliers which -C were used to obtain it. -C The factorization can be written A = U*D*CTRANS(U) -C where U is a product of permutation and unit -C upper triangular matrices , CTRANS(U) is the -C conjugate transpose of U , and D is block diagonal -C with 1 by 1 and 2 by 2 blocks. -C -C KVPT INTEGER(N) -C an integer vector of pivot indices. -C -C RCOND REAL -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 COMPLEX(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***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CDOTC, CHIFA, CSSCAL, SCASUM -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Modified routine equivalence list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CHICO - INTEGER LDA,N,KPVT(*) - COMPLEX A(LDA,*),Z(*) - REAL RCOND -C - COMPLEX AK,AKM1,BK,BKM1,CDOTC,DENOM,EK,T - REAL ANORM,S,SCASUM,YNORM - INTEGER I,INFO,J,JM1,K,KP,KPS,KS - COMPLEX ZDUM,ZDUM2,CSIGN1 - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) - CSIGN1(ZDUM,ZDUM2) = CABS1(ZDUM)*(ZDUM2/CABS1(ZDUM2)) -C -C FIND NORM OF A USING ONLY UPPER HALF -C -C***FIRST EXECUTABLE STATEMENT CHICO - DO 30 J = 1, N - Z(J) = CMPLX(SCASUM(J,A(1,J),1),0.0E0) - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 20 - DO 10 I = 1, JM1 - Z(I) = CMPLX(REAL(Z(I))+CABS1(A(I,J)),0.0E0) - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - ANORM = 0.0E0 - DO 40 J = 1, N - ANORM = MAX(ANORM,REAL(Z(J))) - 40 CONTINUE -C -C FACTOR -C - CALL CHIFA(A,LDA,N,KPVT,INFO) -C -C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . -C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . -C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL -C GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . -C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. -C -C SOLVE U*D*W = E -C - EK = (1.0E0,0.0E0) - DO 50 J = 1, N - Z(J) = (0.0E0,0.0E0) - 50 CONTINUE - K = N - 60 IF (K .EQ. 0) GO TO 120 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - KP = ABS(KPVT(K)) - KPS = K + 1 - KS - IF (KP .EQ. KPS) GO TO 70 - T = Z(KPS) - Z(KPS) = Z(KP) - Z(KP) = T - 70 CONTINUE - IF (CABS1(Z(K)) .NE. 0.0E0) EK = CSIGN1(EK,Z(K)) - Z(K) = Z(K) + EK - CALL CAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) - IF (KS .EQ. 1) GO TO 80 - IF (CABS1(Z(K-1)) .NE. 0.0E0) EK = CSIGN1(EK,Z(K-1)) - Z(K-1) = Z(K-1) + EK - CALL CAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) - 80 CONTINUE - IF (KS .EQ. 2) GO TO 100 - IF (CABS1(Z(K)) .LE. CABS1(A(K,K))) GO TO 90 - S = CABS1(A(K,K))/CABS1(Z(K)) - CALL CSSCAL(N,S,Z,1) - EK = CMPLX(S,0.0E0)*EK - 90 CONTINUE - IF (CABS1(A(K,K)) .NE. 0.0E0) Z(K) = Z(K)/A(K,K) - IF (CABS1(A(K,K)) .EQ. 0.0E0) Z(K) = (1.0E0,0.0E0) - GO TO 110 - 100 CONTINUE - AK = A(K,K)/CONJG(A(K-1,K)) - AKM1 = A(K-1,K-1)/A(K-1,K) - BK = Z(K)/CONJG(A(K-1,K)) - BKM1 = Z(K-1)/A(K-1,K) - DENOM = AK*AKM1 - 1.0E0 - Z(K) = (AKM1*BK - BKM1)/DENOM - Z(K-1) = (AK*BKM1 - BK)/DENOM - 110 CONTINUE - K = K - KS - GO TO 60 - 120 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) -C -C SOLVE CTRANS(U)*Y = W -C - K = 1 - 130 IF (K .GT. N) GO TO 160 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. 1) GO TO 150 - Z(K) = Z(K) + CDOTC(K-1,A(1,K),1,Z(1),1) - IF (KS .EQ. 2) - 1 Z(K+1) = Z(K+1) + CDOTC(K-1,A(1,K+1),1,Z(1),1) - KP = ABS(KPVT(K)) - IF (KP .EQ. K) GO TO 140 - T = Z(K) - Z(K) = Z(KP) - Z(KP) = T - 140 CONTINUE - 150 CONTINUE - K = K + KS - GO TO 130 - 160 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) -C - YNORM = 1.0E0 -C -C SOLVE U*D*V = Y -C - K = N - 170 IF (K .EQ. 0) GO TO 230 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. KS) GO TO 190 - KP = ABS(KPVT(K)) - KPS = K + 1 - KS - IF (KP .EQ. KPS) GO TO 180 - T = Z(KPS) - Z(KPS) = Z(KP) - Z(KP) = T - 180 CONTINUE - CALL CAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) - IF (KS .EQ. 2) CALL CAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) - 190 CONTINUE - IF (KS .EQ. 2) GO TO 210 - IF (CABS1(Z(K)) .LE. CABS1(A(K,K))) GO TO 200 - S = CABS1(A(K,K))/CABS1(Z(K)) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM - 200 CONTINUE - IF (CABS1(A(K,K)) .NE. 0.0E0) Z(K) = Z(K)/A(K,K) - IF (CABS1(A(K,K)) .EQ. 0.0E0) Z(K) = (1.0E0,0.0E0) - GO TO 220 - 210 CONTINUE - AK = A(K,K)/CONJG(A(K-1,K)) - AKM1 = A(K-1,K-1)/A(K-1,K) - BK = Z(K)/CONJG(A(K-1,K)) - BKM1 = Z(K-1)/A(K-1,K) - DENOM = AK*AKM1 - 1.0E0 - Z(K) = (AKM1*BK - BKM1)/DENOM - Z(K-1) = (AK*BKM1 - BK)/DENOM - 220 CONTINUE - K = K - KS - GO TO 170 - 230 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE CTRANS(U)*Z = V -C - K = 1 - 240 IF (K .GT. N) GO TO 270 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. 1) GO TO 260 - Z(K) = Z(K) + CDOTC(K-1,A(1,K),1,Z(1),1) - IF (KS .EQ. 2) - 1 Z(K+1) = Z(K+1) + CDOTC(K-1,A(1,K+1),1,Z(1),1) - KP = ABS(KPVT(K)) - IF (KP .EQ. K) GO TO 250 - T = Z(K) - Z(K) = Z(KP) - Z(KP) = T - 250 CONTINUE - 260 CONTINUE - K = K + KS - GO TO 240 - 270 CONTINUE -C MAKE ZNORM = 1.0 - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM -C - IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM - IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0 - RETURN - END diff --git a/slatec/chidi.f b/slatec/chidi.f deleted file mode 100644 index e779e79..0000000 --- a/slatec/chidi.f +++ /dev/null @@ -1,234 +0,0 @@ -*DECK CHIDI - SUBROUTINE CHIDI (A, LDA, N, KPVT, DET, INERT, WORK, JOB) -C***BEGIN PROLOGUE CHIDI -C***PURPOSE Compute the determinant, inertia and inverse of a complex -C Hermitian matrix using the factors obtained from CHIFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2D1A, D3D1A -C***TYPE COMPLEX (SSIDI-S, DSISI-D, CHIDI-C, CSIDI-C) -C***KEYWORDS DETERMINANT, HERMITIAN, INVERSE, LINEAR ALGEBRA, LINPACK, -C MATRIX -C***AUTHOR Bunch, J., (UCSD) -C***DESCRIPTION -C -C CHIDI computes the determinant, inertia and inverse -C of a complex Hermitian matrix using the factors from CHIFA. -C -C On Entry -C -C A COMPLEX(LDA,N) -C the output from CHIFA. -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 KVPT INTEGER(N) -C the pivot vector from CHIFA. -C -C WORK COMPLEX(N) -C work vector. Contents destroyed. -C -C JOB INTEGER -C JOB has the decimal expansion ABC where -C if C .NE. 0, the inverse is computed, -C if B .NE. 0, the determinant is computed, -C if A .NE. 0, the inertia is computed. -C -C For example, JOB = 111 gives all three. -C -C On Return -C -C Variables not requested by JOB are not used. -C -C A contains the upper triangle of the inverse of -C the original matrix. The strict lower triangle -C is never referenced. -C -C DET REAL(2) -C determinant of original matrix. -C Determinant = DET(1) * 10.0**DET(2) -C with 1.0 .LE. ABS(DET(1)) .LT. 10.0 -C or DET(1) = 0.0. -C -C INERT INTEGER(3) -C the inertia of the original matrix. -C INERT(1) = number of positive eigenvalues. -C INERT(2) = number of negative eigenvalues. -C INERT(3) = number of zero eigenvalues. -C -C Error Condition -C -C A division by zero may occur if the inverse is requested -C and CHICO has set RCOND .EQ. 0.0 -C or CHIFA has set INFO .NE. 0 . -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CCOPY, CDOTC, CSWAP -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Modified routine equivalence list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CHIDI - INTEGER LDA,N,JOB - COMPLEX A(LDA,*),WORK(*) - REAL DET(2) - INTEGER KPVT(*),INERT(3) -C - COMPLEX AKKP1,CDOTC,TEMP - REAL TEN,D,T,AK,AKP1 - INTEGER J,JB,K,KM1,KS,KSTEP - LOGICAL NOINV,NODET,NOERT -C***FIRST EXECUTABLE STATEMENT CHIDI - NOINV = MOD(JOB,10) .EQ. 0 - NODET = MOD(JOB,100)/10 .EQ. 0 - NOERT = MOD(JOB,1000)/100 .EQ. 0 -C - IF (NODET .AND. NOERT) GO TO 140 - IF (NOERT) GO TO 10 - INERT(1) = 0 - INERT(2) = 0 - INERT(3) = 0 - 10 CONTINUE - IF (NODET) GO TO 20 - DET(1) = 1.0E0 - DET(2) = 0.0E0 - TEN = 10.0E0 - 20 CONTINUE - T = 0.0E0 - DO 130 K = 1, N - D = REAL(A(K,K)) -C -C CHECK IF 1 BY 1 -C - IF (KPVT(K) .GT. 0) GO TO 50 -C -C 2 BY 2 BLOCK -C USE DET (D S) = (D/T * C - T) * T , T = ABS(S) -C (S C) -C TO AVOID UNDERFLOW/OVERFLOW TROUBLES. -C TAKE TWO PASSES THROUGH SCALING. USE T FOR FLAG. -C - IF (T .NE. 0.0E0) GO TO 30 - T = ABS(A(K,K+1)) - D = (D/T)*REAL(A(K+1,K+1)) - T - GO TO 40 - 30 CONTINUE - D = T - T = 0.0E0 - 40 CONTINUE - 50 CONTINUE -C - IF (NOERT) GO TO 60 - IF (D .GT. 0.0E0) INERT(1) = INERT(1) + 1 - IF (D .LT. 0.0E0) INERT(2) = INERT(2) + 1 - IF (D .EQ. 0.0E0) INERT(3) = INERT(3) + 1 - 60 CONTINUE -C - IF (NODET) GO TO 120 - DET(1) = D*DET(1) - IF (DET(1) .EQ. 0.0E0) GO TO 110 - 70 IF (ABS(DET(1)) .GE. 1.0E0) GO TO 80 - DET(1) = TEN*DET(1) - DET(2) = DET(2) - 1.0E0 - GO TO 70 - 80 CONTINUE - 90 IF (ABS(DET(1)) .LT. TEN) GO TO 100 - DET(1) = DET(1)/TEN - DET(2) = DET(2) + 1.0E0 - GO TO 90 - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE - 130 CONTINUE - 140 CONTINUE -C -C COMPUTE INVERSE(A) -C - IF (NOINV) GO TO 270 - K = 1 - 150 IF (K .GT. N) GO TO 260 - KM1 = K - 1 - IF (KPVT(K) .LT. 0) GO TO 180 -C -C 1 BY 1 -C - A(K,K) = CMPLX(1.0E0/REAL(A(K,K)),0.0E0) - IF (KM1 .LT. 1) GO TO 170 - CALL CCOPY(KM1,A(1,K),1,WORK,1) - DO 160 J = 1, KM1 - A(J,K) = CDOTC(J,A(1,J),1,WORK,1) - CALL CAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1) - 160 CONTINUE - A(K,K) = A(K,K) - 1 + CMPLX(REAL(CDOTC(KM1,WORK,1,A(1,K),1)), - 2 0.0E0) - 170 CONTINUE - KSTEP = 1 - GO TO 220 - 180 CONTINUE -C -C 2 BY 2 -C - T = ABS(A(K,K+1)) - AK = REAL(A(K,K))/T - AKP1 = REAL(A(K+1,K+1))/T - AKKP1 = A(K,K+1)/T - D = T*(AK*AKP1 - 1.0E0) - A(K,K) = CMPLX(AKP1/D,0.0E0) - A(K+1,K+1) = CMPLX(AK/D,0.0E0) - A(K,K+1) = -AKKP1/D - IF (KM1 .LT. 1) GO TO 210 - CALL CCOPY(KM1,A(1,K+1),1,WORK,1) - DO 190 J = 1, KM1 - A(J,K+1) = CDOTC(J,A(1,J),1,WORK,1) - CALL CAXPY(J-1,WORK(J),A(1,J),1,A(1,K+1),1) - 190 CONTINUE - A(K+1,K+1) = A(K+1,K+1) - 1 + CMPLX(REAL(CDOTC(KM1,WORK,1,A(1,K+1), - 2 1)),0.0E0) - A(K,K+1) = A(K,K+1) + CDOTC(KM1,A(1,K),1,A(1,K+1),1) - CALL CCOPY(KM1,A(1,K),1,WORK,1) - DO 200 J = 1, KM1 - A(J,K) = CDOTC(J,A(1,J),1,WORK,1) - CALL CAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1) - 200 CONTINUE - A(K,K) = A(K,K) - 1 + CMPLX(REAL(CDOTC(KM1,WORK,1,A(1,K),1)), - 2 0.0E0) - 210 CONTINUE - KSTEP = 2 - 220 CONTINUE -C -C SWAP -C - KS = ABS(KPVT(K)) - IF (KS .EQ. K) GO TO 250 - CALL CSWAP(KS,A(1,KS),1,A(1,K),1) - DO 230 JB = KS, K - J = K + KS - JB - TEMP = CONJG(A(J,K)) - A(J,K) = CONJG(A(KS,J)) - A(KS,J) = TEMP - 230 CONTINUE - IF (KSTEP .EQ. 1) GO TO 240 - TEMP = A(KS,K+1) - A(KS,K+1) = A(K,K+1) - A(K,K+1) = TEMP - 240 CONTINUE - 250 CONTINUE - K = K + KSTEP - GO TO 150 - 260 CONTINUE - 270 CONTINUE - RETURN - END diff --git a/slatec/chiev.f b/slatec/chiev.f deleted file mode 100644 index 914ab41..0000000 --- a/slatec/chiev.f +++ /dev/null @@ -1,202 +0,0 @@ -*DECK CHIEV - SUBROUTINE CHIEV (A, LDA, N, E, V, LDV, WORK, JOB, INFO) -C***BEGIN PROLOGUE CHIEV -C***PURPOSE Compute the eigenvalues and, optionally, the eigenvectors -C of a complex Hermitian matrix. -C***LIBRARY SLATEC -C***CATEGORY D4A3 -C***TYPE COMPLEX (SSIEV-S, CHIEV-C) -C***KEYWORDS COMPLEX HERMITIAN, EIGENVALUES, EIGENVECTORS, MATRIX, -C SYMMETRIC -C***AUTHOR Kahaner, D. K., (NBS) -C Moler, C. B., (U. of New Mexico) -C Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C David Kahaner, Cleve Moler, G. W. Stewart, -C N.B.S. U.N.M. N.B.S./U.MD. -C -C Abstract -C CHIEV computes the eigenvalues and, optionally, -C the eigenvectors of a complex Hermitian matrix. -C -C Call Sequence Parameters- -C (the values of parameters marked with * (star) will be changed -C by CHIEV.) -C -C A* COMPLEX(LDA,N) -C complex Hermitian input matrix. -C Only the upper triangle of A need be -C filled in. Elements on diagonal must be real. -C -C LDA INTEGER -C set by the user to -C the leading dimension of the complex array A. -C -C N INTEGER -C set by the user to -C the order of the matrices A and V, and -C the number of elements in E. -C -C E* REAL(N) -C on return from CHIEV E contains the eigenvalues of A. -C See also INFO below. -C -C V* COMPLEX(LDV,N) -C on return from CHIEV if the user has set JOB -C = 0 V is not referenced. -C = nonzero the N eigenvectors of A are stored in the -C first N columns of V. See also INFO below. -C -C LDV INTEGER -C set by the user to -C the leading dimension of the array V if JOB is also -C set nonzero. In that case N must be .LE. LDV. -C If JOB is set to zero LDV is not referenced. -C -C WORK* REAL(4N) -C temporary storage vector. Contents changed by CHIEV. -C -C JOB INTEGER -C set by the user to -C = 0 eigenvalues only to be calculated by CHIEV. -C Neither V nor LDV are referenced. -C = nonzero eigenvalues and vectors to be calculated. -C In this case A and V must be distinct arrays -C also if LDA .GT. LDV CHIEV changes all the -C elements of A thru column N. If LDA < LDV -C CHIEV changes all the elements of V through -C column N. If LDA = LDV only A(I,J) and V(I, -C J) for I,J = 1,...,N are changed by CHIEV. -C -C INFO* INTEGER -C on return from CHIEV the value of INFO is -C = 0 normal return, calculation successful. -C = K if the eigenvalue iteration fails to converge, -C eigenvalues (and eigenvectors if requested) -C 1 through K-1 are correct. -C -C Error Messages -C No. 1 recoverable N is greater than LDA -C No. 2 recoverable N is less than one. -C No. 3 recoverable JOB is nonzero and N is greater than LDV -C No. 4 warning LDA > LDV, elements of A other than the -C N by N input elements have been changed -C No. 5 warning LDA < LDV, elements of V other than the -C N by N output elements have been changed -C No. 6 recoverable nonreal element on diagonal of A. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED HTRIBK, HTRIDI, IMTQL2, SCOPY, SCOPYM, TQLRAT, -C XERMSG -C***REVISION HISTORY (YYMMDD) -C 800808 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***END PROLOGUE CHIEV - INTEGER I,INFO,J,JOB,K,L,LDA,LDV,M,MDIM,N - REAL A(*),E(*),WORK(*),V(*) -C***FIRST EXECUTABLE STATEMENT CHIEV - IF (N .GT. LDA) CALL XERMSG ('SLATEC', 'CHIEV', 'N .GT. LDA.', 1, - + 1) - IF(N .GT. LDA) RETURN - IF (N .LT. 1) CALL XERMSG ('SLATEC', 'CHIEV', 'N .LT. 1', 2, 1) - IF(N .LT. 1) RETURN - IF(N .EQ. 1 .AND. JOB .EQ. 0) GO TO 35 - MDIM = 2 * LDA - IF(JOB .EQ. 0) GO TO 5 - IF (N .GT. LDV) CALL XERMSG ('SLATEC', 'CHIEV', - + 'JOB .NE. 0 AND N .GT. LDV.', 3, 1) - IF(N .GT. LDV) RETURN - IF(N .EQ. 1) GO TO 35 -C -C REARRANGE A IF NECESSARY WHEN LDA.GT.LDV AND JOB .NE.0 -C - MDIM = MIN(MDIM,2 * LDV) - IF (LDA .LT. LDV) CALL XERMSG ('SLATEC', 'CHIEV', - + 'LDA.LT.LDV, ELEMENTS OF V OTHER THAN THE N BY N OUTPUT ' // - + 'ELEMENTS HAVE BEEN CHANGED.', 5, 0) - IF(LDA.LE.LDV) GO TO 5 - CALL XERMSG ('SLATEC', 'CHIEV', - + 'LDA.GT.LDV, ELEMENTS OF A OTHER THAN THE N BY N INPUT ' // - + 'ELEMENTS HAVE BEEN CHANGED.', 4, 0) - L = N - 1 - DO 4 J=1,L - M = 1+J*2*LDV - K = 1+J*2*LDA - CALL SCOPY(2*N,A(K),1,A(M),1) - 4 CONTINUE - 5 CONTINUE -C -C FILL IN LOWER TRIANGLE OF A, COLUMN BY COLUMN. -C - DO 6 J = 1,N - K = (J-1)*(MDIM+2)+1 - IF (A(K+1) .NE. 0.0) CALL XERMSG ('SLATEC', 'CHIEV', - + 'NONREAL ELEMENT ON DIAGONAL OF A', 6, 1) - IF(A(K+1) .NE.0.0) RETURN - CALL SCOPY(N-J+1,A(K),MDIM,A(K),2) - CALL SCOPYM(N-J+1,A(K+1),MDIM,A(K+1),2) - 6 CONTINUE -C -C SEPARATE REAL AND IMAGINARY PARTS -C - DO 10 J = 1, N - K = (J-1) * MDIM +1 - L = K + N - CALL SCOPY(N,A(K+1),2,WORK(1),1) - CALL SCOPY(N,A(K),2,A(K),1) - CALL SCOPY(N,WORK(1),1,A(L),1) - 10 CONTINUE -C -C REDUCE A TO TRIDIAGONAL MATRIX. -C - CALL HTRIDI(MDIM,N,A(1),A(N+1),E,WORK(1),WORK(N+1), - 1 WORK(2*N+1)) - IF(JOB .NE. 0) GOTO 15 -C -C EIGENVALUES ONLY. -C - CALL TQLRAT(N,E,WORK(N+1),INFO) - RETURN -C -C EIGENVALUES AND EIGENVECTORS. -C - 15 DO 17 J = 1,N - K = (J-1) * MDIM + 1 - M = K + N - 1 - DO 16 I = K,M - 16 V(I) = 0. - I = K + J - 1 - V(I) = 1. - 17 CONTINUE - CALL IMTQL2(MDIM,N,E,WORK(1),V,INFO) - IF(INFO .NE. 0) RETURN - CALL HTRIBK(MDIM,N,A(1),A(N+1),WORK(2*N+1),N,V(1),V(N+1)) -C -C CONVERT EIGENVECTORS TO COMPLEX STORAGE. -C - DO 20 J = 1,N - K = (J-1) * MDIM + 1 - I = (J-1) * 2 * LDV + 1 - L = K + N - CALL SCOPY(N,V(K),1,WORK(1),1) - CALL SCOPY(N,V(L),1,V(I+1),2) - CALL SCOPY(N,WORK(1),1,V(I),2) - 20 CONTINUE - RETURN -C -C TAKE CARE OF N=1 CASE. -C - 35 IF (A(2) .NE. 0.) CALL XERMSG ('SLATEC', 'CHIEV', - + 'NONREAL ELEMENT ON DIAGONAL OF A', 6, 1) - IF(A(2) .NE. 0.) RETURN - E(1) = A(1) - INFO = 0 - IF(JOB .EQ. 0) RETURN - V(1) = A(1) - V(2) = 0. - RETURN - END diff --git a/slatec/chifa.f b/slatec/chifa.f deleted file mode 100644 index eb1ce31..0000000 --- a/slatec/chifa.f +++ /dev/null @@ -1,242 +0,0 @@ -*DECK CHIFA - SUBROUTINE CHIFA (A, LDA, N, KPVT, INFO) -C***BEGIN PROLOGUE CHIFA -C***PURPOSE Factor a complex Hermitian matrix by elimination -C (symmetric pivoting). -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2D1A -C***TYPE COMPLEX (SSIFA-S, DSIFA-D, CHIFA-C, CSIFA-C) -C***KEYWORDS HERMITIAN, LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION -C***AUTHOR Bunch, J., (UCSD) -C***DESCRIPTION -C -C CHIFA factors a complex Hermitian matrix by elimination -C with symmetric pivoting. -C -C To solve A*X = B , follow CHIFA by CHISL. -C To compute INVERSE(A)*C , follow CHIFA by CHISL. -C To compute DETERMINANT(A) , follow CHIFA by CHIDI. -C To compute INERTIA(A) , follow CHIFA by CHIDI. -C To compute INVERSE(A) , follow CHIFA by CHIDI. -C -C On Entry -C -C A COMPLEX(LDA,N) -C the Hermitian matrix to be factored. -C Only the diagonal and upper triangle are used. -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 a block diagonal matrix and the multipliers which -C were used to obtain it. -C The factorization can be written A = U*D*CTRANS(U) -C where U is a product of permutation and unit -C upper triangular matrices , CTRANS(U) is the -C conjugate transpose of U , and D is block diagonal -C with 1 by 1 and 2 by 2 blocks. -C -C KVPT INTEGER(N) -C an integer vector of pivot indices. -C -C INFO INTEGER -C = 0 normal value. -C = K if the K-th pivot block is singular. This is -C not an error condition for this subroutine, -C but it does indicate that CHISL or CHIDI may -C divide by zero if called. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CSWAP, ICAMAX -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Modified routine equivalence list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CHIFA - INTEGER LDA,N,KPVT(*),INFO - COMPLEX A(LDA,*) -C - COMPLEX AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T - REAL ABSAKK,ALPHA,COLMAX,ROWMAX - INTEGER IMAX,IMAXP1,J,JJ,JMAX,K,KM1,KM2,KSTEP,ICAMAX - LOGICAL SWAP - COMPLEX ZDUM - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) -C***FIRST EXECUTABLE STATEMENT CHIFA -C -C INITIALIZE -C -C ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE. -C - ALPHA = (1.0E0 + SQRT(17.0E0))/8.0E0 -C - INFO = 0 -C -C MAIN LOOP ON K, WHICH GOES FROM N TO 1. -C - K = N - 10 CONTINUE -C -C LEAVE THE LOOP IF K=0 OR K=1. -C - IF (K .EQ. 0) GO TO 200 - IF (K .GT. 1) GO TO 20 - KPVT(1) = 1 - IF (CABS1(A(1,1)) .EQ. 0.0E0) INFO = 1 - GO TO 200 - 20 CONTINUE -C -C THIS SECTION OF CODE DETERMINES THE KIND OF -C ELIMINATION TO BE PERFORMED. WHEN IT IS COMPLETED, -C KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND -C SWAP WILL BE SET TO .TRUE. IF AN INTERCHANGE IS -C REQUIRED. -C - KM1 = K - 1 - ABSAKK = CABS1(A(K,K)) -C -C DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN -C COLUMN K. -C - IMAX = ICAMAX(K-1,A(1,K),1) - COLMAX = CABS1(A(IMAX,K)) - IF (ABSAKK .LT. ALPHA*COLMAX) GO TO 30 - KSTEP = 1 - SWAP = .FALSE. - GO TO 90 - 30 CONTINUE -C -C DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN -C ROW IMAX. -C - ROWMAX = 0.0E0 - IMAXP1 = IMAX + 1 - DO 40 J = IMAXP1, K - ROWMAX = MAX(ROWMAX,CABS1(A(IMAX,J))) - 40 CONTINUE - IF (IMAX .EQ. 1) GO TO 50 - JMAX = ICAMAX(IMAX-1,A(1,IMAX),1) - ROWMAX = MAX(ROWMAX,CABS1(A(JMAX,IMAX))) - 50 CONTINUE - IF (CABS1(A(IMAX,IMAX)) .LT. ALPHA*ROWMAX) GO TO 60 - KSTEP = 1 - SWAP = .TRUE. - GO TO 80 - 60 CONTINUE - IF (ABSAKK .LT. ALPHA*COLMAX*(COLMAX/ROWMAX)) GO TO 70 - KSTEP = 1 - SWAP = .FALSE. - GO TO 80 - 70 CONTINUE - KSTEP = 2 - SWAP = IMAX .NE. KM1 - 80 CONTINUE - 90 CONTINUE - IF (MAX(ABSAKK,COLMAX) .NE. 0.0E0) GO TO 100 -C -C COLUMN K IS ZERO. SET INFO AND ITERATE THE LOOP. -C - KPVT(K) = K - INFO = K - GO TO 190 - 100 CONTINUE - IF (KSTEP .EQ. 2) GO TO 140 -C -C 1 X 1 PIVOT BLOCK. -C - IF (.NOT.SWAP) GO TO 120 -C -C PERFORM AN INTERCHANGE. -C - CALL CSWAP(IMAX,A(1,IMAX),1,A(1,K),1) - DO 110 JJ = IMAX, K - J = K + IMAX - JJ - T = CONJG(A(J,K)) - A(J,K) = CONJG(A(IMAX,J)) - A(IMAX,J) = T - 110 CONTINUE - 120 CONTINUE -C -C PERFORM THE ELIMINATION. -C - DO 130 JJ = 1, KM1 - J = K - JJ - MULK = -A(J,K)/A(K,K) - T = CONJG(MULK) - CALL CAXPY(J,T,A(1,K),1,A(1,J),1) - A(J,J) = CMPLX(REAL(A(J,J)),0.0E0) - A(J,K) = MULK - 130 CONTINUE -C -C SET THE PIVOT ARRAY. -C - KPVT(K) = K - IF (SWAP) KPVT(K) = IMAX - GO TO 190 - 140 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - IF (.NOT.SWAP) GO TO 160 -C -C PERFORM AN INTERCHANGE. -C - CALL CSWAP(IMAX,A(1,IMAX),1,A(1,K-1),1) - DO 150 JJ = IMAX, KM1 - J = KM1 + IMAX - JJ - T = CONJG(A(J,K-1)) - A(J,K-1) = CONJG(A(IMAX,J)) - A(IMAX,J) = T - 150 CONTINUE - T = A(K-1,K) - A(K-1,K) = A(IMAX,K) - A(IMAX,K) = T - 160 CONTINUE -C -C PERFORM THE ELIMINATION. -C - KM2 = K - 2 - IF (KM2 .EQ. 0) GO TO 180 - AK = A(K,K)/A(K-1,K) - AKM1 = A(K-1,K-1)/CONJG(A(K-1,K)) - DENOM = 1.0E0 - AK*AKM1 - DO 170 JJ = 1, KM2 - J = KM1 - JJ - BK = A(J,K)/A(K-1,K) - BKM1 = A(J,K-1)/CONJG(A(K-1,K)) - MULK = (AKM1*BK - BKM1)/DENOM - MULKM1 = (AK*BKM1 - BK)/DENOM - T = CONJG(MULK) - CALL CAXPY(J,T,A(1,K),1,A(1,J),1) - T = CONJG(MULKM1) - CALL CAXPY(J,T,A(1,K-1),1,A(1,J),1) - A(J,K) = MULK - A(J,K-1) = MULKM1 - A(J,J) = CMPLX(REAL(A(J,J)),0.0E0) - 170 CONTINUE - 180 CONTINUE -C -C SET THE PIVOT ARRAY. -C - KPVT(K) = 1 - K - IF (SWAP) KPVT(K) = -IMAX - KPVT(K-1) = KPVT(K) - 190 CONTINUE - K = K - KSTEP - GO TO 10 - 200 CONTINUE - RETURN - END diff --git a/slatec/chisl.f b/slatec/chisl.f deleted file mode 100644 index 2623738..0000000 --- a/slatec/chisl.f +++ /dev/null @@ -1,187 +0,0 @@ -*DECK CHISL - SUBROUTINE CHISL (A, LDA, N, KPVT, B) -C***BEGIN PROLOGUE CHISL -C***PURPOSE Solve the complex Hermitian system using factors obtained -C from CHIFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2D1A -C***TYPE COMPLEX (SSISL-S, DSISL-D, CHISL-C, CSISL-C) -C***KEYWORDS HERMITIAN, LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE -C***AUTHOR Bunch, J., (UCSD) -C***DESCRIPTION -C -C CHISL solves the complex Hermitian system -C A * X = B -C using the factors computed by CHIFA. -C -C On Entry -C -C A COMPLEX(LDA,N) -C the output from CHIFA. -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 KVPT INTEGER(N) -C the pivot vector from CHIFA. -C -C B COMPLEX(N) -C the right hand side vector. -C -C On Return -C -C B the solution vector X . -C -C Error Condition -C -C A division by zero may occur if CHICO has set RCOND .EQ. 0.0 -C or CHIFA has set INFO .NE. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL CHIFA(A,LDA,N,KVPT,INFO) -C IF (INFO .NE. 0) GO TO ... -C DO 10 J = 1, p -C CALL CHISL(A,LDA,N,KVPT,C(1,J)) -C 10 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CDOTC -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Modified routine equivalence list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CHISL - INTEGER LDA,N,KPVT(*) - COMPLEX A(LDA,*),B(*) -C - COMPLEX AK,AKM1,BK,BKM1,CDOTC,DENOM,TEMP - INTEGER K,KP -C -C LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND -C D INVERSE TO B. -C -C***FIRST EXECUTABLE STATEMENT CHISL - K = N - 10 IF (K .EQ. 0) GO TO 80 - IF (KPVT(K) .LT. 0) GO TO 40 -C -C 1 X 1 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 30 - KP = KPVT(K) - IF (KP .EQ. K) GO TO 20 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 20 CONTINUE -C -C APPLY THE TRANSFORMATION. -C - CALL CAXPY(K-1,B(K),A(1,K),1,B(1),1) - 30 CONTINUE -C -C APPLY D INVERSE. -C - B(K) = B(K)/A(K,K) - K = K - 1 - GO TO 70 - 40 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - IF (K .EQ. 2) GO TO 60 - KP = ABS(KPVT(K)) - IF (KP .EQ. K - 1) GO TO 50 -C -C INTERCHANGE. -C - TEMP = B(K-1) - B(K-1) = B(KP) - B(KP) = TEMP - 50 CONTINUE -C -C APPLY THE TRANSFORMATION. -C - CALL CAXPY(K-2,B(K),A(1,K),1,B(1),1) - CALL CAXPY(K-2,B(K-1),A(1,K-1),1,B(1),1) - 60 CONTINUE -C -C APPLY D INVERSE. -C - AK = A(K,K)/CONJG(A(K-1,K)) - AKM1 = A(K-1,K-1)/A(K-1,K) - BK = B(K)/CONJG(A(K-1,K)) - BKM1 = B(K-1)/A(K-1,K) - DENOM = AK*AKM1 - 1.0E0 - B(K) = (AKM1*BK - BKM1)/DENOM - B(K-1) = (AK*BKM1 - BK)/DENOM - K = K - 2 - 70 CONTINUE - GO TO 10 - 80 CONTINUE -C -C LOOP FORWARD APPLYING THE TRANSFORMATIONS. -C - K = 1 - 90 IF (K .GT. N) GO TO 160 - IF (KPVT(K) .LT. 0) GO TO 120 -C -C 1 X 1 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 110 -C -C APPLY THE TRANSFORMATION. -C - B(K) = B(K) + CDOTC(K-1,A(1,K),1,B(1),1) - KP = KPVT(K) - IF (KP .EQ. K) GO TO 100 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 100 CONTINUE - 110 CONTINUE - K = K + 1 - GO TO 150 - 120 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 140 -C -C APPLY THE TRANSFORMATION. -C - B(K) = B(K) + CDOTC(K-1,A(1,K),1,B(1),1) - B(K+1) = B(K+1) + CDOTC(K-1,A(1,K+1),1,B(1),1) - KP = ABS(KPVT(K)) - IF (KP .EQ. K) GO TO 130 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 130 CONTINUE - 140 CONTINUE - K = K + 2 - 150 CONTINUE - GO TO 90 - 160 CONTINUE - RETURN - END diff --git a/slatec/chkder.f b/slatec/chkder.f deleted file mode 100644 index f699bc6..0000000 --- a/slatec/chkder.f +++ /dev/null @@ -1,158 +0,0 @@ -*DECK CHKDER - SUBROUTINE CHKDER (M, N, X, FVEC, FJAC, LDFJAC, XP, FVECP, MODE, - + ERR) -C***BEGIN PROLOGUE CHKDER -C***PURPOSE Check the gradients of M nonlinear functions in N -C variables, evaluated at a point X, for consistency -C with the functions themselves. -C***LIBRARY SLATEC -C***CATEGORY F3, G4C -C***TYPE SINGLE PRECISION (CHKDER-S, DCKDER-D) -C***KEYWORDS GRADIENTS, JACOBIAN, MINPACK, NONLINEAR -C***AUTHOR Hiebert, K. L. (SNLA) -C***DESCRIPTION -C -C This subroutine is a companion routine to SNLS1,SNLS1E,SNSQ,and -C SNSQE which may be used to check the calculation of the Jacobian. -C -C SUBROUTINE CHKDER -C -C This subroutine checks the gradients of M nonlinear functions -C in N variables, evaluated at a point X, for consistency with -C the functions themselves. The user must call CKDER twice, -C first with MODE = 1 and then with MODE = 2. -C -C MODE = 1. On input, X must contain the point of evaluation. -C On output, XP is set to a neighboring point. -C -C MODE = 2. On input, FVEC must contain the functions and the -C rows of FJAC must contain the gradients -C of the respective functions each evaluated -C at X, and FVECP must contain the functions -C evaluated at XP. -C On output, ERR contains measures of correctness of -C the respective gradients. -C -C The subroutine does not perform reliably if cancellation or -C rounding errors cause a severe loss of significance in the -C evaluation of a function. Therefore, none of the components -C of X should be unusually small (in particular, zero) or any -C other value which may cause loss of significance. -C -C The SUBROUTINE statement is -C -C SUBROUTINE CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR) -C -C where -C -C M is a positive integer input variable set to the number -C of functions. -C -C N is a positive integer input variable set to the number -C of variables. -C -C X is an input array of length N. -C -C FVEC is an array of length M. On input when MODE = 2, -C FVEC must contain the functions evaluated at X. -C -C FJAC is an M by N array. On input when MODE = 2, -C the rows of FJAC must contain the gradients of -C the respective functions evaluated at X. -C -C LDFJAC is a positive integer input parameter not less than M -C which specifies the leading dimension of the array FJAC. -C -C XP is an array of length N. On output when MODE = 1, -C XP is set to a neighboring point of X. -C -C FVECP is an array of length M. On input when MODE = 2, -C FVECP must contain the functions evaluated at XP. -C -C MODE is an integer input variable set to 1 on the first call -C and 2 on the second. Other values of MODE are equivalent -C to MODE = 1. -C -C ERR is an array of length M. On output when MODE = 2, -C ERR contains measures of correctness of the respective -C gradients. If there is no severe loss of significance, -C then if ERR(I) is 1.0 the I-th gradient is correct, -C while if ERR(I) is 0.0 the I-th gradient is incorrect. -C For values of ERR between 0.0 and 1.0, the categorization -C is less certain. In general, a value of ERR(I) greater -C than 0.5 indicates that the I-th gradient is probably -C correct, while a value of ERR(I) less than 0.5 indicates -C that the I-th gradient is probably incorrect. -C -C***REFERENCES M. J. D. Powell, A hybrid method for nonlinear equa- -C tions. In Numerical Methods for Nonlinear Algebraic -C Equations, P. Rabinowitz, Editor. Gordon and Breach, -C 1988. -C***ROUTINES CALLED R1MACH -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CHKDER - INTEGER M,N,LDFJAC,MODE - REAL X(*),FVEC(*),FJAC(LDFJAC,*),XP(*),FVECP(*),ERR(*) - INTEGER I,J - REAL EPS,EPSF,EPSLOG,EPSMCH,FACTOR,ONE,TEMP,ZERO - REAL R1MACH - SAVE FACTOR, ONE, ZERO -C - DATA FACTOR,ONE,ZERO /1.0E2,1.0E0,0.0E0/ -C***FIRST EXECUTABLE STATEMENT CHKDER - EPSMCH = R1MACH(4) -C - EPS = SQRT(EPSMCH) -C - IF (MODE .EQ. 2) GO TO 20 -C -C MODE = 1. -C - DO 10 J = 1, N - TEMP = EPS*ABS(X(J)) - IF (TEMP .EQ. ZERO) TEMP = EPS - XP(J) = X(J) + TEMP - 10 CONTINUE - GO TO 70 - 20 CONTINUE -C -C MODE = 2. -C - EPSF = FACTOR*EPSMCH - EPSLOG = LOG10(EPS) - DO 30 I = 1, M - ERR(I) = ZERO - 30 CONTINUE - DO 50 J = 1, N - TEMP = ABS(X(J)) - IF (TEMP .EQ. ZERO) TEMP = ONE - DO 40 I = 1, M - ERR(I) = ERR(I) + TEMP*FJAC(I,J) - 40 CONTINUE - 50 CONTINUE - DO 60 I = 1, M - TEMP = ONE - IF (FVEC(I) .NE. ZERO .AND. FVECP(I) .NE. ZERO - 1 .AND. ABS(FVECP(I)-FVEC(I)) .GE. EPSF*ABS(FVEC(I))) - 2 TEMP = EPS*ABS((FVECP(I)-FVEC(I))/EPS-ERR(I)) - 3 /(ABS(FVEC(I)) + ABS(FVECP(I))) - ERR(I) = ONE - IF (TEMP .GT. EPSMCH .AND. TEMP .LT. EPS) - 1 ERR(I) = (LOG10(TEMP) - EPSLOG)/EPSLOG - IF (TEMP .GE. EPS) ERR(I) = ZERO - 60 CONTINUE - 70 CONTINUE -C - RETURN -C -C LAST CARD OF SUBROUTINE CHKDER. -C - END diff --git a/slatec/chkpr4.f b/slatec/chkpr4.f deleted file mode 100644 index 74a110b..0000000 --- a/slatec/chkpr4.f +++ /dev/null @@ -1,70 +0,0 @@ -*DECK CHKPR4 - SUBROUTINE CHKPR4 (IORDER, A, B, M, MBDCND, C, D, N, NBDCND, COFX, - + IDMN, IERROR) -C***BEGIN PROLOGUE CHKPR4 -C***SUBSIDIARY -C***PURPOSE Subsidiary to SEPX4 -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (CHKPR4-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This program checks the input parameters for errors. -C -C***SEE ALSO SEPX4 -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE CHKPR4 - EXTERNAL COFX -C***FIRST EXECUTABLE STATEMENT CHKPR4 - IERROR = 1 - IF (A.GE.B .OR. C.GE.D) RETURN -C -C CHECK BOUNDARY SWITCHES -C - IERROR = 2 - IF (MBDCND.LT.0 .OR. MBDCND.GT.4) RETURN - IERROR = 3 - IF (NBDCND.LT.0 .OR. NBDCND.GT.4) RETURN -C -C CHECK FIRST DIMENSION IN CALLING ROUTINE -C - IERROR = 5 - IF (IDMN .LT. 7) RETURN -C -C CHECK M -C - IERROR = 6 - IF (M.GT.(IDMN-1) .OR. M.LT.6) RETURN -C -C CHECK N -C - IERROR = 7 - IF (N .LT. 5) RETURN -C -C CHECK IORDER -C - IERROR = 8 - IF (IORDER.NE.2 .AND. IORDER.NE.4) RETURN -C -C CHECK THAT EQUATION IS ELLIPTIC -C - DLX = (B-A)/M - DO 30 I=2,M - XI = A+(I-1)*DLX - CALL COFX (XI,AI,BI,CI) - IF (AI.GT.0.0) GO TO 10 - IERROR=10 - RETURN - 10 CONTINUE - 30 CONTINUE -C -C NO ERROR FOUND -C - IERROR = 0 - RETURN - END diff --git a/slatec/chkprm.f b/slatec/chkprm.f deleted file mode 100644 index 18ca45b..0000000 --- a/slatec/chkprm.f +++ /dev/null @@ -1,81 +0,0 @@ -*DECK CHKPRM - SUBROUTINE CHKPRM (INTL, IORDER, A, B, M, MBDCND, C, D, N, NBDCND, - + COFX, COFY, IDMN, IERROR) -C***BEGIN PROLOGUE CHKPRM -C***SUBSIDIARY -C***PURPOSE Subsidiary to SEPELI -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (CHKPRM-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This program checks the input parameters for errors. -C -C***SEE ALSO SEPELI -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE CHKPRM -C - EXTERNAL COFX ,COFY -C***FIRST EXECUTABLE STATEMENT CHKPRM - IERROR = 1 - IF (A.GE.B .OR. C.GE.D) RETURN -C -C CHECK BOUNDARY SWITCHES -C - IERROR = 2 - IF (MBDCND.LT.0 .OR. MBDCND.GT.4) RETURN - IERROR = 3 - IF (NBDCND.LT.0 .OR. NBDCND.GT.4) RETURN -C -C CHECK FIRST DIMENSION IN CALLING ROUTINE -C - IERROR = 5 - IF (IDMN .LT. 7) RETURN -C -C CHECK M -C - IERROR = 6 - IF (M.GT.(IDMN-1) .OR. M.LT.6) RETURN -C -C CHECK N -C - IERROR = 7 - IF (N .LT. 5) RETURN -C -C CHECK IORDER -C - IERROR = 8 - IF (IORDER.NE.2 .AND. IORDER.NE.4) RETURN -C -C CHECK INTL -C - IERROR = 9 - IF (INTL.NE.0 .AND. INTL.NE.1) RETURN -C -C CHECK THAT EQUATION IS ELLIPTIC -C - DLX = (B-A)/M - DLY = (D-C)/N - DO 30 I=2,M - XI = A+(I-1)*DLX - CALL COFX (XI,AI,BI,CI) - DO 20 J=2,N - YJ = C+(J-1)*DLY - CALL COFY (YJ,DJ,EJ,FJ) - IF (AI*DJ .GT. 0.0) GO TO 10 - IERROR = 10 - RETURN - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE -C -C NO ERROR FOUND -C - IERROR = 0 - RETURN - END diff --git a/slatec/chksn4.f b/slatec/chksn4.f deleted file mode 100644 index 3c3b81a..0000000 --- a/slatec/chksn4.f +++ /dev/null @@ -1,59 +0,0 @@ -*DECK CHKSN4 - SUBROUTINE CHKSN4 (MBDCND, NBDCND, ALPHA, BETA, COFX, SINGLR) -C***BEGIN PROLOGUE CHKSN4 -C***SUBSIDIARY -C***PURPOSE Subsidiary to SEPX4 -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (CHKSN4-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This subroutine checks if the PDE SEPX4 -C must solve is a singular operator. -C -C***SEE ALSO SEPX4 -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS SPL4 -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE CHKSN4 -C - COMMON /SPL4/ KSWX ,KSWY ,K ,L , - 1 AIT ,BIT ,CIT ,DIT , - 2 MIT ,NIT ,IS ,MS , - 3 JS ,NS ,DLX ,DLY , - 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 - LOGICAL SINGLR - EXTERNAL COFX -C***FIRST EXECUTABLE STATEMENT CHKSN4 - SINGLR = .FALSE. -C -C CHECK IF THE BOUNDARY CONDITIONS ARE -C ENTIRELY PERIODIC AND/OR MIXED -C - IF ((MBDCND.NE.0 .AND. MBDCND.NE.3) .OR. - 1 (NBDCND.NE.0 .AND. NBDCND.NE.3)) RETURN -C -C CHECK THAT MIXED CONDITIONS ARE PURE NEUMAN -C - IF (MBDCND .NE. 3) GO TO 10 - IF (ALPHA.NE.0.0 .OR. BETA.NE.0.0) RETURN - 10 CONTINUE -C -C CHECK THAT NON-DERIVATIVE COEFFICIENT FUNCTIONS -C ARE ZERO -C - DO 30 I=IS,MS - XI = AIT+(I-1)*DLX - CALL COFX (XI,AI,BI,CI) - IF (CI .NE. 0.0) RETURN - 30 CONTINUE -C -C THE OPERATOR MUST BE SINGULAR IF THIS POINT IS REACHED -C - SINGLR = .TRUE. - RETURN - END diff --git a/slatec/chksng.f b/slatec/chksng.f deleted file mode 100644 index 9cb1730..0000000 --- a/slatec/chksng.f +++ /dev/null @@ -1,66 +0,0 @@ -*DECK CHKSNG - SUBROUTINE CHKSNG (MBDCND, NBDCND, ALPHA, BETA, GAMA, XNU, COFX, - + COFY, SINGLR) -C***BEGIN PROLOGUE CHKSNG -C***SUBSIDIARY -C***PURPOSE Subsidiary to SEPELI -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (CHKSNG-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This subroutine checks if the PDE SEPELI -C must solve is a singular operator. -C -C***SEE ALSO SEPELI -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS SPLPCM -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE CHKSNG -C - COMMON /SPLPCM/ KSWX ,KSWY ,K ,L , - 1 AIT ,BIT ,CIT ,DIT , - 2 MIT ,NIT ,IS ,MS , - 3 JS ,NS ,DLX ,DLY , - 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 - LOGICAL SINGLR -C***FIRST EXECUTABLE STATEMENT CHKSNG - SINGLR = .FALSE. -C -C CHECK IF THE BOUNDARY CONDITIONS ARE -C ENTIRELY PERIODIC AND/OR MIXED -C - IF ((MBDCND.NE.0 .AND. MBDCND.NE.3) .OR. - 1 (NBDCND.NE.0 .AND. NBDCND.NE.3)) RETURN -C -C CHECK THAT MIXED CONDITIONS ARE PURE NEUMAN -C - IF (MBDCND .NE. 3) GO TO 10 - IF (ALPHA.NE.0.0 .OR. BETA.NE.0.0) RETURN - 10 IF (NBDCND .NE. 3) GO TO 20 - IF (GAMA.NE.0.0 .OR. XNU.NE.0.0) RETURN - 20 CONTINUE -C -C CHECK THAT NON-DERIVATIVE COEFFICIENT FUNCTIONS -C ARE ZERO -C - DO 30 I=IS,MS - XI = AIT+(I-1)*DLX - CALL COFX (XI,AI,BI,CI) - IF (CI .NE. 0.0) RETURN - 30 CONTINUE - DO 40 J=JS,NS - YJ = CIT+(J-1)*DLY - CALL COFY (YJ,DJ,EJ,FJ) - IF (FJ .NE. 0.0) RETURN - 40 CONTINUE -C -C THE OPERATOR MUST BE SINGULAR IF THIS POINT IS REACHED -C - SINGLR = .TRUE. - RETURN - END diff --git a/slatec/chpco.f b/slatec/chpco.f deleted file mode 100644 index 5942607..0000000 --- a/slatec/chpco.f +++ /dev/null @@ -1,305 +0,0 @@ -*DECK CHPCO - SUBROUTINE CHPCO (AP, N, KPVT, RCOND, Z) -C***BEGIN PROLOGUE CHPCO -C***PURPOSE Factor a complex Hermitian matrix stored in packed form by -C elimination with symmetric pivoting and estimate the -C condition number of the matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2D1A -C***TYPE COMPLEX (SSPCO-S, DSPCO-D, CHPCO-C, CSPCO-C) -C***KEYWORDS CONDITION NUMBER, HERMITIAN, LINEAR ALGEBRA, LINPACK, -C MATRIX FACTORIZATION, PACKED -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C CHPCO factors a complex Hermitian matrix stored in packed -C form by elimination with symmetric pivoting and estimates -C the condition of the matrix. -C -C if RCOND is not needed, CHPFA is slightly faster. -C To solve A*X = B , follow CHPCO by CHPSL. -C To compute INVERSE(A)*C , follow CHPCO by CHPSL. -C To compute INVERSE(A) , follow CHPCO by CHPDI. -C To compute DETERMINANT(A) , follow CHPCO by CHPDI. -C To compute INERTIA(A), follow CHPCO by CHPDI. -C -C On Entry -C -C AP COMPLEX (N*(N+1)/2) -C the packed form of a Hermitian matrix A . The -C columns of the upper triangle are stored sequentially -C in a one-dimensional array of length N*(N+1)/2 . -C See comments below for details. -C -C N INTEGER -C the order of the matrix A . -C -C Output -C -C AP a block diagonal matrix and the multipliers which -C were used to obtain it stored in packed form. -C The factorization can be written A = U*D*CTRANS(U) -C where U is a product of permutation and unit -C upper triangular matrices , CTRANS(U) is the -C conjugate transpose of U , and D is block diagonal -C with 1 by 1 and 2 by 2 blocks. -C -C KVPT INTEGER(N) -C an integer vector of pivot indices. -C -C RCOND REAL -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 COMPLEX(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 Packed Storage -C -C The following program segment will pack the upper -C triangle of a Hermitian matrix. -C -C K = 0 -C DO 20 J = 1, N -C DO 10 I = 1, J -C K = K + 1 -C AP(K) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CDOTC, CHPFA, CSSCAL, SCASUM -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Modified routine equivalence list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CHPCO - INTEGER N,KPVT(*) - COMPLEX AP(*),Z(*) - REAL RCOND -C - COMPLEX AK,AKM1,BK,BKM1,CDOTC,DENOM,EK,T - REAL ANORM,S,SCASUM,YNORM - INTEGER I,IJ,IK,IKM1,IKP1,INFO,J,JM1,J1 - INTEGER K,KK,KM1K,KM1KM1,KP,KPS,KS - COMPLEX ZDUM,ZDUM2,CSIGN1 - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) - CSIGN1(ZDUM,ZDUM2) = CABS1(ZDUM)*(ZDUM2/CABS1(ZDUM2)) -C -C FIND NORM OF A USING ONLY UPPER HALF -C -C***FIRST EXECUTABLE STATEMENT CHPCO - J1 = 1 - DO 30 J = 1, N - Z(J) = CMPLX(SCASUM(J,AP(J1),1),0.0E0) - IJ = J1 - J1 = J1 + J - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 20 - DO 10 I = 1, JM1 - Z(I) = CMPLX(REAL(Z(I))+CABS1(AP(IJ)),0.0E0) - IJ = IJ + 1 - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - ANORM = 0.0E0 - DO 40 J = 1, N - ANORM = MAX(ANORM,REAL(Z(J))) - 40 CONTINUE -C -C FACTOR -C - CALL CHPFA(AP,N,KPVT,INFO) -C -C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . -C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . -C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL -C GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . -C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. -C -C SOLVE U*D*W = E -C - EK = (1.0E0,0.0E0) - DO 50 J = 1, N - Z(J) = (0.0E0,0.0E0) - 50 CONTINUE - K = N - IK = (N*(N - 1))/2 - 60 IF (K .EQ. 0) GO TO 120 - KK = IK + K - IKM1 = IK - (K - 1) - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - KP = ABS(KPVT(K)) - KPS = K + 1 - KS - IF (KP .EQ. KPS) GO TO 70 - T = Z(KPS) - Z(KPS) = Z(KP) - Z(KP) = T - 70 CONTINUE - IF (CABS1(Z(K)) .NE. 0.0E0) EK = CSIGN1(EK,Z(K)) - Z(K) = Z(K) + EK - CALL CAXPY(K-KS,Z(K),AP(IK+1),1,Z(1),1) - IF (KS .EQ. 1) GO TO 80 - IF (CABS1(Z(K-1)) .NE. 0.0E0) EK = CSIGN1(EK,Z(K-1)) - Z(K-1) = Z(K-1) + EK - CALL CAXPY(K-KS,Z(K-1),AP(IKM1+1),1,Z(1),1) - 80 CONTINUE - IF (KS .EQ. 2) GO TO 100 - IF (CABS1(Z(K)) .LE. CABS1(AP(KK))) GO TO 90 - S = CABS1(AP(KK))/CABS1(Z(K)) - CALL CSSCAL(N,S,Z,1) - EK = CMPLX(S,0.0E0)*EK - 90 CONTINUE - IF (CABS1(AP(KK)) .NE. 0.0E0) Z(K) = Z(K)/AP(KK) - IF (CABS1(AP(KK)) .EQ. 0.0E0) Z(K) = (1.0E0,0.0E0) - GO TO 110 - 100 CONTINUE - KM1K = IK + K - 1 - KM1KM1 = IKM1 + K - 1 - AK = AP(KK)/CONJG(AP(KM1K)) - AKM1 = AP(KM1KM1)/AP(KM1K) - BK = Z(K)/CONJG(AP(KM1K)) - BKM1 = Z(K-1)/AP(KM1K) - DENOM = AK*AKM1 - 1.0E0 - Z(K) = (AKM1*BK - BKM1)/DENOM - Z(K-1) = (AK*BKM1 - BK)/DENOM - 110 CONTINUE - K = K - KS - IK = IK - K - IF (KS .EQ. 2) IK = IK - (K + 1) - GO TO 60 - 120 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) -C -C SOLVE CTRANS(U)*Y = W -C - K = 1 - IK = 0 - 130 IF (K .GT. N) GO TO 160 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. 1) GO TO 150 - Z(K) = Z(K) + CDOTC(K-1,AP(IK+1),1,Z(1),1) - IKP1 = IK + K - IF (KS .EQ. 2) - 1 Z(K+1) = Z(K+1) + CDOTC(K-1,AP(IKP1+1),1,Z(1),1) - KP = ABS(KPVT(K)) - IF (KP .EQ. K) GO TO 140 - T = Z(K) - Z(K) = Z(KP) - Z(KP) = T - 140 CONTINUE - 150 CONTINUE - IK = IK + K - IF (KS .EQ. 2) IK = IK + (K + 1) - K = K + KS - GO TO 130 - 160 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) -C - YNORM = 1.0E0 -C -C SOLVE U*D*V = Y -C - K = N - IK = N*(N - 1)/2 - 170 IF (K .EQ. 0) GO TO 230 - KK = IK + K - IKM1 = IK - (K - 1) - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. KS) GO TO 190 - KP = ABS(KPVT(K)) - KPS = K + 1 - KS - IF (KP .EQ. KPS) GO TO 180 - T = Z(KPS) - Z(KPS) = Z(KP) - Z(KP) = T - 180 CONTINUE - CALL CAXPY(K-KS,Z(K),AP(IK+1),1,Z(1),1) - IF (KS .EQ. 2) CALL CAXPY(K-KS,Z(K-1),AP(IKM1+1),1,Z(1),1) - 190 CONTINUE - IF (KS .EQ. 2) GO TO 210 - IF (CABS1(Z(K)) .LE. CABS1(AP(KK))) GO TO 200 - S = CABS1(AP(KK))/CABS1(Z(K)) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM - 200 CONTINUE - IF (CABS1(AP(KK)) .NE. 0.0E0) Z(K) = Z(K)/AP(KK) - IF (CABS1(AP(KK)) .EQ. 0.0E0) Z(K) = (1.0E0,0.0E0) - GO TO 220 - 210 CONTINUE - KM1K = IK + K - 1 - KM1KM1 = IKM1 + K - 1 - AK = AP(KK)/CONJG(AP(KM1K)) - AKM1 = AP(KM1KM1)/AP(KM1K) - BK = Z(K)/CONJG(AP(KM1K)) - BKM1 = Z(K-1)/AP(KM1K) - DENOM = AK*AKM1 - 1.0E0 - Z(K) = (AKM1*BK - BKM1)/DENOM - Z(K-1) = (AK*BKM1 - BK)/DENOM - 220 CONTINUE - K = K - KS - IK = IK - K - IF (KS .EQ. 2) IK = IK - (K + 1) - GO TO 170 - 230 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE CTRANS(U)*Z = V -C - K = 1 - IK = 0 - 240 IF (K .GT. N) GO TO 270 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. 1) GO TO 260 - Z(K) = Z(K) + CDOTC(K-1,AP(IK+1),1,Z(1),1) - IKP1 = IK + K - IF (KS .EQ. 2) - 1 Z(K+1) = Z(K+1) + CDOTC(K-1,AP(IKP1+1),1,Z(1),1) - KP = ABS(KPVT(K)) - IF (KP .EQ. K) GO TO 250 - T = Z(K) - Z(K) = Z(KP) - Z(KP) = T - 250 CONTINUE - 260 CONTINUE - IK = IK + K - IF (KS .EQ. 2) IK = IK + (K + 1) - K = K + KS - GO TO 240 - 270 CONTINUE -C MAKE ZNORM = 1.0 - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM -C - IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM - IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0 - RETURN - END diff --git a/slatec/chpdi.f b/slatec/chpdi.f deleted file mode 100644 index b0a5b37..0000000 --- a/slatec/chpdi.f +++ /dev/null @@ -1,261 +0,0 @@ -*DECK CHPDI - SUBROUTINE CHPDI (AP, N, KPVT, DET, INERT, WORK, JOB) -C***BEGIN PROLOGUE CHPDI -C***PURPOSE Compute the determinant, inertia and inverse of a complex -C Hermitian matrix stored in packed form using the factors -C obtained from CHPFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2D1A, D3D1A -C***TYPE COMPLEX (SSPDI-S, DSPDI-D, CHPDI-C, DSPDI-C) -C***KEYWORDS DETERMINANT, HERMITIAN, INVERSE, LINEAR ALGEBRA, LINPACK, -C MATRIX, PACKED -C***AUTHOR Bunch, J., (UCSD) -C***DESCRIPTION -C -C CHPDI computes the determinant, inertia and inverse -C of a complex Hermitian matrix using the factors from CHPFA, -C where the matrix is stored in packed form. -C -C On Entry -C -C AP COMPLEX (N*(N+1)/2) -C the output from CHPFA. -C -C N INTEGER -C the order of the matrix A. -C -C KVPT INTEGER(N) -C the pivot vector from CHPFA. -C -C WORK COMPLEX(N) -C work vector. Contents ignored. -C -C JOB INTEGER -C JOB has the decimal expansion ABC where -C if C .NE. 0, the inverse is computed, -C if B .NE. 0, the determinant is computed, -C if A .NE. 0, the inertia is computed. -C -C For example, JOB = 111 gives all three. -C -C On Return -C -C Variables not requested by JOB are not used. -C -C AP contains the upper triangle of the inverse of -C the original matrix, stored in packed form. -C The columns of the upper triangle are stored -C sequentially in a one-dimensional array. -C -C DET REAL(2) -C determinant of original matrix. -C Determinant = DET(1) * 10.0**DET(2) -C with 1.0 .LE. ABS(DET(1)) .LT. 10.0 -C or DET(1) = 0.0. -C -C INERT INTEGER(3) -C the inertia of the original matrix. -C INERT(1) = number of positive eigenvalues. -C INERT(2) = number of negative eigenvalues. -C INERT(3) = number of zero eigenvalues. -C -C Error Condition -C -C A division by zero will occur if the inverse is requested -C and CHPCO has set RCOND .EQ. 0.0 -C or CHPFA has set INFO .NE. 0 . -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CCOPY, CDOTC, CSWAP -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Modified routine equivalence list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CHPDI - INTEGER N,JOB - COMPLEX AP(*),WORK(*) - REAL DET(2) - INTEGER KPVT(*),INERT(3) -C - COMPLEX AKKP1,CDOTC,TEMP - REAL TEN,D,T,AK,AKP1 - INTEGER IJ,IK,IKP1,IKS,J,JB,JK,JKP1 - INTEGER K,KK,KKP1,KM1,KS,KSJ,KSKP1,KSTEP - LOGICAL NOINV,NODET,NOERT -C***FIRST EXECUTABLE STATEMENT CHPDI - NOINV = MOD(JOB,10) .EQ. 0 - NODET = MOD(JOB,100)/10 .EQ. 0 - NOERT = MOD(JOB,1000)/100 .EQ. 0 -C - IF (NODET .AND. NOERT) GO TO 140 - IF (NOERT) GO TO 10 - INERT(1) = 0 - INERT(2) = 0 - INERT(3) = 0 - 10 CONTINUE - IF (NODET) GO TO 20 - DET(1) = 1.0E0 - DET(2) = 0.0E0 - TEN = 10.0E0 - 20 CONTINUE - T = 0.0E0 - IK = 0 - DO 130 K = 1, N - KK = IK + K - D = REAL(AP(KK)) -C -C CHECK IF 1 BY 1 -C - IF (KPVT(K) .GT. 0) GO TO 50 -C -C 2 BY 2 BLOCK -C USE DET (D S) = (D/T * C - T) * T , T = ABS(S) -C (S C) -C TO AVOID UNDERFLOW/OVERFLOW TROUBLES. -C TAKE TWO PASSES THROUGH SCALING. USE T FOR FLAG. -C - IF (T .NE. 0.0E0) GO TO 30 - IKP1 = IK + K - KKP1 = IKP1 + K - T = ABS(AP(KKP1)) - D = (D/T)*REAL(AP(KKP1+1)) - T - GO TO 40 - 30 CONTINUE - D = T - T = 0.0E0 - 40 CONTINUE - 50 CONTINUE -C - IF (NOERT) GO TO 60 - IF (D .GT. 0.0E0) INERT(1) = INERT(1) + 1 - IF (D .LT. 0.0E0) INERT(2) = INERT(2) + 1 - IF (D .EQ. 0.0E0) INERT(3) = INERT(3) + 1 - 60 CONTINUE -C - IF (NODET) GO TO 120 - DET(1) = D*DET(1) - IF (DET(1) .EQ. 0.0E0) GO TO 110 - 70 IF (ABS(DET(1)) .GE. 1.0E0) GO TO 80 - DET(1) = TEN*DET(1) - DET(2) = DET(2) - 1.0E0 - GO TO 70 - 80 CONTINUE - 90 IF (ABS(DET(1)) .LT. TEN) GO TO 100 - DET(1) = DET(1)/TEN - DET(2) = DET(2) + 1.0E0 - GO TO 90 - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE - IK = IK + K - 130 CONTINUE - 140 CONTINUE -C -C COMPUTE INVERSE(A) -C - IF (NOINV) GO TO 270 - K = 1 - IK = 0 - 150 IF (K .GT. N) GO TO 260 - KM1 = K - 1 - KK = IK + K - IKP1 = IK + K - KKP1 = IKP1 + K - IF (KPVT(K) .LT. 0) GO TO 180 -C -C 1 BY 1 -C - AP(KK) = CMPLX(1.0E0/REAL(AP(KK)),0.0E0) - IF (KM1 .LT. 1) GO TO 170 - CALL CCOPY(KM1,AP(IK+1),1,WORK,1) - IJ = 0 - DO 160 J = 1, KM1 - JK = IK + J - AP(JK) = CDOTC(J,AP(IJ+1),1,WORK,1) - CALL CAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IK+1),1) - IJ = IJ + J - 160 CONTINUE - AP(KK) = AP(KK) - 1 + CMPLX(REAL(CDOTC(KM1,WORK,1,AP(IK+1),1)), - 2 0.0E0) - 170 CONTINUE - KSTEP = 1 - GO TO 220 - 180 CONTINUE -C -C 2 BY 2 -C - T = ABS(AP(KKP1)) - AK = REAL(AP(KK))/T - AKP1 = REAL(AP(KKP1+1))/T - AKKP1 = AP(KKP1)/T - D = T*(AK*AKP1 - 1.0E0) - AP(KK) = CMPLX(AKP1/D,0.0E0) - AP(KKP1+1) = CMPLX(AK/D,0.0E0) - AP(KKP1) = -AKKP1/D - IF (KM1 .LT. 1) GO TO 210 - CALL CCOPY(KM1,AP(IKP1+1),1,WORK,1) - IJ = 0 - DO 190 J = 1, KM1 - JKP1 = IKP1 + J - AP(JKP1) = CDOTC(J,AP(IJ+1),1,WORK,1) - CALL CAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IKP1+1),1) - IJ = IJ + J - 190 CONTINUE - AP(KKP1+1) = AP(KKP1+1) - 1 + CMPLX(REAL(CDOTC(KM1,WORK,1, - 2 AP(IKP1+1),1)),0.0E0) - AP(KKP1) = AP(KKP1) - 1 + CDOTC(KM1,AP(IK+1),1,AP(IKP1+1),1) - CALL CCOPY(KM1,AP(IK+1),1,WORK,1) - IJ = 0 - DO 200 J = 1, KM1 - JK = IK + J - AP(JK) = CDOTC(J,AP(IJ+1),1,WORK,1) - CALL CAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IK+1),1) - IJ = IJ + J - 200 CONTINUE - AP(KK) = AP(KK) - 1 + CMPLX(REAL(CDOTC(KM1,WORK,1,AP(IK+1),1)), - 2 0.0E0) - 210 CONTINUE - KSTEP = 2 - 220 CONTINUE -C -C SWAP -C - KS = ABS(KPVT(K)) - IF (KS .EQ. K) GO TO 250 - IKS = (KS*(KS - 1))/2 - CALL CSWAP(KS,AP(IKS+1),1,AP(IK+1),1) - KSJ = IK + KS - DO 230 JB = KS, K - J = K + KS - JB - JK = IK + J - TEMP = CONJG(AP(JK)) - AP(JK) = CONJG(AP(KSJ)) - AP(KSJ) = TEMP - KSJ = KSJ - (J - 1) - 230 CONTINUE - IF (KSTEP .EQ. 1) GO TO 240 - KSKP1 = IKP1 + KS - TEMP = AP(KSKP1) - AP(KSKP1) = AP(KKP1) - AP(KKP1) = TEMP - 240 CONTINUE - 250 CONTINUE - IK = IK + K - IF (KSTEP .EQ. 2) IK = IK + K + 1 - K = K + KSTEP - GO TO 150 - 260 CONTINUE - 270 CONTINUE - RETURN - END diff --git a/slatec/chpfa.f b/slatec/chpfa.f deleted file mode 100644 index c7b4448..0000000 --- a/slatec/chpfa.f +++ /dev/null @@ -1,284 +0,0 @@ -*DECK CHPFA - SUBROUTINE CHPFA (AP, N, KPVT, INFO) -C***BEGIN PROLOGUE CHPFA -C***PURPOSE Factor a complex Hermitian matrix stored in packed form by -C elimination with symmetric pivoting. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2D1A -C***TYPE COMPLEX (SSPFA-S, DSPFA-D, CHPFA-C, DSPFA-C) -C***KEYWORDS HERMITIAN, LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, -C PACKED -C***AUTHOR Bunch, J., (UCSD) -C***DESCRIPTION -C -C CHPFA factors a complex Hermitian matrix stored in -C packed form by elimination with symmetric pivoting. -C -C To solve A*X = B , follow CHPFA by CHPSL. -C To compute INVERSE(A)*C , follow CHPFA by CHPSL. -C To compute DETERMINANT(A) , follow CHPFA by CHPDI. -C To compute INERTIA(A) , follow CHPFA by CHPDI. -C To compute INVERSE(A) , follow CHPFA by CHPDI. -C -C On Entry -C -C AP COMPLEX (N*(N+1)/2) -C the packed form of a Hermitian matrix A . The -C columns of the upper triangle are stored sequentially -C in a one-dimensional array of length N*(N+1)/2 . -C See comments below for details. -C -C N INTEGER -C the order of the matrix A . -C -C Output -C -C AP A block diagonal matrix and the multipliers which -C were used to obtain it stored in packed form. -C The factorization can be written A = U*D*CTRANS(U) -C where U is a product of permutation and unit -C upper triangular matrices , CTRANS(U) is the -C conjugate transpose of U , and D is block diagonal -C with 1 by 1 and 2 by 2 blocks. -C -C KVPT INTEGER(N) -C an integer vector of pivot indices. -C -C INFO INTEGER -C = 0 normal value. -C = K if the K-th pivot block is singular. This is -C not an error condition for this subroutine, -C but it does indicate that CHPSL or CHPDI may -C divide by zero if called. -C -C Packed Storage -C -C The following program segment will pack the upper -C triangle of a Hermitian matrix. -C -C K = 0 -C DO 20 J = 1, N -C DO 10 I = 1, J -C K = K + 1 -C AP(K) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CSWAP, ICAMAX -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Modified routine equivalence list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CHPFA - INTEGER N,KPVT(*),INFO - COMPLEX AP(*) -C - COMPLEX AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T - REAL ABSAKK,ALPHA,COLMAX,ROWMAX - INTEGER ICAMAX,IJ,IJJ,IK,IKM1,IM,IMAX,IMAXP1,IMIM,IMJ,IMK - INTEGER J,JJ,JK,JKM1,JMAX,JMIM,K,KK,KM1,KM1K,KM1KM1,KM2,KSTEP - LOGICAL SWAP - COMPLEX ZDUM - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) -C***FIRST EXECUTABLE STATEMENT CHPFA -C -C INITIALIZE -C -C ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE. -C - ALPHA = (1.0E0 + SQRT(17.0E0))/8.0E0 -C - INFO = 0 -C -C MAIN LOOP ON K, WHICH GOES FROM N TO 1. -C - K = N - IK = (N*(N - 1))/2 - 10 CONTINUE -C -C LEAVE THE LOOP IF K=0 OR K=1. -C - IF (K .EQ. 0) GO TO 200 - IF (K .GT. 1) GO TO 20 - KPVT(1) = 1 - IF (CABS1(AP(1)) .EQ. 0.0E0) INFO = 1 - GO TO 200 - 20 CONTINUE -C -C THIS SECTION OF CODE DETERMINES THE KIND OF -C ELIMINATION TO BE PERFORMED. WHEN IT IS COMPLETED, -C KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND -C SWAP WILL BE SET TO .TRUE. IF AN INTERCHANGE IS -C REQUIRED. -C - KM1 = K - 1 - KK = IK + K - ABSAKK = CABS1(AP(KK)) -C -C DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN -C COLUMN K. -C - IMAX = ICAMAX(K-1,AP(IK+1),1) - IMK = IK + IMAX - COLMAX = CABS1(AP(IMK)) - IF (ABSAKK .LT. ALPHA*COLMAX) GO TO 30 - KSTEP = 1 - SWAP = .FALSE. - GO TO 90 - 30 CONTINUE -C -C DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN -C ROW IMAX. -C - ROWMAX = 0.0E0 - IMAXP1 = IMAX + 1 - IM = IMAX*(IMAX - 1)/2 - IMJ = IM + 2*IMAX - DO 40 J = IMAXP1, K - ROWMAX = MAX(ROWMAX,CABS1(AP(IMJ))) - IMJ = IMJ + J - 40 CONTINUE - IF (IMAX .EQ. 1) GO TO 50 - JMAX = ICAMAX(IMAX-1,AP(IM+1),1) - JMIM = JMAX + IM - ROWMAX = MAX(ROWMAX,CABS1(AP(JMIM))) - 50 CONTINUE - IMIM = IMAX + IM - IF (CABS1(AP(IMIM)) .LT. ALPHA*ROWMAX) GO TO 60 - KSTEP = 1 - SWAP = .TRUE. - GO TO 80 - 60 CONTINUE - IF (ABSAKK .LT. ALPHA*COLMAX*(COLMAX/ROWMAX)) GO TO 70 - KSTEP = 1 - SWAP = .FALSE. - GO TO 80 - 70 CONTINUE - KSTEP = 2 - SWAP = IMAX .NE. KM1 - 80 CONTINUE - 90 CONTINUE - IF (MAX(ABSAKK,COLMAX) .NE. 0.0E0) GO TO 100 -C -C COLUMN K IS ZERO. SET INFO AND ITERATE THE LOOP. -C - KPVT(K) = K - INFO = K - GO TO 190 - 100 CONTINUE - IF (KSTEP .EQ. 2) GO TO 140 -C -C 1 X 1 PIVOT BLOCK. -C - IF (.NOT.SWAP) GO TO 120 -C -C PERFORM AN INTERCHANGE. -C - CALL CSWAP(IMAX,AP(IM+1),1,AP(IK+1),1) - IMJ = IK + IMAX - DO 110 JJ = IMAX, K - J = K + IMAX - JJ - JK = IK + J - T = CONJG(AP(JK)) - AP(JK) = CONJG(AP(IMJ)) - AP(IMJ) = T - IMJ = IMJ - (J - 1) - 110 CONTINUE - 120 CONTINUE -C -C PERFORM THE ELIMINATION. -C - IJ = IK - (K - 1) - DO 130 JJ = 1, KM1 - J = K - JJ - JK = IK + J - MULK = -AP(JK)/AP(KK) - T = CONJG(MULK) - CALL CAXPY(J,T,AP(IK+1),1,AP(IJ+1),1) - IJJ = IJ + J - AP(IJJ) = CMPLX(REAL(AP(IJJ)),0.0E0) - AP(JK) = MULK - IJ = IJ - (J - 1) - 130 CONTINUE -C -C SET THE PIVOT ARRAY. -C - KPVT(K) = K - IF (SWAP) KPVT(K) = IMAX - GO TO 190 - 140 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - KM1K = IK + K - 1 - IKM1 = IK - (K - 1) - IF (.NOT.SWAP) GO TO 160 -C -C PERFORM AN INTERCHANGE. -C - CALL CSWAP(IMAX,AP(IM+1),1,AP(IKM1+1),1) - IMJ = IKM1 + IMAX - DO 150 JJ = IMAX, KM1 - J = KM1 + IMAX - JJ - JKM1 = IKM1 + J - T = CONJG(AP(JKM1)) - AP(JKM1) = CONJG(AP(IMJ)) - AP(IMJ) = T - IMJ = IMJ - (J - 1) - 150 CONTINUE - T = AP(KM1K) - AP(KM1K) = AP(IMK) - AP(IMK) = T - 160 CONTINUE -C -C PERFORM THE ELIMINATION. -C - KM2 = K - 2 - IF (KM2 .EQ. 0) GO TO 180 - AK = AP(KK)/AP(KM1K) - KM1KM1 = IKM1 + K - 1 - AKM1 = AP(KM1KM1)/CONJG(AP(KM1K)) - DENOM = 1.0E0 - AK*AKM1 - IJ = IK - (K - 1) - (K - 2) - DO 170 JJ = 1, KM2 - J = KM1 - JJ - JK = IK + J - BK = AP(JK)/AP(KM1K) - JKM1 = IKM1 + J - BKM1 = AP(JKM1)/CONJG(AP(KM1K)) - MULK = (AKM1*BK - BKM1)/DENOM - MULKM1 = (AK*BKM1 - BK)/DENOM - T = CONJG(MULK) - CALL CAXPY(J,T,AP(IK+1),1,AP(IJ+1),1) - T = CONJG(MULKM1) - CALL CAXPY(J,T,AP(IKM1+1),1,AP(IJ+1),1) - AP(JK) = MULK - AP(JKM1) = MULKM1 - IJJ = IJ + J - AP(IJJ) = CMPLX(REAL(AP(IJJ)),0.0E0) - IJ = IJ - (J - 1) - 170 CONTINUE - 180 CONTINUE -C -C SET THE PIVOT ARRAY. -C - KPVT(K) = 1 - K - IF (SWAP) KPVT(K) = -IMAX - KPVT(K-1) = KPVT(K) - 190 CONTINUE - IK = IK - (K - 1) - IF (KSTEP .EQ. 2) IK = IK - (K - 2) - K = K - KSTEP - GO TO 10 - 200 CONTINUE - RETURN - END diff --git a/slatec/chpmv.f b/slatec/chpmv.f deleted file mode 100644 index 4d3d0c4..0000000 --- a/slatec/chpmv.f +++ /dev/null @@ -1,277 +0,0 @@ -*DECK CHPMV - SUBROUTINE CHPMV (UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY) -C***BEGIN PROLOGUE CHPMV -C***PURPOSE Perform the matrix-vector operation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE COMPLEX (SHPMV-S, DHPMV-D, CHPMV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C CHPMV performs the matrix-vector operation -C -C y := alpha*A*x + beta*y, -C -C where alpha and beta are scalars, x and y are n element vectors and -C A is an n by n hermitian matrix, supplied in packed form. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the matrix A is supplied in the packed -C array AP as follows: -C -C UPLO = 'U' or 'u' The upper triangular part of A is -C supplied in AP. -C -C UPLO = 'L' or 'l' The lower triangular part of A is -C supplied in AP. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - COMPLEX . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C AP - COMPLEX array of DIMENSION at least -C ( ( n*( n + 1))/2). -C Before entry with UPLO = 'U' or 'u', the array AP must -C contain the upper triangular part of the hermitian matrix -C packed sequentially, column by column, so that AP( 1 ) -C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -C and a( 2, 2 ) respectively, and so on. -C Before entry with UPLO = 'L' or 'l', the array AP must -C contain the lower triangular part of the hermitian matrix -C packed sequentially, column by column, so that AP( 1 ) -C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -C and a( 3, 1 ) respectively, and so on. -C Note that the imaginary parts of the diagonal elements need -C not be set and are assumed to be zero. -C Unchanged on exit. -C -C X - COMPLEX array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C BETA - COMPLEX . -C On entry, BETA specifies the scalar beta. When BETA is -C supplied as zero then Y need not be set on input. -C Unchanged on exit. -C -C Y - COMPLEX array of dimension at least -C ( 1 + ( n - 1 )*abs( INCY ) ). -C Before entry, the incremented array Y must contain the n -C element vector y. On exit, Y is overwritten by the updated -C vector y. -C -C INCY - INTEGER. -C On entry, INCY specifies the increment for the elements of -C Y. INCY must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE CHPMV -C .. Scalar Arguments .. - COMPLEX ALPHA, BETA - INTEGER INCX, INCY, N - CHARACTER*1 UPLO -C .. Array Arguments .. - COMPLEX AP( * ), X( * ), Y( * ) -C .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -C .. Local Scalars .. - COMPLEX TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC CONJG, REAL -C***FIRST EXECUTABLE STATEMENT CHPMV -C -C Test the input parameters. -C - 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( 'CHPMV ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C Set up the start points in X and Y. -C - 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 -C -C Start the operations. In this version the elements of the array AP -C are accessed sequentially with one pass through AP. -C -C First form y := beta*y. -C - 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 -C -C Form y when AP contains the upper triangle. -C - 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 + CONJG( AP( K ) )*X( I ) - K = K + 1 - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*REAL( 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 + CONJG( AP( K ) )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*REAL( AP( KK + J - 1 ) ) - $ + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - KK = KK + J - 80 CONTINUE - END IF - ELSE -C -C Form y when AP contains the lower triangle. -C - 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*REAL( AP( KK ) ) - K = KK + 1 - DO 90, I = J + 1, N - Y( I ) = Y( I ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + CONJG( 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*REAL( 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 + CONJG( 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 -C - RETURN -C -C End of CHPMV . -C - END diff --git a/slatec/chpr.f b/slatec/chpr.f deleted file mode 100644 index 78a1a70..0000000 --- a/slatec/chpr.f +++ /dev/null @@ -1,224 +0,0 @@ -*DECK CHPR - SUBROUTINE CHPR (UPLO, N, ALPHA, X, INCX, AP) -C***BEGIN PROLOGUE CHPR -C***PURPOSE Perform the hermitian rank 1 operation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE COMPLEX (CHPR-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C CHPR performs the hermitian rank 1 operation -C -C A := alpha*x*conjg( x') + A, -C -C where alpha is a real scalar, x is an n element vector and A is an -C n by n hermitian matrix, supplied in packed form. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the matrix A is supplied in the packed -C array AP as follows: -C -C UPLO = 'U' or 'u' The upper triangular part of A is -C supplied in AP. -C -C UPLO = 'L' or 'l' The lower triangular part of A is -C supplied in AP. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - REAL . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C X - COMPLEX array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C AP - COMPLEX array of DIMENSION at least -C ( ( n*( n + 1 ) )/2 ). -C Before entry with UPLO = 'U' or 'u', the array AP must -C contain the upper triangular part of the hermitian matrix -C packed sequentially, column by column, so that AP( 1 ) -C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -C and a( 2, 2 ) respectively, and so on. On exit, the array -C AP is overwritten by the upper triangular part of the -C updated matrix. -C Before entry with UPLO = 'L' or 'l', the array AP must -C contain the lower triangular part of the hermitian matrix -C packed sequentially, column by column, so that AP( 1 ) -C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -C and a( 3, 1 ) respectively, and so on. On exit, the array -C AP is overwritten by the lower triangular part of the -C updated matrix. -C Note that the imaginary parts of the diagonal elements need -C not be set, they are assumed to be zero, and on exit they -C are set to zero. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE CHPR -C .. Scalar Arguments .. - REAL ALPHA - INTEGER INCX, N - CHARACTER*1 UPLO -C .. Array Arguments .. - COMPLEX AP( * ), X( * ) -C .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -C .. Local Scalars .. - COMPLEX TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC CONJG, REAL -C***FIRST EXECUTABLE STATEMENT CHPR -C -C Test the input parameters. -C - 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( 'CHPR ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.REAL( ZERO ) ) ) - $ RETURN -C -C Set the start point in X if the increment is not unity. -C - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -C -C Start the operations. In this version the elements of the array AP -C are accessed sequentially with one pass through AP. -C - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -C -C Form A when upper triangle is stored in AP. -C - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*CONJG( X( J ) ) - K = KK - DO 10, I = 1, J - 1 - AP( K ) = AP( K ) + X( I )*TEMP - K = K + 1 - 10 CONTINUE - AP( KK + J - 1 ) = REAL( AP( KK + J - 1 ) ) - $ + REAL( X( J )*TEMP ) - ELSE - AP( KK + J - 1 ) = REAL( 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 = ALPHA*CONJG( X( JX ) ) - IX = KX - DO 30, K = KK, KK + J - 2 - AP( K ) = AP( K ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - AP( KK + J - 1 ) = REAL( AP( KK + J - 1 ) ) - $ + REAL( X( JX )*TEMP ) - ELSE - AP( KK + J - 1 ) = REAL( AP( KK + J - 1 ) ) - END IF - JX = JX + INCX - KK = KK + J - 40 CONTINUE - END IF - ELSE -C -C Form A when lower triangle is stored in AP. -C - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*CONJG( X( J ) ) - AP( KK ) = REAL( AP( KK ) ) + REAL( TEMP*X( J ) ) - K = KK + 1 - DO 50, I = J + 1, N - AP( K ) = AP( K ) + X( I )*TEMP - K = K + 1 - 50 CONTINUE - ELSE - AP( KK ) = REAL( AP( KK ) ) - 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*CONJG( X( JX ) ) - AP( KK ) = REAL( AP( KK ) ) + REAL( TEMP*X( JX ) ) - IX = JX - DO 70, K = KK + 1, KK + N - J - IX = IX + INCX - AP( K ) = AP( K ) + X( IX )*TEMP - 70 CONTINUE - ELSE - AP( KK ) = REAL( AP( KK ) ) - END IF - JX = JX + INCX - KK = KK + N - J + 1 - 80 CONTINUE - END IF - END IF -C - RETURN -C -C End of CHPR . -C - END diff --git a/slatec/chpr2.f b/slatec/chpr2.f deleted file mode 100644 index 1920ad2..0000000 --- a/slatec/chpr2.f +++ /dev/null @@ -1,258 +0,0 @@ -*DECK CHPR2 - SUBROUTINE CHPR2 (UPLO, N, ALPHA, X, INCX, Y, INCY, AP) -C***BEGIN PROLOGUE CHPR2 -C***PURPOSE Perform the hermitian rank 2 operation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE COMPLEX (SHPR2-S, DHPR2-D, CHPR2-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C CHPR2 performs the hermitian rank 2 operation -C -C A := alpha*x*conjg( y') + conjg( alpha)*y*conjg( x') + A, -C -C where alpha is a scalar, x and y are n element vectors and A is an -C n by n hermitian matrix, supplied in packed form. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the matrix A is supplied in the packed -C array AP as follows: -C -C UPLO = 'U' or 'u' The upper triangular part of A is -C supplied in AP. -C -C UPLO = 'L' or 'l' The lower triangular part of A is -C supplied in AP. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - COMPLEX . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C X - COMPLEX array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C Y - COMPLEX array of dimension at least -C ( 1 + ( n - 1 )*abs( INCY ) ). -C Before entry, the incremented array Y must contain the n -C element vector y. -C Unchanged on exit. -C -C INCY - INTEGER. -C On entry, INCY specifies the increment for the elements of -C Y. INCY must not be zero. -C Unchanged on exit. -C -C AP - COMPLEX array of DIMENSION at least -C ( ( n*( n + 1 ) )/2 ). -C Before entry with UPLO = 'U' or 'u', the array AP must -C contain the upper triangular part of the hermitian matrix -C packed sequentially, column by column, so that AP( 1 ) -C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -C and a( 2, 2 ) respectively, and so on. On exit, the array -C AP is overwritten by the upper triangular part of the -C updated matrix. -C Before entry with UPLO = 'L' or 'l', the array AP must -C contain the lower triangular part of the hermitian matrix -C packed sequentially, column by column, so that AP( 1 ) -C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -C and a( 3, 1 ) respectively, and so on. On exit, the array -C AP is overwritten by the lower triangular part of the -C updated matrix. -C Note that the imaginary parts of the diagonal elements need -C not be set, they are assumed to be zero, and on exit they -C are set to zero. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE CHPR2 -C .. Scalar Arguments .. - COMPLEX ALPHA - INTEGER INCX, INCY, N - CHARACTER*1 UPLO -C .. Array Arguments .. - COMPLEX AP( * ), X( * ), Y( * ) -C .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -C .. Local Scalars .. - COMPLEX TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC CONJG, REAL -C***FIRST EXECUTABLE STATEMENT CHPR2 -C -C Test the input parameters. -C - 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( 'CHPR2 ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -C -C Set up the start points in X and Y if the increments are not both -C unity. -C - 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 -C -C Start the operations. In this version the elements of the array AP -C are accessed sequentially with one pass through AP. -C - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -C -C Form A when upper triangle is stored in AP. -C - 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*CONJG( Y( J ) ) - TEMP2 = CONJG( ALPHA*X( J ) ) - K = KK - DO 10, I = 1, J - 1 - AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 - K = K + 1 - 10 CONTINUE - AP( KK + J - 1 ) = REAL( AP( KK + J - 1 ) ) + - $ REAL( X( J )*TEMP1 + Y( J )*TEMP2 ) - ELSE - AP( KK + J - 1 ) = REAL( AP( KK + J - 1 ) ) - 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*CONJG( Y( JY ) ) - TEMP2 = CONJG( ALPHA*X( JX ) ) - IX = KX - IY = KY - DO 30, K = KK, KK + J - 2 - AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - AP( KK + J - 1 ) = REAL( AP( KK + J - 1 ) ) + - $ REAL( X( JX )*TEMP1 + - $ Y( JY )*TEMP2 ) - ELSE - AP( KK + J - 1 ) = REAL( AP( KK + J - 1 ) ) - END IF - JX = JX + INCX - JY = JY + INCY - KK = KK + J - 40 CONTINUE - END IF - ELSE -C -C Form A when lower triangle is stored in AP. -C - 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*CONJG( Y( J ) ) - TEMP2 = CONJG( ALPHA*X( J ) ) - AP( KK ) = REAL( AP( KK ) ) + - $ REAL( X( J )*TEMP1 + Y( J )*TEMP2 ) - K = KK + 1 - DO 50, I = J + 1, N - AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 - K = K + 1 - 50 CONTINUE - ELSE - AP( KK ) = REAL( AP( KK ) ) - 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*CONJG( Y( JY ) ) - TEMP2 = CONJG( ALPHA*X( JX ) ) - AP( KK ) = REAL( AP( KK ) ) + - $ REAL( X( JX )*TEMP1 + Y( JY )*TEMP2 ) - IX = JX - IY = JY - DO 70, K = KK + 1, KK + N - J - IX = IX + INCX - IY = IY + INCY - AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 - 70 CONTINUE - ELSE - AP( KK ) = REAL( AP( KK ) ) - END IF - JX = JX + INCX - JY = JY + INCY - KK = KK + N - J + 1 - 80 CONTINUE - END IF - END IF -C - RETURN -C -C End of CHPR2 . -C - END diff --git a/slatec/chpsl.f b/slatec/chpsl.f deleted file mode 100644 index 449613b..0000000 --- a/slatec/chpsl.f +++ /dev/null @@ -1,196 +0,0 @@ -*DECK CHPSL - SUBROUTINE CHPSL (AP, N, KPVT, B) -C***BEGIN PROLOGUE CHPSL -C***PURPOSE Solve a complex Hermitian system using factors obtained -C from CHPFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2D1A -C***TYPE COMPLEX (SSPSL-S, DSPSL-D, CHPSL-C, CSPSL-C) -C***KEYWORDS HERMITIAN, LINEAR ALGEBRA, LINPACK, MATRIX, PACKED, SOLVE -C***AUTHOR Bunch, J., (UCSD) -C***DESCRIPTION -C -C CHISL solves the complex Hermitian system -C A * X = B -C using the factors computed by CHPFA. -C -C On Entry -C -C AP COMPLEX(N*(N+1)/2) -C the output from CHPFA. -C -C N INTEGER -C the order of the matrix A . -C -C KVPT INTEGER(N) -C the pivot vector from CHPFA. -C -C B COMPLEX(N) -C the right hand side vector. -C -C On Return -C -C B the solution vector X . -C -C Error Condition -C -C A division by zero may occur if CHPCO has set RCOND .EQ. 0.0 -C or CHPFA has set INFO .NE. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL CHPFA(AP,N,KVPT,INFO) -C IF (INFO .NE. 0) GO TO ... -C DO 10 J = 1, P -C CALL CHPSL(AP,N,KVPT,C(1,J)) -C 10 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CDOTC -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Modified routine equivalence list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CHPSL - INTEGER N,KPVT(*) - COMPLEX AP(*),B(*) -C - COMPLEX AK,AKM1,BK,BKM1,CDOTC,DENOM,TEMP - INTEGER IK,IKM1,IKP1,K,KK,KM1K,KM1KM1,KP -C -C LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND -C D INVERSE TO B. -C -C***FIRST EXECUTABLE STATEMENT CHPSL - K = N - IK = (N*(N - 1))/2 - 10 IF (K .EQ. 0) GO TO 80 - KK = IK + K - IF (KPVT(K) .LT. 0) GO TO 40 -C -C 1 X 1 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 30 - KP = KPVT(K) - IF (KP .EQ. K) GO TO 20 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 20 CONTINUE -C -C APPLY THE TRANSFORMATION. -C - CALL CAXPY(K-1,B(K),AP(IK+1),1,B(1),1) - 30 CONTINUE -C -C APPLY D INVERSE. -C - B(K) = B(K)/AP(KK) - K = K - 1 - IK = IK - K - GO TO 70 - 40 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - IKM1 = IK - (K - 1) - IF (K .EQ. 2) GO TO 60 - KP = ABS(KPVT(K)) - IF (KP .EQ. K - 1) GO TO 50 -C -C INTERCHANGE. -C - TEMP = B(K-1) - B(K-1) = B(KP) - B(KP) = TEMP - 50 CONTINUE -C -C APPLY THE TRANSFORMATION. -C - CALL CAXPY(K-2,B(K),AP(IK+1),1,B(1),1) - CALL CAXPY(K-2,B(K-1),AP(IKM1+1),1,B(1),1) - 60 CONTINUE -C -C APPLY D INVERSE. -C - KM1K = IK + K - 1 - KK = IK + K - AK = AP(KK)/CONJG(AP(KM1K)) - KM1KM1 = IKM1 + K - 1 - AKM1 = AP(KM1KM1)/AP(KM1K) - BK = B(K)/CONJG(AP(KM1K)) - BKM1 = B(K-1)/AP(KM1K) - DENOM = AK*AKM1 - 1.0E0 - B(K) = (AKM1*BK - BKM1)/DENOM - B(K-1) = (AK*BKM1 - BK)/DENOM - K = K - 2 - IK = IK - (K + 1) - K - 70 CONTINUE - GO TO 10 - 80 CONTINUE -C -C LOOP FORWARD APPLYING THE TRANSFORMATIONS. -C - K = 1 - IK = 0 - 90 IF (K .GT. N) GO TO 160 - IF (KPVT(K) .LT. 0) GO TO 120 -C -C 1 X 1 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 110 -C -C APPLY THE TRANSFORMATION. -C - B(K) = B(K) + CDOTC(K-1,AP(IK+1),1,B(1),1) - KP = KPVT(K) - IF (KP .EQ. K) GO TO 100 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 100 CONTINUE - 110 CONTINUE - IK = IK + K - K = K + 1 - GO TO 150 - 120 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 140 -C -C APPLY THE TRANSFORMATION. -C - B(K) = B(K) + CDOTC(K-1,AP(IK+1),1,B(1),1) - IKP1 = IK + K - B(K+1) = B(K+1) + CDOTC(K-1,AP(IKP1+1),1,B(1),1) - KP = ABS(KPVT(K)) - IF (KP .EQ. K) GO TO 130 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 130 CONTINUE - 140 CONTINUE - IK = IK + K + K + 1 - K = K + 2 - 150 CONTINUE - GO TO 90 - 160 CONTINUE - RETURN - END diff --git a/slatec/chu.f b/slatec/chu.f deleted file mode 100644 index b761da6..0000000 --- a/slatec/chu.f +++ /dev/null @@ -1,166 +0,0 @@ -*DECK CHU - FUNCTION CHU (A, B, X) -C***BEGIN PROLOGUE CHU -C***PURPOSE Compute the logarithmic confluent hypergeometric function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C11 -C***TYPE SINGLE PRECISION (CHU-S, DCHU-D) -C***KEYWORDS FNLIB, LOGARITHMIC CONFLUENT HYPERGEOMETRIC FUNCTION, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C CHU computes the logarithmic confluent hypergeometric function, -C U(A,B,X). -C -C Input Parameters: -C A real -C B real -C X real and positive -C -C This routine is not valid when 1+A-B is close to zero if X is small. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED EXPREL, GAMMA, GAMR, POCH, POCH1, R1MACH, R9CHU, -C XERMSG -C***REVISION HISTORY (YYMMDD) -C 770801 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 900727 Added EXTERNAL statement. (WRB) -C***END PROLOGUE CHU - EXTERNAL GAMMA - SAVE PI, EPS - DATA PI / 3.1415926535 8979324 E0 / - DATA EPS / 0.0 / -C***FIRST EXECUTABLE STATEMENT CHU - IF (EPS.EQ.0.0) EPS = R1MACH(3) -C - IF (X .EQ. 0.0) CALL XERMSG ('SLATEC', 'CHU', - + 'X IS ZERO SO CHU IS INFINITE', 1, 2) - IF (X .LT. 0.0) CALL XERMSG ('SLATEC', 'CHU', - + 'X IS NEGATIVE, USE CCHU', 2, 2) -C - IF (MAX(ABS(A),1.0)*MAX(ABS(1.0+A-B),1.0).LT.0.99*ABS(X)) - 1 GO TO 120 -C -C THE ASCENDING SERIES WILL BE USED, BECAUSE THE DESCENDING RATIONAL -C APPROXIMATION (WHICH IS BASED ON THE ASYMPTOTIC SERIES) IS UNSTABLE. -C - IF (ABS(1.0+A-B) .LT. SQRT(EPS)) CALL XERMSG ('SLATEC', 'CHU', - + 'ALGORITHM IS BAD WHEN 1+A-B IS NEAR ZERO FOR SMALL X', 10, 2) -C - AINTB = AINT(B+0.5) - IF (B.LT.0.0) AINTB = AINT(B-0.5) - BEPS = B - AINTB - N = AINTB -C - ALNX = LOG(X) - XTOEPS = EXP(-BEPS*ALNX) -C -C EVALUATE THE FINITE SUM. ----------------------------------------- -C - IF (N.GE.1) GO TO 40 -C -C CONSIDER THE CASE B .LT. 1.0 FIRST. -C - SUM = 1.0 - IF (N.EQ.0) GO TO 30 -C - T = 1.0 - M = -N - DO 20 I=1,M - XI1 = I - 1 - T = T*(A+XI1)*X/((B+XI1)*(XI1+1.0)) - SUM = SUM + T - 20 CONTINUE -C - 30 SUM = POCH(1.0+A-B, -A) * SUM - GO TO 70 -C -C NOW CONSIDER THE CASE B .GE. 1.0. -C - 40 SUM = 0.0 - M = N - 2 - IF (M.LT.0) GO TO 70 - T = 1.0 - SUM = 1.0 - IF (M.EQ.0) GO TO 60 -C - DO 50 I=1,M - XI = I - T = T * (A-B+XI)*X/((1.0-B+XI)*XI) - SUM = SUM + T - 50 CONTINUE -C - 60 SUM = GAMMA(B-1.0) * GAMR(A) * X**(1-N) * XTOEPS * SUM -C -C NOW EVALUATE THE INFINITE SUM. ----------------------------------- -C - 70 ISTRT = 0 - IF (N.LT.1) ISTRT = 1 - N - XI = ISTRT -C - FACTOR = (-1.0)**N * GAMR(1.0+A-B) * X**ISTRT - IF (BEPS.NE.0.0) FACTOR = FACTOR * BEPS*PI/SIN(BEPS*PI) -C - POCHAI = POCH (A, XI) - GAMRI1 = GAMR (XI+1.0) - GAMRNI = GAMR (AINTB+XI) - B0 = FACTOR * POCH(A,XI-BEPS) * GAMRNI * GAMR(XI+1.0-BEPS) -C - IF (ABS(XTOEPS-1.0).GT.0.5) GO TO 90 -C -C X**(-BEPS) IS CLOSE TO 1.0, SO WE MUST BE CAREFUL IN EVALUATING -C THE DIFFERENCES -C - PCH1AI = POCH1 (A+XI, -BEPS) - PCH1I = POCH1 (XI+1.0-BEPS, BEPS) - C0 = FACTOR * POCHAI * GAMRNI * GAMRI1 * ( - 1 -POCH1(B+XI, -BEPS) + PCH1AI - PCH1I + BEPS*PCH1AI*PCH1I ) -C -C XEPS1 = (1.0 - X**(-BEPS)) / BEPS - XEPS1 = ALNX * EXPREL(-BEPS*ALNX) -C - CHU = SUM + C0 + XEPS1*B0 - XN = N - DO 80 I=1,1000 - XI = ISTRT + I - XI1 = ISTRT + I - 1 - B0 = (A+XI1-BEPS)*B0*X/((XN+XI1)*(XI-BEPS)) - C0 = (A+XI1)*C0*X/((B+XI1)*XI) - ((A-1.0)*(XN+2.*XI-1.0) - 1 + XI*(XI-BEPS)) * B0/(XI*(B+XI1)*(A+XI1-BEPS)) - T = C0 + XEPS1*B0 - CHU = CHU + T - IF (ABS(T).LT.EPS*ABS(CHU)) GO TO 130 - 80 CONTINUE - CALL XERMSG ('SLATEC', 'CHU', - + 'NO CONVERGENCE IN 1000 TERMS OF THE ASCENDING SERIES', 3, 2) -C -C X**(-BEPS) IS VERY DIFFERENT FROM 1.0, SO THE STRAIGHTFORWARD -C FORMULATION IS STABLE. -C - 90 A0 = FACTOR * POCHAI * GAMR(B+XI) * GAMRI1 / BEPS - B0 = XTOEPS*B0/BEPS -C - CHU = SUM + A0 - B0 - DO 100 I=1,1000 - XI = ISTRT + I - XI1 = ISTRT + I - 1 - A0 = (A+XI1)*A0*X/((B+XI1)*XI) - B0 = (A+XI1-BEPS)*B0*X/((AINTB+XI1)*(XI-BEPS)) - T = A0 - B0 - CHU = CHU + T - IF (ABS(T).LT.EPS*ABS(CHU)) GO TO 130 - 100 CONTINUE - CALL XERMSG ('SLATEC', 'CHU', - + 'NO CONVERGENCE IN 1000 TERMS OF THE ASCENDING SERIES', 3, 2) -C -C USE LUKE-S RATIONAL APPROX IN THE ASYMPTOTIC REGION. -C - 120 CHU = X**(-A) * R9CHU(A, B, X) -C - 130 RETURN - END diff --git a/slatec/cinvit.f b/slatec/cinvit.f deleted file mode 100644 index 2626510..0000000 --- a/slatec/cinvit.f +++ /dev/null @@ -1,301 +0,0 @@ -*DECK CINVIT - SUBROUTINE CINVIT (NM, N, AR, AI, WR, WI, SELECT, MM, M, ZR, ZI, - + IERR, RM1, RM2, RV1, RV2) -C***BEGIN PROLOGUE CINVIT -C***PURPOSE Compute the eigenvectors of a complex upper Hessenberg -C associated with specified eigenvalues using inverse -C iteration. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C2B -C***TYPE COMPLEX (INVIT-S, CINVIT-C) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure CXINVIT -C by Peters and Wilkinson. -C HANDBOOK FOR AUTO. COMP. VOL.II-LINEAR ALGEBRA, 418-439(1971). -C -C This subroutine finds those eigenvectors of A COMPLEX UPPER -C Hessenberg matrix corresponding to specified eigenvalues, -C using inverse iteration. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, AR, AI, ZR and ZI, as declared in the -C calling program dimension statement. NM is an INTEGER -C variable. -C -C N is the order of the matrix A=(AR,AI). N is an INTEGER -C variable. N must be less than or equal to NM. -C -C AR and AI contain the real and imaginary parts, respectively, -C of the complex upper Hessenberg matrix. AR and AI are -C two-dimensional REAL arrays, dimensioned AR(NM,N) -C and AI(NM,N). -C -C WR and WI contain the real and imaginary parts, respectively, -C of the eigenvalues of the matrix. The eigenvalues must be -C stored in a manner identical to that of subroutine COMLR, -C which recognizes possible splitting of the matrix. WR and -C WI are one-dimensional REAL arrays, dimensioned WR(N) and -C WI(N). -C -C SELECT specifies the eigenvectors to be found. The -C eigenvector corresponding to the J-th eigenvalue is -C specified by setting SELECT(J) to .TRUE. SELECT is a -C one-dimensional LOGICAL array, dimensioned SELECT(N). -C -C MM should be set to an upper bound for the number of -C eigenvectors to be found. MM is an INTEGER variable. -C -C On OUTPUT -C -C AR, AI, WI, and SELECT are unaltered. -C -C WR may have been altered since close eigenvalues are perturbed -C slightly in searching for independent eigenvectors. -C -C M is the number of eigenvectors actually found. M is an -C INTEGER variable. -C -C ZR and ZI contain the real and imaginary parts, respectively, -C of the eigenvectors corresponding to the flagged eigenvalues. -C The eigenvectors are normalized so that the component of -C largest magnitude is 1. Any vector which fails the -C acceptance test is set to zero. ZR and ZI are -C two-dimensional REAL arrays, dimensioned ZR(NM,MM) and -C ZI(NM,MM). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C -(2*N+1) if more than MM eigenvectors have been requested -C (the MM eigenvectors calculated to this point are -C in ZR and ZI), -C -K if the iteration corresponding to the K-th -C value fails (if this occurs more than once, K -C is the index of the last occurrence); the -C corresponding columns of ZR and ZI are set to -C zero vectors, -C -(N+K) if both error situations occur. -C -C RV1 and RV2 are one-dimensional REAL arrays used for -C temporary storage, dimensioned RV1(N) and RV2(N). -C They hold the approximate eigenvectors during the inverse -C iteration process. -C -C RM1 and RM2 are two-dimensional REAL arrays used for -C temporary storage, dimensioned RM1(N,N) and RM2(N,N). -C These arrays hold the triangularized form of the upper -C Hessenberg matrix used in the inverse iteration process. -C -C The ALGOL procedure GUESSVEC appears in CINVIT in-line. -C -C Calls PYTHAG(A,B) for sqrt(A**2 + B**2). -C Calls CDIV for complex division. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED CDIV, PYTHAG -C***REVISION HISTORY (YYMMDD) -C 760101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CINVIT -C - INTEGER I,J,K,M,N,S,II,MM,MP,NM,UK,IP1,ITS,KM1,IERR - REAL AR(NM,*),AI(NM,*),WR(*),WI(*),ZR(NM,*),ZI(NM,*) - REAL RM1(N,*),RM2(N,*),RV1(*),RV2(*) - REAL X,Y,EPS3,NORM,NORMV,GROWTO,ILAMBD,RLAMBD,UKROOT - REAL PYTHAG - LOGICAL SELECT(N) -C -C***FIRST EXECUTABLE STATEMENT CINVIT - IERR = 0 - UK = 0 - S = 1 -C - DO 980 K = 1, N - IF (.NOT. SELECT(K)) GO TO 980 - IF (S .GT. MM) GO TO 1000 - IF (UK .GE. K) GO TO 200 -C .......... CHECK FOR POSSIBLE SPLITTING .......... - DO 120 UK = K, N - IF (UK .EQ. N) GO TO 140 - IF (AR(UK+1,UK) .EQ. 0.0E0 .AND. AI(UK+1,UK) .EQ. 0.0E0) - 1 GO TO 140 - 120 CONTINUE -C .......... COMPUTE INFINITY NORM OF LEADING UK BY UK -C (HESSENBERG) MATRIX .......... - 140 NORM = 0.0E0 - MP = 1 -C - DO 180 I = 1, UK - X = 0.0E0 -C - DO 160 J = MP, UK - 160 X = X + PYTHAG(AR(I,J),AI(I,J)) -C - IF (X .GT. NORM) NORM = X - MP = I - 180 CONTINUE -C .......... EPS3 REPLACES ZERO PIVOT IN DECOMPOSITION -C AND CLOSE ROOTS ARE MODIFIED BY EPS3 .......... - IF (NORM .EQ. 0.0E0) NORM = 1.0E0 - EPS3 = NORM - 190 EPS3 = 0.5E0*EPS3 - IF (NORM + EPS3 .GT. NORM) GO TO 190 - EPS3 = 2.0E0*EPS3 -C .......... GROWTO IS THE CRITERION FOR GROWTH .......... - UKROOT = SQRT(REAL(UK)) - GROWTO = 0.1E0 / UKROOT - 200 RLAMBD = WR(K) - ILAMBD = WI(K) - IF (K .EQ. 1) GO TO 280 - KM1 = K - 1 - GO TO 240 -C .......... PERTURB EIGENVALUE IF IT IS CLOSE -C TO ANY PREVIOUS EIGENVALUE .......... - 220 RLAMBD = RLAMBD + EPS3 -C .......... FOR I=K-1 STEP -1 UNTIL 1 DO -- .......... - 240 DO 260 II = 1, KM1 - I = K - II - IF (SELECT(I) .AND. ABS(WR(I)-RLAMBD) .LT. EPS3 .AND. - 1 ABS(WI(I)-ILAMBD) .LT. EPS3) GO TO 220 - 260 CONTINUE -C - WR(K) = RLAMBD -C .......... FORM UPPER HESSENBERG (AR,AI)-(RLAMBD,ILAMBD)*I -C AND INITIAL COMPLEX VECTOR .......... - 280 MP = 1 -C - DO 320 I = 1, UK -C - DO 300 J = MP, UK - RM1(I,J) = AR(I,J) - RM2(I,J) = AI(I,J) - 300 CONTINUE -C - RM1(I,I) = RM1(I,I) - RLAMBD - RM2(I,I) = RM2(I,I) - ILAMBD - MP = I - RV1(I) = EPS3 - 320 CONTINUE -C .......... TRIANGULAR DECOMPOSITION WITH INTERCHANGES, -C REPLACING ZERO PIVOTS BY EPS3 .......... - IF (UK .EQ. 1) GO TO 420 -C - DO 400 I = 2, UK - MP = I - 1 - IF (PYTHAG(RM1(I,MP),RM2(I,MP)) .LE. - 1 PYTHAG(RM1(MP,MP),RM2(MP,MP))) GO TO 360 -C - DO 340 J = MP, UK - Y = RM1(I,J) - RM1(I,J) = RM1(MP,J) - RM1(MP,J) = Y - Y = RM2(I,J) - RM2(I,J) = RM2(MP,J) - RM2(MP,J) = Y - 340 CONTINUE -C - 360 IF (RM1(MP,MP) .EQ. 0.0E0 .AND. RM2(MP,MP) .EQ. 0.0E0) - 1 RM1(MP,MP) = EPS3 - CALL CDIV(RM1(I,MP),RM2(I,MP),RM1(MP,MP),RM2(MP,MP),X,Y) - IF (X .EQ. 0.0E0 .AND. Y .EQ. 0.0E0) GO TO 400 -C - DO 380 J = I, UK - RM1(I,J) = RM1(I,J) - X * RM1(MP,J) + Y * RM2(MP,J) - RM2(I,J) = RM2(I,J) - X * RM2(MP,J) - Y * RM1(MP,J) - 380 CONTINUE -C - 400 CONTINUE -C - 420 IF (RM1(UK,UK) .EQ. 0.0E0 .AND. RM2(UK,UK) .EQ. 0.0E0) - 1 RM1(UK,UK) = EPS3 - ITS = 0 -C .......... BACK SUBSTITUTION -C FOR I=UK STEP -1 UNTIL 1 DO -- .......... - 660 DO 720 II = 1, UK - I = UK + 1 - II - X = RV1(I) - Y = 0.0E0 - IF (I .EQ. UK) GO TO 700 - IP1 = I + 1 -C - DO 680 J = IP1, UK - X = X - RM1(I,J) * RV1(J) + RM2(I,J) * RV2(J) - Y = Y - RM1(I,J) * RV2(J) - RM2(I,J) * RV1(J) - 680 CONTINUE -C - 700 CALL CDIV(X,Y,RM1(I,I),RM2(I,I),RV1(I),RV2(I)) - 720 CONTINUE -C .......... ACCEPTANCE TEST FOR EIGENVECTOR -C AND NORMALIZATION .......... - ITS = ITS + 1 - NORM = 0.0E0 - NORMV = 0.0E0 -C - DO 780 I = 1, UK - X = PYTHAG(RV1(I),RV2(I)) - IF (NORMV .GE. X) GO TO 760 - NORMV = X - J = I - 760 NORM = NORM + X - 780 CONTINUE -C - IF (NORM .LT. GROWTO) GO TO 840 -C .......... ACCEPT VECTOR .......... - X = RV1(J) - Y = RV2(J) -C - DO 820 I = 1, UK - CALL CDIV(RV1(I),RV2(I),X,Y,ZR(I,S),ZI(I,S)) - 820 CONTINUE -C - IF (UK .EQ. N) GO TO 940 - J = UK + 1 - GO TO 900 -C .......... IN-LINE PROCEDURE FOR CHOOSING -C A NEW STARTING VECTOR .......... - 840 IF (ITS .GE. UK) GO TO 880 - X = UKROOT - Y = EPS3 / (X + 1.0E0) - RV1(1) = EPS3 -C - DO 860 I = 2, UK - 860 RV1(I) = Y -C - J = UK - ITS + 1 - RV1(J) = RV1(J) - EPS3 * X - GO TO 660 -C .......... SET ERROR -- UNACCEPTED EIGENVECTOR .......... - 880 J = 1 - IERR = -K -C .......... SET REMAINING VECTOR COMPONENTS TO ZERO .......... - 900 DO 920 I = J, N - ZR(I,S) = 0.0E0 - ZI(I,S) = 0.0E0 - 920 CONTINUE -C - 940 S = S + 1 - 980 CONTINUE -C - GO TO 1001 -C .......... SET ERROR -- UNDERESTIMATE OF EIGENVECTOR -C SPACE REQUIRED .......... - 1000 IF (IERR .NE. 0) IERR = IERR - N - IF (IERR .EQ. 0) IERR = -(2 * N + 1) - 1001 M = S - 1 - RETURN - END diff --git a/slatec/ckscl.f b/slatec/ckscl.f deleted file mode 100644 index 8134685..0000000 --- a/slatec/ckscl.f +++ /dev/null @@ -1,112 +0,0 @@ -*DECK CKSCL - SUBROUTINE CKSCL (ZR, FNU, N, Y, NZ, RZ, ASCLE, TOL, ELIM) -C***BEGIN PROLOGUE CKSCL -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBKNU, CUNK1 and CUNK2 -C***LIBRARY SLATEC -C***TYPE ALL (CKSCL-A, ZKSCL-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C SET K FUNCTIONS TO ZERO ON UNDERFLOW, CONTINUE RECURRENCE -C ON SCALED FUNCTIONS UNTIL TWO MEMBERS COME ON SCALE, THEN -C RETURN WITH MIN(NZ+2,N) VALUES SCALED BY 1/TOL. -C -C***SEE ALSO CBKNU, CUNK1, CUNK2 -C***ROUTINES CALLED CUCHK -C***REVISION HISTORY (YYMMDD) -C ?????? DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CKSCL - COMPLEX CK, CS, CY, CZERO, RZ, S1, S2, Y, ZR, ZD, CELM - REAL AA, ASCLE, ACS, AS, CSI, CSR, ELIM, FN, FNU, TOL, XX, ZRI, - * ELM, ALAS, HELIM - INTEGER I, IC, K, KK, N, NN, NW, NZ - DIMENSION Y(N), CY(2) - DATA CZERO / (0.0E0,0.0E0) / -C***FIRST EXECUTABLE STATEMENT CUCHK - NZ = 0 - IC = 0 - XX = REAL(ZR) - NN = MIN(2,N) - DO 10 I=1,NN - S1 = Y(I) - CY(I) = S1 - AS = ABS(S1) - ACS = -XX + ALOG(AS) - NZ = NZ + 1 - Y(I) = CZERO - IF (ACS.LT.(-ELIM)) GO TO 10 - CS = -ZR + CLOG(S1) - CSR = REAL(CS) - CSI = AIMAG(CS) - AA = EXP(CSR)/TOL - CS = CMPLX(AA,0.0E0)*CMPLX(COS(CSI),SIN(CSI)) - CALL CUCHK(CS, NW, ASCLE, TOL) - IF (NW.NE.0) GO TO 10 - Y(I) = CS - NZ = NZ - 1 - IC = I - 10 CONTINUE - IF (N.EQ.1) RETURN - IF (IC.GT.1) GO TO 20 - Y(1) = CZERO - NZ = 2 - 20 CONTINUE - IF (N.EQ.2) RETURN - IF (NZ.EQ.0) RETURN - FN = FNU + 1.0E0 - CK = CMPLX(FN,0.0E0)*RZ - S1 = CY(1) - S2 = CY(2) - HELIM = 0.5E0*ELIM - ELM = EXP(-ELIM) - CELM = CMPLX(ELM,0.0E0) - ZRI =AIMAG(ZR) - ZD = ZR -C -C FIND TWO CONSECUTIVE Y VALUES ON SCALE. SCALE RECURRENCE IF -C S2 GETS LARGER THAN EXP(ELIM/2) -C - DO 30 I=3,N - KK = I - CS = S2 - S2 = CK*S2 + S1 - S1 = CS - CK = CK + RZ - AS = ABS(S2) - ALAS = ALOG(AS) - ACS = -XX + ALAS - NZ = NZ + 1 - Y(I) = CZERO - IF (ACS.LT.(-ELIM)) GO TO 25 - CS = -ZD + CLOG(S2) - CSR = REAL(CS) - CSI = AIMAG(CS) - AA = EXP(CSR)/TOL - CS = CMPLX(AA,0.0E0)*CMPLX(COS(CSI),SIN(CSI)) - CALL CUCHK(CS, NW, ASCLE, TOL) - IF (NW.NE.0) GO TO 25 - Y(I) = CS - NZ = NZ - 1 - IF (IC.EQ.(KK-1)) GO TO 40 - IC = KK - GO TO 30 - 25 CONTINUE - IF(ALAS.LT.HELIM) GO TO 30 - XX = XX-ELIM - S1 = S1*CELM - S2 = S2*CELM - ZD = CMPLX(XX,ZRI) - 30 CONTINUE - NZ = N - IF(IC.EQ.N) NZ=N-1 - GO TO 45 - 40 CONTINUE - NZ = KK - 2 - 45 CONTINUE - DO 50 K=1,NZ - Y(K) = CZERO - 50 CONTINUE - RETURN - END diff --git a/slatec/clbeta.f b/slatec/clbeta.f deleted file mode 100644 index b3115e3..0000000 --- a/slatec/clbeta.f +++ /dev/null @@ -1,38 +0,0 @@ -*DECK CLBETA - COMPLEX FUNCTION CLBETA (A, B) -C***BEGIN PROLOGUE CLBETA -C***PURPOSE Compute the natural logarithm of the complete Beta -C function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7B -C***TYPE COMPLEX (ALBETA-S, DLBETA-D, CLBETA-C) -C***KEYWORDS FNLIB, LOGARITHM OF THE COMPLETE BETA FUNCTION, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C CLBETA computes the natural log of the complex valued complete beta -C function of complex parameters A and B. This is a preliminary version -C which is not accurate. -C -C Input Parameters: -C A complex and the real part of A positive -C B complex and the real part of B positive -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CLNGAM, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 861211 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***END PROLOGUE CLBETA - COMPLEX A, B, CLNGAM -C***FIRST EXECUTABLE STATEMENT CLBETA - IF (REAL(A) .LE. 0.0 .OR. REAL(B) .LE. 0.0) CALL XERMSG ('SLATEC', - + 'CLBETA', 'REAL PART OF BOTH ARGUMENTS MUST BE GT 0', 1, 2) -C - CLBETA = CLNGAM(A) + CLNGAM(B) - CLNGAM(A+B) -C - RETURN - END diff --git a/slatec/clngam.f b/slatec/clngam.f deleted file mode 100644 index 3f90d89..0000000 --- a/slatec/clngam.f +++ /dev/null @@ -1,92 +0,0 @@ -*DECK CLNGAM - COMPLEX FUNCTION CLNGAM (ZIN) -C***BEGIN PROLOGUE CLNGAM -C***PURPOSE Compute the logarithm of the absolute value of the Gamma -C function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7A -C***TYPE COMPLEX (ALNGAM-S, DLNGAM-D, CLNGAM-C) -C***KEYWORDS ABSOLUTE VALUE, COMPLETE GAMMA FUNCTION, FNLIB, LOGARITHM, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C CLNGAM computes the natural log of the complex valued gamma function -C at ZIN, where ZIN is a complex number. This is a preliminary version, -C which is not accurate. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED C9LGMC, CARG, CLNREL, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 780401 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***END PROLOGUE CLNGAM - COMPLEX ZIN, Z, CORR, CLNREL, C9LGMC - LOGICAL FIRST - SAVE PI, SQ2PIL, BOUND, DXREL, FIRST - DATA PI / 3.1415926535 8979324E0 / - DATA SQ2PIL / 0.9189385332 0467274E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT CLNGAM - IF (FIRST) THEN - N = -0.30*LOG(R1MACH(3)) -C BOUND = N*(0.1*EPS)**(-1/(2*N-1))/(PI*EXP(1)) - BOUND = 0.1171*N*(0.1*R1MACH(3))**(-1./(2*N-1)) - DXREL = SQRT (R1MACH(4)) - ENDIF - FIRST = .FALSE. -C - Z = ZIN - X = REAL(ZIN) - Y = AIMAG(ZIN) -C - CORR = (0.0, 0.0) - CABSZ = ABS(Z) - IF (X.GE.0.0 .AND. CABSZ.GT.BOUND) GO TO 50 - IF (X.LT.0.0 .AND. ABS(Y).GT.BOUND) GO TO 50 -C - IF (CABSZ.LT.BOUND) GO TO 20 -C -C USE THE REFLECTION FORMULA FOR REAL(Z) NEGATIVE, ABS(Z) LARGE, AND -C ABS(AIMAG(Y)) SMALL. -C - IF (Y.GT.0.0) Z = CONJG (Z) - CORR = EXP (-CMPLX(0.0,2.0*PI)*Z) - IF (REAL(CORR) .EQ. 1.0 .AND. AIMAG(CORR) .EQ. 0.0) CALL XERMSG - + ('SLATEC', 'CLNGAM', 'Z IS A NEGATIVE INTEGER', 3, 2) -C - CLNGAM = SQ2PIL + 1.0 - CMPLX(0.0,PI)*(Z-0.5) - CLNREL(-CORR) - 1 + (Z-0.5)*LOG(1.0-Z) - Z - C9LGMC(1.0-Z) - IF (Y.GT.0.0) CLNGAM = CONJG (CLNGAM) - RETURN -C -C USE THE RECURSION RELATION FOR ABS(Z) SMALL. -C - 20 IF (X.GE.(-0.5) .OR. ABS(Y).GT.DXREL) GO TO 30 - IF (ABS((Z-AINT(X-0.5))/X) .LT. DXREL) CALL XERMSG ('SLATEC', - + 'CLNGAM', - + 'ANSWER LT HALF PRECISION BECAUSE Z TOO NEAR NEGATIVE INTEGER', - + 1, 1) -C - 30 N = SQRT (BOUND**2 - Y**2) - X + 1.0 - ARGSUM = 0.0 - CORR = (1.0, 0.0) - DO 40 I=1,N - ARGSUM = ARGSUM + CARG(Z) - CORR = Z*CORR - Z = 1.0 + Z - 40 CONTINUE -C - IF (REAL(CORR) .EQ. 0.0 .AND. AIMAG(CORR) .EQ. 0.0) CALL XERMSG - + ('SLATEC', 'CLNGAM', 'Z IS A NEGATIVE INTEGER', 3, 2) - CORR = -CMPLX (LOG(ABS(CORR)), ARGSUM) -C -C USE STIRLING-S APPROXIMATION FOR LARGE Z. -C - 50 CLNGAM = SQ2PIL + (Z-0.5)*LOG(Z) - Z + CORR + C9LGMC(Z) - RETURN -C - END diff --git a/slatec/clnrel.f b/slatec/clnrel.f deleted file mode 100644 index db1daf2..0000000 --- a/slatec/clnrel.f +++ /dev/null @@ -1,46 +0,0 @@ -*DECK CLNREL - COMPLEX FUNCTION CLNREL (Z) -C***BEGIN PROLOGUE CLNREL -C***PURPOSE Evaluate ln(1+X) accurate in the sense of relative error. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4B -C***TYPE COMPLEX (ALNREL-S, DLNREL-D, CLNREL-C) -C***KEYWORDS ELEMENTARY FUNCTIONS, FNLIB, LOGARITHM -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C CLNREL(Z) = LOG(1+Z) with relative error accuracy near Z = 0. -C Let RHO = ABS(Z) and -C R**2 = ABS(1+Z)**2 = (1+X)**2 + Y**2 = 1 + 2*X + RHO**2 . -C Now if RHO is small we may evaluate CLNREL(Z) accurately by -C LOG(1+Z) = CMPLX (LOG(R), CARG(1+Z)) -C = CMPLX (0.5*LOG(R**2), CARG(1+Z)) -C = CMPLX (0.5*ALNREL(2*X+RHO**2), CARG(1+Z)) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED ALNREL, CARG, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 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***END PROLOGUE CLNREL - COMPLEX Z - SAVE SQEPS - DATA SQEPS /0.0/ -C***FIRST EXECUTABLE STATEMENT CLNREL - IF (SQEPS.EQ.0.) SQEPS = SQRT (R1MACH(4)) -C - IF (ABS(1.+Z) .LT. SQEPS) CALL XERMSG ('SLATEC', 'CLNREL', - + 'ANSWER LT HALF PRECISION BECAUSE Z TOO NEAR -1', 1, 1) -C - RHO = ABS(Z) - IF (RHO.GT.0.375) CLNREL = LOG (1.0+Z) - IF (RHO.GT.0.375) RETURN -C - X = REAL(Z) - CLNREL = CMPLX (0.5*ALNREL(2.*X+RHO**2), CARG(1.0+Z)) -C - RETURN - END diff --git a/slatec/clog10.f b/slatec/clog10.f deleted file mode 100644 index ba7a743..0000000 --- a/slatec/clog10.f +++ /dev/null @@ -1,31 +0,0 @@ -*DECK CLOG10 - COMPLEX FUNCTION CLOG10 (Z) -C***BEGIN PROLOGUE CLOG10 -C***PURPOSE Compute the principal value of the complex base 10 -C logarithm. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4B -C***TYPE COMPLEX (CLOG10-C) -C***KEYWORDS BASE TEN LOGARITHM, ELEMENTARY FUNCTIONS, FNLIB -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C CLOG10(Z) calculates the principal value of the complex common -C or base 10 logarithm of Z for -PI .LT. arg(Z) .LE. +PI. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 770401 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***END PROLOGUE CLOG10 - COMPLEX Z - SAVE ALOGE - DATA ALOGE / 0.4342944819 0325182765E0 / -C***FIRST EXECUTABLE STATEMENT CLOG10 - CLOG10 = ALOGE * LOG(Z) -C - RETURN - END diff --git a/slatec/cmgnbn.f b/slatec/cmgnbn.f deleted file mode 100644 index 917cbf8..0000000 --- a/slatec/cmgnbn.f +++ /dev/null @@ -1,366 +0,0 @@ -*DECK CMGNBN - SUBROUTINE CMGNBN (NPEROD, N, MPEROD, M, A, B, C, IDIMY, Y, - + IERROR, W) -C***BEGIN PROLOGUE CMGNBN -C***PURPOSE Solve a complex block tridiagonal linear system of -C equations by a cyclic reduction algorithm. -C***LIBRARY SLATEC (FISHPACK) -C***CATEGORY I2B4B -C***TYPE COMPLEX (GENBUN-S, CMGNBN-C) -C***KEYWORDS CYCLIC REDUCTION, ELLIPTIC PDE, FISHPACK, -C TRIDIAGONAL LINEAR SYSTEM -C***AUTHOR Adams, J., (NCAR) -C Swarztrauber, P. N., (NCAR) -C Sweet, R., (NCAR) -C***DESCRIPTION -C -C Subroutine CMGNBN solves the complex linear system of equations -C -C A(I)*X(I-1,J) + B(I)*X(I,J) + C(I)*X(I+1,J) -C -C + X(I,J-1) - 2.*X(I,J) + X(I,J+1) = Y(I,J) -C -C For I = 1,2,...,M and J = 1,2,...,N. -C -C The indices I+1 and I-1 are evaluated modulo M, i.e., -C X(0,J) = X(M,J) and X(M+1,J) = X(1,J), and X(I,0) may be equal to -C 0, X(I,2), or X(I,N) and X(I,N+1) may be equal to 0, X(I,N-1), or -C X(I,1) depending on an input parameter. -C -C -C * * * * * * * * Parameter Description * * * * * * * * * * -C -C * * * * * * On Input * * * * * * -C -C NPEROD -C Indicates the values that X(I,0) and X(I,N+1) are assumed to -C have. -C -C = 0 If X(I,0) = X(I,N) and X(I,N+1) = X(I,1). -C = 1 If X(I,0) = X(I,N+1) = 0 . -C = 2 If X(I,0) = 0 and X(I,N+1) = X(I,N-1). -C = 3 If X(I,0) = X(I,2) and X(I,N+1) = X(I,N-1). -C = 4 If X(I,0) = X(I,2) and X(I,N+1) = 0. -C -C N -C The number of unknowns in the J-direction. N must be greater -C than 2. -C -C MPEROD -C = 0 If A(1) and C(M) are not zero -C = 1 If A(1) = C(M) = 0 -C -C M -C The number of unknowns in the I-direction. N must be greater -C than 2. -C -C A,B,C -C One-dimensional complex arrays of length M that specify the -C coefficients in the linear equations given above. If MPEROD = 0 -C the array elements must not depend upon the index I, but must be -C constant. Specifically, the subroutine checks the following -C condition -C -C A(I) = C(1) -C C(I) = C(1) -C B(I) = B(1) -C -C For I=1,2,...,M. -C -C IDIMY -C The row (or first) dimension of the two-dimensional array Y as -C it appears in the program calling CMGNBN. This parameter is -C used to specify the variable dimension of Y. IDIMY must be at -C least M. -C -C Y -C A two-dimensional complex array that specifies the values of the -C right side of the linear system of equations given above. Y -C must be dimensioned at least M*N. -C -C W -C A one-dimensional complex array that must be provided by the -C user for work space. W may require up to 4*N + -C (10 + INT(log2(N)))*M LOCATIONS. The actual number of locations -C used is computed by CMGNBN and is returned in location W(1). -C -C -C * * * * * * On Output * * * * * * -C -C Y -C Contains the solution X. -C -C IERROR -C An error flag which indicates invalid input parameters. Except -C for number zero, a solution is not attempted. -C -C = 0 No error. -C = 1 M .LE. 2 -C = 2 N .LE. 2 -C = 3 IDIMY .LT. M -C = 4 NPEROD .LT. 0 or NPEROD .GT. 4 -C = 5 MPEROD .LT. 0 or MPEROD .GT. 1 -C = 6 A(I) .NE. C(1) or C(I) .NE. C(1) or B(I) .NE. B(1) for -C some I=1,2,...,M. -C = 7 A(1) .NE. 0 or C(M) .NE. 0 and MPEROD = 1 -C -C W -C W(1) contains the required length of W. -C -C *Long Description: -C -C * * * * * * * Program Specifications * * * * * * * * * * * * -C -C Dimension of A(M),B(M),C(M),Y(IDIMY,N),W(see parameter list) -C Arguments -C -C Latest June 1979 -C Revision -C -C Subprograms CMGNBN,CMPOSD,CMPOSN,CMPOSP,CMPCSG,CMPMRG, -C Required CMPTRX,CMPTR3,PIMACH -C -C Special None -C Conditions -C -C Common None -C Blocks -C -C I/O None -C -C Precision Single -C -C Specialist Roland Sweet -C -C Language FORTRAN -C -C History Written by Roland Sweet at NCAR in June, 1977 -C -C Algorithm The linear system is solved by a cyclic reduction -C algorithm described in the reference. -C -C Space 4944(DECIMAL) = 11520(octal) locations on the NCAR -C Required Control Data 7600 -C -C Timing and The execution time T on the NCAR Control Data -C Accuracy 7600 for subroutine CMGNBN is roughly proportional -C to M*N*log2(N), but also depends on the input -C parameter NPEROD. Some typical values are listed -C in the table below. -C To measure the accuracy of the algorithm a -C uniform random number generator was used to create -C a solution array X for the system given in the -C 'PURPOSE' with -C -C A(I) = C(I) = -0.5*B(I) = 1, I=1,2,...,M -C -C and, when MPEROD = 1 -C -C A(1) = C(M) = 0 -C A(M) = C(1) = 2. -C -C The solution X was substituted into the given sys- -C tem and a right side Y was computed. Using this -C array Y subroutine CMGNBN was called to produce an -C approximate solution Z. Then the relative error, -C defined as -C -C E = MAX(ABS(Z(I,J)-X(I,J)))/MAX(ABS(X(I,J))) -C -C where the two maxima are taken over all I=1,2,...,M -C and J=1,2,...,N, was computed. The value of E is -C given in the table below for some typical values of -C M and N. -C -C -C M (=N) MPEROD NPEROD T(MSECS) E -C ------ ------ ------ -------- ------ -C -C 31 0 0 77 1.E-12 -C 31 1 1 45 4.E-13 -C 31 1 3 91 2.E-12 -C 32 0 0 59 7.E-14 -C 32 1 1 65 5.E-13 -C 32 1 3 97 2.E-13 -C 33 0 0 80 6.E-13 -C 33 1 1 67 5.E-13 -C 33 1 3 76 3.E-12 -C 63 0 0 350 5.E-12 -C 63 1 1 215 6.E-13 -C 63 1 3 412 1.E-11 -C 64 0 0 264 1.E-13 -C 64 1 1 287 3.E-12 -C 64 1 3 421 3.E-13 -C 65 0 0 338 2.E-12 -C 65 1 1 292 5.E-13 -C 65 1 3 329 1.E-11 -C -C Portability American National Standards Institute Fortran. -C The machine dependent constant PI is defined in -C function PIMACH. -C -C Required COS -C Resident -C Routines -C -C Reference Sweet, R., 'A Cyclic Reduction Algorithm for -C Solving Block Tridiagonal Systems Of Arbitrary -C Dimensions,' SIAM J. on Numer. Anal., -C 14(SEPT., 1977), PP. 706-720. -C -C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -C -C***REFERENCES R. Sweet, A cyclic reduction algorithm for solving -C block tridiagonal systems of arbitrary dimensions, -C SIAM Journal on Numerical Analysis 14, (September -C 1977), pp. 706-720. -C***ROUTINES CALLED CMPOSD, CMPOSN, CMPOSP -C***REVISION HISTORY (YYMMDD) -C 801001 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 CMGNBN -C -C - COMPLEX A ,B ,C ,Y , - 1 W ,A1 - DIMENSION Y(IDIMY,*) - DIMENSION W(*) ,B(*) ,A(*) ,C(*) -C***FIRST EXECUTABLE STATEMENT CMGNBN - IERROR = 0 - IF (M .LE. 2) IERROR = 1 - IF (N .LE. 2) IERROR = 2 - IF (IDIMY .LT. M) IERROR = 3 - IF (NPEROD.LT.0 .OR. NPEROD.GT.4) IERROR = 4 - IF (MPEROD.LT.0 .OR. MPEROD.GT.1) IERROR = 5 - IF (MPEROD .EQ. 1) GO TO 102 - DO 101 I=2,M - IF (ABS(A(I)-C(1)) .NE. 0.) GO TO 103 - IF (ABS(C(I)-C(1)) .NE. 0.) GO TO 103 - IF (ABS(B(I)-B(1)) .NE. 0.) GO TO 103 - 101 CONTINUE - GO TO 104 - 102 IF (ABS(A(1)).NE.0. .AND. ABS(C(M)).NE.0.) IERROR = 7 - GO TO 104 - 103 IERROR = 6 - 104 IF (IERROR .NE. 0) RETURN - IWBA = M+1 - IWBB = IWBA+M - IWBC = IWBB+M - IWB2 = IWBC+M - IWB3 = IWB2+M - IWW1 = IWB3+M - IWW2 = IWW1+M - IWW3 = IWW2+M - IWD = IWW3+M - IWTCOS = IWD+M - IWP = IWTCOS+4*N - DO 106 I=1,M - K = IWBA+I-1 - W(K) = -A(I) - K = IWBC+I-1 - W(K) = -C(I) - K = IWBB+I-1 - W(K) = 2.-B(I) - DO 105 J=1,N - Y(I,J) = -Y(I,J) - 105 CONTINUE - 106 CONTINUE - MP = MPEROD+1 - NP = NPEROD+1 - GO TO (114,107),MP - 107 GO TO (108,109,110,111,123),NP - 108 CALL CMPOSP (M,N,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWB2), - 1 W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS), - 2 W(IWP)) - GO TO 112 - 109 CALL CMPOSD (M,N,1,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWW1), - 1 W(IWD),W(IWTCOS),W(IWP)) - GO TO 112 - 110 CALL CMPOSN (M,N,1,2,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWB2), - 1 W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS), - 2 W(IWP)) - GO TO 112 - 111 CALL CMPOSN (M,N,1,1,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWB2), - 1 W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS), - 2 W(IWP)) - 112 IPSTOR = REAL(W(IWW1)) - IREV = 2 - IF (NPEROD .EQ. 4) GO TO 124 - 113 GO TO (127,133),MP - 114 CONTINUE -C -C REORDER UNKNOWNS WHEN MP =0 -C - MH = (M+1)/2 - MHM1 = MH-1 - MODD = 1 - IF (MH*2 .EQ. M) MODD = 2 - DO 119 J=1,N - DO 115 I=1,MHM1 - MHPI = MH+I - MHMI = MH-I - W(I) = Y(MHMI,J)-Y(MHPI,J) - W(MHPI) = Y(MHMI,J)+Y(MHPI,J) - 115 CONTINUE - W(MH) = 2.*Y(MH,J) - GO TO (117,116),MODD - 116 W(M) = 2.*Y(M,J) - 117 CONTINUE - DO 118 I=1,M - Y(I,J) = W(I) - 118 CONTINUE - 119 CONTINUE - K = IWBC+MHM1-1 - I = IWBA+MHM1 - W(K) = (0.,0.) - W(I) = (0.,0.) - W(K+1) = 2.*W(K+1) - GO TO (120,121),MODD - 120 CONTINUE - K = IWBB+MHM1-1 - W(K) = W(K)-W(I-1) - W(IWBC-1) = W(IWBC-1)+W(IWBB-1) - GO TO 122 - 121 W(IWBB-1) = W(K+1) - 122 CONTINUE - GO TO 107 -C -C REVERSE COLUMNS WHEN NPEROD = 4 -C - 123 IREV = 1 - NBY2 = N/2 - 124 DO 126 J=1,NBY2 - MSKIP = N+1-J - DO 125 I=1,M - A1 = Y(I,J) - Y(I,J) = Y(I,MSKIP) - Y(I,MSKIP) = A1 - 125 CONTINUE - 126 CONTINUE - GO TO (110,113),IREV - 127 CONTINUE - DO 132 J=1,N - DO 128 I=1,MHM1 - MHMI = MH-I - MHPI = MH+I - W(MHMI) = .5*(Y(MHPI,J)+Y(I,J)) - W(MHPI) = .5*(Y(MHPI,J)-Y(I,J)) - 128 CONTINUE - W(MH) = .5*Y(MH,J) - GO TO (130,129),MODD - 129 W(M) = .5*Y(M,J) - 130 CONTINUE - DO 131 I=1,M - Y(I,J) = W(I) - 131 CONTINUE - 132 CONTINUE - 133 CONTINUE -C -C RETURN STORAGE REQUIREMENTS FOR W ARRAY. -C - W(1) = CMPLX(REAL(IPSTOR+IWP-1),0.) - RETURN - END diff --git a/slatec/cmlri.f b/slatec/cmlri.f deleted file mode 100644 index e95dfe7..0000000 --- a/slatec/cmlri.f +++ /dev/null @@ -1,166 +0,0 @@ -*DECK CMLRI - SUBROUTINE CMLRI (Z, FNU, KODE, N, Y, NZ, TOL) -C***BEGIN PROLOGUE CMLRI -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBESI and CBESK -C***LIBRARY SLATEC -C***TYPE ALL (CMLRI-A, ZMLRI-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C CMLRI COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY THE -C MILLER ALGORITHM NORMALIZED BY A NEUMANN SERIES. -C -C***SEE ALSO CBESI, CBESK -C***ROUTINES CALLED GAMLN, R1MACH -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CMLRI - COMPLEX CK, CNORM, CONE, CTWO, CZERO, PT, P1, P2, RZ, SUM, Y, Z - REAL ACK, AK, AP, AT, AZ, BK, FKAP, FKK, FLAM, FNF, FNU, RHO, - * RHO2, SCLE, TFNF, TOL, TST, X, GAMLN, R1MACH - INTEGER I, IAZ, IDUM, IFNU, INU, ITIME, K, KK, KM, KODE, M, N, NZ - DIMENSION Y(N) - DATA CZERO,CONE,CTWO /(0.0E0,0.0E0),(1.0E0,0.0E0),(2.0E0,0.0E0)/ - SCLE = 1.0E+3*R1MACH(1)/TOL -C***FIRST EXECUTABLE STATEMENT CMLRI - NZ=0 - AZ = ABS(Z) - X = REAL(Z) - IAZ = AZ - IFNU = FNU - INU = IFNU + N - 1 - AT = IAZ + 1.0E0 - CK = CMPLX(AT,0.0E0)/Z - RZ = CTWO/Z - P1 = CZERO - P2 = CONE - ACK = (AT+1.0E0)/AZ - RHO = ACK + SQRT(ACK*ACK-1.0E0) - RHO2 = RHO*RHO - TST = (RHO2+RHO2)/((RHO2-1.0E0)*(RHO-1.0E0)) - TST = TST/TOL -C----------------------------------------------------------------------- -C COMPUTE RELATIVE TRUNCATION ERROR INDEX FOR SERIES -C----------------------------------------------------------------------- - AK = AT - DO 10 I=1,80 - PT = P2 - P2 = P1 - CK*P2 - P1 = PT - CK = CK + RZ - AP = ABS(P2) - IF (AP.GT.TST*AK*AK) GO TO 20 - AK = AK + 1.0E0 - 10 CONTINUE - GO TO 110 - 20 CONTINUE - I = I + 1 - K = 0 - IF (INU.LT.IAZ) GO TO 40 -C----------------------------------------------------------------------- -C COMPUTE RELATIVE TRUNCATION ERROR FOR RATIOS -C----------------------------------------------------------------------- - P1 = CZERO - P2 = CONE - AT = INU + 1.0E0 - CK = CMPLX(AT,0.0E0)/Z - ACK = AT/AZ - TST = SQRT(ACK/TOL) - ITIME = 1 - DO 30 K=1,80 - PT = P2 - P2 = P1 - CK*P2 - P1 = PT - CK = CK + RZ - AP = ABS(P2) - IF (AP.LT.TST) GO TO 30 - IF (ITIME.EQ.2) GO TO 40 - ACK = ABS(CK) - FLAM = ACK + SQRT(ACK*ACK-1.0E0) - FKAP = AP/ABS(P1) - RHO = MIN(FLAM,FKAP) - TST = TST*SQRT(RHO/(RHO*RHO-1.0E0)) - ITIME = 2 - 30 CONTINUE - GO TO 110 - 40 CONTINUE -C----------------------------------------------------------------------- -C BACKWARD RECURRENCE AND SUM NORMALIZING RELATION -C----------------------------------------------------------------------- - K = K + 1 - KK = MAX(I+IAZ,K+INU) - FKK = KK - P1 = CZERO -C----------------------------------------------------------------------- -C SCALE P2 AND SUM BY SCLE -C----------------------------------------------------------------------- - P2 = CMPLX(SCLE,0.0E0) - FNF = FNU - IFNU - TFNF = FNF + FNF - BK = GAMLN(FKK+TFNF+1.0E0,IDUM) - GAMLN(FKK+1.0E0,IDUM) - * -GAMLN(TFNF+1.0E0,IDUM) - BK = EXP(BK) - SUM = CZERO - KM = KK - INU - DO 50 I=1,KM - PT = P2 - P2 = P1 + CMPLX(FKK+FNF,0.0E0)*RZ*P2 - P1 = PT - AK = 1.0E0 - TFNF/(FKK+TFNF) - ACK = BK*AK - SUM = SUM + CMPLX(ACK+BK,0.0E0)*P1 - BK = ACK - FKK = FKK - 1.0E0 - 50 CONTINUE - Y(N) = P2 - IF (N.EQ.1) GO TO 70 - DO 60 I=2,N - PT = P2 - P2 = P1 + CMPLX(FKK+FNF,0.0E0)*RZ*P2 - P1 = PT - AK = 1.0E0 - TFNF/(FKK+TFNF) - ACK = BK*AK - SUM = SUM + CMPLX(ACK+BK,0.0E0)*P1 - BK = ACK - FKK = FKK - 1.0E0 - M = N - I + 1 - Y(M) = P2 - 60 CONTINUE - 70 CONTINUE - IF (IFNU.LE.0) GO TO 90 - DO 80 I=1,IFNU - PT = P2 - P2 = P1 + CMPLX(FKK+FNF,0.0E0)*RZ*P2 - P1 = PT - AK = 1.0E0 - TFNF/(FKK+TFNF) - ACK = BK*AK - SUM = SUM + CMPLX(ACK+BK,0.0E0)*P1 - BK = ACK - FKK = FKK - 1.0E0 - 80 CONTINUE - 90 CONTINUE - PT = Z - IF (KODE.EQ.2) PT = PT - CMPLX(X,0.0E0) - P1 = -CMPLX(FNF,0.0E0)*CLOG(RZ) + PT - AP = GAMLN(1.0E0+FNF,IDUM) - PT = P1 - CMPLX(AP,0.0E0) -C----------------------------------------------------------------------- -C THE DIVISION CEXP(PT)/(SUM+P2) IS ALTERED TO AVOID OVERFLOW -C IN THE DENOMINATOR BY SQUARING LARGE QUANTITIES -C----------------------------------------------------------------------- - P2 = P2 + SUM - AP = ABS(P2) - P1 = CMPLX(1.0E0/AP,0.0E0) - CK = CEXP(PT)*P1 - PT = CONJG(P2)*P1 - CNORM = CK*PT - DO 100 I=1,N - Y(I) = Y(I)*CNORM - 100 CONTINUE - RETURN - 110 CONTINUE - NZ=-2 - RETURN - END diff --git a/slatec/cmpcsg.f b/slatec/cmpcsg.f deleted file mode 100644 index 7648074..0000000 --- a/slatec/cmpcsg.f +++ /dev/null @@ -1,68 +0,0 @@ -*DECK CMPCSG - SUBROUTINE CMPCSG (N, IJUMP, FNUM, FDEN, A) -C***BEGIN PROLOGUE CMPCSG -C***SUBSIDIARY -C***PURPOSE Subsidiary to CMGNBN -C***LIBRARY SLATEC -C***TYPE COMPLEX (COSGEN-S, CMPCSG-C) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This subroutine computes required cosine values in ascending -C order. When IJUMP .GT. 1 the routine computes values -C -C 2*COS(J*PI/L) , J=1,2,...,L and J .NE. 0(MOD N/IJUMP+1) -C -C where L = IJUMP*(N/IJUMP+1). -C -C -C when IJUMP = 1 it computes -C -C 2*COS((J-FNUM)*PI/(N+FDEN)) , J=1, 2, ... ,N -C -C where -C FNUM = 0.5, FDEN = 0.0, for regular reduction values. -C FNUM = 0.0, FDEN = 1.0, for B-R and C-R when ISTAG = 1 -C FNUM = 0.0, FDEN = 0.5, for B-R and C-R when ISTAG = 2 -C FNUM = 0.5, FDEN = 0.5, for B-R and C-R when ISTAG = 2 -C in CMPOSN only. -C -C***SEE ALSO CMGNBN -C***ROUTINES CALLED PIMACH -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE CMPCSG - COMPLEX A - DIMENSION A(*) -C -C -C***FIRST EXECUTABLE STATEMENT CMPCSG - PI = PIMACH(DUM) - IF (N .EQ. 0) GO TO 105 - IF (IJUMP .EQ. 1) GO TO 103 - K3 = N/IJUMP+1 - K4 = K3-1 - PIBYN = PI/(N+IJUMP) - DO 102 K=1,IJUMP - K1 = (K-1)*K3 - K5 = (K-1)*K4 - DO 101 I=1,K4 - X = K1+I - K2 = K5+I - A(K2) = CMPLX(-2.*COS(X*PIBYN),0.) - 101 CONTINUE - 102 CONTINUE - GO TO 105 - 103 CONTINUE - NP1 = N+1 - Y = PI/(N+FDEN) - DO 104 I=1,N - X = NP1-I-FNUM - A(I) = CMPLX(2.*COS(X*Y),0.) - 104 CONTINUE - 105 CONTINUE - RETURN - END diff --git a/slatec/cmposd.f b/slatec/cmposd.f deleted file mode 100644 index 47333bd..0000000 --- a/slatec/cmposd.f +++ /dev/null @@ -1,334 +0,0 @@ -*DECK CMPOSD - SUBROUTINE CMPOSD (MR, NR, ISTAG, BA, BB, BC, Q, IDIMQ, B, W, D, - + TCOS, P) -C***BEGIN PROLOGUE CMPOSD -C***SUBSIDIARY -C***PURPOSE Subsidiary to CMGNBN -C***LIBRARY SLATEC -C***TYPE COMPLEX (POISD2-S, CMPOSD-C) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Subroutine to solve Poisson's equation for Dirichlet boundary -C conditions. -C -C ISTAG = 1 if the last diagonal block is the matrix A. -C ISTAG = 2 if the last diagonal block is the matrix A+I. -C -C***SEE ALSO CMGNBN -C***ROUTINES CALLED C1MERG, CMPCSG, CMPTRX -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 920130 Modified to use merge routine C1MERG rather than deleted -C routine CMPMRG. (WRB) -C***END PROLOGUE CMPOSD -C - COMPLEX BA ,BB ,BC ,Q , - 1 B ,W ,D ,TCOS , - 2 P ,T - DIMENSION Q(IDIMQ,*) ,BA(*) ,BB(*) ,BC(*) , - 1 TCOS(*) ,B(*) ,D(*) ,W(*) , - 2 P(*) -C***FIRST EXECUTABLE STATEMENT CMPOSD - M = MR - N = NR - FI = 1./ISTAG - IP = -M - IPSTOR = 0 - JSH = 0 - GO TO (101,102),ISTAG - 101 KR = 0 - IRREG = 1 - IF (N .GT. 1) GO TO 106 - TCOS(1) = (0.,0.) - GO TO 103 - 102 KR = 1 - JSTSAV = 1 - IRREG = 2 - IF (N .GT. 1) GO TO 106 - TCOS(1) = CMPLX(-1.,0.) - 103 DO 104 I=1,M - B(I) = Q(I,1) - 104 CONTINUE - CALL CMPTRX (1,0,M,BA,BB,BC,B,TCOS,D,W) - DO 105 I=1,M - Q(I,1) = B(I) - 105 CONTINUE - GO TO 183 - 106 LR = 0 - DO 107 I=1,M - P(I) = CMPLX(0.,0.) - 107 CONTINUE - NUN = N - JST = 1 - JSP = N -C -C IRREG = 1 WHEN NO IRREGULARITIES HAVE OCCURRED, OTHERWISE IT IS 2. -C - 108 L = 2*JST - NODD = 2-2*((NUN+1)/2)+NUN -C -C NODD = 1 WHEN NUN IS ODD, OTHERWISE IT IS 2. -C - GO TO (110,109),NODD - 109 JSP = JSP-L - GO TO 111 - 110 JSP = JSP-JST - IF (IRREG .NE. 1) JSP = JSP-L - 111 CONTINUE -C -C REGULAR REDUCTION -C - CALL CMPCSG (JST,1,0.5,0.0,TCOS) - IF (L .GT. JSP) GO TO 118 - DO 117 J=L,JSP,L - JM1 = J-JSH - JP1 = J+JSH - JM2 = J-JST - JP2 = J+JST - JM3 = JM2-JSH - JP3 = JP2+JSH - IF (JST .NE. 1) GO TO 113 - DO 112 I=1,M - B(I) = 2.*Q(I,J) - Q(I,J) = Q(I,JM2)+Q(I,JP2) - 112 CONTINUE - GO TO 115 - 113 DO 114 I=1,M - T = Q(I,J)-Q(I,JM1)-Q(I,JP1)+Q(I,JM2)+Q(I,JP2) - B(I) = T+Q(I,J)-Q(I,JM3)-Q(I,JP3) - Q(I,J) = T - 114 CONTINUE - 115 CONTINUE - CALL CMPTRX (JST,0,M,BA,BB,BC,B,TCOS,D,W) - DO 116 I=1,M - Q(I,J) = Q(I,J)+B(I) - 116 CONTINUE - 117 CONTINUE -C -C REDUCTION FOR LAST UNKNOWN -C - 118 GO TO (119,136),NODD - 119 GO TO (152,120),IRREG -C -C ODD NUMBER OF UNKNOWNS -C - 120 JSP = JSP+L - J = JSP - JM1 = J-JSH - JP1 = J+JSH - JM2 = J-JST - JP2 = J+JST - JM3 = JM2-JSH - GO TO (123,121),ISTAG - 121 CONTINUE - IF (JST .NE. 1) GO TO 123 - DO 122 I=1,M - B(I) = Q(I,J) - Q(I,J) = CMPLX(0.,0.) - 122 CONTINUE - GO TO 130 - 123 GO TO (124,126),NODDPR - 124 DO 125 I=1,M - IP1 = IP+I - B(I) = .5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3))+P(IP1)+Q(I,J) - 125 CONTINUE - GO TO 128 - 126 DO 127 I=1,M - B(I) = .5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3))+Q(I,JP2)-Q(I,JP1)+Q(I,J) - 127 CONTINUE - 128 DO 129 I=1,M - Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) - 129 CONTINUE - 130 CALL CMPTRX (JST,0,M,BA,BB,BC,B,TCOS,D,W) - IP = IP+M - IPSTOR = MAX(IPSTOR,IP+M) - DO 131 I=1,M - IP1 = IP+I - P(IP1) = Q(I,J)+B(I) - B(I) = Q(I,JP2)+P(IP1) - 131 CONTINUE - IF (LR .NE. 0) GO TO 133 - DO 132 I=1,JST - KRPI = KR+I - TCOS(KRPI) = TCOS(I) - 132 CONTINUE - GO TO 134 - 133 CONTINUE - CALL CMPCSG (LR,JSTSAV,0.,FI,TCOS(JST+1)) - CALL C1MERG (TCOS,0,JST,JST,LR,KR) - 134 CONTINUE - CALL CMPCSG (KR,JSTSAV,0.0,FI,TCOS) - CALL CMPTRX (KR,KR,M,BA,BB,BC,B,TCOS,D,W) - DO 135 I=1,M - IP1 = IP+I - Q(I,J) = Q(I,JM2)+B(I)+P(IP1) - 135 CONTINUE - LR = KR - KR = KR+L - GO TO 152 -C -C EVEN NUMBER OF UNKNOWNS -C - 136 JSP = JSP+L - J = JSP - JM1 = J-JSH - JP1 = J+JSH - JM2 = J-JST - JP2 = J+JST - JM3 = JM2-JSH - GO TO (137,138),IRREG - 137 CONTINUE - JSTSAV = JST - IDEG = JST - KR = L - GO TO 139 - 138 CALL CMPCSG (KR,JSTSAV,0.0,FI,TCOS) - CALL CMPCSG (LR,JSTSAV,0.0,FI,TCOS(KR+1)) - IDEG = KR - KR = KR+JST - 139 IF (JST .NE. 1) GO TO 141 - IRREG = 2 - DO 140 I=1,M - B(I) = Q(I,J) - Q(I,J) = Q(I,JM2) - 140 CONTINUE - GO TO 150 - 141 DO 142 I=1,M - B(I) = Q(I,J)+.5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3)) - 142 CONTINUE - GO TO (143,145),IRREG - 143 DO 144 I=1,M - Q(I,J) = Q(I,JM2)+.5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) - 144 CONTINUE - IRREG = 2 - GO TO 150 - 145 CONTINUE - GO TO (146,148),NODDPR - 146 DO 147 I=1,M - IP1 = IP+I - Q(I,J) = Q(I,JM2)+P(IP1) - 147 CONTINUE - IP = IP-M - GO TO 150 - 148 DO 149 I=1,M - Q(I,J) = Q(I,JM2)+Q(I,J)-Q(I,JM1) - 149 CONTINUE - 150 CALL CMPTRX (IDEG,LR,M,BA,BB,BC,B,TCOS,D,W) - DO 151 I=1,M - Q(I,J) = Q(I,J)+B(I) - 151 CONTINUE - 152 NUN = NUN/2 - NODDPR = NODD - JSH = JST - JST = 2*JST - IF (NUN .GE. 2) GO TO 108 -C -C START SOLUTION. -C - J = JSP - DO 153 I=1,M - B(I) = Q(I,J) - 153 CONTINUE - GO TO (154,155),IRREG - 154 CONTINUE - CALL CMPCSG (JST,1,0.5,0.0,TCOS) - IDEG = JST - GO TO 156 - 155 KR = LR+JST - CALL CMPCSG (KR,JSTSAV,0.0,FI,TCOS) - CALL CMPCSG (LR,JSTSAV,0.0,FI,TCOS(KR+1)) - IDEG = KR - 156 CONTINUE - CALL CMPTRX (IDEG,LR,M,BA,BB,BC,B,TCOS,D,W) - JM1 = J-JSH - JP1 = J+JSH - GO TO (157,159),IRREG - 157 DO 158 I=1,M - Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))+B(I) - 158 CONTINUE - GO TO 164 - 159 GO TO (160,162),NODDPR - 160 DO 161 I=1,M - IP1 = IP+I - Q(I,J) = P(IP1)+B(I) - 161 CONTINUE - IP = IP-M - GO TO 164 - 162 DO 163 I=1,M - Q(I,J) = Q(I,J)-Q(I,JM1)+B(I) - 163 CONTINUE - 164 CONTINUE -C -C START BACK SUBSTITUTION. -C - JST = JST/2 - JSH = JST/2 - NUN = 2*NUN - IF (NUN .GT. N) GO TO 183 - DO 182 J=JST,N,L - JM1 = J-JSH - JP1 = J+JSH - JM2 = J-JST - JP2 = J+JST - IF (J .GT. JST) GO TO 166 - DO 165 I=1,M - B(I) = Q(I,J)+Q(I,JP2) - 165 CONTINUE - GO TO 170 - 166 IF (JP2 .LE. N) GO TO 168 - DO 167 I=1,M - B(I) = Q(I,J)+Q(I,JM2) - 167 CONTINUE - IF (JST .LT. JSTSAV) IRREG = 1 - GO TO (170,171),IRREG - 168 DO 169 I=1,M - B(I) = Q(I,J)+Q(I,JM2)+Q(I,JP2) - 169 CONTINUE - 170 CONTINUE - CALL CMPCSG (JST,1,0.5,0.0,TCOS) - IDEG = JST - JDEG = 0 - GO TO 172 - 171 IF (J+L .GT. N) LR = LR-JST - KR = JST+LR - CALL CMPCSG (KR,JSTSAV,0.0,FI,TCOS) - CALL CMPCSG (LR,JSTSAV,0.0,FI,TCOS(KR+1)) - IDEG = KR - JDEG = LR - 172 CONTINUE - CALL CMPTRX (IDEG,JDEG,M,BA,BB,BC,B,TCOS,D,W) - IF (JST .GT. 1) GO TO 174 - DO 173 I=1,M - Q(I,J) = B(I) - 173 CONTINUE - GO TO 182 - 174 IF (JP2 .GT. N) GO TO 177 - 175 DO 176 I=1,M - Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))+B(I) - 176 CONTINUE - GO TO 182 - 177 GO TO (175,178),IRREG - 178 IF (J+JSH .GT. N) GO TO 180 - DO 179 I=1,M - IP1 = IP+I - Q(I,J) = B(I)+P(IP1) - 179 CONTINUE - IP = IP-M - GO TO 182 - 180 DO 181 I=1,M - Q(I,J) = B(I)+Q(I,J)-Q(I,JM1) - 181 CONTINUE - 182 CONTINUE - L = L/2 - GO TO 164 - 183 CONTINUE -C -C RETURN STORAGE REQUIREMENTS FOR P VECTORS. -C - W(1) = CMPLX(REAL(IPSTOR),0.) - RETURN - END diff --git a/slatec/cmposn.f b/slatec/cmposn.f deleted file mode 100644 index d5ef424..0000000 --- a/slatec/cmposn.f +++ /dev/null @@ -1,563 +0,0 @@ -*DECK CMPOSN - SUBROUTINE CMPOSN (M, N, ISTAG, MIXBND, A, BB, C, Q, IDIMQ, B, B2, - + B3, W, W2, W3, D, TCOS, P) -C***BEGIN PROLOGUE CMPOSN -C***SUBSIDIARY -C***PURPOSE Subsidiary to CMGNBN -C***LIBRARY SLATEC -C***TYPE COMPLEX (POISN2-S, CMPOSN-C) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Subroutine to solve Poisson's equation with Neumann boundary -C conditions. -C -C ISTAG = 1 if the last diagonal block is A. -C ISTAG = 2 if the last diagonal block is A-I. -C MIXBND = 1 if have Neumann boundary conditions at both boundaries. -C MIXBND = 2 if have Neumann boundary conditions at bottom and -C Dirichlet condition at top. (For this case, must have ISTAG = 1) -C -C***SEE ALSO CMGNBN -C***ROUTINES CALLED C1MERG, CMPCSG, CMPTR3, CMPTRX -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 920130 Modified to use merge routine C1MERG rather than deleted -C routine CMPMRG. (WRB) -C***END PROLOGUE CMPOSN -C - COMPLEX A ,BB ,C ,Q , - 1 B ,B2 ,B3 ,W , - 2 W2 ,W3 ,D ,TCOS , - 3 P ,FI ,T - DIMENSION A(*) ,BB(*) ,C(*) ,Q(IDIMQ,*) , - 1 B(*) ,B2(*) ,B3(*) ,W(*) , - 2 W2(*) ,W3(*) ,D(*) ,TCOS(*) , - 3 K(4) ,P(*) - EQUIVALENCE (K(1),K1) ,(K(2),K2) ,(K(3),K3) ,(K(4),K4) -C***FIRST EXECUTABLE STATEMENT CMPOSN - FISTAG = 3-ISTAG - FNUM = 1./ISTAG - FDEN = 0.5*(ISTAG-1) - MR = M - IP = -MR - IPSTOR = 0 - I2R = 1 - JR = 2 - NR = N - NLAST = N - KR = 1 - LR = 0 - GO TO (101,103),ISTAG - 101 CONTINUE - DO 102 I=1,MR - Q(I,N) = .5*Q(I,N) - 102 CONTINUE - GO TO (103,104),MIXBND - 103 IF (N .LE. 3) GO TO 155 - 104 CONTINUE - JR = 2*I2R - NROD = 1 - IF ((NR/2)*2 .EQ. NR) NROD = 0 - GO TO (105,106),MIXBND - 105 JSTART = 1 - GO TO 107 - 106 JSTART = JR - NROD = 1-NROD - 107 CONTINUE - JSTOP = NLAST-JR - IF (NROD .EQ. 0) JSTOP = JSTOP-I2R - CALL CMPCSG (I2R,1,0.5,0.0,TCOS) - I2RBY2 = I2R/2 - IF (JSTOP .GE. JSTART) GO TO 108 - J = JR - GO TO 116 - 108 CONTINUE -C -C REGULAR REDUCTION. -C - DO 115 J=JSTART,JSTOP,JR - JP1 = J+I2RBY2 - JP2 = J+I2R - JP3 = JP2+I2RBY2 - JM1 = J-I2RBY2 - JM2 = J-I2R - JM3 = JM2-I2RBY2 - IF (J .NE. 1) GO TO 109 - JM1 = JP1 - JM2 = JP2 - JM3 = JP3 - 109 CONTINUE - IF (I2R .NE. 1) GO TO 111 - IF (J .EQ. 1) JM2 = JP2 - DO 110 I=1,MR - B(I) = 2.*Q(I,J) - Q(I,J) = Q(I,JM2)+Q(I,JP2) - 110 CONTINUE - GO TO 113 - 111 CONTINUE - DO 112 I=1,MR - FI = Q(I,J) - Q(I,J) = Q(I,J)-Q(I,JM1)-Q(I,JP1)+Q(I,JM2)+Q(I,JP2) - B(I) = FI+Q(I,J)-Q(I,JM3)-Q(I,JP3) - 112 CONTINUE - 113 CONTINUE - CALL CMPTRX (I2R,0,MR,A,BB,C,B,TCOS,D,W) - DO 114 I=1,MR - Q(I,J) = Q(I,J)+B(I) - 114 CONTINUE -C -C END OF REDUCTION FOR REGULAR UNKNOWNS. -C - 115 CONTINUE -C -C BEGIN SPECIAL REDUCTION FOR LAST UNKNOWN. -C - J = JSTOP+JR - 116 NLAST = J - JM1 = J-I2RBY2 - JM2 = J-I2R - JM3 = JM2-I2RBY2 - IF (NROD .EQ. 0) GO TO 128 -C -C ODD NUMBER OF UNKNOWNS -C - IF (I2R .NE. 1) GO TO 118 - DO 117 I=1,MR - B(I) = FISTAG*Q(I,J) - Q(I,J) = Q(I,JM2) - 117 CONTINUE - GO TO 126 - 118 DO 119 I=1,MR - B(I) = Q(I,J)+.5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3)) - 119 CONTINUE - IF (NRODPR .NE. 0) GO TO 121 - DO 120 I=1,MR - II = IP+I - Q(I,J) = Q(I,JM2)+P(II) - 120 CONTINUE - IP = IP-MR - GO TO 123 - 121 CONTINUE - DO 122 I=1,MR - Q(I,J) = Q(I,J)-Q(I,JM1)+Q(I,JM2) - 122 CONTINUE - 123 IF (LR .EQ. 0) GO TO 124 - CALL CMPCSG (LR,1,0.5,FDEN,TCOS(KR+1)) - GO TO 126 - 124 CONTINUE - DO 125 I=1,MR - B(I) = FISTAG*B(I) - 125 CONTINUE - 126 CONTINUE - CALL CMPCSG (KR,1,0.5,FDEN,TCOS) - CALL CMPTRX (KR,LR,MR,A,BB,C,B,TCOS,D,W) - DO 127 I=1,MR - Q(I,J) = Q(I,J)+B(I) - 127 CONTINUE - KR = KR+I2R - GO TO 151 - 128 CONTINUE -C -C EVEN NUMBER OF UNKNOWNS -C - JP1 = J+I2RBY2 - JP2 = J+I2R - IF (I2R .NE. 1) GO TO 135 - DO 129 I=1,MR - B(I) = Q(I,J) - 129 CONTINUE - CALL CMPTRX (1,0,MR,A,BB,C,B,TCOS,D,W) - IP = 0 - IPSTOR = MR - GO TO (133,130),ISTAG - 130 DO 131 I=1,MR - P(I) = B(I) - B(I) = B(I)+Q(I,N) - 131 CONTINUE - TCOS(1) = CMPLX(1.,0.) - TCOS(2) = CMPLX(0.,0.) - CALL CMPTRX (1,1,MR,A,BB,C,B,TCOS,D,W) - DO 132 I=1,MR - Q(I,J) = Q(I,JM2)+P(I)+B(I) - 132 CONTINUE - GO TO 150 - 133 CONTINUE - DO 134 I=1,MR - P(I) = B(I) - Q(I,J) = Q(I,JM2)+2.*Q(I,JP2)+3.*B(I) - 134 CONTINUE - GO TO 150 - 135 CONTINUE - DO 136 I=1,MR - B(I) = Q(I,J)+.5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3)) - 136 CONTINUE - IF (NRODPR .NE. 0) GO TO 138 - DO 137 I=1,MR - II = IP+I - B(I) = B(I)+P(II) - 137 CONTINUE - GO TO 140 - 138 CONTINUE - DO 139 I=1,MR - B(I) = B(I)+Q(I,JP2)-Q(I,JP1) - 139 CONTINUE - 140 CONTINUE - CALL CMPTRX (I2R,0,MR,A,BB,C,B,TCOS,D,W) - IP = IP+MR - IPSTOR = MAX(IPSTOR,IP+MR) - DO 141 I=1,MR - II = IP+I - P(II) = B(I)+.5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) - B(I) = P(II)+Q(I,JP2) - 141 CONTINUE - IF (LR .EQ. 0) GO TO 142 - CALL CMPCSG (LR,1,0.5,FDEN,TCOS(I2R+1)) - CALL C1MERG (TCOS,0,I2R,I2R,LR,KR) - GO TO 144 - 142 DO 143 I=1,I2R - II = KR+I - TCOS(II) = TCOS(I) - 143 CONTINUE - 144 CALL CMPCSG (KR,1,0.5,FDEN,TCOS) - IF (LR .NE. 0) GO TO 145 - GO TO (146,145),ISTAG - 145 CONTINUE - CALL CMPTRX (KR,KR,MR,A,BB,C,B,TCOS,D,W) - GO TO 148 - 146 CONTINUE - DO 147 I=1,MR - B(I) = FISTAG*B(I) - 147 CONTINUE - 148 CONTINUE - DO 149 I=1,MR - II = IP+I - Q(I,J) = Q(I,JM2)+P(II)+B(I) - 149 CONTINUE - 150 CONTINUE - LR = KR - KR = KR+JR - 151 CONTINUE - GO TO (152,153),MIXBND - 152 NR = (NLAST-1)/JR+1 - IF (NR .LE. 3) GO TO 155 - GO TO 154 - 153 NR = NLAST/JR - IF (NR .LE. 1) GO TO 192 - 154 I2R = JR - NRODPR = NROD - GO TO 104 - 155 CONTINUE -C -C BEGIN SOLUTION -C - J = 1+JR - JM1 = J-I2R - JP1 = J+I2R - JM2 = NLAST-I2R - IF (NR .EQ. 2) GO TO 184 - IF (LR .NE. 0) GO TO 170 - IF (N .NE. 3) GO TO 161 -C -C CASE N = 3. -C - GO TO (156,168),ISTAG - 156 CONTINUE - DO 157 I=1,MR - B(I) = Q(I,2) - 157 CONTINUE - TCOS(1) = CMPLX(0.,0.) - CALL CMPTRX (1,0,MR,A,BB,C,B,TCOS,D,W) - DO 158 I=1,MR - Q(I,2) = B(I) - B(I) = 4.*B(I)+Q(I,1)+2.*Q(I,3) - 158 CONTINUE - TCOS(1) = CMPLX(-2.,0.) - TCOS(2) = CMPLX(2.,0.) - I1 = 2 - I2 = 0 - CALL CMPTRX (I1,I2,MR,A,BB,C,B,TCOS,D,W) - DO 159 I=1,MR - Q(I,2) = Q(I,2)+B(I) - B(I) = Q(I,1)+2.*Q(I,2) - 159 CONTINUE - TCOS(1) = (0.,0.) - CALL CMPTRX (1,0,MR,A,BB,C,B,TCOS,D,W) - DO 160 I=1,MR - Q(I,1) = B(I) - 160 CONTINUE - JR = 1 - I2R = 0 - GO TO 194 -C -C CASE N = 2**P+1 -C - 161 CONTINUE - GO TO (162,170),ISTAG - 162 CONTINUE - DO 163 I=1,MR - B(I) = Q(I,J)+.5*Q(I,1)-Q(I,JM1)+Q(I,NLAST)-Q(I,JM2) - 163 CONTINUE - CALL CMPCSG (JR,1,0.5,0.0,TCOS) - CALL CMPTRX (JR,0,MR,A,BB,C,B,TCOS,D,W) - DO 164 I=1,MR - Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))+B(I) - B(I) = Q(I,1)+2.*Q(I,NLAST)+4.*Q(I,J) - 164 CONTINUE - JR2 = 2*JR - CALL CMPCSG (JR,1,0.0,0.0,TCOS) - DO 165 I=1,JR - I1 = JR+I - I2 = JR+1-I - TCOS(I1) = -TCOS(I2) - 165 CONTINUE - CALL CMPTRX (JR2,0,MR,A,BB,C,B,TCOS,D,W) - DO 166 I=1,MR - Q(I,J) = Q(I,J)+B(I) - B(I) = Q(I,1)+2.*Q(I,J) - 166 CONTINUE - CALL CMPCSG (JR,1,0.5,0.0,TCOS) - CALL CMPTRX (JR,0,MR,A,BB,C,B,TCOS,D,W) - DO 167 I=1,MR - Q(I,1) = .5*Q(I,1)-Q(I,JM1)+B(I) - 167 CONTINUE - GO TO 194 -C -C CASE OF GENERAL N WITH NR = 3 . -C - 168 DO 169 I=1,MR - B(I) = Q(I,2) - Q(I,2) = (0.,0.) - B2(I) = Q(I,3) - B3(I) = Q(I,1) - 169 CONTINUE - JR = 1 - I2R = 0 - J = 2 - GO TO 177 - 170 CONTINUE - DO 171 I=1,MR - B(I) = .5*Q(I,1)-Q(I,JM1)+Q(I,J) - 171 CONTINUE - IF (NROD .NE. 0) GO TO 173 - DO 172 I=1,MR - II = IP+I - B(I) = B(I)+P(II) - 172 CONTINUE - GO TO 175 - 173 DO 174 I=1,MR - B(I) = B(I)+Q(I,NLAST)-Q(I,JM2) - 174 CONTINUE - 175 CONTINUE - DO 176 I=1,MR - T = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) - Q(I,J) = T - B2(I) = Q(I,NLAST)+T - B3(I) = Q(I,1)+2.*T - 176 CONTINUE - 177 CONTINUE - K1 = KR+2*JR-1 - K2 = KR+JR - TCOS(K1+1) = (-2.,0.) - K4 = K1+3-ISTAG - CALL CMPCSG (K2+ISTAG-2,1,0.0,FNUM,TCOS(K4)) - K4 = K1+K2+1 - CALL CMPCSG (JR-1,1,0.0,1.0,TCOS(K4)) - CALL C1MERG (TCOS,K1,K2,K1+K2,JR-1,0) - K3 = K1+K2+LR - CALL CMPCSG (JR,1,0.5,0.0,TCOS(K3+1)) - K4 = K3+JR+1 - CALL CMPCSG (KR,1,0.5,FDEN,TCOS(K4)) - CALL C1MERG (TCOS,K3,JR,K3+JR,KR,K1) - IF (LR .EQ. 0) GO TO 178 - CALL CMPCSG (LR,1,0.5,FDEN,TCOS(K4)) - CALL C1MERG (TCOS,K3,JR,K3+JR,LR,K3-LR) - CALL CMPCSG (KR,1,0.5,FDEN,TCOS(K4)) - 178 K3 = KR - K4 = KR - CALL CMPTR3 (MR,A,BB,C,K,B,B2,B3,TCOS,D,W,W2,W3) - DO 179 I=1,MR - B(I) = B(I)+B2(I)+B3(I) - 179 CONTINUE - TCOS(1) = (2.,0.) - CALL CMPTRX (1,0,MR,A,BB,C,B,TCOS,D,W) - DO 180 I=1,MR - Q(I,J) = Q(I,J)+B(I) - B(I) = Q(I,1)+2.*Q(I,J) - 180 CONTINUE - CALL CMPCSG (JR,1,0.5,0.0,TCOS) - CALL CMPTRX (JR,0,MR,A,BB,C,B,TCOS,D,W) - IF (JR .NE. 1) GO TO 182 - DO 181 I=1,MR - Q(I,1) = B(I) - 181 CONTINUE - GO TO 194 - 182 CONTINUE - DO 183 I=1,MR - Q(I,1) = .5*Q(I,1)-Q(I,JM1)+B(I) - 183 CONTINUE - GO TO 194 - 184 CONTINUE - IF (N .NE. 2) GO TO 188 -C -C CASE N = 2 -C - DO 185 I=1,MR - B(I) = Q(I,1) - 185 CONTINUE - TCOS(1) = (0.,0.) - CALL CMPTRX (1,0,MR,A,BB,C,B,TCOS,D,W) - DO 186 I=1,MR - Q(I,1) = B(I) - B(I) = 2.*(Q(I,2)+B(I))*FISTAG - 186 CONTINUE - TCOS(1) = CMPLX(-FISTAG,0.) - TCOS(2) = CMPLX(2.,0.) - CALL CMPTRX (2,0,MR,A,BB,C,B,TCOS,D,W) - DO 187 I=1,MR - Q(I,1) = Q(I,1)+B(I) - 187 CONTINUE - JR = 1 - I2R = 0 - GO TO 194 - 188 CONTINUE -C -C CASE OF GENERAL N AND NR = 2 . -C - DO 189 I=1,MR - II = IP+I - B3(I) = (0.,0.) - B(I) = Q(I,1)+2.*P(II) - Q(I,1) = .5*Q(I,1)-Q(I,JM1) - B2(I) = 2.*(Q(I,1)+Q(I,NLAST)) - 189 CONTINUE - K1 = KR+JR-1 - TCOS(K1+1) = (-2.,0.) - K4 = K1+3-ISTAG - CALL CMPCSG (KR+ISTAG-2,1,0.0,FNUM,TCOS(K4)) - K4 = K1+KR+1 - CALL CMPCSG (JR-1,1,0.0,1.0,TCOS(K4)) - CALL C1MERG (TCOS,K1,KR,K1+KR,JR-1,0) - CALL CMPCSG (KR,1,0.5,FDEN,TCOS(K1+1)) - K2 = KR - K4 = K1+K2+1 - CALL CMPCSG (LR,1,0.5,FDEN,TCOS(K4)) - K3 = LR - K4 = 0 - CALL CMPTR3 (MR,A,BB,C,K,B,B2,B3,TCOS,D,W,W2,W3) - DO 190 I=1,MR - B(I) = B(I)+B2(I) - 190 CONTINUE - TCOS(1) = (2.,0.) - CALL CMPTRX (1,0,MR,A,BB,C,B,TCOS,D,W) - DO 191 I=1,MR - Q(I,1) = Q(I,1)+B(I) - 191 CONTINUE - GO TO 194 - 192 DO 193 I=1,MR - B(I) = Q(I,NLAST) - 193 CONTINUE - GO TO 196 - 194 CONTINUE -C -C START BACK SUBSTITUTION. -C - J = NLAST-JR - DO 195 I=1,MR - B(I) = Q(I,NLAST)+Q(I,J) - 195 CONTINUE - 196 JM2 = NLAST-I2R - IF (JR .NE. 1) GO TO 198 - DO 197 I=1,MR - Q(I,NLAST) = (0.,0.) - 197 CONTINUE - GO TO 202 - 198 CONTINUE - IF (NROD .NE. 0) GO TO 200 - DO 199 I=1,MR - II = IP+I - Q(I,NLAST) = P(II) - 199 CONTINUE - IP = IP-MR - GO TO 202 - 200 DO 201 I=1,MR - Q(I,NLAST) = Q(I,NLAST)-Q(I,JM2) - 201 CONTINUE - 202 CONTINUE - CALL CMPCSG (KR,1,0.5,FDEN,TCOS) - CALL CMPCSG (LR,1,0.5,FDEN,TCOS(KR+1)) - IF (LR .NE. 0) GO TO 204 - DO 203 I=1,MR - B(I) = FISTAG*B(I) - 203 CONTINUE - 204 CONTINUE - CALL CMPTRX (KR,LR,MR,A,BB,C,B,TCOS,D,W) - DO 205 I=1,MR - Q(I,NLAST) = Q(I,NLAST)+B(I) - 205 CONTINUE - NLASTP = NLAST - 206 CONTINUE - JSTEP = JR - JR = I2R - I2R = I2R/2 - IF (JR .EQ. 0) GO TO 222 - GO TO (207,208),MIXBND - 207 JSTART = 1+JR - GO TO 209 - 208 JSTART = JR - 209 CONTINUE - KR = KR-JR - IF (NLAST+JR .GT. N) GO TO 210 - KR = KR-JR - NLAST = NLAST+JR - JSTOP = NLAST-JSTEP - GO TO 211 - 210 CONTINUE - JSTOP = NLAST-JR - 211 CONTINUE - LR = KR-JR - CALL CMPCSG (JR,1,0.5,0.0,TCOS) - DO 221 J=JSTART,JSTOP,JSTEP - JM2 = J-JR - JP2 = J+JR - IF (J .NE. JR) GO TO 213 - DO 212 I=1,MR - B(I) = Q(I,J)+Q(I,JP2) - 212 CONTINUE - GO TO 215 - 213 CONTINUE - DO 214 I=1,MR - B(I) = Q(I,J)+Q(I,JM2)+Q(I,JP2) - 214 CONTINUE - 215 CONTINUE - IF (JR .NE. 1) GO TO 217 - DO 216 I=1,MR - Q(I,J) = (0.,0.) - 216 CONTINUE - GO TO 219 - 217 CONTINUE - JM1 = J-I2R - JP1 = J+I2R - DO 218 I=1,MR - Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) - 218 CONTINUE - 219 CONTINUE - CALL CMPTRX (JR,0,MR,A,BB,C,B,TCOS,D,W) - DO 220 I=1,MR - Q(I,J) = Q(I,J)+B(I) - 220 CONTINUE - 221 CONTINUE - NROD = 1 - IF (NLAST+I2R .LE. N) NROD = 0 - IF (NLASTP .NE. NLAST) GO TO 194 - GO TO 206 - 222 CONTINUE -C -C RETURN STORAGE REQUIREMENTS FOR P VECTORS. -C - W(1) = CMPLX(REAL(IPSTOR),0.) - RETURN - END diff --git a/slatec/cmposp.f b/slatec/cmposp.f deleted file mode 100644 index 4b6cb8f..0000000 --- a/slatec/cmposp.f +++ /dev/null @@ -1,130 +0,0 @@ -*DECK CMPOSP - SUBROUTINE CMPOSP (M, N, A, BB, C, Q, IDIMQ, B, B2, B3, W, W2, W3, - + D, TCOS, P) -C***BEGIN PROLOGUE CMPOSP -C***SUBSIDIARY -C***PURPOSE Subsidiary to CMGNBN -C***LIBRARY SLATEC -C***TYPE COMPLEX (POISP2-S, CMPOSP-C) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Subroutine to solve Poisson's equation with periodic boundary -C conditions. -C -C***SEE ALSO CMGNBN -C***ROUTINES CALLED CMPOSD, CMPOSN -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE CMPOSP -C - COMPLEX A ,BB ,C ,Q , - 1 B ,B2 ,B3 ,W , - 2 W2 ,W3 ,D ,TCOS , - 3 P ,S ,T - DIMENSION A(*) ,BB(*) ,C(*) ,Q(IDIMQ,*) , - 1 B(*) ,B2(*) ,B3(*) ,W(*) , - 2 W2(*) ,W3(*) ,D(*) ,TCOS(*) , - 3 P(*) -C***FIRST EXECUTABLE STATEMENT CMPOSP - MR = M - NR = (N+1)/2 - NRM1 = NR-1 - IF (2*NR .NE. N) GO TO 107 -C -C EVEN NUMBER OF UNKNOWNS -C - DO 102 J=1,NRM1 - NRMJ = NR-J - NRPJ = NR+J - DO 101 I=1,MR - S = Q(I,NRMJ)-Q(I,NRPJ) - T = Q(I,NRMJ)+Q(I,NRPJ) - Q(I,NRMJ) = S - Q(I,NRPJ) = T - 101 CONTINUE - 102 CONTINUE - DO 103 I=1,MR - Q(I,NR) = 2.*Q(I,NR) - Q(I,N) = 2.*Q(I,N) - 103 CONTINUE - CALL CMPOSD (MR,NRM1,1,A,BB,C,Q,IDIMQ,B,W,D,TCOS,P) - IPSTOR = REAL(W(1)) - CALL CMPOSN (MR,NR+1,1,1,A,BB,C,Q(1,NR),IDIMQ,B,B2,B3,W,W2,W3,D, - 1 TCOS,P) - IPSTOR = MAX(IPSTOR,INT(REAL(W(1)))) - DO 105 J=1,NRM1 - NRMJ = NR-J - NRPJ = NR+J - DO 104 I=1,MR - S = .5*(Q(I,NRPJ)+Q(I,NRMJ)) - T = .5*(Q(I,NRPJ)-Q(I,NRMJ)) - Q(I,NRMJ) = S - Q(I,NRPJ) = T - 104 CONTINUE - 105 CONTINUE - DO 106 I=1,MR - Q(I,NR) = .5*Q(I,NR) - Q(I,N) = .5*Q(I,N) - 106 CONTINUE - GO TO 118 - 107 CONTINUE -C -C ODD NUMBER OF UNKNOWNS -C - DO 109 J=1,NRM1 - NRPJ = N+1-J - DO 108 I=1,MR - S = Q(I,J)-Q(I,NRPJ) - T = Q(I,J)+Q(I,NRPJ) - Q(I,J) = S - Q(I,NRPJ) = T - 108 CONTINUE - 109 CONTINUE - DO 110 I=1,MR - Q(I,NR) = 2.*Q(I,NR) - 110 CONTINUE - LH = NRM1/2 - DO 112 J=1,LH - NRMJ = NR-J - DO 111 I=1,MR - S = Q(I,J) - Q(I,J) = Q(I,NRMJ) - Q(I,NRMJ) = S - 111 CONTINUE - 112 CONTINUE - CALL CMPOSD (MR,NRM1,2,A,BB,C,Q,IDIMQ,B,W,D,TCOS,P) - IPSTOR = REAL(W(1)) - CALL CMPOSN (MR,NR,2,1,A,BB,C,Q(1,NR),IDIMQ,B,B2,B3,W,W2,W3,D, - 1 TCOS,P) - IPSTOR = MAX(IPSTOR,INT(REAL(W(1)))) - DO 114 J=1,NRM1 - NRPJ = NR+J - DO 113 I=1,MR - S = .5*(Q(I,NRPJ)+Q(I,J)) - T = .5*(Q(I,NRPJ)-Q(I,J)) - Q(I,NRPJ) = T - Q(I,J) = S - 113 CONTINUE - 114 CONTINUE - DO 115 I=1,MR - Q(I,NR) = .5*Q(I,NR) - 115 CONTINUE - DO 117 J=1,LH - NRMJ = NR-J - DO 116 I=1,MR - S = Q(I,J) - Q(I,J) = Q(I,NRMJ) - Q(I,NRMJ) = S - 116 CONTINUE - 117 CONTINUE - 118 CONTINUE -C -C RETURN STORAGE REQUIREMENTS FOR P VECTORS. -C - W(1) = CMPLX(REAL(IPSTOR),0.) - RETURN - END diff --git a/slatec/cmptr3.f b/slatec/cmptr3.f deleted file mode 100644 index c80fd5b..0000000 --- a/slatec/cmptr3.f +++ /dev/null @@ -1,113 +0,0 @@ -*DECK CMPTR3 - SUBROUTINE CMPTR3 (M, A, B, C, K, Y1, Y2, Y3, TCOS, D, W1, W2, W3) -C***BEGIN PROLOGUE CMPTR3 -C***SUBSIDIARY -C***PURPOSE Subsidiary to CMGNBN -C***LIBRARY SLATEC -C***TYPE COMPLEX (TRI3-S, CMPTR3-C) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Subroutine to solve tridiagonal systems. -C -C***SEE ALSO CMGNBN -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890206 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE CMPTR3 - COMPLEX A ,B ,C ,Y1 , - 1 Y2 ,Y3 ,TCOS ,D , - 2 W1 ,W2 ,W3 ,X , - 3 XX ,Z - DIMENSION A(*) ,B(*) ,C(*) ,K(4) , - 1 TCOS(*) ,Y1(*) ,Y2(*) ,Y3(*) , - 2 D(*) ,W1(*) ,W2(*) ,W3(*) - INTEGER K1P1, K2P1, K3P1, K4P1 -C -C***FIRST EXECUTABLE STATEMENT CMPTR3 - MM1 = M-1 - K1 = K(1) - K2 = K(2) - K3 = K(3) - K4 = K(4) - K1P1 = K1+1 - K2P1 = K2+1 - K3P1 = K3+1 - K4P1 = K4+1 - K2K3K4 = K2+K3+K4 - IF (K2K3K4 .EQ. 0) GO TO 101 - L1 = K1P1/K2P1 - L2 = K1P1/K3P1 - L3 = K1P1/K4P1 - LINT1 = 1 - LINT2 = 1 - LINT3 = 1 - KINT1 = K1 - KINT2 = KINT1+K2 - KINT3 = KINT2+K3 - 101 CONTINUE - DO 115 N=1,K1 - X = TCOS(N) - IF (K2K3K4 .EQ. 0) GO TO 107 - IF (N .NE. L1) GO TO 103 - DO 102 I=1,M - W1(I) = Y1(I) - 102 CONTINUE - 103 IF (N .NE. L2) GO TO 105 - DO 104 I=1,M - W2(I) = Y2(I) - 104 CONTINUE - 105 IF (N .NE. L3) GO TO 107 - DO 106 I=1,M - W3(I) = Y3(I) - 106 CONTINUE - 107 CONTINUE - Z = 1./(B(1)-X) - D(1) = C(1)*Z - Y1(1) = Y1(1)*Z - Y2(1) = Y2(1)*Z - Y3(1) = Y3(1)*Z - DO 108 I=2,M - Z = 1./(B(I)-X-A(I)*D(I-1)) - D(I) = C(I)*Z - Y1(I) = (Y1(I)-A(I)*Y1(I-1))*Z - Y2(I) = (Y2(I)-A(I)*Y2(I-1))*Z - Y3(I) = (Y3(I)-A(I)*Y3(I-1))*Z - 108 CONTINUE - DO 109 IP=1,MM1 - I = M-IP - Y1(I) = Y1(I)-D(I)*Y1(I+1) - Y2(I) = Y2(I)-D(I)*Y2(I+1) - Y3(I) = Y3(I)-D(I)*Y3(I+1) - 109 CONTINUE - IF (K2K3K4 .EQ. 0) GO TO 115 - IF (N .NE. L1) GO TO 111 - I = LINT1+KINT1 - XX = X-TCOS(I) - DO 110 I=1,M - Y1(I) = XX*Y1(I)+W1(I) - 110 CONTINUE - LINT1 = LINT1+1 - L1 = (LINT1*K1P1)/K2P1 - 111 IF (N .NE. L2) GO TO 113 - I = LINT2+KINT2 - XX = X-TCOS(I) - DO 112 I=1,M - Y2(I) = XX*Y2(I)+W2(I) - 112 CONTINUE - LINT2 = LINT2+1 - L2 = (LINT2*K1P1)/K3P1 - 113 IF (N .NE. L3) GO TO 115 - I = LINT3+KINT3 - XX = X-TCOS(I) - DO 114 I=1,M - Y3(I) = XX*Y3(I)+W3(I) - 114 CONTINUE - LINT3 = LINT3+1 - L3 = (LINT3*K1P1)/K4P1 - 115 CONTINUE - RETURN - END diff --git a/slatec/cmptrx.f b/slatec/cmptrx.f deleted file mode 100644 index dd761a0..0000000 --- a/slatec/cmptrx.f +++ /dev/null @@ -1,73 +0,0 @@ -*DECK CMPTRX - SUBROUTINE CMPTRX (IDEGBR, IDEGCR, M, A, B, C, Y, TCOS, D, W) -C***BEGIN PROLOGUE CMPTRX -C***SUBSIDIARY -C***PURPOSE Subsidiary to CMGNBN -C***LIBRARY SLATEC -C***TYPE COMPLEX (TRIX-S, CMPTRX-C) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Subroutine to solve a system of linear equations where the -C coefficient matrix is a rational function in the matrix given by -C tridiagonal ( . . . , A(I), B(I), C(I), . . . ). -C -C***SEE ALSO CMGNBN -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 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 900402 Added TYPE section. (WRB) -C***END PROLOGUE CMPTRX -C - COMPLEX A ,B ,C ,Y , - 1 TCOS ,D ,W ,X , - 2 XX ,Z - DIMENSION A(*) ,B(*) ,C(*) ,Y(*) , - 1 TCOS(*) ,D(*) ,W(*) - INTEGER KB, KC -C***FIRST EXECUTABLE STATEMENT CMPTRX - MM1 = M-1 - KB = IDEGBR+1 - KC = IDEGCR+1 - L = KB/KC - LINT = 1 - DO 108 K=1,IDEGBR - X = TCOS(K) - IF (K .NE. L) GO TO 102 - I = IDEGBR+LINT - XX = X-TCOS(I) - DO 101 I=1,M - W(I) = Y(I) - Y(I) = XX*Y(I) - 101 CONTINUE - 102 CONTINUE - Z = 1./(B(1)-X) - D(1) = C(1)*Z - Y(1) = Y(1)*Z - DO 103 I=2,MM1 - Z = 1./(B(I)-X-A(I)*D(I-1)) - D(I) = C(I)*Z - Y(I) = (Y(I)-A(I)*Y(I-1))*Z - 103 CONTINUE - Z = B(M)-X-A(M)*D(MM1) - IF (ABS(Z) .NE. 0.) GO TO 104 - Y(M) = (0.,0.) - GO TO 105 - 104 Y(M) = (Y(M)-A(M)*Y(MM1))/Z - 105 CONTINUE - DO 106 IP=1,MM1 - I = M-IP - Y(I) = Y(I)-D(I)*Y(I+1) - 106 CONTINUE - IF (K .NE. L) GO TO 108 - DO 107 I=1,M - Y(I) = Y(I)+W(I) - 107 CONTINUE - LINT = LINT+1 - L = (LINT*KB)/KC - 108 CONTINUE - RETURN - END diff --git a/slatec/cnbco.f b/slatec/cnbco.f deleted file mode 100644 index e3dcce8..0000000 --- a/slatec/cnbco.f +++ /dev/null @@ -1,280 +0,0 @@ -*DECK CNBCO - SUBROUTINE CNBCO (ABE, LDA, N, ML, MU, IPVT, RCOND, Z) -C***BEGIN PROLOGUE CNBCO -C***PURPOSE Factor a band matrix using Gaussian elimination and -C estimate the condition number. -C***LIBRARY SLATEC -C***CATEGORY D2C2 -C***TYPE COMPLEX (SNBCO-S, DNBCO-D, CNBCO-C) -C***KEYWORDS BANDED, LINEAR EQUATIONS, MATRIX FACTORIZATION, -C NONSYMMETRIC -C***AUTHOR Voorhees, E. A., (LANL) -C***DESCRIPTION -C -C CNBCO factors a complex band matrix by Gaussian -C elimination and estimates the condition of the matrix. -C -C If RCOND is not needed, CNBFA is slightly faster. -C To solve A*X = B , follow CNBCO by CNBSL. -C To compute INVERSE(A)*C , follow CNBCO by CNBSL. -C To compute DETERMINANT(A) , follow CNBCO by CNBDI. -C -C On Entry -C -C ABE COMPLEX(LDA, NC) -C contains the matrix in band storage. The rows -C of the original matrix are stored in the rows -C of ABE and the diagonals of the original matrix -C are stored in columns 1 through ML+MU+1 of ABE. -C NC must be .GE. 2*ML+MU+1 . -C See the comments below for details. -C -C LDA INTEGER -C the leading dimension of the array ABE. -C LDA must be .GE. N . -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 ABE an upper triangular matrix in band storage -C and 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 REAL -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 COMPLEX(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 DO 20 I = 1, N -C J1 = MAX(1, I-ML) -C J2 = MIN(N, I+MU) -C DO 10 J = J1, J2 -C K = J - I + ML + 1 -C ABE(I,K) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C This uses columns 1 through ML+MU+1 of ABE . -C Furthermore, ML additional columns are needed in -C ABE starting with column ML+MU+2 for elements -C generated during the triangularization. The total -C number of columns needed in ABE is 2*ML+MU+1 . -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 ABE should contain -C -C * 11 12 13 + , * = not used -C 21 22 23 24 + , + = used for pivoting -C 32 33 34 35 + -C 43 44 45 46 + -C 54 55 56 * + -C 65 66 * * + -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CDOTC, CNBFA, CSSCAL, SCASUM -C***REVISION HISTORY (YYMMDD) -C 800730 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CNBCO - INTEGER LDA,N,ML,MU,IPVT(*) - COMPLEX ABE(LDA,*),Z(*) - REAL RCOND -C - COMPLEX CDOTC,EK,T,WK,WKM - REAL ANORM,S,SCASUM,SM,YNORM - INTEGER I,INFO,J,JU,K,KB,KP1,L,LDB,LM,LZ,M,ML1,MM,NL,NU - COMPLEX ZDUM,ZDUM1,ZDUM2,CSIGN1 - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) - CSIGN1(ZDUM1,ZDUM2) = CABS1(ZDUM1)*(ZDUM2/CABS1(ZDUM2)) -C -C COMPUTE 1-NORM OF A -C -C***FIRST EXECUTABLE STATEMENT CNBCO - ML1=ML+1 - LDB = LDA - 1 - ANORM = 0.0E0 - DO 10 J = 1, N - NU = MIN(MU,J-1) - NL = MIN(ML,N-J) - L = 1 + NU + NL - ANORM = MAX(ANORM,SCASUM(L,ABE(J+NL,ML1-NL),LDB)) - 10 CONTINUE -C -C FACTOR -C - CALL CNBFA(ABE,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 CTRANS(A)*Y = E . -C CTRANS(A) IS THE CONJUGATE TRANSPOSE OF A . -C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL -C GROWTH IN THE ELEMENTS OF W WHERE CTRANS(U)*W = E . -C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. -C -C SOLVE CTRANS(U)*W = E -C - EK = (1.0E0,0.0E0) - DO 20 J = 1, N - Z(J) = (0.0E0,0.0E0) - 20 CONTINUE - M = ML + MU + 1 - JU = 0 - DO 100 K = 1, N - IF (CABS1(Z(K)) .NE. 0.0E0) EK = CSIGN1(EK,-Z(K)) - IF (CABS1(EK-Z(K)) .LE. CABS1(ABE(K,ML1))) GO TO 30 - S = CABS1(ABE(K,ML1))/CABS1(EK-Z(K)) - CALL CSSCAL(N,S,Z,1) - EK = CMPLX(S,0.0E0)*EK - 30 CONTINUE - WK = EK - Z(K) - WKM = -EK - Z(K) - S = CABS1(WK) - SM = CABS1(WKM) - IF (CABS1(ABE(K,ML1)) .EQ. 0.0E0) GO TO 40 - WK = WK/CONJG(ABE(K,ML1)) - WKM = WKM/CONJG(ABE(K,ML1)) - GO TO 50 - 40 CONTINUE - WK = (1.0E0,0.0E0) - WKM = (1.0E0,0.0E0) - 50 CONTINUE - KP1 = K + 1 - JU = MIN(MAX(JU,MU+IPVT(K)),N) - MM = ML1 - IF (KP1 .GT. JU) GO TO 90 - DO 60 I = KP1, JU - MM = MM + 1 - SM = SM + CABS1(Z(I)+WKM*CONJG(ABE(K,MM))) - Z(I) = Z(I) + WK*CONJG(ABE(K,MM)) - S = S + CABS1(Z(I)) - 60 CONTINUE - IF (S .GE. SM) GO TO 80 - T = WKM -WK - WK = WKM - MM = ML1 - DO 70 I = KP1, JU - MM = MM + 1 - Z(I) = Z(I) + T*CONJG(ABE(K,MM)) - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - Z(K) = WK - 100 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) -C -C SOLVE CTRANS(L)*Y = W -C - DO 120 KB = 1, N - K = N + 1 - KB - NL = MIN(ML,N-K) - IF (K .LT. N) Z(K) = Z(K) + CDOTC(NL,ABE(K+NL,ML1-NL),-LDB, - 1 Z(K+1),1) - IF (CABS1(Z(K)) .LE. 1.0E0) GO TO 110 - S = 1.0E0/CABS1(Z(K)) - CALL CSSCAL(N,S,Z,1) - 110 CONTINUE - L = IPVT(K) - T = Z(L) - Z(L) = Z(K) - Z(K) = T - 120 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) -C - YNORM = 1.0E0 -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 - NL = MIN(ML,N-K) - IF (K .LT. N) CALL CAXPY(NL,T,ABE(K+NL,ML1-NL),-LDB,Z(K+1),1) - IF (CABS1(Z(K)) .LE. 1.0E0) GO TO 130 - S = 1.0E0/CABS1(Z(K)) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM - 130 CONTINUE - 140 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE U*Z = V -C - DO 160 KB = 1, N - K = N + 1 - KB - IF (CABS1(Z(K)) .LE. CABS1(ABE(K,ML1))) GO TO 150 - S = CABS1(ABE(K,ML1))/CABS1(Z(K)) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM - 150 CONTINUE - IF (CABS1(ABE(K,ML1)) .NE. 0.0E0) Z(K) = Z(K)/ABE(K,ML1) - IF (CABS1(ABE(K,ML1)) .EQ. 0.0E0) Z(K) = 1.0E0 - LM = MIN(K,M) - 1 - LZ = K - LM - T = -Z(K) - CALL CAXPY(LM,T,ABE(K-1,ML+2),-LDB,Z(LZ),1) - 160 CONTINUE -C MAKE ZNORM = 1.0E0 - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM -C - IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM - IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0 - RETURN - END diff --git a/slatec/cnbdi.f b/slatec/cnbdi.f deleted file mode 100644 index 9a5d7c4..0000000 --- a/slatec/cnbdi.f +++ /dev/null @@ -1,86 +0,0 @@ -*DECK CNBDI - SUBROUTINE CNBDI (ABE, LDA, N, ML, MU, IPVT, DET) -C***BEGIN PROLOGUE CNBDI -C***PURPOSE Compute the determinant of a band matrix using the factors -C computed by CNBCO or CNBFA. -C***LIBRARY SLATEC -C***CATEGORY D3C2 -C***TYPE COMPLEX (SNBDI-S, DNBDI-D, CNBDI-C) -C***KEYWORDS BANDED, DETERMINANT, LINEAR EQUATIONS, NONSYMMETRIC -C***AUTHOR Voorhees, E. A., (LANL) -C***DESCRIPTION -C -C CNBDI computes the determinant of a band matrix -C using the factors computed by CNBCO or CNBFA. -C If the inverse is needed, use CNBSL N times. -C -C On Entry -C -C ABE COMPLEX(LDA, NC) -C the output from CNBCO or CNBFA. -C NC must be .GE. 2*ML+MU+1 . -C -C LDA INTEGER -C the leading dimension of the array ABE . -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 CNBCO or CNBFA. -C -C On Return -C -C DET COMPLEX(2) -C determinant of original matrix. -C Determinant = DET(1) * 10.0**DET(2) -C with 1.0 .LE. CABS1(DET(1)) .LT. 10.0 -C or DET(1) = 0.0 . -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 800730 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CNBDI - INTEGER LDA,N,ML,MU,IPVT(*) - COMPLEX ABE(LDA,*),DET(2) -C - REAL TEN - INTEGER I - COMPLEX ZDUM - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) -C -C***FIRST EXECUTABLE STATEMENT CNBDI - DET(1) = (1.0E0,0.0E0) - DET(2) = (0.0E0,0.0E0) - TEN = 10.0E0 - DO 50 I = 1, N - IF (IPVT(I) .NE. I) DET(1) = -DET(1) - DET(1) = ABE(I,ML+1)*DET(1) - IF (CABS1(DET(1)) .EQ. 0.0E0) GO TO 60 - 10 IF (CABS1(DET(1)) .GE. 1.0E0) GO TO 20 - DET(1) = CMPLX(TEN,0.0E0)*DET(1) - DET(2) = DET(2) - (1.0E0,0.0E0) - GO TO 10 - 20 CONTINUE - 30 IF (CABS1(DET(1)) .LT. TEN) GO TO 40 - DET(1) = DET(1)/CMPLX(TEN,0.0E0) - DET(2) = DET(2) + (1.0E0,0.0E0) - GO TO 30 - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE - RETURN - END diff --git a/slatec/cnbfa.f b/slatec/cnbfa.f deleted file mode 100644 index 23cb507..0000000 --- a/slatec/cnbfa.f +++ /dev/null @@ -1,183 +0,0 @@ -*DECK CNBFA - SUBROUTINE CNBFA (ABE, LDA, N, ML, MU, IPVT, INFO) -C***BEGIN PROLOGUE CNBFA -C***PURPOSE Factor a band matrix by elimination. -C***LIBRARY SLATEC -C***CATEGORY D2C2 -C***TYPE COMPLEX (SNBFA-S, DNBFA-D, CNBFA-C) -C***KEYWORDS BANDED, LINEAR EQUATIONS, MATRIX FACTORIZATION, -C NONSYMMETRIC -C***AUTHOR Voorhees, E. A., (LANL) -C***DESCRIPTION -C -C CNBFA factors a complex band matrix by elimination. -C -C CNBFA is usually called by CNBCO, but it can be called -C directly with a saving in time if RCOND is not needed. -C -C On Entry -C -C ABE COMPLEX(LDA, NC) -C contains the matrix in band storage. The rows -C of the original matrix are stored in the rows -C of ABE and the diagonals of the original matrix -C are stored in columns 1 through ML+MU+1 of ABE. -C NC must be .GE. 2*ML+MU+1 . -C See the comments below for details. -C -C LDA INTEGER -C the leading dimension of the array ABE. -C LDA must be .GE. N . -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 ABE an upper triangular matrix in band storage -C and 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 CNBSL will divide by zero if -C called. Use RCOND in CNBCO 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 DO 20 I = 1, N -C J1 = MAX(1, I-ML) -C J2 = MIN(N, I+MU) -C DO 10 J = J1, J2 -C K = J - I + ML + 1 -C ABE(I,K) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C This uses columns 1 through ML+MU+1 of ABE . -C Furthermore, ML additional columns are needed in -C ABE starting with column ML+MU+2 for elements -C generated during the triangularization. The total -C number of columns needed in ABE is 2*ML+MU+1 . -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 ABE should contain -C -C * 11 12 13 + , * = not used -C 21 22 23 24 + , + = used for pivoting -C 32 33 34 35 + -C 43 44 45 46 + -C 54 55 56 * + -C 65 66 * * + -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CSCAL, CSWAP, ICAMAX -C***REVISION HISTORY (YYMMDD) -C 800730 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CNBFA - INTEGER LDA,N,ML,MU,IPVT(*),INFO - COMPLEX ABE(LDA,*) -C - INTEGER ML1,MB,M,N1,LDB,I,J,K,L,LM,LM1,LM2,MP,ICAMAX - COMPLEX T - COMPLEX ZDUM - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) -C -C***FIRST EXECUTABLE STATEMENT CNBFA - ML1=ML+1 - MB=ML+MU - M=ML+MU+1 - N1=N-1 - LDB=LDA-1 - INFO=0 -C -C SET FILL-IN COLUMNS TO ZERO -C - IF(N.LE.1)GO TO 50 - IF(ML.LE.0)GO TO 7 - DO 6 J=1,ML - DO 5 I=1,N - ABE(I,M+J)=(0.0E0,0.0E0) - 5 CONTINUE - 6 CONTINUE - 7 CONTINUE -C -C GAUSSIAN ELIMINATION WITH PARTIAL ELIMINATION -C - DO 40 K=1,N1 - LM=MIN(N-K,ML) - LM1=LM+1 - LM2=ML1-LM -C -C SEARCH FOR PIVOT INDEX -C - L=-ICAMAX(LM1,ABE(LM+K,LM2),LDB)+LM1+K - IPVT(K)=L - MP=MIN(MB,N-K) -C -C SWAP ROWS IF NECESSARY -C - IF(L.NE.K)CALL CSWAP(MP+1,ABE(K,ML1),LDA,ABE(L,ML1+K-L),LDA) -C -C SKIP COLUMN REDUCTION IF PIVOT IS ZERO -C - IF(CABS1(ABE(K,ML1)).EQ.0.0E0) GO TO 20 -C -C COMPUTE MULTIPLIERS -C - T=-(1.0E0,0.0E0)/ABE(K,ML1) - CALL CSCAL(LM,T,ABE(LM+K,LM2),LDB) -C -C ROW ELIMINATION WITH COLUMN INDEXING -C - DO 10 J=1,MP - CALL CAXPY (LM,ABE(K,ML1+J),ABE(LM+K,LM2),LDB,ABE(LM+K,LM2+J), - 1 LDB) - 10 CONTINUE - GO TO 30 - 20 CONTINUE - INFO=K - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - IPVT(N)=N - IF(CABS1(ABE(N,ML1)).EQ.0.0E0) INFO=N - RETURN - END diff --git a/slatec/cnbfs.f b/slatec/cnbfs.f deleted file mode 100644 index f81cd41..0000000 --- a/slatec/cnbfs.f +++ /dev/null @@ -1,251 +0,0 @@ -*DECK CNBFS - SUBROUTINE CNBFS (ABE, LDA, N, ML, MU, V, ITASK, IND, WORK, IWORK) -C***BEGIN PROLOGUE CNBFS -C***PURPOSE Solve a general nonsymmetric banded system of linear -C equations. -C***LIBRARY SLATEC -C***CATEGORY D2C2 -C***TYPE COMPLEX (SNBFS-S, DNBFS-D, CNBFS-C) -C***KEYWORDS BANDED, LINEAR EQUATIONS, NONSYMMETRIC -C***AUTHOR Voorhees, E. A., (LANL) -C***DESCRIPTION -C -C Subroutine CNBFS solves a general nonsymmetric banded NxN -C system of single precision complex linear equations using -C SLATEC subroutines CNBCO and CNBSL. These are adaptations -C of the LINPACK subroutines CGBCO and CGBSL which require -C a different format for storing the matrix elements. If -C A is an NxN complex matrix and if X and B are complex -C N-vectors, then CNBFS solves the equation -C -C A*X=B. -C -C A band matrix is a matrix whose nonzero elements are all -C fairly near the main diagonal, specifically A(I,J) = 0 -C if I-J is greater than ML or J-I is greater than -C MU . The integers ML and MU are called the lower and upper -C band widths and M = ML+MU+1 is the total band width. -C CNBFS uses less time and storage than the corresponding -C program for general matrices (CGEFS) if 2*ML+MU .LT. N . -C -C The matrix A is first factored into upper and lower tri- -C angular matrices U and L using partial pivoting. These -C factors and the pivoting information are used to find the -C solution vector X. An approximate condition number is -C calculated to provide a rough estimate of the number of -C digits of accuracy in the computed solution. -C -C If the equation A*X=B is to be solved for more than one vector -C B, the factoring of A does not need to be performed again and -C the option to only solve (ITASK .GT. 1) will be faster for -C the succeeding solutions. In this case, the contents of A, -C LDA, N and IWORK must not have been altered by the user follow- -C ing factorization (ITASK=1). IND will not be changed by CNBFS -C in this case. -C -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 DO 20 I = 1, N -C J1 = MAX(1, I-ML) -C J2 = MIN(N, I+MU) -C DO 10 J = J1, J2 -C K = J - I + ML + 1 -C ABE(I,K) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C This uses columns 1 through ML+MU+1 of ABE . -C Furthermore, ML additional columns are needed in -C ABE starting with column ML+MU+2 for elements -C generated during the triangularization. The total -C number of columns needed in ABE is 2*ML+MU+1 . -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 ABE should contain -C -C * 11 12 13 + , * = not used -C 21 22 23 24 + , + = used for pivoting -C 32 33 34 35 + -C 43 44 45 46 + -C 54 55 56 * + -C 65 66 * * + -C -C -C Argument Description *** -C -C ABE COMPLEX(LDA,NC) -C on entry, contains the matrix in band storage as -C described above. NC must not be less than -C 2*ML+MU+1 . The user is cautioned to specify NC -C with care since it is not an argument and cannot -C be checked by CNBFS. The rows of the original -C matrix are stored in the rows of ABE and the -C diagonals of the original matrix are stored in -C columns 1 through ML+MU+1 of ABE . -C on return, contains an upper triangular matrix U and -C the multipliers necessary to construct a matrix L -C so that A=L*U. -C LDA INTEGER -C the leading dimension of array ABE. LDA must be great- -C er than or equal to N. (terminal error message IND=-1) -C N INTEGER -C the order of the matrix A. N must be greater -C than or equal to 1 . (terminal error message IND=-2) -C ML INTEGER -C the number of diagonals below the main diagonal. -C ML must not be less than zero nor greater than or -C equal to N . (terminal error message IND=-5) -C MU INTEGER -C the number of diagonals above the main diagonal. -C MU must not be less than zero nor greater than or -C equal to N . (terminal error message IND=-6) -C V COMPLEX(N) -C on entry, the singly subscripted array(vector) of di- -C mension N which contains the right hand side B of a -C system of simultaneous linear equations A*X=B. -C on return, V contains the solution vector, X . -C ITASK INTEGER -C if ITASK = 1, the matrix A is factored and then the -C linear equation is solved. -C if ITASK .GT. 1, the equation is solved using the existing -C factored matrix A and IWORK. -C if ITASK .LT. 1, then terminal error message IND=-3 is -C printed. -C IND INTEGER -C GT. 0 IND is a rough estimate of the number of digits -C of accuracy in the solution, X. -C LT. 0 see error message corresponding to IND below. -C WORK COMPLEX(N) -C a singly subscripted array of dimension at least N. -C IWORK INTEGER(N) -C a singly subscripted array of dimension at least N. -C -C Error Messages Printed *** -C -C IND=-1 terminal N is greater than LDA. -C IND=-2 terminal N is less than 1. -C IND=-3 terminal ITASK is less than 1. -C IND=-4 terminal The matrix A is computationally singular. -C A solution has not been computed. -C IND=-5 terminal ML is less than zero or is greater than -C or equal to N . -C IND=-6 terminal MU is less than zero or is greater than -C or equal to N . -C IND=-10 warning The solution has no apparent significance. -C The solution may be inaccurate or the matrix -C A may be poorly scaled. -C -C NOTE- The above terminal(*fatal*) error messages are -C designed to be handled by XERMSG in which -C LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 -C for warning error messages from XERMSG. Unless -C the user provides otherwise, an error message -C will be printed followed by an abort. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CNBCO, CNBSL, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800813 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900510 Convert XERRWV calls to XERMSG calls, cvt GOTO's to -C IF-THEN-ELSE. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CNBFS -C - INTEGER LDA,N,ITASK,IND,IWORK(*),ML,MU - COMPLEX ABE(LDA,*),V(*),WORK(*) - REAL RCOND - REAL R1MACH - CHARACTER*8 XERN1, XERN2 -C***FIRST EXECUTABLE STATEMENT CNBFS - IF (LDA.LT.N) THEN - IND = -1 - WRITE (XERN1, '(I8)') LDA - WRITE (XERN2, '(I8)') N - CALL XERMSG ('SLATEC', 'CNBFS', 'LDA = ' // XERN1 // - * ' IS LESS THAN N = ' // XERN2, -1, 1) - RETURN - ENDIF -C - IF (N.LE.0) THEN - IND = -2 - WRITE (XERN1, '(I8)') N - CALL XERMSG ('SLATEC', 'CNBFS', 'N = ' // XERN1 // - * ' IS LESS THAN 1', -2, 1) - RETURN - ENDIF -C - IF (ITASK.LT.1) THEN - IND = -3 - WRITE (XERN1, '(I8)') ITASK - CALL XERMSG ('SLATEC', 'CNBFS', 'ITASK = ' // XERN1 // - * ' IS LESS THAN 1', -3, 1) - RETURN - ENDIF -C - IF (ML.LT.0 .OR. ML.GE.N) THEN - IND = -5 - WRITE (XERN1, '(I8)') ML - CALL XERMSG ('SLATEC', 'CNBFS', - * 'ML = ' // XERN1 // ' IS OUT OF RANGE', -5, 1) - RETURN - ENDIF -C - IF (MU.LT.0 .OR. MU.GE.N) THEN - IND = -6 - WRITE (XERN1, '(I8)') MU - CALL XERMSG ('SLATEC', 'CNBFS', - * 'MU = ' // XERN1 // ' IS OUT OF RANGE', -6, 1) - RETURN - ENDIF -C - IF (ITASK.EQ.1) THEN -C -C FACTOR MATRIX A INTO LU -C - CALL CNBCO(ABE,LDA,N,ML,MU,IWORK,RCOND,WORK) -C -C CHECK FOR COMPUTATIONALLY SINGULAR MATRIX -C - IF (RCOND.EQ.0.0) THEN - IND = -4 - CALL XERMSG ('SLATEC', 'CNBFS', - * 'SINGULAR MATRIX A - NO SOLUTION', -4, 1) - RETURN - ENDIF -C -C COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) -C AND CHECK FOR IND GREATER THAN ZERO -C - IND = -LOG10(R1MACH(4)/RCOND) - IF (IND.LE.0) THEN - IND = -10 - CALL XERMSG ('SLATEC', 'CNBFS', - * 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) - ENDIF - ENDIF -C -C SOLVE AFTER FACTORING -C - CALL CNBSL(ABE,LDA,N,ML,MU,IWORK,V,0) - RETURN - END diff --git a/slatec/cnbir.f b/slatec/cnbir.f deleted file mode 100644 index fc114fc..0000000 --- a/slatec/cnbir.f +++ /dev/null @@ -1,284 +0,0 @@ -*DECK CNBIR - SUBROUTINE CNBIR (ABE, LDA, N, ML, MU, V, ITASK, IND, WORK, IWORK) -C***BEGIN PROLOGUE CNBIR -C***PURPOSE Solve a general nonsymmetric banded system of linear -C equations. Iterative refinement is used to obtain an error -C estimate. -C***LIBRARY SLATEC -C***CATEGORY D2C2 -C***TYPE COMPLEX (SNBIR-S, CNBIR-C) -C***KEYWORDS BANDED, LINEAR EQUATIONS, NONSYMMETRIC -C***AUTHOR Voorhees, E. A., (LANL) -C***DESCRIPTION -C -C Subroutine CNBIR solves a general nonsymmetric banded NxN -C system of single precision complex linear equations using -C SLATEC subroutines CNBFA and CNBSL. These are adaptations -C of the LINPACK subroutines CGBFA and CGBSL which require -C a different format for storing the matrix elements. -C One pass of iterative refinement is used only to obtain an -C estimate of the accuracy. If A is an NxN complex banded -C matrix and if X and B are complex N-vectors, then CNBIR -C solves the equation -C -C A*X=B. -C -C A band matrix is a matrix whose nonzero elements are all -C fairly near the main diagonal, specifically A(I,J) = 0 -C if I-J is greater than ML or J-I is greater than -C MU . The integers ML and MU are called the lower and upper -C band widths and M = ML+MU+1 is the total band width. -C CNBIR uses less time and storage than the corresponding -C program for general matrices (CGEIR) if 2*ML+MU .LT. N . -C -C The matrix A is first factored into upper and lower tri- -C angular matrices U and L using partial pivoting. These -C factors and the pivoting information are used to find the -C solution vector X . Then the residual vector is found and used -C to calculate an estimate of the relative error, IND . IND esti- -C mates the accuracy of the solution only when the input matrix -C and the right hand side are represented exactly in the computer -C and does not take into account any errors in the input data. -C -C If the equation A*X=B is to be solved for more than one vector -C B, the factoring of A does not need to be performed again and -C the option to only solve (ITASK .GT. 1) will be faster for -C the succeeding solutions. In this case, the contents of A, LDA, -C N, WORK and IWORK must not have been altered by the user follow- -C ing factorization (ITASK=1). IND will not be changed by CNBIR -C in this case. -C -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 DO 20 I = 1, N -C J1 = MAX(1, I-ML) -C J2 = MIN(N, I+MU) -C DO 10 J = J1, J2 -C K = J - I + ML + 1 -C ABE(I,K) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C This uses columns 1 through ML+MU+1 of ABE . -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 ABE should contain -C -C * 11 12 13 , * = not used -C 21 22 23 24 -C 32 33 34 35 -C 43 44 45 46 -C 54 55 56 * -C 65 66 * * -C -C -C Argument Description *** -C -C ABE COMPLEX(LDA,MM) -C on entry, contains the matrix in band storage as -C described above. MM must not be less than M = -C ML+MU+1 . The user is cautioned to dimension ABE -C with care since MM is not an argument and cannot -C be checked by CNBIR. The rows of the original -C matrix are stored in the rows of ABE and the -C diagonals of the original matrix are stored in -C columns 1 through ML+MU+1 of ABE . ABE is -C not altered by the program. -C LDA INTEGER -C the leading dimension of array ABE. LDA must be great- -C er than or equal to N. (terminal error message IND=-1) -C N INTEGER -C the order of the matrix A. N must be greater -C than or equal to 1 . (terminal error message IND=-2) -C ML INTEGER -C the number of diagonals below the main diagonal. -C ML must not be less than zero nor greater than or -C equal to N . (terminal error message IND=-5) -C MU INTEGER -C the number of diagonals above the main diagonal. -C MU must not be less than zero nor greater than or -C equal to N . (terminal error message IND=-6) -C V COMPLEX(N) -C on entry, the singly subscripted array(vector) of di- -C mension N which contains the right hand side B of a -C system of simultaneous linear equations A*X=B. -C on return, V contains the solution vector, X . -C ITASK INTEGER -C if ITASK=1, the matrix A is factored and then the -C linear equation is solved. -C if ITASK .GT. 1, the equation is solved using the existing -C factored matrix A and IWORK. -C if ITASK .LT. 1, then terminal error message IND=-3 is -C printed. -C IND INTEGER -C GT. 0 IND is a rough estimate of the number of digits -C of accuracy in the solution, X . IND=75 means -C that the solution vector X is zero. -C LT. 0 see error message corresponding to IND below. -C WORK COMPLEX(N*(NC+1)) -C a singly subscripted array of dimension at least -C N*(NC+1) where NC = 2*ML+MU+1 . -C IWORK INTEGER(N) -C a singly subscripted array of dimension at least N. -C -C Error Messages Printed *** -C -C IND=-1 terminal N is greater than LDA. -C IND=-2 terminal N is less than 1. -C IND=-3 terminal ITASK is less than 1. -C IND=-4 terminal The matrix A is computationally singular. -C A solution has not been computed. -C IND=-5 terminal ML is less than zero or is greater than -C or equal to N . -C IND=-6 terminal MU is less than zero or is greater than -C or equal to N . -C IND=-10 warning The solution has no apparent significance. -C The solution may be inaccurate or the matrix -C A may be poorly scaled. -C -C NOTE- The above terminal(*fatal*) error messages are -C designed to be handled by XERMSG in which -C LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 -C for warning error messages from XERMSG. Unless -C the user provides otherwise, an error message -C will be printed followed by an abort. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CCOPY, CDCDOT, CNBFA, CNBSL, R1MACH, SCASUM, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800819 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900510 Convert XERRWV calls to XERMSG calls, cvt GOTO's to -C IF-THEN-ELSE. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CNBIR -C - INTEGER LDA,N,ITASK,IND,IWORK(*),INFO,J,K,KK,L,M,ML,MU,NC - COMPLEX ABE(LDA,*),V(*),WORK(N,*),CDCDOT - REAL XNORM,DNORM,SCASUM,R1MACH - CHARACTER*8 XERN1, XERN2 -C***FIRST EXECUTABLE STATEMENT CNBIR - IF (LDA.LT.N) THEN - IND = -1 - WRITE (XERN1, '(I8)') LDA - WRITE (XERN2, '(I8)') N - CALL XERMSG ('SLATEC', 'CNBIR', 'LDA = ' // XERN1 // - * ' IS LESS THAN N = ' // XERN2, -1, 1) - RETURN - ENDIF -C - IF (N.LE.0) THEN - IND = -2 - WRITE (XERN1, '(I8)') N - CALL XERMSG ('SLATEC', 'CNBIR', 'N = ' // XERN1 // - * ' IS LESS THAN 1', -2, 1) - RETURN - ENDIF -C - IF (ITASK.LT.1) THEN - IND = -3 - WRITE (XERN1, '(I8)') ITASK - CALL XERMSG ('SLATEC', 'CNBIR', 'ITASK = ' // XERN1 // - * ' IS LESS THAN 1', -3, 1) - RETURN - ENDIF -C - IF (ML.LT.0 .OR. ML.GE.N) THEN - IND = -5 - WRITE (XERN1, '(I8)') ML - CALL XERMSG ('SLATEC', 'CNBIR', - * 'ML = ' // XERN1 // ' IS OUT OF RANGE', -5, 1) - RETURN - ENDIF -C - IF (MU.LT.0 .OR. MU.GE.N) THEN - IND = -6 - WRITE (XERN1, '(I8)') MU - CALL XERMSG ('SLATEC', 'CNBIR', - * 'MU = ' // XERN1 // ' IS OUT OF RANGE', -6, 1) - RETURN - ENDIF -C - NC = 2*ML+MU+1 - IF (ITASK.EQ.1) THEN -C -C MOVE MATRIX ABE TO WORK -C - M=ML+MU+1 - DO 10 J=1,M - CALL CCOPY(N,ABE(1,J),1,WORK(1,J),1) - 10 CONTINUE -C -C FACTOR MATRIX A INTO LU - CALL CNBFA(WORK,N,N,ML,MU,IWORK,INFO) -C -C CHECK FOR COMPUTATIONALLY SINGULAR MATRIX - IF (INFO.NE.0) THEN - IND=-4 - CALL XERMSG ('SLATEC', 'CNBIR', - * 'SINGULAR MATRIX A - NO SOLUTION', -4, 1) - RETURN - ENDIF - ENDIF -C -C SOLVE WHEN FACTORING COMPLETE -C MOVE VECTOR B TO WORK -C - CALL CCOPY(N,V(1),1,WORK(1,NC+1),1) - CALL CNBSL(WORK,N,N,ML,MU,IWORK,V,0) -C -C FORM NORM OF X0 -C - XNORM = SCASUM(N,V(1),1) - IF (XNORM.EQ.0.0) THEN - IND = 75 - RETURN - ENDIF -C -C COMPUTE RESIDUAL -C - DO 40 J=1,N - K = MAX(1,ML+2-J) - KK = MAX(1,J-ML) - L = MIN(J-1,ML)+MIN(N-J,MU)+1 - WORK(J,NC+1) = CDCDOT(L,-WORK(J,NC+1),ABE(J,K),LDA,V(KK),1) - 40 CONTINUE -C -C SOLVE A*DELTA=R -C - CALL CNBSL(WORK,N,N,ML,MU,IWORK,WORK(1,NC+1),0) -C -C FORM NORM OF DELTA -C - DNORM = SCASUM(N,WORK(1,NC+1),1) -C -C COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) -C AND CHECK FOR IND GREATER THAN ZERO -C - IND = -LOG10(MAX(R1MACH(4),DNORM/XNORM)) - IF (IND.LE.0) THEN - IND = -10 - CALL XERMSG ('SLATEC', 'CNBIR', - * 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) - ENDIF - RETURN - END diff --git a/slatec/cnbsl.f b/slatec/cnbsl.f deleted file mode 100644 index 590a1a5..0000000 --- a/slatec/cnbsl.f +++ /dev/null @@ -1,149 +0,0 @@ -*DECK CNBSL - SUBROUTINE CNBSL (ABE, LDA, N, ML, MU, IPVT, B, JOB) -C***BEGIN PROLOGUE CNBSL -C***PURPOSE Solve a complex band system using the factors computed by -C CNBCO or CNBFA. -C***LIBRARY SLATEC -C***CATEGORY D2C2 -C***TYPE COMPLEX (SNBSL-S, DNBSL-D, CNBSL-C) -C***KEYWORDS BANDED, LINEAR EQUATIONS, NONSYMMETRIC, SOLVE -C***AUTHOR Voorhees, E. A., (LANL) -C***DESCRIPTION -C -C CNBSL solves the complex band system -C A * X = B or CTRANS(A) * X = B -C using the factors computed by CNBCO or CNBFA. -C -C On Entry -C -C ABE COMPLEX(LDA, NC) -C the output from CNBCO or CNBFA. -C NC must be .GE. 2*ML+MU+1 . -C -C LDA INTEGER -C the leading dimension of the array ABE . -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 CNBCO or CNBFA. -C -C B COMPLEX(N) -C the right hand side vector. -C -C JOB INTEGER -C = 0 to solve A*X = B . -C = nonzero to solve CTRANS(A)*X = B , where -C CTRANS(A) is the conjugate 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 CNBCO has set RCOND .GT. 0.0 -C or CNBFA has set INFO .EQ. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL CNBCO(ABE,LDA,N,ML,MU,IPVT,RCOND,Z) -C IF (RCOND is too small) GO TO ... -C DO 10 J = 1, P -C CALL CNBSL(ABE,LDA,N,ML,MU,IPVT,C(1,J),0) -C 10 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CDOTC -C***REVISION HISTORY (YYMMDD) -C 800730 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CNBSL - INTEGER LDA,N,ML,MU,IPVT(*),JOB - COMPLEX ABE(LDA,*),B(*) -C - COMPLEX CDOTC,T - INTEGER K,KB,L,LB,LDB,LM,M,MLM,NM1 -C***FIRST EXECUTABLE STATEMENT CNBSL - M=MU+ML+1 - NM1=N-1 - LDB=1-LDA - 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=MIN(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 - MLM=ML-(LM-1) - CALL CAXPY(LM,T,ABE(K+LM,MLM),LDB,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)/ABE(K,ML+1) - LM=MIN(K,M)-1 - LB=K-LM - T=-B(K) - CALL CAXPY(LM,T,ABE(K-1,ML+2),LDB,B(LB),1) - 40 CONTINUE - GO TO 100 - 50 CONTINUE -C -C JOB = NONZERO, SOLVE CTRANS(A) * X = B -C FIRST SOLVE CTRANS(U)*Y = B -C - DO 60 K = 1, N - LM = MIN(K,M) - 1 - LB = K - LM - T = CDOTC(LM,ABE(K-1,ML+2),LDB,B(LB),1) - B(K) = (B(K) - T)/CONJG(ABE(K,ML+1)) - 60 CONTINUE -C -C NOW SOLVE CTRANS(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 = MIN(ML,N-K) - MLM = ML - (LM - 1) - B(K) = B(K) + CDOTC(LM,ABE(K+LM,MLM),LDB,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/slatec/combak.f b/slatec/combak.f deleted file mode 100644 index d9b4e6a..0000000 --- a/slatec/combak.f +++ /dev/null @@ -1,115 +0,0 @@ -*DECK COMBAK - SUBROUTINE COMBAK (NM, LOW, IGH, AR, AI, INT, M, ZR, ZI) -C***BEGIN PROLOGUE COMBAK -C***PURPOSE Form the eigenvectors of a complex general matrix from the -C eigenvectors of a upper Hessenberg matrix output from -C COMHES. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C4 -C***TYPE COMPLEX (ELMBAK-S, COMBAK-C) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure COMBAK, -C NUM. MATH. 12, 349-368(1968) by Martin and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). -C -C This subroutine forms the eigenvectors of a COMPLEX GENERAL -C matrix by back transforming those of the corresponding -C upper Hessenberg matrix determined by COMHES. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, AR, AI, ZR and ZI, as declared in the -C calling program dimension statement. NM is an INTEGER -C variable. -C -C LOW and IGH are two INTEGER variables determined by the -C balancing subroutine CBAL. If CBAL has not been used, -C set LOW=1 and IGH equal to the order of the matrix. -C -C AR and AI contain the multipliers which were used in the -C reduction by COMHES in their lower triangles below -C the subdiagonal. AR and AI are two-dimensional REAL -C arrays, dimensioned AR(NM,IGH) and AI(NM,IGH). -C -C INT contains information on the rows and columns -C interchanged in the reduction by COMHES. Only -C elements LOW through IGH are used. INT is a -C one-dimensional INTEGER array, dimensioned INT(IGH). -C -C M is the number of eigenvectors to be back transformed. -C M is an INTEGER variable. -C -C ZR and ZI contain the real and imaginary parts, respectively, -C of the eigenvectors to be back transformed in their first M -C columns. ZR and ZI are two-dimensional REAL arrays, -C dimensioned ZR(NM,M) and ZI(NM,M). -C -C On OUTPUT -C -C ZR and ZI contain the real and imaginary parts, respectively, -C of the transformed eigenvectors in their first M columns. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE COMBAK -C - INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1 - REAL AR(NM,*),AI(NM,*),ZR(NM,*),ZI(NM,*) - REAL XR,XI - INTEGER INT(*) -C -C***FIRST EXECUTABLE STATEMENT COMBAK - IF (M .EQ. 0) GO TO 200 - LA = IGH - 1 - KP1 = LOW + 1 - IF (LA .LT. KP1) GO TO 200 -C .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... - DO 140 MM = KP1, LA - MP = LOW + IGH - MM - MP1 = MP + 1 -C - DO 110 I = MP1, IGH - XR = AR(I,MP-1) - XI = AI(I,MP-1) - IF (XR .EQ. 0.0E0 .AND. XI .EQ. 0.0E0) GO TO 110 -C - DO 100 J = 1, M - ZR(I,J) = ZR(I,J) + XR * ZR(MP,J) - XI * ZI(MP,J) - ZI(I,J) = ZI(I,J) + XR * ZI(MP,J) + XI * ZR(MP,J) - 100 CONTINUE -C - 110 CONTINUE -C - I = INT(MP) - IF (I .EQ. MP) GO TO 140 -C - DO 130 J = 1, M - XR = ZR(I,J) - ZR(I,J) = ZR(MP,J) - ZR(MP,J) = XR - XI = ZI(I,J) - ZI(I,J) = ZI(MP,J) - ZI(MP,J) = XI - 130 CONTINUE -C - 140 CONTINUE -C - 200 RETURN - END diff --git a/slatec/comhes.f b/slatec/comhes.f deleted file mode 100644 index 14cdabd..0000000 --- a/slatec/comhes.f +++ /dev/null @@ -1,142 +0,0 @@ -*DECK COMHES - SUBROUTINE COMHES (NM, N, LOW, IGH, AR, AI, INT) -C***BEGIN PROLOGUE COMHES -C***PURPOSE Reduce a complex general matrix to complex upper Hessenberg -C form using stabilized elementary similarity -C transformations. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C1B2 -C***TYPE COMPLEX (ELMHES-S, COMHES-C) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure COMHES, -C NUM. MATH. 12, 349-368(1968) by Martin and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). -C -C Given a COMPLEX GENERAL matrix, this subroutine -C reduces a submatrix situated in rows and columns -C LOW through IGH to upper Hessenberg form by -C stabilized elementary similarity transformations. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, AR and AI, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix A=(AR,AI). N is an INTEGER -C variable. N must be less than or equal to NM. -C -C LOW and IGH are two INTEGER variables determined by the -C balancing subroutine CBAL. If CBAL has not been used, -C set LOW=1 and IGH equal to the order of the matrix, N. -C -C AR and AI contain the real and imaginary parts, respectively, -C of the complex input matrix. AR and AI are two-dimensional -C REAL arrays, dimensioned AR(NM,N) and AI(NM,N). -C -C On OUTPUT -C -C AR and AI contain the real and imaginary parts, respectively, -C of the upper Hessenberg matrix. The multipliers which -C were used in the reduction are stored in the remaining -C triangles under the Hessenberg matrix. -C -C INT contains information on the rows and columns -C interchanged in the reduction. Only elements LOW through -C IGH are used. INT is a one-dimensional INTEGER array, -C dimensioned INT(IGH). -C -C Calls CDIV for complex division. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED CDIV -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE COMHES -C - INTEGER I,J,M,N,LA,NM,IGH,KP1,LOW,MM1,MP1 - REAL AR(NM,*),AI(NM,*) - REAL XR,XI,YR,YI - INTEGER INT(*) -C -C***FIRST EXECUTABLE STATEMENT COMHES - LA = IGH - 1 - KP1 = LOW + 1 - IF (LA .LT. KP1) GO TO 200 -C - DO 180 M = KP1, LA - MM1 = M - 1 - XR = 0.0E0 - XI = 0.0E0 - I = M -C - DO 100 J = M, IGH - IF (ABS(AR(J,MM1)) + ABS(AI(J,MM1)) - 1 .LE. ABS(XR) + ABS(XI)) GO TO 100 - XR = AR(J,MM1) - XI = AI(J,MM1) - I = J - 100 CONTINUE -C - INT(M) = I - IF (I .EQ. M) GO TO 130 -C .......... INTERCHANGE ROWS AND COLUMNS OF AR AND AI .......... - DO 110 J = MM1, N - YR = AR(I,J) - AR(I,J) = AR(M,J) - AR(M,J) = YR - YI = AI(I,J) - AI(I,J) = AI(M,J) - AI(M,J) = YI - 110 CONTINUE -C - DO 120 J = 1, IGH - YR = AR(J,I) - AR(J,I) = AR(J,M) - AR(J,M) = YR - YI = AI(J,I) - AI(J,I) = AI(J,M) - AI(J,M) = YI - 120 CONTINUE -C .......... END INTERCHANGE .......... - 130 IF (XR .EQ. 0.0E0 .AND. XI .EQ. 0.0E0) GO TO 180 - MP1 = M + 1 -C - DO 160 I = MP1, IGH - YR = AR(I,MM1) - YI = AI(I,MM1) - IF (YR .EQ. 0.0E0 .AND. YI .EQ. 0.0E0) GO TO 160 - CALL CDIV(YR,YI,XR,XI,YR,YI) - AR(I,MM1) = YR - AI(I,MM1) = YI -C - DO 140 J = M, N - AR(I,J) = AR(I,J) - YR * AR(M,J) + YI * AI(M,J) - AI(I,J) = AI(I,J) - YR * AI(M,J) - YI * AR(M,J) - 140 CONTINUE -C - DO 150 J = 1, IGH - AR(J,M) = AR(J,M) + YR * AR(J,I) - YI * AI(J,I) - AI(J,M) = AI(J,M) + YR * AI(J,I) + YI * AR(J,I) - 150 CONTINUE -C - 160 CONTINUE -C - 180 CONTINUE -C - 200 RETURN - END diff --git a/slatec/comlr.f b/slatec/comlr.f deleted file mode 100644 index d16d730..0000000 --- a/slatec/comlr.f +++ /dev/null @@ -1,231 +0,0 @@ -*DECK COMLR - SUBROUTINE COMLR (NM, N, LOW, IGH, HR, HI, WR, WI, IERR) -C***BEGIN PROLOGUE COMLR -C***PURPOSE Compute the eigenvalues of a complex upper Hessenberg -C matrix using the modified LR method. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C2B -C***TYPE COMPLEX (COMLR-C) -C***KEYWORDS EIGENVALUES, EISPACK, LR METHOD -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure COMLR, -C NUM. MATH. 12, 369-376(1968) by Martin and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971). -C -C This subroutine finds the eigenvalues of a COMPLEX -C UPPER Hessenberg matrix by the modified LR method. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, HR and HI, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix H=(HR,HI). N is an INTEGER -C variable. N must be less than or equal to NM. -C -C LOW and IGH are two INTEGER variables determined by the -C balancing subroutine CBAL. If CBAL has not been used, -C set LOW=1 and IGH equal to the order of the matrix, N. -C -C HR and HI contain the real and imaginary parts, respectively, -C of the complex upper Hessenberg matrix. Their lower -C triangles below the subdiagonal contain the multipliers -C which were used in the reduction by COMHES, if performed. -C HR and HI are two-dimensional REAL arrays, dimensioned -C HR(NM,N) and HI(NM,N). -C -C On OUTPUT -C -C The upper Hessenberg portions of HR and HI have been -C destroyed. Therefore, they must be saved before calling -C COMLR if subsequent calculation of eigenvectors is to -C be performed. -C -C WR and WI contain the real and imaginary parts, respectively, -C of the eigenvalues of the upper Hessenberg matrix. If an -C error exit is made, the eigenvalues should be correct for -C indices IERR+1, IERR+2, ..., N. WR and WI are one- -C dimensional REAL arrays, dimensioned WR(N) and WI(N). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C J if the J-th eigenvalue has not been -C determined after a total of 30*N iterations. -C The eigenvalues should be correct for indices -C IERR+1, IERR+2, ..., N. -C -C Calls CSROOT for complex square root. -C Calls CDIV for complex division. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED CDIV, CSROOT -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE COMLR -C - INTEGER I,J,L,M,N,EN,LL,MM,NM,IGH,IM1,ITN,ITS,LOW,MP1,ENM1,IERR - REAL HR(NM,*),HI(NM,*),WR(*),WI(*) - REAL SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,S1,S2 -C -C***FIRST EXECUTABLE STATEMENT COMLR - IERR = 0 -C .......... STORE ROOTS ISOLATED BY CBAL .......... - DO 200 I = 1, N - IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200 - WR(I) = HR(I,I) - WI(I) = HI(I,I) - 200 CONTINUE -C - EN = IGH - TR = 0.0E0 - TI = 0.0E0 - ITN = 30*N -C .......... SEARCH FOR NEXT EIGENVALUE .......... - 220 IF (EN .LT. LOW) GO TO 1001 - ITS = 0 - ENM1 = EN - 1 -C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT -C FOR L=EN STEP -1 UNTIL LOW E0 -- .......... - 240 DO 260 LL = LOW, EN - L = EN + LOW - LL - IF (L .EQ. LOW) GO TO 300 - S1 = ABS(HR(L-1,L-1)) + ABS(HI(L-1,L-1)) - 1 + ABS(HR(L,L)) + ABS(HI(L,L)) - S2 = S1 + ABS(HR(L,L-1)) + ABS(HI(L,L-1)) - IF (S2 .EQ. S1) GO TO 300 - 260 CONTINUE -C .......... FORM SHIFT .......... - 300 IF (L .EQ. EN) GO TO 660 - IF (ITN .EQ. 0) GO TO 1000 - IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320 - SR = HR(EN,EN) - SI = HI(EN,EN) - XR = HR(ENM1,EN) * HR(EN,ENM1) - HI(ENM1,EN) * HI(EN,ENM1) - XI = HR(ENM1,EN) * HI(EN,ENM1) + HI(ENM1,EN) * HR(EN,ENM1) - IF (XR .EQ. 0.0E0 .AND. XI .EQ. 0.0E0) GO TO 340 - YR = (HR(ENM1,ENM1) - SR) / 2.0E0 - YI = (HI(ENM1,ENM1) - SI) / 2.0E0 - CALL CSROOT(YR**2-YI**2+XR,2.0E0*YR*YI+XI,ZZR,ZZI) - IF (YR * ZZR + YI * ZZI .GE. 0.0E0) GO TO 310 - ZZR = -ZZR - ZZI = -ZZI - 310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI) - SR = SR - XR - SI = SI - XI - GO TO 340 -C .......... FORM EXCEPTIONAL SHIFT .......... - 320 SR = ABS(HR(EN,ENM1)) + ABS(HR(ENM1,EN-2)) - SI = ABS(HI(EN,ENM1)) + ABS(HI(ENM1,EN-2)) -C - 340 DO 360 I = LOW, EN - HR(I,I) = HR(I,I) - SR - HI(I,I) = HI(I,I) - SI - 360 CONTINUE -C - TR = TR + SR - TI = TI + SI - ITS = ITS + 1 - ITN = ITN - 1 -C .......... LOOK FOR TWO CONSECUTIVE SMALL -C SUB-DIAGONAL ELEMENTS .......... - XR = ABS(HR(ENM1,ENM1)) + ABS(HI(ENM1,ENM1)) - YR = ABS(HR(EN,ENM1)) + ABS(HI(EN,ENM1)) - ZZR = ABS(HR(EN,EN)) + ABS(HI(EN,EN)) -C .......... FOR M=EN-1 STEP -1 UNTIL L DO -- .......... - DO 380 MM = L, ENM1 - M = ENM1 + L - MM - IF (M .EQ. L) GO TO 420 - YI = YR - YR = ABS(HR(M,M-1)) + ABS(HI(M,M-1)) - XI = ZZR - ZZR = XR - XR = ABS(HR(M-1,M-1)) + ABS(HI(M-1,M-1)) - S1 = ZZR / YI * (ZZR + XR + XI) - S2 = S1 + YR - IF (S2 .EQ. S1) GO TO 420 - 380 CONTINUE -C .......... TRIANGULAR DECOMPOSITION H=L*R .......... - 420 MP1 = M + 1 -C - DO 520 I = MP1, EN - IM1 = I - 1 - XR = HR(IM1,IM1) - XI = HI(IM1,IM1) - YR = HR(I,IM1) - YI = HI(I,IM1) - IF (ABS(XR) + ABS(XI) .GE. ABS(YR) + ABS(YI)) GO TO 460 -C .......... INTERCHANGE ROWS OF HR AND HI .......... - DO 440 J = IM1, EN - ZZR = HR(IM1,J) - HR(IM1,J) = HR(I,J) - HR(I,J) = ZZR - ZZI = HI(IM1,J) - HI(IM1,J) = HI(I,J) - HI(I,J) = ZZI - 440 CONTINUE -C - CALL CDIV(XR,XI,YR,YI,ZZR,ZZI) - WR(I) = 1.0E0 - GO TO 480 - 460 CALL CDIV(YR,YI,XR,XI,ZZR,ZZI) - WR(I) = -1.0E0 - 480 HR(I,IM1) = ZZR - HI(I,IM1) = ZZI -C - DO 500 J = I, EN - HR(I,J) = HR(I,J) - ZZR * HR(IM1,J) + ZZI * HI(IM1,J) - HI(I,J) = HI(I,J) - ZZR * HI(IM1,J) - ZZI * HR(IM1,J) - 500 CONTINUE -C - 520 CONTINUE -C .......... COMPOSITION R*L=H .......... - DO 640 J = MP1, EN - XR = HR(J,J-1) - XI = HI(J,J-1) - HR(J,J-1) = 0.0E0 - HI(J,J-1) = 0.0E0 -C .......... INTERCHANGE COLUMNS OF HR AND HI, -C IF NECESSARY .......... - IF (WR(J) .LE. 0.0E0) GO TO 580 -C - DO 540 I = L, J - ZZR = HR(I,J-1) - HR(I,J-1) = HR(I,J) - HR(I,J) = ZZR - ZZI = HI(I,J-1) - HI(I,J-1) = HI(I,J) - HI(I,J) = ZZI - 540 CONTINUE -C - 580 DO 600 I = L, J - HR(I,J-1) = HR(I,J-1) + XR * HR(I,J) - XI * HI(I,J) - HI(I,J-1) = HI(I,J-1) + XR * HI(I,J) + XI * HR(I,J) - 600 CONTINUE -C - 640 CONTINUE -C - GO TO 240 -C .......... A ROOT FOUND .......... - 660 WR(EN) = HR(EN,EN) + TR - WI(EN) = HI(EN,EN) + TI - EN = ENM1 - GO TO 220 -C .......... SET ERROR -- NO CONVERGENCE TO AN -C EIGENVALUE AFTER 30*N ITERATIONS .......... - 1000 IERR = EN - 1001 RETURN - END diff --git a/slatec/comlr2.f b/slatec/comlr2.f deleted file mode 100644 index d775358..0000000 --- a/slatec/comlr2.f +++ /dev/null @@ -1,383 +0,0 @@ -*DECK COMLR2 - SUBROUTINE COMLR2 (NM, N, LOW, IGH, INT, HR, HI, WR, WI, ZR, ZI, - + IERR) -C***BEGIN PROLOGUE COMLR2 -C***PURPOSE Compute the eigenvalues and eigenvectors of a complex upper -C Hessenberg matrix using the modified LR method. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C2B -C***TYPE COMPLEX (COMLR2-C) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK, LR METHOD -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure COMLR2, -C NUM. MATH. 16, 181-204(1970) by Peters and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). -C -C This subroutine finds the eigenvalues and eigenvectors -C of a COMPLEX UPPER Hessenberg matrix by the modified LR -C method. The eigenvectors of a COMPLEX GENERAL matrix -C can also be found if COMHES has been used to reduce -C this general matrix to Hessenberg form. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, HR, HI, ZR and ZI, as declared in the -C calling program dimension statement. NM is an INTEGER -C variable. -C -C N is the order of the matrix H=(HR,HI). N is an INTEGER -C variable. N must be less than or equal to NM. -C -C LOW and IGH are two INTEGER variables determined by the -C balancing subroutine CBAL. If CBAL has not been used, -C set LOW=1 and IGH equal to the order of the matrix, N. -C -C INT contains information on the rows and columns -C interchanged in the reduction by COMHES, if performed. -C Only elements LOW through IGH are used. If you want the -C eigenvectors of a complex general matrix, leave INT as it -C came from COMHES. If the eigenvectors of the Hessenberg -C matrix are desired, set INT(J)=J for these elements. INT -C is a one-dimensional INTEGER array, dimensioned INT(IGH). -C -C HR and HI contain the real and imaginary parts, respectively, -C of the complex upper Hessenberg matrix. Their lower -C triangles below the subdiagonal contain the multipliers -C which were used in the reduction by COMHES, if performed. -C If the eigenvectors of a complex general matrix are -C desired, leave these multipliers in the lower triangles. -C If the eigenvectors of the Hessenberg matrix are desired, -C these elements must be set to zero. HR and HI are -C two-dimensional REAL arrays, dimensioned HR(NM,N) and -C HI(NM,N). -C -C On OUTPUT -C -C The upper Hessenberg portions of HR and HI have been -C destroyed, but the location HR(1,1) contains the norm -C of the triangularized matrix. -C -C WR and WI contain the real and imaginary parts, respectively, -C of the eigenvalues of the upper Hessenberg matrix. If an -C error exit is made, the eigenvalues should be correct for -C indices IERR+1, IERR+2, ..., N. WR and WI are one- -C dimensional REAL arrays, dimensioned WR(N) and WI(N). -C -C ZR and ZI contain the real and imaginary parts, respectively, -C of the eigenvectors. The eigenvectors are unnormalized. -C If an error exit is made, none of the eigenvectors has been -C found. ZR and ZI are two-dimensional REAL arrays, -C dimensioned ZR(NM,N) and ZI(NM,N). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C J if the J-th eigenvalue has not been -C determined after a total of 30*N iterations. -C The eigenvalues should be correct for indices -C IERR+1, IERR+2, ..., N, but no eigenvectors are -C computed. -C -C Calls CSROOT for complex square root. -C Calls CDIV for complex division. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED CDIV, CSROOT -C***REVISION HISTORY (YYMMDD) -C 760101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE COMLR2 -C - INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NM,NN,IGH,IM1,IP1 - INTEGER ITN,ITS,LOW,MP1,ENM1,IEND,IERR - REAL HR(NM,*),HI(NM,*),WR(*),WI(*),ZR(NM,*),ZI(NM,*) - REAL SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,S1,S2 - INTEGER INT(*) -C -C***FIRST EXECUTABLE STATEMENT COMLR2 - IERR = 0 -C .......... INITIALIZE EIGENVECTOR MATRIX .......... - DO 100 I = 1, N -C - DO 100 J = 1, N - ZR(I,J) = 0.0E0 - ZI(I,J) = 0.0E0 - IF (I .EQ. J) ZR(I,J) = 1.0E0 - 100 CONTINUE -C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS -C FROM THE INFORMATION LEFT BY COMHES .......... - IEND = IGH - LOW - 1 - IF (IEND .LE. 0) GO TO 180 -C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... - DO 160 II = 1, IEND - I = IGH - II - IP1 = I + 1 -C - DO 120 K = IP1, IGH - ZR(K,I) = HR(K,I-1) - ZI(K,I) = HI(K,I-1) - 120 CONTINUE -C - J = INT(I) - IF (I .EQ. J) GO TO 160 -C - DO 140 K = I, IGH - ZR(I,K) = ZR(J,K) - ZI(I,K) = ZI(J,K) - ZR(J,K) = 0.0E0 - ZI(J,K) = 0.0E0 - 140 CONTINUE -C - ZR(J,I) = 1.0E0 - 160 CONTINUE -C .......... STORE ROOTS ISOLATED BY CBAL .......... - 180 DO 200 I = 1, N - IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200 - WR(I) = HR(I,I) - WI(I) = HI(I,I) - 200 CONTINUE -C - EN = IGH - TR = 0.0E0 - TI = 0.0E0 - ITN = 30*N -C .......... SEARCH FOR NEXT EIGENVALUE .......... - 220 IF (EN .LT. LOW) GO TO 680 - ITS = 0 - ENM1 = EN - 1 -C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT -C FOR L=EN STEP -1 UNTIL LOW DO -- .......... - 240 DO 260 LL = LOW, EN - L = EN + LOW - LL - IF (L .EQ. LOW) GO TO 300 - S1 = ABS(HR(L-1,L-1)) + ABS(HI(L-1,L-1)) - 1 + ABS(HR(L,L)) + ABS(HI(L,L)) - S2 = S1 + ABS(HR(L,L-1)) + ABS(HI(L,L-1)) - IF (S2 .EQ. S1) GO TO 300 - 260 CONTINUE -C .......... FORM SHIFT .......... - 300 IF (L .EQ. EN) GO TO 660 - IF (ITN .EQ. 0) GO TO 1000 - IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320 - SR = HR(EN,EN) - SI = HI(EN,EN) - XR = HR(ENM1,EN) * HR(EN,ENM1) - HI(ENM1,EN) * HI(EN,ENM1) - XI = HR(ENM1,EN) * HI(EN,ENM1) + HI(ENM1,EN) * HR(EN,ENM1) - IF (XR .EQ. 0.0E0 .AND. XI .EQ. 0.0E0) GO TO 340 - YR = (HR(ENM1,ENM1) - SR) / 2.0E0 - YI = (HI(ENM1,ENM1) - SI) / 2.0E0 - CALL CSROOT(YR**2-YI**2+XR,2.0E0*YR*YI+XI,ZZR,ZZI) - IF (YR * ZZR + YI * ZZI .GE. 0.0E0) GO TO 310 - ZZR = -ZZR - ZZI = -ZZI - 310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI) - SR = SR - XR - SI = SI - XI - GO TO 340 -C .......... FORM EXCEPTIONAL SHIFT .......... - 320 SR = ABS(HR(EN,ENM1)) + ABS(HR(ENM1,EN-2)) - SI = ABS(HI(EN,ENM1)) + ABS(HI(ENM1,EN-2)) -C - 340 DO 360 I = LOW, EN - HR(I,I) = HR(I,I) - SR - HI(I,I) = HI(I,I) - SI - 360 CONTINUE -C - TR = TR + SR - TI = TI + SI - ITS = ITS + 1 - ITN = ITN - 1 -C .......... LOOK FOR TWO CONSECUTIVE SMALL -C SUB-DIAGONAL ELEMENTS .......... - XR = ABS(HR(ENM1,ENM1)) + ABS(HI(ENM1,ENM1)) - YR = ABS(HR(EN,ENM1)) + ABS(HI(EN,ENM1)) - ZZR = ABS(HR(EN,EN)) + ABS(HI(EN,EN)) -C .......... FOR M=EN-1 STEP -1 UNTIL L DO -- .......... - DO 380 MM = L, ENM1 - M = ENM1 + L - MM - IF (M .EQ. L) GO TO 420 - YI = YR - YR = ABS(HR(M,M-1)) + ABS(HI(M,M-1)) - XI = ZZR - ZZR = XR - XR = ABS(HR(M-1,M-1)) + ABS(HI(M-1,M-1)) - S1 = ZZR / YI * (ZZR + XR + XI) - S2 = S1 + YR - IF (S2 .EQ. S1) GO TO 420 - 380 CONTINUE -C .......... TRIANGULAR DECOMPOSITION H=L*R .......... - 420 MP1 = M + 1 -C - DO 520 I = MP1, EN - IM1 = I - 1 - XR = HR(IM1,IM1) - XI = HI(IM1,IM1) - YR = HR(I,IM1) - YI = HI(I,IM1) - IF (ABS(XR) + ABS(XI) .GE. ABS(YR) + ABS(YI)) GO TO 460 -C .......... INTERCHANGE ROWS OF HR AND HI .......... - DO 440 J = IM1, N - ZZR = HR(IM1,J) - HR(IM1,J) = HR(I,J) - HR(I,J) = ZZR - ZZI = HI(IM1,J) - HI(IM1,J) = HI(I,J) - HI(I,J) = ZZI - 440 CONTINUE -C - CALL CDIV(XR,XI,YR,YI,ZZR,ZZI) - WR(I) = 1.0E0 - GO TO 480 - 460 CALL CDIV(YR,YI,XR,XI,ZZR,ZZI) - WR(I) = -1.0E0 - 480 HR(I,IM1) = ZZR - HI(I,IM1) = ZZI -C - DO 500 J = I, N - HR(I,J) = HR(I,J) - ZZR * HR(IM1,J) + ZZI * HI(IM1,J) - HI(I,J) = HI(I,J) - ZZR * HI(IM1,J) - ZZI * HR(IM1,J) - 500 CONTINUE -C - 520 CONTINUE -C .......... COMPOSITION R*L=H .......... - DO 640 J = MP1, EN - XR = HR(J,J-1) - XI = HI(J,J-1) - HR(J,J-1) = 0.0E0 - HI(J,J-1) = 0.0E0 -C .......... INTERCHANGE COLUMNS OF HR, HI, ZR, AND ZI, -C IF NECESSARY .......... - IF (WR(J) .LE. 0.0E0) GO TO 580 -C - DO 540 I = 1, J - ZZR = HR(I,J-1) - HR(I,J-1) = HR(I,J) - HR(I,J) = ZZR - ZZI = HI(I,J-1) - HI(I,J-1) = HI(I,J) - HI(I,J) = ZZI - 540 CONTINUE -C - DO 560 I = LOW, IGH - ZZR = ZR(I,J-1) - ZR(I,J-1) = ZR(I,J) - ZR(I,J) = ZZR - ZZI = ZI(I,J-1) - ZI(I,J-1) = ZI(I,J) - ZI(I,J) = ZZI - 560 CONTINUE -C - 580 DO 600 I = 1, J - HR(I,J-1) = HR(I,J-1) + XR * HR(I,J) - XI * HI(I,J) - HI(I,J-1) = HI(I,J-1) + XR * HI(I,J) + XI * HR(I,J) - 600 CONTINUE -C .......... ACCUMULATE TRANSFORMATIONS .......... - DO 620 I = LOW, IGH - ZR(I,J-1) = ZR(I,J-1) + XR * ZR(I,J) - XI * ZI(I,J) - ZI(I,J-1) = ZI(I,J-1) + XR * ZI(I,J) + XI * ZR(I,J) - 620 CONTINUE -C - 640 CONTINUE -C - GO TO 240 -C .......... A ROOT FOUND .......... - 660 HR(EN,EN) = HR(EN,EN) + TR - WR(EN) = HR(EN,EN) - HI(EN,EN) = HI(EN,EN) + TI - WI(EN) = HI(EN,EN) - EN = ENM1 - GO TO 220 -C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND -C VECTORS OF UPPER TRIANGULAR FORM .......... - 680 NORM = 0.0E0 -C - DO 720 I = 1, N -C - DO 720 J = I, N - NORM = NORM + ABS(HR(I,J)) + ABS(HI(I,J)) - 720 CONTINUE -C - HR(1,1) = NORM - IF (N .EQ. 1 .OR. NORM .EQ. 0.0E0) GO TO 1001 -C .......... FOR EN=N STEP -1 UNTIL 2 DO -- .......... - DO 800 NN = 2, N - EN = N + 2 - NN - XR = WR(EN) - XI = WI(EN) - ENM1 = EN - 1 -C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... - DO 780 II = 1, ENM1 - I = EN - II - ZZR = HR(I,EN) - ZZI = HI(I,EN) - IF (I .EQ. ENM1) GO TO 760 - IP1 = I + 1 -C - DO 740 J = IP1, ENM1 - ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN) - ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN) - 740 CONTINUE -C - 760 YR = XR - WR(I) - YI = XI - WI(I) - IF (YR .NE. 0.0E0 .OR. YI .NE. 0.0E0) GO TO 775 - YR = NORM - 770 YR = 0.5E0*YR - IF (NORM + YR .GT. NORM) GO TO 770 - YR = 2.0E0*YR - 775 CALL CDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN)) - 780 CONTINUE -C - 800 CONTINUE -C .......... END BACKSUBSTITUTION .......... - ENM1 = N - 1 -C .......... VECTORS OF ISOLATED ROOTS .......... - DO 840 I = 1, ENM1 - IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840 - IP1 = I + 1 -C - DO 820 J = IP1, N - ZR(I,J) = HR(I,J) - ZI(I,J) = HI(I,J) - 820 CONTINUE -C - 840 CONTINUE -C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE -C VECTORS OF ORIGINAL FULL MATRIX. -C FOR J=N STEP -1 UNTIL LOW+1 DO -- .......... - DO 880 JJ = LOW, ENM1 - J = N + LOW - JJ - M = MIN(J-1,IGH) -C - DO 880 I = LOW, IGH - ZZR = ZR(I,J) - ZZI = ZI(I,J) -C - DO 860 K = LOW, M - ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J) - ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J) - 860 CONTINUE -C - ZR(I,J) = ZZR - ZI(I,J) = ZZI - 880 CONTINUE -C - GO TO 1001 -C .......... SET ERROR -- NO CONVERGENCE TO AN -C EIGENVALUE AFTER 30*N ITERATIONS .......... - 1000 IERR = EN - 1001 RETURN - END diff --git a/slatec/compb.f b/slatec/compb.f deleted file mode 100644 index 9ecc02d..0000000 --- a/slatec/compb.f +++ /dev/null @@ -1,109 +0,0 @@ -*DECK COMPB - SUBROUTINE COMPB (N, IERROR, AN, BN, CN, B, AH, BH) -C***BEGIN PROLOGUE COMPB -C***SUBSIDIARY -C***PURPOSE Subsidiary to BLKTRI -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (COMPB-S, CCMPB-C) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C COMPB computes the roots of the B polynomials using subroutine -C TEVLS which is a modification the EISPACK program TQLRAT. -C IERROR is set to 4 if either TEVLS fails or if A(J+1)*C(J) is -C less than zero for some J. AH,BH are temporary work arrays. -C -C***SEE ALSO BLKTRI -C***ROUTINES CALLED INDXB, PPADD, R1MACH, TEVLS -C***COMMON BLOCKS CBLKT -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE COMPB -C - DIMENSION AN(*) ,BN(*) ,CN(*) ,B(*) , - 1 AH(*) ,BH(*) - COMMON /CBLKT/ NPP ,K ,EPS ,CNV , - 1 NM ,NCMPLX ,IK -C***FIRST EXECUTABLE STATEMENT COMPB - EPS = R1MACH(4) - BNORM = ABS(BN(1)) - DO 102 J=2,NM - BNORM = MAX(BNORM,ABS(BN(J))) - ARG = AN(J)*CN(J-1) - IF (ARG) 119,101,101 - 101 B(J) = SIGN(SQRT(ARG),AN(J)) - 102 CONTINUE - CNV = EPS*BNORM - IF = 2**K - KDO = K-1 - DO 108 L=1,KDO - IR = L-1 - I2 = 2**IR - I4 = I2+I2 - IPL = I4-1 - IFD = IF-I4 - DO 107 I=I4,IFD,I4 - CALL INDXB (I,L,IB,NB) - IF (NB) 108,108,103 - 103 JS = I-IPL - JF = JS+NB-1 - LS = 0 - DO 104 J=JS,JF - LS = LS+1 - BH(LS) = BN(J) - AH(LS) = B(J) - 104 CONTINUE - CALL TEVLS (NB,BH,AH,IERROR) - IF (IERROR) 118,105,118 - 105 LH = IB-1 - DO 106 J=1,NB - LH = LH+1 - B(LH) = -BH(J) - 106 CONTINUE - 107 CONTINUE - 108 CONTINUE - DO 109 J=1,NM - B(J) = -BN(J) - 109 CONTINUE - IF (NPP) 117,110,117 - 110 NMP = NM+1 - NB = NM+NMP - DO 112 J=1,NB - L1 = MOD(J-1,NMP)+1 - L2 = MOD(J+NM-1,NMP)+1 - ARG = AN(L1)*CN(L2) - IF (ARG) 119,111,111 - 111 BH(J) = SIGN(SQRT(ARG),-AN(L1)) - AH(J) = -BN(L1) - 112 CONTINUE - CALL TEVLS (NB,AH,BH,IERROR) - IF (IERROR) 118,113,118 - 113 CALL INDXB (IF,K-1,J2,LH) - CALL INDXB (IF/2,K-1,J1,LH) - J2 = J2+1 - LH = J2 - N2M2 = J2+NM+NM-2 - 114 D1 = ABS(B(J1)-B(J2-1)) - D2 = ABS(B(J1)-B(J2)) - D3 = ABS(B(J1)-B(J2+1)) - IF ((D2 .LT. D1) .AND. (D2 .LT. D3)) GO TO 115 - B(LH) = B(J2) - J2 = J2+1 - LH = LH+1 - IF (J2-N2M2) 114,114,116 - 115 J2 = J2+1 - J1 = J1+1 - IF (J2-N2M2) 114,114,116 - 116 B(LH) = B(N2M2+1) - CALL INDXB (IF,K-1,J1,J2) - J2 = J1+NMP+NMP - CALL PPADD (NM+1,IERROR,AN,CN,B(J1),B(J1),B(J2)) - 117 RETURN - 118 IERROR = 4 - RETURN - 119 IERROR = 5 - RETURN - END diff --git a/slatec/comqr.f b/slatec/comqr.f deleted file mode 100644 index 1fc1b88..0000000 --- a/slatec/comqr.f +++ /dev/null @@ -1,249 +0,0 @@ -*DECK COMQR - SUBROUTINE COMQR (NM, N, LOW, IGH, HR, HI, WR, WI, IERR) -C***BEGIN PROLOGUE COMQR -C***PURPOSE Compute the eigenvalues of complex upper Hessenberg matrix -C using the QR method. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C2B -C***TYPE COMPLEX (HQR-S, COMQR-C) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of a unitary analogue of the -C ALGOL procedure COMLR, NUM. MATH. 12, 369-376(1968) by Martin -C and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971). -C The unitary analogue substitutes the QR algorithm of Francis -C (COMP. JOUR. 4, 332-345(1962)) for the LR algorithm. -C -C This subroutine finds the eigenvalues of a COMPLEX -C upper Hessenberg matrix by the QR method. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, HR and HI, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix H=(HR,HI). N is an INTEGER -C variable. N must be less than or equal to NM. -C -C LOW and IGH are two INTEGER variables determined by the -C balancing subroutine CBAL. If CBAL has not been used, -C set LOW=1 and IGH equal to the order of the matrix, N. -C -C HR and HI contain the real and imaginary parts, respectively, -C of the complex upper Hessenberg matrix. Their lower -C triangles below the subdiagonal contain information about -C the unitary transformations used in the reduction by CORTH, -C if performed. HR and HI are two-dimensional REAL arrays, -C dimensioned HR(NM,N) and HI(NM,N). -C -C On OUTPUT -C -C The upper Hessenberg portions of HR and HI have been -C destroyed. Therefore, they must be saved before calling -C COMQR if subsequent calculation of eigenvectors is to -C be performed. -C -C WR and WI contain the real and imaginary parts, respectively, -C of the eigenvalues of the upper Hessenberg matrix. If an -C error exit is made, the eigenvalues should be correct for -C indices IERR+1, IERR+2, ..., N. WR and WI are one- -C dimensional REAL arrays, dimensioned WR(N) and WI(N). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C J if the J-th eigenvalue has not been -C determined after a total of 30*N iterations. -C The eigenvalues should be correct for indices -C IERR+1, IERR+2, ..., N. -C -C Calls CSROOT for complex square root. -C Calls PYTHAG(A,B) for sqrt(A**2 + B**2). -C Calls CDIV for complex division. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED CDIV, CSROOT, PYTHAG -C***REVISION HISTORY (YYMMDD) -C 760101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE COMQR -C - INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR - REAL HR(NM,*),HI(NM,*),WR(*),WI(*) - REAL SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,S1,S2 - REAL PYTHAG -C -C***FIRST EXECUTABLE STATEMENT COMQR - IERR = 0 - IF (LOW .EQ. IGH) GO TO 180 -C .......... CREATE REAL SUBDIAGONAL ELEMENTS .......... - L = LOW + 1 -C - DO 170 I = L, IGH - LL = MIN(I+1,IGH) - IF (HI(I,I-1) .EQ. 0.0E0) GO TO 170 - NORM = PYTHAG(HR(I,I-1),HI(I,I-1)) - YR = HR(I,I-1) / NORM - YI = HI(I,I-1) / NORM - HR(I,I-1) = NORM - HI(I,I-1) = 0.0E0 -C - DO 155 J = I, IGH - SI = YR * HI(I,J) - YI * HR(I,J) - HR(I,J) = YR * HR(I,J) + YI * HI(I,J) - HI(I,J) = SI - 155 CONTINUE -C - DO 160 J = LOW, LL - SI = YR * HI(J,I) + YI * HR(J,I) - HR(J,I) = YR * HR(J,I) - YI * HI(J,I) - HI(J,I) = SI - 160 CONTINUE -C - 170 CONTINUE -C .......... STORE ROOTS ISOLATED BY CBAL .......... - 180 DO 200 I = 1, N - IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200 - WR(I) = HR(I,I) - WI(I) = HI(I,I) - 200 CONTINUE -C - EN = IGH - TR = 0.0E0 - TI = 0.0E0 - ITN = 30*N -C .......... SEARCH FOR NEXT EIGENVALUE .......... - 220 IF (EN .LT. LOW) GO TO 1001 - ITS = 0 - ENM1 = EN - 1 -C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT -C FOR L=EN STEP -1 UNTIL LOW E0 -- .......... - 240 DO 260 LL = LOW, EN - L = EN + LOW - LL - IF (L .EQ. LOW) GO TO 300 - S1 = ABS(HR(L-1,L-1)) + ABS(HI(L-1,L-1)) - 1 + ABS(HR(L,L)) +ABS(HI(L,L)) - S2 = S1 + ABS(HR(L,L-1)) - IF (S2 .EQ. S1) GO TO 300 - 260 CONTINUE -C .......... FORM SHIFT .......... - 300 IF (L .EQ. EN) GO TO 660 - IF (ITN .EQ. 0) GO TO 1000 - IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320 - SR = HR(EN,EN) - SI = HI(EN,EN) - XR = HR(ENM1,EN) * HR(EN,ENM1) - XI = HI(ENM1,EN) * HR(EN,ENM1) - IF (XR .EQ. 0.0E0 .AND. XI .EQ. 0.0E0) GO TO 340 - YR = (HR(ENM1,ENM1) - SR) / 2.0E0 - YI = (HI(ENM1,ENM1) - SI) / 2.0E0 - CALL CSROOT(YR**2-YI**2+XR,2.0E0*YR*YI+XI,ZZR,ZZI) - IF (YR * ZZR + YI * ZZI .GE. 0.0E0) GO TO 310 - ZZR = -ZZR - ZZI = -ZZI - 310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI) - SR = SR - XR - SI = SI - XI - GO TO 340 -C .......... FORM EXCEPTIONAL SHIFT .......... - 320 SR = ABS(HR(EN,ENM1)) + ABS(HR(ENM1,EN-2)) - SI = 0.0E0 -C - 340 DO 360 I = LOW, EN - HR(I,I) = HR(I,I) - SR - HI(I,I) = HI(I,I) - SI - 360 CONTINUE -C - TR = TR + SR - TI = TI + SI - ITS = ITS + 1 - ITN = ITN - 1 -C .......... REDUCE TO TRIANGLE (ROWS) .......... - LP1 = L + 1 -C - DO 500 I = LP1, EN - SR = HR(I,I-1) - HR(I,I-1) = 0.0E0 - NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR) - XR = HR(I-1,I-1) / NORM - WR(I-1) = XR - XI = HI(I-1,I-1) / NORM - WI(I-1) = XI - HR(I-1,I-1) = NORM - HI(I-1,I-1) = 0.0E0 - HI(I,I-1) = SR / NORM -C - DO 490 J = I, EN - YR = HR(I-1,J) - YI = HI(I-1,J) - ZZR = HR(I,J) - ZZI = HI(I,J) - HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR - HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI - HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR - HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI - 490 CONTINUE -C - 500 CONTINUE -C - SI = HI(EN,EN) - IF (SI .EQ. 0.0E0) GO TO 540 - NORM = PYTHAG(HR(EN,EN),SI) - SR = HR(EN,EN) / NORM - SI = SI / NORM - HR(EN,EN) = NORM - HI(EN,EN) = 0.0E0 -C .......... INVERSE OPERATION (COLUMNS) .......... - 540 DO 600 J = LP1, EN - XR = WR(J-1) - XI = WI(J-1) -C - DO 580 I = L, J - YR = HR(I,J-1) - YI = 0.0E0 - ZZR = HR(I,J) - ZZI = HI(I,J) - IF (I .EQ. J) GO TO 560 - YI = HI(I,J-1) - HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI - 560 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR - HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR - HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI - 580 CONTINUE -C - 600 CONTINUE -C - IF (SI .EQ. 0.0E0) GO TO 240 -C - DO 630 I = L, EN - YR = HR(I,EN) - YI = HI(I,EN) - HR(I,EN) = SR * YR - SI * YI - HI(I,EN) = SR * YI + SI * YR - 630 CONTINUE -C - GO TO 240 -C .......... A ROOT FOUND .......... - 660 WR(EN) = HR(EN,EN) + TR - WI(EN) = HI(EN,EN) + TI - EN = ENM1 - GO TO 220 -C .......... SET ERROR -- NO CONVERGENCE TO AN -C EIGENVALUE AFTER 30*N ITERATIONS .......... - 1000 IERR = EN - 1001 RETURN - END diff --git a/slatec/comqr2.f b/slatec/comqr2.f deleted file mode 100644 index 273e8c0..0000000 --- a/slatec/comqr2.f +++ /dev/null @@ -1,426 +0,0 @@ -*DECK COMQR2 - SUBROUTINE COMQR2 (NM, N, LOW, IGH, ORTR, ORTI, HR, HI, WR, WI, - + ZR, ZI, IERR) -C***BEGIN PROLOGUE COMQR2 -C***PURPOSE Compute the eigenvalues and eigenvectors of a complex upper -C Hessenberg matrix. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C2B -C***TYPE COMPLEX (HQR2-S, COMQR2-C) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of a unitary analogue of the -C ALGOL procedure COMLR2, NUM. MATH. 16, 181-204(1970) by Peters -C and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). -C The unitary analogue substitutes the QR algorithm of Francis -C (COMP. JOUR. 4, 332-345(1962)) for the LR algorithm. -C -C This subroutine finds the eigenvalues and eigenvectors -C of a COMPLEX UPPER Hessenberg matrix by the QR -C method. The eigenvectors of a COMPLEX GENERAL matrix -C can also be found if CORTH has been used to reduce -C this general matrix to Hessenberg form. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, HR, HI, ZR, and ZI, as declared in the -C calling program dimension statement. NM is an INTEGER -C variable. -C -C N is the order of the matrix H=(HR,HI). N is an INTEGER -C variable. N must be less than or equal to NM. -C -C LOW and IGH are two INTEGER variables determined by the -C balancing subroutine CBAL. If CBAL has not been used, -C set LOW=1 and IGH equal to the order of the matrix, N. -C -C ORTR and ORTI contain information about the unitary trans- -C formations used in the reduction by CORTH, if performed. -C Only elements LOW through IGH are used. If the eigenvectors -C of the Hessenberg matrix are desired, set ORTR(J) and -C ORTI(J) to 0.0E0 for these elements. ORTR and ORTI are -C one-dimensional REAL arrays, dimensioned ORTR(IGH) and -C ORTI(IGH). -C -C HR and HI contain the real and imaginary parts, respectively, -C of the complex upper Hessenberg matrix. Their lower -C triangles below the subdiagonal contain information about -C the unitary transformations used in the reduction by CORTH, -C if performed. If the eigenvectors of the Hessenberg matrix -C are desired, these elements may be arbitrary. HR and HI -C are two-dimensional REAL arrays, dimensioned HR(NM,N) and -C HI(NM,N). -C -C On OUTPUT -C -C ORTR, ORTI, and the upper Hessenberg portions of HR and HI -C have been destroyed. -C -C WR and WI contain the real and imaginary parts, respectively, -C of the eigenvalues of the upper Hessenberg matrix. If an -C error exit is made, the eigenvalues should be correct for -C indices IERR+1, IERR+2, ..., N. WR and WI are one- -C dimensional REAL arrays, dimensioned WR(N) and WI(N). -C -C ZR and ZI contain the real and imaginary parts, respectively, -C of the eigenvectors. The eigenvectors are unnormalized. -C If an error exit is made, none of the eigenvectors has been -C found. ZR and ZI are two-dimensional REAL arrays, -C dimensioned ZR(NM,N) and ZI(NM,N). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C J if the J-th eigenvalue has not been -C determined after a total of 30*N iterations. -C The eigenvalues should be correct for indices -C IERR+1, IERR+2, ..., N, but no eigenvectors are -C computed. -C -C Calls CSROOT for complex square root. -C Calls PYTHAG(A,B) for sqrt(A**2 + B**2). -C Calls CDIV for complex division. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED CDIV, CSROOT, PYTHAG -C***REVISION HISTORY (YYMMDD) -C 760101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE COMQR2 -C - INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1 - INTEGER ITN,ITS,LOW,LP1,ENM1,IEND,IERR - REAL HR(NM,*),HI(NM,*),WR(*),WI(*),ZR(NM,*),ZI(NM,*) - REAL ORTR(*),ORTI(*) - REAL SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,S1,S2 - REAL PYTHAG -C -C***FIRST EXECUTABLE STATEMENT COMQR2 - IERR = 0 -C .......... INITIALIZE EIGENVECTOR MATRIX .......... - DO 100 I = 1, N -C - DO 100 J = 1, N - ZR(I,J) = 0.0E0 - ZI(I,J) = 0.0E0 - IF (I .EQ. J) ZR(I,J) = 1.0E0 - 100 CONTINUE -C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS -C FROM THE INFORMATION LEFT BY CORTH .......... - IEND = IGH - LOW - 1 - IF (IEND) 180, 150, 105 -C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... - 105 DO 140 II = 1, IEND - I = IGH - II - IF (ORTR(I) .EQ. 0.0E0 .AND. ORTI(I) .EQ. 0.0E0) GO TO 140 - IF (HR(I,I-1) .EQ. 0.0E0 .AND. HI(I,I-1) .EQ. 0.0E0) GO TO 140 -C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH .......... - NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I) - IP1 = I + 1 -C - DO 110 K = IP1, IGH - ORTR(K) = HR(K,I-1) - ORTI(K) = HI(K,I-1) - 110 CONTINUE -C - DO 130 J = I, IGH - SR = 0.0E0 - SI = 0.0E0 -C - DO 115 K = I, IGH - SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J) - SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J) - 115 CONTINUE -C - SR = SR / NORM - SI = SI / NORM -C - DO 120 K = I, IGH - ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K) - ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K) - 120 CONTINUE -C - 130 CONTINUE -C - 140 CONTINUE -C .......... CREATE REAL SUBDIAGONAL ELEMENTS .......... - 150 L = LOW + 1 -C - DO 170 I = L, IGH - LL = MIN(I+1,IGH) - IF (HI(I,I-1) .EQ. 0.0E0) GO TO 170 - NORM = PYTHAG(HR(I,I-1),HI(I,I-1)) - YR = HR(I,I-1) / NORM - YI = HI(I,I-1) / NORM - HR(I,I-1) = NORM - HI(I,I-1) = 0.0E0 -C - DO 155 J = I, N - SI = YR * HI(I,J) - YI * HR(I,J) - HR(I,J) = YR * HR(I,J) + YI * HI(I,J) - HI(I,J) = SI - 155 CONTINUE -C - DO 160 J = 1, LL - SI = YR * HI(J,I) + YI * HR(J,I) - HR(J,I) = YR * HR(J,I) - YI * HI(J,I) - HI(J,I) = SI - 160 CONTINUE -C - DO 165 J = LOW, IGH - SI = YR * ZI(J,I) + YI * ZR(J,I) - ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I) - ZI(J,I) = SI - 165 CONTINUE -C - 170 CONTINUE -C .......... STORE ROOTS ISOLATED BY CBAL .......... - 180 DO 200 I = 1, N - IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200 - WR(I) = HR(I,I) - WI(I) = HI(I,I) - 200 CONTINUE -C - EN = IGH - TR = 0.0E0 - TI = 0.0E0 - ITN = 30*N -C .......... SEARCH FOR NEXT EIGENVALUE .......... - 220 IF (EN .LT. LOW) GO TO 680 - ITS = 0 - ENM1 = EN - 1 -C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT -C FOR L=EN STEP -1 UNTIL LOW DO -- .......... - 240 DO 260 LL = LOW, EN - L = EN + LOW - LL - IF (L .EQ. LOW) GO TO 300 - S1 = ABS(HR(L-1,L-1)) + ABS(HI(L-1,L-1)) - 1 + ABS(HR(L,L)) +ABS(HI(L,L)) - S2 = S1 + ABS(HR(L,L-1)) - IF (S2 .EQ. S1) GO TO 300 - 260 CONTINUE -C .......... FORM SHIFT .......... - 300 IF (L .EQ. EN) GO TO 660 - IF (ITN .EQ. 0) GO TO 1000 - IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320 - SR = HR(EN,EN) - SI = HI(EN,EN) - XR = HR(ENM1,EN) * HR(EN,ENM1) - XI = HI(ENM1,EN) * HR(EN,ENM1) - IF (XR .EQ. 0.0E0 .AND. XI .EQ. 0.0E0) GO TO 340 - YR = (HR(ENM1,ENM1) - SR) / 2.0E0 - YI = (HI(ENM1,ENM1) - SI) / 2.0E0 - CALL CSROOT(YR**2-YI**2+XR,2.0E0*YR*YI+XI,ZZR,ZZI) - IF (YR * ZZR + YI * ZZI .GE. 0.0E0) GO TO 310 - ZZR = -ZZR - ZZI = -ZZI - 310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI) - SR = SR - XR - SI = SI - XI - GO TO 340 -C .......... FORM EXCEPTIONAL SHIFT .......... - 320 SR = ABS(HR(EN,ENM1)) + ABS(HR(ENM1,EN-2)) - SI = 0.0E0 -C - 340 DO 360 I = LOW, EN - HR(I,I) = HR(I,I) - SR - HI(I,I) = HI(I,I) - SI - 360 CONTINUE -C - TR = TR + SR - TI = TI + SI - ITS = ITS + 1 - ITN = ITN - 1 -C .......... REDUCE TO TRIANGLE (ROWS) .......... - LP1 = L + 1 -C - DO 500 I = LP1, EN - SR = HR(I,I-1) - HR(I,I-1) = 0.0E0 - NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR) - XR = HR(I-1,I-1) / NORM - WR(I-1) = XR - XI = HI(I-1,I-1) / NORM - WI(I-1) = XI - HR(I-1,I-1) = NORM - HI(I-1,I-1) = 0.0E0 - HI(I,I-1) = SR / NORM -C - DO 490 J = I, N - YR = HR(I-1,J) - YI = HI(I-1,J) - ZZR = HR(I,J) - ZZI = HI(I,J) - HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR - HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI - HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR - HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI - 490 CONTINUE -C - 500 CONTINUE -C - SI = HI(EN,EN) - IF (SI .EQ. 0.0E0) GO TO 540 - NORM = PYTHAG(HR(EN,EN),SI) - SR = HR(EN,EN) / NORM - SI = SI / NORM - HR(EN,EN) = NORM - HI(EN,EN) = 0.0E0 - IF (EN .EQ. N) GO TO 540 - IP1 = EN + 1 -C - DO 520 J = IP1, N - YR = HR(EN,J) - YI = HI(EN,J) - HR(EN,J) = SR * YR + SI * YI - HI(EN,J) = SR * YI - SI * YR - 520 CONTINUE -C .......... INVERSE OPERATION (COLUMNS) .......... - 540 DO 600 J = LP1, EN - XR = WR(J-1) - XI = WI(J-1) -C - DO 580 I = 1, J - YR = HR(I,J-1) - YI = 0.0E0 - ZZR = HR(I,J) - ZZI = HI(I,J) - IF (I .EQ. J) GO TO 560 - YI = HI(I,J-1) - HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI - 560 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR - HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR - HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI - 580 CONTINUE -C - DO 590 I = LOW, IGH - YR = ZR(I,J-1) - YI = ZI(I,J-1) - ZZR = ZR(I,J) - ZZI = ZI(I,J) - ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR - ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI - ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR - ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI - 590 CONTINUE -C - 600 CONTINUE -C - IF (SI .EQ. 0.0E0) GO TO 240 -C - DO 630 I = 1, EN - YR = HR(I,EN) - YI = HI(I,EN) - HR(I,EN) = SR * YR - SI * YI - HI(I,EN) = SR * YI + SI * YR - 630 CONTINUE -C - DO 640 I = LOW, IGH - YR = ZR(I,EN) - YI = ZI(I,EN) - ZR(I,EN) = SR * YR - SI * YI - ZI(I,EN) = SR * YI + SI * YR - 640 CONTINUE -C - GO TO 240 -C .......... A ROOT FOUND .......... - 660 HR(EN,EN) = HR(EN,EN) + TR - WR(EN) = HR(EN,EN) - HI(EN,EN) = HI(EN,EN) + TI - WI(EN) = HI(EN,EN) - EN = ENM1 - GO TO 220 -C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND -C VECTORS OF UPPER TRIANGULAR FORM .......... - 680 NORM = 0.0E0 -C - DO 720 I = 1, N -C - DO 720 J = I, N - NORM = NORM + ABS(HR(I,J)) + ABS(HI(I,J)) - 720 CONTINUE -C - IF (N .EQ. 1 .OR. NORM .EQ. 0.0E0) GO TO 1001 -C .......... FOR EN=N STEP -1 UNTIL 2 DO -- .......... - DO 800 NN = 2, N - EN = N + 2 - NN - XR = WR(EN) - XI = WI(EN) - ENM1 = EN - 1 -C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... - DO 780 II = 1, ENM1 - I = EN - II - ZZR = HR(I,EN) - ZZI = HI(I,EN) - IF (I .EQ. ENM1) GO TO 760 - IP1 = I + 1 -C - DO 740 J = IP1, ENM1 - ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN) - ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN) - 740 CONTINUE -C - 760 YR = XR - WR(I) - YI = XI - WI(I) - IF (YR .NE. 0.0E0 .OR. YI .NE. 0.0E0) GO TO 775 - YR = NORM - 770 YR = 0.5E0*YR - IF (NORM + YR .GT. NORM) GO TO 770 - YR = 2.0E0*YR - 775 CALL CDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN)) - 780 CONTINUE -C - 800 CONTINUE -C .......... END BACKSUBSTITUTION .......... - ENM1 = N - 1 -C .......... VECTORS OF ISOLATED ROOTS .......... - DO 840 I = 1, ENM1 - IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840 - IP1 = I + 1 -C - DO 820 J = IP1, N - ZR(I,J) = HR(I,J) - ZI(I,J) = HI(I,J) - 820 CONTINUE -C - 840 CONTINUE -C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE -C VECTORS OF ORIGINAL FULL MATRIX. -C FOR J=N STEP -1 UNTIL LOW+1 DO -- .......... - DO 880 JJ = LOW, ENM1 - J = N + LOW - JJ - M = MIN(J-1,IGH) -C - DO 880 I = LOW, IGH - ZZR = ZR(I,J) - ZZI = ZI(I,J) -C - DO 860 K = LOW, M - ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J) - ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J) - 860 CONTINUE -C - ZR(I,J) = ZZR - ZI(I,J) = ZZI - 880 CONTINUE -C - GO TO 1001 -C .......... SET ERROR -- NO CONVERGENCE TO AN -C EIGENVALUE AFTER 30*N ITERATIONS .......... - 1000 IERR = EN - 1001 RETURN - END diff --git a/slatec/cortb.f b/slatec/cortb.f deleted file mode 100644 index b810ce3..0000000 --- a/slatec/cortb.f +++ /dev/null @@ -1,125 +0,0 @@ -*DECK CORTB - SUBROUTINE CORTB (NM, LOW, IGH, AR, AI, ORTR, ORTI, M, ZR, ZI) -C***BEGIN PROLOGUE CORTB -C***PURPOSE Form the eigenvectors of a complex general matrix from -C eigenvectors of upper Hessenberg matrix output from -C CORTH. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C4 -C***TYPE COMPLEX (ORTBAK-S, CORTB-C) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of a complex analogue of -C the ALGOL procedure ORTBAK, NUM. MATH. 12, 349-368(1968) -C by Martin and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). -C -C This subroutine forms the eigenvectors of a COMPLEX GENERAL -C matrix by back transforming those of the corresponding -C upper Hessenberg matrix determined by CORTH. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, AR, AI, ZR, and ZI, as declared in the -C calling program dimension statement. NM is an INTEGER -C variable. -C -C LOW and IGH are two INTEGER variables determined by the -C balancing subroutine CBAL. If CBAL has not been used, -C set LOW=1 and IGH equal to the order of the matrix. -C -C AR and AI contain information about the unitary trans- -C formations used in the reduction by CORTH in their -C strict lower triangles. AR and AI are two-dimensional -C REAL arrays, dimensioned AR(NM,IGH) and AI(NM,IGH). -C -C ORTR and ORTI contain further information about the unitary -C transformations used in the reduction by CORTH. Only -C elements LOW through IGH are used. ORTR and ORTI are -C one-dimensional REAL arrays, dimensioned ORTR(IGH) and -C ORTI(IGH). -C -C M is the number of columns of Z=(ZR,ZI) to be back transformed. -C M is an INTEGER variable. -C -C ZR and ZI contain the real and imaginary parts, respectively, -C of the eigenvectors to be back transformed in their first -C M columns. ZR and ZI are two-dimensional REAL arrays, -C dimensioned ZR(NM,M) and ZI(NM,M). -C -C On OUTPUT -C -C ZR and ZI contain the real and imaginary parts, respectively, -C of the transformed eigenvectors in their first M columns. -C -C ORTR and ORTI have been altered. -C -C Note that CORTB preserves vector Euclidean norms. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CORTB -C - INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1 - REAL AR(NM,*),AI(NM,*),ORTR(*),ORTI(*) - REAL ZR(NM,*),ZI(NM,*) - REAL H,GI,GR -C -C***FIRST EXECUTABLE STATEMENT CORTB - IF (M .EQ. 0) GO TO 200 - LA = IGH - 1 - KP1 = LOW + 1 - IF (LA .LT. KP1) GO TO 200 -C .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... - DO 140 MM = KP1, LA - MP = LOW + IGH - MM - IF (AR(MP,MP-1) .EQ. 0.0E0 .AND. AI(MP,MP-1) .EQ. 0.0E0) - 1 GO TO 140 -C .......... H BELOW IS NEGATIVE OF H FORMED IN CORTH .......... - H = AR(MP,MP-1) * ORTR(MP) + AI(MP,MP-1) * ORTI(MP) - MP1 = MP + 1 -C - DO 100 I = MP1, IGH - ORTR(I) = AR(I,MP-1) - ORTI(I) = AI(I,MP-1) - 100 CONTINUE -C - DO 130 J = 1, M - GR = 0.0E0 - GI = 0.0E0 -C - DO 110 I = MP, IGH - GR = GR + ORTR(I) * ZR(I,J) + ORTI(I) * ZI(I,J) - GI = GI + ORTR(I) * ZI(I,J) - ORTI(I) * ZR(I,J) - 110 CONTINUE -C - GR = GR / H - GI = GI / H -C - DO 120 I = MP, IGH - ZR(I,J) = ZR(I,J) + GR * ORTR(I) - GI * ORTI(I) - ZI(I,J) = ZI(I,J) + GR * ORTI(I) + GI * ORTR(I) - 120 CONTINUE -C - 130 CONTINUE -C - 140 CONTINUE -C - 200 RETURN - END diff --git a/slatec/corth.f b/slatec/corth.f deleted file mode 100644 index d4e82c6..0000000 --- a/slatec/corth.f +++ /dev/null @@ -1,159 +0,0 @@ -*DECK CORTH - SUBROUTINE CORTH (NM, N, LOW, IGH, AR, AI, ORTR, ORTI) -C***BEGIN PROLOGUE CORTH -C***PURPOSE Reduce a complex general matrix to complex upper Hessenberg -C form using unitary similarity transformations. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C1B2 -C***TYPE COMPLEX (ORTHES-S, CORTH-C) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of a complex analogue of -C the ALGOL procedure ORTHES, NUM. MATH. 12, 349-368(1968) -C by Martin and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). -C -C Given a COMPLEX GENERAL matrix, this subroutine -C reduces a submatrix situated in rows and columns -C LOW through IGH to upper Hessenberg form by -C unitary similarity transformations. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, AR and AI, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix A=(AR,AI). N is an INTEGER -C variable. N must be less than or equal to NM. -C -C LOW and IGH are two INTEGER variables determined by the -C balancing subroutine CBAL. If CBAL has not been used, -C set LOW=1 and IGH equal to the order of the matrix, N. -C -C AR and AI contain the real and imaginary parts, respectively, -C of the complex input matrix. AR and AI are two-dimensional -C REAL arrays, dimensioned AR(NM,N) and AI(NM,N). -C -C On OUTPUT -C -C AR and AI contain the real and imaginary parts, respectively, -C of the Hessenberg matrix. Information about the unitary -C transformations used in the reduction is stored in the -C remaining triangles under the Hessenberg matrix. -C -C ORTR and ORTI contain further information about the unitary -C transformations. Only elements LOW through IGH are used. -C ORTR and ORTI are one-dimensional REAL arrays, dimensioned -C ORTR(IGH) and ORTI(IGH). -C -C Calls PYTHAG(A,B) for sqrt(A**2 + B**2). -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED PYTHAG -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CORTH -C - INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW - REAL AR(NM,*),AI(NM,*),ORTR(*),ORTI(*) - REAL F,G,H,FI,FR,SCALE - REAL PYTHAG -C -C***FIRST EXECUTABLE STATEMENT CORTH - LA = IGH - 1 - KP1 = LOW + 1 - IF (LA .LT. KP1) GO TO 200 -C - DO 180 M = KP1, LA - H = 0.0E0 - ORTR(M) = 0.0E0 - ORTI(M) = 0.0E0 - SCALE = 0.0E0 -C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) .......... - DO 90 I = M, IGH - 90 SCALE = SCALE + ABS(AR(I,M-1)) + ABS(AI(I,M-1)) -C - IF (SCALE .EQ. 0.0E0) GO TO 180 - MP = M + IGH -C .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... - DO 100 II = M, IGH - I = MP - II - ORTR(I) = AR(I,M-1) / SCALE - ORTI(I) = AI(I,M-1) / SCALE - H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I) - 100 CONTINUE -C - G = SQRT(H) - F = PYTHAG(ORTR(M),ORTI(M)) - IF (F .EQ. 0.0E0) GO TO 103 - H = H + F * G - G = G / F - ORTR(M) = (1.0E0 + G) * ORTR(M) - ORTI(M) = (1.0E0 + G) * ORTI(M) - GO TO 105 -C - 103 ORTR(M) = G - AR(M,M-1) = SCALE -C .......... FORM (I-(U*UT)/H) * A .......... - 105 DO 130 J = M, N - FR = 0.0E0 - FI = 0.0E0 -C .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... - DO 110 II = M, IGH - I = MP - II - FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J) - FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J) - 110 CONTINUE -C - FR = FR / H - FI = FI / H -C - DO 120 I = M, IGH - AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I) - AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I) - 120 CONTINUE -C - 130 CONTINUE -C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) .......... - DO 160 I = 1, IGH - FR = 0.0E0 - FI = 0.0E0 -C .......... FOR J=IGH STEP -1 UNTIL M DO -- .......... - DO 140 JJ = M, IGH - J = MP - JJ - FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J) - FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J) - 140 CONTINUE -C - FR = FR / H - FI = FI / H -C - DO 150 J = M, IGH - AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J) - AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J) - 150 CONTINUE -C - 160 CONTINUE -C - ORTR(M) = SCALE * ORTR(M) - ORTI(M) = SCALE * ORTI(M) - AR(M,M-1) = -G * AR(M,M-1) - AI(M,M-1) = -G * AI(M,M-1) - 180 CONTINUE -C - 200 RETURN - END diff --git a/slatec/cosdg.f b/slatec/cosdg.f deleted file mode 100644 index 256d433..0000000 --- a/slatec/cosdg.f +++ /dev/null @@ -1,37 +0,0 @@ -*DECK COSDG - FUNCTION COSDG (X) -C***BEGIN PROLOGUE COSDG -C***PURPOSE Compute the cosine of an argument in degrees. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4A -C***TYPE SINGLE PRECISION (COSDG-S, DCOSDG-D) -C***KEYWORDS COSINE, DEGREES, ELEMENTARY FUNCTIONS, FNLIB, -C TRIGONOMETRIC -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C COSDG(X) evaluates the cosine for real X in degrees. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 770601 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***END PROLOGUE COSDG -C JUNE 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. - SAVE RADDEG - DATA RADDEG / .017453292519943296E0 / -C -C***FIRST EXECUTABLE STATEMENT COSDG - COSDG = COS (RADDEG*X) -C - IF (MOD(X,90.).NE.0.) RETURN - N = ABS(X)/90.0 + 0.5 - N = MOD (N, 2) - IF (N.EQ.0) COSDG = SIGN (1.0, COSDG) - IF (N.EQ.1) COSDG = 0.0 -C - RETURN - END diff --git a/slatec/cosgen.f b/slatec/cosgen.f deleted file mode 100644 index 53ac7d3..0000000 --- a/slatec/cosgen.f +++ /dev/null @@ -1,67 +0,0 @@ -*DECK COSGEN - SUBROUTINE COSGEN (N, IJUMP, FNUM, FDEN, A) -C***BEGIN PROLOGUE COSGEN -C***SUBSIDIARY -C***PURPOSE Subsidiary to GENBUN -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (COSGEN-S, CMPCSG-C) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This subroutine computes required cosine values in ascending -C order. When IJUMP .GT. 1 the routine computes values -C -C 2*COS(J*PI/L) , J=1,2,...,L and J .NE. 0(MOD N/IJUMP+1) -C -C where L = IJUMP*(N/IJUMP+1). -C -C -C when IJUMP = 1 it computes -C -C 2*COS((J-FNUM)*PI/(N+FDEN)) , J=1, 2, ... ,N -C -C where -C FNUM = 0.5, FDEN = 0.0, for regular reduction values. -C FNUM = 0.0, FDEN = 1.0, for B-R and C-R when ISTAG = 1 -C FNUM = 0.0, FDEN = 0.5, for B-R and C-R when ISTAG = 2 -C FNUM = 0.5, FDEN = 0.5, for B-R and C-R when ISTAG = 2 -C in POISN2 only. -C -C***SEE ALSO GENBUN -C***ROUTINES CALLED PIMACH -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE COSGEN - DIMENSION A(*) -C -C -C***FIRST EXECUTABLE STATEMENT COSGEN - PI = PIMACH(DUM) - IF (N .EQ. 0) GO TO 105 - IF (IJUMP .EQ. 1) GO TO 103 - K3 = N/IJUMP+1 - K4 = K3-1 - PIBYN = PI/(N+IJUMP) - DO 102 K=1,IJUMP - K1 = (K-1)*K3 - K5 = (K-1)*K4 - DO 101 I=1,K4 - X = K1+I - K2 = K5+I - A(K2) = -2.*COS(X*PIBYN) - 101 CONTINUE - 102 CONTINUE - GO TO 105 - 103 CONTINUE - NP1 = N+1 - Y = PI/(N+FDEN) - DO 104 I=1,N - X = NP1-I-FNUM - A(I) = 2.*COS(X*Y) - 104 CONTINUE - 105 CONTINUE - RETURN - END diff --git a/slatec/cosqb.f b/slatec/cosqb.f deleted file mode 100644 index 8a5611b..0000000 --- a/slatec/cosqb.f +++ /dev/null @@ -1,85 +0,0 @@ -*DECK COSQB - SUBROUTINE COSQB (N, X, WSAVE) -C***BEGIN PROLOGUE COSQB -C***PURPOSE Compute the unnormalized inverse cosine transform. -C***LIBRARY SLATEC (FFTPACK) -C***CATEGORY J1A3 -C***TYPE SINGLE PRECISION (COSQB-S) -C***KEYWORDS FFTPACK, INVERSE COSINE FOURIER TRANSFORM -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C Subroutine COSQB computes the fast Fourier transform of quarter -C wave data. That is, COSQB computes a sequence from its -C representation in terms of a cosine series with odd wave numbers. -C The transform is defined below at output parameter X. -C -C COSQB is the unnormalized inverse of COSQF since a call of COSQB -C followed by a call of COSQF will multiply the input sequence X -C by 4*N. -C -C The array WSAVE which is used by subroutine COSQB must be -C initialized by calling subroutine COSQI(N,WSAVE). -C -C -C Input Parameters -C -C N the length of the array X to be transformed. The method -C is most efficient when N is a product of small primes. -C -C X an array which contains the sequence to be transformed -C -C WSAVE a work array which must be dimensioned at least 3*N+15 -C in the program that calls COSQB. The WSAVE array must be -C initialized by calling subroutine COSQI(N,WSAVE), and a -C different WSAVE array must be used for each different -C value of N. This initialization does not have to be -C repeated so long as N remains unchanged. Thus subsequent -C transforms can be obtained faster than the first. -C -C Output Parameters -C -C X For I=1,...,N -C -C X(I)= the sum from K=1 to K=N of -C -C 2*X(K)*COS((2*K-1)*(I-1)*PI/(2*N)) -C -C A call of COSQB followed by a call of -C COSQF will multiply the sequence X by 4*N. -C Therefore COSQF is the unnormalized inverse -C of COSQB. -C -C WSAVE contains initialization calculations which must not -C be destroyed between calls of COSQB or COSQF. -C -C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel -C Computations (G. Rodrigue, ed.), Academic Press, -C 1982, pp. 51-83. -C***ROUTINES CALLED COSQB1 -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C (a) changing dummy array size declarations (1) to (*), -C (b) changing definition of variable TSQRT2 by using -C FORTRAN intrinsic function SQRT instead of a DATA -C statement. -C 861211 REVISION DATE from Version 3.2 -C 881128 Modified by Dick Valent to meet prologue standards. -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE COSQB - DIMENSION X(*), WSAVE(*) -C***FIRST EXECUTABLE STATEMENT COSQB - TSQRT2 = 2.*SQRT(2.) - IF (N-2) 101,102,103 - 101 X(1) = 4.*X(1) - RETURN - 102 X1 = 4.*(X(1)+X(2)) - X(2) = TSQRT2*(X(1)-X(2)) - X(1) = X1 - RETURN - 103 CALL COSQB1 (N,X,WSAVE,WSAVE(N+1)) - RETURN - END diff --git a/slatec/cosqb1.f b/slatec/cosqb1.f deleted file mode 100644 index aff2333..0000000 --- a/slatec/cosqb1.f +++ /dev/null @@ -1,57 +0,0 @@ -*DECK COSQB1 - SUBROUTINE COSQB1 (N, X, W, XH) -C***BEGIN PROLOGUE COSQB1 -C***SUBSIDIARY -C***PURPOSE Compute the unnormalized inverse of COSQF1. -C***LIBRARY SLATEC (FFTPACK) -C***CATEGORY J1A3 -C***TYPE SINGLE PRECISION (COSQB1-S) -C***KEYWORDS FFTPACK, FOURIER TRANSFORM -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C Subroutine COSQB1 computes the fast Fourier transform of quarter -C wave data. That is, COSQB1 computes a sequence from its -C representation in terms of a cosine series with odd wave numbers. -C The transform is defined below at output parameter X. -C -C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel -C Computations (G. Rodrigue, ed.), Academic Press, -C 1982, pp. 51-83. -C***ROUTINES CALLED RFFTB -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C changing dummy array size declarations (1) to (*). -C 881128 Modified by Dick Valent to meet prologue standards. -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE COSQB1 - DIMENSION X(*), W(*), XH(*) -C***FIRST EXECUTABLE STATEMENT COSQB1 - NS2 = (N+1)/2 - NP2 = N+2 - DO 101 I=3,N,2 - XIM1 = X(I-1)+X(I) - X(I) = X(I)-X(I-1) - X(I-1) = XIM1 - 101 CONTINUE - X(1) = X(1)+X(1) - MODN = MOD(N,2) - IF (MODN .EQ. 0) X(N) = X(N)+X(N) - CALL RFFTB (N,X,XH) - DO 102 K=2,NS2 - KC = NP2-K - XH(K) = W(K-1)*X(KC)+W(KC-1)*X(K) - XH(KC) = W(K-1)*X(K)-W(KC-1)*X(KC) - 102 CONTINUE - IF (MODN .EQ. 0) X(NS2+1) = W(NS2)*(X(NS2+1)+X(NS2+1)) - DO 103 K=2,NS2 - KC = NP2-K - X(K) = XH(K)+XH(KC) - X(KC) = XH(K)-XH(KC) - 103 CONTINUE - X(1) = X(1)+X(1) - RETURN - END diff --git a/slatec/cosqf.f b/slatec/cosqf.f deleted file mode 100644 index 3378b8b..0000000 --- a/slatec/cosqf.f +++ /dev/null @@ -1,83 +0,0 @@ -*DECK COSQF - SUBROUTINE COSQF (N, X, WSAVE) -C***BEGIN PROLOGUE COSQF -C***PURPOSE Compute the forward cosine transform with odd wave numbers. -C***LIBRARY SLATEC (FFTPACK) -C***CATEGORY J1A3 -C***TYPE SINGLE PRECISION (COSQF-S) -C***KEYWORDS COSINE FOURIER TRANSFORM, FFTPACK -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C Subroutine COSQF computes the fast Fourier transform of quarter -C wave data. That is, COSQF computes the coefficients in a cosine -C series representation with only odd wave numbers. The transform -C is defined below at Output Parameter X -C -C COSQF is the unnormalized inverse of COSQB since a call of COSQF -C followed by a call of COSQB will multiply the input sequence X -C by 4*N. -C -C The array WSAVE which is used by subroutine COSQF must be -C initialized by calling subroutine COSQI(N,WSAVE). -C -C -C Input Parameters -C -C N the length of the array X to be transformed. The method -C is most efficient when N is a product of small primes. -C -C X an array which contains the sequence to be transformed -C -C WSAVE a work array which must be dimensioned at least 3*N+15 -C in the program that calls COSQF. The WSAVE array must be -C initialized by calling subroutine COSQI(N,WSAVE), and a -C different WSAVE array must be used for each different -C value of N. This initialization does not have to be -C repeated so long as N remains unchanged. Thus subsequent -C transforms can be obtained faster than the first. -C -C Output Parameters -C -C X For I=1,...,N -C -C X(I) = X(1) plus the sum from K=2 to K=N of -C -C 2*X(K)*COS((2*I-1)*(K-1)*PI/(2*N)) -C -C A call of COSQF followed by a call of -C COSQB will multiply the sequence X by 4*N. -C Therefore COSQB is the unnormalized inverse -C of COSQF. -C -C WSAVE contains initialization calculations which must not -C be destroyed between calls of COSQF or COSQB. -C -C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel -C Computations (G. Rodrigue, ed.), Academic Press, -C 1982, pp. 51-83. -C***ROUTINES CALLED COSQF1 -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C (a) changing dummy array size declarations (1) to (*), -C (b) changing definition of variable SQRT2 by using -C FORTRAN intrinsic function SQRT instead of a DATA -C statement. -C 861211 REVISION DATE from Version 3.2 -C 881128 Modified by Dick Valent to meet prologue standards. -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE COSQF - DIMENSION X(*), WSAVE(*) -C***FIRST EXECUTABLE STATEMENT COSQF - SQRT2 = SQRT(2.) - IF (N-2) 102,101,103 - 101 TSQX = SQRT2*X(2) - X(2) = X(1)-TSQX - X(1) = X(1)+TSQX - 102 RETURN - 103 CALL COSQF1 (N,X,WSAVE,WSAVE(N+1)) - RETURN - END diff --git a/slatec/cosqf1.f b/slatec/cosqf1.f deleted file mode 100644 index 30e8fd4..0000000 --- a/slatec/cosqf1.f +++ /dev/null @@ -1,55 +0,0 @@ -*DECK COSQF1 - SUBROUTINE COSQF1 (N, X, W, XH) -C***BEGIN PROLOGUE COSQF1 -C***SUBSIDIARY -C***PURPOSE Compute the forward cosine transform with odd wave numbers. -C***LIBRARY SLATEC (FFTPACK) -C***CATEGORY J1A3 -C***TYPE SINGLE PRECISION (COSQF1-S) -C***KEYWORDS FFTPACK, FOURIER TRANSFORM -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C Subroutine COSQF1 computes the fast Fourier transform of quarter -C wave data. That is, COSQF1 computes the coefficients in a cosine -C series representation with only odd wave numbers. The transform -C is defined below at Output Parameter X -C -C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel -C Computations (G. Rodrigue, ed.), Academic Press, -C 1982, pp. 51-83. -C***ROUTINES CALLED RFFTF -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C changing dummy array size declarations (1) to (*). -C 881128 Modified by Dick Valent to meet prologue standards. -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE COSQF1 - DIMENSION X(*), W(*), XH(*) -C***FIRST EXECUTABLE STATEMENT COSQF1 - NS2 = (N+1)/2 - NP2 = N+2 - DO 101 K=2,NS2 - KC = NP2-K - XH(K) = X(K)+X(KC) - XH(KC) = X(K)-X(KC) - 101 CONTINUE - MODN = MOD(N,2) - IF (MODN .EQ. 0) XH(NS2+1) = X(NS2+1)+X(NS2+1) - DO 102 K=2,NS2 - KC = NP2-K - X(K) = W(K-1)*XH(KC)+W(KC-1)*XH(K) - X(KC) = W(K-1)*XH(K)-W(KC-1)*XH(KC) - 102 CONTINUE - IF (MODN .EQ. 0) X(NS2+1) = W(NS2)*XH(NS2+1) - CALL RFFTF (N,X,XH) - DO 103 I=3,N,2 - XIM1 = X(I-1)-X(I) - X(I) = X(I-1)+X(I) - X(I-1) = XIM1 - 103 CONTINUE - RETURN - END diff --git a/slatec/cosqi.f b/slatec/cosqi.f deleted file mode 100644 index d0b621c..0000000 --- a/slatec/cosqi.f +++ /dev/null @@ -1,61 +0,0 @@ -*DECK COSQI - SUBROUTINE COSQI (N, WSAVE) -C***BEGIN PROLOGUE COSQI -C***PURPOSE Initialize a work array for COSQF and COSQB. -C***LIBRARY SLATEC (FFTPACK) -C***CATEGORY J1A3 -C***TYPE SINGLE PRECISION (COSQI-S) -C***KEYWORDS COSINE FOURIER TRANSFORM, FFTPACK -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C Subroutine COSQI initializes the work array WSAVE which is used in -C both COSQF1 and COSQB1. The prime factorization of N together with -C a tabulation of the trigonometric functions are computed and -C stored in WSAVE. -C -C Input Parameter -C -C N the length of the array to be transformed. The method -C is most efficient when N is a product of small primes. -C -C Output Parameter -C -C WSAVE a work array which must be dimensioned at least 3*N+15. -C The same work array can be used for both COSQF1 and COSQB1 -C as long as N remains unchanged. Different WSAVE arrays -C are required for different values of N. The contents of -C WSAVE must not be changed between calls of COSQF1 or COSQB1. -C -C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel -C Computations (G. Rodrigue, ed.), Academic Press, -C 1982, pp. 51-83. -C***ROUTINES CALLED RFFTI -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C (a) changing dummy array size declarations (1) to (*), -C (b) changing references to intrinsic function FLOAT -C to REAL, and -C (c) changing definition of variable PIH by using -C FORTRAN intrinsic function ATAN instead of a DATA -C statement. -C 881128 Modified by Dick Valent to meet prologue standards. -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 COSQI - DIMENSION WSAVE(*) -C***FIRST EXECUTABLE STATEMENT COSQI - PIH = 2.*ATAN(1.) - DT = PIH/N - FK = 0. - DO 101 K=1,N - FK = FK+1. - WSAVE(K) = COS(FK*DT) - 101 CONTINUE - CALL RFFTI (N,WSAVE(N+1)) - RETURN - END diff --git a/slatec/cost.f b/slatec/cost.f deleted file mode 100644 index 77e966f..0000000 --- a/slatec/cost.f +++ /dev/null @@ -1,112 +0,0 @@ -*DECK COST - SUBROUTINE COST (N, X, WSAVE) -C***BEGIN PROLOGUE COST -C***PURPOSE Compute the cosine transform of a real, even sequence. -C***LIBRARY SLATEC (FFTPACK) -C***CATEGORY J1A3 -C***TYPE SINGLE PRECISION (COST-S) -C***KEYWORDS COSINE FOURIER TRANSFORM, FFTPACK -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C Subroutine COST computes the discrete Fourier cosine transform -C of an even sequence X(I). The transform is defined below at output -C parameter X. -C -C COST is the unnormalized inverse of itself since a call of COST -C followed by another call of COST will multiply the input sequence -C X by 2*(N-1). The transform is defined below at output parameter X. -C -C The array WSAVE which is used by subroutine COST must be -C initialized by calling subroutine COSTI(N,WSAVE). -C -C Input Parameters -C -C N the length of the sequence X. N must be greater than 1. -C The method is most efficient when N-1 is a product of -C small primes. -C -C X an array which contains the sequence to be transformed -C -C WSAVE a work array which must be dimensioned at least 3*N+15 -C in the program that calls COST. The WSAVE array must be -C initialized by calling subroutine COSTI(N,WSAVE), and a -C different WSAVE array must be used for each different -C value of N. This initialization does not have to be -C repeated so long as N remains unchanged. Thus subsequent -C transforms can be obtained faster than the first. -C -C Output Parameters -C -C X For I=1,...,N -C -C X(I) = X(1)+(-1)**(I-1)*X(N) -C -C + the sum from K=2 to K=N-1 -C -C 2*X(K)*COS((K-1)*(I-1)*PI/(N-1)) -C -C A call of COST followed by another call of -C COST will multiply the sequence X by 2*(N-1). -C Hence COST is the unnormalized inverse -C of itself. -C -C WSAVE contains initialization calculations which must not be -C destroyed between calls of COST. -C -C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel -C Computations (G. Rodrigue, ed.), Academic Press, -C 1982, pp. 51-83. -C***ROUTINES CALLED RFFTF -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C changing dummy array size declarations (1) to (*) -C 861211 REVISION DATE from Version 3.2 -C 881128 Modified by Dick Valent to meet prologue standards. -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE COST - DIMENSION X(*), WSAVE(*) -C***FIRST EXECUTABLE STATEMENT COST - NM1 = N-1 - NP1 = N+1 - NS2 = N/2 - IF (N-2) 106,101,102 - 101 X1H = X(1)+X(2) - X(2) = X(1)-X(2) - X(1) = X1H - RETURN - 102 IF (N .GT. 3) GO TO 103 - X1P3 = X(1)+X(3) - TX2 = X(2)+X(2) - X(2) = X(1)-X(3) - X(1) = X1P3+TX2 - X(3) = X1P3-TX2 - RETURN - 103 C1 = X(1)-X(N) - X(1) = X(1)+X(N) - DO 104 K=2,NS2 - KC = NP1-K - T1 = X(K)+X(KC) - T2 = X(K)-X(KC) - C1 = C1+WSAVE(KC)*T2 - T2 = WSAVE(K)*T2 - X(K) = T1-T2 - X(KC) = T1+T2 - 104 CONTINUE - MODN = MOD(N,2) - IF (MODN .NE. 0) X(NS2+1) = X(NS2+1)+X(NS2+1) - CALL RFFTF (NM1,X,WSAVE(N+1)) - XIM2 = X(2) - X(2) = C1 - DO 105 I=4,N,2 - XI = X(I) - X(I) = X(I-2)-X(I-1) - X(I-1) = XIM2 - XIM2 = XI - 105 CONTINUE - IF (MODN .NE. 0) X(N) = XIM2 - 106 RETURN - END diff --git a/slatec/costi.f b/slatec/costi.f deleted file mode 100644 index 52d407f..0000000 --- a/slatec/costi.f +++ /dev/null @@ -1,66 +0,0 @@ -*DECK COSTI - SUBROUTINE COSTI (N, WSAVE) -C***BEGIN PROLOGUE COSTI -C***PURPOSE Initialize a work array for COST. -C***LIBRARY SLATEC (FFTPACK) -C***CATEGORY J1A3 -C***TYPE SINGLE PRECISION (COSTI-S) -C***KEYWORDS COSINE FOURIER TRANSFORM, FFTPACK -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C Subroutine COSTI initializes the array WSAVE which is used in -C subroutine COST. The prime factorization of N together with -C a tabulation of the trigonometric functions are computed and -C stored in WSAVE. -C -C Input Parameter -C -C N the length of the sequence to be transformed. The method -C is most efficient when N-1 is a product of small primes. -C -C Output Parameter -C -C WSAVE a work array which must be dimensioned at least 3*N+15. -C Different WSAVE arrays are required for different values -C of N. The contents of WSAVE must not be changed between -C calls of COST. -C -C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel -C Computations (G. Rodrigue, ed.), Academic Press, -C 1982, pp. 51-83. -C***ROUTINES CALLED RFFTI -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C (a) changing dummy array size declarations (1) to (*), -C (b) changing references to intrinsic function FLOAT -C to REAL, and -C (c) changing definition of variable PI by using -C FORTRAN intrinsic function ATAN instead of a DATA -C statement. -C 881128 Modified by Dick Valent to meet prologue standards. -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 COSTI - DIMENSION WSAVE(*) -C***FIRST EXECUTABLE STATEMENT COSTI - IF (N .LE. 3) RETURN - PI = 4.*ATAN(1.) - NM1 = N-1 - NP1 = N+1 - NS2 = N/2 - DT = PI/NM1 - FK = 0. - DO 101 K=2,NS2 - KC = NP1-K - FK = FK+1. - WSAVE(K) = 2.*SIN(FK*DT) - WSAVE(KC) = 2.*COS(FK*DT) - 101 CONTINUE - CALL RFFTI (NM1,WSAVE(N+1)) - RETURN - END diff --git a/slatec/cot.f b/slatec/cot.f deleted file mode 100644 index 026a3de..0000000 --- a/slatec/cot.f +++ /dev/null @@ -1,99 +0,0 @@ -*DECK COT - FUNCTION COT (X) -C***BEGIN PROLOGUE COT -C***PURPOSE Compute the cotangent. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4A -C***TYPE SINGLE PRECISION (COT-S, DCOT-D, CCOT-C) -C***KEYWORDS COTANGENT, ELEMENTARY FUNCTIONS, FNLIB, TRIGONOMETRIC -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C COT(X) calculates the cotangent of the real argument X. X is in -C units of radians. -C -C Series for COT on the interval 0. to 6.25000D-02 -C with weighted error 3.76E-17 -C log weighted error 16.42 -C significant figures required 15.51 -C decimal places required 16.88 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 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 920618 Removed space from variable names. (RWC, WRB) -C***END PROLOGUE COT - DIMENSION COTCS(8) - LOGICAL FIRST - SAVE COTCS, PI2REC, NTERMS, XMAX, XSML, XMIN, SQEPS, FIRST - DATA COTCS( 1) / .2402591609 8295630E0 / - DATA COTCS( 2) / -.0165330316 01500228E0 / - DATA COTCS( 3) / -.0000429983 91931724E0 / - DATA COTCS( 4) / -.0000001592 83223327E0 / - DATA COTCS( 5) / -.0000000006 19109313E0 / - DATA COTCS( 6) / -.0000000000 02430197E0 / - DATA COTCS( 7) / -.0000000000 00009560E0 / - DATA COTCS( 8) / -.0000000000 00000037E0 / - DATA PI2REC / .01161977236 75813430 E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT COT - IF (FIRST) THEN - NTERMS = INITS (COTCS, 8, 0.1*R1MACH(3)) - XMAX = 1.0/R1MACH(4) - XSML = SQRT (3.0*R1MACH(3)) - XMIN = EXP ( MAX(LOG(R1MACH(1)), -LOG(R1MACH(2))) + 0.01) - SQEPS = SQRT (R1MACH(4)) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (ABS(X) .LT. XMIN) CALL XERMSG ('SLATEC', 'COT', - + 'ABS(X) IS ZERO OR SO SMALL COT OVERFLOWS', 2, 2) - IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'COT', - + 'NO PRECISION BECAUSE ABS(X) IS TOO BIG', 3, 2) -C -C CAREFULLY COMPUTE Y * (2/PI) = (AINT(Y) + REM(Y)) * (.625 + PI2REC) -C = AINT(.625*Y) + REM(.625*Y) + Y*PI2REC = AINT(.625*Y) + Z -C = AINT(.625*Y) + AINT(Z) + REM(Z) -C - AINTY = AINT (Y) - YREM = Y - AINTY - PRODBG = 0.625*AINTY - AINTY = AINT (PRODBG) - Y = (PRODBG-AINTY) + 0.625*YREM + Y*PI2REC - AINTY2 = AINT (Y) - AINTY = AINTY + AINTY2 - Y = Y - AINTY2 -C - IFN = MOD (AINTY, 2.) - IF (IFN.EQ.1) Y = 1.0 - Y -C - IF (ABS(X) .GT. 0.5 .AND. Y .LT. ABS(X)*SQEPS) CALL XERMSG - + ('SLATEC', 'COT', - + 'ANSWER LT HALF PRECISION, ABS(X) TOO BIG OR X NEAR N*PI ' // - + '(N.NE.0)' , 1, 1) -C - IF (Y.GT.0.25) GO TO 20 - COT = 1.0/X - IF (Y.GT.XSML) COT = (0.5 + CSEVL (32.0*Y*Y-1., COTCS, NTERMS)) /Y - GO TO 40 -C - 20 IF (Y.GT.0.5) GO TO 30 - COT = (0.5 + CSEVL (8.0*Y*Y-1., COTCS, NTERMS)) / (0.5*Y) - COT = (COT**2 - 1.0) * 0.5 / COT - GO TO 40 -C - 30 COT = (0.5 + CSEVL (2.0*Y*Y-1., COTCS, NTERMS)) / (0.25*Y) - COT = (COT**2 - 1.0) * 0.5 / COT - COT = (COT**2 - 1.0) * 0.5 / COT -C - 40 IF (X.NE.0.) COT = SIGN (COT, X) - IF (IFN.EQ.1) COT = -COT -C - RETURN - END diff --git a/slatec/cpadd.f b/slatec/cpadd.f deleted file mode 100644 index 44dd7e9..0000000 --- a/slatec/cpadd.f +++ /dev/null @@ -1,164 +0,0 @@ -*DECK CPADD - SUBROUTINE CPADD (N, IERROR, A, C, CBP, BP, BH) -C***BEGIN PROLOGUE CPADD -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBLKTR -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (CPADD-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C CPADD computes the eigenvalues of the periodic tridiagonal matrix -C with coefficients AN,BN,CN. -C -C N is the order of the BH and BP polynomials. -C BP contains the eigenvalues on output. -C CBP is the same as BP except type complex. -C BH is used to temporarily store the roots of the B HAT polynomial -C which enters through BP. -C -C***SEE ALSO CBLKTR -C***ROUTINES CALLED BCRH, PGSF, PPGSF, PPPSF -C***COMMON BLOCKS CCBLK -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE CPADD -C - COMPLEX CX ,FSG ,HSG , - 1 DD ,F ,FP ,FPP , - 2 CDIS ,R1 ,R2 ,R3 , - 3 CBP - DIMENSION A(*) ,C(*) ,BP(*) ,BH(*) , - 1 CBP(*) - COMMON /CCBLK/ NPP ,K ,EPS ,CNV , - 1 NM ,NCMPLX ,IK - EXTERNAL PGSF ,PPPSF ,PPGSF -C***FIRST EXECUTABLE STATEMENT CPADD - SCNV = SQRT(CNV) - IZ = N - IF (BP(N)-BP(1)) 101,142,103 - 101 DO 102 J=1,N - NT = N-J - BH(J) = BP(NT+1) - 102 CONTINUE - GO TO 105 - 103 DO 104 J=1,N - BH(J) = BP(J) - 104 CONTINUE - 105 NCMPLX = 0 - MODIZ = MOD(IZ,2) - IS = 1 - IF (MODIZ) 106,107,106 - 106 IF (A(1)) 110,142,107 - 107 XL = BH(1) - DB = BH(3)-BH(1) - 108 XL = XL-DB - IF (PGSF(XL,IZ,C,A,BH)) 108,108,109 - 109 SGN = -1. - CBP(1) = CMPLX(BCRH(XL,BH(1),IZ,C,A,BH,PGSF,SGN),0.) - IS = 2 - 110 IF = IZ-1 - IF (MODIZ) 111,112,111 - 111 IF (A(1)) 112,142,115 - 112 XR = BH(IZ) - DB = BH(IZ)-BH(IZ-2) - 113 XR = XR+DB - IF (PGSF(XR,IZ,C,A,BH)) 113,114,114 - 114 SGN = 1. - CBP(IZ) = CMPLX(BCRH(BH(IZ),XR,IZ,C,A,BH,PGSF,SGN),0.) - IF = IZ-2 - 115 DO 136 IG=IS,IF,2 - XL = BH(IG) - XR = BH(IG+1) - SGN = -1. - XM = BCRH(XL,XR,IZ,C,A,BH,PPPSF,SGN) - PSG = PGSF(XM,IZ,C,A,BH) - IF (ABS(PSG)-EPS) 118,118,116 - 116 IF (PSG*PPGSF(XM,IZ,C,A,BH)) 117,118,119 -C -C CASE OF A REAL ZERO -C - 117 SGN = 1. - CBP(IG) = CMPLX(BCRH(BH(IG),XM,IZ,C,A,BH,PGSF,SGN),0.) - SGN = -1. - CBP(IG+1) = CMPLX(BCRH(XM,BH(IG+1),IZ,C,A,BH,PGSF,SGN),0.) - GO TO 136 -C -C CASE OF A MULTIPLE ZERO -C - 118 CBP(IG) = CMPLX(XM,0.) - CBP(IG+1) = CMPLX(XM,0.) - GO TO 136 -C -C CASE OF A COMPLEX ZERO -C - 119 IT = 0 - ICV = 0 - CX = CMPLX(XM,0.) - 120 FSG = (1.,0.) - HSG = (1.,0.) - FP = (0.,0.) - FPP = (0.,0.) - DO 121 J=1,IZ - DD = 1./(CX-BH(J)) - FSG = FSG*A(J)*DD - HSG = HSG*C(J)*DD - FP = FP+DD - FPP = FPP-DD*DD - 121 CONTINUE - IF (MODIZ) 123,122,123 - 122 F = (1.,0.)-FSG-HSG - GO TO 124 - 123 F = (1.,0.)+FSG+HSG - 124 I3 = 0 - IF (ABS(FP)) 126,126,125 - 125 I3 = 1 - R3 = -F/FP - 126 IF (ABS(FPP)) 132,132,127 - 127 CDIS = SQRT(FP**2-2.*F*FPP) - R1 = CDIS-FP - R2 = -FP-CDIS - IF (ABS(R1)-ABS(R2)) 129,129,128 - 128 R1 = R1/FPP - GO TO 130 - 129 R1 = R2/FPP - 130 R2 = 2.*F/FPP/R1 - IF (ABS(R2) .LT. ABS(R1)) R1 = R2 - IF (I3) 133,133,131 - 131 IF (ABS(R3) .LT. ABS(R1)) R1 = R3 - GO TO 133 - 132 R1 = R3 - 133 CX = CX+R1 - IT = IT+1 - IF (IT .GT. 50) GO TO 142 - IF (ABS(R1) .GT. SCNV) GO TO 120 - IF (ICV) 134,134,135 - 134 ICV = 1 - GO TO 120 - 135 CBP(IG) = CX - CBP(IG+1) = CONJG(CX) - 136 CONTINUE - IF (ABS(CBP(N))-ABS(CBP(1))) 137,142,139 - 137 NHALF = N/2 - DO 138 J=1,NHALF - NT = N-J - CX = CBP(J) - CBP(J) = CBP(NT+1) - CBP(NT+1) = CX - 138 CONTINUE - 139 NCMPLX = 1 - DO 140 J=2,IZ - IF (AIMAG(CBP(J))) 143,140,143 - 140 CONTINUE - NCMPLX = 0 - DO 141 J=2,IZ - BP(J) = REAL(CBP(J)) - 141 CONTINUE - GO TO 143 - 142 IERROR = 4 - 143 CONTINUE - RETURN - END diff --git a/slatec/cpbco.f b/slatec/cpbco.f deleted file mode 100644 index 2765fc3..0000000 --- a/slatec/cpbco.f +++ /dev/null @@ -1,267 +0,0 @@ -*DECK CPBCO - SUBROUTINE CPBCO (ABD, LDA, N, M, RCOND, Z, INFO) -C***BEGIN PROLOGUE CPBCO -C***PURPOSE Factor a complex Hermitian positive definite matrix stored -C in band form and estimate the condition number of the -C matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2D2 -C***TYPE COMPLEX (SPBCO-S, DPBCO-D, CPBCO-C) -C***KEYWORDS BANDED, CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, -C MATRIX FACTORIZATION, POSITIVE DEFINITE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C CPBCO factors a complex Hermitian positive definite matrix -C stored in band form and estimates the condition of the matrix. -C -C If RCOND is not needed, CPBFA is slightly faster. -C To solve A*X = B , follow CPBCO by CPBSL. -C To compute INVERSE(A)*C , follow CPBCO by CPBSL. -C To compute DETERMINANT(A) , follow CPBCO by CPBDI. -C -C On Entry -C -C ABD COMPLEX(LDA, N) -C the matrix to be factored. The columns of the upper -C triangle are stored in the columns of ABD and the -C diagonals of the upper triangle are stored in the -C rows of ABD . See the comments below for details. -C -C LDA INTEGER -C the leading dimension of the array ABD . -C LDA must be .GE. M + 1 . -C -C N INTEGER -C the order of the matrix A . -C -C M INTEGER -C the number of diagonals above the main diagonal. -C 0 .LE. M .LT. N . -C -C On Return -C -C ABD an upper triangular matrix R , stored in band -C form, so that A = CTRANS(R)*R . -C If INFO .NE. 0 , the factorization is not complete. -C -C RCOND REAL -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. If INFO .NE. 0 , RCOND is unchanged. -C -C Z COMPLEX(N) -C a work vector whose contents are usually unimportant. -C If A is singular to working precision, then Z is -C an approximate null vector in the sense that -C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . -C If INFO .NE. 0 , Z is unchanged. -C -C INFO INTEGER -C = 0 for normal return. -C = K signals an error condition. The leading minor -C of order K is not positive definite. -C -C Band Storage -C -C If A is a Hermitian positive definite band matrix, -C the following program segment will set up the input. -C -C M = (band width above diagonal) -C DO 20 J = 1, N -C I1 = MAX(1, J-M) -C DO 10 I = I1, J -C K = I-J+M+1 -C ABD(K,J) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C This uses M + 1 rows of A , except for the M by M -C upper left triangle, which is ignored. -C -C Example: If the original matrix is -C -C 11 12 13 0 0 0 -C 12 22 23 24 0 0 -C 13 23 33 34 35 0 -C 0 24 34 44 45 46 -C 0 0 35 45 55 56 -C 0 0 0 46 56 66 -C -C then N = 6 , M = 2 and ABD should contain -C -C * * 13 24 35 46 -C * 12 23 34 45 56 -C 11 22 33 44 55 66 -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CDOTC, CPBFA, CSSCAL, SCASUM -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CPBCO - INTEGER LDA,N,M,INFO - COMPLEX ABD(LDA,*),Z(*) - REAL RCOND -C - COMPLEX CDOTC,EK,T,WK,WKM - REAL ANORM,S,SCASUM,SM,YNORM - INTEGER I,J,J2,K,KB,KP1,L,LA,LB,LM,MU - COMPLEX ZDUM,ZDUM2,CSIGN1 - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) - CSIGN1(ZDUM,ZDUM2) = CABS1(ZDUM)*(ZDUM2/CABS1(ZDUM2)) -C -C FIND NORM OF A -C -C***FIRST EXECUTABLE STATEMENT CPBCO - DO 30 J = 1, N - L = MIN(J,M+1) - MU = MAX(M+2-J,1) - Z(J) = CMPLX(SCASUM(L,ABD(MU,J),1),0.0E0) - K = J - L - IF (M .LT. MU) GO TO 20 - DO 10 I = MU, M - K = K + 1 - Z(K) = CMPLX(REAL(Z(K))+CABS1(ABD(I,J)),0.0E0) - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - ANORM = 0.0E0 - DO 40 J = 1, N - ANORM = MAX(ANORM,REAL(Z(J))) - 40 CONTINUE -C -C FACTOR -C - CALL CPBFA(ABD,LDA,N,M,INFO) - IF (INFO .NE. 0) GO TO 180 -C -C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . -C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . -C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL -C GROWTH IN THE ELEMENTS OF W WHERE CTRANS(R)*W = E . -C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. -C -C SOLVE CTRANS(R)*W = E -C - EK = (1.0E0,0.0E0) - DO 50 J = 1, N - Z(J) = (0.0E0,0.0E0) - 50 CONTINUE - DO 110 K = 1, N - IF (CABS1(Z(K)) .NE. 0.0E0) EK = CSIGN1(EK,-Z(K)) - IF (CABS1(EK-Z(K)) .LE. REAL(ABD(M+1,K))) GO TO 60 - S = REAL(ABD(M+1,K))/CABS1(EK-Z(K)) - CALL CSSCAL(N,S,Z,1) - EK = CMPLX(S,0.0E0)*EK - 60 CONTINUE - WK = EK - Z(K) - WKM = -EK - Z(K) - S = CABS1(WK) - SM = CABS1(WKM) - WK = WK/ABD(M+1,K) - WKM = WKM/ABD(M+1,K) - KP1 = K + 1 - J2 = MIN(K+M,N) - I = M + 1 - IF (KP1 .GT. J2) GO TO 100 - DO 70 J = KP1, J2 - I = I - 1 - SM = SM + CABS1(Z(J)+WKM*CONJG(ABD(I,J))) - Z(J) = Z(J) + WK*CONJG(ABD(I,J)) - S = S + CABS1(Z(J)) - 70 CONTINUE - IF (S .GE. SM) GO TO 90 - T = WKM - WK - WK = WKM - I = M + 1 - DO 80 J = KP1, J2 - I = I - 1 - Z(J) = Z(J) + T*CONJG(ABD(I,J)) - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - Z(K) = WK - 110 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) -C -C SOLVE R*Y = W -C - DO 130 KB = 1, N - K = N + 1 - KB - IF (CABS1(Z(K)) .LE. REAL(ABD(M+1,K))) GO TO 120 - S = REAL(ABD(M+1,K))/CABS1(Z(K)) - CALL CSSCAL(N,S,Z,1) - 120 CONTINUE - Z(K) = Z(K)/ABD(M+1,K) - LM = MIN(K-1,M) - LA = M + 1 - LM - LB = K - LM - T = -Z(K) - CALL CAXPY(LM,T,ABD(LA,K),1,Z(LB),1) - 130 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) -C - YNORM = 1.0E0 -C -C SOLVE CTRANS(R)*V = Y -C - DO 150 K = 1, N - LM = MIN(K-1,M) - LA = M + 1 - LM - LB = K - LM - Z(K) = Z(K) - CDOTC(LM,ABD(LA,K),1,Z(LB),1) - IF (CABS1(Z(K)) .LE. REAL(ABD(M+1,K))) GO TO 140 - S = REAL(ABD(M+1,K))/CABS1(Z(K)) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM - 140 CONTINUE - Z(K) = Z(K)/ABD(M+1,K) - 150 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE R*Z = W -C - DO 170 KB = 1, N - K = N + 1 - KB - IF (CABS1(Z(K)) .LE. REAL(ABD(M+1,K))) GO TO 160 - S = REAL(ABD(M+1,K))/CABS1(Z(K)) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM - 160 CONTINUE - Z(K) = Z(K)/ABD(M+1,K) - LM = MIN(K-1,M) - LA = M + 1 - LM - LB = K - LM - T = -Z(K) - CALL CAXPY(LM,T,ABD(LA,K),1,Z(LB),1) - 170 CONTINUE -C MAKE ZNORM = 1.0 - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM -C - IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM - IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0 - 180 CONTINUE - RETURN - END diff --git a/slatec/cpbdi.f b/slatec/cpbdi.f deleted file mode 100644 index 4e1992c..0000000 --- a/slatec/cpbdi.f +++ /dev/null @@ -1,83 +0,0 @@ -*DECK CPBDI - SUBROUTINE CPBDI (ABD, LDA, N, M, DET) -C***BEGIN PROLOGUE CPBDI -C***PURPOSE Compute the determinant of a complex Hermitian positive -C definite band matrix using the factors computed by CPBCO or -C CPBFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D3D2 -C***TYPE COMPLEX (SPBDI-S, DPBDI-D, CPBDI-C) -C***KEYWORDS BANDED, DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, -C MATRIX, POSITIVE DEFINITE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C CPBDI computes the determinant -C of a complex Hermitian positive definite band matrix -C using the factors computed by CPBCO or CPBFA. -C If the inverse is needed, use CPBSL N times. -C -C On Entry -C -C ABD COMPLEX(LDA, N) -C the output from CPBCO or CPBFA. -C -C LDA INTEGER -C the leading dimension of the array ABD . -C -C N INTEGER -C the order of the matrix A . -C -C M INTEGER -C the number of diagonals above the main diagonal. -C -C On Return -C -C DET REAL(2) -C determinant of original matrix in the form -C determinant = DET(1) * 10.0**DET(2) -C with 1.0 .LE. DET(1) .LT. 10.0 -C or DET(1) .EQ. 0.0 . -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CPBDI - INTEGER LDA,N,M - COMPLEX ABD(LDA,*) - REAL DET(2) -C - REAL S - INTEGER I -C***FIRST EXECUTABLE STATEMENT CPBDI -C -C COMPUTE DETERMINANT -C - DET(1) = 1.0E0 - DET(2) = 0.0E0 - S = 10.0E0 - DO 50 I = 1, N - DET(1) = REAL(ABD(M+1,I))**2*DET(1) - IF (DET(1) .EQ. 0.0E0) GO TO 60 - 10 IF (DET(1) .GE. 1.0E0) GO TO 20 - DET(1) = S*DET(1) - DET(2) = DET(2) - 1.0E0 - GO TO 10 - 20 CONTINUE - 30 IF (DET(1) .LT. S) GO TO 40 - DET(1) = DET(1)/S - DET(2) = DET(2) + 1.0E0 - GO TO 30 - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE - RETURN - END diff --git a/slatec/cpbfa.f b/slatec/cpbfa.f deleted file mode 100644 index b2955b9..0000000 --- a/slatec/cpbfa.f +++ /dev/null @@ -1,107 +0,0 @@ -*DECK CPBFA - SUBROUTINE CPBFA (ABD, LDA, N, M, INFO) -C***BEGIN PROLOGUE CPBFA -C***PURPOSE Factor a complex Hermitian positive definite matrix stored -C in band form. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2D2 -C***TYPE COMPLEX (SPBFA-S, DPBFA-D, CPBFA-C) -C***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, -C POSITIVE DEFINITE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C CPBFA factors a complex Hermitian positive definite matrix -C stored in band form. -C -C CPBFA is usually called by CPBCO, but it can be called -C directly with a saving in time if RCOND is not needed. -C -C On Entry -C -C ABD COMPLEX(LDA, N) -C the matrix to be factored. The columns of the upper -C triangle are stored in the columns of ABD and the -C diagonals of the upper triangle are stored in the -C rows of ABD . See the comments below for details. -C -C LDA INTEGER -C the leading dimension of the array ABD . -C LDA must be .GE. M + 1 . -C -C N INTEGER -C the order of the matrix A . -C -C M INTEGER -C the number of diagonals above the main diagonal. -C 0 .LE. M .LT. N . -C -C On Return -C -C ABD an upper triangular matrix R , stored in band -C form, so that A = CTRANS(R)*R . -C -C INFO INTEGER -C = 0 for normal return. -C = K if the leading minor of order K is not -C positive definite. -C -C Band Storage -C -C If A is a Hermitian positive definite band matrix, -C the following program segment will set up the input. -C -C M = (band width above diagonal) -C DO 20 J = 1, N -C I1 = MAX(1, J-M) -C DO 10 I = I1, J -C K = I-J+M+1 -C ABD(K,J) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CDOTC -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CPBFA - INTEGER LDA,N,M,INFO - COMPLEX ABD(LDA,*) -C - COMPLEX CDOTC,T - REAL S - INTEGER IK,J,JK,K,MU -C***FIRST EXECUTABLE STATEMENT CPBFA - DO 30 J = 1, N - INFO = J - S = 0.0E0 - IK = M + 1 - JK = MAX(J-M,1) - MU = MAX(M+2-J,1) - IF (M .LT. MU) GO TO 20 - DO 10 K = MU, M - T = ABD(K,J) - CDOTC(K-MU,ABD(IK,JK),1,ABD(MU,J),1) - T = T/ABD(M+1,JK) - ABD(K,J) = T - S = S + REAL(T*CONJG(T)) - IK = IK - 1 - JK = JK + 1 - 10 CONTINUE - 20 CONTINUE - S = REAL(ABD(M+1,J)) - S - IF (S .LE. 0.0E0 .OR. AIMAG(ABD(M+1,J)) .NE. 0.0E0) - 1 GO TO 40 - ABD(M+1,J) = CMPLX(SQRT(S),0.0E0) - 30 CONTINUE - INFO = 0 - 40 CONTINUE - RETURN - END diff --git a/slatec/cpbsl.f b/slatec/cpbsl.f deleted file mode 100644 index 2f0298e..0000000 --- a/slatec/cpbsl.f +++ /dev/null @@ -1,97 +0,0 @@ -*DECK CPBSL - SUBROUTINE CPBSL (ABD, LDA, N, M, B) -C***BEGIN PROLOGUE CPBSL -C***PURPOSE Solve the complex Hermitian positive definite band system -C using the factors computed by CPBCO or CPBFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2D2 -C***TYPE COMPLEX (SPBSL-S, DPBSL-D, CPBSL-C) -C***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX, -C POSITIVE DEFINITE, SOLVE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C CPBSL solves the complex Hermitian positive definite band -C system A*X = B -C using the factors computed by CPBCO or CPBFA. -C -C On Entry -C -C ABD COMPLEX(LDA, N) -C the output from CPBCO or CPBFA. -C -C LDA INTEGER -C the leading dimension of the array ABD . -C -C N INTEGER -C the order of the matrix A . -C -C M INTEGER -C the number of diagonals above the main diagonal. -C -C B COMPLEX(N) -C the right hand side vector. -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 -C a zero on the diagonal. Technically this indicates -C singularity but it is usually caused by improper subroutine -C arguments. It will not occur if the subroutines are called -C correctly and INFO .EQ. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL CPBCO(ABD,LDA,N,RCOND,Z,INFO) -C IF (RCOND is too small .OR. INFO .NE. 0) GO TO ... -C DO 10 J = 1, P -C CALL CPBSL(ABD,LDA,N,C(1,J)) -C 10 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CDOTC -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CPBSL - INTEGER LDA,N,M - COMPLEX ABD(LDA,*),B(*) -C - COMPLEX CDOTC,T - INTEGER K,KB,LA,LB,LM -C -C SOLVE CTRANS(R)*Y = B -C -C***FIRST EXECUTABLE STATEMENT CPBSL - DO 10 K = 1, N - LM = MIN(K-1,M) - LA = M + 1 - LM - LB = K - LM - T = CDOTC(LM,ABD(LA,K),1,B(LB),1) - B(K) = (B(K) - T)/ABD(M+1,K) - 10 CONTINUE -C -C SOLVE R*X = Y -C - DO 20 KB = 1, N - K = N + 1 - KB - LM = MIN(K-1,M) - LA = M + 1 - LM - LB = K - LM - B(K) = B(K)/ABD(M+1,K) - T = -B(K) - CALL CAXPY(LM,T,ABD(LA,K),1,B(LB),1) - 20 CONTINUE - RETURN - END diff --git a/slatec/cpevl.f b/slatec/cpevl.f deleted file mode 100644 index 1ffd66f..0000000 --- a/slatec/cpevl.f +++ /dev/null @@ -1,74 +0,0 @@ -*DECK CPEVL - SUBROUTINE CPEVL (N, M, A, Z, C, B, KBD) -C***BEGIN PROLOGUE CPEVL -C***SUBSIDIARY -C***PURPOSE Subsidiary to CPZERO -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (CPEVL-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Evaluate a complex polynomial and its derivatives. -C Optionally compute error bounds for these values. -C -C INPUT... -C N = Degree of the polynomial -C M = Number of derivatives to be calculated, -C M=0 evaluates only the function -C M=1 evaluates the function and first derivative, etc. -C if M .GT. N+1 function and all N derivatives will be -C calculated. -C A = Complex vector containing the N+1 coefficients of polynomial -C A(I)= coefficient of Z**(N+1-I) -C Z = Complex point at which the evaluation is to take place. -C C = Array of 2(M+1) words into which values are placed. -C B = Array of 2(M+1) words only needed if bounds are to be -C calculated. It is not used otherwise. -C KBD = A logical variable, e.g. .TRUE. or .FALSE. which is -C to be set .TRUE. if bounds are to be computed. -C -C OUTPUT... -C C = C(I+1) contains the complex value of the I-th -C derivative at Z, I=0,...,M -C B = B(I) contains the bounds on the real and imaginary parts -C of C(I) if they were requested. -C -C***SEE ALSO CPZERO -C***ROUTINES CALLED I1MACH -C***REVISION HISTORY (YYMMDD) -C 810223 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE CPEVL -C - COMPLEX A(*),C(*),Z,CI,CIM1,B(*),BI,BIM1,T,ZA,Q - LOGICAL KBD - SAVE D1 - DATA D1 /0.0/ - ZA(Q)=CMPLX(ABS(REAL(Q)),ABS(AIMAG(Q))) -C***FIRST EXECUTABLE STATEMENT CPEVL - IF (D1 .EQ. 0.0) D1 = REAL(I1MACH(10))**(1-I1MACH(11)) - NP1=N+1 - DO 1 J=1,NP1 - CI=0.0 - CIM1=A(J) - BI=0.0 - BIM1=0.0 - MINI=MIN(M+1,N+2-J) - DO 1 I=1,MINI - IF(J .NE. 1) CI=C(I) - IF(I .NE. 1) CIM1=C(I-1) - C(I)=CIM1+Z*CI - IF(.NOT. KBD) GO TO 1 - IF(J .NE. 1) BI=B(I) - IF(I .NE. 1) BIM1=B(I-1) - T=BI+(3.*D1+4.*D1*D1)*ZA(CI) - R=REAL(ZA(Z)*CMPLX(REAL(T),-AIMAG(T))) - S=AIMAG(ZA(Z)*T) - B(I)=(1.+8.*D1)*(BIM1+D1*ZA(CIM1)+CMPLX(R,S)) - IF(J .EQ. 1) B(I)=0.0 - 1 CONTINUE - RETURN - END diff --git a/slatec/cpevlr.f b/slatec/cpevlr.f deleted file mode 100644 index 3cecd9e..0000000 --- a/slatec/cpevlr.f +++ /dev/null @@ -1,31 +0,0 @@ -*DECK CPEVLR - SUBROUTINE CPEVLR (N, M, A, X, C) -C***BEGIN PROLOGUE CPEVLR -C***SUBSIDIARY -C***PURPOSE Subsidiary to CPZERO -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (CPEVLR-S) -C***AUTHOR (UNKNOWN) -C***SEE ALSO CPZERO -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 810223 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE CPEVLR - REAL A(*),C(*) -C***FIRST EXECUTABLE STATEMENT CPEVLR - NP1=N+1 - DO 1 J=1,NP1 - CI=0.0 - CIM1=A(J) - MINI=MIN(M+1,N+2-J) - DO 1 I=1,MINI - IF(J .NE. 1) CI=C(I) - IF(I .NE. 1) CIM1=C(I-1) - C(I)=CIM1+X*CI - 1 CONTINUE - RETURN - END diff --git a/slatec/cpoco.f b/slatec/cpoco.f deleted file mode 100644 index 7b5d6dc..0000000 --- a/slatec/cpoco.f +++ /dev/null @@ -1,212 +0,0 @@ -*DECK CPOCO - SUBROUTINE CPOCO (A, LDA, N, RCOND, Z, INFO) -C***BEGIN PROLOGUE CPOCO -C***PURPOSE Factor a complex Hermitian positive definite matrix -C and estimate the condition number of the matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2D1B -C***TYPE COMPLEX (SPOCO-S, DPOCO-D, CPOCO-C) -C***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, -C MATRIX FACTORIZATION, POSITIVE DEFINITE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C CPOCO factors a complex Hermitian positive definite matrix -C and estimates the condition of the matrix. -C -C If RCOND is not needed, CPOFA is slightly faster. -C To solve A*X = B , follow CPOCO by CPOSL. -C To compute INVERSE(A)*C , follow CPOCO by CPOSL. -C To compute DETERMINANT(A) , follow CPOCO by CPODI. -C To compute INVERSE(A) , follow CPOCO by CPODI. -C -C On Entry -C -C A COMPLEX(LDA, N) -C the Hermitian matrix to be factored. Only the -C diagonal and upper triangle are used. -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 R so that A = -C CTRANS(R)*R where CTRANS(R) is the conjugate -C transpose. The strict lower triangle is unaltered. -C If INFO .NE. 0 , the factorization is not complete. -C -C RCOND REAL -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. If INFO .NE. 0 , RCOND is unchanged. -C -C Z COMPLEX(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 If INFO .NE. 0 , Z is unchanged. -C -C INFO INTEGER -C = 0 for normal return. -C = K signals an error condition. The leading minor -C of order K is not positive definite. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CDOTC, CPOFA, CSSCAL, SCASUM -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CPOCO - INTEGER LDA,N,INFO - COMPLEX A(LDA,*),Z(*) - REAL RCOND -C - COMPLEX CDOTC,EK,T,WK,WKM - REAL ANORM,S,SCASUM,SM,YNORM - INTEGER I,J,JM1,K,KB,KP1 - COMPLEX ZDUM,ZDUM2,CSIGN1 - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) - CSIGN1(ZDUM,ZDUM2) = CABS1(ZDUM)*(ZDUM2/CABS1(ZDUM2)) -C -C FIND NORM OF A USING ONLY UPPER HALF -C -C***FIRST EXECUTABLE STATEMENT CPOCO - DO 30 J = 1, N - Z(J) = CMPLX(SCASUM(J,A(1,J),1),0.0E0) - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 20 - DO 10 I = 1, JM1 - Z(I) = CMPLX(REAL(Z(I))+CABS1(A(I,J)),0.0E0) - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - ANORM = 0.0E0 - DO 40 J = 1, N - ANORM = MAX(ANORM,REAL(Z(J))) - 40 CONTINUE -C -C FACTOR -C - CALL CPOFA(A,LDA,N,INFO) - IF (INFO .NE. 0) GO TO 180 -C -C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . -C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . -C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL -C GROWTH IN THE ELEMENTS OF W WHERE CTRANS(R)*W = E . -C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. -C -C SOLVE CTRANS(R)*W = E -C - EK = (1.0E0,0.0E0) - DO 50 J = 1, N - Z(J) = (0.0E0,0.0E0) - 50 CONTINUE - DO 110 K = 1, N - IF (CABS1(Z(K)) .NE. 0.0E0) EK = CSIGN1(EK,-Z(K)) - IF (CABS1(EK-Z(K)) .LE. REAL(A(K,K))) GO TO 60 - S = REAL(A(K,K))/CABS1(EK-Z(K)) - CALL CSSCAL(N,S,Z,1) - EK = CMPLX(S,0.0E0)*EK - 60 CONTINUE - WK = EK - Z(K) - WKM = -EK - Z(K) - S = CABS1(WK) - SM = CABS1(WKM) - WK = WK/A(K,K) - WKM = WKM/A(K,K) - KP1 = K + 1 - IF (KP1 .GT. N) GO TO 100 - DO 70 J = KP1, N - SM = SM + CABS1(Z(J)+WKM*CONJG(A(K,J))) - Z(J) = Z(J) + WK*CONJG(A(K,J)) - S = S + CABS1(Z(J)) - 70 CONTINUE - IF (S .GE. SM) GO TO 90 - T = WKM - WK - WK = WKM - DO 80 J = KP1, N - Z(J) = Z(J) + T*CONJG(A(K,J)) - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - Z(K) = WK - 110 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) -C -C SOLVE R*Y = W -C - DO 130 KB = 1, N - K = N + 1 - KB - IF (CABS1(Z(K)) .LE. REAL(A(K,K))) GO TO 120 - S = REAL(A(K,K))/CABS1(Z(K)) - CALL CSSCAL(N,S,Z,1) - 120 CONTINUE - Z(K) = Z(K)/A(K,K) - T = -Z(K) - CALL CAXPY(K-1,T,A(1,K),1,Z(1),1) - 130 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) -C - YNORM = 1.0E0 -C -C SOLVE CTRANS(R)*V = Y -C - DO 150 K = 1, N - Z(K) = Z(K) - CDOTC(K-1,A(1,K),1,Z(1),1) - IF (CABS1(Z(K)) .LE. REAL(A(K,K))) GO TO 140 - S = REAL(A(K,K))/CABS1(Z(K)) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM - 140 CONTINUE - Z(K) = Z(K)/A(K,K) - 150 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE R*Z = V -C - DO 170 KB = 1, N - K = N + 1 - KB - IF (CABS1(Z(K)) .LE. REAL(A(K,K))) GO TO 160 - S = REAL(A(K,K))/CABS1(Z(K)) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM - 160 CONTINUE - Z(K) = Z(K)/A(K,K) - T = -Z(K) - CALL CAXPY(K-1,T,A(1,K),1,Z(1),1) - 170 CONTINUE -C MAKE ZNORM = 1.0 - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM -C - IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM - IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0 - 180 CONTINUE - RETURN - END diff --git a/slatec/cpodi.f b/slatec/cpodi.f deleted file mode 100644 index 47e2c3d..0000000 --- a/slatec/cpodi.f +++ /dev/null @@ -1,136 +0,0 @@ -*DECK CPODI - SUBROUTINE CPODI (A, LDA, N, DET, JOB) -C***BEGIN PROLOGUE CPODI -C***PURPOSE Compute the determinant and inverse of a certain complex -C Hermitian positive definite matrix using the factors -C computed by CPOCO, CPOFA, or CQRDC. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2D1B, D3D1B -C***TYPE COMPLEX (SPODI-S, DPODI-D, CPODI-C) -C***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, -C POSITIVE DEFINITE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C CPODI computes the determinant and inverse of a certain -C complex Hermitian positive definite matrix (see below) -C using the factors computed by CPOCO, CPOFA or CQRDC. -C -C On Entry -C -C A COMPLEX(LDA, N) -C the output A from CPOCO or CPOFA -C or the output X from CQRDC. -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 JOB INTEGER -C = 11 both determinant and inverse. -C = 01 inverse only. -C = 10 determinant only. -C -C On Return -C -C A If CPOCO or CPOFA was used to factor A then -C CPODI produces the upper half of INVERSE(A) . -C If CQRDC was used to decompose X then -C CPODI produces the upper half of INVERSE(CTRANS(X)*X) -C where CTRANS(X) is the conjugate transpose. -C Elements of A below the diagonal are unchanged. -C If the units digit of JOB is zero, A is unchanged. -C -C DET REAL(2) -C determinant of A or of CTRANS(X)*X if requested. -C Otherwise not referenced. -C Determinant = DET(1) * 10.0**DET(2) -C with 1.0 .LE. 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 CPOCO or CPOFA has set INFO .EQ. 0 . -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CSCAL -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CPODI - INTEGER LDA,N,JOB - COMPLEX A(LDA,*) - REAL DET(2) -C - COMPLEX T - REAL S - INTEGER I,J,JM1,K,KP1 -C***FIRST EXECUTABLE STATEMENT CPODI -C -C COMPUTE DETERMINANT -C - IF (JOB/10 .EQ. 0) GO TO 70 - DET(1) = 1.0E0 - DET(2) = 0.0E0 - S = 10.0E0 - DO 50 I = 1, N - DET(1) = REAL(A(I,I))**2*DET(1) - IF (DET(1) .EQ. 0.0E0) GO TO 60 - 10 IF (DET(1) .GE. 1.0E0) GO TO 20 - DET(1) = S*DET(1) - DET(2) = DET(2) - 1.0E0 - GO TO 10 - 20 CONTINUE - 30 IF (DET(1) .LT. S) GO TO 40 - DET(1) = DET(1)/S - DET(2) = DET(2) + 1.0E0 - GO TO 30 - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE -C -C COMPUTE INVERSE(R) -C - IF (MOD(JOB,10) .EQ. 0) GO TO 140 - DO 100 K = 1, N - A(K,K) = (1.0E0,0.0E0)/A(K,K) - T = -A(K,K) - CALL CSCAL(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.0E0,0.0E0) - CALL CAXPY(K,T,A(1,K),1,A(1,J),1) - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE -C -C FORM INVERSE(R) * CTRANS(INVERSE(R)) -C - DO 130 J = 1, N - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 120 - DO 110 K = 1, JM1 - T = CONJG(A(K,J)) - CALL CAXPY(K,T,A(1,J),1,A(1,K),1) - 110 CONTINUE - 120 CONTINUE - T = CONJG(A(J,J)) - CALL CSCAL(J,T,A(1,J),1) - 130 CONTINUE - 140 CONTINUE - RETURN - END diff --git a/slatec/cpofa.f b/slatec/cpofa.f deleted file mode 100644 index 5117532..0000000 --- a/slatec/cpofa.f +++ /dev/null @@ -1,81 +0,0 @@ -*DECK CPOFA - SUBROUTINE CPOFA (A, LDA, N, INFO) -C***BEGIN PROLOGUE CPOFA -C***PURPOSE Factor a complex Hermitian positive definite matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2D1B -C***TYPE COMPLEX (SPOFA-S, DPOFA-D, CPOFA-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, -C POSITIVE DEFINITE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C CPOFA factors a complex Hermitian positive definite matrix. -C -C CPOFA is usually called by CPOCO, but it can be called -C directly with a saving in time if RCOND is not needed. -C (Time for CPOCO) = (1 + 18/N)*(Time for CPOFA) . -C -C On Entry -C -C A COMPLEX(LDA, N) -C the Hermitian matrix to be factored. Only the -C diagonal and upper triangle are used. -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 R so that A = -C CTRANS(R)*R where CTRANS(R) is the conjugate -C transpose. The strict lower triangle is unaltered. -C If INFO .NE. 0 , the factorization is not complete. -C -C INFO INTEGER -C = 0 for normal return. -C = K signals an error condition. The leading minor -C of order K is not positive definite. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CDOTC -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CPOFA - INTEGER LDA,N,INFO - COMPLEX A(LDA,*) -C - COMPLEX CDOTC,T - REAL S - INTEGER J,JM1,K -C***FIRST EXECUTABLE STATEMENT CPOFA - DO 30 J = 1, N - INFO = J - S = 0.0E0 - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 20 - DO 10 K = 1, JM1 - T = A(K,J) - CDOTC(K-1,A(1,K),1,A(1,J),1) - T = T/A(K,K) - A(K,J) = T - S = S + REAL(T*CONJG(T)) - 10 CONTINUE - 20 CONTINUE - S = REAL(A(J,J)) - S - IF (S .LE. 0.0E0 .OR. AIMAG(A(J,J)) .NE. 0.0E0) GO TO 40 - A(J,J) = CMPLX(SQRT(S),0.0E0) - 30 CONTINUE - INFO = 0 - 40 CONTINUE - RETURN - END diff --git a/slatec/cpofs.f b/slatec/cpofs.f deleted file mode 100644 index ce03b0c..0000000 --- a/slatec/cpofs.f +++ /dev/null @@ -1,168 +0,0 @@ -*DECK CPOFS - SUBROUTINE CPOFS (A, LDA, N, V, ITASK, IND, WORK) -C***BEGIN PROLOGUE CPOFS -C***PURPOSE Solve a positive definite symmetric complex system of -C linear equations. -C***LIBRARY SLATEC -C***CATEGORY D2D1B -C***TYPE COMPLEX (SPOFS-S, DPOFS-D, CPOFS-C) -C***KEYWORDS HERMITIAN, LINEAR EQUATIONS, POSITIVE DEFINITE, SYMMETRIC -C***AUTHOR Voorhees, E. A., (LANL) -C***DESCRIPTION -C -C Subroutine CPOFS solves a positive definite symmetric -C NxN system of complex linear equations using LINPACK -C subroutines CPOCO and CPOSL. That is, if A is an NxN -C complex positive definite symmetric matrix and if X and B -C are complex N-vectors, then CPOFS solves the equation -C -C A*X=B. -C -C Care should be taken not to use CPOFS with a non-Hermitian -C matrix. -C -C The matrix A is first factored into upper and lower tri- -C angular matrices R and R-TRANSPOSE. These factors are used to -C find the solution vector X. An approximate condition number is -C calculated to provide a rough estimate of the number of -C digits of accuracy in the computed solution. -C -C If the equation A*X=B is to be solved for more than one vector -C B, the factoring of a does not need to be performed again and -C the option to only solve (ITASK .GT. 1) will be faster for -C the succeeding solutions. In this case, the contents of A, -C LDA, and N must not have been altered by the user following -C factorization (ITASK=1). IND will not be changed by CPOFS -C in this case. -C -C Argument Description *** -C -C A COMPLEX(LDA,N) -C on entry, the doubly subscripted array with dimension -C (LDA,N) which contains the coefficient matrix. Only -C the upper triangle, including the diagonal, of the -C coefficient matrix need be entered and will subse- -C quently be referenced and changed by the routine. -C on return, contains in its upper triangle an upper -C triangular matrix R such that A = (R-TRANSPOSE) * R . -C LDA INTEGER -C the leading dimension of the array A. LDA must be great- -C er than or equal to N. (terminal error message IND=-1) -C N INTEGER -C the order of the matrix A. N must be greater -C than or equal to 1. (terminal error message IND=-2) -C V COMPLEX(N) -C on entry the singly subscripted array(vector) of di- -C mension N which contains the right hand side B of a -C system of simultaneous linear equations A*X=B. -C on return, V contains the solution vector, X . -C ITASK INTEGER -C if ITASK = 1, the matrix A is factored and then the -C linear equation is solved. -C if ITASK .GT. 1, the equation is solved using the existing -C factored matrix A. -C if ITASK .LT. 1, then terminal error message IND=-3 is -C printed. -C IND INTEGER -C GT. 0 IND is a rough estimate of the number of digits -C of accuracy in the solution, X. -C LT. 0 see error message corresponding to IND below. -C WORK COMPLEX(N) -C a singly subscripted array of dimension at least N. -C -C Error Messages Printed *** -C -C IND=-1 terminal N is greater than LDA. -C IND=-2 terminal N is less than 1. -C IND=-3 terminal ITASK is less than 1. -C IND=-4 terminal The matrix A is computationally singular or -C is not positive definite. A solution -C has not been computed. -C IND=-10 warning The solution has no apparent significance. -C The solution may be inaccurate or the -C matrix A may be poorly scaled. -C -C NOTE- The above terminal(*fatal*) error messages are -C designed to be handled by XERMSG in which -C LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 -C for warning error messages from XERMSG. Unless -C the user provides otherwise, an error message -C will be printed followed by an abort. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CPOCO, CPOSL, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800516 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900510 Convert XERRWV calls to XERMSG calls, cvt GOTO's to -C IF-THEN-ELSE. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CPOFS -C - INTEGER LDA,N,ITASK,IND,INFO - COMPLEX A(LDA,*),V(*),WORK(*) - REAL R1MACH - REAL RCOND - CHARACTER*8 XERN1, XERN2 -C***FIRST EXECUTABLE STATEMENT CPOFS - IF (LDA.LT.N) THEN - IND = -1 - WRITE (XERN1, '(I8)') LDA - WRITE (XERN2, '(I8)') N - CALL XERMSG ('SLATEC', 'CPOFS', 'LDA = ' // XERN1 // - * ' IS LESS THAN N = ' // XERN2, -1, 1) - RETURN - ENDIF -C - IF (N.LE.0) THEN - IND = -2 - WRITE (XERN1, '(I8)') N - CALL XERMSG ('SLATEC', 'CPOFS', 'N = ' // XERN1 // - * ' IS LESS THAN 1', -2, 1) - RETURN - ENDIF -C - IF (ITASK.LT.1) THEN - IND = -3 - WRITE (XERN1, '(I8)') ITASK - CALL XERMSG ('SLATEC', 'CPOFS', 'ITASK = ' // XERN1 // - * ' IS LESS THAN 1', -3, 1) - RETURN - ENDIF -C - IF (ITASK.EQ.1) THEN -C -C FACTOR MATRIX A INTO R -C - CALL CPOCO(A,LDA,N,RCOND,WORK,INFO) -C -C CHECK FOR POSITIVE DEFINITE MATRIX -C - IF (INFO.NE.0) THEN - IND = -4 - CALL XERMSG ('SLATEC', 'CPOFS', - * 'SINGULAR OR NOT POSITIVE DEFINITE - NO SOLUTION', -4, 1) - RETURN - ENDIF -C -C COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) -C AND CHECK FOR IND GREATER THAN ZERO -C - IND = -LOG10(R1MACH(4)/RCOND) - IF (IND.LE.0) THEN - IND = -10 - CALL XERMSG ('SLATEC', 'CPOFS', - * 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) - ENDIF - ENDIF -C -C SOLVE AFTER FACTORING -C - CALL CPOSL(A,LDA,N,V) - RETURN - END diff --git a/slatec/cpoir.f b/slatec/cpoir.f deleted file mode 100644 index 3b9dbb5..0000000 --- a/slatec/cpoir.f +++ /dev/null @@ -1,207 +0,0 @@ -*DECK CPOIR - SUBROUTINE CPOIR (A, LDA, N, V, ITASK, IND, WORK) -C***BEGIN PROLOGUE CPOIR -C***PURPOSE Solve a positive definite Hermitian system of linear -C equations. Iterative refinement is used to obtain an -C error estimate. -C***LIBRARY SLATEC -C***CATEGORY D2D1B -C***TYPE COMPLEX (SPOIR-S, CPOIR-C) -C***KEYWORDS HERMITIAN, LINEAR EQUATIONS, POSITIVE DEFINITE, SYMMETRIC -C***AUTHOR Voorhees, E. A., (LANL) -C***DESCRIPTION -C -C Subroutine CPOIR solves a complex positive definite Hermitian -C NxN system of single precision linear equations using LINPACK -C subroutines CPOFA and CPOSL. One pass of iterative refine- -C ment is used only to obtain an estimate of the accuracy. That -C is, if A is an NxN complex positive definite Hermitian matrix -C and if X and B are complex N-vectors, then CPOIR solves the -C equation -C -C A*X=B. -C -C Care should be taken not to use CPOIR with a non-Hermitian -C matrix. -C -C The matrix A is first factored into upper and lower -C triangular matrices R and R-TRANSPOSE. These -C factors are used to calculate the solution, X. -C Then the residual vector is found and used -C to calculate an estimate of the relative error, IND. -C IND estimates the accuracy of the solution only when the -C input matrix and the right hand side are represented -C exactly in the computer and does not take into account -C any errors in the input data. -C -C If the equation A*X=B is to be solved for more than one vector -C B, the factoring of A does not need to be performed again and -C the option to only solve (ITASK .GT. 1) will be faster for -C the succeeding solutions. In this case, the contents of A, -C LDA, N, and WORK must not have been altered by the user -C following factorization (ITASK=1). IND will not be changed -C by CPOIR in this case. -C -C Argument Description *** -C A COMPLEX(LDA,N) -C the doubly subscripted array with dimension (LDA,N) -C which contains the coefficient matrix. Only the -C upper triangle, including the diagonal, of the -C coefficient matrix need be entered. A is not -C altered by the routine. -C LDA INTEGER -C the leading dimension of the array A. LDA must be great- -C er than or equal to N. (terminal error message IND=-1) -C N INTEGER -C the order of the matrix A. N must be greater than -C or equal to one. (terminal error message IND=-2) -C V COMPLEX(N) -C on entry, the singly subscripted array(vector) of di- -C mension N which contains the right hand side B of a -C system of simultaneous linear equations A*X=B. -C on return, V contains the solution vector, X . -C ITASK INTEGER -C if ITASK = 1, the matrix A is factored and then the -C linear equation is solved. -C if ITASK .GT. 1, the equation is solved using the existing -C factored matrix A (stored in WORK). -C if ITASK .LT. 1, then terminal terminal error IND=-3 is -C printed. -C IND INTEGER -C GT. 0 IND is a rough estimate of the number of digits -C of accuracy in the solution, X. IND=75 means -C that the solution vector X is zero. -C LT. 0 see error message corresponding to IND below. -C WORK COMPLEX(N*(N+1)) -C a singly subscripted array of dimension at least N*(N+1). -C -C Error Messages Printed *** -C -C IND=-1 terminal N is greater than LDA. -C IND=-2 terminal N is less than one. -C IND=-3 terminal ITASK is less than one. -C IND=-4 terminal The matrix A is computationally singular -C or is not positive definite. -C A solution has not been computed. -C IND=-10 warning The solution has no apparent significance. -C the solution may be inaccurate or the matrix -C a may be poorly scaled. -C -C NOTE- the above terminal(*fatal*) error messages are -C designed to be handled by XERMSG in which -C LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 -C for warning error messages from XERMSG. Unless -C the user provides otherwise, an error message -C will be printed followed by an abort. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CCOPY, CPOFA, CPOSL, DCDOT, R1MACH, SCASUM, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800530 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900510 Convert XERRWV calls to XERMSG calls, cvt GOTO's to -C IF-THEN-ELSE. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CPOIR -C - INTEGER LDA,N,ITASK,IND,INFO,J - COMPLEX A(LDA,*),V(*),WORK(N,*) - REAL SCASUM,XNORM,DNORM,R1MACH - DOUBLE PRECISION DR1,DI1,DR2,DI2 - CHARACTER*8 XERN1, XERN2 -C***FIRST EXECUTABLE STATEMENT CPOIR - IF (LDA.LT.N) THEN - IND = -1 - WRITE (XERN1, '(I8)') LDA - WRITE (XERN2, '(I8)') N - CALL XERMSG ('SLATEC', 'CPOIR', 'LDA = ' // XERN1 // - * ' IS LESS THAN N = ' // XERN2, -1, 1) - RETURN - ENDIF -C - IF (N.LE.0) THEN - IND = -2 - WRITE (XERN1, '(I8)') N - CALL XERMSG ('SLATEC', 'CPOIR', 'N = ' // XERN1 // - * ' IS LESS THAN 1', -2, 1) - RETURN - ENDIF -C - IF (ITASK.LT.1) THEN - IND = -3 - WRITE (XERN1, '(I8)') ITASK - CALL XERMSG ('SLATEC', 'CPOIR', 'ITASK = ' // XERN1 // - * ' IS LESS THAN 1', -3, 1) - RETURN - ENDIF -C - IF (ITASK.EQ.1) THEN -C -C MOVE MATRIX A TO WORK -C - DO 10 J=1,N - CALL CCOPY(N,A(1,J),1,WORK(1,J),1) - 10 CONTINUE -C -C FACTOR MATRIX A INTO R -C - CALL CPOFA(WORK,N,N,INFO) -C -C CHECK FOR SINGULAR OR NOT POS.DEF. MATRIX -C - IF (INFO.NE.0) THEN - IND = -4 - CALL XERMSG ('SLATEC', 'CPOIR', - * 'SINGULAR OR NOT POSITIVE DEFINITE - NO SOLUTION', -4, 1) - RETURN - ENDIF - ENDIF -C -C SOLVE AFTER FACTORING -C MOVE VECTOR B TO WORK -C - CALL CCOPY(N,V(1),1,WORK(1,N+1),1) - CALL CPOSL(WORK,N,N,V) -C -C FORM NORM OF X0 -C - XNORM = SCASUM(N,V(1),1) - IF (XNORM.EQ.0.0) THEN - IND = 75 - RETURN - ENDIF -C -C COMPUTE RESIDUAL -C - DO 40 J=1,N - CALL DCDOT(J-1,-1.D0,A(1,J),1,V(1),1,DR1,DI1) - CALL DCDOT(N-J+1,1.D0,A(J,J),LDA,V(J),1,DR2,DI2) - DR1 = DR1+DR2-DBLE(REAL(WORK(J,N+1))) - DI1 = DI1+DI2-DBLE(AIMAG(WORK(J,N+1))) - WORK(J,N+1) = CMPLX(REAL(DR1),REAL(DI1)) - 40 CONTINUE -C -C SOLVE A*DELTA=R -C - CALL CPOSL(WORK,N,N,WORK(1,N+1)) -C -C FORM NORM OF DELTA -C - DNORM = SCASUM(N,WORK(1,N+1),1) -C -C COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) -C AND CHECK FOR IND GREATER THAN ZERO -C - IND = -LOG10(MAX(R1MACH(4),DNORM/XNORM)) - IF (IND.LE.0) THEN - IND = -10 - CALL XERMSG ('SLATEC', 'CPOIR', - * 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) - ENDIF - RETURN - END diff --git a/slatec/cposl.f b/slatec/cposl.f deleted file mode 100644 index a5404d0..0000000 --- a/slatec/cposl.f +++ /dev/null @@ -1,86 +0,0 @@ -*DECK CPOSL - SUBROUTINE CPOSL (A, LDA, N, B) -C***BEGIN PROLOGUE CPOSL -C***PURPOSE Solve the complex Hermitian positive definite linear system -C using the factors computed by CPOCO or CPOFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2D1B -C***TYPE COMPLEX (SPOSL-S, DPOSL-D, CPOSL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, POSITIVE DEFINITE, SOLVE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C CPOSL solves the COMPLEX Hermitian positive definite system -C A * X = B -C using the factors computed by CPOCO or CPOFA. -C -C On Entry -C -C A COMPLEX(LDA, N) -C the output from CPOCO or CPOFA. -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 B COMPLEX(N) -C the right hand side vector. -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 -C a zero on the diagonal. Technically this indicates -C singularity but it is usually caused by improper subroutine -C arguments. It will not occur if the subroutines are called -C correctly and INFO .EQ. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL CPOCO(A,LDA,N,RCOND,Z,INFO) -C IF (RCOND is too small .OR. INFO .NE. 0) GO TO ... -C DO 10 J = 1, P -C CALL CPOSL(A,LDA,N,C(1,J)) -C 10 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CDOTC -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CPOSL - INTEGER LDA,N - COMPLEX A(LDA,*),B(*) -C - COMPLEX CDOTC,T - INTEGER K,KB -C -C SOLVE CTRANS(R)*Y = B -C -C***FIRST EXECUTABLE STATEMENT CPOSL - DO 10 K = 1, N - T = CDOTC(K-1,A(1,K),1,B(1),1) - B(K) = (B(K) - T)/A(K,K) - 10 CONTINUE -C -C SOLVE R*X = Y -C - DO 20 KB = 1, N - K = N + 1 - KB - B(K) = B(K)/A(K,K) - T = -B(K) - CALL CAXPY(K-1,T,A(1,K),1,B(1),1) - 20 CONTINUE - RETURN - END diff --git a/slatec/cppco.f b/slatec/cppco.f deleted file mode 100644 index 6b4fdb8..0000000 --- a/slatec/cppco.f +++ /dev/null @@ -1,237 +0,0 @@ -*DECK CPPCO - SUBROUTINE CPPCO (AP, N, RCOND, Z, INFO) -C***BEGIN PROLOGUE CPPCO -C***PURPOSE Factor a complex Hermitian positive definite matrix stored -C in packed form and estimate the condition number of the -C matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2D1B -C***TYPE COMPLEX (SPPCO-S, DPPCO-D, CPPCO-C) -C***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, -C MATRIX FACTORIZATION, PACKED, POSITIVE DEFINITE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C CPPCO factors a complex Hermitian positive definite matrix -C stored in packed form and estimates the condition of the matrix. -C -C If RCOND is not needed, CPPFA is slightly faster. -C To solve A*X = B , follow CPPCO by CPPSL. -C To compute INVERSE(A)*C , follow CPPCO by CPPSL. -C To compute DETERMINANT(A) , follow CPPCO by CPPDI. -C To compute INVERSE(A) , follow CPPCO by CPPDI. -C -C On Entry -C -C AP COMPLEX (N*(N+1)/2) -C the packed form of a Hermitian matrix A . The -C columns of the upper triangle are stored sequentially -C in a one-dimensional array of length N*(N+1)/2 . -C See comments below for details. -C -C N INTEGER -C the order of the matrix A . -C -C On Return -C -C AP an upper triangular matrix R , stored in packed -C form, so that A = CTRANS(R)*R . -C If INFO .NE. 0 , the factorization is not complete. -C -C RCOND REAL -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. If INFO .NE. 0 , RCOND is unchanged. -C -C Z COMPLEX(N) -C a work vector whose contents are usually unimportant. -C If A is singular to working precision, then Z is -C an approximate null vector in the sense that -C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . -C If INFO .NE. 0 , Z is unchanged. -C -C INFO INTEGER -C = 0 for normal return. -C = K signals an error condition. The leading minor -C of order K is not positive definite. -C -C Packed Storage -C -C The following program segment will pack the upper -C triangle of a Hermitian matrix. -C -C K = 0 -C DO 20 J = 1, N -C DO 10 I = 1, J -C K = K + 1 -C AP(K) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CDOTC, CPPFA, CSSCAL, SCASUM -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CPPCO - INTEGER N,INFO - COMPLEX AP(*),Z(*) - REAL RCOND -C - COMPLEX CDOTC,EK,T,WK,WKM - REAL ANORM,S,SCASUM,SM,YNORM - INTEGER I,IJ,J,JM1,J1,K,KB,KJ,KK,KP1 - COMPLEX ZDUM,ZDUM2,CSIGN1 - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) - CSIGN1(ZDUM,ZDUM2) = CABS1(ZDUM)*(ZDUM2/CABS1(ZDUM2)) -C -C FIND NORM OF A -C -C***FIRST EXECUTABLE STATEMENT CPPCO - J1 = 1 - DO 30 J = 1, N - Z(J) = CMPLX(SCASUM(J,AP(J1),1),0.0E0) - IJ = J1 - J1 = J1 + J - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 20 - DO 10 I = 1, JM1 - Z(I) = CMPLX(REAL(Z(I))+CABS1(AP(IJ)),0.0E0) - IJ = IJ + 1 - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - ANORM = 0.0E0 - DO 40 J = 1, N - ANORM = MAX(ANORM,REAL(Z(J))) - 40 CONTINUE -C -C FACTOR -C - CALL CPPFA(AP,N,INFO) - IF (INFO .NE. 0) GO TO 180 -C -C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . -C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . -C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL -C GROWTH IN THE ELEMENTS OF W WHERE CTRANS(R)*W = E . -C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. -C -C SOLVE CTRANS(R)*W = E -C - EK = (1.0E0,0.0E0) - DO 50 J = 1, N - Z(J) = (0.0E0,0.0E0) - 50 CONTINUE - KK = 0 - DO 110 K = 1, N - KK = KK + K - IF (CABS1(Z(K)) .NE. 0.0E0) EK = CSIGN1(EK,-Z(K)) - IF (CABS1(EK-Z(K)) .LE. REAL(AP(KK))) GO TO 60 - S = REAL(AP(KK))/CABS1(EK-Z(K)) - CALL CSSCAL(N,S,Z,1) - EK = CMPLX(S,0.0E0)*EK - 60 CONTINUE - WK = EK - Z(K) - WKM = -EK - Z(K) - S = CABS1(WK) - SM = CABS1(WKM) - WK = WK/AP(KK) - WKM = WKM/AP(KK) - KP1 = K + 1 - KJ = KK + K - IF (KP1 .GT. N) GO TO 100 - DO 70 J = KP1, N - SM = SM + CABS1(Z(J)+WKM*CONJG(AP(KJ))) - Z(J) = Z(J) + WK*CONJG(AP(KJ)) - S = S + CABS1(Z(J)) - KJ = KJ + J - 70 CONTINUE - IF (S .GE. SM) GO TO 90 - T = WKM - WK - WK = WKM - KJ = KK + K - DO 80 J = KP1, N - Z(J) = Z(J) + T*CONJG(AP(KJ)) - KJ = KJ + J - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - Z(K) = WK - 110 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) -C -C SOLVE R*Y = W -C - DO 130 KB = 1, N - K = N + 1 - KB - IF (CABS1(Z(K)) .LE. REAL(AP(KK))) GO TO 120 - S = REAL(AP(KK))/CABS1(Z(K)) - CALL CSSCAL(N,S,Z,1) - 120 CONTINUE - Z(K) = Z(K)/AP(KK) - KK = KK - K - T = -Z(K) - CALL CAXPY(K-1,T,AP(KK+1),1,Z(1),1) - 130 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) -C - YNORM = 1.0E0 -C -C SOLVE CTRANS(R)*V = Y -C - DO 150 K = 1, N - Z(K) = Z(K) - CDOTC(K-1,AP(KK+1),1,Z(1),1) - KK = KK + K - IF (CABS1(Z(K)) .LE. REAL(AP(KK))) GO TO 140 - S = REAL(AP(KK))/CABS1(Z(K)) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM - 140 CONTINUE - Z(K) = Z(K)/AP(KK) - 150 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE R*Z = V -C - DO 170 KB = 1, N - K = N + 1 - KB - IF (CABS1(Z(K)) .LE. REAL(AP(KK))) GO TO 160 - S = REAL(AP(KK))/CABS1(Z(K)) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM - 160 CONTINUE - Z(K) = Z(K)/AP(KK) - KK = KK - K - T = -Z(K) - CALL CAXPY(K-1,T,AP(KK+1),1,Z(1),1) - 170 CONTINUE -C MAKE ZNORM = 1.0 - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM -C - IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM - IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0 - 180 CONTINUE - RETURN - END diff --git a/slatec/cppdi.f b/slatec/cppdi.f deleted file mode 100644 index 1256c11..0000000 --- a/slatec/cppdi.f +++ /dev/null @@ -1,142 +0,0 @@ -*DECK CPPDI - SUBROUTINE CPPDI (AP, N, DET, JOB) -C***BEGIN PROLOGUE CPPDI -C***PURPOSE Compute the determinant and inverse of a complex Hermitian -C positive definite matrix using factors from CPPCO or CPPFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2D1B, D3D1B -C***TYPE COMPLEX (SPPDI-S, DPPDI-D, CPPDI-C) -C***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, -C PACKED, POSITIVE DEFINITE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C CPPDI computes the determinant and inverse -C of a complex Hermitian positive definite matrix -C using the factors computed by CPPCO or CPPFA . -C -C On Entry -C -C AP COMPLEX (N*(N+1)/2) -C the output from CPPCO or CPPFA. -C -C N INTEGER -C the order of the matrix A . -C -C JOB INTEGER -C = 11 both determinant and inverse. -C = 01 inverse only. -C = 10 determinant only. -C -C On Return -C -C AP the upper triangular half of the inverse . -C The strict lower triangle is unaltered. -C -C DET REAL(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. 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 CPOCO or CPOFA has set INFO .EQ. 0 . -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CSCAL -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CPPDI - INTEGER N,JOB - COMPLEX AP(*) - REAL DET(2) -C - COMPLEX T - REAL S - INTEGER I,II,J,JJ,JM1,J1,K,KJ,KK,KP1,K1 -C***FIRST EXECUTABLE STATEMENT CPPDI -C -C COMPUTE DETERMINANT -C - IF (JOB/10 .EQ. 0) GO TO 70 - DET(1) = 1.0E0 - DET(2) = 0.0E0 - S = 10.0E0 - II = 0 - DO 50 I = 1, N - II = II + I - DET(1) = REAL(AP(II))**2*DET(1) - IF (DET(1) .EQ. 0.0E0) GO TO 60 - 10 IF (DET(1) .GE. 1.0E0) GO TO 20 - DET(1) = S*DET(1) - DET(2) = DET(2) - 1.0E0 - GO TO 10 - 20 CONTINUE - 30 IF (DET(1) .LT. S) GO TO 40 - DET(1) = DET(1)/S - DET(2) = DET(2) + 1.0E0 - GO TO 30 - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE -C -C COMPUTE INVERSE(R) -C - IF (MOD(JOB,10) .EQ. 0) GO TO 140 - KK = 0 - DO 100 K = 1, N - K1 = KK + 1 - KK = KK + K - AP(KK) = (1.0E0,0.0E0)/AP(KK) - T = -AP(KK) - CALL CSCAL(K-1,T,AP(K1),1) - KP1 = K + 1 - J1 = KK + 1 - KJ = KK + K - IF (N .LT. KP1) GO TO 90 - DO 80 J = KP1, N - T = AP(KJ) - AP(KJ) = (0.0E0,0.0E0) - CALL CAXPY(K,T,AP(K1),1,AP(J1),1) - J1 = J1 + J - KJ = KJ + J - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE -C -C FORM INVERSE(R) * CTRANS(INVERSE(R)) -C - JJ = 0 - DO 130 J = 1, N - J1 = JJ + 1 - JJ = JJ + J - JM1 = J - 1 - K1 = 1 - KJ = J1 - IF (JM1 .LT. 1) GO TO 120 - DO 110 K = 1, JM1 - T = CONJG(AP(KJ)) - CALL CAXPY(K,T,AP(J1),1,AP(K1),1) - K1 = K1 + K - KJ = KJ + 1 - 110 CONTINUE - 120 CONTINUE - T = CONJG(AP(JJ)) - CALL CSCAL(J,T,AP(J1),1) - 130 CONTINUE - 140 CONTINUE - RETURN - END diff --git a/slatec/cppfa.f b/slatec/cppfa.f deleted file mode 100644 index b925a14..0000000 --- a/slatec/cppfa.f +++ /dev/null @@ -1,100 +0,0 @@ -*DECK CPPFA - SUBROUTINE CPPFA (AP, N, INFO) -C***BEGIN PROLOGUE CPPFA -C***PURPOSE Factor a complex Hermitian positive definite matrix stored -C in packed form. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2D1B -C***TYPE COMPLEX (SPPFA-S, DPPFA-D, CPPFA-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, PACKED, -C POSITIVE DEFINITE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C CPPFA factors a complex Hermitian positive definite matrix -C stored in packed form. -C -C CPPFA is usually called by CPPCO, but it can be called -C directly with a saving in time if RCOND is not needed. -C (Time for CPPCO) = (1 + 18/N)*(Time for CPPFA) . -C -C On Entry -C -C AP COMPLEX (N*(N+1)/2) -C the packed form of a Hermitian matrix A . The -C columns of the upper triangle are stored sequentially -C in a one-dimensional array of length N*(N+1)/2 . -C See comments below for details. -C -C N INTEGER -C the order of the matrix A . -C -C On Return -C -C AP an upper triangular matrix R , stored in packed -C form, so that A = CTRANS(R)*R . -C -C INFO INTEGER -C = 0 for normal return. -C = K If the leading minor of order K is not -C positive definite. -C -C -C Packed Storage -C -C The following program segment will pack the upper -C triangle of a Hermitian matrix. -C -C K = 0 -C DO 20 J = 1, N -C DO 10 I = 1, J -C K = K + 1 -C AP(K) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CDOTC -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CPPFA - INTEGER N,INFO - COMPLEX AP(*) -C - COMPLEX CDOTC,T - REAL S - INTEGER J,JJ,JM1,K,KJ,KK -C***FIRST EXECUTABLE STATEMENT CPPFA - JJ = 0 - DO 30 J = 1, N - INFO = J - S = 0.0E0 - JM1 = J - 1 - KJ = JJ - KK = 0 - IF (JM1 .LT. 1) GO TO 20 - DO 10 K = 1, JM1 - KJ = KJ + 1 - T = AP(KJ) - CDOTC(K-1,AP(KK+1),1,AP(JJ+1),1) - KK = KK + K - T = T/AP(KK) - AP(KJ) = T - S = S + REAL(T*CONJG(T)) - 10 CONTINUE - 20 CONTINUE - JJ = JJ + J - S = REAL(AP(JJ)) - S - IF (S .LE. 0.0E0 .OR. AIMAG(AP(JJ)) .NE. 0.0E0) GO TO 40 - AP(JJ) = CMPLX(SQRT(S),0.0E0) - 30 CONTINUE - INFO = 0 - 40 CONTINUE - RETURN - END diff --git a/slatec/cppsl.f b/slatec/cppsl.f deleted file mode 100644 index b5f823e..0000000 --- a/slatec/cppsl.f +++ /dev/null @@ -1,81 +0,0 @@ -*DECK CPPSL - SUBROUTINE CPPSL (AP, N, B) -C***BEGIN PROLOGUE CPPSL -C***PURPOSE Solve the complex Hermitian positive definite system using -C the factors computed by CPPCO or CPPFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2D1B -C***TYPE COMPLEX (SPPSL-S, DPPSL-D, CPPSL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, PACKED, -C POSITIVE DEFINITE, SOLVE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C CPPSL solves the complex Hermitian positive definite system -C A * X = B -C using the factors computed by CPPCO or CPPFA. -C -C On Entry -C -C AP COMPLEX (N*(N+1)/2) -C the output from CPPCO or CPPFA. -C -C N INTEGER -C the order of the matrix A . -C -C B COMPLEX(N) -C the right hand side vector. -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 -C a zero on the diagonal. Technically this indicates -C singularity but it is usually caused by improper subroutine -C arguments. It will not occur if the subroutines are called -C correctly and INFO .EQ. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL CPPCO(AP,N,RCOND,Z,INFO) -C IF (RCOND is too small .OR. INFO .NE. 0) GO TO ... -C DO 10 J = 1, P -C CALL CPPSL(AP,N,C(1,J)) -C 10 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CDOTC -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CPPSL - INTEGER N - COMPLEX AP(*),B(*) -C - COMPLEX CDOTC,T - INTEGER K,KB,KK -C***FIRST EXECUTABLE STATEMENT CPPSL - KK = 0 - DO 10 K = 1, N - T = CDOTC(K-1,AP(KK+1),1,B(1),1) - KK = KK + K - B(K) = (B(K) - T)/AP(KK) - 10 CONTINUE - DO 20 KB = 1, N - K = N + 1 - KB - B(K) = B(K)/AP(KK) - KK = KK - K - T = -B(K) - CALL CAXPY(K-1,T,AP(KK+1),1,B(1),1) - 20 CONTINUE - RETURN - END diff --git a/slatec/cpqr79.f b/slatec/cpqr79.f deleted file mode 100644 index cb19f07..0000000 --- a/slatec/cpqr79.f +++ /dev/null @@ -1,110 +0,0 @@ -*DECK CPQR79 - SUBROUTINE CPQR79 (NDEG, COEFF, ROOT, IERR, WORK) -C***BEGIN PROLOGUE CPQR79 -C***PURPOSE Find the zeros of a polynomial with complex coefficients. -C***LIBRARY SLATEC -C***CATEGORY F1A1B -C***TYPE COMPLEX (RPQR79-S, CPQR79-C) -C***KEYWORDS COMPLEX POLYNOMIAL, POLYNOMIAL ROOTS, POLYNOMIAL ZEROS -C***AUTHOR Vandevender, W. H., (SNLA) -C***DESCRIPTION -C -C Abstract -C This routine computes all zeros of a polynomial of degree NDEG -C with complex coefficients by computing the eigenvalues of the -C companion matrix. -C -C Description of Parameters -C The user must dimension all arrays appearing in the call list -C COEFF(NDEG+1), ROOT(NDEG), WORK(2*NDEG*(NDEG+1)) -C -C --Input-- -C NDEG degree of polynomial -C -C COEFF COMPLEX coefficients in descending order. i.e., -C P(Z)= COEFF(1)*(Z**NDEG) + COEFF(NDEG)*Z + COEFF(NDEG+1) -C -C WORK REAL work array of dimension at least 2*NDEG*(NDEG+1) -C -C --Output-- -C ROOT COMPLEX vector of roots -C -C IERR Output Error Code -C - Normal Code -C 0 means the roots were computed. -C - Abnormal Codes -C 1 more than 30 QR iterations on some eigenvalue of the -C companion matrix -C 2 COEFF(1)=0.0 -C 3 NDEG is invalid (less than or equal to 0) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED COMQR, XERMSG -C***REVISION HISTORY (YYMMDD) -C 791201 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 911010 Code reworked and simplified. (RWC and WRB) -C***END PROLOGUE CPQR79 - COMPLEX COEFF(*), ROOT(*), SCALE, C - REAL WORK(*) - INTEGER NDEG, IERR, K, KHR, KHI, KWR, KWI, KAD, KJ -C***FIRST EXECUTABLE STATEMENT CPQR79 - IERR = 0 - IF (ABS(COEFF(1)) .EQ. 0.0) THEN - IERR = 2 - CALL XERMSG ('SLATEC', 'CPQR79', - + 'LEADING COEFFICIENT IS ZERO.', 2, 1) - RETURN - ENDIF -C - IF (NDEG .LE. 0) THEN - IERR = 3 - CALL XERMSG ('SLATEC', 'CPQR79', 'DEGREE INVALID.', 3, 1) - RETURN - ENDIF -C - IF (NDEG .EQ. 1) THEN - ROOT(1) = -COEFF(2)/COEFF(1) - RETURN - ENDIF -C - SCALE = 1.0E0/COEFF(1) - KHR = 1 - KHI = KHR+NDEG*NDEG - KWR = KHI+KHI-KHR - KWI = KWR+NDEG -C - DO 10 K=1,KWR - WORK(K) = 0.0E0 - 10 CONTINUE -C - DO 20 K=1,NDEG - KAD = (K-1)*NDEG+1 - C = SCALE*COEFF(K+1) - WORK(KAD) = -REAL(C) - KJ = KHI+KAD-1 - WORK(KJ) = -AIMAG(C) - IF (K .NE. NDEG) WORK(KAD+K) = 1.0E0 - 20 CONTINUE -C - CALL COMQR (NDEG,NDEG,1,NDEG,WORK(KHR),WORK(KHI),WORK(KWR), - 1 WORK(KWI),IERR) -C - IF (IERR .NE. 0) THEN - IERR = 1 - CALL XERMSG ('SLATEC', 'CPQR79', - + 'NO CONVERGENCE IN 30 QR ITERATIONS.', 1, 1) - RETURN - ENDIF -C - DO 30 K=1,NDEG - KM1 = K-1 - ROOT(K) = CMPLX(WORK(KWR+KM1),WORK(KWI+KM1)) - 30 CONTINUE - RETURN - END diff --git a/slatec/cproc.f b/slatec/cproc.f deleted file mode 100644 index 8bbe38b..0000000 --- a/slatec/cproc.f +++ /dev/null @@ -1,112 +0,0 @@ -*DECK CPROC - SUBROUTINE CPROC (ND, BD, NM1, BM1, NM2, BM2, NA, AA, X, Y, M, A, - + B, C, D, W, YY) -C***BEGIN PROLOGUE CPROC -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBLKTR -C***LIBRARY SLATEC -C***TYPE COMPLEX (CPROD-S, CPROC-C) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C PROC applies a sequence of matrix operations to the vector X and -C stores the result in Y. -C AA Array containing scalar multipliers of the vector X. -C ND,NM1,NM2 are the lengths of the arrays BD,BM1,BM2 respectively. -C BD,BM1,BM2 are arrays containing roots of certain B polynomials. -C NA is the length of the array AA. -C X,Y The matrix operations are applied to X and the result is Y. -C A,B,C are arrays which contain the tridiagonal matrix. -C M is the order of the matrix. -C D,W are work arrays. -C ISGN determines whether or not a change in sign is made. -C -C***SEE ALSO CBLKTR -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE CPROC -C - COMPLEX Y ,D ,W ,BD , - 1 CRT ,DEN ,Y1 ,Y2 , - 2 X ,A ,B ,C - DIMENSION A(*) ,B(*) ,C(*) ,X(*) , - 1 Y(*) ,D(*) ,W(*) ,BD(*) , - 2 BM1(*) ,BM2(*) ,AA(*) ,YY(*) -C***FIRST EXECUTABLE STATEMENT CPROC - DO 101 J=1,M - Y(J) = X(J) - 101 CONTINUE - MM = M-1 - ID = ND - M1 = NM1 - M2 = NM2 - IA = NA - 102 IFLG = 0 - IF (ID) 109,109,103 - 103 CRT = BD(ID) - ID = ID-1 -C -C BEGIN SOLUTION TO SYSTEM -C - D(M) = A(M)/(B(M)-CRT) - W(M) = Y(M)/(B(M)-CRT) - DO 104 J=2,MM - K = M-J - DEN = B(K+1)-CRT-C(K+1)*D(K+2) - D(K+1) = A(K+1)/DEN - W(K+1) = (Y(K+1)-C(K+1)*W(K+2))/DEN - 104 CONTINUE - DEN = B(1)-CRT-C(1)*D(2) - IF (ABS(DEN)) 105,106,105 - 105 Y(1) = (Y(1)-C(1)*W(2))/DEN - GO TO 107 - 106 Y(1) = (1.,0.) - 107 DO 108 J=2,M - Y(J) = W(J)-D(J)*Y(J-1) - 108 CONTINUE - 109 IF (M1) 110,110,112 - 110 IF (M2) 121,121,111 - 111 RT = BM2(M2) - M2 = M2-1 - GO TO 117 - 112 IF (M2) 113,113,114 - 113 RT = BM1(M1) - M1 = M1-1 - GO TO 117 - 114 IF (ABS(BM1(M1))-ABS(BM2(M2))) 116,116,115 - 115 RT = BM1(M1) - M1 = M1-1 - GO TO 117 - 116 RT = BM2(M2) - M2 = M2-1 - 117 Y1 = (B(1)-RT)*Y(1)+C(1)*Y(2) - IF (MM-2) 120,118,118 -C -C MATRIX MULTIPLICATION -C - 118 DO 119 J=2,MM - Y2 = A(J)*Y(J-1)+(B(J)-RT)*Y(J)+C(J)*Y(J+1) - Y(J-1) = Y1 - Y1 = Y2 - 119 CONTINUE - 120 Y(M) = A(M)*Y(M-1)+(B(M)-RT)*Y(M) - Y(M-1) = Y1 - IFLG = 1 - GO TO 102 - 121 IF (IA) 124,124,122 - 122 RT = AA(IA) - IA = IA-1 - IFLG = 1 -C -C SCALAR MULTIPLICATION -C - DO 123 J=1,M - Y(J) = RT*Y(J) - 123 CONTINUE - 124 IF (IFLG) 125,125,102 - 125 RETURN - END diff --git a/slatec/cprocp.f b/slatec/cprocp.f deleted file mode 100644 index 4a756ff..0000000 --- a/slatec/cprocp.f +++ /dev/null @@ -1,134 +0,0 @@ -*DECK CPROCP - SUBROUTINE CPROCP (ND, BD, NM1, BM1, NM2, BM2, NA, AA, X, Y, M, A, - + B, C, D, U, YY) -C***BEGIN PROLOGUE CPROCP -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBLKTR -C***LIBRARY SLATEC -C***TYPE COMPLEX (CPRODP-S, CPROCP-C) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C CPROCP applies a sequence of matrix operations to the vector X and -C stores the result in Y. -C -C BD,BM1,BM2 are arrays containing roots of certain B polynomials. -C ND,NM1,NM2 are the lengths of the arrays BD,BM1,BM2 respectively. -C AA Array containing scalar multipliers of the vector X. -C NA is the length of the array AA. -C X,Y The matrix operations are applied to X and the result is Y. -C A,B,C are arrays which contain the tridiagonal matrix. -C M is the order of the matrix. -C D,U are work arrays. -C ISGN determines whether or not a change in sign is made. -C -C***SEE ALSO CBLKTR -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE CPROCP -C - COMPLEX Y ,D ,U ,V , - 1 DEN ,BH ,YM ,AM , - 2 Y1 ,Y2 ,YH ,BD , - 3 CRT ,X ,A ,B ,C - DIMENSION A(*) ,B(*) ,C(*) ,X(*) , - 1 Y(*) ,D(*) ,U(*) ,BD(*) , - 2 BM1(*) ,BM2(*) ,AA(*) ,YY(*) -C***FIRST EXECUTABLE STATEMENT CPROCP - DO 101 J=1,M - Y(J) = X(J) - 101 CONTINUE - MM = M-1 - MM2 = M-2 - ID = ND - M1 = NM1 - M2 = NM2 - IA = NA - 102 IFLG = 0 - IF (ID) 111,111,103 - 103 CRT = BD(ID) - ID = ID-1 - IFLG = 1 -C -C BEGIN SOLUTION TO SYSTEM -C - BH = B(M)-CRT - YM = Y(M) - DEN = B(1)-CRT - D(1) = C(1)/DEN - U(1) = A(1)/DEN - Y(1) = Y(1)/DEN - V = C(M) - IF (MM2-2) 106,104,104 - 104 DO 105 J=2,MM2 - DEN = B(J)-CRT-A(J)*D(J-1) - D(J) = C(J)/DEN - U(J) = -A(J)*U(J-1)/DEN - Y(J) = (Y(J)-A(J)*Y(J-1))/DEN - BH = BH-V*U(J-1) - YM = YM-V*Y(J-1) - V = -V*D(J-1) - 105 CONTINUE - 106 DEN = B(M-1)-CRT-A(M-1)*D(M-2) - D(M-1) = (C(M-1)-A(M-1)*U(M-2))/DEN - Y(M-1) = (Y(M-1)-A(M-1)*Y(M-2))/DEN - AM = A(M)-V*D(M-2) - BH = BH-V*U(M-2) - YM = YM-V*Y(M-2) - DEN = BH-AM*D(M-1) - IF (ABS(DEN)) 107,108,107 - 107 Y(M) = (YM-AM*Y(M-1))/DEN - GO TO 109 - 108 Y(M) = (1.,0.) - 109 Y(M-1) = Y(M-1)-D(M-1)*Y(M) - DO 110 J=2,MM - K = M-J - Y(K) = Y(K)-D(K)*Y(K+1)-U(K)*Y(M) - 110 CONTINUE - 111 IF (M1) 112,112,114 - 112 IF (M2) 123,123,113 - 113 RT = BM2(M2) - M2 = M2-1 - GO TO 119 - 114 IF (M2) 115,115,116 - 115 RT = BM1(M1) - M1 = M1-1 - GO TO 119 - 116 IF (ABS(BM1(M1))-ABS(BM2(M2))) 118,118,117 - 117 RT = BM1(M1) - M1 = M1-1 - GO TO 119 - 118 RT = BM2(M2) - M2 = M2-1 -C -C MATRIX MULTIPLICATION -C - 119 YH = Y(1) - Y1 = (B(1)-RT)*Y(1)+C(1)*Y(2)+A(1)*Y(M) - IF (MM-2) 122,120,120 - 120 DO 121 J=2,MM - Y2 = A(J)*Y(J-1)+(B(J)-RT)*Y(J)+C(J)*Y(J+1) - Y(J-1) = Y1 - Y1 = Y2 - 121 CONTINUE - 122 Y(M) = A(M)*Y(M-1)+(B(M)-RT)*Y(M)+C(M)*YH - Y(M-1) = Y1 - IFLG = 1 - GO TO 102 - 123 IF (IA) 126,126,124 - 124 RT = AA(IA) - IA = IA-1 - IFLG = 1 -C -C SCALAR MULTIPLICATION -C - DO 125 J=1,M - Y(J) = RT*Y(J) - 125 CONTINUE - 126 IF (IFLG) 127,127,102 - 127 RETURN - END diff --git a/slatec/cprod.f b/slatec/cprod.f deleted file mode 100644 index 96ad5c3..0000000 --- a/slatec/cprod.f +++ /dev/null @@ -1,114 +0,0 @@ -*DECK CPROD - SUBROUTINE CPROD (ND, BD, NM1, BM1, NM2, BM2, NA, AA, X, YY, M, A, - + B, C, D, W, Y) -C***BEGIN PROLOGUE CPROD -C***SUBSIDIARY -C***PURPOSE Subsidiary to BLKTRI -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (CPROD-S, CPROC-C) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C PROD applies a sequence of matrix operations to the vector X and -C stores the result in YY. (COMPLEX case) -C AA array containing scalar multipliers of the vector X. -C ND,NM1,NM2 are the lengths of the arrays BD,BM1,BM2 respectively. -C BD,BM1,BM2 are arrays containing roots of certain B polynomials. -C NA is the length of the array AA. -C X,YY The matrix operations are applied to X and the result is YY. -C A,B,C are arrays which contain the tridiagonal matrix. -C M is the order of the matrix. -C D,W,Y are working arrays. -C ISGN determines whether or not a change in sign is made. -C -C***SEE ALSO BLKTRI -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE CPROD -C - COMPLEX Y ,D ,W ,BD , - 1 CRT ,DEN ,Y1 ,Y2 - DIMENSION A(*) ,B(*) ,C(*) ,X(*) , - 1 Y(*) ,D(*) ,W(*) ,BD(*) , - 2 BM1(*) ,BM2(*) ,AA(*) ,YY(*) -C***FIRST EXECUTABLE STATEMENT CPROD - DO 101 J=1,M - Y(J) = CMPLX(X(J),0.) - 101 CONTINUE - MM = M-1 - ID = ND - M1 = NM1 - M2 = NM2 - IA = NA - 102 IFLG = 0 - IF (ID) 109,109,103 - 103 CRT = BD(ID) - ID = ID-1 -C -C BEGIN SOLUTION TO SYSTEM -C - D(M) = A(M)/(B(M)-CRT) - W(M) = Y(M)/(B(M)-CRT) - DO 104 J=2,MM - K = M-J - DEN = B(K+1)-CRT-C(K+1)*D(K+2) - D(K+1) = A(K+1)/DEN - W(K+1) = (Y(K+1)-C(K+1)*W(K+2))/DEN - 104 CONTINUE - DEN = B(1)-CRT-C(1)*D(2) - IF (ABS(DEN)) 105,106,105 - 105 Y(1) = (Y(1)-C(1)*W(2))/DEN - GO TO 107 - 106 Y(1) = (1.,0.) - 107 DO 108 J=2,M - Y(J) = W(J)-D(J)*Y(J-1) - 108 CONTINUE - 109 IF (M1) 110,110,112 - 110 IF (M2) 121,121,111 - 111 RT = BM2(M2) - M2 = M2-1 - GO TO 117 - 112 IF (M2) 113,113,114 - 113 RT = BM1(M1) - M1 = M1-1 - GO TO 117 - 114 IF (ABS(BM1(M1))-ABS(BM2(M2))) 116,116,115 - 115 RT = BM1(M1) - M1 = M1-1 - GO TO 117 - 116 RT = BM2(M2) - M2 = M2-1 - 117 Y1 = (B(1)-RT)*Y(1)+C(1)*Y(2) - IF (MM-2) 120,118,118 -C -C MATRIX MULTIPLICATION -C - 118 DO 119 J=2,MM - Y2 = A(J)*Y(J-1)+(B(J)-RT)*Y(J)+C(J)*Y(J+1) - Y(J-1) = Y1 - Y1 = Y2 - 119 CONTINUE - 120 Y(M) = A(M)*Y(M-1)+(B(M)-RT)*Y(M) - Y(M-1) = Y1 - IFLG = 1 - GO TO 102 - 121 IF (IA) 124,124,122 - 122 RT = AA(IA) - IA = IA-1 - IFLG = 1 -C -C SCALAR MULTIPLICATION -C - DO 123 J=1,M - Y(J) = RT*Y(J) - 123 CONTINUE - 124 IF (IFLG) 125,125,102 - 125 DO 126 J=1,M - YY(J) = REAL(Y(J)) - 126 CONTINUE - RETURN - END diff --git a/slatec/cprodp.f b/slatec/cprodp.f deleted file mode 100644 index 8be7d96..0000000 --- a/slatec/cprodp.f +++ /dev/null @@ -1,138 +0,0 @@ -*DECK CPRODP - SUBROUTINE CPRODP (ND, BD, NM1, BM1, NM2, BM2, NA, AA, X, YY, M, - + A, B, C, D, U, Y) -C***BEGIN PROLOGUE CPRODP -C***SUBSIDIARY -C***PURPOSE Subsidiary to BLKTRI -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (CPRODP-S, CPROCP-C) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C PRODP applies a sequence of matrix operations to the vector X and -C stores the result in YY. (Periodic boundary conditions and COMPLEX -C case) -C -C BD,BM1,BM2 are arrays containing roots of certain B polynomials. -C ND,NM1,NM2 are the lengths of the arrays BD,BM1,BM2 respectively. -C AA Array containing scalar multipliers of the vector X. -C NA is the length of the array AA. -C X,YY The matrix operations are applied to X and the result is YY. -C A,B,C are arrays which contain the tridiagonal matrix. -C M is the order of the matrix. -C D,U,Y are working arrays. -C ISGN determines whether or not a change in sign is made. -C -C***SEE ALSO BLKTRI -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE CPRODP -C - COMPLEX Y ,D ,U ,V , - 1 DEN ,BH ,YM ,AM , - 2 Y1 ,Y2 ,YH ,BD , - 3 CRT - DIMENSION A(*) ,B(*) ,C(*) ,X(*) , - 1 Y(*) ,D(*) ,U(*) ,BD(*) , - 2 BM1(*) ,BM2(*) ,AA(*) ,YY(*) -C***FIRST EXECUTABLE STATEMENT CPRODP - DO 101 J=1,M - Y(J) = CMPLX(X(J),0.) - 101 CONTINUE - MM = M-1 - MM2 = M-2 - ID = ND - M1 = NM1 - M2 = NM2 - IA = NA - 102 IFLG = 0 - IF (ID) 111,111,103 - 103 CRT = BD(ID) - ID = ID-1 - IFLG = 1 -C -C BEGIN SOLUTION TO SYSTEM -C - BH = B(M)-CRT - YM = Y(M) - DEN = B(1)-CRT - D(1) = C(1)/DEN - U(1) = A(1)/DEN - Y(1) = Y(1)/DEN - V = CMPLX(C(M),0.) - IF (MM2-2) 106,104,104 - 104 DO 105 J=2,MM2 - DEN = B(J)-CRT-A(J)*D(J-1) - D(J) = C(J)/DEN - U(J) = -A(J)*U(J-1)/DEN - Y(J) = (Y(J)-A(J)*Y(J-1))/DEN - BH = BH-V*U(J-1) - YM = YM-V*Y(J-1) - V = -V*D(J-1) - 105 CONTINUE - 106 DEN = B(M-1)-CRT-A(M-1)*D(M-2) - D(M-1) = (C(M-1)-A(M-1)*U(M-2))/DEN - Y(M-1) = (Y(M-1)-A(M-1)*Y(M-2))/DEN - AM = A(M)-V*D(M-2) - BH = BH-V*U(M-2) - YM = YM-V*Y(M-2) - DEN = BH-AM*D(M-1) - IF (ABS(DEN)) 107,108,107 - 107 Y(M) = (YM-AM*Y(M-1))/DEN - GO TO 109 - 108 Y(M) = (1.,0.) - 109 Y(M-1) = Y(M-1)-D(M-1)*Y(M) - DO 110 J=2,MM - K = M-J - Y(K) = Y(K)-D(K)*Y(K+1)-U(K)*Y(M) - 110 CONTINUE - 111 IF (M1) 112,112,114 - 112 IF (M2) 123,123,113 - 113 RT = BM2(M2) - M2 = M2-1 - GO TO 119 - 114 IF (M2) 115,115,116 - 115 RT = BM1(M1) - M1 = M1-1 - GO TO 119 - 116 IF (ABS(BM1(M1))-ABS(BM2(M2))) 118,118,117 - 117 RT = BM1(M1) - M1 = M1-1 - GO TO 119 - 118 RT = BM2(M2) - M2 = M2-1 -C -C MATRIX MULTIPLICATION -C - 119 YH = Y(1) - Y1 = (B(1)-RT)*Y(1)+C(1)*Y(2)+A(1)*Y(M) - IF (MM-2) 122,120,120 - 120 DO 121 J=2,MM - Y2 = A(J)*Y(J-1)+(B(J)-RT)*Y(J)+C(J)*Y(J+1) - Y(J-1) = Y1 - Y1 = Y2 - 121 CONTINUE - 122 Y(M) = A(M)*Y(M-1)+(B(M)-RT)*Y(M)+C(M)*YH - Y(M-1) = Y1 - IFLG = 1 - GO TO 102 - 123 IF (IA) 126,126,124 - 124 RT = AA(IA) - IA = IA-1 - IFLG = 1 -C -C SCALAR MULTIPLICATION -C - DO 125 J=1,M - Y(J) = RT*Y(J) - 125 CONTINUE - 126 IF (IFLG) 127,127,102 - 127 DO 128 J=1,M - YY(J) = REAL(Y(J)) - 128 CONTINUE - RETURN - END diff --git a/slatec/cpsi.f b/slatec/cpsi.f deleted file mode 100644 index b7c6f40..0000000 --- a/slatec/cpsi.f +++ /dev/null @@ -1,110 +0,0 @@ -*DECK CPSI - COMPLEX FUNCTION CPSI (ZIN) -C***BEGIN PROLOGUE CPSI -C***PURPOSE Compute the Psi (or Digamma) function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7C -C***TYPE COMPLEX (PSI-S, DPSI-D, CPSI-C) -C***KEYWORDS DIGAMMA FUNCTION, FNLIB, PSI FUNCTION, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C PSI(X) calculates the psi (or digamma) function of X. PSI(X) -C is the logarithmic derivative of the gamma function of X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CCOT, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 780501 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 900727 Added EXTERNAL statement. (WRB) -C***END PROLOGUE CPSI - COMPLEX ZIN, Z, Z2INV, CORR, CCOT - DIMENSION BERN(13) - LOGICAL FIRST - EXTERNAL CCOT - SAVE BERN, PI, NTERM, BOUND, DXREL, RMIN, RBIG, FIRST - DATA BERN( 1) / .8333333333 3333333 E-1 / - DATA BERN( 2) / -.8333333333 3333333 E-2 / - DATA BERN( 3) / .3968253968 2539683 E-2 / - DATA BERN( 4) / -.4166666666 6666667 E-2 / - DATA BERN( 5) / .7575757575 7575758 E-2 / - DATA BERN( 6) / -.2109279609 2796093 E-1 / - DATA BERN( 7) / .8333333333 3333333 E-1 / - DATA BERN( 8) / -.4432598039 2156863 E0 / - DATA BERN( 9) / .3053954330 2701197 E1 / - DATA BERN(10) / -.2645621212 1212121 E2 / - DATA BERN(11) / .2814601449 2753623 E3 / - DATA BERN(12) / -.3454885393 7728938 E4 / - DATA BERN(13) / .5482758333 3333333 E5 / - DATA PI / 3.141592653 589793 E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT CPSI - IF (FIRST) THEN - NTERM = -0.30*LOG(R1MACH(3)) -C MAYBE BOUND = N*(0.1*EPS)**(-1/(2*N-1)) / (PI*EXP(1)) - BOUND = 0.1171*NTERM*(0.1*R1MACH(3))**(-1.0/(2*NTERM-1)) - DXREL = SQRT(R1MACH(4)) - RMIN = EXP (MAX (LOG(R1MACH(1)), -LOG(R1MACH(2))) + 0.011 ) - RBIG = 1.0/R1MACH(3) - ENDIF - FIRST = .FALSE. -C - Z = ZIN - X = REAL(Z) - Y = AIMAG(Z) - IF (Y.LT.0.0) Z = CONJG(Z) -C - CORR = (0.0, 0.0) - CABSZ = ABS(Z) - IF (X.GE.0.0 .AND. CABSZ.GT.BOUND) GO TO 50 - IF (X.LT.0.0 .AND. ABS(Y).GT.BOUND) GO TO 50 -C - IF (CABSZ.LT.BOUND) GO TO 20 -C -C USE THE REFLECTION FORMULA FOR REAL(Z) NEGATIVE, ABS(Z) LARGE, AND -C ABS(AIMAG(Y)) SMALL. -C - CORR = -PI*CCOT(PI*Z) - Z = 1.0 - Z - GO TO 50 -C -C USE THE RECURSION RELATION FOR ABS(Z) SMALL. -C - 20 IF (CABSZ .LT. RMIN) CALL XERMSG ('SLATEC', 'CPSI', - + 'CPSI CALLED WITH Z SO NEAR 0 THAT CPSI OVERFLOWS', 2, 2) -C - IF (X.GE.(-0.5) .OR. ABS(Y).GT.DXREL) GO TO 30 - IF (ABS((Z-AINT(X-0.5))/X) .LT. DXREL) CALL XERMSG ('SLATEC', - + 'CPSI', - + 'ANSWER LT HALF PRECISION BECAUSE Z TOO NEAR NEGATIVE INTEGER', - + 1, 1) - IF (Y .EQ. 0.0 .AND. X .EQ. AINT(X)) CALL XERMSG ('SLATEC', - + 'CPSI', 'Z IS A NEGATIVE INTEGER', 3, 2) -C - 30 N = SQRT(BOUND**2-Y**2) - X + 1.0 - DO 40 I=1,N - CORR = CORR - 1.0/Z - Z = Z + 1.0 - 40 CONTINUE -C -C NOW EVALUATE THE ASYMPTOTIC SERIES FOR SUITABLY LARGE Z. -C - 50 IF (CABSZ.GT.RBIG) CPSI = LOG(Z) + CORR - IF (CABSZ.GT.RBIG) GO TO 70 -C - CPSI = (0.0, 0.0) - Z2INV = 1.0/Z**2 - DO 60 I=1,NTERM - NDX = NTERM + 1 - I - CPSI = BERN(NDX) + Z2INV*CPSI - 60 CONTINUE - CPSI = LOG(Z) - 0.5/Z - CPSI*Z2INV + CORR -C - 70 IF (Y.LT.0.0) CPSI = CONJG(CPSI) -C - RETURN - END diff --git a/slatec/cptsl.f b/slatec/cptsl.f deleted file mode 100644 index 72f6d38..0000000 --- a/slatec/cptsl.f +++ /dev/null @@ -1,106 +0,0 @@ -*DECK CPTSL - SUBROUTINE CPTSL (N, D, E, B) -C***BEGIN PROLOGUE CPTSL -C***PURPOSE Solve a positive definite tridiagonal linear system. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2D2A -C***TYPE COMPLEX (SPTSL-S, DPTSL-D, CPTSL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, POSITIVE DEFINITE, SOLVE, -C TRIDIAGONAL -C***AUTHOR Dongarra, J., (ANL) -C***DESCRIPTION -C -C CPTSL given a positive definite tridiagonal matrix and a right -C hand side will find the solution. -C -C On Entry -C -C N INTEGER -C is the order of the tridiagonal matrix. -C -C D COMPLEX(N) -C is the diagonal of the tridiagonal matrix. -C On output D is destroyed. -C -C E COMPLEX(N) -C is the offdiagonal of the tridiagonal matrix. -C E(1) through E(N-1) should contain the -C offdiagonal. -C -C B COMPLEX(N) -C is the right hand side vector. -C -C On Return -C -C B contains the solution. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890505 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CPTSL - INTEGER N - COMPLEX D(*),E(*),B(*) -C - INTEGER K,KBM1,KE,KF,KP1,NM1,NM1D2 - COMPLEX T1,T2 -C -C CHECK FOR 1 X 1 CASE -C -C***FIRST EXECUTABLE STATEMENT CPTSL - IF (N .NE. 1) GO TO 10 - B(1) = B(1)/D(1) - GO TO 70 - 10 CONTINUE - NM1 = N - 1 - NM1D2 = NM1/2 - IF (N .EQ. 2) GO TO 30 - KBM1 = N - 1 -C -C ZERO TOP HALF OF SUBDIAGONAL AND BOTTOM HALF OF -C SUPERDIAGONAL -C - DO 20 K = 1, NM1D2 - T1 = CONJG(E(K))/D(K) - D(K+1) = D(K+1) - T1*E(K) - B(K+1) = B(K+1) - T1*B(K) - T2 = E(KBM1)/D(KBM1+1) - D(KBM1) = D(KBM1) - T2*CONJG(E(KBM1)) - B(KBM1) = B(KBM1) - T2*B(KBM1+1) - KBM1 = KBM1 - 1 - 20 CONTINUE - 30 CONTINUE - KP1 = NM1D2 + 1 -C -C CLEAN UP FOR POSSIBLE 2 X 2 BLOCK AT CENTER -C - IF (MOD(N,2) .NE. 0) GO TO 40 - T1 = CONJG(E(KP1))/D(KP1) - D(KP1+1) = D(KP1+1) - T1*E(KP1) - B(KP1+1) = B(KP1+1) - T1*B(KP1) - KP1 = KP1 + 1 - 40 CONTINUE -C -C BACK SOLVE STARTING AT THE CENTER, GOING TOWARDS THE TOP -C AND BOTTOM -C - B(KP1) = B(KP1)/D(KP1) - IF (N .EQ. 2) GO TO 60 - K = KP1 - 1 - KE = KP1 + NM1D2 - 1 - DO 50 KF = KP1, KE - B(K) = (B(K) - E(K)*B(K+1))/D(K) - B(KF+1) = (B(KF+1) - CONJG(E(KF))*B(KF))/D(KF+1) - K = K - 1 - 50 CONTINUE - 60 CONTINUE - IF (MOD(N,2) .EQ. 0) B(1) = (B(1) - E(1)*B(2))/D(1) - 70 CONTINUE - RETURN - END diff --git a/slatec/cpzero.f b/slatec/cpzero.f deleted file mode 100644 index 3974fa4..0000000 --- a/slatec/cpzero.f +++ /dev/null @@ -1,140 +0,0 @@ -*DECK CPZERO - SUBROUTINE CPZERO (IN, A, R, T, IFLG, S) -C***BEGIN PROLOGUE CPZERO -C***PURPOSE Find the zeros of a polynomial with complex coefficients. -C***LIBRARY SLATEC -C***CATEGORY F1A1B -C***TYPE COMPLEX (RPZERO-S, CPZERO-C) -C***KEYWORDS POLYNOMIAL ROOTS, POLYNOMIAL ZEROS, REAL ROOTS -C***AUTHOR Kahaner, D. K., (NBS) -C***DESCRIPTION -C -C Find the zeros of the complex polynomial -C P(Z)= A(1)*Z**N + A(2)*Z**(N-1) +...+ A(N+1) -C -C Input... -C IN = degree of P(Z) -C A = complex vector containing coefficients of P(Z), -C A(I) = coefficient of Z**(N+1-i) -C R = N word complex vector containing initial estimates for zeros -C if these are known. -C T = 4(N+1) word array used for temporary storage -C IFLG = flag to indicate if initial estimates of -C zeros are input. -C If IFLG .EQ. 0, no estimates are input. -C If IFLG .NE. 0, the vector R contains estimates of -C the zeros -C ** WARNING ****** If estimates are input, they must -C be separated, that is, distinct or -C not repeated. -C S = an N word array -C -C Output... -C R(I) = Ith zero, -C S(I) = bound for R(I) . -C IFLG = error diagnostic -C Error Diagnostics... -C If IFLG .EQ. 0 on return, all is well -C If IFLG .EQ. 1 on return, A(1)=0.0 or N=0 on input -C If IFLG .EQ. 2 on return, the program failed to converge -C after 25*N iterations. Best current estimates of the -C zeros are in R(I). Error bounds are not calculated. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CPEVL -C***REVISION HISTORY (YYMMDD) -C 810223 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***END PROLOGUE CPZERO -C - REAL S(*) - COMPLEX R(*),T(*),A(*),PN,TEMP -C***FIRST EXECUTABLE STATEMENT CPZERO - IF( IN .LE. 0 .OR. ABS(A(1)) .EQ. 0.0 ) GO TO 30 -C -C CHECK FOR EASILY OBTAINED ZEROS -C - N=IN - N1=N+1 - IF(IFLG .NE. 0) GO TO 14 - 1 N1=N+1 - IF(N .GT. 1) GO TO 2 - R(1)=-A(2)/A(1) - S(1)=0.0 - RETURN - 2 IF( ABS(A(N1)) .NE. 0.0 ) GO TO 3 - R(N)=0.0 - S(N)=0.0 - N=N-1 - GO TO 1 -C -C IF INITIAL ESTIMATES FOR ZEROS NOT GIVEN, FIND SOME -C - 3 TEMP=-A(2)/(A(1)*N) - CALL CPEVL(N,N,A,TEMP,T,T,.FALSE.) - IMAX=N+2 - T(N1)=ABS(T(N1)) - DO 6 I=2,N1 - T(N+I)=-ABS(T(N+2-I)) - IF(REAL(T(N+I)) .LT. REAL(T(IMAX))) IMAX=N+I - 6 CONTINUE - X=(-REAL(T(IMAX))/REAL(T(N1)))**(1./(IMAX-N1)) - 7 X=2.*X - CALL CPEVL(N,0,T(N1),CMPLX(X,0.0),PN,PN,.FALSE.) - IF (REAL(PN).LT.0.) GO TO 7 - U=.5*X - V=X - 10 X=.5*(U+V) - CALL CPEVL(N,0,T(N1),CMPLX(X,0.0),PN,PN,.FALSE.) - IF (REAL(PN).GT.0.) V=X - IF (REAL(PN).LE.0.) U=X - IF((V-U) .GT. .001*(1.+V)) GO TO 10 - DO 13 I=1,N - U=(3.14159265/N)*(2*I-1.5) - 13 R(I)=MAX(X,.001*ABS(TEMP))*CMPLX(COS(U),SIN(U))+TEMP -C -C MAIN ITERATION LOOP STARTS HERE -C - 14 NR=0 - NMAX=25*N - DO 19 NIT=1,NMAX - DO 18 I=1,N - IF(NIT .NE. 1 .AND. ABS(T(I)) .EQ. 0.) GO TO 18 - CALL CPEVL(N,0,A,R(I),PN,TEMP,.TRUE.) - IF(ABS(REAL(PN))+ABS(AIMAG(PN)) .GT. REAL(TEMP)+ - 1 AIMAG(TEMP)) GO TO 16 - T(I)=0.0 - NR=NR+1 - GO TO 18 - 16 TEMP=A(1) - DO 17 J=1,N - 17 IF(J .NE. I) TEMP=TEMP*(R(I)-R(J)) - T(I)=PN/TEMP - 18 CONTINUE - DO 15 I=1,N - 15 R(I)=R(I)-T(I) - IF(NR .EQ. N) GO TO 21 - 19 CONTINUE - GO TO 26 -C -C CALCULATE ERROR BOUNDS FOR ZEROS -C - 21 DO 25 NR=1,N - CALL CPEVL(N,N,A,R(NR),T,T(N+2),.TRUE.) - X=ABS(CMPLX(ABS(REAL(T(1))),ABS(AIMAG(T(1))))+T(N+2)) - S(NR)=0.0 - DO 23 I=1,N - X=X*REAL(N1-I)/I - TEMP=CMPLX(MAX(ABS(REAL(T(I+1)))-REAL(T(N1+I)),0.0), - 1 MAX(ABS(AIMAG(T(I+1)))-AIMAG(T(N1+I)),0.0)) - 23 S(NR)=MAX(S(NR),(ABS(TEMP)/X)**(1./I)) - 25 S(NR)=1./S(NR) - RETURN -C ERROR EXITS - 26 IFLG=2 - RETURN - 30 IFLG=1 - RETURN - END diff --git a/slatec/cqrdc.f b/slatec/cqrdc.f deleted file mode 100644 index caa6b1e..0000000 --- a/slatec/cqrdc.f +++ /dev/null @@ -1,229 +0,0 @@ -*DECK CQRDC - SUBROUTINE CQRDC (X, LDX, N, P, QRAUX, JPVT, WORK, JOB) -C***BEGIN PROLOGUE CQRDC -C***PURPOSE Use Householder transformations to compute the QR -C factorization of an N by P matrix. Column pivoting is a -C users option. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D5 -C***TYPE COMPLEX (SQRDC-S, DQRDC-D, CQRDC-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, ORTHOGONAL TRIANGULAR, -C QR DECOMPOSITION -C***AUTHOR Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C CQRDC uses Householder transformations to compute the QR -C factorization of an N by P matrix X. Column pivoting -C based on the 2-norms of the reduced columns may be -C performed at the users option. -C -C On Entry -C -C X COMPLEX(LDX,P), where LDX .GE. N. -C X contains the matrix whose decomposition is to be -C computed. -C -C LDX INTEGER. -C LDX is the leading dimension of the array X. -C -C N INTEGER. -C N is the number of rows of the matrix X. -C -C P INTEGER. -C P is the number of columns of the matrix X. -C -C JVPT INTEGER(P). -C JVPT contains integers that control the selection -C of the pivot columns. The K-th column X(K) of X -C is placed in one of three classes according to the -C value of JVPT(K). -C -C If JVPT(K) .GT. 0, then X(K) is an initial -C column. -C -C If JVPT(K) .EQ. 0, then X(K) is a free column. -C -C If JVPT(K) .LT. 0, then X(K) is a final column. -C -C Before the decomposition is computed, initial columns -C are moved to the beginning of the array X and final -C columns to the end. Both initial and final columns -C are frozen in place during the computation and only -C free columns are moved. At the K-th stage of the -C reduction, if X(K) is occupied by a free column -C it is interchanged with the free column of largest -C reduced norm. JVPT is not referenced if -C JOB .EQ. 0. -C -C WORK COMPLEX(P). -C WORK is a work array. WORK is not referenced if -C JOB .EQ. 0. -C -C JOB INTEGER. -C JOB is an integer that initiates column pivoting. -C If JOB .EQ. 0, no pivoting is done. -C If JOB .NE. 0, pivoting is done. -C -C On Return -C -C X X contains in its upper triangle the upper -C triangular matrix R of the QR factorization. -C Below its diagonal X contains information from -C which the unitary part of the decomposition -C can be recovered. Note that if pivoting has -C been requested, the decomposition is not that -C of the original matrix X but that of X -C with its columns permuted as described by JVPT. -C -C QRAUX COMPLEX(P). -C QRAUX contains further information required to recover -C the unitary part of the decomposition. -C -C JVPT JVPT(K) contains the index of the column of the -C original matrix that has been interchanged into -C the K-th column, if pivoting was requested. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CDOTC, CSCAL, CSWAP, SCNRM2 -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CQRDC - INTEGER LDX,N,P,JOB - INTEGER JPVT(*) - COMPLEX X(LDX,*),QRAUX(*),WORK(*) -C - INTEGER J,JP,L,LP1,LUP,MAXJ,PL,PU - REAL MAXNRM,SCNRM2,TT - COMPLEX CDOTC,NRMXL,T - LOGICAL NEGJ,SWAPJ - COMPLEX CSIGN,ZDUM,ZDUM1,ZDUM2 - REAL CABS1 - CSIGN(ZDUM1,ZDUM2) = ABS(ZDUM1)*(ZDUM2/ABS(ZDUM2)) - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) -C -C***FIRST EXECUTABLE STATEMENT CQRDC - PL = 1 - PU = 0 - IF (JOB .EQ. 0) GO TO 60 -C -C PIVOTING HAS BEEN REQUESTED. REARRANGE THE COLUMNS -C ACCORDING TO JPVT. -C - DO 20 J = 1, P - SWAPJ = JPVT(J) .GT. 0 - NEGJ = JPVT(J) .LT. 0 - JPVT(J) = J - IF (NEGJ) JPVT(J) = -J - IF (.NOT.SWAPJ) GO TO 10 - IF (J .NE. PL) CALL CSWAP(N,X(1,PL),1,X(1,J),1) - JPVT(J) = JPVT(PL) - JPVT(PL) = J - PL = PL + 1 - 10 CONTINUE - 20 CONTINUE - PU = P - DO 50 JJ = 1, P - J = P - JJ + 1 - IF (JPVT(J) .GE. 0) GO TO 40 - JPVT(J) = -JPVT(J) - IF (J .EQ. PU) GO TO 30 - CALL CSWAP(N,X(1,PU),1,X(1,J),1) - JP = JPVT(PU) - JPVT(PU) = JPVT(J) - JPVT(J) = JP - 30 CONTINUE - PU = PU - 1 - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE -C -C COMPUTE THE NORMS OF THE FREE COLUMNS. -C - IF (PU .LT. PL) GO TO 80 - DO 70 J = PL, PU - QRAUX(J) = CMPLX(SCNRM2(N,X(1,J),1),0.0E0) - WORK(J) = QRAUX(J) - 70 CONTINUE - 80 CONTINUE -C -C PERFORM THE HOUSEHOLDER REDUCTION OF X. -C - LUP = MIN(N,P) - DO 200 L = 1, LUP - IF (L .LT. PL .OR. L .GE. PU) GO TO 120 -C -C LOCATE THE COLUMN OF LARGEST NORM AND BRING IT -C INTO THE PIVOT POSITION. -C - MAXNRM = 0.0E0 - MAXJ = L - DO 100 J = L, PU - IF (REAL(QRAUX(J)) .LE. MAXNRM) GO TO 90 - MAXNRM = REAL(QRAUX(J)) - MAXJ = J - 90 CONTINUE - 100 CONTINUE - IF (MAXJ .EQ. L) GO TO 110 - CALL CSWAP(N,X(1,L),1,X(1,MAXJ),1) - QRAUX(MAXJ) = QRAUX(L) - WORK(MAXJ) = WORK(L) - JP = JPVT(MAXJ) - JPVT(MAXJ) = JPVT(L) - JPVT(L) = JP - 110 CONTINUE - 120 CONTINUE - QRAUX(L) = (0.0E0,0.0E0) - IF (L .EQ. N) GO TO 190 -C -C COMPUTE THE HOUSEHOLDER TRANSFORMATION FOR COLUMN L. -C - NRMXL = CMPLX(SCNRM2(N-L+1,X(L,L),1),0.0E0) - IF (CABS1(NRMXL) .EQ. 0.0E0) GO TO 180 - IF (CABS1(X(L,L)) .NE. 0.0E0) - 1 NRMXL = CSIGN(NRMXL,X(L,L)) - CALL CSCAL(N-L+1,(1.0E0,0.0E0)/NRMXL,X(L,L),1) - X(L,L) = (1.0E0,0.0E0) + X(L,L) -C -C APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS, -C UPDATING THE NORMS. -C - LP1 = L + 1 - IF (P .LT. LP1) GO TO 170 - DO 160 J = LP1, P - T = -CDOTC(N-L+1,X(L,L),1,X(L,J),1)/X(L,L) - CALL CAXPY(N-L+1,T,X(L,L),1,X(L,J),1) - IF (J .LT. PL .OR. J .GT. PU) GO TO 150 - IF (CABS1(QRAUX(J)) .EQ. 0.0E0) GO TO 150 - TT = 1.0E0 - (ABS(X(L,J))/REAL(QRAUX(J)))**2 - TT = MAX(TT,0.0E0) - T = CMPLX(TT,0.0E0) - TT = 1.0E0 - 1 + 0.05E0*TT*(REAL(QRAUX(J))/REAL(WORK(J)))**2 - IF (TT .EQ. 1.0E0) GO TO 130 - QRAUX(J) = QRAUX(J)*SQRT(T) - GO TO 140 - 130 CONTINUE - QRAUX(J) = CMPLX(SCNRM2(N-L,X(L+1,J),1),0.0E0) - WORK(J) = QRAUX(J) - 140 CONTINUE - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE -C -C SAVE THE TRANSFORMATION. -C - QRAUX(L) = X(L,L) - X(L,L) = -NRMXL - 180 CONTINUE - 190 CONTINUE - 200 CONTINUE - RETURN - END diff --git a/slatec/cqrsl.f b/slatec/cqrsl.f deleted file mode 100644 index d55b331..0000000 --- a/slatec/cqrsl.f +++ /dev/null @@ -1,291 +0,0 @@ -*DECK CQRSL - SUBROUTINE CQRSL (X, LDX, N, K, QRAUX, Y, QY, QTY, B, RSD, XB, - + JOB, INFO) -C***BEGIN PROLOGUE CQRSL -C***PURPOSE Apply the output of CQRDC to compute coordinate transfor- -C mations, projections, and least squares solutions. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D9, D2C1 -C***TYPE COMPLEX (SQRSL-S, DQRSL-D, CQRSL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, ORTHOGONAL TRIANGULAR, -C SOLVE -C***AUTHOR Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C CQRSL applies the output of CQRDC to compute coordinate -C transformations, projections, and least squares solutions. -C For K .LE. MIN(N,P), let XK be the matrix -C -C XK = (X(JVPT(1)),X(JVPT(2)), ... ,X(JVPT(K))) -C -C formed from columns JVPT(1), ... ,JVPT(K) of the original -C N x P matrix X that was input to CQRDC (if no pivoting was -C done, XK consists of the first K columns of X in their -C original order). CQRDC produces a factored unitary matrix Q -C and an upper triangular matrix R such that -C -C XK = Q * (R) -C (0) -C -C This information is contained in coded form in the arrays -C X and QRAUX. -C -C On Entry -C -C X COMPLEX(LDX,P). -C X contains the output of CQRDC. -C -C LDX INTEGER. -C LDX is the leading dimension of the array X. -C -C N INTEGER. -C N is the number of rows of the matrix XK. It must -C have the same value as N in CQRDC. -C -C K INTEGER. -C K is the number of columns of the matrix XK. K -C must not be greater than (N,P), where P is the -C same as in the calling sequence to CQRDC. -C -C QRAUX COMPLEX(P). -C QRAUX contains the auxiliary output from CQRDC. -C -C Y COMPLEX(N) -C Y contains an N-vector that is to be manipulated -C by CQRSL. -C -C JOB INTEGER. -C JOB specifies what is to be computed. JOB has -C the decimal expansion ABCDE, with the following -C meaning. -C -C If A .NE. 0, compute QY. -C If B,C,D, or E .NE. 0, compute QTY. -C If C .NE. 0, compute B. -C If D .NE. 0, compute RSD . -C If E .NE. 0, compute XB. -C -C Note that a request to compute B, RSD, or XB -C automatically triggers the computation of QTY, for -C which an array must be provided in the calling -C sequence. -C -C On Return -C -C QY COMPLEX(N). -C QY contains Q*Y, if its computation has been -C requested. -C -C QTY COMPLEX(N). -C QTY contains CTRANS(Q)*Y, if its computation has -C been requested. Here CTRANS(Q) is the conjugate -C transpose of the matrix Q. -C -C B COMPLEX(K) -C B contains the solution of the least squares problem -C -C minimize NORM2(Y - XK*B), -C -C if its computation has been requested. (Note that -C if pivoting was requested in CQRDC, the J-th -C component of B will be associated with column JVPT(J) -C of the original matrix X that was input into CQRDC.) -C -C RSD COMPLEX(N). -C RSD contains the least squares residual Y - XK*B, -C if its computation has been requested. RSD is -C also the orthogonal projection of Y onto the -C orthogonal complement of the column space of XK. -C -C XB COMPLEX(N). -C XB contains the least squares approximation XK*B, -C if its computation has been requested. XB is also -C the orthogonal projection of Y onto the column space -C of X. -C -C INFO INTEGER. -C INFO is zero unless the computation of B has -C been requested and R is exactly singular. In -C this case, INFO is the index of the first zero -C diagonal element of R and B is left unaltered. -C -C The parameters QY, QTY, B, RSD, and XB are not referenced -C if their computation is not requested and in this case -C can be replaced by dummy variables in the calling program. -C To save storage, the user may in some cases use the same -C array for different parameters in the calling sequence. A -C frequently occurring example is when one wishes to compute -C any of B, RSD, or XB and does not need Y or QTY. In this -C case one may identify Y, QTY, and one of B, RSD, or XB, while -C providing separate arrays for anything else that is to be -C computed. Thus the calling sequence -C -C CALL CQRSL(X,LDX,N,K,QRAUX,Y,DUM,Y,B,Y,DUM,110,INFO) -C -C will result in the computation of B and RSD, with RSD -C overwriting Y. More generally, each item in the following -C list contains groups of permissible identifications for -C a single calling sequence. -C -C 1. (Y,QTY,B) (RSD) (XB) (QY) -C -C 2. (Y,QTY,RSD) (B) (XB) (QY) -C -C 3. (Y,QTY,XB) (B) (RSD) (QY) -C -C 4. (Y,QY) (QTY,B) (RSD) (XB) -C -C 5. (Y,QY) (QTY,RSD) (B) (XB) -C -C 6. (Y,QY) (QTY,XB) (B) (RSD) -C -C In any group the value returned in the array allocated to -C the group corresponds to the last member of the group. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CCOPY, CDOTC -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CQRSL - INTEGER LDX,N,K,JOB,INFO - COMPLEX X(LDX,*),QRAUX(*),Y(*),QY(*),QTY(*),B(*),RSD(*),XB(*) -C - INTEGER I,J,JJ,JU,KP1 - COMPLEX CDOTC,T,TEMP - LOGICAL CB,CQY,CQTY,CR,CXB - COMPLEX ZDUM - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) -C***FIRST EXECUTABLE STATEMENT CQRSL -C -C SET INFO FLAG. -C - INFO = 0 -C -C DETERMINE WHAT IS TO BE COMPUTED. -C - CQY = JOB/10000 .NE. 0 - CQTY = MOD(JOB,10000) .NE. 0 - CB = MOD(JOB,1000)/100 .NE. 0 - CR = MOD(JOB,100)/10 .NE. 0 - CXB = MOD(JOB,10) .NE. 0 - JU = MIN(K,N-1) -C -C SPECIAL ACTION WHEN N=1. -C - IF (JU .NE. 0) GO TO 40 - IF (CQY) QY(1) = Y(1) - IF (CQTY) QTY(1) = Y(1) - IF (CXB) XB(1) = Y(1) - IF (.NOT.CB) GO TO 30 - IF (CABS1(X(1,1)) .NE. 0.0E0) GO TO 10 - INFO = 1 - GO TO 20 - 10 CONTINUE - B(1) = Y(1)/X(1,1) - 20 CONTINUE - 30 CONTINUE - IF (CR) RSD(1) = (0.0E0,0.0E0) - GO TO 250 - 40 CONTINUE -C -C SET UP TO COMPUTE QY OR QTY. -C - IF (CQY) CALL CCOPY(N,Y,1,QY,1) - IF (CQTY) CALL CCOPY(N,Y,1,QTY,1) - IF (.NOT.CQY) GO TO 70 -C -C COMPUTE QY. -C - DO 60 JJ = 1, JU - J = JU - JJ + 1 - IF (CABS1(QRAUX(J)) .EQ. 0.0E0) GO TO 50 - TEMP = X(J,J) - X(J,J) = QRAUX(J) - T = -CDOTC(N-J+1,X(J,J),1,QY(J),1)/X(J,J) - CALL CAXPY(N-J+1,T,X(J,J),1,QY(J),1) - X(J,J) = TEMP - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE - IF (.NOT.CQTY) GO TO 100 -C -C COMPUTE CTRANS(Q)*Y. -C - DO 90 J = 1, JU - IF (CABS1(QRAUX(J)) .EQ. 0.0E0) GO TO 80 - TEMP = X(J,J) - X(J,J) = QRAUX(J) - T = -CDOTC(N-J+1,X(J,J),1,QTY(J),1)/X(J,J) - CALL CAXPY(N-J+1,T,X(J,J),1,QTY(J),1) - X(J,J) = TEMP - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE -C -C SET UP TO COMPUTE B, RSD, OR XB. -C - IF (CB) CALL CCOPY(K,QTY,1,B,1) - KP1 = K + 1 - IF (CXB) CALL CCOPY(K,QTY,1,XB,1) - IF (CR .AND. K .LT. N) CALL CCOPY(N-K,QTY(KP1),1,RSD(KP1),1) - IF (.NOT.CXB .OR. KP1 .GT. N) GO TO 120 - DO 110 I = KP1, N - XB(I) = (0.0E0,0.0E0) - 110 CONTINUE - 120 CONTINUE - IF (.NOT.CR) GO TO 140 - DO 130 I = 1, K - RSD(I) = (0.0E0,0.0E0) - 130 CONTINUE - 140 CONTINUE - IF (.NOT.CB) GO TO 190 -C -C COMPUTE B. -C - DO 170 JJ = 1, K - J = K - JJ + 1 - IF (CABS1(X(J,J)) .NE. 0.0E0) GO TO 150 - INFO = J - GO TO 180 - 150 CONTINUE - B(J) = B(J)/X(J,J) - IF (J .EQ. 1) GO TO 160 - T = -B(J) - CALL CAXPY(J-1,T,X(1,J),1,B,1) - 160 CONTINUE - 170 CONTINUE - 180 CONTINUE - 190 CONTINUE - IF (.NOT.CR .AND. .NOT.CXB) GO TO 240 -C -C COMPUTE RSD OR XB AS REQUIRED. -C - DO 230 JJ = 1, JU - J = JU - JJ + 1 - IF (CABS1(QRAUX(J)) .EQ. 0.0E0) GO TO 220 - TEMP = X(J,J) - X(J,J) = QRAUX(J) - IF (.NOT.CR) GO TO 200 - T = -CDOTC(N-J+1,X(J,J),1,RSD(J),1)/X(J,J) - CALL CAXPY(N-J+1,T,X(J,J),1,RSD(J),1) - 200 CONTINUE - IF (.NOT.CXB) GO TO 210 - T = -CDOTC(N-J+1,X(J,J),1,XB(J),1)/X(J,J) - CALL CAXPY(N-J+1,T,X(J,J),1,XB(J),1) - 210 CONTINUE - X(J,J) = TEMP - 220 CONTINUE - 230 CONTINUE - 240 CONTINUE - 250 CONTINUE - RETURN - END diff --git a/slatec/crati.f b/slatec/crati.f deleted file mode 100644 index e1370c9..0000000 --- a/slatec/crati.f +++ /dev/null @@ -1,111 +0,0 @@ -*DECK CRATI - SUBROUTINE CRATI (Z, FNU, N, CY, TOL) -C***BEGIN PROLOGUE CRATI -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBESH, CBESI and CBESK -C***LIBRARY SLATEC -C***TYPE ALL (CRATI-A, ZRATI-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C CRATI COMPUTES RATIOS OF I BESSEL FUNCTIONS BY BACKWARD -C RECURRENCE. THE STARTING INDEX IS DETERMINED BY FORWARD -C RECURRENCE AS DESCRIBED IN J. RES. OF NAT. BUR. OF STANDARDS-B, -C MATHEMATICAL SCIENCES, VOL 77B, P111-114, SEPTEMBER, 1973, -C BESSEL FUNCTIONS I AND J OF COMPLEX ARGUMENT AND INTEGER ORDER, -C BY D. J. SOOKNE. -C -C***SEE ALSO CBESH, CBESI, CBESK -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CRATI - COMPLEX CDFNU, CONE, CY, CZERO, PT, P1, P2, RZ, T1, Z - REAL AK, AMAGZ, AP1, AP2, ARG, AZ, DFNU, FDNU, FLAM, FNU, FNUP, - * RAP1, RHO, TEST, TEST1, TOL - INTEGER I, ID, IDNU, INU, ITIME, K, KK, MAGZ, N - DIMENSION CY(N) - DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) / -C***FIRST EXECUTABLE STATEMENT CRATI - AZ = ABS(Z) - INU = FNU - IDNU = INU + N - 1 - FDNU = IDNU - MAGZ = AZ - AMAGZ = MAGZ+1 - FNUP = MAX(AMAGZ,FDNU) - ID = IDNU - MAGZ - 1 - ITIME = 1 - K = 1 - RZ = (CONE+CONE)/Z - T1 = CMPLX(FNUP,0.0E0)*RZ - P2 = -T1 - P1 = CONE - T1 = T1 + RZ - IF (ID.GT.0) ID = 0 - AP2 = ABS(P2) - AP1 = ABS(P1) -C----------------------------------------------------------------------- -C THE OVERFLOW TEST ON K(FNU+I-1,Z) BEFORE THE CALL TO CBKNX -C GUARANTEES THAT P2 IS ON SCALE. SCALE TEST1 AND ALL SUBSEQUENT -C P2 VALUES BY AP1 TO ENSURE THAT AN OVERFLOW DOES NOT OCCUR -C PREMATURELY. -C----------------------------------------------------------------------- - ARG = (AP2+AP2)/(AP1*TOL) - TEST1 = SQRT(ARG) - TEST = TEST1 - RAP1 = 1.0E0/AP1 - P1 = P1*CMPLX(RAP1,0.0E0) - P2 = P2*CMPLX(RAP1,0.0E0) - AP2 = AP2*RAP1 - 10 CONTINUE - K = K + 1 - AP1 = AP2 - PT = P2 - P2 = P1 - T1*P2 - P1 = PT - T1 = T1 + RZ - AP2 = ABS(P2) - IF (AP1.LE.TEST) GO TO 10 - IF (ITIME.EQ.2) GO TO 20 - AK = ABS(T1)*0.5E0 - FLAM = AK + SQRT(AK*AK-1.0E0) - RHO = MIN(AP2/AP1,FLAM) - TEST = TEST1*SQRT(RHO/(RHO*RHO-1.0E0)) - ITIME = 2 - GO TO 10 - 20 CONTINUE - KK = K + 1 - ID - AK = KK - DFNU = FNU + (N-1) - CDFNU = CMPLX(DFNU,0.0E0) - T1 = CMPLX(AK,0.0E0) - P1 = CMPLX(1.0E0/AP2,0.0E0) - P2 = CZERO - DO 30 I=1,KK - PT = P1 - P1 = RZ*(CDFNU+T1)*P1 + P2 - P2 = PT - T1 = T1 - CONE - 30 CONTINUE - IF (REAL(P1).NE.0.0E0 .OR. AIMAG(P1).NE.0.0E0) GO TO 40 - P1 = CMPLX(TOL,TOL) - 40 CONTINUE - CY(N) = P2/P1 - IF (N.EQ.1) RETURN - K = N - 1 - AK = K - T1 = CMPLX(AK,0.0E0) - CDFNU = CMPLX(FNU,0.0E0)*RZ - DO 60 I=2,N - PT = CDFNU + T1*RZ + CY(K+1) - IF (REAL(PT).NE.0.0E0 .OR. AIMAG(PT).NE.0.0E0) GO TO 50 - PT = CMPLX(TOL,TOL) - 50 CONTINUE - CY(K) = CONE/PT - T1 = T1 - CONE - K = K - 1 - 60 CONTINUE - RETURN - END diff --git a/slatec/crotg.f b/slatec/crotg.f deleted file mode 100644 index b202c34..0000000 --- a/slatec/crotg.f +++ /dev/null @@ -1,60 +0,0 @@ -*DECK CROTG - SUBROUTINE CROTG (CA, CB, C, S) -C***BEGIN PROLOGUE CROTG -C***PURPOSE Construct a Givens transformation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B10 -C***TYPE COMPLEX (SROTG-S, DROTG-D, CROTG-C) -C***KEYWORDS BLAS, GIVENS ROTATION, GIVENS TRANSFORMATION, -C LINEAR ALGEBRA, VECTOR -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Complex Givens transformation -C -C Construct the Givens transformation -C -C (C S) -C G = ( ), C**2 + ABS(S)**2 =1, -C (-S C) -C -C which zeros the second entry of the complex 2-vector (CA,CB)**T -C -C The quantity CA/ABS(CA)*NORM(CA,CB) overwrites CA in storage. -C -C Input: -C CA (Complex) -C CB (Complex) -C -C Output: -C CA (Complex) CA/ABS(CA)*NORM(CA,CB) -C C (Real) -C S (Complex) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790101 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***END PROLOGUE CROTG - COMPLEX CA, CB, S - REAL C - REAL NORM, SCALE - COMPLEX ALPHA -C***FIRST EXECUTABLE STATEMENT CROTG - IF (ABS(CA) .EQ. 0.0) THEN - C = 0.0 - S = (1.0,0.0) - CA = CB - ELSE - SCALE = ABS(CA) + ABS(CB) - NORM = SCALE * SQRT((ABS(CA/SCALE))**2 + (ABS(CB/SCALE))**2) - ALPHA = CA /ABS(CA) - C = ABS(CA) / NORM - S = ALPHA * CONJG(CB) / NORM - CA = ALPHA * NORM - ENDIF - RETURN - END diff --git a/slatec/cs1s2.f b/slatec/cs1s2.f deleted file mode 100644 index aa60995..0000000 --- a/slatec/cs1s2.f +++ /dev/null @@ -1,55 +0,0 @@ -*DECK CS1S2 - SUBROUTINE CS1S2 (ZR, S1, S2, NZ, ASCLE, ALIM, IUF) -C***BEGIN PROLOGUE CS1S2 -C***SUBSIDIARY -C***PURPOSE Subsidiary to CAIRY and CBESK -C***LIBRARY SLATEC -C***TYPE ALL (CS1S2-A, ZS1S2-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C CS1S2 TESTS FOR A POSSIBLE UNDERFLOW RESULTING FROM THE -C ADDITION OF THE I AND K FUNCTIONS IN THE ANALYTIC CON- -C TINUATION FORMULA WHERE S1=K FUNCTION AND S2=I FUNCTION. -C ON KODE=1 THE I AND K FUNCTIONS ARE DIFFERENT ORDERS OF -C MAGNITUDE, BUT FOR KODE=2 THEY CAN BE OF THE SAME ORDER -C OF MAGNITUDE AND THE MAXIMUM MUST BE AT LEAST ONE -C PRECISION ABOVE THE UNDERFLOW LIMIT. -C -C***SEE ALSO CAIRY, CBESK -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CS1S2 - COMPLEX CZERO, C1, S1, S1D, S2, ZR - REAL AA, ALIM, ALN, ASCLE, AS1, AS2, XX - INTEGER IUF, NZ - DATA CZERO / (0.0E0,0.0E0) / -C***FIRST EXECUTABLE STATEMENT CS1S2 - NZ = 0 - AS1 = ABS(S1) - AS2 = ABS(S2) - AA = REAL(S1) - ALN = AIMAG(S1) - IF (AA.EQ.0.0E0 .AND. ALN.EQ.0.0E0) GO TO 10 - IF (AS1.EQ.0.0E0) GO TO 10 - XX = REAL(ZR) - ALN = -XX - XX + ALOG(AS1) - S1D = S1 - S1 = CZERO - AS1 = 0.0E0 - IF (ALN.LT.(-ALIM)) GO TO 10 - C1 = CLOG(S1D) - ZR - ZR - S1 = CEXP(C1) - AS1 = ABS(S1) - IUF = IUF + 1 - 10 CONTINUE - AA = MAX(AS1,AS2) - IF (AA.GT.ASCLE) RETURN - S1 = CZERO - S2 = CZERO - NZ = 1 - IUF = 0 - RETURN - END diff --git a/slatec/cscal.f b/slatec/cscal.f deleted file mode 100644 index e0da47a..0000000 --- a/slatec/cscal.f +++ /dev/null @@ -1,68 +0,0 @@ -*DECK CSCAL - SUBROUTINE CSCAL (N, CA, CX, INCX) -C***BEGIN PROLOGUE CSCAL -C***PURPOSE Multiply a vector by a constant. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A6 -C***TYPE COMPLEX (SSCAL-S, DSCAL-D, CSCAL-C) -C***KEYWORDS BLAS, LINEAR ALGEBRA, SCALE, 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 CA complex scale factor -C CX complex vector with N elements -C INCX storage spacing between elements of CX -C -C --Output-- -C CX complex result (unchanged if N .LE. 0) -C -C Replace complex CX by complex CA*CX. -C For I = 0 to N-1, replace CX(IX+I*INCX) with CA*CX(IX+I*INCX), -C where IX = 1 if INCX .GE. 0, else IX = 1+(1-N)*INCX. -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 900821 Modified to correct problem with a negative increment. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CSCAL - COMPLEX CA, CX(*) - INTEGER I, INCX, IX, N -C***FIRST EXECUTABLE STATEMENT CSCAL - IF (N .LE. 0) RETURN -C - IF (INCX .EQ. 1) GOTO 20 -C -C Code for increment not equal to 1. -C - IX = 1 - IF (INCX .LT. 0) IX = (-N+1)*INCX + 1 - DO 10 I = 1,N - CX(IX) = CA*CX(IX) - IX = IX + INCX - 10 CONTINUE - RETURN -C -C Code for increment equal to 1. -C - 20 DO 30 I = 1,N - CX(I) = CA*CX(I) - 30 CONTINUE - RETURN - END diff --git a/slatec/cscale.f b/slatec/cscale.f deleted file mode 100644 index 477c0e2..0000000 --- a/slatec/cscale.f +++ /dev/null @@ -1,74 +0,0 @@ -*DECK CSCALE - SUBROUTINE CSCALE (A, NRDA, NROW, NCOL, COLS, COLSAV, ROWS, - + ROWSAV, ANORM, SCALES, ISCALE, IC) -C***BEGIN PROLOGUE CSCALE -C***SUBSIDIARY -C***PURPOSE Subsidiary to BVSUP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (CSCALE-S, DCSCAL-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C This routine scales the matrix A by columns when needed -C -C***SEE ALSO BVSUP -C***ROUTINES CALLED SDOT -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE CSCALE - DIMENSION A(NRDA,*),COLS(*),COLSAV(*),SCALES(*), - 1 ROWS(*),ROWSAV(*) -C - SAVE TEN4, TEN20 - DATA TEN4,TEN20/1.E+4,1.E+20/ -C -C***FIRST EXECUTABLE STATEMENT CSCALE - IF (ISCALE .NE. (-1)) GO TO 25 -C - IF (IC .EQ. 0) GO TO 10 - DO 5 K=1,NCOL - 5 COLS(K)=SDOT(NROW,A(1,K),1,A(1,K),1) -C - 10 ASCALE=ANORM/NCOL - DO 20 K=1,NCOL - CS=COLS(K) - IF ((CS .GT. TEN4*ASCALE) .OR. (TEN4*CS .LT. ASCALE)) GO TO 50 - IF ((CS .LT. 1./TEN20) .OR. (CS .GT. TEN20)) GO TO 50 - 20 CONTINUE -C - 25 DO 30 K=1,NCOL - 30 SCALES(K)=1. - RETURN -C - 50 ALOG2=LOG(2.) - ANORM=0. - DO 100 K=1,NCOL - CS=COLS(K) - IF (CS .NE. 0.) GO TO 60 - SCALES(K)=1. - GO TO 100 - 60 P=LOG(CS)/ALOG2 - IP=-0.5*P - S=2.**IP - SCALES(K)=S - IF (IC .EQ. 1) GO TO 70 - COLS(K)=S*S*COLS(K) - ANORM=ANORM+COLS(K) - COLSAV(K)=COLS(K) - 70 DO 80 J=1,NROW - 80 A(J,K)=S*A(J,K) - 100 CONTINUE -C - IF (IC .EQ. 0) RETURN -C - DO 200 K=1,NROW - ROWS(K)=SDOT(NCOL,A(K,1),NRDA,A(K,1),NRDA) - ROWSAV(K)=ROWS(K) - 200 ANORM=ANORM+ROWS(K) - RETURN - END diff --git a/slatec/cseri.f b/slatec/cseri.f deleted file mode 100644 index 3cf49cc..0000000 --- a/slatec/cseri.f +++ /dev/null @@ -1,164 +0,0 @@ -*DECK CSERI - SUBROUTINE CSERI (Z, FNU, KODE, N, Y, NZ, TOL, ELIM, ALIM) -C***BEGIN PROLOGUE CSERI -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBESI and CBESK -C***LIBRARY SLATEC -C***TYPE ALL (CSERI-A, ZSERI-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C CSERI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY -C MEANS OF THE POWER SERIES FOR LARGE ABS(Z) IN THE -C REGION ABS(Z).LE.2*SQRT(FNU+1). NZ=0 IS A NORMAL RETURN. -C NZ.GT.0 MEANS THAT THE LAST NZ COMPONENTS WERE SET TO ZERO -C DUE TO UNDERFLOW. NZ.LT.0 MEANS UNDERFLOW OCCURRED, BUT THE -C CONDITION ABS(Z).LE.2*SQRT(FNU+1) WAS VIOLATED AND THE -C COMPUTATION MUST BE COMPLETED IN ANOTHER ROUTINE WITH N=N-ABS(NZ). -C -C***SEE ALSO CBESI, CBESK -C***ROUTINES CALLED CUCHK, GAMLN, R1MACH -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CSERI - COMPLEX AK1, CK, COEF, CONE, CRSC, CZ, CZERO, HZ, RZ, S1, S2, W, - * Y, Z - REAL AA, ACZ, AK, ALIM, ARM, ASCLE, ATOL, AZ, DFNU, ELIM, FNU, - * FNUP, RAK1, RS, RTR1, S, SS, TOL, X, GAMLN, R1MACH - INTEGER I, IB, IDUM, IFLAG, IL, K, KODE, L, M, N, NN, NW, NZ - DIMENSION Y(N), W(2) - DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) / -C***FIRST EXECUTABLE STATEMENT CSERI - NZ = 0 - AZ = ABS(Z) - IF (AZ.EQ.0.0E0) GO TO 150 - X = REAL(Z) - ARM = 1.0E+3*R1MACH(1) - RTR1 = SQRT(ARM) - CRSC = CMPLX(1.0E0,0.0E0) - IFLAG = 0 - IF (AZ.LT.ARM) GO TO 140 - HZ = Z*CMPLX(0.5E0,0.0E0) - CZ = CZERO - IF (AZ.GT.RTR1) CZ = HZ*HZ - ACZ = ABS(CZ) - NN = N - CK = CLOG(HZ) - 10 CONTINUE - DFNU = FNU + (NN-1) - FNUP = DFNU + 1.0E0 -C----------------------------------------------------------------------- -C UNDERFLOW TEST -C----------------------------------------------------------------------- - AK1 = CK*CMPLX(DFNU,0.0E0) - AK = GAMLN(FNUP,IDUM) - AK1 = AK1 - CMPLX(AK,0.0E0) - IF (KODE.EQ.2) AK1 = AK1 - CMPLX(X,0.0E0) - RAK1 = REAL(AK1) - IF (RAK1.GT.(-ELIM)) GO TO 30 - 20 CONTINUE - NZ = NZ + 1 - Y(NN) = CZERO - IF (ACZ.GT.DFNU) GO TO 170 - NN = NN - 1 - IF (NN.EQ.0) RETURN - GO TO 10 - 30 CONTINUE - IF (RAK1.GT.(-ALIM)) GO TO 40 - IFLAG = 1 - SS = 1.0E0/TOL - CRSC = CMPLX(TOL,0.0E0) - ASCLE = ARM*SS - 40 CONTINUE - AK = AIMAG(AK1) - AA = EXP(RAK1) - IF (IFLAG.EQ.1) AA = AA*SS - COEF = CMPLX(AA,0.0E0)*CMPLX(COS(AK),SIN(AK)) - ATOL = TOL*ACZ/FNUP - IL = MIN(2,NN) - DO 80 I=1,IL - DFNU = FNU + (NN-I) - FNUP = DFNU + 1.0E0 - S1 = CONE - IF (ACZ.LT.TOL*FNUP) GO TO 60 - AK1 = CONE - AK = FNUP + 2.0E0 - S = FNUP - AA = 2.0E0 - 50 CONTINUE - RS = 1.0E0/S - AK1 = AK1*CZ*CMPLX(RS,0.0E0) - S1 = S1 + AK1 - S = S + AK - AK = AK + 2.0E0 - AA = AA*ACZ*RS - IF (AA.GT.ATOL) GO TO 50 - 60 CONTINUE - M = NN - I + 1 - S2 = S1*COEF - W(I) = S2 - IF (IFLAG.EQ.0) GO TO 70 - CALL CUCHK(S2, NW, ASCLE, TOL) - IF (NW.NE.0) GO TO 20 - 70 CONTINUE - Y(M) = S2*CRSC - IF (I.NE.IL) COEF = COEF*CMPLX(DFNU,0.0E0)/HZ - 80 CONTINUE - IF (NN.LE.2) RETURN - K = NN - 2 - AK = K - RZ = (CONE+CONE)/Z - IF (IFLAG.EQ.1) GO TO 110 - IB = 3 - 90 CONTINUE - DO 100 I=IB,NN - Y(K) = CMPLX(AK+FNU,0.0E0)*RZ*Y(K+1) + Y(K+2) - AK = AK - 1.0E0 - K = K - 1 - 100 CONTINUE - RETURN -C----------------------------------------------------------------------- -C RECUR BACKWARD WITH SCALED VALUES -C----------------------------------------------------------------------- - 110 CONTINUE -C----------------------------------------------------------------------- -C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION ABOVE THE -C UNDERFLOW LIMIT = ASCLE = R1MACH(1)*CSCL*1.0E+3 -C----------------------------------------------------------------------- - S1 = W(1) - S2 = W(2) - DO 120 L=3,NN - CK = S2 - S2 = S1 + CMPLX(AK+FNU,0.0E0)*RZ*S2 - S1 = CK - CK = S2*CRSC - Y(K) = CK - AK = AK - 1.0E0 - K = K - 1 - IF (ABS(CK).GT.ASCLE) GO TO 130 - 120 CONTINUE - RETURN - 130 CONTINUE - IB = L + 1 - IF (IB.GT.NN) RETURN - GO TO 90 - 140 CONTINUE - NZ = N - IF (FNU.EQ.0.0E0) NZ = NZ - 1 - 150 CONTINUE - Y(1) = CZERO - IF (FNU.EQ.0.0E0) Y(1) = CONE - IF (N.EQ.1) RETURN - DO 160 I=2,N - Y(I) = CZERO - 160 CONTINUE - RETURN -C----------------------------------------------------------------------- -C RETURN WITH NZ.LT.0 IF ABS(Z*Z/4).GT.FNU+N-NZ-1 COMPLETE -C THE CALCULATION IN CBINU WITH N=N-ABS(NZ) -C----------------------------------------------------------------------- - 170 CONTINUE - NZ = -NZ - RETURN - END diff --git a/slatec/csevl.f b/slatec/csevl.f deleted file mode 100644 index 8b7d2a8..0000000 --- a/slatec/csevl.f +++ /dev/null @@ -1,65 +0,0 @@ -*DECK CSEVL - FUNCTION CSEVL (X, CS, N) -C***BEGIN PROLOGUE CSEVL -C***PURPOSE Evaluate a Chebyshev series. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C3A2 -C***TYPE SINGLE PRECISION (CSEVL-S, DCSEVL-D) -C***KEYWORDS CHEBYSHEV SERIES, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate the N-term Chebyshev series CS at X. Adapted from -C a method presented in the paper by Broucke referenced below. -C -C Input Arguments -- -C X value at which the series is to be evaluated. -C CS array of N terms of a Chebyshev series. In evaluating -C CS, only half the first coefficient is summed. -C N number of terms in array CS. -C -C***REFERENCES R. Broucke, Ten subroutines for the manipulation of -C Chebyshev series, Algorithm 446, Communications of -C the A.C.M. 16, (1973) pp. 254-256. -C L. Fox and I. B. Parker, Chebyshev Polynomials in -C Numerical Analysis, Oxford University Press, 1968, -C page 56. -C***ROUTINES CALLED R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900329 Prologued revised extensively and code rewritten to allow -C X to be slightly outside interval (-1,+1). (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CSEVL - REAL B0, B1, B2, CS(*), ONEPL, TWOX, X - LOGICAL FIRST - SAVE FIRST, ONEPL - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT CSEVL - IF (FIRST) ONEPL = 1.0E0 + R1MACH(4) - FIRST = .FALSE. - IF (N .LT. 1) CALL XERMSG ('SLATEC', 'CSEVL', - + 'NUMBER OF TERMS .LE. 0', 2, 2) - IF (N .GT. 1000) CALL XERMSG ('SLATEC', 'CSEVL', - + 'NUMBER OF TERMS .GT. 1000', 3, 2) - IF (ABS(X) .GT. ONEPL) CALL XERMSG ('SLATEC', 'CSEVL', - + 'X OUTSIDE THE INTERVAL (-1,+1)', 1, 1) -C - B1 = 0.0E0 - B0 = 0.0E0 - TWOX = 2.0*X - DO 10 I = 1,N - B2 = B1 - B1 = B0 - NI = N + 1 - I - B0 = TWOX*B1 - B2 + CS(NI) - 10 CONTINUE -C - CSEVL = 0.5E0*(B0-B2) -C - RETURN - END diff --git a/slatec/cshch.f b/slatec/cshch.f deleted file mode 100644 index 024e122..0000000 --- a/slatec/cshch.f +++ /dev/null @@ -1,36 +0,0 @@ -*DECK CSHCH - SUBROUTINE CSHCH (Z, CSH, CCH) -C***BEGIN PROLOGUE CSHCH -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBESH and CBESK -C***LIBRARY SLATEC -C***TYPE ALL (CSHCH-A, ZSHCH-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C CSHCH COMPUTES THE COMPLEX HYPERBOLIC FUNCTIONS CSH=SINH(X+I*Y) -C AND CCH=COSH(X+I*Y), WHERE I**2=-1. -C -C***SEE ALSO CBESH, CBESK -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CSHCH - COMPLEX CCH, CSH, Z - REAL CCHI, CCHR, CH, CN, CSHI, CSHR, SH, SN, X, Y -C***FIRST EXECUTABLE STATEMENT CSHCH - X = REAL(Z) - Y = AIMAG(Z) - SH = SINH(X) - CH = COSH(X) - SN = SIN(Y) - CN = COS(Y) - CSHR = SH*CN - CSHI = CH*SN - CSH = CMPLX(CSHR,CSHI) - CCHR = CH*CN - CCHI = SH*SN - CCH = CMPLX(CCHR,CCHI) - RETURN - END diff --git a/slatec/csico.f b/slatec/csico.f deleted file mode 100644 index 156bab1..0000000 --- a/slatec/csico.f +++ /dev/null @@ -1,265 +0,0 @@ -*DECK CSICO - SUBROUTINE CSICO (A, LDA, N, KPVT, RCOND, Z) -C***BEGIN PROLOGUE CSICO -C***PURPOSE Factor a complex symmetric matrix by elimination with -C symmetric pivoting and estimate the condition number of the -C matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2C1 -C***TYPE COMPLEX (SSICO-S, DSICO-D, CHICO-C, CSICO-C) -C***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, -C MATRIX FACTORIZATION, SYMMETRIC -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C CSICO factors a complex symmetric matrix by elimination with -C symmetric pivoting and estimates the condition of the matrix. -C -C If RCOND is not needed, CSIFA is slightly faster. -C To solve A*X = B , follow CSICO by CSISL. -C To compute INVERSE(A)*C , follow CSICO by CSISL. -C To compute INVERSE(A) , follow CSICO by CSIDI. -C To compute DETERMINANT(A) , follow CSICO by CSIDI. -C -C On Entry -C -C A COMPLEX(LDA, N) -C the symmetric matrix to be factored. -C Only the diagonal and upper triangle are used. -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 a block diagonal matrix and the multipliers which -C were used to obtain it. -C The factorization can be written A = U*D*TRANS(U) -C where U is a product of permutation and unit -C upper triangular matrices , TRANS(U) is the -C transpose of U , and D is block diagonal -C with 1 by 1 and 2 by 2 blocks. -C -C KVPT INTEGER(N) -C an integer vector of pivot indices. -C -C RCOND REAL -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 COMPLEX(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***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CDOTU, CSIFA, CSSCAL, SCASUM -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Corrected category and modified routine equivalence -C list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CSICO - INTEGER LDA,N,KPVT(*) - COMPLEX A(LDA,*),Z(*) - REAL RCOND -C - COMPLEX AK,AKM1,BK,BKM1,CDOTU,DENOM,EK,T - REAL ANORM,S,SCASUM,YNORM - INTEGER I,INFO,J,JM1,K,KP,KPS,KS - COMPLEX ZDUM,ZDUM2,CSIGN1 - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) - CSIGN1(ZDUM,ZDUM2) = CABS1(ZDUM)*(ZDUM2/CABS1(ZDUM2)) -C -C FIND NORM OF A USING ONLY UPPER HALF -C -C***FIRST EXECUTABLE STATEMENT CSICO - DO 30 J = 1, N - Z(J) = CMPLX(SCASUM(J,A(1,J),1),0.0E0) - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 20 - DO 10 I = 1, JM1 - Z(I) = CMPLX(REAL(Z(I))+CABS1(A(I,J)),0.0E0) - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - ANORM = 0.0E0 - DO 40 J = 1, N - ANORM = MAX(ANORM,REAL(Z(J))) - 40 CONTINUE -C -C FACTOR -C - CALL CSIFA(A,LDA,N,KPVT,INFO) -C -C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . -C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . -C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL -C GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . -C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. -C -C SOLVE U*D*W = E -C - EK = (1.0E0,0.0E0) - DO 50 J = 1, N - Z(J) = (0.0E0,0.0E0) - 50 CONTINUE - K = N - 60 IF (K .EQ. 0) GO TO 120 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - KP = ABS(KPVT(K)) - KPS = K + 1 - KS - IF (KP .EQ. KPS) GO TO 70 - T = Z(KPS) - Z(KPS) = Z(KP) - Z(KP) = T - 70 CONTINUE - IF (CABS1(Z(K)) .NE. 0.0E0) EK = CSIGN1(EK,Z(K)) - Z(K) = Z(K) + EK - CALL CAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) - IF (KS .EQ. 1) GO TO 80 - IF (CABS1(Z(K-1)) .NE. 0.0E0) EK = CSIGN1(EK,Z(K-1)) - Z(K-1) = Z(K-1) + EK - CALL CAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) - 80 CONTINUE - IF (KS .EQ. 2) GO TO 100 - IF (CABS1(Z(K)) .LE. CABS1(A(K,K))) GO TO 90 - S = CABS1(A(K,K))/CABS1(Z(K)) - CALL CSSCAL(N,S,Z,1) - EK = CMPLX(S,0.0E0)*EK - 90 CONTINUE - IF (CABS1(A(K,K)) .NE. 0.0E0) Z(K) = Z(K)/A(K,K) - IF (CABS1(A(K,K)) .EQ. 0.0E0) Z(K) = (1.0E0,0.0E0) - GO TO 110 - 100 CONTINUE - AK = A(K,K)/A(K-1,K) - AKM1 = A(K-1,K-1)/A(K-1,K) - BK = Z(K)/A(K-1,K) - BKM1 = Z(K-1)/A(K-1,K) - DENOM = AK*AKM1 - 1.0E0 - Z(K) = (AKM1*BK - BKM1)/DENOM - Z(K-1) = (AK*BKM1 - BK)/DENOM - 110 CONTINUE - K = K - KS - GO TO 60 - 120 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) -C -C SOLVE TRANS(U)*Y = W -C - K = 1 - 130 IF (K .GT. N) GO TO 160 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. 1) GO TO 150 - Z(K) = Z(K) + CDOTU(K-1,A(1,K),1,Z(1),1) - IF (KS .EQ. 2) - 1 Z(K+1) = Z(K+1) + CDOTU(K-1,A(1,K+1),1,Z(1),1) - KP = ABS(KPVT(K)) - IF (KP .EQ. K) GO TO 140 - T = Z(K) - Z(K) = Z(KP) - Z(KP) = T - 140 CONTINUE - 150 CONTINUE - K = K + KS - GO TO 130 - 160 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) -C - YNORM = 1.0E0 -C -C SOLVE U*D*V = Y -C - K = N - 170 IF (K .EQ. 0) GO TO 230 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. KS) GO TO 190 - KP = ABS(KPVT(K)) - KPS = K + 1 - KS - IF (KP .EQ. KPS) GO TO 180 - T = Z(KPS) - Z(KPS) = Z(KP) - Z(KP) = T - 180 CONTINUE - CALL CAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) - IF (KS .EQ. 2) CALL CAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) - 190 CONTINUE - IF (KS .EQ. 2) GO TO 210 - IF (CABS1(Z(K)) .LE. CABS1(A(K,K))) GO TO 200 - S = CABS1(A(K,K))/CABS1(Z(K)) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM - 200 CONTINUE - IF (CABS1(A(K,K)) .NE. 0.0E0) Z(K) = Z(K)/A(K,K) - IF (CABS1(A(K,K)) .EQ. 0.0E0) Z(K) = (1.0E0,0.0E0) - GO TO 220 - 210 CONTINUE - AK = A(K,K)/A(K-1,K) - AKM1 = A(K-1,K-1)/A(K-1,K) - BK = Z(K)/A(K-1,K) - BKM1 = Z(K-1)/A(K-1,K) - DENOM = AK*AKM1 - 1.0E0 - Z(K) = (AKM1*BK - BKM1)/DENOM - Z(K-1) = (AK*BKM1 - BK)/DENOM - 220 CONTINUE - K = K - KS - GO TO 170 - 230 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE TRANS(U)*Z = V -C - K = 1 - 240 IF (K .GT. N) GO TO 270 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. 1) GO TO 260 - Z(K) = Z(K) + CDOTU(K-1,A(1,K),1,Z(1),1) - IF (KS .EQ. 2) - 1 Z(K+1) = Z(K+1) + CDOTU(K-1,A(1,K+1),1,Z(1),1) - KP = ABS(KPVT(K)) - IF (KP .EQ. K) GO TO 250 - T = Z(K) - Z(K) = Z(KP) - Z(KP) = T - 250 CONTINUE - 260 CONTINUE - K = K + KS - GO TO 240 - 270 CONTINUE -C MAKE ZNORM = 1.0 - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM -C - IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM - IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0 - RETURN - END diff --git a/slatec/csidi.f b/slatec/csidi.f deleted file mode 100644 index 56149b1..0000000 --- a/slatec/csidi.f +++ /dev/null @@ -1,210 +0,0 @@ -*DECK CSIDI - SUBROUTINE CSIDI (A, LDA, N, KPVT, DET, WORK, JOB) -C***BEGIN PROLOGUE CSIDI -C***PURPOSE Compute the determinant and inverse of a complex symmetric -C matrix using the factors from CSIFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2C1, D3C1 -C***TYPE COMPLEX (SSIDI-S, DSIDI-D, CHIDI-C, CSIDI-C) -C***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, -C SYMMETRIC -C***AUTHOR Bunch, J., (UCSD) -C***DESCRIPTION -C -C CSIDI computes the determinant and inverse -C of a complex symmetric matrix using the factors from CSIFA. -C -C On Entry -C -C A COMPLEX(LDA,N) -C the output from CSIFA. -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 KVPT INTEGER(N) -C the pivot vector from CSIFA. -C -C WORK COMPLEX(N) -C work vector. Contents destroyed. -C -C JOB INTEGER -C JOB has the decimal expansion AB where -C If B .NE. 0, the inverse is computed, -C If A .NE. 0, the determinant is computed, -C -C For example, JOB = 11 gives both. -C -C On Return -C -C Variables not requested by JOB are not used. -C -C A contains the upper triangle of the inverse of -C the original matrix. The strict lower triangle -C is never referenced. -C -C DET COMPLEX(2) -C determinant of original matrix. -C Determinant = DET(1) * 10.0**DET(2) -C with 1.0 .LE. ABS(DET(1)) .LT. 10.0 -C or DET(1) = 0.0. -C -C Error Condition -C -C A division by zero may occur if the inverse is requested -C and CSICO has set RCOND .EQ. 0.0 -C or CSIFA has set INFO .NE. 0 . -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CCOPY, CDOTU, CSWAP -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Corrected category and modified routine equivalence -C list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CSIDI - INTEGER LDA,N,JOB - COMPLEX A(LDA,*),DET(2),WORK(*) - INTEGER KPVT(*) -C - COMPLEX AK,AKP1,AKKP1,CDOTU,D,T,TEMP - REAL TEN - INTEGER J,JB,K,KM1,KS,KSTEP - LOGICAL NOINV,NODET - COMPLEX ZDUM - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) -C -C***FIRST EXECUTABLE STATEMENT CSIDI - NOINV = MOD(JOB,10) .EQ. 0 - NODET = MOD(JOB,100)/10 .EQ. 0 -C - IF (NODET) GO TO 100 - DET(1) = (1.0E0,0.0E0) - DET(2) = (0.0E0,0.0E0) - TEN = 10.0E0 - T = (0.0E0,0.0E0) - DO 90 K = 1, N - D = A(K,K) -C -C CHECK IF 1 BY 1 -C - IF (KPVT(K) .GT. 0) GO TO 30 -C -C 2 BY 2 BLOCK -C USE DET (D T) = (D/T * C - T) * T -C (T C) -C TO AVOID UNDERFLOW/OVERFLOW TROUBLES. -C TAKE TWO PASSES THROUGH SCALING. USE T FOR FLAG. -C - IF (CABS1(T) .NE. 0.0E0) GO TO 10 - T = A(K,K+1) - D = (D/T)*A(K+1,K+1) - T - GO TO 20 - 10 CONTINUE - D = T - T = (0.0E0,0.0E0) - 20 CONTINUE - 30 CONTINUE -C - DET(1) = D*DET(1) - IF (CABS1(DET(1)) .EQ. 0.0E0) GO TO 80 - 40 IF (CABS1(DET(1)) .GE. 1.0E0) GO TO 50 - DET(1) = CMPLX(TEN,0.0E0)*DET(1) - DET(2) = DET(2) - (1.0E0,0.0E0) - GO TO 40 - 50 CONTINUE - 60 IF (CABS1(DET(1)) .LT. TEN) GO TO 70 - DET(1) = DET(1)/CMPLX(TEN,0.0E0) - DET(2) = DET(2) + (1.0E0,0.0E0) - GO TO 60 - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE -C -C COMPUTE INVERSE(A) -C - IF (NOINV) GO TO 230 - K = 1 - 110 IF (K .GT. N) GO TO 220 - KM1 = K - 1 - IF (KPVT(K) .LT. 0) GO TO 140 -C -C 1 BY 1 -C - A(K,K) = (1.0E0,0.0E0)/A(K,K) - IF (KM1 .LT. 1) GO TO 130 - CALL CCOPY(KM1,A(1,K),1,WORK,1) - DO 120 J = 1, KM1 - A(J,K) = CDOTU(J,A(1,J),1,WORK,1) - CALL CAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1) - 120 CONTINUE - A(K,K) = A(K,K) + CDOTU(KM1,WORK,1,A(1,K),1) - 130 CONTINUE - KSTEP = 1 - GO TO 180 - 140 CONTINUE -C -C 2 BY 2 -C - T = A(K,K+1) - AK = A(K,K)/T - AKP1 = A(K+1,K+1)/T - AKKP1 = A(K,K+1)/T - D = T*(AK*AKP1 - (1.0E0,0.0E0)) - A(K,K) = AKP1/D - A(K+1,K+1) = AK/D - A(K,K+1) = -AKKP1/D - IF (KM1 .LT. 1) GO TO 170 - CALL CCOPY(KM1,A(1,K+1),1,WORK,1) - DO 150 J = 1, KM1 - A(J,K+1) = CDOTU(J,A(1,J),1,WORK,1) - CALL CAXPY(J-1,WORK(J),A(1,J),1,A(1,K+1),1) - 150 CONTINUE - A(K+1,K+1) = A(K+1,K+1) - 1 + CDOTU(KM1,WORK,1,A(1,K+1),1) - A(K,K+1) = A(K,K+1) + CDOTU(KM1,A(1,K),1,A(1,K+1),1) - CALL CCOPY(KM1,A(1,K),1,WORK,1) - DO 160 J = 1, KM1 - A(J,K) = CDOTU(J,A(1,J),1,WORK,1) - CALL CAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1) - 160 CONTINUE - A(K,K) = A(K,K) + CDOTU(KM1,WORK,1,A(1,K),1) - 170 CONTINUE - KSTEP = 2 - 180 CONTINUE -C -C SWAP -C - KS = ABS(KPVT(K)) - IF (KS .EQ. K) GO TO 210 - CALL CSWAP(KS,A(1,KS),1,A(1,K),1) - DO 190 JB = KS, K - J = K + KS - JB - TEMP = A(J,K) - A(J,K) = A(KS,J) - A(KS,J) = TEMP - 190 CONTINUE - IF (KSTEP .EQ. 1) GO TO 200 - TEMP = A(KS,K+1) - A(KS,K+1) = A(K,K+1) - A(K,K+1) = TEMP - 200 CONTINUE - 210 CONTINUE - K = K + KSTEP - GO TO 110 - 220 CONTINUE - 230 CONTINUE - RETURN - END diff --git a/slatec/csifa.f b/slatec/csifa.f deleted file mode 100644 index 8284c76..0000000 --- a/slatec/csifa.f +++ /dev/null @@ -1,240 +0,0 @@ -*DECK CSIFA - SUBROUTINE CSIFA (A, LDA, N, KPVT, INFO) -C***BEGIN PROLOGUE CSIFA -C***PURPOSE Factor a complex symmetric matrix by elimination with -C symmetric pivoting. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2C1 -C***TYPE COMPLEX (SSIFA-S, DSIFA-D, CHIFA-C, CSIFA-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, SYMMETRIC -C***AUTHOR Bunch, J., (UCSD) -C***DESCRIPTION -C -C CSIFA factors a complex symmetric matrix by elimination -C with symmetric pivoting. -C -C To solve A*X = B , follow CSIFA by CSISL. -C To compute INVERSE(A)*C , follow CSIFA by CSISL. -C To compute DETERMINANT(A) , follow CSIFA by CSIDI. -C To compute INVERSE(A) , follow CSIFA by CSIDI. -C -C On Entry -C -C A COMPLEX(LDA,N) -C the symmetric matrix to be factored. -C Only the diagonal and upper triangle are used. -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 a block diagonal matrix and the multipliers which -C were used to obtain it. -C The factorization can be written A = U*D*TRANS(U) -C where U is a product of permutation and unit -C upper triangular matrices , TRANS(U) is the -C transpose of U , and D is block diagonal -C with 1 by 1 and 2 by 2 blocks. -C -C KVPT INTEGER(N) -C an integer vector of pivot indices. -C -C INFO INTEGER -C = 0 normal value. -C = K if the K-th pivot block is singular. This is -C not an error condition for this subroutine, -C but it does indicate that CSISL or CSIDI may -C divide by zero if called. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CSWAP, ICAMAX -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Corrected category and modified routine equivalence -C list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CSIFA - INTEGER LDA,N,KPVT(*),INFO - COMPLEX A(LDA,*) -C - COMPLEX AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T - REAL ABSAKK,ALPHA,COLMAX,ROWMAX - INTEGER IMAX,IMAXP1,J,JJ,JMAX,K,KM1,KM2,KSTEP,ICAMAX - LOGICAL SWAP - COMPLEX ZDUM - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) -C***FIRST EXECUTABLE STATEMENT CSIFA -C -C INITIALIZE -C -C ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE. -C - ALPHA = (1.0E0 + SQRT(17.0E0))/8.0E0 -C - INFO = 0 -C -C MAIN LOOP ON K, WHICH GOES FROM N TO 1. -C - K = N - 10 CONTINUE -C -C LEAVE THE LOOP IF K=0 OR K=1. -C - IF (K .EQ. 0) GO TO 200 - IF (K .GT. 1) GO TO 20 - KPVT(1) = 1 - IF (CABS1(A(1,1)) .EQ. 0.0E0) INFO = 1 - GO TO 200 - 20 CONTINUE -C -C THIS SECTION OF CODE DETERMINES THE KIND OF -C ELIMINATION TO BE PERFORMED. WHEN IT IS COMPLETED, -C KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND -C SWAP WILL BE SET TO .TRUE. IF AN INTERCHANGE IS -C REQUIRED. -C - KM1 = K - 1 - ABSAKK = CABS1(A(K,K)) -C -C DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN -C COLUMN K. -C - IMAX = ICAMAX(K-1,A(1,K),1) - COLMAX = CABS1(A(IMAX,K)) - IF (ABSAKK .LT. ALPHA*COLMAX) GO TO 30 - KSTEP = 1 - SWAP = .FALSE. - GO TO 90 - 30 CONTINUE -C -C DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN -C ROW IMAX. -C - ROWMAX = 0.0E0 - IMAXP1 = IMAX + 1 - DO 40 J = IMAXP1, K - ROWMAX = MAX(ROWMAX,CABS1(A(IMAX,J))) - 40 CONTINUE - IF (IMAX .EQ. 1) GO TO 50 - JMAX = ICAMAX(IMAX-1,A(1,IMAX),1) - ROWMAX = MAX(ROWMAX,CABS1(A(JMAX,IMAX))) - 50 CONTINUE - IF (CABS1(A(IMAX,IMAX)) .LT. ALPHA*ROWMAX) GO TO 60 - KSTEP = 1 - SWAP = .TRUE. - GO TO 80 - 60 CONTINUE - IF (ABSAKK .LT. ALPHA*COLMAX*(COLMAX/ROWMAX)) GO TO 70 - KSTEP = 1 - SWAP = .FALSE. - GO TO 80 - 70 CONTINUE - KSTEP = 2 - SWAP = IMAX .NE. KM1 - 80 CONTINUE - 90 CONTINUE - IF (MAX(ABSAKK,COLMAX) .NE. 0.0E0) GO TO 100 -C -C COLUMN K IS ZERO. SET INFO AND ITERATE THE LOOP. -C - KPVT(K) = K - INFO = K - GO TO 190 - 100 CONTINUE - IF (KSTEP .EQ. 2) GO TO 140 -C -C 1 X 1 PIVOT BLOCK. -C - IF (.NOT.SWAP) GO TO 120 -C -C PERFORM AN INTERCHANGE. -C - CALL CSWAP(IMAX,A(1,IMAX),1,A(1,K),1) - DO 110 JJ = IMAX, K - J = K + IMAX - JJ - T = A(J,K) - A(J,K) = A(IMAX,J) - A(IMAX,J) = T - 110 CONTINUE - 120 CONTINUE -C -C PERFORM THE ELIMINATION. -C - DO 130 JJ = 1, KM1 - J = K - JJ - MULK = -A(J,K)/A(K,K) - T = MULK - CALL CAXPY(J,T,A(1,K),1,A(1,J),1) - A(J,K) = MULK - 130 CONTINUE -C -C SET THE PIVOT ARRAY. -C - KPVT(K) = K - IF (SWAP) KPVT(K) = IMAX - GO TO 190 - 140 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - IF (.NOT.SWAP) GO TO 160 -C -C PERFORM AN INTERCHANGE. -C - CALL CSWAP(IMAX,A(1,IMAX),1,A(1,K-1),1) - DO 150 JJ = IMAX, KM1 - J = KM1 + IMAX - JJ - T = A(J,K-1) - A(J,K-1) = A(IMAX,J) - A(IMAX,J) = T - 150 CONTINUE - T = A(K-1,K) - A(K-1,K) = A(IMAX,K) - A(IMAX,K) = T - 160 CONTINUE -C -C PERFORM THE ELIMINATION. -C - KM2 = K - 2 - IF (KM2 .EQ. 0) GO TO 180 - AK = A(K,K)/A(K-1,K) - AKM1 = A(K-1,K-1)/A(K-1,K) - DENOM = 1.0E0 - AK*AKM1 - DO 170 JJ = 1, KM2 - J = KM1 - JJ - BK = A(J,K)/A(K-1,K) - BKM1 = A(J,K-1)/A(K-1,K) - MULK = (AKM1*BK - BKM1)/DENOM - MULKM1 = (AK*BKM1 - BK)/DENOM - T = MULK - CALL CAXPY(J,T,A(1,K),1,A(1,J),1) - T = MULKM1 - CALL CAXPY(J,T,A(1,K-1),1,A(1,J),1) - A(J,K) = MULK - A(J,K-1) = MULKM1 - 170 CONTINUE - 180 CONTINUE -C -C SET THE PIVOT ARRAY. -C - KPVT(K) = 1 - K - IF (SWAP) KPVT(K) = -IMAX - KPVT(K-1) = KPVT(K) - 190 CONTINUE - K = K - KSTEP - GO TO 10 - 200 CONTINUE - RETURN - END diff --git a/slatec/csinh.f b/slatec/csinh.f deleted file mode 100644 index 393d3f8..0000000 --- a/slatec/csinh.f +++ /dev/null @@ -1,30 +0,0 @@ -*DECK CSINH - COMPLEX FUNCTION CSINH (Z) -C***BEGIN PROLOGUE CSINH -C***PURPOSE Compute the complex hyperbolic sine. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4C -C***TYPE COMPLEX (CSINH-C) -C***KEYWORDS ELEMENTARY FUNCTIONS, FNLIB, HYPERBOLIC SINE -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C CSINH(Z) calculates the complex hyperbolic sine of complex -C argument Z. Z is in units of radians. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 770401 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***END PROLOGUE CSINH - COMPLEX Z, CI - SAVE CI - DATA CI /(0.,1.)/ -C***FIRST EXECUTABLE STATEMENT CSINH - CSINH = -CI*SIN(CI*Z) -C - RETURN - END diff --git a/slatec/csisl.f b/slatec/csisl.f deleted file mode 100644 index e16f227..0000000 --- a/slatec/csisl.f +++ /dev/null @@ -1,188 +0,0 @@ -*DECK CSISL - SUBROUTINE CSISL (A, LDA, N, KPVT, B) -C***BEGIN PROLOGUE CSISL -C***PURPOSE Solve a complex symmetric system using the factors obtained -C from CSIFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2C1 -C***TYPE COMPLEX (SSISL-S, DSISL-D, CHISL-C, CSISL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE, SYMMETRIC -C***AUTHOR Bunch, J., (UCSD) -C***DESCRIPTION -C -C CSISL solves the complex symmetric system -C A * X = B -C using the factors computed by CSIFA. -C -C On Entry -C -C A COMPLEX(LDA,N) -C the output from CSIFA. -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 KVPT INTEGER(N) -C the pivot vector from CSIFA. -C -C B COMPLEX(N) -C the right hand side vector. -C -C On Return -C -C B the solution vector X . -C -C Error Condition -C -C A division by zero may occur if CSICO has set RCOND .EQ. 0.0 -C or CSIFA has set INFO .NE. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL CSIFA(A,LDA,N,KVPT,INFO) -C If (INFO .NE. 0) GO TO ... -C DO 10 J = 1, P -C CALL CSISL(A,LDA,N,KVPT,C(1,j)) -C 10 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CDOTU -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Corrected category and modified routine equivalence -C list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CSISL - INTEGER LDA,N,KPVT(*) - COMPLEX A(LDA,*),B(*) -C - COMPLEX AK,AKM1,BK,BKM1,CDOTU,DENOM,TEMP - INTEGER K,KP -C -C LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND -C D INVERSE TO B. -C -C***FIRST EXECUTABLE STATEMENT CSISL - K = N - 10 IF (K .EQ. 0) GO TO 80 - IF (KPVT(K) .LT. 0) GO TO 40 -C -C 1 X 1 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 30 - KP = KPVT(K) - IF (KP .EQ. K) GO TO 20 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 20 CONTINUE -C -C APPLY THE TRANSFORMATION. -C - CALL CAXPY(K-1,B(K),A(1,K),1,B(1),1) - 30 CONTINUE -C -C APPLY D INVERSE. -C - B(K) = B(K)/A(K,K) - K = K - 1 - GO TO 70 - 40 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - IF (K .EQ. 2) GO TO 60 - KP = ABS(KPVT(K)) - IF (KP .EQ. K - 1) GO TO 50 -C -C INTERCHANGE. -C - TEMP = B(K-1) - B(K-1) = B(KP) - B(KP) = TEMP - 50 CONTINUE -C -C APPLY THE TRANSFORMATION. -C - CALL CAXPY(K-2,B(K),A(1,K),1,B(1),1) - CALL CAXPY(K-2,B(K-1),A(1,K-1),1,B(1),1) - 60 CONTINUE -C -C APPLY D INVERSE. -C - AK = A(K,K)/A(K-1,K) - AKM1 = A(K-1,K-1)/A(K-1,K) - BK = B(K)/A(K-1,K) - BKM1 = B(K-1)/A(K-1,K) - DENOM = AK*AKM1 - 1.0E0 - B(K) = (AKM1*BK - BKM1)/DENOM - B(K-1) = (AK*BKM1 - BK)/DENOM - K = K - 2 - 70 CONTINUE - GO TO 10 - 80 CONTINUE -C -C LOOP FORWARD APPLYING THE TRANSFORMATIONS. -C - K = 1 - 90 IF (K .GT. N) GO TO 160 - IF (KPVT(K) .LT. 0) GO TO 120 -C -C 1 X 1 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 110 -C -C APPLY THE TRANSFORMATION. -C - B(K) = B(K) + CDOTU(K-1,A(1,K),1,B(1),1) - KP = KPVT(K) - IF (KP .EQ. K) GO TO 100 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 100 CONTINUE - 110 CONTINUE - K = K + 1 - GO TO 150 - 120 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 140 -C -C APPLY THE TRANSFORMATION. -C - B(K) = B(K) + CDOTU(K-1,A(1,K),1,B(1),1) - B(K+1) = B(K+1) + CDOTU(K-1,A(1,K+1),1,B(1),1) - KP = ABS(KPVT(K)) - IF (KP .EQ. K) GO TO 130 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 130 CONTINUE - 140 CONTINUE - K = K + 2 - 150 CONTINUE - GO TO 90 - 160 CONTINUE - RETURN - END diff --git a/slatec/cspco.f b/slatec/cspco.f deleted file mode 100644 index e54e14a..0000000 --- a/slatec/cspco.f +++ /dev/null @@ -1,305 +0,0 @@ -*DECK CSPCO - SUBROUTINE CSPCO (AP, N, KPVT, RCOND, Z) -C***BEGIN PROLOGUE CSPCO -C***PURPOSE Factor a complex symmetric matrix stored in packed form -C by elimination with symmetric pivoting and estimate the -C condition number of the matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2C1 -C***TYPE COMPLEX (SSPCO-S, DSPCO-D, CHPCO-C, CSPCO-C) -C***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, -C MATRIX FACTORIZATION, PACKED, SYMMETRIC -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C CSPCO factors a complex symmetric matrix stored in packed -C form by elimination with symmetric pivoting and estimates -C the condition of the matrix. -C -C If RCOND is not needed, CSPFA is slightly faster. -C To solve A*X = B , follow CSPCO by CSPSL. -C To compute INVERSE(A)*C , follow CSPCO by CSPSL. -C To compute INVERSE(A) , follow CSPCO by CSPDI. -C To compute DETERMINANT(A) , follow CSPCO by CSPDI. -C -C On Entry -C -C AP COMPLEX (N*(N+1)/2) -C the packed form of a symmetric matrix A . The -C columns of the upper triangle are stored sequentially -C in a one-dimensional array of length N*(N+1)/2 . -C See comments below for details. -C -C N INTEGER -C the order of the matrix A . -C -C On Return -C -C AP a block diagonal matrix and the multipliers which -C were used to obtain it stored in packed form. -C The factorization can be written A = U*D*TRANS(U) -C where U is a product of permutation and unit -C upper triangular matrices , TRANS(U) is the -C transpose of U , and D is block diagonal -C with 1 by 1 and 2 by 2 blocks. -C -C KVPT INTEGER(N) -C an integer vector of pivot indices. -C -C RCOND REAL -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 COMPLEX(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 Packed Storage -C -C The following program segment will pack the upper -C triangle of a symmetric matrix. -C -C K = 0 -C DO 20 J = 1, N -C DO 10 I = 1, J -C K = K + 1 -C AP(K) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CDOTU, CSPFA, CSSCAL, SCASUM -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Corrected category and modified routine equivalence -C list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CSPCO - INTEGER N,KPVT(*) - COMPLEX AP(*),Z(*) - REAL RCOND -C - COMPLEX AK,AKM1,BK,BKM1,CDOTU,DENOM,EK,T - REAL ANORM,S,SCASUM,YNORM - INTEGER I,IJ,IK,IKM1,IKP1,INFO,J,JM1,J1 - INTEGER K,KK,KM1K,KM1KM1,KP,KPS,KS - COMPLEX ZDUM,ZDUM2,CSIGN1 - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) - CSIGN1(ZDUM,ZDUM2) = CABS1(ZDUM)*(ZDUM2/CABS1(ZDUM2)) -C -C FIND NORM OF A USING ONLY UPPER HALF -C -C***FIRST EXECUTABLE STATEMENT CSPCO - J1 = 1 - DO 30 J = 1, N - Z(J) = CMPLX(SCASUM(J,AP(J1),1),0.0E0) - IJ = J1 - J1 = J1 + J - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 20 - DO 10 I = 1, JM1 - Z(I) = CMPLX(REAL(Z(I))+CABS1(AP(IJ)),0.0E0) - IJ = IJ + 1 - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - ANORM = 0.0E0 - DO 40 J = 1, N - ANORM = MAX(ANORM,REAL(Z(J))) - 40 CONTINUE -C -C FACTOR -C - CALL CSPFA(AP,N,KPVT,INFO) -C -C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . -C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . -C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL -C GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . -C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. -C -C SOLVE U*D*W = E -C - EK = (1.0E0,0.0E0) - DO 50 J = 1, N - Z(J) = (0.0E0,0.0E0) - 50 CONTINUE - K = N - IK = (N*(N - 1))/2 - 60 IF (K .EQ. 0) GO TO 120 - KK = IK + K - IKM1 = IK - (K - 1) - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - KP = ABS(KPVT(K)) - KPS = K + 1 - KS - IF (KP .EQ. KPS) GO TO 70 - T = Z(KPS) - Z(KPS) = Z(KP) - Z(KP) = T - 70 CONTINUE - IF (CABS1(Z(K)) .NE. 0.0E0) EK = CSIGN1(EK,Z(K)) - Z(K) = Z(K) + EK - CALL CAXPY(K-KS,Z(K),AP(IK+1),1,Z(1),1) - IF (KS .EQ. 1) GO TO 80 - IF (CABS1(Z(K-1)) .NE. 0.0E0) EK = CSIGN1(EK,Z(K-1)) - Z(K-1) = Z(K-1) + EK - CALL CAXPY(K-KS,Z(K-1),AP(IKM1+1),1,Z(1),1) - 80 CONTINUE - IF (KS .EQ. 2) GO TO 100 - IF (CABS1(Z(K)) .LE. CABS1(AP(KK))) GO TO 90 - S = CABS1(AP(KK))/CABS1(Z(K)) - CALL CSSCAL(N,S,Z,1) - EK = CMPLX(S,0.0E0)*EK - 90 CONTINUE - IF (CABS1(AP(KK)) .NE. 0.0E0) Z(K) = Z(K)/AP(KK) - IF (CABS1(AP(KK)) .EQ. 0.0E0) Z(K) = (1.0E0,0.0E0) - GO TO 110 - 100 CONTINUE - KM1K = IK + K - 1 - KM1KM1 = IKM1 + K - 1 - AK = AP(KK)/AP(KM1K) - AKM1 = AP(KM1KM1)/AP(KM1K) - BK = Z(K)/AP(KM1K) - BKM1 = Z(K-1)/AP(KM1K) - DENOM = AK*AKM1 - 1.0E0 - Z(K) = (AKM1*BK - BKM1)/DENOM - Z(K-1) = (AK*BKM1 - BK)/DENOM - 110 CONTINUE - K = K - KS - IK = IK - K - IF (KS .EQ. 2) IK = IK - (K + 1) - GO TO 60 - 120 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) -C -C SOLVE TRANS(U)*Y = W -C - K = 1 - IK = 0 - 130 IF (K .GT. N) GO TO 160 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. 1) GO TO 150 - Z(K) = Z(K) + CDOTU(K-1,AP(IK+1),1,Z(1),1) - IKP1 = IK + K - IF (KS .EQ. 2) - 1 Z(K+1) = Z(K+1) + CDOTU(K-1,AP(IKP1+1),1,Z(1),1) - KP = ABS(KPVT(K)) - IF (KP .EQ. K) GO TO 140 - T = Z(K) - Z(K) = Z(KP) - Z(KP) = T - 140 CONTINUE - 150 CONTINUE - IK = IK + K - IF (KS .EQ. 2) IK = IK + (K + 1) - K = K + KS - GO TO 130 - 160 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) -C - YNORM = 1.0E0 -C -C SOLVE U*D*V = Y -C - K = N - IK = N*(N - 1)/2 - 170 IF (K .EQ. 0) GO TO 230 - KK = IK + K - IKM1 = IK - (K - 1) - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. KS) GO TO 190 - KP = ABS(KPVT(K)) - KPS = K + 1 - KS - IF (KP .EQ. KPS) GO TO 180 - T = Z(KPS) - Z(KPS) = Z(KP) - Z(KP) = T - 180 CONTINUE - CALL CAXPY(K-KS,Z(K),AP(IK+1),1,Z(1),1) - IF (KS .EQ. 2) CALL CAXPY(K-KS,Z(K-1),AP(IKM1+1),1,Z(1),1) - 190 CONTINUE - IF (KS .EQ. 2) GO TO 210 - IF (CABS1(Z(K)) .LE. CABS1(AP(KK))) GO TO 200 - S = CABS1(AP(KK))/CABS1(Z(K)) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM - 200 CONTINUE - IF (CABS1(AP(KK)) .NE. 0.0E0) Z(K) = Z(K)/AP(KK) - IF (CABS1(AP(KK)) .EQ. 0.0E0) Z(K) = (1.0E0,0.0E0) - GO TO 220 - 210 CONTINUE - KM1K = IK + K - 1 - KM1KM1 = IKM1 + K - 1 - AK = AP(KK)/AP(KM1K) - AKM1 = AP(KM1KM1)/AP(KM1K) - BK = Z(K)/AP(KM1K) - BKM1 = Z(K-1)/AP(KM1K) - DENOM = AK*AKM1 - 1.0E0 - Z(K) = (AKM1*BK - BKM1)/DENOM - Z(K-1) = (AK*BKM1 - BK)/DENOM - 220 CONTINUE - K = K - KS - IK = IK - K - IF (KS .EQ. 2) IK = IK - (K + 1) - GO TO 170 - 230 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE TRANS(U)*Z = V -C - K = 1 - IK = 0 - 240 IF (K .GT. N) GO TO 270 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. 1) GO TO 260 - Z(K) = Z(K) + CDOTU(K-1,AP(IK+1),1,Z(1),1) - IKP1 = IK + K - IF (KS .EQ. 2) - 1 Z(K+1) = Z(K+1) + CDOTU(K-1,AP(IKP1+1),1,Z(1),1) - KP = ABS(KPVT(K)) - IF (KP .EQ. K) GO TO 250 - T = Z(K) - Z(K) = Z(KP) - Z(KP) = T - 250 CONTINUE - 260 CONTINUE - IK = IK + K - IF (KS .EQ. 2) IK = IK + (K + 1) - K = K + KS - GO TO 240 - 270 CONTINUE -C MAKE ZNORM = 1.0 - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM -C - IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM - IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0 - RETURN - END diff --git a/slatec/cspdi.f b/slatec/cspdi.f deleted file mode 100644 index f944646..0000000 --- a/slatec/cspdi.f +++ /dev/null @@ -1,238 +0,0 @@ -*DECK CSPDI - SUBROUTINE CSPDI (AP, N, KPVT, DET, WORK, JOB) -C***BEGIN PROLOGUE CSPDI -C***PURPOSE Compute the determinant and inverse of a complex symmetric -C matrix stored in packed form using the factors from CSPFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2C1, D3C1 -C***TYPE COMPLEX (SSPDI-S, DSPDI-D, CHPDI-C, CSPDI-C) -C***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, -C PACKED, SYMMETRIC -C***AUTHOR Bunch, J., (UCSD) -C***DESCRIPTION -C -C CSPDI computes the determinant and inverse -C of a complex symmetric matrix using the factors from CSPFA, -C where the matrix is stored in packed form. -C -C On Entry -C -C AP COMPLEX (N*(N+1)/2) -C the output from CSPFA. -C -C N INTEGER -C the order of the matrix A . -C -C KVPT INTEGER(N) -C the pivot vector from CSPFA. -C -C WORK COMPLEX(N) -C work vector. Contents ignored. -C -C JOB INTEGER -C JOB has the decimal expansion AB where -C if B .NE. 0, the inverse is computed, -C if A .NE. 0, the determinant is computed. -C -C For example, JOB = 11 gives both. -C -C On Return -C -C Variables not requested by JOB are not used. -C -C AP contains the upper triangle of the inverse of -C the original matrix, stored in packed form. -C The columns of the upper triangle are stored -C sequentially in a one-dimensional array. -C -C DET COMPLEX(2) -C determinant of original matrix. -C Determinant = DET(1) * 10.0**DET(2) -C with 1.0 .LE. ABS(DET(1)) .LT. 10.0 -C or DET(1) = 0.0. -C -C Error Condition -C -C A division by zero will occur if the inverse is requested -C and CSPCO has set RCOND .EQ. 0.0 -C or CSPFA has set INFO .NE. 0 . -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CCOPY, CDOTU, CSWAP -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Corrected category and modified routine equivalence -C list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CSPDI - INTEGER N,JOB - COMPLEX AP(*),WORK(*),DET(2) - INTEGER KPVT(*) -C - COMPLEX AK,AKKP1,AKP1,CDOTU,D,T,TEMP - REAL TEN - INTEGER IJ,IK,IKP1,IKS,J,JB,JK,JKP1 - INTEGER K,KK,KKP1,KM1,KS,KSJ,KSKP1,KSTEP - LOGICAL NOINV,NODET - COMPLEX ZDUM - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) -C -C***FIRST EXECUTABLE STATEMENT CSPDI - NOINV = MOD(JOB,10) .EQ. 0 - NODET = MOD(JOB,100)/10 .EQ. 0 -C - IF (NODET) GO TO 110 - DET(1) = (1.0E0,0.0E0) - DET(2) = (0.0E0,0.0E0) - TEN = 10.0E0 - T = (0.0E0,0.0E0) - IK = 0 - DO 100 K = 1, N - KK = IK + K - D = AP(KK) -C -C CHECK IF 1 BY 1 -C - IF (KPVT(K) .GT. 0) GO TO 30 -C -C 2 BY 2 BLOCK -C USE DET (D T) = (D/T * C - T) * T -C (T C) -C TO AVOID UNDERFLOW/OVERFLOW TROUBLES. -C TAKE TWO PASSES THROUGH SCALING. USE T FOR FLAG. -C - IF (CABS1(T) .NE. 0.0E0) GO TO 10 - IKP1 = IK + K - KKP1 = IKP1 + K - T = AP(KKP1) - D = (D/T)*AP(KKP1+1) - T - GO TO 20 - 10 CONTINUE - D = T - T = (0.0E0,0.0E0) - 20 CONTINUE - 30 CONTINUE -C - IF (NODET) GO TO 90 - DET(1) = D*DET(1) - IF (CABS1(DET(1)) .EQ. 0.0E0) GO TO 80 - 40 IF (CABS1(DET(1)) .GE. 1.0E0) GO TO 50 - DET(1) = CMPLX(TEN,0.0E0)*DET(1) - DET(2) = DET(2) - (1.0E0,0.0E0) - GO TO 40 - 50 CONTINUE - 60 IF (CABS1(DET(1)) .LT. TEN) GO TO 70 - DET(1) = DET(1)/CMPLX(TEN,0.0E0) - DET(2) = DET(2) + (1.0E0,0.0E0) - GO TO 60 - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - IK = IK + K - 100 CONTINUE - 110 CONTINUE -C -C COMPUTE INVERSE(A) -C - IF (NOINV) GO TO 240 - K = 1 - IK = 0 - 120 IF (K .GT. N) GO TO 230 - KM1 = K - 1 - KK = IK + K - IKP1 = IK + K - IF (KPVT(K) .LT. 0) GO TO 150 -C -C 1 BY 1 -C - AP(KK) = (1.0E0,0.0E0)/AP(KK) - IF (KM1 .LT. 1) GO TO 140 - CALL CCOPY(KM1,AP(IK+1),1,WORK,1) - IJ = 0 - DO 130 J = 1, KM1 - JK = IK + J - AP(JK) = CDOTU(J,AP(IJ+1),1,WORK,1) - CALL CAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IK+1),1) - IJ = IJ + J - 130 CONTINUE - AP(KK) = AP(KK) + CDOTU(KM1,WORK,1,AP(IK+1),1) - 140 CONTINUE - KSTEP = 1 - GO TO 190 - 150 CONTINUE -C -C 2 BY 2 -C - KKP1 = IKP1 + K - T = AP(KKP1) - AK = AP(KK)/T - AKP1 = AP(KKP1+1)/T - AKKP1 = AP(KKP1)/T - D = T*(AK*AKP1 - (1.0E0,0.0E0)) - AP(KK) = AKP1/D - AP(KKP1+1) = AK/D - AP(KKP1) = -AKKP1/D - IF (KM1 .LT. 1) GO TO 180 - CALL CCOPY(KM1,AP(IKP1+1),1,WORK,1) - IJ = 0 - DO 160 J = 1, KM1 - JKP1 = IKP1 + J - AP(JKP1) = CDOTU(J,AP(IJ+1),1,WORK,1) - CALL CAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IKP1+1),1) - IJ = IJ + J - 160 CONTINUE - AP(KKP1+1) = AP(KKP1+1) - 1 + CDOTU(KM1,WORK,1,AP(IKP1+1),1) - AP(KKP1) = AP(KKP1) - 1 + CDOTU(KM1,AP(IK+1),1,AP(IKP1+1),1) - CALL CCOPY(KM1,AP(IK+1),1,WORK,1) - IJ = 0 - DO 170 J = 1, KM1 - JK = IK + J - AP(JK) = CDOTU(J,AP(IJ+1),1,WORK,1) - CALL CAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IK+1),1) - IJ = IJ + J - 170 CONTINUE - AP(KK) = AP(KK) + CDOTU(KM1,WORK,1,AP(IK+1),1) - 180 CONTINUE - KSTEP = 2 - 190 CONTINUE -C -C SWAP -C - KS = ABS(KPVT(K)) - IF (KS .EQ. K) GO TO 220 - IKS = (KS*(KS - 1))/2 - CALL CSWAP(KS,AP(IKS+1),1,AP(IK+1),1) - KSJ = IK + KS - DO 200 JB = KS, K - J = K + KS - JB - JK = IK + J - TEMP = AP(JK) - AP(JK) = AP(KSJ) - AP(KSJ) = TEMP - KSJ = KSJ - (J - 1) - 200 CONTINUE - IF (KSTEP .EQ. 1) GO TO 210 - KSKP1 = IKP1 + KS - TEMP = AP(KSKP1) - AP(KSKP1) = AP(KKP1) - AP(KKP1) = TEMP - 210 CONTINUE - 220 CONTINUE - IK = IK + K - IF (KSTEP .EQ. 2) IK = IK + K + 1 - K = K + KSTEP - GO TO 120 - 230 CONTINUE - 240 CONTINUE - RETURN - END diff --git a/slatec/cspfa.f b/slatec/cspfa.f deleted file mode 100644 index de5b3dd..0000000 --- a/slatec/cspfa.f +++ /dev/null @@ -1,280 +0,0 @@ -*DECK CSPFA - SUBROUTINE CSPFA (AP, N, KPVT, INFO) -C***BEGIN PROLOGUE CSPFA -C***PURPOSE Factor a complex symmetric matrix stored in packed form by -C elimination with symmetric pivoting. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2C1 -C***TYPE COMPLEX (SSPFA-S, DSPFA-D, CHPFA-C, CSPFA-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, PACKED, -C SYMMETRIC -C***AUTHOR Bunch, J., (UCSD) -C***DESCRIPTION -C -C CSPFA factors a complex symmetric matrix stored in -C packed form by elimination with symmetric pivoting. -C -C To solve A*X = B , follow CSPFA by CSPSL. -C To compute INVERSE(A)*C , follow CSPFA by CSPSL. -C To compute DETERMINANT(A) , follow CSPFA by CSPDI. -C To compute INVERSE(A) , follow CSPFA by CSPDI. -C -C On Entry -C -C AP COMPLEX (N*(N+1)/2) -C the packed form of a symmetric matrix A . The -C columns of the upper triangle are stored sequentially -C in a one-dimensional array of length N*(N+1)/2 . -C See comments below for details. -C -C N INTEGER -C the order of the matrix A . -C -C On Return -C -C AP a block diagonal matrix and the multipliers which -C were used to obtain it stored in packed form. -C The factorization can be written A = U*D*TRANS(U) -C where U is a product of permutation and unit -C upper triangular matrices , TRANS(U) is the -C transpose of U , and D is block diagonal -C with 1 by 1 and 2 by 2 blocks. -C -C KVPT INTEGER(N) -C an integer vector of pivot indices. -C -C INFO INTEGER -C = 0 normal value. -C = K if the K-th pivot block is singular. This is -C not an error condition for this subroutine, -C but it does indicate that CSPSL or CSPDI may -C divide by zero if called. -C -C Packed Storage -C -C The following program segment will pack the upper -C triangle of a symmetric matrix. -C -C K = 0 -C DO 20 J = 1, N -C DO 10 I = 1, J -C K = K + 1 -C AP(K) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CSWAP, ICAMAX -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Corrected category and modified routine equivalence -C list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CSPFA - INTEGER N,KPVT(*),INFO - COMPLEX AP(*) -C - COMPLEX AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T - REAL ABSAKK,ALPHA,COLMAX,ROWMAX - INTEGER ICAMAX,IJ,IK,IKM1,IM,IMAX,IMAXP1,IMIM,IMJ,IMK - INTEGER J,JJ,JK,JKM1,JMAX,JMIM,K,KK,KM1,KM1K,KM1KM1,KM2,KSTEP - LOGICAL SWAP - COMPLEX ZDUM - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) -C***FIRST EXECUTABLE STATEMENT CSPFA -C -C INITIALIZE -C -C ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE. -C - ALPHA = (1.0E0 + SQRT(17.0E0))/8.0E0 -C - INFO = 0 -C -C MAIN LOOP ON K, WHICH GOES FROM N TO 1. -C - K = N - IK = (N*(N - 1))/2 - 10 CONTINUE -C -C LEAVE THE LOOP IF K=0 OR K=1. -C - IF (K .EQ. 0) GO TO 200 - IF (K .GT. 1) GO TO 20 - KPVT(1) = 1 - IF (CABS1(AP(1)) .EQ. 0.0E0) INFO = 1 - GO TO 200 - 20 CONTINUE -C -C THIS SECTION OF CODE DETERMINES THE KIND OF -C ELIMINATION TO BE PERFORMED. WHEN IT IS COMPLETED, -C KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND -C SWAP WILL BE SET TO .TRUE. IF AN INTERCHANGE IS -C REQUIRED. -C - KM1 = K - 1 - KK = IK + K - ABSAKK = CABS1(AP(KK)) -C -C DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN -C COLUMN K. -C - IMAX = ICAMAX(K-1,AP(IK+1),1) - IMK = IK + IMAX - COLMAX = CABS1(AP(IMK)) - IF (ABSAKK .LT. ALPHA*COLMAX) GO TO 30 - KSTEP = 1 - SWAP = .FALSE. - GO TO 90 - 30 CONTINUE -C -C DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN -C ROW IMAX. -C - ROWMAX = 0.0E0 - IMAXP1 = IMAX + 1 - IM = IMAX*(IMAX - 1)/2 - IMJ = IM + 2*IMAX - DO 40 J = IMAXP1, K - ROWMAX = MAX(ROWMAX,CABS1(AP(IMJ))) - IMJ = IMJ + J - 40 CONTINUE - IF (IMAX .EQ. 1) GO TO 50 - JMAX = ICAMAX(IMAX-1,AP(IM+1),1) - JMIM = JMAX + IM - ROWMAX = MAX(ROWMAX,CABS1(AP(JMIM))) - 50 CONTINUE - IMIM = IMAX + IM - IF (CABS1(AP(IMIM)) .LT. ALPHA*ROWMAX) GO TO 60 - KSTEP = 1 - SWAP = .TRUE. - GO TO 80 - 60 CONTINUE - IF (ABSAKK .LT. ALPHA*COLMAX*(COLMAX/ROWMAX)) GO TO 70 - KSTEP = 1 - SWAP = .FALSE. - GO TO 80 - 70 CONTINUE - KSTEP = 2 - SWAP = IMAX .NE. KM1 - 80 CONTINUE - 90 CONTINUE - IF (MAX(ABSAKK,COLMAX) .NE. 0.0E0) GO TO 100 -C -C COLUMN K IS ZERO. SET INFO AND ITERATE THE LOOP. -C - KPVT(K) = K - INFO = K - GO TO 190 - 100 CONTINUE - IF (KSTEP .EQ. 2) GO TO 140 -C -C 1 X 1 PIVOT BLOCK. -C - IF (.NOT.SWAP) GO TO 120 -C -C PERFORM AN INTERCHANGE. -C - CALL CSWAP(IMAX,AP(IM+1),1,AP(IK+1),1) - IMJ = IK + IMAX - DO 110 JJ = IMAX, K - J = K + IMAX - JJ - JK = IK + J - T = AP(JK) - AP(JK) = AP(IMJ) - AP(IMJ) = T - IMJ = IMJ - (J - 1) - 110 CONTINUE - 120 CONTINUE -C -C PERFORM THE ELIMINATION. -C - IJ = IK - (K - 1) - DO 130 JJ = 1, KM1 - J = K - JJ - JK = IK + J - MULK = -AP(JK)/AP(KK) - T = MULK - CALL CAXPY(J,T,AP(IK+1),1,AP(IJ+1),1) - AP(JK) = MULK - IJ = IJ - (J - 1) - 130 CONTINUE -C -C SET THE PIVOT ARRAY. -C - KPVT(K) = K - IF (SWAP) KPVT(K) = IMAX - GO TO 190 - 140 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - KM1K = IK + K - 1 - IKM1 = IK - (K - 1) - IF (.NOT.SWAP) GO TO 160 -C -C PERFORM AN INTERCHANGE. -C - CALL CSWAP(IMAX,AP(IM+1),1,AP(IKM1+1),1) - IMJ = IKM1 + IMAX - DO 150 JJ = IMAX, KM1 - J = KM1 + IMAX - JJ - JKM1 = IKM1 + J - T = AP(JKM1) - AP(JKM1) = AP(IMJ) - AP(IMJ) = T - IMJ = IMJ - (J - 1) - 150 CONTINUE - T = AP(KM1K) - AP(KM1K) = AP(IMK) - AP(IMK) = T - 160 CONTINUE -C -C PERFORM THE ELIMINATION. -C - KM2 = K - 2 - IF (KM2 .EQ. 0) GO TO 180 - AK = AP(KK)/AP(KM1K) - KM1KM1 = IKM1 + K - 1 - AKM1 = AP(KM1KM1)/AP(KM1K) - DENOM = 1.0E0 - AK*AKM1 - IJ = IK - (K - 1) - (K - 2) - DO 170 JJ = 1, KM2 - J = KM1 - JJ - JK = IK + J - BK = AP(JK)/AP(KM1K) - JKM1 = IKM1 + J - BKM1 = AP(JKM1)/AP(KM1K) - MULK = (AKM1*BK - BKM1)/DENOM - MULKM1 = (AK*BKM1 - BK)/DENOM - T = MULK - CALL CAXPY(J,T,AP(IK+1),1,AP(IJ+1),1) - T = MULKM1 - CALL CAXPY(J,T,AP(IKM1+1),1,AP(IJ+1),1) - AP(JK) = MULK - AP(JKM1) = MULKM1 - IJ = IJ - (J - 1) - 170 CONTINUE - 180 CONTINUE -C -C SET THE PIVOT ARRAY. -C - KPVT(K) = 1 - K - IF (SWAP) KPVT(K) = -IMAX - KPVT(K-1) = KPVT(K) - 190 CONTINUE - IK = IK - (K - 1) - IF (KSTEP .EQ. 2) IK = IK - (K - 2) - K = K - KSTEP - GO TO 10 - 200 CONTINUE - RETURN - END diff --git a/slatec/cspsl.f b/slatec/cspsl.f deleted file mode 100644 index 98e8aea..0000000 --- a/slatec/cspsl.f +++ /dev/null @@ -1,197 +0,0 @@ -*DECK CSPSL - SUBROUTINE CSPSL (AP, N, KPVT, B) -C***BEGIN PROLOGUE CSPSL -C***PURPOSE Solve a complex symmetric system using the factors obtained -C from CSPFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2C1 -C***TYPE COMPLEX (SSPSL-S, DSPSL-D, CHPSL-C, CSPSL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, PACKED, SOLVE, SYMMETRIC -C***AUTHOR Bunch, J., (UCSD) -C***DESCRIPTION -C -C CSISL solves the complex symmetric system -C A * X = B -C using the factors computed by CSPFA. -C -C On Entry -C -C AP COMPLEX(N*(N+1)/2) -C the output from CSPFA. -C -C N INTEGER -C the order of the matrix A . -C -C KVPT INTEGER(N) -C the pivot vector from CSPFA. -C -C B COMPLEX(N) -C the right hand side vector. -C -C On Return -C -C B the solution vector X . -C -C Error Condition -C -C A division by zero may occur if CSPCO has set RCOND .EQ. 0.0 -C or CSPFA has set INFO .NE. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL CSPFA(AP,N,KVPT,INFO) -C IF (INFO .NE. 0) GO TO ... -C DO 10 J = 1, P -C CALL CSPSL(AP,N,KVPT,C(1,J)) -C 10 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CDOTU -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Corrected category and modified routine equivalence -C list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CSPSL - INTEGER N,KPVT(*) - COMPLEX AP(*),B(*) -C - COMPLEX AK,AKM1,BK,BKM1,CDOTU,DENOM,TEMP - INTEGER IK,IKM1,IKP1,K,KK,KM1K,KM1KM1,KP -C -C LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND -C D INVERSE TO B. -C -C***FIRST EXECUTABLE STATEMENT CSPSL - K = N - IK = (N*(N - 1))/2 - 10 IF (K .EQ. 0) GO TO 80 - KK = IK + K - IF (KPVT(K) .LT. 0) GO TO 40 -C -C 1 X 1 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 30 - KP = KPVT(K) - IF (KP .EQ. K) GO TO 20 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 20 CONTINUE -C -C APPLY THE TRANSFORMATION. -C - CALL CAXPY(K-1,B(K),AP(IK+1),1,B(1),1) - 30 CONTINUE -C -C APPLY D INVERSE. -C - B(K) = B(K)/AP(KK) - K = K - 1 - IK = IK - K - GO TO 70 - 40 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - IKM1 = IK - (K - 1) - IF (K .EQ. 2) GO TO 60 - KP = ABS(KPVT(K)) - IF (KP .EQ. K - 1) GO TO 50 -C -C INTERCHANGE. -C - TEMP = B(K-1) - B(K-1) = B(KP) - B(KP) = TEMP - 50 CONTINUE -C -C APPLY THE TRANSFORMATION. -C - CALL CAXPY(K-2,B(K),AP(IK+1),1,B(1),1) - CALL CAXPY(K-2,B(K-1),AP(IKM1+1),1,B(1),1) - 60 CONTINUE -C -C APPLY D INVERSE. -C - KM1K = IK + K - 1 - KK = IK + K - AK = AP(KK)/AP(KM1K) - KM1KM1 = IKM1 + K - 1 - AKM1 = AP(KM1KM1)/AP(KM1K) - BK = B(K)/AP(KM1K) - BKM1 = B(K-1)/AP(KM1K) - DENOM = AK*AKM1 - 1.0E0 - B(K) = (AKM1*BK - BKM1)/DENOM - B(K-1) = (AK*BKM1 - BK)/DENOM - K = K - 2 - IK = IK - (K + 1) - K - 70 CONTINUE - GO TO 10 - 80 CONTINUE -C -C LOOP FORWARD APPLYING THE TRANSFORMATIONS. -C - K = 1 - IK = 0 - 90 IF (K .GT. N) GO TO 160 - IF (KPVT(K) .LT. 0) GO TO 120 -C -C 1 X 1 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 110 -C -C APPLY THE TRANSFORMATION. -C - B(K) = B(K) + CDOTU(K-1,AP(IK+1),1,B(1),1) - KP = KPVT(K) - IF (KP .EQ. K) GO TO 100 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 100 CONTINUE - 110 CONTINUE - IK = IK + K - K = K + 1 - GO TO 150 - 120 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 140 -C -C APPLY THE TRANSFORMATION. -C - B(K) = B(K) + CDOTU(K-1,AP(IK+1),1,B(1),1) - IKP1 = IK + K - B(K+1) = B(K+1) + CDOTU(K-1,AP(IKP1+1),1,B(1),1) - KP = ABS(KPVT(K)) - IF (KP .EQ. K) GO TO 130 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 130 CONTINUE - 140 CONTINUE - IK = IK + K + K + 1 - K = K + 2 - 150 CONTINUE - GO TO 90 - 160 CONTINUE - RETURN - END diff --git a/slatec/csroot.f b/slatec/csroot.f deleted file mode 100644 index bf309e4..0000000 --- a/slatec/csroot.f +++ /dev/null @@ -1,33 +0,0 @@ -*DECK CSROOT - SUBROUTINE CSROOT (XR, XI, YR, YI) -C***BEGIN PROLOGUE CSROOT -C***SUBSIDIARY -C***PURPOSE Compute the complex square root of a complex number. -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (CSROOT-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C (YR,YI) = complex sqrt(XR,XI) -C -C***SEE ALSO EISDOC -C***ROUTINES CALLED PYTHAG -C***REVISION HISTORY (YYMMDD) -C 811101 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE CSROOT - REAL XR,XI,YR,YI,S,TR,TI,PYTHAG -C -C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI) -C***FIRST EXECUTABLE STATEMENT CSROOT - TR = XR - TI = XI - S = SQRT(0.5E0*(PYTHAG(TR,TI) + ABS(TR))) - IF (TR .GE. 0.0E0) YR = S - IF (TI .LT. 0.0E0) S = -S - IF (TR .LE. 0.0E0) YI = S - IF (TR .LT. 0.0E0) YR = 0.5E0*(TI/YI) - IF (TR .GT. 0.0E0) YI = 0.5E0*(TI/YR) - RETURN - END diff --git a/slatec/csrot.f b/slatec/csrot.f deleted file mode 100644 index 3b6abe2..0000000 --- a/slatec/csrot.f +++ /dev/null @@ -1,85 +0,0 @@ -*DECK CSROT - SUBROUTINE CSROT (N, CX, INCX, CY, INCY, C, S) -C***BEGIN PROLOGUE CSROT -C***PURPOSE Apply a plane Givens rotation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B10 -C***TYPE COMPLEX (SROT-S, DROT-D, CSROT-C) -C***KEYWORDS BLAS, GIVENS ROTATION, GIVENS TRANSFORMATION, -C LINEAR ALGEBRA, PLANE ROTATION, VECTOR -C***AUTHOR Dongarra, J., (ANL) -C***DESCRIPTION -C -C CSROT applies the complex Givens rotation -C -C (X) ( C S)(X) -C (Y) = (-S C)(Y) -C -C N times where for I = 0,...,N-1 -C -C X = CX(LX+I*INCX) -C Y = CY(LY+I*INCY), -C -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 Argument Description -C -C N (integer) number of elements in each vector -C -C CX (complex array) beginning of one vector -C -C INCX (integer) memory spacing of successive elements -C of vector CX -C -C CY (complex array) beginning of the other vector -C -C INCY (integer) memory spacing of successive elements -C of vector CY -C -C C (real) cosine term of the rotation -C -C S (real) sine term of the rotation. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 810223 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 CSROT - COMPLEX CX(*), CY(*), CTEMP - REAL C, S - INTEGER I, INCX, INCY, IX, IY, N -C***FIRST EXECUTABLE STATEMENT CSROT - 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 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 - CTEMP = C*CX(IX) + S*CY(IY) - CY(IY) = C*CY(IY) - S*CX(IX) - CX(IX) = CTEMP - 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 - CTEMP = C*CX(I) + S*CY(I) - CY(I) = C*CY(I) - S*CX(I) - CX(I) = CTEMP - 30 CONTINUE - RETURN - END diff --git a/slatec/csscal.f b/slatec/csscal.f deleted file mode 100644 index a40c4c8..0000000 --- a/slatec/csscal.f +++ /dev/null @@ -1,69 +0,0 @@ -*DECK CSSCAL - SUBROUTINE CSSCAL (N, SA, CX, INCX) -C***BEGIN PROLOGUE CSSCAL -C***PURPOSE Scale a complex vector. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A6 -C***TYPE COMPLEX (CSSCAL-C) -C***KEYWORDS BLAS, LINEAR ALGEBRA, SCALE, 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 SA single precision scale factor -C CX complex vector with N elements -C INCX storage spacing between elements of CX -C -C --Output-- -C CX scaled result (unchanged if N .LE. 0) -C -C Replace complex CX by (single precision SA) * (complex CX) -C For I = 0 to N-1, replace CX(IX+I*INCX) with SA * CX(IX+I*INCX), -C where IX = 1 if INCX .GE. 0, else IX = 1+(1-N)*INCX. -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 900821 Modified to correct problem with a negative increment. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CSSCAL - COMPLEX CX(*) - REAL SA - INTEGER I, INCX, IX, N -C***FIRST EXECUTABLE STATEMENT CSSCAL - IF (N .LE. 0) RETURN -C - IF (INCX .EQ. 1) GOTO 20 -C -C Code for increment not equal to 1. -C - IX = 1 - IF (INCX .LT. 0) IX = (-N+1)*INCX + 1 - DO 10 I = 1,N - CX(IX) = SA*CX(IX) - IX = IX + INCX - 10 CONTINUE - RETURN -C -C Code for increment equal to 1. -C - 20 DO 30 I = 1,N - CX(I) = SA*CX(I) - 30 CONTINUE - RETURN - END diff --git a/slatec/csvdc.f b/slatec/csvdc.f deleted file mode 100644 index c01ee40..0000000 --- a/slatec/csvdc.f +++ /dev/null @@ -1,513 +0,0 @@ -*DECK CSVDC - SUBROUTINE CSVDC (X, LDX, N, P, S, E, U, LDU, V, LDV, WORK, JOB, - + INFO) -C***BEGIN PROLOGUE CSVDC -C***PURPOSE Perform the singular value decomposition of a rectangular -C matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D6 -C***TYPE COMPLEX (SSVDC-S, DSVDC-D, CSVDC-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, -C SINGULAR VALUE DECOMPOSITION -C***AUTHOR Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C CSVDC is a subroutine to reduce a complex NxP matrix X by -C unitary transformations U and V to diagonal form. The -C diagonal elements S(I) are the singular values of X. The -C columns of U are the corresponding left singular vectors, -C and the columns of V the right singular vectors. -C -C On Entry -C -C X COMPLEX(LDX,P), where LDX .GE. N. -C X contains the matrix whose singular value -C decomposition is to be computed. X is -C destroyed by CSVDC. -C -C LDX INTEGER. -C LDX is the leading dimension of the array X. -C -C N INTEGER. -C N is the number of rows of the matrix X. -C -C P INTEGER. -C P is the number of columns of the matrix X. -C -C LDU INTEGER. -C LDU is the leading dimension of the array U -C (see below). -C -C LDV INTEGER. -C LDV is the leading dimension of the array V -C (see below). -C -C WORK COMPLEX(N). -C WORK is a scratch array. -C -C JOB INTEGER. -C JOB controls the computation of the singular -C vectors. It has the decimal expansion AB -C with the following meaning -C -C A .EQ. 0 Do not compute the left singular -C vectors. -C A .EQ. 1 Return the N left singular vectors -C in U. -C A .GE. 2 Return the first MIN(N,P) -C left singular vectors in U. -C B .EQ. 0 Do not compute the right singular -C vectors. -C B .EQ. 1 Return the right singular vectors -C in V. -C -C On Return -C -C S COMPLEX(MM), where MM = MIN(N+1,P). -C The first MIN(N,P) entries of S contain the -C singular values of X arranged in descending -C order of magnitude. -C -C E COMPLEX(P). -C E ordinarily contains zeros. However see the -C discussion of INFO for exceptions. -C -C U COMPLEX(LDU,K), where LDU .GE. N. If JOBA .EQ. 1 -C then K .EQ. N. If JOBA .GE. 2 then -C K .EQ. MIN(N,P). -C U contains the matrix of right singular vectors. -C U is not referenced if JOBA .EQ. 0. If N .LE. P -C or if JOBA .GT. 2, then U may be identified with X -C in the subroutine call. -C -C V COMPLEX(LDV,P), where LDV .GE. P. -C V contains the matrix of right singular vectors. -C V is not referenced if JOB .EQ. 0. If P .LE. N, -C then V may be identified with X in the -C subroutine call. -C -C INFO INTEGER. -C The singular values (and their corresponding -C singular vectors) S(INFO+1),S(INFO+2),...,S(M) -C are correct (here M=MIN(N,P)). Thus if -C INFO.EQ. 0, all the singular values and their -C vectors are correct. In any event, the matrix -C B = CTRANS(U)*X*V is the bidiagonal matrix -C with the elements of S on its diagonal and the -C elements of E on its super-diagonal (CTRANS(U) -C is the conjugate-transpose of U). Thus the -C singular values of X and B are the same. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CDOTC, CSCAL, CSROT, CSWAP, SCNRM2, SROTG -C***REVISION HISTORY (YYMMDD) -C 790319 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CSVDC - INTEGER LDX,N,P,LDU,LDV,JOB,INFO - COMPLEX X(LDX,*),S(*),E(*),U(LDU,*),V(LDV,*),WORK(*) -C -C - INTEGER I,ITER,J,JOBU,K,KASE,KK,L,LL,LLS,LM1,LP1,LS,LU,M,MAXIT, - 1 MM,MM1,MP1,NCT,NCTP1,NCU,NRT,NRTP1 - COMPLEX CDOTC,T,R - REAL B,C,CS,EL,EMM1,F,G,SCNRM2,SCALE,SHIFT,SL,SM,SN,SMM1,T1,TEST, - 1 ZTEST - LOGICAL WANTU,WANTV - COMPLEX CSIGN,ZDUM,ZDUM1,ZDUM2 - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) - CSIGN(ZDUM1,ZDUM2) = ABS(ZDUM1)*(ZDUM2/ABS(ZDUM2)) -C***FIRST EXECUTABLE STATEMENT CSVDC -C -C SET THE MAXIMUM NUMBER OF ITERATIONS. -C - MAXIT = 30 -C -C DETERMINE WHAT IS TO BE COMPUTED. -C - WANTU = .FALSE. - WANTV = .FALSE. - JOBU = MOD(JOB,100)/10 - NCU = N - IF (JOBU .GT. 1) NCU = MIN(N,P) - IF (JOBU .NE. 0) WANTU = .TRUE. - IF (MOD(JOB,10) .NE. 0) WANTV = .TRUE. -C -C REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS -C IN S AND THE SUPER-DIAGONAL ELEMENTS IN E. -C - INFO = 0 - NCT = MIN(N-1,P) - NRT = MAX(0,MIN(P-2,N)) - LU = MAX(NCT,NRT) - IF (LU .LT. 1) GO TO 170 - DO 160 L = 1, LU - LP1 = L + 1 - IF (L .GT. NCT) GO TO 20 -C -C COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND -C PLACE THE L-TH DIAGONAL IN S(L). -C - S(L) = CMPLX(SCNRM2(N-L+1,X(L,L),1),0.0E0) - IF (CABS1(S(L)) .EQ. 0.0E0) GO TO 10 - IF (CABS1(X(L,L)) .NE. 0.0E0) S(L) = CSIGN(S(L),X(L,L)) - CALL CSCAL(N-L+1,1.0E0/S(L),X(L,L),1) - X(L,L) = (1.0E0,0.0E0) + X(L,L) - 10 CONTINUE - S(L) = -S(L) - 20 CONTINUE - IF (P .LT. LP1) GO TO 50 - DO 40 J = LP1, P - IF (L .GT. NCT) GO TO 30 - IF (CABS1(S(L)) .EQ. 0.0E0) GO TO 30 -C -C APPLY THE TRANSFORMATION. -C - T = -CDOTC(N-L+1,X(L,L),1,X(L,J),1)/X(L,L) - CALL CAXPY(N-L+1,T,X(L,L),1,X(L,J),1) - 30 CONTINUE -C -C PLACE THE L-TH ROW OF X INTO E FOR THE -C SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION. -C - E(J) = CONJG(X(L,J)) - 40 CONTINUE - 50 CONTINUE - IF (.NOT.WANTU .OR. L .GT. NCT) GO TO 70 -C -C PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK -C MULTIPLICATION. -C - DO 60 I = L, N - U(I,L) = X(I,L) - 60 CONTINUE - 70 CONTINUE - IF (L .GT. NRT) GO TO 150 -C -C COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE -C L-TH SUPER-DIAGONAL IN E(L). -C - E(L) = CMPLX(SCNRM2(P-L,E(LP1),1),0.0E0) - IF (CABS1(E(L)) .EQ. 0.0E0) GO TO 80 - IF (CABS1(E(LP1)) .NE. 0.0E0) E(L) = CSIGN(E(L),E(LP1)) - CALL CSCAL(P-L,1.0E0/E(L),E(LP1),1) - E(LP1) = (1.0E0,0.0E0) + E(LP1) - 80 CONTINUE - E(L) = -CONJG(E(L)) - IF (LP1 .GT. N .OR. CABS1(E(L)) .EQ. 0.0E0) GO TO 120 -C -C APPLY THE TRANSFORMATION. -C - DO 90 I = LP1, N - WORK(I) = (0.0E0,0.0E0) - 90 CONTINUE - DO 100 J = LP1, P - CALL CAXPY(N-L,E(J),X(LP1,J),1,WORK(LP1),1) - 100 CONTINUE - DO 110 J = LP1, P - CALL CAXPY(N-L,CONJG(-E(J)/E(LP1)),WORK(LP1),1, - 1 X(LP1,J),1) - 110 CONTINUE - 120 CONTINUE - IF (.NOT.WANTV) GO TO 140 -C -C PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT -C BACK MULTIPLICATION. -C - DO 130 I = LP1, P - V(I,L) = E(I) - 130 CONTINUE - 140 CONTINUE - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE -C -C SET UP THE FINAL BIDIAGONAL MATRIX OR ORDER M. -C - M = MIN(P,N+1) - NCTP1 = NCT + 1 - NRTP1 = NRT + 1 - IF (NCT .LT. P) S(NCTP1) = X(NCTP1,NCTP1) - IF (N .LT. M) S(M) = (0.0E0,0.0E0) - IF (NRTP1 .LT. M) E(NRTP1) = X(NRTP1,M) - E(M) = (0.0E0,0.0E0) -C -C IF REQUIRED, GENERATE U. -C - IF (.NOT.WANTU) GO TO 300 - IF (NCU .LT. NCTP1) GO TO 200 - DO 190 J = NCTP1, NCU - DO 180 I = 1, N - U(I,J) = (0.0E0,0.0E0) - 180 CONTINUE - U(J,J) = (1.0E0,0.0E0) - 190 CONTINUE - 200 CONTINUE - IF (NCT .LT. 1) GO TO 290 - DO 280 LL = 1, NCT - L = NCT - LL + 1 - IF (CABS1(S(L)) .EQ. 0.0E0) GO TO 250 - LP1 = L + 1 - IF (NCU .LT. LP1) GO TO 220 - DO 210 J = LP1, NCU - T = -CDOTC(N-L+1,U(L,L),1,U(L,J),1)/U(L,L) - CALL CAXPY(N-L+1,T,U(L,L),1,U(L,J),1) - 210 CONTINUE - 220 CONTINUE - CALL CSCAL(N-L+1,(-1.0E0,0.0E0),U(L,L),1) - U(L,L) = (1.0E0,0.0E0) + U(L,L) - LM1 = L - 1 - IF (LM1 .LT. 1) GO TO 240 - DO 230 I = 1, LM1 - U(I,L) = (0.0E0,0.0E0) - 230 CONTINUE - 240 CONTINUE - GO TO 270 - 250 CONTINUE - DO 260 I = 1, N - U(I,L) = (0.0E0,0.0E0) - 260 CONTINUE - U(L,L) = (1.0E0,0.0E0) - 270 CONTINUE - 280 CONTINUE - 290 CONTINUE - 300 CONTINUE -C -C IF IT IS REQUIRED, GENERATE V. -C - IF (.NOT.WANTV) GO TO 350 - DO 340 LL = 1, P - L = P - LL + 1 - LP1 = L + 1 - IF (L .GT. NRT) GO TO 320 - IF (CABS1(E(L)) .EQ. 0.0E0) GO TO 320 - DO 310 J = LP1, P - T = -CDOTC(P-L,V(LP1,L),1,V(LP1,J),1)/V(LP1,L) - CALL CAXPY(P-L,T,V(LP1,L),1,V(LP1,J),1) - 310 CONTINUE - 320 CONTINUE - DO 330 I = 1, P - V(I,L) = (0.0E0,0.0E0) - 330 CONTINUE - V(L,L) = (1.0E0,0.0E0) - 340 CONTINUE - 350 CONTINUE -C -C TRANSFORM S AND E SO THAT THEY ARE REAL. -C - DO 380 I = 1, M - IF (CABS1(S(I)) .EQ. 0.0E0) GO TO 360 - T = CMPLX(ABS(S(I)),0.0E0) - R = S(I)/T - S(I) = T - IF (I .LT. M) E(I) = E(I)/R - IF (WANTU) CALL CSCAL(N,R,U(1,I),1) - 360 CONTINUE - IF (I .EQ. M) GO TO 390 - IF (CABS1(E(I)) .EQ. 0.0E0) GO TO 370 - T = CMPLX(ABS(E(I)),0.0E0) - R = T/E(I) - E(I) = T - S(I+1) = S(I+1)*R - IF (WANTV) CALL CSCAL(P,R,V(1,I+1),1) - 370 CONTINUE - 380 CONTINUE - 390 CONTINUE -C -C MAIN ITERATION LOOP FOR THE SINGULAR VALUES. -C - MM = M - ITER = 0 - 400 CONTINUE -C -C QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND. -C - IF (M .EQ. 0) GO TO 660 -C -C IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET -C FLAG AND RETURN. -C - IF (ITER .LT. MAXIT) GO TO 410 - INFO = M - GO TO 660 - 410 CONTINUE -C -C THIS SECTION OF THE PROGRAM INSPECTS FOR -C NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS. ON -C COMPLETION THE VARIABLES KASE AND L ARE SET AS FOLLOWS. -C -C KASE = 1 IF S(M) AND E(L-1) ARE NEGLIGIBLE AND L.LT.M -C KASE = 2 IF S(L) IS NEGLIGIBLE AND L.LT.M -C KASE = 3 IF E(L-1) IS NEGLIGIBLE, L.LT.M, AND -C S(L), ..., S(M) ARE NOT NEGLIGIBLE (QR STEP). -C KASE = 4 IF E(M-1) IS NEGLIGIBLE (CONVERGENCE). -C - DO 430 LL = 1, M - L = M - LL - IF (L .EQ. 0) GO TO 440 - TEST = ABS(S(L)) + ABS(S(L+1)) - ZTEST = TEST + ABS(E(L)) - IF (ZTEST .NE. TEST) GO TO 420 - E(L) = (0.0E0,0.0E0) - GO TO 440 - 420 CONTINUE - 430 CONTINUE - 440 CONTINUE - IF (L .NE. M - 1) GO TO 450 - KASE = 4 - GO TO 520 - 450 CONTINUE - LP1 = L + 1 - MP1 = M + 1 - DO 470 LLS = LP1, MP1 - LS = M - LLS + LP1 - IF (LS .EQ. L) GO TO 480 - TEST = 0.0E0 - IF (LS .NE. M) TEST = TEST + ABS(E(LS)) - IF (LS .NE. L + 1) TEST = TEST + ABS(E(LS-1)) - ZTEST = TEST + ABS(S(LS)) - IF (ZTEST .NE. TEST) GO TO 460 - S(LS) = (0.0E0,0.0E0) - GO TO 480 - 460 CONTINUE - 470 CONTINUE - 480 CONTINUE - IF (LS .NE. L) GO TO 490 - KASE = 3 - GO TO 510 - 490 CONTINUE - IF (LS .NE. M) GO TO 500 - KASE = 1 - GO TO 510 - 500 CONTINUE - KASE = 2 - L = LS - 510 CONTINUE - 520 CONTINUE - L = L + 1 -C -C PERFORM THE TASK INDICATED BY KASE. -C - GO TO (530, 560, 580, 610), KASE -C -C DEFLATE NEGLIGIBLE S(M). -C - 530 CONTINUE - MM1 = M - 1 - F = REAL(E(M-1)) - E(M-1) = (0.0E0,0.0E0) - DO 550 KK = L, MM1 - K = MM1 - KK + L - T1 = REAL(S(K)) - CALL SROTG(T1,F,CS,SN) - S(K) = CMPLX(T1,0.0E0) - IF (K .EQ. L) GO TO 540 - F = -SN*REAL(E(K-1)) - E(K-1) = CS*E(K-1) - 540 CONTINUE - IF (WANTV) CALL CSROT(P,V(1,K),1,V(1,M),1,CS,SN) - 550 CONTINUE - GO TO 650 -C -C SPLIT AT NEGLIGIBLE S(L). -C - 560 CONTINUE - F = REAL(E(L-1)) - E(L-1) = (0.0E0,0.0E0) - DO 570 K = L, M - T1 = REAL(S(K)) - CALL SROTG(T1,F,CS,SN) - S(K) = CMPLX(T1,0.0E0) - F = -SN*REAL(E(K)) - E(K) = CS*E(K) - IF (WANTU) CALL CSROT(N,U(1,K),1,U(1,L-1),1,CS,SN) - 570 CONTINUE - GO TO 650 -C -C PERFORM ONE QR STEP. -C - 580 CONTINUE -C -C CALCULATE THE SHIFT. -C - SCALE = MAX(ABS(S(M)),ABS(S(M-1)),ABS(E(M-1)), - 1 ABS(S(L)),ABS(E(L))) - SM = REAL(S(M))/SCALE - SMM1 = REAL(S(M-1))/SCALE - EMM1 = REAL(E(M-1))/SCALE - SL = REAL(S(L))/SCALE - EL = REAL(E(L))/SCALE - B = ((SMM1 + SM)*(SMM1 - SM) + EMM1**2)/2.0E0 - C = (SM*EMM1)**2 - SHIFT = 0.0E0 - IF (B .EQ. 0.0E0 .AND. C .EQ. 0.0E0) GO TO 590 - SHIFT = SQRT(B**2+C) - IF (B .LT. 0.0E0) SHIFT = -SHIFT - SHIFT = C/(B + SHIFT) - 590 CONTINUE - F = (SL + SM)*(SL - SM) - SHIFT - G = SL*EL -C -C CHASE ZEROS. -C - MM1 = M - 1 - DO 600 K = L, MM1 - CALL SROTG(F,G,CS,SN) - IF (K .NE. L) E(K-1) = CMPLX(F,0.0E0) - F = CS*REAL(S(K)) + SN*REAL(E(K)) - E(K) = CS*E(K) - SN*S(K) - G = SN*REAL(S(K+1)) - S(K+1) = CS*S(K+1) - IF (WANTV) CALL CSROT(P,V(1,K),1,V(1,K+1),1,CS,SN) - CALL SROTG(F,G,CS,SN) - S(K) = CMPLX(F,0.0E0) - F = CS*REAL(E(K)) + SN*REAL(S(K+1)) - S(K+1) = -SN*E(K) + CS*S(K+1) - G = SN*REAL(E(K+1)) - E(K+1) = CS*E(K+1) - IF (WANTU .AND. K .LT. N) - 1 CALL CSROT(N,U(1,K),1,U(1,K+1),1,CS,SN) - 600 CONTINUE - E(M-1) = CMPLX(F,0.0E0) - ITER = ITER + 1 - GO TO 650 -C -C CONVERGENCE. -C - 610 CONTINUE -C -C MAKE THE SINGULAR VALUE POSITIVE -C - IF (REAL(S(L)) .GE. 0.0E0) GO TO 620 - S(L) = -S(L) - IF (WANTV) CALL CSCAL(P,(-1.0E0,0.0E0),V(1,L),1) - 620 CONTINUE -C -C ORDER THE SINGULAR VALUE. -C - 630 IF (L .EQ. MM) GO TO 640 - IF (REAL(S(L)) .GE. REAL(S(L+1))) GO TO 640 - T = S(L) - S(L) = S(L+1) - S(L+1) = T - IF (WANTV .AND. L .LT. P) - 1 CALL CSWAP(P,V(1,L),1,V(1,L+1),1) - IF (WANTU .AND. L .LT. N) - 1 CALL CSWAP(N,U(1,L),1,U(1,L+1),1) - L = L + 1 - GO TO 630 - 640 CONTINUE - ITER = 0 - M = M - 1 - 650 CONTINUE - GO TO 400 - 660 CONTINUE - RETURN - END diff --git a/slatec/cswap.f b/slatec/cswap.f deleted file mode 100644 index 3e1fc62..0000000 --- a/slatec/cswap.f +++ /dev/null @@ -1,76 +0,0 @@ -*DECK CSWAP - SUBROUTINE CSWAP (N, CX, INCX, CY, INCY) -C***BEGIN PROLOGUE CSWAP -C***PURPOSE Interchange two vectors. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A5 -C***TYPE COMPLEX (SSWAP-S, DSWAP-D, CSWAP-C, ISWAP-I) -C***KEYWORDS BLAS, INTERCHANGE, 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 CX complex vector with N elements -C INCX storage spacing between elements of CX -C CY complex vector with N elements -C INCY storage spacing between elements of CY -C -C --Output-- -C CX input vector CY (unchanged if N .LE. 0) -C CY input vector CX (unchanged if N .LE. 0) -C -C Interchange complex CX and complex CY -C For I = 0 to N-1, interchange CX(LX+I*INCX) and CY(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 CSWAP - COMPLEX CX(*),CY(*),CTEMP -C***FIRST EXECUTABLE STATEMENT CSWAP - 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 - CTEMP = CX(KX) - CX(KX) = CY(KY) - CY(KY) = CTEMP - 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 - CTEMP = CX(I) - CX(I) = CY(I) - CY(I) = CTEMP - 30 CONTINUE - RETURN - END diff --git a/slatec/csymm.f b/slatec/csymm.f deleted file mode 100644 index 152c571..0000000 --- a/slatec/csymm.f +++ /dev/null @@ -1,303 +0,0 @@ -*DECK CSYMM - SUBROUTINE CSYMM (SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, - $ C, LDC) -C***BEGIN PROLOGUE CSYMM -C***PURPOSE Multiply a complex general matrix by a complex symmetric -C matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B6 -C***TYPE COMPLEX (SSYMM-S, DSYMM-D, CSYMM-C) -C***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J., (ANL) -C Duff, I., (AERE) -C Du Croz, J., (NAG) -C Hammarling, S. (NAG) -C***DESCRIPTION -C -C CSYMM performs one of the matrix-matrix operations -C -C C := alpha*A*B + beta*C, -C -C or -C -C C := alpha*B*A + beta*C, -C -C where alpha and beta are scalars, A is a symmetric matrix and B and -C C are m by n matrices. -C -C Parameters -C ========== -C -C SIDE - CHARACTER*1. -C On entry, SIDE specifies whether the symmetric matrix A -C appears on the left or right in the operation as follows: -C -C SIDE = 'L' or 'l' C := alpha*A*B + beta*C, -C -C SIDE = 'R' or 'r' C := alpha*B*A + beta*C, -C -C Unchanged on exit. -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the symmetric matrix A is to be -C referenced as follows: -C -C UPLO = 'U' or 'u' Only the upper triangular part of the -C symmetric matrix is to be referenced. -C -C UPLO = 'L' or 'l' Only the lower triangular part of the -C symmetric matrix is to be referenced. -C -C Unchanged on exit. -C -C M - INTEGER. -C On entry, M specifies the number of rows of the matrix C. -C M must be at least zero. -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the number of columns of the matrix C. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - COMPLEX . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is -C m when SIDE = 'L' or 'l' and is n otherwise. -C Before entry with SIDE = 'L' or 'l', the m by m part of -C the array A must contain the symmetric matrix, such that -C when UPLO = 'U' or 'u', the leading m by m upper triangular -C part of the array A must contain the upper triangular part -C of the symmetric matrix and the strictly lower triangular -C part of A is not referenced, and when UPLO = 'L' or 'l', -C the leading m by m lower triangular part of the array A -C must contain the lower triangular part of the symmetric -C matrix and the strictly upper triangular part of A is not -C referenced. -C Before entry with SIDE = 'R' or 'r', the n by n part of -C the array A must contain the symmetric matrix, such that -C when UPLO = 'U' or 'u', the leading n by n upper triangular -C part of the array A must contain the upper triangular part -C of the symmetric matrix and the strictly lower triangular -C part of A is not referenced, and when UPLO = 'L' or 'l', -C the leading n by n lower triangular part of the array A -C must contain the lower triangular part of the symmetric -C matrix and the strictly upper triangular part of A is not -C referenced. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. When SIDE = 'L' or 'l' then -C LDA must be at least max( 1, m ), otherwise LDA must be at -C least max( 1, n ). -C Unchanged on exit. -C -C B - COMPLEX array of DIMENSION ( LDB, n ). -C Before entry, the leading m by n part of the array B must -C contain the matrix B. -C Unchanged on exit. -C -C LDB - INTEGER. -C On entry, LDB specifies the first dimension of B as declared -C in the calling (sub) program. LDB must be at least -C max( 1, m ). -C Unchanged on exit. -C -C BETA - COMPLEX . -C On entry, BETA specifies the scalar beta. When BETA is -C supplied as zero then C need not be set on input. -C Unchanged on exit. -C -C C - COMPLEX array of DIMENSION ( LDC, n ). -C Before entry, the leading m by n part of the array C must -C contain the matrix C, except when beta is zero, in which -C case C need not be set on entry. -C On exit, the array C is overwritten by the m by n updated -C matrix. -C -C LDC - INTEGER. -C On entry, LDC specifies the first dimension of C as declared -C in the calling (sub) program. LDC must be at least -C max( 1, m ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. -C A set of level 3 basic linear algebra subprograms. -C ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 890208 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE CSYMM -C .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO - INTEGER M, N, LDA, LDB, LDC - COMPLEX ALPHA, BETA -C .. Array Arguments .. - COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, K, NROWA - COMPLEX TEMP1, TEMP2 -C .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -C***FIRST EXECUTABLE STATEMENT CSYMM -C -C Set NROWA as the number of rows of A. -C - IF( LSAME( SIDE, 'L' ) )THEN - NROWA = M - ELSE - NROWA = N - END IF - UPPER = LSAME( UPLO, 'U' ) -C -C Test the input parameters. -C - 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( 'CSYMM ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C And when alpha.eq.zero. -C - 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 -C -C Start the operations. -C - IF( LSAME( SIDE, 'L' ) )THEN -C -C Form C := alpha*A*B + beta*C. -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 -C -C Form C := alpha*B*A + beta*C. -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 -C - RETURN -C -C End of CSYMM . -C - END diff --git a/slatec/csyr2k.f b/slatec/csyr2k.f deleted file mode 100644 index 1be52be..0000000 --- a/slatec/csyr2k.f +++ /dev/null @@ -1,331 +0,0 @@ -*DECK CSYR2K - SUBROUTINE CSYR2K (UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, - $ C, LDC) -C***BEGIN PROLOGUE CSYR2K -C***PURPOSE Perform symmetric rank 2k update of a complex symmetric -C matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B6 -C***TYPE COMPLEX (SSYR2-S, DSYR2-D, CSYR2-C, CSYR2K-C) -C***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J., (ANL) -C Duff, I., (AERE) -C Du Croz, J., (NAG) -C Hammarling, S. (NAG) -C***DESCRIPTION -C -C CSYR2K performs one of the symmetric rank 2k operations -C -C C := alpha*A*B' + alpha*B*A' + beta*C, -C -C or -C -C C := alpha*A'*B + alpha*B'*A + beta*C, -C -C where alpha and beta are scalars, C is an n by n symmetric matrix -C and A and B are n by k matrices in the first case and k by n -C matrices in the second case. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the array C is to be referenced as -C follows: -C -C UPLO = 'U' or 'u' Only the upper triangular part of C -C is to be referenced. -C -C UPLO = 'L' or 'l' Only the lower triangular part of C -C is to be referenced. -C -C Unchanged on exit. -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the operation to be performed as -C follows: -C -C TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + -C beta*C. -C -C TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + -C beta*C. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix C. N must be -C at least zero. -C Unchanged on exit. -C -C K - INTEGER. -C On entry with TRANS = 'N' or 'n', K specifies the number -C of columns of the matrices A and B, and on entry with -C TRANS = 'T' or 't', K specifies the number of rows of the -C matrices A and B. K must be at least zero. -C Unchanged on exit. -C -C ALPHA - COMPLEX . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is -C k when TRANS = 'N' or 'n', and is n otherwise. -C Before entry with TRANS = 'N' or 'n', the leading n by k -C part of the array A must contain the matrix A, otherwise -C the leading k by n part of the array A must contain the -C matrix A. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. When TRANS = 'N' or 'n' -C then LDA must be at least max( 1, n ), otherwise LDA must -C be at least max( 1, k ). -C Unchanged on exit. -C -C B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is -C k when TRANS = 'N' or 'n', and is n otherwise. -C Before entry with TRANS = 'N' or 'n', the leading n by k -C part of the array B must contain the matrix B, otherwise -C the leading k by n part of the array B must contain the -C matrix B. -C Unchanged on exit. -C -C LDB - INTEGER. -C On entry, LDB specifies the first dimension of B as declared -C in the calling (sub) program. When TRANS = 'N' or 'n' -C then LDB must be at least max( 1, n ), otherwise LDB must -C be at least max( 1, k ). -C Unchanged on exit. -C -C BETA - COMPLEX . -C On entry, BETA specifies the scalar beta. -C Unchanged on exit. -C -C C - COMPLEX array of DIMENSION ( LDC, n ). -C Before entry with UPLO = 'U' or 'u', the leading n by n -C upper triangular part of the array C must contain the upper -C triangular part of the symmetric matrix and the strictly -C lower triangular part of C is not referenced. On exit, the -C upper triangular part of the array C is overwritten by the -C upper triangular part of the updated matrix. -C Before entry with UPLO = 'L' or 'l', the leading n by n -C lower triangular part of the array C must contain the lower -C triangular part of the symmetric matrix and the strictly -C upper triangular part of C is not referenced. On exit, the -C lower triangular part of the array C is overwritten by the -C lower triangular part of the updated matrix. -C -C LDC - INTEGER. -C On entry, LDC specifies the first dimension of C as declared -C in the calling (sub) program. LDC must be at least -C max( 1, n ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. -C A set of level 3 basic linear algebra subprograms. -C ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 890208 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE CSYR2K -C .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDB, LDC - COMPLEX ALPHA, BETA -C .. Array Arguments .. - COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - COMPLEX TEMP1, TEMP2 -C .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -C***FIRST EXECUTABLE STATEMENT CSYR2K -C -C Test the input parameters. -C - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -C - INFO = 0 - IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'T' ) ) )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( 'CSYR2K', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C And when alpha.eq.zero. -C - 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 -C -C Start the operations. -C - IF( LSAME( TRANS, 'N' ) )THEN -C -C Form C := alpha*A*B' + alpha*B*A' + C. -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 -C -C Form C := alpha*A'*B + alpha*B'*A + C. -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 -C - RETURN -C -C End of CSYR2K. -C - END diff --git a/slatec/csyrk.f b/slatec/csyrk.f deleted file mode 100644 index 3e6c5d3..0000000 --- a/slatec/csyrk.f +++ /dev/null @@ -1,299 +0,0 @@ -*DECK CSYRK - SUBROUTINE CSYRK (UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC) -C***BEGIN PROLOGUE CSYRK -C***PURPOSE Perform symmetric rank k update of a complex symmetric -C matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B6 -C***TYPE COMPLEX (SSYRK-S, DSYRK-D, CSYRK-C) -C***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J., (ANL) -C Duff, I., (AERE) -C Du Croz, J., (NAG) -C Hammarling, S. (NAG) -C***DESCRIPTION -C -C CSYRK performs one of the symmetric rank k operations -C -C C := alpha*A*A' + beta*C, -C -C or -C -C C := alpha*A'*A + beta*C, -C -C where alpha and beta are scalars, C is an n by n symmetric matrix -C and A is an n by k matrix in the first case and a k by n matrix -C in the second case. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the array C is to be referenced as -C follows: -C -C UPLO = 'U' or 'u' Only the upper triangular part of C -C is to be referenced. -C -C UPLO = 'L' or 'l' Only the lower triangular part of C -C is to be referenced. -C -C Unchanged on exit. -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the operation to be performed as -C follows: -C -C TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. -C -C TRANS = 'T' or 't' C := alpha*A'*A + beta*C. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix C. N must be -C at least zero. -C Unchanged on exit. -C -C K - INTEGER. -C On entry with TRANS = 'N' or 'n', K specifies the number -C of columns of the matrix A, and on entry with -C TRANS = 'T' or 't', K specifies the number of rows of the -C matrix A. K must be at least zero. -C Unchanged on exit. -C -C ALPHA - COMPLEX . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is -C k when TRANS = 'N' or 'n', and is n otherwise. -C Before entry with TRANS = 'N' or 'n', the leading n by k -C part of the array A must contain the matrix A, otherwise -C the leading k by n part of the array A must contain the -C matrix A. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. When TRANS = 'N' or 'n' -C then LDA must be at least max( 1, n ), otherwise LDA must -C be at least max( 1, k ). -C Unchanged on exit. -C -C BETA - COMPLEX . -C On entry, BETA specifies the scalar beta. -C Unchanged on exit. -C -C C - COMPLEX array of DIMENSION ( LDC, n ). -C Before entry with UPLO = 'U' or 'u', the leading n by n -C upper triangular part of the array C must contain the upper -C triangular part of the symmetric matrix and the strictly -C lower triangular part of C is not referenced. On exit, the -C upper triangular part of the array C is overwritten by the -C upper triangular part of the updated matrix. -C Before entry with UPLO = 'L' or 'l', the leading n by n -C lower triangular part of the array C must contain the lower -C triangular part of the symmetric matrix and the strictly -C upper triangular part of C is not referenced. On exit, the -C lower triangular part of the array C is overwritten by the -C lower triangular part of the updated matrix. -C -C LDC - INTEGER. -C On entry, LDC specifies the first dimension of C as declared -C in the calling (sub) program. LDC must be at least -C max( 1, n ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. -C A set of level 3 basic linear algebra subprograms. -C ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 890208 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE CSYRK -C .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDC - COMPLEX ALPHA, BETA -C .. Array Arguments .. - COMPLEX A( LDA, * ), C( LDC, * ) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - COMPLEX TEMP -C .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -C***FIRST EXECUTABLE STATEMENT CSYRK -C -C Test the input parameters. -C - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -C - INFO = 0 - IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'T' ) ) )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( 'CSYRK ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C And when alpha.eq.zero. -C - 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 -C -C Start the operations. -C - IF( LSAME( TRANS, 'N' ) )THEN -C -C Form C := alpha*A*A' + beta*C. -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 -C -C Form C := alpha*A'*A + beta*C. -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 -C - RETURN -C -C End of CSYRK . -C - END diff --git a/slatec/ctan.f b/slatec/ctan.f deleted file mode 100644 index 64c1e3a..0000000 --- a/slatec/ctan.f +++ /dev/null @@ -1,50 +0,0 @@ -*DECK CTAN - COMPLEX FUNCTION CTAN (Z) -C***BEGIN PROLOGUE CTAN -C***PURPOSE Compute the complex tangent. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4A -C***TYPE COMPLEX (CTAN-C) -C***KEYWORDS ELEMENTARY FUNCTIONS, FNLIB, TANGENT, TRIGONOMETRIC -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C CTAN(Z) calculates the complex trigonometric tangent of complex -C argument Z. Z is in units of radians. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH, XERCLR, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 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***END PROLOGUE CTAN - COMPLEX Z - SAVE SQEPS - DATA SQEPS /0./ -C***FIRST EXECUTABLE STATEMENT CTAN - IF (SQEPS.EQ.0.) SQEPS = SQRT (R1MACH(4)) -C - X2 = 2.0*REAL(Z) - Y2 = 2.0*AIMAG(Z) -C - SN2X = SIN (X2) - CALL XERCLR -C - DEN = COS(X2) + COSH(Y2) - IF (DEN .EQ. 0.) CALL XERMSG ('SLATEC', 'CTAN', - + 'TAN IS SINGULAR FOR INPUT Z (X IS PI/2 OR 3*PI/2 AND Y IS 0)', - + 2, 2) -C - IF (ABS(DEN).GT.MAX(ABS(X2),1.)*SQEPS) GO TO 10 - CALL XERCLR - CALL XERMSG ('SLATEC', 'CTAN', - + 'ANSWER LT HALF PRECISION, ABS(X) TOO BIG OR X TOO NEAR ' // - + 'PI/2 OR 3*PI/2', 1, 1) -C - 10 CTAN = CMPLX (SN2X/DEN, SINH(Y2)/DEN) -C - RETURN - END diff --git a/slatec/ctanh.f b/slatec/ctanh.f deleted file mode 100644 index ab50e2d..0000000 --- a/slatec/ctanh.f +++ /dev/null @@ -1,29 +0,0 @@ -*DECK CTANH - COMPLEX FUNCTION CTANH (Z) -C***BEGIN PROLOGUE CTANH -C***PURPOSE Compute the complex hyperbolic tangent. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4C -C***TYPE COMPLEX (CTANH-C) -C***KEYWORDS ELEMENTARY FUNCTIONS, FNLIB, HYPERBOLIC TANGENT -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C CTANH(Z) calculates the complex hyperbolic tangent of complex -C argument Z. Z is in units of radians. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CTAN -C***REVISION HISTORY (YYMMDD) -C 770401 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CTANH - COMPLEX Z, CI, CTAN - SAVE CI - DATA CI /(0.,1.)/ -C***FIRST EXECUTABLE STATEMENT CTANH - CTANH = -CI*CTAN(CI*Z) -C - RETURN - END diff --git a/slatec/ctbmv.f b/slatec/ctbmv.f deleted file mode 100644 index 58b2d8e..0000000 --- a/slatec/ctbmv.f +++ /dev/null @@ -1,385 +0,0 @@ -*DECK CTBMV - SUBROUTINE CTBMV (UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) -C***BEGIN PROLOGUE CTBMV -C***PURPOSE Multiply a complex vector by a complex triangular band -C matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE COMPLEX (STBMV-S, DTBMV-D, CTBMV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C CTBMV performs one of the matrix-vector operations -C -C x := A*x, or x := A'*x, or x := conjg( A')*x, -C -C where x is an n element vector and A is an n by n unit, or non-unit, -C upper or lower triangular band matrix, with ( k + 1 ) diagonals. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the matrix is an upper or -C lower triangular matrix as follows: -C -C UPLO = 'U' or 'u' A is an upper triangular matrix. -C -C UPLO = 'L' or 'l' A is a lower triangular matrix. -C -C Unchanged on exit. -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the operation to be performed as -C follows: -C -C TRANS = 'N' or 'n' x := A*x. -C -C TRANS = 'T' or 't' x := A'*x. -C -C TRANS = 'C' or 'c' x := conjg( A' )*x. -C -C Unchanged on exit. -C -C DIAG - CHARACTER*1. -C On entry, DIAG specifies whether or not A is unit -C triangular as follows: -C -C DIAG = 'U' or 'u' A is assumed to be unit triangular. -C -C DIAG = 'N' or 'n' A is not assumed to be unit -C triangular. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C K - INTEGER. -C On entry with UPLO = 'U' or 'u', K specifies the number of -C super-diagonals of the matrix A. -C On entry with UPLO = 'L' or 'l', K specifies the number of -C sub-diagonals of the matrix A. -C K must satisfy 0 .le. K. -C Unchanged on exit. -C -C A - COMPLEX array of DIMENSION ( LDA, n ). -C Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -C by n part of the array A must contain the upper triangular -C band part of the matrix of coefficients, supplied column by -C column, with the leading diagonal of the matrix in row -C ( k + 1 ) of the array, the first super-diagonal starting at -C position 2 in row k, and so on. The top left k by k triangle -C of the array A is not referenced. -C The following program segment will transfer an upper -C triangular band matrix from conventional full matrix storage -C to band storage: -C -C DO 20, J = 1, N -C M = K + 1 - J -C DO 10, I = MAX( 1, J - K ), J -C A( M + I, J ) = matrix( I, J ) -C 10 CONTINUE -C 20 CONTINUE -C -C Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -C by n part of the array A must contain the lower triangular -C band part of the matrix of coefficients, supplied column by -C column, with the leading diagonal of the matrix in row 1 of -C the array, the first sub-diagonal starting at position 1 in -C row 2, and so on. The bottom right k by k triangle of the -C array A is not referenced. -C The following program segment will transfer a lower -C triangular band matrix from conventional full matrix storage -C to band storage: -C -C DO 20, J = 1, N -C M = 1 - J -C DO 10, I = J, MIN( N, J + K ) -C A( M + I, J ) = matrix( I, J ) -C 10 CONTINUE -C 20 CONTINUE -C -C Note that when DIAG = 'U' or 'u' the elements of the array A -C corresponding to the diagonal elements of the matrix are not -C referenced, but are assumed to be unity. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C ( k + 1 ). -C Unchanged on exit. -C -C X - COMPLEX array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element vector x. On exit, X is overwritten with the -C transformed vector x. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE CTBMV -C .. Scalar Arguments .. - INTEGER INCX, K, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -C .. Array Arguments .. - COMPLEX A( LDA, * ), X( * ) -C .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -C .. Local Scalars .. - COMPLEX TEMP - INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L - LOGICAL NOCONJ, NOUNIT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC CONJG, MAX, MIN -C***FIRST EXECUTABLE STATEMENT CTBMV -C -C Test the input parameters. -C - 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( 'CTBMV ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - NOCONJ = LSAME( TRANS, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) -C -C Set up the start point in X if the increment is not unity. This -C will be ( N - 1 )*INCX too small for descending loops. -C - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through A. -C - IF( LSAME( TRANS, 'N' ) )THEN -C -C Form x := A*x. -C - 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 -C -C Form x := A'*x or x := conjg( A' )*x. -C - IF( LSAME( UPLO, 'U' ) )THEN - KPLUS1 = K + 1 - IF( INCX.EQ.1 )THEN - DO 110, J = N, 1, -1 - TEMP = X( J ) - L = KPLUS1 - J - IF( NOCONJ )THEN - 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 - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( A( KPLUS1, J ) ) - DO 100, I = J - 1, MAX( 1, J - K ), -1 - TEMP = TEMP + CONJG( A( L + I, J ) )*X( I ) - 100 CONTINUE - END IF - X( J ) = TEMP - 110 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 140, J = N, 1, -1 - TEMP = X( JX ) - KX = KX - INCX - IX = KX - L = KPLUS1 - J - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( KPLUS1, J ) - DO 120, I = J - 1, MAX( 1, J - K ), -1 - TEMP = TEMP + A( L + I, J )*X( IX ) - IX = IX - INCX - 120 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( A( KPLUS1, J ) ) - DO 130, I = J - 1, MAX( 1, J - K ), -1 - TEMP = TEMP + CONJG( A( L + I, J ) )*X( IX ) - IX = IX - INCX - 130 CONTINUE - END IF - X( JX ) = TEMP - JX = JX - INCX - 140 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 170, J = 1, N - TEMP = X( J ) - L = 1 - J - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( 1, J ) - DO 150, I = J + 1, MIN( N, J + K ) - TEMP = TEMP + A( L + I, J )*X( I ) - 150 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( A( 1, J ) ) - DO 160, I = J + 1, MIN( N, J + K ) - TEMP = TEMP + CONJG( A( L + I, J ) )*X( I ) - 160 CONTINUE - END IF - X( J ) = TEMP - 170 CONTINUE - ELSE - JX = KX - DO 200, J = 1, N - TEMP = X( JX ) - KX = KX + INCX - IX = KX - L = 1 - J - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( 1, J ) - DO 180, I = J + 1, MIN( N, J + K ) - TEMP = TEMP + A( L + I, J )*X( IX ) - IX = IX + INCX - 180 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( A( 1, J ) ) - DO 190, I = J + 1, MIN( N, J + K ) - TEMP = TEMP + CONJG( A( L + I, J ) )*X( IX ) - IX = IX + INCX - 190 CONTINUE - END IF - X( JX ) = TEMP - JX = JX + INCX - 200 CONTINUE - END IF - END IF - END IF -C - RETURN -C -C End of CTBMV . -C - END diff --git a/slatec/ctbsv.f b/slatec/ctbsv.f deleted file mode 100644 index 2592f0e..0000000 --- a/slatec/ctbsv.f +++ /dev/null @@ -1,388 +0,0 @@ -*DECK CTBSV - SUBROUTINE CTBSV (UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) -C***BEGIN PROLOGUE CTBSV -C***PURPOSE Solve a complex triangular banded system of equations. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE COMPLEX (STBSV-S, DTBSV-D, CTBSV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C CTBSV solves one of the systems of equations -C -C A*x = b, or A'*x = b, or conjg( A')*x = b, -C -C where b and x are n element vectors and A is an n by n unit, or -C non-unit, upper or lower triangular band matrix, with ( k + 1 ) -C diagonals. -C -C No test for singularity or near-singularity is included in this -C routine. Such tests must be performed before calling this routine. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the matrix is an upper or -C lower triangular matrix as follows: -C -C UPLO = 'U' or 'u' A is an upper triangular matrix. -C -C UPLO = 'L' or 'l' A is a lower triangular matrix. -C -C Unchanged on exit. -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the equations to be solved as -C follows: -C -C TRANS = 'N' or 'n' A*x = b. -C -C TRANS = 'T' or 't' A'*x = b. -C -C TRANS = 'C' or 'c' conjg( A' )*x = b. -C -C Unchanged on exit. -C -C DIAG - CHARACTER*1. -C On entry, DIAG specifies whether or not A is unit -C triangular as follows: -C -C DIAG = 'U' or 'u' A is assumed to be unit triangular. -C -C DIAG = 'N' or 'n' A is not assumed to be unit -C triangular. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C K - INTEGER. -C On entry with UPLO = 'U' or 'u', K specifies the number of -C super-diagonals of the matrix A. -C On entry with UPLO = 'L' or 'l', K specifies the number of -C sub-diagonals of the matrix A. -C K must satisfy 0 .le. K. -C Unchanged on exit. -C -C A - COMPLEX array of DIMENSION ( LDA, n ). -C Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -C by n part of the array A must contain the upper triangular -C band part of the matrix of coefficients, supplied column by -C column, with the leading diagonal of the matrix in row -C ( k + 1 ) of the array, the first super-diagonal starting at -C position 2 in row k, and so on. The top left k by k triangle -C of the array A is not referenced. -C The following program segment will transfer an upper -C triangular band matrix from conventional full matrix storage -C to band storage: -C -C DO 20, J = 1, N -C M = K + 1 - J -C DO 10, I = MAX( 1, J - K ), J -C A( M + I, J ) = matrix( I, J ) -C 10 CONTINUE -C 20 CONTINUE -C -C Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -C by n part of the array A must contain the lower triangular -C band part of the matrix of coefficients, supplied column by -C column, with the leading diagonal of the matrix in row 1 of -C the array, the first sub-diagonal starting at position 1 in -C row 2, and so on. The bottom right k by k triangle of the -C array A is not referenced. -C The following program segment will transfer a lower -C triangular band matrix from conventional full matrix storage -C to band storage: -C -C DO 20, J = 1, N -C M = 1 - J -C DO 10, I = J, MIN( N, J + K ) -C A( M + I, J ) = matrix( I, J ) -C 10 CONTINUE -C 20 CONTINUE -C -C Note that when DIAG = 'U' or 'u' the elements of the array A -C corresponding to the diagonal elements of the matrix are not -C referenced, but are assumed to be unity. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C ( k + 1 ). -C Unchanged on exit. -C -C X - COMPLEX array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element right-hand side vector b. On exit, X is overwritten -C with the solution vector x. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE CTBSV -C .. Scalar Arguments .. - INTEGER INCX, K, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -C .. Array Arguments .. - COMPLEX A( LDA, * ), X( * ) -C .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -C .. Local Scalars .. - COMPLEX TEMP - INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L - LOGICAL NOCONJ, NOUNIT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC CONJG, MAX, MIN -C***FIRST EXECUTABLE STATEMENT CTBSV -C -C Test the input parameters. -C - 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( 'CTBSV ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - NOCONJ = LSAME( TRANS, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) -C -C Set up the start point in X if the increment is not unity. This -C will be ( N - 1 )*INCX too small for descending loops. -C - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -C -C Start the operations. In this version the elements of A are -C accessed by sequentially with one pass through A. -C - IF( LSAME( TRANS, 'N' ) )THEN -C -C Form x := inv( A )*x. -C - 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 -C -C Form x := inv( A' )*x or x := inv( conjg( A') )*x. -C - IF( LSAME( UPLO, 'U' ) )THEN - KPLUS1 = K + 1 - IF( INCX.EQ.1 )THEN - DO 110, J = 1, N - TEMP = X( J ) - L = KPLUS1 - J - IF( NOCONJ )THEN - 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 ) - ELSE - DO 100, I = MAX( 1, J - K ), J - 1 - TEMP = TEMP - CONJG( A( L + I, J ) )*X( I ) - 100 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/CONJG( A( KPLUS1, J ) ) - END IF - X( J ) = TEMP - 110 CONTINUE - ELSE - JX = KX - DO 140, J = 1, N - TEMP = X( JX ) - IX = KX - L = KPLUS1 - J - IF( NOCONJ )THEN - DO 120, I = MAX( 1, J - K ), J - 1 - TEMP = TEMP - A( L + I, J )*X( IX ) - IX = IX + INCX - 120 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( KPLUS1, J ) - ELSE - DO 130, I = MAX( 1, J - K ), J - 1 - TEMP = TEMP - CONJG( A( L + I, J ) )*X( IX ) - IX = IX + INCX - 130 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/CONJG( A( KPLUS1, J ) ) - END IF - X( JX ) = TEMP - JX = JX + INCX - IF( J.GT.K ) - $ KX = KX + INCX - 140 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 170, J = N, 1, -1 - TEMP = X( J ) - L = 1 - J - IF( NOCONJ )THEN - DO 150, I = MIN( N, J + K ), J + 1, -1 - TEMP = TEMP - A( L + I, J )*X( I ) - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( 1, J ) - ELSE - DO 160, I = MIN( N, J + K ), J + 1, -1 - TEMP = TEMP - CONJG( A( L + I, J ) )*X( I ) - 160 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/CONJG( A( 1, J ) ) - END IF - X( J ) = TEMP - 170 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 200, J = N, 1, -1 - TEMP = X( JX ) - IX = KX - L = 1 - J - IF( NOCONJ )THEN - DO 180, I = MIN( N, J + K ), J + 1, -1 - TEMP = TEMP - A( L + I, J )*X( IX ) - IX = IX - INCX - 180 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( 1, J ) - ELSE - DO 190, I = MIN( N, J + K ), J + 1, -1 - TEMP = TEMP - CONJG( A( L + I, J ) )*X( IX ) - IX = IX - INCX - 190 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/CONJG( A( 1, J ) ) - END IF - X( JX ) = TEMP - JX = JX - INCX - IF( ( N - J ).GE.K ) - $ KX = KX - INCX - 200 CONTINUE - END IF - END IF - END IF -C - RETURN -C -C End of CTBSV . -C - END diff --git a/slatec/ctpmv.f b/slatec/ctpmv.f deleted file mode 100644 index 30d528a..0000000 --- a/slatec/ctpmv.f +++ /dev/null @@ -1,345 +0,0 @@ -*DECK CTPMV - SUBROUTINE CTPMV (UPLO, TRANS, DIAG, N, AP, X, INCX) -C***BEGIN PROLOGUE CTPMV -C***PURPOSE Perform one of the matrix-vector operations. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE COMPLEX (STPMV-S, DTPMV-D, CTPMV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C CTPMV performs one of the matrix-vector operations -C -C x := A*x, or x := A'*x, or x := conjg( A')*x, -C -C where x is an n element vector and A is an n by n unit, or non-unit, -C upper or lower triangular matrix, supplied in packed form. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the matrix is an upper or -C lower triangular matrix as follows: -C -C UPLO = 'U' or 'u' A is an upper triangular matrix. -C -C UPLO = 'L' or 'l' A is a lower triangular matrix. -C -C Unchanged on exit. -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the operation to be performed as -C follows: -C -C TRANS = 'N' or 'n' x := A*x. -C -C TRANS = 'T' or 't' x := A'*x. -C -C TRANS = 'C' or 'c' x := conjg( A' )*x. -C -C Unchanged on exit. -C -C DIAG - CHARACTER*1. -C On entry, DIAG specifies whether or not A is unit -C triangular as follows: -C -C DIAG = 'U' or 'u' A is assumed to be unit triangular. -C -C DIAG = 'N' or 'n' A is not assumed to be unit -C triangular. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C AP - COMPLEX array of DIMENSION at least -C ( ( n*( n + 1 ) )/2 ). -C Before entry with UPLO = 'U' or 'u', the array AP must -C contain the upper triangular matrix packed sequentially, -C column by column, so that AP( 1 ) contains a( 1, 1 ), -C AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) -C respectively, and so on. -C Before entry with UPLO = 'L' or 'l', the array AP must -C contain the lower triangular matrix packed sequentially, -C column by column, so that AP( 1 ) contains a( 1, 1 ), -C AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) -C respectively, and so on. -C Note that when DIAG = 'U' or 'u', the diagonal elements of -C A are not referenced, but are assumed to be unity. -C Unchanged on exit. -C -C X - COMPLEX array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element vector x. On exit, X is overwritten with the -C transformed vector x. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE CTPMV -C .. Scalar Arguments .. - INTEGER INCX, N - CHARACTER*1 DIAG, TRANS, UPLO -C .. Array Arguments .. - COMPLEX AP( * ), X( * ) -C .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -C .. Local Scalars .. - COMPLEX TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX - LOGICAL NOCONJ, NOUNIT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC CONJG -C***FIRST EXECUTABLE STATEMENT CTPMV -C -C Test the input parameters. -C - 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( 'CTPMV ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - NOCONJ = LSAME( TRANS, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) -C -C Set up the start point in X if the increment is not unity. This -C will be ( N - 1 )*INCX too small for descending loops. -C - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -C -C Start the operations. In this version the elements of AP are -C accessed sequentially with one pass through AP. -C - IF( LSAME( TRANS, 'N' ) )THEN -C -C Form x:= A*x. -C - 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 -C -C Form x := A'*x or x := conjg( A' )*x. -C - IF( LSAME( UPLO, 'U' ) )THEN - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 110, J = N, 1, -1 - TEMP = X( J ) - K = KK - 1 - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - DO 90, I = J - 1, 1, -1 - TEMP = TEMP + AP( K )*X( I ) - K = K - 1 - 90 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( AP( KK ) ) - DO 100, I = J - 1, 1, -1 - TEMP = TEMP + CONJG( AP( K ) )*X( I ) - K = K - 1 - 100 CONTINUE - END IF - X( J ) = TEMP - KK = KK - J - 110 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 140, J = N, 1, -1 - TEMP = X( JX ) - IX = JX - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - DO 120, K = KK - 1, KK - J + 1, -1 - IX = IX - INCX - TEMP = TEMP + AP( K )*X( IX ) - 120 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( AP( KK ) ) - DO 130, K = KK - 1, KK - J + 1, -1 - IX = IX - INCX - TEMP = TEMP + CONJG( AP( K ) )*X( IX ) - 130 CONTINUE - END IF - X( JX ) = TEMP - JX = JX - INCX - KK = KK - J - 140 CONTINUE - END IF - ELSE - KK = 1 - IF( INCX.EQ.1 )THEN - DO 170, J = 1, N - TEMP = X( J ) - K = KK + 1 - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - DO 150, I = J + 1, N - TEMP = TEMP + AP( K )*X( I ) - K = K + 1 - 150 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( AP( KK ) ) - DO 160, I = J + 1, N - TEMP = TEMP + CONJG( AP( K ) )*X( I ) - K = K + 1 - 160 CONTINUE - END IF - X( J ) = TEMP - KK = KK + ( N - J + 1 ) - 170 CONTINUE - ELSE - JX = KX - DO 200, J = 1, N - TEMP = X( JX ) - IX = JX - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - DO 180, K = KK + 1, KK + N - J - IX = IX + INCX - TEMP = TEMP + AP( K )*X( IX ) - 180 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( AP( KK ) ) - DO 190, K = KK + 1, KK + N - J - IX = IX + INCX - TEMP = TEMP + CONJG( AP( K ) )*X( IX ) - 190 CONTINUE - END IF - X( JX ) = TEMP - JX = JX + INCX - KK = KK + ( N - J + 1 ) - 200 CONTINUE - END IF - END IF - END IF -C - RETURN -C -C End of CTPMV . -C - END diff --git a/slatec/ctpsv.f b/slatec/ctpsv.f deleted file mode 100644 index 74a190d..0000000 --- a/slatec/ctpsv.f +++ /dev/null @@ -1,348 +0,0 @@ -*DECK CTPSV - SUBROUTINE CTPSV (UPLO, TRANS, DIAG, N, AP, X, INCX) -C***BEGIN PROLOGUE CTPSV -C***PURPOSE Solve one of the systems of equations. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE COMPLEX (STPSV-S, DTPSV-D, CTPSV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C CTPSV solves one of the systems of equations -C -C A*x = b, or A'*x = b, or conjg( A')*x = b, -C -C where b and x are n element vectors and A is an n by n unit, or -C non-unit, upper or lower triangular matrix, supplied in packed form. -C -C No test for singularity or near-singularity is included in this -C routine. Such tests must be performed before calling this routine. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the matrix is an upper or -C lower triangular matrix as follows: -C -C UPLO = 'U' or 'u' A is an upper triangular matrix. -C -C UPLO = 'L' or 'l' A is a lower triangular matrix. -C -C Unchanged on exit. -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the equations to be solved as -C follows: -C -C TRANS = 'N' or 'n' A*x = b. -C -C TRANS = 'T' or 't' A'*x = b. -C -C TRANS = 'C' or 'c' conjg( A' )*x = b. -C -C Unchanged on exit. -C -C DIAG - CHARACTER*1. -C On entry, DIAG specifies whether or not A is unit -C triangular as follows: -C -C DIAG = 'U' or 'u' A is assumed to be unit triangular. -C -C DIAG = 'N' or 'n' A is not assumed to be unit -C triangular. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C AP - COMPLEX array of DIMENSION at least -C ( ( n*( n + 1 ) )/2 ). -C Before entry with UPLO = 'U' or 'u', the array AP must -C contain the upper triangular matrix packed sequentially, -C column by column, so that AP( 1 ) contains a( 1, 1 ), -C AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) -C respectively, and so on. -C Before entry with UPLO = 'L' or 'l', the array AP must -C contain the lower triangular matrix packed sequentially, -C column by column, so that AP( 1 ) contains a( 1, 1 ), -C AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) -C respectively, and so on. -C Note that when DIAG = 'U' or 'u', the diagonal elements of -C A are not referenced, but are assumed to be unity. -C Unchanged on exit. -C -C X - COMPLEX array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element right-hand side vector b. On exit, X is overwritten -C with the solution vector x. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE CTPSV -C .. Scalar Arguments .. - INTEGER INCX, N - CHARACTER*1 DIAG, TRANS, UPLO -C .. Array Arguments .. - COMPLEX AP( * ), X( * ) -C .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -C .. Local Scalars .. - COMPLEX TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX - LOGICAL NOCONJ, NOUNIT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC CONJG -C***FIRST EXECUTABLE STATEMENT CTPSV -C -C Test the input parameters. -C - 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( 'CTPSV ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - NOCONJ = LSAME( TRANS, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) -C -C Set up the start point in X if the increment is not unity. This -C will be ( N - 1 )*INCX too small for descending loops. -C - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -C -C Start the operations. In this version the elements of AP are -C accessed sequentially with one pass through AP. -C - IF( LSAME( TRANS, 'N' ) )THEN -C -C Form x := inv( A )*x. -C - 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 -C -C Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. -C - IF( LSAME( UPLO, 'U' ) )THEN - KK = 1 - IF( INCX.EQ.1 )THEN - DO 110, J = 1, N - TEMP = X( J ) - K = KK - IF( NOCONJ )THEN - 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 ) - ELSE - DO 100, I = 1, J - 1 - TEMP = TEMP - CONJG( AP( K ) )*X( I ) - K = K + 1 - 100 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/CONJG( AP( KK + J - 1 ) ) - END IF - X( J ) = TEMP - KK = KK + J - 110 CONTINUE - ELSE - JX = KX - DO 140, J = 1, N - TEMP = X( JX ) - IX = KX - IF( NOCONJ )THEN - DO 120, K = KK, KK + J - 2 - TEMP = TEMP - AP( K )*X( IX ) - IX = IX + INCX - 120 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK + J - 1 ) - ELSE - DO 130, K = KK, KK + J - 2 - TEMP = TEMP - CONJG( AP( K ) )*X( IX ) - IX = IX + INCX - 130 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/CONJG( AP( KK + J - 1 ) ) - END IF - X( JX ) = TEMP - JX = JX + INCX - KK = KK + J - 140 CONTINUE - END IF - ELSE - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 170, J = N, 1, -1 - TEMP = X( J ) - K = KK - IF( NOCONJ )THEN - DO 150, I = N, J + 1, -1 - TEMP = TEMP - AP( K )*X( I ) - K = K - 1 - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK - N + J ) - ELSE - DO 160, I = N, J + 1, -1 - TEMP = TEMP - CONJG( AP( K ) )*X( I ) - K = K - 1 - 160 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/CONJG( AP( KK - N + J ) ) - END IF - X( J ) = TEMP - KK = KK - ( N - J + 1 ) - 170 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 200, J = N, 1, -1 - TEMP = X( JX ) - IX = KX - IF( NOCONJ )THEN - DO 180, K = KK, KK - ( N - ( J + 1 ) ), -1 - TEMP = TEMP - AP( K )*X( IX ) - IX = IX - INCX - 180 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK - N + J ) - ELSE - DO 190, K = KK, KK - ( N - ( J + 1 ) ), -1 - TEMP = TEMP - CONJG( AP( K ) )*X( IX ) - IX = IX - INCX - 190 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/CONJG( AP( KK - N + J ) ) - END IF - X( JX ) = TEMP - JX = JX - INCX - KK = KK - ( N - J + 1 ) - 200 CONTINUE - END IF - END IF - END IF -C - RETURN -C -C End of CTPSV . -C - END diff --git a/slatec/ctrco.f b/slatec/ctrco.f deleted file mode 100644 index 82474fd..0000000 --- a/slatec/ctrco.f +++ /dev/null @@ -1,179 +0,0 @@ -*DECK CTRCO - SUBROUTINE CTRCO (T, LDT, N, RCOND, Z, JOB) -C***BEGIN PROLOGUE CTRCO -C***PURPOSE Estimate the condition number of a triangular matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2C3 -C***TYPE COMPLEX (STRCO-S, DTRCO-D, CTRCO-C) -C***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, -C TRIANGULAR MATRIX -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C CTRCO estimates the condition of a complex triangular matrix. -C -C On Entry -C -C T COMPLEX(LDT,N) -C T contains the triangular matrix. The zero -C elements of the matrix are not referenced, and -C the corresponding elements of the array can be -C used to store other information. -C -C LDT INTEGER -C LDT is the leading dimension of the array T. -C -C N INTEGER -C N is the order of the system. -C -C JOB INTEGER -C = 0 T is lower triangular. -C = nonzero T is upper triangular. -C -C On Return -C -C RCOND REAL -C an estimate of the reciprocal condition of T . -C For the system T*X = B , relative perturbations -C in T 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 T 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 COMPLEX(N) -C a work vector whose contents are usually unimportant. -C If T 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***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CSSCAL, SCASUM -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CTRCO - INTEGER LDT,N,JOB - COMPLEX T(LDT,*),Z(*) - REAL RCOND -C - COMPLEX W,WK,WKM,EK - REAL TNORM,YNORM,S,SM,SCASUM - INTEGER I1,J,J1,J2,K,KK,L - LOGICAL LOWER - COMPLEX ZDUM,ZDUM1,ZDUM2,CSIGN1 - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) - CSIGN1(ZDUM1,ZDUM2) = CABS1(ZDUM1)*(ZDUM2/CABS1(ZDUM2)) -C -C***FIRST EXECUTABLE STATEMENT CTRCO - LOWER = JOB .EQ. 0 -C -C COMPUTE 1-NORM OF T -C - TNORM = 0.0E0 - DO 10 J = 1, N - L = J - IF (LOWER) L = N + 1 - J - I1 = 1 - IF (LOWER) I1 = J - TNORM = MAX(TNORM,SCASUM(L,T(I1,J),1)) - 10 CONTINUE -C -C RCOND = 1/(NORM(T)*(ESTIMATE OF NORM(INVERSE(T)))) . -C ESTIMATE = NORM(Z)/NORM(Y) WHERE T*Z = Y AND CTRANS(T)*Y = E . -C CTRANS(T) IS THE CONJUGATE TRANSPOSE OF T . -C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL -C GROWTH IN THE ELEMENTS OF Y . -C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. -C -C SOLVE CTRANS(T)*Y = E -C - EK = (1.0E0,0.0E0) - DO 20 J = 1, N - Z(J) = (0.0E0,0.0E0) - 20 CONTINUE - DO 100 KK = 1, N - K = KK - IF (LOWER) K = N + 1 - KK - IF (CABS1(Z(K)) .NE. 0.0E0) EK = CSIGN1(EK,-Z(K)) - IF (CABS1(EK-Z(K)) .LE. CABS1(T(K,K))) GO TO 30 - S = CABS1(T(K,K))/CABS1(EK-Z(K)) - CALL CSSCAL(N,S,Z,1) - EK = CMPLX(S,0.0E0)*EK - 30 CONTINUE - WK = EK - Z(K) - WKM = -EK - Z(K) - S = CABS1(WK) - SM = CABS1(WKM) - IF (CABS1(T(K,K)) .EQ. 0.0E0) GO TO 40 - WK = WK/CONJG(T(K,K)) - WKM = WKM/CONJG(T(K,K)) - GO TO 50 - 40 CONTINUE - WK = (1.0E0,0.0E0) - WKM = (1.0E0,0.0E0) - 50 CONTINUE - IF (KK .EQ. N) GO TO 90 - J1 = K + 1 - IF (LOWER) J1 = 1 - J2 = N - IF (LOWER) J2 = K - 1 - DO 60 J = J1, J2 - SM = SM + CABS1(Z(J)+WKM*CONJG(T(K,J))) - Z(J) = Z(J) + WK*CONJG(T(K,J)) - S = S + CABS1(Z(J)) - 60 CONTINUE - IF (S .GE. SM) GO TO 80 - W = WKM - WK - WK = WKM - DO 70 J = J1, J2 - Z(J) = Z(J) + W*CONJG(T(K,J)) - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - Z(K) = WK - 100 CONTINUE - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) -C - YNORM = 1.0E0 -C -C SOLVE T*Z = Y -C - DO 130 KK = 1, N - K = N + 1 - KK - IF (LOWER) K = KK - IF (CABS1(Z(K)) .LE. CABS1(T(K,K))) GO TO 110 - S = CABS1(T(K,K))/CABS1(Z(K)) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM - 110 CONTINUE - IF (CABS1(T(K,K)) .NE. 0.0E0) Z(K) = Z(K)/T(K,K) - IF (CABS1(T(K,K)) .EQ. 0.0E0) Z(K) = (1.0E0,0.0E0) - I1 = 1 - IF (LOWER) I1 = K + 1 - IF (KK .GE. N) GO TO 120 - W = -Z(K) - CALL CAXPY(N-KK,W,T(I1,K),1,Z(I1),1) - 120 CONTINUE - 130 CONTINUE -C MAKE ZNORM = 1.0 - S = 1.0E0/SCASUM(N,Z,1) - CALL CSSCAL(N,S,Z,1) - YNORM = S*YNORM -C - IF (TNORM .NE. 0.0E0) RCOND = YNORM/TNORM - IF (TNORM .EQ. 0.0E0) RCOND = 0.0E0 - RETURN - END diff --git a/slatec/ctrdi.f b/slatec/ctrdi.f deleted file mode 100644 index 6edffe1..0000000 --- a/slatec/ctrdi.f +++ /dev/null @@ -1,149 +0,0 @@ -*DECK CTRDI - SUBROUTINE CTRDI (T, LDT, N, DET, JOB, INFO) -C***BEGIN PROLOGUE CTRDI -C***PURPOSE Compute the determinant and inverse of a triangular matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2C3, D3C3 -C***TYPE COMPLEX (STRDI-S, DTRDI-D, CTRDI-C) -C***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, -C TRIANGULAR MATRIX -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C CTRDI computes the determinant and inverse of a complex -C triangular matrix. -C -C On Entry -C -C T COMPLEX(LDT,N) -C T contains the triangular matrix. The zero -C elements of the matrix are not referenced, and -C the corresponding elements of the array can be -C used to store other information. -C -C LDT INTEGER -C LDT is the leading dimension of the array T. -C -C N INTEGER -C N is the order of the system. -C -C JOB INTEGER -C = 010 no det, inverse of lower triangular. -C = 011 no det, inverse of upper triangular. -C = 100 det, no inverse. -C = 110 det, inverse of lower triangular. -C = 111 det, inverse of upper triangular. -C -C On Return -C -C T inverse of original matrix if requested. -C Otherwise unchanged. -C -C DET COMPLEX(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. CABS1(DET(1)) .LT. 10.0 -C or DET(1) .EQ. 0.0 . -C -C INFO INTEGER -C INFO contains zero if the system is nonsingular -C and the inverse is requested. -C Otherwise INFO contains the index of -C a zero diagonal element of T. -C -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CSCAL -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CTRDI - INTEGER LDT,N,JOB,INFO - COMPLEX T(LDT,*),DET(2) -C - COMPLEX TEMP - REAL TEN - INTEGER I,J,K,KB,KM1,KP1 - COMPLEX ZDUM - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) -C***FIRST EXECUTABLE STATEMENT CTRDI -C -C COMPUTE DETERMINANT -C - IF (JOB/100 .EQ. 0) GO TO 70 - DET(1) = (1.0E0,0.0E0) - DET(2) = (0.0E0,0.0E0) - TEN = 10.0E0 - DO 50 I = 1, N - DET(1) = T(I,I)*DET(1) - IF (CABS1(DET(1)) .EQ. 0.0E0) GO TO 60 - 10 IF (CABS1(DET(1)) .GE. 1.0E0) GO TO 20 - DET(1) = CMPLX(TEN,0.0E0)*DET(1) - DET(2) = DET(2) - (1.0E0,0.0E0) - GO TO 10 - 20 CONTINUE - 30 IF (CABS1(DET(1)) .LT. TEN) GO TO 40 - DET(1) = DET(1)/CMPLX(TEN,0.0E0) - DET(2) = DET(2) + (1.0E0,0.0E0) - GO TO 30 - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE -C -C COMPUTE INVERSE OF UPPER TRIANGULAR -C - IF (MOD(JOB/10,10) .EQ. 0) GO TO 170 - IF (MOD(JOB,10) .EQ. 0) GO TO 120 - DO 100 K = 1, N - INFO = K - IF (CABS1(T(K,K)) .EQ. 0.0E0) GO TO 110 - T(K,K) = (1.0E0,0.0E0)/T(K,K) - TEMP = -T(K,K) - CALL CSCAL(K-1,TEMP,T(1,K),1) - KP1 = K + 1 - IF (N .LT. KP1) GO TO 90 - DO 80 J = KP1, N - TEMP = T(K,J) - T(K,J) = (0.0E0,0.0E0) - CALL CAXPY(K,TEMP,T(1,K),1,T(1,J),1) - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - INFO = 0 - 110 CONTINUE - GO TO 160 - 120 CONTINUE -C -C COMPUTE INVERSE OF LOWER TRIANGULAR -C - DO 150 KB = 1, N - K = N + 1 - KB - INFO = K - IF (CABS1(T(K,K)) .EQ. 0.0E0) GO TO 180 - T(K,K) = (1.0E0,0.0E0)/T(K,K) - TEMP = -T(K,K) - IF (K .NE. N) CALL CSCAL(N-K,TEMP,T(K+1,K),1) - KM1 = K - 1 - IF (KM1 .LT. 1) GO TO 140 - DO 130 J = 1, KM1 - TEMP = T(K,J) - T(K,J) = (0.0E0,0.0E0) - CALL CAXPY(N-K+1,TEMP,T(K,K),1,T(K,J),1) - 130 CONTINUE - 140 CONTINUE - 150 CONTINUE - INFO = 0 - 160 CONTINUE - 170 CONTINUE - 180 CONTINUE - RETURN - END diff --git a/slatec/ctrmm.f b/slatec/ctrmm.f deleted file mode 100644 index 80c035e..0000000 --- a/slatec/ctrmm.f +++ /dev/null @@ -1,399 +0,0 @@ -*DECK CTRMM - SUBROUTINE CTRMM (SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB) -C***BEGIN PROLOGUE CTRMM -C***PURPOSE Multiply a complex general matrix by a complex triangular -C matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B6 -C***TYPE COMPLEX (STRMM-S, DTRMM-D, CTRMM-C) -C***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J., (ANL) -C Duff, I., (AERE) -C Du Croz, J., (NAG) -C Hammarling, S. (NAG) -C***DESCRIPTION -C -C CTRMM performs one of the matrix-matrix operations -C -C B := alpha*op( A )*B, or B := alpha*B*op( A ) -C -C where alpha is a scalar, B is an m by n matrix, A is a unit, or -C non-unit, upper or lower triangular matrix and op( A ) is one of -C -C op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). -C -C Parameters -C ========== -C -C SIDE - CHARACTER*1. -C On entry, SIDE specifies whether op( A ) multiplies B from -C the left or right as follows: -C -C SIDE = 'L' or 'l' B := alpha*op( A )*B. -C -C SIDE = 'R' or 'r' B := alpha*B*op( A ). -C -C Unchanged on exit. -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the matrix A is an upper or -C lower triangular matrix as follows: -C -C UPLO = 'U' or 'u' A is an upper triangular matrix. -C -C UPLO = 'L' or 'l' A is a lower triangular matrix. -C -C Unchanged on exit. -C -C TRANSA - CHARACTER*1. -C On entry, TRANSA specifies the form of op( A ) to be used in -C the matrix multiplication as follows: -C -C TRANSA = 'N' or 'n' op( A ) = A. -C -C TRANSA = 'T' or 't' op( A ) = A'. -C -C TRANSA = 'C' or 'c' op( A ) = conjg( A' ). -C -C Unchanged on exit. -C -C DIAG - CHARACTER*1. -C On entry, DIAG specifies whether or not A is unit triangular -C as follows: -C -C DIAG = 'U' or 'u' A is assumed to be unit triangular. -C -C DIAG = 'N' or 'n' A is not assumed to be unit -C triangular. -C -C Unchanged on exit. -C -C M - INTEGER. -C On entry, M specifies the number of rows of B. M must be at -C least zero. -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the number of columns of B. N must be -C at least zero. -C Unchanged on exit. -C -C ALPHA - COMPLEX . -C On entry, ALPHA specifies the scalar alpha. When alpha is -C zero then A is not referenced and B need not be set before -C entry. -C Unchanged on exit. -C -C A - COMPLEX array of DIMENSION ( LDA, k ), where k is m -C when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -C Before entry with UPLO = 'U' or 'u', the leading k by k -C upper triangular part of the array A must contain the upper -C triangular matrix and the strictly lower triangular part of -C A is not referenced. -C Before entry with UPLO = 'L' or 'l', the leading k by k -C lower triangular part of the array A must contain the lower -C triangular matrix and the strictly upper triangular part of -C A is not referenced. -C Note that when DIAG = 'U' or 'u', the diagonal elements of -C A are not referenced either, but are assumed to be unity. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. When SIDE = 'L' or 'l' then -C LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -C then LDA must be at least max( 1, n ). -C Unchanged on exit. -C -C B - COMPLEX array of DIMENSION ( LDB, n ). -C Before entry, the leading m by n part of the array B must -C contain the matrix B, and on exit is overwritten by the -C transformed matrix. -C -C LDB - INTEGER. -C On entry, LDB specifies the first dimension of B as declared -C in the calling (sub) program. LDB must be at least -C max( 1, m ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. -C A set of level 3 basic linear algebra subprograms. -C ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 890208 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE CTRMM -C .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - COMPLEX ALPHA -C .. Array Arguments .. - COMPLEX A( LDA, * ), B( LDB, * ) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC CONJG, MAX -C .. Local Scalars .. - LOGICAL LSIDE, NOCONJ, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - COMPLEX TEMP -C .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -C***FIRST EXECUTABLE STATEMENT CTRMM -C -C Test the input parameters. -C - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOCONJ = LSAME( TRANSA, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -C - 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( 'CTRMM ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C -C And when alpha.eq.zero. -C - 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 -C -C Start the operations. -C - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) )THEN -C -C Form B := alpha*A*B. -C - 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 -C -C Form B := alpha*B*A' or B := alpha*B*conjg( A' ). -C - IF( UPPER )THEN - DO 120, J = 1, N - DO 110, I = M, 1, -1 - TEMP = B( I, J ) - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( I, I ) - DO 90, K = 1, I - 1 - TEMP = TEMP + A( K, I )*B( K, J ) - 90 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( A( I, I ) ) - DO 100, K = 1, I - 1 - TEMP = TEMP + CONJG( A( K, I ) )*B( K, J ) - 100 CONTINUE - END IF - B( I, J ) = ALPHA*TEMP - 110 CONTINUE - 120 CONTINUE - ELSE - DO 160, J = 1, N - DO 150, I = 1, M - TEMP = B( I, J ) - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( I, I ) - DO 130, K = I + 1, M - TEMP = TEMP + A( K, I )*B( K, J ) - 130 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( A( I, I ) ) - DO 140, K = I + 1, M - TEMP = TEMP + CONJG( A( K, I ) )*B( K, J ) - 140 CONTINUE - END IF - B( I, J ) = ALPHA*TEMP - 150 CONTINUE - 160 CONTINUE - END IF - END IF - ELSE - IF( LSAME( TRANSA, 'N' ) )THEN -C -C Form B := alpha*B*A. -C - IF( UPPER )THEN - DO 200, J = N, 1, -1 - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 170, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 170 CONTINUE - DO 190, K = 1, J - 1 - IF( A( K, J ).NE.ZERO )THEN - TEMP = ALPHA*A( K, J ) - DO 180, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 180 CONTINUE - END IF - 190 CONTINUE - 200 CONTINUE - ELSE - DO 240, J = 1, N - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 210, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 210 CONTINUE - DO 230, K = J + 1, N - IF( A( K, J ).NE.ZERO )THEN - TEMP = ALPHA*A( K, J ) - DO 220, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 220 CONTINUE - END IF - 230 CONTINUE - 240 CONTINUE - END IF - ELSE -C -C Form B := alpha*B*A' or B := alpha*B*conjg( A' ). -C - IF( UPPER )THEN - DO 280, K = 1, N - DO 260, J = 1, K - 1 - IF( A( J, K ).NE.ZERO )THEN - IF( NOCONJ )THEN - TEMP = ALPHA*A( J, K ) - ELSE - TEMP = ALPHA*CONJG( A( J, K ) ) - END IF - DO 250, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 250 CONTINUE - END IF - 260 CONTINUE - TEMP = ALPHA - IF( NOUNIT )THEN - IF( NOCONJ )THEN - TEMP = TEMP*A( K, K ) - ELSE - TEMP = TEMP*CONJG( A( K, K ) ) - END IF - END IF - IF( TEMP.NE.ONE )THEN - DO 270, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 270 CONTINUE - END IF - 280 CONTINUE - ELSE - DO 320, K = N, 1, -1 - DO 300, J = K + 1, N - IF( A( J, K ).NE.ZERO )THEN - IF( NOCONJ )THEN - TEMP = ALPHA*A( J, K ) - ELSE - TEMP = ALPHA*CONJG( A( J, K ) ) - END IF - DO 290, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 290 CONTINUE - END IF - 300 CONTINUE - TEMP = ALPHA - IF( NOUNIT )THEN - IF( NOCONJ )THEN - TEMP = TEMP*A( K, K ) - ELSE - TEMP = TEMP*CONJG( A( K, K ) ) - END IF - END IF - IF( TEMP.NE.ONE )THEN - DO 310, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 310 CONTINUE - END IF - 320 CONTINUE - END IF - END IF - END IF -C - RETURN -C -C End of CTRMM . -C - END diff --git a/slatec/ctrmv.f b/slatec/ctrmv.f deleted file mode 100644 index 4c82a11..0000000 --- a/slatec/ctrmv.f +++ /dev/null @@ -1,328 +0,0 @@ -*DECK CTRMV - SUBROUTINE CTRMV (UPLO, TRANS, DIAG, N, A, LDA, X, INCX) -C***BEGIN PROLOGUE CTRMV -C***PURPOSE Multiply a complex vector by a complex triangular matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE COMPLEX (STRMV-S, DTRMV-D, CTRMV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C CTRMV performs one of the matrix-vector operations -C -C x := A*x, or x := A'*x, or x := conjg( A')*x, -C -C where x is an n element vector and A is an n by n unit, or non-unit, -C upper or lower triangular matrix. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the matrix is an upper or -C lower triangular matrix as follows: -C -C UPLO = 'U' or 'u' A is an upper triangular matrix. -C -C UPLO = 'L' or 'l' A is a lower triangular matrix. -C -C Unchanged on exit. -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the operation to be performed as -C follows: -C -C TRANS = 'N' or 'n' x := A*x. -C -C TRANS = 'T' or 't' x := A'*x. -C -C TRANS = 'C' or 'c' x := conjg( A' )*x. -C -C Unchanged on exit. -C -C DIAG - CHARACTER*1. -C On entry, DIAG specifies whether or not A is unit -C triangular as follows: -C -C DIAG = 'U' or 'u' A is assumed to be unit triangular. -C -C DIAG = 'N' or 'n' A is not assumed to be unit -C triangular. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C A - COMPLEX array of DIMENSION ( LDA, n ). -C Before entry with UPLO = 'U' or 'u', the leading n by n -C upper triangular part of the array A must contain the upper -C triangular matrix and the strictly lower triangular part of -C A is not referenced. -C Before entry with UPLO = 'L' or 'l', the leading n by n -C lower triangular part of the array A must contain the lower -C triangular matrix and the strictly upper triangular part of -C A is not referenced. -C Note that when DIAG = 'U' or 'u', the diagonal elements of -C A are not referenced either, but are assumed to be unity. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C max( 1, n ). -C Unchanged on exit. -C -C X - COMPLEX array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element vector x. On exit, X is overwritten with the -C transformed vector x. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE CTRMV -C .. Scalar Arguments .. - INTEGER INCX, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -C .. Array Arguments .. - COMPLEX A( LDA, * ), X( * ) -C .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -C .. Local Scalars .. - COMPLEX TEMP - INTEGER I, INFO, IX, J, JX, KX - LOGICAL NOCONJ, NOUNIT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC CONJG, MAX -C***FIRST EXECUTABLE STATEMENT CTRMV -C -C Test the input parameters. -C - 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( 'CTRMV ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - NOCONJ = LSAME( TRANS, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) -C -C Set up the start point in X if the increment is not unity. This -C will be ( N - 1 )*INCX too small for descending loops. -C - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through A. -C - IF( LSAME( TRANS, 'N' ) )THEN -C -C Form x := A*x. -C - 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 -C -C Form x := A'*x or x := conjg( A' )*x. -C - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 110, J = N, 1, -1 - TEMP = X( J ) - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 90, I = J - 1, 1, -1 - TEMP = TEMP + A( I, J )*X( I ) - 90 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( A( J, J ) ) - DO 100, I = J - 1, 1, -1 - TEMP = TEMP + CONJG( A( I, J ) )*X( I ) - 100 CONTINUE - END IF - X( J ) = TEMP - 110 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 140, J = N, 1, -1 - TEMP = X( JX ) - IX = JX - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 120, I = J - 1, 1, -1 - IX = IX - INCX - TEMP = TEMP + A( I, J )*X( IX ) - 120 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( A( J, J ) ) - DO 130, I = J - 1, 1, -1 - IX = IX - INCX - TEMP = TEMP + CONJG( A( I, J ) )*X( IX ) - 130 CONTINUE - END IF - X( JX ) = TEMP - JX = JX - INCX - 140 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 170, J = 1, N - TEMP = X( J ) - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 150, I = J + 1, N - TEMP = TEMP + A( I, J )*X( I ) - 150 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( A( J, J ) ) - DO 160, I = J + 1, N - TEMP = TEMP + CONJG( A( I, J ) )*X( I ) - 160 CONTINUE - END IF - X( J ) = TEMP - 170 CONTINUE - ELSE - JX = KX - DO 200, J = 1, N - TEMP = X( JX ) - IX = JX - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 180, I = J + 1, N - IX = IX + INCX - TEMP = TEMP + A( I, J )*X( IX ) - 180 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( A( J, J ) ) - DO 190, I = J + 1, N - IX = IX + INCX - TEMP = TEMP + CONJG( A( I, J ) )*X( IX ) - 190 CONTINUE - END IF - X( JX ) = TEMP - JX = JX + INCX - 200 CONTINUE - END IF - END IF - END IF -C - RETURN -C -C End of CTRMV . -C - END diff --git a/slatec/ctrsl.f b/slatec/ctrsl.f deleted file mode 100644 index daba033..0000000 --- a/slatec/ctrsl.f +++ /dev/null @@ -1,150 +0,0 @@ -*DECK CTRSL - SUBROUTINE CTRSL (T, LDT, N, B, JOB, INFO) -C***BEGIN PROLOGUE CTRSL -C***PURPOSE Solve a system of the form T*X=B or CTRANS(T)*X=B, where -C T is a triangular matrix. Here CTRANS(T) is the conjugate -C transpose. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2C3 -C***TYPE COMPLEX (STRSL-S, DTRSL-D, CTRSL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, TRIANGULAR LINEAR SYSTEM, -C TRIANGULAR MATRIX -C***AUTHOR Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C CTRSL solves systems of the form -C -C T * X = B -C or -C CTRANS(T) * X = B -C -C where T is a triangular matrix of order N. Here CTRANS(T) -C denotes the conjugate transpose of the matrix T. -C -C On Entry -C -C T COMPLEX(LDT,N) -C T contains the matrix of the system. The zero -C elements of the matrix are not referenced, and -C the corresponding elements of the array can be -C used to store other information. -C -C LDT INTEGER -C LDT is the leading dimension of the array T. -C -C N INTEGER -C N is the order of the system. -C -C B COMPLEX(N). -C B contains the right hand side of the system. -C -C JOB INTEGER -C JOB specifies what kind of system is to be solved. -C If JOB is -C -C 00 solve T*X = B, T lower triangular, -C 01 solve T*X = B, T upper triangular, -C 10 solve CTRANS(T)*X = B, T lower triangular, -C 11 solve CTRANS(T)*X = B, T upper triangular. -C -C On Return -C -C B B contains the solution, if INFO .EQ. 0. -C Otherwise B is unaltered. -C -C INFO INTEGER -C INFO contains zero if the system is nonsingular. -C Otherwise INFO contains the index of -C the first zero diagonal element of T. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED CAXPY, CDOTC -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CTRSL - INTEGER LDT,N,JOB,INFO - COMPLEX T(LDT,*),B(*) -C -C - COMPLEX CDOTC,TEMP - INTEGER CASE,J,JJ - COMPLEX ZDUM - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) -C***FIRST EXECUTABLE STATEMENT CTRSL -C -C CHECK FOR ZERO DIAGONAL ELEMENTS. -C - DO 10 INFO = 1, N - IF (CABS1(T(INFO,INFO)) .EQ. 0.0E0) GO TO 150 - 10 CONTINUE - INFO = 0 -C -C DETERMINE THE TASK AND GO TO IT. -C - CASE = 1 - IF (MOD(JOB,10) .NE. 0) CASE = 2 - IF (MOD(JOB,100)/10 .NE. 0) CASE = CASE + 2 - GO TO (20,50,80,110), CASE -C -C SOLVE T*X=B FOR T LOWER TRIANGULAR -C - 20 CONTINUE - B(1) = B(1)/T(1,1) - IF (N .LT. 2) GO TO 40 - DO 30 J = 2, N - TEMP = -B(J-1) - CALL CAXPY(N-J+1,TEMP,T(J,J-1),1,B(J),1) - B(J) = B(J)/T(J,J) - 30 CONTINUE - 40 CONTINUE - GO TO 140 -C -C SOLVE T*X=B FOR T UPPER TRIANGULAR. -C - 50 CONTINUE - B(N) = B(N)/T(N,N) - IF (N .LT. 2) GO TO 70 - DO 60 JJ = 2, N - J = N - JJ + 1 - TEMP = -B(J+1) - CALL CAXPY(J,TEMP,T(1,J+1),1,B(1),1) - B(J) = B(J)/T(J,J) - 60 CONTINUE - 70 CONTINUE - GO TO 140 -C -C SOLVE CTRANS(T)*X=B FOR T LOWER TRIANGULAR. -C - 80 CONTINUE - B(N) = B(N)/CONJG(T(N,N)) - IF (N .LT. 2) GO TO 100 - DO 90 JJ = 2, N - J = N - JJ + 1 - B(J) = B(J) - CDOTC(JJ-1,T(J+1,J),1,B(J+1),1) - B(J) = B(J)/CONJG(T(J,J)) - 90 CONTINUE - 100 CONTINUE - GO TO 140 -C -C SOLVE CTRANS(T)*X=B FOR T UPPER TRIANGULAR. -C - 110 CONTINUE - B(1) = B(1)/CONJG(T(1,1)) - IF (N .LT. 2) GO TO 130 - DO 120 J = 2, N - B(J) = B(J) - CDOTC(J-1,T(1,J),1,B(1),1) - B(J) = B(J)/CONJG(T(J,J)) - 120 CONTINUE - 130 CONTINUE - 140 CONTINUE - 150 CONTINUE - RETURN - END diff --git a/slatec/ctrsm.f b/slatec/ctrsm.f deleted file mode 100644 index da18cea..0000000 --- a/slatec/ctrsm.f +++ /dev/null @@ -1,421 +0,0 @@ -*DECK CTRSM - SUBROUTINE CTRSM (SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB) -C***BEGIN PROLOGUE CTRSM -C***PURPOSE Solve a complex triangular system of equations with -C multiple right-hand sides. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B6 -C***TYPE COMPLEX (STRSM-S, DTRSM-D, CTRSM-C) -C***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J., (ANL) -C Duff, I., (AERE) -C Du Croz, J., (NAG) -C Hammarling, S. (NAG) -C***DESCRIPTION -C -C CTRSM solves one of the matrix equations -C -C op( A )*X = alpha*B, or X*op( A ) = alpha*B, -C -C where alpha is a scalar, X and B are m by n matrices, A is a unit, or -C non-unit, upper or lower triangular matrix and op( A ) is one of -C -C op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). -C -C The matrix X is overwritten on B. -C -C Parameters -C ========== -C -C SIDE - CHARACTER*1. -C On entry, SIDE specifies whether op( A ) appears on the left -C or right of X as follows: -C -C SIDE = 'L' or 'l' op( A )*X = alpha*B. -C -C SIDE = 'R' or 'r' X*op( A ) = alpha*B. -C -C Unchanged on exit. -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the matrix A is an upper or -C lower triangular matrix as follows: -C -C UPLO = 'U' or 'u' A is an upper triangular matrix. -C -C UPLO = 'L' or 'l' A is a lower triangular matrix. -C -C Unchanged on exit. -C -C TRANSA - CHARACTER*1. -C On entry, TRANSA specifies the form of op( A ) to be used in -C the matrix multiplication as follows: -C -C TRANSA = 'N' or 'n' op( A ) = A. -C -C TRANSA = 'T' or 't' op( A ) = A'. -C -C TRANSA = 'C' or 'c' op( A ) = conjg( A' ). -C -C Unchanged on exit. -C -C DIAG - CHARACTER*1. -C On entry, DIAG specifies whether or not A is unit triangular -C as follows: -C -C DIAG = 'U' or 'u' A is assumed to be unit triangular. -C -C DIAG = 'N' or 'n' A is not assumed to be unit -C triangular. -C -C Unchanged on exit. -C -C M - INTEGER. -C On entry, M specifies the number of rows of B. M must be at -C least zero. -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the number of columns of B. N must be -C at least zero. -C Unchanged on exit. -C -C ALPHA - COMPLEX . -C On entry, ALPHA specifies the scalar alpha. When alpha is -C zero then A is not referenced and B need not be set before -C entry. -C Unchanged on exit. -C -C A - COMPLEX array of DIMENSION ( LDA, k ), where k is m -C when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -C Before entry with UPLO = 'U' or 'u', the leading k by k -C upper triangular part of the array A must contain the upper -C triangular matrix and the strictly lower triangular part of -C A is not referenced. -C Before entry with UPLO = 'L' or 'l', the leading k by k -C lower triangular part of the array A must contain the lower -C triangular matrix and the strictly upper triangular part of -C A is not referenced. -C Note that when DIAG = 'U' or 'u', the diagonal elements of -C A are not referenced either, but are assumed to be unity. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. When SIDE = 'L' or 'l' then -C LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -C then LDA must be at least max( 1, n ). -C Unchanged on exit. -C -C B - COMPLEX array of DIMENSION ( LDB, n ). -C Before entry, the leading m by n part of the array B must -C contain the right-hand side matrix B, and on exit is -C overwritten by the solution matrix X. -C -C LDB - INTEGER. -C On entry, LDB specifies the first dimension of B as declared -C in the calling (sub) program. LDB must be at least -C max( 1, m ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. -C A set of level 3 basic linear algebra subprograms. -C ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 890208 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE CTRSM -C .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - COMPLEX ALPHA -C .. Array Arguments .. - COMPLEX A( LDA, * ), B( LDB, * ) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC CONJG, MAX -C .. Local Scalars .. - LOGICAL LSIDE, NOCONJ, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - COMPLEX TEMP -C .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -C***FIRST EXECUTABLE STATEMENT CTRSM -C -C Test the input parameters. -C - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOCONJ = LSAME( TRANSA, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -C - 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( 'CTRSM ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C -C And when alpha.eq.zero. -C - 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 -C -C Start the operations. -C - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) )THEN -C -C Form B := alpha*inv( A )*B. -C - 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 -C -C Form B := alpha*inv( A' )*B -C or B := alpha*inv( conjg( A' ) )*B. -C - IF( UPPER )THEN - DO 140, J = 1, N - DO 130, I = 1, M - TEMP = ALPHA*B( I, J ) - IF( NOCONJ )THEN - DO 110, K = 1, I - 1 - TEMP = TEMP - A( K, I )*B( K, J ) - 110 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - ELSE - DO 120, K = 1, I - 1 - TEMP = TEMP - CONJG( A( K, I ) )*B( K, J ) - 120 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/CONJG( A( I, I ) ) - END IF - B( I, J ) = TEMP - 130 CONTINUE - 140 CONTINUE - ELSE - DO 180, J = 1, N - DO 170, I = M, 1, -1 - TEMP = ALPHA*B( I, J ) - IF( NOCONJ )THEN - DO 150, K = I + 1, M - TEMP = TEMP - A( K, I )*B( K, J ) - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - ELSE - DO 160, K = I + 1, M - TEMP = TEMP - CONJG( A( K, I ) )*B( K, J ) - 160 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/CONJG( A( I, I ) ) - END IF - B( I, J ) = TEMP - 170 CONTINUE - 180 CONTINUE - END IF - END IF - ELSE - IF( LSAME( TRANSA, 'N' ) )THEN -C -C Form B := alpha*B*inv( A ). -C - IF( UPPER )THEN - DO 230, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 190, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 190 CONTINUE - END IF - DO 210, K = 1, J - 1 - IF( A( K, J ).NE.ZERO )THEN - DO 200, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 200 CONTINUE - END IF - 210 CONTINUE - IF( NOUNIT )THEN - TEMP = ONE/A( J, J ) - DO 220, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 220 CONTINUE - END IF - 230 CONTINUE - ELSE - DO 280, J = N, 1, -1 - IF( ALPHA.NE.ONE )THEN - DO 240, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 240 CONTINUE - END IF - DO 260, K = J + 1, N - IF( A( K, J ).NE.ZERO )THEN - DO 250, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 250 CONTINUE - END IF - 260 CONTINUE - IF( NOUNIT )THEN - TEMP = ONE/A( J, J ) - DO 270, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 270 CONTINUE - END IF - 280 CONTINUE - END IF - ELSE -C -C Form B := alpha*B*inv( A' ) -C or B := alpha*B*inv( conjg( A' ) ). -C - IF( UPPER )THEN - DO 330, K = N, 1, -1 - IF( NOUNIT )THEN - IF( NOCONJ )THEN - TEMP = ONE/A( K, K ) - ELSE - TEMP = ONE/CONJG( A( K, K ) ) - END IF - DO 290, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 290 CONTINUE - END IF - DO 310, J = 1, K - 1 - IF( A( J, K ).NE.ZERO )THEN - IF( NOCONJ )THEN - TEMP = A( J, K ) - ELSE - TEMP = CONJG( A( J, K ) ) - END IF - DO 300, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 300 CONTINUE - END IF - 310 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 320, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 320 CONTINUE - END IF - 330 CONTINUE - ELSE - DO 380, K = 1, N - IF( NOUNIT )THEN - IF( NOCONJ )THEN - TEMP = ONE/A( K, K ) - ELSE - TEMP = ONE/CONJG( A( K, K ) ) - END IF - DO 340, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 340 CONTINUE - END IF - DO 360, J = K + 1, N - IF( A( J, K ).NE.ZERO )THEN - IF( NOCONJ )THEN - TEMP = A( J, K ) - ELSE - TEMP = CONJG( A( J, K ) ) - END IF - DO 350, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 350 CONTINUE - END IF - 360 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 370, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 370 CONTINUE - END IF - 380 CONTINUE - END IF - END IF - END IF -C - RETURN -C -C End of CTRSM . -C - END diff --git a/slatec/ctrsv.f b/slatec/ctrsv.f deleted file mode 100644 index 26af36f..0000000 --- a/slatec/ctrsv.f +++ /dev/null @@ -1,331 +0,0 @@ -*DECK CTRSV - SUBROUTINE CTRSV (UPLO, TRANS, DIAG, N, A, LDA, X, INCX) -C***BEGIN PROLOGUE CTRSV -C***PURPOSE Solve a complex triangular system of equations. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE COMPLEX (STRSV-S, DTRSV-D, CTRSV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C CTRSV solves one of the systems of equations -C -C A*x = b, or A'*x = b, or conjg( A')*x = b, -C -C where b and x are n element vectors and A is an n by n unit, or -C non-unit, upper or lower triangular matrix. -C -C No test for singularity or near-singularity is included in this -C routine. Such tests must be performed before calling this routine. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the matrix is an upper or -C lower triangular matrix as follows: -C -C UPLO = 'U' or 'u' A is an upper triangular matrix. -C -C UPLO = 'L' or 'l' A is a lower triangular matrix. -C -C Unchanged on exit. -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the equations to be solved as -C follows: -C -C TRANS = 'N' or 'n' A*x = b. -C -C TRANS = 'T' or 't' A'*x = b. -C -C TRANS = 'C' or 'c' conjg( A' )*x = b. -C -C Unchanged on exit. -C -C DIAG - CHARACTER*1. -C On entry, DIAG specifies whether or not A is unit -C triangular as follows: -C -C DIAG = 'U' or 'u' A is assumed to be unit triangular. -C -C DIAG = 'N' or 'n' A is not assumed to be unit -C triangular. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C A - COMPLEX array of DIMENSION ( LDA, n ). -C Before entry with UPLO = 'U' or 'u', the leading n by n -C upper triangular part of the array A must contain the upper -C triangular matrix and the strictly lower triangular part of -C A is not referenced. -C Before entry with UPLO = 'L' or 'l', the leading n by n -C lower triangular part of the array A must contain the lower -C triangular matrix and the strictly upper triangular part of -C A is not referenced. -C Note that when DIAG = 'U' or 'u', the diagonal elements of -C A are not referenced either, but are assumed to be unity. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C max( 1, n ). -C Unchanged on exit. -C -C X - COMPLEX array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element right-hand side vector b. On exit, X is overwritten -C with the solution vector x. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE CTRSV -C .. Scalar Arguments .. - INTEGER INCX, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -C .. Array Arguments .. - COMPLEX A( LDA, * ), X( * ) -C .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -C .. Local Scalars .. - COMPLEX TEMP - INTEGER I, INFO, IX, J, JX, KX - LOGICAL NOCONJ, NOUNIT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC CONJG, MAX -C***FIRST EXECUTABLE STATEMENT CTRSV -C -C Test the input parameters. -C - 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( 'CTRSV ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - NOCONJ = LSAME( TRANS, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) -C -C Set up the start point in X if the increment is not unity. This -C will be ( N - 1 )*INCX too small for descending loops. -C - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through A. -C - IF( LSAME( TRANS, 'N' ) )THEN -C -C Form x := inv( A )*x. -C - 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 -C -C Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. -C - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 110, J = 1, N - TEMP = X( J ) - IF( NOCONJ )THEN - DO 90, I = 1, J - 1 - TEMP = TEMP - A( I, J )*X( I ) - 90 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - ELSE - DO 100, I = 1, J - 1 - TEMP = TEMP - CONJG( A( I, J ) )*X( I ) - 100 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/CONJG( A( J, J ) ) - END IF - X( J ) = TEMP - 110 CONTINUE - ELSE - JX = KX - DO 140, J = 1, N - IX = KX - TEMP = X( JX ) - IF( NOCONJ )THEN - DO 120, I = 1, J - 1 - TEMP = TEMP - A( I, J )*X( IX ) - IX = IX + INCX - 120 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - ELSE - DO 130, I = 1, J - 1 - TEMP = TEMP - CONJG( A( I, J ) )*X( IX ) - IX = IX + INCX - 130 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/CONJG( A( J, J ) ) - END IF - X( JX ) = TEMP - JX = JX + INCX - 140 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 170, J = N, 1, -1 - TEMP = X( J ) - IF( NOCONJ )THEN - DO 150, I = N, J + 1, -1 - TEMP = TEMP - A( I, J )*X( I ) - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - ELSE - DO 160, I = N, J + 1, -1 - TEMP = TEMP - CONJG( A( I, J ) )*X( I ) - 160 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/CONJG( A( J, J ) ) - END IF - X( J ) = TEMP - 170 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 200, J = N, 1, -1 - IX = KX - TEMP = X( JX ) - IF( NOCONJ )THEN - DO 180, I = N, J + 1, -1 - TEMP = TEMP - A( I, J )*X( IX ) - IX = IX - INCX - 180 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - ELSE - DO 190, I = N, J + 1, -1 - TEMP = TEMP - CONJG( A( I, J ) )*X( IX ) - IX = IX - INCX - 190 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/CONJG( A( J, J ) ) - END IF - X( JX ) = TEMP - JX = JX - INCX - 200 CONTINUE - END IF - END IF - END IF -C - RETURN -C -C End of CTRSV . -C - END diff --git a/slatec/cuchk.f b/slatec/cuchk.f deleted file mode 100644 index 5415657..0000000 --- a/slatec/cuchk.f +++ /dev/null @@ -1,42 +0,0 @@ -*DECK CUCHK - SUBROUTINE CUCHK (Y, NZ, ASCLE, TOL) -C***BEGIN PROLOGUE CUCHK -C***SUBSIDIARY -C***PURPOSE Subsidiary to SERI, CUOIK, CUNK1, CUNK2, CUNI1, CUNI2 and -C CKSCL -C***LIBRARY SLATEC -C***TYPE ALL (CUCHK-A, ZUCHK-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C Y ENTERS AS A SCALED QUANTITY WHOSE MAGNITUDE IS GREATER THAN -C EXP(-ALIM)=ASCLE=1.0E+3*R1MACH(1)/TOL. THE TEST IS MADE TO SEE -C IF THE MAGNITUDE OF THE REAL OR IMAGINARY PART WOULD UNDER FLOW -C WHEN Y IS SCALED (BY TOL) TO ITS PROPER VALUE. Y IS ACCEPTED -C IF THE UNDERFLOW IS AT LEAST ONE PRECISION BELOW THE MAGNITUDE -C OF THE LARGEST COMPONENT; OTHERWISE THE PHASE ANGLE DOES NOT HAVE -C ABSOLUTE ACCURACY AND AN UNDERFLOW IS ASSUMED. -C -C***SEE ALSO CKSCL, CUNI1, CUNI2, CUNK1, CUNK2, CUOIK, SERI -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C ?????? DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CUCHK -C - COMPLEX Y - REAL ASCLE, SS, ST, TOL, YR, YI - INTEGER NZ -C***FIRST EXECUTABLE STATEMENT CUCHK - NZ = 0 - YR = REAL(Y) - YI = AIMAG(Y) - YR = ABS(YR) - YI = ABS(YI) - ST = MIN(YR,YI) - IF (ST.GT.ASCLE) RETURN - SS = MAX(YR,YI) - ST=ST/TOL - IF (SS.LT.ST) NZ = 1 - RETURN - END diff --git a/slatec/cunhj.f b/slatec/cunhj.f deleted file mode 100644 index 603118d..0000000 --- a/slatec/cunhj.f +++ /dev/null @@ -1,658 +0,0 @@ -*DECK CUNHJ - SUBROUTINE CUNHJ (Z, FNU, IPMTR, TOL, PHI, ARG, ZETA1, ZETA2, - + ASUM, BSUM) -C***BEGIN PROLOGUE CUNHJ -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBESI and CBESK -C***LIBRARY SLATEC -C***TYPE ALL (CUNHJ-A, ZUNHJ-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C REFERENCES -C HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ AND I.A. -C STEGUN, AMS55, NATIONAL BUREAU OF STANDARDS, 1965, CHAPTER 9. -C -C ASYMPTOTICS AND SPECIAL FUNCTIONS BY F.W.J. OLVER, ACADEMIC -C PRESS, N.Y., 1974, PAGE 420 -C -C ABSTRACT -C CUNHJ COMPUTES PARAMETERS FOR BESSEL FUNCTIONS C(FNU,Z) = -C J(FNU,Z), Y(FNU,Z) OR H(I,FNU,Z) I=1,2 FOR LARGE ORDERS FNU -C BY MEANS OF THE UNIFORM ASYMPTOTIC EXPANSION -C -C C(FNU,Z)=C1*PHI*( ASUM*AIRY(ARG) + C2*BSUM*DAIRY(ARG) ) -C -C FOR PROPER CHOICES OF C1, C2, AIRY AND DAIRY WHERE AIRY IS -C AN AIRY FUNCTION AND DAIRY IS ITS DERIVATIVE. -C -C (2/3)*FNU*ZETA**1.5 = ZETA1-ZETA2, -C -C ZETA1=0.5*FNU*CLOG((1+W)/(1-W)), ZETA2=FNU*W FOR SCALING -C PURPOSES IN AIRY FUNCTIONS FROM CAIRY OR CBIRY. -C -C MCONJ=SIGN OF AIMAG(Z), BUT IS AMBIGUOUS WHEN Z IS REAL AND -C MUST BE SPECIFIED. IPMTR=0 RETURNS ALL PARAMETERS. IPMTR= -C 1 COMPUTES ALL EXCEPT ASUM AND BSUM. -C -C***SEE ALSO CBESI, CBESK -C***ROUTINES CALLED R1MACH -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CUNHJ - COMPLEX ARG, ASUM, BSUM, CFNU, CONE, CR, CZERO, DR, P, PHI, - * PRZTH, PTFN, RFN13, RTZTA, RZTH, SUMA, SUMB, TFN, T2, UP, W, W2, - * Z, ZA, ZB, ZC, ZETA, ZETA1, ZETA2, ZTH - REAL ALFA, ANG, AP, AR, ATOL, AW2, AZTH, BETA, BR, BTOL, C, EX1, - * EX2, FNU, FN13, FN23, GAMA, HPI, PI, PP, RFNU, RFNU2, THPI, TOL, - * WI, WR, ZCI, ZCR, ZETAI, ZETAR, ZTHI, ZTHR, ASUMR, ASUMI, BSUMR, - * BSUMI, TEST, TSTR, TSTI, AC, R1MACH - INTEGER IAS, IBS, IPMTR, IS, J, JR, JU, K, KMAX, KP1, KS, L, LR, - * LRP1, L1, L2, M - DIMENSION AR(14), BR(14), C(105), ALFA(180), BETA(210), GAMA(30), - * AP(30), P(30), UP(14), CR(14), DR(14) - DATA AR(1), AR(2), AR(3), AR(4), AR(5), AR(6), AR(7), AR(8), - 1 AR(9), AR(10), AR(11), AR(12), AR(13), AR(14)/ - 2 1.00000000000000000E+00, 1.04166666666666667E-01, - 3 8.35503472222222222E-02, 1.28226574556327160E-01, - 4 2.91849026464140464E-01, 8.81627267443757652E-01, - 5 3.32140828186276754E+00, 1.49957629868625547E+01, - 6 7.89230130115865181E+01, 4.74451538868264323E+02, - 7 3.20749009089066193E+03, 2.40865496408740049E+04, - 8 1.98923119169509794E+05, 1.79190200777534383E+06/ - DATA BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), BR(8), - 1 BR(9), BR(10), BR(11), BR(12), BR(13), BR(14)/ - 2 1.00000000000000000E+00, -1.45833333333333333E-01, - 3 -9.87413194444444444E-02, -1.43312053915895062E-01, - 4 -3.17227202678413548E-01, -9.42429147957120249E-01, - 5 -3.51120304082635426E+00, -1.57272636203680451E+01, - 6 -8.22814390971859444E+01, -4.92355370523670524E+02, - 7 -3.31621856854797251E+03, -2.48276742452085896E+04, - 8 -2.04526587315129788E+05, -1.83844491706820990E+06/ - DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), - 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), - 2 C(19), C(20), C(21), C(22), C(23), C(24)/ - 3 1.00000000000000000E+00, -2.08333333333333333E-01, - 4 1.25000000000000000E-01, 3.34201388888888889E-01, - 5 -4.01041666666666667E-01, 7.03125000000000000E-02, - 6 -1.02581259645061728E+00, 1.84646267361111111E+00, - 7 -8.91210937500000000E-01, 7.32421875000000000E-02, - 8 4.66958442342624743E+00, -1.12070026162229938E+01, - 9 8.78912353515625000E+00, -2.36408691406250000E+00, - A 1.12152099609375000E-01, -2.82120725582002449E+01, - B 8.46362176746007346E+01, -9.18182415432400174E+01, - C 4.25349987453884549E+01, -7.36879435947963170E+00, - D 2.27108001708984375E-01, 2.12570130039217123E+02, - E -7.65252468141181642E+02, 1.05999045252799988E+03/ - DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), - 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), - 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ - 3 -6.99579627376132541E+02, 2.18190511744211590E+02, - 4 -2.64914304869515555E+01, 5.72501420974731445E-01, - 5 -1.91945766231840700E+03, 8.06172218173730938E+03, - 6 -1.35865500064341374E+04, 1.16553933368645332E+04, - 7 -5.30564697861340311E+03, 1.20090291321635246E+03, - 8 -1.08090919788394656E+02, 1.72772750258445740E+00, - 9 2.02042913309661486E+04, -9.69805983886375135E+04, - A 1.92547001232531532E+05, -2.03400177280415534E+05, - B 1.22200464983017460E+05, -4.11926549688975513E+04, - C 7.10951430248936372E+03, -4.93915304773088012E+02, - D 6.07404200127348304E+00, -2.42919187900551333E+05, - E 1.31176361466297720E+06, -2.99801591853810675E+06/ - DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), - 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), - 2 C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ - 3 3.76327129765640400E+06, -2.81356322658653411E+06, - 4 1.26836527332162478E+06, -3.31645172484563578E+05, - 5 4.52187689813627263E+04, -2.49983048181120962E+03, - 6 2.43805296995560639E+01, 3.28446985307203782E+06, - 7 -1.97068191184322269E+07, 5.09526024926646422E+07, - 8 -7.41051482115326577E+07, 6.63445122747290267E+07, - 9 -3.75671766607633513E+07, 1.32887671664218183E+07, - A -2.78561812808645469E+06, 3.08186404612662398E+05, - B -1.38860897537170405E+04, 1.10017140269246738E+02, - C -4.93292536645099620E+07, 3.25573074185765749E+08, - D -9.39462359681578403E+08, 1.55359689957058006E+09, - E -1.62108055210833708E+09, 1.10684281682301447E+09/ - DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), - 1 C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), - 2 C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ - 3 -4.95889784275030309E+08, 1.42062907797533095E+08, - 4 -2.44740627257387285E+07, 2.24376817792244943E+06, - 5 -8.40054336030240853E+04, 5.51335896122020586E+02, - 6 8.14789096118312115E+08, -5.86648149205184723E+09, - 7 1.86882075092958249E+10, -3.46320433881587779E+10, - 8 4.12801855797539740E+10, -3.30265997498007231E+10, - 9 1.79542137311556001E+10, -6.56329379261928433E+09, - A 1.55927986487925751E+09, -2.25105661889415278E+08, - B 1.73951075539781645E+07, -5.49842327572288687E+05, - C 3.03809051092238427E+03, -1.46792612476956167E+10, - D 1.14498237732025810E+11, -3.99096175224466498E+11, - E 8.19218669548577329E+11, -1.09837515608122331E+12/ - DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104), - 1 C(105)/ - 2 1.00815810686538209E+12, -6.45364869245376503E+11, - 3 2.87900649906150589E+11, -8.78670721780232657E+10, - 4 1.76347306068349694E+10, -2.16716498322379509E+09, - 5 1.43157876718888981E+08, -3.87183344257261262E+06, - 6 1.82577554742931747E+04/ - DATA ALFA(1), ALFA(2), ALFA(3), ALFA(4), ALFA(5), ALFA(6), - 1 ALFA(7), ALFA(8), ALFA(9), ALFA(10), ALFA(11), ALFA(12), - 2 ALFA(13), ALFA(14), ALFA(15), ALFA(16), ALFA(17), ALFA(18), - 3 ALFA(19), ALFA(20), ALFA(21), ALFA(22)/ - 4 -4.44444444444444444E-03, -9.22077922077922078E-04, - 5 -8.84892884892884893E-05, 1.65927687832449737E-04, - 6 2.46691372741792910E-04, 2.65995589346254780E-04, - 7 2.61824297061500945E-04, 2.48730437344655609E-04, - 8 2.32721040083232098E-04, 2.16362485712365082E-04, - 9 2.00738858762752355E-04, 1.86267636637545172E-04, - A 1.73060775917876493E-04, 1.61091705929015752E-04, - B 1.50274774160908134E-04, 1.40503497391269794E-04, - C 1.31668816545922806E-04, 1.23667445598253261E-04, - D 1.16405271474737902E-04, 1.09798298372713369E-04, - E 1.03772410422992823E-04, 9.82626078369363448E-05/ - DATA ALFA(23), ALFA(24), ALFA(25), ALFA(26), ALFA(27), ALFA(28), - 1 ALFA(29), ALFA(30), ALFA(31), ALFA(32), ALFA(33), ALFA(34), - 2 ALFA(35), ALFA(36), ALFA(37), ALFA(38), ALFA(39), ALFA(40), - 3 ALFA(41), ALFA(42), ALFA(43), ALFA(44)/ - 4 9.32120517249503256E-05, 8.85710852478711718E-05, - 5 8.42963105715700223E-05, 8.03497548407791151E-05, - 6 7.66981345359207388E-05, 7.33122157481777809E-05, - 7 7.01662625163141333E-05, 6.72375633790160292E-05, - 8 6.93735541354588974E-04, 2.32241745182921654E-04, - 9 -1.41986273556691197E-05, -1.16444931672048640E-04, - A -1.50803558053048762E-04, -1.55121924918096223E-04, - B -1.46809756646465549E-04, -1.33815503867491367E-04, - C -1.19744975684254051E-04, -1.06184319207974020E-04, - D -9.37699549891194492E-05, -8.26923045588193274E-05, - E -7.29374348155221211E-05, -6.44042357721016283E-05/ - DATA ALFA(45), ALFA(46), ALFA(47), ALFA(48), ALFA(49), ALFA(50), - 1 ALFA(51), ALFA(52), ALFA(53), ALFA(54), ALFA(55), ALFA(56), - 2 ALFA(57), ALFA(58), ALFA(59), ALFA(60), ALFA(61), ALFA(62), - 3 ALFA(63), ALFA(64), ALFA(65), ALFA(66)/ - 4 -5.69611566009369048E-05, -5.04731044303561628E-05, - 5 -4.48134868008882786E-05, -3.98688727717598864E-05, - 6 -3.55400532972042498E-05, -3.17414256609022480E-05, - 7 -2.83996793904174811E-05, -2.54522720634870566E-05, - 8 -2.28459297164724555E-05, -2.05352753106480604E-05, - 9 -1.84816217627666085E-05, -1.66519330021393806E-05, - A -1.50179412980119482E-05, -1.35554031379040526E-05, - B -1.22434746473858131E-05, -1.10641884811308169E-05, - C -3.54211971457743841E-04, -1.56161263945159416E-04, - D 3.04465503594936410E-05, 1.30198655773242693E-04, - E 1.67471106699712269E-04, 1.70222587683592569E-04/ - DATA ALFA(67), ALFA(68), ALFA(69), ALFA(70), ALFA(71), ALFA(72), - 1 ALFA(73), ALFA(74), ALFA(75), ALFA(76), ALFA(77), ALFA(78), - 2 ALFA(79), ALFA(80), ALFA(81), ALFA(82), ALFA(83), ALFA(84), - 3 ALFA(85), ALFA(86), ALFA(87), ALFA(88)/ - 4 1.56501427608594704E-04, 1.36339170977445120E-04, - 5 1.14886692029825128E-04, 9.45869093034688111E-05, - 6 7.64498419250898258E-05, 6.07570334965197354E-05, - 7 4.74394299290508799E-05, 3.62757512005344297E-05, - 8 2.69939714979224901E-05, 1.93210938247939253E-05, - 9 1.30056674793963203E-05, 7.82620866744496661E-06, - A 3.59257485819351583E-06, 1.44040049814251817E-07, - B -2.65396769697939116E-06, -4.91346867098485910E-06, - C -6.72739296091248287E-06, -8.17269379678657923E-06, - D -9.31304715093561232E-06, -1.02011418798016441E-05, - E -1.08805962510592880E-05, -1.13875481509603555E-05/ - DATA ALFA(89), ALFA(90), ALFA(91), ALFA(92), ALFA(93), ALFA(94), - 1 ALFA(95), ALFA(96), ALFA(97), ALFA(98), ALFA(99), ALFA(100), - 2 ALFA(101), ALFA(102), ALFA(103), ALFA(104), ALFA(105), - 3 ALFA(106), ALFA(107), ALFA(108), ALFA(109), ALFA(110)/ - 4 -1.17519675674556414E-05, -1.19987364870944141E-05, - 5 3.78194199201772914E-04, 2.02471952761816167E-04, - 6 -6.37938506318862408E-05, -2.38598230603005903E-04, - 7 -3.10916256027361568E-04, -3.13680115247576316E-04, - 8 -2.78950273791323387E-04, -2.28564082619141374E-04, - 9 -1.75245280340846749E-04, -1.25544063060690348E-04, - A -8.22982872820208365E-05, -4.62860730588116458E-05, - B -1.72334302366962267E-05, 5.60690482304602267E-06, - C 2.31395443148286800E-05, 3.62642745856793957E-05, - D 4.58006124490188752E-05, 5.24595294959114050E-05, - E 5.68396208545815266E-05, 5.94349820393104052E-05/ - DATA ALFA(111), ALFA(112), ALFA(113), ALFA(114), ALFA(115), - 1 ALFA(116), ALFA(117), ALFA(118), ALFA(119), ALFA(120), - 2 ALFA(121), ALFA(122), ALFA(123), ALFA(124), ALFA(125), - 3 ALFA(126), ALFA(127), ALFA(128), ALFA(129), ALFA(130)/ - 4 6.06478527578421742E-05, 6.08023907788436497E-05, - 5 6.01577894539460388E-05, 5.89199657344698500E-05, - 6 5.72515823777593053E-05, 5.52804375585852577E-05, - 7 5.31063773802880170E-05, 5.08069302012325706E-05, - 8 4.84418647620094842E-05, 4.60568581607475370E-05, - 9 -6.91141397288294174E-04, -4.29976633058871912E-04, - A 1.83067735980039018E-04, 6.60088147542014144E-04, - B 8.75964969951185931E-04, 8.77335235958235514E-04, - C 7.49369585378990637E-04, 5.63832329756980918E-04, - D 3.68059319971443156E-04, 1.88464535514455599E-04/ - DATA ALFA(131), ALFA(132), ALFA(133), ALFA(134), ALFA(135), - 1 ALFA(136), ALFA(137), ALFA(138), ALFA(139), ALFA(140), - 2 ALFA(141), ALFA(142), ALFA(143), ALFA(144), ALFA(145), - 3 ALFA(146), ALFA(147), ALFA(148), ALFA(149), ALFA(150)/ - 4 3.70663057664904149E-05, -8.28520220232137023E-05, - 5 -1.72751952869172998E-04, -2.36314873605872983E-04, - 6 -2.77966150694906658E-04, -3.02079514155456919E-04, - 7 -3.12594712643820127E-04, -3.12872558758067163E-04, - 8 -3.05678038466324377E-04, -2.93226470614557331E-04, - 9 -2.77255655582934777E-04, -2.59103928467031709E-04, - A -2.39784014396480342E-04, -2.20048260045422848E-04, - B -2.00443911094971498E-04, -1.81358692210970687E-04, - C -1.63057674478657464E-04, -1.45712672175205844E-04, - D -1.29425421983924587E-04, -1.14245691942445952E-04/ - DATA ALFA(151), ALFA(152), ALFA(153), ALFA(154), ALFA(155), - 1 ALFA(156), ALFA(157), ALFA(158), ALFA(159), ALFA(160), - 2 ALFA(161), ALFA(162), ALFA(163), ALFA(164), ALFA(165), - 3 ALFA(166), ALFA(167), ALFA(168), ALFA(169), ALFA(170)/ - 4 1.92821964248775885E-03, 1.35592576302022234E-03, - 5 -7.17858090421302995E-04, -2.58084802575270346E-03, - 6 -3.49271130826168475E-03, -3.46986299340960628E-03, - 7 -2.82285233351310182E-03, -1.88103076404891354E-03, - 8 -8.89531718383947600E-04, 3.87912102631035228E-06, - 9 7.28688540119691412E-04, 1.26566373053457758E-03, - A 1.62518158372674427E-03, 1.83203153216373172E-03, - B 1.91588388990527909E-03, 1.90588846755546138E-03, - C 1.82798982421825727E-03, 1.70389506421121530E-03, - D 1.55097127171097686E-03, 1.38261421852276159E-03/ - DATA ALFA(171), ALFA(172), ALFA(173), ALFA(174), ALFA(175), - 1 ALFA(176), ALFA(177), ALFA(178), ALFA(179), ALFA(180)/ - 2 1.20881424230064774E-03, 1.03676532638344962E-03, - 3 8.71437918068619115E-04, 7.16080155297701002E-04, - 4 5.72637002558129372E-04, 4.42089819465802277E-04, - 5 3.24724948503090564E-04, 2.20342042730246599E-04, - 6 1.28412898401353882E-04, 4.82005924552095464E-05/ - DATA BETA(1), BETA(2), BETA(3), BETA(4), BETA(5), BETA(6), - 1 BETA(7), BETA(8), BETA(9), BETA(10), BETA(11), BETA(12), - 2 BETA(13), BETA(14), BETA(15), BETA(16), BETA(17), BETA(18), - 3 BETA(19), BETA(20), BETA(21), BETA(22)/ - 4 1.79988721413553309E-02, 5.59964911064388073E-03, - 5 2.88501402231132779E-03, 1.80096606761053941E-03, - 6 1.24753110589199202E-03, 9.22878876572938311E-04, - 7 7.14430421727287357E-04, 5.71787281789704872E-04, - 8 4.69431007606481533E-04, 3.93232835462916638E-04, - 9 3.34818889318297664E-04, 2.88952148495751517E-04, - A 2.52211615549573284E-04, 2.22280580798883327E-04, - B 1.97541838033062524E-04, 1.76836855019718004E-04, - C 1.59316899661821081E-04, 1.44347930197333986E-04, - D 1.31448068119965379E-04, 1.20245444949302884E-04, - E 1.10449144504599392E-04, 1.01828770740567258E-04/ - DATA BETA(23), BETA(24), BETA(25), BETA(26), BETA(27), BETA(28), - 1 BETA(29), BETA(30), BETA(31), BETA(32), BETA(33), BETA(34), - 2 BETA(35), BETA(36), BETA(37), BETA(38), BETA(39), BETA(40), - 3 BETA(41), BETA(42), BETA(43), BETA(44)/ - 4 9.41998224204237509E-05, 8.74130545753834437E-05, - 5 8.13466262162801467E-05, 7.59002269646219339E-05, - 6 7.09906300634153481E-05, 6.65482874842468183E-05, - 7 6.25146958969275078E-05, 5.88403394426251749E-05, - 8 -1.49282953213429172E-03, -8.78204709546389328E-04, - 9 -5.02916549572034614E-04, -2.94822138512746025E-04, - A -1.75463996970782828E-04, -1.04008550460816434E-04, - B -5.96141953046457895E-05, -3.12038929076098340E-05, - C -1.26089735980230047E-05, -2.42892608575730389E-07, - D 8.05996165414273571E-06, 1.36507009262147391E-05, - E 1.73964125472926261E-05, 1.98672978842133780E-05/ - DATA BETA(45), BETA(46), BETA(47), BETA(48), BETA(49), BETA(50), - 1 BETA(51), BETA(52), BETA(53), BETA(54), BETA(55), BETA(56), - 2 BETA(57), BETA(58), BETA(59), BETA(60), BETA(61), BETA(62), - 3 BETA(63), BETA(64), BETA(65), BETA(66)/ - 4 2.14463263790822639E-05, 2.23954659232456514E-05, - 5 2.28967783814712629E-05, 2.30785389811177817E-05, - 6 2.30321976080909144E-05, 2.28236073720348722E-05, - 7 2.25005881105292418E-05, 2.20981015361991429E-05, - 8 2.16418427448103905E-05, 2.11507649256220843E-05, - 9 2.06388749782170737E-05, 2.01165241997081666E-05, - A 1.95913450141179244E-05, 1.90689367910436740E-05, - B 1.85533719641636667E-05, 1.80475722259674218E-05, - C 5.52213076721292790E-04, 4.47932581552384646E-04, - D 2.79520653992020589E-04, 1.52468156198446602E-04, - E 6.93271105657043598E-05, 1.76258683069991397E-05/ - DATA BETA(67), BETA(68), BETA(69), BETA(70), BETA(71), BETA(72), - 1 BETA(73), BETA(74), BETA(75), BETA(76), BETA(77), BETA(78), - 2 BETA(79), BETA(80), BETA(81), BETA(82), BETA(83), BETA(84), - 3 BETA(85), BETA(86), BETA(87), BETA(88)/ - 4 -1.35744996343269136E-05, -3.17972413350427135E-05, - 5 -4.18861861696693365E-05, -4.69004889379141029E-05, - 6 -4.87665447413787352E-05, -4.87010031186735069E-05, - 7 -4.74755620890086638E-05, -4.55813058138628452E-05, - 8 -4.33309644511266036E-05, -4.09230193157750364E-05, - 9 -3.84822638603221274E-05, -3.60857167535410501E-05, - A -3.37793306123367417E-05, -3.15888560772109621E-05, - B -2.95269561750807315E-05, -2.75978914828335759E-05, - C -2.58006174666883713E-05, -2.41308356761280200E-05, - D -2.25823509518346033E-05, -2.11479656768912971E-05, - E -1.98200638885294927E-05, -1.85909870801065077E-05/ - DATA BETA(89), BETA(90), BETA(91), BETA(92), BETA(93), BETA(94), - 1 BETA(95), BETA(96), BETA(97), BETA(98), BETA(99), BETA(100), - 2 BETA(101), BETA(102), BETA(103), BETA(104), BETA(105), - 3 BETA(106), BETA(107), BETA(108), BETA(109), BETA(110)/ - 4 -1.74532699844210224E-05, -1.63997823854497997E-05, - 5 -4.74617796559959808E-04, -4.77864567147321487E-04, - 6 -3.20390228067037603E-04, -1.61105016119962282E-04, - 7 -4.25778101285435204E-05, 3.44571294294967503E-05, - 8 7.97092684075674924E-05, 1.03138236708272200E-04, - 9 1.12466775262204158E-04, 1.13103642108481389E-04, - A 1.08651634848774268E-04, 1.01437951597661973E-04, - B 9.29298396593363896E-05, 8.40293133016089978E-05, - C 7.52727991349134062E-05, 6.69632521975730872E-05, - D 5.92564547323194704E-05, 5.22169308826975567E-05, - E 4.58539485165360646E-05, 4.01445513891486808E-05/ - DATA BETA(111), BETA(112), BETA(113), BETA(114), BETA(115), - 1 BETA(116), BETA(117), BETA(118), BETA(119), BETA(120), - 2 BETA(121), BETA(122), BETA(123), BETA(124), BETA(125), - 3 BETA(126), BETA(127), BETA(128), BETA(129), BETA(130)/ - 4 3.50481730031328081E-05, 3.05157995034346659E-05, - 5 2.64956119950516039E-05, 2.29363633690998152E-05, - 6 1.97893056664021636E-05, 1.70091984636412623E-05, - 7 1.45547428261524004E-05, 1.23886640995878413E-05, - 8 1.04775876076583236E-05, 8.79179954978479373E-06, - 9 7.36465810572578444E-04, 8.72790805146193976E-04, - A 6.22614862573135066E-04, 2.85998154194304147E-04, - B 3.84737672879366102E-06, -1.87906003636971558E-04, - C -2.97603646594554535E-04, -3.45998126832656348E-04, - D -3.53382470916037712E-04, -3.35715635775048757E-04/ - DATA BETA(131), BETA(132), BETA(133), BETA(134), BETA(135), - 1 BETA(136), BETA(137), BETA(138), BETA(139), BETA(140), - 2 BETA(141), BETA(142), BETA(143), BETA(144), BETA(145), - 3 BETA(146), BETA(147), BETA(148), BETA(149), BETA(150)/ - 4 -3.04321124789039809E-04, -2.66722723047612821E-04, - 5 -2.27654214122819527E-04, -1.89922611854562356E-04, - 6 -1.55058918599093870E-04, -1.23778240761873630E-04, - 7 -9.62926147717644187E-05, -7.25178327714425337E-05, - 8 -5.22070028895633801E-05, -3.50347750511900522E-05, - 9 -2.06489761035551757E-05, -8.70106096849767054E-06, - A 1.13698686675100290E-06, 9.16426474122778849E-06, - B 1.56477785428872620E-05, 2.08223629482466847E-05, - C 2.48923381004595156E-05, 2.80340509574146325E-05, - D 3.03987774629861915E-05, 3.21156731406700616E-05/ - DATA BETA(151), BETA(152), BETA(153), BETA(154), BETA(155), - 1 BETA(156), BETA(157), BETA(158), BETA(159), BETA(160), - 2 BETA(161), BETA(162), BETA(163), BETA(164), BETA(165), - 3 BETA(166), BETA(167), BETA(168), BETA(169), BETA(170)/ - 4 -1.80182191963885708E-03, -2.43402962938042533E-03, - 5 -1.83422663549856802E-03, -7.62204596354009765E-04, - 6 2.39079475256927218E-04, 9.49266117176881141E-04, - 7 1.34467449701540359E-03, 1.48457495259449178E-03, - 8 1.44732339830617591E-03, 1.30268261285657186E-03, - 9 1.10351597375642682E-03, 8.86047440419791759E-04, - A 6.73073208165665473E-04, 4.77603872856582378E-04, - B 3.05991926358789362E-04, 1.60315694594721630E-04, - C 4.00749555270613286E-05, -5.66607461635251611E-05, - D -1.32506186772982638E-04, -1.90296187989614057E-04/ - DATA BETA(171), BETA(172), BETA(173), BETA(174), BETA(175), - 1 BETA(176), BETA(177), BETA(178), BETA(179), BETA(180), - 2 BETA(181), BETA(182), BETA(183), BETA(184), BETA(185), - 3 BETA(186), BETA(187), BETA(188), BETA(189), BETA(190)/ - 4 -2.32811450376937408E-04, -2.62628811464668841E-04, - 5 -2.82050469867598672E-04, -2.93081563192861167E-04, - 6 -2.97435962176316616E-04, -2.96557334239348078E-04, - 7 -2.91647363312090861E-04, -2.83696203837734166E-04, - 8 -2.73512317095673346E-04, -2.61750155806768580E-04, - 9 6.38585891212050914E-03, 9.62374215806377941E-03, - A 7.61878061207001043E-03, 2.83219055545628054E-03, - B -2.09841352012720090E-03, -5.73826764216626498E-03, - C -7.70804244495414620E-03, -8.21011692264844401E-03, - D -7.65824520346905413E-03, -6.47209729391045177E-03/ - DATA BETA(191), BETA(192), BETA(193), BETA(194), BETA(195), - 1 BETA(196), BETA(197), BETA(198), BETA(199), BETA(200), - 2 BETA(201), BETA(202), BETA(203), BETA(204), BETA(205), - 3 BETA(206), BETA(207), BETA(208), BETA(209), BETA(210)/ - 4 -4.99132412004966473E-03, -3.45612289713133280E-03, - 5 -2.01785580014170775E-03, -7.59430686781961401E-04, - 6 2.84173631523859138E-04, 1.10891667586337403E-03, - 7 1.72901493872728771E-03, 2.16812590802684701E-03, - 8 2.45357710494539735E-03, 2.61281821058334862E-03, - 9 2.67141039656276912E-03, 2.65203073395980430E-03, - A 2.57411652877287315E-03, 2.45389126236094427E-03, - B 2.30460058071795494E-03, 2.13684837686712662E-03, - C 1.95896528478870911E-03, 1.77737008679454412E-03, - D 1.59690280765839059E-03, 1.42111975664438546E-03/ - DATA GAMA(1), GAMA(2), GAMA(3), GAMA(4), GAMA(5), GAMA(6), - 1 GAMA(7), GAMA(8), GAMA(9), GAMA(10), GAMA(11), GAMA(12), - 2 GAMA(13), GAMA(14), GAMA(15), GAMA(16), GAMA(17), GAMA(18), - 3 GAMA(19), GAMA(20), GAMA(21), GAMA(22)/ - 4 6.29960524947436582E-01, 2.51984209978974633E-01, - 5 1.54790300415655846E-01, 1.10713062416159013E-01, - 6 8.57309395527394825E-02, 6.97161316958684292E-02, - 7 5.86085671893713576E-02, 5.04698873536310685E-02, - 8 4.42600580689154809E-02, 3.93720661543509966E-02, - 9 3.54283195924455368E-02, 3.21818857502098231E-02, - A 2.94646240791157679E-02, 2.71581677112934479E-02, - B 2.51768272973861779E-02, 2.34570755306078891E-02, - C 2.19508390134907203E-02, 2.06210828235646240E-02, - D 1.94388240897880846E-02, 1.83810633800683158E-02, - E 1.74293213231963172E-02, 1.65685837786612353E-02/ - DATA GAMA(23), GAMA(24), GAMA(25), GAMA(26), GAMA(27), GAMA(28), - 1 GAMA(29), GAMA(30)/ - 2 1.57865285987918445E-02, 1.50729501494095594E-02, - 3 1.44193250839954639E-02, 1.38184805735341786E-02, - 4 1.32643378994276568E-02, 1.27517121970498651E-02, - 5 1.22761545318762767E-02, 1.18338262398482403E-02/ - DATA EX1, EX2, HPI, PI, THPI / - 1 3.33333333333333333E-01, 6.66666666666666667E-01, - 2 1.57079632679489662E+00, 3.14159265358979324E+00, - 3 4.71238898038468986E+00/ - DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) / -C***FIRST EXECUTABLE STATEMENT CUNHJ - RFNU = 1.0E0/FNU -C ZB = Z*CMPLX(RFNU,0.0E0) -C----------------------------------------------------------------------- -C OVERFLOW TEST (Z/FNU TOO SMALL) -C----------------------------------------------------------------------- - TSTR = REAL(Z) - TSTI = AIMAG(Z) - TEST = R1MACH(1)*1.0E+3 - AC = FNU*TEST - IF (ABS(TSTR).GT.AC .OR. ABS(TSTI).GT.AC) GO TO 15 - AC = 2.0E0*ABS(ALOG(TEST))+FNU - ZETA1 = CMPLX(AC,0.0E0) - ZETA2 = CMPLX(FNU,0.0E0) - PHI=CONE - ARG=CONE - RETURN - 15 CONTINUE - ZB = Z*CMPLX(RFNU,0.0E0) - RFNU2 = RFNU*RFNU -C----------------------------------------------------------------------- -C COMPUTE IN THE FOURTH QUADRANT -C----------------------------------------------------------------------- - FN13 = FNU**EX1 - FN23 = FN13*FN13 - RFN13 = CMPLX(1.0E0/FN13,0.0E0) - W2 = CONE - ZB*ZB - AW2 = ABS(W2) - IF (AW2.GT.0.25E0) GO TO 130 -C----------------------------------------------------------------------- -C POWER SERIES FOR ABS(W2).LE.0.25E0 -C----------------------------------------------------------------------- - K = 1 - P(1) = CONE - SUMA = CMPLX(GAMA(1),0.0E0) - AP(1) = 1.0E0 - IF (AW2.LT.TOL) GO TO 20 - DO 10 K=2,30 - P(K) = P(K-1)*W2 - SUMA = SUMA + P(K)*CMPLX(GAMA(K),0.0E0) - AP(K) = AP(K-1)*AW2 - IF (AP(K).LT.TOL) GO TO 20 - 10 CONTINUE - K = 30 - 20 CONTINUE - KMAX = K - ZETA = W2*SUMA - ARG = ZETA*CMPLX(FN23,0.0E0) - ZA = CSQRT(SUMA) - ZETA2 = CSQRT(W2)*CMPLX(FNU,0.0E0) - ZETA1 = ZETA2*(CONE+ZETA*ZA*CMPLX(EX2,0.0E0)) - ZA = ZA + ZA - PHI = CSQRT(ZA)*RFN13 - IF (IPMTR.EQ.1) GO TO 120 -C----------------------------------------------------------------------- -C SUM SERIES FOR ASUM AND BSUM -C----------------------------------------------------------------------- - SUMB = CZERO - DO 30 K=1,KMAX - SUMB = SUMB + P(K)*CMPLX(BETA(K),0.0E0) - 30 CONTINUE - ASUM = CZERO - BSUM = SUMB - L1 = 0 - L2 = 30 - BTOL = TOL*ABS(BSUM) - ATOL = TOL - PP = 1.0E0 - IAS = 0 - IBS = 0 - IF (RFNU2.LT.TOL) GO TO 110 - DO 100 IS=2,7 - ATOL = ATOL/RFNU2 - PP = PP*RFNU2 - IF (IAS.EQ.1) GO TO 60 - SUMA = CZERO - DO 40 K=1,KMAX - M = L1 + K - SUMA = SUMA + P(K)*CMPLX(ALFA(M),0.0E0) - IF (AP(K).LT.ATOL) GO TO 50 - 40 CONTINUE - 50 CONTINUE - ASUM = ASUM + SUMA*CMPLX(PP,0.0E0) - IF (PP.LT.TOL) IAS = 1 - 60 CONTINUE - IF (IBS.EQ.1) GO TO 90 - SUMB = CZERO - DO 70 K=1,KMAX - M = L2 + K - SUMB = SUMB + P(K)*CMPLX(BETA(M),0.0E0) - IF (AP(K).LT.ATOL) GO TO 80 - 70 CONTINUE - 80 CONTINUE - BSUM = BSUM + SUMB*CMPLX(PP,0.0E0) - IF (PP.LT.BTOL) IBS = 1 - 90 CONTINUE - IF (IAS.EQ.1 .AND. IBS.EQ.1) GO TO 110 - L1 = L1 + 30 - L2 = L2 + 30 - 100 CONTINUE - 110 CONTINUE - ASUM = ASUM + CONE - PP = RFNU*REAL(RFN13) - BSUM = BSUM*CMPLX(PP,0.0E0) - 120 CONTINUE - RETURN -C----------------------------------------------------------------------- -C ABS(W2).GT.0.25E0 -C----------------------------------------------------------------------- - 130 CONTINUE - W = CSQRT(W2) - WR = REAL(W) - WI = AIMAG(W) - IF (WR.LT.0.0E0) WR = 0.0E0 - IF (WI.LT.0.0E0) WI = 0.0E0 - W = CMPLX(WR,WI) - ZA = (CONE+W)/ZB - ZC = CLOG(ZA) - ZCR = REAL(ZC) - ZCI = AIMAG(ZC) - IF (ZCI.LT.0.0E0) ZCI = 0.0E0 - IF (ZCI.GT.HPI) ZCI = HPI - IF (ZCR.LT.0.0E0) ZCR = 0.0E0 - ZC = CMPLX(ZCR,ZCI) - ZTH = (ZC-W)*CMPLX(1.5E0,0.0E0) - CFNU = CMPLX(FNU,0.0E0) - ZETA1 = ZC*CFNU - ZETA2 = W*CFNU - AZTH = ABS(ZTH) - ZTHR = REAL(ZTH) - ZTHI = AIMAG(ZTH) - ANG = THPI - IF (ZTHR.GE.0.0E0 .AND. ZTHI.LT.0.0E0) GO TO 140 - ANG = HPI - IF (ZTHR.EQ.0.0E0) GO TO 140 - ANG = ATAN(ZTHI/ZTHR) - IF (ZTHR.LT.0.0E0) ANG = ANG + PI - 140 CONTINUE - PP = AZTH**EX2 - ANG = ANG*EX2 - ZETAR = PP*COS(ANG) - ZETAI = PP*SIN(ANG) - IF (ZETAI.LT.0.0E0) ZETAI = 0.0E0 - ZETA = CMPLX(ZETAR,ZETAI) - ARG = ZETA*CMPLX(FN23,0.0E0) - RTZTA = ZTH/ZETA - ZA = RTZTA/W - PHI = CSQRT(ZA+ZA)*RFN13 - IF (IPMTR.EQ.1) GO TO 120 - TFN = CMPLX(RFNU,0.0E0)/W - RZTH = CMPLX(RFNU,0.0E0)/ZTH - ZC = RZTH*CMPLX(AR(2),0.0E0) - T2 = CONE/W2 - UP(2) = (T2*CMPLX(C(2),0.0E0)+CMPLX(C(3),0.0E0))*TFN - BSUM = UP(2) + ZC - ASUM = CZERO - IF (RFNU.LT.TOL) GO TO 220 - PRZTH = RZTH - PTFN = TFN - UP(1) = CONE - PP = 1.0E0 - BSUMR = REAL(BSUM) - BSUMI = AIMAG(BSUM) - BTOL = TOL*(ABS(BSUMR)+ABS(BSUMI)) - KS = 0 - KP1 = 2 - L = 3 - IAS = 0 - IBS = 0 - DO 210 LR=2,12,2 - LRP1 = LR + 1 -C----------------------------------------------------------------------- -C COMPUTE TWO ADDITIONAL CR, DR, AND UP FOR TWO MORE TERMS IN -C NEXT SUMA AND SUMB -C----------------------------------------------------------------------- - DO 160 K=LR,LRP1 - KS = KS + 1 - KP1 = KP1 + 1 - L = L + 1 - ZA = CMPLX(C(L),0.0E0) - DO 150 J=2,KP1 - L = L + 1 - ZA = ZA*T2 + CMPLX(C(L),0.0E0) - 150 CONTINUE - PTFN = PTFN*TFN - UP(KP1) = PTFN*ZA - CR(KS) = PRZTH*CMPLX(BR(KS+1),0.0E0) - PRZTH = PRZTH*RZTH - DR(KS) = PRZTH*CMPLX(AR(KS+2),0.0E0) - 160 CONTINUE - PP = PP*RFNU2 - IF (IAS.EQ.1) GO TO 180 - SUMA = UP(LRP1) - JU = LRP1 - DO 170 JR=1,LR - JU = JU - 1 - SUMA = SUMA + CR(JR)*UP(JU) - 170 CONTINUE - ASUM = ASUM + SUMA - ASUMR = REAL(ASUM) - ASUMI = AIMAG(ASUM) - TEST = ABS(ASUMR) + ABS(ASUMI) - IF (PP.LT.TOL .AND. TEST.LT.TOL) IAS = 1 - 180 CONTINUE - IF (IBS.EQ.1) GO TO 200 - SUMB = UP(LR+2) + UP(LRP1)*ZC - JU = LRP1 - DO 190 JR=1,LR - JU = JU - 1 - SUMB = SUMB + DR(JR)*UP(JU) - 190 CONTINUE - BSUM = BSUM + SUMB - BSUMR = REAL(BSUM) - BSUMI = AIMAG(BSUM) - TEST = ABS(BSUMR) + ABS(BSUMI) - IF (PP.LT.BTOL .AND. TEST.LT.TOL) IBS = 1 - 200 CONTINUE - IF (IAS.EQ.1 .AND. IBS.EQ.1) GO TO 220 - 210 CONTINUE - 220 CONTINUE - ASUM = ASUM + CONE - BSUM = -BSUM*RFN13/RTZTA - GO TO 120 - END diff --git a/slatec/cuni1.f b/slatec/cuni1.f deleted file mode 100644 index 39a3d37..0000000 --- a/slatec/cuni1.f +++ /dev/null @@ -1,178 +0,0 @@ -*DECK CUNI1 - SUBROUTINE CUNI1 (Z, FNU, KODE, N, Y, NZ, NLAST, FNUL, TOL, ELIM, - + ALIM) -C***BEGIN PROLOGUE CUNI1 -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBESI and CBESK -C***LIBRARY SLATEC -C***TYPE ALL (CUNI1-A, ZUNI1-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C CUNI1 COMPUTES I(FNU,Z) BY MEANS OF THE UNIFORM ASYMPTOTIC -C EXPANSION FOR I(FNU,Z) IN -PI/3.LE.ARG Z.LE.PI/3. -C -C FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC -C EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. -C NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER -C FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL. -C Y(I)=CZERO FOR I=NLAST+1,N -C -C***SEE ALSO CBESI, CBESK -C***ROUTINES CALLED CUCHK, CUNIK, CUOIK, R1MACH -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CUNI1 - COMPLEX CFN, CONE, CRSC, CSCL, CSR, CSS, CWRK, CZERO, C1, C2, - * PHI, RZ, SUM, S1, S2, Y, Z, ZETA1, ZETA2, CY - REAL ALIM, APHI, ASCLE, BRY, C2I, C2M, C2R, ELIM, FN, FNU, FNUL, - * RS1, TOL, YY, R1MACH - INTEGER I, IFLAG, INIT, K, KODE, M, N, ND, NLAST, NN, NUF, NW, NZ - DIMENSION BRY(3), Y(N), CWRK(16), CSS(3), CSR(3), CY(2) - DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) / -C***FIRST EXECUTABLE STATEMENT CUNI1 - NZ = 0 - ND = N - NLAST = 0 -C----------------------------------------------------------------------- -C COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- -C NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, -C EXP(ALIM)=EXP(ELIM)*TOL -C----------------------------------------------------------------------- - CSCL = CMPLX(1.0E0/TOL,0.0E0) - CRSC = CMPLX(TOL,0.0E0) - CSS(1) = CSCL - CSS(2) = CONE - CSS(3) = CRSC - CSR(1) = CRSC - CSR(2) = CONE - CSR(3) = CSCL - BRY(1) = 1.0E+3*R1MACH(1)/TOL -C----------------------------------------------------------------------- -C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER -C----------------------------------------------------------------------- - FN = MAX(FNU,1.0E0) - INIT = 0 - CALL CUNIK(Z, FN, 1, 1, TOL, INIT, PHI, ZETA1, ZETA2, SUM, CWRK) - IF (KODE.EQ.1) GO TO 10 - CFN = CMPLX(FN,0.0E0) - S1 = -ZETA1 + CFN*(CFN/(Z+ZETA2)) - GO TO 20 - 10 CONTINUE - S1 = -ZETA1 + ZETA2 - 20 CONTINUE - RS1 = REAL(S1) - IF (ABS(RS1).GT.ELIM) GO TO 130 - 30 CONTINUE - NN = MIN(2,ND) - DO 80 I=1,NN - FN = FNU + (ND-I) - INIT = 0 - CALL CUNIK(Z, FN, 1, 0, TOL, INIT, PHI, ZETA1, ZETA2, SUM, CWRK) - IF (KODE.EQ.1) GO TO 40 - CFN = CMPLX(FN,0.0E0) - YY = AIMAG(Z) - S1 = -ZETA1 + CFN*(CFN/(Z+ZETA2)) + CMPLX(0.0E0,YY) - GO TO 50 - 40 CONTINUE - S1 = -ZETA1 + ZETA2 - 50 CONTINUE -C----------------------------------------------------------------------- -C TEST FOR UNDERFLOW AND OVERFLOW -C----------------------------------------------------------------------- - RS1 = REAL(S1) - IF (ABS(RS1).GT.ELIM) GO TO 110 - IF (I.EQ.1) IFLAG = 2 - IF (ABS(RS1).LT.ALIM) GO TO 60 -C----------------------------------------------------------------------- -C REFINE TEST AND SCALE -C----------------------------------------------------------------------- - APHI = ABS(PHI) - RS1 = RS1 + ALOG(APHI) - IF (ABS(RS1).GT.ELIM) GO TO 110 - IF (I.EQ.1) IFLAG = 1 - IF (RS1.LT.0.0E0) GO TO 60 - IF (I.EQ.1) IFLAG = 3 - 60 CONTINUE -C----------------------------------------------------------------------- -C SCALE S1 IF ABS(S1).LT.ASCLE -C----------------------------------------------------------------------- - S2 = PHI*SUM - C2R = REAL(S1) - C2I = AIMAG(S1) - C2M = EXP(C2R)*REAL(CSS(IFLAG)) - S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) - S2 = S2*S1 - IF (IFLAG.NE.1) GO TO 70 - CALL CUCHK(S2, NW, BRY(1), TOL) - IF (NW.NE.0) GO TO 110 - 70 CONTINUE - M = ND - I + 1 - CY(I) = S2 - Y(M) = S2*CSR(IFLAG) - 80 CONTINUE - IF (ND.LE.2) GO TO 100 - RZ = CMPLX(2.0E0,0.0E0)/Z - BRY(2) = 1.0E0/BRY(1) - BRY(3) = R1MACH(2) - S1 = CY(1) - S2 = CY(2) - C1 = CSR(IFLAG) - ASCLE = BRY(IFLAG) - K = ND - 2 - FN = K - DO 90 I=3,ND - C2 = S2 - S2 = S1 + CMPLX(FNU+FN,0.0E0)*RZ*S2 - S1 = C2 - C2 = S2*C1 - Y(K) = C2 - K = K - 1 - FN = FN - 1.0E0 - IF (IFLAG.GE.3) GO TO 90 - C2R = REAL(C2) - C2I = AIMAG(C2) - C2R = ABS(C2R) - C2I = ABS(C2I) - C2M = MAX(C2R,C2I) - IF (C2M.LE.ASCLE) GO TO 90 - IFLAG = IFLAG + 1 - ASCLE = BRY(IFLAG) - S1 = S1*C1 - S2 = C2 - S1 = S1*CSS(IFLAG) - S2 = S2*CSS(IFLAG) - C1 = CSR(IFLAG) - 90 CONTINUE - 100 CONTINUE - RETURN -C----------------------------------------------------------------------- -C SET UNDERFLOW AND UPDATE PARAMETERS -C----------------------------------------------------------------------- - 110 CONTINUE - IF (RS1.GT.0.0E0) GO TO 120 - Y(ND) = CZERO - NZ = NZ + 1 - ND = ND - 1 - IF (ND.EQ.0) GO TO 100 - CALL CUOIK(Z, FNU, KODE, 1, ND, Y, NUF, TOL, ELIM, ALIM) - IF (NUF.LT.0) GO TO 120 - ND = ND - NUF - NZ = NZ + NUF - IF (ND.EQ.0) GO TO 100 - FN = FNU + (ND-1) - IF (FN.GE.FNUL) GO TO 30 - NLAST = ND - RETURN - 120 CONTINUE - NZ = -1 - RETURN - 130 CONTINUE - IF (RS1.GT.0.0E0) GO TO 120 - NZ = N - DO 140 I=1,N - Y(I) = CZERO - 140 CONTINUE - RETURN - END diff --git a/slatec/cuni2.f b/slatec/cuni2.f deleted file mode 100644 index ffc2bcd..0000000 --- a/slatec/cuni2.f +++ /dev/null @@ -1,225 +0,0 @@ -*DECK CUNI2 - SUBROUTINE CUNI2 (Z, FNU, KODE, N, Y, NZ, NLAST, FNUL, TOL, ELIM, - + ALIM) -C***BEGIN PROLOGUE CUNI2 -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBESI and CBESK -C***LIBRARY SLATEC -C***TYPE ALL (CUNI2-A, ZUNI2-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C CUNI2 COMPUTES I(FNU,Z) IN THE RIGHT HALF PLANE BY MEANS OF -C UNIFORM ASYMPTOTIC EXPANSION FOR J(FNU,ZN) WHERE ZN IS Z*I -C OR -Z*I AND ZN IS IN THE RIGHT HALF PLANE ALSO. -C -C FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC -C EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. -C NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER -C FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL. -C Y(I)=CZERO FOR I=NLAST+1,N -C -C***SEE ALSO CBESI, CBESK -C***ROUTINES CALLED CAIRY, CUCHK, CUNHJ, CUOIK, R1MACH -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CUNI2 - COMPLEX AI, ARG, ASUM, BSUM, CFN, CI, CID, CIP, CONE, CRSC, CSCL, - * CSR, CSS, CY, CZERO, C1, C2, DAI, PHI, RZ, S1, S2, Y, Z, ZB, - * ZETA1, ZETA2, ZN, ZAR - REAL AARG, AIC, ALIM, ANG, APHI, ASCLE, AY, BRY, CAR, C2I, C2M, - * C2R, ELIM, FN, FNU, FNUL, HPI, RS1, SAR, TOL, YY, R1MACH - INTEGER I, IFLAG, IN, INU, J, K, KODE, N, NAI, ND, NDAI, NLAST, - * NN, NUF, NW, NZ, IDUM - DIMENSION BRY(3), Y(N), CIP(4), CSS(3), CSR(3), CY(2) - DATA CZERO,CONE,CI/(0.0E0,0.0E0),(1.0E0,0.0E0),(0.0E0,1.0E0)/ - DATA CIP(1),CIP(2),CIP(3),CIP(4)/ - 1 (1.0E0,0.0E0), (0.0E0,1.0E0), (-1.0E0,0.0E0), (0.0E0,-1.0E0)/ - DATA HPI, AIC / - 1 1.57079632679489662E+00, 1.265512123484645396E+00/ -C***FIRST EXECUTABLE STATEMENT CUNI2 - NZ = 0 - ND = N - NLAST = 0 -C----------------------------------------------------------------------- -C COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- -C NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, -C EXP(ALIM)=EXP(ELIM)*TOL -C----------------------------------------------------------------------- - CSCL = CMPLX(1.0E0/TOL,0.0E0) - CRSC = CMPLX(TOL,0.0E0) - CSS(1) = CSCL - CSS(2) = CONE - CSS(3) = CRSC - CSR(1) = CRSC - CSR(2) = CONE - CSR(3) = CSCL - BRY(1) = 1.0E+3*R1MACH(1)/TOL - YY = AIMAG(Z) -C----------------------------------------------------------------------- -C ZN IS IN THE RIGHT HALF PLANE AFTER ROTATION BY CI OR -CI -C----------------------------------------------------------------------- - ZN = -Z*CI - ZB = Z - CID = -CI - INU = FNU - ANG = HPI*(FNU-INU) - CAR = COS(ANG) - SAR = SIN(ANG) - C2 = CMPLX(CAR,SAR) - ZAR = C2 - IN = INU + N - 1 - IN = MOD(IN,4) - C2 = C2*CIP(IN+1) - IF (YY.GT.0.0E0) GO TO 10 - ZN = CONJG(-ZN) - ZB = CONJG(ZB) - CID = -CID - C2 = CONJG(C2) - 10 CONTINUE -C----------------------------------------------------------------------- -C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER -C----------------------------------------------------------------------- - FN = MAX(FNU,1.0E0) - CALL CUNHJ(ZN, FN, 1, TOL, PHI, ARG, ZETA1, ZETA2, ASUM, BSUM) - IF (KODE.EQ.1) GO TO 20 - CFN = CMPLX(FNU,0.0E0) - S1 = -ZETA1 + CFN*(CFN/(ZB+ZETA2)) - GO TO 30 - 20 CONTINUE - S1 = -ZETA1 + ZETA2 - 30 CONTINUE - RS1 = REAL(S1) - IF (ABS(RS1).GT.ELIM) GO TO 150 - 40 CONTINUE - NN = MIN(2,ND) - DO 90 I=1,NN - FN = FNU + (ND-I) - CALL CUNHJ(ZN, FN, 0, TOL, PHI, ARG, ZETA1, ZETA2, ASUM, BSUM) - IF (KODE.EQ.1) GO TO 50 - CFN = CMPLX(FN,0.0E0) - AY = ABS(YY) - S1 = -ZETA1 + CFN*(CFN/(ZB+ZETA2)) + CMPLX(0.0E0,AY) - GO TO 60 - 50 CONTINUE - S1 = -ZETA1 + ZETA2 - 60 CONTINUE -C----------------------------------------------------------------------- -C TEST FOR UNDERFLOW AND OVERFLOW -C----------------------------------------------------------------------- - RS1 = REAL(S1) - IF (ABS(RS1).GT.ELIM) GO TO 120 - IF (I.EQ.1) IFLAG = 2 - IF (ABS(RS1).LT.ALIM) GO TO 70 -C----------------------------------------------------------------------- -C REFINE TEST AND SCALE -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - APHI = ABS(PHI) - AARG = ABS(ARG) - RS1 = RS1 + ALOG(APHI) - 0.25E0*ALOG(AARG) - AIC - IF (ABS(RS1).GT.ELIM) GO TO 120 - IF (I.EQ.1) IFLAG = 1 - IF (RS1.LT.0.0E0) GO TO 70 - IF (I.EQ.1) IFLAG = 3 - 70 CONTINUE -C----------------------------------------------------------------------- -C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR -C EXPONENT EXTREMES -C----------------------------------------------------------------------- - CALL CAIRY(ARG, 0, 2, AI, NAI, IDUM) - CALL CAIRY(ARG, 1, 2, DAI, NDAI, IDUM) - S2 = PHI*(AI*ASUM+DAI*BSUM) - C2R = REAL(S1) - C2I = AIMAG(S1) - C2M = EXP(C2R)*REAL(CSS(IFLAG)) - S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) - S2 = S2*S1 - IF (IFLAG.NE.1) GO TO 80 - CALL CUCHK(S2, NW, BRY(1), TOL) - IF (NW.NE.0) GO TO 120 - 80 CONTINUE - IF (YY.LE.0.0E0) S2 = CONJG(S2) - J = ND - I + 1 - S2 = S2*C2 - CY(I) = S2 - Y(J) = S2*CSR(IFLAG) - C2 = C2*CID - 90 CONTINUE - IF (ND.LE.2) GO TO 110 - RZ = CMPLX(2.0E0,0.0E0)/Z - BRY(2) = 1.0E0/BRY(1) - BRY(3) = R1MACH(2) - S1 = CY(1) - S2 = CY(2) - C1 = CSR(IFLAG) - ASCLE = BRY(IFLAG) - K = ND - 2 - FN = K - DO 100 I=3,ND - C2 = S2 - S2 = S1 + CMPLX(FNU+FN,0.0E0)*RZ*S2 - S1 = C2 - C2 = S2*C1 - Y(K) = C2 - K = K - 1 - FN = FN - 1.0E0 - IF (IFLAG.GE.3) GO TO 100 - C2R = REAL(C2) - C2I = AIMAG(C2) - C2R = ABS(C2R) - C2I = ABS(C2I) - C2M = MAX(C2R,C2I) - IF (C2M.LE.ASCLE) GO TO 100 - IFLAG = IFLAG + 1 - ASCLE = BRY(IFLAG) - S1 = S1*C1 - S2 = C2 - S1 = S1*CSS(IFLAG) - S2 = S2*CSS(IFLAG) - C1 = CSR(IFLAG) - 100 CONTINUE - 110 CONTINUE - RETURN - 120 CONTINUE - IF (RS1.GT.0.0E0) GO TO 140 -C----------------------------------------------------------------------- -C SET UNDERFLOW AND UPDATE PARAMETERS -C----------------------------------------------------------------------- - Y(ND) = CZERO - NZ = NZ + 1 - ND = ND - 1 - IF (ND.EQ.0) GO TO 110 - CALL CUOIK(Z, FNU, KODE, 1, ND, Y, NUF, TOL, ELIM, ALIM) - IF (NUF.LT.0) GO TO 140 - ND = ND - NUF - NZ = NZ + NUF - IF (ND.EQ.0) GO TO 110 - FN = FNU + (ND-1) - IF (FN.LT.FNUL) GO TO 130 -C FN = AIMAG(CID) -C J = NUF + 1 -C K = MOD(J,4) + 1 -C S1 = CIP(K) -C IF (FN.LT.0.0E0) S1 = CONJG(S1) -C C2 = C2*S1 - IN = INU + ND - 1 - IN = MOD(IN,4) + 1 - C2 = ZAR*CIP(IN) - IF (YY.LE.0.0E0)C2=CONJG(C2) - GO TO 40 - 130 CONTINUE - NLAST = ND - RETURN - 140 CONTINUE - NZ = -1 - RETURN - 150 CONTINUE - IF (RS1.GT.0.0E0) GO TO 140 - NZ = N - DO 160 I=1,N - Y(I) = CZERO - 160 CONTINUE - RETURN - END diff --git a/slatec/cunik.f b/slatec/cunik.f deleted file mode 100644 index dd31228..0000000 --- a/slatec/cunik.f +++ /dev/null @@ -1,198 +0,0 @@ -*DECK CUNIK - SUBROUTINE CUNIK (ZR, FNU, IKFLG, IPMTR, TOL, INIT, PHI, ZETA1, - + ZETA2, SUM, CWRK) -C***BEGIN PROLOGUE CUNIK -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBESI and CBESK -C***LIBRARY SLATEC -C***TYPE ALL (CUNIK-A, ZUNIK-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C CUNIK COMPUTES PARAMETERS FOR THE UNIFORM ASYMPTOTIC -C EXPANSIONS OF THE I AND K FUNCTIONS ON IKFLG= 1 OR 2 -C RESPECTIVELY BY -C -C W(FNU,ZR) = PHI*EXP(ZETA)*SUM -C -C WHERE ZETA=-ZETA1 + ZETA2 OR -C ZETA1 - ZETA2 -C -C THE FIRST CALL MUST HAVE INIT=0. SUBSEQUENT CALLS WITH THE -C SAME ZR AND FNU WILL RETURN THE I OR K FUNCTION ON IKFLG= -C 1 OR 2 WITH NO CHANGE IN INIT. CWRK IS A COMPLEX WORK -C ARRAY. IPMTR=0 COMPUTES ALL PARAMETERS. IPMTR=1 COMPUTES PHI, -C ZETA1,ZETA2. -C -C***SEE ALSO CBESI, CBESK -C***ROUTINES CALLED R1MACH -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CUNIK - COMPLEX CFN, CON, CONE, CRFN, CWRK, CZERO, PHI, S, SR, SUM, T, - * T2, ZETA1, ZETA2, ZN, ZR - REAL AC, C, FNU, RFN, TEST, TOL, TSTR, TSTI, R1MACH - INTEGER I, IKFLG, INIT, IPMTR, J, K, L - DIMENSION C(120), CWRK(16), CON(2) - DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) / - DATA CON(1), CON(2) / - 1(3.98942280401432678E-01,0.0E0),(1.25331413731550025E+00,0.0E0)/ - DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), - 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), - 2 C(19), C(20), C(21), C(22), C(23), C(24)/ - 3 1.00000000000000000E+00, -2.08333333333333333E-01, - 4 1.25000000000000000E-01, 3.34201388888888889E-01, - 5 -4.01041666666666667E-01, 7.03125000000000000E-02, - 6 -1.02581259645061728E+00, 1.84646267361111111E+00, - 7 -8.91210937500000000E-01, 7.32421875000000000E-02, - 8 4.66958442342624743E+00, -1.12070026162229938E+01, - 9 8.78912353515625000E+00, -2.36408691406250000E+00, - A 1.12152099609375000E-01, -2.82120725582002449E+01, - B 8.46362176746007346E+01, -9.18182415432400174E+01, - C 4.25349987453884549E+01, -7.36879435947963170E+00, - D 2.27108001708984375E-01, 2.12570130039217123E+02, - E -7.65252468141181642E+02, 1.05999045252799988E+03/ - DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), - 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), - 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ - 3 -6.99579627376132541E+02, 2.18190511744211590E+02, - 4 -2.64914304869515555E+01, 5.72501420974731445E-01, - 5 -1.91945766231840700E+03, 8.06172218173730938E+03, - 6 -1.35865500064341374E+04, 1.16553933368645332E+04, - 7 -5.30564697861340311E+03, 1.20090291321635246E+03, - 8 -1.08090919788394656E+02, 1.72772750258445740E+00, - 9 2.02042913309661486E+04, -9.69805983886375135E+04, - A 1.92547001232531532E+05, -2.03400177280415534E+05, - B 1.22200464983017460E+05, -4.11926549688975513E+04, - C 7.10951430248936372E+03, -4.93915304773088012E+02, - D 6.07404200127348304E+00, -2.42919187900551333E+05, - E 1.31176361466297720E+06, -2.99801591853810675E+06/ - DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), - 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), - 2 C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ - 3 3.76327129765640400E+06, -2.81356322658653411E+06, - 4 1.26836527332162478E+06, -3.31645172484563578E+05, - 5 4.52187689813627263E+04, -2.49983048181120962E+03, - 6 2.43805296995560639E+01, 3.28446985307203782E+06, - 7 -1.97068191184322269E+07, 5.09526024926646422E+07, - 8 -7.41051482115326577E+07, 6.63445122747290267E+07, - 9 -3.75671766607633513E+07, 1.32887671664218183E+07, - A -2.78561812808645469E+06, 3.08186404612662398E+05, - B -1.38860897537170405E+04, 1.10017140269246738E+02, - C -4.93292536645099620E+07, 3.25573074185765749E+08, - D -9.39462359681578403E+08, 1.55359689957058006E+09, - E -1.62108055210833708E+09, 1.10684281682301447E+09/ - DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), - 1 C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), - 2 C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ - 3 -4.95889784275030309E+08, 1.42062907797533095E+08, - 4 -2.44740627257387285E+07, 2.24376817792244943E+06, - 5 -8.40054336030240853E+04, 5.51335896122020586E+02, - 6 8.14789096118312115E+08, -5.86648149205184723E+09, - 7 1.86882075092958249E+10, -3.46320433881587779E+10, - 8 4.12801855797539740E+10, -3.30265997498007231E+10, - 9 1.79542137311556001E+10, -6.56329379261928433E+09, - A 1.55927986487925751E+09, -2.25105661889415278E+08, - B 1.73951075539781645E+07, -5.49842327572288687E+05, - C 3.03809051092238427E+03, -1.46792612476956167E+10, - D 1.14498237732025810E+11, -3.99096175224466498E+11, - E 8.19218669548577329E+11, -1.09837515608122331E+12/ - DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104), - 1 C(105), C(106), C(107), C(108), C(109), C(110), C(111), - 2 C(112), C(113), C(114), C(115), C(116), C(117), C(118)/ - 3 1.00815810686538209E+12, -6.45364869245376503E+11, - 4 2.87900649906150589E+11, -8.78670721780232657E+10, - 5 1.76347306068349694E+10, -2.16716498322379509E+09, - 6 1.43157876718888981E+08, -3.87183344257261262E+06, - 7 1.82577554742931747E+04, 2.86464035717679043E+11, - 8 -2.40629790002850396E+12, 9.10934118523989896E+12, - 9 -2.05168994109344374E+13, 3.05651255199353206E+13, - A -3.16670885847851584E+13, 2.33483640445818409E+13, - B -1.23204913055982872E+13, 4.61272578084913197E+12, - C -1.19655288019618160E+12, 2.05914503232410016E+11, - D -2.18229277575292237E+10, 1.24700929351271032E+09/ - DATA C(119), C(120)/ - 1 -2.91883881222208134E+07, 1.18838426256783253E+05/ -C***FIRST EXECUTABLE STATEMENT CUNIK - IF (INIT.NE.0) GO TO 40 -C----------------------------------------------------------------------- -C INITIALIZE ALL VARIABLES -C----------------------------------------------------------------------- - RFN = 1.0E0/FNU - CRFN = CMPLX(RFN,0.0E0) -C T = ZR*CRFN -C----------------------------------------------------------------------- -C OVERFLOW TEST (ZR/FNU TOO SMALL) -C----------------------------------------------------------------------- - TSTR = REAL(ZR) - TSTI = AIMAG(ZR) - TEST = R1MACH(1)*1.0E+3 - AC = FNU*TEST - IF (ABS(TSTR).GT.AC .OR. ABS(TSTI).GT.AC) GO TO 15 - AC = 2.0E0*ABS(ALOG(TEST))+FNU - ZETA1 = CMPLX(AC,0.0E0) - ZETA2 = CMPLX(FNU,0.0E0) - PHI=CONE - RETURN - 15 CONTINUE - T=ZR*CRFN - S = CONE + T*T - SR = CSQRT(S) - CFN = CMPLX(FNU,0.0E0) - ZN = (CONE+SR)/T - ZETA1 = CFN*CLOG(ZN) - ZETA2 = CFN*SR - T = CONE/SR - SR = T*CRFN - CWRK(16) = CSQRT(SR) - PHI = CWRK(16)*CON(IKFLG) - IF (IPMTR.NE.0) RETURN - T2 = CONE/S - CWRK(1) = CONE - CRFN = CONE - AC = 1.0E0 - L = 1 - DO 20 K=2,15 - S = CZERO - DO 10 J=1,K - L = L + 1 - S = S*T2 + CMPLX(C(L),0.0E0) - 10 CONTINUE - CRFN = CRFN*SR - CWRK(K) = CRFN*S - AC = AC*RFN - TSTR = REAL(CWRK(K)) - TSTI = AIMAG(CWRK(K)) - TEST = ABS(TSTR) + ABS(TSTI) - IF (AC.LT.TOL .AND. TEST.LT.TOL) GO TO 30 - 20 CONTINUE - K = 15 - 30 CONTINUE - INIT = K - 40 CONTINUE - IF (IKFLG.EQ.2) GO TO 60 -C----------------------------------------------------------------------- -C COMPUTE SUM FOR THE I FUNCTION -C----------------------------------------------------------------------- - S = CZERO - DO 50 I=1,INIT - S = S + CWRK(I) - 50 CONTINUE - SUM = S - PHI = CWRK(16)*CON(1) - RETURN - 60 CONTINUE -C----------------------------------------------------------------------- -C COMPUTE SUM FOR THE K FUNCTION -C----------------------------------------------------------------------- - S = CZERO - T = CONE - DO 70 I=1,INIT - S = S + T*CWRK(I) - T = -T - 70 CONTINUE - SUM = S - PHI = CWRK(16)*CON(2) - RETURN - END diff --git a/slatec/cunk1.f b/slatec/cunk1.f deleted file mode 100644 index 4e34b23..0000000 --- a/slatec/cunk1.f +++ /dev/null @@ -1,353 +0,0 @@ -*DECK CUNK1 - SUBROUTINE CUNK1 (Z, FNU, KODE, MR, N, Y, NZ, TOL, ELIM, ALIM) -C***BEGIN PROLOGUE CUNK1 -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBESK -C***LIBRARY SLATEC -C***TYPE ALL (CUNK1-A, ZUNK1-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C CUNK1 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE -C RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE -C UNIFORM ASYMPTOTIC EXPANSION. -C MR INDICATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. -C NZ=-1 MEANS AN OVERFLOW WILL OCCUR -C -C***SEE ALSO CBESK -C***ROUTINES CALLED CS1S2, CUCHK, CUNIK, R1MACH -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CUNK1 - COMPLEX CFN, CK, CONE, CRSC, CS, CSCL, CSGN, CSPN, CSR, CSS, - * CWRK, CY, CZERO, C1, C2, PHI, RZ, SUM, S1, S2, Y, Z, - * ZETA1, ZETA2, ZR, PHID, ZETA1D, ZETA2D, SUMD - REAL ALIM, ANG, APHI, ASC, ASCLE, BRY, CPN, C2I, C2M, C2R, ELIM, - * FMR, FN, FNF, FNU, PI, RS1, SGN, SPN, TOL, X, R1MACH - INTEGER I, IB, IFLAG, IFN, IL, INIT, INU, IUF, K, KDFLG, KFLAG, - * KK, KODE, MR, N, NW, NZ, J, IPARD, INITD, IC, M - DIMENSION BRY(3), INIT(2), Y(N), SUM(2), PHI(2), ZETA1(2), - * ZETA2(2), CY(2), CWRK(16,3), CSS(3), CSR(3) - DATA CZERO, CONE / (0.0E0,0.0E0) , (1.0E0,0.0E0) / - DATA PI / 3.14159265358979324E0 / -C***FIRST EXECUTABLE STATEMENT CUNK1 - KDFLG = 1 - NZ = 0 -C----------------------------------------------------------------------- -C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN -C THE UNDERFLOW LIMIT -C----------------------------------------------------------------------- - CSCL = CMPLX(1.0E0/TOL,0.0E0) - CRSC = CMPLX(TOL,0.0E0) - CSS(1) = CSCL - CSS(2) = CONE - CSS(3) = CRSC - CSR(1) = CRSC - CSR(2) = CONE - CSR(3) = CSCL - BRY(1) = 1.0E+3*R1MACH(1)/TOL - BRY(2) = 1.0E0/BRY(1) - BRY(3) = R1MACH(2) - X = REAL(Z) - ZR = Z - IF (X.LT.0.0E0) ZR = -Z - J=2 - DO 70 I=1,N -C----------------------------------------------------------------------- -C J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J -C----------------------------------------------------------------------- - J = 3 - J - FN = FNU + (I-1) - INIT(J) = 0 - CALL CUNIK(ZR, FN, 2, 0, TOL, INIT(J), PHI(J), ZETA1(J), - * ZETA2(J), SUM(J), CWRK(1,J)) - IF (KODE.EQ.1) GO TO 20 - CFN = CMPLX(FN,0.0E0) - S1 = ZETA1(J) - CFN*(CFN/(ZR+ZETA2(J))) - GO TO 30 - 20 CONTINUE - S1 = ZETA1(J) - ZETA2(J) - 30 CONTINUE -C----------------------------------------------------------------------- -C TEST FOR UNDERFLOW AND OVERFLOW -C----------------------------------------------------------------------- - RS1 = REAL(S1) - IF (ABS(RS1).GT.ELIM) GO TO 60 - IF (KDFLG.EQ.1) KFLAG = 2 - IF (ABS(RS1).LT.ALIM) GO TO 40 -C----------------------------------------------------------------------- -C REFINE TEST AND SCALE -C----------------------------------------------------------------------- - APHI = ABS(PHI(J)) - RS1 = RS1 + ALOG(APHI) - IF (ABS(RS1).GT.ELIM) GO TO 60 - IF (KDFLG.EQ.1) KFLAG = 1 - IF (RS1.LT.0.0E0) GO TO 40 - IF (KDFLG.EQ.1) KFLAG = 3 - 40 CONTINUE -C----------------------------------------------------------------------- -C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR -C EXPONENT EXTREMES -C----------------------------------------------------------------------- - S2 = PHI(J)*SUM(J) - C2R = REAL(S1) - C2I = AIMAG(S1) - C2M = EXP(C2R)*REAL(CSS(KFLAG)) - S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) - S2 = S2*S1 - IF (KFLAG.NE.1) GO TO 50 - CALL CUCHK(S2, NW, BRY(1), TOL) - IF (NW.NE.0) GO TO 60 - 50 CONTINUE - CY(KDFLG) = S2 - Y(I) = S2*CSR(KFLAG) - IF (KDFLG.EQ.2) GO TO 75 - KDFLG = 2 - GO TO 70 - 60 CONTINUE - IF (RS1.GT.0.0E0) GO TO 290 -C----------------------------------------------------------------------- -C FOR X.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW -C----------------------------------------------------------------------- - IF (X.LT.0.0E0) GO TO 290 - KDFLG = 1 - Y(I) = CZERO - NZ=NZ+1 - IF (I.EQ.1) GO TO 70 - IF (Y(I-1).EQ.CZERO) GO TO 70 - Y(I-1) = CZERO - NZ=NZ+1 - 70 CONTINUE - I=N - 75 CONTINUE - RZ = CMPLX(2.0E0,0.0E0)/ZR - CK = CMPLX(FN,0.0E0)*RZ - IB = I+1 - IF (N.LT.IB) GO TO 160 -C----------------------------------------------------------------------- -C TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW, SET SEQUENCE TO ZERO -C ON UNDERFLOW -C----------------------------------------------------------------------- - FN = FNU+(N-1) - IPARD = 1 - IF (MR.NE.0) IPARD = 0 - INITD = 0 - CALL CUNIK(ZR,FN,2,IPARD,TOL,INITD,PHID,ZETA1D,ZETA2D,SUMD, - *CWRK(1,3)) - IF (KODE.EQ.1) GO TO 80 - CFN=CMPLX(FN,0.0E0) - S1=ZETA1D-CFN*(CFN/(ZR+ZETA2D)) - GO TO 90 - 80 CONTINUE - S1=ZETA1D-ZETA2D - 90 CONTINUE - RS1=REAL(S1) - IF (ABS(RS1).GT.ELIM) GO TO 95 - IF (ABS(RS1).LT.ALIM) GO TO 100 -C----------------------------------------------------------------------- -C REFINE ESTIMATE AND TEST -C----------------------------------------------------------------------- - APHI=ABS(PHID) - RS1=RS1+ALOG(APHI) - IF (ABS(RS1).LT.ELIM) GO TO 100 - 95 CONTINUE - IF (RS1.GT.0.0E0) GO TO 290 -C----------------------------------------------------------------------- -C FOR X.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW -C----------------------------------------------------------------------- - IF (X.LT.0.0E0) GO TO 290 - NZ=N - DO 96 I=1,N - Y(I) = CZERO - 96 CONTINUE - RETURN - 100 CONTINUE -C----------------------------------------------------------------------- -C RECUR FORWARD FOR REMAINDER OF THE SEQUENCE -C----------------------------------------------------------------------- - S1 = CY(1) - S2 = CY(2) - C1 = CSR(KFLAG) - ASCLE = BRY(KFLAG) - DO 120 I=IB,N - C2 = S2 - S2 = CK*S2 + S1 - S1 = C2 - CK = CK + RZ - C2 = S2*C1 - Y(I) = C2 - IF (KFLAG.GE.3) GO TO 120 - C2R = REAL(C2) - C2I = AIMAG(C2) - C2R = ABS(C2R) - C2I = ABS(C2I) - C2M = MAX(C2R,C2I) - IF (C2M.LE.ASCLE) GO TO 120 - KFLAG = KFLAG + 1 - ASCLE = BRY(KFLAG) - S1 = S1*C1 - S2 = C2 - S1 = S1*CSS(KFLAG) - S2 = S2*CSS(KFLAG) - C1 = CSR(KFLAG) - 120 CONTINUE - 160 CONTINUE - IF (MR.EQ.0) RETURN -C----------------------------------------------------------------------- -C ANALYTIC CONTINUATION FOR RE(Z).LT.0.0E0 -C----------------------------------------------------------------------- - NZ = 0 - FMR = MR - SGN = -SIGN(PI,FMR) -C----------------------------------------------------------------------- -C CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP. -C----------------------------------------------------------------------- - CSGN = CMPLX(0.0E0,SGN) - INU = FNU - FNF = FNU - INU - IFN = INU + N - 1 - ANG = FNF*SGN - CPN = COS(ANG) - SPN = SIN(ANG) - CSPN = CMPLX(CPN,SPN) - IF (MOD(IFN,2).EQ.1) CSPN = -CSPN - ASC = BRY(1) - KK = N - IUF = 0 - KDFLG = 1 - IB = IB-1 - IC = IB-1 - DO 260 K=1,N - FN = FNU + (KK-1) -C----------------------------------------------------------------------- -C LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K -C FUNCTION ABOVE -C----------------------------------------------------------------------- - M=3 - IF (N.GT.2) GO TO 175 - 170 CONTINUE - INITD = INIT(J) - PHID = PHI(J) - ZETA1D = ZETA1(J) - ZETA2D = ZETA2(J) - SUMD = SUM(J) - M = J - J = 3 - J - GO TO 180 - 175 CONTINUE - IF ((KK.EQ.N).AND.(IB.LT.N)) GO TO 180 - IF ((KK.EQ.IB).OR.(KK.EQ.IC)) GO TO 170 - INITD = 0 - 180 CONTINUE - CALL CUNIK(ZR, FN, 1, 0, TOL, INITD, PHID, ZETA1D, - * ZETA2D, SUMD, CWRK(1,M)) - IF (KODE.EQ.1) GO TO 190 - CFN = CMPLX(FN,0.0E0) - S1 = -ZETA1D + CFN*(CFN/(ZR+ZETA2D)) - GO TO 200 - 190 CONTINUE - S1 = -ZETA1D + ZETA2D - 200 CONTINUE -C----------------------------------------------------------------------- -C TEST FOR UNDERFLOW AND OVERFLOW -C----------------------------------------------------------------------- - RS1 = REAL(S1) - IF (ABS(RS1).GT.ELIM) GO TO 250 - IF (KDFLG.EQ.1) IFLAG = 2 - IF (ABS(RS1).LT.ALIM) GO TO 210 -C----------------------------------------------------------------------- -C REFINE TEST AND SCALE -C----------------------------------------------------------------------- - APHI = ABS(PHID) - RS1 = RS1 + ALOG(APHI) - IF (ABS(RS1).GT.ELIM) GO TO 250 - IF (KDFLG.EQ.1) IFLAG = 1 - IF (RS1.LT.0.0E0) GO TO 210 - IF (KDFLG.EQ.1) IFLAG = 3 - 210 CONTINUE - S2 = CSGN*PHID*SUMD - C2R = REAL(S1) - C2I = AIMAG(S1) - C2M = EXP(C2R)*REAL(CSS(IFLAG)) - S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) - S2 = S2*S1 - IF (IFLAG.NE.1) GO TO 220 - CALL CUCHK(S2, NW, BRY(1), TOL) - IF (NW.NE.0) S2 = CMPLX(0.0E0,0.0E0) - 220 CONTINUE - CY(KDFLG) = S2 - C2 = S2 - S2 = S2*CSR(IFLAG) -C----------------------------------------------------------------------- -C ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N -C----------------------------------------------------------------------- - S1 = Y(KK) - IF (KODE.EQ.1) GO TO 240 - CALL CS1S2(ZR, S1, S2, NW, ASC, ALIM, IUF) - NZ = NZ + NW - 240 CONTINUE - Y(KK) = S1*CSPN + S2 - KK = KK - 1 - CSPN = -CSPN - IF (C2.NE.CZERO) GO TO 245 - KDFLG = 1 - GO TO 260 - 245 CONTINUE - IF (KDFLG.EQ.2) GO TO 265 - KDFLG = 2 - GO TO 260 - 250 CONTINUE - IF (RS1.GT.0.0E0) GO TO 290 - S2 = CZERO - GO TO 220 - 260 CONTINUE - K = N - 265 CONTINUE - IL = N - K - IF (IL.EQ.0) RETURN -C----------------------------------------------------------------------- -C RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE -C K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP -C INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES. -C----------------------------------------------------------------------- - S1 = CY(1) - S2 = CY(2) - CS = CSR(IFLAG) - ASCLE = BRY(IFLAG) - FN = (INU+IL) - DO 280 I=1,IL - C2 = S2 - S2 = S1 + CMPLX(FN+FNF,0.0E0)*RZ*S2 - S1 = C2 - FN = FN - 1.0E0 - C2 = S2*CS - CK = C2 - C1 = Y(KK) - IF (KODE.EQ.1) GO TO 270 - CALL CS1S2(ZR, C1, C2, NW, ASC, ALIM, IUF) - NZ = NZ + NW - 270 CONTINUE - Y(KK) = C1*CSPN + C2 - KK = KK - 1 - CSPN = -CSPN - IF (IFLAG.GE.3) GO TO 280 - C2R = REAL(CK) - C2I = AIMAG(CK) - C2R = ABS(C2R) - C2I = ABS(C2I) - C2M = MAX(C2R,C2I) - IF (C2M.LE.ASCLE) GO TO 280 - IFLAG = IFLAG + 1 - ASCLE = BRY(IFLAG) - S1 = S1*CS - S2 = CK - S1 = S1*CSS(IFLAG) - S2 = S2*CSS(IFLAG) - CS = CSR(IFLAG) - 280 CONTINUE - RETURN - 290 CONTINUE - NZ = -1 - RETURN - END diff --git a/slatec/cunk2.f b/slatec/cunk2.f deleted file mode 100644 index 7a079d0..0000000 --- a/slatec/cunk2.f +++ /dev/null @@ -1,403 +0,0 @@ -*DECK CUNK2 - SUBROUTINE CUNK2 (Z, FNU, KODE, MR, N, Y, NZ, TOL, ELIM, ALIM) -C***BEGIN PROLOGUE CUNK2 -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBESK -C***LIBRARY SLATEC -C***TYPE ALL (CUNK2-A, ZUNK2-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C CUNK2 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE -C RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE -C UNIFORM ASYMPTOTIC EXPANSIONS FOR H(KIND,FNU,ZN) AND J(FNU,ZN) -C WHERE ZN IS IN THE RIGHT HALF PLANE, KIND=(3-MR)/2, MR=+1 OR -C -1. HERE ZN=ZR*I OR -ZR*I WHERE ZR=Z IF Z IS IN THE RIGHT -C HALF PLANE OR ZR=-Z IF Z IS IN THE LEFT HALF PLANE. MR INDIC- -C ATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. -C NZ=-1 MEANS AN OVERFLOW WILL OCCUR -C -C***SEE ALSO CBESK -C***ROUTINES CALLED CAIRY, CS1S2, CUCHK, CUNHJ, R1MACH -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CUNK2 - COMPLEX AI, ARG, ASUM, BSUM, CFN, CI, CIP, - * CK, CONE, CRSC, CR1, CR2, CS, CSCL, CSGN, CSPN, CSR, CSS, CY, - * CZERO, C1, C2, DAI, PHI, RZ, S1, S2, Y, Z, ZB, ZETA1, - * ZETA2, ZN, ZR, PHID, ARGD, ZETA1D, ZETA2D, ASUMD, BSUMD - REAL AARG, AIC, ALIM, ANG, APHI, ASC, ASCLE, BRY, CAR, CPN, C2I, - * C2M, C2R, ELIM, FMR, FN, FNF, FNU, HPI, PI, RS1, SAR, SGN, SPN, - * TOL, X, YY, R1MACH - INTEGER I, IB, IFLAG, IFN, IL, IN, INU, IUF, K, KDFLG, KFLAG, KK, - * KODE, MR, N, NAI, NDAI, NW, NZ, IDUM, J, IPARD, IC - DIMENSION BRY(3), Y(N), ASUM(2), BSUM(2), PHI(2), ARG(2), - * ZETA1(2), ZETA2(2), CY(2), CIP(4), CSS(3), CSR(3) - DATA CZERO, CONE, CI, CR1, CR2 / - 1 (0.0E0,0.0E0),(1.0E0,0.0E0),(0.0E0,1.0E0), - 1(1.0E0,1.73205080756887729E0),(-0.5E0,-8.66025403784438647E-01)/ - DATA HPI, PI, AIC / - 1 1.57079632679489662E+00, 3.14159265358979324E+00, - 1 1.26551212348464539E+00/ - DATA CIP(1),CIP(2),CIP(3),CIP(4)/ - 1 (1.0E0,0.0E0), (0.0E0,-1.0E0), (-1.0E0,0.0E0), (0.0E0,1.0E0)/ -C***FIRST EXECUTABLE STATEMENT CUNK2 - KDFLG = 1 - NZ = 0 -C----------------------------------------------------------------------- -C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN -C THE UNDERFLOW LIMIT -C----------------------------------------------------------------------- - CSCL = CMPLX(1.0E0/TOL,0.0E0) - CRSC = CMPLX(TOL,0.0E0) - CSS(1) = CSCL - CSS(2) = CONE - CSS(3) = CRSC - CSR(1) = CRSC - CSR(2) = CONE - CSR(3) = CSCL - BRY(1) = 1.0E+3*R1MACH(1)/TOL - BRY(2) = 1.0E0/BRY(1) - BRY(3) = R1MACH(2) - X = REAL(Z) - ZR = Z - IF (X.LT.0.0E0) ZR = -Z - YY = AIMAG(ZR) - ZN = -ZR*CI - ZB = ZR - INU = FNU - FNF = FNU - INU - ANG = -HPI*FNF - CAR = COS(ANG) - SAR = SIN(ANG) - CPN = -HPI*CAR - SPN = -HPI*SAR - C2 = CMPLX(-SPN,CPN) - KK = MOD(INU,4) + 1 - CS = CR1*C2*CIP(KK) - IF (YY.GT.0.0E0) GO TO 10 - ZN = CONJG(-ZN) - ZB = CONJG(ZB) - 10 CONTINUE -C----------------------------------------------------------------------- -C K(FNU,Z) IS COMPUTED FROM H(2,FNU,-I*Z) WHERE Z IS IN THE FIRST -C QUADRANT. FOURTH QUADRANT VALUES (YY.LE.0.0E0) ARE COMPUTED BY -C CONJUGATION SINCE THE K FUNCTION IS REAL ON THE POSITIVE REAL AXIS -C----------------------------------------------------------------------- - J = 2 - DO 70 I=1,N -C----------------------------------------------------------------------- -C J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J -C----------------------------------------------------------------------- - J = 3 - J - FN = FNU + (I-1) - CALL CUNHJ(ZN, FN, 0, TOL, PHI(J), ARG(J), ZETA1(J), ZETA2(J), - * ASUM(J), BSUM(J)) - IF (KODE.EQ.1) GO TO 20 - CFN = CMPLX(FN,0.0E0) - S1 = ZETA1(J) - CFN*(CFN/(ZB+ZETA2(J))) - GO TO 30 - 20 CONTINUE - S1 = ZETA1(J) - ZETA2(J) - 30 CONTINUE -C----------------------------------------------------------------------- -C TEST FOR UNDERFLOW AND OVERFLOW -C----------------------------------------------------------------------- - RS1 = REAL(S1) - IF (ABS(RS1).GT.ELIM) GO TO 60 - IF (KDFLG.EQ.1) KFLAG = 2 - IF (ABS(RS1).LT.ALIM) GO TO 40 -C----------------------------------------------------------------------- -C REFINE TEST AND SCALE -C----------------------------------------------------------------------- - APHI = ABS(PHI(J)) - AARG = ABS(ARG(J)) - RS1 = RS1 + ALOG(APHI) - 0.25E0*ALOG(AARG) - AIC - IF (ABS(RS1).GT.ELIM) GO TO 60 - IF (KDFLG.EQ.1) KFLAG = 1 - IF (RS1.LT.0.0E0) GO TO 40 - IF (KDFLG.EQ.1) KFLAG = 3 - 40 CONTINUE -C----------------------------------------------------------------------- -C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR -C EXPONENT EXTREMES -C----------------------------------------------------------------------- - C2 = ARG(J)*CR2 - CALL CAIRY(C2, 0, 2, AI, NAI, IDUM) - CALL CAIRY(C2, 1, 2, DAI, NDAI, IDUM) - S2 = CS*PHI(J)*(AI*ASUM(J)+CR2*DAI*BSUM(J)) - C2R = REAL(S1) - C2I = AIMAG(S1) - C2M = EXP(C2R)*REAL(CSS(KFLAG)) - S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) - S2 = S2*S1 - IF (KFLAG.NE.1) GO TO 50 - CALL CUCHK(S2, NW, BRY(1), TOL) - IF (NW.NE.0) GO TO 60 - 50 CONTINUE - IF (YY.LE.0.0E0) S2 = CONJG(S2) - CY(KDFLG) = S2 - Y(I) = S2*CSR(KFLAG) - CS = -CI*CS - IF (KDFLG.EQ.2) GO TO 75 - KDFLG = 2 - GO TO 70 - 60 CONTINUE - IF (RS1.GT.0.0E0) GO TO 300 -C----------------------------------------------------------------------- -C FOR X.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW -C----------------------------------------------------------------------- - IF (X.LT.0.0E0) GO TO 300 - KDFLG = 1 - Y(I) = CZERO - CS = -CI*CS - NZ=NZ+1 - IF (I.EQ.1) GO TO 70 - IF (Y(I-1).EQ.CZERO) GO TO 70 - Y(I-1) = CZERO - NZ=NZ+1 - 70 CONTINUE - I=N - 75 CONTINUE - RZ = CMPLX(2.0E0,0.0E0)/ZR - CK = CMPLX(FN,0.0E0)*RZ - IB = I + 1 - IF (N.LT.IB) GO TO 170 -C----------------------------------------------------------------------- -C TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW, SET SEQUENCE TO ZERO -C ON UNDERFLOW -C----------------------------------------------------------------------- - FN = FNU+(N-1) - IPARD = 1 - IF (MR.NE.0) IPARD = 0 - CALL CUNHJ(ZN,FN,IPARD,TOL,PHID,ARGD,ZETA1D,ZETA2D,ASUMD,BSUMD) - IF (KODE.EQ.1) GO TO 80 - CFN=CMPLX(FN,0.0E0) - S1=ZETA1D-CFN*(CFN/(ZB+ZETA2D)) - GO TO 90 - 80 CONTINUE - S1=ZETA1D-ZETA2D - 90 CONTINUE - RS1=REAL(S1) - IF (ABS(RS1).GT.ELIM) GO TO 95 - IF (ABS(RS1).LT.ALIM) GO TO 100 -C----------------------------------------------------------------------- -C REFINE ESTIMATE AND TEST -C----------------------------------------------------------------------- - APHI=ABS(PHID) - AARG = ABS(ARGD) - RS1=RS1+ALOG(APHI)-0.25E0*ALOG(AARG)-AIC - IF (ABS(RS1).LT.ELIM) GO TO 100 - 95 CONTINUE - IF (RS1.GT.0.0E0) GO TO 300 -C----------------------------------------------------------------------- -C FOR X.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW -C----------------------------------------------------------------------- - IF (X.LT.0.0E0) GO TO 300 - NZ=N - DO 96 I=1,N - Y(I) = CZERO - 96 CONTINUE - RETURN - 100 CONTINUE -C----------------------------------------------------------------------- -C SCALED FORWARD RECURRENCE FOR REMAINDER OF THE SEQUENCE -C----------------------------------------------------------------------- - S1 = CY(1) - S2 = CY(2) - C1 = CSR(KFLAG) - ASCLE = BRY(KFLAG) - DO 120 I=IB,N - C2 = S2 - S2 = CK*S2 + S1 - S1 = C2 - CK = CK + RZ - C2 = S2*C1 - Y(I) = C2 - IF (KFLAG.GE.3) GO TO 120 - C2R = REAL(C2) - C2I = AIMAG(C2) - C2R = ABS(C2R) - C2I = ABS(C2I) - C2M = MAX(C2R,C2I) - IF (C2M.LE.ASCLE) GO TO 120 - KFLAG = KFLAG + 1 - ASCLE = BRY(KFLAG) - S1 = S1*C1 - S2 = C2 - S1 = S1*CSS(KFLAG) - S2 = S2*CSS(KFLAG) - C1 = CSR(KFLAG) - 120 CONTINUE - 170 CONTINUE - IF (MR.EQ.0) RETURN -C----------------------------------------------------------------------- -C ANALYTIC CONTINUATION FOR RE(Z).LT.0.0E0 -C----------------------------------------------------------------------- - NZ = 0 - FMR = MR - SGN = -SIGN(PI,FMR) -C----------------------------------------------------------------------- -C CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP. -C----------------------------------------------------------------------- - CSGN = CMPLX(0.0E0,SGN) - IF (YY.LE.0.0E0) CSGN = CONJG(CSGN) - IFN = INU + N - 1 - ANG = FNF*SGN - CPN = COS(ANG) - SPN = SIN(ANG) - CSPN = CMPLX(CPN,SPN) - IF (MOD(IFN,2).EQ.1) CSPN = -CSPN -C----------------------------------------------------------------------- -C CS=COEFF OF THE J FUNCTION TO GET THE I FUNCTION. I(FNU,Z) IS -C COMPUTED FROM EXP(I*FNU*HPI)*J(FNU,-I*Z) WHERE Z IS IN THE FIRST -C QUADRANT. FOURTH QUADRANT VALUES (YY.LE.0.0E0) ARE COMPUTED BY -C CONJUGATION SINCE THE I FUNCTION IS REAL ON THE POSITIVE REAL AXIS -C----------------------------------------------------------------------- - CS = CMPLX(CAR,-SAR)*CSGN - IN = MOD(IFN,4) + 1 - C2 = CIP(IN) - CS = CS*CONJG(C2) - ASC = BRY(1) - KK = N - KDFLG = 1 - IB = IB-1 - IC = IB-1 - IUF = 0 - DO 270 K=1,N -C----------------------------------------------------------------------- -C LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K -C FUNCTION ABOVE -C----------------------------------------------------------------------- - FN = FNU+(KK-1) - IF (N.GT.2) GO TO 180 - 175 CONTINUE - PHID = PHI(J) - ARGD = ARG(J) - ZETA1D = ZETA1(J) - ZETA2D = ZETA2(J) - ASUMD = ASUM(J) - BSUMD = BSUM(J) - J = 3 - J - GO TO 190 - 180 CONTINUE - IF ((KK.EQ.N).AND.(IB.LT.N)) GO TO 190 - IF ((KK.EQ.IB).OR.(KK.EQ.IC)) GO TO 175 - CALL CUNHJ(ZN, FN, 0, TOL, PHID, ARGD, ZETA1D, ZETA2D, - * ASUMD, BSUMD) - 190 CONTINUE - IF (KODE.EQ.1) GO TO 200 - CFN = CMPLX(FN,0.0E0) - S1 = -ZETA1D + CFN*(CFN/(ZB+ZETA2D)) - GO TO 210 - 200 CONTINUE - S1 = -ZETA1D + ZETA2D - 210 CONTINUE -C----------------------------------------------------------------------- -C TEST FOR UNDERFLOW AND OVERFLOW -C----------------------------------------------------------------------- - RS1 = REAL(S1) - IF (ABS(RS1).GT.ELIM) GO TO 260 - IF (KDFLG.EQ.1) IFLAG = 2 - IF (ABS(RS1).LT.ALIM) GO TO 220 -C----------------------------------------------------------------------- -C REFINE TEST AND SCALE -C----------------------------------------------------------------------- - APHI = ABS(PHID) - AARG = ABS(ARGD) - RS1 = RS1 + ALOG(APHI) - 0.25E0*ALOG(AARG) - AIC - IF (ABS(RS1).GT.ELIM) GO TO 260 - IF (KDFLG.EQ.1) IFLAG = 1 - IF (RS1.LT.0.0E0) GO TO 220 - IF (KDFLG.EQ.1) IFLAG = 3 - 220 CONTINUE - CALL CAIRY(ARGD, 0, 2, AI, NAI, IDUM) - CALL CAIRY(ARGD, 1, 2, DAI, NDAI, IDUM) - S2 = CS*PHID*(AI*ASUMD+DAI*BSUMD) - C2R = REAL(S1) - C2I = AIMAG(S1) - C2M = EXP(C2R)*REAL(CSS(IFLAG)) - S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) - S2 = S2*S1 - IF (IFLAG.NE.1) GO TO 230 - CALL CUCHK(S2, NW, BRY(1), TOL) - IF (NW.NE.0) S2 = CMPLX(0.0E0,0.0E0) - 230 CONTINUE - IF (YY.LE.0.0E0) S2 = CONJG(S2) - CY(KDFLG) = S2 - C2 = S2 - S2 = S2*CSR(IFLAG) -C----------------------------------------------------------------------- -C ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N -C----------------------------------------------------------------------- - S1 = Y(KK) - IF (KODE.EQ.1) GO TO 250 - CALL CS1S2(ZR, S1, S2, NW, ASC, ALIM, IUF) - NZ = NZ + NW - 250 CONTINUE - Y(KK) = S1*CSPN + S2 - KK = KK - 1 - CSPN = -CSPN - CS = -CS*CI - IF (C2.NE.CZERO) GO TO 255 - KDFLG = 1 - GO TO 270 - 255 CONTINUE - IF (KDFLG.EQ.2) GO TO 275 - KDFLG = 2 - GO TO 270 - 260 CONTINUE - IF (RS1.GT.0.0E0) GO TO 300 - S2 = CZERO - GO TO 230 - 270 CONTINUE - K = N - 275 CONTINUE - IL = N-K - IF (IL.EQ.0) RETURN -C----------------------------------------------------------------------- -C RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE -C K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP -C INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES. -C----------------------------------------------------------------------- - S1 = CY(1) - S2 = CY(2) - CS = CSR(IFLAG) - ASCLE = BRY(IFLAG) - FN = INU+IL - DO 290 I=1,IL - C2 = S2 - S2 = S1 + CMPLX(FN+FNF,0.0E0)*RZ*S2 - S1 = C2 - FN = FN - 1.0E0 - C2 = S2*CS - CK = C2 - C1 = Y(KK) - IF (KODE.EQ.1) GO TO 280 - CALL CS1S2(ZR, C1, C2, NW, ASC, ALIM, IUF) - NZ = NZ + NW - 280 CONTINUE - Y(KK) = C1*CSPN + C2 - KK = KK - 1 - CSPN = -CSPN - IF (IFLAG.GE.3) GO TO 290 - C2R = REAL(CK) - C2I = AIMAG(CK) - C2R = ABS(C2R) - C2I = ABS(C2I) - C2M = MAX(C2R,C2I) - IF (C2M.LE.ASCLE) GO TO 290 - IFLAG = IFLAG + 1 - ASCLE = BRY(IFLAG) - S1 = S1*CS - S2 = CK - S1 = S1*CSS(IFLAG) - S2 = S2*CSS(IFLAG) - CS = CSR(IFLAG) - 290 CONTINUE - RETURN - 300 CONTINUE - NZ = -1 - RETURN - END diff --git a/slatec/cuoik.f b/slatec/cuoik.f deleted file mode 100644 index d30b9e8..0000000 --- a/slatec/cuoik.f +++ /dev/null @@ -1,170 +0,0 @@ -*DECK CUOIK - SUBROUTINE CUOIK (Z, FNU, KODE, IKFLG, N, Y, NUF, TOL, ELIM, ALIM) -C***BEGIN PROLOGUE CUOIK -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBESH, CBESI and CBESK -C***LIBRARY SLATEC -C***TYPE ALL (CUOIK-A, ZUOIK-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C CUOIK COMPUTES THE LEADING TERMS OF THE UNIFORM ASYMPTOTIC -C EXPANSIONS FOR THE I AND K FUNCTIONS AND COMPARES THEM -C (IN LOGARITHMIC FORM) TO ALIM AND ELIM FOR OVER AND UNDERFLOW -C WHERE ALIM.LT.ELIM. IF THE MAGNITUDE, BASED ON THE LEADING -C EXPONENTIAL, IS LESS THAN ALIM OR GREATER THAN -ALIM, THEN -C THE RESULT IS ON SCALE. IF NOT, THEN A REFINED TEST USING OTHER -C MULTIPLIERS (IN LOGARITHMIC FORM) IS MADE BASED ON ELIM. HERE -C EXP(-ELIM)=SMALLEST MACHINE NUMBER*1.0E+3 AND EXP(-ALIM)= -C EXP(-ELIM)/TOL -C -C IKFLG=1 MEANS THE I SEQUENCE IS TESTED -C =2 MEANS THE K SEQUENCE IS TESTED -C NUF = 0 MEANS THE LAST MEMBER OF THE SEQUENCE IS ON SCALE -C =-1 MEANS AN OVERFLOW WOULD OCCUR -C IKFLG=1 AND NUF.GT.0 MEANS THE LAST NUF Y VALUES WERE SET TO ZERO -C THE FIRST N-NUF VALUES MUST BE SET BY ANOTHER ROUTINE -C IKFLG=2 AND NUF.EQ.N MEANS ALL Y VALUES WERE SET TO ZERO -C IKFLG=2 AND 0.LT.NUF.LT.N NOT CONSIDERED. Y MUST BE SET BY -C ANOTHER ROUTINE -C -C***SEE ALSO CBESH, CBESI, CBESK -C***ROUTINES CALLED CUCHK, CUNHJ, CUNIK, R1MACH -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CUOIK - COMPLEX ARG, ASUM, BSUM, CWRK, CZ, CZERO, PHI, SUM, Y, Z, ZB, - * ZETA1, ZETA2, ZN, ZR - REAL AARG, AIC, ALIM, APHI, ASCLE, AX, AY, ELIM, FNN, FNU, GNN, - * GNU, RCZ, TOL, X, YY, R1MACH - INTEGER I, IFORM, IKFLG, INIT, KODE, N, NN, NUF, NW - DIMENSION Y(N), CWRK(16) - DATA CZERO / (0.0E0,0.0E0) / - DATA AIC / 1.265512123484645396E+00 / -C***FIRST EXECUTABLE STATEMENT CUOIK - NUF = 0 - NN = N - X = REAL(Z) - ZR = Z - IF (X.LT.0.0E0) ZR = -Z - ZB = ZR - YY = AIMAG(ZR) - AX = ABS(X)*1.7321E0 - AY = ABS(YY) - IFORM = 1 - IF (AY.GT.AX) IFORM = 2 - GNU = MAX(FNU,1.0E0) - IF (IKFLG.EQ.1) GO TO 10 - FNN = NN - GNN = FNU + FNN - 1.0E0 - GNU = MAX(GNN,FNN) - 10 CONTINUE -C----------------------------------------------------------------------- -C ONLY THE MAGNITUDE OF ARG AND PHI ARE NEEDED ALONG WITH THE -C REAL PARTS OF ZETA1, ZETA2 AND ZB. NO ATTEMPT IS MADE TO GET -C THE SIGN OF THE IMAGINARY PART CORRECT. -C----------------------------------------------------------------------- - IF (IFORM.EQ.2) GO TO 20 - INIT = 0 - CALL CUNIK(ZR, GNU, IKFLG, 1, TOL, INIT, PHI, ZETA1, ZETA2, SUM, - * CWRK) - CZ = -ZETA1 + ZETA2 - GO TO 40 - 20 CONTINUE - ZN = -ZR*CMPLX(0.0E0,1.0E0) - IF (YY.GT.0.0E0) GO TO 30 - ZN = CONJG(-ZN) - 30 CONTINUE - CALL CUNHJ(ZN, GNU, 1, TOL, PHI, ARG, ZETA1, ZETA2, ASUM, BSUM) - CZ = -ZETA1 + ZETA2 - AARG = ABS(ARG) - 40 CONTINUE - IF (KODE.EQ.2) CZ = CZ - ZB - IF (IKFLG.EQ.2) CZ = -CZ - APHI = ABS(PHI) - RCZ = REAL(CZ) -C----------------------------------------------------------------------- -C OVERFLOW TEST -C----------------------------------------------------------------------- - IF (RCZ.GT.ELIM) GO TO 170 - IF (RCZ.LT.ALIM) GO TO 50 - RCZ = RCZ + ALOG(APHI) - IF (IFORM.EQ.2) RCZ = RCZ - 0.25E0*ALOG(AARG) - AIC - IF (RCZ.GT.ELIM) GO TO 170 - GO TO 100 - 50 CONTINUE -C----------------------------------------------------------------------- -C UNDERFLOW TEST -C----------------------------------------------------------------------- - IF (RCZ.LT.(-ELIM)) GO TO 60 - IF (RCZ.GT.(-ALIM)) GO TO 100 - RCZ = RCZ + ALOG(APHI) - IF (IFORM.EQ.2) RCZ = RCZ - 0.25E0*ALOG(AARG) - AIC - IF (RCZ.GT.(-ELIM)) GO TO 80 - 60 CONTINUE - DO 70 I=1,NN - Y(I) = CZERO - 70 CONTINUE - NUF = NN - RETURN - 80 CONTINUE - ASCLE = 1.0E+3*R1MACH(1)/TOL - CZ = CZ + CLOG(PHI) - IF (IFORM.EQ.1) GO TO 90 - CZ = CZ - CMPLX(0.25E0,0.0E0)*CLOG(ARG) - CMPLX(AIC,0.0E0) - 90 CONTINUE - AX = EXP(RCZ)/TOL - AY = AIMAG(CZ) - CZ = CMPLX(AX,0.0E0)*CMPLX(COS(AY),SIN(AY)) - CALL CUCHK(CZ, NW, ASCLE, TOL) - IF (NW.EQ.1) GO TO 60 - 100 CONTINUE - IF (IKFLG.EQ.2) RETURN - IF (N.EQ.1) RETURN -C----------------------------------------------------------------------- -C SET UNDERFLOWS ON I SEQUENCE -C----------------------------------------------------------------------- - 110 CONTINUE - GNU = FNU + (NN-1) - IF (IFORM.EQ.2) GO TO 120 - INIT = 0 - CALL CUNIK(ZR, GNU, IKFLG, 1, TOL, INIT, PHI, ZETA1, ZETA2, SUM, - * CWRK) - CZ = -ZETA1 + ZETA2 - GO TO 130 - 120 CONTINUE - CALL CUNHJ(ZN, GNU, 1, TOL, PHI, ARG, ZETA1, ZETA2, ASUM, BSUM) - CZ = -ZETA1 + ZETA2 - AARG = ABS(ARG) - 130 CONTINUE - IF (KODE.EQ.2) CZ = CZ - ZB - APHI = ABS(PHI) - RCZ = REAL(CZ) - IF (RCZ.LT.(-ELIM)) GO TO 140 - IF (RCZ.GT.(-ALIM)) RETURN - RCZ = RCZ + ALOG(APHI) - IF (IFORM.EQ.2) RCZ = RCZ - 0.25E0*ALOG(AARG) - AIC - IF (RCZ.GT.(-ELIM)) GO TO 150 - 140 CONTINUE - Y(NN) = CZERO - NN = NN - 1 - NUF = NUF + 1 - IF (NN.EQ.0) RETURN - GO TO 110 - 150 CONTINUE - ASCLE = 1.0E+3*R1MACH(1)/TOL - CZ = CZ + CLOG(PHI) - IF (IFORM.EQ.1) GO TO 160 - CZ = CZ - CMPLX(0.25E0,0.0E0)*CLOG(ARG) - CMPLX(AIC,0.0E0) - 160 CONTINUE - AX = EXP(RCZ)/TOL - AY = AIMAG(CZ) - CZ = CMPLX(AX,0.0E0)*CMPLX(COS(AY),SIN(AY)) - CALL CUCHK(CZ, NW, ASCLE, TOL) - IF (NW.EQ.1) GO TO 140 - RETURN - 170 CONTINUE - NUF = -1 - RETURN - END diff --git a/slatec/cv.f b/slatec/cv.f deleted file mode 100644 index 7bcf5d3..0000000 --- a/slatec/cv.f +++ /dev/null @@ -1,124 +0,0 @@ -*DECK CV - REAL FUNCTION CV (XVAL, NDATA, NCONST, NORD, NBKPT, BKPT, W) -C***BEGIN PROLOGUE CV -C***PURPOSE Evaluate the variance function of the curve obtained -C by the constrained B-spline fitting subprogram FC. -C***LIBRARY SLATEC -C***CATEGORY L7A3 -C***TYPE SINGLE PRECISION (CV-S, DCV-D) -C***KEYWORDS ANALYSIS OF COVARIANCE, B-SPLINE, -C CONSTRAINED LEAST SQUARES, CURVE FITTING -C***AUTHOR Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C CV( ) is a companion function subprogram for FC( ). The -C documentation for FC( ) has complete usage instructions. -C -C CV( ) is used to evaluate the variance function of the curve -C obtained by the constrained B-spline fitting subprogram, FC( ). -C The variance function defines the square of the probable error -C of the fitted curve at any point, XVAL. One can use the square -C root of this variance function to determine a probable error band -C around the fitted curve. -C -C CV( ) is used after a call to FC( ). MODE, an input variable to -C FC( ), is used to indicate if the variance function is desired. -C In order to use CV( ), MODE must equal 2 or 4 on input to FC( ). -C MODE is also used as an output flag from FC( ). Check to make -C sure that MODE = 0 after calling FC( ), indicating a successful -C constrained curve fit. The array SDDATA, as input to FC( ), must -C also be defined with the standard deviation or uncertainty of the -C Y values to use CV( ). -C -C To evaluate the variance function after calling FC( ) as stated -C above, use CV( ) as shown here -C -C VAR=CV(XVAL,NDATA,NCONST,NORD,NBKPT,BKPT,W) -C -C The variance function is given by -C -C VAR=(transpose of B(XVAL))*C*B(XVAL)/MAX(NDATA-N,1) -C -C where N = NBKPT - NORD. -C -C The vector B(XVAL) is the B-spline basis function values at -C X=XVAL. The covariance matrix, C, of the solution coefficients -C accounts only for the least squares equations and the explicitly -C stated equality constraints. This fact must be considered when -C interpreting the variance function from a data fitting problem -C that has inequality constraints on the fitted curve. -C -C All the variables in the calling sequence for CV( ) are used in -C FC( ) except the variable XVAL. Do not change the values of these -C variables between the call to FC( ) and the use of CV( ). -C -C The following is a brief description of the variables -C -C XVAL The point where the variance is desired. -C -C NDATA The number of discrete (X,Y) pairs for which FC( ) -C calculated a piece-wise polynomial curve. -C -C NCONST The number of conditions that constrained the B-spline in -C FC( ). -C -C NORD The order of the B-spline used in FC( ). -C The value of NORD must satisfy 1 < NORD < 20 . -C -C (The order of the spline is one more than the degree of -C the piece-wise polynomial defined on each interval. This -C is consistent with the B-spline package convention. For -C example, NORD=4 when we are using piece-wise cubics.) -C -C NBKPT The number of knots in the array BKPT(*). -C The value of NBKPT must satisfy NBKPT .GE. 2*NORD. -C -C BKPT(*) The real array of knots. Normally the problem data -C interval will be included between the limits BKPT(NORD) -C and BKPT(NBKPT-NORD+1). The additional end knots -C BKPT(I),I=1,...,NORD-1 and I=NBKPT-NORD+2,...,NBKPT, are -C required by FC( ) to compute the functions used to fit -C the data. -C -C W(*) Real work array as used in FC( ). See FC( ) for the -C required length of W(*). The contents of W(*) must not -C be modified by the user if the variance function is -C desired. -C -C***REFERENCES R. J. Hanson, Constrained least squares curve fitting -C to discrete data using B-splines, a users guide, -C Report SAND78-1291, Sandia Laboratories, December -C 1978. -C***ROUTINES CALLED BSPLVN, SDOT -C***REVISION HISTORY (YYMMDD) -C 780801 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 CV - DIMENSION BKPT(NBKPT), W(*), V(40) -C***FIRST EXECUTABLE STATEMENT CV - ZERO = 0. - MDG = NBKPT - NORD + 3 - MDW = NBKPT - NORD + 1 + NCONST - IS = MDG*(NORD+1) + 2*MAX(NDATA,NBKPT) + NBKPT + NORD**2 - LAST = NBKPT - NORD + 1 - ILEFT = NORD - 10 IF (.NOT.(XVAL.GE.BKPT(ILEFT+1) .AND. ILEFT.LT.LAST-1)) GO TO 20 - ILEFT = ILEFT + 1 - GO TO 10 - 20 CALL BSPLVN(BKPT, NORD, 1, XVAL, ILEFT, V(NORD+1)) - ILEFT = ILEFT - NORD + 1 - IP = MDW*(ILEFT-1) + ILEFT + IS - N = NBKPT - NORD - DO 30 I=1,NORD - V(I) = SDOT(NORD,W(IP),1,V(NORD+1),1) - IP = IP + MDW - 30 CONTINUE - CV = MAX(SDOT(NORD,V,1,V(NORD+1),1),ZERO) -C -C SCALE THE VARIANCE SO IT IS AN UNBIASED ESTIMATE. - CV = CV/MAX(NDATA-N,1) - RETURN - END diff --git a/slatec/cwrsk.f b/slatec/cwrsk.f deleted file mode 100644 index 887de94..0000000 --- a/slatec/cwrsk.f +++ /dev/null @@ -1,86 +0,0 @@ -*DECK CWRSK - SUBROUTINE CWRSK (ZR, FNU, KODE, N, Y, NZ, CW, TOL, ELIM, ALIM) -C***BEGIN PROLOGUE CWRSK -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBESI and CBESK -C***LIBRARY SLATEC -C***TYPE ALL (CWRSK-A, ZWRSK-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C CWRSK COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY -C NORMALIZING THE I FUNCTION RATIOS FROM CRATI BY THE WRONSKIAN -C -C***SEE ALSO CBESI, CBESK -C***ROUTINES CALLED CBKNU, CRATI, R1MACH -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE CWRSK - COMPLEX CINU, CSCL, CT, CW, C1, C2, RCT, ST, Y, ZR - REAL ACT, ACW, ALIM, ASCLE, ELIM, FNU, S1, S2, TOL, YY, R1MACH - INTEGER I, KODE, N, NW, NZ - DIMENSION Y(N), CW(2) -C***FIRST EXECUTABLE STATEMENT CWRSK -C----------------------------------------------------------------------- -C I(FNU+I-1,Z) BY BACKWARD RECURRENCE FOR RATIOS -C Y(I)=I(FNU+I,Z)/I(FNU+I-1,Z) FROM CRATI NORMALIZED BY THE -C WRONSKIAN WITH K(FNU,Z) AND K(FNU+1,Z) FROM CBKNU. -C----------------------------------------------------------------------- - NZ = 0 - CALL CBKNU(ZR, FNU, KODE, 2, CW, NW, TOL, ELIM, ALIM) - IF (NW.NE.0) GO TO 50 - CALL CRATI(ZR, FNU, N, Y, TOL) -C----------------------------------------------------------------------- -C RECUR FORWARD ON I(FNU+1,Z) = R(FNU,Z)*I(FNU,Z), -C R(FNU+J-1,Z)=Y(J), J=1,...,N -C----------------------------------------------------------------------- - CINU = CMPLX(1.0E0,0.0E0) - IF (KODE.EQ.1) GO TO 10 - YY = AIMAG(ZR) - S1 = COS(YY) - S2 = SIN(YY) - CINU = CMPLX(S1,S2) - 10 CONTINUE -C----------------------------------------------------------------------- -C ON LOW EXPONENT MACHINES THE K FUNCTIONS CAN BE CLOSE TO BOTH -C THE UNDER AND OVERFLOW LIMITS AND THE NORMALIZATION MUST BE -C SCALED TO PREVENT OVER OR UNDERFLOW. CUOIK HAS DETERMINED THAT -C THE RESULT IS ON SCALE. -C----------------------------------------------------------------------- - ACW = ABS(CW(2)) - ASCLE = 1.0E+3*R1MACH(1)/TOL - CSCL = CMPLX(1.0E0,0.0E0) - IF (ACW.GT.ASCLE) GO TO 20 - CSCL = CMPLX(1.0E0/TOL,0.0E0) - GO TO 30 - 20 CONTINUE - ASCLE = 1.0E0/ASCLE - IF (ACW.LT.ASCLE) GO TO 30 - CSCL = CMPLX(TOL,0.0E0) - 30 CONTINUE - C1 = CW(1)*CSCL - C2 = CW(2)*CSCL - ST = Y(1) -C----------------------------------------------------------------------- -C CINU=CINU*(CONJG(CT)/ABS(CT))*(1.0E0/ABS(CT) PREVENTS -C UNDER- OR OVERFLOW PREMATURELY BY SQUARING ABS(CT) -C----------------------------------------------------------------------- - CT = ZR*(C2+ST*C1) - ACT = ABS(CT) - RCT = CMPLX(1.0E0/ACT,0.0E0) - CT = CONJG(CT)*RCT - CINU = CINU*RCT*CT - Y(1) = CINU*CSCL - IF (N.EQ.1) RETURN - DO 40 I=2,N - CINU = ST*CINU - ST = Y(I) - Y(I) = CINU*CSCL - 40 CONTINUE - RETURN - 50 CONTINUE - NZ = -1 - IF(NW.EQ.(-2)) NZ=-2 - RETURN - END diff --git a/slatec/d1mach.f b/slatec/d1mach.f deleted file mode 100644 index 6f10f70..0000000 --- a/slatec/d1mach.f +++ /dev/null @@ -1,502 +0,0 @@ -*DECK D1MACH - DOUBLE PRECISION FUNCTION D1MACH (I) -C***BEGIN PROLOGUE D1MACH -C***PURPOSE Return floating point machine dependent constants. -C***LIBRARY SLATEC -C***CATEGORY R1 -C***TYPE DOUBLE PRECISION (R1MACH-S, D1MACH-D) -C***KEYWORDS MACHINE CONSTANTS -C***AUTHOR Fox, P. A., (Bell Labs) -C Hall, A. D., (Bell Labs) -C Schryer, N. L., (Bell Labs) -C***DESCRIPTION -C -C D1MACH can be used to obtain machine-dependent parameters for the -C local machine environment. It is a function subprogram with one -C (input) argument, and can be referenced as follows: -C -C D = D1MACH(I) -C -C where I=1,...,5. The (output) value of D above is determined by -C the (input) value of I. The results for various values of I are -C discussed below. -C -C D1MACH( 1) = B**(EMIN-1), the smallest positive magnitude. -C D1MACH( 2) = B**EMAX*(1 - B**(-T)), the largest magnitude. -C D1MACH( 3) = B**(-T), the smallest relative spacing. -C D1MACH( 4) = B**(1-T), the largest relative spacing. -C D1MACH( 5) = LOG10(B) -C -C Assume double precision numbers are represented in the T-digit, -C base-B form -C -C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) -C -C where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and -C EMIN .LE. E .LE. EMAX. -C -C The values of B, T, EMIN and EMAX are provided in I1MACH as -C follows: -C I1MACH(10) = B, the base. -C I1MACH(14) = T, the number of base-B digits. -C I1MACH(15) = EMIN, the smallest exponent E. -C I1MACH(16) = EMAX, the largest exponent E. -C -C To alter this function for a particular environment, the desired -C set of DATA statements should be activated by removing the C from -C column 1. Also, the values of D1MACH(1) - D1MACH(4) should be -C checked for consistency with the local operating system. -C -C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for -C a portable library, ACM Transactions on Mathematical -C Software 4, 2 (June 1978), pp. 177-188. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 890213 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 900618 Added DEC RISC constants. (WRB) -C 900723 Added IBM RS 6000 constants. (WRB) -C 900911 Added SUN 386i constants. (WRB) -C 910710 Added HP 730 constants. (SMR) -C 911114 Added Convex IEEE constants. (WRB) -C 920121 Added SUN -r8 compiler option constants. (WRB) -C 920229 Added Touchstone Delta i860 constants. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 920625 Added CONVEX -p8 and -pd8 compiler option constants. -C (BKS, WRB) -C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) -C***END PROLOGUE D1MACH -C - INTEGER SMALL(4) - INTEGER LARGE(4) - INTEGER RIGHT(4) - INTEGER DIVER(4) - INTEGER LOG10(4) -C - DOUBLE PRECISION DMACH(5) - SAVE DMACH -C - EQUIVALENCE (DMACH(1),SMALL(1)) - EQUIVALENCE (DMACH(2),LARGE(1)) - EQUIVALENCE (DMACH(3),RIGHT(1)) - EQUIVALENCE (DMACH(4),DIVER(1)) - EQUIVALENCE (DMACH(5),LOG10(1)) -C -C MACHINE CONSTANTS FOR THE AMIGA -C ABSOFT FORTRAN COMPILER USING THE 68020/68881 COMPILER OPTION -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE AMIGA -C ABSOFT FORTRAN COMPILER USING SOFTWARE FLOATING POINT -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FDFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE APOLLO -C -C DATA SMALL(1), SMALL(2) / 16#00100000, 16#00000000 / -C DATA LARGE(1), LARGE(2) / 16#7FFFFFFF, 16#FFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / 16#3CA00000, 16#00000000 / -C DATA DIVER(1), DIVER(2) / 16#3CB00000, 16#00000000 / -C DATA LOG10(1), LOG10(2) / 16#3FD34413, 16#509F79FF / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM -C -C DATA SMALL(1) / ZC00800000 / -C DATA SMALL(2) / Z000000000 / -C DATA LARGE(1) / ZDFFFFFFFF / -C DATA LARGE(2) / ZFFFFFFFFF / -C DATA RIGHT(1) / ZCC5800000 / -C DATA RIGHT(2) / Z000000000 / -C DATA DIVER(1) / ZCC6800000 / -C DATA DIVER(2) / Z000000000 / -C DATA LOG10(1) / ZD00E730E7 / -C DATA LOG10(2) / ZC77800DC0 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM -C -C DATA SMALL(1) / O1771000000000000 / -C DATA SMALL(2) / O0000000000000000 / -C DATA LARGE(1) / O0777777777777777 / -C DATA LARGE(2) / O0007777777777777 / -C DATA RIGHT(1) / O1461000000000000 / -C DATA RIGHT(2) / O0000000000000000 / -C DATA DIVER(1) / O1451000000000000 / -C DATA DIVER(2) / O0000000000000000 / -C DATA LOG10(1) / O1157163034761674 / -C DATA LOG10(2) / O0006677466732724 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS -C -C DATA SMALL(1) / O1771000000000000 / -C DATA SMALL(2) / O7770000000000000 / -C DATA LARGE(1) / O0777777777777777 / -C DATA LARGE(2) / O7777777777777777 / -C DATA RIGHT(1) / O1461000000000000 / -C DATA RIGHT(2) / O0000000000000000 / -C DATA DIVER(1) / O1451000000000000 / -C DATA DIVER(2) / O0000000000000000 / -C DATA LOG10(1) / O1157163034761674 / -C DATA LOG10(2) / O0006677466732724 / -C -C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE -C -C DATA SMALL(1) / Z"3001800000000000" / -C DATA SMALL(2) / Z"3001000000000000" / -C DATA LARGE(1) / Z"4FFEFFFFFFFFFFFE" / -C DATA LARGE(2) / Z"4FFE000000000000" / -C DATA RIGHT(1) / Z"3FD2800000000000" / -C DATA RIGHT(2) / Z"3FD2000000000000" / -C DATA DIVER(1) / Z"3FD3800000000000" / -C DATA DIVER(2) / Z"3FD3000000000000" / -C DATA LOG10(1) / Z"3FFF9A209A84FBCF" / -C DATA LOG10(2) / Z"3FFFF7988F8959AC" / -C -C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES -C -C DATA SMALL(1) / 00564000000000000000B / -C DATA SMALL(2) / 00000000000000000000B / -C DATA LARGE(1) / 37757777777777777777B / -C DATA LARGE(2) / 37157777777777777777B / -C DATA RIGHT(1) / 15624000000000000000B / -C DATA RIGHT(2) / 00000000000000000000B / -C DATA DIVER(1) / 15634000000000000000B / -C DATA DIVER(2) / 00000000000000000000B / -C DATA LOG10(1) / 17164642023241175717B / -C DATA LOG10(2) / 16367571421742254654B / -C -C MACHINE CONSTANTS FOR THE CELERITY C1260 -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fn OR -pd8 COMPILER OPTION -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CC0000000000000' / -C DATA DMACH(4) / Z'3CD0000000000000' / -C DATA DMACH(5) / Z'3FF34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fi COMPILER OPTION -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -p8 COMPILER OPTION -C -C DATA DMACH(1) / Z'00010000000000000000000000000000' / -C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3F900000000000000000000000000000' / -C DATA DMACH(4) / Z'3F910000000000000000000000000000' / -C DATA DMACH(5) / Z'3FFF34413509F79FEF311F12B35816F9' / -C -C MACHINE CONSTANTS FOR THE CRAY -C -C DATA SMALL(1) / 201354000000000000000B / -C DATA SMALL(2) / 000000000000000000000B / -C DATA LARGE(1) / 577767777777777777777B / -C DATA LARGE(2) / 000007777777777777774B / -C DATA RIGHT(1) / 376434000000000000000B / -C DATA RIGHT(2) / 000000000000000000000B / -C DATA DIVER(1) / 376444000000000000000B / -C DATA DIVER(2) / 000000000000000000000B / -C DATA LOG10(1) / 377774642023241175717B / -C DATA LOG10(2) / 000007571421742254654B / -C -C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 -C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - -C STATIC DMACH(5) -C -C DATA SMALL / 20K, 3*0 / -C DATA LARGE / 77777K, 3*177777K / -C DATA RIGHT / 31420K, 3*0 / -C DATA DIVER / 32020K, 3*0 / -C DATA LOG10 / 40423K, 42023K, 50237K, 74776K / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING G_FLOAT -C -C DATA DMACH(1) / '0000000000000010'X / -C DATA DMACH(2) / 'FFFFFFFFFFFF7FFF'X / -C DATA DMACH(3) / '0000000000003CC0'X / -C DATA DMACH(4) / '0000000000003CD0'X / -C DATA DMACH(5) / '79FF509F44133FF3'X / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING IEEE_FORMAT -C -C DATA DMACH(1) / '0010000000000000'X / -C DATA DMACH(2) / '7FEFFFFFFFFFFFFF'X / -C DATA DMACH(3) / '3CA0000000000000'X / -C DATA DMACH(4) / '3CB0000000000000'X / -C DATA DMACH(5) / '3FD34413509F79FF'X / -C -C MACHINE CONSTANTS FOR THE DEC RISC -C -C DATA SMALL(1), SMALL(2) / Z'00000000', Z'00100000'/ -C DATA LARGE(1), LARGE(2) / Z'FFFFFFFF', Z'7FEFFFFF'/ -C DATA RIGHT(1), RIGHT(2) / Z'00000000', Z'3CA00000'/ -C DATA DIVER(1), DIVER(2) / Z'00000000', Z'3CB00000'/ -C DATA LOG10(1), LOG10(2) / Z'509F79FF', Z'3FD34413'/ -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING D_FLOATING -C (EXPRESSED IN INTEGER AND HEXADECIMAL) -C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS -C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS -C -C DATA SMALL(1), SMALL(2) / 128, 0 / -C DATA LARGE(1), LARGE(2) / -32769, -1 / -C DATA RIGHT(1), RIGHT(2) / 9344, 0 / -C DATA DIVER(1), DIVER(2) / 9472, 0 / -C DATA LOG10(1), LOG10(2) / 546979738, -805796613 / -C -C DATA SMALL(1), SMALL(2) / Z00000080, Z00000000 / -C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / Z00002480, Z00000000 / -C DATA DIVER(1), DIVER(2) / Z00002500, Z00000000 / -C DATA LOG10(1), LOG10(2) / Z209A3F9A, ZCFF884FB / -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING G_FLOATING -C (EXPRESSED IN INTEGER AND HEXADECIMAL) -C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS -C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS -C -C DATA SMALL(1), SMALL(2) / 16, 0 / -C DATA LARGE(1), LARGE(2) / -32769, -1 / -C DATA RIGHT(1), RIGHT(2) / 15552, 0 / -C DATA DIVER(1), DIVER(2) / 15568, 0 / -C DATA LOG10(1), LOG10(2) / 1142112243, 2046775455 / -C -C DATA SMALL(1), SMALL(2) / Z00000010, Z00000000 / -C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / Z00003CC0, Z00000000 / -C DATA DIVER(1), DIVER(2) / Z00003CD0, Z00000000 / -C DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F / -C -C MACHINE CONSTANTS FOR THE ELXSI 6400 -C (ASSUMING REAL*8 IS THE DEFAULT DOUBLE PRECISION) -C -C DATA SMALL(1), SMALL(2) / '00100000'X,'00000000'X / -C DATA LARGE(1), LARGE(2) / '7FEFFFFF'X,'FFFFFFFF'X / -C DATA RIGHT(1), RIGHT(2) / '3CB00000'X,'00000000'X / -C DATA DIVER(1), DIVER(2) / '3CC00000'X,'00000000'X / -C DATA LOG10(1), LOG10(2) / '3FD34413'X,'509F79FF'X / -C -C MACHINE CONSTANTS FOR THE HARRIS 220 -C -C DATA SMALL(1), SMALL(2) / '20000000, '00000201 / -C DATA LARGE(1), LARGE(2) / '37777777, '37777577 / -C DATA RIGHT(1), RIGHT(2) / '20000000, '00000333 / -C DATA DIVER(1), DIVER(2) / '20000000, '00000334 / -C DATA LOG10(1), LOG10(2) / '23210115, '10237777 / -C -C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES -C -C DATA SMALL(1), SMALL(2) / O402400000000, O000000000000 / -C DATA LARGE(1), LARGE(2) / O376777777777, O777777777777 / -C DATA RIGHT(1), RIGHT(2) / O604400000000, O000000000000 / -C DATA DIVER(1), DIVER(2) / O606400000000, O000000000000 / -C DATA LOG10(1), LOG10(2) / O776464202324, O117571775714 / -C -C MACHINE CONSTANTS FOR THE HP 730 -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C THREE WORD DOUBLE PRECISION OPTION WITH FTN4 -C -C DATA SMALL(1), SMALL(2), SMALL(3) / 40000B, 0, 1 / -C DATA LARGE(1), LARGE(2), LARGE(3) / 77777B, 177777B, 177776B / -C DATA RIGHT(1), RIGHT(2), RIGHT(3) / 40000B, 0, 265B / -C DATA DIVER(1), DIVER(2), DIVER(3) / 40000B, 0, 276B / -C DATA LOG10(1), LOG10(2), LOG10(3) / 46420B, 46502B, 77777B / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C FOUR WORD DOUBLE PRECISION OPTION WITH FTN4 -C -C DATA SMALL(1), SMALL(2) / 40000B, 0 / -C DATA SMALL(3), SMALL(4) / 0, 1 / -C DATA LARGE(1), LARGE(2) / 77777B, 177777B / -C DATA LARGE(3), LARGE(4) / 177777B, 177776B / -C DATA RIGHT(1), RIGHT(2) / 40000B, 0 / -C DATA RIGHT(3), RIGHT(4) / 0, 225B / -C DATA DIVER(1), DIVER(2) / 40000B, 0 / -C DATA DIVER(3), DIVER(4) / 0, 227B / -C DATA LOG10(1), LOG10(2) / 46420B, 46502B / -C DATA LOG10(3), LOG10(4) / 76747B, 176377B / -C -C MACHINE CONSTANTS FOR THE HP 9000 -C -C DATA SMALL(1), SMALL(2) / 00040000000B, 00000000000B / -C DATA LARGE(1), LARGE(2) / 17737777777B, 37777777777B / -C DATA RIGHT(1), RIGHT(2) / 07454000000B, 00000000000B / -C DATA DIVER(1), DIVER(2) / 07460000000B, 00000000000B / -C DATA LOG10(1), LOG10(2) / 07764642023B, 12047674777B / -C -C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, -C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND -C THE PERKIN ELMER (INTERDATA) 7/32. -C -C DATA SMALL(1), SMALL(2) / Z00100000, Z00000000 / -C DATA LARGE(1), LARGE(2) / Z7FFFFFFF, ZFFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / Z33100000, Z00000000 / -C DATA DIVER(1), DIVER(2) / Z34100000, Z00000000 / -C DATA LOG10(1), LOG10(2) / Z41134413, Z509F79FF / -C -C MACHINE CONSTANTS FOR THE IBM PC -C ASSUMES THAT ALL ARITHMETIC IS DONE IN DOUBLE PRECISION -C ON 8088, I.E., NOT IN 80 BIT FORM FOR THE 8087. -C -C DATA SMALL(1) / 2.23D-308 / -C DATA LARGE(1) / 1.79D+308 / -C DATA RIGHT(1) / 1.11D-16 / -C DATA DIVER(1) / 2.22D-16 / -C DATA LOG10(1) / 0.301029995663981195D0 / -C -C MACHINE CONSTANTS FOR THE IBM RS 6000 -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE INTEL i860 -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) -C -C DATA SMALL(1), SMALL(2) / "033400000000, "000000000000 / -C DATA LARGE(1), LARGE(2) / "377777777777, "344777777777 / -C DATA RIGHT(1), RIGHT(2) / "113400000000, "000000000000 / -C DATA DIVER(1), DIVER(2) / "114400000000, "000000000000 / -C DATA LOG10(1), LOG10(2) / "177464202324, "144117571776 / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) -C -C DATA SMALL(1), SMALL(2) / "000400000000, "000000000000 / -C DATA LARGE(1), LARGE(2) / "377777777777, "377777777777 / -C DATA RIGHT(1), RIGHT(2) / "103400000000, "000000000000 / -C DATA DIVER(1), DIVER(2) / "104400000000, "000000000000 / -C DATA LOG10(1), LOG10(2) / "177464202324, "476747767461 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). -C -C DATA SMALL(1), SMALL(2) / 8388608, 0 / -C DATA LARGE(1), LARGE(2) / 2147483647, -1 / -C DATA RIGHT(1), RIGHT(2) / 612368384, 0 / -C DATA DIVER(1), DIVER(2) / 620756992, 0 / -C DATA LOG10(1), LOG10(2) / 1067065498, -2063872008 / -C -C DATA SMALL(1), SMALL(2) / O00040000000, O00000000000 / -C DATA LARGE(1), LARGE(2) / O17777777777, O37777777777 / -C DATA RIGHT(1), RIGHT(2) / O04440000000, O00000000000 / -C DATA DIVER(1), DIVER(2) / O04500000000, O00000000000 / -C DATA LOG10(1), LOG10(2) / O07746420232, O20476747770 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). -C -C DATA SMALL(1), SMALL(2) / 128, 0 / -C DATA SMALL(3), SMALL(4) / 0, 0 / -C DATA LARGE(1), LARGE(2) / 32767, -1 / -C DATA LARGE(3), LARGE(4) / -1, -1 / -C DATA RIGHT(1), RIGHT(2) / 9344, 0 / -C DATA RIGHT(3), RIGHT(4) / 0, 0 / -C DATA DIVER(1), DIVER(2) / 9472, 0 / -C DATA DIVER(3), DIVER(4) / 0, 0 / -C DATA LOG10(1), LOG10(2) / 16282, 8346 / -C DATA LOG10(3), LOG10(4) / -31493, -12296 / -C -C DATA SMALL(1), SMALL(2) / O000200, O000000 / -C DATA SMALL(3), SMALL(4) / O000000, O000000 / -C DATA LARGE(1), LARGE(2) / O077777, O177777 / -C DATA LARGE(3), LARGE(4) / O177777, O177777 / -C DATA RIGHT(1), RIGHT(2) / O022200, O000000 / -C DATA RIGHT(3), RIGHT(4) / O000000, O000000 / -C DATA DIVER(1), DIVER(2) / O022400, O000000 / -C DATA DIVER(3), DIVER(4) / O000000, O000000 / -C DATA LOG10(1), LOG10(2) / O037632, O020232 / -C DATA LOG10(3), LOG10(4) / O102373, O147770 / -C -C MACHINE CONSTANTS FOR THE SILICON GRAPHICS -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE SUN -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE SUN -C USING THE -r8 COMPILER OPTION -C -C DATA DMACH(1) / Z'00010000000000000000000000000000' / -C DATA DMACH(2) / Z'7FFEFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3F8E0000000000000000000000000000' / -C DATA DMACH(4) / Z'3F8F0000000000000000000000000000' / -C DATA DMACH(5) / Z'3FFD34413509F79FEF311F12B35816F9' / -C -C MACHINE CONSTANTS FOR THE SUN 386i -C -C DATA SMALL(1), SMALL(2) / Z'FFFFFFFD', Z'000FFFFF' / -C DATA LARGE(1), LARGE(2) / Z'FFFFFFB0', Z'7FEFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'000000B0', Z'3CA00000' / -C DATA DIVER(1), DIVER(2) / Z'FFFFFFCB', Z'3CAFFFFF' -C DATA LOG10(1), LOG10(2) / Z'509F79E9', Z'3FD34413' / -C -C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER -C -C DATA SMALL(1), SMALL(2) / O000040000000, O000000000000 / -C DATA LARGE(1), LARGE(2) / O377777777777, O777777777777 / -C DATA RIGHT(1), RIGHT(2) / O170540000000, O000000000000 / -C DATA DIVER(1), DIVER(2) / O170640000000, O000000000000 / -C DATA LOG10(1), LOG10(2) / O177746420232, O411757177572 / -C -C***FIRST EXECUTABLE STATEMENT D1MACH - IF (I .LT. 1 .OR. I .GT. 5) CALL XERMSG ('SLATEC', 'D1MACH', - + 'I OUT OF BOUNDS', 1, 2) -C - D1MACH = DMACH(I) - RETURN -C - END diff --git a/slatec/d1merg.f b/slatec/d1merg.f deleted file mode 100644 index 350416b..0000000 --- a/slatec/d1merg.f +++ /dev/null @@ -1,63 +0,0 @@ -*DECK D1MERG - SUBROUTINE D1MERG (TCOS, I1, M1, I2, M2, I3) -C***BEGIN PROLOGUE D1MERG -C***SUBSIDIARY -C***PURPOSE Merge two strings of ascending double precision numbers. -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (S1MERG-S, D1MERG-D, CMERGE-C, I1MERG-I) -C***AUTHOR Boland, W. Robert, (LANL) -C Clemens, Reginald, (PLK) -C***DESCRIPTION -C -C This subroutine merges two ascending strings of numbers in the -C array TCOS. The first string is of length M1 and starts at -C TCOS(I1+1). The second string is of length M2 and starts at -C TCOS(I2+1). The merged string goes into TCOS(I3+1). -C -C This routine is currently unused, but was added to complete -C the set of routines S1MERG and C1MERG (both of which are used). -C -C***ROUTINES CALLED DCOPY -C***REVISION HISTORY (YYMMDD) -C 910819 DATE WRITTEN -C***END PROLOGUE D1MERG - INTEGER I1, I2, I3, M1, M2 - DOUBLE PRECISION TCOS(*) -C - INTEGER J1, J2, J3 -C -C***FIRST EXECUTABLE STATEMENT D1MERG - IF (M1.EQ.0 .AND. M2.EQ.0) RETURN -C - IF (M1.EQ.0 .AND. M2.NE.0) THEN - CALL DCOPY (M2, TCOS(I2+1), 1, TCOS(I3+1), 1) - RETURN - ENDIF -C - IF (M1.NE.0 .AND. M2.EQ.0) THEN - CALL DCOPY (M1, TCOS(I1+1), 1, TCOS(I3+1), 1) - RETURN - ENDIF -C - J1 = 1 - J2 = 1 - J3 = 1 -C - 10 IF (TCOS(I1+J1) .LE. TCOS(I2+J2)) THEN - TCOS(I3+J3) = TCOS(I1+J1) - J1 = J1+1 - IF (J1 .GT. M1) THEN - CALL DCOPY (M2-J2+1, TCOS(I2+J2), 1, TCOS(I3+J3+1), 1) - RETURN - ENDIF - ELSE - TCOS(I3+J3) = TCOS(I2+J2) - J2 = J2+1 - IF (J2 .GT. M2) THEN - CALL DCOPY (M1-J1+1, TCOS(I1+J1), 1, TCOS(I3+J3+1), 1) - RETURN - ENDIF - ENDIF - J3 = J3+1 - GO TO 10 - END diff --git a/slatec/d1mpyq.f b/slatec/d1mpyq.f deleted file mode 100644 index a7d61a9..0000000 --- a/slatec/d1mpyq.f +++ /dev/null @@ -1,100 +0,0 @@ -*DECK D1MPYQ - SUBROUTINE D1MPYQ (M, N, A, LDA, V, W) -C***BEGIN PROLOGUE D1MPYQ -C***SUBSIDIARY -C***PURPOSE Subsidiary to DNSQ and DNSQE -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (R1MPYQ-S, D1MPYQ-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Given an M by N matrix A, this subroutine computes A*Q where -C Q is the product of 2*(N - 1) transformations -C -C GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1) -C -C and GV(I), GW(I) are Givens rotations in the (I,N) plane which -C eliminate elements in the I-th and N-th planes, respectively. -C Q itself is not given, rather the information to recover the -C GV, GW rotations is supplied. -C -C The SUBROUTINE statement is -C -C SUBROUTINE D1MPYQ(M,N,A,LDA,V,W) -C -C where -C -C M is a positive integer input variable set to the number -C of rows of A. -C -C N IS a positive integer input variable set to the number -C of columns of A. -C -C A is an M by N array. On input A must contain the matrix -C to be postmultiplied by the orthogonal matrix Q -C described above. On output A*Q has replaced A. -C -C LDA is a positive integer input variable not less than M -C which specifies the leading dimension of the array A. -C -C V is an input array of length N. V(I) must contain the -C information necessary to recover the Givens rotation GV(I) -C described above. -C -C W is an input array of length N. W(I) must contain the -C information necessary to recover the Givens rotation GW(I) -C described above. -C -C***SEE ALSO DNSQ, DNSQE -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE D1MPYQ - INTEGER I, J, LDA, M, N, NM1, NMJ - DOUBLE PRECISION A(LDA,*), COS, ONE, SIN, TEMP, V(*), W(*) - SAVE ONE - DATA ONE /1.0D0/ -C -C APPLY THE FIRST SET OF GIVENS ROTATIONS TO A. -C -C***FIRST EXECUTABLE STATEMENT D1MPYQ - NM1 = N - 1 - IF (NM1 .LT. 1) GO TO 50 - DO 20 NMJ = 1, NM1 - J = N - NMJ - IF (ABS(V(J)) .GT. ONE) COS = ONE/V(J) - IF (ABS(V(J)) .GT. ONE) SIN = SQRT(ONE-COS**2) - IF (ABS(V(J)) .LE. ONE) SIN = V(J) - IF (ABS(V(J)) .LE. ONE) COS = SQRT(ONE-SIN**2) - DO 10 I = 1, M - TEMP = COS*A(I,J) - SIN*A(I,N) - A(I,N) = SIN*A(I,J) + COS*A(I,N) - A(I,J) = TEMP - 10 CONTINUE - 20 CONTINUE -C -C APPLY THE SECOND SET OF GIVENS ROTATIONS TO A. -C - DO 40 J = 1, NM1 - IF (ABS(W(J)) .GT. ONE) COS = ONE/W(J) - IF (ABS(W(J)) .GT. ONE) SIN = SQRT(ONE-COS**2) - IF (ABS(W(J)) .LE. ONE) SIN = W(J) - IF (ABS(W(J)) .LE. ONE) COS = SQRT(ONE-SIN**2) - DO 30 I = 1, M - TEMP = COS*A(I,J) + SIN*A(I,N) - A(I,N) = -SIN*A(I,J) + COS*A(I,N) - A(I,J) = TEMP - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE D1MPYQ. -C - END diff --git a/slatec/d1updt.f b/slatec/d1updt.f deleted file mode 100644 index c6efcdf..0000000 --- a/slatec/d1updt.f +++ /dev/null @@ -1,212 +0,0 @@ -*DECK D1UPDT - SUBROUTINE D1UPDT (M, N, S, LS, U, V, W, SING) -C***BEGIN PROLOGUE D1UPDT -C***SUBSIDIARY -C***PURPOSE Subsidiary to DNSQ and DNSQE -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (R1UPDT-S, D1UPDT-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Given an M by N lower trapezoidal matrix S, an M-vector U, -C and an N-vector V, the problem is to determine an -C orthogonal matrix Q such that -C -C t -C (S + U*V )*Q -C -C is again lower trapezoidal. -C -C This subroutine determines Q as the product of 2*(N - 1) -C transformations -C -C GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1) -C -C where GV(I), GW(I) are Givens rotations in the (I,N) plane -C which eliminate elements in the I-th and N-th planes, -C respectively. Q itself is not accumulated, rather the -C information to recover the GV, GW rotations is returned. -C -C The SUBROUTINE statement is -C -C SUBROUTINE D1UPDT(M,N,S,LS,U,V,W,SING) -C -C where -C -C M is a positive integer input variable set to the number -C of rows of S. -C -C N is a positive integer input variable set to the number -C of columns of S. N must not exceed M. -C -C S is an array of length LS. On input S must contain the lower -C trapezoidal matrix S stored by columns. On output S contains -C the lower trapezoidal matrix produced as described above. -C -C LS is a positive integer input variable not less than -C (N*(2*M-N+1))/2. -C -C U is an input array of length M which must contain the -C vector U. -C -C V is an array of length N. On input V must contain the vector -C V. On output V(I) contains the information necessary to -C recover the Givens rotation GV(I) described above. -C -C W is an output array of length M. W(I) contains information -C necessary to recover the Givens rotation GW(I) described -C above. -C -C SING is a LOGICAL output variable. SING is set TRUE if any -C of the diagonal elements of the output S are zero. Otherwise -C SING is set FALSE. -C -C***SEE ALSO DNSQ, DNSQE -C***ROUTINES CALLED D1MACH -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE D1UPDT - DOUBLE PRECISION D1MACH - INTEGER I, J, JJ, L, LS, M, N, NM1, NMJ - DOUBLE PRECISION COS, COTAN, GIANT, ONE, P25, P5, S(*), - 1 SIN, TAN, TAU, TEMP, U(*), V(*), W(*), ZERO - LOGICAL SING - SAVE ONE, P5, P25, ZERO - DATA ONE,P5,P25,ZERO /1.0D0,5.0D-1,2.5D-1,0.0D0/ -C -C GIANT IS THE LARGEST MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT D1UPDT - GIANT = D1MACH(2) -C -C INITIALIZE THE DIAGONAL ELEMENT POINTER. -C - JJ = (N*(2*M - N + 1))/2 - (M - N) -C -C MOVE THE NONTRIVIAL PART OF THE LAST COLUMN OF S INTO W. -C - L = JJ - DO 10 I = N, M - W(I) = S(L) - L = L + 1 - 10 CONTINUE -C -C ROTATE THE VECTOR V INTO A MULTIPLE OF THE N-TH UNIT VECTOR -C IN SUCH A WAY THAT A SPIKE IS INTRODUCED INTO W. -C - NM1 = N - 1 - IF (NM1 .LT. 1) GO TO 70 - DO 60 NMJ = 1, NM1 - J = N - NMJ - JJ = JJ - (M - J + 1) - W(J) = ZERO - IF (V(J) .EQ. ZERO) GO TO 50 -C -C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE -C J-TH ELEMENT OF V. -C - IF (ABS(V(N)) .GE. ABS(V(J))) GO TO 20 - COTAN = V(N)/V(J) - SIN = P5/SQRT(P25+P25*COTAN**2) - COS = SIN*COTAN - TAU = ONE - IF (ABS(COS)*GIANT .GT. ONE) TAU = ONE/COS - GO TO 30 - 20 CONTINUE - TAN = V(J)/V(N) - COS = P5/SQRT(P25+P25*TAN**2) - SIN = COS*TAN - TAU = SIN - 30 CONTINUE -C -C APPLY THE TRANSFORMATION TO V AND STORE THE INFORMATION -C NECESSARY TO RECOVER THE GIVENS ROTATION. -C - V(N) = SIN*V(J) + COS*V(N) - V(J) = TAU -C -C APPLY THE TRANSFORMATION TO S AND EXTEND THE SPIKE IN W. -C - L = JJ - DO 40 I = J, M - TEMP = COS*S(L) - SIN*W(I) - W(I) = SIN*S(L) + COS*W(I) - S(L) = TEMP - L = L + 1 - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE -C -C ADD THE SPIKE FROM THE RANK 1 UPDATE TO W. -C - DO 80 I = 1, M - W(I) = W(I) + V(N)*U(I) - 80 CONTINUE -C -C ELIMINATE THE SPIKE. -C - SING = .FALSE. - IF (NM1 .LT. 1) GO TO 140 - DO 130 J = 1, NM1 - IF (W(J) .EQ. ZERO) GO TO 120 -C -C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE -C J-TH ELEMENT OF THE SPIKE. -C - IF (ABS(S(JJ)) .GE. ABS(W(J))) GO TO 90 - COTAN = S(JJ)/W(J) - SIN = P5/SQRT(P25+P25*COTAN**2) - COS = SIN*COTAN - TAU = ONE - IF (ABS(COS)*GIANT .GT. ONE) TAU = ONE/COS - GO TO 100 - 90 CONTINUE - TAN = W(J)/S(JJ) - COS = P5/SQRT(P25+P25*TAN**2) - SIN = COS*TAN - TAU = SIN - 100 CONTINUE -C -C APPLY THE TRANSFORMATION TO S AND REDUCE THE SPIKE IN W. -C - L = JJ - DO 110 I = J, M - TEMP = COS*S(L) + SIN*W(I) - W(I) = -SIN*S(L) + COS*W(I) - S(L) = TEMP - L = L + 1 - 110 CONTINUE -C -C STORE THE INFORMATION NECESSARY TO RECOVER THE -C GIVENS ROTATION. -C - W(J) = TAU - 120 CONTINUE -C -C TEST FOR ZERO DIAGONAL ELEMENTS IN THE OUTPUT S. -C - IF (S(JJ) .EQ. ZERO) SING = .TRUE. - JJ = JJ + (M - J + 1) - 130 CONTINUE - 140 CONTINUE -C -C MOVE W BACK INTO THE LAST COLUMN OF THE OUTPUT S. -C - L = JJ - DO 150 I = N, M - S(L) = W(I) - L = L + 1 - 150 CONTINUE - IF (S(JJ) .EQ. ZERO) SING = .TRUE. - RETURN -C -C LAST CARD OF SUBROUTINE D1UPDT. -C - END diff --git a/slatec/d9aimp.f b/slatec/d9aimp.f deleted file mode 100644 index 90f6e35..0000000 --- a/slatec/d9aimp.f +++ /dev/null @@ -1,482 +0,0 @@ -*DECK D9AIMP - SUBROUTINE D9AIMP (X, AMPL, THETA) -C***BEGIN PROLOGUE D9AIMP -C***SUBSIDIARY -C***PURPOSE Evaluate the Airy modulus and phase. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10D -C***TYPE DOUBLE PRECISION (R9AIMP-S, D9AIMP-D) -C***KEYWORDS AIRY FUNCTION, FNLIB, MODULUS, PHASE, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate the Airy modulus and phase for X .LE. -1.0 -C -C Series for AM20 on the interval -1.56250E-02 to 0. -C with weighted error 3.12E-32 -C log weighted error 31.51 -C significant figures required 29.24 -C decimal places required 32.38 -C -C Series for ATH0 on the interval -1.56250E-02 to 0. -C with weighted error 2.75E-32 -C log weighted error 31.56 -C significant figures required 30.17 -C decimal places required 32.42 -C -C Series for AM21 on the interval -1.25000E-01 to -1.56250E-02 -C with weighted error 3.40E-32 -C log weighted error 31.47 -C significant figures required 29.02 -C decimal places required 32.36 -C -C Series for ATH1 on the interval -1.25000E-01 to -1.56250E-02 -C with weighted error 2.94E-32 -C log weighted error 31.53 -C significant figures required 30.08 -C decimal places required 32.41 -C -C Series for AM22 on the interval -1.00000E+00 to -1.25000E-01 -C with weighted error 3.76E-32 -C log weighted error 31.42 -C significant figures required 29.47 -C decimal places required 32.36 -C -C Series for ATH2 on the interval -1.00000E+00 to -1.25000E-01 -C with weighted error 4.97E-32 -C log weighted error 31.30 -C significant figures required 29.79 -C decimal places required 32.23 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE D9AIMP - DOUBLE PRECISION X, AMPL, THETA, AM20CS(57), ATH0CS(53), - 1 AM21CS(60), ATH1CS(58), AM22CS(74), ATH2CS(72), PI4, SQRTX, - 2 XSML, Z, D1MACH, DCSEVL - LOGICAL FIRST - SAVE AM20CS, ATH0CS, AM21CS, ATH1CS, AM22CS, ATH2CS, - 1 PI4, NAM20, NATH0, NAM21, NATH1, NAM22, NATH2, XSML, FIRST - DATA AM20CS( 1) / +.1087167490 8656185661 5730588125 D-1 / - DATA AM20CS( 2) / +.3694892289 8266355509 1728665146 D-3 / - DATA AM20CS( 3) / +.4406801004 8468956366 7507001327 D-5 / - DATA AM20CS( 4) / +.1436867623 6191115392 9183952833 D-6 / - DATA AM20CS( 5) / +.8242755523 9007830867 0628855353 D-8 / - DATA AM20CS( 6) / +.6844267588 9366160617 3927278180 D-9 / - DATA AM20CS( 7) / +.7395666972 8273928773 1004740213 D-10 / - DATA AM20CS( 8) / +.9745956336 9682501763 8702600847 D-11 / - DATA AM20CS( 9) / +.1500768858 2940577565 0973119497 D-11 / - DATA AM20CS( 10) / +.2621479102 2152763420 6252854802 D-12 / - DATA AM20CS( 11) / +.5083541113 7648718035 7278966914 D-13 / - DATA AM20CS( 12) / +.1076847533 5881144049 2985997070 D-13 / - DATA AM20CS( 13) / +.2460912866 1843342933 5914062617 D-14 / - DATA AM20CS( 14) / +.6007863803 5865641843 6110373550 D-15 / - DATA AM20CS( 15) / +.1554491561 0238807115 0651388384 D-15 / - DATA AM20CS( 16) / +.4235351250 3557660442 6382780182 D-16 / - DATA AM20CS( 17) / +.1208621662 8929984015 4401109189 D-16 / - DATA AM20CS( 18) / +.3596096512 1465824086 1499706423 D-17 / - DATA AM20CS( 19) / +.1111342183 8639563826 1774604677 D-17 / - DATA AM20CS( 20) / +.3555595324 3236660989 3680289225 D-18 / - DATA AM20CS( 21) / +.1174330216 0013930999 8766947387 D-18 / - DATA AM20CS( 22) / +.3993974546 6107756138 9162200966 D-19 / - DATA AM20CS( 23) / +.1395766715 2891631042 5606325640 D-19 / - DATA AM20CS( 24) / +.5002400553 0923604139 3459280716 D-20 / - DATA AM20CS( 25) / +.1835527609 5813267918 4834866457 D-20 / - DATA AM20CS( 26) / +.6884909981 7920274319 7790112404 D-21 / - DATA AM20CS( 27) / +.2636310356 1141701235 9996885105 D-21 / - DATA AM20CS( 28) / +.1029248902 3733836028 7153563785 D-21 / - DATA AM20CS( 29) / +.4092469666 7159488548 9762960571 D-22 / - DATA AM20CS( 30) / +.1655585734 0673465103 9727903828 D-22 / - DATA AM20CS( 31) / +.6807974670 6303335611 6599685727 D-23 / - DATA AM20CS( 32) / +.2843265599 3407983241 9751134476 D-23 / - DATA AM20CS( 33) / +.1205073983 4896525509 7287818819 D-23 / - DATA AM20CS( 34) / +.5179612432 8750521797 6613610424 D-24 / - DATA AM20CS( 35) / +.2256226134 2756281630 3268640887 D-24 / - DATA AM20CS( 36) / +.9954188011 4774516883 2117078246 D-25 / - DATA AM20CS( 37) / +.4445516963 9734242430 8280582053 D-25 / - DATA AM20CS( 38) / +.2008651954 6150110142 5916097338 D-25 / - DATA AM20CS( 39) / +.9177863441 5177516597 3885645402 D-26 / - DATA AM20CS( 40) / +.4238729581 0558924066 1672197948 D-26 / - DATA AM20CS( 41) / +.1977892720 0784609237 0846251490 D-26 / - DATA AM20CS( 42) / +.9321163512 8462066568 0435253373 D-27 / - DATA AM20CS( 43) / +.4434821332 4991809995 5611379722 D-27 / - DATA AM20CS( 44) / +.2129456723 6557389559 4589552837 D-27 / - DATA AM20CS( 45) / +.1031585696 5107597755 2209344907 D-27 / - DATA AM20CS( 46) / +.5040237730 2259119915 7904590029 D-28 / - DATA AM20CS( 47) / +.2483013045 7015594530 4046541005 D-28 / - DATA AM20CS( 48) / +.1233017831 2856219605 4198238560 D-28 / - DATA AM20CS( 49) / +.6170334499 2052174612 1976730507 D-29 / - DATA AM20CS( 50) / +.3110926174 1591889723 3869792213 D-29 / - DATA AM20CS( 51) / +.1579830852 0170617301 5269071503 D-29 / - DATA AM20CS( 52) / +.8079319875 3828360767 8121339092 D-30 / - DATA AM20CS( 53) / +.4159973941 3866756272 2951360052 D-30 / - DATA AM20CS( 54) / +.2156109340 9771690047 1935862504 D-30 / - DATA AM20CS( 55) / +.1124688572 6586917829 6752823613 D-30 / - DATA AM20CS( 56) / +.5903315606 3283809112 3040811797 D-31 / - DATA AM20CS( 57) / +.3117356676 9292856204 6280505333 D-31 / - DATA ATH0CS( 1) / -.8172601764 1616344998 4020870054 3 D-1 / - DATA ATH0CS( 2) / -.8004012824 7882732875 9648111306 8 D-3 / - DATA ATH0CS( 3) / -.3186525268 7821132037 9555362824 2 D-5 / - DATA ATH0CS( 4) / -.6688388266 4775093307 4169886503 3 D-7 / - DATA ATH0CS( 5) / -.2931759284 9945645165 0682246318 4 D-8 / - DATA ATH0CS( 6) / -.2011263760 8836216690 4903030718 6 D-9 / - DATA ATH0CS( 7) / -.1877522678 0559734260 7400816665 2 D-10 / - DATA ATH0CS( 8) / -.2199637137 7046012518 9900219984 8 D-11 / - DATA ATH0CS( 9) / -.3071616682 5922724490 2574660558 6 D-12 / - DATA ATH0CS( 10) / -.4936140553 6734183610 2560098538 9 D-13 / - DATA ATH0CS( 11) / -.8902833722 5836604169 3523696986 6 D-14 / - DATA ATH0CS( 12) / -.1768987764 6152726136 5681419946 7 D-14 / - DATA ATH0CS( 13) / -.3817868689 0322770146 7819960960 0 D-15 / - DATA ATH0CS( 14) / -.8851159014 8199475941 5628650998 4 D-16 / - DATA ATH0CS( 15) / -.2184818181 4143659531 4967767956 8 D-16 / - DATA ATH0CS( 16) / -.5700849046 9864523805 9944229511 9 D-17 / - DATA ATH0CS( 17) / -.1563121122 1778753925 1603179549 5 D-17 / - DATA ATH0CS( 18) / -.4481437996 7689950679 0668877635 3 D-18 / - DATA ATH0CS( 19) / -.1337794883 7361880220 4456604409 8 D-18 / - DATA ATH0CS( 20) / -.4143340036 8741144537 7685244544 2 D-19 / - DATA ATH0CS( 21) / -.1327263385 7188050250 8048116465 2 D-19 / - DATA ATH0CS( 22) / -.4385728589 1284405222 1575683595 5 D-20 / - DATA ATH0CS( 23) / -.1491360695 9528180676 8620174395 6 D-20 / - DATA ATH0CS( 24) / -.5208104738 6307113771 5423818877 3 D-21 / - DATA ATH0CS( 25) / -.1864382222 3904989238 7252660497 9 D-21 / - DATA ATH0CS( 26) / -.6830263751 1679690129 7543538188 1 D-22 / - DATA ATH0CS( 27) / -.2557117058 0293296292 9620759134 7 D-22 / - DATA ATH0CS( 28) / -.9770158640 2543002182 4690725404 6 D-23 / - DATA ATH0CS( 29) / -.3805161433 4166790840 6842825488 6 D-23 / - DATA ATH0CS( 30) / -.1509022750 7370540634 9392648299 5 D-23 / - DATA ATH0CS( 31) / -.6087551341 2424249290 0556801452 5 D-24 / - DATA ATH0CS( 32) / -.2495879513 8097114954 2598212405 8 D-24 / - DATA ATH0CS( 33) / -.1039157654 5819209489 0958808427 4 D-24 / - DATA ATH0CS( 34) / -.4390235913 9768465369 7459496905 1 D-25 / - DATA ATH0CS( 35) / -.1880790678 4479902116 7582682058 2 D-25 / - DATA ATH0CS( 36) / -.8165070764 1994629488 6302220575 3 D-26 / - DATA ATH0CS( 37) / -.3589944503 7497505142 6643558504 1 D-26 / - DATA ATH0CS( 38) / -.1597658126 6321328729 8129160870 8 D-26 / - DATA ATH0CS( 39) / -.7193250175 7038239691 1380283530 5 D-27 / - DATA ATH0CS( 40) / -.3274943012 7278565062 0935113272 1 D-27 / - DATA ATH0CS( 41) / -.1507042445 7836906658 1697504727 2 D-27 / - DATA ATH0CS( 42) / -.7006624198 3199047178 4396794914 0 D-28 / - DATA ATH0CS( 43) / -.3289907402 9837182265 2881567835 6 D-28 / - DATA ATH0CS( 44) / -.1559518084 3651465264 4532271149 6 D-28 / - DATA ATH0CS( 45) / -.7460690508 2082545828 3385111972 1 D-29 / - DATA ATH0CS( 46) / -.3600877034 8246620205 6327724943 1 D-29 / - DATA ATH0CS( 47) / -.1752851437 4737722573 5040221919 7 D-29 / - DATA ATH0CS( 48) / -.8603275775 1885129096 2377862872 4 D-30 / - DATA ATH0CS( 49) / -.4256432603 2269465346 6803948010 5 D-30 / - DATA ATH0CS( 50) / -.2122161865 0442629277 2365069820 6 D-30 / - DATA ATH0CS( 51) / -.1065996156 7048790524 7206079856 1 D-30 / - DATA ATH0CS( 52) / -.5393568608 8169491164 1068808689 2 D-31 / - DATA ATH0CS( 53) / -.2748174851 0439548222 7849651787 0 D-31 / - DATA AM21CS( 1) / +.5927902667 2130958837 5717482814 D-2 / - DATA AM21CS( 2) / +.2005694053 9316518642 8695217690 D-2 / - DATA AM21CS( 3) / +.9110818502 6227589355 3072526291 D-4 / - DATA AM21CS( 4) / +.8498943063 7204715563 3172107475 D-5 / - DATA AM21CS( 5) / +.1132979089 7691307663 7929215494 D-5 / - DATA AM21CS( 6) / +.1875179461 0066649618 0950627804 D-6 / - DATA AM21CS( 7) / +.3593065190 1824583269 9035211192 D-7 / - DATA AM21CS( 8) / +.7657577140 7168386403 9093517470 D-8 / - DATA AM21CS( 9) / +.1769999671 6803917392 5953460744 D-8 / - DATA AM21CS( 10) / +.4362595556 5459893272 0546585535 D-9 / - DATA AM21CS( 11) / +.1132916413 3785323003 5520085219 D-9 / - DATA AM21CS( 12) / +.3072576909 8241924413 7868398126 D-10 / - DATA AM21CS( 13) / +.8644824164 8220107554 1200465766 D-11 / - DATA AM21CS( 14) / +.2510152500 6092440211 5104562212 D-11 / - DATA AM21CS( 15) / +.7491024967 6444037160 1802227751 D-12 / - DATA AM21CS( 16) / +.2289969284 8799407308 9565214432 D-12 / - DATA AM21CS( 17) / +.7151136589 2798769494 9327491175 D-13 / - DATA AM21CS( 18) / +.2276079249 5956684194 6395165061 D-13 / - DATA AM21CS( 19) / +.7369421427 6088651396 9953227782 D-14 / - DATA AM21CS( 20) / +.2423286752 6782749046 3991742006 D-14 / - DATA AM21CS( 21) / +.8081537745 4823986928 3406558403 D-15 / - DATA AM21CS( 22) / +.2730080798 0435608665 9174563386 D-15 / - DATA AM21CS( 23) / +.9332360708 9138531847 3519474326 D-16 / - DATA AM21CS( 24) / +.3225080996 8108462221 3867546973 D-16 / - DATA AM21CS( 25) / +.1125819323 4644454121 7757573416 D-16 / - DATA AM21CS( 26) / +.3966994639 8693882166 0259459530 D-17 / - DATA AM21CS( 27) / +.1410065679 4431950466 0865034527 D-17 / - DATA AM21CS( 28) / +.5053020865 3785121337 5537393032 D-18 / - DATA AM21CS( 29) / +.1824615232 1594514119 7999102789 D-18 / - DATA AM21CS( 30) / +.6635845682 6213046692 8029121642 D-19 / - DATA AM21CS( 31) / +.2429637316 3127617974 1747455826 D-19 / - DATA AM21CS( 32) / +.8952389151 2368780201 3669922963 D-20 / - DATA AM21CS( 33) / +.3318452893 5005079126 0229250755 D-20 / - DATA AM21CS( 34) / +.1237061961 8865831538 4437905922 D-20 / - DATA AM21CS( 35) / +.4636366770 1239084030 6767734243 D-21 / - DATA AM21CS( 36) / +.1746531359 4776447546 9758765989 D-21 / - DATA AM21CS( 37) / +.6611168102 3499117630 7910643111 D-22 / - DATA AM21CS( 38) / +.2514099189 9407248617 6125666459 D-22 / - DATA AM21CS( 39) / +.9602749955 7173256869 4034386998 D-23 / - DATA AM21CS( 40) / +.3683249522 8929639568 6436898078 D-23 / - DATA AM21CS( 41) / +.1418431382 6915913614 5535939553 D-23 / - DATA AM21CS( 42) / +.5483426742 7693583010 6345800990 D-24 / - DATA AM21CS( 43) / +.2127610546 2311880665 0372562616 D-24 / - DATA AM21CS( 44) / +.8284437008 4941859148 7734760953 D-25 / - DATA AM21CS( 45) / +.3236705639 2612700142 1028600927 D-25 / - DATA AM21CS( 46) / +.1268688829 6328605735 5055062493 D-25 / - DATA AM21CS( 47) / +.4988438189 9212162693 5068934362 D-26 / - DATA AM21CS( 48) / +.1967345844 6764939096 7119381790 D-26 / - DATA AM21CS( 49) / +.7781359710 2032695771 3212064836 D-27 / - DATA AM21CS( 50) / +.3086339414 9891115291 9192968451 D-27 / - DATA AM21CS( 51) / +.1227446470 4545311978 9338037234 D-27 / - DATA AM21CS( 52) / +.4894312791 3429220588 5241216204 D-28 / - DATA AM21CS( 53) / +.1956468798 0290982117 5925099724 D-28 / - DATA AM21CS( 54) / +.7839889529 2242617116 6311492266 D-29 / - DATA AM21CS( 55) / +.3148969140 0248422374 8298978099 D-29 / - DATA AM21CS( 56) / +.1267697631 3725068130 7067842559 D-29 / - DATA AM21CS( 57) / +.5114706919 0690014164 1632107724 D-30 / - DATA AM21CS( 58) / +.2068017097 9553877025 0900316706 D-30 / - DATA AM21CS( 59) / +.8378913447 6851900132 5996867583 D-31 / - DATA AM21CS( 60) / +.3401689919 7148980205 2339079577 D-31 / - DATA ATH1CS( 1) / -.6972849916 2088838458 8814841503 7 D-1 / - DATA ATH1CS( 2) / -.5108722790 6500449870 7344807796 1 D-2 / - DATA ATH1CS( 3) / -.8644335996 9897550945 2533474951 2 D-4 / - DATA ATH1CS( 4) / -.5604720044 2352635421 8869891612 5 D-5 / - DATA ATH1CS( 5) / -.6045735125 6238974091 5637664007 7 D-6 / - DATA ATH1CS( 6) / -.8639802632 4883343932 1972113849 9 D-7 / - DATA ATH1CS( 7) / -.1480809484 3099271571 4778248078 0 D-7 / - DATA ATH1CS( 8) / -.2885809334 5772360399 9944990871 2 D-8 / - DATA ATH1CS( 9) / -.6191631975 6656996093 0919123180 0 D-9 / - DATA ATH1CS( 10) / -.1431992808 8609578309 3136525987 9 D-9 / - DATA ATH1CS( 11) / -.3518141102 1372147215 0461687432 1 D-10 / - DATA ATH1CS( 12) / -.9084761919 9550782900 7033980805 1 D-11 / - DATA ATH1CS( 13) / -.2446171672 6885984493 4328366476 7 D-11 / - DATA ATH1CS( 14) / -.6826083203 2134462408 2899671026 4 D-12 / - DATA ATH1CS( 15) / -.1964579931 1949401712 7854625780 2 D-12 / - DATA ATH1CS( 16) / -.5808933227 1396931640 0919126585 6 D-13 / - DATA ATH1CS( 17) / -.1759042249 5274419927 9540095902 4 D-13 / - DATA ATH1CS( 18) / -.5440902932 7148966136 3253894531 9 D-14 / - DATA ATH1CS( 19) / -.1715247407 4868068026 2235851945 1 D-14 / - DATA ATH1CS( 20) / -.5500929233 5769915468 7110184716 1 D-15 / - DATA ATH1CS( 21) / -.1791878287 7393172594 9515263875 4 D-15 / - DATA ATH1CS( 22) / -.5920372520 0866941977 7841106223 1 D-16 / - DATA ATH1CS( 23) / -.1981713027 8764839624 7097220659 0 D-16 / - DATA ATH1CS( 24) / -.6713232347 0163522620 4998434379 0 D-17 / - DATA ATH1CS( 25) / -.2299450243 6582811161 2235861983 2 D-17 / - DATA ATH1CS( 26) / -.7957300928 2363765953 0463714563 4 D-18 / - DATA ATH1CS( 27) / -.2779994027 2917841571 7229023373 9 D-18 / - DATA ATH1CS( 28) / -.9798924361 3269852244 0679548081 4 D-19 / - DATA ATH1CS( 29) / -.3482717006 0615743867 0264556584 9 D-19 / - DATA ATH1CS( 30) / -.1247489122 5585990571 7330005808 4 D-19 / - DATA ATH1CS( 31) / -.4501210041 4782281134 8775182445 2 D-20 / - DATA ATH1CS( 32) / -.1635346244 0133521355 9611416466 7 D-20 / - DATA ATH1CS( 33) / -.5980102897 7803362680 9876226594 1 D-21 / - DATA ATH1CS( 34) / -.2200246286 2861234540 2819629547 5 D-21 / - DATA ATH1CS( 35) / -.8142463073 5150858974 0820529151 9 D-22 / - DATA ATH1CS( 36) / -.3029924773 6600425374 3233070967 4 D-22 / - DATA ATH1CS( 37) / -.1133390098 5746235377 2294396968 9 D-22 / - DATA ATH1CS( 38) / -.4260766024 7492957192 8304988979 1 D-23 / - DATA ATH1CS( 39) / -.1609363396 2781897187 9750063445 3 D-23 / - DATA ATH1CS( 40) / -.6106377190 8250262930 4533044428 7 D-24 / - DATA ATH1CS( 41) / -.2326954318 0216940618 3657788757 3 D-24 / - DATA ATH1CS( 42) / -.8903987877 4722526044 7412955818 6 D-25 / - DATA ATH1CS( 43) / -.3420558530 0056750241 1791475234 1 D-25 / - DATA ATH1CS( 44) / -.1319026715 2572726590 1721210060 7 D-25 / - DATA ATH1CS( 45) / -.5104899493 6120430913 1619117738 6 D-26 / - DATA ATH1CS( 46) / -.1982599478 4745474512 4244466346 6 D-26 / - DATA ATH1CS( 47) / -.7725702356 8808305356 3611185151 9 D-27 / - DATA ATH1CS( 48) / -.3020234733 6646801008 1577686357 3 D-27 / - DATA ATH1CS( 49) / -.1184379739 0741699937 1294638080 0 D-27 / - DATA ATH1CS( 50) / -.4658430227 9223085205 7325284010 6 D-28 / - DATA ATH1CS( 51) / -.1837554188 1003846471 5750200661 3 D-28 / - DATA ATH1CS( 52) / -.7268566894 4279909533 2187668480 0 D-29 / - DATA ATH1CS( 53) / -.2882863120 3914681355 2708987562 6 D-29 / - DATA ATH1CS( 54) / -.1146374629 4599063504 1759166463 9 D-29 / - DATA ATH1CS( 55) / -.4570031437 7485330581 7999168853 3 D-30 / - DATA ATH1CS( 56) / -.1826276602 0453461048 0993402879 9 D-30 / - DATA ATH1CS( 57) / -.7315349993 3852504691 1106635093 3 D-31 / - DATA ATH1CS( 58) / -.2936925599 9714297816 3781577386 6 D-31 / - DATA AM22CS( 1) / -.1562844480 6253411275 3545828583 D-1 / - DATA AM22CS( 2) / +.7783364452 3968130701 8943100334 D-2 / - DATA AM22CS( 3) / +.8670577704 7718952840 6072812110 D-3 / - DATA AM22CS( 4) / +.1569662731 5611371946 9953482266 D-3 / - DATA AM22CS( 5) / +.3563962571 4328651132 4100666302 D-4 / - DATA AM22CS( 6) / +.9245983354 2504315449 5080090994 D-5 / - DATA AM22CS( 7) / +.2621101618 5042238952 3194982066 D-5 / - DATA AM22CS( 8) / +.7918822165 1601256148 9469982263 D-6 / - DATA AM22CS( 9) / +.2510415279 2101184780 3162690862 D-6 / - DATA AM22CS( 10) / +.8265223206 6540773447 2997712940 D-7 / - DATA AM22CS( 11) / +.2805711662 8130526439 6384290014 D-7 / - DATA AM22CS( 12) / +.9768210904 8468078667 4631273890 D-8 / - DATA AM22CS( 13) / +.3474079232 2771034328 7279035573 D-8 / - DATA AM22CS( 14) / +.1258281321 6983691421 9092738164 D-8 / - DATA AM22CS( 15) / +.4629882606 4189526449 7330784625 D-9 / - DATA AM22CS( 16) / +.1727282588 1360407246 8143128696 D-9 / - DATA AM22CS( 17) / +.6523192001 3115413514 8574124970 D-10 / - DATA AM22CS( 18) / +.2490471685 2098205601 9881087112 D-10 / - DATA AM22CS( 19) / +.9601568205 5376594807 8189890126 D-11 / - DATA AM22CS( 20) / +.3734480020 6772685697 4776596757 D-11 / - DATA AM22CS( 21) / +.1464175650 3205339172 2216189678 D-11 / - DATA AM22CS( 22) / +.5782654711 6851282547 5827881553 D-12 / - DATA AM22CS( 23) / +.2299154072 4470611856 0254184494 D-12 / - DATA AM22CS( 24) / +.9197807112 3199725715 0883662365 D-13 / - DATA AM22CS( 25) / +.3700600688 1309006580 7504045556 D-13 / - DATA AM22CS( 26) / +.1496757616 9867298782 3326345205 D-13 / - DATA AM22CS( 27) / +.6083611949 3846114872 0451399443 D-14 / - DATA AM22CS( 28) / +.2484040871 1512139763 5425326873 D-14 / - DATA AM22CS( 29) / +.1018624765 2676908072 7914465339 D-14 / - DATA AM22CS( 30) / +.4193838563 5275398942 9640310957 D-15 / - DATA AM22CS( 31) / +.1733189017 6293075614 9702493501 D-15 / - DATA AM22CS( 32) / +.7188219023 8850851782 0445406811 D-16 / - DATA AM22CS( 33) / +.2991236335 9840360771 2470896113 D-16 / - DATA AM22CS( 34) / +.1248689904 3323862785 5713110880 D-16 / - DATA AM22CS( 35) / +.5228293446 0948366192 8651193632 D-17 / - DATA AM22CS( 36) / +.2195329617 2471339659 5998454359 D-17 / - DATA AM22CS( 37) / +.9242983252 2977728115 4410024332 D-18 / - DATA AM22CS( 38) / +.3901577082 3609140782 5543197309 D-18 / - DATA AM22CS( 39) / +.1650938926 9386370721 3759030367 D-18 / - DATA AM22CS( 40) / +.7002218157 1599436756 5716554487 D-19 / - DATA AM22CS( 41) / +.2976518336 1678691557 3214963506 D-19 / - DATA AM22CS( 42) / +.1267965390 8690207257 1134261229 D-19 / - DATA AM22CS( 43) / +.5412434006 9707762868 7581725061 D-20 / - DATA AM22CS( 44) / +.2314873502 1815525229 6382133283 D-20 / - DATA AM22CS( 45) / +.9919202883 8656656346 2623851167 D-21 / - DATA AM22CS( 46) / +.4258030153 2373235715 8897608174 D-21 / - DATA AM22CS( 47) / +.1831018429 7302450167 8402003088 D-21 / - DATA AM22CS( 48) / +.7886787123 1107537556 4526811022 D-22 / - DATA AM22CS( 49) / +.3402546073 8622987495 6582997235 D-22 / - DATA AM22CS( 50) / +.1470208814 0571253079 1860892535 D-22 / - DATA AM22CS( 51) / +.6362110183 2491695773 3348071767 D-23 / - DATA AM22CS( 52) / +.2757070506 8098072191 9395987768 D-23 / - DATA AM22CS( 53) / +.1196458580 9010407135 6261780457 D-23 / - DATA AM22CS( 54) / +.5199125457 2924214798 1768210567 D-24 / - DATA AM22CS( 55) / +.2262176748 4710447526 0575286850 D-24 / - DATA AM22CS( 56) / +.9855261137 5443181944 8565068283 D-25 / - DATA AM22CS( 57) / +.4298706303 3250871722 3681286187 D-25 / - DATA AM22CS( 58) / +.1877236416 6158063982 9657670189 D-25 / - DATA AM22CS( 59) / +.8207219417 7284213726 8801052115 D-26 / - DATA AM22CS( 60) / +.3592146656 0461550781 2767944463 D-26 / - DATA AM22CS( 61) / +.1573905946 1277331561 1458940587 D-26 / - DATA AM22CS( 62) / +.6903297810 3933383496 5319153586 D-27 / - DATA AM22CS( 63) / +.3030920790 7896853460 7859331415 D-27 / - DATA AM22CS( 64) / +.1332049341 6048121918 5689121944 D-27 / - DATA AM22CS( 65) / +.5859788368 5152349011 7937981442 D-28 / - DATA AM22CS( 66) / +.2580168684 8948780633 8425080457 D-28 / - DATA AM22CS( 67) / +.1137124336 3728366722 3632182863 D-28 / - DATA AM22CS( 68) / +.5015925572 2606850923 6430548549 D-29 / - DATA AM22CS( 69) / +.2214458293 9550937332 2569708484 D-29 / - DATA AM22CS( 70) / +.9784702838 8650728998 4691416411 D-30 / - DATA AM22CS( 71) / +.4326954149 3418017011 2000952983 D-30 / - DATA AM22CS( 72) / +.1914972881 9399457061 2929860440 D-30 / - DATA AM22CS( 73) / +.8481646224 0239235417 1298331562 D-31 / - DATA AM22CS( 74) / +.3759470651 7395591994 7455052934 D-31 / - DATA ATH2CS( 1) / +.4405273458 7187789970 6112705777 5 D-2 / - DATA ATH2CS( 2) / -.3042919452 3184546084 8384423987 3 D-1 / - DATA ATH2CS( 3) / -.1385653283 7717937916 0269284265 3 D-2 / - DATA ATH2CS( 4) / -.1804443908 9549523026 7048691095 2 D-3 / - DATA ATH2CS( 5) / -.3380847108 3273086710 5746532361 8 D-4 / - DATA ATH2CS( 6) / -.7678183535 2290230552 5767681776 5 D-5 / - DATA ATH2CS( 7) / -.1967839443 7160353246 9093541707 7 D-5 / - DATA ATH2CS( 8) / -.5483727115 8777003615 8614365928 1 D-6 / - DATA ATH2CS( 9) / -.1625461550 5326124527 1269621225 8 D-6 / - DATA ATH2CS( 10) / -.5053049981 2688950152 7763784207 8 D-7 / - DATA ATH2CS( 11) / -.1631580701 1240668811 8385171561 7 D-7 / - DATA ATH2CS( 12) / -.5434204112 3485175079 6343669481 7 D-8 / - DATA ATH2CS( 13) / -.1857398556 4099003257 6385010963 0 D-8 / - DATA ATH2CS( 14) / -.6489512033 3261088162 1351364067 6 D-9 / - DATA ATH2CS( 15) / -.2310594885 8009447204 8299598707 9 D-9 / - DATA ATH2CS( 16) / -.8363282183 2044116828 1932954674 5 D-10 / - DATA ATH2CS( 17) / -.3071196844 8901914626 6066130389 1 D-10 / - DATA ATH2CS( 18) / -.1142367142 4327168194 0951457989 2 D-10 / - DATA ATH2CS( 19) / -.4298116066 3458030658 2247010897 1 D-11 / - DATA ATH2CS( 20) / -.1633898699 5967154406 0164608663 2 D-11 / - DATA ATH2CS( 21) / -.6269328620 0166194321 2344375407 6 D-12 / - DATA ATH2CS( 22) / -.2426052694 8162573573 5615920399 1 D-12 / - DATA ATH2CS( 23) / -.9461198321 6240390907 4252776505 2 D-13 / - DATA ATH2CS( 24) / -.3716060313 4115048068 4779828126 9 D-13 / - DATA ATH2CS( 25) / -.1469155684 0975267631 7013881030 9 D-13 / - DATA ATH2CS( 26) / -.5843694726 1409119445 5640136309 4 D-14 / - DATA ATH2CS( 27) / -.2337502595 5919512988 3267503493 4 D-14 / - DATA ATH2CS( 28) / -.9399231371 1714354011 6016735841 1 D-15 / - DATA ATH2CS( 29) / -.3798014669 3728945000 7633526371 5 D-15 / - DATA ATH2CS( 30) / -.1541731043 9849725248 8344368177 5 D-15 / - DATA ATH2CS( 31) / -.6285287079 5353071629 2566236520 2 D-16 / - DATA ATH2CS( 32) / -.2572731812 8114554247 5538399277 4 D-16 / - DATA ATH2CS( 33) / -.1057098119 3540178093 4097486655 5 D-16 / - DATA ATH2CS( 34) / -.4359080267 4026969666 9599269996 4 D-17 / - DATA ATH2CS( 35) / -.1803634315 9599780139 5317694554 0 D-17 / - DATA ATH2CS( 36) / -.7486838064 3805368217 1943167691 4 D-18 / - DATA ATH2CS( 37) / -.3117261367 3476046567 9959720998 5 D-18 / - DATA ATH2CS( 38) / -.1301687980 9277007347 9287162069 6 D-18 / - DATA ATH2CS( 39) / -.5450527587 5195224689 7388390990 9 D-19 / - DATA ATH2CS( 40) / -.2288293490 1142318722 6863593190 3 D-19 / - DATA ATH2CS( 41) / -.9631059503 8295386556 5506044008 8 D-20 / - DATA ATH2CS( 42) / -.4063281001 5246140890 9219541643 4 D-20 / - DATA ATH2CS( 43) / -.1718203980 9080267639 0041385851 0 D-20 / - DATA ATH2CS( 44) / -.7281574619 8925363674 1532247332 8 D-21 / - DATA ATH2CS( 45) / -.3092352652 6806431279 6068034579 0 D-21 / - DATA ATH2CS( 46) / -.1315917855 9654404903 8341702325 4 D-21 / - DATA ATH2CS( 47) / -.5610606786 0870555126 6490741266 8 D-22 / - DATA ATH2CS( 48) / -.2396621894 0863552060 2030433789 5 D-22 / - DATA ATH2CS( 49) / -.1025574332 3905812008 3295442392 4 D-22 / - DATA ATH2CS( 50) / -.4396264138 1436564764 0360732366 3 D-23 / - DATA ATH2CS( 51) / -.1887652998 3725773733 4250871945 0 D-23 / - DATA ATH2CS( 52) / -.8118140359 5768076035 7943323044 5 D-24 / - DATA ATH2CS( 53) / -.3496734274 3662868563 7595208921 4 D-24 / - DATA ATH2CS( 54) / -.1508402925 1568732151 7175147586 7 D-24 / - DATA ATH2CS( 55) / -.6516268284 7786710597 8777383434 1 D-25 / - DATA ATH2CS( 56) / -.2818945797 5292074245 0594211458 3 D-25 / - DATA ATH2CS( 57) / -.1221127596 5122627445 9809446450 5 D-25 / - DATA ATH2CS( 58) / -.5296674341 1698671686 2001170507 3 D-26 / - DATA ATH2CS( 59) / -.2300359270 7736734313 5887097174 4 D-26 / - DATA ATH2CS( 60) / -.1000279482 3553674947 8122034893 0 D-26 / - DATA ATH2CS( 61) / -.4354760404 1808793948 0689316217 9 D-27 / - DATA ATH2CS( 62) / -.1898056134 7414775225 1548282703 0 D-27 / - DATA ATH2CS( 63) / -.8282111868 7129746975 5400930931 5 D-28 / - DATA ATH2CS( 64) / -.3617815493 0665690065 8621348437 4 D-28 / - DATA ATH2CS( 65) / -.1582018896 1780036548 5894184363 6 D-28 / - DATA ATH2CS( 66) / -.6925068597 8022700117 7282038324 7 D-29 / - DATA ATH2CS( 67) / -.3034390239 7786291289 0862972733 5 D-29 / - DATA ATH2CS( 68) / -.1330889568 1667252247 6197744650 9 D-29 / - DATA ATH2CS( 69) / -.5842848522 1730901204 8760697170 6 D-30 / - DATA ATH2CS( 70) / -.2567488423 2383026311 2127435767 8 D-30 / - DATA ATH2CS( 71) / -.1129232322 2688821857 9150581915 1 D-30 / - DATA ATH2CS( 72) / -.4970947029 7533369165 5057010502 3 D-31 / - DATA PI4 / 0.7853981633 9744830961 5660845819 88D0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT D9AIMP - IF (FIRST) THEN - ETA = 0.1*REAL(D1MACH(3)) - NAM20 = INITDS (AM20CS, 57, ETA) - NATH0 = INITDS (ATH0CS, 53, ETA) - NAM21 = INITDS (AM21CS, 60, ETA) - NATH1 = INITDS (ATH1CS, 58, ETA) - NAM22 = INITDS (AM22CS, 74, ETA) - NATH2 = INITDS (ATH2CS, 72, ETA) -C - XSML = -1.0D0/D1MACH(3)**0.3333D0 - ENDIF - FIRST = .FALSE. -C - IF (X.GE.(-4.0D0)) GO TO 20 - Z = 1.0D0 - IF (X.GT.XSML) Z = 128.D0/X**3 + 1.0D0 - AMPL = 0.3125D0 + DCSEVL (Z, AM20CS, NAM20) - THETA = -0.625D0 + DCSEVL (Z, ATH0CS, NATH0) - GO TO 40 -C - 20 IF (X.GE.(-2.0D0)) GO TO 30 - Z = (128.D0/X**3 + 9.0D0)/7.0D0 - AMPL = 0.3125D0 + DCSEVL (Z, AM21CS, NAM21) - THETA = -0.625D0 + DCSEVL (Z, ATH1CS, NATH1) - GO TO 40 -C - 30 IF (X .GE. (-1.0D0)) CALL XERMSG ('SLATEC', 'D9AIMP', - + 'X MUST BE LE -1.0', 1, 2) -C - Z = (16.D0/X**3 + 9.0D0)/7.0D0 - AMPL = 0.3125D0 + DCSEVL (Z, AM22CS, NAM22) - THETA = -0.625D0 + DCSEVL (Z, ATH2CS, NATH2) -C - 40 SQRTX = SQRT(-X) - AMPL = SQRT(AMPL/SQRTX) - THETA = PI4 - X*SQRTX*THETA -C - RETURN - END diff --git a/slatec/d9atn1.f b/slatec/d9atn1.f deleted file mode 100644 index 8f64e14..0000000 --- a/slatec/d9atn1.f +++ /dev/null @@ -1,109 +0,0 @@ -*DECK D9ATN1 - DOUBLE PRECISION FUNCTION D9ATN1 (X) -C***BEGIN PROLOGUE D9ATN1 -C***SUBSIDIARY -C***PURPOSE Evaluate DATAN(X) from first order relative accuracy so -C that DATAN(X) = X + X**3*D9ATN1(X). -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4A -C***TYPE DOUBLE PRECISION (R9ATN1-S, D9ATN1-D) -C***KEYWORDS ARC TANGENT, ELEMENTARY FUNCTIONS, FIRST ORDER, FNLIB, -C TRIGONOMETRIC -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate DATAN(X) from first order, that is, evaluate -C (DATAN(X)-X)/X**3 with relative error accuracy so that -C DATAN(X) = X + X**3*D9ATN1(X). -C -C Series for ATN1 on the interval 0. to 1.00000E+00 -C with weighted error 3.39E-32 -C log weighted error 31.47 -C significant figures required 30.26 -C decimal places required 32.27 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 780401 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891115 Corrected third argument in reference to INITDS. (WRB) -C 891115 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 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE D9ATN1 - DOUBLE PRECISION X, XBIG, XMAX, XSML, Y, ATN1CS(40), EPS, - 1 DCSEVL, D1MACH - LOGICAL FIRST - SAVE ATN1CS, NTATN1, XSML, XBIG, XMAX, FIRST - DATA ATN1CS( 1) / -.3283997535 3552023569 0793992299 0 D-1 / - DATA ATN1CS( 2) / +.5833432343 1724124499 5166991490 7 D-1 / - DATA ATN1CS( 3) / -.7400369696 7196464638 0901155141 3 D-2 / - DATA ATN1CS( 4) / +.1009784199 3372880835 9035751163 9 D-2 / - DATA ATN1CS( 5) / -.1439787163 5652056214 7130369770 0 D-3 / - DATA ATN1CS( 6) / +.2114512648 9921075720 7211224343 9 D-4 / - DATA ATN1CS( 7) / -.3172321074 2546671674 0256499675 7 D-5 / - DATA ATN1CS( 8) / +.4836620365 4607108253 7785938480 0 D-6 / - DATA ATN1CS( 9) / -.7467746546 8141126704 3761432277 6 D-7 / - DATA ATN1CS( 10) / +.1164800896 8244298306 2099864134 2 D-7 / - DATA ATN1CS( 11) / -.1832088370 8472013926 9995624245 2 D-8 / - DATA ATN1CS( 12) / +.2901908277 9660633131 7535123045 5 D-9 / - DATA ATN1CS( 13) / -.4623885312 1063267383 5180572151 2 D-10 / - DATA ATN1CS( 14) / +.7405528668 7757369179 9219704828 6 D-11 / - DATA ATN1CS( 15) / -.1191354457 8451366823 7082037341 7 D-11 / - DATA ATN1CS( 16) / +.1924090144 3917725998 6785569251 8 D-12 / - DATA ATN1CS( 17) / -.3118271051 0761942722 5447615532 7 D-13 / - DATA ATN1CS( 18) / +.5069240036 5677317896 9452059303 2 D-14 / - DATA ATN1CS( 19) / -.8263694719 8028660538 1828440596 4 D-15 / - DATA ATN1CS( 20) / +.1350486709 8170794205 2650612302 9 D-15 / - DATA ATN1CS( 21) / -.2212023650 4817460458 4013782319 1 D-16 / - DATA ATN1CS( 22) / +.3630654747 3813567838 2904764770 9 D-17 / - DATA ATN1CS( 23) / -.5970345328 8471540524 5121585916 5 D-18 / - DATA ATN1CS( 24) / +.9834816050 0771331194 4832900573 8 D-19 / - DATA ATN1CS( 25) / -.1622655075 8550623361 4438760448 0 D-19 / - DATA ATN1CS( 26) / +.2681186176 9454367963 0132030122 6 D-20 / - DATA ATN1CS( 27) / -.4436309706 7852554796 3624368810 6 D-21 / - DATA ATN1CS( 28) / +.7349691897 6524969450 7246551040 0 D-22 / - DATA ATN1CS( 29) / -.1219077508 3500525882 8940137813 3 D-22 / - DATA ATN1CS( 30) / +.2024298836 8052154031 8454087679 9 D-23 / - DATA ATN1CS( 31) / -.3364871555 7973545799 2557636266 6 D-24 / - DATA ATN1CS( 32) / +.5598673968 3469887494 9293397333 3 D-25 / - DATA ATN1CS( 33) / -.9323939267 2723202296 2853205333 3 D-26 / - DATA ATN1CS( 34) / +.1554133116 9959702229 3480789333 3 D-26 / - DATA ATN1CS( 35) / -.2592569534 1797459227 5742719999 9 D-27 / - DATA ATN1CS( 36) / +.4328193466 2457346850 3790933333 3 D-28 / - DATA ATN1CS( 37) / -.7231013125 5954374711 9240533333 3 D-29 / - DATA ATN1CS( 38) / +.1208902859 8304947729 4216533333 3 D-29 / - DATA ATN1CS( 39) / -.2022404543 4498975793 1519999999 9 D-30 / - DATA ATN1CS( 40) / +.3385428713 0464938430 7370666666 6 D-31 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT D9ATN1 - IF (FIRST) THEN - EPS = D1MACH(3) - NTATN1 = INITDS (ATN1CS, 40, 0.1*REAL(EPS)) -C - XSML = SQRT (0.1D0*EPS) - XBIG = 1.571D0/SQRT(EPS) - XMAX = 1.571D0/EPS - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.1.0D0) GO TO 20 -C - IF (Y.LE.XSML) D9ATN1 = -1.0D0/3.0D0 - IF (Y.LE.XSML) RETURN -C - D9ATN1 = -0.25D0 + DCSEVL (2.D0*Y*Y-1.D0, ATN1CS, NTATN1) - RETURN -C - 20 IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'D9ATN1', - + 'NO PRECISION IN ANSWER BECAUSE X IS TOO BIG', 2, 2) - IF (Y .GT. XBIG) CALL XERMSG ('SLATEC', 'D9ATN1', - + 'ANSWER LT HALF PRECISION BECAUSE X IS TOO BIG', 1, 1) -C - D9ATN1 = (ATAN(X) - X) / X**3 - RETURN -C - END diff --git a/slatec/d9b0mp.f b/slatec/d9b0mp.f deleted file mode 100644 index e3a3246..0000000 --- a/slatec/d9b0mp.f +++ /dev/null @@ -1,247 +0,0 @@ -*DECK D9B0MP - SUBROUTINE D9B0MP (X, AMPL, THETA) -C***BEGIN PROLOGUE D9B0MP -C***SUBSIDIARY -C***PURPOSE Evaluate the modulus and phase for the J0 and Y0 Bessel -C functions. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10A1 -C***TYPE DOUBLE PRECISION (D9B0MP-D) -C***KEYWORDS BESSEL FUNCTION, FNLIB, MODULUS, PHASE, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate the modulus and phase for the Bessel J0 and Y0 functions. -C -C Series for BM0 on the interval 1.56250E-02 to 6.25000E-02 -C with weighted error 4.40E-32 -C log weighted error 31.36 -C significant figures required 30.02 -C decimal places required 32.14 -C -C Series for BTH0 on the interval 0. to 1.56250E-02 -C with weighted error 2.66E-32 -C log weighted error 31.57 -C significant figures required 30.67 -C decimal places required 32.40 -C -C Series for BM02 on the interval 0. to 1.56250E-02 -C with weighted error 4.72E-32 -C log weighted error 31.33 -C significant figures required 30.00 -C decimal places required 32.13 -C -C Series for BT02 on the interval 1.56250E-02 to 6.25000E-02 -C with weighted error 2.99E-32 -C log weighted error 31.52 -C significant figures required 30.61 -C decimal places required 32.32 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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 900720 Routine changed from user-callable to subsidiary. (WRB) -C 920618 Removed space from variable names. (RWC, WRB) -C***END PROLOGUE D9B0MP - DOUBLE PRECISION X, AMPL, THETA, BM0CS(37), BT02CS(39), - 1 BM02CS(40), BTH0CS(44), XMAX, PI4, Z, D1MACH, DCSEVL - LOGICAL FIRST - SAVE BM0CS, BTH0CS, BM02CS, BT02CS, PI4, NBM0, NBT02, - 1 NBM02, NBTH0, XMAX, FIRST - DATA BM0CS( 1) / +.9211656246 8277427125 7376773018 2 D-1 / - DATA BM0CS( 2) / -.1050590997 2719051024 8071637175 5 D-2 / - DATA BM0CS( 3) / +.1470159840 7687597540 5639285095 2 D-4 / - DATA BM0CS( 4) / -.5058557606 0385542233 4792932770 2 D-6 / - DATA BM0CS( 5) / +.2787254538 6324441766 3035613788 1 D-7 / - DATA BM0CS( 6) / -.2062363611 7809148026 1884101897 3 D-8 / - DATA BM0CS( 7) / +.1870214313 1388796751 3817259626 1 D-9 / - DATA BM0CS( 8) / -.1969330971 1356362002 4173077782 5 D-10 / - DATA BM0CS( 9) / +.2325973793 9992754440 1250881805 2 D-11 / - DATA BM0CS( 10) / -.3009520344 9382502728 5122473448 2 D-12 / - DATA BM0CS( 11) / +.4194521333 8506691814 7120676864 6 D-13 / - DATA BM0CS( 12) / -.6219449312 1884458259 7326742956 4 D-14 / - DATA BM0CS( 13) / +.9718260411 3360684696 0176588526 9 D-15 / - DATA BM0CS( 14) / -.1588478585 7010752073 6663596693 7 D-15 / - DATA BM0CS( 15) / +.2700072193 6713088900 8621732445 8 D-16 / - DATA BM0CS( 16) / -.4750092365 2340089924 7750478677 3 D-17 / - DATA BM0CS( 17) / +.8615128162 6043708731 9170374656 0 D-18 / - DATA BM0CS( 18) / -.1605608686 9561448157 4560270335 9 D-18 / - DATA BM0CS( 19) / +.3066513987 3144829751 8853980159 9 D-19 / - DATA BM0CS( 20) / -.5987764223 1939564306 9650561706 6 D-20 / - DATA BM0CS( 21) / +.1192971253 7482483064 8906984106 6 D-20 / - DATA BM0CS( 22) / -.2420969142 0448054894 8468258133 3 D-21 / - DATA BM0CS( 23) / +.4996751760 5106164533 7100287999 9 D-22 / - DATA BM0CS( 24) / -.1047493639 3511585100 9504051199 9 D-22 / - DATA BM0CS( 25) / +.2227786843 7974681010 4818346666 6 D-23 / - DATA BM0CS( 26) / -.4801813239 3981628623 7054293333 3 D-24 / - DATA BM0CS( 27) / +.1047962723 4709599564 7699626666 6 D-24 / - DATA BM0CS( 28) / -.2313858165 6786153251 0126080000 0 D-25 / - DATA BM0CS( 29) / +.5164823088 4626742116 3519999999 9 D-26 / - DATA BM0CS( 30) / -.1164691191 8500653895 2540159999 9 D-26 / - DATA BM0CS( 31) / +.2651788486 0433192829 5833600000 0 D-27 / - DATA BM0CS( 32) / -.6092559503 8257284976 9130666666 6 D-28 / - DATA BM0CS( 33) / +.1411804686 1442593080 3882666666 6 D-28 / - DATA BM0CS( 34) / -.3298094961 2317372457 5061333333 3 D-29 / - DATA BM0CS( 35) / +.7763931143 0740650317 1413333333 3 D-30 / - DATA BM0CS( 36) / -.1841031343 6614584784 2133333333 3 D-30 / - DATA BM0CS( 37) / +.4395880138 5943107371 0079999999 9 D-31 / - DATA BTH0CS( 1) / -.2490178086 2128936717 7097937899 67 D+0 / - DATA BTH0CS( 2) / +.4855029960 9623749241 0486155354 85 D-3 / - DATA BTH0CS( 3) / -.5451183734 5017204950 6562735635 05 D-5 / - DATA BTH0CS( 4) / +.1355867305 9405964054 3774459299 03 D-6 / - DATA BTH0CS( 5) / -.5569139890 2227626227 5832184149 20 D-8 / - DATA BTH0CS( 6) / +.3260903182 4994335304 0042057194 68 D-9 / - DATA BTH0CS( 7) / -.2491880786 2461341125 2379038779 93 D-10 / - DATA BTH0CS( 8) / +.2344937742 0882520554 3524135648 91 D-11 / - DATA BTH0CS( 9) / -.2609653444 4310387762 1775747661 36 D-12 / - DATA BTH0CS( 10) / +.3335314042 0097395105 8699550149 23 D-13 / - DATA BTH0CS( 11) / -.4789000044 0572684646 7507705574 09 D-14 / - DATA BTH0CS( 12) / +.7595617843 6192215972 6425685452 48 D-15 / - DATA BTH0CS( 13) / -.1313155601 6891440382 7733974876 33 D-15 / - DATA BTH0CS( 14) / +.2448361834 5240857495 4268207383 55 D-16 / - DATA BTH0CS( 15) / -.4880572981 0618777683 2567619183 31 D-17 / - DATA BTH0CS( 16) / +.1032728502 9786316149 2237563612 04 D-17 / - DATA BTH0CS( 17) / -.2305763381 5057217157 0047445270 25 D-18 / - DATA BTH0CS( 18) / +.5404444300 1892693993 0171084837 65 D-19 / - DATA BTH0CS( 19) / -.1324069519 4366572724 1550328823 85 D-19 / - DATA BTH0CS( 20) / +.3378079562 1371970203 4247921247 22 D-20 / - DATA BTH0CS( 21) / -.8945762915 7111779003 0269262922 99 D-21 / - DATA BTH0CS( 22) / +.2451990688 9219317090 8999086514 05 D-21 / - DATA BTH0CS( 23) / -.6938842287 6866318680 1399331576 57 D-22 / - DATA BTH0CS( 24) / +.2022827871 4890138392 9463033377 91 D-22 / - DATA BTH0CS( 25) / -.6062850000 2335483105 7941953717 64 D-23 / - DATA BTH0CS( 26) / +.1864974896 4037635381 8237883962 70 D-23 / - DATA BTH0CS( 27) / -.5878373238 4849894560 2450365308 67 D-24 / - DATA BTH0CS( 28) / +.1895859144 7999563485 5311795035 13 D-24 / - DATA BTH0CS( 29) / -.6248197937 2258858959 2916207285 65 D-25 / - DATA BTH0CS( 30) / +.2101790168 4551024686 6386335290 74 D-25 / - DATA BTH0CS( 31) / -.7208430093 5209253690 8139339924 46 D-26 / - DATA BTH0CS( 32) / +.2518136389 2474240867 1564059767 46 D-26 / - DATA BTH0CS( 33) / -.8951804225 8785778806 1439459536 43 D-27 / - DATA BTH0CS( 34) / +.3235723747 9762298533 2562358685 87 D-27 / - DATA BTH0CS( 35) / -.1188301051 9855353657 0471441137 96 D-27 / - DATA BTH0CS( 36) / +.4430628690 7358104820 5792319417 31 D-28 / - DATA BTH0CS( 37) / -.1676100964 8834829495 7920101356 81 D-28 / - DATA BTH0CS( 38) / +.6429294692 1207466972 5323939660 88 D-29 / - DATA BTH0CS( 39) / -.2499226116 6978652421 2072136827 63 D-29 / - DATA BTH0CS( 40) / +.9839979429 9521955672 8282603553 18 D-30 / - DATA BTH0CS( 41) / -.3922037524 2408016397 9891316261 58 D-30 / - DATA BTH0CS( 42) / +.1581810703 0056522138 5906188456 92 D-30 / - DATA BTH0CS( 43) / -.6452550614 4890715944 3440983654 26 D-31 / - DATA BTH0CS( 44) / +.2661111136 9199356137 1770183463 67 D-31 / - DATA BM02CS( 1) / +.9500415145 2283813693 3086133556 0 D-1 / - DATA BM02CS( 2) / -.3801864682 3656709917 4808156685 1 D-3 / - DATA BM02CS( 3) / +.2258339301 0314811929 5182992722 4 D-5 / - DATA BM02CS( 4) / -.3895725802 3722287647 3062141260 5 D-7 / - DATA BM02CS( 5) / +.1246886416 5120816979 3099052972 5 D-8 / - DATA BM02CS( 6) / -.6065949022 1025037798 0383505838 7 D-10 / - DATA BM02CS( 7) / +.4008461651 4217469910 1527597104 5 D-11 / - DATA BM02CS( 8) / -.3350998183 3980942184 6729879457 4 D-12 / - DATA BM02CS( 9) / +.3377119716 5174173670 6326434199 6 D-13 / - DATA BM02CS( 10) / -.3964585901 6350127005 6935629582 3 D-14 / - DATA BM02CS( 11) / +.5286111503 8838572173 8793974473 5 D-15 / - DATA BM02CS( 12) / -.7852519083 4508523136 5464024349 3 D-16 / - DATA BM02CS( 13) / +.1280300573 3866822010 1163407344 9 D-16 / - DATA BM02CS( 14) / -.2263996296 3914297762 8709924488 4 D-17 / - DATA BM02CS( 15) / +.4300496929 6567903886 4641029047 7 D-18 / - DATA BM02CS( 16) / -.8705749805 1325870797 4753545145 5 D-19 / - DATA BM02CS( 17) / +.1865862713 9620951411 8144277205 0 D-19 / - DATA BM02CS( 18) / -.4210482486 0930654573 4508697230 1 D-20 / - DATA BM02CS( 19) / +.9956676964 2284009915 8162741784 2 D-21 / - DATA BM02CS( 20) / -.2457357442 8053133596 0592147854 7 D-21 / - DATA BM02CS( 21) / +.6307692160 7620315680 8735370705 9 D-22 / - DATA BM02CS( 22) / -.1678773691 4407401426 9333117238 8 D-22 / - DATA BM02CS( 23) / +.4620259064 6739044337 7087813608 7 D-23 / - DATA BM02CS( 24) / -.1311782266 8603087322 3769340249 6 D-23 / - DATA BM02CS( 25) / +.3834087564 1163028277 4792244027 6 D-24 / - DATA BM02CS( 26) / -.1151459324 0777412710 7261329357 6 D-24 / - DATA BM02CS( 27) / +.3547210007 5233385230 7697134521 3 D-25 / - DATA BM02CS( 28) / -.1119218385 8150046462 6435594217 6 D-25 / - DATA BM02CS( 29) / +.3611879427 6298378316 9840499425 7 D-26 / - DATA BM02CS( 30) / -.1190687765 9133331500 9264176246 3 D-26 / - DATA BM02CS( 31) / +.4005094059 4039681318 0247644953 6 D-27 / - DATA BM02CS( 32) / -.1373169422 4522123905 9519391601 7 D-27 / - DATA BM02CS( 33) / +.4794199088 7425315859 9649152643 7 D-28 / - DATA BM02CS( 34) / -.1702965627 6241095840 0699447645 2 D-28 / - DATA BM02CS( 35) / +.6149512428 9363300715 0357516132 4 D-29 / - DATA BM02CS( 36) / -.2255766896 5818283499 4430023724 2 D-29 / - DATA BM02CS( 37) / +.8399707509 2942994860 6165835320 0 D-30 / - DATA BM02CS( 38) / -.3172997595 5626023555 6742393615 2 D-30 / - DATA BM02CS( 39) / +.1215205298 8812985545 8333302651 4 D-30 / - DATA BM02CS( 40) / -.4715852749 7544386930 1321056804 5 D-31 / - DATA BT02CS( 1) / -.2454829521 3424597462 0504672493 24 D+0 / - DATA BT02CS( 2) / +.1254412103 9084615780 7853317782 99 D-2 / - DATA BT02CS( 3) / -.3125395041 4871522854 9734467095 71 D-4 / - DATA BT02CS( 4) / +.1470977824 9940831164 4534269693 14 D-5 / - DATA BT02CS( 5) / -.9954348893 7950033643 4688503511 58 D-7 / - DATA BT02CS( 6) / +.8549316673 3203041247 5787113977 51 D-8 / - DATA BT02CS( 7) / -.8698975952 6554334557 9855121791 92 D-9 / - DATA BT02CS( 8) / +.1005209953 3559791084 5401010821 53 D-9 / - DATA BT02CS( 9) / -.1282823060 1708892903 4836236855 44 D-10 / - DATA BT02CS( 10) / +.1773170078 1805131705 6557504510 23 D-11 / - DATA BT02CS( 11) / -.2617457456 9485577488 6362841809 25 D-12 / - DATA BT02CS( 12) / +.4082835138 9972059621 9664812211 03 D-13 / - DATA BT02CS( 13) / -.6675166823 9742720054 6067495542 61 D-14 / - DATA BT02CS( 14) / +.1136576139 3071629448 3924695499 51 D-14 / - DATA BT02CS( 15) / -.2005118962 0647160250 5592664121 17 D-15 / - DATA BT02CS( 16) / +.3649797879 4766269635 7205914641 06 D-16 / - DATA BT02CS( 17) / -.6830963756 4582303169 3558437888 00 D-17 / - DATA BT02CS( 18) / +.1310758314 5670756620 0571042679 46 D-17 / - DATA BT02CS( 19) / -.2572336310 1850607778 7571306495 99 D-18 / - DATA BT02CS( 20) / +.5152165744 1863959925 2677809493 33 D-19 / - DATA BT02CS( 21) / -.1051301756 3758802637 9407414613 33 D-19 / - DATA BT02CS( 22) / +.2182038199 1194813847 3010845013 33 D-20 / - DATA BT02CS( 23) / -.4600470121 0362160577 2259054933 33 D-21 / - DATA BT02CS( 24) / +.9840700692 5466818520 9536511999 99 D-22 / - DATA BT02CS( 25) / -.2133403803 5728375844 7359863466 66 D-22 / - DATA BT02CS( 26) / +.4683103642 3973365296 0662869333 33 D-23 / - DATA BT02CS( 27) / -.1040021369 1985747236 5133823999 99 D-23 / - DATA BT02CS( 28) / +.2334910567 7301510051 7777408000 00 D-24 / - DATA BT02CS( 29) / -.5295682532 3318615788 0497493333 33 D-25 / - DATA BT02CS( 30) / +.1212634195 2959756829 1962879999 99 D-25 / - DATA BT02CS( 31) / -.2801889708 2289428760 2756266666 66 D-26 / - DATA BT02CS( 32) / +.6529267898 7012873342 5937066666 66 D-27 / - DATA BT02CS( 33) / -.1533798006 1873346427 8357333333 33 D-27 / - DATA BT02CS( 34) / +.3630588430 6364536682 3594666666 66 D-28 / - DATA BT02CS( 35) / -.8656075571 3629122479 1722666666 66 D-29 / - DATA BT02CS( 36) / +.2077990997 2536284571 2383999999 99 D-29 / - DATA BT02CS( 37) / -.5021117022 1417221674 3253333333 33 D-30 / - DATA BT02CS( 38) / +.1220836027 9441714184 1919999999 99 D-30 / - DATA BT02CS( 39) / -.2986005626 7039913454 2506666666 66 D-31 / - DATA PI4 / 0.7853981633 9744830961 5660845819 876 D0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT D9B0MP - IF (FIRST) THEN - ETA = 0.1*REAL(D1MACH(3)) - NBM0 = INITDS (BM0CS, 37, ETA) - NBT02 = INITDS (BT02CS, 39, ETA) - NBM02 = INITDS (BM02CS, 40, ETA) - NBTH0 = INITDS (BTH0CS, 44, ETA) -C - XMAX = 1.0D0/D1MACH(4) - ENDIF - FIRST = .FALSE. -C - IF (X .LT. 4.D0) CALL XERMSG ('SLATEC', 'D9B0MP', - + 'X MUST BE GE 4', 1, 2) -C - IF (X.GT.8.D0) GO TO 20 - Z = (128.D0/(X*X) - 5.D0)/3.D0 - AMPL = (.75D0 + DCSEVL (Z, BM0CS, NBM0))/SQRT(X) - THETA = X - PI4 + DCSEVL (Z, BT02CS, NBT02)/X - RETURN -C - 20 IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'D9B0MP', - + 'NO PRECISION BECAUSE X IS BIG', 2, 2) -C - Z = 128.D0/(X*X) - 1.D0 - AMPL = (.75D0 + DCSEVL (Z, BM02CS, NBM02))/SQRT(X) - THETA = X - PI4 + DCSEVL (Z, BTH0CS, NBTH0)/X - RETURN -C - END diff --git a/slatec/d9b1mp.f b/slatec/d9b1mp.f deleted file mode 100644 index 1b87c7f..0000000 --- a/slatec/d9b1mp.f +++ /dev/null @@ -1,249 +0,0 @@ -*DECK D9B1MP - SUBROUTINE D9B1MP (X, AMPL, THETA) -C***BEGIN PROLOGUE D9B1MP -C***SUBSIDIARY -C***PURPOSE Evaluate the modulus and phase for the J1 and Y1 Bessel -C functions. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10A1 -C***TYPE DOUBLE PRECISION (D9B1MP-D) -C***KEYWORDS BESSEL FUNCTION, FNLIB, MODULUS, PHASE, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate the modulus and phase for the Bessel J1 and Y1 functions. -C -C Series for BM1 on the interval 1.56250E-02 to 6.25000E-02 -C with weighted error 4.91E-32 -C log weighted error 31.31 -C significant figures required 30.04 -C decimal places required 32.09 -C -C Series for BT12 on the interval 1.56250E-02 to 6.25000E-02 -C with weighted error 3.33E-32 -C log weighted error 31.48 -C significant figures required 31.05 -C decimal places required 32.27 -C -C Series for BM12 on the interval 0. to 1.56250E-02 -C with weighted error 5.01E-32 -C log weighted error 31.30 -C significant figures required 29.99 -C decimal places required 32.10 -C -C Series for BTH1 on the interval 0. to 1.56250E-02 -C with weighted error 2.82E-32 -C log weighted error 31.55 -C significant figures required 31.12 -C decimal places required 32.37 -C -C***SEE ALSO DBESJ1, DBESY1 -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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 900720 Routine changed from user-callable to subsidiary. (WRB) -C 920618 Removed space from variable name and code restructured to -C use IF-THEN-ELSE. (RWC, WRB) -C***END PROLOGUE D9B1MP - DOUBLE PRECISION X, AMPL, THETA, BM1CS(37), BT12CS(39), - 1 BM12CS(40), BTH1CS(44), XMAX, PI4, Z, D1MACH, DCSEVL - LOGICAL FIRST - SAVE BM1CS, BT12CS, BTH1CS, BM12CS, PI4, NBM1, NBT12, - 1 NBM12, NBTH1, XMAX, FIRST - DATA BM1CS( 1) / +.1069845452 6180630149 6998530853 8 D+0 / - DATA BM1CS( 2) / +.3274915039 7159649007 2905514344 5 D-2 / - DATA BM1CS( 3) / -.2987783266 8316985920 3044577793 8 D-4 / - DATA BM1CS( 4) / +.8331237177 9919745313 9322266902 3 D-6 / - DATA BM1CS( 5) / -.4112665690 3020073048 9638172549 8 D-7 / - DATA BM1CS( 6) / +.2855344228 7892152207 1975766316 1 D-8 / - DATA BM1CS( 7) / -.2485408305 4156238780 6002659605 5 D-9 / - DATA BM1CS( 8) / +.2543393338 0725824427 4248439717 4 D-10 / - DATA BM1CS( 9) / -.2941045772 8229675234 8975082790 9 D-11 / - DATA BM1CS( 10) / +.3743392025 4939033092 6505615362 6 D-12 / - DATA BM1CS( 11) / -.5149118293 8211672187 2054824352 7 D-13 / - DATA BM1CS( 12) / +.7552535949 8651439080 3404076419 9 D-14 / - DATA BM1CS( 13) / -.1169409706 8288464441 6629062246 4 D-14 / - DATA BM1CS( 14) / +.1896562449 4347915717 2182460506 0 D-15 / - DATA BM1CS( 15) / -.3201955368 6932864206 6477531639 4 D-16 / - DATA BM1CS( 16) / +.5599548399 3162041144 8416990549 3 D-17 / - DATA BM1CS( 17) / -.1010215894 7304324431 1939044454 4 D-17 / - DATA BM1CS( 18) / +.1873844985 7275629833 0204271957 3 D-18 / - DATA BM1CS( 19) / -.3563537470 3285802192 7430143999 9 D-19 / - DATA BM1CS( 20) / +.6931283819 9712383304 2276351999 9 D-20 / - DATA BM1CS( 21) / -.1376059453 4065001522 5140893013 3 D-20 / - DATA BM1CS( 22) / +.2783430784 1070802205 9977932799 9 D-21 / - DATA BM1CS( 23) / -.5727595364 3205616893 4866943999 9 D-22 / - DATA BM1CS( 24) / +.1197361445 9188926725 3575679999 9 D-22 / - DATA BM1CS( 25) / -.2539928509 8918719766 4144042666 6 D-23 / - DATA BM1CS( 26) / +.5461378289 6572959730 6961919999 9 D-24 / - DATA BM1CS( 27) / -.1189211341 7733202889 8628949333 3 D-24 / - DATA BM1CS( 28) / +.2620150977 3400815949 5782400000 0 D-25 / - DATA BM1CS( 29) / -.5836810774 2556859019 2093866666 6 D-26 / - DATA BM1CS( 30) / +.1313743500 0805957734 2361599999 9 D-26 / - DATA BM1CS( 31) / -.2985814622 5103803553 3277866666 6 D-27 / - DATA BM1CS( 32) / +.6848390471 3346049376 2559999999 9 D-28 / - DATA BM1CS( 33) / -.1584401568 2224767211 9296000000 0 D-28 / - DATA BM1CS( 34) / +.3695641006 5709380543 0101333333 3 D-29 / - DATA BM1CS( 35) / -.8687115921 1446682430 1226666666 6 D-30 / - DATA BM1CS( 36) / +.2057080846 1587634629 2906666666 6 D-30 / - DATA BM1CS( 37) / -.4905225761 1162255185 2373333333 3 D-31 / - DATA BT12CS( 1) / +.7382386012 8742974662 6208397927 64 D+0 / - DATA BT12CS( 2) / -.3336111317 4483906384 4701476811 89 D-2 / - DATA BT12CS( 3) / +.6146345488 8046964698 5148994201 86 D-4 / - DATA BT12CS( 4) / -.2402458516 1602374264 9776354695 68 D-5 / - DATA BT12CS( 5) / +.1466355557 7509746153 2105919972 04 D-6 / - DATA BT12CS( 6) / -.1184191730 5589180567 0051475049 83 D-7 / - DATA BT12CS( 7) / +.1157419896 3919197052 1254663030 55 D-8 / - DATA BT12CS( 8) / -.1300116112 9439187449 3660077945 71 D-9 / - DATA BT12CS( 9) / +.1624539114 1361731937 7421662736 67 D-10 / - DATA BT12CS( 10) / -.2208963682 1403188752 1554417701 28 D-11 / - DATA BT12CS( 11) / +.3218030425 8553177090 4743586537 78 D-12 / - DATA BT12CS( 12) / -.4965314793 2768480785 5520211353 81 D-13 / - DATA BT12CS( 13) / +.8043890043 2847825985 5588826393 17 D-14 / - DATA BT12CS( 14) / -.1358912131 0161291384 6947126822 82 D-14 / - DATA BT12CS( 15) / +.2381050439 7147214869 6765296059 73 D-15 / - DATA BT12CS( 16) / -.4308146636 3849106724 4712414207 99 D-16 / - DATA BT12CS( 17) / +.8020254403 2771002434 9935125504 00 D-17 / - DATA BT12CS( 18) / -.1531631064 2462311864 2300274687 99 D-17 / - DATA BT12CS( 19) / +.2992860635 2715568924 0730405546 66 D-18 / - DATA BT12CS( 20) / -.5970996465 8085443393 8156366506 66 D-19 / - DATA BT12CS( 21) / +.1214028966 9415185024 1608526506 66 D-19 / - DATA BT12CS( 22) / -.2511511469 6612948901 0069777066 66 D-20 / - DATA BT12CS( 23) / +.5279056717 0328744850 7383807999 99 D-21 / - DATA BT12CS( 24) / -.1126050922 7550498324 3611613866 66 D-21 / - DATA BT12CS( 25) / +.2434827735 9576326659 6634624000 00 D-22 / - DATA BT12CS( 26) / -.5331726123 6931800130 0384426666 66 D-23 / - DATA BT12CS( 27) / +.1181361505 9707121039 2059903999 99 D-23 / - DATA BT12CS( 28) / -.2646536828 3353523514 8567893333 33 D-24 / - DATA BT12CS( 29) / +.5990339404 1361503945 5778133333 33 D-25 / - DATA BT12CS( 30) / -.1369085463 0829503109 1363839999 99 D-25 / - DATA BT12CS( 31) / +.3157679015 4380228326 4136533333 33 D-26 / - DATA BT12CS( 32) / -.7345791508 2084356491 4005333333 33 D-27 / - DATA BT12CS( 33) / +.1722808148 0722747930 7059200000 00 D-27 / - DATA BT12CS( 34) / -.4071690796 1286507941 0688000000 00 D-28 / - DATA BT12CS( 35) / +.9693474513 6779622700 3733333333 33 D-29 / - DATA BT12CS( 36) / -.2323763633 7765716765 3546666666 66 D-29 / - DATA BT12CS( 37) / +.5607451067 3522029406 8906666666 66 D-30 / - DATA BT12CS( 38) / -.1361646539 1539005860 5226666666 66 D-30 / - DATA BT12CS( 39) / +.3326310923 3894654388 9066666666 66 D-31 / - DATA BM12CS( 1) / +.9807979156 2330500272 7209354693 7 D-1 / - DATA BM12CS( 2) / +.1150961189 5046853061 7548348460 2 D-2 / - DATA BM12CS( 3) / -.4312482164 3382054098 8935809773 2 D-5 / - DATA BM12CS( 4) / +.5951839610 0888163078 1302980183 2 D-7 / - DATA BM12CS( 5) / -.1704844019 8269098574 0070158647 8 D-8 / - DATA BM12CS( 6) / +.7798265413 6111095086 5817382740 1 D-10 / - DATA BM12CS( 7) / -.4958986126 7664158094 9175495186 5 D-11 / - DATA BM12CS( 8) / +.4038432416 4211415168 3820226514 4 D-12 / - DATA BM12CS( 9) / -.3993046163 7251754457 6548384664 5 D-13 / - DATA BM12CS( 10) / +.4619886183 1189664943 1334243277 5 D-14 / - DATA BM12CS( 11) / -.6089208019 0953833013 4547261933 3 D-15 / - DATA BM12CS( 12) / +.8960930916 4338764821 5704804124 9 D-16 / - DATA BM12CS( 13) / -.1449629423 9420231229 1651891892 5 D-16 / - DATA BM12CS( 14) / +.2546463158 5377760561 6514964806 8 D-17 / - DATA BM12CS( 15) / -.4809472874 6478364442 5926371862 0 D-18 / - DATA BM12CS( 16) / +.9687684668 2925990490 8727583912 4 D-19 / - DATA BM12CS( 17) / -.2067213372 2779660232 4503811755 1 D-19 / - DATA BM12CS( 18) / +.4646651559 1503847318 0276780959 0 D-20 / - DATA BM12CS( 19) / -.1094966128 8483341382 4135132833 9 D-20 / - DATA BM12CS( 20) / +.2693892797 2886828609 0570761278 5 D-21 / - DATA BM12CS( 21) / -.6894992910 9303744778 1897002685 7 D-22 / - DATA BM12CS( 22) / +.1830268262 7520629098 9066855474 0 D-22 / - DATA BM12CS( 23) / -.5025064246 3519164281 5611355322 4 D-23 / - DATA BM12CS( 24) / +.1423545194 4548060396 3169363419 4 D-23 / - DATA BM12CS( 25) / -.4152191203 6164503880 6888676980 1 D-24 / - DATA BM12CS( 26) / +.1244609201 5039793258 8233007654 7 D-24 / - DATA BM12CS( 27) / -.3827336370 5693042994 3191866128 6 D-25 / - DATA BM12CS( 28) / +.1205591357 8156175353 7472398183 5 D-25 / - DATA BM12CS( 29) / -.3884536246 3764880764 3185936112 4 D-26 / - DATA BM12CS( 30) / +.1278689528 7204097219 0489528346 1 D-26 / - DATA BM12CS( 31) / -.4295146689 4479462720 6193691591 2 D-27 / - DATA BM12CS( 32) / +.1470689117 8290708864 5680270798 3 D-27 / - DATA BM12CS( 33) / -.5128315665 1060731281 8037401779 6 D-28 / - DATA BM12CS( 34) / +.1819509585 4711693854 8143737328 6 D-28 / - DATA BM12CS( 35) / -.6563031314 8419808676 1863505037 3 D-29 / - DATA BM12CS( 36) / +.2404898976 9199606531 9891487583 4 D-29 / - DATA BM12CS( 37) / -.8945966744 6906124732 3495824297 9 D-30 / - DATA BM12CS( 38) / +.3376085160 6572310266 3714897824 0 D-30 / - DATA BM12CS( 39) / -.1291791454 6206563609 1309991696 6 D-30 / - DATA BM12CS( 40) / +.5008634462 9588105206 8495150125 4 D-31 / - DATA BTH1CS( 1) / +.7474995720 3587276055 4434839696 95 D+0 / - DATA BTH1CS( 2) / -.1240077714 4651711252 5457775413 84 D-2 / - DATA BTH1CS( 3) / +.9925244240 4424527376 6414976895 92 D-5 / - DATA BTH1CS( 4) / -.2030369073 7159711052 4193753756 08 D-6 / - DATA BTH1CS( 5) / +.7535961770 5690885712 1840175836 29 D-8 / - DATA BTH1CS( 6) / -.4166161271 5343550107 6300238562 28 D-9 / - DATA BTH1CS( 7) / +.3070161807 0834890481 2451020912 16 D-10 / - DATA BTH1CS( 8) / -.2817849963 7605213992 3240088839 24 D-11 / - DATA BTH1CS( 9) / +.3079069673 9040295476 0281468216 47 D-12 / - DATA BTH1CS( 10) / -.3880330026 2803434112 7873475547 81 D-13 / - DATA BTH1CS( 11) / +.5509603960 8630904934 5617262085 62 D-14 / - DATA BTH1CS( 12) / -.8659006076 8383779940 1033989539 94 D-15 / - DATA BTH1CS( 13) / +.1485604914 1536749003 4236890606 83 D-15 / - DATA BTH1CS( 14) / -.2751952981 5904085805 3712121250 09 D-16 / - DATA BTH1CS( 15) / +.5455079609 0481089625 0362236409 23 D-17 / - DATA BTH1CS( 16) / -.1148653450 1983642749 5436310271 77 D-17 / - DATA BTH1CS( 17) / +.2553521337 7973900223 1990525335 22 D-18 / - DATA BTH1CS( 18) / -.5962149019 7413450395 7682879078 49 D-19 / - DATA BTH1CS( 19) / +.1455662290 2372718620 2883020058 33 D-19 / - DATA BTH1CS( 20) / -.3702218542 2450538201 5797760195 93 D-20 / - DATA BTH1CS( 21) / +.9776307412 5345357664 1684345179 24 D-21 / - DATA BTH1CS( 22) / -.2672682163 9668488468 7237753930 52 D-21 / - DATA BTH1CS( 23) / +.7545330038 4983271794 0381906557 64 D-22 / - DATA BTH1CS( 24) / -.2194789991 9802744897 8923833716 47 D-22 / - DATA BTH1CS( 25) / +.6564839462 3955262178 9069998174 93 D-23 / - DATA BTH1CS( 26) / -.2015560429 8370207570 7840768695 19 D-23 / - DATA BTH1CS( 27) / +.6341776855 6776143492 1446671856 70 D-24 / - DATA BTH1CS( 28) / -.2041927788 5337895634 8137699555 91 D-24 / - DATA BTH1CS( 29) / +.6719146422 0720567486 6589800185 51 D-25 / - DATA BTH1CS( 30) / -.2256907911 0207573595 7090036873 36 D-25 / - DATA BTH1CS( 31) / +.7729771989 2989706370 9269598719 29 D-26 / - DATA BTH1CS( 32) / -.2696744451 2294640913 2114240809 20 D-26 / - DATA BTH1CS( 33) / +.9574934451 8502698072 2955219336 27 D-27 / - DATA BTH1CS( 34) / -.3456916844 8890113000 1756808276 27 D-27 / - DATA BTH1CS( 35) / +.1268123481 7398436504 2119862383 74 D-27 / - DATA BTH1CS( 36) / -.4723253663 0722639860 4649937134 45 D-28 / - DATA BTH1CS( 37) / +.1785000847 8186376177 8586197964 17 D-28 / - DATA BTH1CS( 38) / -.6840436100 4510395406 2152235667 46 D-29 / - DATA BTH1CS( 39) / +.2656602867 1720419358 2934226722 12 D-29 / - DATA BTH1CS( 40) / -.1045040252 7914452917 7141614846 70 D-29 / - DATA BTH1CS( 41) / +.4161829082 5377144306 8619171970 64 D-30 / - DATA BTH1CS( 42) / -.1677163920 3643714856 5013478828 87 D-30 / - DATA BTH1CS( 43) / +.6836199777 6664389173 5359280285 28 D-31 / - DATA BTH1CS( 44) / -.2817224786 1233641166 7395746228 10 D-31 / - DATA PI4 / 0.7853981633 9744830961 5660845819 876 D0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT D9B1MP - IF (FIRST) THEN - ETA = 0.1*REAL(D1MACH(3)) - NBM1 = INITDS (BM1CS, 37, ETA) - NBT12 = INITDS (BT12CS, 39, ETA) - NBM12 = INITDS (BM12CS, 40, ETA) - NBTH1 = INITDS (BTH1CS, 44, ETA) -C - XMAX = 1.0D0/D1MACH(4) - ENDIF - FIRST = .FALSE. -C - IF (X .LT. 4.0D0) THEN - CALL XERMSG ('SLATEC', 'D9B1MP', 'X must be .GE. 4', 1, 2) - AMPL = 0.0D0 - THETA = 0.0D0 - ELSE IF (X .LE. 8.0D0) THEN - Z = (128.0D0/(X*X) - 5.0D0)/3.0D0 - AMPL = (0.75D0 + DCSEVL (Z, BM1CS, NBM1))/SQRT(X) - THETA = X - 3.0D0*PI4 + DCSEVL (Z, BT12CS, NBT12)/X - ELSE - IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'D9B1MP', - + 'No precision because X is too big', 2, 2) -C - Z = 128.0D0/(X*X) - 1.0D0 - AMPL = (0.75D0 + DCSEVL (Z, BM12CS, NBM12))/SQRT(X) - THETA = X - 3.0D0*PI4 + DCSEVL (Z, BTH1CS, NBTH1)/X - ENDIF - RETURN - END diff --git a/slatec/d9chu.f b/slatec/d9chu.f deleted file mode 100644 index 2089d4c..0000000 --- a/slatec/d9chu.f +++ /dev/null @@ -1,97 +0,0 @@ -*DECK D9CHU - DOUBLE PRECISION FUNCTION D9CHU (A, B, Z) -C***BEGIN PROLOGUE D9CHU -C***SUBSIDIARY -C***PURPOSE Evaluate for large Z Z**A * U(A,B,Z) where U is the -C logarithmic confluent hypergeometric function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C11 -C***TYPE DOUBLE PRECISION (R9CHU-S, D9CHU-D) -C***KEYWORDS FNLIB, LOGARITHMIC CONFLUENT HYPERGEOMETRIC FUNCTION, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate for large Z Z**A * U(A,B,Z) where U is the logarithmic -C confluent hypergeometric function. A rational approximation due to Y. -C L. Luke is used. When U is not in the asymptotic region, i.e., when A -C or B is large compared with Z, considerable significance loss occurs. -C A warning is provided when the computed result is less than half -C precision. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770801 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 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE D9CHU - DOUBLE PRECISION A, B, Z, AA(4), BB(4), AB, ANBN, BP, CT1, CT2, - 1 CT3, C2, D1Z, EPS, G1, G2, G3, SAB, SQEPS, X2I1, D1MACH - LOGICAL FIRST - SAVE EPS, SQEPS, FIRST - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT D9CHU - IF (FIRST) THEN - EPS = 4.0D0*D1MACH(4) - SQEPS = SQRT(D1MACH(4)) - ENDIF - FIRST = .FALSE. -C - BP = 1.0D0 + A - B - AB = A*BP - CT2 = 2.0D0 * (Z - AB) - SAB = A + BP -C - BB(1) = 1.0D0 - AA(1) = 1.0D0 -C - CT3 = SAB + 1.0D0 + AB - BB(2) = 1.0D0 + 2.0D0*Z/CT3 - AA(2) = 1.0D0 + CT2/CT3 -C - ANBN = CT3 + SAB + 3.0D0 - CT1 = 1.0D0 + 2.0D0*Z/ANBN - BB(3) = 1.0D0 + 6.0D0*CT1*Z/CT3 - AA(3) = 1.0D0 + 6.0D0*AB/ANBN + 3.0D0*CT1*CT2/CT3 -C - DO 30 I=4,300 - X2I1 = 2*I - 3 - CT1 = X2I1/(X2I1-2.0D0) - ANBN = ANBN + X2I1 + SAB - CT2 = (X2I1 - 1.0D0)/ANBN - C2 = X2I1*CT2 - 1.0D0 - D1Z = X2I1*2.0D0*Z/ANBN -C - CT3 = SAB*CT2 - G1 = D1Z + CT1*(C2+CT3) - G2 = D1Z - C2 - G3 = CT1*(1.0D0 - CT3 - 2.0D0*CT2) -C - BB(4) = G1*BB(3) + G2*BB(2) + G3*BB(1) - AA(4) = G1*AA(3) + G2*AA(2) + G3*AA(1) - IF (ABS(AA(4)*BB(1)-AA(1)*BB(4)).LT.EPS*ABS(BB(4)*BB(1))) - 1 GO TO 40 -C -C IF OVERFLOWS OR UNDERFLOWS PROVE TO BE A PROBLEM, THE STATEMENTS -C BELOW COULD BE ALTERED TO INCORPORATE A DYNAMICALLY ADJUSTED SCALE -C FACTOR. -C - DO 20 J=1,3 - AA(J) = AA(J+1) - BB(J) = BB(J+1) - 20 CONTINUE - 30 CONTINUE - CALL XERMSG ('SLATEC', 'D9CHU', 'NO CONVERGENCE IN 300 TERMS', 2, - + 2) -C - 40 D9CHU = AA(4)/BB(4) -C - IF (D9CHU .LT. SQEPS .OR. D9CHU .GT. 1.0D0/SQEPS) CALL XERMSG - + ('SLATEC', 'D9CHU', 'ANSWER LT HALF PRECISION', 2, 1) -C - RETURN - END diff --git a/slatec/d9gmic.f b/slatec/d9gmic.f deleted file mode 100644 index 50e86e5..0000000 --- a/slatec/d9gmic.f +++ /dev/null @@ -1,98 +0,0 @@ -*DECK D9GMIC - DOUBLE PRECISION FUNCTION D9GMIC (A, X, ALX) -C***BEGIN PROLOGUE D9GMIC -C***SUBSIDIARY -C***PURPOSE Compute the complementary incomplete Gamma function for A -C near a negative integer and X small. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE DOUBLE PRECISION (R9GMIC-S, D9GMIC-D) -C***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, SMALL X, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Compute the complementary incomplete gamma function for A near -C a negative integer and for small X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DLNGAM, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 890911 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 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE D9GMIC - DOUBLE PRECISION A, X, ALX, ALNG, BOT, EPS, EULER, FK, FKP1, FM, - 1 S, SGNG, T, TE, D1MACH, DLNGAM - LOGICAL FIRST - SAVE EULER, EPS, BOT, FIRST - DATA EULER / 0.5772156649 0153286060 6512090082 40 D0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT D9GMIC - IF (FIRST) THEN - EPS = 0.5D0*D1MACH(3) - BOT = LOG (D1MACH(1)) - ENDIF - FIRST = .FALSE. -C - IF (A .GT. 0.D0) CALL XERMSG ('SLATEC', 'D9GMIC', - + 'A MUST BE NEAR A NEGATIVE INTEGER', 2, 2) - IF (X .LE. 0.D0) CALL XERMSG ('SLATEC', 'D9GMIC', - + 'X MUST BE GT ZERO', 3, 2) -C - M = -(A - 0.5D0) - FM = M -C - TE = 1.0D0 - T = 1.0D0 - S = T - DO 20 K=1,200 - FKP1 = K + 1 - TE = -X*TE/(FM+FKP1) - T = TE/FKP1 - S = S + T - IF (ABS(T).LT.EPS*S) GO TO 30 - 20 CONTINUE - CALL XERMSG ('SLATEC', 'D9GMIC', - + 'NO CONVERGENCE IN 200 TERMS OF CONTINUED FRACTION', 4, 2) -C - 30 D9GMIC = -ALX - EULER + X*S/(FM+1.0D0) - IF (M.EQ.0) RETURN -C - IF (M.EQ.1) D9GMIC = -D9GMIC - 1.D0 + 1.D0/X - IF (M.EQ.1) RETURN -C - TE = FM - T = 1.D0 - S = T - MM1 = M - 1 - DO 40 K=1,MM1 - FK = K - TE = -X*TE/FK - T = TE/(FM-FK) - S = S + T - IF (ABS(T).LT.EPS*ABS(S)) GO TO 50 - 40 CONTINUE -C - 50 DO 60 K=1,M - D9GMIC = D9GMIC + 1.0D0/K - 60 CONTINUE -C - SGNG = 1.0D0 - IF (MOD(M,2).EQ.1) SGNG = -1.0D0 - ALNG = LOG(D9GMIC) - DLNGAM(FM+1.D0) -C - D9GMIC = 0.D0 - IF (ALNG.GT.BOT) D9GMIC = SGNG * EXP(ALNG) - IF (S.NE.0.D0) D9GMIC = D9GMIC + - 1 SIGN (EXP(-FM*ALX+LOG(ABS(S)/FM)), S) -C - IF (D9GMIC .EQ. 0.D0 .AND. S .EQ. 0.D0) CALL XERMSG ('SLATEC', - + 'D9GMIC', 'RESULT UNDERFLOWS', 1, 1) - RETURN -C - END diff --git a/slatec/d9gmit.f b/slatec/d9gmit.f deleted file mode 100644 index 9752136..0000000 --- a/slatec/d9gmit.f +++ /dev/null @@ -1,91 +0,0 @@ -*DECK D9GMIT - DOUBLE PRECISION FUNCTION D9GMIT (A, X, ALGAP1, SGNGAM, ALX) -C***BEGIN PROLOGUE D9GMIT -C***SUBSIDIARY -C***PURPOSE Compute Tricomi's incomplete Gamma function for small -C arguments. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE DOUBLE PRECISION (R9GMIT-S, D9GMIT-D) -C***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, SMALL X, -C SPECIAL FUNCTIONS, TRICOMI -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Compute Tricomi's incomplete gamma function for small X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DLNGAM, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 890911 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 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE D9GMIT - DOUBLE PRECISION A, X, ALGAP1, SGNGAM, ALX, AE, AEPS, ALGS, ALG2, - 1 BOT, EPS, FK, S, SGNG2, T, TE, D1MACH, DLNGAM - LOGICAL FIRST - SAVE EPS, BOT, FIRST - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT D9GMIT - IF (FIRST) THEN - EPS = 0.5D0*D1MACH(3) - BOT = LOG (D1MACH(1)) - ENDIF - FIRST = .FALSE. -C - IF (X .LE. 0.D0) CALL XERMSG ('SLATEC', 'D9GMIT', - + 'X SHOULD BE GT 0', 1, 2) -C - MA = A + 0.5D0 - IF (A.LT.0.D0) MA = A - 0.5D0 - AEPS = A - MA -C - AE = A - IF (A.LT.(-0.5D0)) AE = AEPS -C - T = 1.D0 - TE = AE - S = T - DO 20 K=1,200 - FK = K - TE = -X*TE/FK - T = TE/(AE+FK) - S = S + T - IF (ABS(T).LT.EPS*ABS(S)) GO TO 30 - 20 CONTINUE - CALL XERMSG ('SLATEC', 'D9GMIT', - + 'NO CONVERGENCE IN 200 TERMS OF TAYLOR-S SERIES', 2, 2) -C - 30 IF (A.GE.(-0.5D0)) ALGS = -ALGAP1 + LOG(S) - IF (A.GE.(-0.5D0)) GO TO 60 -C - ALGS = -DLNGAM(1.D0+AEPS) + LOG(S) - S = 1.0D0 - M = -MA - 1 - IF (M.EQ.0) GO TO 50 - T = 1.0D0 - DO 40 K=1,M - T = X*T/(AEPS-(M+1-K)) - S = S + T - IF (ABS(T).LT.EPS*ABS(S)) GO TO 50 - 40 CONTINUE -C - 50 D9GMIT = 0.0D0 - ALGS = -MA*LOG(X) + ALGS - IF (S.EQ.0.D0 .OR. AEPS.EQ.0.D0) GO TO 60 -C - SGNG2 = SGNGAM * SIGN (1.0D0, S) - ALG2 = -X - ALGAP1 + LOG(ABS(S)) -C - IF (ALG2.GT.BOT) D9GMIT = SGNG2 * EXP(ALG2) - IF (ALGS.GT.BOT) D9GMIT = D9GMIT + EXP(ALGS) - RETURN -C - 60 D9GMIT = EXP (ALGS) - RETURN -C - END diff --git a/slatec/d9knus.f b/slatec/d9knus.f deleted file mode 100644 index 8758849..0000000 --- a/slatec/d9knus.f +++ /dev/null @@ -1,252 +0,0 @@ -*DECK D9KNUS - SUBROUTINE D9KNUS (XNU, X, BKNU, BKNU1, ISWTCH) -C***BEGIN PROLOGUE D9KNUS -C***SUBSIDIARY -C***PURPOSE Compute Bessel functions EXP(X)*K-SUB-XNU(X) and EXP(X)* -C K-SUB-XNU+1(X) for 0.0 .LE. XNU .LT. 1.0. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10B3 -C***TYPE DOUBLE PRECISION (R9KNUS-S, D9KNUS-D) -C***KEYWORDS BESSEL FUNCTION, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Compute Bessel functions EXP(X) * K-sub-XNU (X) and -C EXP(X) * K-sub-XNU+1 (X) for 0.0 .LE. XNU .LT. 1.0 . -C -C Series for C0K on the interval 0. to 2.50000E-01 -C with weighted error 2.16E-32 -C log weighted error 31.67 -C significant figures required 30.86 -C decimal places required 32.40 -C -C Series for ZNU1 on the interval -7.00000E-01 to 0. -C with weighted error 2.45E-33 -C log weighted error 32.61 -C significant figures required 31.85 -C decimal places required 33.26 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DCSEVL, DGAMMA, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 890911 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 900720 Routine changed from user-callable to subsidiary. (WRB) -C 900727 Added EXTERNAL statement. (WRB) -C 920618 Removed space from variable names. (RWC, WRB) -C***END PROLOGUE D9KNUS - DOUBLE PRECISION XNU, X, BKNU, BKNU1, ALPHA(32), BETA(32), A(32), - 1 C0KCS(29), ZNU1CS(20), ALNZ, ALN2, A0, BKNUD, BKNU0, - 2 B0, C0, EULER, EXPX, P1, P2, P3, QQ, RESULT, SQPI2, SQRTX, V, - 3 VLNZ, XI, XMU, XNUSML, XSML, X2N, X2TOV, Z, ZTOV, ALNSML, - 4 ALNBIG - REAL ALNEPS - DOUBLE PRECISION D1MACH, DCSEVL, DGAMMA - LOGICAL FIRST - EXTERNAL DGAMMA - SAVE C0KCS, ZNU1CS, EULER, SQPI2, ALN2, NTC0K, - 1 NTZNU1, XNUSML, XSML, ALNSML, ALNBIG, ALNEPS, FIRST - DATA C0KCS( 1) / +.6018305724 2626108387 5774451803 29 D-1 / - DATA C0KCS( 2) / -.1536487143 3017286092 9597559431 24 D+0 / - DATA C0KCS( 3) / -.1175117600 8210492040 0682292262 13 D-1 / - DATA C0KCS( 4) / -.8524878889 1979509827 0484015509 87 D-3 / - DATA C0KCS( 5) / -.6132983876 7496791874 0981769221 11 D-4 / - DATA C0KCS( 6) / -.4405228124 5510444562 6798895485 05 D-5 / - DATA C0KCS( 7) / -.3163124672 8384488192 9154458921 99 D-6 / - DATA C0KCS( 8) / -.2271071938 2899588330 6737717933 96 D-7 / - DATA C0KCS( 9) / -.1630564460 8077609552 2746205153 60 D-8 / - DATA C0KCS( 10) / -.1170693929 9414776568 7560440431 30 D-9 / - DATA C0KCS( 11) / -.8405206378 6464437174 5465934137 92 D-11 / - DATA C0KCS( 12) / -.6034667011 8979991487 0960507371 98 D-12 / - DATA C0KCS( 13) / -.4332696033 5681371952 0459973669 03 D-13 / - DATA C0KCS( 14) / -.3110735803 0203546214 6346977722 37 D-14 / - DATA C0KCS( 15) / -.2233407822 6736982254 4861334098 40 D-15 / - DATA C0KCS( 16) / -.1603514671 6864226300 6357915286 10 D-16 / - DATA C0KCS( 17) / -.1151271736 3666556196 0356977053 05 D-17 / - DATA C0KCS( 18) / -.8265759174 6836959105 1694790892 58 D-19 / - DATA C0KCS( 19) / -.5934548080 6383948172 3334366959 84 D-20 / - DATA C0KCS( 20) / -.4260813819 6467143926 4996130239 76 D-21 / - DATA C0KCS( 21) / -.3059126686 4812876299 2636983705 42 D-22 / - DATA C0KCS( 22) / -.2196354142 6734575224 9755018155 16 D-23 / - DATA C0KCS( 23) / -.1576911326 1495836071 1057506847 60 D-24 / - DATA C0KCS( 24) / -.1132171393 5950320948 7577310480 56 D-25 / - DATA C0KCS( 25) / -.8128624883 4598404082 7923497144 33 D-27 / - DATA C0KCS( 26) / -.5836090089 3453226552 8293493159 49 D-28 / - DATA C0KCS( 27) / -.4190124162 3610922519 4523377809 05 D-29 / - DATA C0KCS( 28) / -.3008373796 0206435069 5305042128 62 D-30 / - DATA C0KCS( 29) / -.2159915206 7808647728 3421680898 32 D-31 / - DATA ZNU1CS( 1) / +.2033067569 9419172967 4444001216 911 D+0 / - DATA ZNU1CS( 2) / +.1400779334 1321977106 2943670790 563 D+0 / - DATA ZNU1CS( 3) / +.7916796961 0016135284 0972241972 320 D-2 / - DATA ZNU1CS( 4) / +.3398011825 3210404535 2930092205 750 D-3 / - DATA ZNU1CS( 5) / +.1174197568 8989336666 4507228352 690 D-4 / - DATA ZNU1CS( 6) / +.3393575706 1226168033 3825865475 121 D-6 / - DATA ZNU1CS( 7) / +.8425941769 7621991019 4629891264 803 D-8 / - DATA ZNU1CS( 8) / +.1833366770 2485008918 4748150900 090 D-9 / - DATA ZNU1CS( 9) / +.3549698447 0441631086 3007064469 557 D-11 / - DATA ZNU1CS( 10) / +.6190324964 6988733220 5244342078 407 D-13 / - DATA ZNU1CS( 11) / +.9819645356 8043942496 0346115456 527 D-15 / - DATA ZNU1CS( 12) / +.1428513143 9649047421 1473563005 985 D-16 / - DATA ZNU1CS( 13) / +.1918949218 8782529896 6162467488 436 D-18 / - DATA ZNU1CS( 14) / +.2394309797 3949891416 2313140597 128 D-20 / - DATA ZNU1CS( 15) / +.2788902468 1534735483 5870465474 995 D-22 / - DATA ZNU1CS( 16) / +.3046066506 3303344258 2845214092 865 D-24 / - DATA ZNU1CS( 17) / +.3131732370 4219181577 1564260932 089 D-26 / - DATA ZNU1CS( 18) / +.3041330989 8785495164 5174908005 034 D-28 / - DATA ZNU1CS( 19) / +.2798403846 3683308434 3185097659 733 D-30 / - DATA ZNU1CS( 20) / +.2446371862 7449759648 5238794922 666 D-32 / - DATA EULER / 0.5772156649 0153286060 6512090082 40D0 / - DATA SQPI2 / +1.253314137 3155002512 0788264240 55 D0 / - DATA ALN2 / 0.6931471805 5994530941 7232121458 18D0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT D9KNUS - IF (FIRST) THEN - ETA = 0.1D0*D1MACH(3) - NTC0K = INITDS (C0KCS, 29, ETA) - NTZNU1 = INITDS (ZNU1CS, 20, ETA) -C - XNUSML = SQRT(D1MACH(3)/8.D0) - XSML = 0.1D0*D1MACH(3) - ALNSML = LOG (D1MACH(1)) - ALNBIG = LOG (D1MACH(2)) - ALNEPS = LOG (0.1D0*D1MACH(3)) - ENDIF - FIRST = .FALSE. -C - IF (XNU .LT. 0.D0 .OR. XNU .GE. 1.D0) CALL XERMSG ('SLATEC', - + 'D9KNUS', 'XNU MUST BE GE 0 AND LT 1', 1, 2) - IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'D9KNUS', 'X MUST BE GT 0', - + 2, 2) -C - ISWTCH = 0 - IF (X.GT.2.0D0) GO TO 50 -C -C X IS SMALL. COMPUTE K-SUB-XNU (X) AND THE DERIVATIVE OF K-SUB-XNU (X) -C THEN FIND K-SUB-XNU+1 (X). XNU IS REDUCED TO THE INTERVAL (-.5,+.5) -C THEN TO (0., .5), BECAUSE K OF NEGATIVE ORDER (-NU) = K OF POSITIVE -C ORDER (+NU). -C - V = XNU - IF (XNU.GT.0.5D0) V = 1.0D0 - XNU -C -C CAREFULLY FIND (X/2)**XNU AND Z**XNU WHERE Z = X*X/4. - ALNZ = 2.D0 * (LOG(X) - ALN2) -C - IF (X.GT.XNU) GO TO 20 - IF (-0.5D0*XNU*ALNZ-ALN2-LOG(XNU) .GT. ALNBIG) CALL XERMSG - + ('SLATEC', 'D9KNUS', 'X SO SMALL BESSEL K-SUB-XNU OVERFLOWS', - + 3, 2) -C - 20 VLNZ = V*ALNZ - X2TOV = EXP (0.5D0*VLNZ) - ZTOV = 0.0D0 - IF (VLNZ.GT.ALNSML) ZTOV = X2TOV**2 -C - A0 = 0.5D0*DGAMMA(1.0D0+V) - B0 = 0.5D0*DGAMMA(1.0D0-V) - C0 = -EULER - IF (ZTOV.GT.0.5D0 .AND. V.GT.XNUSML) C0 = -0.75D0 + - 1 DCSEVL ((8.0D0*V)*V-1.0D0, C0KCS, NTC0K) -C - IF (ZTOV.LE.0.5D0) ALPHA(1) = (A0-ZTOV*B0)/V - IF (ZTOV.GT.0.5D0) ALPHA(1) = C0 - ALNZ*(0.75D0 + - 1 DCSEVL (VLNZ/0.35D0+1.0D0, ZNU1CS, NTZNU1))*B0 - BETA(1) = -0.5D0*(A0+ZTOV*B0) -C - Z = 0.0D0 - IF (X.GT.XSML) Z = 0.25D0*X*X - NTERMS = MAX (2.0, 11.0+(8.*REAL(ALNZ)-25.19-ALNEPS) - 1 /(4.28-REAL(ALNZ))) - DO 30 I=2,NTERMS - XI = I - 1 - A0 = A0/(XI*(XI-V)) - B0 = B0/(XI*(XI+V)) - ALPHA(I) = (ALPHA(I-1)+2.0D0*XI*A0)/(XI*(XI+V)) - BETA(I) = (XI-0.5D0*V)*ALPHA(I) - ZTOV*B0 - 30 CONTINUE -C - BKNU = ALPHA(NTERMS) - BKNUD = BETA(NTERMS) - DO 40 II=2,NTERMS - I = NTERMS + 1 - II - BKNU = ALPHA(I) + BKNU*Z - BKNUD = BETA(I) + BKNUD*Z - 40 CONTINUE -C - EXPX = EXP(X) - BKNU = EXPX*BKNU/X2TOV -C - IF (-0.5D0*(XNU+1.D0)*ALNZ-2.0D0*ALN2.GT.ALNBIG) ISWTCH = 1 - IF (ISWTCH.EQ.1) RETURN - BKNUD = EXPX*BKNUD*2.0D0/(X2TOV*X) -C - IF (XNU.LE.0.5D0) BKNU1 = V*BKNU/X - BKNUD - IF (XNU.LE.0.5D0) RETURN -C - BKNU0 = BKNU - BKNU = -V*BKNU/X - BKNUD - BKNU1 = 2.0D0*XNU*BKNU/X + BKNU0 - RETURN -C -C X IS LARGE. FIND K-SUB-XNU (X) AND K-SUB-XNU+1 (X) WITH Y. L. LUKE-S -C RATIONAL EXPANSION. -C - 50 SQRTX = SQRT(X) - IF (X.GT.1.0D0/XSML) GO TO 90 - AN = -0.60 - 1.02/REAL(X) - BN = -0.27 - 0.53/REAL(X) - NTERMS = MIN (32, MAX1 (3.0, AN+BN*ALNEPS)) -C - DO 80 INU=1,2 - XMU = 0.D0 - IF (INU.EQ.1 .AND. XNU.GT.XNUSML) XMU = (4.0D0*XNU)*XNU - IF (INU.EQ.2) XMU = 4.0D0*(ABS(XNU)+1.D0)**2 -C - A(1) = 1.0D0 - XMU - A(2) = 9.0D0 - XMU - A(3) = 25.0D0 - XMU - IF (A(2).EQ.0.D0) RESULT = SQPI2*(16.D0*X+XMU+7.D0) / - 1 (16.D0*X*SQRTX) - IF (A(2).EQ.0.D0) GO TO 70 -C - ALPHA(1) = 1.0D0 - ALPHA(2) = (16.D0*X+A(2))/A(2) - ALPHA(3) = ((768.D0*X+48.D0*A(3))*X + A(2)*A(3))/(A(2)*A(3)) -C - BETA(1) = 1.0D0 - BETA(2) = (16.D0*X+(XMU+7.D0))/A(2) - BETA(3) = ((768.D0*X+48.D0*(XMU+23.D0))*X + - 1 ((XMU+62.D0)*XMU+129.D0))/(A(2)*A(3)) -C - IF (NTERMS.LT.4) GO TO 65 - DO 60 I=4,NTERMS - N = I - 1 - X2N = 2*N - 1 -C - A(I) = (X2N+2.D0)**2 - XMU - QQ = 16.D0*X2N/A(I) - P1 = -X2N*((12*N*N-20*N)-A(1))/((X2N-2.D0)*A(I)) - 1 - QQ*X - P2 = ((12*N*N-28*N+8)-A(1))/A(I) - QQ*X - P3 = -X2N*A(I-3)/((X2N-2.D0)*A(I)) -C - ALPHA(I) = -P1*ALPHA(I-1) - P2*ALPHA(I-2) - P3*ALPHA(I-3) - BETA(I) = -P1*BETA(I-1) - P2*BETA(I-2) - P3*BETA(I-3) - 60 CONTINUE -C - 65 RESULT = SQPI2*BETA(NTERMS)/(SQRTX*ALPHA(NTERMS)) -C - 70 IF (INU.EQ.1) BKNU = RESULT - IF (INU.EQ.2) BKNU1 = RESULT - 80 CONTINUE - RETURN -C - 90 BKNU = SQPI2/SQRTX - BKNU1 = BKNU - RETURN -C - END diff --git a/slatec/d9lgic.f b/slatec/d9lgic.f deleted file mode 100644 index fbe764d..0000000 --- a/slatec/d9lgic.f +++ /dev/null @@ -1,54 +0,0 @@ -*DECK D9LGIC - DOUBLE PRECISION FUNCTION D9LGIC (A, X, ALX) -C***BEGIN PROLOGUE D9LGIC -C***SUBSIDIARY -C***PURPOSE Compute the log complementary incomplete Gamma function -C for large X and for A .LE. X. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE DOUBLE PRECISION (R9LGIC-S, D9LGIC-D) -C***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, LARGE X, -C LOGARITHM, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Compute the log complementary incomplete gamma function for large X -C and for A .LE. X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE D9LGIC - DOUBLE PRECISION A, X, ALX, EPS, FK, P, R, S, T, XMA, XPA, D1MACH - SAVE EPS - DATA EPS / 0.D0 / -C***FIRST EXECUTABLE STATEMENT D9LGIC - IF (EPS.EQ.0.D0) EPS = 0.5D0*D1MACH(3) -C - XPA = X + 1.0D0 - A - XMA = X - 1.D0 - A -C - R = 0.D0 - P = 1.D0 - S = P - DO 10 K=1,300 - FK = K - T = FK*(A-FK)*(1.D0+R) - R = -T/((XMA+2.D0*FK)*(XPA+2.D0*FK)+T) - P = R*P - S = S + P - IF (ABS(P).LT.EPS*S) GO TO 20 - 10 CONTINUE - CALL XERMSG ('SLATEC', 'D9LGIC', - + 'NO CONVERGENCE IN 300 TERMS OF CONTINUED FRACTION', 1, 2) -C - 20 D9LGIC = A*ALX - X + LOG(S/XPA) -C - RETURN - END diff --git a/slatec/d9lgit.f b/slatec/d9lgit.f deleted file mode 100644 index 8cc79f1..0000000 --- a/slatec/d9lgit.f +++ /dev/null @@ -1,67 +0,0 @@ -*DECK D9LGIT - DOUBLE PRECISION FUNCTION D9LGIT (A, X, ALGAP1) -C***BEGIN PROLOGUE D9LGIT -C***SUBSIDIARY -C***PURPOSE Compute the logarithm of Tricomi's incomplete Gamma -C function with Perron's continued fraction for large X and -C A .GE. X. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE DOUBLE PRECISION (R9LGIT-S, D9LGIT-D) -C***KEYWORDS FNLIB, INCOMPLETE GAMMA FUNCTION, LOGARITHM, -C PERRON'S CONTINUED FRACTION, SPECIAL FUNCTIONS, TRICOMI -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Compute the log of Tricomi's incomplete gamma function with Perron's -C continued fraction for large X and for A .GE. X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE D9LGIT - DOUBLE PRECISION A, X, ALGAP1, AX, A1X, EPS, FK, HSTAR, P, R, S, - 1 SQEPS, T, D1MACH - LOGICAL FIRST - SAVE EPS, SQEPS, FIRST - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT D9LGIT - IF (FIRST) THEN - EPS = 0.5D0*D1MACH(3) - SQEPS = SQRT(D1MACH(4)) - ENDIF - FIRST = .FALSE. -C - IF (X .LE. 0.D0 .OR. A .LT. X) CALL XERMSG ('SLATEC', 'D9LGIT', - + 'X SHOULD BE GT 0.0 AND LE A', 2, 2) -C - AX = A + X - A1X = AX + 1.0D0 - R = 0.D0 - P = 1.D0 - S = P - DO 20 K=1,200 - FK = K - T = (A+FK)*X*(1.D0+R) - R = T/((AX+FK)*(A1X+FK)-T) - P = R*P - S = S + P - IF (ABS(P).LT.EPS*S) GO TO 30 - 20 CONTINUE - CALL XERMSG ('SLATEC', 'D9LGIT', - + 'NO CONVERGENCE IN 200 TERMS OF CONTINUED FRACTION', 3, 2) -C - 30 HSTAR = 1.0D0 - X*S/A1X - IF (HSTAR .LT. SQEPS) CALL XERMSG ('SLATEC', 'D9LGIT', - + 'RESULT LESS THAN HALF PRECISION', 1, 1) -C - D9LGIT = -X - ALGAP1 - LOG(HSTAR) - RETURN -C - END diff --git a/slatec/d9lgmc.f b/slatec/d9lgmc.f deleted file mode 100644 index 0b4b327..0000000 --- a/slatec/d9lgmc.f +++ /dev/null @@ -1,76 +0,0 @@ -*DECK D9LGMC - DOUBLE PRECISION FUNCTION D9LGMC (X) -C***BEGIN PROLOGUE D9LGMC -C***SUBSIDIARY -C***PURPOSE Compute the log Gamma correction factor so that -C LOG(DGAMMA(X)) = LOG(SQRT(2*PI)) + (X-5.)*LOG(X) - X -C + D9LGMC(X). -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE DOUBLE PRECISION (R9LGMC-S, D9LGMC-D, C9LGMC-C) -C***KEYWORDS COMPLETE GAMMA FUNCTION, CORRECTION TERM, FNLIB, -C LOG GAMMA, LOGARITHM, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Compute the log gamma correction factor for X .GE. 10. so that -C LOG (DGAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X + D9lGMC(X) -C -C Series for ALGM on the interval 0. to 1.00000E-02 -C with weighted error 1.28E-31 -C log weighted error 30.89 -C significant figures required 29.81 -C decimal places required 31.48 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 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 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE D9LGMC - DOUBLE PRECISION X, ALGMCS(15), XBIG, XMAX, DCSEVL, D1MACH - LOGICAL FIRST - SAVE ALGMCS, NALGM, XBIG, XMAX, FIRST - DATA ALGMCS( 1) / +.1666389480 4518632472 0572965082 2 D+0 / - DATA ALGMCS( 2) / -.1384948176 0675638407 3298605913 5 D-4 / - DATA ALGMCS( 3) / +.9810825646 9247294261 5717154748 7 D-8 / - DATA ALGMCS( 4) / -.1809129475 5724941942 6330626671 9 D-10 / - DATA ALGMCS( 5) / +.6221098041 8926052271 2601554341 6 D-13 / - DATA ALGMCS( 6) / -.3399615005 4177219443 0333059966 6 D-15 / - DATA ALGMCS( 7) / +.2683181998 4826987489 5753884666 6 D-17 / - DATA ALGMCS( 8) / -.2868042435 3346432841 4462239999 9 D-19 / - DATA ALGMCS( 9) / +.3962837061 0464348036 7930666666 6 D-21 / - DATA ALGMCS( 10) / -.6831888753 9857668701 1199999999 9 D-23 / - DATA ALGMCS( 11) / +.1429227355 9424981475 7333333333 3 D-24 / - DATA ALGMCS( 12) / -.3547598158 1010705471 9999999999 9 D-26 / - DATA ALGMCS( 13) / +.1025680058 0104709120 0000000000 0 D-27 / - DATA ALGMCS( 14) / -.3401102254 3167487999 9999999999 9 D-29 / - DATA ALGMCS( 15) / +.1276642195 6300629333 3333333333 3 D-30 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT D9LGMC - IF (FIRST) THEN - NALGM = INITDS (ALGMCS, 15, REAL(D1MACH(3)) ) - XBIG = 1.0D0/SQRT(D1MACH(3)) - XMAX = EXP (MIN(LOG(D1MACH(2)/12.D0), -LOG(12.D0*D1MACH(1)))) - ENDIF - FIRST = .FALSE. -C - IF (X .LT. 10.D0) CALL XERMSG ('SLATEC', 'D9LGMC', - + 'X MUST BE GE 10', 1, 2) - IF (X.GE.XMAX) GO TO 20 -C - D9LGMC = 1.D0/(12.D0*X) - IF (X.LT.XBIG) D9LGMC = DCSEVL (2.0D0*(10.D0/X)**2-1.D0, ALGMCS, - 1 NALGM) / X - RETURN -C - 20 D9LGMC = 0.D0 - CALL XERMSG ('SLATEC', 'D9LGMC', 'X SO BIG D9LGMC UNDERFLOWS', 2, - + 1) - RETURN -C - END diff --git a/slatec/d9ln2r.f b/slatec/d9ln2r.f deleted file mode 100644 index 1c63ed6..0000000 --- a/slatec/d9ln2r.f +++ /dev/null @@ -1,167 +0,0 @@ -*DECK D9LN2R - DOUBLE PRECISION FUNCTION D9LN2R (X) -C***BEGIN PROLOGUE D9LN2R -C***SUBSIDIARY -C***PURPOSE Evaluate LOG(1+X) from second order relative accuracy so -C that LOG(1+X) = X - X**2/2 + X**3*D9LN2R(X) -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4B -C***TYPE DOUBLE PRECISION (R9LN2R-S, D9LN2R-D, C9LN2R-C) -C***KEYWORDS ELEMENTARY FUNCTIONS, FNLIB, LOGARITHM, SECOND ORDER -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate LOG(1+X) from 2-nd order with relative error accuracy so -C that LOG(1+X) = X - X**2/2 + X**3*D9LN2R(X) -C -C Series for LN21 on the interval -6.25000E-01 to 0. -C with weighted error 1.82E-32 -C log weighted error 31.74 -C significant figures required 31.00 -C decimal places required 32.59 -C -C Series for LN22 on the interval 0. to 8.12500E-01 -C with weighted error 6.10E-32 -C log weighted error 31.21 -C significant figures required 30.32 -C decimal places required 32.00 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 780401 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 890911 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 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE D9LN2R - DOUBLE PRECISION X, XBIG, TXBIG, XMAX, TXMAX, XMIN, LN21CS(50), - * LN22CS(37), DCSEVL, D1MACH - LOGICAL FIRST - SAVE LN21CS, LN22CS, NTLN21, NTLN22, XMIN, XBIG, XMAX, FIRST - DATA LN21CS( 1) / +.1811196251 3478809875 8949530430 71 D+0 / - DATA LN21CS( 2) / -.1562712319 2872462669 6251555410 78 D+0 / - DATA LN21CS( 3) / +.2867630536 1557275209 5406271020 51 D-1 / - DATA LN21CS( 4) / -.5558699655 9481398781 1577251267 81 D-2 / - DATA LN21CS( 5) / +.1117897665 2299837657 3356662797 27 D-2 / - DATA LN21CS( 6) / -.2308050898 2327947182 2992795857 05 D-3 / - DATA LN21CS( 7) / +.4859885334 1100175874 6815580687 50 D-4 / - DATA LN21CS( 8) / -.1039012738 8903210765 5142426333 38 D-4 / - DATA LN21CS( 9) / +.2248456370 7390128494 6218049464 08 D-5 / - DATA LN21CS( 10) / -.4914059273 9266484875 3278025970 91 D-6 / - DATA LN21CS( 11) / +.1082825650 7077483336 6201529715 97 D-6 / - DATA LN21CS( 12) / -.2402587276 3420701435 9766754167 19 D-7 / - DATA LN21CS( 13) / +.5362460047 2708133762 9844432501 63 D-8 / - DATA LN21CS( 14) / -.1202995136 2138772264 6716464243 77 D-8 / - DATA LN21CS( 15) / +.2710788927 7591860785 6225516322 66 D-9 / - DATA LN21CS( 16) / -.6132356261 8319010068 7967284306 90 D-10 / - DATA LN21CS( 17) / +.1392085836 9159469857 4369085439 78 D-10 / - DATA LN21CS( 18) / -.3169930033 0223494015 2830572608 83 D-11 / - DATA LN21CS( 19) / +.7238375404 4307505335 2143261970 11 D-12 / - DATA LN21CS( 20) / -.1657001718 4764411391 4988055062 68 D-12 / - DATA LN21CS( 21) / +.3801842866 3117424257 3644226318 76 D-13 / - DATA LN21CS( 22) / -.8741118929 6972700259 7244298991 37 D-14 / - DATA LN21CS( 23) / +.2013561984 5055748302 1187510281 54 D-14 / - DATA LN21CS( 24) / -.4646445640 9033907031 1020081544 77 D-15 / - DATA LN21CS( 25) / +.1073928214 7018339453 4533385549 25 D-15 / - DATA LN21CS( 26) / -.2485853461 9937794755 5340218339 60 D-16 / - DATA LN21CS( 27) / +.5762019795 0800189813 8881426281 81 D-17 / - DATA LN21CS( 28) / -.1337306376 9804394701 4021999580 50 D-17 / - DATA LN21CS( 29) / +.3107465322 7331824966 5338071668 05 D-18 / - DATA LN21CS( 30) / -.7228810408 3040539906 9019579176 27 D-19 / - DATA LN21CS( 31) / +.1683378378 8037385103 3132581868 88 D-19 / - DATA LN21CS( 32) / -.3923946331 2069958052 5193727399 25 D-20 / - DATA LN21CS( 33) / +.9155146838 7536789746 3855286408 53 D-21 / - DATA LN21CS( 34) / -.2137889532 1320159520 9820958010 02 D-21 / - DATA LN21CS( 35) / +.4996450747 9047864699 8285645687 46 D-22 / - DATA LN21CS( 36) / -.1168624063 6080170135 3608061474 13 D-22 / - DATA LN21CS( 37) / +.2735312347 0391863775 6286867865 59 D-23 / - DATA LN21CS( 38) / -.6406802508 4792111965 0503458815 99 D-24 / - DATA LN21CS( 39) / +.1501629320 4334124162 9490719402 66 D-24 / - DATA LN21CS( 40) / -.3521737241 0398479759 4971450026 66 D-25 / - DATA LN21CS( 41) / +.8264390101 4814767012 4827333973 33 D-26 / - DATA LN21CS( 42) / -.1940493027 5943401918 0366178986 66 D-26 / - DATA LN21CS( 43) / +.4558788001 8841283562 4515884373 33 D-27 / - DATA LN21CS( 44) / -.1071549208 7545202154 3786250239 99 D-27 / - DATA LN21CS( 45) / +.2519940800 7927592978 0966741333 33 D-28 / - DATA LN21CS( 46) / -.5928908840 0120969341 7504768000 00 D-29 / - DATA LN21CS( 47) / +.1395586406 1057513058 2371532799 99 D-29 / - DATA LN21CS( 48) / -.3286457881 3478583431 4366975999 99 D-30 / - DATA LN21CS( 49) / +.7742496795 0478166247 2546986666 66 D-31 / - DATA LN21CS( 50) / -.1824773566 7260887638 1252266666 66 D-31 / - DATA LN22CS( 1) / -.2224253253 5020460829 8601522355 2 D+0 / - DATA LN22CS( 2) / -.6104710010 8078623986 8010475576 4 D-1 / - DATA LN22CS( 3) / +.7427235009 7503945905 1962975572 9 D-2 / - DATA LN22CS( 4) / -.9335018261 6369705656 1277960639 7 D-3 / - DATA LN22CS( 5) / +.1200499076 8726012833 5073128735 9 D-3 / - DATA LN22CS( 6) / -.1570472295 2820041128 2335260824 3 D-4 / - DATA LN22CS( 7) / +.2081874781 0512710960 5078359275 9 D-5 / - DATA LN22CS( 8) / -.2789195577 6467136540 5721305137 5 D-6 / - DATA LN22CS( 9) / +.3769355823 7601320584 2289513544 7 D-7 / - DATA LN22CS( 10) / -.5130902896 5277112582 4058993800 3 D-8 / - DATA LN22CS( 11) / +.7027141178 1506947382 0621821539 2 D-9 / - DATA LN22CS( 12) / -.9674859550 1343423892 4397200513 7 D-10 / - DATA LN22CS( 13) / +.1338104645 9248873065 8849644974 8 D-10 / - DATA LN22CS( 14) / -.1858102603 5340639816 2845384659 1 D-11 / - DATA LN22CS( 15) / +.2589294422 5279197493 0860012307 0 D-12 / - DATA LN22CS( 16) / -.3619568316 1415886744 6602538217 2 D-13 / - DATA LN22CS( 17) / +.5074037398 0166230880 0685891739 6 D-14 / - DATA LN22CS( 18) / -.7131012977 0311273027 0093874892 7 D-15 / - DATA LN22CS( 19) / +.1004490328 5545674818 5338678412 6 D-15 / - DATA LN22CS( 20) / -.1417906532 1840257919 0440507528 5 D-16 / - DATA LN22CS( 21) / +.2005297034 7433261178 9108639607 4 D-17 / - DATA LN22CS( 22) / -.2840996662 3398033053 6539671756 7 D-18 / - DATA LN22CS( 23) / +.4031469883 9690798995 9987866282 6 D-19 / - DATA LN22CS( 24) / -.5729325241 8322073204 5549895679 9 D-20 / - DATA LN22CS( 25) / +.8153488253 8900106758 4892873386 6 D-21 / - DATA LN22CS( 26) / -.1161825588 5497217876 0602746879 9 D-21 / - DATA LN22CS( 27) / +.1657516611 6625383436 5933977599 9 D-22 / - DATA LN22CS( 28) / -.2367336704 7108051901 1401728000 0 D-23 / - DATA LN22CS( 29) / +.3384670367 9755213860 7656959999 9 D-24 / - DATA LN22CS( 30) / -.4843940829 2157182042 9639679999 9 D-25 / - DATA LN22CS( 31) / +.6938759162 5142737186 7613866666 6 D-26 / - DATA LN22CS( 32) / -.9948142607 0314365719 2379733333 3 D-27 / - DATA LN22CS( 33) / +.1427440611 2116986106 3475200000 0 D-27 / - DATA LN22CS( 34) / -.2049794721 8982349115 6650666666 6 D-28 / - DATA LN22CS( 35) / +.2945648756 4013622228 8554666666 6 D-29 / - DATA LN22CS( 36) / -.4235973185 1849570276 6933333333 3 D-30 / - DATA LN22CS( 37) / +.6095532614 0038320401 0666666666 6 D-31 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT D9LN2R - IF (FIRST) THEN - EPS = D1MACH(3) - NTLN21 = INITDS (LN21CS, 50, 0.1*EPS) - NTLN22 = INITDS (LN22CS, 37, 0.1*EPS) -C - XMIN = -1.0D0 + SQRT(D1MACH(4)) - SQEPS = SQRT (EPS) - TXMAX = 8.0/SQEPS - XMAX = TXMAX - (EPS*TXMAX**2 - 2.D0*LOG(TXMAX)) - 1 / (2.D0*EPS*TXMAX) - TXBIG = 6.0/SQRT(SQEPS) - XBIG = TXBIG - (SQEPS*TXBIG**2 - 2.D0*LOG(TXBIG)) - 1 / (2.D0*SQEPS*TXBIG) - ENDIF - FIRST = .FALSE. -C - IF (X.LT.(-.625D0) .OR. X.GT.0.8125D0) GO TO 20 -C - IF (X.LT.0.0D0) D9LN2R = 0.375D0 + DCSEVL (16.D0*X/5.D0+1.D0, - 1 LN21CS, NTLN21) - IF (X.GE.0.0D0) D9LN2R = 0.375D0 + DCSEVL (32.D0*X/13.D0-1.D0, - 1 LN22CS, NTLN22) - RETURN -C - 20 IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'D9LN2R', - + 'ANSWER LT HALF PRECISION BECAUSE X IS TOO NEAR -1', 1, 1) - IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'D9LN2R', - + 'NO PRECISION IN ANSWER BECAUSE X IS TOO BIG', 3, 2) - IF (X .GT. XBIG) CALL XERMSG ('SLATEC', 'D9LN2R', - + 'ANSWER LT HALF PRECISION BECAUSE X IS TOO BIG', 2, 1) -C - D9LN2R = (LOG(1.D0+X) - X*(1.D0 - 0.5D0*X)) / X**3 - RETURN -C - END diff --git a/slatec/d9pak.f b/slatec/d9pak.f deleted file mode 100644 index c73db00..0000000 --- a/slatec/d9pak.f +++ /dev/null @@ -1,69 +0,0 @@ -*DECK D9PAK - DOUBLE PRECISION FUNCTION D9PAK (Y, N) -C***BEGIN PROLOGUE D9PAK -C***PURPOSE Pack a base 2 exponent into a floating point number. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY A6B -C***TYPE DOUBLE PRECISION (R9PAK-S, D9PAK-D) -C***KEYWORDS FNLIB, PACK -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Pack a base 2 exponent into floating point number X. This routine is -C almost the inverse of D9UPAK. It is not exactly the inverse, because -C ABS(X) need not be between 0.5 and 1.0. If both D9PAK and 2.d0**N -C were known to be in range we could compute -C D9PAK = X *2.0d0**N -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, D9UPAK, I1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 891009 Corrected error when XERROR called. (WRB) -C 891009 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 901009 Routine used I1MACH(7) where it should use I1MACH(10), -C Corrected (RWC) -C***END PROLOGUE D9PAK - DOUBLE PRECISION Y, A1N2B,A1N210,D1MACH - LOGICAL FIRST - SAVE NMIN, NMAX, A1N210, FIRST - DATA A1N210 / 3.321928094 8873623478 7031942948 9 D0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT D9PAK - IF (FIRST) THEN - A1N2B = 1.0D0 - IF(I1MACH(10).NE.2) A1N2B=D1MACH(5)*A1N210 - NMIN = A1N2B*I1MACH(15) - NMAX = A1N2B*I1MACH(16) - ENDIF - FIRST = .FALSE. -C - CALL D9UPAK(Y,D9PAK,NY) -C - NSUM=N+NY - IF(NSUM.LT.NMIN)GO TO 40 - IF (NSUM .GT. NMAX) CALL XERMSG ('SLATEC', 'D9PAK', - + 'PACKED NUMBER OVERFLOWS', 1, 2) -C - IF (NSUM.EQ.0) RETURN - IF(NSUM.GT.0) GO TO 30 -C - 20 D9PAK = 0.5D0*D9PAK - NSUM=NSUM+1 - IF(NSUM.NE.0) GO TO 20 - RETURN -C - 30 D9PAK = 2.0D0*D9PAK - NSUM=NSUM - 1 - IF (NSUM.NE.0) GO TO 30 - RETURN -C - 40 CALL XERMSG ('SLATEC', 'D9PAK', 'PACKED NUMBER UNDERFLOWS', 1, 1) - D9PAK = 0.0D0 - RETURN -C - END diff --git a/slatec/d9upak.f b/slatec/d9upak.f deleted file mode 100644 index 596ccca..0000000 --- a/slatec/d9upak.f +++ /dev/null @@ -1,44 +0,0 @@ -*DECK D9UPAK - SUBROUTINE D9UPAK (X, Y, N) -C***BEGIN PROLOGUE D9UPAK -C***PURPOSE Unpack a floating point number X so that X = Y*2**N. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY A6B -C***TYPE DOUBLE PRECISION (R9UPAK-S, D9UPAK-D) -C***KEYWORDS FNLIB, UNPACK -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Unpack a floating point number X so that X = Y*2.0**N, where -C 0.5 .LE. ABS(Y) .LT. 1.0. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 780701 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 900820 Corrected code to find Y between 0.5 and 1.0 rather than -C between 0.05 and 1.0. (WRB) -C***END PROLOGUE D9UPAK - DOUBLE PRECISION X,Y,ABSX -C***FIRST EXECUTABLE STATEMENT D9UPAK - ABSX = ABS(X) - N = 0 - IF (X.EQ.0.0D0) GO TO 30 -C - 10 IF (ABSX.GE.0.5D0) GO TO 20 - N = N-1 - ABSX = ABSX*2.0D0 - GO TO 10 -C - 20 IF (ABSX.LT.1.0D0) GO TO 30 - N = N+1 - ABSX = ABSX*0.5D0 - GO TO 20 -C - 30 Y = SIGN(ABSX,X) - RETURN -C - END diff --git a/slatec/dacosh.f b/slatec/dacosh.f deleted file mode 100644 index 06cfb3f..0000000 --- a/slatec/dacosh.f +++ /dev/null @@ -1,40 +0,0 @@ -*DECK DACOSH - DOUBLE PRECISION FUNCTION DACOSH (X) -C***BEGIN PROLOGUE DACOSH -C***PURPOSE Compute the arc hyperbolic cosine. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4C -C***TYPE DOUBLE PRECISION (ACOSH-S, DACOSH-D, CACOSH-C) -C***KEYWORDS ACOSH, ARC HYPERBOLIC COSINE, ELEMENTARY FUNCTIONS, FNLIB, -C INVERSE HYPERBOLIC COSINE -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DACOSH(X) calculates the double precision arc hyperbolic cosine for -C double precision argument X. The result is returned on the -C positive branch. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 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***END PROLOGUE DACOSH - DOUBLE PRECISION X, DLN2, XMAX, D1MACH - SAVE DLN2, XMAX - DATA DLN2 / 0.6931471805 5994530941 7232121458 18 D0 / - DATA XMAX / 0.D0 / -C***FIRST EXECUTABLE STATEMENT DACOSH - IF (XMAX.EQ.0.D0) XMAX = 1.0D0/SQRT(D1MACH(3)) -C - IF (X .LT. 1.D0) CALL XERMSG ('SLATEC', 'DACOSH', - + 'X LESS THAN 1', 1, 2) -C - IF (X.LT.XMAX) DACOSH = LOG (X+SQRT(X*X-1.0D0)) - IF (X.GE.XMAX) DACOSH = DLN2 + LOG(X) -C - RETURN - END diff --git a/slatec/dai.f b/slatec/dai.f deleted file mode 100644 index 33abca8..0000000 --- a/slatec/dai.f +++ /dev/null @@ -1,100 +0,0 @@ -*DECK DAI - DOUBLE PRECISION FUNCTION DAI (X) -C***BEGIN PROLOGUE DAI -C***PURPOSE Evaluate the Airy function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10D -C***TYPE DOUBLE PRECISION (AI-S, DAI-D) -C***KEYWORDS AIRY FUNCTION, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DAI(X) calculates the double precision Airy function for double -C precision argument X. -C -C Series for AIF on the interval -1.00000E+00 to 1.00000E+00 -C with weighted error 8.37E-33 -C log weighted error 32.08 -C significant figures required 30.87 -C decimal places required 32.63 -C -C Series for AIG on the interval -1.00000E+00 to 1.00000E+00 -C with weighted error 7.47E-34 -C log weighted error 33.13 -C significant figures required 31.50 -C decimal places required 33.68 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, D9AIMP, DAIE, DCSEVL, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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 920618 Removed space from variable names. (RWC, WRB) -C***END PROLOGUE DAI - DOUBLE PRECISION X, AIFCS(13), AIGCS(13), THETA, XM, XMAX, X3SML, - 1 Z, D1MACH, DCSEVL, DAIE, XMAXT - LOGICAL FIRST - SAVE AIFCS, AIGCS, NAIF, NAIG, X3SML, XMAX, FIRST - DATA AIFCS( 1) / -.3797135849 6669997496 1970894694 14 D-1 / - DATA AIFCS( 2) / +.5919188853 7263638574 3197280137 77 D-1 / - DATA AIFCS( 3) / +.9862928057 7279975365 6038910440 60 D-3 / - DATA AIFCS( 4) / +.6848843819 0765667554 8548301824 12 D-5 / - DATA AIFCS( 5) / +.2594202596 2194713019 4892790814 03 D-7 / - DATA AIFCS( 6) / +.6176612774 0813750329 4457496972 36 D-10 / - DATA AIFCS( 7) / +.1009245417 2466117901 4295562246 01 D-12 / - DATA AIFCS( 8) / +.1201479251 1179938141 2880332253 33 D-15 / - DATA AIFCS( 9) / +.1088294558 8716991878 5252954666 66 D-18 / - DATA AIFCS( 10) / +.7751377219 6684887039 2384000000 00 D-22 / - DATA AIFCS( 11) / +.4454811203 7175638391 4666666666 66 D-25 / - DATA AIFCS( 12) / +.2109284523 1692343466 6666666666 66 D-28 / - DATA AIFCS( 13) / +.8370173591 0741333333 3333333333 33 D-32 / - DATA AIGCS( 1) / +.1815236558 1161273011 5562099578 64 D-1 / - DATA AIGCS( 2) / +.2157256316 6010755534 0306388199 68 D-1 / - DATA AIGCS( 3) / +.2567835698 7483249659 0524280901 33 D-3 / - DATA AIGCS( 4) / +.1426521411 9792403898 8294969217 21 D-5 / - DATA AIGCS( 5) / +.4572114920 0180426070 4340975581 91 D-8 / - DATA AIGCS( 6) / +.9525170843 5647098607 3922788405 92 D-11 / - DATA AIGCS( 7) / +.1392563460 5771399051 1504206861 90 D-13 / - DATA AIGCS( 8) / +.1507099914 2762379592 3069911386 66 D-16 / - DATA AIGCS( 9) / +.1255914831 2567778822 7032053333 33 D-19 / - DATA AIGCS( 10) / +.8306307377 0821340343 8293333333 33 D-23 / - DATA AIGCS( 11) / +.4465753849 3718567445 3333333333 33 D-26 / - DATA AIGCS( 12) / +.1990085503 4518869333 3333333333 33 D-29 / - DATA AIGCS( 13) / +.7470288525 6533333333 3333333333 33 D-33 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DAI - IF (FIRST) THEN - NAIF = INITDS (AIFCS, 13, 0.1*REAL(D1MACH(3))) - NAIG = INITDS (AIGCS, 13, 0.1*REAL(D1MACH(3))) -C - X3SML = D1MACH(3)**0.3334D0 - XMAXT = (-1.5D0*LOG(D1MACH(1)))**0.6667D0 - XMAX = XMAXT - XMAXT*LOG(XMAXT)/(4.0D0*SQRT(XMAXT)+1.0D0) - * - 0.01D0 - ENDIF - FIRST = .FALSE. -C - IF (X.GE.(-1.D0)) GO TO 20 - CALL D9AIMP (X, XM, THETA) - DAI = XM * COS(THETA) - RETURN -C - 20 IF (X.GT.1.0D0) GO TO 30 - Z = 0.0D0 - IF (ABS(X).GT.X3SML) Z = X**3 - DAI = 0.375D0 + (DCSEVL (Z, AIFCS, NAIF) - X*(0.25D0 + - 1 DCSEVL (Z, AIGCS, NAIG)) ) - RETURN -C - 30 IF (X.GT.XMAX) GO TO 40 - DAI = DAIE(X) * EXP(-2.0D0*X*SQRT(X)/3.0D0) - RETURN -C - 40 DAI = 0.0D0 - CALL XERMSG ('SLATEC', 'DAI', 'X SO BIG AI UNDERFLOWS', 1, 1) - RETURN -C - END diff --git a/slatec/daie.f b/slatec/daie.f deleted file mode 100644 index 098cf22..0000000 --- a/slatec/daie.f +++ /dev/null @@ -1,220 +0,0 @@ -*DECK DAIE - DOUBLE PRECISION FUNCTION DAIE (X) -C***BEGIN PROLOGUE DAIE -C***PURPOSE Calculate the Airy function for a negative argument and an -C exponentially scaled Airy function for a non-negative -C argument. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10D -C***TYPE DOUBLE PRECISION (AIE-S, DAIE-D) -C***KEYWORDS EXPONENTIALLY SCALED AIRY FUNCTION, FNLIB, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DAIE(X) calculates the Airy function or the exponentially scaled -C Airy function depending on the value of the argument. The function -C and argument are both double precision. -C -C Evaluate AI(X) for X .LE. 0.0 and AI(X)*EXP(ZETA) where -C ZETA = 2/3 * X**(3/2) for X .GE. 0.0 -C -C Series for AIF on the interval -1.00000E+00 to 1.00000E+00 -C with weighted error 8.37E-33 -C log weighted error 32.08 -C significant figures required 30.87 -C decimal places required 32.63 -C -C Series for AIG on the interval -1.00000E+00 to 1.00000E+00 -C with weighted error 7.47E-34 -C log weighted error 33.13 -C significant figures required 31.50 -C decimal places required 33.68 -C -C Series for AIP1 on the interval 1.25000E-01 to 1.00000E+00 -C with weighted error 3.69E-32 -C log weighted error 31.43 -C significant figures required 29.55 -C decimal places required 32.31 -C -C Series for AIP2 on the interval 0. to 1.25000E-01 -C with weighted error 3.48E-32 -C log weighted error 31.46 -C significant figures required 28.74 -C decimal places required 32.24 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, D9AIMP, DCSEVL, INITDS -C***REVISION HISTORY (YYMMDD) -C 770701 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 920618 Removed space from variable names. (RWC, WRB) -C***END PROLOGUE DAIE - DOUBLE PRECISION X, AIFCS(13), AIGCS(13), AIP1CS(57), AIP2CS(37), - 1 SQRTX, THETA, XBIG, XM, X3SML, X32SML, Z, D1MACH, DCSEVL - LOGICAL FIRST - SAVE AIFCS, AIGCS, AIP1CS, AIP2CS, NAIF, NAIG, NAIP1, - 1 NAIP2, X3SML, X32SML, XBIG, FIRST - DATA AIFCS( 1) / -.3797135849 6669997496 1970894694 14 D-1 / - DATA AIFCS( 2) / +.5919188853 7263638574 3197280137 77 D-1 / - DATA AIFCS( 3) / +.9862928057 7279975365 6038910440 60 D-3 / - DATA AIFCS( 4) / +.6848843819 0765667554 8548301824 12 D-5 / - DATA AIFCS( 5) / +.2594202596 2194713019 4892790814 03 D-7 / - DATA AIFCS( 6) / +.6176612774 0813750329 4457496972 36 D-10 / - DATA AIFCS( 7) / +.1009245417 2466117901 4295562246 01 D-12 / - DATA AIFCS( 8) / +.1201479251 1179938141 2880332253 33 D-15 / - DATA AIFCS( 9) / +.1088294558 8716991878 5252954666 66 D-18 / - DATA AIFCS( 10) / +.7751377219 6684887039 2384000000 00 D-22 / - DATA AIFCS( 11) / +.4454811203 7175638391 4666666666 66 D-25 / - DATA AIFCS( 12) / +.2109284523 1692343466 6666666666 66 D-28 / - DATA AIFCS( 13) / +.8370173591 0741333333 3333333333 33 D-32 / - DATA AIGCS( 1) / +.1815236558 1161273011 5562099578 64 D-1 / - DATA AIGCS( 2) / +.2157256316 6010755534 0306388199 68 D-1 / - DATA AIGCS( 3) / +.2567835698 7483249659 0524280901 33 D-3 / - DATA AIGCS( 4) / +.1426521411 9792403898 8294969217 21 D-5 / - DATA AIGCS( 5) / +.4572114920 0180426070 4340975581 91 D-8 / - DATA AIGCS( 6) / +.9525170843 5647098607 3922788405 92 D-11 / - DATA AIGCS( 7) / +.1392563460 5771399051 1504206861 90 D-13 / - DATA AIGCS( 8) / +.1507099914 2762379592 3069911386 66 D-16 / - DATA AIGCS( 9) / +.1255914831 2567778822 7032053333 33 D-19 / - DATA AIGCS( 10) / +.8306307377 0821340343 8293333333 33 D-23 / - DATA AIGCS( 11) / +.4465753849 3718567445 3333333333 33 D-26 / - DATA AIGCS( 12) / +.1990085503 4518869333 3333333333 33 D-29 / - DATA AIGCS( 13) / +.7470288525 6533333333 3333333333 33 D-33 / - DATA AIP1CS( 1) / -.2146951858 9105384554 6086346777 8 D-1 / - DATA AIP1CS( 2) / -.7535382535 0433011662 1972086556 5 D-2 / - DATA AIP1CS( 3) / +.5971527949 0263808520 3538888199 4 D-3 / - DATA AIP1CS( 4) / -.7283251254 2076106485 0236829154 8 D-4 / - DATA AIP1CS( 5) / +.1110297130 7392996665 1738182114 0 D-4 / - DATA AIP1CS( 6) / -.1950386152 2844057103 4693031403 3 D-5 / - DATA AIP1CS( 7) / +.3786973885 1595151938 8531967005 7 D-6 / - DATA AIP1CS( 8) / -.7929675297 3509782790 3907287915 4 D-7 / - DATA AIP1CS( 9) / +.1762247638 6742560755 6842012220 2 D-7 / - DATA AIP1CS( 10) / -.4110767539 6671950450 2989659389 3 D-8 / - DATA AIP1CS( 11) / +.9984770057 8578922471 8341410754 4 D-9 / - DATA AIP1CS( 12) / -.2510093251 3871222113 4986773003 4 D-9 / - DATA AIP1CS( 13) / +.6500501929 8606954092 7203860172 5 D-10 / - DATA AIP1CS( 14) / -.1727818405 3936165154 7887710736 6 D-10 / - DATA AIP1CS( 15) / +.4699378842 8245125783 6229287230 7 D-11 / - DATA AIP1CS( 16) / -.1304675656 2977439144 9124124627 2 D-11 / - DATA AIP1CS( 17) / +.3689698478 4626788104 7394838228 2 D-12 / - DATA AIP1CS( 18) / -.1061087206 6468061736 5035967903 5 D-12 / - DATA AIP1CS( 19) / +.3098414384 8781874386 6021007011 0 D-13 / - DATA AIP1CS( 20) / -.9174908079 8241393078 3342354785 1 D-14 / - DATA AIP1CS( 21) / +.2752049140 3472108956 9357906227 1 D-14 / - DATA AIP1CS( 22) / -.8353750115 9220465580 9139330188 0 D-15 / - DATA AIP1CS( 23) / +.2563931129 3579349475 6863616861 2 D-15 / - DATA AIP1CS( 24) / -.7950633762 5988549832 7374728982 2 D-16 / - DATA AIP1CS( 25) / +.2489283634 6030699774 3728117564 4 D-16 / - DATA AIP1CS( 26) / -.7864326933 9287355696 6462622129 6 D-17 / - DATA AIP1CS( 27) / +.2505687311 4399756723 2447064501 9 D-17 / - DATA AIP1CS( 28) / -.8047420364 1639095245 3795868224 1 D-18 / - DATA AIP1CS( 29) / +.2604097118 9520539644 4340110439 2 D-18 / - DATA AIP1CS( 30) / -.8486954164 0564122594 8248883418 4 D-19 / - DATA AIP1CS( 31) / +.2784706882 1423378433 5942918602 7 D-19 / - DATA AIP1CS( 32) / -.9195858953 4986129136 8722415135 4 D-20 / - DATA AIP1CS( 33) / +.3055304318 3742387422 4766822558 3 D-20 / - DATA AIP1CS( 34) / -.1021035455 4794778759 0217704843 9 D-20 / - DATA AIP1CS( 35) / +.3431118190 7437578440 0055568083 6 D-21 / - DATA AIP1CS( 36) / -.1159129341 7977495133 7692246310 9 D-21 / - DATA AIP1CS( 37) / +.3935772844 2002556108 3626822915 4 D-22 / - DATA AIP1CS( 38) / -.1342880980 2967176119 5671898903 8 D-22 / - DATA AIP1CS( 39) / +.4603287883 5200027416 5919030531 4 D-23 / - DATA AIP1CS( 40) / -.1585043927 0040642278 1077249938 7 D-23 / - DATA AIP1CS( 41) / +.5481275667 7296759089 2552375500 8 D-24 / - DATA AIP1CS( 42) / -.1903349371 8550472590 6401794894 5 D-24 / - DATA AIP1CS( 43) / +.6635682302 3740087167 7761211596 8 D-25 / - DATA AIP1CS( 44) / -.2322311650 0263143079 7520098645 3 D-25 / - DATA AIP1CS( 45) / +.8157640113 4291793131 4274369535 9 D-26 / - DATA AIP1CS( 46) / -.2875824240 6329004900 5748992955 7 D-26 / - DATA AIP1CS( 47) / +.1017329450 9429014350 7971431901 8 D-26 / - DATA AIP1CS( 48) / -.3610879108 7422164465 7570349055 9 D-27 / - DATA AIP1CS( 49) / +.1285788540 3639934212 5664034269 8 D-27 / - DATA AIP1CS( 50) / -.4592901037 3785474251 6069302271 9 D-28 / - DATA AIP1CS( 51) / +.1645597033 8207137258 1210248533 3 D-28 / - DATA AIP1CS( 52) / -.5913421299 8435018420 8792027136 0 D-29 / - DATA AIP1CS( 53) / +.2131057006 6049933034 7936950954 6 D-29 / - DATA AIP1CS( 54) / -.7701158157 7875982169 8276174506 6 D-30 / - DATA AIP1CS( 55) / +.2790533307 9689304175 8178377728 0 D-30 / - DATA AIP1CS( 56) / -.1013807715 1112840064 5224136703 9 D-30 / - DATA AIP1CS( 57) / +.3692580158 7196240936 5828621653 3 D-31 / - DATA AIP2CS( 1) / -.1743144969 2937551339 0355844011 D-2 / - DATA AIP2CS( 2) / -.1678938543 2554167163 2190613480 D-2 / - DATA AIP2CS( 3) / +.3596534033 5216603588 5983858114 D-4 / - DATA AIP2CS( 4) / -.1380818602 7392283545 7399383100 D-5 / - DATA AIP2CS( 5) / +.7411228077 3150529884 8699095233 D-7 / - DATA AIP2CS( 6) / -.5002382039 0013301313 0422866325 D-8 / - DATA AIP2CS( 7) / +.4006939174 1718424067 5446866355 D-9 / - DATA AIP2CS( 8) / -.3673312427 9590504419 9318496207 D-10 / - DATA AIP2CS( 9) / +.3760344395 9237385243 9592002918 D-11 / - DATA AIP2CS( 10) / -.4223213327 1874753802 6564938968 D-12 / - DATA AIP2CS( 11) / +.5135094540 3365707091 9618754120 D-13 / - DATA AIP2CS( 12) / -.6690958503 9047759565 1681356676 D-14 / - DATA AIP2CS( 13) / +.9266675456 4129064823 9550724382 D-15 / - DATA AIP2CS( 14) / -.1355143824 1607057633 3397356591 D-15 / - DATA AIP2CS( 15) / +.2081154963 1283099529 9006549335 D-16 / - DATA AIP2CS( 16) / -.3341164991 5917685687 1277570256 D-17 / - DATA AIP2CS( 17) / +.5585785845 8592431686 8032946585 D-18 / - DATA AIP2CS( 18) / -.9692190401 5236524751 8658209109 D-19 / - DATA AIP2CS( 19) / +.1740457001 2889320646 5696557738 D-19 / - DATA AIP2CS( 20) / -.3226409797 3113040024 7846333098 D-20 / - DATA AIP2CS( 21) / +.6160744711 0662525853 3259618986 D-21 / - DATA AIP2CS( 22) / -.1209363479 8249005907 6420676266 D-21 / - DATA AIP2CS( 23) / +.2436327633 1013810826 1570095786 D-22 / - DATA AIP2CS( 24) / -.5029142214 9745746894 3403144533 D-23 / - DATA AIP2CS( 25) / +.1062241755 4363568949 5470626133 D-23 / - DATA AIP2CS( 26) / -.2292842848 9598924150 9856324266 D-24 / - DATA AIP2CS( 27) / +.5051817339 2950374498 6884778666 D-25 / - DATA AIP2CS( 28) / -.1134981237 1441240497 9793920000 D-25 / - DATA AIP2CS( 29) / +.2597655659 8560698069 8374144000 D-26 / - DATA AIP2CS( 30) / -.6051246215 4293950617 2231679999 D-27 / - DATA AIP2CS( 31) / +.1433597779 6677280072 0295253333 D-27 / - DATA AIP2CS( 32) / -.3451477570 6089998628 0721066666 D-28 / - DATA AIP2CS( 33) / +.8438751902 1364674042 7025066666 D-29 / - DATA AIP2CS( 34) / -.2093961422 9818816943 4453333333 D-29 / - DATA AIP2CS( 35) / +.5270088734 7894550318 2848000000 D-30 / - DATA AIP2CS( 36) / -.1344574330 1455338578 9030399999 D-30 / - DATA AIP2CS( 37) / +.3475709645 2660114734 0117333333 D-31 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DAIE - IF (FIRST) THEN - ETA = 0.1*REAL(D1MACH(3)) - NAIF = INITDS (AIFCS, 13, ETA) - NAIG = INITDS (AIGCS, 13, ETA) - NAIP1 = INITDS (AIP1CS, 57, ETA) - NAIP2 = INITDS (AIP2CS, 37, ETA) -C - X3SML = ETA**0.3333E0 - X32SML = 1.3104D0*X3SML**2 - XBIG = D1MACH(2)**0.6666D0 - ENDIF - FIRST = .FALSE. -C - IF (X.GE.(-1.0D0)) GO TO 20 - CALL D9AIMP (X, XM, THETA) - DAIE = XM * COS(THETA) - RETURN -C - 20 IF (X.GT.1.0D0) GO TO 30 - Z = 0.0D0 - IF (ABS(X).GT.X3SML) Z = X**3 - DAIE = 0.375D0 + (DCSEVL (Z, AIFCS, NAIF) - X*(0.25D0 + - 1 DCSEVL (Z, AIGCS, NAIG)) ) - IF (X.GT.X32SML) DAIE = DAIE * EXP (2.0D0*X*SQRT(X)/3.0D0) - RETURN -C - 30 IF (X.GT.4.0D0) GO TO 40 - SQRTX = SQRT(X) - Z = (16.D0/(X*SQRTX) - 9.D0)/7.D0 - DAIE = (0.28125D0 + DCSEVL (Z, AIP1CS, NAIP1))/SQRT(SQRTX) - RETURN -C - 40 SQRTX = SQRT(X) - Z = -1.0D0 - IF (X.LT.XBIG) Z = 16.0D0/(X*SQRTX) - 1.0D0 - DAIE = (0.28125D0 + DCSEVL (Z, AIP2CS, NAIP2))/SQRT(SQRTX) - RETURN -C - END diff --git a/slatec/dasinh.f b/slatec/dasinh.f deleted file mode 100644 index 7836777..0000000 --- a/slatec/dasinh.f +++ /dev/null @@ -1,89 +0,0 @@ -*DECK DASINH - DOUBLE PRECISION FUNCTION DASINH (X) -C***BEGIN PROLOGUE DASINH -C***PURPOSE Compute the arc hyperbolic sine. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4C -C***TYPE DOUBLE PRECISION (ASINH-S, DASINH-D, CASINH-C) -C***KEYWORDS ARC HYPERBOLIC SINE, ASINH, ELEMENTARY FUNCTIONS, FNLIB, -C INVERSE HYPERBOLIC SINE -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DASINH(X) calculates the double precision arc hyperbolic -C sine for double precision argument X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DCSEVL, INITDS -C***REVISION HISTORY (YYMMDD) -C 770601 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***END PROLOGUE DASINH - DOUBLE PRECISION X, ASNHCS(39), ALN2, SQEPS, XMAX, Y, - 1 DCSEVL, D1MACH - LOGICAL FIRST - SAVE ASNHCS, ALN2, NTERMS, XMAX, SQEPS, FIRST - DATA ASNHCS( 1) / -.1282003991 1738186343 3721273592 68 D+0 / - DATA ASNHCS( 2) / -.5881176118 9951767565 2117571383 62 D-1 / - DATA ASNHCS( 3) / +.4727465432 2124815640 7252497560 29 D-2 / - DATA ASNHCS( 4) / -.4938363162 6536172101 3601747902 73 D-3 / - DATA ASNHCS( 5) / +.5850620705 8557412287 4948352593 21 D-4 / - DATA ASNHCS( 6) / -.7466998328 9313681354 7550692171 88 D-5 / - DATA ASNHCS( 7) / +.1001169358 3558199265 9661920158 12 D-5 / - DATA ASNHCS( 8) / -.1390354385 8708333608 6164722588 86 D-6 / - DATA ASNHCS( 9) / +.1982316948 3172793547 3173602371 48 D-7 / - DATA ASNHCS( 10) / -.2884746841 7848843612 7472728003 17 D-8 / - DATA ASNHCS( 11) / +.4267296546 7159937953 4575149959 07 D-9 / - DATA ASNHCS( 12) / -.6397608465 4366357868 7526323096 81 D-10 / - DATA ASNHCS( 13) / +.9699168608 9064704147 8782931311 79 D-11 / - DATA ASNHCS( 14) / -.1484427697 2043770830 2466583656 96 D-11 / - DATA ASNHCS( 15) / +.2290373793 9027447988 0401843789 83 D-12 / - DATA ASNHCS( 16) / -.3558839513 2732645159 9789426513 10 D-13 / - DATA ASNHCS( 17) / +.5563969408 0056789953 3745390885 54 D-14 / - DATA ASNHCS( 18) / -.8746250959 9624678045 6665935201 62 D-15 / - DATA ASNHCS( 19) / +.1381524884 4526692155 8688022981 29 D-15 / - DATA ASNHCS( 20) / -.2191668828 2900363984 9551422641 49 D-16 / - DATA ASNHCS( 21) / +.3490465852 4827565638 3139237068 80 D-17 / - DATA ASNHCS( 22) / -.5578578840 0895742439 6301570321 06 D-18 / - DATA ASNHCS( 23) / +.8944514661 7134012551 0508827989 33 D-19 / - DATA ASNHCS( 24) / -.1438342634 6571317305 5518452394 66 D-19 / - DATA ASNHCS( 25) / +.2319181187 2169963036 3261446826 66 D-20 / - DATA ASNHCS( 26) / -.3748700795 3314343674 5706045439 99 D-21 / - DATA ASNHCS( 27) / +.6073210982 2064279404 5492428800 00 D-22 / - DATA ASNHCS( 28) / -.9859940276 4633583177 3701734400 00 D-23 / - DATA ASNHCS( 29) / +.1603921745 2788496315 2326382933 33 D-23 / - DATA ASNHCS( 30) / -.2613884735 0287686596 7161343999 99 D-24 / - DATA ASNHCS( 31) / +.4267084960 6857390833 3581653333 33 D-25 / - DATA ASNHCS( 32) / -.6977021703 9185243299 7307733333 33 D-26 / - DATA ASNHCS( 33) / +.1142508833 6806858659 8126933333 33 D-26 / - DATA ASNHCS( 34) / -.1873529207 8860968933 0210133333 33 D-27 / - DATA ASNHCS( 35) / +.3076358441 4464922794 0659200000 00 D-28 / - DATA ASNHCS( 36) / -.5057736403 1639824787 0463999999 99 D-29 / - DATA ASNHCS( 37) / +.8325075471 2689142224 2133333333 33 D-30 / - DATA ASNHCS( 38) / -.1371845728 2501044163 9253333333 33 D-30 / - DATA ASNHCS( 39) / +.2262986842 6552784104 1066666666 66 D-31 / - DATA ALN2 / 0.6931471805 5994530941 7232121458 18D0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DASINH - IF (FIRST) THEN - NTERMS = INITDS (ASNHCS, 39, 0.1*REAL(D1MACH(3)) ) - SQEPS = SQRT(D1MACH(3)) - XMAX = 1.0D0/SQEPS - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.1.0D0) GO TO 20 -C - DASINH = X - IF (Y.GT.SQEPS) DASINH = X*(1.0D0 + DCSEVL (2.D0*X*X-1.D0, - 1 ASNHCS, NTERMS) ) - RETURN - 20 IF (Y.LT.XMAX) DASINH = LOG (Y+SQRT(Y*Y+1.D0)) - IF (Y.GE.XMAX) DASINH = ALN2 + LOG(Y) - DASINH = SIGN (DASINH, X) - RETURN -C - END diff --git a/slatec/dasum.f b/slatec/dasum.f deleted file mode 100644 index 6165e55..0000000 --- a/slatec/dasum.f +++ /dev/null @@ -1,80 +0,0 @@ -*DECK DASUM - DOUBLE PRECISION FUNCTION DASUM (N, DX, INCX) -C***BEGIN PROLOGUE DASUM -C***PURPOSE Compute the sum of the magnitudes of the elements of a -C vector. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A3A -C***TYPE DOUBLE PRECISION (SASUM-S, DASUM-D, SCASUM-C) -C***KEYWORDS BLAS, LINEAR ALGEBRA, SUM OF MAGNITUDES OF A 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 DX double precision vector with N elements -C INCX storage spacing between elements of DX -C -C --Output-- -C DASUM double precision result (zero if N .LE. 0) -C -C Returns sum of magnitudes of double precision DX. -C DASUM = sum from 0 to N-1 of ABS(DX(IX+I*INCX)), -C where IX = 1 if INCX .GE. 0, else IX = 1+(1-N)*INCX. -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 890531 Changed all specific intrinsics to generic. (WRB) -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 900821 Modified to correct problem with a negative increment. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DASUM - DOUBLE PRECISION DX(*) - INTEGER I, INCX, IX, M, MP1, N -C***FIRST EXECUTABLE STATEMENT DASUM - DASUM = 0.0D0 - IF (N .LE. 0) RETURN -C - IF (INCX .EQ. 1) GOTO 20 -C -C Code for increment not equal to 1. -C - IX = 1 - IF (INCX .LT. 0) IX = (-N+1)*INCX + 1 - DO 10 I = 1,N - DASUM = DASUM + ABS(DX(IX)) - IX = IX + INCX - 10 CONTINUE - RETURN -C -C Code for increment equal to 1. -C -C Clean-up loop so remaining vector length is a multiple of 6. -C - 20 M = MOD(N,6) - IF (M .EQ. 0) GOTO 40 - DO 30 I = 1,M - DASUM = DASUM + ABS(DX(I)) - 30 CONTINUE - IF (N .LT. 6) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,6 - DASUM = DASUM + ABS(DX(I)) + ABS(DX(I+1)) + ABS(DX(I+2)) + - 1 ABS(DX(I+3)) + ABS(DX(I+4)) + ABS(DX(I+5)) - 50 CONTINUE - RETURN - END diff --git a/slatec/dasyik.f b/slatec/dasyik.f deleted file mode 100644 index a999e26..0000000 --- a/slatec/dasyik.f +++ /dev/null @@ -1,145 +0,0 @@ -*DECK DASYIK - SUBROUTINE DASYIK (X, FNU, KODE, FLGIK, RA, ARG, IN, Y) -C***BEGIN PROLOGUE DASYIK -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBESI and DBESK -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (ASYIK-S, DASYIK-D) -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C DASYIK computes Bessel functions I and K -C for arguments X.GT.0.0 and orders FNU.GE.35 -C on FLGIK = 1 and FLGIK = -1 respectively. -C -C INPUT -C -C X - Argument, X.GT.0.0D0 -C FNU - Order of first Bessel function -C KODE - A parameter to indicate the scaling option -C KODE=1 returns Y(I)= I/SUB(FNU+I-1)/(X), I=1,IN -C or Y(I)= K/SUB(FNU+I-1)/(X), I=1,IN -C on FLGIK = 1.0D0 or FLGIK = -1.0D0 -C KODE=2 returns Y(I)=EXP(-X)*I/SUB(FNU+I-1)/(X), I=1,IN -C or Y(I)=EXP( X)*K/SUB(FNU+I-1)/(X), I=1,IN -C on FLGIK = 1.0D0 or FLGIK = -1.0D0 -C FLGIK - Selection parameter for I or K FUNCTION -C FLGIK = 1.0D0 gives the I function -C FLGIK = -1.0D0 gives the K function -C RA - SQRT(1.+Z*Z), Z=X/FNU -C ARG - Argument of the leading exponential -C IN - Number of functions desired, IN=1 or 2 -C -C OUTPUT -C -C Y - A vector whose first IN components contain the sequence -C -C Abstract **** A double precision routine **** -C DASYIK implements the uniform asymptotic expansion of -C the I and K Bessel functions for FNU.GE.35 and real -C X.GT.0.0D0. The forms are identical except for a change -C in sign of some of the terms. This change in sign is -C accomplished by means of the FLAG FLGIK = 1 or -1. -C -C***SEE ALSO DBESI, DBESK -C***ROUTINES CALLED D1MACH -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910408 Updated the AUTHOR section. (WRB) -C***END PROLOGUE DASYIK -C - INTEGER IN, J, JN, K, KK, KODE, L - DOUBLE PRECISION AK,AP,ARG,C,COEF,CON,ETX,FLGIK,FN,FNU,GLN,RA, - 1 S1, S2, T, TOL, T2, X, Y, Z - DOUBLE PRECISION D1MACH - DIMENSION Y(*), C(65), CON(2) - SAVE CON, C - DATA CON(1), CON(2) / - 1 3.98942280401432678D-01, 1.25331413731550025D+00/ - DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), - 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), - 2 C(19), C(20), C(21), C(22), C(23), C(24)/ - 3 -2.08333333333333D-01, 1.25000000000000D-01, - 4 3.34201388888889D-01, -4.01041666666667D-01, - 5 7.03125000000000D-02, -1.02581259645062D+00, - 6 1.84646267361111D+00, -8.91210937500000D-01, - 7 7.32421875000000D-02, 4.66958442342625D+00, - 8 -1.12070026162230D+01, 8.78912353515625D+00, - 9 -2.36408691406250D+00, 1.12152099609375D-01, - 1 -2.82120725582002D+01, 8.46362176746007D+01, - 2 -9.18182415432400D+01, 4.25349987453885D+01, - 3 -7.36879435947963D+00, 2.27108001708984D-01, - 4 2.12570130039217D+02, -7.65252468141182D+02, - 5 1.05999045252800D+03, -6.99579627376133D+02/ - DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), - 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), - 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ - 3 2.18190511744212D+02, -2.64914304869516D+01, - 4 5.72501420974731D-01, -1.91945766231841D+03, - 5 8.06172218173731D+03, -1.35865500064341D+04, - 6 1.16553933368645D+04, -5.30564697861340D+03, - 7 1.20090291321635D+03, -1.08090919788395D+02, - 8 1.72772750258446D+00, 2.02042913309661D+04, - 9 -9.69805983886375D+04, 1.92547001232532D+05, - 1 -2.03400177280416D+05, 1.22200464983017D+05, - 2 -4.11926549688976D+04, 7.10951430248936D+03, - 3 -4.93915304773088D+02, 6.07404200127348D+00, - 4 -2.42919187900551D+05, 1.31176361466298D+06, - 5 -2.99801591853811D+06, 3.76327129765640D+06/ - DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), - 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), - 2 C(65)/ - 3 -2.81356322658653D+06, 1.26836527332162D+06, - 4 -3.31645172484564D+05, 4.52187689813627D+04, - 5 -2.49983048181121D+03, 2.43805296995561D+01, - 6 3.28446985307204D+06, -1.97068191184322D+07, - 7 5.09526024926646D+07, -7.41051482115327D+07, - 8 6.63445122747290D+07, -3.75671766607634D+07, - 9 1.32887671664218D+07, -2.78561812808645D+06, - 1 3.08186404612662D+05, -1.38860897537170D+04, - 2 1.10017140269247D+02/ -C***FIRST EXECUTABLE STATEMENT DASYIK - TOL = D1MACH(3) - TOL = MAX(TOL,1.0D-15) - FN = FNU - Z = (3.0D0-FLGIK)/2.0D0 - KK = INT(Z) - DO 50 JN=1,IN - IF (JN.EQ.1) GO TO 10 - FN = FN - FLGIK - Z = X/FN - RA = SQRT(1.0D0+Z*Z) - GLN = LOG((1.0D0+RA)/Z) - ETX = KODE - 1 - T = RA*(1.0D0-ETX) + ETX/(Z+RA) - ARG = FN*(T-GLN)*FLGIK - 10 COEF = EXP(ARG) - T = 1.0D0/RA - T2 = T*T - T = T/FN - T = SIGN(T,FLGIK) - S2 = 1.0D0 - AP = 1.0D0 - L = 0 - DO 30 K=2,11 - L = L + 1 - S1 = C(L) - DO 20 J=2,K - L = L + 1 - S1 = S1*T2 + C(L) - 20 CONTINUE - AP = AP*T - AK = AP*S1 - S2 = S2 + AK - IF (MAX(ABS(AK),ABS(AP)) .LT.TOL) GO TO 40 - 30 CONTINUE - 40 CONTINUE - T = ABS(T) - Y(JN) = S2*COEF*SQRT(T)*CON(KK) - 50 CONTINUE - RETURN - END diff --git a/slatec/dasyjy.f b/slatec/dasyjy.f deleted file mode 100644 index f247907..0000000 --- a/slatec/dasyjy.f +++ /dev/null @@ -1,493 +0,0 @@ -*DECK DASYJY - SUBROUTINE DASYJY (FUNJY, X, FNU, FLGJY, IN, Y, WK, IFLW) -C***BEGIN PROLOGUE DASYJY -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBESJ and DBESY -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (ASYJY-S, DASYJY-D) -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C DASYJY computes Bessel functions J and Y -C for arguments X.GT.0.0 and orders FNU .GE. 35.0 -C on FLGJY = 1 and FLGJY = -1 respectively -C -C INPUT -C -C FUNJY - External subroutine JAIRY or YAIRY -C X - Argument, X.GT.0.0D0 -C FNU - Order of the first Bessel function -C FLGJY - Selection flag -C FLGJY = 1.0D0 gives the J function -C FLGJY = -1.0D0 gives the Y function -C IN - Number of functions desired, IN = 1 or 2 -C -C OUTPUT -C -C Y - A vector whose first IN components contain the sequence -C IFLW - A flag indicating underflow or overflow -C return variables for BESJ only -C WK(1) = 1 - (X/FNU)**2 = W**2 -C WK(2) = SQRT(ABS(WK(1))) -C WK(3) = ABS(WK(2) - ATAN(WK(2))) or -C ABS(LN((1 + WK(2))/(X/FNU)) - WK(2)) -C = ABS((2/3)*ZETA**(3/2)) -C WK(4) = FNU*WK(3) -C WK(5) = (1.5*WK(3)*FNU)**(1/3) = SQRT(ZETA)*FNU**(1/3) -C WK(6) = SIGN(1.,W**2)*WK(5)**2 = SIGN(1.,W**2)*ZETA*FNU**(2/3) -C WK(7) = FNU**(1/3) -C -C Abstract **** A Double Precision Routine **** -C DASYJY implements the uniform asymptotic expansion of -C the J and Y Bessel functions for FNU.GE.35 and real -C X.GT.0.0D0. The forms are identical except for a change -C in sign of some of the terms. This change in sign is -C accomplished by means of the flag FLGJY = 1 or -1. On -C FLGJY = 1 the Airy functions AI(X) and DAI(X) are -C supplied by the external function JAIRY, and on -C FLGJY = -1 the Airy functions BI(X) and DBI(X) are -C supplied by the external function YAIRY. -C -C***SEE ALSO DBESJ, DBESY -C***ROUTINES CALLED D1MACH, I1MACH -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 891004 Correction computation of ELIM. (WRB) -C 891009 Removed unreferenced variable. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910408 Updated the AUTHOR section. (WRB) -C***END PROLOGUE DASYJY - INTEGER I, IFLW, IN, J, JN,JR,JU,K, KB,KLAST,KMAX,KP1, KS, KSP1, - * KSTEMP, L, LR, LRP1, ISETA, ISETB - INTEGER I1MACH - DOUBLE PRECISION ABW2, AKM, ALFA, ALFA1, ALFA2, AP, AR, ASUM, AZ, - * BETA, BETA1, BETA2, BETA3, BR, BSUM, C, CON1, CON2, - * CON548,CR,CRZ32, DFI,ELIM, DR,FI, FLGJY, FN, FNU, - * FN2, GAMA, PHI, RCZ, RDEN, RELB, RFN2, RTZ, RZDEN, - * SA, SB, SUMA, SUMB, S1, TA, TAU, TB, TFN, TOL, TOLS, T2, UPOL, - * WK, X, XX, Y, Z, Z32 - DOUBLE PRECISION D1MACH - DIMENSION Y(*), WK(*), C(65) - DIMENSION ALFA(26,4), BETA(26,5) - DIMENSION ALFA1(26,2), ALFA2(26,2) - DIMENSION BETA1(26,2), BETA2(26,2), BETA3(26,1) - DIMENSION GAMA(26), KMAX(5), AR(8), BR(10), UPOL(10) - DIMENSION CR(10), DR(10) - EQUIVALENCE (ALFA(1,1),ALFA1(1,1)) - EQUIVALENCE (ALFA(1,3),ALFA2(1,1)) - EQUIVALENCE (BETA(1,1),BETA1(1,1)) - EQUIVALENCE (BETA(1,3),BETA2(1,1)) - EQUIVALENCE (BETA(1,5),BETA3(1,1)) - SAVE TOLS, CON1, CON2, CON548, AR, BR, C, - 1 ALFA1, ALFA2, BETA1, BETA2, BETA3, GAMA - DATA TOLS /-6.90775527898214D+00/ - DATA CON1,CON2,CON548/ - 1 6.66666666666667D-01, 3.33333333333333D-01, 1.04166666666667D-01/ - DATA AR(1), AR(2), AR(3), AR(4), AR(5), AR(6), AR(7), - A AR(8) / 8.35503472222222D-02, 1.28226574556327D-01, - 1 2.91849026464140D-01, 8.81627267443758D-01, 3.32140828186277D+00, - 2 1.49957629868626D+01, 7.89230130115865D+01, 4.74451538868264D+02/ - DATA BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), BR(8), - A BR(9), BR(10) /-1.45833333333333D-01,-9.87413194444444D-02, - 1-1.43312053915895D-01,-3.17227202678414D-01,-9.42429147957120D-01, - 2-3.51120304082635D+00,-1.57272636203680D+01,-8.22814390971859D+01, - 3-4.92355370523671D+02,-3.31621856854797D+03/ - DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), - 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), - 2 C(19), C(20), C(21), C(22), C(23), C(24)/ - 3 -2.08333333333333D-01, 1.25000000000000D-01, - 4 3.34201388888889D-01, -4.01041666666667D-01, - 5 7.03125000000000D-02, -1.02581259645062D+00, - 6 1.84646267361111D+00, -8.91210937500000D-01, - 7 7.32421875000000D-02, 4.66958442342625D+00, - 8 -1.12070026162230D+01, 8.78912353515625D+00, - 9 -2.36408691406250D+00, 1.12152099609375D-01, - A -2.82120725582002D+01, 8.46362176746007D+01, - B -9.18182415432400D+01, 4.25349987453885D+01, - C -7.36879435947963D+00, 2.27108001708984D-01, - D 2.12570130039217D+02, -7.65252468141182D+02, - E 1.05999045252800D+03, -6.99579627376133D+02/ - DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), - 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), - 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ - 3 2.18190511744212D+02, -2.64914304869516D+01, - 4 5.72501420974731D-01, -1.91945766231841D+03, - 5 8.06172218173731D+03, -1.35865500064341D+04, - 6 1.16553933368645D+04, -5.30564697861340D+03, - 7 1.20090291321635D+03, -1.08090919788395D+02, - 8 1.72772750258446D+00, 2.02042913309661D+04, - 9 -9.69805983886375D+04, 1.92547001232532D+05, - A -2.03400177280416D+05, 1.22200464983017D+05, - B -4.11926549688976D+04, 7.10951430248936D+03, - C -4.93915304773088D+02, 6.07404200127348D+00, - D -2.42919187900551D+05, 1.31176361466298D+06, - E -2.99801591853811D+06, 3.76327129765640D+06/ - DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), - 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), - 2 C(65)/ - 3 -2.81356322658653D+06, 1.26836527332162D+06, - 4 -3.31645172484564D+05, 4.52187689813627D+04, - 5 -2.49983048181121D+03, 2.43805296995561D+01, - 6 3.28446985307204D+06, -1.97068191184322D+07, - 7 5.09526024926646D+07, -7.41051482115327D+07, - 8 6.63445122747290D+07, -3.75671766607634D+07, - 9 1.32887671664218D+07, -2.78561812808645D+06, - A 3.08186404612662D+05, -1.38860897537170D+04, - B 1.10017140269247D+02/ - DATA ALFA1(1,1), ALFA1(2,1), ALFA1(3,1), ALFA1(4,1), ALFA1(5,1), - 1 ALFA1(6,1), ALFA1(7,1), ALFA1(8,1), ALFA1(9,1), ALFA1(10,1), - 2 ALFA1(11,1),ALFA1(12,1),ALFA1(13,1),ALFA1(14,1),ALFA1(15,1), - 3 ALFA1(16,1),ALFA1(17,1),ALFA1(18,1),ALFA1(19,1),ALFA1(20,1), - 4 ALFA1(21,1),ALFA1(22,1),ALFA1(23,1),ALFA1(24,1),ALFA1(25,1), - 5 ALFA1(26,1) /-4.44444444444444D-03,-9.22077922077922D-04, - 6-8.84892884892885D-05, 1.65927687832450D-04, 2.46691372741793D-04, - 7 2.65995589346255D-04, 2.61824297061501D-04, 2.48730437344656D-04, - 8 2.32721040083232D-04, 2.16362485712365D-04, 2.00738858762752D-04, - 9 1.86267636637545D-04, 1.73060775917876D-04, 1.61091705929016D-04, - 1 1.50274774160908D-04, 1.40503497391270D-04, 1.31668816545923D-04, - 2 1.23667445598253D-04, 1.16405271474738D-04, 1.09798298372713D-04, - 3 1.03772410422993D-04, 9.82626078369363D-05, 9.32120517249503D-05, - 4 8.85710852478712D-05, 8.42963105715700D-05, 8.03497548407791D-05/ - DATA ALFA1(1,2), ALFA1(2,2), ALFA1(3,2), ALFA1(4,2), ALFA1(5,2), - 1 ALFA1(6,2), ALFA1(7,2), ALFA1(8,2), ALFA1(9,2), ALFA1(10,2), - 2 ALFA1(11,2),ALFA1(12,2),ALFA1(13,2),ALFA1(14,2),ALFA1(15,2), - 3 ALFA1(16,2),ALFA1(17,2),ALFA1(18,2),ALFA1(19,2),ALFA1(20,2), - 4 ALFA1(21,2),ALFA1(22,2),ALFA1(23,2),ALFA1(24,2),ALFA1(25,2), - 5 ALFA1(26,2) / 6.93735541354589D-04, 2.32241745182922D-04, - 6-1.41986273556691D-05,-1.16444931672049D-04,-1.50803558053049D-04, - 7-1.55121924918096D-04,-1.46809756646466D-04,-1.33815503867491D-04, - 8-1.19744975684254D-04,-1.06184319207974D-04,-9.37699549891194D-05, - 9-8.26923045588193D-05,-7.29374348155221D-05,-6.44042357721016D-05, - 1-5.69611566009369D-05,-5.04731044303562D-05,-4.48134868008883D-05, - 2-3.98688727717599D-05,-3.55400532972042D-05,-3.17414256609022D-05, - 3-2.83996793904175D-05,-2.54522720634871D-05,-2.28459297164725D-05, - 4-2.05352753106481D-05,-1.84816217627666D-05,-1.66519330021394D-05/ - DATA ALFA2(1,1), ALFA2(2,1), ALFA2(3,1), ALFA2(4,1), ALFA2(5,1), - 1 ALFA2(6,1), ALFA2(7,1), ALFA2(8,1), ALFA2(9,1), ALFA2(10,1), - 2 ALFA2(11,1),ALFA2(12,1),ALFA2(13,1),ALFA2(14,1),ALFA2(15,1), - 3 ALFA2(16,1),ALFA2(17,1),ALFA2(18,1),ALFA2(19,1),ALFA2(20,1), - 4 ALFA2(21,1),ALFA2(22,1),ALFA2(23,1),ALFA2(24,1),ALFA2(25,1), - 5 ALFA2(26,1) /-3.54211971457744D-04,-1.56161263945159D-04, - 6 3.04465503594936D-05, 1.30198655773243D-04, 1.67471106699712D-04, - 7 1.70222587683593D-04, 1.56501427608595D-04, 1.36339170977445D-04, - 8 1.14886692029825D-04, 9.45869093034688D-05, 7.64498419250898D-05, - 9 6.07570334965197D-05, 4.74394299290509D-05, 3.62757512005344D-05, - 1 2.69939714979225D-05, 1.93210938247939D-05, 1.30056674793963D-05, - 2 7.82620866744497D-06, 3.59257485819352D-06, 1.44040049814252D-07, - 3-2.65396769697939D-06,-4.91346867098486D-06,-6.72739296091248D-06, - 4-8.17269379678658D-06,-9.31304715093561D-06,-1.02011418798016D-05/ - DATA ALFA2(1,2), ALFA2(2,2), ALFA2(3,2), ALFA2(4,2), ALFA2(5,2), - 1 ALFA2(6,2), ALFA2(7,2), ALFA2(8,2), ALFA2(9,2), ALFA2(10,2), - 2 ALFA2(11,2),ALFA2(12,2),ALFA2(13,2),ALFA2(14,2),ALFA2(15,2), - 3 ALFA2(16,2),ALFA2(17,2),ALFA2(18,2),ALFA2(19,2),ALFA2(20,2), - 4 ALFA2(21,2),ALFA2(22,2),ALFA2(23,2),ALFA2(24,2),ALFA2(25,2), - 5 ALFA2(26,2) / 3.78194199201773D-04, 2.02471952761816D-04, - 6-6.37938506318862D-05,-2.38598230603006D-04,-3.10916256027362D-04, - 7-3.13680115247576D-04,-2.78950273791323D-04,-2.28564082619141D-04, - 8-1.75245280340847D-04,-1.25544063060690D-04,-8.22982872820208D-05, - 9-4.62860730588116D-05,-1.72334302366962D-05, 5.60690482304602D-06, - 1 2.31395443148287D-05, 3.62642745856794D-05, 4.58006124490189D-05, - 2 5.24595294959114D-05, 5.68396208545815D-05, 5.94349820393104D-05, - 3 6.06478527578422D-05, 6.08023907788436D-05, 6.01577894539460D-05, - 4 5.89199657344698D-05, 5.72515823777593D-05, 5.52804375585853D-05/ - DATA BETA1(1,1), BETA1(2,1), BETA1(3,1), BETA1(4,1), BETA1(5,1), - 1 BETA1(6,1), BETA1(7,1), BETA1(8,1), BETA1(9,1), BETA1(10,1), - 2 BETA1(11,1),BETA1(12,1),BETA1(13,1),BETA1(14,1),BETA1(15,1), - 3 BETA1(16,1),BETA1(17,1),BETA1(18,1),BETA1(19,1),BETA1(20,1), - 4 BETA1(21,1),BETA1(22,1),BETA1(23,1),BETA1(24,1),BETA1(25,1), - 5 BETA1(26,1) / 1.79988721413553D-02, 5.59964911064388D-03, - 6 2.88501402231133D-03, 1.80096606761054D-03, 1.24753110589199D-03, - 7 9.22878876572938D-04, 7.14430421727287D-04, 5.71787281789705D-04, - 8 4.69431007606482D-04, 3.93232835462917D-04, 3.34818889318298D-04, - 9 2.88952148495752D-04, 2.52211615549573D-04, 2.22280580798883D-04, - 1 1.97541838033063D-04, 1.76836855019718D-04, 1.59316899661821D-04, - 2 1.44347930197334D-04, 1.31448068119965D-04, 1.20245444949303D-04, - 3 1.10449144504599D-04, 1.01828770740567D-04, 9.41998224204238D-05, - 4 8.74130545753834D-05, 8.13466262162801D-05, 7.59002269646219D-05/ - DATA BETA1(1,2), BETA1(2,2), BETA1(3,2), BETA1(4,2), BETA1(5,2), - 1 BETA1(6,2), BETA1(7,2), BETA1(8,2), BETA1(9,2), BETA1(10,2), - 2 BETA1(11,2),BETA1(12,2),BETA1(13,2),BETA1(14,2),BETA1(15,2), - 3 BETA1(16,2),BETA1(17,2),BETA1(18,2),BETA1(19,2),BETA1(20,2), - 4 BETA1(21,2),BETA1(22,2),BETA1(23,2),BETA1(24,2),BETA1(25,2), - 5 BETA1(26,2) /-1.49282953213429D-03,-8.78204709546389D-04, - 6-5.02916549572035D-04,-2.94822138512746D-04,-1.75463996970783D-04, - 7-1.04008550460816D-04,-5.96141953046458D-05,-3.12038929076098D-05, - 8-1.26089735980230D-05,-2.42892608575730D-07, 8.05996165414274D-06, - 9 1.36507009262147D-05, 1.73964125472926D-05, 1.98672978842134D-05, - 1 2.14463263790823D-05, 2.23954659232457D-05, 2.28967783814713D-05, - 2 2.30785389811178D-05, 2.30321976080909D-05, 2.28236073720349D-05, - 3 2.25005881105292D-05, 2.20981015361991D-05, 2.16418427448104D-05, - 4 2.11507649256221D-05, 2.06388749782171D-05, 2.01165241997082D-05/ - DATA BETA2(1,1), BETA2(2,1), BETA2(3,1), BETA2(4,1), BETA2(5,1), - 1 BETA2(6,1), BETA2(7,1), BETA2(8,1), BETA2(9,1), BETA2(10,1), - 2 BETA2(11,1),BETA2(12,1),BETA2(13,1),BETA2(14,1),BETA2(15,1), - 3 BETA2(16,1),BETA2(17,1),BETA2(18,1),BETA2(19,1),BETA2(20,1), - 4 BETA2(21,1),BETA2(22,1),BETA2(23,1),BETA2(24,1),BETA2(25,1), - 5 BETA2(26,1) / 5.52213076721293D-04, 4.47932581552385D-04, - 6 2.79520653992021D-04, 1.52468156198447D-04, 6.93271105657044D-05, - 7 1.76258683069991D-05,-1.35744996343269D-05,-3.17972413350427D-05, - 8-4.18861861696693D-05,-4.69004889379141D-05,-4.87665447413787D-05, - 9-4.87010031186735D-05,-4.74755620890087D-05,-4.55813058138628D-05, - 1-4.33309644511266D-05,-4.09230193157750D-05,-3.84822638603221D-05, - 2-3.60857167535411D-05,-3.37793306123367D-05,-3.15888560772110D-05, - 3-2.95269561750807D-05,-2.75978914828336D-05,-2.58006174666884D-05, - 4-2.41308356761280D-05,-2.25823509518346D-05,-2.11479656768913D-05/ - DATA BETA2(1,2), BETA2(2,2), BETA2(3,2), BETA2(4,2), BETA2(5,2), - 1 BETA2(6,2), BETA2(7,2), BETA2(8,2), BETA2(9,2), BETA2(10,2), - 2 BETA2(11,2),BETA2(12,2),BETA2(13,2),BETA2(14,2),BETA2(15,2), - 3 BETA2(16,2),BETA2(17,2),BETA2(18,2),BETA2(19,2),BETA2(20,2), - 4 BETA2(21,2),BETA2(22,2),BETA2(23,2),BETA2(24,2),BETA2(25,2), - 5 BETA2(26,2) /-4.74617796559960D-04,-4.77864567147321D-04, - 6-3.20390228067038D-04,-1.61105016119962D-04,-4.25778101285435D-05, - 7 3.44571294294968D-05, 7.97092684075675D-05, 1.03138236708272D-04, - 8 1.12466775262204D-04, 1.13103642108481D-04, 1.08651634848774D-04, - 9 1.01437951597662D-04, 9.29298396593364D-05, 8.40293133016090D-05, - 1 7.52727991349134D-05, 6.69632521975731D-05, 5.92564547323195D-05, - 2 5.22169308826976D-05, 4.58539485165361D-05, 4.01445513891487D-05, - 3 3.50481730031328D-05, 3.05157995034347D-05, 2.64956119950516D-05, - 4 2.29363633690998D-05, 1.97893056664022D-05, 1.70091984636413D-05/ - DATA BETA3(1,1), BETA3(2,1), BETA3(3,1), BETA3(4,1), BETA3(5,1), - 1 BETA3(6,1), BETA3(7,1), BETA3(8,1), BETA3(9,1), BETA3(10,1), - 2 BETA3(11,1),BETA3(12,1),BETA3(13,1),BETA3(14,1),BETA3(15,1), - 3 BETA3(16,1),BETA3(17,1),BETA3(18,1),BETA3(19,1),BETA3(20,1), - 4 BETA3(21,1),BETA3(22,1),BETA3(23,1),BETA3(24,1),BETA3(25,1), - 5 BETA3(26,1) / 7.36465810572578D-04, 8.72790805146194D-04, - 6 6.22614862573135D-04, 2.85998154194304D-04, 3.84737672879366D-06, - 7-1.87906003636972D-04,-2.97603646594555D-04,-3.45998126832656D-04, - 8-3.53382470916038D-04,-3.35715635775049D-04,-3.04321124789040D-04, - 9-2.66722723047613D-04,-2.27654214122820D-04,-1.89922611854562D-04, - 1-1.55058918599094D-04,-1.23778240761874D-04,-9.62926147717644D-05, - 2-7.25178327714425D-05,-5.22070028895634D-05,-3.50347750511901D-05, - 3-2.06489761035552D-05,-8.70106096849767D-06, 1.13698686675100D-06, - 4 9.16426474122779D-06, 1.56477785428873D-05, 2.08223629482467D-05/ - DATA GAMA(1), GAMA(2), GAMA(3), GAMA(4), GAMA(5), - 1 GAMA(6), GAMA(7), GAMA(8), GAMA(9), GAMA(10), - 2 GAMA(11), GAMA(12), GAMA(13), GAMA(14), GAMA(15), - 3 GAMA(16), GAMA(17), GAMA(18), GAMA(19), GAMA(20), - 4 GAMA(21), GAMA(22), GAMA(23), GAMA(24), GAMA(25), - 5 GAMA(26) / 6.29960524947437D-01, 2.51984209978975D-01, - 6 1.54790300415656D-01, 1.10713062416159D-01, 8.57309395527395D-02, - 7 6.97161316958684D-02, 5.86085671893714D-02, 5.04698873536311D-02, - 8 4.42600580689155D-02, 3.93720661543510D-02, 3.54283195924455D-02, - 9 3.21818857502098D-02, 2.94646240791158D-02, 2.71581677112934D-02, - 1 2.51768272973862D-02, 2.34570755306079D-02, 2.19508390134907D-02, - 2 2.06210828235646D-02, 1.94388240897881D-02, 1.83810633800683D-02, - 3 1.74293213231963D-02, 1.65685837786612D-02, 1.57865285987918D-02, - 4 1.50729501494096D-02, 1.44193250839955D-02, 1.38184805735342D-02/ -C***FIRST EXECUTABLE STATEMENT DASYJY - TA = D1MACH(3) - TOL = MAX(TA,1.0D-15) - TB = D1MACH(5) - JU = I1MACH(15) - IF(FLGJY.EQ.1.0D0) GO TO 6 - JR = I1MACH(14) - ELIM = -2.303D0*TB*(JU+JR) - GO TO 7 - 6 CONTINUE - ELIM = -2.303D0*(TB*JU+3.0D0) - 7 CONTINUE - FN = FNU - IFLW = 0 - DO 170 JN=1,IN - XX = X/FN - WK(1) = 1.0D0 - XX*XX - ABW2 = ABS(WK(1)) - WK(2) = SQRT(ABW2) - WK(7) = FN**CON2 - IF (ABW2.GT.0.27750D0) GO TO 80 -C -C ASYMPTOTIC EXPANSION -C CASES NEAR X=FN, ABS(1.-(X/FN)**2).LE.0.2775 -C COEFFICIENTS OF ASYMPTOTIC EXPANSION BY SERIES -C -C ZETA AND TRUNCATION FOR A(ZETA) AND B(ZETA) SERIES -C -C KMAX IS TRUNCATION INDEX FOR A(ZETA) AND B(ZETA) SERIES=MAX(2,SA) -C - SA = 0.0D0 - IF (ABW2.EQ.0.0D0) GO TO 10 - SA = TOLS/LOG(ABW2) - 10 SB = SA - DO 20 I=1,5 - AKM = MAX(SA,2.0D0) - KMAX(I) = INT(AKM) - SA = SA + SB - 20 CONTINUE - KB = KMAX(5) - KLAST = KB - 1 - SA = GAMA(KB) - DO 30 K=1,KLAST - KB = KB - 1 - SA = SA*WK(1) + GAMA(KB) - 30 CONTINUE - Z = WK(1)*SA - AZ = ABS(Z) - RTZ = SQRT(AZ) - WK(3) = CON1*AZ*RTZ - WK(4) = WK(3)*FN - WK(5) = RTZ*WK(7) - WK(6) = -WK(5)*WK(5) - IF(Z.LE.0.0D0) GO TO 35 - IF(WK(4).GT.ELIM) GO TO 75 - WK(6) = -WK(6) - 35 CONTINUE - PHI = SQRT(SQRT(SA+SA+SA+SA)) -C -C B(ZETA) FOR S=0 -C - KB = KMAX(5) - KLAST = KB - 1 - SB = BETA(KB,1) - DO 40 K=1,KLAST - KB = KB - 1 - SB = SB*WK(1) + BETA(KB,1) - 40 CONTINUE - KSP1 = 1 - FN2 = FN*FN - RFN2 = 1.0D0/FN2 - RDEN = 1.0D0 - ASUM = 1.0D0 - RELB = TOL*ABS(SB) - BSUM = SB - DO 60 KS=1,4 - KSP1 = KSP1 + 1 - RDEN = RDEN*RFN2 -C -C A(ZETA) AND B(ZETA) FOR S=1,2,3,4 -C - KSTEMP = 5 - KS - KB = KMAX(KSTEMP) - KLAST = KB - 1 - SA = ALFA(KB,KS) - SB = BETA(KB,KSP1) - DO 50 K=1,KLAST - KB = KB - 1 - SA = SA*WK(1) + ALFA(KB,KS) - SB = SB*WK(1) + BETA(KB,KSP1) - 50 CONTINUE - TA = SA*RDEN - TB = SB*RDEN - ASUM = ASUM + TA - BSUM = BSUM + TB - IF (ABS(TA).LE.TOL .AND. ABS(TB).LE.RELB) GO TO 70 - 60 CONTINUE - 70 CONTINUE - BSUM = BSUM/(FN*WK(7)) - GO TO 160 -C - 75 CONTINUE - IFLW = 1 - RETURN -C - 80 CONTINUE - UPOL(1) = 1.0D0 - TAU = 1.0D0/WK(2) - T2 = 1.0D0/WK(1) - IF (WK(1).GE.0.0D0) GO TO 90 -C -C CASES FOR (X/FN).GT.SQRT(1.2775) -C - WK(3) = ABS(WK(2)-ATAN(WK(2))) - WK(4) = WK(3)*FN - RCZ = -CON1/WK(4) - Z32 = 1.5D0*WK(3) - RTZ = Z32**CON2 - WK(5) = RTZ*WK(7) - WK(6) = -WK(5)*WK(5) - GO TO 100 - 90 CONTINUE -C -C CASES FOR (X/FN).LT.SQRT(0.7225) -C - WK(3) = ABS(LOG((1.0D0+WK(2))/XX)-WK(2)) - WK(4) = WK(3)*FN - RCZ = CON1/WK(4) - IF(WK(4).GT.ELIM) GO TO 75 - Z32 = 1.5D0*WK(3) - RTZ = Z32**CON2 - WK(7) = FN**CON2 - WK(5) = RTZ*WK(7) - WK(6) = WK(5)*WK(5) - 100 CONTINUE - PHI = SQRT((RTZ+RTZ)*TAU) - TB = 1.0D0 - ASUM = 1.0D0 - TFN = TAU/FN - RDEN=1.0D0/FN - RFN2=RDEN*RDEN - RDEN=1.0D0 - UPOL(2) = (C(1)*T2+C(2))*TFN - CRZ32 = CON548*RCZ - BSUM = UPOL(2) + CRZ32 - RELB = TOL*ABS(BSUM) - AP = TFN - KS = 0 - KP1 = 2 - RZDEN = RCZ - L = 2 - ISETA=0 - ISETB=0 - DO 140 LR=2,8,2 -C -C COMPUTE TWO U POLYNOMIALS FOR NEXT A(ZETA) AND B(ZETA) -C - LRP1 = LR + 1 - DO 120 K=LR,LRP1 - KS = KS + 1 - KP1 = KP1 + 1 - L = L + 1 - S1 = C(L) - DO 110 J=2,KP1 - L = L + 1 - S1 = S1*T2 + C(L) - 110 CONTINUE - AP = AP*TFN - UPOL(KP1) = AP*S1 - CR(KS) = BR(KS)*RZDEN - RZDEN = RZDEN*RCZ - DR(KS) = AR(KS)*RZDEN - 120 CONTINUE - SUMA = UPOL(LRP1) - SUMB = UPOL(LR+2) + UPOL(LRP1)*CRZ32 - JU = LRP1 - DO 130 JR=1,LR - JU = JU - 1 - SUMA = SUMA + CR(JR)*UPOL(JU) - SUMB = SUMB + DR(JR)*UPOL(JU) - 130 CONTINUE - RDEN=RDEN*RFN2 - TB = -TB - IF (WK(1).GT.0.0D0) TB = ABS(TB) - IF(RDEN.LT.TOL) GO TO 131 - ASUM = ASUM + SUMA*TB - BSUM = BSUM + SUMB*TB - GO TO 140 - 131 IF(ISETA.EQ.1) GO TO 132 - IF(ABS(SUMA).LT.TOL) ISETA=1 - ASUM=ASUM+SUMA*TB - 132 IF(ISETB.EQ.1) GO TO 133 - IF(ABS(SUMB).LT.RELB) ISETB=1 - BSUM=BSUM+SUMB*TB - 133 IF(ISETA.EQ.1 .AND. ISETB.EQ.1) GO TO 150 - 140 CONTINUE - 150 TB = WK(5) - IF (WK(1).GT.0.0D0) TB = -TB - BSUM = BSUM/TB -C - 160 CONTINUE - CALL FUNJY(WK(6), WK(5), WK(4), FI, DFI) - TA=1.0D0/TOL - TB=D1MACH(1)*TA*1.0D+3 - IF(ABS(FI).GT.TB) GO TO 165 - FI=FI*TA - DFI=DFI*TA - PHI=PHI*TOL - 165 CONTINUE - Y(JN) = FLGJY*PHI*(FI*ASUM+DFI*BSUM)/WK(7) - FN = FN - FLGJY - 170 CONTINUE - RETURN - END diff --git a/slatec/datanh.f b/slatec/datanh.f deleted file mode 100644 index 3599a48..0000000 --- a/slatec/datanh.f +++ /dev/null @@ -1,83 +0,0 @@ -*DECK DATANH - DOUBLE PRECISION FUNCTION DATANH (X) -C***BEGIN PROLOGUE DATANH -C***PURPOSE Compute the arc hyperbolic tangent. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4C -C***TYPE DOUBLE PRECISION (ATANH-S, DATANH-D, CATANH-C) -C***KEYWORDS ARC HYPERBOLIC TANGENT, ATANH, ELEMENTARY FUNCTIONS, -C FNLIB, INVERSE HYPERBOLIC TANGENT -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DATANH(X) calculates the double precision arc hyperbolic -C tangent for double precision argument X. -C -C Series for ATNH on the interval 0. to 2.50000E-01 -C with weighted error 6.86E-32 -C log weighted error 31.16 -C significant figures required 30.00 -C decimal places required 31.88 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 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***END PROLOGUE DATANH - DOUBLE PRECISION X, ATNHCS(27), DXREL, SQEPS, Y, DCSEVL, D1MACH - LOGICAL FIRST - SAVE ATNHCS, NTERMS, DXREL, SQEPS, FIRST - DATA ATNHCS( 1) / +.9439510239 3195492308 4289221863 3 D-1 / - DATA ATNHCS( 2) / +.4919843705 5786159472 0003457666 8 D-1 / - DATA ATNHCS( 3) / +.2102593522 4554327634 7932733175 2 D-2 / - DATA ATNHCS( 4) / +.1073554449 7761165846 4073104527 6 D-3 / - DATA ATNHCS( 5) / +.5978267249 2930314786 4278751787 2 D-5 / - DATA ATNHCS( 6) / +.3505062030 8891348459 6683488620 0 D-6 / - DATA ATNHCS( 7) / +.2126374343 7653403508 9621931443 1 D-7 / - DATA ATNHCS( 8) / +.1321694535 7155271921 2980172305 5 D-8 / - DATA ATNHCS( 9) / +.8365875501 1780703646 2360405295 9 D-10 / - DATA ATNHCS( 10) / +.5370503749 3110021638 8143458777 2 D-11 / - DATA ATNHCS( 11) / +.3486659470 1571079229 7124578429 0 D-12 / - DATA ATNHCS( 12) / +.2284549509 6034330155 2402411972 2 D-13 / - DATA ATNHCS( 13) / +.1508407105 9447930448 7422906755 8 D-14 / - DATA ATNHCS( 14) / +.1002418816 8041091261 3699572283 7 D-15 / - DATA ATNHCS( 15) / +.6698674738 1650695397 1552688298 6 D-17 / - DATA ATNHCS( 16) / +.4497954546 4949310830 8332762453 3 D-18 / - DATA ATNHCS( 17) / +.3032954474 2794535416 8236714666 6 D-19 / - DATA ATNHCS( 18) / +.2052702064 1909368264 6386141866 6 D-20 / - DATA ATNHCS( 19) / +.1393848977 0538377131 9301461333 3 D-21 / - DATA ATNHCS( 20) / +.9492580637 2245769719 5895466666 6 D-23 / - DATA ATNHCS( 21) / +.6481915448 2423076049 8244266666 6 D-24 / - DATA ATNHCS( 22) / +.4436730205 7236152726 3232000000 0 D-25 / - DATA ATNHCS( 23) / +.3043465618 5431616389 1200000000 0 D-26 / - DATA ATNHCS( 24) / +.2091881298 7923934740 4799999999 9 D-27 / - DATA ATNHCS( 25) / +.1440445411 2340505613 6533333333 3 D-28 / - DATA ATNHCS( 26) / +.9935374683 1416404650 6666666666 6 D-30 / - DATA ATNHCS( 27) / +.6863462444 3582600533 3333333333 3 D-31 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DATANH - IF (FIRST) THEN - NTERMS = INITDS (ATNHCS, 27, 0.1*REAL(D1MACH(3)) ) - DXREL = SQRT(D1MACH(4)) - SQEPS = SQRT(3.0D0*D1MACH(3)) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y .GE. 1.D0) CALL XERMSG ('SLATEC', 'DATANH', 'ABS(X) GE 1', - + 2, 2) -C - IF (1.D0-Y .LT. DXREL) CALL XERMSG ('SLATEC', 'DATANH', - + 'ANSWER LT HALF PRECISION BECAUSE ABS(X) TOO NEAR 1', 1, 1) -C - DATANH = X - IF (Y.GT.SQEPS .AND. Y.LE.0.5D0) DATANH = X*(1.0D0 + - 1 DCSEVL (8.D0*X*X-1.D0, ATNHCS, NTERMS) ) - IF (Y.GT.0.5D0) DATANH = 0.5D0*LOG ((1.0D0+X)/(1.0D0-X)) -C - RETURN - END diff --git a/slatec/davint.f b/slatec/davint.f deleted file mode 100644 index b9a255f..0000000 --- a/slatec/davint.f +++ /dev/null @@ -1,214 +0,0 @@ -*DECK DAVINT - SUBROUTINE DAVINT (X, Y, N, XLO, XUP, ANS, IERR) -C***BEGIN PROLOGUE DAVINT -C***PURPOSE Integrate a function tabulated at arbitrarily spaced -C abscissas using overlapping parabolas. -C***LIBRARY SLATEC -C***CATEGORY H2A1B2 -C***TYPE DOUBLE PRECISION (AVINT-S, DAVINT-D) -C***KEYWORDS INTEGRATION, QUADRATURE, TABULATED DATA -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C DAVINT integrates a function tabulated at arbitrarily spaced -C abscissas. The limits of integration need not coincide -C with the tabulated abscissas. -C -C A method of overlapping parabolas fitted to the data is used -C provided that there are at least 3 abscissas between the -C limits of integration. DAVINT also handles two special cases. -C If the limits of integration are equal, DAVINT returns a -C result of zero regardless of the number of tabulated values. -C If there are only two function values, DAVINT uses the -C trapezoid rule. -C -C Description of Parameters -C The user must dimension all arrays appearing in the call list -C X(N), Y(N) -C -C Input-- -C X - DOUBLE PRECISION array of abscissas, which must be in -C increasing order. -C Y - DOUBLE PRECISION array of function values. i.e., -C Y(I)=FUNC(X(I)) -C N - The integer number of function values supplied. -C N .GE. 2 unless XLO = XUP. -C XLO - DOUBLE PRECISION lower limit of integration -C XUP - DOUBLE PRECISION upper limit of integration. Must have -C XLO.LE.XUP -C -C Output-- -C ANS - Double Precision computed approximate value of integral -C IERR - A status code -C --Normal Code -C =1 Means the requested integration was performed. -C --Abnormal Codes -C =2 Means XUP was less than XLO. -C =3 Means the number of X(I) between XLO and XUP -C (inclusive) was less than 3 and neither of the two -C special cases described in the abstract occurred. -C No integration was performed. -C =4 Means the restriction X(I+1).GT.X(I) was violated. -C =5 Means the number N of function values was .lt. 2. -C ANS is set to zero if IERR=2,3,4,or 5. -C -C DAVINT is documented completely in SC-M-69-335 -C Original program from *Numerical Integration* by Davis & Rabinowitz -C Adaptation and modifications by Rondall E Jones. -C -C***REFERENCES R. E. Jones, Approximate integrator of functions -C tabulated at arbitrarily spaced abscissas, -C Report SC-M-69-335, Sandia Laboratories, 1969. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 690901 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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DAVINT -C - INTEGER I, IERR, INLFT, INRT, ISTART, ISTOP, N - DOUBLE PRECISION A, ANS, B, C, CA, CB, CC, FL, FR, R3, RP5, - 1 SLOPE, SUM, SYL, SYL2, SYL3, SYU, SYU2, SYU3, TERM1, TERM2, - 2 TERM3, X, X1, X12, X13, X2, X23, X3, XLO, XUP, Y - DIMENSION X(*),Y(*) -C BEGIN BLOCK PERMITTING ...EXITS TO 190 -C BEGIN BLOCK PERMITTING ...EXITS TO 180 -C***FIRST EXECUTABLE STATEMENT DAVINT - IERR = 1 - ANS = 0.0D0 - IF (XLO .GT. XUP) GO TO 160 - IF (XLO .EQ. XUP) GO TO 150 - IF (N .GE. 2) GO TO 10 - IERR = 5 - CALL XERMSG ('SLATEC', 'DAVINT', - + 'LESS THAN TWO FUNCTION VALUES WERE SUPPLIED.', - + 4, 1) -C ...............EXIT - GO TO 190 - 10 CONTINUE - DO 20 I = 2, N -C ............EXIT - IF (X(I) .LE. X(I-1)) GO TO 180 -C ...EXIT - IF (X(I) .GT. XUP) GO TO 30 - 20 CONTINUE - 30 CONTINUE - IF (N .GE. 3) GO TO 40 -C -C SPECIAL N=2 CASE - SLOPE = (Y(2) - Y(1))/(X(2) - X(1)) - FL = Y(1) + SLOPE*(XLO - X(1)) - FR = Y(2) + SLOPE*(XUP - X(2)) - ANS = 0.5D0*(FL + FR)*(XUP - XLO) -C ...............EXIT - GO TO 190 - 40 CONTINUE - IF (X(N-2) .GE. XLO) GO TO 50 - IERR = 3 - CALL XERMSG ('SLATEC', 'DAVINT', - + 'THERE WERE LESS THAN THREE FUNCTION VALUES ' // - + 'BETWEEN THE LIMITS OF INTEGRATION.', 4, 1) -C ...............EXIT - GO TO 190 - 50 CONTINUE - IF (X(3) .LE. XUP) GO TO 60 - IERR = 3 - CALL XERMSG ('SLATEC', 'DAVINT', - + 'THERE WERE LESS THAN THREE FUNCTION VALUES ' // - + 'BETWEEN THE LIMITS OF INTEGRATION.', 4, 1) -C ...............EXIT - GO TO 190 - 60 CONTINUE - I = 1 - 70 IF (X(I) .GE. XLO) GO TO 80 - I = I + 1 - GO TO 70 - 80 CONTINUE - INLFT = I - I = N - 90 IF (X(I) .LE. XUP) GO TO 100 - I = I - 1 - GO TO 90 - 100 CONTINUE - INRT = I - IF ((INRT - INLFT) .GE. 2) GO TO 110 - IERR = 3 - CALL XERMSG ('SLATEC', 'DAVINT', - + 'THERE WERE LESS THAN THREE FUNCTION VALUES ' // - + 'BETWEEN THE LIMITS OF INTEGRATION.', 4, 1) -C ...............EXIT - GO TO 190 - 110 CONTINUE - ISTART = INLFT - IF (INLFT .EQ. 1) ISTART = 2 - ISTOP = INRT - IF (INRT .EQ. N) ISTOP = N - 1 -C - R3 = 3.0D0 - RP5 = 0.5D0 - SUM = 0.0D0 - SYL = XLO - SYL2 = SYL*SYL - SYL3 = SYL2*SYL -C - DO 140 I = ISTART, ISTOP - X1 = X(I-1) - X2 = X(I) - X3 = X(I+1) - X12 = X1 - X2 - X13 = X1 - X3 - X23 = X2 - X3 - TERM1 = Y(I-1)/(X12*X13) - TERM2 = -Y(I)/(X12*X23) - TERM3 = Y(I+1)/(X13*X23) - A = TERM1 + TERM2 + TERM3 - B = -(X2 + X3)*TERM1 - (X1 + X3)*TERM2 - 1 - (X1 + X2)*TERM3 - C = X2*X3*TERM1 + X1*X3*TERM2 + X1*X2*TERM3 - IF (I .GT. ISTART) GO TO 120 - CA = A - CB = B - CC = C - GO TO 130 - 120 CONTINUE - CA = 0.5D0*(A + CA) - CB = 0.5D0*(B + CB) - CC = 0.5D0*(C + CC) - 130 CONTINUE - SYU = X2 - SYU2 = SYU*SYU - SYU3 = SYU2*SYU - SUM = SUM + CA*(SYU3 - SYL3)/R3 - 1 + CB*RP5*(SYU2 - SYL2) + CC*(SYU - SYL) - CA = A - CB = B - CC = C - SYL = SYU - SYL2 = SYU2 - SYL3 = SYU3 - 140 CONTINUE - SYU = XUP - ANS = SUM + CA*(SYU**3 - SYL3)/R3 - 1 + CB*RP5*(SYU**2 - SYL2) + CC*(SYU - SYL) - 150 CONTINUE - GO TO 170 - 160 CONTINUE - IERR = 2 - CALL XERMSG ('SLATEC', 'DAVINT', - + 'THE UPPER LIMIT OF INTEGRATION WAS NOT GREATER ' // - + 'THAN THE LOWER LIMIT.', 4, 1) - 170 CONTINUE -C ......EXIT - GO TO 190 - 180 CONTINUE - IERR = 4 - CALL XERMSG ('SLATEC', 'DAVINT', - + 'THE ABSCISSAS WERE NOT STRICTLY INCREASING. MUST HAVE ' // - + 'X(I-1) .LT. X(I) FOR ALL I.', 4, 1) - 190 CONTINUE - RETURN - END diff --git a/slatec/daws.f b/slatec/daws.f deleted file mode 100644 index 3446528..0000000 --- a/slatec/daws.f +++ /dev/null @@ -1,153 +0,0 @@ -*DECK DAWS - FUNCTION DAWS (X) -C***BEGIN PROLOGUE DAWS -C***PURPOSE Compute Dawson's function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C8C -C***TYPE SINGLE PRECISION (DAWS-S, DDAWS-D) -C***KEYWORDS DAWSON'S FUNCTION, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DAWS(X) calculates Dawson's integral for real argument X. -C -C Series for DAW on the interval 0. to 1.00000D+00 -C with weighted error 3.83E-17 -C log weighted error 16.42 -C significant figures required 15.78 -C decimal places required 16.97 -C -C Series for DAW2 on the interval 0. to 1.60000D+01 -C with weighted error 5.17E-17 -C log weighted error 16.29 -C significant figures required 15.90 -C decimal places required 17.02 -C -C Series for DAWA on the interval 0. to 6.25000D-02 -C with weighted error 2.24E-17 -C log weighted error 16.65 -C significant figures required 14.73 -C decimal places required 17.36 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 780401 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 920618 Removed space from variable names. (RWC, WRB) -C***END PROLOGUE DAWS - DIMENSION DAWCS(13), DAW2CS(29), DAWACS(26) - LOGICAL FIRST - SAVE DAWCS, DAW2CS, DAWACS, NTDAW, NTDAW2, NTDAWA, - 1 XSML, XBIG, XMAX, FIRST - DATA DAWCS( 1) / -.0063517343 75145949E0 / - DATA DAWCS( 2) / -.2294071479 6773869E0 / - DATA DAWCS( 3) / .0221305009 39084764E0 / - DATA DAWCS( 4) / -.0015492654 53892985E0 / - DATA DAWCS( 5) / .0000849732 77156849E0 / - DATA DAWCS( 6) / -.0000038282 66270972E0 / - DATA DAWCS( 7) / .0000001462 85480625E0 / - DATA DAWCS( 8) / -.0000000048 51982381E0 / - DATA DAWCS( 9) / .0000000001 42146357E0 / - DATA DAWCS(10) / -.0000000000 03728836E0 / - DATA DAWCS(11) / .0000000000 00088549E0 / - DATA DAWCS(12) / -.0000000000 00001920E0 / - DATA DAWCS(13) / .0000000000 00000038E0 / - DATA DAW2CS( 1) / -.0568865441 05215527E0 / - DATA DAW2CS( 2) / -.3181134699 6168131E0 / - DATA DAW2CS( 3) / .2087384541 3642237E0 / - DATA DAW2CS( 4) / -.1247540991 3779131E0 / - DATA DAW2CS( 5) / .0678693051 86676777E0 / - DATA DAW2CS( 6) / -.0336591448 95270940E0 / - DATA DAW2CS( 7) / .0152607812 71987972E0 / - DATA DAW2CS( 8) / -.0063483709 62596214E0 / - DATA DAW2CS( 9) / .0024326740 92074852E0 / - DATA DAW2CS(10) / -.0008621954 14910650E0 / - DATA DAW2CS(11) / .0002837657 33363216E0 / - DATA DAW2CS(12) / -.0000870575 49874170E0 / - DATA DAW2CS(13) / .0000249868 49985481E0 / - DATA DAW2CS(14) / -.0000067319 28676416E0 / - DATA DAW2CS(15) / .0000017078 57878557E0 / - DATA DAW2CS(16) / -.0000004091 75512264E0 / - DATA DAW2CS(17) / .0000000928 28292216E0 / - DATA DAW2CS(18) / -.0000000199 91403610E0 / - DATA DAW2CS(19) / .0000000040 96349064E0 / - DATA DAW2CS(20) / -.0000000008 00324095E0 / - DATA DAW2CS(21) / .0000000001 49385031E0 / - DATA DAW2CS(22) / -.0000000000 26687999E0 / - DATA DAW2CS(23) / .0000000000 04571221E0 / - DATA DAW2CS(24) / -.0000000000 00751873E0 / - DATA DAW2CS(25) / .0000000000 00118931E0 / - DATA DAW2CS(26) / -.0000000000 00018116E0 / - DATA DAW2CS(27) / .0000000000 00002661E0 / - DATA DAW2CS(28) / -.0000000000 00000377E0 / - DATA DAW2CS(29) / .0000000000 00000051E0 / - DATA DAWACS( 1) / .0169048563 7765704E0 / - DATA DAWACS( 2) / .0086832522 7840695E0 / - DATA DAWACS( 3) / .0002424864 0424177E0 / - DATA DAWACS( 4) / .0000126118 2399572E0 / - DATA DAWACS( 5) / .0000010664 5331463E0 / - DATA DAWACS( 6) / .0000001358 1597947E0 / - DATA DAWACS( 7) / .0000000217 1042356E0 / - DATA DAWACS( 8) / .0000000028 6701050E0 / - DATA DAWACS( 9) / -.0000000001 9013363E0 / - DATA DAWACS(10) / -.0000000003 0977804E0 / - DATA DAWACS(11) / -.0000000001 0294148E0 / - DATA DAWACS(12) / -.0000000000 0626035E0 / - DATA DAWACS(13) / .0000000000 0856313E0 / - DATA DAWACS(14) / .0000000000 0303304E0 / - DATA DAWACS(15) / -.0000000000 0025236E0 / - DATA DAWACS(16) / -.0000000000 0042106E0 / - DATA DAWACS(17) / -.0000000000 0004431E0 / - DATA DAWACS(18) / .0000000000 0004911E0 / - DATA DAWACS(19) / .0000000000 0001235E0 / - DATA DAWACS(20) / -.0000000000 0000578E0 / - DATA DAWACS(21) / -.0000000000 0000228E0 / - DATA DAWACS(22) / .0000000000 0000076E0 / - DATA DAWACS(23) / .0000000000 0000038E0 / - DATA DAWACS(24) / -.0000000000 0000011E0 / - DATA DAWACS(25) / -.0000000000 0000006E0 / - DATA DAWACS(26) / .0000000000 0000002E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DAWS - IF (FIRST) THEN - EPS = R1MACH(3) - NTDAW = INITS (DAWCS, 13, 0.1*EPS) - NTDAW2 = INITS (DAW2CS, 29, 0.1*EPS) - NTDAWA = INITS (DAWACS, 26, 0.1*EPS) -C - XSML = SQRT (1.5*EPS) - XBIG = SQRT (0.5/EPS) - XMAX = EXP (MIN (-LOG(2.*R1MACH(1)), LOG(R1MACH(2))) - 1.0) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.1.0) GO TO 20 -C - DAWS = X - IF (Y.LE.XSML) RETURN -C - DAWS = X * (0.75 + CSEVL (2.0*Y*Y-1.0, DAWCS, NTDAW)) - RETURN -C - 20 IF (Y.GT.4.0) GO TO 30 - DAWS = X * (0.25 + CSEVL (0.125*Y*Y-1.0, DAW2CS, NTDAW2)) - RETURN -C - 30 IF (Y.GT.XMAX) GO TO 40 - DAWS = 0.5/X - IF (Y.GT.XBIG) RETURN -C - DAWS = (0.5 + CSEVL (32.0/Y**2-1.0, DAWACS, NTDAWA)) / X - RETURN -C - 40 CALL XERMSG ('SLATEC', 'DAWS', 'ABS(X) SO LARGE DAWS UNDERFLOWS', - + 1, 1) - DAWS = 0.0 - RETURN -C - END diff --git a/slatec/daxpy.f b/slatec/daxpy.f deleted file mode 100644 index d1a0ff6..0000000 --- a/slatec/daxpy.f +++ /dev/null @@ -1,92 +0,0 @@ -*DECK DAXPY - SUBROUTINE DAXPY (N, DA, DX, INCX, DY, INCY) -C***BEGIN PROLOGUE DAXPY -C***PURPOSE Compute a constant times a vector plus a vector. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A7 -C***TYPE DOUBLE PRECISION (SAXPY-S, DAXPY-D, CAXPY-C) -C***KEYWORDS BLAS, LINEAR ALGEBRA, TRIAD, 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 DA double precision scalar multiplier -C DX double precision vector with N elements -C INCX storage spacing between elements of DX -C DY double precision vector with N elements -C INCY storage spacing between elements of DY -C -C --Output-- -C DY double precision result (unchanged if N .LE. 0) -C -C Overwrite double precision DY with double precision DA*DX + DY. -C For I = 0 to N-1, replace DY(LY+I*INCY) with DA*DX(LX+I*INCX) + -C DY(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 DAXPY - DOUBLE PRECISION DX(*), DY(*), DA -C***FIRST EXECUTABLE STATEMENT DAXPY - IF (N.LE.0 .OR. DA.EQ.0.0D0) RETURN - IF (INCX .EQ. INCY) IF (INCX-1) 5,20,60 -C -C Code for unequal or nonpositive increments. -C - 5 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 Clean-up loop so remaining vector length is a multiple of 4. -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 -C -C Code for equal, positive, non-unit increments. -C - 60 NS = N*INCX - DO 70 I = 1,NS,INCX - DY(I) = DA*DX(I) + DY(I) - 70 CONTINUE - RETURN - END diff --git a/slatec/dbcg.f b/slatec/dbcg.f deleted file mode 100644 index dae61f2..0000000 --- a/slatec/dbcg.f +++ /dev/null @@ -1,377 +0,0 @@ -*DECK DBCG - SUBROUTINE DBCG (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, - + MSOLVE, MTSOLV, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, - + P, RR, ZZ, PP, DZ, RWORK, IWORK) -C***BEGIN PROLOGUE DBCG -C***PURPOSE Preconditioned BiConjugate Gradient Sparse Ax = b Solver. -C Routine to solve a Non-Symmetric linear system Ax = b -C using the Preconditioned BiConjugate Gradient method. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (SBCG-S, DBCG-D) -C***KEYWORDS BICONJUGATE GRADIENT, ITERATIVE PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) -C DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N), P(N) -C DOUBLE PRECISION RR(N), ZZ(N), PP(N), DZ(N) -C DOUBLE PRECISION RWORK(USER DEFINED) -C EXTERNAL MATVEC, MTTVEC, MSOLVE, MTSOLV -C -C CALL DBCG(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, -C $ MSOLVE, MTSOLV, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, -C $ R, Z, P, RR, ZZ, PP, DZ, RWORK, IWORK) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right-hand side vector. -C X :INOUT Double Precision X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Double Precision A(NELT). -C These arrays contain the matrix data structure for A. -C It could take any form. See "Description", below, for more -C details. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C MATVEC :EXT External. -C Name of a routine which performs the matrix vector multiply -C operation Y = A*X given A and X. The name of the MATVEC -C routine must be declared external in the calling program. -C The calling sequence of MATVEC is: -C CALL MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) -C Where N is the number of unknowns, Y is the product A*X upon -C return, X is an input vector. NELT, IA, JA, A and ISYM -C define the SLAP matrix data structure: see Description,below. -C MTTVEC :EXT External. -C Name of a routine which performs the matrix transpose vector -C multiply y = A'*X given A and X (where ' denotes transpose). -C The name of the MTTVEC routine must be declared external in -C the calling program. The calling sequence to MTTVEC is the -C same as that for MTTVEC, viz.: -C CALL MTTVEC( N, X, Y, NELT, IA, JA, A, ISYM ) -C Where N is the number of unknowns, Y is the product A'*X -C upon return, X is an input vector. NELT, IA, JA, A and ISYM -C define the SLAP matrix data structure: see Description,below. -C MSOLVE :EXT External. -C Name of a routine which solves a linear system MZ = R for Z -C given R with the preconditioning matrix M (M is supplied via -C RWORK and IWORK arrays). The name of the MSOLVE routine -C must be declared external in the calling program. The -C calling sequence of MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, R is the right-hand side -C vector, and Z is the solution upon return. NELT, IA, JA, A -C and ISYM define the SLAP matrix data structure: see -C Description, below. RWORK is a double precision array that -C can be used to pass necessary preconditioning information and/ -C or workspace to MSOLVE. IWORK is an integer work array for -C the same purpose as RWORK. -C MTSOLV :EXT External. -C Name of a routine which solves a linear system M'ZZ = RR for -C ZZ given RR with the preconditioning matrix M (M is supplied -C via RWORK and IWORK arrays). The name of the MTSOLV routine -C must be declared external in the calling program. The call- -C ing sequence to MTSOLV is: -C CALL MTSOLV(N, RR, ZZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, RR is the right-hand side -C vector, and ZZ is the solution upon return. NELT, IA, JA, A -C and ISYM define the SLAP matrix data structure: see -C Description, below. RWORK is a double precision array that -C can be used to pass necessary preconditioning information and/ -C or workspace to MTSOLV. IWORK is an integer work array for -C the same purpose as RWORK. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /DSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Double Precision. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Double Precision. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*D1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C R :WORK Double Precision R(N). -C Z :WORK Double Precision Z(N). -C P :WORK Double Precision P(N). -C RR :WORK Double Precision RR(N). -C ZZ :WORK Double Precision ZZ(N). -C PP :WORK Double Precision PP(N). -C DZ :WORK Double Precision DZ(N). -C Double Precision arrays used for workspace. -C RWORK :WORK Double Precision RWORK(USER DEFINED). -C Double Precision array that can be used for workspace in -C MSOLVE and MTSOLV. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used for workspace in MSOLVE -C and MTSOLV. -C -C *Description -C This routine does not care what matrix data structure is used -C for A and M. It simply calls MATVEC, MTTVEC, MSOLVE, MTSOLV -C routines, with arguments as above. The user could write any -C type of structure, and appropriate MATVEC, MSOLVE, MTTVEC, -C and MTSOLV routines. It is assumed that A is stored in the -C IA, JA, A arrays in some fashion and that M (or INV(M)) is -C stored in IWORK and RWORK in some fashion. The SLAP -C routines DSDBCG and DSLUBC are examples of this procedure. -C -C Two examples of matrix data structures are the: 1) SLAP -C Triad format and 2) SLAP Column format. -C -C =================== S L A P Triad format =================== -C In this format only the non-zeros are stored. They may -C appear in *ANY* order. The user supplies three arrays of -C length NELT, where NELT is the number of non-zeros in the -C matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero -C the user puts the row and column index of that matrix -C element in the IA and JA arrays. The value of the non-zero -C matrix element is placed in the corresponding location of -C the A array. This is an extremely easy data structure to -C generate. On the other hand it is not too efficient on -C vector computers for the iterative solution of linear -C systems. Hence, SLAP changes this input data structure to -C the SLAP Column format for the iteration (but does not -C change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C In this format the non-zeros are stored counting down -C columns (except for the diagonal entry, which must appear -C first in each "column") and are stored in the double pre- -C cision array A. In other words, for each column in the -C matrix first put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)),A(JA(ICOL)) are the first elements of the ICOL- -C th column in IA and A, and IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) -C are the last elements of the ICOL-th column. Note that we -C always have JA(N+1)=NELT+1, where N is the number of columns -C in the matrix and NELT is the number of non-zeros in the -C matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO DSDBCG, DSLUBC -C***REFERENCES 1. Mark K. Seager, A SLAP for the Masses, in -C G. F. Carey, Ed., Parallel Supercomputing: Methods, -C Algorithms and Applications, Wiley, 1989, pp.135-155. -C***ROUTINES CALLED D1MACH, DAXPY, DCOPY, DDOT, ISDBCG -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 891004 Added new reference. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MATVEC, MTTVEC, MSOLVE, MTSOLV from ROUTINES -C CALLED list. (FNF) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of reference. (FNF) -C 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE DBCG -C .. Scalar Arguments .. - DOUBLE PRECISION ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), B(N), DZ(N), P(N), PP(N), R(N), RR(N), - + RWORK(*), X(N), Z(N), ZZ(N) - INTEGER IA(NELT), IWORK(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MATVEC, MSOLVE, MTSOLV, MTTVEC -C .. Local Scalars .. - DOUBLE PRECISION AK, AKDEN, BK, BKDEN, BKNUM, BNRM, FUZZ, SOLNRM, - + TOLMIN - INTEGER I, K -C .. External Functions .. - DOUBLE PRECISION D1MACH, DDOT - INTEGER ISDBCG - EXTERNAL D1MACH, DDOT, ISDBCG -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY -C .. Intrinsic Functions .. - INTRINSIC ABS -C***FIRST EXECUTABLE STATEMENT DBCG -C -C Check some of the input data. -C - ITER = 0 - IERR = 0 - IF( N.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF - FUZZ = D1MACH(3) - TOLMIN = 500*FUZZ - FUZZ = FUZZ*FUZZ - IF( TOL.LT.TOLMIN ) THEN - TOL = TOLMIN - IERR = 4 - ENDIF -C -C Calculate initial residual and pseudo-residual, and check -C stopping criterion. - CALL MATVEC(N, X, R, NELT, IA, JA, A, ISYM) - DO 10 I = 1, N - R(I) = B(I) - R(I) - RR(I) = R(I) - 10 CONTINUE - CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) - CALL MTSOLV(N, RR, ZZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C - IF( ISDBCG(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, - $ ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, RR, ZZ, PP, - $ DZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) .NE. 0 ) - $ GO TO 200 - IF( IERR.NE.0 ) RETURN -C -C ***** iteration loop ***** -C - DO 100 K=1,ITMAX - ITER = K -C -C Calculate coefficient BK and direction vectors P and PP. - BKNUM = DDOT(N, Z, 1, RR, 1) - IF( ABS(BKNUM).LE.FUZZ ) THEN - IERR = 6 - RETURN - ENDIF - IF(ITER .EQ. 1) THEN - CALL DCOPY(N, Z, 1, P, 1) - CALL DCOPY(N, ZZ, 1, PP, 1) - ELSE - BK = BKNUM/BKDEN - DO 20 I = 1, N - P(I) = Z(I) + BK*P(I) - PP(I) = ZZ(I) + BK*PP(I) - 20 CONTINUE - ENDIF - BKDEN = BKNUM -C -C Calculate coefficient AK, new iterate X, new residuals R and -C RR, and new pseudo-residuals Z and ZZ. - CALL MATVEC(N, P, Z, NELT, IA, JA, A, ISYM) - AKDEN = DDOT(N, PP, 1, Z, 1) - AK = BKNUM/AKDEN - IF( ABS(AKDEN).LE.FUZZ ) THEN - IERR = 6 - RETURN - ENDIF - CALL DAXPY(N, AK, P, 1, X, 1) - CALL DAXPY(N, -AK, Z, 1, R, 1) - CALL MTTVEC(N, PP, ZZ, NELT, IA, JA, A, ISYM) - CALL DAXPY(N, -AK, ZZ, 1, RR, 1) - CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) - CALL MTSOLV(N, RR, ZZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C -C check stopping criterion. - IF( ISDBCG(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, - $ ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, RR, ZZ, - $ PP, DZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) .NE. 0 ) - $ GO TO 200 -C - 100 CONTINUE -C -C ***** end of loop ***** -C -C stopping criterion not satisfied. - ITER = ITMAX + 1 - IERR = 2 -C - 200 RETURN -C------------- LAST LINE OF DBCG FOLLOWS ---------------------------- - END diff --git a/slatec/dbdiff.f b/slatec/dbdiff.f deleted file mode 100644 index f1fbcba..0000000 --- a/slatec/dbdiff.f +++ /dev/null @@ -1,37 +0,0 @@ -*DECK DBDIFF - SUBROUTINE DBDIFF (L, V) -C***BEGIN PROLOGUE DBDIFF -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBSKIN -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (BDIFF-S, DBDIFF-D) -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C DBDIFF computes the sum of B(L,K)*V(K)*(-1)**K where B(L,K) -C are the binomial coefficients. Truncated sums are computed by -C setting last part of the V vector to zero. On return, the binomial -C sum is in V(L). -C -C***SEE ALSO DBSKIN -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 820601 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DBDIFF -C - INTEGER I, J, K, L - DOUBLE PRECISION V - DIMENSION V(*) -C***FIRST EXECUTABLE STATEMENT DBDIFF - IF (L.EQ.1) RETURN - DO 20 J=2,L - K = L - DO 10 I=J,L - V(K) = V(K-1) - V(K) - K = K - 1 - 10 CONTINUE - 20 CONTINUE - RETURN - END diff --git a/slatec/dbesi.f b/slatec/dbesi.f deleted file mode 100644 index 4f64d54..0000000 --- a/slatec/dbesi.f +++ /dev/null @@ -1,467 +0,0 @@ -*DECK DBESI - SUBROUTINE DBESI (X, ALPHA, KODE, N, Y, NZ) -C***BEGIN PROLOGUE DBESI -C***PURPOSE Compute an N member sequence of I Bessel functions -C I/SUB(ALPHA+K-1)/(X), K=1,...,N or scaled Bessel functions -C EXP(-X)*I/SUB(ALPHA+K-1)/(X), K=1,...,N for nonnegative -C ALPHA and X. -C***LIBRARY SLATEC -C***CATEGORY C10B3 -C***TYPE DOUBLE PRECISION (BESI-S, DBESI-D) -C***KEYWORDS I BESSEL FUNCTION, SPECIAL FUNCTIONS -C***AUTHOR Amos, D. E., (SNLA) -C Daniel, S. L., (SNLA) -C***DESCRIPTION -C -C Abstract **** a double precision routine **** -C DBESI computes an N member sequence of I Bessel functions -C I/sub(ALPHA+K-1)/(X), K=1,...,N or scaled Bessel functions -C EXP(-X)*I/sub(ALPHA+K-1)/(X), K=1,...,N for nonnegative ALPHA -C and X. A combination of the power series, the asymptotic -C expansion for X to infinity, and the uniform asymptotic -C expansion for NU to infinity are applied over subdivisions of -C the (NU,X) plane. For values not covered by one of these -C formulae, the order is incremented by an integer so that one -C of these formulae apply. Backward recursion is used to reduce -C orders by integer values. The asymptotic expansion for X to -C infinity is used only when the entire sequence (specifically -C the last member) lies within the region covered by the -C expansion. Leading terms of these expansions are used to test -C for over or underflow where appropriate. If a sequence is -C requested and the last member would underflow, the result is -C set to zero and the next lower order tried, etc., until a -C member comes on scale or all are set to zero. An overflow -C cannot occur with scaling. -C -C The maximum number of significant digits obtainable -C is the smaller of 14 and the number of digits carried in -C double precision arithmetic. -C -C Description of Arguments -C -C Input X,ALPHA are double precision -C X - X .GE. 0.0D0 -C ALPHA - order of first member of the sequence, -C ALPHA .GE. 0.0D0 -C KODE - a parameter to indicate the scaling option -C KODE=1 returns -C Y(K)= I/sub(ALPHA+K-1)/(X), -C K=1,...,N -C KODE=2 returns -C Y(K)=EXP(-X)*I/sub(ALPHA+K-1)/(X), -C K=1,...,N -C N - number of members in the sequence, N .GE. 1 -C -C Output Y is double precision -C Y - a vector whose first N components contain -C values for I/sub(ALPHA+K-1)/(X) or scaled -C values for EXP(-X)*I/sub(ALPHA+K-1)/(X), -C K=1,...,N depending on KODE -C NZ - number of components of Y set to zero due to -C underflow, -C NZ=0 , normal return, computation completed -C NZ .NE. 0, last NZ components of Y set to zero, -C Y(K)=0.0D0, K=N-NZ+1,...,N. -C -C Error Conditions -C Improper input arguments - a fatal error -C Overflow with KODE=1 - a fatal error -C Underflow - a non-fatal error(NZ .NE. 0) -C -C***REFERENCES D. E. Amos, S. L. Daniel and M. K. Weston, CDC 6600 -C subroutines IBESS and JBESS for Bessel functions -C I(NU,X) and J(NU,X), X .GE. 0, NU .GE. 0, ACM -C Transactions on Mathematical Software 3, (1977), -C pp. 76-92. -C F. W. J. Olver, Tables of Bessel Functions of Moderate -C or Large Orders, NPL Mathematical Tables 6, Her -C Majesty's Stationery Office, London, 1962. -C***ROUTINES CALLED D1MACH, DASYIK, DLNGAM, I1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 890911 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DBESI -C - INTEGER I, IALP, IN, INLIM, IS, I1, K, KK, KM, KODE, KT, - 1 N, NN, NS, NZ - INTEGER I1MACH - DOUBLE PRECISION AIN,AK,AKM,ALPHA,ANS,AP,ARG,ATOL,TOLLN,DFN, - 1 DTM, DX, EARG, ELIM, ETX, FLGIK,FN, FNF, FNI,FNP1,FNU,GLN,RA, - 2 RTTPI, S, SX, SXO2, S1, S2, T, TA, TB, TEMP, TFN, TM, TOL, - 3 TRX, T2, X, XO2, XO2L, Y, Z - DOUBLE PRECISION D1MACH, DLNGAM - DIMENSION Y(*), TEMP(3) - SAVE RTTPI, INLIM - DATA RTTPI / 3.98942280401433D-01/ - DATA INLIM / 80 / -C***FIRST EXECUTABLE STATEMENT DBESI - NZ = 0 - KT = 1 -C I1MACH(15) REPLACES I1MACH(12) IN A DOUBLE PRECISION CODE -C I1MACH(14) REPLACES I1MACH(11) IN A DOUBLE PRECISION CODE - RA = D1MACH(3) - TOL = MAX(RA,1.0D-15) - I1 = -I1MACH(15) - GLN = D1MACH(5) - ELIM = 2.303D0*(I1*GLN-3.0D0) -C TOLLN = -LN(TOL) - I1 = I1MACH(14)+1 - TOLLN = 2.303D0*GLN*I1 - TOLLN = MIN(TOLLN,34.5388D0) - IF (N-1) 590, 10, 20 - 10 KT = 2 - 20 NN = N - IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 570 - IF (X) 600, 30, 80 - 30 IF (ALPHA) 580, 40, 50 - 40 Y(1) = 1.0D0 - IF (N.EQ.1) RETURN - I1 = 2 - GO TO 60 - 50 I1 = 1 - 60 DO 70 I=I1,N - Y(I) = 0.0D0 - 70 CONTINUE - RETURN - 80 CONTINUE - IF (ALPHA.LT.0.0D0) GO TO 580 -C - IALP = INT(ALPHA) - FNI = IALP + N - 1 - FNF = ALPHA - IALP - DFN = FNI + FNF - FNU = DFN - IN = 0 - XO2 = X*0.5D0 - SXO2 = XO2*XO2 - ETX = KODE - 1 - SX = ETX*X -C -C DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X -C TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE -C APPLIED. -C - IF (SXO2.LE.(FNU+1.0D0)) GO TO 90 - IF (X.LE.12.0D0) GO TO 110 - FN = 0.55D0*FNU*FNU - FN = MAX(17.0D0,FN) - IF (X.GE.FN) GO TO 430 - ANS = MAX(36.0D0-FNU,0.0D0) - NS = INT(ANS) - FNI = FNI + NS - DFN = FNI + FNF - FN = DFN - IS = KT - KM = N - 1 + NS - IF (KM.GT.0) IS = 3 - GO TO 120 - 90 FN = FNU - FNP1 = FN + 1.0D0 - XO2L = LOG(XO2) - IS = KT - IF (X.LE.0.5D0) GO TO 230 - NS = 0 - 100 FNI = FNI + NS - DFN = FNI + FNF - FN = DFN - FNP1 = FN + 1.0D0 - IS = KT - IF (N-1+NS.GT.0) IS = 3 - GO TO 230 - 110 XO2L = LOG(XO2) - NS = INT(SXO2-FNU) - GO TO 100 - 120 CONTINUE -C -C OVERFLOW TEST ON UNIFORM ASYMPTOTIC EXPANSION -C - IF (KODE.EQ.2) GO TO 130 - IF (ALPHA.LT.1.0D0) GO TO 150 - Z = X/ALPHA - RA = SQRT(1.0D0+Z*Z) - GLN = LOG((1.0D0+RA)/Z) - T = RA*(1.0D0-ETX) + ETX/(Z+RA) - ARG = ALPHA*(T-GLN) - IF (ARG.GT.ELIM) GO TO 610 - IF (KM.EQ.0) GO TO 140 - 130 CONTINUE -C -C UNDERFLOW TEST ON UNIFORM ASYMPTOTIC EXPANSION -C - Z = X/FN - RA = SQRT(1.0D0+Z*Z) - GLN = LOG((1.0D0+RA)/Z) - T = RA*(1.0D0-ETX) + ETX/(Z+RA) - ARG = FN*(T-GLN) - 140 IF (ARG.LT.(-ELIM)) GO TO 280 - GO TO 190 - 150 IF (X.GT.ELIM) GO TO 610 - GO TO 130 -C -C UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY -C - 160 IF (KM.NE.0) GO TO 170 - Y(1) = TEMP(3) - RETURN - 170 TEMP(1) = TEMP(3) - IN = NS - KT = 1 - I1 = 0 - 180 CONTINUE - IS = 2 - FNI = FNI - 1.0D0 - DFN = FNI + FNF - FN = DFN - IF(I1.EQ.2) GO TO 350 - Z = X/FN - RA = SQRT(1.0D0+Z*Z) - GLN = LOG((1.0D0+RA)/Z) - T = RA*(1.0D0-ETX) + ETX/(Z+RA) - ARG = FN*(T-GLN) - 190 CONTINUE - I1 = ABS(3-IS) - I1 = MAX(I1,1) - FLGIK = 1.0D0 - CALL DASYIK(X,FN,KODE,FLGIK,RA,ARG,I1,TEMP(IS)) - GO TO (180, 350, 510), IS -C -C SERIES FOR (X/2)**2.LE.NU+1 -C - 230 CONTINUE - GLN = DLNGAM(FNP1) - ARG = FN*XO2L - GLN - SX - IF (ARG.LT.(-ELIM)) GO TO 300 - EARG = EXP(ARG) - 240 CONTINUE - S = 1.0D0 - IF (X.LT.TOL) GO TO 260 - AK = 3.0D0 - T2 = 1.0D0 - T = 1.0D0 - S1 = FN - DO 250 K=1,17 - S2 = T2 + S1 - T = T*SXO2/S2 - S = S + T - IF (ABS(T).LT.TOL) GO TO 260 - T2 = T2 + AK - AK = AK + 2.0D0 - S1 = S1 + FN - 250 CONTINUE - 260 CONTINUE - TEMP(IS) = S*EARG - GO TO (270, 350, 500), IS - 270 EARG = EARG*FN/XO2 - FNI = FNI - 1.0D0 - DFN = FNI + FNF - FN = DFN - IS = 2 - GO TO 240 -C -C SET UNDERFLOW VALUE AND UPDATE PARAMETERS -C - 280 Y(NN) = 0.0D0 - NN = NN - 1 - FNI = FNI - 1.0D0 - DFN = FNI + FNF - FN = DFN - IF (NN-1) 340, 290, 130 - 290 KT = 2 - IS = 2 - GO TO 130 - 300 Y(NN) = 0.0D0 - NN = NN - 1 - FNP1 = FN - FNI = FNI - 1.0D0 - DFN = FNI + FNF - FN = DFN - IF (NN-1) 340, 310, 320 - 310 KT = 2 - IS = 2 - 320 IF (SXO2.LE.FNP1) GO TO 330 - GO TO 130 - 330 ARG = ARG - XO2L + LOG(FNP1) - IF (ARG.LT.(-ELIM)) GO TO 300 - GO TO 230 - 340 NZ = N - NN - RETURN -C -C BACKWARD RECURSION SECTION -C - 350 CONTINUE - NZ = N - NN - 360 CONTINUE - IF(KT.EQ.2) GO TO 420 - S1 = TEMP(1) - S2 = TEMP(2) - TRX = 2.0D0/X - DTM = FNI - TM = (DTM+FNF)*TRX - IF (IN.EQ.0) GO TO 390 -C BACKWARD RECUR TO INDEX ALPHA+NN-1 - DO 380 I=1,IN - S = S2 - S2 = TM*S2 + S1 - S1 = S - DTM = DTM - 1.0D0 - TM = (DTM+FNF)*TRX - 380 CONTINUE - Y(NN) = S1 - IF (NN.EQ.1) RETURN - Y(NN-1) = S2 - IF (NN.EQ.2) RETURN - GO TO 400 - 390 CONTINUE -C BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA - Y(NN) = S1 - Y(NN-1) = S2 - IF (NN.EQ.2) RETURN - 400 K = NN + 1 - DO 410 I=3,NN - K = K - 1 - Y(K-2) = TM*Y(K-1) + Y(K) - DTM = DTM - 1.0D0 - TM = (DTM+FNF)*TRX - 410 CONTINUE - RETURN - 420 Y(1) = TEMP(2) - RETURN -C -C ASYMPTOTIC EXPANSION FOR X TO INFINITY -C - 430 CONTINUE - EARG = RTTPI/SQRT(X) - IF (KODE.EQ.2) GO TO 440 - IF (X.GT.ELIM) GO TO 610 - EARG = EARG*EXP(X) - 440 ETX = 8.0D0*X - IS = KT - IN = 0 - FN = FNU - 450 DX = FNI + FNI - TM = 0.0D0 - IF (FNI.EQ.0.0D0 .AND. ABS(FNF).LT.TOL) GO TO 460 - TM = 4.0D0*FNF*(FNI+FNI+FNF) - 460 CONTINUE - DTM = DX*DX - S1 = ETX - TRX = DTM - 1.0D0 - DX = -(TRX+TM)/ETX - T = DX - S = 1.0D0 + DX - ATOL = TOL*ABS(S) - S2 = 1.0D0 - AK = 8.0D0 - DO 470 K=1,25 - S1 = S1 + ETX - S2 = S2 + AK - DX = DTM - S2 - AP = DX + TM - T = -T*AP/S1 - S = S + T - IF (ABS(T).LE.ATOL) GO TO 480 - AK = AK + 8.0D0 - 470 CONTINUE - 480 TEMP(IS) = S*EARG - IF(IS.EQ.2) GO TO 360 - IS = 2 - FNI = FNI - 1.0D0 - DFN = FNI + FNF - FN = DFN - GO TO 450 -C -C BACKWARD RECURSION WITH NORMALIZATION BY -C ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES. -C - 500 CONTINUE -C COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION - AKM = MAX(3.0D0-FN,0.0D0) - KM = INT(AKM) - TFN = FN + KM - TA = (GLN+TFN-0.9189385332D0-0.0833333333D0/TFN)/(TFN+0.5D0) - TA = XO2L - TA - TB = -(1.0D0-1.0D0/TFN)/TFN - AIN = TOLLN/(-TA+SQRT(TA*TA-TOLLN*TB)) + 1.5D0 - IN = INT(AIN) - IN = IN + KM - GO TO 520 - 510 CONTINUE -C COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION - T = 1.0D0/(FN*RA) - AIN = TOLLN/(GLN+SQRT(GLN*GLN+T*TOLLN)) + 1.5D0 - IN = INT(AIN) - IF (IN.GT.INLIM) GO TO 160 - 520 CONTINUE - TRX = 2.0D0/X - DTM = FNI + IN - TM = (DTM+FNF)*TRX - TA = 0.0D0 - TB = TOL - KK = 1 - 530 CONTINUE -C -C BACKWARD RECUR UNINDEXED -C - DO 540 I=1,IN - S = TB - TB = TM*TB + TA - TA = S - DTM = DTM - 1.0D0 - TM = (DTM+FNF)*TRX - 540 CONTINUE -C NORMALIZATION - IF (KK.NE.1) GO TO 550 - TA = (TA/TB)*TEMP(3) - TB = TEMP(3) - KK = 2 - IN = NS - IF (NS.NE.0) GO TO 530 - 550 Y(NN) = TB - NZ = N - NN - IF (NN.EQ.1) RETURN - TB = TM*TB + TA - K = NN - 1 - Y(K) = TB - IF (NN.EQ.2) RETURN - DTM = DTM - 1.0D0 - TM = (DTM+FNF)*TRX - KM = K - 1 -C -C BACKWARD RECUR INDEXED -C - DO 560 I=1,KM - Y(K-1) = TM*Y(K) + Y(K+1) - DTM = DTM - 1.0D0 - TM = (DTM+FNF)*TRX - K = K - 1 - 560 CONTINUE - RETURN -C -C -C - 570 CONTINUE - CALL XERMSG ('SLATEC', 'DBESI', - + 'SCALING OPTION, KODE, NOT 1 OR 2.', 2, 1) - RETURN - 580 CONTINUE - CALL XERMSG ('SLATEC', 'DBESI', 'ORDER, ALPHA, LESS THAN ZERO.', - + 2, 1) - RETURN - 590 CONTINUE - CALL XERMSG ('SLATEC', 'DBESI', 'N LESS THAN ONE.', 2, 1) - RETURN - 600 CONTINUE - CALL XERMSG ('SLATEC', 'DBESI', 'X LESS THAN ZERO.', 2, 1) - RETURN - 610 CONTINUE - CALL XERMSG ('SLATEC', 'DBESI', - + 'OVERFLOW, X TOO LARGE FOR KODE = 1.', 6, 1) - RETURN - END diff --git a/slatec/dbesi0.f b/slatec/dbesi0.f deleted file mode 100644 index ef4e2c4..0000000 --- a/slatec/dbesi0.f +++ /dev/null @@ -1,78 +0,0 @@ -*DECK DBESI0 - DOUBLE PRECISION FUNCTION DBESI0 (X) -C***BEGIN PROLOGUE DBESI0 -C***PURPOSE Compute the hyperbolic Bessel function of the first kind -C of order zero. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10B1 -C***TYPE DOUBLE PRECISION (BESI0-S, DBESI0-D) -C***KEYWORDS FIRST KIND, FNLIB, HYPERBOLIC BESSEL FUNCTION, -C MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DBESI0(X) calculates the double precision modified (hyperbolic) -C Bessel function of the first kind of order zero and double -C precision argument X. -C -C Series for BI0 on the interval 0. to 9.00000E+00 -C with weighted error 9.51E-34 -C log weighted error 33.02 -C significant figures required 33.31 -C decimal places required 33.65 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DBSI0E, DCSEVL, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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***END PROLOGUE DBESI0 - DOUBLE PRECISION X, BI0CS(18), XMAX, XSML, Y, D1MACH, - 1 DCSEVL, DBSI0E - LOGICAL FIRST - SAVE BI0CS, NTI0, XSML, XMAX, FIRST - DATA BI0CS( 1) / -.7660547252 8391449510 8189497624 3285 D-1 / - DATA BI0CS( 2) / +.1927337953 9938082699 5240875088 1196 D+1 / - DATA BI0CS( 3) / +.2282644586 9203013389 3702929233 0415 D+0 / - DATA BI0CS( 4) / +.1304891466 7072904280 7933421069 1888 D-1 / - DATA BI0CS( 5) / +.4344270900 8164874513 7868268102 6107 D-3 / - DATA BI0CS( 6) / +.9422657686 0019346639 2317174411 8766 D-5 / - DATA BI0CS( 7) / +.1434006289 5106910799 6209187817 9957 D-6 / - DATA BI0CS( 8) / +.1613849069 6617490699 1541971999 4611 D-8 / - DATA BI0CS( 9) / +.1396650044 5356696994 9509270814 2522 D-10 / - DATA BI0CS( 10) / +.9579451725 5054453446 2752317189 3333 D-13 / - DATA BI0CS( 11) / +.5333981859 8625021310 1510774400 0000 D-15 / - DATA BI0CS( 12) / +.2458716088 4374707746 9678591999 9999 D-17 / - DATA BI0CS( 13) / +.9535680890 2487700269 4434133333 3333 D-20 / - DATA BI0CS( 14) / +.3154382039 7214273367 8933333333 3333 D-22 / - DATA BI0CS( 15) / +.9004564101 0946374314 6666666666 6666 D-25 / - DATA BI0CS( 16) / +.2240647369 1236700160 0000000000 0000 D-27 / - DATA BI0CS( 17) / +.4903034603 2428373333 3333333333 3333 D-30 / - DATA BI0CS( 18) / +.9508172606 1226666666 6666666666 6666 D-33 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DBESI0 - IF (FIRST) THEN - NTI0 = INITDS (BI0CS, 18, 0.1*REAL(D1MACH(3))) - XSML = SQRT(4.5D0*D1MACH(3)) - XMAX = LOG (D1MACH(2)) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.3.0D0) GO TO 20 -C - DBESI0 = 1.0D0 - IF (Y.GT.XSML) DBESI0 = 2.75D0 + DCSEVL (Y*Y/4.5D0-1.D0, BI0CS, - 1 NTI0) - RETURN -C - 20 IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'DBESI0', - + 'ABS(X) SO BIG I0 OVERFLOWS', 2, 2) -C - DBESI0 = EXP(Y) * DBSI0E(X) -C - RETURN - END diff --git a/slatec/dbesi1.f b/slatec/dbesi1.f deleted file mode 100644 index 0306c06..0000000 --- a/slatec/dbesi1.f +++ /dev/null @@ -1,83 +0,0 @@ -*DECK DBESI1 - DOUBLE PRECISION FUNCTION DBESI1 (X) -C***BEGIN PROLOGUE DBESI1 -C***PURPOSE Compute the modified (hyperbolic) Bessel function of the -C first kind of order one. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10B1 -C***TYPE DOUBLE PRECISION (BESI1-S, DBESI1-D) -C***KEYWORDS FIRST KIND, FNLIB, HYPERBOLIC BESSEL FUNCTION, -C MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DBESI1(X) calculates the double precision modified (hyperbolic) -C Bessel function of the first kind of order one and double precision -C argument X. -C -C Series for BI1 on the interval 0. to 9.00000E+00 -C with weighted error 1.44E-32 -C log weighted error 31.84 -C significant figures required 31.45 -C decimal places required 32.46 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DBSI1E, DCSEVL, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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***END PROLOGUE DBESI1 - DOUBLE PRECISION X, BI1CS(17), XMAX, XMIN, XSML, Y, D1MACH, - 1 DCSEVL, DBSI1E - LOGICAL FIRST - SAVE BI1CS, NTI1, XMIN, XSML, XMAX, FIRST - DATA BI1CS( 1) / -.1971713261 0998597316 1385032181 49 D-2 / - DATA BI1CS( 2) / +.4073488766 7546480608 1553936520 14 D+0 / - DATA BI1CS( 3) / +.3483899429 9959455866 2450377837 87 D-1 / - DATA BI1CS( 4) / +.1545394556 3001236038 5984010584 89 D-2 / - DATA BI1CS( 5) / +.4188852109 8377784129 4588320041 20 D-4 / - DATA BI1CS( 6) / +.7649026764 8362114741 9597039660 69 D-6 / - DATA BI1CS( 7) / +.1004249392 4741178689 1798080372 38 D-7 / - DATA BI1CS( 8) / +.9932207791 9238106481 3712980548 63 D-10 / - DATA BI1CS( 9) / +.7663801791 8447637275 2001716813 49 D-12 / - DATA BI1CS( 10) / +.4741418923 8167394980 3880919481 60 D-14 / - DATA BI1CS( 11) / +.2404114404 0745181799 8631720320 00 D-16 / - DATA BI1CS( 12) / +.1017150500 7093713649 1211007999 99 D-18 / - DATA BI1CS( 13) / +.3645093565 7866949458 4917333333 33 D-21 / - DATA BI1CS( 14) / +.1120574950 2562039344 8106666666 66 D-23 / - DATA BI1CS( 15) / +.2987544193 4468088832 0000000000 00 D-26 / - DATA BI1CS( 16) / +.6973231093 9194709333 3333333333 33 D-29 / - DATA BI1CS( 17) / +.1436794822 0620800000 0000000000 00 D-31 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DBESI1 - IF (FIRST) THEN - NTI1 = INITDS (BI1CS, 17, 0.1*REAL(D1MACH(3))) - XMIN = 2.0D0*D1MACH(1) - XSML = SQRT(4.5D0*D1MACH(3)) - XMAX = LOG (D1MACH(2)) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.3.0D0) GO TO 20 -C - DBESI1 = 0.D0 - IF (Y.EQ.0.D0) RETURN -C - IF (Y .LE. XMIN) CALL XERMSG ('SLATEC', 'DBESI1', - + 'ABS(X) SO SMALL I1 UNDERFLOWS', 1, 1) - IF (Y.GT.XMIN) DBESI1 = 0.5D0*X - IF (Y.GT.XSML) DBESI1 = X*(0.875D0 + DCSEVL (Y*Y/4.5D0-1.D0, - 1 BI1CS, NTI1)) - RETURN -C - 20 IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'DBESI1', - + 'ABS(X) SO BIG I1 OVERFLOWS', 2, 2) -C - DBESI1 = EXP(Y) * DBSI1E(X) -C - RETURN - END diff --git a/slatec/dbesj.f b/slatec/dbesj.f deleted file mode 100644 index 11fcb4f..0000000 --- a/slatec/dbesj.f +++ /dev/null @@ -1,508 +0,0 @@ -*DECK DBESJ - SUBROUTINE DBESJ (X, ALPHA, N, Y, NZ) -C***BEGIN PROLOGUE DBESJ -C***PURPOSE Compute an N member sequence of J Bessel functions -C J/SUB(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA -C and X. -C***LIBRARY SLATEC -C***CATEGORY C10A3 -C***TYPE DOUBLE PRECISION (BESJ-S, DBESJ-D) -C***KEYWORDS J BESSEL FUNCTION, SPECIAL FUNCTIONS -C***AUTHOR Amos, D. E., (SNLA) -C Daniel, S. L., (SNLA) -C Weston, M. K., (SNLA) -C***DESCRIPTION -C -C Abstract **** a double precision routine **** -C DBESJ computes an N member sequence of J Bessel functions -C J/sub(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA and X. -C A combination of the power series, the asymptotic expansion -C for X to infinity and the uniform asymptotic expansion for -C NU to infinity are applied over subdivisions of the (NU,X) -C plane. For values of (NU,X) not covered by one of these -C formulae, the order is incremented or decremented by integer -C values into a region where one of the formulae apply. Backward -C recursion is applied to reduce orders by integer values except -C where the entire sequence lies in the oscillatory region. In -C this case forward recursion is stable and values from the -C asymptotic expansion for X to infinity start the recursion -C when it is efficient to do so. Leading terms of the series and -C uniform expansion are tested for underflow. If a sequence is -C requested and the last member would underflow, the result is -C set to zero and the next lower order tried, etc., until a -C member comes on scale or all members are set to zero. -C Overflow cannot occur. -C -C The maximum number of significant digits obtainable -C is the smaller of 14 and the number of digits carried in -C double precision arithmetic. -C -C Description of Arguments -C -C Input X,ALPHA are double precision -C X - X .GE. 0.0D0 -C ALPHA - order of first member of the sequence, -C ALPHA .GE. 0.0D0 -C N - number of members in the sequence, N .GE. 1 -C -C Output Y is double precision -C Y - a vector whose first N components contain -C values for J/sub(ALPHA+K-1)/(X), K=1,...,N -C NZ - number of components of Y set to zero due to -C underflow, -C NZ=0 , normal return, computation completed -C NZ .NE. 0, last NZ components of Y set to zero, -C Y(K)=0.0D0, K=N-NZ+1,...,N. -C -C Error Conditions -C Improper input arguments - a fatal error -C Underflow - a non-fatal error (NZ .NE. 0) -C -C***REFERENCES D. E. Amos, S. L. Daniel and M. K. Weston, CDC 6600 -C subroutines IBESS and JBESS for Bessel functions -C I(NU,X) and J(NU,X), X .GE. 0, NU .GE. 0, ACM -C Transactions on Mathematical Software 3, (1977), -C pp. 76-92. -C F. W. J. Olver, Tables of Bessel Functions of Moderate -C or Large Orders, NPL Mathematical Tables 6, Her -C Majesty's Stationery Office, London, 1962. -C***ROUTINES CALLED D1MACH, DASYJY, DJAIRY, DLNGAM, I1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 890911 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DBESJ - EXTERNAL DJAIRY - INTEGER I,IALP,IDALP,IFLW,IN,INLIM,IS,I1,I2,K,KK,KM,KT,N,NN, - 1 NS,NZ - INTEGER I1MACH - DOUBLE PRECISION AK,AKM,ALPHA,ANS,AP,ARG,COEF,DALPHA,DFN,DTM, - 1 EARG,ELIM1,ETX,FIDAL,FLGJY,FN,FNF,FNI,FNP1,FNU, - 2 FNULIM,GLN,PDF,PIDT,PP,RDEN,RELB,RTTP,RTWO,RTX,RZDEN, - 3 S,SA,SB,SXO2,S1,S2,T,TA,TAU,TB,TEMP,TFN,TM,TOL, - 4 TOLLN,TRX,TX,T1,T2,WK,X,XO2,XO2L,Y,SLIM,RTOL - SAVE RTWO, PDF, RTTP, PIDT, PP, INLIM, FNULIM - DOUBLE PRECISION D1MACH, DLNGAM - DIMENSION Y(*), TEMP(3), FNULIM(2), PP(4), WK(7) - DATA RTWO,PDF,RTTP,PIDT / 1.34839972492648D+00, - 1 7.85398163397448D-01, 7.97884560802865D-01, 1.57079632679490D+00/ - DATA PP(1), PP(2), PP(3), PP(4) / 8.72909153935547D+00, - 1 2.65693932265030D-01, 1.24578576865586D-01, 7.70133747430388D-04/ - DATA INLIM / 150 / - DATA FNULIM(1), FNULIM(2) / 100.0D0, 60.0D0 / -C***FIRST EXECUTABLE STATEMENT DBESJ - NZ = 0 - KT = 1 - NS=0 -C I1MACH(14) REPLACES I1MACH(11) IN A DOUBLE PRECISION CODE -C I1MACH(15) REPLACES I1MACH(12) IN A DOUBLE PRECISION CODE - TA = D1MACH(3) - TOL = MAX(TA,1.0D-15) - I1 = I1MACH(14) + 1 - I2 = I1MACH(15) - TB = D1MACH(5) - ELIM1 = -2.303D0*(I2*TB+3.0D0) - RTOL=1.0D0/TOL - SLIM=D1MACH(1)*RTOL*1.0D+3 -C TOLLN = -LN(TOL) - TOLLN = 2.303D0*TB*I1 - TOLLN = MIN(TOLLN,34.5388D0) - IF (N-1) 720, 10, 20 - 10 KT = 2 - 20 NN = N - IF (X) 730, 30, 80 - 30 IF (ALPHA) 710, 40, 50 - 40 Y(1) = 1.0D0 - IF (N.EQ.1) RETURN - I1 = 2 - GO TO 60 - 50 I1 = 1 - 60 DO 70 I=I1,N - Y(I) = 0.0D0 - 70 CONTINUE - RETURN - 80 CONTINUE - IF (ALPHA.LT.0.0D0) GO TO 710 -C - IALP = INT(ALPHA) - FNI = IALP + N - 1 - FNF = ALPHA - IALP - DFN = FNI + FNF - FNU = DFN - XO2 = X*0.5D0 - SXO2 = XO2*XO2 -C -C DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X -C TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE -C APPLIED. -C - IF (SXO2.LE.(FNU+1.0D0)) GO TO 90 - TA = MAX(20.0D0,FNU) - IF (X.GT.TA) GO TO 120 - IF (X.GT.12.0D0) GO TO 110 - XO2L = LOG(XO2) - NS = INT(SXO2-FNU) + 1 - GO TO 100 - 90 FN = FNU - FNP1 = FN + 1.0D0 - XO2L = LOG(XO2) - IS = KT - IF (X.LE.0.50D0) GO TO 330 - NS = 0 - 100 FNI = FNI + NS - DFN = FNI + FNF - FN = DFN - FNP1 = FN + 1.0D0 - IS = KT - IF (N-1+NS.GT.0) IS = 3 - GO TO 330 - 110 ANS = MAX(36.0D0-FNU,0.0D0) - NS = INT(ANS) - FNI = FNI + NS - DFN = FNI + FNF - FN = DFN - IS = KT - IF (N-1+NS.GT.0) IS = 3 - GO TO 130 - 120 CONTINUE - RTX = SQRT(X) - TAU = RTWO*RTX - TA = TAU + FNULIM(KT) - IF (FNU.LE.TA) GO TO 480 - FN = FNU - IS = KT -C -C UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY -C - 130 CONTINUE - I1 = ABS(3-IS) - I1 = MAX(I1,1) - FLGJY = 1.0D0 - CALL DASYJY(DJAIRY,X,FN,FLGJY,I1,TEMP(IS),WK,IFLW) - IF(IFLW.NE.0) GO TO 380 - GO TO (320, 450, 620), IS - 310 TEMP(1) = TEMP(3) - KT = 1 - 320 IS = 2 - FNI = FNI - 1.0D0 - DFN = FNI + FNF - FN = DFN - IF(I1.EQ.2) GO TO 450 - GO TO 130 -C -C SERIES FOR (X/2)**2.LE.NU+1 -C - 330 CONTINUE - GLN = DLNGAM(FNP1) - ARG = FN*XO2L - GLN - IF (ARG.LT.(-ELIM1)) GO TO 400 - EARG = EXP(ARG) - 340 CONTINUE - S = 1.0D0 - IF (X.LT.TOL) GO TO 360 - AK = 3.0D0 - T2 = 1.0D0 - T = 1.0D0 - S1 = FN - DO 350 K=1,17 - S2 = T2 + S1 - T = -T*SXO2/S2 - S = S + T - IF (ABS(T).LT.TOL) GO TO 360 - T2 = T2 + AK - AK = AK + 2.0D0 - S1 = S1 + FN - 350 CONTINUE - 360 CONTINUE - TEMP(IS) = S*EARG - GO TO (370, 450, 610), IS - 370 EARG = EARG*FN/XO2 - FNI = FNI - 1.0D0 - DFN = FNI + FNF - FN = DFN - IS = 2 - GO TO 340 -C -C SET UNDERFLOW VALUE AND UPDATE PARAMETERS -C UNDERFLOW CAN ONLY OCCUR FOR NS=0 SINCE THE ORDER MUST BE LARGER -C THAN 36. THEREFORE, NS NEE NOT BE TESTED. -C - 380 Y(NN) = 0.0D0 - NN = NN - 1 - FNI = FNI - 1.0D0 - DFN = FNI + FNF - FN = DFN - IF (NN-1) 440, 390, 130 - 390 KT = 2 - IS = 2 - GO TO 130 - 400 Y(NN) = 0.0D0 - NN = NN - 1 - FNP1 = FN - FNI = FNI - 1.0D0 - DFN = FNI + FNF - FN = DFN - IF (NN-1) 440, 410, 420 - 410 KT = 2 - IS = 2 - 420 IF (SXO2.LE.FNP1) GO TO 430 - GO TO 130 - 430 ARG = ARG - XO2L + LOG(FNP1) - IF (ARG.LT.(-ELIM1)) GO TO 400 - GO TO 330 - 440 NZ = N - NN - RETURN -C -C BACKWARD RECURSION SECTION -C - 450 CONTINUE - IF(NS.NE.0) GO TO 451 - NZ = N - NN - IF (KT.EQ.2) GO TO 470 -C BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA - Y(NN) = TEMP(1) - Y(NN-1) = TEMP(2) - IF (NN.EQ.2) RETURN - 451 CONTINUE - TRX = 2.0D0/X - DTM = FNI - TM = (DTM+FNF)*TRX - AK=1.0D0 - TA=TEMP(1) - TB=TEMP(2) - IF(ABS(TA).GT.SLIM) GO TO 455 - TA=TA*RTOL - TB=TB*RTOL - AK=TOL - 455 CONTINUE - KK=2 - IN=NS-1 - IF(IN.EQ.0) GO TO 690 - IF(NS.NE.0) GO TO 670 - K=NN-2 - DO 460 I=3,NN - S=TB - TB = TM*TB - TA - TA=S - Y(K)=TB*AK - DTM = DTM - 1.0D0 - TM = (DTM+FNF)*TRX - K = K - 1 - 460 CONTINUE - RETURN - 470 Y(1) = TEMP(2) - RETURN -C -C ASYMPTOTIC EXPANSION FOR X TO INFINITY WITH FORWARD RECURSION IN -C OSCILLATORY REGION X.GT.MAX(20, NU), PROVIDED THE LAST MEMBER -C OF THE SEQUENCE IS ALSO IN THE REGION. -C - 480 CONTINUE - IN = INT(ALPHA-TAU+2.0D0) - IF (IN.LE.0) GO TO 490 - IDALP = IALP - IN - 1 - KT = 1 - GO TO 500 - 490 CONTINUE - IDALP = IALP - IN = 0 - 500 IS = KT - FIDAL = IDALP - DALPHA = FIDAL + FNF - ARG = X - PIDT*DALPHA - PDF - SA = SIN(ARG) - SB = COS(ARG) - COEF = RTTP/RTX - ETX = 8.0D0*X - 510 CONTINUE - DTM = FIDAL + FIDAL - DTM = DTM*DTM - TM = 0.0D0 - IF (FIDAL.EQ.0.0D0 .AND. ABS(FNF).LT.TOL) GO TO 520 - TM = 4.0D0*FNF*(FIDAL+FIDAL+FNF) - 520 CONTINUE - TRX = DTM - 1.0D0 - T2 = (TRX+TM)/ETX - S2 = T2 - RELB = TOL*ABS(T2) - T1 = ETX - S1 = 1.0D0 - FN = 1.0D0 - AK = 8.0D0 - DO 530 K=1,13 - T1 = T1 + ETX - FN = FN + AK - TRX = DTM - FN - AP = TRX + TM - T2 = -T2*AP/T1 - S1 = S1 + T2 - T1 = T1 + ETX - AK = AK + 8.0D0 - FN = FN + AK - TRX = DTM - FN - AP = TRX + TM - T2 = T2*AP/T1 - S2 = S2 + T2 - IF (ABS(T2).LE.RELB) GO TO 540 - AK = AK + 8.0D0 - 530 CONTINUE - 540 TEMP(IS) = COEF*(S1*SB-S2*SA) - IF(IS.EQ.2) GO TO 560 - FIDAL = FIDAL + 1.0D0 - DALPHA = FIDAL + FNF - IS = 2 - TB = SA - SA = -SB - SB = TB - GO TO 510 -C -C FORWARD RECURSION SECTION -C - 560 IF (KT.EQ.2) GO TO 470 - S1 = TEMP(1) - S2 = TEMP(2) - TX = 2.0D0/X - TM = DALPHA*TX - IF (IN.EQ.0) GO TO 580 -C -C FORWARD RECUR TO INDEX ALPHA -C - DO 570 I=1,IN - S = S2 - S2 = TM*S2 - S1 - TM = TM + TX - S1 = S - 570 CONTINUE - IF (NN.EQ.1) GO TO 600 - S = S2 - S2 = TM*S2 - S1 - TM = TM + TX - S1 = S - 580 CONTINUE -C -C FORWARD RECUR FROM INDEX ALPHA TO ALPHA+N-1 -C - Y(1) = S1 - Y(2) = S2 - IF (NN.EQ.2) RETURN - DO 590 I=3,NN - Y(I) = TM*Y(I-1) - Y(I-2) - TM = TM + TX - 590 CONTINUE - RETURN - 600 Y(1) = S2 - RETURN -C -C BACKWARD RECURSION WITH NORMALIZATION BY -C ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES. -C - 610 CONTINUE -C COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION - AKM = MAX(3.0D0-FN,0.0D0) - KM = INT(AKM) - TFN = FN + KM - TA = (GLN+TFN-0.9189385332D0-0.0833333333D0/TFN)/(TFN+0.5D0) - TA = XO2L - TA - TB = -(1.0D0-1.5D0/TFN)/TFN - AKM = TOLLN/(-TA+SQRT(TA*TA-TOLLN*TB)) + 1.5D0 - IN = KM + INT(AKM) - GO TO 660 - 620 CONTINUE -C COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION - GLN = WK(3) + WK(2) - IF (WK(6).GT.30.0D0) GO TO 640 - RDEN = (PP(4)*WK(6)+PP(3))*WK(6) + 1.0D0 - RZDEN = PP(1) + PP(2)*WK(6) - TA = RZDEN/RDEN - IF (WK(1).LT.0.10D0) GO TO 630 - TB = GLN/WK(5) - GO TO 650 - 630 TB=(1.259921049D0+(0.1679894730D0+0.0887944358D0*WK(1))*WK(1)) - 1 /WK(7) - GO TO 650 - 640 CONTINUE - TA = 0.5D0*TOLLN/WK(4) - TA=((0.0493827160D0*TA-0.1111111111D0)*TA+0.6666666667D0)*TA*WK(6) - IF (WK(1).LT.0.10D0) GO TO 630 - TB = GLN/WK(5) - 650 IN = INT(TA/TB+1.5D0) - IF (IN.GT.INLIM) GO TO 310 - 660 CONTINUE - DTM = FNI + IN - TRX = 2.0D0/X - TM = (DTM+FNF)*TRX - TA = 0.0D0 - TB = TOL - KK = 1 - AK=1.0D0 - 670 CONTINUE -C -C BACKWARD RECUR UNINDEXED -C - DO 680 I=1,IN - S = TB - TB = TM*TB - TA - TA = S - DTM = DTM - 1.0D0 - TM = (DTM+FNF)*TRX - 680 CONTINUE -C NORMALIZATION - IF (KK.NE.1) GO TO 690 - S=TEMP(3) - SA=TA/TB - TA=S - TB=S - IF(ABS(S).GT.SLIM) GO TO 685 - TA=TA*RTOL - TB=TB*RTOL - AK=TOL - 685 CONTINUE - TA=TA*SA - KK = 2 - IN = NS - IF (NS.NE.0) GO TO 670 - 690 Y(NN) = TB*AK - NZ = N - NN - IF (NN.EQ.1) RETURN - K = NN - 1 - S=TB - TB = TM*TB - TA - TA=S - Y(K)=TB*AK - IF (NN.EQ.2) RETURN - DTM = DTM - 1.0D0 - TM = (DTM+FNF)*TRX - K=NN-2 -C -C BACKWARD RECUR INDEXED -C - DO 700 I=3,NN - S=TB - TB = TM*TB - TA - TA=S - Y(K)=TB*AK - DTM = DTM - 1.0D0 - TM = (DTM+FNF)*TRX - K = K - 1 - 700 CONTINUE - RETURN -C -C -C - 710 CONTINUE - CALL XERMSG ('SLATEC', 'DBESJ', 'ORDER, ALPHA, LESS THAN ZERO.', - + 2, 1) - RETURN - 720 CONTINUE - CALL XERMSG ('SLATEC', 'DBESJ', 'N LESS THAN ONE.', 2, 1) - RETURN - 730 CONTINUE - CALL XERMSG ('SLATEC', 'DBESJ', 'X LESS THAN ZERO.', 2, 1) - RETURN - END diff --git a/slatec/dbesj0.f b/slatec/dbesj0.f deleted file mode 100644 index 4d4a007..0000000 --- a/slatec/dbesj0.f +++ /dev/null @@ -1,73 +0,0 @@ -*DECK DBESJ0 - DOUBLE PRECISION FUNCTION DBESJ0 (X) -C***BEGIN PROLOGUE DBESJ0 -C***PURPOSE Compute the Bessel function of the first kind of order -C zero. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10A1 -C***TYPE DOUBLE PRECISION (BESJ0-S, DBESJ0-D) -C***KEYWORDS BESSEL FUNCTION, FIRST KIND, FNLIB, ORDER ZERO, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DBESJ0(X) calculates the double precision Bessel function of -C the first kind of order zero for double precision argument X. -C -C Series for BJ0 on the interval 0. to 1.60000E+01 -C with weighted error 4.39E-32 -C log weighted error 31.36 -C significant figures required 31.21 -C decimal places required 32.00 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, D9B0MP, DCSEVL, INITDS -C***REVISION HISTORY (YYMMDD) -C 770701 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***END PROLOGUE DBESJ0 - DOUBLE PRECISION X, BJ0CS(19), AMPL, THETA, XSML, Y, D1MACH, - 1 DCSEVL - LOGICAL FIRST - SAVE BJ0CS, NTJ0, XSML, FIRST - DATA BJ0CS( 1) / +.1002541619 6893913701 0731272640 74 D+0 / - DATA BJ0CS( 2) / -.6652230077 6440513177 6787578311 24 D+0 / - DATA BJ0CS( 3) / +.2489837034 9828131370 4604687266 80 D+0 / - DATA BJ0CS( 4) / -.3325272317 0035769653 8843415038 54 D-1 / - DATA BJ0CS( 5) / +.2311417930 4694015462 9049241177 29 D-2 / - DATA BJ0CS( 6) / -.9911277419 9508092339 0485193365 49 D-4 / - DATA BJ0CS( 7) / +.2891670864 3998808884 7339037470 78 D-5 / - DATA BJ0CS( 8) / -.6121085866 3032635057 8184074815 16 D-7 / - DATA BJ0CS( 9) / +.9838650793 8567841324 7687486364 15 D-9 / - DATA BJ0CS( 10) / -.1242355159 7301765145 5158970068 36 D-10 / - DATA BJ0CS( 11) / +.1265433630 2559045797 9158272103 63 D-12 / - DATA BJ0CS( 12) / -.1061945649 5287244546 9148175129 59 D-14 / - DATA BJ0CS( 13) / +.7470621075 8024567437 0989155840 00 D-17 / - DATA BJ0CS( 14) / -.4469703227 4412780547 6270079999 99 D-19 / - DATA BJ0CS( 15) / +.2302428158 4337436200 5230933333 33 D-21 / - DATA BJ0CS( 16) / -.1031914479 4166698148 5226666666 66 D-23 / - DATA BJ0CS( 17) / +.4060817827 4873322700 8000000000 00 D-26 / - DATA BJ0CS( 18) / -.1414383600 5240913919 9999999999 99 D-28 / - DATA BJ0CS( 19) / +.4391090549 6698880000 0000000000 00 D-31 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DBESJ0 - IF (FIRST) THEN - NTJ0 = INITDS (BJ0CS, 19, 0.1*REAL(D1MACH(3))) - XSML = SQRT(8.0D0*D1MACH(3)) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.4.0D0) GO TO 20 -C - DBESJ0 = 1.0D0 - IF (Y.GT.XSML) DBESJ0 = DCSEVL (.125D0*Y*Y-1.D0, BJ0CS, NTJ0) - RETURN -C - 20 CALL D9B0MP (Y, AMPL, THETA) - DBESJ0 = AMPL * COS(THETA) -C - RETURN - END diff --git a/slatec/dbesj1.f b/slatec/dbesj1.f deleted file mode 100644 index c6ef17f..0000000 --- a/slatec/dbesj1.f +++ /dev/null @@ -1,82 +0,0 @@ -*DECK DBESJ1 - DOUBLE PRECISION FUNCTION DBESJ1 (X) -C***BEGIN PROLOGUE DBESJ1 -C***PURPOSE Compute the Bessel function of the first kind of order one. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10A1 -C***TYPE DOUBLE PRECISION (BESJ1-S, DBESJ1-D) -C***KEYWORDS BESSEL FUNCTION, FIRST KIND, FNLIB, ORDER ONE, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DBESJ1(X) calculates the double precision Bessel function of the -C first kind of order one for double precision argument X. -C -C Series for BJ1 on the interval 0. to 1.60000E+01 -C with weighted error 1.16E-33 -C log weighted error 32.93 -C significant figures required 32.36 -C decimal places required 33.57 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, D9B1MP, DCSEVL, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 780601 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 910401 Corrected error in code which caused values to have the -C wrong sign for arguments less than 4.0. (WRB) -C***END PROLOGUE DBESJ1 - DOUBLE PRECISION X, BJ1CS(19), AMPL, THETA, XSML, XMIN, Y, - 1 D1MACH, DCSEVL - LOGICAL FIRST - SAVE BJ1CS, NTJ1, XSML, XMIN, FIRST - DATA BJ1CS( 1) / -.1172614151 3332786560 6240574524 003 D+0 / - DATA BJ1CS( 2) / -.2536152183 0790639562 3030884554 698 D+0 / - DATA BJ1CS( 3) / +.5012708098 4469568505 3656363203 743 D-1 / - DATA BJ1CS( 4) / -.4631514809 6250819184 2619728789 772 D-2 / - DATA BJ1CS( 5) / +.2479962294 1591402453 9124064592 364 D-3 / - DATA BJ1CS( 6) / -.8678948686 2788258452 1246435176 416 D-5 / - DATA BJ1CS( 7) / +.2142939171 4379369150 2766250991 292 D-6 / - DATA BJ1CS( 8) / -.3936093079 1831797922 9322764073 061 D-8 / - DATA BJ1CS( 9) / +.5591182317 9468800401 8248059864 032 D-10 / - DATA BJ1CS( 10) / -.6327616404 6613930247 7695274014 880 D-12 / - DATA BJ1CS( 11) / +.5840991610 8572470032 6945563268 266 D-14 / - DATA BJ1CS( 12) / -.4482533818 7012581903 9135059199 999 D-16 / - DATA BJ1CS( 13) / +.2905384492 6250246630 6018688000 000 D-18 / - DATA BJ1CS( 14) / -.1611732197 8414416541 2118186666 666 D-20 / - DATA BJ1CS( 15) / +.7739478819 3927463729 8346666666 666 D-23 / - DATA BJ1CS( 16) / -.3248693782 1119984114 3466666666 666 D-25 / - DATA BJ1CS( 17) / +.1202237677 2274102272 0000000000 000 D-27 / - DATA BJ1CS( 18) / -.3952012212 6513493333 3333333333 333 D-30 / - DATA BJ1CS( 19) / +.1161678082 2664533333 3333333333 333 D-32 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DBESJ1 - IF (FIRST) THEN - NTJ1 = INITDS (BJ1CS, 19, 0.1*REAL(D1MACH(3))) -C - XSML = SQRT(8.0D0*D1MACH(3)) - XMIN = 2.0D0*D1MACH(1) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.4.0D0) GO TO 20 -C - DBESJ1 = 0.0D0 - IF (Y.EQ.0.0D0) RETURN - IF (Y .LE. XMIN) CALL XERMSG ('SLATEC', 'DBESJ1', - + 'ABS(X) SO SMALL J1 UNDERFLOWS', 1, 1) - IF (Y.GT.XMIN) DBESJ1 = 0.5D0*X - IF (Y.GT.XSML) DBESJ1 = X*(.25D0 + DCSEVL (.125D0*Y*Y-1.D0, - 1 BJ1CS, NTJ1) ) - RETURN -C - 20 CALL D9B1MP (Y, AMPL, THETA) - DBESJ1 = SIGN (AMPL, X) * COS(THETA) -C - RETURN - END diff --git a/slatec/dbesk.f b/slatec/dbesk.f deleted file mode 100644 index 2e4384f..0000000 --- a/slatec/dbesk.f +++ /dev/null @@ -1,280 +0,0 @@ -*DECK DBESK - SUBROUTINE DBESK (X, FNU, KODE, N, Y, NZ) -C***BEGIN PROLOGUE DBESK -C***PURPOSE Implement forward recursion on the three term recursion -C relation for a sequence of non-negative order Bessel -C functions K/SUB(FNU+I-1)/(X), or scaled Bessel functions -C EXP(X)*K/SUB(FNU+I-1)/(X), I=1,...,N for real, positive -C X and non-negative orders FNU. -C***LIBRARY SLATEC -C***CATEGORY C10B3 -C***TYPE DOUBLE PRECISION (BESK-S, DBESK-D) -C***KEYWORDS K BESSEL FUNCTION, SPECIAL FUNCTIONS -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Abstract **** a double precision routine **** -C DBESK implements forward recursion on the three term -C recursion relation for a sequence of non-negative order Bessel -C functions K/sub(FNU+I-1)/(X), or scaled Bessel functions -C EXP(X)*K/sub(FNU+I-1)/(X), I=1,..,N for real X .GT. 0.0D0 and -C non-negative orders FNU. If FNU .LT. NULIM, orders FNU and -C FNU+1 are obtained from DBSKNU to start the recursion. If -C FNU .GE. NULIM, the uniform asymptotic expansion is used for -C orders FNU and FNU+1 to start the recursion. NULIM is 35 or -C 70 depending on whether N=1 or N .GE. 2. Under and overflow -C tests are made on the leading term of the asymptotic expansion -C before any extensive computation is done. -C -C The maximum number of significant digits obtainable -C is the smaller of 14 and the number of digits carried in -C double precision arithmetic. -C -C Description of Arguments -C -C Input X,FNU are double precision -C X - X .GT. 0.0D0 -C FNU - order of the initial K function, FNU .GE. 0.0D0 -C KODE - a parameter to indicate the scaling option -C KODE=1 returns Y(I)= K/sub(FNU+I-1)/(X), -C I=1,...,N -C KODE=2 returns Y(I)=EXP(X)*K/sub(FNU+I-1)/(X), -C I=1,...,N -C N - number of members in the sequence, N .GE. 1 -C -C Output Y is double precision -C Y - a vector whose first N components contain values -C for the sequence -C Y(I)= k/sub(FNU+I-1)/(X), I=1,...,N or -C Y(I)=EXP(X)*K/sub(FNU+I-1)/(X), I=1,...,N -C depending on KODE -C NZ - number of components of Y set to zero due to -C underflow with KODE=1, -C NZ=0 , normal return, computation completed -C NZ .NE. 0, first NZ components of Y set to zero -C due to underflow, Y(I)=0.0D0, I=1,...,NZ -C -C Error Conditions -C Improper input arguments - a fatal error -C Overflow - a fatal error -C Underflow with KODE=1 - a non-fatal error (NZ .NE. 0) -C -C***REFERENCES F. W. J. Olver, Tables of Bessel Functions of Moderate -C or Large Orders, NPL Mathematical Tables 6, Her -C Majesty's Stationery Office, London, 1962. -C N. M. Temme, On the numerical evaluation of the modified -C Bessel function of the third kind, Journal of -C Computational Physics 19, (1975), pp. 324-337. -C***ROUTINES CALLED D1MACH, DASYIK, DBESK0, DBESK1, DBSK0E, DBSK1E, -C DBSKNU, I1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790201 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 890911 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***END PROLOGUE DBESK -C - INTEGER I, J, K, KODE, MZ, N, NB, ND, NN, NUD, NULIM, NZ - INTEGER I1MACH - DOUBLE PRECISION CN,DNU,ELIM,ETX,FLGIK,FN,FNN,FNU,GLN,GNU,RTZ, - 1 S, S1, S2, T, TM, TRX, W, X, XLIM, Y, ZN - DOUBLE PRECISION DBESK0, DBESK1, DBSK1E, DBSK0E, D1MACH - DIMENSION W(2), NULIM(2), Y(*) - SAVE NULIM - DATA NULIM(1),NULIM(2) / 35 , 70 / -C***FIRST EXECUTABLE STATEMENT DBESK - NN = -I1MACH(15) - ELIM = 2.303D0*(NN*D1MACH(5)-3.0D0) - XLIM = D1MACH(1)*1.0D+3 - IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 280 - IF (FNU.LT.0.0D0) GO TO 290 - IF (X.LE.0.0D0) GO TO 300 - IF (X.LT.XLIM) GO TO 320 - IF (N.LT.1) GO TO 310 - ETX = KODE - 1 -C -C ND IS A DUMMY VARIABLE FOR N -C GNU IS A DUMMY VARIABLE FOR FNU -C NZ = NUMBER OF UNDERFLOWS ON KODE=1 -C - ND = N - NZ = 0 - NUD = INT(FNU) - DNU = FNU - NUD - GNU = FNU - NN = MIN(2,ND) - FN = FNU + N - 1 - FNN = FN - IF (FN.LT.2.0D0) GO TO 150 -C -C OVERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION) -C FOR THE LAST ORDER, FNU+N-1.GE.NULIM -C - ZN = X/FN - IF (ZN.EQ.0.0D0) GO TO 320 - RTZ = SQRT(1.0D0+ZN*ZN) - GLN = LOG((1.0D0+RTZ)/ZN) - T = RTZ*(1.0D0-ETX) + ETX/(ZN+RTZ) - CN = -FN*(T-GLN) - IF (CN.GT.ELIM) GO TO 320 - IF (NUD.LT.NULIM(NN)) GO TO 30 - IF (NN.EQ.1) GO TO 20 - 10 CONTINUE -C -C UNDERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION) -C FOR THE FIRST ORDER, FNU.GE.NULIM -C - FN = GNU - ZN = X/FN - RTZ = SQRT(1.0D0+ZN*ZN) - GLN = LOG((1.0D0+RTZ)/ZN) - T = RTZ*(1.0D0-ETX) + ETX/(ZN+RTZ) - CN = -FN*(T-GLN) - 20 CONTINUE - IF (CN.LT.-ELIM) GO TO 230 -C -C ASYMPTOTIC EXPANSION FOR ORDERS FNU AND FNU+1.GE.NULIM -C - FLGIK = -1.0D0 - CALL DASYIK(X,GNU,KODE,FLGIK,RTZ,CN,NN,Y) - IF (NN.EQ.1) GO TO 240 - TRX = 2.0D0/X - TM = (GNU+GNU+2.0D0)/X - GO TO 130 -C - 30 CONTINUE - IF (KODE.EQ.2) GO TO 40 -C -C UNDERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION IN X) -C FOR ORDER DNU -C - IF (X.GT.ELIM) GO TO 230 - 40 CONTINUE - IF (DNU.NE.0.0D0) GO TO 80 - IF (KODE.EQ.2) GO TO 50 - S1 = DBESK0(X) - GO TO 60 - 50 S1 = DBSK0E(X) - 60 CONTINUE - IF (NUD.EQ.0 .AND. ND.EQ.1) GO TO 120 - IF (KODE.EQ.2) GO TO 70 - S2 = DBESK1(X) - GO TO 90 - 70 S2 = DBSK1E(X) - GO TO 90 - 80 CONTINUE - NB = 2 - IF (NUD.EQ.0 .AND. ND.EQ.1) NB = 1 - CALL DBSKNU(X, DNU, KODE, NB, W, NZ) - S1 = W(1) - IF (NB.EQ.1) GO TO 120 - S2 = W(2) - 90 CONTINUE - TRX = 2.0D0/X - TM = (DNU+DNU+2.0D0)/X -C FORWARD RECUR FROM DNU TO FNU+1 TO GET Y(1) AND Y(2) - IF (ND.EQ.1) NUD = NUD - 1 - IF (NUD.GT.0) GO TO 100 - IF (ND.GT.1) GO TO 120 - S1 = S2 - GO TO 120 - 100 CONTINUE - DO 110 I=1,NUD - S = S2 - S2 = TM*S2 + S1 - S1 = S - TM = TM + TRX - 110 CONTINUE - IF (ND.EQ.1) S1 = S2 - 120 CONTINUE - Y(1) = S1 - IF (ND.EQ.1) GO TO 240 - Y(2) = S2 - 130 CONTINUE - IF (ND.EQ.2) GO TO 240 -C FORWARD RECUR FROM FNU+2 TO FNU+N-1 - DO 140 I=3,ND - Y(I) = TM*Y(I-1) + Y(I-2) - TM = TM + TRX - 140 CONTINUE - GO TO 240 -C - 150 CONTINUE -C UNDERFLOW TEST FOR KODE=1 - IF (KODE.EQ.2) GO TO 160 - IF (X.GT.ELIM) GO TO 230 - 160 CONTINUE -C OVERFLOW TEST - IF (FN.LE.1.0D0) GO TO 170 - IF (-FN*(LOG(X)-0.693D0).GT.ELIM) GO TO 320 - 170 CONTINUE - IF (DNU.EQ.0.0D0) GO TO 180 - CALL DBSKNU(X, FNU, KODE, ND, Y, MZ) - GO TO 240 - 180 CONTINUE - J = NUD - IF (J.EQ.1) GO TO 210 - J = J + 1 - IF (KODE.EQ.2) GO TO 190 - Y(J) = DBESK0(X) - GO TO 200 - 190 Y(J) = DBSK0E(X) - 200 IF (ND.EQ.1) GO TO 240 - J = J + 1 - 210 IF (KODE.EQ.2) GO TO 220 - Y(J) = DBESK1(X) - GO TO 240 - 220 Y(J) = DBSK1E(X) - GO TO 240 -C -C UPDATE PARAMETERS ON UNDERFLOW -C - 230 CONTINUE - NUD = NUD + 1 - ND = ND - 1 - IF (ND.EQ.0) GO TO 240 - NN = MIN(2,ND) - GNU = GNU + 1.0D0 - IF (FNN.LT.2.0D0) GO TO 230 - IF (NUD.LT.NULIM(NN)) GO TO 230 - GO TO 10 - 240 CONTINUE - NZ = N - ND - IF (NZ.EQ.0) RETURN - IF (ND.EQ.0) GO TO 260 - DO 250 I=1,ND - J = N - I + 1 - K = ND - I + 1 - Y(J) = Y(K) - 250 CONTINUE - 260 CONTINUE - DO 270 I=1,NZ - Y(I) = 0.0D0 - 270 CONTINUE - RETURN -C -C -C - 280 CONTINUE - CALL XERMSG ('SLATEC', 'DBESK', - + 'SCALING OPTION, KODE, NOT 1 OR 2', 2, 1) - RETURN - 290 CONTINUE - CALL XERMSG ('SLATEC', 'DBESK', 'ORDER, FNU, LESS THAN ZERO', 2, - + 1) - RETURN - 300 CONTINUE - CALL XERMSG ('SLATEC', 'DBESK', 'X LESS THAN OR EQUAL TO ZERO', - + 2, 1) - RETURN - 310 CONTINUE - CALL XERMSG ('SLATEC', 'DBESK', 'N LESS THAN ONE', 2, 1) - RETURN - 320 CONTINUE - CALL XERMSG ('SLATEC', 'DBESK', - + 'OVERFLOW, FNU OR N TOO LARGE OR X TOO SMALL', 6, 1) - RETURN - END diff --git a/slatec/dbesk0.f b/slatec/dbesk0.f deleted file mode 100644 index 99d61e8..0000000 --- a/slatec/dbesk0.f +++ /dev/null @@ -1,83 +0,0 @@ -*DECK DBESK0 - DOUBLE PRECISION FUNCTION DBESK0 (X) -C***BEGIN PROLOGUE DBESK0 -C***PURPOSE Compute the modified (hyperbolic) Bessel function of the -C third kind of order zero. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10B1 -C***TYPE DOUBLE PRECISION (BESK0-S, DBESK0-D) -C***KEYWORDS FNLIB, HYPERBOLIC BESSEL FUNCTION, -C MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS, -C THIRD KIND -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DBESK0(X) calculates the double precision modified (hyperbolic) -C Bessel function of the third kind of order zero for double -C precision argument X. The argument must be greater than zero -C but not so large that the result underflows. -C -C Series for BK0 on the interval 0. to 4.00000E+00 -C with weighted error 3.08E-33 -C log weighted error 32.51 -C significant figures required 32.05 -C decimal places required 33.11 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DBESI0, DBSK0E, DCSEVL, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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***END PROLOGUE DBESK0 - DOUBLE PRECISION X, BK0CS(16), XMAX, XMAXT, XSML, Y, - 1 D1MACH, DCSEVL, DBESI0, DBSK0E - LOGICAL FIRST - SAVE BK0CS, NTK0, XSML, XMAX, FIRST - DATA BK0CS( 1) / -.3532739323 3902768720 1140060063 153 D-1 / - DATA BK0CS( 2) / +.3442898999 2462848688 6344927529 213 D+0 / - DATA BK0CS( 3) / +.3597993651 5361501626 5721303687 231 D-1 / - DATA BK0CS( 4) / +.1264615411 4469259233 8479508673 447 D-2 / - DATA BK0CS( 5) / +.2286212103 1194517860 8269830297 585 D-4 / - DATA BK0CS( 6) / +.2534791079 0261494573 0790013428 354 D-6 / - DATA BK0CS( 7) / +.1904516377 2202088589 7214059381 366 D-8 / - DATA BK0CS( 8) / +.1034969525 7633624585 1008317853 089 D-10 / - DATA BK0CS( 9) / +.4259816142 7910825765 2445327170 133 D-13 / - DATA BK0CS( 10) / +.1374465435 8807508969 4238325440 000 D-15 / - DATA BK0CS( 11) / +.3570896528 5083735909 9688597333 333 D-18 / - DATA BK0CS( 12) / +.7631643660 1164373766 7498666666 666 D-21 / - DATA BK0CS( 13) / +.1365424988 4407818590 8053333333 333 D-23 / - DATA BK0CS( 14) / +.2075275266 9066680831 9999999999 999 D-26 / - DATA BK0CS( 15) / +.2712814218 0729856000 0000000000 000 D-29 / - DATA BK0CS( 16) / +.3082593887 9146666666 6666666666 666 D-32 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DBESK0 - IF (FIRST) THEN - NTK0 = INITDS (BK0CS, 16, 0.1*REAL(D1MACH(3))) - XSML = SQRT(4.0D0*D1MACH(3)) - XMAXT = -LOG(D1MACH(1)) - XMAX = XMAXT - 0.5D0*XMAXT*LOG(XMAXT)/(XMAXT+0.5D0) - ENDIF - FIRST = .FALSE. -C - IF (X .LE. 0.D0) CALL XERMSG ('SLATEC', 'DBESK0', - + 'X IS ZERO OR NEGATIVE', 2, 2) - IF (X.GT.2.0D0) GO TO 20 -C - Y = 0.D0 - IF (X.GT.XSML) Y = X*X - DBESK0 = -LOG(0.5D0*X)*DBESI0(X) - 0.25D0 + DCSEVL (.5D0*Y-1.D0, - 1 BK0CS, NTK0) - RETURN -C - 20 DBESK0 = 0.D0 - IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'DBESK0', - + 'X SO BIG K0 UNDERFLOWS', 1, 1) - IF (X.GT.XMAX) RETURN -C - DBESK0 = EXP(-X) * DBSK0E(X) -C - RETURN - END diff --git a/slatec/dbesk1.f b/slatec/dbesk1.f deleted file mode 100644 index 262abe3..0000000 --- a/slatec/dbesk1.f +++ /dev/null @@ -1,86 +0,0 @@ -*DECK DBESK1 - DOUBLE PRECISION FUNCTION DBESK1 (X) -C***BEGIN PROLOGUE DBESK1 -C***PURPOSE Compute the modified (hyperbolic) Bessel function of the -C third kind of order one. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10B1 -C***TYPE DOUBLE PRECISION (BESK1-S, DBESK1-D) -C***KEYWORDS FNLIB, HYPERBOLIC BESSEL FUNCTION, -C MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS, -C THIRD KIND -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DBESK1(X) calculates the double precision modified (hyperbolic) -C Bessel function of the third kind of order one for double precision -C argument X. The argument must be large enough that the result does -C not overflow and small enough that the result does not underflow. -C -C Series for BK1 on the interval 0. to 4.00000E+00 -C with weighted error 9.16E-32 -C log weighted error 31.04 -C significant figures required 30.61 -C decimal places required 31.64 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DBESI1, DBSK1E, DCSEVL, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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***END PROLOGUE DBESK1 - DOUBLE PRECISION X, BK1CS(16), XMAX, XMAXT, XMIN, XSML, Y, - 1 D1MACH, DCSEVL, DBESI1, DBSK1E - LOGICAL FIRST - SAVE BK1CS, NTK1, XMIN, XSML, XMAX, FIRST - DATA BK1CS( 1) / +.2530022733 8947770532 5311208685 33 D-1 / - DATA BK1CS( 2) / -.3531559607 7654487566 7238316918 01 D+0 / - DATA BK1CS( 3) / -.1226111808 2265714823 4790679300 42 D+0 / - DATA BK1CS( 4) / -.6975723859 6398643501 8129202960 83 D-2 / - DATA BK1CS( 5) / -.1730288957 5130520630 1765073689 79 D-3 / - DATA BK1CS( 6) / -.2433406141 5659682349 6007350301 64 D-5 / - DATA BK1CS( 7) / -.2213387630 7347258558 3152525451 26 D-7 / - DATA BK1CS( 8) / -.1411488392 6335277610 9583302126 08 D-9 / - DATA BK1CS( 9) / -.6666901694 1993290060 8537512643 73 D-12 / - DATA BK1CS( 10) / -.2427449850 5193659339 2631968648 53 D-14 / - DATA BK1CS( 11) / -.7023863479 3862875971 7837971200 00 D-17 / - DATA BK1CS( 12) / -.1654327515 5100994675 4910293333 33 D-19 / - DATA BK1CS( 13) / -.3233834745 9944491991 8933333333 33 D-22 / - DATA BK1CS( 14) / -.5331275052 9265274999 4666666666 66 D-25 / - DATA BK1CS( 15) / -.7513040716 2157226666 6666666666 66 D-28 / - DATA BK1CS( 16) / -.9155085717 6541866666 6666666666 66 D-31 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DBESK1 - IF (FIRST) THEN - NTK1 = INITDS (BK1CS, 16, 0.1*REAL(D1MACH(3))) - XMIN = EXP(MAX(LOG(D1MACH(1)), -LOG(D1MACH(2))) + 0.01D0) - XSML = SQRT(4.0D0*D1MACH(3)) - XMAXT = -LOG(D1MACH(1)) - XMAX = XMAXT - 0.5D0*XMAXT*LOG(XMAXT)/(XMAXT+0.5D0) - ENDIF - FIRST = .FALSE. -C - IF (X .LE. 0.D0) CALL XERMSG ('SLATEC', 'DBESK1', - + 'X IS ZERO OR NEGATIVE', 2, 2) - IF (X.GT.2.0D0) GO TO 20 -C - IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'DBESK1', - + 'X SO SMALL K1 OVERFLOWS', 3, 2) - Y = 0.D0 - IF (X.GT.XSML) Y = X*X - DBESK1 = LOG(0.5D0*X)*DBESI1(X) + (0.75D0 + DCSEVL (.5D0*Y-1.D0, - 1 BK1CS, NTK1))/X - RETURN -C - 20 DBESK1 = 0.D0 - IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'DBESK1', - + 'X SO BIG K1 UNDERFLOWS', 1, 1) - IF (X.GT.XMAX) RETURN -C - DBESK1 = EXP(-X) * DBSK1E(X) -C - RETURN - END diff --git a/slatec/dbesks.f b/slatec/dbesks.f deleted file mode 100644 index 7d5eed3..0000000 --- a/slatec/dbesks.f +++ /dev/null @@ -1,50 +0,0 @@ -*DECK DBESKS - SUBROUTINE DBESKS (XNU, X, NIN, BK) -C***BEGIN PROLOGUE DBESKS -C***PURPOSE Compute a sequence of modified Bessel functions of the -C third kind of fractional order. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10B3 -C***TYPE DOUBLE PRECISION (BESKS-S, DBESKS-D) -C***KEYWORDS FNLIB, FRACTIONAL ORDER, MODIFIED BESSEL FUNCTION, -C SEQUENCE OF BESSEL FUNCTIONS, SPECIAL FUNCTIONS, -C THIRD KIND -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DBESKS computes a sequence of modified Bessel functions of the third -C kind of order XNU + I at X, where X .GT. 0, XNU lies in (-1,1), -C and I = 0, 1, ... , NIN - 1, if NIN is positive and I = 0, 1, ... , -C NIN + 1, if NIN is negative. On return, the vector BK(.) contains -C the results at X for order starting at XNU. XNU, X, and BK are -C double precision. NIN is an integer. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DBSKES, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE DBESKS - DOUBLE PRECISION XNU, X, BK(*), EXPXI, XMAX, D1MACH - SAVE XMAX - DATA XMAX / 0.D0 / -C***FIRST EXECUTABLE STATEMENT DBESKS - IF (XMAX.EQ.0.D0) XMAX = -LOG (D1MACH(1)) -C - IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'DBESKS', - + 'X SO BIG BESSEL K UNDERFLOWS', 1, 2) -C - CALL DBSKES (XNU, X, NIN, BK) -C - EXPXI = EXP (-X) - N = ABS (NIN) - DO 20 I=1,N - BK(I) = EXPXI * BK(I) - 20 CONTINUE -C - RETURN - END diff --git a/slatec/dbesy.f b/slatec/dbesy.f deleted file mode 100644 index bd9caaf..0000000 --- a/slatec/dbesy.f +++ /dev/null @@ -1,203 +0,0 @@ -*DECK DBESY - SUBROUTINE DBESY (X, FNU, N, Y) -C***BEGIN PROLOGUE DBESY -C***PURPOSE Implement forward recursion on the three term recursion -C relation for a sequence of non-negative order Bessel -C functions Y/SUB(FNU+I-1)/(X), I=1,...,N for real, positive -C X and non-negative orders FNU. -C***LIBRARY SLATEC -C***CATEGORY C10A3 -C***TYPE DOUBLE PRECISION (BESY-S, DBESY-D) -C***KEYWORDS SPECIAL FUNCTIONS, Y BESSEL FUNCTION -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Abstract **** a double precision routine **** -C DBESY implements forward recursion on the three term -C recursion relation for a sequence of non-negative order Bessel -C functions Y/sub(FNU+I-1)/(X), I=1,N for real X .GT. 0.0D0 and -C non-negative orders FNU. If FNU .LT. NULIM, orders FNU and -C FNU+1 are obtained from DBSYNU which computes by a power -C series for X .LE. 2, the K Bessel function of an imaginary -C argument for 2 .LT. X .LE. 20 and the asymptotic expansion for -C X .GT. 20. -C -C If FNU .GE. NULIM, the uniform asymptotic expansion is coded -C in DASYJY for orders FNU and FNU+1 to start the recursion. -C NULIM is 70 or 100 depending on whether N=1 or N .GE. 2. An -C overflow test is made on the leading term of the asymptotic -C expansion before any extensive computation is done. -C -C The maximum number of significant digits obtainable -C is the smaller of 14 and the number of digits carried in -C double precision arithmetic. -C -C Description of Arguments -C -C Input -C X - X .GT. 0.0D0 -C FNU - order of the initial Y function, FNU .GE. 0.0D0 -C N - number of members in the sequence, N .GE. 1 -C -C Output -C Y - a vector whose first N components contain values -C for the sequence Y(I)=Y/sub(FNU+I-1)/(X), I=1,N. -C -C Error Conditions -C Improper input arguments - a fatal error -C Overflow - a fatal error -C -C***REFERENCES F. W. J. Olver, Tables of Bessel Functions of Moderate -C or Large Orders, NPL Mathematical Tables 6, Her -C Majesty's Stationery Office, London, 1962. -C N. M. Temme, On the numerical evaluation of the modified -C Bessel function of the third kind, Journal of -C Computational Physics 19, (1975), pp. 324-337. -C N. M. Temme, On the numerical evaluation of the ordinary -C Bessel function of the second kind, Journal of -C Computational Physics 21, (1976), pp. 343-350. -C***ROUTINES CALLED D1MACH, DASYJY, DBESY0, DBESY1, DBSYNU, DYAIRY, -C I1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800501 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 890911 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***END PROLOGUE DBESY -C - EXTERNAL DYAIRY - INTEGER I, IFLW, J, N, NB, ND, NN, NUD, NULIM - INTEGER I1MACH - DOUBLE PRECISION AZN,CN,DNU,ELIM,FLGJY,FN,FNU,RAN,S,S1,S2,TM,TRX, - 1 W,WK,W2N,X,XLIM,XXN,Y - DOUBLE PRECISION DBESY0, DBESY1, D1MACH - DIMENSION W(2), NULIM(2), Y(*), WK(7) - SAVE NULIM - DATA NULIM(1),NULIM(2) / 70 , 100 / -C***FIRST EXECUTABLE STATEMENT DBESY - NN = -I1MACH(15) - ELIM = 2.303D0*(NN*D1MACH(5)-3.0D0) - XLIM = D1MACH(1)*1.0D+3 - IF (FNU.LT.0.0D0) GO TO 140 - IF (X.LE.0.0D0) GO TO 150 - IF (X.LT.XLIM) GO TO 170 - IF (N.LT.1) GO TO 160 -C -C ND IS A DUMMY VARIABLE FOR N -C - ND = N - NUD = INT(FNU) - DNU = FNU - NUD - NN = MIN(2,ND) - FN = FNU + N - 1 - IF (FN.LT.2.0D0) GO TO 100 -C -C OVERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION) -C FOR THE LAST ORDER, FNU+N-1.GE.NULIM -C - XXN = X/FN - W2N = 1.0D0-XXN*XXN - IF(W2N.LE.0.0D0) GO TO 10 - RAN = SQRT(W2N) - AZN = LOG((1.0D0+RAN)/XXN) - RAN - CN = FN*AZN - IF(CN.GT.ELIM) GO TO 170 - 10 CONTINUE - IF (NUD.LT.NULIM(NN)) GO TO 20 -C -C ASYMPTOTIC EXPANSION FOR ORDERS FNU AND FNU+1.GE.NULIM -C - FLGJY = -1.0D0 - CALL DASYJY(DYAIRY,X,FNU,FLGJY,NN,Y,WK,IFLW) - IF(IFLW.NE.0) GO TO 170 - IF (NN.EQ.1) RETURN - TRX = 2.0D0/X - TM = (FNU+FNU+2.0D0)/X - GO TO 80 -C - 20 CONTINUE - IF (DNU.NE.0.0D0) GO TO 30 - S1 = DBESY0(X) - IF (NUD.EQ.0 .AND. ND.EQ.1) GO TO 70 - S2 = DBESY1(X) - GO TO 40 - 30 CONTINUE - NB = 2 - IF (NUD.EQ.0 .AND. ND.EQ.1) NB = 1 - CALL DBSYNU(X, DNU, NB, W) - S1 = W(1) - IF (NB.EQ.1) GO TO 70 - S2 = W(2) - 40 CONTINUE - TRX = 2.0D0/X - TM = (DNU+DNU+2.0D0)/X -C FORWARD RECUR FROM DNU TO FNU+1 TO GET Y(1) AND Y(2) - IF (ND.EQ.1) NUD = NUD - 1 - IF (NUD.GT.0) GO TO 50 - IF (ND.GT.1) GO TO 70 - S1 = S2 - GO TO 70 - 50 CONTINUE - DO 60 I=1,NUD - S = S2 - S2 = TM*S2 - S1 - S1 = S - TM = TM + TRX - 60 CONTINUE - IF (ND.EQ.1) S1 = S2 - 70 CONTINUE - Y(1) = S1 - IF (ND.EQ.1) RETURN - Y(2) = S2 - 80 CONTINUE - IF (ND.EQ.2) RETURN -C FORWARD RECUR FROM FNU+2 TO FNU+N-1 - DO 90 I=3,ND - Y(I) = TM*Y(I-1) - Y(I-2) - TM = TM + TRX - 90 CONTINUE - RETURN -C - 100 CONTINUE -C OVERFLOW TEST - IF (FN.LE.1.0D0) GO TO 110 - IF (-FN*(LOG(X)-0.693D0).GT.ELIM) GO TO 170 - 110 CONTINUE - IF (DNU.EQ.0.0D0) GO TO 120 - CALL DBSYNU(X, FNU, ND, Y) - RETURN - 120 CONTINUE - J = NUD - IF (J.EQ.1) GO TO 130 - J = J + 1 - Y(J) = DBESY0(X) - IF (ND.EQ.1) RETURN - J = J + 1 - 130 CONTINUE - Y(J) = DBESY1(X) - IF (ND.EQ.1) RETURN - TRX = 2.0D0/X - TM = TRX - GO TO 80 -C -C -C - 140 CONTINUE - CALL XERMSG ('SLATEC', 'DBESY', 'ORDER, FNU, LESS THAN ZERO', 2, - + 1) - RETURN - 150 CONTINUE - CALL XERMSG ('SLATEC', 'DBESY', 'X LESS THAN OR EQUAL TO ZERO', - + 2, 1) - RETURN - 160 CONTINUE - CALL XERMSG ('SLATEC', 'DBESY', 'N LESS THAN ONE', 2, 1) - RETURN - 170 CONTINUE - CALL XERMSG ('SLATEC', 'DBESY', - + 'OVERFLOW, FNU OR N TOO LARGE OR X TOO SMALL', 6, 1) - RETURN - END diff --git a/slatec/dbesy0.f b/slatec/dbesy0.f deleted file mode 100644 index 57c1042..0000000 --- a/slatec/dbesy0.f +++ /dev/null @@ -1,78 +0,0 @@ -*DECK DBESY0 - DOUBLE PRECISION FUNCTION DBESY0 (X) -C***BEGIN PROLOGUE DBESY0 -C***PURPOSE Compute the Bessel function of the second kind of order -C zero. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10A1 -C***TYPE DOUBLE PRECISION (BESY0-S, DBESY0-D) -C***KEYWORDS BESSEL FUNCTION, FNLIB, ORDER ZERO, SECOND KIND, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DBESY0(X) calculates the double precision Bessel function of the -C second kind of order zero for double precision argument X. -C -C Series for BY0 on the interval 0. to 1.60000E+01 -C with weighted error 8.14E-32 -C log weighted error 31.09 -C significant figures required 30.31 -C decimal places required 31.73 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, D9B0MP, DBESJ0, DCSEVL, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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***END PROLOGUE DBESY0 - DOUBLE PRECISION X, BY0CS(19), AMPL, THETA, TWODPI, XSML, - 1 Y, D1MACH, DCSEVL, DBESJ0 - LOGICAL FIRST - SAVE BY0CS, TWODPI, NTY0, XSML, FIRST - DATA BY0CS( 1) / -.1127783939 2865573217 9398054602 8 D-1 / - DATA BY0CS( 2) / -.1283452375 6042034604 8088453183 8 D+0 / - DATA BY0CS( 3) / -.1043788479 9794249365 8176227661 8 D+0 / - DATA BY0CS( 4) / +.2366274918 3969695409 2415926461 3 D-1 / - DATA BY0CS( 5) / -.2090391647 7004862391 9622395034 2 D-2 / - DATA BY0CS( 6) / +.1039754539 3905725209 9924657638 1 D-3 / - DATA BY0CS( 7) / -.3369747162 4239720967 1877534503 7 D-5 / - DATA BY0CS( 8) / +.7729384267 6706671585 2136721637 1 D-7 / - DATA BY0CS( 9) / -.1324976772 6642595914 4347606896 4 D-8 / - DATA BY0CS( 10) / +.1764823261 5404527921 0038936315 8 D-10 / - DATA BY0CS( 11) / -.1881055071 5801962006 0282301206 9 D-12 / - DATA BY0CS( 12) / +.1641865485 3661495027 9223718574 9 D-14 / - DATA BY0CS( 13) / -.1195659438 6046060857 4599100672 0 D-16 / - DATA BY0CS( 14) / +.7377296297 4401858424 9411242666 6 D-19 / - DATA BY0CS( 15) / -.3906843476 7104373307 4090666666 6 D-21 / - DATA BY0CS( 16) / +.1795503664 4361579498 2912000000 0 D-23 / - DATA BY0CS( 17) / -.7229627125 4480104789 3333333333 3 D-26 / - DATA BY0CS( 18) / +.2571727931 6351685973 3333333333 3 D-28 / - DATA BY0CS( 19) / -.8141268814 1636949333 3333333333 3 D-31 / - DATA TWODPI / 0.6366197723 6758134307 5535053490 057 D0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DBESY0 - IF (FIRST) THEN - NTY0 = INITDS (BY0CS, 19, 0.1*REAL(D1MACH(3))) - XSML = SQRT(4.0D0*D1MACH(3)) - ENDIF - FIRST = .FALSE. -C - IF (X .LE. 0.D0) CALL XERMSG ('SLATEC', 'DBESY0', - + 'X IS ZERO OR NEGATIVE', 1, 2) - IF (X.GT.4.0D0) GO TO 20 -C - Y = 0.D0 - IF (X.GT.XSML) Y = X*X - DBESY0 = TWODPI*LOG(0.5D0*X)*DBESJ0(X) + .375D0 + DCSEVL ( - 1 .125D0*Y-1.D0, BY0CS, NTY0) - RETURN -C - 20 CALL D9B0MP (X, AMPL, THETA) - DBESY0 = AMPL * SIN(THETA) - RETURN -C - END diff --git a/slatec/dbesy1.f b/slatec/dbesy1.f deleted file mode 100644 index c26c732..0000000 --- a/slatec/dbesy1.f +++ /dev/null @@ -1,84 +0,0 @@ -*DECK DBESY1 - DOUBLE PRECISION FUNCTION DBESY1 (X) -C***BEGIN PROLOGUE DBESY1 -C***PURPOSE Compute the Bessel function of the second kind of order -C one. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10A1 -C***TYPE DOUBLE PRECISION (BESY1-S, DBESY1-D) -C***KEYWORDS BESSEL FUNCTION, FNLIB, ORDER ONE, SECOND KIND, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DBESY1(X) calculates the double precision Bessel function of the -C second kind of order for double precision argument X. -C -C Series for BY1 on the interval 0. to 1.60000E+01 -C with weighted error 8.65E-33 -C log weighted error 32.06 -C significant figures required 32.17 -C decimal places required 32.71 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, D9B1MP, DBESJ1, DCSEVL, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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***END PROLOGUE DBESY1 - DOUBLE PRECISION X, BY1CS(20), AMPL, THETA, TWODPI, XMIN, XSML, - 1 Y, D1MACH, DCSEVL, DBESJ1 - LOGICAL FIRST - SAVE BY1CS, TWODPI, NTY1, XMIN, XSML, FIRST - DATA BY1CS( 1) / +.3208047100 6119086293 2352018628 015 D-1 / - DATA BY1CS( 2) / +.1262707897 4335004495 3431725999 727 D+1 / - DATA BY1CS( 3) / +.6499961899 9231750009 7490637314 144 D-2 / - DATA BY1CS( 4) / -.8936164528 8605041165 3144160009 712 D-1 / - DATA BY1CS( 5) / +.1325088122 1757095451 2375510370 043 D-1 / - DATA BY1CS( 6) / -.8979059119 6483523775 3039508298 105 D-3 / - DATA BY1CS( 7) / +.3647361487 9583067824 2287368165 349 D-4 / - DATA BY1CS( 8) / -.1001374381 6660005554 9075523845 295 D-5 / - DATA BY1CS( 9) / +.1994539657 3901739703 1159372421 243 D-7 / - DATA BY1CS( 10) / -.3023065601 8033816728 4799332520 743 D-9 / - DATA BY1CS( 11) / +.3609878156 9478119611 6252914242 474 D-11 / - DATA BY1CS( 12) / -.3487488297 2875824241 4552947409 066 D-13 / - DATA BY1CS( 13) / +.2783878971 5591766581 3507698517 333 D-15 / - DATA BY1CS( 14) / -.1867870968 6194876876 6825352533 333 D-17 / - DATA BY1CS( 15) / +.1068531533 9116825975 7070336000 000 D-19 / - DATA BY1CS( 16) / -.5274721956 6844822894 3872000000 000 D-22 / - DATA BY1CS( 17) / +.2270199403 1556641437 0133333333 333 D-24 / - DATA BY1CS( 18) / -.8595390353 9452310869 3333333333 333 D-27 / - DATA BY1CS( 19) / +.2885404379 8337945600 0000000000 000 D-29 / - DATA BY1CS( 20) / -.8647541138 9371733333 3333333333 333 D-32 / - DATA TWODPI / 0.6366197723 6758134307 5535053490 057 D0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DBESY1 - IF (FIRST) THEN - NTY1 = INITDS (BY1CS, 20, 0.1*REAL(D1MACH(3))) -C - XMIN = 1.571D0 * EXP (MAX(LOG(D1MACH(1)), -LOG(D1MACH(2))) + - 1 0.01D0) - XSML = SQRT(4.0D0*D1MACH(3)) - ENDIF - FIRST = .FALSE. -C - IF (X .LE. 0.D0) CALL XERMSG ('SLATEC', 'DBESY1', - + 'X IS ZERO OR NEGATIVE', 1, 2) - IF (X.GT.4.0D0) GO TO 20 -C - IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'DBESY1', - + 'X SO SMALL Y1 OVERFLOWS', 3, 2) - Y = 0.D0 - IF (X.GT.XSML) Y = X*X - DBESY1 = TWODPI * LOG(0.5D0*X)*DBESJ1(X) + (0.5D0 + - 1 DCSEVL (.125D0*Y-1.D0, BY1CS, NTY1))/X - RETURN -C - 20 CALL D9B1MP (X, AMPL, THETA) - DBESY1 = AMPL * SIN(THETA) - RETURN -C - END diff --git a/slatec/dbeta.f b/slatec/dbeta.f deleted file mode 100644 index 3960007..0000000 --- a/slatec/dbeta.f +++ /dev/null @@ -1,53 +0,0 @@ -*DECK DBETA - DOUBLE PRECISION FUNCTION DBETA (A, B) -C***BEGIN PROLOGUE DBETA -C***PURPOSE Compute the complete Beta function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7B -C***TYPE DOUBLE PRECISION (BETA-S, DBETA-D, CBETA-C) -C***KEYWORDS COMPLETE BETA FUNCTION, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DBETA(A,B) calculates the double precision complete beta function -C for double precision arguments A and B. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DGAMLM, DGAMMA, DLBETA, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 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 900727 Added EXTERNAL statement. (WRB) -C***END PROLOGUE DBETA - DOUBLE PRECISION A, B, ALNSML, XMAX, XMIN, DLBETA, DGAMMA, D1MACH - LOGICAL FIRST - EXTERNAL DGAMMA - SAVE XMAX, ALNSML, FIRST - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DBETA - IF (FIRST) THEN - CALL DGAMLM (XMIN, XMAX) - ALNSML = LOG (D1MACH(1)) - ENDIF - FIRST = .FALSE. -C - IF (A .LE. 0.D0 .OR. B .LE. 0.D0) CALL XERMSG ('SLATEC', 'DBETA', - + 'BOTH ARGUMENTS MUST BE GT 0', 2, 2) -C - IF (A+B.LT.XMAX) DBETA = DGAMMA(A)*DGAMMA(B)/DGAMMA(A+B) - IF (A+B.LT.XMAX) RETURN -C - DBETA = DLBETA (A, B) - IF (DBETA.LT.ALNSML) GO TO 20 - DBETA = EXP (DBETA) - RETURN -C - 20 DBETA = 0.D0 - CALL XERMSG ('SLATEC', 'DBETA', - + 'A AND/OR B SO BIG BETA UNDERFLOWS', 1, 1) - RETURN -C - END diff --git a/slatec/dbetai.f b/slatec/dbetai.f deleted file mode 100644 index 076458d..0000000 --- a/slatec/dbetai.f +++ /dev/null @@ -1,120 +0,0 @@ -*DECK DBETAI - DOUBLE PRECISION FUNCTION DBETAI (X, PIN, QIN) -C***BEGIN PROLOGUE DBETAI -C***PURPOSE Calculate the incomplete Beta function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7F -C***TYPE DOUBLE PRECISION (BETAI-S, DBETAI-D) -C***KEYWORDS FNLIB, INCOMPLETE BETA FUNCTION, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DBETAI calculates the DOUBLE PRECISION incomplete beta function. -C -C The incomplete beta function ratio is the probability that a -C random variable from a beta distribution having parameters PIN and -C QIN will be less than or equal to X. -C -C -- Input Arguments -- All arguments are DOUBLE PRECISION. -C X upper limit of integration. X must be in (0,1) inclusive. -C PIN first beta distribution parameter. PIN must be .GT. 0.0. -C QIN second beta distribution parameter. QIN must be .GT. 0.0. -C -C***REFERENCES Nancy E. Bosten and E. L. Battiste, Remark on Algorithm -C 179, Communications of the ACM 17, 3 (March 1974), -C pp. 156. -C***ROUTINES CALLED D1MACH, DLBETA, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 890911 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 920528 DESCRIPTION and REFERENCES sections revised. (WRB) -C***END PROLOGUE DBETAI - DOUBLE PRECISION X, PIN, QIN, ALNEPS, ALNSML, C, EPS, FINSUM, P, - 1 PS, Q, SML, TERM, XB, XI, Y, D1MACH, DLBETA, P1 - LOGICAL FIRST - SAVE EPS, ALNEPS, SML, ALNSML, FIRST - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DBETAI - IF (FIRST) THEN - EPS = D1MACH(3) - ALNEPS = LOG (EPS) - SML = D1MACH(1) - ALNSML = LOG (SML) - ENDIF - FIRST = .FALSE. -C - IF (X .LT. 0.D0 .OR. X .GT. 1.D0) CALL XERMSG ('SLATEC', 'DBETAI', - + 'X IS NOT IN THE RANGE (0,1)', 1, 2) - IF (PIN .LE. 0.D0 .OR. QIN .LE. 0.D0) CALL XERMSG ('SLATEC', - + 'DBETAI', 'P AND/OR Q IS LE ZERO', 2, 2) -C - Y = X - P = PIN - Q = QIN - IF (Q.LE.P .AND. X.LT.0.8D0) GO TO 20 - IF (X.LT.0.2D0) GO TO 20 - Y = 1.0D0 - Y - P = QIN - Q = PIN -C - 20 IF ((P+Q)*Y/(P+1.D0).LT.EPS) GO TO 80 -C -C EVALUATE THE INFINITE SUM FIRST. TERM WILL EQUAL -C Y**P/BETA(PS,P) * (1.-PS)-SUB-I * Y**I / FAC(I) . -C - PS = Q - AINT(Q) - IF (PS.EQ.0.D0) PS = 1.0D0 - XB = P*LOG(Y) - DLBETA(PS,P) - LOG(P) - DBETAI = 0.0D0 - IF (XB.LT.ALNSML) GO TO 40 -C - DBETAI = EXP (XB) - TERM = DBETAI*P - IF (PS.EQ.1.0D0) GO TO 40 - N = MAX (ALNEPS/LOG(Y), 4.0D0) - DO 30 I=1,N - XI = I - TERM = TERM * (XI-PS)*Y/XI - DBETAI = DBETAI + TERM/(P+XI) - 30 CONTINUE -C -C NOW EVALUATE THE FINITE SUM, MAYBE. -C - 40 IF (Q.LE.1.0D0) GO TO 70 -C - XB = P*LOG(Y) + Q*LOG(1.0D0-Y) - DLBETA(P,Q) - LOG(Q) - IB = MAX (XB/ALNSML, 0.0D0) - TERM = EXP(XB - IB*ALNSML) - C = 1.0D0/(1.D0-Y) - P1 = Q*C/(P+Q-1.D0) -C - FINSUM = 0.0D0 - N = Q - IF (Q.EQ.DBLE(N)) N = N - 1 - DO 50 I=1,N - IF (P1.LE.1.0D0 .AND. TERM/EPS.LE.FINSUM) GO TO 60 - XI = I - TERM = (Q-XI+1.0D0)*C*TERM/(P+Q-XI) -C - IF (TERM.GT.1.0D0) IB = IB - 1 - IF (TERM.GT.1.0D0) TERM = TERM*SML -C - IF (IB.EQ.0) FINSUM = FINSUM + TERM - 50 CONTINUE -C - 60 DBETAI = DBETAI + FINSUM - 70 IF (Y.NE.X .OR. P.NE.PIN) DBETAI = 1.0D0 - DBETAI - DBETAI = MAX (MIN (DBETAI, 1.0D0), 0.0D0) - RETURN -C - 80 DBETAI = 0.0D0 - XB = P*LOG(MAX(Y,SML)) - LOG(P) - DLBETA(P,Q) - IF (XB.GT.ALNSML .AND. Y.NE.0.0D0) DBETAI = EXP(XB) - IF (Y.NE.X .OR. P.NE.PIN) DBETAI = 1.0D0 - DBETAI -C - RETURN - END diff --git a/slatec/dbfqad.f b/slatec/dbfqad.f deleted file mode 100644 index 702f6b6..0000000 --- a/slatec/dbfqad.f +++ /dev/null @@ -1,137 +0,0 @@ -*DECK DBFQAD - SUBROUTINE DBFQAD (F, T, BCOEF, N, K, ID, X1, X2, TOL, QUAD, IERR, - + WORK) -C***BEGIN PROLOGUE DBFQAD -C***PURPOSE Compute the integral of a product of a function and a -C derivative of a K-th order B-spline. -C***LIBRARY SLATEC -C***CATEGORY H2A2A1, E3, K6 -C***TYPE DOUBLE PRECISION (BFQAD-S, DBFQAD-D) -C***KEYWORDS INTEGRAL OF B-SPLINE, QUADRATURE -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Abstract **** a double precision routine **** -C -C DBFQAD computes the integral on (X1,X2) of a product of a -C function F and the ID-th derivative of a K-th order B-spline, -C using the B-representation (T,BCOEF,N,K). (X1,X2) must be a -C subinterval of T(K) .LE. X .LE. T(N+1). An integration rou- -C tine, DBSGQ8 (a modification of GAUS8), integrates the product -C on subintervals of (X1,X2) formed by included (distinct) knots -C -C The maximum number of significant digits obtainable in -C DBSQAD is the smaller of 18 and the number of digits -C carried in double precision arithmetic. -C -C Description of Arguments -C Input F,T,BCOEF,X1,X2,TOL are double precision -C F - external function of one argument for the -C integrand BF(X)=F(X)*DBVALU(T,BCOEF,N,K,ID,X,INBV, -C WORK) -C T - knot array of length N+K -C BCOEF - coefficient array of length N -C N - length of coefficient array -C K - order of B-spline, K .GE. 1 -C ID - order of the spline derivative, 0 .LE. ID .LE. K-1 -C ID=0 gives the spline function -C X1,X2 - end points of quadrature interval in -C T(K) .LE. X .LE. T(N+1) -C TOL - desired accuracy for the quadrature, suggest -C 10.*DTOL .LT. TOL .LE. .1 where DTOL is the maximum -C of 1.0D-18 and double precision unit roundoff for -C the machine = D1MACH(4) -C -C Output QUAD,WORK are double precision -C QUAD - integral of BF(X) on (X1,X2) -C IERR - a status code -C IERR=1 normal return -C 2 some quadrature on (X1,X2) does not meet -C the requested tolerance. -C WORK - work vector of length 3*K -C -C Error Conditions -C Improper input is a fatal error -C Some quadrature fails to meet the requested tolerance -C -C***REFERENCES D. E. Amos, Quadrature subroutines for splines and -C B-splines, Report SAND79-1825, Sandia Laboratories, -C December 1979. -C***ROUTINES CALLED D1MACH, DBSGQ8, DINTRV, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800901 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DBFQAD -C -C - INTEGER ID, IERR, IFLG, ILO, IL1, IL2, K, LEFT, MFLAG, N, NPK, NP1 - DOUBLE PRECISION A,AA,ANS,B,BB,BCOEF,Q,QUAD,T,TA,TB,TOL,WORK,WTOL, - 1 X1, X2 - DOUBLE PRECISION D1MACH, F - DIMENSION T(*), BCOEF(*), WORK(*) - EXTERNAL F -C***FIRST EXECUTABLE STATEMENT DBFQAD - IERR = 1 - QUAD = 0.0D0 - IF(K.LT.1) GO TO 100 - IF(N.LT.K) GO TO 105 - IF(ID.LT.0 .OR. ID.GE.K) GO TO 110 - WTOL = D1MACH(4) - WTOL = MAX(WTOL,1.D-18) - IF (TOL.LT.WTOL .OR. TOL.GT.0.1D0) GO TO 30 - AA = MIN(X1,X2) - BB = MAX(X1,X2) - IF (AA.LT.T(K)) GO TO 20 - NP1 = N + 1 - IF (BB.GT.T(NP1)) GO TO 20 - IF (AA.EQ.BB) RETURN - NPK = N + K -C - ILO = 1 - CALL DINTRV(T, NPK, AA, ILO, IL1, MFLAG) - CALL DINTRV(T, NPK, BB, ILO, IL2, MFLAG) - IF (IL2.GE.NP1) IL2 = N - INBV = 1 - Q = 0.0D0 - DO 10 LEFT=IL1,IL2 - TA = T(LEFT) - TB = T(LEFT+1) - IF (TA.EQ.TB) GO TO 10 - A = MAX(AA,TA) - B = MIN(BB,TB) - CALL DBSGQ8(F,T,BCOEF,N,K,ID,A,B,INBV,TOL,ANS,IFLG,WORK) - IF (IFLG.GT.1) IERR = 2 - Q = Q + ANS - 10 CONTINUE - IF (X1.GT.X2) Q = -Q - QUAD = Q - RETURN -C -C - 20 CONTINUE - CALL XERMSG ('SLATEC', 'DBFQAD', - + 'X1 OR X2 OR BOTH DO NOT SATISFY T(K).LE.X.LE.T(N+1)', 2, 1) - RETURN - 30 CONTINUE - CALL XERMSG ('SLATEC', 'DBFQAD', - + 'TOL IS LESS DTOL OR GREATER THAN 0.1', 2, 1) - RETURN - 100 CONTINUE - CALL XERMSG ('SLATEC', 'DBFQAD', 'K DOES NOT SATISFY K.GE.1', 2, - + 1) - RETURN - 105 CONTINUE - CALL XERMSG ('SLATEC', 'DBFQAD', 'N DOES NOT SATISFY N.GE.K', 2, - + 1) - RETURN - 110 CONTINUE - CALL XERMSG ('SLATEC', 'DBFQAD', - + 'ID DOES NOT SATISFY 0.LE.ID.LT.K', 2, 1) - RETURN - END diff --git a/slatec/dbhin.f b/slatec/dbhin.f deleted file mode 100644 index 1e0e09f..0000000 --- a/slatec/dbhin.f +++ /dev/null @@ -1,286 +0,0 @@ -*DECK DBHIN - SUBROUTINE DBHIN (N, NELT, IA, JA, A, ISYM, SOLN, RHS, IUNIT, JOB) -C***BEGIN PROLOGUE DBHIN -C***PURPOSE Read a Sparse Linear System in the Boeing/Harwell Format. -C The matrix is read in and if the right hand side is also -C present in the input file then it too is read in. The -C matrix is then modified to be in the SLAP Column format. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY N1 -C***TYPE DOUBLE PRECISION (SBHIN-S, DBHIN-D) -C***KEYWORDS LINEAR SYSTEM, MATRIX READ, SLAP SPARSE -C***AUTHOR Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, IUNIT, JOB -C DOUBLE PRECISION A(NELT), SOLN(N), RHS(N) -C -C CALL DBHIN( N, NELT, IA, JA, A, ISYM, SOLN, RHS, IUNIT, JOB ) -C -C *Arguments: -C N :OUT Integer -C Order of the Matrix. -C NELT :INOUT Integer. -C On input NELT is the maximum number of non-zeros that -C can be stored in the IA, JA, A arrays. -C On output NELT is the number of non-zeros stored in A. -C IA :OUT Integer IA(NELT). -C JA :OUT Integer JA(NELT). -C A :OUT Double Precision A(NELT). -C On output these arrays hold the matrix A in the SLAP -C Triad format. See "Description", below. -C ISYM :OUT Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the lower -C triangle of the matrix is stored. -C SOLN :OUT Double Precision SOLN(N). -C The solution to the linear system, if present. This array -C is accessed if and only if JOB is set to read it in, see -C below. If the user requests that SOLN be read in, but it is -C not in the file, then it is simply zeroed out. -C RHS :OUT Double Precision RHS(N). -C The right hand side vector. This array is accessed if and -C only if JOB is set to read it in, see below. -C If the user requests that RHS be read in, but it is not in -C the file, then it is simply zeroed out. -C IUNIT :IN Integer. -C Fortran logical I/O device unit number to read the matrix -C from. This unit must be connected in a system dependent -C fashion to a file, or you will get a nasty message -C from the Fortran I/O libraries. -C JOB :INOUT Integer. -C Flag indicating what I/O operations to perform. -C On input JOB indicates what Input operations to try to -C perform. -C JOB = 0 => Read only the matrix. -C JOB = 1 => Read matrix and RHS (if present). -C JOB = 2 => Read matrix and SOLN (if present). -C JOB = 3 => Read matrix, RHS and SOLN (if present). -C On output JOB indicates what operations were actually -C performed. -C JOB = -3 => Unable to parse matrix "CODE" from input file -C to determine if only the lower triangle of matrix -C is stored. -C JOB = -2 => Number of non-zeros (NELT) too large. -C JOB = -1 => System size (N) too large. -C JOB = 0 => Read in only the matrix. -C JOB = 1 => Read in the matrix and RHS. -C JOB = 2 => Read in the matrix and SOLN. -C JOB = 3 => Read in the matrix, RHS and SOLN. -C JOB = 10 => Read in only the matrix *STRUCTURE*, but no -C non-zero entries. Hence, A(*) is not referenced -C and has the return values the same as the input. -C JOB = 11 => Read in the matrix *STRUCTURE* and RHS. -C JOB = 12 => Read in the matrix *STRUCTURE* and SOLN. -C JOB = 13 => Read in the matrix *STRUCTURE*, RHS and SOLN. -C -C *Description: -C The format for the input is as follows. The first line contains -C a title to identify the data file. On the second line (5I4) are -C counters: NLINE, NPLS, NRILS, NNVLS, NRHSLS. -C NLINE Number of data lines (after the header) in the file. -C NPLS Number of lines for the Column Pointer data in the file. -C NRILS Number of lines for the Row indices in the file. -C NNVLS Number of lines for the Matrix elements in the file. -C NRHSLS Number of lines for the RHS in the file. -C The third line (A3,11X,4I4) contains a symmetry code and some -C additional counters: CODE, NROW, NCOL, NIND, NELE. -C On the fourth line (2A16,2A20) are formats to be used to read -C the following data: PNTFNT, RINFMT, NVLFMT, RHSFMT. -C Following that are the blocks of data in the order indicated. -C -C =================== S L A P Triad format =================== -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Portability: -C You must make sure that IUNIT is a valid Fortran logical -C I/O device unit number and that the unit number has been -C associated with a file or the console. This is a system -C dependent function. -C -C *Implementation note: -C SOLN is not read by this version. It will simply be -C zeroed out if JOB = 2 or 3 and the returned value of -C JOB will indicate SOLN has not been read. -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 881107 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 911122 Added loop to zero out RHS if user wants to read RHS, but -C it's not in the input file. (MKS) -C 911125 Minor improvements to prologue. (FNF) -C 920511 Added complete declaration section. (WRB) -C 921007 Corrected description of input format. (FNF) -C 921208 Added Implementation Note and code to zero out SOLN. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE DBHIN -C .. Scalar Arguments .. - INTEGER ISYM, IUNIT, JOB, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), RHS(N), SOLN(N) - INTEGER IA(NELT), JA(NELT) -C .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, IBGN, ICOL, IEND, ITEMP, J, JOBRET, NCOL, NELE, NIND, - + NLINE, NNVLS, NPLS, NRHSLS, NRILS, NROW - CHARACTER CODE*3, PNTFMT*16, RINFMT*16, NVLFMT*20, RHSFMT*20, - + TITLE*80 -C .. Intrinsic Functions .. - INTRINSIC MOD -C***FIRST EXECUTABLE STATEMENT DBHIN -C -C Read Matrices In BOEING-HARWELL format. -C -C TITLE Header line to identify data file. -C NLINE Number of data lines (after the header) in the file. -C NPLS Number of lines for the Column Pointer data in the file. -C NRILS Number of lines for the Row indices in the data file. -C NNVLS Number of lines for the Matrix elements in the data file. -C NRHSLS Number of lines for the RHS in the data file. -C ---- Only those variables needed by SLAP are referenced. ---- -C - READ(IUNIT,9000) TITLE - READ(IUNIT,9010) NLINE, NPLS, NRILS, NNVLS, NRHSLS - READ(IUNIT,9020) CODE, NROW, NCOL, NIND, NELE - READ(IUNIT,9030) PNTFMT, RINFMT, NVLFMT, RHSFMT -C - IF( NROW.GT.N ) THEN - N = NROW - JOBRET = -1 - GOTO 999 - ENDIF - IF( NIND.GT.NELT ) THEN - NELT = NIND - JOBRET = -2 - GOTO 999 - ENDIF -C -C Set the parameters. -C - N = NROW - NELT = NIND - IF( CODE.EQ.'RUA' ) THEN - ISYM = 0 - ELSE IF( CODE.EQ.'RSA' ) THEN - ISYM = 1 - ELSE - JOBRET = -3 - GOTO 999 - ENDIF - READ(IUNIT,PNTFMT) (JA(I), I = 1, N+1) - READ(IUNIT,RINFMT) (IA(I), I = 1, NELT) - JOBRET = 10 - IF( NNVLS.GT.0 ) THEN - READ(IUNIT,NVLFMT) (A(I), I = 1, NELT) - JOBRET = 0 - ENDIF - IF( MOD(JOB,2).EQ.1 ) THEN -C -C User requests that the RHS be read in. If it is in the input -C file, read it in; otherwise just zero it out. -C - IF( NRHSLS.GT.0 ) THEN - READ(5,RHSFMT) (RHS(I), I = 1, N) - JOBRET = JOBRET + 1 - ELSE - DO 10 I = 1, N - RHS(I) = 0 - 10 CONTINUE - ENDIF - ENDIF - IF ( (JOB.EQ.2).OR.(JOB.EQ.3) ) THEN -C -C User requests that the SOLN be read in. -C Just zero out the array. -C - DO 20 I = 1, N - SOLN(I) = 0 - 20 CONTINUE - ENDIF -C -C Now loop through the IA array making sure that the diagonal -C matrix element appears first in the column. Then sort the -C rest of the column in ascending order. -C -CVD$R NOCONCUR -CVD$R NOVECTOR - DO 70 ICOL = 1, N - IBGN = JA(ICOL) - IEND = JA(ICOL+1)-1 - DO 30 I = IBGN, IEND - IF( IA(I).EQ.ICOL ) THEN -C -C Swap the diagonal element with the first element in the -C column. -C - ITEMP = IA(I) - IA(I) = IA(IBGN) - IA(IBGN) = ITEMP - TEMP = A(I) - A(I) = A(IBGN) - A(IBGN) = TEMP - GOTO 40 - ENDIF - 30 CONTINUE - 40 IBGN = IBGN + 1 - IF( IBGN.LT.IEND ) THEN - DO 60 I = IBGN, IEND - DO 50 J = I+1, IEND - IF( IA(I).GT.IA(J) ) THEN - ITEMP = IA(I) - IA(I) = IA(J) - IA(J) = ITEMP - TEMP = A(I) - A(I) = A(J) - A(J) = TEMP - ENDIF - 50 CONTINUE - 60 CONTINUE - ENDIF - 70 CONTINUE -C -C Set return flag. - 999 JOB = JOBRET - RETURN - 9000 FORMAT( A80 ) - 9010 FORMAT( 5I14 ) - 9020 FORMAT( A3, 11X, 4I14 ) - 9030 FORMAT( 2A16, 2A20 ) -C------------- LAST LINE OF DBHIN FOLLOWS ------------------------------ - END diff --git a/slatec/dbi.f b/slatec/dbi.f deleted file mode 100644 index fa1d79a..0000000 --- a/slatec/dbi.f +++ /dev/null @@ -1,148 +0,0 @@ -*DECK DBI - DOUBLE PRECISION FUNCTION DBI (X) -C***BEGIN PROLOGUE DBI -C***PURPOSE Evaluate the Bairy function (the Airy function of the -C second kind). -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10D -C***TYPE DOUBLE PRECISION (BI-S, DBI-D) -C***KEYWORDS BAIRY FUNCTION, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DBI(X) calculates the double precision Airy function of the -C second kind for double precision argument X. -C -C Series for BIF on the interval -1.00000E+00 to 1.00000E+00 -C with weighted error 1.45E-32 -C log weighted error 31.84 -C significant figures required 30.85 -C decimal places required 32.40 -C -C Series for BIG on the interval -1.00000E+00 to 1.00000E+00 -C with weighted error 1.29E-33 -C log weighted error 32.89 -C significant figures required 31.48 -C decimal places required 33.45 -C -C Series for BIF2 on the interval 1.00000E+00 to 8.00000E+00 -C with weighted error 6.08E-32 -C log weighted error 31.22 -C approx significant figures required 30.8 -C decimal places required 31.80 -C -C Series for BIG2 on the interval 1.00000E+00 to 8.00000E+00 -C with weighted error 4.91E-33 -C log weighted error 32.31 -C approx significant figures required 31.6 -C decimal places required 32.90 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, D9AIMP, DBIE, DCSEVL, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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***END PROLOGUE DBI - DOUBLE PRECISION X, BIFCS(13), BIGCS(13), BIF2CS(15), BIG2CS(15), - 1 THETA, XM, XMAX, X3SML, Z, D1MACH, DCSEVL, DBIE - LOGICAL FIRST - SAVE BIFCS, BIGCS, BIF2CS, BIG2CS, NBIF, NBIG, - 1 NBIF2, NBIG2, X3SML, XMAX, FIRST - DATA BIFCS( 1) / -.1673021647 1986649483 5374239281 76 D-1 / - DATA BIFCS( 2) / +.1025233583 4249445611 4263627777 57 D+0 / - DATA BIFCS( 3) / +.1708309250 7381516539 4296502420 13 D-2 / - DATA BIFCS( 4) / +.1186254546 7744681179 2164592100 40 D-4 / - DATA BIFCS( 5) / +.4493290701 7792133694 5318879272 42 D-7 / - DATA BIFCS( 6) / +.1069820714 3387889067 5677676636 28 D-9 / - DATA BIFCS( 7) / +.1748064339 9771824706 0105176285 73 D-12 / - DATA BIFCS( 8) / +.2081023107 1761711025 8818918343 99 D-15 / - DATA BIFCS( 9) / +.1884981469 5665416509 9279717333 33 D-18 / - DATA BIFCS( 10) / +.1342577917 3097804625 8826666666 66 D-21 / - DATA BIFCS( 11) / +.7715959342 9658887893 3333333333 33 D-25 / - DATA BIFCS( 12) / +.3653387961 7478566399 9999999999 99 D-28 / - DATA BIFCS( 13) / +.1449756592 7953066666 6666666666 66 D-31 / - DATA BIGCS( 1) / +.2246622324 8574522283 4682201390 24 D-1 / - DATA BIGCS( 2) / +.3736477545 3019545441 7275616667 52 D-1 / - DATA BIGCS( 3) / +.4447621895 7212285696 2152943266 39 D-3 / - DATA BIGCS( 4) / +.2470807563 6329384245 4945919488 82 D-5 / - DATA BIGCS( 5) / +.7919135339 5149635134 8624262855 96 D-8 / - DATA BIGCS( 6) / +.1649807985 1827779880 8878724027 06 D-10 / - DATA BIGCS( 7) / +.2411990666 4835455909 2475011228 41 D-13 / - DATA BIGCS( 8) / +.2610373623 6091436985 1847812693 33 D-16 / - DATA BIGCS( 9) / +.2175308297 7160323853 1237920000 00 D-19 / - DATA BIGCS( 10) / +.1438694640 0390433219 4837333333 33 D-22 / - DATA BIGCS( 11) / +.7734912561 2083468629 3333333333 33 D-26 / - DATA BIGCS( 12) / +.3446929203 3849002666 6666666666 66 D-29 / - DATA BIGCS( 13) / +.1293891927 3216000000 0000000000 00 D-32 / - DATA BIF2CS( 1) / +.0998457269 3816041044 6828425799 3 D+0 / - DATA BIF2CS( 2) / +.4786249778 6300553772 2114673182 31 D+0 / - DATA BIF2CS( 3) / +.2515521196 0433011771 3244154366 75 D-1 / - DATA BIF2CS( 4) / +.5820693885 2326456396 5156978722 16 D-3 / - DATA BIF2CS( 5) / +.7499765964 4377865943 8614573782 17 D-5 / - DATA BIF2CS( 6) / +.6134602870 3493836681 4030103564 74 D-7 / - DATA BIF2CS( 7) / +.3462753885 1480632900 4342687333 59 D-9 / - DATA BIF2CS( 8) / +.1428891008 0270254287 7708467489 31 D-11 / - DATA BIF2CS( 9) / +.4496270429 8334641895 0564721792 00 D-14 / - DATA BIF2CS( 10) / +.1114232306 5833011708 4283001066 66 D-16 / - DATA BIF2CS( 11) / +.2230479106 6175002081 5178666666 66 D-19 / - DATA BIF2CS( 12) / +.3681577873 6393142842 9226666666 66 D-22 / - DATA BIF2CS( 13) / +.5096086844 9338261333 3333333333 33 D-25 / - DATA BIF2CS( 14) / +.6000338692 6288554666 6666666666 66 D-28 / - DATA BIF2CS( 15) / +.6082749744 6570666666 6666666666 66 D-31 / - DATA BIG2CS( 1) / +.0333056621 4551434046 5176188111 647 D+0 / - DATA BIG2CS( 2) / +.1613092151 2319706761 3287532084 943 D+0 / - DATA BIG2CS( 3) / +.6319007309 6134286912 1615634921 173 D-2 / - DATA BIG2CS( 4) / +.1187904568 1625173638 9780192304 567 D-3 / - DATA BIG2CS( 5) / +.1304534588 6200265614 7116485012 843 D-5 / - DATA BIG2CS( 6) / +.9374125995 5352172954 6809615508 936 D-8 / - DATA BIG2CS( 7) / +.4745801886 7472515378 8510169834 595 D-10 / - DATA BIG2CS( 8) / +.1783107265 0948139980 0065667560 946 D-12 / - DATA BIG2CS( 9) / +.5167591927 8495818037 4276356640 000 D-15 / - DATA BIG2CS( 10) / +.1190045083 8682712512 9496251733 333 D-17 / - DATA BIG2CS( 11) / +.2229828806 6640351727 7063466666 666 D-20 / - DATA BIG2CS( 12) / +.3465519230 2768941972 2666666666 666 D-23 / - DATA BIG2CS( 13) / +.4539263363 2050451413 3333333333 333 D-26 / - DATA BIG2CS( 14) / +.5078849965 1352234666 6666666666 666 D-29 / - DATA BIG2CS( 15) / +.4910206746 9653333333 3333333333 333 D-32 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DBI - IF (FIRST) THEN - ETA = 0.1*REAL(D1MACH(3)) - NBIF = INITDS (BIFCS, 13, ETA) - NBIG = INITDS (BIGCS, 13, ETA) - NBIF2 = INITDS (BIF2CS, 15, ETA) - NBIG2 = INITDS (BIG2CS, 15, ETA) -C - X3SML = ETA**0.3333 - XMAX = (1.5*LOG(D1MACH(2)))**0.6666D0 - ENDIF - FIRST = .FALSE. -C - IF (X.GE.(-1.0D0)) GO TO 20 - CALL D9AIMP (X, XM, THETA) - DBI = XM * SIN(THETA) - RETURN -C - 20 IF (X.GT.1.0D0) GO TO 30 - Z = 0.D0 - IF (ABS(X).GT.X3SML) Z = X**3 - DBI = 0.625 + DCSEVL (Z, BIFCS, NBIF) + X*(0.4375D0 + - 1 DCSEVL (Z, BIGCS, NBIG)) - RETURN -C - 30 IF (X.GT.2.0D0) GO TO 40 - Z = (2.0D0*X**3 - 9.0D0)/7.D0 - DBI = 1.125D0 + DCSEVL (Z, BIF2CS, NBIF2) + X*(0.625D0 + - 1 DCSEVL (Z, BIG2CS, NBIG2)) - RETURN -C - 40 IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'DBI', - + 'X SO BIG THAT BI OVERFLOWS', 1, 2) -C - DBI = DBIE(X) * EXP(2.0D0*X*SQRT(X)/3.0D0) - RETURN -C - END diff --git a/slatec/dbie.f b/slatec/dbie.f deleted file mode 100644 index 0f6907a..0000000 --- a/slatec/dbie.f +++ /dev/null @@ -1,322 +0,0 @@ -*DECK DBIE - DOUBLE PRECISION FUNCTION DBIE (X) -C***BEGIN PROLOGUE DBIE -C***PURPOSE Calculate the Bairy function for a negative argument and an -C exponentially scaled Bairy function for a non-negative -C argument. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10D -C***TYPE DOUBLE PRECISION (BIE-S, DBIE-D) -C***KEYWORDS BAIRY FUNCTION, EXPONENTIALLY SCALED, FNLIB, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DBIE(X) calculates the double precision Airy function of the -C second kind or the double precision exponentially scaled Airy -C function of the second kind, depending on the value of the -C double precision argument X. -C -C Evaluate BI(X) for X .LE. 0.0 and BI(X)*EXP(-ZETA) where -C ZETA = 2/3 * X**(3/2) for X .GE. 0.0 -C -C -C Series for BIF on the interval -1.00000E+00 to 1.00000E+00 -C with weighted error 1.45E-32 -C log weighted error 31.84 -C significant figures required 30.85 -C decimal places required 32.40 -C -C -C Series for BIG on the interval -1.00000E+00 to 1.00000E+00 -C with weighted error 1.29E-33 -C log weighted error 32.89 -C significant figures required 31.48 -C decimal places required 33.45 -C -C -C Series for BIF2 on the interval 1.00000E+00 to 8.00000E+00 -C with weighted error 6.08E-32 -C log weighted error 31.22 -C approx significant figures required 30.8 -C decimal places required 31.80 -C -C -C Series for BIG2 on the interval 1.00000E+00 to 8.00000E+00 -C with weighted error 4.91E-33 -C log weighted error 32.31 -C approx significant figures required 31.6 -C decimal places required 32.90 -C -C -C Series for BIP1 on the interval 1.25000E-01 to 3.53553E-01 -C with weighted error 1.06E-32 -C log weighted error 31.98 -C significant figures required 30.61 -C decimal places required 32.81 -C -C -C Series for BIP2 on the interval 0. to 1.25000E-01 -C with weighted error 4.04E-33 -C log weighted error 32.39 -C significant figures required 31.15 -C decimal places required 33.37 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, D9AIMP, DCSEVL, INITDS -C***REVISION HISTORY (YYMMDD) -C 770701 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***END PROLOGUE DBIE - DOUBLE PRECISION X, BIFCS(13), BIGCS(13), BIF2CS(15), BIG2CS(15), - 1 BIP1CS(47), BIP2CS(88), ATR, BTR, SQRTX, THETA, XBIG, XM, X3SML, - 2 X32SML, Z, D1MACH, DCSEVL - LOGICAL FIRST - SAVE BIFCS, BIGCS, BIF2CS, BIG2CS, BIP1CS, BIP2CS, ATR, BTR, - 1 NBIF, NBIG, NBIF2, NBIG2, NBIP1, NBIP2, X3SML, X32SML, XBIG, - 2 FIRST - DATA BIFCS( 1) / -.1673021647 1986649483 5374239281 76 D-1 / - DATA BIFCS( 2) / +.1025233583 4249445611 4263627777 57 D+0 / - DATA BIFCS( 3) / +.1708309250 7381516539 4296502420 13 D-2 / - DATA BIFCS( 4) / +.1186254546 7744681179 2164592100 40 D-4 / - DATA BIFCS( 5) / +.4493290701 7792133694 5318879272 42 D-7 / - DATA BIFCS( 6) / +.1069820714 3387889067 5677676636 28 D-9 / - DATA BIFCS( 7) / +.1748064339 9771824706 0105176285 73 D-12 / - DATA BIFCS( 8) / +.2081023107 1761711025 8818918343 99 D-15 / - DATA BIFCS( 9) / +.1884981469 5665416509 9279717333 33 D-18 / - DATA BIFCS( 10) / +.1342577917 3097804625 8826666666 66 D-21 / - DATA BIFCS( 11) / +.7715959342 9658887893 3333333333 33 D-25 / - DATA BIFCS( 12) / +.3653387961 7478566399 9999999999 99 D-28 / - DATA BIFCS( 13) / +.1449756592 7953066666 6666666666 66 D-31 / - DATA BIGCS( 1) / +.2246622324 8574522283 4682201390 24 D-1 / - DATA BIGCS( 2) / +.3736477545 3019545441 7275616667 52 D-1 / - DATA BIGCS( 3) / +.4447621895 7212285696 2152943266 39 D-3 / - DATA BIGCS( 4) / +.2470807563 6329384245 4945919488 82 D-5 / - DATA BIGCS( 5) / +.7919135339 5149635134 8624262855 96 D-8 / - DATA BIGCS( 6) / +.1649807985 1827779880 8878724027 06 D-10 / - DATA BIGCS( 7) / +.2411990666 4835455909 2475011228 41 D-13 / - DATA BIGCS( 8) / +.2610373623 6091436985 1847812693 33 D-16 / - DATA BIGCS( 9) / +.2175308297 7160323853 1237920000 00 D-19 / - DATA BIGCS( 10) / +.1438694640 0390433219 4837333333 33 D-22 / - DATA BIGCS( 11) / +.7734912561 2083468629 3333333333 33 D-26 / - DATA BIGCS( 12) / +.3446929203 3849002666 6666666666 66 D-29 / - DATA BIGCS( 13) / +.1293891927 3216000000 0000000000 00 D-32 / - DATA BIF2CS( 1) / +.0998457269 3816041044 6828425799 3 D+0 / - DATA BIF2CS( 2) / +.4786249778 6300553772 2114673182 31 D+0 / - DATA BIF2CS( 3) / +.2515521196 0433011771 3244154366 75 D-1 / - DATA BIF2CS( 4) / +.5820693885 2326456396 5156978722 16 D-3 / - DATA BIF2CS( 5) / +.7499765964 4377865943 8614573782 17 D-5 / - DATA BIF2CS( 6) / +.6134602870 3493836681 4030103564 74 D-7 / - DATA BIF2CS( 7) / +.3462753885 1480632900 4342687333 59 D-9 / - DATA BIF2CS( 8) / +.1428891008 0270254287 7708467489 31 D-11 / - DATA BIF2CS( 9) / +.4496270429 8334641895 0564721792 00 D-14 / - DATA BIF2CS( 10) / +.1114232306 5833011708 4283001066 66 D-16 / - DATA BIF2CS( 11) / +.2230479106 6175002081 5178666666 66 D-19 / - DATA BIF2CS( 12) / +.3681577873 6393142842 9226666666 66 D-22 / - DATA BIF2CS( 13) / +.5096086844 9338261333 3333333333 33 D-25 / - DATA BIF2CS( 14) / +.6000338692 6288554666 6666666666 66 D-28 / - DATA BIF2CS( 15) / +.6082749744 6570666666 6666666666 66 D-31 / - DATA BIG2CS( 1) / +.0333056621 4551434046 5176188111 647 D+0 / - DATA BIG2CS( 2) / +.1613092151 2319706761 3287532084 943 D+0 / - DATA BIG2CS( 3) / +.6319007309 6134286912 1615634921 173 D-2 / - DATA BIG2CS( 4) / +.1187904568 1625173638 9780192304 567 D-3 / - DATA BIG2CS( 5) / +.1304534588 6200265614 7116485012 843 D-5 / - DATA BIG2CS( 6) / +.9374125995 5352172954 6809615508 936 D-8 / - DATA BIG2CS( 7) / +.4745801886 7472515378 8510169834 595 D-10 / - DATA BIG2CS( 8) / +.1783107265 0948139980 0065667560 946 D-12 / - DATA BIG2CS( 9) / +.5167591927 8495818037 4276356640 000 D-15 / - DATA BIG2CS( 10) / +.1190045083 8682712512 9496251733 333 D-17 / - DATA BIG2CS( 11) / +.2229828806 6640351727 7063466666 666 D-20 / - DATA BIG2CS( 12) / +.3465519230 2768941972 2666666666 666 D-23 / - DATA BIG2CS( 13) / +.4539263363 2050451413 3333333333 333 D-26 / - DATA BIG2CS( 14) / +.5078849965 1352234666 6666666666 666 D-29 / - DATA BIG2CS( 15) / +.4910206746 9653333333 3333333333 333 D-32 / - DATA BIP1CS( 1) / -.8322047477 9434474687 4718647079 73 D-1 / - DATA BIP1CS( 2) / +.1146118927 3711742889 9202261280 31 D-1 / - DATA BIP1CS( 3) / +.4289644071 8911509494 1344725666 35 D-3 / - DATA BIP1CS( 4) / -.1490663937 9950514017 8476777329 54 D-3 / - DATA BIP1CS( 5) / -.1307659726 7876290663 1363409988 81 D-4 / - DATA BIP1CS( 6) / +.6327598396 1030344754 5357160324 94 D-5 / - DATA BIP1CS( 7) / -.4222669698 2681924884 7785158894 33 D-6 / - DATA BIP1CS( 8) / -.1914718629 8654689632 8354941812 77 D-6 / - DATA BIP1CS( 9) / +.6453106284 5583173611 0381578809 34 D-7 / - DATA BIP1CS( 10) / -.7844854677 1397719289 7483104486 28 D-8 / - DATA BIP1CS( 11) / -.9607721662 3785085879 1985335654 32 D-9 / - DATA BIP1CS( 12) / +.7000471331 6443966339 0060744020 68 D-9 / - DATA BIP1CS( 13) / -.1773178913 2814932022 0831280566 98 D-9 / - DATA BIP1CS( 14) / +.2272089478 3465236347 2821263893 11 D-10 / - DATA BIP1CS( 15) / +.1654045631 3972049847 0328606818 91 D-11 / - DATA BIP1CS( 16) / -.1851712555 9292316390 7553698966 93 D-11 / - DATA BIP1CS( 17) / +.5957631247 7117290165 6807155342 77 D-12 / - DATA BIP1CS( 18) / -.1219434814 7346564781 0557694989 86 D-12 / - DATA BIP1CS( 19) / +.1334786925 3513048815 3863478135 97 D-13 / - DATA BIP1CS( 20) / +.1727831152 4339746664 3847928897 31 D-14 / - DATA BIP1CS( 21) / -.1459073201 3016720735 2688717131 66 D-14 / - DATA BIP1CS( 22) / +.4901031992 7115819978 9949895201 04 D-15 / - DATA BIP1CS( 23) / -.1155654551 9261548129 2629727625 21 D-15 / - DATA BIP1CS( 24) / +.1909880736 7072411430 6717324415 24 D-16 / - DATA BIP1CS( 25) / -.1176896685 4492179886 9139959578 62 D-17 / - DATA BIP1CS( 26) / -.6327192514 9530064474 5374596770 47 D-18 / - DATA BIP1CS( 27) / +.3386183888 0715361614 1301913223 16 D-18 / - DATA BIP1CS( 28) / -.1072582532 1758625254 9921622196 22 D-18 / - DATA BIP1CS( 29) / +.2599570960 5617169284 7869331155 62 D-19 / - DATA BIP1CS( 30) / -.4847758357 1081193660 9623094941 01 D-20 / - DATA BIP1CS( 31) / +.5529891398 2121625361 5055131989 33 D-21 / - DATA BIP1CS( 32) / +.4942166082 6069471371 7481974442 66 D-22 / - DATA BIP1CS( 33) / -.5516212192 4145707458 0697208149 33 D-22 / - DATA BIP1CS( 34) / +.2143756041 7632550086 6318844996 26 D-22 / - DATA BIP1CS( 35) / -.6191031338 7655605798 7850611370 66 D-23 / - DATA BIP1CS( 36) / +.1462936270 7391245659 8309673369 59 D-23 / - DATA BIP1CS( 37) / -.2791848447 1059005576 1778660693 33 D-24 / - DATA BIP1CS( 38) / +.3645570316 8570246150 9067953493 33 D-25 / - DATA BIP1CS( 39) / +.5851182190 6188711839 3824597333 33 D-27 / - DATA BIP1CS( 40) / -.2494695048 7566510969 7450475519 99 D-26 / - DATA BIP1CS( 41) / +.1097932398 0338380977 9195794773 33 D-26 / - DATA BIP1CS( 42) / -.3474338834 5961115015 0340881066 66 D-27 / - DATA BIP1CS( 43) / +.9137340263 5349697363 1710822400 00 D-28 / - DATA BIP1CS( 44) / -.2051035272 8210629186 2477209599 99 D-28 / - DATA BIP1CS( 45) / +.3797698569 8546461748 6516223999 99 D-29 / - DATA BIP1CS( 46) / -.4847945849 7755565887 8484480000 00 D-30 / - DATA BIP1CS( 47) / -.1055830694 1230714314 2058666666 66 D-31 / - DATA BIP2CS( 1) / -.1135967375 8598867913 7973108955 27 D+0 / - DATA BIP2CS( 2) / +.4138147394 7881595760 0520811714 44 D-2 / - DATA BIP2CS( 3) / +.1353470622 1193329857 6969217275 08 D-3 / - DATA BIP2CS( 4) / +.1042731665 3015353405 8871834567 80 D-4 / - DATA BIP2CS( 5) / +.1347495476 7849907889 5899119589 25 D-5 / - DATA BIP2CS( 6) / +.1696537405 4383983356 0625111637 56 D-6 / - DATA BIP2CS( 7) / -.1009650086 5641624301 3662283963 73 D-7 / - DATA BIP2CS( 8) / -.1672911949 3778475127 8369730959 43 D-7 / - DATA BIP2CS( 9) / -.4581536448 5068383217 1527956133 91 D-8 / - DATA BIP2CS( 10) / +.3736681366 5655477274 0647493842 84 D-9 / - DATA BIP2CS( 11) / +.5766930320 1452448119 5846435021 11 D-9 / - DATA BIP2CS( 12) / +.6218126508 7850324095 3934087923 71 D-10 / - DATA BIP2CS( 13) / -.6329412028 2743068241 5891772813 54 D-10 / - DATA BIP2CS( 14) / -.1491504790 8598767633 9990919894 87 D-10 / - DATA BIP2CS( 15) / +.7889621394 2486771938 1723942948 91 D-11 / - DATA BIP2CS( 16) / +.2496051372 1857797984 8880640001 27 D-11 / - DATA BIP2CS( 17) / -.1213007528 7291659477 7466647348 14 D-11 / - DATA BIP2CS( 18) / -.3740493910 8727277887 3434604027 16 D-12 / - DATA BIP2CS( 19) / +.2237727814 0321476798 7834469310 91 D-12 / - DATA BIP2CS( 20) / +.4749029631 2192466341 9860774725 14 D-13 / - DATA BIP2CS( 21) / -.4526160799 1821224810 6056558312 94 D-13 / - DATA BIP2CS( 22) / -.3017227184 1986072645 1122458760 20 D-14 / - DATA BIP2CS( 23) / +.9105860355 8754058327 5926834789 08 D-14 / - DATA BIP2CS( 24) / -.9814923803 3807062926 6438642077 09 D-15 / - DATA BIP2CS( 25) / -.1642940064 7889465253 6012452515 89 D-14 / - DATA BIP2CS( 26) / +.5533483421 4274215451 1821146351 64 D-15 / - DATA BIP2CS( 27) / +.2175047986 4482655984 3743819981 56 D-15 / - DATA BIP2CS( 28) / -.1737923620 0220656971 2870295580 87 D-15 / - DATA BIP2CS( 29) / -.1047002347 1443714959 2839093136 04 D-17 / - DATA BIP2CS( 30) / +.3921914598 6056386925 4414033114 62 D-16 / - DATA BIP2CS( 31) / -.1162129368 6345196925 8240056659 10 D-16 / - DATA BIP2CS( 32) / -.5402747449 1754245533 7354113077 73 D-17 / - DATA BIP2CS( 33) / +.4544158212 3884610882 6754285533 04 D-17 / - DATA BIP2CS( 34) / -.2877559962 5221075729 4275854800 86 D-18 / - DATA BIP2CS( 35) / -.1001734092 7225341243 5961629604 40 D-17 / - DATA BIP2CS( 36) / +.4482393121 5068369856 3325619063 13 D-18 / - DATA BIP2CS( 37) / +.7613596865 4908942328 9489823667 75 D-19 / - DATA BIP2CS( 38) / -.1444832409 4881347238 9560601454 22 D-18 / - DATA BIP2CS( 39) / +.4046085944 9205362251 6248473921 12 D-19 / - DATA BIP2CS( 40) / +.2032108570 0338446891 3251907072 77 D-19 / - DATA BIP2CS( 41) / -.1960279547 1446798718 2727580419 62 D-19 / - DATA BIP2CS( 42) / +.3427303844 3944824263 5189582117 38 D-20 / - DATA BIP2CS( 43) / +.3702370585 3905135480 0246515931 54 D-20 / - DATA BIP2CS( 44) / -.2687959517 2041591131 4003329667 12 D-20 / - DATA BIP2CS( 45) / +.2812167846 3531712209 7144546833 64 D-21 / - DATA BIP2CS( 46) / +.6093396363 6177797173 2711196803 29 D-21 / - DATA BIP2CS( 47) / -.3866662189 7150844994 1729778934 13 D-21 / - DATA BIP2CS( 48) / +.2598933125 3566943450 8956519272 28 D-22 / - DATA BIP2CS( 49) / +.9719439362 2938503767 2811752160 84 D-22 / - DATA BIP2CS( 50) / -.5939281783 4375098415 6304782045 91 D-22 / - DATA BIP2CS( 51) / +.3886494997 7113015409 5919604394 44 D-23 / - DATA BIP2CS( 52) / +.1533430739 3617272869 7215128687 69 D-22 / - DATA BIP2CS( 53) / -.9751355520 9762624036 3365214097 24 D-23 / - DATA BIP2CS( 54) / +.9634064444 0489471424 7413393837 26 D-24 / - DATA BIP2CS( 55) / +.2384199940 0208880109 9467487924 54 D-23 / - DATA BIP2CS( 56) / -.1689698631 5019706184 8480442052 07 D-23 / - DATA BIP2CS( 57) / +.2735271588 8928361222 5784448014 78 D-24 / - DATA BIP2CS( 58) / +.3566001618 5409578960 1116850257 30 D-24 / - DATA BIP2CS( 59) / -.3023402660 8258827249 5342806669 54 D-24 / - DATA BIP2CS( 60) / +.7500204160 5973930653 1442048232 32 D-25 / - DATA BIP2CS( 61) / +.4840328757 5851388827 4553198387 48 D-25 / - DATA BIP2CS( 62) / -.5436413765 4447888432 6980102977 66 D-25 / - DATA BIP2CS( 63) / +.1928121447 0820962653 3459788097 56 D-25 / - DATA BIP2CS( 64) / +.5011635502 0532656659 6118141721 72 D-26 / - DATA BIP2CS( 65) / -.9504074458 2693253786 0346208699 72 D-26 / - DATA BIP2CS( 66) / +.4637264615 7101975948 6963322456 11 D-26 / - DATA BIP2CS( 67) / +.2117717070 4466954163 7681705770 46 D-28 / - DATA BIP2CS( 68) / -.1540485026 8168594303 6922045487 26 D-26 / - DATA BIP2CS( 69) / +.1038794429 3201213662 0478891944 41 D-26 / - DATA BIP2CS( 70) / -.1989007815 6915416751 3167282351 53 D-27 / - DATA BIP2CS( 71) / -.2102217387 8658495471 1770445225 32 D-27 / - DATA BIP2CS( 72) / +.2135309972 4525793150 6333566704 91 D-27 / - DATA BIP2CS( 73) / -.7904081074 7961342319 0235376326 27 D-28 / - DATA BIP2CS( 74) / -.1657535996 0435585049 9737417635 92 D-28 / - DATA BIP2CS( 75) / +.3886834285 0124112587 6255864965 37 D-28 / - DATA BIP2CS( 76) / -.2230923733 0896866182 6215624247 17 D-28 / - DATA BIP2CS( 77) / +.2777724442 0176260265 6259774043 82 D-29 / - DATA BIP2CS( 78) / +.5707854347 2657725368 7124337827 72 D-29 / - DATA BIP2CS( 79) / -.5174308444 5303852800 1733715552 80 D-29 / - DATA BIP2CS( 80) / +.1841328075 1095837198 4509270715 69 D-29 / - DATA BIP2CS( 81) / +.4442256239 0957094598 5440710686 47 D-30 / - DATA BIP2CS( 82) / -.9850414263 9629801547 4649582269 43 D-30 / - DATA BIP2CS( 83) / +.5885720135 3585104884 7541988819 95 D-30 / - DATA BIP2CS( 84) / -.9763607544 0429787961 4023126285 95 D-31 / - DATA BIP2CS( 85) / -.1358101199 6074695047 0635978841 22 D-30 / - DATA BIP2CS( 86) / +.1399974351 8492413270 5680483803 45 D-30 / - DATA BIP2CS( 87) / -.5975490454 5248477620 8845629811 18 D-31 / - DATA BIP2CS( 88) / -.4039165387 5428313641 0453275298 56 D-32 / - DATA ATR / 8.750690570 8484345088 0771988210 148 D0 / - DATA BTR / -2.093836321 3560543136 0096498526 268 D0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DBIE - IF (FIRST) THEN - ETA = 0.1*REAL(D1MACH(3)) - NBIF = INITDS (BIFCS, 13, ETA) - NBIG = INITDS (BIGCS, 13, ETA) - NBIF2 = INITDS (BIF2CS, 15, ETA) - NBIG2 = INITDS (BIG2CS, 15, ETA) - NBIP1 = INITDS (BIP1CS, 47, ETA) - NBIP2 = INITDS (BIP2CS, 88, ETA) -C - X3SML = ETA**0.3333 - X32SML = 1.3104D0*X3SML**2 - XBIG = D1MACH(2)**0.6666D0 - ENDIF - FIRST = .FALSE. -C - IF (X.GE.(-1.0D0)) GO TO 20 - CALL D9AIMP (X, XM, THETA) - DBIE = XM * SIN(THETA) - RETURN -C - 20 IF (X.GT.1.0D0) GO TO 30 - Z = 0.D0 - IF (ABS(X).GT.X3SML) Z = X**3 - DBIE = 0.625D0 + DCSEVL (Z, BIFCS, NBIF) + X*(0.4375D0 + - 1 DCSEVL (Z, BIGCS, NBIG) ) - IF (X.GT.X32SML) DBIE = DBIE * EXP(-2.0D0*X*SQRT(X)/3.0D0) - RETURN -C - 30 IF (X.GT.2.0D0) GO TO 40 - Z = (2.0D0*X**3 - 9.0D0)/7.0D0 - DBIE = EXP(-2.0D0*X*SQRT(X)/3.0D0) * (1.125D0 + - 1 DCSEVL (Z, BIF2CS, NBIF2) + X*(0.625D0 + DCSEVL (Z, BIG2CS, - 2 NBIG2)) ) - RETURN -C - 40 IF (X.GT.4.0D0) GO TO 50 - SQRTX = SQRT(X) - Z = ATR/(X*SQRTX) + BTR - DBIE = (0.625D0 + DCSEVL (Z, BIP1CS, NBIP1))/SQRT(SQRTX) - RETURN -C - 50 SQRTX = SQRT(X) - Z = -1.0D0 - IF (X.LT.XBIG) Z = 16.D0/(X*SQRTX) - 1.0D0 - DBIE = (0.625D0 + DCSEVL (Z, BIP2CS, NBIP2))/SQRT(SQRTX) - RETURN -C - END diff --git a/slatec/dbinom.f b/slatec/dbinom.f deleted file mode 100644 index 7ff3f19..0000000 --- a/slatec/dbinom.f +++ /dev/null @@ -1,75 +0,0 @@ -*DECK DBINOM - DOUBLE PRECISION FUNCTION DBINOM (N, M) -C***BEGIN PROLOGUE DBINOM -C***PURPOSE Compute the binomial coefficients. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C1 -C***TYPE DOUBLE PRECISION (BINOM-S, DBINOM-D) -C***KEYWORDS BINOMIAL COEFFICIENTS, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DBINOM(N,M) calculates the double precision binomial coefficient -C for integer arguments N and M. The result is (N!)/((M!)(N-M)!). -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, D9LGMC, DLNREL, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 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***END PROLOGUE DBINOM - DOUBLE PRECISION CORR, FINTMX, SQ2PIL, XK, XN, XNK, D9LGMC, - 1 DLNREL, D1MACH, BILNMX - LOGICAL FIRST - SAVE SQ2PIL, BILNMX, FINTMX, FIRST - DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DBINOM - IF (FIRST) THEN - BILNMX = LOG(D1MACH(2)) - 0.0001D0 - FINTMX = 0.9D0/D1MACH(3) - ENDIF - FIRST = .FALSE. -C - IF (N .LT. 0 .OR. M .LT. 0) CALL XERMSG ('SLATEC', 'DBINOM', - + 'N OR M LT ZERO', 1, 2) - IF (N .LT. M) CALL XERMSG ('SLATEC', 'DBINOM', 'N LT M', 2, 2) -C - K = MIN (M, N-M) - IF (K.GT.20) GO TO 30 - IF (K*LOG(AMAX0(N,1)).GT.BILNMX) GO TO 30 -C - DBINOM = 1.0D0 - IF (K.EQ.0) RETURN - DO 20 I=1,K - XN = N - I + 1 - XK = I - DBINOM = DBINOM * (XN/XK) - 20 CONTINUE -C - IF (DBINOM.LT.FINTMX) DBINOM = AINT (DBINOM+0.5D0) - RETURN -C -C IF K.LT.9, APPROX IS NOT VALID AND ANSWER IS CLOSE TO THE OVERFLOW LIM - 30 IF (K .LT. 9) CALL XERMSG ('SLATEC', 'DBINOM', - + 'RESULT OVERFLOWS BECAUSE N AND/OR M TOO BIG', 3, 2) -C - XN = N + 1 - XK = K + 1 - XNK = N - K + 1 -C - CORR = D9LGMC(XN) - D9LGMC(XK) - D9LGMC(XNK) - DBINOM = XK*LOG(XNK/XK) - XN*DLNREL(-(XK-1.0D0)/XN) - 1 -0.5D0*LOG(XN*XNK/XK) + 1.0D0 - SQ2PIL + CORR -C - IF (DBINOM .GT. BILNMX) CALL XERMSG ('SLATEC', 'DBINOM', - + 'RESULT OVERFLOWS BECAUSE N AND/OR M TOO BIG', 3, 2) -C - DBINOM = EXP (DBINOM) - IF (DBINOM.LT.FINTMX) DBINOM = AINT (DBINOM+0.5D0) -C - RETURN - END diff --git a/slatec/dbint4.f b/slatec/dbint4.f deleted file mode 100644 index 9e239de..0000000 --- a/slatec/dbint4.f +++ /dev/null @@ -1,241 +0,0 @@ -*DECK DBINT4 - SUBROUTINE DBINT4 (X, Y, NDATA, IBCL, IBCR, FBCL, FBCR, KNTOPT, T, - + BCOEF, N, K, W) -C***BEGIN PROLOGUE DBINT4 -C***PURPOSE Compute the B-representation of a cubic spline -C which interpolates given data. -C***LIBRARY SLATEC -C***CATEGORY E1A -C***TYPE DOUBLE PRECISION (BINT4-S, DBINT4-D) -C***KEYWORDS B-SPLINE, CUBIC SPLINES, DATA FITTING, INTERPOLATION -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Abstract **** a double precision routine **** -C -C DBINT4 computes the B representation (T,BCOEF,N,K) of a -C cubic spline (K=4) which interpolates data (X(I),Y(I)), -C I=1,NDATA. Parameters IBCL, IBCR, FBCL, FBCR allow the -C specification of the spline first or second derivative at -C both X(1) and X(NDATA). When this data is not specified -C by the problem, it is common practice to use a natural -C spline by setting second derivatives at X(1) and X(NDATA) -C to zero (IBCL=IBCR=2,FBCL=FBCR=0.0). The spline is defined -C on T(4) .LE. X .LE. T(N+1) with (ordered) interior knots at -C X(I) values where N=NDATA+2. The knots T(1),T(2),T(3) lie to -C the left of T(4)=X(1) and the knots T(N+2), T(N+3), T(N+4) -C lie to the right of T(N+1)=X(NDATA) in increasing order. If -C no extrapolation outside (X(1),X(NDATA)) is anticipated, the -C knots T(1)=T(2)=T(3)=T(4)=X(1) and T(N+2)=T(N+3)=T(N+4)= -C T(N+1)=X(NDATA) can be specified by KNTOPT=1. KNTOPT=2 -C selects a knot placement for T(1), T(2), T(3) to make the -C first 7 knots symmetric about T(4)=X(1) and similarly for -C T(N+2), T(N+3), T(N+4) about T(N+1)=X(NDATA). KNTOPT=3 -C allows the user to make his own selection, in increasing -C order, for T(1), T(2), T(3) to the left of X(1) and T(N+2), -C T(N+3), T(N+4) to the right of X(NDATA) in the work array -C W(1) through W(6). In any case, the interpolation on -C T(4) .LE. X .LE. T(N+1) by using function DBVALU is unique -C for given boundary conditions. -C -C Description of Arguments -C -C Input X,Y,FBCL,FBCR,W are double precision -C X - X vector of abscissae of length NDATA, distinct -C and in increasing order -C Y - Y vector of ordinates of length NDATA -C NDATA - number of data points, NDATA .GE. 2 -C IBCL - selection parameter for left boundary condition -C IBCL = 1 constrain the first derivative at -C X(1) to FBCL -C = 2 constrain the second derivative at -C X(1) to FBCL -C IBCR - selection parameter for right boundary condition -C IBCR = 1 constrain first derivative at -C X(NDATA) to FBCR -C IBCR = 2 constrain second derivative at -C X(NDATA) to FBCR -C FBCL - left boundary values governed by IBCL -C FBCR - right boundary values governed by IBCR -C KNTOPT - knot selection parameter -C KNTOPT = 1 sets knot multiplicity at T(4) and -C T(N+1) to 4 -C = 2 sets a symmetric placement of knots -C about T(4) and T(N+1) -C = 3 sets T(I)=W(I) and T(N+1+I)=W(3+I),I=1,3 -C where W(I),I=1,6 is supplied by the user -C W - work array of dimension at least 5*(NDATA+2) -C If KNTOPT=3, then W(1),W(2),W(3) are knot values to -C the left of X(1) and W(4),W(5),W(6) are knot -C values to the right of X(NDATA) in increasing -C order to be supplied by the user -C -C Output T,BCOEF are double precision -C T - knot array of length N+4 -C BCOEF - B spline coefficient array of length N -C N - number of coefficients, N=NDATA+2 -C K - order of spline, K=4 -C -C Error Conditions -C Improper input is a fatal error -C Singular system of equations is a fatal error -C -C***REFERENCES D. E. Amos, Computation with splines and B-splines, -C Report SAND78-1968, Sandia Laboratories, March 1979. -C Carl de Boor, Package for calculating with B-splines, -C SIAM Journal on Numerical Analysis 14, 3 (June 1977), -C pp. 441-472. -C Carl de Boor, A Practical Guide to Splines, Applied -C Mathematics Series 27, Springer-Verlag, New York, -C 1978. -C***ROUTINES CALLED D1MACH, DBNFAC, DBNSLV, DBSPVD, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800901 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DBINT4 -C - INTEGER I, IBCL, IBCR, IFLAG, ILB, ILEFT, IT, IUB, IW, IWP, J, - 1 JW, K, KNTOPT, N, NDATA, NDM, NP, NWROW - DOUBLE PRECISION BCOEF,FBCL,FBCR,T,TOL,TXN,TX1,VNIKX,W,WDTOL, - 1 WORK,X,XL,Y - DOUBLE PRECISION D1MACH - DIMENSION X(*), Y(*), T(*), BCOEF(*), W(5,*), VNIKX(4,4), WORK(15) -C***FIRST EXECUTABLE STATEMENT DBINT4 - WDTOL = D1MACH(4) - TOL = SQRT(WDTOL) - IF (NDATA.LT.2) GO TO 200 - NDM = NDATA - 1 - DO 10 I=1,NDM - IF (X(I).GE.X(I+1)) GO TO 210 - 10 CONTINUE - IF (IBCL.LT.1 .OR. IBCL.GT.2) GO TO 220 - IF (IBCR.LT.1 .OR. IBCR.GT.2) GO TO 230 - IF (KNTOPT.LT.1 .OR. KNTOPT.GT.3) GO TO 240 - K = 4 - N = NDATA + 2 - NP = N + 1 - DO 20 I=1,NDATA - T(I+3) = X(I) - 20 CONTINUE - GO TO (30, 50, 90), KNTOPT -C SET UP KNOT ARRAY WITH MULTIPLICITY 4 AT X(1) AND X(NDATA) - 30 CONTINUE - DO 40 I=1,3 - T(4-I) = X(1) - T(NP+I) = X(NDATA) - 40 CONTINUE - GO TO 110 -C SET UP KNOT ARRAY WITH SYMMETRIC PLACEMENT ABOUT END POINTS - 50 CONTINUE - IF (NDATA.GT.3) GO TO 70 - XL = (X(NDATA)-X(1))/3.0D0 - DO 60 I=1,3 - T(4-I) = T(5-I) - XL - T(NP+I) = T(NP+I-1) + XL - 60 CONTINUE - GO TO 110 - 70 CONTINUE - TX1 = X(1) + X(1) - TXN = X(NDATA) + X(NDATA) - DO 80 I=1,3 - T(4-I) = TX1 - X(I+1) - T(NP+I) = TXN - X(NDATA-I) - 80 CONTINUE - GO TO 110 -C SET UP KNOT ARRAY LESS THAN X(1) AND GREATER THAN X(NDATA) TO BE -C SUPPLIED BY USER IN WORK LOCATIONS W(1) THROUGH W(6) WHEN KNTOPT=3 - 90 CONTINUE - DO 100 I=1,3 - T(4-I) = W(4-I,1) - JW = MAX(1,I-1) - IW = MOD(I+2,5)+1 - T(NP+I) = W(IW,JW) - IF (T(4-I).GT.T(5-I)) GO TO 250 - IF (T(NP+I).LT.T(NP+I-1)) GO TO 250 - 100 CONTINUE - 110 CONTINUE -C - DO 130 I=1,5 - DO 120 J=1,N - W(I,J) = 0.0D0 - 120 CONTINUE - 130 CONTINUE -C SET UP LEFT INTERPOLATION POINT AND LEFT BOUNDARY CONDITION FOR -C RIGHT LIMITS - IT = IBCL + 1 - CALL DBSPVD(T, K, IT, X(1), K, 4, VNIKX, WORK) - IW = 0 - IF (ABS(VNIKX(3,1)).LT.TOL) IW = 1 - DO 140 J=1,3 - W(J+1,4-J) = VNIKX(4-J,IT) - W(J,4-J) = VNIKX(4-J,1) - 140 CONTINUE - BCOEF(1) = Y(1) - BCOEF(2) = FBCL -C SET UP INTERPOLATION EQUATIONS FOR POINTS I=2 TO I=NDATA-1 - ILEFT = 4 - IF (NDM.LT.2) GO TO 170 - DO 160 I=2,NDM - ILEFT = ILEFT + 1 - CALL DBSPVD(T, K, 1, X(I), ILEFT, 4, VNIKX, WORK) - DO 150 J=1,3 - W(J+1,3+I-J) = VNIKX(4-J,1) - 150 CONTINUE - BCOEF(I+1) = Y(I) - 160 CONTINUE -C SET UP RIGHT INTERPOLATION POINT AND RIGHT BOUNDARY CONDITION FOR -C LEFT LIMITS(ILEFT IS ASSOCIATED WITH T(N)=X(NDATA-1)) - 170 CONTINUE - IT = IBCR + 1 - CALL DBSPVD(T, K, IT, X(NDATA), ILEFT, 4, VNIKX, WORK) - JW = 0 - IF (ABS(VNIKX(2,1)).LT.TOL) JW = 1 - DO 180 J=1,3 - W(J+1,3+NDATA-J) = VNIKX(5-J,IT) - W(J+2,3+NDATA-J) = VNIKX(5-J,1) - 180 CONTINUE - BCOEF(N-1) = FBCR - BCOEF(N) = Y(NDATA) -C SOLVE SYSTEM OF EQUATIONS - ILB = 2 - JW - IUB = 2 - IW - NWROW = 5 - IWP = IW + 1 - CALL DBNFAC(W(IWP,1), NWROW, N, ILB, IUB, IFLAG) - IF (IFLAG.EQ.2) GO TO 190 - CALL DBNSLV(W(IWP,1), NWROW, N, ILB, IUB, BCOEF) - RETURN -C -C - 190 CONTINUE - CALL XERMSG ('SLATEC', 'DBINT4', - + 'THE SYSTEM OF EQUATIONS IS SINGULAR', 2, 1) - RETURN - 200 CONTINUE - CALL XERMSG ('SLATEC', 'DBINT4', 'NDATA IS LESS THAN 2', 2, 1) - RETURN - 210 CONTINUE - CALL XERMSG ('SLATEC', 'DBINT4', - + 'X VALUES ARE NOT DISTINCT OR NOT ORDERED', 2, 1) - RETURN - 220 CONTINUE - CALL XERMSG ('SLATEC', 'DBINT4', 'IBCL IS NOT 1 OR 2', 2, 1) - RETURN - 230 CONTINUE - CALL XERMSG ('SLATEC', 'DBINT4', 'IBCR IS NOT 1 OR 2', 2, 1) - RETURN - 240 CONTINUE - CALL XERMSG ('SLATEC', 'DBINT4', 'KNTOPT IS NOT 1, 2, OR 3', 2, - + 1) - RETURN - 250 CONTINUE - CALL XERMSG ('SLATEC', 'DBINT4', - + 'KNOT INPUT THROUGH W ARRAY IS NOT ORDERED PROPERLY', 2, 1) - RETURN - END diff --git a/slatec/dbintk.f b/slatec/dbintk.f deleted file mode 100644 index 1d2cf6b..0000000 --- a/slatec/dbintk.f +++ /dev/null @@ -1,189 +0,0 @@ -*DECK DBINTK - SUBROUTINE DBINTK (X, Y, T, N, K, BCOEF, Q, WORK) -C***BEGIN PROLOGUE DBINTK -C***PURPOSE Compute the B-representation of a spline which interpolates -C given data. -C***LIBRARY SLATEC -C***CATEGORY E1A -C***TYPE DOUBLE PRECISION (BINTK-S, DBINTK-D) -C***KEYWORDS B-SPLINE, DATA FITTING, INTERPOLATION -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Written by Carl de Boor and modified by D. E. Amos -C -C Abstract **** a double precision routine **** -C -C DBINTK is the SPLINT routine of the reference. -C -C DBINTK produces the B-spline coefficients, BCOEF, of the -C B-spline of order K with knots T(I), I=1,...,N+K, which -C takes on the value Y(I) at X(I), I=1,...,N. The spline or -C any of its derivatives can be evaluated by calls to DBVALU. -C -C The I-th equation of the linear system A*BCOEF = B for the -C coefficients of the interpolant enforces interpolation at -C X(I), I=1,...,N. Hence, B(I) = Y(I), for all I, and A is -C a band matrix with 2K-1 bands if A is invertible. The matrix -C A is generated row by row and stored, diagonal by diagonal, -C in the rows of Q, with the main diagonal going into row K. -C The banded system is then solved by a call to DBNFAC (which -C constructs the triangular factorization for A and stores it -C again in Q), followed by a call to DBNSLV (which then -C obtains the solution BCOEF by substitution). DBNFAC does no -C pivoting, since the total positivity of the matrix A makes -C this unnecessary. The linear system to be solved is -C (theoretically) invertible if and only if -C T(I) .LT. X(I) .LT. T(I+K), for all I. -C Equality is permitted on the left for I=1 and on the right -C for I=N when K knots are used at X(1) or X(N). Otherwise, -C violation of this condition is certain to lead to an error. -C -C Description of Arguments -C -C Input X,Y,T are double precision -C X - vector of length N containing data point abscissa -C in strictly increasing order. -C Y - corresponding vector of length N containing data -C point ordinates. -C T - knot vector of length N+K -C Since T(1),..,T(K) .LE. X(1) and T(N+1),..,T(N+K) -C .GE. X(N), this leaves only N-K knots (not nec- -C essarily X(I) values) interior to (X(1),X(N)) -C N - number of data points, N .GE. K -C K - order of the spline, K .GE. 1 -C -C Output BCOEF,Q,WORK are double precision -C BCOEF - a vector of length N containing the B-spline -C coefficients -C Q - a work vector of length (2*K-1)*N, containing -C the triangular factorization of the coefficient -C matrix of the linear system being solved. The -C coefficients for the interpolant of an -C additional data set (X(I),YY(I)), I=1,...,N -C with the same abscissa can be obtained by loading -C YY into BCOEF and then executing -C CALL DBNSLV (Q,2K-1,N,K-1,K-1,BCOEF) -C WORK - work vector of length 2*K -C -C Error Conditions -C Improper input is a fatal error -C Singular system of equations is a fatal error -C -C***REFERENCES D. E. Amos, Computation with splines and B-splines, -C Report SAND78-1968, Sandia Laboratories, March 1979. -C Carl de Boor, Package for calculating with B-splines, -C SIAM Journal on Numerical Analysis 14, 3 (June 1977), -C pp. 441-472. -C Carl de Boor, A Practical Guide to Splines, Applied -C Mathematics Series 27, Springer-Verlag, New York, -C 1978. -C***ROUTINES CALLED DBNFAC, DBNSLV, DBSPVN, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800901 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DBINTK -C - INTEGER IFLAG, IWORK, K, N, I, ILP1MX, J, JJ, KM1, KPKM2, LEFT, - 1 LENQ, NP1 - DOUBLE PRECISION BCOEF(*), Y(*), Q(*), T(*), X(*), XI, WORK(*) -C DIMENSION Q(2*K-1,N), T(N+K) -C***FIRST EXECUTABLE STATEMENT DBINTK - IF(K.LT.1) GO TO 100 - IF(N.LT.K) GO TO 105 - JJ = N - 1 - IF(JJ.EQ.0) GO TO 6 - DO 5 I=1,JJ - IF(X(I).GE.X(I+1)) GO TO 110 - 5 CONTINUE - 6 CONTINUE - NP1 = N + 1 - KM1 = K - 1 - KPKM2 = 2*KM1 - LEFT = K -C ZERO OUT ALL ENTRIES OF Q - LENQ = N*(K+KM1) - DO 10 I=1,LENQ - Q(I) = 0.0D0 - 10 CONTINUE -C -C *** LOOP OVER I TO CONSTRUCT THE N INTERPOLATION EQUATIONS - DO 50 I=1,N - XI = X(I) - ILP1MX = MIN(I+K,NP1) -C *** FIND LEFT IN THE CLOSED INTERVAL (I,I+K-1) SUCH THAT -C T(LEFT) .LE. X(I) .LT. T(LEFT+1) -C MATRIX IS SINGULAR IF THIS IS NOT POSSIBLE - LEFT = MAX(LEFT,I) - IF (XI.LT.T(LEFT)) GO TO 80 - 20 IF (XI.LT.T(LEFT+1)) GO TO 30 - LEFT = LEFT + 1 - IF (LEFT.LT.ILP1MX) GO TO 20 - LEFT = LEFT - 1 - IF (XI.GT.T(LEFT+1)) GO TO 80 -C *** THE I-TH EQUATION ENFORCES INTERPOLATION AT XI, HENCE -C A(I,J) = B(J,K,T)(XI), ALL J. ONLY THE K ENTRIES WITH J = -C LEFT-K+1,...,LEFT ACTUALLY MIGHT BE NONZERO. THESE K NUMBERS -C ARE RETURNED, IN BCOEF (USED FOR TEMP. STORAGE HERE), BY THE -C FOLLOWING - 30 CALL DBSPVN(T, K, K, 1, XI, LEFT, BCOEF, WORK, IWORK) -C WE THEREFORE WANT BCOEF(J) = B(LEFT-K+J)(XI) TO GO INTO -C A(I,LEFT-K+J), I.E., INTO Q(I-(LEFT+J)+2*K,(LEFT+J)-K) SINCE -C A(I+J,J) IS TO GO INTO Q(I+K,J), ALL I,J, IF WE CONSIDER Q -C AS A TWO-DIM. ARRAY , WITH 2*K-1 ROWS (SEE COMMENTS IN -C DBNFAC). IN THE PRESENT PROGRAM, WE TREAT Q AS AN EQUIVALENT -C ONE-DIMENSIONAL ARRAY (BECAUSE OF FORTRAN RESTRICTIONS ON -C DIMENSION STATEMENTS) . WE THEREFORE WANT BCOEF(J) TO GO INTO -C ENTRY -C I -(LEFT+J) + 2*K + ((LEFT+J) - K-1)*(2*K-1) -C = I-LEFT+1 + (LEFT -K)*(2*K-1) + (2*K-2)*J -C OF Q . - JJ = I - LEFT + 1 + (LEFT-K)*(K+KM1) - DO 40 J=1,K - JJ = JJ + KPKM2 - Q(JJ) = BCOEF(J) - 40 CONTINUE - 50 CONTINUE -C -C ***OBTAIN FACTORIZATION OF A , STORED AGAIN IN Q. - CALL DBNFAC(Q, K+KM1, N, KM1, KM1, IFLAG) - GO TO (60, 90), IFLAG -C *** SOLVE A*BCOEF = Y BY BACKSUBSTITUTION - 60 DO 70 I=1,N - BCOEF(I) = Y(I) - 70 CONTINUE - CALL DBNSLV(Q, K+KM1, N, KM1, KM1, BCOEF) - RETURN -C -C - 80 CONTINUE - CALL XERMSG ('SLATEC', 'DBINTK', - + 'SOME ABSCISSA WAS NOT IN THE SUPPORT OF THE CORRESPONDING ' // - + 'BASIS FUNCTION AND THE SYSTEM IS SINGULAR.', 2, 1) - RETURN - 90 CONTINUE - CALL XERMSG ('SLATEC', 'DBINTK', - + 'THE SYSTEM OF SOLVER DETECTS A SINGULAR SYSTEM ALTHOUGH ' // - + 'THE THEORETICAL CONDITIONS FOR A SOLUTION WERE SATISFIED.', - + 8, 1) - RETURN - 100 CONTINUE - CALL XERMSG ('SLATEC', 'DBINTK', 'K DOES NOT SATISFY K.GE.1', 2, - + 1) - RETURN - 105 CONTINUE - CALL XERMSG ('SLATEC', 'DBINTK', 'N DOES NOT SATISFY N.GE.K', 2, - + 1) - RETURN - 110 CONTINUE - CALL XERMSG ('SLATEC', 'DBINTK', - + 'X(I) DOES NOT SATISFY X(I).LT.X(I+1) FOR SOME I', 2, 1) - RETURN - END diff --git a/slatec/dbkias.f b/slatec/dbkias.f deleted file mode 100644 index 6e276e5..0000000 --- a/slatec/dbkias.f +++ /dev/null @@ -1,261 +0,0 @@ -*DECK DBKIAS - SUBROUTINE DBKIAS (X, N, KTRMS, T, ANS, IND, MS, GMRN, H, IERR) -C***BEGIN PROLOGUE DBKIAS -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBSKIN -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (BKIAS-S, DBKIAS-D) -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C DBKIAS computes repeated integrals of the K0 Bessel function -C by the asymptotic expansion -C -C***SEE ALSO DBSKIN -C***ROUTINES CALLED D1MACH, DBDIFF, DGAMRN, DHKSEQ -C***REVISION HISTORY (YYMMDD) -C 820601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DBKIAS - INTEGER I, II, IND, J, JMI, JN, K, KK, KM, KTRMS, MM, MP, MS, N, - * IERR - DOUBLE PRECISION ANS, B, BND, DEN1, DEN2, DEN3, ER, ERR, FJ, FK, - * FLN, FM1, GMRN, G1, GS, H, HN, HRTPI, RAT, RG1, RXP, RZ, RZX, S, - * SS, SUMI, SUMJ, T, TOL, V, W, X, XP, Z - DOUBLE PRECISION DGAMRN, D1MACH - DIMENSION B(120), XP(16), S(31), H(*), V(52), W(52), T(50), - * BND(15) - SAVE B, BND, HRTPI -C----------------------------------------------------------------------- -C COEFFICIENTS OF POLYNOMIAL P(J-1,X), J=1,15 -C----------------------------------------------------------------------- - DATA B(1), B(2), B(3), B(4), B(5), B(6), B(7), B(8), B(9), B(10), - * B(11), B(12), B(13), B(14), B(15), B(16), B(17), B(18), B(19), - * B(20), B(21), B(22), B(23), B(24) /1.00000000000000000D+00, - * 1.00000000000000000D+00,-2.00000000000000000D+00, - * 1.00000000000000000D+00,-8.00000000000000000D+00, - * 6.00000000000000000D+00,1.00000000000000000D+00, - * -2.20000000000000000D+01,5.80000000000000000D+01, - * -2.40000000000000000D+01,1.00000000000000000D+00, - * -5.20000000000000000D+01,3.28000000000000000D+02, - * -4.44000000000000000D+02,1.20000000000000000D+02, - * 1.00000000000000000D+00,-1.14000000000000000D+02, - * 1.45200000000000000D+03,-4.40000000000000000D+03, - * 3.70800000000000000D+03,-7.20000000000000000D+02, - * 1.00000000000000000D+00,-2.40000000000000000D+02, - * 5.61000000000000000D+03/ - DATA B(25), B(26), B(27), B(28), B(29), B(30), B(31), B(32), - * B(33), B(34), B(35), B(36), B(37), B(38), B(39), B(40), B(41), - * B(42), B(43), B(44), B(45), B(46), B(47), B(48) - * /-3.21200000000000000D+04,5.81400000000000000D+04, - * -3.39840000000000000D+04,5.04000000000000000D+03, - * 1.00000000000000000D+00,-4.94000000000000000D+02, - * 1.99500000000000000D+04,-1.95800000000000000D+05, - * 6.44020000000000000D+05,-7.85304000000000000D+05, - * 3.41136000000000000D+05,-4.03200000000000000D+04, - * 1.00000000000000000D+00,-1.00400000000000000D+03, - * 6.72600000000000000D+04,-1.06250000000000000D+06, - * 5.76550000000000000D+06,-1.24400640000000000D+07, - * 1.10262960000000000D+07,-3.73392000000000000D+06, - * 3.62880000000000000D+05,1.00000000000000000D+00, - * -2.02600000000000000D+03,2.18848000000000000D+05/ - DATA B(49), B(50), B(51), B(52), B(53), B(54), B(55), B(56), - * B(57), B(58), B(59), B(60), B(61), B(62), B(63), B(64), B(65), - * B(66), B(67), B(68), B(69), B(70), B(71), B(72) - * /-5.32616000000000000D+06,4.47650000000000000D+07, - * -1.55357384000000000D+08,2.38904904000000000D+08, - * -1.62186912000000000D+08,4.43390400000000000D+07, - * -3.62880000000000000D+06,1.00000000000000000D+00, - * -4.07200000000000000D+03,6.95038000000000000D+05, - * -2.52439040000000000D+07,3.14369720000000000D+08, - * -1.64838430400000000D+09,4.00269508800000000D+09, - * -4.64216395200000000D+09,2.50748121600000000D+09, - * -5.68356480000000000D+08,3.99168000000000000D+07, - * 1.00000000000000000D+00,-8.16600000000000000D+03, - * 2.17062600000000000D+06,-1.14876376000000000D+08, - * 2.05148277600000000D+09,-1.55489607840000000D+10/ - DATA B(73), B(74), B(75), B(76), B(77), B(78), B(79), B(80), - * B(81), B(82), B(83), B(84), B(85), B(86), B(87), B(88), B(89), - * B(90), B(91), B(92), B(93), B(94), B(95), B(96) - * /5.60413987840000000D+10,-1.01180433024000000D+11, - * 9.21997902240000000D+10,-4.07883018240000000D+10, - * 7.82771904000000000D+09,-4.79001600000000000D+08, - * 1.00000000000000000D+00,-1.63560000000000000D+04, - * 6.69969600000000000D+06,-5.07259276000000000D+08, - * 1.26698177760000000D+10,-1.34323420224000000D+11, - * 6.87720046384000000D+11,-1.81818864230400000D+12, - * 2.54986547342400000D+12,-1.88307966182400000D+12, - * 6.97929436800000000D+11,-1.15336085760000000D+11, - * 6.22702080000000000D+09,1.00000000000000000D+00, - * -3.27380000000000000D+04,2.05079880000000000D+07, - * -2.18982980800000000D+09,7.50160522280000000D+10/ - DATA B(97), B(98), B(99), B(100), B(101), B(102), B(103), B(104), - * B(105), B(106), B(107), B(108), B(109), B(110), B(111), B(112), - * B(113), B(114), B(115), B(116), B(117), B(118) - * /-1.08467651241600000D+12,7.63483214939200000D+12, - * -2.82999100661120000D+13,5.74943734645920000D+13, - * -6.47283751398720000D+13,3.96895780558080000D+13, - * -1.25509040179200000D+13,1.81099255680000000D+12, - * -8.71782912000000000D+10,1.00000000000000000D+00, - * -6.55040000000000000D+04,6.24078900000000000D+07, - * -9.29252692000000000D+09,4.29826006340000000D+11, - * -8.30844432796800000D+12,7.83913848313120000D+13, - * -3.94365587815520000D+14,1.11174747256968000D+15, - * -1.79717122069056000D+15,1.66642448627145600D+15, - * -8.65023253219584000D+14,2.36908271543040000D+14/ - DATA B(119), B(120) /-3.01963769856000000D+13, - * 1.30767436800000000D+12/ -C----------------------------------------------------------------------- -C BOUNDS B(M,K) , K=M-3 -C----------------------------------------------------------------------- - DATA BND(1), BND(2), BND(3), BND(4), BND(5), BND(6), BND(7), - * BND(8), BND(9), BND(10), BND(11), BND(12), BND(13), BND(14), - * BND(15) /1.0D0,1.0D0,1.0D0,1.0D0,3.10D0,5.18D0,11.7D0,29.8D0, - * 90.4D0,297.0D0,1070.0D0,4290.0D0,18100.0D0,84700.0D0,408000.0D0/ - DATA HRTPI /8.86226925452758014D-01/ -C -C***FIRST EXECUTABLE STATEMENT DBKIAS - IERR=0 - TOL = MAX(D1MACH(4),1.0D-18) - FLN = N - RZ = 1.0D0/(X+FLN) - RZX = X*RZ - Z = 0.5D0*(X+FLN) - IF (IND.GT.1) GO TO 10 - GMRN = DGAMRN(Z) - 10 CONTINUE - GS = HRTPI*GMRN - G1 = GS + GS - RG1 = 1.0D0/G1 - GMRN = (RZ+RZ)/GMRN - IF (IND.GT.1) GO TO 70 -C----------------------------------------------------------------------- -C EVALUATE ERROR FOR M=MS -C----------------------------------------------------------------------- - HN = 0.5D0*FLN - DEN2 = KTRMS + KTRMS + N - DEN3 = DEN2 - 2.0D0 - DEN1 = X + DEN2 - ERR = RG1*(X+X)/(DEN1-1.0D0) - IF (N.EQ.0) GO TO 20 - RAT = 1.0D0/(FLN*FLN) - 20 CONTINUE - IF (KTRMS.EQ.0) GO TO 30 - FJ = KTRMS - RAT = 0.25D0/(HRTPI*DEN3*SQRT(FJ)) - 30 CONTINUE - ERR = ERR*RAT - FJ = -3.0D0 - DO 50 J=1,15 - IF (J.LE.5) ERR = ERR/DEN1 - FM1 = MAX(1.0D0,FJ) - FJ = FJ + 1.0D0 - ER = BND(J)*ERR - IF (KTRMS.EQ.0) GO TO 40 - ER = ER/FM1 - IF (ER.LT.TOL) GO TO 60 - IF (J.GE.5) ERR = ERR/DEN3 - GO TO 50 - 40 CONTINUE - ER = ER*(1.0D0+HN/FM1) - IF (ER.LT.TOL) GO TO 60 - IF (J.GE.5) ERR = ERR/FLN - 50 CONTINUE - GO TO 200 - 60 CONTINUE - MS = J - 70 CONTINUE - MM = MS + MS - MP = MM + 1 -C----------------------------------------------------------------------- -C H(K)=(-Z)**(K)*(PSI(K-1,Z)-PSI(K-1,Z+0.5))/GAMMA(K) , K=1,2,...,MM -C----------------------------------------------------------------------- - IF (IND.GT.1) GO TO 80 - CALL DHKSEQ(Z, MM, H, IERR) - GO TO 100 - 80 CONTINUE - RAT = Z/(Z-0.5D0) - RXP = RAT - DO 90 I=1,MM - H(I) = RXP*(1.0D0-H(I)) - RXP = RXP*RAT - 90 CONTINUE - 100 CONTINUE -C----------------------------------------------------------------------- -C SCALED S SEQUENCE -C----------------------------------------------------------------------- - S(1) = 1.0D0 - FK = 1.0D0 - DO 120 K=2,MP - SS = 0.0D0 - KM = K - 1 - I = KM - DO 110 J=1,KM - SS = SS + S(J)*H(I) - I = I - 1 - 110 CONTINUE - S(K) = SS/FK - FK = FK + 1.0D0 - 120 CONTINUE -C----------------------------------------------------------------------- -C SCALED S-TILDA SEQUENCE -C----------------------------------------------------------------------- - IF (KTRMS.EQ.0) GO TO 160 - FK = 0.0D0 - SS = 0.0D0 - RG1 = RG1/Z - DO 130 K=1,KTRMS - V(K) = Z/(Z+FK) - W(K) = T(K)*V(K) - SS = SS + W(K) - FK = FK + 1.0D0 - 130 CONTINUE - S(1) = S(1) - SS*RG1 - DO 150 I=2,MP - SS = 0.0D0 - DO 140 K=1,KTRMS - W(K) = W(K)*V(K) - SS = SS + W(K) - 140 CONTINUE - S(I) = S(I) - SS*RG1 - 150 CONTINUE - 160 CONTINUE -C----------------------------------------------------------------------- -C SUM ON J -C----------------------------------------------------------------------- - SUMJ = 0.0D0 - JN = 1 - RXP = 1.0D0 - XP(1) = 1.0D0 - DO 190 J=1,MS - JN = JN + J - 1 - XP(J+1) = XP(J)*RZX - RXP = RXP*RZ -C----------------------------------------------------------------------- -C SUM ON I -C----------------------------------------------------------------------- - SUMI = 0.0D0 - II = JN - DO 180 I=1,J - JMI = J - I + 1 - KK = J + I + 1 - DO 170 K=1,JMI - V(K) = S(KK)*XP(K) - KK = KK + 1 - 170 CONTINUE - CALL DBDIFF(JMI, V) - SUMI = SUMI + B(II)*V(JMI)*XP(I+1) - II = II + 1 - 180 CONTINUE - SUMJ = SUMJ + SUMI*RXP - 190 CONTINUE - ANS = GS*(S(1)-SUMJ) - RETURN - 200 CONTINUE - IERR=2 - RETURN - END diff --git a/slatec/dbkisr.f b/slatec/dbkisr.f deleted file mode 100644 index 5c57b23..0000000 --- a/slatec/dbkisr.f +++ /dev/null @@ -1,87 +0,0 @@ -*DECK DBKISR - SUBROUTINE DBKISR (X, N, SUM, IERR) -C***BEGIN PROLOGUE DBKISR -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBSKIN -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (BKISR-S, DBKISR-D) -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C DBKISR computes repeated integrals of the K0 Bessel function -C by the series for N=0,1, and 2. -C -C***SEE ALSO DBSKIN -C***ROUTINES CALLED D1MACH, DPSIXN -C***REVISION HISTORY (YYMMDD) -C 820601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DBKISR - INTEGER I, IERR, K, KK, KKN, K1, N, NP - DOUBLE PRECISION AK, ATOL, BK, C, FK, FN, HX, HXS, POL, PR, SUM, - * TKP, TOL, TRM, X, XLN - DOUBLE PRECISION DPSIXN, D1MACH - DIMENSION C(2) - SAVE C -C - DATA C(1), C(2) /1.57079632679489662D+00,1.0D0/ -C***FIRST EXECUTABLE STATEMENT DBKISR - IERR=0 - TOL = MAX(D1MACH(4),1.0D-18) - IF (X.LT.TOL) GO TO 50 - PR = 1.0D0 - POL = 0.0D0 - IF (N.EQ.0) GO TO 20 - DO 10 I=1,N - POL = -POL*X + C(I) - PR = PR*X/I - 10 CONTINUE - 20 CONTINUE - HX = X*0.5D0 - HXS = HX*HX - XLN = LOG(HX) - NP = N + 1 - TKP = 3.0D0 - FK = 2.0D0 - FN = N - BK = 4.0D0 - AK = 2.0D0/((FN+1.0D0)*(FN+2.0D0)) - SUM = AK*(DPSIXN(N+3)-DPSIXN(3)+DPSIXN(2)-XLN) - ATOL = SUM*TOL*0.75D0 - DO 30 K=2,20 - AK = AK*(HXS/BK)*((TKP+1.0D0)/(TKP+FN+1.0D0))*(TKP/(TKP+FN)) - K1 = K + 1 - KK = K1 + K - KKN = KK + N - TRM = (DPSIXN(K1)+DPSIXN(KKN)-DPSIXN(KK)-XLN)*AK - SUM = SUM + TRM - IF (ABS(TRM).LE.ATOL) GO TO 40 - TKP = TKP + 2.0D0 - BK = BK + TKP - FK = FK + 1.0D0 - 30 CONTINUE - GO TO 80 - 40 CONTINUE - SUM = (SUM*HXS+DPSIXN(NP)-XLN)*PR - IF (N.EQ.1) SUM = -SUM - SUM = POL + SUM - RETURN -C----------------------------------------------------------------------- -C SMALL X CASE, X.LT.WORD TOLERANCE -C----------------------------------------------------------------------- - 50 CONTINUE - IF (N.GT.0) GO TO 60 - HX = X*0.5D0 - SUM = DPSIXN(1) - LOG(HX) - RETURN - 60 CONTINUE - SUM = C(N) - RETURN - 80 CONTINUE - IERR=2 - RETURN - END diff --git a/slatec/dbksol.f b/slatec/dbksol.f deleted file mode 100644 index ab6732a..0000000 --- a/slatec/dbksol.f +++ /dev/null @@ -1,50 +0,0 @@ -*DECK DBKSOL - SUBROUTINE DBKSOL (N, A, X) -C***BEGIN PROLOGUE DBKSOL -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBVSUP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (BKSOL-S, DBKSOL-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C ********************************************************************** -C Solution of an upper triangular linear system by -C back-substitution -C -C The matrix A is assumed to be stored in a linear -C array proceeding in a row-wise manner. The -C vector X contains the given constant vector on input -C and contains the solution on return. -C The actual diagonal of A is unity while a diagonal -C scaling matrix is stored there. -C ********************************************************************** -C -C***SEE ALSO DBVSUP -C***ROUTINES CALLED DDOT -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DBKSOL -C - DOUBLE PRECISION DDOT - INTEGER J, K, M, N, NM1 - DOUBLE PRECISION A(*), X(*) -C -C***FIRST EXECUTABLE STATEMENT DBKSOL - M = (N*(N + 1))/2 - X(N) = X(N)*A(M) - NM1 = N - 1 - IF (NM1 .LT. 1) GO TO 20 - DO 10 K = 1, NM1 - J = N - K - M = M - K - 1 - X(J) = X(J)*A(M) - DDOT(K,A(M+1),1,X(J+1),1) - 10 CONTINUE - 20 CONTINUE -C - RETURN - END diff --git a/slatec/dbndac.f b/slatec/dbndac.f deleted file mode 100644 index 3d64cf1..0000000 --- a/slatec/dbndac.f +++ /dev/null @@ -1,270 +0,0 @@ -*DECK DBNDAC - SUBROUTINE DBNDAC (G, MDG, NB, IP, IR, MT, JT) -C***BEGIN PROLOGUE DBNDAC -C***PURPOSE Compute the LU factorization of a banded matrices using -C sequential accumulation of rows of the data matrix. -C Exactly one right-hand side vector is permitted. -C***LIBRARY SLATEC -C***CATEGORY D9 -C***TYPE DOUBLE PRECISION (BNDACC-S, DBNDAC-D) -C***KEYWORDS BANDED MATRIX, CURVE FITTING, LEAST SQUARES -C***AUTHOR Lawson, C. L., (JPL) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C These subroutines solve the least squares problem Ax = b for -C banded matrices A using sequential accumulation of rows of the -C data matrix. Exactly one right-hand side vector is permitted. -C -C These subroutines are intended for the type of least squares -C systems that arise in applications such as curve or surface -C fitting of data. The least squares equations are accumulated and -C processed using only part of the data. This requires a certain -C user interaction during the solution of Ax = b. -C -C Specifically, suppose the data matrix (A B) is row partitioned -C into Q submatrices. Let (E F) be the T-th one of these -C submatrices where E = (0 C 0). Here the dimension of E is MT by N -C and the dimension of C is MT by NB. The value of NB is the -C bandwidth of A. The dimensions of the leading block of zeros in E -C are MT by JT-1. -C -C The user of the subroutine DBNDAC provides MT,JT,C and F for -C T=1,...,Q. Not all of this data must be supplied at once. -C -C Following the processing of the various blocks (E F), the matrix -C (A B) has been transformed to the form (R D) where R is upper -C triangular and banded with bandwidth NB. The least squares -C system Rx = d is then easily solved using back substitution by -C executing the statement CALL DBNDSL(1,...). The sequence of -C values for JT must be nondecreasing. This may require some -C preliminary interchanges of rows and columns of the matrix A. -C -C The primary reason for these subroutines is that the total -C processing can take place in a working array of dimension MU by -C NB+1. An acceptable value for MU is -C -C MU = MAX(MT + N + 1), -C -C where N is the number of unknowns. -C -C Here the maximum is taken over all values of MT for T=1,...,Q. -C Notice that MT can be taken to be a small as one, showing that -C MU can be as small as N+2. The subprogram DBNDAC processes the -C rows more efficiently if MU is large enough so that each new -C block (C F) has a distinct value of JT. -C -C The four principle parts of these algorithms are obtained by the -C following call statements -C -C CALL DBNDAC(...) Introduce new blocks of data. -C -C CALL DBNDSL(1,...)Compute solution vector and length of -C residual vector. -C -C CALL DBNDSL(2,...)Given any row vector H solve YR = H for the -C row vector Y. -C -C CALL DBNDSL(3,...)Given any column vector W solve RZ = W for -C the column vector Z. -C -C The dots in the above call statements indicate additional -C arguments that will be specified in the following paragraphs. -C -C The user must dimension the array appearing in the call list.. -C G(MDG,NB+1) -C -C Description of calling sequence for DBNDAC.. -C -C The entire set of parameters for DBNDAC are -C -C Input.. All Type REAL variables are DOUBLE PRECISION -C -C G(*,*) The working array into which the user will -C place the MT by NB+1 block (C F) in rows IR -C through IR+MT-1, columns 1 through NB+1. -C See descriptions of IR and MT below. -C -C MDG The number of rows in the working array -C G(*,*). The value of MDG should be .GE. MU. -C The value of MU is defined in the abstract -C of these subprograms. -C -C NB The bandwidth of the data matrix A. -C -C IP Set by the user to the value 1 before the -C first call to DBNDAC. Its subsequent value -C is controlled by DBNDAC to set up for the -C next call to DBNDAC. -C -C IR Index of the row of G(*,*) where the user is -C to place the new block of data (C F). Set by -C the user to the value 1 before the first call -C to DBNDAC. Its subsequent value is controlled -C by DBNDAC. A value of IR .GT. MDG is considered -C an error. -C -C MT,JT Set by the user to indicate respectively the -C number of new rows of data in the block and -C the index of the first nonzero column in that -C set of rows (E F) = (0 C 0 F) being processed. -C -C Output.. All Type REAL variables are DOUBLE PRECISION -C -C G(*,*) The working array which will contain the -C processed rows of that part of the data -C matrix which has been passed to DBNDAC. -C -C IP,IR The values of these arguments are advanced by -C DBNDAC to be ready for storing and processing -C a new block of data in G(*,*). -C -C Description of calling sequence for DBNDSL.. -C -C The user must dimension the arrays appearing in the call list.. -C -C G(MDG,NB+1), X(N) -C -C The entire set of parameters for DBNDSL are -C -C Input.. All Type REAL variables are DOUBLE PRECISION -C -C MODE Set by the user to one of the values 1, 2, or -C 3. These values respectively indicate that -C the solution of AX = B, YR = H or RZ = W is -C required. -C -C G(*,*),MDG, These arguments all have the same meaning and -C NB,IP,IR contents as following the last call to DBNDAC. -C -C X(*) With mode=2 or 3 this array contains, -C respectively, the right-side vectors H or W of -C the systems YR = H or RZ = W. -C -C N The number of variables in the solution -C vector. If any of the N diagonal terms are -C zero the subroutine DBNDSL prints an -C appropriate message. This condition is -C considered an error. -C -C Output.. All Type REAL variables are DOUBLE PRECISION -C -C X(*) This array contains the solution vectors X, -C Y or Z of the systems AX = B, YR = H or -C RZ = W depending on the value of MODE=1, -C 2 or 3. -C -C RNORM If MODE=1 RNORM is the Euclidean length of the -C residual vector AX-B. When MODE=2 or 3 RNORM -C is set to zero. -C -C Remarks.. -C -C To obtain the upper triangular matrix and transformed right-hand -C side vector D so that the super diagonals of R form the columns -C of G(*,*), execute the following Fortran statements. -C -C NBP1=NB+1 -C -C DO 10 J=1, NBP1 -C -C 10 G(IR,J) = 0.E0 -C -C MT=1 -C -C JT=N+1 -C -C CALL DBNDAC(G,MDG,NB,IP,IR,MT,JT) -C -C***REFERENCES C. L. Lawson and R. J. Hanson, Solving Least Squares -C Problems, Prentice-Hall, Inc., 1974, Chapter 27. -C***ROUTINES CALLED DH12, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DBNDAC - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION G(MDG,*) -C***FIRST EXECUTABLE STATEMENT DBNDAC - ZERO=0.D0 -C -C ALG. STEPS 1-4 ARE PERFORMED EXTERNAL TO THIS SUBROUTINE. -C - NBP1=NB+1 - IF (MT.LE.0.OR.NB.LE.0) RETURN -C - IF(.NOT.MDG.LT.IR) GO TO 5 - NERR=1 - IOPT=2 - CALL XERMSG ('SLATEC', 'DBNDAC', 'MDG.LT.IR, PROBABLE ERROR.', - + NERR, IOPT) - RETURN - 5 CONTINUE -C -C ALG. STEP 5 - IF (JT.EQ.IP) GO TO 70 -C ALG. STEPS 6-7 - IF (JT.LE.IR) GO TO 30 -C ALG. STEPS 8-9 - DO 10 I=1,MT - IG1=JT+MT-I - IG2=IR+MT-I - DO 10 J=1,NBP1 - G(IG1,J)=G(IG2,J) - 10 CONTINUE -C ALG. STEP 10 - IE=JT-IR - DO 20 I=1,IE - IG=IR+I-1 - DO 20 J=1,NBP1 - G(IG,J)=ZERO - 20 CONTINUE -C ALG. STEP 11 - IR=JT -C ALG. STEP 12 - 30 MU=MIN(NB-1,IR-IP-1) - IF (MU.EQ.0) GO TO 60 -C ALG. STEP 13 - DO 50 L=1,MU -C ALG. STEP 14 - K=MIN(L,JT-IP) -C ALG. STEP 15 - LP1=L+1 - IG=IP+L - DO 40 I=LP1,NB - JG=I-K - G(IG,JG)=G(IG,I) - 40 CONTINUE -C ALG. STEP 16 - DO 50 I=1,K - JG=NBP1-I - G(IG,JG)=ZERO - 50 CONTINUE -C ALG. STEP 17 - 60 IP=JT -C ALG. STEPS 18-19 - 70 MH=IR+MT-IP - KH=MIN(NBP1,MH) -C ALG. STEP 20 - DO 80 I=1,KH - CALL DH12 (1,I,MAX(I+1,IR-IP+1),MH,G(IP,I),1,RHO, - 1 G(IP,I+1),1,MDG,NBP1-I) - 80 CONTINUE -C ALG. STEP 21 - IR=IP+KH -C ALG. STEP 22 - IF (KH.LT.NBP1) GO TO 100 -C ALG. STEP 23 - DO 90 I=1,NB - G(IR-1,I)=ZERO - 90 CONTINUE -C ALG. STEP 24 - 100 CONTINUE -C ALG. STEP 25 - RETURN - END diff --git a/slatec/dbndsl.f b/slatec/dbndsl.f deleted file mode 100644 index 549ebeb..0000000 --- a/slatec/dbndsl.f +++ /dev/null @@ -1,254 +0,0 @@ -*DECK DBNDSL - SUBROUTINE DBNDSL (MODE, G, MDG, NB, IP, IR, X, N, RNORM) -C***BEGIN PROLOGUE DBNDSL -C***PURPOSE Solve the least squares problem for a banded matrix using -C sequential accumulation of rows of the data matrix. -C Exactly one right-hand side vector is permitted. -C***LIBRARY SLATEC -C***CATEGORY D9 -C***TYPE DOUBLE PRECISION (BNDSOL-S, DBNDSL-D) -C***KEYWORDS BANDED MATRIX, CURVE FITTING, LEAST SQUARES -C***AUTHOR Lawson, C. L., (JPL) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C These subroutines solve the least squares problem Ax = b for -C banded matrices A using sequential accumulation of rows of the -C data matrix. Exactly one right-hand side vector is permitted. -C -C These subroutines are intended for the type of least squares -C systems that arise in applications such as curve or surface -C fitting of data. The least squares equations are accumulated and -C processed using only part of the data. This requires a certain -C user interaction during the solution of Ax = b. -C -C Specifically, suppose the data matrix (A B) is row partitioned -C into Q submatrices. Let (E F) be the T-th one of these -C submatrices where E = (0 C 0). Here the dimension of E is MT by N -C and the dimension of C is MT by NB. The value of NB is the -C bandwidth of A. The dimensions of the leading block of zeros in E -C are MT by JT-1. -C -C The user of the subroutine DBNDAC provides MT,JT,C and F for -C T=1,...,Q. Not all of this data must be supplied at once. -C -C Following the processing of the various blocks (E F), the matrix -C (A B) has been transformed to the form (R D) where R is upper -C triangular and banded with bandwidth NB. The least squares -C system Rx = d is then easily solved using back substitution by -C executing the statement CALL DBNDSL(1,...). The sequence of -C values for JT must be nondecreasing. This may require some -C preliminary interchanges of rows and columns of the matrix A. -C -C The primary reason for these subroutines is that the total -C processing can take place in a working array of dimension MU by -C NB+1. An acceptable value for MU is -C -C MU = MAX(MT + N + 1), -C -C where N is the number of unknowns. -C -C Here the maximum is taken over all values of MT for T=1,...,Q. -C Notice that MT can be taken to be a small as one, showing that -C MU can be as small as N+2. The subprogram DBNDAC processes the -C rows more efficiently if MU is large enough so that each new -C block (C F) has a distinct value of JT. -C -C The four principle parts of these algorithms are obtained by the -C following call statements -C -C CALL DBNDAC(...) Introduce new blocks of data. -C -C CALL DBNDSL(1,...)Compute solution vector and length of -C residual vector. -C -C CALL DBNDSL(2,...)Given any row vector H solve YR = H for the -C row vector Y. -C -C CALL DBNDSL(3,...)Given any column vector W solve RZ = W for -C the column vector Z. -C -C The dots in the above call statements indicate additional -C arguments that will be specified in the following paragraphs. -C -C The user must dimension the array appearing in the call list.. -C G(MDG,NB+1) -C -C Description of calling sequence for DBNDAC.. -C -C The entire set of parameters for DBNDAC are -C -C Input.. All Type REAL variables are DOUBLE PRECISION -C -C G(*,*) The working array into which the user will -C place the MT by NB+1 block (C F) in rows IR -C through IR+MT-1, columns 1 through NB+1. -C See descriptions of IR and MT below. -C -C MDG The number of rows in the working array -C G(*,*). The value of MDG should be .GE. MU. -C The value of MU is defined in the abstract -C of these subprograms. -C -C NB The bandwidth of the data matrix A. -C -C IP Set by the user to the value 1 before the -C first call to DBNDAC. Its subsequent value -C is controlled by DBNDAC to set up for the -C next call to DBNDAC. -C -C IR Index of the row of G(*,*) where the user is -C the user to the value 1 before the first call -C to DBNDAC. Its subsequent value is controlled -C by DBNDAC. A value of IR .GT. MDG is considered -C an error. -C -C MT,JT Set by the user to indicate respectively the -C number of new rows of data in the block and -C the index of the first nonzero column in that -C set of rows (E F) = (0 C 0 F) being processed. -C Output.. All Type REAL variables are DOUBLE PRECISION -C -C G(*,*) The working array which will contain the -C processed rows of that part of the data -C matrix which has been passed to DBNDAC. -C -C IP,IR The values of these arguments are advanced by -C DBNDAC to be ready for storing and processing -C a new block of data in G(*,*). -C -C Description of calling sequence for DBNDSL.. -C -C The user must dimension the arrays appearing in the call list.. -C -C G(MDG,NB+1), X(N) -C -C The entire set of parameters for DBNDSL are -C -C Input.. -C -C MODE Set by the user to one of the values 1, 2, or -C 3. These values respectively indicate that -C the solution of AX = B, YR = H or RZ = W is -C required. -C -C G(*,*),MDG, These arguments all have the same meaning and -C NB,IP,IR contents as following the last call to DBNDAC. -C -C X(*) With mode=2 or 3 this array contains, -C respectively, the right-side vectors H or W of -C the systems YR = H or RZ = W. -C -C N The number of variables in the solution -C vector. If any of the N diagonal terms are -C zero the subroutine DBNDSL prints an -C appropriate message. This condition is -C considered an error. -C -C Output.. -C -C X(*) This array contains the solution vectors X, -C Y or Z of the systems AX = B, YR = H or -C RZ = W depending on the value of MODE=1, -C 2 or 3. -C -C RNORM If MODE=1 RNORM is the Euclidean length of the -C residual vector AX-B. When MODE=2 or 3 RNORM -C is set to zero. -C -C Remarks.. -C -C To obtain the upper triangular matrix and transformed right-hand -C side vector D so that the super diagonals of R form the columns -C of G(*,*), execute the following Fortran statements. -C -C NBP1=NB+1 -C -C DO 10 J=1, NBP1 -C -C 10 G(IR,J) = 0.E0 -C -C MT=1 -C -C JT=N+1 -C -C CALL DBNDAC(G,MDG,NB,IP,IR,MT,JT) -C -C***REFERENCES C. L. Lawson and R. J. Hanson, Solving Least Squares -C Problems, Prentice-Hall, Inc., 1974, Chapter 27. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 790101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DBNDSL - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION G(MDG,*),X(*) -C***FIRST EXECUTABLE STATEMENT DBNDSL - ZERO=0.D0 -C - RNORM=ZERO - GO TO (10,90,50), MODE -C ********************* MODE = 1 -C ALG. STEP 26 - 10 DO 20 J=1,N - X(J)=G(J,NB+1) - 20 CONTINUE - RSQ=ZERO - NP1=N+1 - IRM1=IR-1 - IF (NP1.GT.IRM1) GO TO 40 - DO 30 J=NP1,IRM1 - RSQ=RSQ+G(J,NB+1)**2 - 30 CONTINUE - RNORM=SQRT(RSQ) - 40 CONTINUE -C ********************* MODE = 3 -C ALG. STEP 27 - 50 DO 80 II=1,N - I=N+1-II -C ALG. STEP 28 - S=ZERO - L=MAX(0,I-IP) -C ALG. STEP 29 - IF (I.EQ.N) GO TO 70 -C ALG. STEP 30 - IE=MIN(N+1-I,NB) - DO 60 J=2,IE - JG=J+L - IX=I-1+J - S=S+G(I,JG)*X(IX) - 60 CONTINUE -C ALG. STEP 31 - 70 IF (G(I,L+1)) 80,130,80 - 80 X(I)=(X(I)-S)/G(I,L+1) -C ALG. STEP 32 - RETURN -C ********************* MODE = 2 - 90 DO 120 J=1,N - S=ZERO - IF (J.EQ.1) GO TO 110 - I1=MAX(1,J-NB+1) - I2=J-1 - DO 100 I=I1,I2 - L=J-I+1+MAX(0,I-IP) - S=S+X(I)*G(I,L) - 100 CONTINUE - 110 L=MAX(0,J-IP) - IF (G(J,L+1)) 120,130,120 - 120 X(J)=(X(J)-S)/G(J,L+1) - RETURN -C - 130 CONTINUE - NERR=1 - IOPT=2 - CALL XERMSG ('SLATEC', 'DBNDSL', - + 'A ZERO DIAGONAL TERM IS IN THE N BY N UPPER TRIANGULAR ' // - + 'MATRIX.', NERR, IOPT) - RETURN - END diff --git a/slatec/dbnfac.f b/slatec/dbnfac.f deleted file mode 100644 index eb61515..0000000 --- a/slatec/dbnfac.f +++ /dev/null @@ -1,139 +0,0 @@ -*DECK DBNFAC - SUBROUTINE DBNFAC (W, NROWW, NROW, NBANDL, NBANDU, IFLAG) -C***BEGIN PROLOGUE DBNFAC -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBINT4 and DBINTK -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (BNFAC-S, DBNFAC-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C DBNFAC is the BANFAC routine from -C * A Practical Guide to Splines * by C. de Boor -C -C DBNFAC is a double precision routine -C -C Returns in W the LU-factorization (without pivoting) of the banded -C matrix A of order NROW with (NBANDL + 1 + NBANDU) bands or diag- -C onals in the work array W . -C -C ***** I N P U T ****** W is double precision -C W.....Work array of size (NROWW,NROW) containing the interesting -C part of a banded matrix A , with the diagonals or bands of A -C stored in the rows of W , while columns of A correspond to -C columns of W . This is the storage mode used in LINPACK and -C results in efficient innermost loops. -C Explicitly, A has NBANDL bands below the diagonal -C + 1 (main) diagonal -C + NBANDU bands above the diagonal -C and thus, with MIDDLE = NBANDU + 1, -C A(I+J,J) is in W(I+MIDDLE,J) for I=-NBANDU,...,NBANDL -C J=1,...,NROW . -C For example, the interesting entries of A (1,2)-banded matrix -C of order 9 would appear in the first 1+1+2 = 4 rows of W -C as follows. -C 13 24 35 46 57 68 79 -C 12 23 34 45 56 67 78 89 -C 11 22 33 44 55 66 77 88 99 -C 21 32 43 54 65 76 87 98 -C -C All other entries of W not identified in this way with an en- -C try of A are never referenced . -C NROWW.....Row dimension of the work array W . -C must be .GE. NBANDL + 1 + NBANDU . -C NBANDL.....Number of bands of A below the main diagonal -C NBANDU.....Number of bands of A above the main diagonal . -C -C ***** O U T P U T ****** W is double precision -C IFLAG.....Integer indicating success( = 1) or failure ( = 2) . -C If IFLAG = 1, then -C W.....contains the LU-factorization of A into a unit lower triangu- -C lar matrix L and an upper triangular matrix U (both banded) -C and stored in customary fashion over the corresponding entries -C of A . This makes it possible to solve any particular linear -C system A*X = B for X by a -C CALL DBNSLV ( W, NROWW, NROW, NBANDL, NBANDU, B ) -C with the solution X contained in B on return . -C If IFLAG = 2, then -C one of NROW-1, NBANDL,NBANDU failed to be nonnegative, or else -C one of the potential pivots was found to be zero indicating -C that A does not have an LU-factorization. This implies that -C A is singular in case it is totally positive . -C -C ***** M E T H O D ****** -C Gauss elimination W I T H O U T pivoting is used. The routine is -C intended for use with matrices A which do not require row inter- -C changes during factorization, especially for the T O T A L L Y -C P O S I T I V E matrices which occur in spline calculations. -C The routine should NOT be used for an arbitrary banded matrix. -C -C***SEE ALSO DBINT4, DBINTK -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 800901 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DBNFAC -C - INTEGER IFLAG, NBANDL, NBANDU, NROW, NROWW, I, IPK, J, JMAX, K, - 1 KMAX, MIDDLE, MIDMK, NROWM1 - DOUBLE PRECISION W(NROWW,*), FACTOR, PIVOT -C -C***FIRST EXECUTABLE STATEMENT DBNFAC - IFLAG = 1 - MIDDLE = NBANDU + 1 -C W(MIDDLE,.) CONTAINS THE MAIN DIAGONAL OF A . - NROWM1 = NROW - 1 - IF (NROWM1) 120, 110, 10 - 10 IF (NBANDL.GT.0) GO TO 30 -C A IS UPPER TRIANGULAR. CHECK THAT DIAGONAL IS NONZERO . - DO 20 I=1,NROWM1 - IF (W(MIDDLE,I).EQ.0.0D0) GO TO 120 - 20 CONTINUE - GO TO 110 - 30 IF (NBANDU.GT.0) GO TO 60 -C A IS LOWER TRIANGULAR. CHECK THAT DIAGONAL IS NONZERO AND -C DIVIDE EACH COLUMN BY ITS DIAGONAL . - DO 50 I=1,NROWM1 - PIVOT = W(MIDDLE,I) - IF (PIVOT.EQ.0.0D0) GO TO 120 - JMAX = MIN(NBANDL,NROW-I) - DO 40 J=1,JMAX - W(MIDDLE+J,I) = W(MIDDLE+J,I)/PIVOT - 40 CONTINUE - 50 CONTINUE - RETURN -C -C A IS NOT JUST A TRIANGULAR MATRIX. CONSTRUCT LU FACTORIZATION - 60 DO 100 I=1,NROWM1 -C W(MIDDLE,I) IS PIVOT FOR I-TH STEP . - PIVOT = W(MIDDLE,I) - IF (PIVOT.EQ.0.0D0) GO TO 120 -C JMAX IS THE NUMBER OF (NONZERO) ENTRIES IN COLUMN I -C BELOW THE DIAGONAL . - JMAX = MIN(NBANDL,NROW-I) -C DIVIDE EACH ENTRY IN COLUMN I BELOW DIAGONAL BY PIVOT . - DO 70 J=1,JMAX - W(MIDDLE+J,I) = W(MIDDLE+J,I)/PIVOT - 70 CONTINUE -C KMAX IS THE NUMBER OF (NONZERO) ENTRIES IN ROW I TO -C THE RIGHT OF THE DIAGONAL . - KMAX = MIN(NBANDU,NROW-I) -C SUBTRACT A(I,I+K)*(I-TH COLUMN) FROM (I+K)-TH COLUMN -C (BELOW ROW I ) . - DO 90 K=1,KMAX - IPK = I + K - MIDMK = MIDDLE - K - FACTOR = W(MIDMK,IPK) - DO 80 J=1,JMAX - W(MIDMK+J,IPK) = W(MIDMK+J,IPK) - W(MIDDLE+J,I)*FACTOR - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE -C CHECK THE LAST DIAGONAL ENTRY . - 110 IF (W(MIDDLE,NROW).NE.0.0D0) RETURN - 120 IFLAG = 2 - RETURN - END diff --git a/slatec/dbnslv.f b/slatec/dbnslv.f deleted file mode 100644 index 2bae84b..0000000 --- a/slatec/dbnslv.f +++ /dev/null @@ -1,81 +0,0 @@ -*DECK DBNSLV - SUBROUTINE DBNSLV (W, NROWW, NROW, NBANDL, NBANDU, B) -C***BEGIN PROLOGUE DBNSLV -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBINT4 and DBINTK -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (BNSLV-S, DBNSLV-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C DBNSLV is the BANSLV routine from -C * A Practical Guide to Splines * by C. de Boor -C -C DBNSLV is a double precision routine -C -C Companion routine to DBNFAC . It returns the solution X of the -C linear system A*X = B in place of B , given the LU-factorization -C for A in the work array W from DBNFAC. -C -C ***** I N P U T ****** W,B are DOUBLE PRECISION -C W, NROWW,NROW,NBANDL,NBANDU.....Describe the LU-factorization of a -C banded matrix A of order NROW as constructed in DBNFAC . -C For details, see DBNFAC . -C B.....Right side of the system to be solved . -C -C ***** O U T P U T ****** B is DOUBLE PRECISION -C B.....Contains the solution X , of order NROW . -C -C ***** M E T H O D ****** -C (With A = L*U, as stored in W,) the unit lower triangular system -C L(U*X) = B is solved for Y = U*X, and Y stored in B . Then the -C upper triangular system U*X = Y is solved for X . The calcul- -C ations are so arranged that the innermost loops stay within columns. -C -C***SEE ALSO DBINT4, DBINTK -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 800901 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DBNSLV -C - INTEGER NBANDL, NBANDU, NROW, NROWW, I, J, JMAX, MIDDLE, NROWM1 - DOUBLE PRECISION W(NROWW,*), B(*) -C***FIRST EXECUTABLE STATEMENT DBNSLV - MIDDLE = NBANDU + 1 - IF (NROW.EQ.1) GO TO 80 - NROWM1 = NROW - 1 - IF (NBANDL.EQ.0) GO TO 30 -C FORWARD PASS -C FOR I=1,2,...,NROW-1, SUBTRACT RIGHT SIDE(I)*(I-TH COLUMN -C OF L ) FROM RIGHT SIDE (BELOW I-TH ROW) . - DO 20 I=1,NROWM1 - JMAX = MIN(NBANDL,NROW-I) - DO 10 J=1,JMAX - B(I+J) = B(I+J) - B(I)*W(MIDDLE+J,I) - 10 CONTINUE - 20 CONTINUE -C BACKWARD PASS -C FOR I=NROW,NROW-1,...,1, DIVIDE RIGHT SIDE(I) BY I-TH DIAG- -C ONAL ENTRY OF U, THEN SUBTRACT RIGHT SIDE(I)*(I-TH COLUMN -C OF U) FROM RIGHT SIDE (ABOVE I-TH ROW). - 30 IF (NBANDU.GT.0) GO TO 50 -C A IS LOWER TRIANGULAR . - DO 40 I=1,NROW - B(I) = B(I)/W(1,I) - 40 CONTINUE - RETURN - 50 I = NROW - 60 B(I) = B(I)/W(MIDDLE,I) - JMAX = MIN(NBANDU,I-1) - DO 70 J=1,JMAX - B(I-J) = B(I-J) - B(I)*W(MIDDLE-J,I) - 70 CONTINUE - I = I - 1 - IF (I.GT.1) GO TO 60 - 80 B(1) = B(1)/W(MIDDLE,1) - RETURN - END diff --git a/slatec/dbocls.f b/slatec/dbocls.f deleted file mode 100644 index 131bd14..0000000 --- a/slatec/dbocls.f +++ /dev/null @@ -1,1147 +0,0 @@ -*DECK DBOCLS - SUBROUTINE DBOCLS (W, MDW, MCON, MROWS, NCOLS, BL, BU, IND, IOPT, - + X, RNORMC, RNORM, MODE, RW, IW) -C***BEGIN PROLOGUE DBOCLS -C***PURPOSE Solve the bounded and constrained least squares -C problem consisting of solving the equation -C E*X = F (in the least squares sense) -C subject to the linear constraints -C C*X = Y. -C***LIBRARY SLATEC -C***CATEGORY K1A2A, G2E, G2H1, G2H2 -C***TYPE DOUBLE PRECISION (SBOCLS-S, DBOCLS-D) -C***KEYWORDS BOUNDS, CONSTRAINTS, INEQUALITY, LEAST SQUARES, LINEAR -C***AUTHOR Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C **** All INPUT and OUTPUT real variables are DOUBLE PRECISION **** -C -C This subprogram solves the bounded and constrained least squares -C problem. The problem statement is: -C -C Solve E*X = F (least squares sense), subject to constraints -C C*X=Y. -C -C In this formulation both X and Y are unknowns, and both may -C have bounds on any of their components. This formulation -C of the problem allows the user to have equality and inequality -C constraints as well as simple bounds on the solution components. -C -C This constrained linear least squares subprogram solves E*X=F -C subject to C*X=Y, where E is MROWS by NCOLS, C is MCON by NCOLS. -C -C The user must have dimension statements of the form -C -C DIMENSION W(MDW,NCOLS+MCON+1), BL(NCOLS+MCON), BU(NCOLS+MCON), -C * X(2*(NCOLS+MCON)+2+NX), RW(6*NCOLS+5*MCON) -C INTEGER IND(NCOLS+MCON), IOPT(17+NI), IW(2*(NCOLS+MCON)) -C -C (here NX=number of extra locations required for the options; NX=0 -C if no options are in use. Also NI=number of extra locations -C for options 1-9.) -C -C INPUT -C ----- -C -C ------------------------- -C W(MDW,*),MCON,MROWS,NCOLS -C ------------------------- -C The array W contains the (possibly null) matrix [C:*] followed by -C [E:F]. This must be placed in W as follows: -C [C : *] -C W = [ ] -C [E : F] -C The (*) after C indicates that this data can be undefined. The -C matrix [E:F] has MROWS rows and NCOLS+1 columns. The matrix C is -C placed in the first MCON rows of W(*,*) while [E:F] -C follows in rows MCON+1 through MCON+MROWS of W(*,*). The vector F -C is placed in rows MCON+1 through MCON+MROWS, column NCOLS+1. The -C values of MDW and NCOLS must be positive; the value of MCON must -C be nonnegative. An exception to this occurs when using option 1 -C for accumulation of blocks of equations. In that case MROWS is an -C OUTPUT variable only, and the matrix data for [E:F] is placed in -C W(*,*), one block of rows at a time. See IOPT(*) contents, option -C number 1, for further details. The row dimension, MDW, of the -C array W(*,*) must satisfy the inequality: -C -C If using option 1, -C MDW .ge. MCON + max(max. number of -C rows accumulated, NCOLS) + 1. -C If using option 8, -C MDW .ge. MCON + MROWS. -C Else -C MDW .ge. MCON + max(MROWS, NCOLS). -C -C Other values are errors, but this is checked only when using -C option=2. The value of MROWS is an output parameter when -C using option number 1 for accumulating large blocks of least -C squares equations before solving the problem. -C See IOPT(*) contents for details about option 1. -C -C ------------------ -C BL(*),BU(*),IND(*) -C ------------------ -C These arrays contain the information about the bounds that the -C solution values are to satisfy. The value of IND(J) tells the -C type of bound and BL(J) and BU(J) give the explicit values for -C the respective upper and lower bounds on the unknowns X and Y. -C The first NVARS entries of IND(*), BL(*) and BU(*) specify -C bounds on X; the next MCON entries specify bounds on Y. -C -C 1. For IND(J)=1, require X(J) .ge. BL(J); -C IF J.gt.NCOLS, Y(J-NCOLS) .ge. BL(J). -C (the value of BU(J) is not used.) -C 2. For IND(J)=2, require X(J) .le. BU(J); -C IF J.gt.NCOLS, Y(J-NCOLS) .le. BU(J). -C (the value of BL(J) is not used.) -C 3. For IND(J)=3, require X(J) .ge. BL(J) and -C X(J) .le. BU(J); -C IF J.gt.NCOLS, Y(J-NCOLS) .ge. BL(J) and -C Y(J-NCOLS) .le. BU(J). -C (to impose equality constraints have BL(J)=BU(J)= -C constraining value.) -C 4. For IND(J)=4, no bounds on X(J) or Y(J-NCOLS) are required. -C (the values of BL(J) and BU(J) are not used.) -C -C Values other than 1,2,3 or 4 for IND(J) are errors. In the case -C IND(J)=3 (upper and lower bounds) the condition BL(J) .gt. BU(J) -C is an error. The values BL(J), BU(J), J .gt. NCOLS, will be -C changed. Significant changes mean that the constraints are -C infeasible. (Users must make this decision themselves.) -C The new values for BL(J), BU(J), J .gt. NCOLS, define a -C region such that the perturbed problem is feasible. If users -C know that their problem is feasible, this step can be skipped -C by using option number 8 described below. -C See IOPT(*) description. -C -C -C ------- -C IOPT(*) -C ------- -C This is the array where the user can specify nonstandard options -C for DBOCLS( ). Most of the time this feature can be ignored by -C setting the input value IOPT(1)=99. Occasionally users may have -C needs that require use of the following subprogram options. For -C details about how to use the options see below: IOPT(*) CONTENTS. -C -C Option Number Brief Statement of Purpose -C ------ ------ ----- --------- -- ------- -C 1 Return to user for accumulation of blocks -C of least squares equations. The values -C of IOPT(*) are changed with this option. -C The changes are updates to pointers for -C placing the rows of equations into position -C for processing. -C 2 Check lengths of all arrays used in the -C subprogram. -C 3 Column scaling of the data matrix, [C]. -C [E] -C 4 User provides column scaling for matrix [C]. -C [E] -C 5 Provide option array to the low-level -C subprogram SBOLS( ). -C 6 Provide option array to the low-level -C subprogram SBOLSM( ). -C 7 Move the IOPT(*) processing pointer. -C 8 Do not preprocess the constraints to -C resolve infeasibilities. -C 9 Do not pretriangularize the least squares matrix. -C 99 No more options to change. -C -C ---- -C X(*) -C ---- -C This array is used to pass data associated with options 4,5 and -C 6. Ignore this parameter (on input) if no options are used. -C Otherwise see below: IOPT(*) CONTENTS. -C -C -C OUTPUT -C ------ -C -C ----------------- -C X(*),RNORMC,RNORM -C ----------------- -C The array X(*) contains a solution (if MODE .ge.0 or .eq.-22) for -C the constrained least squares problem. The value RNORMC is the -C minimum residual vector length for the constraints C*X - Y = 0. -C The value RNORM is the minimum residual vector length for the -C least squares equations. Normally RNORMC=0, but in the case of -C inconsistent constraints this value will be nonzero. -C The values of X are returned in the first NVARS entries of X(*). -C The values of Y are returned in the last MCON entries of X(*). -C -C ---- -C MODE -C ---- -C The sign of MODE determines whether the subprogram has completed -C normally, or encountered an error condition or abnormal status. A -C value of MODE .ge. 0 signifies that the subprogram has completed -C normally. The value of mode (.ge. 0) is the number of variables -C in an active status: not at a bound nor at the value zero, for -C the case of free variables. A negative value of MODE will be one -C of the cases (-57)-(-41), (-37)-(-22), (-19)-(-2). Values .lt. -1 -C correspond to an abnormal completion of the subprogram. These -C error messages are in groups for the subprograms DBOCLS(), -C SBOLSM(), and SBOLS(). An approximate solution will be returned -C to the user only when max. iterations is reached, MODE=-22. -C -C ----------- -C RW(*),IW(*) -C ----------- -C These are working arrays. (normally the user can ignore the -C contents of these arrays.) -C -C IOPT(*) CONTENTS -C ------- -------- -C The option array allows a user to modify some internal variables -C in the subprogram without recompiling the source code. A central -C goal of the initial software design was to do a good job for most -C people. Thus the use of options will be restricted to a select -C group of users. The processing of the option array proceeds as -C follows: a pointer, here called LP, is initially set to the value -C 1. At the pointer position the option number is extracted and -C used for locating other information that allows for options to be -C changed. The portion of the array IOPT(*) that is used for each -C option is fixed; the user and the subprogram both know how many -C locations are needed for each option. The value of LP is updated -C for each option based on the amount of storage in IOPT(*) that is -C required. A great deal of error checking is done by the -C subprogram on the contents of the option array. Nevertheless it -C is still possible to give the subprogram optional input that is -C meaningless. For example option 4 uses the locations -C X(NCOLS+IOFF),...,X(NCOLS+IOFF+NCOLS-1) for passing scaling data. -C The user must manage the allocation of these locations. -C -C 1 -C - -C This option allows the user to solve problems with a large number -C of rows compared to the number of variables. The idea is that the -C subprogram returns to the user (perhaps many times) and receives -C new least squares equations from the calling program unit. -C Eventually the user signals "that's all" and a solution is then -C computed. The value of MROWS is an output variable when this -C option is used. Its value is always in the range 0 .le. MROWS -C .le. NCOLS+1. It is the number of rows after the -C triangularization of the entire set of equations. If LP is the -C processing pointer for IOPT(*), the usage for the sequential -C processing of blocks of equations is -C -C -C IOPT(LP)=1 -C Move block of equations to W(*,*) starting at -C the first row of W(*,*). -C IOPT(LP+3)=# of rows in the block; user defined -C -C The user now calls DBOCLS( ) in a loop. The value of IOPT(LP+1) -C directs the user's action. The value of IOPT(LP+2) points to -C where the subsequent rows are to be placed in W(*,*). Both of -C these values are first defined in the subprogram. The user -C changes the value of IOPT(LP+1) (to 2) as a signal that all of -C the rows have been processed. -C -C -C . All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*D1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C R :WORK Double Precision R(N). -C Z :WORK Double Precision Z(N). -C P :WORK Double Precision P(N). -C DZ :WORK Double Precision DZ(N). -C Double Precision arrays used for workspace. -C RWORK :WORK Double Precision RWORK(USER DEFINED). -C Double Precision array that can be used by MSOLVE. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used by MSOLVE. -C -C *Description -C This routine does not care what matrix data structure is -C used for A and M. It simply calls the MATVEC and MSOLVE -C routines, with the arguments as described above. The user -C could write any type of structure and the appropriate MATVEC -C and MSOLVE routines. It is assumed that A is stored in the -C IA, JA, A arrays in some fashion and that M (or INV(M)) is -C stored in IWORK and RWORK in some fashion. The SLAP -C routines DSDCG and DSICCG are examples of this procedure. -C -C Two examples of matrix data structures are the: 1) SLAP -C Triad format and 2) SLAP Column format. -C -C =================== S L A P Triad format =================== -C -C In this format only the non-zeros are stored. They may -C appear in *ANY* order. The user supplies three arrays of -C length NELT, where NELT is the number of non-zeros in the -C matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero -C the user puts the row and column index of that matrix -C element in the IA and JA arrays. The value of the non-zero -C matrix element is placed in the corresponding location of -C the A array. This is an extremely easy data structure to -C generate. On the other hand it is not too efficient on -C vector computers for the iterative solution of linear -C systems. Hence, SLAP changes this input data structure to -C the SLAP Column format for the iteration (but does not -C change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C In this format the non-zeros are stored counting down -C columns (except for the diagonal entry, which must appear -C first in each "column") and are stored in the double pre- -C cision array A. In other words, for each column in the -C matrix first put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)),A(JA(ICOL)) are the first elements of the ICOL- -C th column in IA and A, and IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) -C are the last elements of the ICOL-th column. Note that we -C always have JA(N+1)=NELT+1, where N is the number of columns -C in the matrix and NELT is the number of non-zeros in the -C matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO DSDCG, DSICCG -C***REFERENCES 1. Louis Hageman and David Young, Applied Iterative -C Methods, Academic Press, New York, 1981. -C 2. Concus, Golub and O'Leary, A Generalized Conjugate -C Gradient Method for the Numerical Solution of -C Elliptic Partial Differential Equations, in Sparse -C Matrix Computations, Bunch and Rose, Eds., Academic -C Press, New York, 1979. -C 3. Mark K. Seager, A SLAP for the Masses, in -C G. F. Carey, Ed., Parallel Supercomputing: Methods, -C Algorithms and Applications, Wiley, 1989, pp.135-155. -C***ROUTINES CALLED D1MACH, DAXPY, DCOPY, DDOT, ISDCG -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 891004 Added new reference. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MATVEC and MSOLVE from ROUTINES CALLED list. (FNF) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of references. (FNF) -C 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) -C***END PROLOGUE DCG -C .. Scalar Arguments .. - DOUBLE PRECISION ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), B(N), DZ(N), P(N), R(N), RWORK(*), X(N), - + Z(N) - INTEGER IA(NELT), IWORK(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MATVEC, MSOLVE -C .. Local Scalars .. - DOUBLE PRECISION AK, AKDEN, BK, BKDEN, BKNUM, BNRM, SOLNRM, TOLMIN - INTEGER I, K -C .. External Functions .. - DOUBLE PRECISION D1MACH, DDOT - INTEGER ISDCG - EXTERNAL D1MACH, DDOT, ISDCG -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY -C***FIRST EXECUTABLE STATEMENT DCG -C -C Check some of the input data. -C - ITER = 0 - IERR = 0 - IF( N.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF - TOLMIN = 500*D1MACH(3) - IF( TOL.LT.TOLMIN ) THEN - TOL = TOLMIN - IERR = 4 - ENDIF -C -C Calculate initial residual and pseudo-residual, and check -C stopping criterion. - CALL MATVEC(N, X, R, NELT, IA, JA, A, ISYM) - DO 10 I = 1, N - R(I) = B(I) - R(I) - 10 CONTINUE - CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C - IF( ISDCG(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, - $ ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, DZ, - $ RWORK, IWORK, AK, BK, BNRM, SOLNRM) .NE. 0 ) GO TO 200 - IF( IERR.NE.0 ) RETURN -C -C ***** Iteration loop ***** -C - DO 100 K=1,ITMAX - ITER = K -C -C Calculate coefficient bk and direction vector p. - BKNUM = DDOT(N, Z, 1, R, 1) - IF( BKNUM.LE.0.0D0 ) THEN - IERR = 5 - RETURN - ENDIF - IF(ITER .EQ. 1) THEN - CALL DCOPY(N, Z, 1, P, 1) - ELSE - BK = BKNUM/BKDEN - DO 20 I = 1, N - P(I) = Z(I) + BK*P(I) - 20 CONTINUE - ENDIF - BKDEN = BKNUM -C -C Calculate coefficient ak, new iterate x, new residual r, -C and new pseudo-residual z. - CALL MATVEC(N, P, Z, NELT, IA, JA, A, ISYM) - AKDEN = DDOT(N, P, 1, Z, 1) - IF( AKDEN.LE.0.0D0 ) THEN - IERR = 6 - RETURN - ENDIF - AK = BKNUM/AKDEN - CALL DAXPY(N, AK, P, 1, X, 1) - CALL DAXPY(N, -AK, Z, 1, R, 1) - CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C -C check stopping criterion. - IF( ISDCG(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, - $ ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, DZ, RWORK, - $ IWORK, AK, BK, BNRM, SOLNRM) .NE. 0 ) GO TO 200 -C - 100 CONTINUE -C -C ***** end of loop ***** -C -C stopping criterion not satisfied. - ITER = ITMAX + 1 - IERR = 2 -C - 200 RETURN -C------------- LAST LINE OF DCG FOLLOWS ----------------------------- - END diff --git a/slatec/dcgn.f b/slatec/dcgn.f deleted file mode 100644 index 34d4496..0000000 --- a/slatec/dcgn.f +++ /dev/null @@ -1,372 +0,0 @@ -*DECK DCGN - SUBROUTINE DCGN (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, - + MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, ATP, - + ATZ, DZ, ATDZ, RWORK, IWORK) -C***BEGIN PROLOGUE DCGN -C***PURPOSE Preconditioned CG Sparse Ax=b Solver for Normal Equations. -C Routine to solve a general linear system Ax = b using the -C Preconditioned Conjugate Gradient method applied to the -C normal equations AA'y = b, x=A'y. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (SCGN-S, DCGN-D) -C***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM SOLVE, -C NORMAL EQUATIONS., SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) -C DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N) -C DOUBLE PRECISION P(N), ATP(N), ATZ(N), DZ(N), ATDZ(N) -C DOUBLE PRECISION RWORK(USER DEFINED) -C EXTERNAL MATVEC, MTTVEC, MSOLVE -C -C CALL DCGN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, -C $ MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, -C $ Z, P, ATP, ATZ, DZ, ATDZ, RWORK, IWORK) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right-hand side vector. -C X :INOUT Double Precision X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Double Precision A(NELT). -C These arrays contain the matrix data structure for A. -C It could take any form. See "Description", below, -C for more details. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C MATVEC :EXT External. -C Name of a routine which performs the matrix vector multiply -C y = A*X given A and X. The name of the MATVEC routine must -C be declared external in the calling program. The calling -C sequence to MATVEC is: -C CALL MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) -C Where N is the number of unknowns, Y is the product A*X -C upon return X is an input vector, NELT is the number of -C non-zeros in the SLAP-Column IA, JA, A storage for the matrix -C A. ISYM is a flag which, if non-zero, denotes that A is -C symmetric and only the lower or upper triangle is stored. -C MTTVEC :EXT External. -C Name of a routine which performs the matrix transpose vector -C multiply y = A'*X given A and X (where ' denotes transpose). -C The name of the MTTVEC routine must be declared external in -C the calling program. The calling sequence to MTTVEC is the -C same as that for MATVEC, viz.: -C CALL MTTVEC( N, X, Y, NELT, IA, JA, A, ISYM ) -C Where N is the number of unknowns, Y is the product A'*X -C upon return X is an input vector, NELT is the number of -C non-zeros in the SLAP-Column IA, JA, A storage for the matrix -C A. ISYM is a flag which, if non-zero, denotes that A is -C symmetric and only the lower or upper triangle is stored. -C MSOLVE :EXT External. -C Name of a routine which solves a linear system MZ = R for -C Z given R with the preconditioning matrix M (M is supplied via -C RWORK and IWORK arrays). The name of the MSOLVE routine must -C be declared external in the calling program. The calling -C sequence to MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, R is the right-hand side -C vector and Z is the solution upon return. NELT, IA, JA, A and -C ISYM are defined as above. RWORK is a double precision array -C that can be used to pass necessary preconditioning information -C and/or workspace to MSOLVE. IWORK is an integer work array -C for the same purpose as RWORK. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /DSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Double Precision. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Double Precision. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*D1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C R :WORK Double Precision R(N). -C Z :WORK Double Precision Z(N). -C P :WORK Double Precision P(N). -C ATP :WORK Double Precision ATP(N). -C ATZ :WORK Double Precision ATZ(N). -C DZ :WORK Double Precision DZ(N). -C ATDZ :WORK Double Precision ATDZ(N). -C Double Precision arrays used for workspace. -C RWORK :WORK Double Precision RWORK(USER DEFINED). -C Double Precision array that can be used by MSOLVE. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used by MSOLVE. -C -C *Description: -C This routine applies the preconditioned conjugate gradient -C (PCG) method to a non-symmetric system of equations Ax=b. To -C do this the normal equations are solved: -C AA' y = b, where x = A'y. -C In PCG method the iteration count is determined by condition -C -1 -C number of the matrix (M A). In the situation where the -C normal equations are used to solve a non-symmetric system -C the condition number depends on AA' and should therefore be -C much worse than that of A. This is the conventional wisdom. -C When one has a good preconditioner for AA' this may not hold. -C The latter is the situation when DCGN should be tried. -C -C If one is trying to solve a symmetric system, SCG should be -C used instead. -C -C This routine does not care what matrix data structure is -C used for A and M. It simply calls MATVEC, MTTVEC and MSOLVE -C routines, with arguments as described above. The user could -C write any type of structure, and appropriate MATVEC, MTTVEC -C and MSOLVE routines. It is assumed that A is stored in the -C IA, JA, A arrays in some fashion and that M (or INV(M)) is -C stored in IWORK and RWORK) in some fashion. The SLAP -C routines SSDCGN and SSLUCN are examples of this procedure. -C -C Two examples of matrix data structures are the: 1) SLAP -C Triad format and 2) SLAP Column format. -C -C =================== S L A P Triad format =================== -C -C In this format only the non-zeros are stored. They may -C appear in *ANY* order. The user supplies three arrays of -C length NELT, where NELT is the number of non-zeros in the -C matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero -C the user puts the row and column index of that matrix -C element in the IA and JA arrays. The value of the non-zero -C matrix element is placed in the corresponding location of -C the A array. This is an extremely easy data structure to -C generate. On the other hand it is not too efficient on -C vector computers for the iterative solution of linear -C systems. Hence, SLAP changes this input data structure to -C the SLAP Column format for the iteration (but does not -C change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C In this format the non-zeros are stored counting down -C columns (except for the diagonal entry, which must appear -C first in each "column") and are stored in the double pre- -C cision array A. In other words, for each column in the -C matrix first put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)),A(JA(ICOL)) are the first elements of the ICOL- -C th column in IA and A, and IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) -C are the last elements of the ICOL-th column. Note that we -C always have JA(N+1)=NELT+1, where N is the number of columns -C in the matrix and NELT is the number of non-zeros in the -C matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO DSDCGN, DSLUCN, ISDCGN -C***REFERENCES 1. Mark K. Seager, A SLAP for the Masses, in -C G. F. Carey, Ed., Parallel Supercomputing: Methods, -C Algorithms and Applications, Wiley, 1989, pp.135-155. -C***ROUTINES CALLED D1MACH, DAXPY, DCOPY, DDOT, ISDCGN -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 891004 Added new reference. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MATVEC, MTTVEC and MSOLVE from ROUTINES CALLED -C list. (FNF) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of reference. (FNF) -C 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE DCGN -C .. Scalar Arguments .. - DOUBLE PRECISION ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(N), ATDZ(N), ATP(N), ATZ(N), B(N), DZ(N), P(N), - + R(N), RWORK(*), X(N), Z(N) - INTEGER IA(NELT), IWORK(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MATVEC, MSOLVE, MTTVEC -C .. Local Scalars .. - DOUBLE PRECISION AK, AKDEN, BK, BKDEN, BKNUM, BNRM, SOLNRM, TOLMIN - INTEGER I, K -C .. External Functions .. - DOUBLE PRECISION D1MACH, DDOT - INTEGER ISDCGN - EXTERNAL D1MACH, DDOT, ISDCGN -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY -C***FIRST EXECUTABLE STATEMENT DCGN -C -C Check user input. -C - ITER = 0 - IERR = 0 - IF( N.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF - TOLMIN = 500*D1MACH(3) - IF( TOL.LT.TOLMIN ) THEN - TOL = TOLMIN - IERR = 4 - ENDIF -C Calculate initial residual and pseudo-residual, and check -C stopping criterion. - CALL MATVEC(N, X, R, NELT, IA, JA, A, ISYM) - DO 10 I = 1, N - R(I) = B(I) - R(I) - 10 CONTINUE - CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) - CALL MTTVEC(N, Z, ATZ, NELT, IA, JA, A, ISYM) -C - IF( ISDCGN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, MSOLVE, - $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, ATP, ATZ, - $ DZ, ATDZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) .NE. 0 ) - $ GO TO 200 - IF( IERR.NE.0 ) RETURN -C -C ***** iteration loop ***** -C - DO 100 K=1,ITMAX - ITER = K -C -C Calculate coefficient BK and direction vector P. - BKNUM = DDOT(N, Z, 1, R, 1) - IF( BKNUM.LE.0.0D0 ) THEN - IERR = 6 - RETURN - ENDIF - IF(ITER .EQ. 1) THEN - CALL DCOPY(N, Z, 1, P, 1) - ELSE - BK = BKNUM/BKDEN - DO 20 I = 1, N - P(I) = Z(I) + BK*P(I) - 20 CONTINUE - ENDIF - BKDEN = BKNUM -C -C Calculate coefficient AK, new iterate X, new residual R, -C and new pseudo-residual ATZ. - IF(ITER .NE. 1) CALL DAXPY(N, BK, ATP, 1, ATZ, 1) - CALL DCOPY(N, ATZ, 1, ATP, 1) - AKDEN = DDOT(N, ATP, 1, ATP, 1) - IF( AKDEN.LE.0.0D0 ) THEN - IERR = 6 - RETURN - ENDIF - AK = BKNUM/AKDEN - CALL DAXPY(N, AK, ATP, 1, X, 1) - CALL MATVEC(N, ATP, Z, NELT, IA, JA, A, ISYM) - CALL DAXPY(N, -AK, Z, 1, R, 1) - CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) - CALL MTTVEC(N, Z, ATZ, NELT, IA, JA, A, ISYM) -C -C check stopping criterion. - IF( ISDCGN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, - $ MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, - $ Z, P, ATP, ATZ, DZ, ATDZ, RWORK, IWORK, AK, BK, BNRM, - $ SOLNRM) .NE. 0) GOTO 200 -C - 100 CONTINUE -C -C ***** end of loop ***** -C -C stopping criterion not satisfied. - ITER = ITMAX + 1 -C - 200 RETURN -C------------- LAST LINE OF DCGN FOLLOWS ---------------------------- - END diff --git a/slatec/dcgs.f b/slatec/dcgs.f deleted file mode 100644 index 3efb5e3..0000000 --- a/slatec/dcgs.f +++ /dev/null @@ -1,377 +0,0 @@ -*DECK DCGS - SUBROUTINE DCGS (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, - + ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, R0, P, Q, U, V1, - + V2, RWORK, IWORK) -C***BEGIN PROLOGUE DCGS -C***PURPOSE Preconditioned BiConjugate Gradient Squared Ax=b Solver. -C Routine to solve a Non-Symmetric linear system Ax = b -C using the Preconditioned BiConjugate Gradient Squared -C method. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (SCGS-S, DCGS-D) -C***KEYWORDS BICONJUGATE GRADIENT, ITERATIVE PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) -C DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, R(N), R0(N), P(N) -C DOUBLE PRECISION Q(N), U(N), V1(N), V2(N), RWORK(USER DEFINED) -C EXTERNAL MATVEC, MSOLVE -C -C CALL DCGS(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, -C $ MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, -C $ R, R0, P, Q, U, V1, V2, RWORK, IWORK) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right-hand side vector. -C X :INOUT Double Precision X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Double Precision A(NELT). -C These arrays contain the matrix data structure for A. -C It could take any form. See "Description", below, -C for more details. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C MATVEC :EXT External. -C Name of a routine which performs the matrix vector multiply -C operation Y = A*X given A and X. The name of the MATVEC -C routine must be declared external in the calling program. -C The calling sequence of MATVEC is: -C CALL MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) -C Where N is the number of unknowns, Y is the product A*X upon -C return, X is an input vector. NELT, IA, JA, A and ISYM -C define the SLAP matrix data structure: see Description,below. -C MSOLVE :EXT External. -C Name of a routine which solves a linear system MZ = R for Z -C given R with the preconditioning matrix M (M is supplied via -C RWORK and IWORK arrays). The name of the MSOLVE routine -C must be declared external in the calling program. The -C calling sequence of MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, R is the right-hand side -C vector, and Z is the solution upon return. NELT, IA, JA, A -C and ISYM define the SLAP matrix data structure: see -C Description, below. RWORK is a double precision array that -C can be used to pass necessary preconditioning information and/ -C or workspace to MSOLVE. IWORK is an integer work array for -C the same purpose as RWORK. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C This routine must calculate the residual from R = A*X - B. -C This is unnatural and hence expensive for this type of iter- -C ative method. ITOL=2 is *STRONGLY* recommended. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv time a vector is the pre- -C conditioning step. This is the *NATURAL* stopping for this -C iterative method and is *STRONGLY* recommended. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /DSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. -C TOL :INOUT Double Precision. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Double Precision. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*D1MACH(3). Iteration proceeded. -C IERR = 5 => Breakdown of the method detected. -C (r0,r) approximately 0. -C IERR = 6 => Stagnation of the method detected. -C (r0,v) approximately 0. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C R :WORK Double Precision R(N). -C R0 :WORK Double Precision R0(N). -C P :WORK Double Precision P(N). -C Q :WORK Double Precision Q(N). -C U :WORK Double Precision U(N). -C V1 :WORK Double Precision V1(N). -C V2 :WORK Double Precision V2(N). -C Double Precision arrays used for workspace. -C RWORK :WORK Double Precision RWORK(USER DEFINED). -C Double Precision array that can be used for workspace in -C MSOLVE. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used for workspace in MSOLVE. -C -C *Description -C This routine does not care what matrix data structure is -C used for A and M. It simply calls the MATVEC and MSOLVE -C routines, with the arguments as described above. The user -C could write any type of structure and the appropriate MATVEC -C and MSOLVE routines. It is assumed that A is stored in the -C IA, JA, A arrays in some fashion and that M (or INV(M)) is -C stored in IWORK and RWORK in some fashion. The SLAP -C routines DSDBCG and DSLUCS are examples of this procedure. -C -C Two examples of matrix data structures are the: 1) SLAP -C Triad format and 2) SLAP Column format. -C -C =================== S L A P Triad format =================== -C -C In this format only the non-zeros are stored. They may -C appear in *ANY* order. The user supplies three arrays of -C length NELT, where NELT is the number of non-zeros in the -C matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero -C the user puts the row and column index of that matrix -C element in the IA and JA arrays. The value of the non-zero -C matrix element is placed in the corresponding location of -C the A array. This is an extremely easy data structure to -C generate. On the other hand it is not too efficient on -C vector computers for the iterative solution of linear -C systems. Hence, SLAP changes this input data structure to -C the SLAP Column format for the iteration (but does not -C change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C In this format the non-zeros are stored counting down -C columns (except for the diagonal entry, which must appear -C first in each "column") and are stored in the double pre- -C cision array A. In other words, for each column in the -C matrix first put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)),A(JA(ICOL)) are the first elements of the ICOL- -C th column in IA and A, and IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) -C are the last elements of the ICOL-th column. Note that we -C always have JA(N+1)=NELT+1, where N is the number of columns -C in the matrix and NELT is the number of non-zeros in the -C matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO DSDCGS, DSLUCS -C***REFERENCES 1. P. Sonneveld, CGS, a fast Lanczos-type solver -C for nonsymmetric linear systems, Delft University -C of Technology Report 84-16, Department of Mathe- -C matics and Informatics, Delft, The Netherlands. -C 2. E. F. Kaasschieter, The solution of non-symmetric -C linear systems by biconjugate gradients or conjugate -C gradients squared, Delft University of Technology -C Report 86-21, Department of Mathematics and Informa- -C tics, Delft, The Netherlands. -C 3. Mark K. Seager, A SLAP for the Masses, in -C G. F. Carey, Ed., Parallel Supercomputing: Methods, -C Algorithms and Applications, Wiley, 1989, pp.135-155. -C***ROUTINES CALLED D1MACH, DAXPY, DDOT, ISDCGS -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 891004 Added new reference. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MATVEC and MSOLVE from ROUTINES CALLED list. (FNF) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of references. (FNF) -C 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE DCGS -C .. Scalar Arguments .. - DOUBLE PRECISION ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), B(N), P(N), Q(N), R(N), R0(N), RWORK(*), - + U(N), V1(N), V2(N), X(N) - INTEGER IA(NELT), IWORK(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MATVEC, MSOLVE -C .. Local Scalars .. - DOUBLE PRECISION AK, AKM, BK, BNRM, FUZZ, RHON, RHONM1, SIGMA, - + SOLNRM, TOLMIN - INTEGER I, K -C .. External Functions .. - DOUBLE PRECISION D1MACH, DDOT - INTEGER ISDCGS - EXTERNAL D1MACH, DDOT, ISDCGS -C .. External Subroutines .. - EXTERNAL DAXPY -C .. Intrinsic Functions .. - INTRINSIC ABS -C***FIRST EXECUTABLE STATEMENT DCGS -C -C Check some of the input data. -C - ITER = 0 - IERR = 0 - IF( N.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF - TOLMIN = 500*D1MACH(3) - IF( TOL.LT.TOLMIN ) THEN - TOL = TOLMIN - IERR = 4 - ENDIF -C -C Calculate initial residual and pseudo-residual, and check -C stopping criterion. - CALL MATVEC(N, X, R, NELT, IA, JA, A, ISYM) - DO 10 I = 1, N - V1(I) = R(I) - B(I) - 10 CONTINUE - CALL MSOLVE(N, V1, R, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C - IF( ISDCGS(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, - $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, R0, P, Q, - $ U, V1, V2, RWORK, IWORK, AK, BK, BNRM, SOLNRM) .NE. 0 ) - $ GO TO 200 - IF( IERR.NE.0 ) RETURN -C -C Set initial values. -C - FUZZ = D1MACH(3)**2 - DO 20 I = 1, N - R0(I) = R(I) - 20 CONTINUE - RHONM1 = 1 -C -C ***** ITERATION LOOP ***** -C - DO 100 K=1,ITMAX - ITER = K -C -C Calculate coefficient BK and direction vectors U, V and P. - RHON = DDOT(N, R0, 1, R, 1) - IF( ABS(RHONM1).LT.FUZZ ) GOTO 998 - BK = RHON/RHONM1 - IF( ITER.EQ.1 ) THEN - DO 30 I = 1, N - U(I) = R(I) - P(I) = R(I) - 30 CONTINUE - ELSE - DO 40 I = 1, N - U(I) = R(I) + BK*Q(I) - V1(I) = Q(I) + BK*P(I) - 40 CONTINUE - DO 50 I = 1, N - P(I) = U(I) + BK*V1(I) - 50 CONTINUE - ENDIF -C -C Calculate coefficient AK, new iterate X, Q - CALL MATVEC(N, P, V2, NELT, IA, JA, A, ISYM) - CALL MSOLVE(N, V2, V1, NELT, IA, JA, A, ISYM, RWORK, IWORK) - SIGMA = DDOT(N, R0, 1, V1, 1) - IF( ABS(SIGMA).LT.FUZZ ) GOTO 999 - AK = RHON/SIGMA - AKM = -AK - DO 60 I = 1, N - Q(I) = U(I) + AKM*V1(I) - 60 CONTINUE - DO 70 I = 1, N - V1(I) = U(I) + Q(I) - 70 CONTINUE -C X = X - ak*V1. - CALL DAXPY( N, AKM, V1, 1, X, 1 ) -C -1 -C R = R - ak*M *A*V1 - CALL MATVEC(N, V1, V2, NELT, IA, JA, A, ISYM) - CALL MSOLVE(N, V2, V1, NELT, IA, JA, A, ISYM, RWORK, IWORK) - CALL DAXPY( N, AKM, V1, 1, R, 1 ) -C -C check stopping criterion. - IF( ISDCGS(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, - $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, R0, P, Q, - $ U, V1, V2, RWORK, IWORK, AK, BK, BNRM, SOLNRM) .NE. 0 ) - $ GO TO 200 -C -C Update RHO. - RHONM1 = RHON - 100 CONTINUE -C -C ***** end of loop ***** -C Stopping criterion not satisfied. - ITER = ITMAX + 1 - IERR = 2 - 200 RETURN -C -C Breakdown of method detected. - 998 IERR = 5 - RETURN -C -C Stagnation of method detected. - 999 IERR = 6 - RETURN -C------------- LAST LINE OF DCGS FOLLOWS ---------------------------- - END diff --git a/slatec/dchdc.f b/slatec/dchdc.f deleted file mode 100644 index f1faf49..0000000 --- a/slatec/dchdc.f +++ /dev/null @@ -1,251 +0,0 @@ -*DECK DCHDC - SUBROUTINE DCHDC (A, LDA, P, WORK, JPVT, JOB, INFO) -C***BEGIN PROLOGUE DCHDC -C***PURPOSE Compute the Cholesky decomposition of a positive definite -C matrix. A pivoting option allows the user to estimate the -C condition number of a positive definite matrix or determine -C the rank of a positive semidefinite matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1B -C***TYPE DOUBLE PRECISION (SCHDC-S, DCHDC-D, CCHDC-C) -C***KEYWORDS CHOLESKY DECOMPOSITION, LINEAR ALGEBRA, LINPACK, MATRIX, -C POSITIVE DEFINITE -C***AUTHOR Dongarra, J., (ANL) -C Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C DCHDC computes the Cholesky decomposition of a positive definite -C matrix. A pivoting option allows the user to estimate the -C condition of a positive definite matrix or determine the rank -C of a positive semidefinite matrix. -C -C On Entry -C -C A DOUBLE PRECISION(LDA,P). -C A contains the matrix whose decomposition is to -C be computed. Only the upper half of A need be stored. -C The lower part of the array A is not referenced. -C -C LDA INTEGER. -C LDA is the leading dimension of the array A. -C -C P INTEGER. -C P is the order of the matrix. -C -C WORK DOUBLE PRECISION. -C WORK is a work array. -C -C JPVT INTEGER(P). -C JPVT contains integers that control the selection -C of the pivot elements, if pivoting has been requested. -C Each diagonal element A(K,K) -C is placed in one of three classes according to the -C value of JPVT(K). -C -C If JPVT(K) .GT. 0, then X(K) is an initial -C element. -C -C If JPVT(K) .EQ. 0, then X(K) is a free element. -C -C If JPVT(K) .LT. 0, then X(K) is a final element. -C -C Before the decomposition is computed, initial elements -C are moved by symmetric row and column interchanges to -C the beginning of the array A and final -C elements to the end. Both initial and final elements -C are frozen in place during the computation and only -C free elements are moved. At the K-th stage of the -C reduction, if A(K,K) is occupied by a free element -C it is interchanged with the largest free element -C A(L,L) with L .GE. K. JPVT is not referenced if -C JOB .EQ. 0. -C -C JOB INTEGER. -C JOB is an integer that initiates column pivoting. -C If JOB .EQ. 0, no pivoting is done. -C If JOB .NE. 0, pivoting is done. -C -C On Return -C -C A A contains in its upper half the Cholesky factor -C of the matrix A as it has been permuted by pivoting. -C -C JPVT JPVT(J) contains the index of the diagonal element -C of a that was moved into the J-th position, -C provided pivoting was requested. -C -C INFO contains the index of the last positive diagonal -C element of the Cholesky factor. -C -C For positive definite matrices INFO = P is the normal return. -C For pivoting with positive semidefinite matrices INFO will -C in general be less than P. However, INFO may be greater than -C the rank of A, since rounding error can cause an otherwise zero -C element to be positive. Indefinite systems will always cause -C INFO to be less than P. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DSWAP -C***REVISION HISTORY (YYMMDD) -C 790319 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DCHDC - INTEGER LDA,P,JPVT(*),JOB,INFO - DOUBLE PRECISION A(LDA,*),WORK(*) -C - INTEGER PU,PL,PLP1,J,JP,JT,K,KB,KM1,KP1,L,MAXL - DOUBLE PRECISION TEMP - DOUBLE PRECISION MAXDIA - LOGICAL SWAPK,NEGK -C***FIRST EXECUTABLE STATEMENT DCHDC - PL = 1 - PU = 0 - INFO = P - IF (JOB .EQ. 0) GO TO 160 -C -C PIVOTING HAS BEEN REQUESTED. REARRANGE THE -C THE ELEMENTS ACCORDING TO JPVT. -C - DO 70 K = 1, P - SWAPK = JPVT(K) .GT. 0 - NEGK = JPVT(K) .LT. 0 - JPVT(K) = K - IF (NEGK) JPVT(K) = -JPVT(K) - IF (.NOT.SWAPK) GO TO 60 - IF (K .EQ. PL) GO TO 50 - CALL DSWAP(PL-1,A(1,K),1,A(1,PL),1) - TEMP = A(K,K) - A(K,K) = A(PL,PL) - A(PL,PL) = TEMP - PLP1 = PL + 1 - IF (P .LT. PLP1) GO TO 40 - DO 30 J = PLP1, P - IF (J .GE. K) GO TO 10 - TEMP = A(PL,J) - A(PL,J) = A(J,K) - A(J,K) = TEMP - GO TO 20 - 10 CONTINUE - IF (J .EQ. K) GO TO 20 - TEMP = A(K,J) - A(K,J) = A(PL,J) - A(PL,J) = TEMP - 20 CONTINUE - 30 CONTINUE - 40 CONTINUE - JPVT(K) = JPVT(PL) - JPVT(PL) = K - 50 CONTINUE - PL = PL + 1 - 60 CONTINUE - 70 CONTINUE - PU = P - IF (P .LT. PL) GO TO 150 - DO 140 KB = PL, P - K = P - KB + PL - IF (JPVT(K) .GE. 0) GO TO 130 - JPVT(K) = -JPVT(K) - IF (PU .EQ. K) GO TO 120 - CALL DSWAP(K-1,A(1,K),1,A(1,PU),1) - TEMP = A(K,K) - A(K,K) = A(PU,PU) - A(PU,PU) = TEMP - KP1 = K + 1 - IF (P .LT. KP1) GO TO 110 - DO 100 J = KP1, P - IF (J .GE. PU) GO TO 80 - TEMP = A(K,J) - A(K,J) = A(J,PU) - A(J,PU) = TEMP - GO TO 90 - 80 CONTINUE - IF (J .EQ. PU) GO TO 90 - TEMP = A(K,J) - A(K,J) = A(PU,J) - A(PU,J) = TEMP - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE - JT = JPVT(K) - JPVT(K) = JPVT(PU) - JPVT(PU) = JT - 120 CONTINUE - PU = PU - 1 - 130 CONTINUE - 140 CONTINUE - 150 CONTINUE - 160 CONTINUE - DO 270 K = 1, P -C -C REDUCTION LOOP. -C - MAXDIA = A(K,K) - KP1 = K + 1 - MAXL = K -C -C DETERMINE THE PIVOT ELEMENT. -C - IF (K .LT. PL .OR. K .GE. PU) GO TO 190 - DO 180 L = KP1, PU - IF (A(L,L) .LE. MAXDIA) GO TO 170 - MAXDIA = A(L,L) - MAXL = L - 170 CONTINUE - 180 CONTINUE - 190 CONTINUE -C -C QUIT IF THE PIVOT ELEMENT IS NOT POSITIVE. -C - IF (MAXDIA .GT. 0.0D0) GO TO 200 - INFO = K - 1 - GO TO 280 - 200 CONTINUE - IF (K .EQ. MAXL) GO TO 210 -C -C START THE PIVOTING AND UPDATE JPVT. -C - KM1 = K - 1 - CALL DSWAP(KM1,A(1,K),1,A(1,MAXL),1) - A(MAXL,MAXL) = A(K,K) - A(K,K) = MAXDIA - JP = JPVT(MAXL) - JPVT(MAXL) = JPVT(K) - JPVT(K) = JP - 210 CONTINUE -C -C REDUCTION STEP. PIVOTING IS CONTAINED ACROSS THE ROWS. -C - WORK(K) = SQRT(A(K,K)) - A(K,K) = WORK(K) - IF (P .LT. KP1) GO TO 260 - DO 250 J = KP1, P - IF (K .EQ. MAXL) GO TO 240 - IF (J .GE. MAXL) GO TO 220 - TEMP = A(K,J) - A(K,J) = A(J,MAXL) - A(J,MAXL) = TEMP - GO TO 230 - 220 CONTINUE - IF (J .EQ. MAXL) GO TO 230 - TEMP = A(K,J) - A(K,J) = A(MAXL,J) - A(MAXL,J) = TEMP - 230 CONTINUE - 240 CONTINUE - A(K,J) = A(K,J)/WORK(K) - WORK(J) = A(K,J) - TEMP = -A(K,J) - CALL DAXPY(J-K,TEMP,WORK(KP1),1,A(KP1,J),1) - 250 CONTINUE - 260 CONTINUE - 270 CONTINUE - 280 CONTINUE - RETURN - END diff --git a/slatec/dchdd.f b/slatec/dchdd.f deleted file mode 100644 index e202475..0000000 --- a/slatec/dchdd.f +++ /dev/null @@ -1,202 +0,0 @@ -*DECK DCHDD - SUBROUTINE DCHDD (R, LDR, P, X, Z, LDZ, NZ, Y, RHO, C, S, INFO) -C***BEGIN PROLOGUE DCHDD -C***PURPOSE Downdate an augmented Cholesky decomposition or the -C triangular factor of an augmented QR decomposition. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D7B -C***TYPE DOUBLE PRECISION (SCHDD-S, DCHDD-D, CCHDD-C) -C***KEYWORDS CHOLESKY DECOMPOSITION, DOWNDATE, LINEAR ALGEBRA, LINPACK, -C MATRIX -C***AUTHOR Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C DCHDD downdates an augmented Cholesky decomposition or the -C triangular factor of an augmented QR decomposition. -C Specifically, given an upper triangular matrix R of order P, a -C row vector X, a column vector Z, and a scalar Y, DCHDD -C determines an orthogonal matrix U and a scalar ZETA such that -C -C (R Z ) (RR ZZ) -C U * ( ) = ( ) , -C (0 ZETA) ( X Y) -C -C where RR is upper triangular. If R and Z have been obtained -C from the factorization of a least squares problem, then -C RR and ZZ are the factors corresponding to the problem -C with the observation (X,Y) removed. In this case, if RHO -C is the norm of the residual vector, then the norm of -C the residual vector of the downdated problem is -C SQRT(RHO**2 - ZETA**2). DCHDD will simultaneously downdate -C several triplets (Z,Y,RHO) along with R. -C For a less terse description of what DCHDD does and how -C it may be applied, see the LINPACK guide. -C -C The matrix U is determined as the product U(1)*...*U(P) -C where U(I) is a rotation in the (P+1,I)-plane of the -C form -C -C ( C(I) -S(I) ) -C ( ) . -C ( S(I) C(I) ) -C -C The rotations are chosen so that C(I) is double precision. -C -C The user is warned that a given downdating problem may -C be impossible to accomplish or may produce -C inaccurate results. For example, this can happen -C if X is near a vector whose removal will reduce the -C rank of R. Beware. -C -C On Entry -C -C R DOUBLE PRECISION(LDR,P), where LDR .GE. P. -C R contains the upper triangular matrix -C that is to be downdated. The part of R -C below the diagonal is not referenced. -C -C LDR INTEGER. -C LDR is the leading dimension of the array R. -C -C P INTEGER. -C P is the order of the matrix R. -C -C X DOUBLE PRECISION(P). -C X contains the row vector that is to -C be removed from R. X is not altered by DCHDD. -C -C Z DOUBLE PRECISION(LDZ,N)Z), where LDZ .GE. P. -C Z is an array of NZ P-vectors which -C are to be downdated along with R. -C -C LDZ INTEGER. -C LDZ is the leading dimension of the array Z. -C -C NZ INTEGER. -C NZ is the number of vectors to be downdated -C NZ may be zero, in which case Z, Y, and RHO -C are not referenced. -C -C Y DOUBLE PRECISION(NZ). -C Y contains the scalars for the downdating -C of the vectors Z. Y is not altered by DCHDD. -C -C RHO DOUBLE PRECISION(NZ). -C RHO contains the norms of the residual -C vectors that are to be downdated. -C -C On Return -C -C R -C Z contain the downdated quantities. -C RHO -C -C C DOUBLE PRECISION(P). -C C contains the cosines of the transforming -C rotations. -C -C S DOUBLE PRECISION(P). -C S contains the sines of the transforming -C rotations. -C -C INFO INTEGER. -C INFO is set as follows. -C -C INFO = 0 if the entire downdating -C was successful. -C -C INFO =-1 if R could not be downdated. -C in this case, all quantities -C are left unaltered. -C -C INFO = 1 if some RHO could not be -C downdated. The offending RHO's are -C set to -1. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DDOT, DNRM2 -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DCHDD - INTEGER LDR,P,LDZ,NZ,INFO - DOUBLE PRECISION R(LDR,*),X(*),Z(LDZ,*),Y(*),S(*) - DOUBLE PRECISION RHO(*),C(*) -C - INTEGER I,II,J - DOUBLE PRECISION A,ALPHA,AZETA,NORM,DNRM2 - DOUBLE PRECISION DDOT,T,ZETA,B,XX,SCALE -C -C SOLVE THE SYSTEM TRANS(R)*A = X, PLACING THE RESULT -C IN THE ARRAY S. -C -C***FIRST EXECUTABLE STATEMENT DCHDD - INFO = 0 - S(1) = X(1)/R(1,1) - IF (P .LT. 2) GO TO 20 - DO 10 J = 2, P - S(J) = X(J) - DDOT(J-1,R(1,J),1,S,1) - S(J) = S(J)/R(J,J) - 10 CONTINUE - 20 CONTINUE - NORM = DNRM2(P,S,1) - IF (NORM .LT. 1.0D0) GO TO 30 - INFO = -1 - GO TO 120 - 30 CONTINUE - ALPHA = SQRT(1.0D0-NORM**2) -C -C DETERMINE THE TRANSFORMATIONS. -C - DO 40 II = 1, P - I = P - II + 1 - SCALE = ALPHA + ABS(S(I)) - A = ALPHA/SCALE - B = S(I)/SCALE - NORM = SQRT(A**2+B**2) - C(I) = A/NORM - S(I) = B/NORM - ALPHA = SCALE*NORM - 40 CONTINUE -C -C APPLY THE TRANSFORMATIONS TO R. -C - DO 60 J = 1, P - XX = 0.0D0 - DO 50 II = 1, J - I = J - II + 1 - T = C(I)*XX + S(I)*R(I,J) - R(I,J) = C(I)*R(I,J) - S(I)*XX - XX = T - 50 CONTINUE - 60 CONTINUE -C -C IF REQUIRED, DOWNDATE Z AND RHO. -C - IF (NZ .LT. 1) GO TO 110 - DO 100 J = 1, NZ - ZETA = Y(J) - DO 70 I = 1, P - Z(I,J) = (Z(I,J) - S(I)*ZETA)/C(I) - ZETA = C(I)*ZETA - S(I)*Z(I,J) - 70 CONTINUE - AZETA = ABS(ZETA) - IF (AZETA .LE. RHO(J)) GO TO 80 - INFO = 1 - RHO(J) = -1.0D0 - GO TO 90 - 80 CONTINUE - RHO(J) = RHO(J)*SQRT(1.0D0-(AZETA/RHO(J))**2) - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE - RETURN - END diff --git a/slatec/dchex.f b/slatec/dchex.f deleted file mode 100644 index 949e24b..0000000 --- a/slatec/dchex.f +++ /dev/null @@ -1,267 +0,0 @@ -*DECK DCHEX - SUBROUTINE DCHEX (R, LDR, P, K, L, Z, LDZ, NZ, C, S, JOB) -C***BEGIN PROLOGUE DCHEX -C***PURPOSE Update the Cholesky factorization A=TRANS(R)*R of a -C positive definite matrix A of order P under diagonal -C permutations of the form TRANS(E)*A*E, where E is a -C permutation matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D7B -C***TYPE DOUBLE PRECISION (SCHEX-S, DCHEX-D, CCHEX-C) -C***KEYWORDS CHOLESKY DECOMPOSITION, EXCHANGE, LINEAR ALGEBRA, LINPACK, -C MATRIX, POSITIVE DEFINITE -C***AUTHOR Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C DCHEX updates the Cholesky factorization -C -C A = TRANS(R)*R -C -C of a positive definite matrix A of order P under diagonal -C permutations of the form -C -C TRANS(E)*A*E -C -C where E is a permutation matrix. Specifically, given -C an upper triangular matrix R and a permutation matrix -C E (which is specified by K, L, and JOB), DCHEX determines -C an orthogonal matrix U such that -C -C U*R*E = RR, -C -C where RR is upper triangular. At the users option, the -C transformation U will be multiplied into the array Z. -C If A = TRANS(X)*X, so that R is the triangular part of the -C QR factorization of X, then RR is the triangular part of the -C QR factorization of X*E, i.e. X with its columns permuted. -C For a less terse description of what DCHEX does and how -C it may be applied, see the LINPACK guide. -C -C The matrix Q is determined as the product U(L-K)*...*U(1) -C of plane rotations of the form -C -C ( C(I) S(I) ) -C ( ) , -C ( -S(I) C(I) ) -C -C where C(I) is double precision. The rows these rotations operate -C on are described below. -C -C There are two types of permutations, which are determined -C by the value of JOB. -C -C 1. Right circular shift (JOB = 1). -C -C The columns are rearranged in the following order. -C -C 1,...,K-1,L,K,K+1,...,L-1,L+1,...,P. -C -C U is the product of L-K rotations U(I), where U(I) -C acts in the (L-I,L-I+1)-plane. -C -C 2. Left circular shift (JOB = 2). -C The columns are rearranged in the following order -C -C 1,...,K-1,K+1,K+2,...,L,K,L+1,...,P. -C -C U is the product of L-K rotations U(I), where U(I) -C acts in the (K+I-1,K+I)-plane. -C -C On Entry -C -C R DOUBLE PRECISION(LDR,P), where LDR .GE. P. -C R contains the upper triangular factor -C that is to be updated. Elements of R -C below the diagonal are not referenced. -C -C LDR INTEGER. -C LDR is the leading dimension of the array R. -C -C P INTEGER. -C P is the order of the matrix R. -C -C K INTEGER. -C K is the first column to be permuted. -C -C L INTEGER. -C L is the last column to be permuted. -C L must be strictly greater than K. -C -C Z DOUBLE PRECISION(LDZ,N)Z), where LDZ .GE. P. -C Z is an array of NZ P-vectors into which the -C transformation U is multiplied. Z is -C not referenced if NZ = 0. -C -C LDZ INTEGER. -C LDZ is the leading dimension of the array Z. -C -C NZ INTEGER. -C NZ is the number of columns of the matrix Z. -C -C JOB INTEGER. -C JOB determines the type of permutation. -C JOB = 1 right circular shift. -C JOB = 2 left circular shift. -C -C On Return -C -C R contains the updated factor. -C -C Z contains the updated matrix Z. -C -C C DOUBLE PRECISION(P). -C C contains the cosines of the transforming rotations. -C -C S DOUBLE PRECISION(P). -C S contains the sines of the transforming rotations. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DROTG -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DCHEX - INTEGER LDR,P,K,L,LDZ,NZ,JOB - DOUBLE PRECISION R(LDR,*),Z(LDZ,*),S(*) - DOUBLE PRECISION C(*) -C - INTEGER I,II,IL,IU,J,JJ,KM1,KP1,LMK,LM1 - DOUBLE PRECISION T -C -C INITIALIZE -C -C***FIRST EXECUTABLE STATEMENT DCHEX - KM1 = K - 1 - KP1 = K + 1 - LMK = L - K - LM1 = L - 1 -C -C PERFORM THE APPROPRIATE TASK. -C - GO TO (10,130), JOB -C -C RIGHT CIRCULAR SHIFT. -C - 10 CONTINUE -C -C REORDER THE COLUMNS. -C - DO 20 I = 1, L - II = L - I + 1 - S(I) = R(II,L) - 20 CONTINUE - DO 40 JJ = K, LM1 - J = LM1 - JJ + K - DO 30 I = 1, J - R(I,J+1) = R(I,J) - 30 CONTINUE - R(J+1,J+1) = 0.0D0 - 40 CONTINUE - IF (K .EQ. 1) GO TO 60 - DO 50 I = 1, KM1 - II = L - I + 1 - R(I,K) = S(II) - 50 CONTINUE - 60 CONTINUE -C -C CALCULATE THE ROTATIONS. -C - T = S(1) - DO 70 I = 1, LMK - CALL DROTG(S(I+1),T,C(I),S(I)) - T = S(I+1) - 70 CONTINUE - R(K,K) = T - DO 90 J = KP1, P - IL = MAX(1,L-J+1) - DO 80 II = IL, LMK - I = L - II - T = C(II)*R(I,J) + S(II)*R(I+1,J) - R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J) - R(I,J) = T - 80 CONTINUE - 90 CONTINUE -C -C IF REQUIRED, APPLY THE TRANSFORMATIONS TO Z. -C - IF (NZ .LT. 1) GO TO 120 - DO 110 J = 1, NZ - DO 100 II = 1, LMK - I = L - II - T = C(II)*Z(I,J) + S(II)*Z(I+1,J) - Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J) - Z(I,J) = T - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE - GO TO 260 -C -C LEFT CIRCULAR SHIFT -C - 130 CONTINUE -C -C REORDER THE COLUMNS -C - DO 140 I = 1, K - II = LMK + I - S(II) = R(I,K) - 140 CONTINUE - DO 160 J = K, LM1 - DO 150 I = 1, J - R(I,J) = R(I,J+1) - 150 CONTINUE - JJ = J - KM1 - S(JJ) = R(J+1,J+1) - 160 CONTINUE - DO 170 I = 1, K - II = LMK + I - R(I,L) = S(II) - 170 CONTINUE - DO 180 I = KP1, L - R(I,L) = 0.0D0 - 180 CONTINUE -C -C REDUCTION LOOP. -C - DO 220 J = K, P - IF (J .EQ. K) GO TO 200 -C -C APPLY THE ROTATIONS. -C - IU = MIN(J-1,L-1) - DO 190 I = K, IU - II = I - K + 1 - T = C(II)*R(I,J) + S(II)*R(I+1,J) - R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J) - R(I,J) = T - 190 CONTINUE - 200 CONTINUE - IF (J .GE. L) GO TO 210 - JJ = J - K + 1 - T = S(JJ) - CALL DROTG(R(J,J),T,C(JJ),S(JJ)) - 210 CONTINUE - 220 CONTINUE -C -C APPLY THE ROTATIONS TO Z. -C - IF (NZ .LT. 1) GO TO 250 - DO 240 J = 1, NZ - DO 230 I = K, LM1 - II = I - KM1 - T = C(II)*Z(I,J) + S(II)*Z(I+1,J) - Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J) - Z(I,J) = T - 230 CONTINUE - 240 CONTINUE - 250 CONTINUE - 260 CONTINUE - RETURN - END diff --git a/slatec/dchfcm.f b/slatec/dchfcm.f deleted file mode 100644 index 4dfbe07..0000000 --- a/slatec/dchfcm.f +++ /dev/null @@ -1,152 +0,0 @@ -*DECK DCHFCM - INTEGER FUNCTION DCHFCM (D1, D2, DELTA) -C***BEGIN PROLOGUE DCHFCM -C***SUBSIDIARY -C***PURPOSE Check a single cubic for monotonicity. -C***LIBRARY SLATEC (PCHIP) -C***TYPE DOUBLE PRECISION (CHFCM-S, DCHFCM-D) -C***AUTHOR Fritsch, F. N., (LLNL) -C***DESCRIPTION -C -C *Usage: -C -C DOUBLE PRECISION D1, D2, DELTA -C INTEGER ISMON, DCHFCM -C -C ISMON = DCHFCM (D1, D2, DELTA) -C -C *Arguments: -C -C D1,D2:IN are the derivative values at the ends of an interval. -C -C DELTA:IN is the data slope over that interval. -C -C *Function Return Values: -C ISMON : indicates the monotonicity of the cubic segment: -C ISMON = -3 if function is probably decreasing; -C ISMON = -1 if function is strictly decreasing; -C ISMON = 0 if function is constant; -C ISMON = 1 if function is strictly increasing; -C ISMON = 2 if function is non-monotonic; -C ISMON = 3 if function is probably increasing. -C If ABS(ISMON)=3, the derivative values are too close to the -C boundary of the monotonicity region to declare monotonicity -C in the presence of roundoff error. -C -C *Description: -C -C DCHFCM: Cubic Hermite Function -- Check Monotonicity. -C -C Called by DPCHCM to determine the monotonicity properties of the -C cubic with boundary derivative values D1,D2 and chord slope DELTA. -C -C *Cautions: -C This is essentially the same as old DCHFMC, except that a -C new output value, -3, was added February 1989. (Formerly, -3 -C and +3 were lumped together in the single value 3.) Codes that -C flag nonmonotonicity by "IF (ISMON.EQ.2)" need not be changed. -C Codes that check via "IF (ISMON.GE.3)" should change the test to -C "IF (IABS(ISMON).GE.3)". Codes that declare monotonicity via -C "IF (ISMON.LE.1)" should change to "IF (IABS(ISMON).LE.1)". -C -C REFER TO DPCHCM -C -C***ROUTINES CALLED D1MACH -C***REVISION HISTORY (YYMMDD) -C 820518 DATE WRITTEN -C 820805 Converted to SLATEC library version. -C 831201 Changed from ISIGN to SIGN to correct bug that -C produced wrong sign when -1 .LT. DELTA .LT. 0 . -C 890206 Added SAVE statements. -C 890209 Added sign to returned value ISMON=3 and corrected -C argument description accordingly. -C 890306 Added caution about changed output. -C 890407 Changed name from DCHFMC to DCHFCM, as requested at the -C March 1989 SLATEC CML meeting, and made a few other -C minor modifications necessitated by this change. -C 890407 Converted to new SLATEC format. -C 890407 Modified DESCRIPTION to LDOC format. -C 891214 Moved SAVE statements. (WRB) -C***END PROLOGUE DCHFCM -C -C Fortran intrinsics used: DSIGN. -C Other routines used: D1MACH. -C -C ---------------------------------------------------------------------- -C -C Programming notes: -C -C TEN is actually a tuning parameter, which determines the width of -C the fuzz around the elliptical boundary. -C -C To produce a single precision version, simply: -C a. Change DCHFCM to CHFCM wherever it occurs, -C b. Change the double precision declarations to real, and -C c. Change the constants ZERO, ONE, ... to single precision. -C -C DECLARE ARGUMENTS. -C - DOUBLE PRECISION D1, D2, DELTA, D1MACH -C -C DECLARE LOCAL VARIABLES. -C - INTEGER ISMON, ITRUE - DOUBLE PRECISION A, B, EPS, FOUR, ONE, PHI, TEN, THREE, TWO, - * ZERO - SAVE ZERO, ONE, TWO, THREE, FOUR - SAVE TEN -C -C INITIALIZE. -C - DATA ZERO /0.D0/, ONE/1.D0/, TWO/2.D0/, THREE/3.D0/, FOUR/4.D0/, - 1 TEN /10.D0/ -C -C MACHINE-DEPENDENT PARAMETER -- SHOULD BE ABOUT 10*UROUND. -C***FIRST EXECUTABLE STATEMENT DCHFCM - EPS = TEN*D1MACH(4) -C -C MAKE THE CHECK. -C - IF (DELTA .EQ. ZERO) THEN -C CASE OF CONSTANT DATA. - IF ((D1.EQ.ZERO) .AND. (D2.EQ.ZERO)) THEN - ISMON = 0 - ELSE - ISMON = 2 - ENDIF - ELSE -C DATA IS NOT CONSTANT -- PICK UP SIGN. - ITRUE = DSIGN (ONE, DELTA) - A = D1/DELTA - B = D2/DELTA - IF ((A.LT.ZERO) .OR. (B.LT.ZERO)) THEN - ISMON = 2 - ELSE IF ((A.LE.THREE-EPS) .AND. (B.LE.THREE-EPS)) THEN -C INSIDE SQUARE (0,3)X(0,3) IMPLIES OK. - ISMON = ITRUE - ELSE IF ((A.GT.FOUR+EPS) .AND. (B.GT.FOUR+EPS)) THEN -C OUTSIDE SQUARE (0,4)X(0,4) IMPLIES NONMONOTONIC. - ISMON = 2 - ELSE -C MUST CHECK AGAINST BOUNDARY OF ELLIPSE. - A = A - TWO - B = B - TWO - PHI = ((A*A + B*B) + A*B) - THREE - IF (PHI .LT. -EPS) THEN - ISMON = ITRUE - ELSE IF (PHI .GT. EPS) THEN - ISMON = 2 - ELSE -C TO CLOSE TO BOUNDARY TO TELL, -C IN THE PRESENCE OF ROUND-OFF ERRORS. - ISMON = 3*ITRUE - ENDIF - ENDIF - ENDIF -C -C RETURN VALUE. -C - DCHFCM = ISMON - RETURN -C------------- LAST LINE OF DCHFCM FOLLOWS ----------------------------- - END diff --git a/slatec/dchfdv.f b/slatec/dchfdv.f deleted file mode 100644 index b68bb95..0000000 --- a/slatec/dchfdv.f +++ /dev/null @@ -1,170 +0,0 @@ -*DECK DCHFDV - SUBROUTINE DCHFDV (X1, X2, F1, F2, D1, D2, NE, XE, FE, DE, NEXT, - + IERR) -C***BEGIN PROLOGUE DCHFDV -C***PURPOSE Evaluate a cubic polynomial given in Hermite form and its -C first derivative at an array of points. While designed for -C use by DPCHFD, it may be useful directly as an evaluator -C for a piecewise cubic Hermite function in applications, -C such as graphing, where the interval is known in advance. -C If only function values are required, use DCHFEV instead. -C***LIBRARY SLATEC (PCHIP) -C***CATEGORY E3, H1 -C***TYPE DOUBLE PRECISION (CHFDV-S, DCHFDV-D) -C***KEYWORDS CUBIC HERMITE DIFFERENTIATION, CUBIC HERMITE EVALUATION, -C CUBIC POLYNOMIAL EVALUATION, PCHIP -C***AUTHOR Fritsch, F. N., (LLNL) -C Lawrence Livermore National Laboratory -C P.O. Box 808 (L-316) -C Livermore, CA 94550 -C FTS 532-4275, (510) 422-4275 -C***DESCRIPTION -C -C DCHFDV: Cubic Hermite Function and Derivative Evaluator -C -C Evaluates the cubic polynomial determined by function values -C F1,F2 and derivatives D1,D2 on interval (X1,X2), together with -C its first derivative, at the points XE(J), J=1(1)NE. -C -C If only function values are required, use DCHFEV, instead. -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C INTEGER NE, NEXT(2), IERR -C DOUBLE PRECISION X1, X2, F1, F2, D1, D2, XE(NE), FE(NE), -C DE(NE) -C -C CALL DCHFDV (X1,X2, F1,F2, D1,D2, NE, XE, FE, DE, NEXT, IERR) -C -C Parameters: -C -C X1,X2 -- (input) endpoints of interval of definition of cubic. -C (Error return if X1.EQ.X2 .) -C -C F1,F2 -- (input) values of function at X1 and X2, respectively. -C -C D1,D2 -- (input) values of derivative at X1 and X2, respectively. -C -C NE -- (input) number of evaluation points. (Error return if -C NE.LT.1 .) -C -C XE -- (input) real*8 array of points at which the functions are to -C be evaluated. If any of the XE are outside the interval -C [X1,X2], a warning error is returned in NEXT. -C -C FE -- (output) real*8 array of values of the cubic function -C defined by X1,X2, F1,F2, D1,D2 at the points XE. -C -C DE -- (output) real*8 array of values of the first derivative of -C the same function at the points XE. -C -C NEXT -- (output) integer array indicating number of extrapolation -C points: -C NEXT(1) = number of evaluation points to left of interval. -C NEXT(2) = number of evaluation points to right of interval. -C -C IERR -- (output) error flag. -C Normal return: -C IERR = 0 (no errors). -C "Recoverable" errors: -C IERR = -1 if NE.LT.1 . -C IERR = -2 if X1.EQ.X2 . -C (Output arrays have not been changed in either case.) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 811019 DATE WRITTEN -C 820803 Minor cosmetic changes for release 1. -C 870707 Corrected XERROR calls for d.p. names(s). -C 870813 Minor cosmetic changes. -C 890411 Added SAVE statements (Vers. 3.2). -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (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***END PROLOGUE DCHFDV -C Programming notes: -C -C To produce a single precision version, simply: -C a. Change DCHFDV to CHFDV wherever it occurs, -C b. Change the double precision declaration to real, and -C c. Change the constant ZERO to single precision. -C -C DECLARE ARGUMENTS. -C - INTEGER NE, NEXT(2), IERR - DOUBLE PRECISION X1, X2, F1, F2, D1, D2, XE(*), FE(*), DE(*) -C -C DECLARE LOCAL VARIABLES. -C - INTEGER I - DOUBLE PRECISION C2, C2T2, C3, C3T3, DEL1, DEL2, DELTA, H, X, - * XMI, XMA, ZERO - SAVE ZERO - DATA ZERO /0.D0/ -C -C VALIDITY-CHECK ARGUMENTS. -C -C***FIRST EXECUTABLE STATEMENT DCHFDV - IF (NE .LT. 1) GO TO 5001 - H = X2 - X1 - IF (H .EQ. ZERO) GO TO 5002 -C -C INITIALIZE. -C - IERR = 0 - NEXT(1) = 0 - NEXT(2) = 0 - XMI = MIN(ZERO, H) - XMA = MAX(ZERO, H) -C -C COMPUTE CUBIC COEFFICIENTS (EXPANDED ABOUT X1). -C - DELTA = (F2 - F1)/H - DEL1 = (D1 - DELTA)/H - DEL2 = (D2 - DELTA)/H -C (DELTA IS NO LONGER NEEDED.) - C2 = -(DEL1+DEL1 + DEL2) - C2T2 = C2 + C2 - C3 = (DEL1 + DEL2)/H -C (H, DEL1 AND DEL2 ARE NO LONGER NEEDED.) - C3T3 = C3+C3+C3 -C -C EVALUATION LOOP. -C - DO 500 I = 1, NE - X = XE(I) - X1 - FE(I) = F1 + X*(D1 + X*(C2 + X*C3)) - DE(I) = D1 + X*(C2T2 + X*C3T3) -C COUNT EXTRAPOLATION POINTS. - IF ( X.LT.XMI ) NEXT(1) = NEXT(1) + 1 - IF ( X.GT.XMA ) NEXT(2) = NEXT(2) + 1 -C (NOTE REDUNDANCY--IF EITHER CONDITION IS TRUE, OTHER IS FALSE.) - 500 CONTINUE -C -C NORMAL RETURN. -C - RETURN -C -C ERROR RETURNS. -C - 5001 CONTINUE -C NE.LT.1 RETURN. - IERR = -1 - CALL XERMSG ('SLATEC', 'DCHFDV', - + 'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1) - RETURN -C - 5002 CONTINUE -C X1.EQ.X2 RETURN. - IERR = -2 - CALL XERMSG ('SLATEC', 'DCHFDV', 'INTERVAL ENDPOINTS EQUAL', - + IERR, 1) - RETURN -C------------- LAST LINE OF DCHFDV FOLLOWS ----------------------------- - END diff --git a/slatec/dchfev.f b/slatec/dchfev.f deleted file mode 100644 index 476d952..0000000 --- a/slatec/dchfev.f +++ /dev/null @@ -1,160 +0,0 @@ -*DECK DCHFEV - SUBROUTINE DCHFEV (X1, X2, F1, F2, D1, D2, NE, XE, FE, NEXT, IERR) -C***BEGIN PROLOGUE DCHFEV -C***PURPOSE Evaluate a cubic polynomial given in Hermite form at an -C array of points. While designed for use by DPCHFE, it may -C be useful directly as an evaluator for a piecewise cubic -C Hermite function in applications, such as graphing, where -C the interval is known in advance. -C***LIBRARY SLATEC (PCHIP) -C***CATEGORY E3 -C***TYPE DOUBLE PRECISION (CHFEV-S, DCHFEV-D) -C***KEYWORDS CUBIC HERMITE EVALUATION, CUBIC POLYNOMIAL EVALUATION, -C PCHIP -C***AUTHOR Fritsch, F. N., (LLNL) -C Lawrence Livermore National Laboratory -C P.O. Box 808 (L-316) -C Livermore, CA 94550 -C FTS 532-4275, (510) 422-4275 -C***DESCRIPTION -C -C DCHFEV: Cubic Hermite Function EValuator -C -C Evaluates the cubic polynomial determined by function values -C F1,F2 and derivatives D1,D2 on interval (X1,X2) at the points -C XE(J), J=1(1)NE. -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C INTEGER NE, NEXT(2), IERR -C DOUBLE PRECISION X1, X2, F1, F2, D1, D2, XE(NE), FE(NE) -C -C CALL DCHFEV (X1,X2, F1,F2, D1,D2, NE, XE, FE, NEXT, IERR) -C -C Parameters: -C -C X1,X2 -- (input) endpoints of interval of definition of cubic. -C (Error return if X1.EQ.X2 .) -C -C F1,F2 -- (input) values of function at X1 and X2, respectively. -C -C D1,D2 -- (input) values of derivative at X1 and X2, respectively. -C -C NE -- (input) number of evaluation points. (Error return if -C NE.LT.1 .) -C -C XE -- (input) real*8 array of points at which the function is to -C be evaluated. If any of the XE are outside the interval -C [X1,X2], a warning error is returned in NEXT. -C -C FE -- (output) real*8 array of values of the cubic function -C defined by X1,X2, F1,F2, D1,D2 at the points XE. -C -C NEXT -- (output) integer array indicating number of extrapolation -C points: -C NEXT(1) = number of evaluation points to left of interval. -C NEXT(2) = number of evaluation points to right of interval. -C -C IERR -- (output) error flag. -C Normal return: -C IERR = 0 (no errors). -C "Recoverable" errors: -C IERR = -1 if NE.LT.1 . -C IERR = -2 if X1.EQ.X2 . -C (The FE-array has not been changed in either case.) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 811019 DATE WRITTEN -C 820803 Minor cosmetic changes for release 1. -C 870813 Corrected XERROR calls for d.p. names(s). -C 890206 Corrected XERROR calls. -C 890411 Added SAVE statements (Vers. 3.2). -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890703 Corrected category record. (WRB) -C 890831 Modified array declarations. (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***END PROLOGUE DCHFEV -C Programming notes: -C -C To produce a single precision version, simply: -C a. Change DCHFEV to CHFEV wherever it occurs, -C b. Change the double precision declaration to real, and -C c. Change the constant ZERO to single precision. -C -C DECLARE ARGUMENTS. -C - INTEGER NE, NEXT(2), IERR - DOUBLE PRECISION X1, X2, F1, F2, D1, D2, XE(*), FE(*) -C -C DECLARE LOCAL VARIABLES. -C - INTEGER I - DOUBLE PRECISION C2, C3, DEL1, DEL2, DELTA, H, X, XMI, XMA, - * ZERO - SAVE ZERO - DATA ZERO /0.D0/ -C -C VALIDITY-CHECK ARGUMENTS. -C -C***FIRST EXECUTABLE STATEMENT DCHFEV - IF (NE .LT. 1) GO TO 5001 - H = X2 - X1 - IF (H .EQ. ZERO) GO TO 5002 -C -C INITIALIZE. -C - IERR = 0 - NEXT(1) = 0 - NEXT(2) = 0 - XMI = MIN(ZERO, H) - XMA = MAX(ZERO, H) -C -C COMPUTE CUBIC COEFFICIENTS (EXPANDED ABOUT X1). -C - DELTA = (F2 - F1)/H - DEL1 = (D1 - DELTA)/H - DEL2 = (D2 - DELTA)/H -C (DELTA IS NO LONGER NEEDED.) - C2 = -(DEL1+DEL1 + DEL2) - C3 = (DEL1 + DEL2)/H -C (H, DEL1 AND DEL2 ARE NO LONGER NEEDED.) -C -C EVALUATION LOOP. -C - DO 500 I = 1, NE - X = XE(I) - X1 - FE(I) = F1 + X*(D1 + X*(C2 + X*C3)) -C COUNT EXTRAPOLATION POINTS. - IF ( X.LT.XMI ) NEXT(1) = NEXT(1) + 1 - IF ( X.GT.XMA ) NEXT(2) = NEXT(2) + 1 -C (NOTE REDUNDANCY--IF EITHER CONDITION IS TRUE, OTHER IS FALSE.) - 500 CONTINUE -C -C NORMAL RETURN. -C - RETURN -C -C ERROR RETURNS. -C - 5001 CONTINUE -C NE.LT.1 RETURN. - IERR = -1 - CALL XERMSG ('SLATEC', 'DCHFEV', - + 'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1) - RETURN -C - 5002 CONTINUE -C X1.EQ.X2 RETURN. - IERR = -2 - CALL XERMSG ('SLATEC', 'DCHFEV', 'INTERVAL ENDPOINTS EQUAL', - + IERR, 1) - RETURN -C------------- LAST LINE OF DCHFEV FOLLOWS ----------------------------- - END diff --git a/slatec/dchfie.f b/slatec/dchfie.f deleted file mode 100644 index 8d141b4..0000000 --- a/slatec/dchfie.f +++ /dev/null @@ -1,109 +0,0 @@ -*DECK DCHFIE - DOUBLE PRECISION FUNCTION DCHFIE (X1, X2, F1, F2, D1, D2, A, B) -C***BEGIN PROLOGUE DCHFIE -C***SUBSIDIARY -C***PURPOSE Evaluates integral of a single cubic for DPCHIA -C***LIBRARY SLATEC (PCHIP) -C***TYPE DOUBLE PRECISION (CHFIE-S, DCHFIE-D) -C***AUTHOR Fritsch, F. N., (LLNL) -C***DESCRIPTION -C -C DCHFIE: Cubic Hermite Function Integral Evaluator. -C -C Called by DPCHIA to evaluate the integral of a single cubic (in -C Hermite form) over an arbitrary interval (A,B). -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C DOUBLE PRECISION X1, X2, F1, F2, D1, D2, A, B -C DOUBLE PRECISION VALUE, DCHFIE -C -C VALUE = DCHFIE (X1, X2, F1, F2, D1, D2, A, B) -C -C Parameters: -C -C VALUE -- (output) value of the requested integral. -C -C X1,X2 -- (input) endpoints if interval of definition of cubic. -C -C F1,F2 -- (input) function values at the ends of the interval. -C -C D1,D2 -- (input) derivative values at the ends of the interval. -C -C A,B -- (input) endpoints of interval of integration. -C -C***SEE ALSO DPCHIA -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 820730 DATE WRITTEN -C 820805 Converted to SLATEC library version. -C 870707 Corrected subroutine name from DCHIV to DCHFIV. -C 870813 Minor cosmetic changes. -C 890411 1. Added SAVE statements (Vers. 3.2). -C 2. Added SIX to DOUBLE PRECISION declaration. -C 890411 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 900328 Added TYPE section. (WRB) -C 910408 Updated AUTHOR section in prologue. (WRB) -C 930503 Corrected to set VALUE=0 when IERR.ne.0. (FNF) -C 930504 Eliminated IERR and changed name DCHFIV to DCHFIE. (FNF) -C***END PROLOGUE DCHFIE -C -C Programming notes: -C 1. There is no error return from this routine because zero is -C indeed the mathematically correct answer when X1.EQ.X2 . -C**End -C -C DECLARE ARGUMENTS. -C - DOUBLE PRECISION X1, X2, F1, F2, D1, D2, A, B -C -C DECLARE LOCAL VARIABLES. -C - DOUBLE PRECISION DTERM, FOUR, FTERM, H, HALF, PHIA1, PHIA2, - * PHIB1, PHIB2, PSIA1, PSIA2, PSIB1, PSIB2, SIX, TA1, TA2, - * TB1, TB2, THREE, TWO, UA1, UA2, UB1, UB2 - SAVE HALF, TWO, THREE, FOUR, SIX -C -C INITIALIZE. -C - DATA HALF/.5D0/, TWO/2.D0/, THREE/3.D0/, FOUR/4.D0/, SIX/6.D0/ -C -C VALIDITY CHECK INPUT. -C -C***FIRST EXECUTABLE STATEMENT DCHFIE - IF (X1 .EQ. X2) THEN - DCHFIE = 0 - ELSE - H = X2 - X1 - TA1 = (A - X1) / H - TA2 = (X2 - A) / H - TB1 = (B - X1) / H - TB2 = (X2 - B) / H -C - UA1 = TA1**3 - PHIA1 = UA1 * (TWO - TA1) - PSIA1 = UA1 * (THREE*TA1 - FOUR) - UA2 = TA2**3 - PHIA2 = UA2 * (TWO - TA2) - PSIA2 = -UA2 * (THREE*TA2 - FOUR) -C - UB1 = TB1**3 - PHIB1 = UB1 * (TWO - TB1) - PSIB1 = UB1 * (THREE*TB1 - FOUR) - UB2 = TB2**3 - PHIB2 = UB2 * (TWO - TB2) - PSIB2 = -UB2 * (THREE*TB2 - FOUR) -C - FTERM = F1*(PHIA2 - PHIB2) + F2*(PHIB1 - PHIA1) - DTERM = ( D1*(PSIA2 - PSIB2) + D2*(PSIB1 - PSIA1) )*(H/SIX) -C - DCHFIE = (HALF*H) * (FTERM + DTERM) - ENDIF -C - RETURN -C------------- LAST LINE OF DCHFIE FOLLOWS ----------------------------- - END diff --git a/slatec/dchkw.f b/slatec/dchkw.f deleted file mode 100644 index 95198cb..0000000 --- a/slatec/dchkw.f +++ /dev/null @@ -1,112 +0,0 @@ -*DECK DCHKW - SUBROUTINE DCHKW (NAME, LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR) -C***BEGIN PROLOGUE DCHKW -C***SUBSIDIARY -C***PURPOSE SLAP WORK/IWORK Array Bounds Checker. -C This routine checks the work array lengths and interfaces -C to the SLATEC error handler if a problem is found. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY R2 -C***TYPE DOUBLE PRECISION (SCHKW-S, DCHKW-D) -C***KEYWORDS ERROR CHECKING, SLAP, WORKSPACE CHECKING -C***AUTHOR Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C CHARACTER*(*) NAME -C INTEGER LOCIW, LENIW, LOCW, LENW, IERR, ITER -C DOUBLE PRECISION ERR -C -C CALL DCHKW( NAME, LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) -C -C *Arguments: -C NAME :IN Character*(*). -C Name of the calling routine. This is used in the output -C message, if an error is detected. -C LOCIW :IN Integer. -C Location of the first free element in the integer workspace -C array. -C LENIW :IN Integer. -C Length of the integer workspace array. -C LOCW :IN Integer. -C Location of the first free element in the double precision -C workspace array. -C LENRW :IN Integer. -C Length of the double precision workspace array. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient storage allocated for -C WORK or IWORK. -C ITER :OUT Integer. -C Set to zero on return. -C ERR :OUT Double Precision. -C Set to the smallest positive magnitude if all went well. -C Set to a very large number if an error is detected. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 880225 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 900805 Changed XERRWV calls to calls to XERMSG. (RWC) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Corrected XERMSG calls to satisfy Section 6.2.2 of ANSI -C X3.9-1978. (FNF) -C 910506 Made subsidiary. (FNF) -C 920511 Added complete declaration section. (WRB) -C 921015 Added code to initialize ITER and ERR when IERR=0. (FNF) -C***END PROLOGUE DCHKW -C .. Scalar Arguments .. - DOUBLE PRECISION ERR - INTEGER IERR, ITER, LENIW, LENW, LOCIW, LOCW - CHARACTER NAME*(*) -C .. Local Scalars .. - CHARACTER XERN1*8, XERN2*8, XERNAM*8 -C .. External Functions .. - DOUBLE PRECISION D1MACH - EXTERNAL D1MACH -C .. External Subroutines .. - EXTERNAL XERMSG -C***FIRST EXECUTABLE STATEMENT DCHKW -C -C Check the Integer workspace situation. -C - IERR = 0 - ITER = 0 - ERR = D1MACH(1) - IF( LOCIW.GT.LENIW ) THEN - IERR = 1 - ERR = D1MACH(2) - XERNAM = NAME - WRITE (XERN1, '(I8)') LOCIW - WRITE (XERN2, '(I8)') LENIW - CALL XERMSG ('SLATEC', 'DCHKW', - $ 'In ' // XERNAM // ', INTEGER work array too short. ' // - $ 'IWORK needs ' // XERN1 // '; have allocated ' // XERN2, - $ 1, 1) - ENDIF -C -C Check the Double Precision workspace situation. - IF( LOCW.GT.LENW ) THEN - IERR = 1 - ERR = D1MACH(2) - XERNAM = NAME - WRITE (XERN1, '(I8)') LOCW - WRITE (XERN2, '(I8)') LENW - CALL XERMSG ('SLATEC', 'DCHKW', - $ 'In ' // XERNAM // ', DOUBLE PRECISION work array too ' // - $ 'short. RWORK needs ' // XERN1 // '; have allocated ' // - $ XERN2, 1, 1) - ENDIF - RETURN -C------------- LAST LINE OF DCHKW FOLLOWS ---------------------------- - END diff --git a/slatec/dchu.f b/slatec/dchu.f deleted file mode 100644 index 217f0b6..0000000 --- a/slatec/dchu.f +++ /dev/null @@ -1,167 +0,0 @@ -*DECK DCHU - DOUBLE PRECISION FUNCTION DCHU (A, B, X) -C***BEGIN PROLOGUE DCHU -C***PURPOSE Compute the logarithmic confluent hypergeometric function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C11 -C***TYPE DOUBLE PRECISION (CHU-S, DCHU-D) -C***KEYWORDS FNLIB, LOGARITHMIC CONFLUENT HYPERGEOMETRIC FUNCTION, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DCHU(A,B,X) calculates the double precision logarithmic confluent -C hypergeometric function U(A,B,X) for double precision arguments -C A, B, and X. -C -C This routine is not valid when 1+A-B is close to zero if X is small. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, D9CHU, DEXPRL, DGAMMA, DGAMR, DPOCH, -C DPOCH1, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770801 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 900727 Added EXTERNAL statement. (WRB) -C***END PROLOGUE DCHU - DOUBLE PRECISION A, B, X, AINTB, ALNX, A0, BEPS, B0, C0, EPS, - 1 FACTOR, GAMRI1, GAMRNI, PCH1AI, PCH1I, PI, POCHAI, SUM, T, - 2 XEPS1, XI, XI1, XN, XTOEPS, D1MACH, DPOCH, DGAMMA, DGAMR, - 3 DPOCH1, DEXPRL, D9CHU - EXTERNAL DGAMMA - SAVE PI, EPS - DATA PI / 3.1415926535 8979323846 2643383279 503 D0 / - DATA EPS / 0.0D0 / -C***FIRST EXECUTABLE STATEMENT DCHU - IF (EPS.EQ.0.0D0) EPS = D1MACH(3) -C - IF (X .EQ. 0.0D0) CALL XERMSG ('SLATEC', 'DCHU', - + 'X IS ZERO SO DCHU IS INFINITE', 1, 2) - IF (X .LT. 0.0D0) CALL XERMSG ('SLATEC', 'DCHU', - + 'X IS NEGATIVE, USE CCHU', 2, 2) -C - IF (MAX(ABS(A),1.0D0)*MAX(ABS(1.0D0+A-B),1.0D0).LT. - 1 0.99D0*ABS(X)) GO TO 120 -C -C THE ASCENDING SERIES WILL BE USED, BECAUSE THE DESCENDING RATIONAL -C APPROXIMATION (WHICH IS BASED ON THE ASYMPTOTIC SERIES) IS UNSTABLE. -C - IF (ABS(1.0D0+A-B) .LT. SQRT(EPS)) CALL XERMSG ('SLATEC', 'DCHU', - + 'ALGORITHMIS BAD WHEN 1+A-B IS NEAR ZERO FOR SMALL X', 10, 2) -C - IF (B.GE.0.0D0) AINTB = AINT(B+0.5D0) - IF (B.LT.0.0D0) AINTB = AINT(B-0.5D0) - BEPS = B - AINTB - N = AINTB -C - ALNX = LOG(X) - XTOEPS = EXP (-BEPS*ALNX) -C -C EVALUATE THE FINITE SUM. ----------------------------------------- -C - IF (N.GE.1) GO TO 40 -C -C CONSIDER THE CASE B .LT. 1.0 FIRST. -C - SUM = 1.0D0 - IF (N.EQ.0) GO TO 30 -C - T = 1.0D0 - M = -N - DO 20 I=1,M - XI1 = I - 1 - T = T*(A+XI1)*X/((B+XI1)*(XI1+1.0D0)) - SUM = SUM + T - 20 CONTINUE -C - 30 SUM = DPOCH(1.0D0+A-B, -A)*SUM - GO TO 70 -C -C NOW CONSIDER THE CASE B .GE. 1.0. -C - 40 SUM = 0.0D0 - M = N - 2 - IF (M.LT.0) GO TO 70 - T = 1.0D0 - SUM = 1.0D0 - IF (M.EQ.0) GO TO 60 -C - DO 50 I=1,M - XI = I - T = T * (A-B+XI)*X/((1.0D0-B+XI)*XI) - SUM = SUM + T - 50 CONTINUE -C - 60 SUM = DGAMMA(B-1.0D0) * DGAMR(A) * X**(1-N) * XTOEPS * SUM -C -C NEXT EVALUATE THE INFINITE SUM. ---------------------------------- -C - 70 ISTRT = 0 - IF (N.LT.1) ISTRT = 1 - N - XI = ISTRT -C - FACTOR = (-1.0D0)**N * DGAMR(1.0D0+A-B) * X**ISTRT - IF (BEPS.NE.0.0D0) FACTOR = FACTOR * BEPS*PI/SIN(BEPS*PI) -C - POCHAI = DPOCH (A, XI) - GAMRI1 = DGAMR (XI+1.0D0) - GAMRNI = DGAMR (AINTB+XI) - B0 = FACTOR * DPOCH(A,XI-BEPS) * GAMRNI * DGAMR(XI+1.0D0-BEPS) -C - IF (ABS(XTOEPS-1.0D0).GT.0.5D0) GO TO 90 -C -C X**(-BEPS) IS CLOSE TO 1.0D0, SO WE MUST BE CAREFUL IN EVALUATING THE -C DIFFERENCES. -C - PCH1AI = DPOCH1 (A+XI, -BEPS) - PCH1I = DPOCH1 (XI+1.0D0-BEPS, BEPS) - C0 = FACTOR * POCHAI * GAMRNI * GAMRI1 * ( - 1 -DPOCH1(B+XI,-BEPS) + PCH1AI - PCH1I + BEPS*PCH1AI*PCH1I) -C -C XEPS1 = (1.0 - X**(-BEPS))/BEPS = (X**(-BEPS) - 1.0)/(-BEPS) - XEPS1 = ALNX*DEXPRL(-BEPS*ALNX) -C - DCHU = SUM + C0 + XEPS1*B0 - XN = N - DO 80 I=1,1000 - XI = ISTRT + I - XI1 = ISTRT + I - 1 - B0 = (A+XI1-BEPS)*B0*X/((XN+XI1)*(XI-BEPS)) - C0 = (A+XI1)*C0*X/((B+XI1)*XI) - 1 - ((A-1.0D0)*(XN+2.D0*XI-1.0D0) + XI*(XI-BEPS)) * B0 - 2 / (XI*(B+XI1)*(A+XI1-BEPS)) - T = C0 + XEPS1*B0 - DCHU = DCHU + T - IF (ABS(T).LT.EPS*ABS(DCHU)) GO TO 130 - 80 CONTINUE - CALL XERMSG ('SLATEC', 'DCHU', - + 'NO CONVERGENCE IN 1000 TERMS OF THE ASCENDING SERIES', 3, 2) -C -C X**(-BEPS) IS VERY DIFFERENT FROM 1.0, SO THE STRAIGHTFORWARD -C FORMULATION IS STABLE. -C - 90 A0 = FACTOR * POCHAI * DGAMR(B+XI) * GAMRI1 / BEPS - B0 = XTOEPS * B0 / BEPS -C - DCHU = SUM + A0 - B0 - DO 100 I=1,1000 - XI = ISTRT + I - XI1 = ISTRT + I - 1 - A0 = (A+XI1)*A0*X/((B+XI1)*XI) - B0 = (A+XI1-BEPS)*B0*X/((AINTB+XI1)*(XI-BEPS)) - T = A0 - B0 - DCHU = DCHU + T - IF (ABS(T).LT.EPS*ABS(DCHU)) GO TO 130 - 100 CONTINUE - CALL XERMSG ('SLATEC', 'DCHU', - + 'NO CONVERGENCE IN 1000 TERMS OF THE ASCENDING SERIES', 3, 2) -C -C USE LUKE-S RATIONAL APPROXIMATION IN THE ASYMPTOTIC REGION. -C - 120 DCHU = X**(-A) * D9CHU(A,B,X) -C - 130 RETURN - END diff --git a/slatec/dchud.f b/slatec/dchud.f deleted file mode 100644 index 021f7a3..0000000 --- a/slatec/dchud.f +++ /dev/null @@ -1,159 +0,0 @@ -*DECK DCHUD - SUBROUTINE DCHUD (R, LDR, P, X, Z, LDZ, NZ, Y, RHO, C, S) -C***BEGIN PROLOGUE DCHUD -C***PURPOSE Update an augmented Cholesky decomposition of the -C triangular part of an augmented QR decomposition. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D7B -C***TYPE DOUBLE PRECISION (SCHUD-S, DCHUD-D, CCHUD-C) -C***KEYWORDS CHOLESKY DECOMPOSITION, LINEAR ALGEBRA, LINPACK, MATRIX, -C UPDATE -C***AUTHOR Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C DCHUD updates an augmented Cholesky decomposition of the -C triangular part of an augmented QR decomposition. Specifically, -C given an upper triangular matrix R of order P, a row vector -C X, a column vector Z, and a scalar Y, DCHUD determines a -C unitary matrix U and a scalar ZETA such that -C -C -C (R Z) (RR ZZ ) -C U * ( ) = ( ) , -C (X Y) ( 0 ZETA) -C -C where RR is upper triangular. If R and Z have been -C obtained from the factorization of a least squares -C problem, then RR and ZZ are the factors corresponding to -C the problem with the observation (X,Y) appended. In this -C case, if RHO is the norm of the residual vector, then the -C norm of the residual vector of the updated problem is -C SQRT(RHO**2 + ZETA**2). DCHUD will simultaneously update -C several triplets (Z,Y,RHO). -C For a less terse description of what DCHUD does and how -C it may be applied, see the LINPACK guide. -C -C The matrix U is determined as the product U(P)*...*U(1), -C where U(I) is a rotation in the (I,P+1) plane of the -C form -C -C ( C(I) S(I) ) -C ( ) . -C ( -S(I) C(I) ) -C -C The rotations are chosen so that C(I) is double precision. -C -C On Entry -C -C R DOUBLE PRECISION(LDR,P), where LDR .GE. P. -C R contains the upper triangular matrix -C that is to be updated. The part of R -C below the diagonal is not referenced. -C -C LDR INTEGER. -C LDR is the leading dimension of the array R. -C -C P INTEGER. -C P is the order of the matrix R. -C -C X DOUBLE PRECISION(P). -C X contains the row to be added to R. X is -C not altered by DCHUD. -C -C Z DOUBLE PRECISION(LDZ,N)Z), where LDZ .GE. P. -C Z is an array containing NZ P-vectors to -C be updated with R. -C -C LDZ INTEGER. -C LDZ is the leading dimension of the array Z. -C -C NZ INTEGER. -C NZ is the number of vectors to be updated -C NZ may be zero, in which case Z, Y, and RHO -C are not referenced. -C -C Y DOUBLE PRECISION(NZ). -C Y contains the scalars for updating the vectors -C Z. Y is not altered by DCHUD. -C -C RHO DOUBLE PRECISION(NZ). -C RHO contains the norms of the residual -C vectors that are to be updated. If RHO(J) -C is negative, it is left unaltered. -C -C On Return -C -C RC -C RHO contain the updated quantities. -C Z -C -C C DOUBLE PRECISION(P). -C C contains the cosines of the transforming -C rotations. -C -C S DOUBLE PRECISION(P). -C S contains the sines of the transforming -C rotations. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DROTG -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DCHUD - INTEGER LDR,P,LDZ,NZ - DOUBLE PRECISION RHO(*),C(*) - DOUBLE PRECISION R(LDR,*),X(*),Z(LDZ,*),Y(*),S(*) -C - INTEGER I,J,JM1 - DOUBLE PRECISION AZETA,SCALE - DOUBLE PRECISION T,XJ,ZETA -C -C UPDATE R. -C -C***FIRST EXECUTABLE STATEMENT DCHUD - DO 30 J = 1, P - XJ = X(J) -C -C APPLY THE PREVIOUS ROTATIONS. -C - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 20 - DO 10 I = 1, JM1 - T = C(I)*R(I,J) + S(I)*XJ - XJ = C(I)*XJ - S(I)*R(I,J) - R(I,J) = T - 10 CONTINUE - 20 CONTINUE -C -C COMPUTE THE NEXT ROTATION. -C - CALL DROTG(R(J,J),XJ,C(J),S(J)) - 30 CONTINUE -C -C IF REQUIRED, UPDATE Z AND RHO. -C - IF (NZ .LT. 1) GO TO 70 - DO 60 J = 1, NZ - ZETA = Y(J) - DO 40 I = 1, P - T = C(I)*Z(I,J) + S(I)*ZETA - ZETA = C(I)*ZETA - S(I)*Z(I,J) - Z(I,J) = T - 40 CONTINUE - AZETA = ABS(ZETA) - IF (AZETA .EQ. 0.0D0 .OR. RHO(J) .LT. 0.0D0) GO TO 50 - SCALE = AZETA + RHO(J) - RHO(J) = SCALE*SQRT((AZETA/SCALE)**2+(RHO(J)/SCALE)**2) - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE - RETURN - END diff --git a/slatec/dckder.f b/slatec/dckder.f deleted file mode 100644 index 3c97601..0000000 --- a/slatec/dckder.f +++ /dev/null @@ -1,159 +0,0 @@ -*DECK DCKDER - SUBROUTINE DCKDER (M, N, X, FVEC, FJAC, LDFJAC, XP, FVECP, MODE, - + ERR) -C***BEGIN PROLOGUE DCKDER -C***PURPOSE Check the gradients of M nonlinear functions in N -C variables, evaluated at a point X, for consistency -C with the functions themselves. -C***LIBRARY SLATEC -C***CATEGORY F3, G4C -C***TYPE DOUBLE PRECISION (CHKDER-S, DCKDER-D) -C***KEYWORDS GRADIENTS, JACOBIAN, MINPACK, NONLINEAR -C***AUTHOR Hiebert, K. L. (SNLA) -C***DESCRIPTION -C -C This subroutine is a companion routine to DNSQ and DNSQE. It may -C be used to check the coding of the Jacobian calculation. -C -C SUBROUTINE DCKDER -C -C This subroutine checks the gradients of M nonlinear functions -C in N variables, evaluated at a point X, for consistency with -C the functions themselves. The user must call DCKDER twice, -C first with MODE = 1 and then with MODE = 2. -C -C MODE = 1. On input, X must contain the point of evaluation. -C On output, XP is set to a neighboring point. -C -C MODE = 2. On input, FVEC must contain the functions and the -C rows of FJAC must contain the gradients -C of the respective functions each evaluated -C at X, and FVECP must contain the functions -C evaluated at XP. -C On output, ERR contains measures of correctness of -C the respective gradients. -C -C The subroutine does not perform reliably if cancellation or -C rounding errors cause a severe loss of significance in the -C evaluation of a function. Therefore, none of the components -C of X should be unusually small (in particular, zero) or any -C other value which may cause loss of significance. -C -C The SUBROUTINE statement is -C -C SUBROUTINE DCKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR) -C -C where -C -C M is a positive integer input variable set to the number -C of functions. -C -C N is a positive integer input variable set to the number -C of variables. -C -C X is an input array of length N. -C -C FVEC is an array of length M. On input when MODE = 2, -C FVEC must contain the functions evaluated at X. -C -C FJAC is an M by N array. On input when MODE = 2, -C the rows of FJAC must contain the gradients of -C the respective functions evaluated at X. -C -C LDFJAC is a positive integer input parameter not less than M -C which specifies the leading dimension of the array FJAC. -C -C XP is an array of length N. On output when MODE = 1, -C XP is set to a neighboring point of X. -C -C FVECP is an array of length M. On input when MODE = 2, -C FVECP must contain the functions evaluated at XP. -C -C MODE is an integer input variable set to 1 on the first call -C and 2 on the second. Other values of MODE are equivalent -C to MODE = 1. -C -C ERR is an array of length M. On output when MODE = 2, -C ERR contains measures of correctness of the respective -C gradients. If there is no severe loss of significance, -C then if ERR(I) is 1.0 the I-th gradient is correct, -C while if ERR(I) is 0.0 the I-th gradient is incorrect. -C For values of ERR between 0.0 and 1.0, the categorization -C is less certain. In general, a value of ERR(I) greater -C than 0.5 indicates that the I-th gradient is probably -C correct, while a value of ERR(I) less than 0.5 indicates -C that the I-th gradient is probably incorrect. -C -C***REFERENCES M. J. D. Powell, A hybrid method for nonlinear equa- -C tions. In Numerical Methods for Nonlinear Algebraic -C Equations, P. Rabinowitz, Editor. Gordon and Breach, -C 1988. -C***ROUTINES CALLED D1MACH -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DCKDER - INTEGER I, J, LDFJAC, M, MODE, N - DOUBLE PRECISION D1MACH, EPS, EPSF, EPSLOG, EPSMCH, ERR(*), - 1 FACTOR, FJAC(LDFJAC,*), FVEC(*), FVECP(*), ONE, TEMP, X(*), - 2 XP(*), ZERO - SAVE FACTOR, ONE, ZERO - DATA FACTOR,ONE,ZERO /1.0D2,1.0D0,0.0D0/ -C -C EPSMCH IS THE MACHINE PRECISION. -C -C***FIRST EXECUTABLE STATEMENT DCKDER - EPSMCH = D1MACH(4) -C - EPS = SQRT(EPSMCH) -C - IF (MODE .EQ. 2) GO TO 20 -C -C MODE = 1. -C - DO 10 J = 1, N - TEMP = EPS*ABS(X(J)) - IF (TEMP .EQ. ZERO) TEMP = EPS - XP(J) = X(J) + TEMP - 10 CONTINUE - GO TO 70 - 20 CONTINUE -C -C MODE = 2. -C - EPSF = FACTOR*EPSMCH - EPSLOG = LOG10(EPS) - DO 30 I = 1, M - ERR(I) = ZERO - 30 CONTINUE - DO 50 J = 1, N - TEMP = ABS(X(J)) - IF (TEMP .EQ. ZERO) TEMP = ONE - DO 40 I = 1, M - ERR(I) = ERR(I) + TEMP*FJAC(I,J) - 40 CONTINUE - 50 CONTINUE - DO 60 I = 1, M - TEMP = ONE - IF (FVEC(I) .NE. ZERO .AND. FVECP(I) .NE. ZERO - 1 .AND. ABS(FVECP(I)-FVEC(I)) .GE. EPSF*ABS(FVEC(I))) - 2 TEMP = EPS*ABS((FVECP(I)-FVEC(I))/EPS-ERR(I)) - 3 /(ABS(FVEC(I)) + ABS(FVECP(I))) - ERR(I) = ONE - IF (TEMP .GT. EPSMCH .AND. TEMP .LT. EPS) - 1 ERR(I) = (LOG10(TEMP) - EPSLOG)/EPSLOG - IF (TEMP .GE. EPS) ERR(I) = ZERO - 60 CONTINUE - 70 CONTINUE -C - RETURN -C -C LAST CARD OF SUBROUTINE DCKDER. -C - END diff --git a/slatec/dcoef.f b/slatec/dcoef.f deleted file mode 100644 index a34c6a7..0000000 --- a/slatec/dcoef.f +++ /dev/null @@ -1,197 +0,0 @@ -*DECK DCOEF - SUBROUTINE DCOEF (YH, YP, NCOMP, NROWB, NFC, NIC, B, BETA, COEF, - + INHOMO, RE, AE, BY, CVEC, WORK, IWORK, IFLAG, NFCC) -C***BEGIN PROLOGUE DCOEF -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBVSUP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (SCOEF-S, DCOEF-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C ********************************************************************** -C INPUT to DCOEF -C ********************************************************************** -C -C YH = matrix of homogeneous solutions. -C YP = vector containing particular solution. -C NCOMP = number of components per solution vector. -C NROWB = first dimension of B in calling program. -C NFC = number of base solution vectors. -C NFCC = 2*NFC for the special treatment of COMPLEX*16 valued -C equations. Otherwise, NFCC=NFC. -C NIC = number of specified initial conditions. -C B = boundary condition matrix at X = XFINAL. -C BETA = vector of nonhomogeneous boundary conditions at X = XFINAL. -C 1 - nonzero particular solution -C INHOMO = 2 - zero particular solution -C 3 - eigenvalue problem -C RE = relative error tolerance. -C AE = absolute error tolerance. -C BY = storage space for the matrix B*YH -C CVEC = storage space for the vector BETA-B*YP -C WORK = double precision array of internal storage. Dimension must -C be GE -C NFCC*(NFCC+4) -C IWORK = integer array of internal storage. Dimension must be GE -C 3+NFCC -C -C ********************************************************************** -C OUTPUT from DCOEF -C ********************************************************************** -C -C COEF = array containing superposition constants. -C IFLAG = indicator of success from DSUDS in solving the -C boundary equations. -C = 0 boundary equations are solved. -C = 1 boundary equations appear to have many solutions. -C = 2 boundary equations appear to be inconsistent. -C = 3 for this value of an eigenparameter, the boundary -C equations have only the zero solution. -C -C ********************************************************************** -C -C Subroutine DCOEF solves for the superposition constants from the -C linear equations defined by the boundary conditions at X = XFINAL. -C -C B*YP + B*YH*COEF = BETA -C -C ********************************************************************** -C -C***SEE ALSO DBVSUP -C***ROUTINES CALLED DDOT, DSUDS, XGETF, XSETF -C***COMMON BLOCKS DML5MC -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 890921 Realigned order of variables in certain COMMON blocks. -C (WRB) -C 890921 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DCOEF -C - DOUBLE PRECISION DDOT - INTEGER I, IFLAG, INHOMO, IWORK(*), J, K, KFLAG, KI, L, LPAR, - 1 MLSO, NCOMP, NCOMP2, NF, NFC, NFCC, NFCCM1, NIC, - 2 NROWB - DOUBLE PRECISION AE, B(NROWB,*), BBN, BETA(*), BN, BRN, - 1 BY(NFCC,*), BYKL, BYS, COEF(*), CONS, CVEC(*), EPS, - 2 FOURU, GAM, RE, SQOVFL, SRU, TWOU, UN, URO, WORK(*), - 3 YH(NCOMP,*), YP(*), YPN -C - COMMON /DML5MC/ URO,SRU,EPS,SQOVFL,TWOU,FOURU,LPAR -C***FIRST EXECUTABLE STATEMENT DCOEF -C -C SET UP MATRIX B*YH AND VECTOR BETA - B*YP -C - NCOMP2 = NCOMP/2 - DO 80 K = 1, NFCC - DO 10 J = 1, NFC - L = J - IF (NFC .NE. NFCC) L = 2*J - 1 - BY(K,L) = DDOT(NCOMP,B(K,1),NROWB,YH(1,J),1) - 10 CONTINUE - IF (NFC .EQ. NFCC) GO TO 30 - DO 20 J = 1, NFC - L = 2*J - BYKL = DDOT(NCOMP2,B(K,1),NROWB,YH(NCOMP2+1,J),1) - BY(K,L) = DDOT(NCOMP2,B(K,NCOMP2+1),NROWB,YH(1,J),1) - 1 - BYKL - 20 CONTINUE - 30 CONTINUE - GO TO (40,50,60), INHOMO -C CASE 1 - 40 CONTINUE - CVEC(K) = BETA(K) - DDOT(NCOMP,B(K,1),NROWB,YP,1) - GO TO 70 -C CASE 2 - 50 CONTINUE - CVEC(K) = BETA(K) - GO TO 70 -C CASE 3 - 60 CONTINUE - CVEC(K) = 0.0D0 - 70 CONTINUE - 80 CONTINUE - CONS = ABS(CVEC(1)) - BYS = ABS(BY(1,1)) -C -C ****************************************************************** -C SOLVE LINEAR SYSTEM -C - IFLAG = 0 - MLSO = 0 - IF (INHOMO .EQ. 3) MLSO = 1 - KFLAG = 0.5D0 * LOG10(EPS) - CALL XGETF(NF) - CALL XSETF(0) - 90 CONTINUE - CALL DSUDS(BY,COEF,CVEC,NFCC,NFCC,NFCC,KFLAG,MLSO,WORK,IWORK) - IF (KFLAG .NE. 3) GO TO 100 - KFLAG = 1 - IFLAG = 1 - GO TO 90 - 100 CONTINUE - IF (KFLAG .EQ. 4) IFLAG = 2 - CALL XSETF(NF) - IF (NFCC .EQ. 1) GO TO 180 - IF (INHOMO .NE. 3) GO TO 170 - IF (IWORK(1) .LT. NFCC) GO TO 140 - IFLAG = 3 - DO 110 K = 1, NFCC - COEF(K) = 0.0D0 - 110 CONTINUE - COEF(NFCC) = 1.0D0 - NFCCM1 = NFCC - 1 - DO 130 K = 1, NFCCM1 - J = NFCC - K - L = NFCC - J + 1 - GAM = DDOT(L,BY(J,J),NFCC,COEF(J),1)/(WORK(J)*BY(J,J)) - DO 120 I = J, NFCC - COEF(I) = COEF(I) + GAM*BY(J,I) - 120 CONTINUE - 130 CONTINUE - GO TO 160 - 140 CONTINUE - DO 150 K = 1, NFCC - KI = 4*NFCC + K - COEF(K) = WORK(KI) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE - GO TO 220 - 180 CONTINUE -C -C *************************************************************** -C TESTING FOR EXISTENCE AND UNIQUENESS OF BOUNDARY-VALUE -C PROBLEM SOLUTION IN A SCALAR CASE -C - BN = 0.0D0 - UN = 0.0D0 - YPN = 0.0D0 - DO 190 K = 1, NCOMP - UN = MAX(UN,ABS(YH(K,1))) - YPN = MAX(YPN,ABS(YP(K))) - BN = MAX(BN,ABS(B(1,K))) - 190 CONTINUE - BBN = MAX(BN,ABS(BETA(1))) - IF (BYS .GT. 10.0D0*(RE*UN + AE)*BN) GO TO 200 - BRN = BBN/BN*BYS - IF (CONS .GE. 0.1D0*BRN .AND. CONS .LE. 10.0D0*BRN) - 1 IFLAG = 1 - IF (CONS .GT. 10.0D0*BRN) IFLAG = 2 - IF (CONS .LE. RE*ABS(BETA(1)) + AE + (RE*YPN + AE)*BN) - 1 IFLAG = 1 - IF (INHOMO .EQ. 3) COEF(1) = 1.0D0 - GO TO 210 - 200 CONTINUE - IF (INHOMO .NE. 3) GO TO 210 - IFLAG = 3 - COEF(1) = 1.0D0 - 210 CONTINUE - 220 CONTINUE - RETURN - END diff --git a/slatec/dcopy.f b/slatec/dcopy.f deleted file mode 100644 index 7d628fd..0000000 --- a/slatec/dcopy.f +++ /dev/null @@ -1,93 +0,0 @@ -*DECK DCOPY - SUBROUTINE DCOPY (N, DX, INCX, DY, INCY) -C***BEGIN PROLOGUE DCOPY -C***PURPOSE Copy a vector. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A5 -C***TYPE DOUBLE PRECISION (SCOPY-S, DCOPY-D, CCOPY-C, ICOPY-I) -C***KEYWORDS BLAS, COPY, 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 DX double precision vector with N elements -C INCX storage spacing between elements of DX -C DY double precision vector with N elements -C INCY storage spacing between elements of DY -C -C --Output-- -C DY copy of vector DX (unchanged if N .LE. 0) -C -C Copy double precision DX to double precision DY. -C For I = 0 to N-1, copy DX(LX+I*INCX) to DY(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 DCOPY - DOUBLE PRECISION DX(*), DY(*) -C***FIRST EXECUTABLE STATEMENT DCOPY - IF (N .LE. 0) RETURN - IF (INCX .EQ. INCY) IF (INCX-1) 5,20,60 -C -C Code for unequal or nonpositive increments. -C - 5 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 Clean-up loop so remaining vector length is a multiple of 7. -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 -C -C Code for equal, positive, non-unit increments. -C - 60 NS = N*INCX - DO 70 I = 1,NS,INCX - DY(I) = DX(I) - 70 CONTINUE - RETURN - END diff --git a/slatec/dcopym.f b/slatec/dcopym.f deleted file mode 100644 index b0cae7a..0000000 --- a/slatec/dcopym.f +++ /dev/null @@ -1,83 +0,0 @@ -*DECK DCOPYM - SUBROUTINE DCOPYM (N, DX, INCX, DY, INCY) -C***BEGIN PROLOGUE DCOPYM -C***PURPOSE Copy the negative of a vector to a vector. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A5 -C***TYPE DOUBLE PRECISION (SCOPYM-S, DCOPYM-D) -C***KEYWORDS BLAS, COPY, VECTOR -C***AUTHOR Kahaner, D. K., (NBS) -C***DESCRIPTION -C -C Description of Parameters -C The * Flags Output Variables -C -C N Number of elements in vector(s) -C DX Double precision vector with N elements -C INCX Storage spacing between elements of DX -C DY* Double precision negative copy of DX -C INCY Storage spacing between elements of DY -C -C *** Note that DY = -DX *** -C -C Copy negative of d.p. DX to d.p. DY. For I=0 to N-1, -C copy -DX(LX+I*INCX) to DY(LY+I*INCY), where LX=1 if -C INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is defined -C in a similar way using INCY. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 861211 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***END PROLOGUE DCOPYM - DOUBLE PRECISION DX(*), DY(*) -C***FIRST EXECUTABLE STATEMENT DCOPYM - IF (N .LE. 0) RETURN - IF (INCX .EQ. INCY) IF (INCX-1) 5,20,60 -C -C Code for unequal or nonpositive increments. -C - 5 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 Clean-up loop so remaining vector length is a multiple of 7. -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 -C -C Code for equal, positive, non-unit increments. -C - 60 NS = N*INCX - DO 70 I = 1,NS,INCX - DY(I) = -DX(I) - 70 CONTINUE - RETURN - END diff --git a/slatec/dcosdg.f b/slatec/dcosdg.f deleted file mode 100644 index 04e9281..0000000 --- a/slatec/dcosdg.f +++ /dev/null @@ -1,37 +0,0 @@ -*DECK DCOSDG - DOUBLE PRECISION FUNCTION DCOSDG (X) -C***BEGIN PROLOGUE DCOSDG -C***PURPOSE Compute the cosine of an argument in degrees. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4A -C***TYPE DOUBLE PRECISION (COSDG-S, DCOSDG-D) -C***KEYWORDS COSINE, DEGREES, ELEMENTARY FUNCTIONS, FNLIB, -C TRIGONOMETRIC -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DCOSDG(X) calculates the double precision trigonometric cosine -C for double precision argument X in units of degrees. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 770601 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***END PROLOGUE DCOSDG - DOUBLE PRECISION X, RADDEG - SAVE RADDEG - DATA RADDEG / 0.0174532925 1994329576 9236907684 886 D0 / -C***FIRST EXECUTABLE STATEMENT DCOSDG - DCOSDG = COS (RADDEG*X) -C - IF (MOD(X,90.D0).NE.0.D0) RETURN - N = ABS(X)/90.D0 + 0.5D0 - N = MOD (N, 2) - IF (N.EQ.0) DCOSDG = SIGN (1.0D0, DCOSDG) - IF (N.EQ.1) DCOSDG = 0.0D0 -C - RETURN - END diff --git a/slatec/dcot.f b/slatec/dcot.f deleted file mode 100644 index 8313340..0000000 --- a/slatec/dcot.f +++ /dev/null @@ -1,108 +0,0 @@ -*DECK DCOT - DOUBLE PRECISION FUNCTION DCOT (X) -C***BEGIN PROLOGUE DCOT -C***PURPOSE Compute the cotangent. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4A -C***TYPE DOUBLE PRECISION (COT-S, DCOT-D, CCOT-C) -C***KEYWORDS COTANGENT, ELEMENTARY FUNCTIONS, FNLIB, TRIGONOMETRIC -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DCOT(X) calculates the double precision trigonometric cotangent -C for double precision argument X. X is in units of radians. -C -C Series for COT on the interval 0. to 6.25000E-02 -C with weighted error 5.52E-34 -C log weighted error 33.26 -C significant figures required 32.34 -C decimal places required 33.85 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 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 920618 Removed space from variable names. (RWC, WRB) -C***END PROLOGUE DCOT - DOUBLE PRECISION X, COTCS(15), AINTY, AINTY2, PI2REC, SQEPS, - 1 XMAX, XMIN, XSML, Y, YREM, PRODBG, DCSEVL, D1MACH - LOGICAL FIRST - SAVE COTCS, PI2REC, NTERMS, XMAX, XSML, XMIN, SQEPS, FIRST - DATA COTCS( 1) / +.2402591609 8295630250 9553617744 970 D+0 / - DATA COTCS( 2) / -.1653303160 1500227845 4746025255 758 D-1 / - DATA COTCS( 3) / -.4299839193 1724018935 6476228239 895 D-4 / - DATA COTCS( 4) / -.1592832233 2754104602 3490851122 445 D-6 / - DATA COTCS( 5) / -.6191093135 1293487258 8620579343 187 D-9 / - DATA COTCS( 6) / -.2430197415 0726460433 1702590579 575 D-11 / - DATA COTCS( 7) / -.9560936758 8000809842 7062083100 000 D-14 / - DATA COTCS( 8) / -.3763537981 9458058041 6291539706 666 D-16 / - DATA COTCS( 9) / -.1481665746 4674657885 2176794666 666 D-18 / - DATA COTCS( 10) / -.5833356589 0366657947 7984000000 000 D-21 / - DATA COTCS( 11) / -.2296626469 6464577392 8533333333 333 D-23 / - DATA COTCS( 12) / -.9041970573 0748332671 9999999999 999 D-26 / - DATA COTCS( 13) / -.3559885519 2060006400 0000000000 000 D-28 / - DATA COTCS( 14) / -.1401551398 2429866666 6666666666 666 D-30 / - DATA COTCS( 15) / -.5518004368 7253333333 3333333333 333 D-33 / - DATA PI2REC / .01161977236 7581343075 5350534900 57 D0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DCOT - IF (FIRST) THEN - NTERMS = INITDS (COTCS, 15, 0.1*REAL(D1MACH(3)) ) - XMAX = 1.0D0/D1MACH(4) - XSML = SQRT(3.0D0*D1MACH(3)) - XMIN = EXP (MAX(LOG(D1MACH(1)), -LOG(D1MACH(2))) + 0.01D0) - SQEPS = SQRT(D1MACH(4)) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y .LT. XMIN) CALL XERMSG ('SLATEC', 'DCOT', - + 'ABS(X) IS ZERO OR SO SMALL DCOT OVERFLOWS', 2, 2) - IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'DCOT', - + 'NO PRECISION BECAUSE ABS(X) IS TOO BIG', 3, 2) -C -C CAREFULLY COMPUTE Y * (2/PI) = (AINT(Y) + REM(Y)) * (.625 + PI2REC) -C = AINT(.625*Y) + REM(.625*Y) + Y*PI2REC = AINT(.625*Y) + Z -C = AINT(.625*Y) + AINT(Z) + REM(Z) -C - AINTY = AINT (Y) - YREM = Y - AINTY - PRODBG = 0.625D0*AINTY - AINTY = AINT (PRODBG) - Y = (PRODBG-AINTY) + 0.625D0*YREM + PI2REC*Y - AINTY2 = AINT (Y) - AINTY = AINTY + AINTY2 - Y = Y - AINTY2 -C - IFN = MOD (AINTY, 2.0D0) - IF (IFN.EQ.1) Y = 1.0D0 - Y -C - IF (ABS(X) .GT. 0.5D0 .AND. Y .LT. ABS(X)*SQEPS) CALL XERMSG - + ('SLATEC', 'DCOT', - + 'ANSWER LT HALF PRECISION, ABS(X) TOO BIG OR X NEAR N*PI ' // - + '(N.NE.0)', 1, 1) -C - IF (Y.GT.0.25D0) GO TO 20 - DCOT = 1.0D0/X - IF (Y.GT.XSML) DCOT = (0.5D0 + DCSEVL (32.0D0*Y*Y-1.D0, COTCS, - 1 NTERMS)) / Y - GO TO 40 -C - 20 IF (Y.GT.0.5D0) GO TO 30 - DCOT = (0.5D0 + DCSEVL (8.D0*Y*Y-1.D0, COTCS, NTERMS))/(0.5D0*Y) - DCOT = (DCOT*DCOT-1.D0)*0.5D0/DCOT - GO TO 40 -C - 30 DCOT = (0.5D0 + DCSEVL (2.D0*Y*Y-1.D0, COTCS, NTERMS))/(.25D0*Y) - DCOT = (DCOT*DCOT-1.D0)*0.5D0/DCOT - DCOT = (DCOT*DCOT-1.D0)*0.5D0/DCOT -C - 40 IF (X.NE.0.D0) DCOT = SIGN (DCOT, X) - IF (IFN.EQ.1) DCOT = -DCOT -C - RETURN - END diff --git a/slatec/dcov.f b/slatec/dcov.f deleted file mode 100644 index ee7e34f..0000000 --- a/slatec/dcov.f +++ /dev/null @@ -1,273 +0,0 @@ -*DECK DCOV - SUBROUTINE DCOV (FCN, IOPT, M, N, X, FVEC, R, LDR, INFO, WA1, WA2, - + WA3, WA4) -C***BEGIN PROLOGUE DCOV -C***PURPOSE Calculate the covariance matrix for a nonlinear data -C fitting problem. It is intended to be used after a -C successful return from either DNLS1 or DNLS1E. -C***LIBRARY SLATEC -C***CATEGORY K1B1 -C***TYPE DOUBLE PRECISION (SCOV-S, DCOV-D) -C***KEYWORDS COVARIANCE MATRIX, NONLINEAR DATA FITTING, -C NONLINEAR LEAST SQUARES -C***AUTHOR Hiebert, K. L., (SNLA) -C***DESCRIPTION -C -C 1. Purpose. -C -C DCOV calculates the covariance matrix for a nonlinear data -C fitting problem. It is intended to be used after a -C successful return from either DNLS1 or DNLS1E. DCOV -C and DNLS1 (and DNLS1E) have compatible parameters. The -C required external subroutine, FCN, is the same -C for all three codes, DCOV, DNLS1, and DNLS1E. -C -C 2. Subroutine and Type Statements. -C -C SUBROUTINE DCOV(FCN,IOPT,M,N,X,FVEC,R,LDR,INFO, -C WA1,WA2,WA3,WA4) -C INTEGER IOPT,M,N,LDR,INFO -C DOUBLE PRECISION X(N),FVEC(M),R(LDR,N),WA1(N),WA2(N),WA3(N),WA4(M) -C EXTERNAL FCN -C -C 3. Parameters. All TYPE REAL parameters are DOUBLE PRECISION -C -C FCN is the name of the user-supplied subroutine which calculates -C the functions. If the user wants to supply the Jacobian -C (IOPT=2 or 3), then FCN must be written to calculate the -C Jacobian, as well as the functions. See the explanation -C of the IOPT argument below. -C If the user wants the iterates printed in DNLS1 or DNLS1E, -C then FCN must do the printing. See the explanation of NPRINT -C in DNLS1 or DNLS1E. FCN must be declared in an EXTERNAL -C statement in the calling program and should be written as -C follows. -C -C SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) -C INTEGER IFLAG,LDFJAC,M,N -C DOUBLE PRECISION X(N),FVEC(M) -C ---------- -C FJAC and LDFJAC may be ignored , if IOPT=1. -C DOUBLE PRECISION FJAC(LDFJAC,N) , if IOPT=2. -C DOUBLE PRECISION FJAC(N) , if IOPT=3. -C ---------- -C If IFLAG=0, the values in X and FVEC are available -C for printing in DNLS1 or DNLS1E. -C IFLAG will never be zero when FCN is called by DCOV. -C The values of X and FVEC must not be changed. -C RETURN -C ---------- -C If IFLAG=1, calculate the functions at X and return -C this vector in FVEC. -C RETURN -C ---------- -C If IFLAG=2, calculate the full Jacobian at X and return -C this matrix in FJAC. Note that IFLAG will never be 2 unless -C IOPT=2. FVEC contains the function values at X and must -C not be altered. FJAC(I,J) must be set to the derivative -C of FVEC(I) with respect to X(J). -C RETURN -C ---------- -C If IFLAG=3, calculate the LDFJAC-th row of the Jacobian -C and return this vector in FJAC. Note that IFLAG will -C never be 3 unless IOPT=3. FJAC(J) must be set to -C the derivative of FVEC(LDFJAC) with respect to X(J). -C RETURN -C ---------- -C END -C -C -C The value of IFLAG should not be changed by FCN unless the -C user wants to terminate execution of DCOV. In this case, set -C IFLAG to a negative integer. -C -C -C IOPT is an input variable which specifies how the Jacobian will -C be calculated. If IOPT=2 or 3, then the user must supply the -C Jacobian, as well as the function values, through the -C subroutine FCN. If IOPT=2, the user supplies the full -C Jacobian with one call to FCN. If IOPT=3, the user supplies -C one row of the Jacobian with each call. (In this manner, -C storage can be saved because the full Jacobian is not stored.) -C If IOPT=1, the code will approximate the Jacobian by forward -C differencing. -C -C M is a positive integer input variable set to the number of -C functions. -C -C N is a positive integer input variable set to the number of -C variables. N must not exceed M. -C -C X is an array of length N. On input X must contain the value -C at which the covariance matrix is to be evaluated. This is -C usually the value for X returned from a successful run of -C DNLS1 (or DNLS1E). The value of X will not be changed. -C -C FVEC is an output array of length M which contains the functions -C evaluated at X. -C -C R is an output array. For IOPT=1 and 2, R is an M by N array. -C For IOPT=3, R is an N by N array. On output, if INFO=1, -C the upper N by N submatrix of R contains the covariance -C matrix evaluated at X. -C -C LDR is a positive integer input variable which specifies -C the leading dimension of the array R. For IOPT=1 and 2, -C LDR must not be less than M. For IOPT=3, LDR must not -C be less than N. -C -C INFO is an integer output variable. If the user has terminated -C execution, INFO is set to the (negative) value of IFLAG. See -C description of FCN. Otherwise, INFO is set as follows. -C -C INFO = 0 Improper input parameters (M.LE.0 or N.LE.0). -C -C INFO = 1 Successful return. The covariance matrix has been -C calculated and stored in the upper N by N -C submatrix of R. -C -C INFO = 2 The Jacobian matrix is singular for the input value -C of X. The covariance matrix cannot be calculated. -C The upper N by N submatrix of R contains the QR -C factorization of the Jacobian (probably not of -C interest to the user). -C -C WA1,WA2 are work arrays of length N. -C and WA3 -C -C WA4 is a work array of length M. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED DENORM, DFDJC3, DQRFAC, DWUPDT, XERMSG -C***REVISION HISTORY (YYMMDD) -C 810522 DATE WRITTEN -C 890831 Modified array declarations. (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 Fixed an error message. (RWC) -C***END PROLOGUE DCOV -C -C REVISED 850601-1100 -C REVISED YYMMDD HHMM -C - INTEGER I,IDUM,IFLAG,INFO,IOPT,J,K,KP1,LDR,M,N,NM1,NROW - DOUBLE PRECISION X(*),R(LDR,*),FVEC(*),WA1(*),WA2(*),WA3(*), - 1 WA4(*) - EXTERNAL FCN - DOUBLE PRECISION ONE,SIGMA,TEMP,ZERO,DENORM - LOGICAL SING - SAVE ZERO, ONE - DATA ZERO/0.D0/,ONE/1.D0/ -C***FIRST EXECUTABLE STATEMENT DCOV - SING=.FALSE. - IFLAG=0 - IF (M.LE.0 .OR. N.LE.0) GO TO 300 -C -C CALCULATE SIGMA = (SUM OF THE SQUARED RESIDUALS) / (M-N) - IFLAG=1 - CALL FCN(IFLAG,M,N,X,FVEC,R,LDR) - IF (IFLAG.LT.0) GO TO 300 - TEMP=DENORM(M,FVEC) - SIGMA=ONE - IF (M.NE.N) SIGMA=TEMP*TEMP/(M-N) -C -C CALCULATE THE JACOBIAN - IF (IOPT.EQ.3) GO TO 200 -C -C STORE THE FULL JACOBIAN USING M*N STORAGE - IF (IOPT.EQ.1) GO TO 100 -C -C USER SUPPLIES THE JACOBIAN - IFLAG=2 - CALL FCN(IFLAG,M,N,X,FVEC,R,LDR) - GO TO 110 -C -C CODE APPROXIMATES THE JACOBIAN -100 CALL DFDJC3(FCN,M,N,X,FVEC,R,LDR,IFLAG,ZERO,WA4) -110 IF (IFLAG.LT.0) GO TO 300 -C -C COMPUTE THE QR DECOMPOSITION - CALL DQRFAC(M,N,R,LDR,.FALSE.,IDUM,1,WA1,WA1,WA1) - DO 120 I=1,N -120 R(I,I)=WA1(I) - GO TO 225 -C -C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN MATRIX CALCULATED ONE -C ROW AT A TIME AND STORED IN THE UPPER TRIANGLE OF R. -C ( (Q TRANSPOSE)*FVEC IS ALSO CALCULATED BUT NOT USED.) -200 CONTINUE - DO 210 J=1,N - WA2(J)=ZERO - DO 205 I=1,N - R(I,J)=ZERO -205 CONTINUE -210 CONTINUE - IFLAG=3 - DO 220 I=1,M - NROW = I - CALL FCN(IFLAG,M,N,X,FVEC,WA1,NROW) - IF (IFLAG.LT.0) GO TO 300 - TEMP=FVEC(I) - CALL DWUPDT(N,R,LDR,WA1,WA2,TEMP,WA3,WA4) -220 CONTINUE -C -C CHECK IF R IS SINGULAR. -225 CONTINUE - DO 230 I=1,N - IF (R(I,I).EQ.ZERO) SING=.TRUE. -230 CONTINUE - IF (SING) GO TO 300 -C -C R IS UPPER TRIANGULAR. CALCULATE (R TRANSPOSE) INVERSE AND STORE -C IN THE UPPER TRIANGLE OF R. - IF (N.EQ.1) GO TO 275 - NM1=N-1 - DO 270 K=1,NM1 -C -C INITIALIZE THE RIGHT-HAND SIDE (WA1(*)) AS THE K-TH COLUMN OF THE -C IDENTITY MATRIX. - DO 240 I=1,N - WA1(I)=ZERO -240 CONTINUE - WA1(K)=ONE -C - R(K,K)=WA1(K)/R(K,K) - KP1=K+1 - DO 260 I=KP1,N -C -C SUBTRACT R(K,I-1)*R(I-1,*) FROM THE RIGHT-HAND SIDE, WA1(*). - DO 250 J=I,N - WA1(J)=WA1(J)-R(K,I-1)*R(I-1,J) -250 CONTINUE - R(K,I)=WA1(I)/R(I,I) -260 CONTINUE -270 CONTINUE -275 R(N,N)=ONE/R(N,N) -C -C CALCULATE R-INVERSE * (R TRANSPOSE) INVERSE AND STORE IN THE UPPER -C TRIANGLE OF R. - DO 290 I=1,N - DO 290 J=I,N - TEMP=ZERO - DO 280 K=J,N - TEMP=TEMP+R(I,K)*R(J,K) -280 CONTINUE - R(I,J)=TEMP*SIGMA -290 CONTINUE - INFO=1 -C -300 CONTINUE - IF (M.LE.0 .OR. N.LE.0) INFO=0 - IF (IFLAG.LT.0) INFO=IFLAG - IF (SING) INFO=2 - IF (INFO .LT. 0) CALL XERMSG ('SLATEC', 'DCOV', - + 'EXECUTION TERMINATED BECAUSE USER SET IFLAG NEGATIVE.', 1, 1) - IF (INFO .EQ. 0) CALL XERMSG ('SLATEC', 'DCOV', - + 'INVALID INPUT PARAMETER.', 2, 1) - IF (INFO .EQ. 2) CALL XERMSG ('SLATEC', 'DCOV', - + 'SINGULAR JACOBIAN MATRIX, COVARIANCE MATRIX CANNOT BE ' // - + 'CALCULATED.', 1, 1) - RETURN - END diff --git a/slatec/dcpplt.f b/slatec/dcpplt.f deleted file mode 100644 index fcbbb3b..0000000 --- a/slatec/dcpplt.f +++ /dev/null @@ -1,198 +0,0 @@ -*DECK DCPPLT - SUBROUTINE DCPPLT (N, NELT, IA, JA, A, ISYM, IUNIT) -C***BEGIN PROLOGUE DCPPLT -C***PURPOSE Printer Plot of SLAP Column Format Matrix. -C Routine to print out a SLAP Column format matrix in a -C "printer plot" graphical representation. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY N1 -C***TYPE DOUBLE PRECISION (SCPPLT-S, DCPPLT-D) -C***KEYWORDS DIAGNOSTICS, LINEAR SYSTEM, SLAP SPARSE -C***AUTHOR Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, IUNIT -C DOUBLE PRECISION A(NELT) -C -C CALL DCPPLT( N, NELT, IA, JA, A, ISYM, IUNIT ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C If N.gt.MAXORD, only the leading MAXORD x MAXORD -C submatrix will be printed. (Currently MAXORD = 225.) -C NELT :IN Integer. -C Number of non-zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Double Precision A(NELT). -C These arrays should hold the matrix A in the SLAP -C Column format. See "Description", below. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the lower -C triangle of the matrix is stored. -C IUNIT :IN Integer. -C Fortran logical I/O device unit number to write the matrix -C to. This unit must be connected in a system dependent fashion -C to a file or the console or you will get a nasty message -C from the Fortran I/O libraries. -C -C *Description: -C This routine prints out a SLAP Column format matrix to the -C Fortran logical I/O unit number IUNIT. The numbers them -C selves are not printed out, but rather a one character -C representation of the numbers. Elements of the matrix that -C are not represented in the (IA,JA,A) arrays are denoted by -C ' ' character (a blank). Elements of A that are *ZERO* (and -C hence should really not be stored) are denoted by a '0' -C character. Elements of A that are *POSITIVE* are denoted by -C 'D' if they are Diagonal elements and '#' if they are off -C Diagonal elements. Elements of A that are *NEGATIVE* are -C denoted by 'N' if they are Diagonal elements and '*' if -C they are off Diagonal elements. -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C *Portability: -C This routine, as distributed, can generate lines up to 229 -C characters long. Some Fortran systems have more restricted -C line lengths. Change parameter MAXORD and the large number -C in FORMAT 1010 to reduce this line length. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 921007 Replaced hard-wired 225 with parameter MAXORD. (FNF) -C 921021 Corrected syntax of CHARACTER declaration. (FNF) -C 921026 Corrected D to E in output format. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE DCPPLT -C .. Scalar Arguments .. - INTEGER ISYM, IUNIT, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT) - INTEGER IA(NELT), JA(NELT) -C .. Parameters .. - INTEGER MAXORD - PARAMETER (MAXORD=225) -C .. Local Scalars .. - INTEGER I, ICOL, IROW, J, JBGN, JEND, NMAX -C .. Local Arrays .. - CHARACTER CHMAT(MAXORD)*(MAXORD) -C .. Intrinsic Functions .. - INTRINSIC MIN, MOD, REAL -C***FIRST EXECUTABLE STATEMENT DCPPLT -C -C Set up the character matrix... -C - NMAX = MIN( MAXORD, N ) - DO 10 I = 1, NMAX - CHMAT(I)(1:NMAX) = ' ' - 10 CONTINUE - DO 30 ICOL = 1, NMAX - JBGN = JA(ICOL) - JEND = JA(ICOL+1)-1 - DO 20 J = JBGN, JEND - IROW = IA(J) - IF( IROW.LE.NMAX ) THEN - IF( ISYM.NE.0 ) THEN -C Put in non-sym part as well... - IF( A(J).EQ.0.0D0 ) THEN - CHMAT(IROW)(ICOL:ICOL) = '0' - ELSEIF( A(J).GT.0.0D0 ) THEN - CHMAT(IROW)(ICOL:ICOL) = '#' - ELSE - CHMAT(IROW)(ICOL:ICOL) = '*' - ENDIF - ENDIF - IF( IROW.EQ.ICOL ) THEN -C Diagonal entry. - IF( A(J).EQ.0.0D0 ) THEN - CHMAT(IROW)(ICOL:ICOL) = '0' - ELSEIF( A(J).GT.0.0D0 ) THEN - CHMAT(IROW)(ICOL:ICOL) = 'D' - ELSE - CHMAT(IROW)(ICOL:ICOL) = 'N' - ENDIF - ELSE -C Off-Diagonal entry - IF( A(J).EQ.0.0D0 ) THEN - CHMAT(IROW)(ICOL:ICOL) = '0' - ELSEIF( A(J).GT.0.0D0 ) THEN - CHMAT(IROW)(ICOL:ICOL) = '#' - ELSE - CHMAT(IROW)(ICOL:ICOL) = '*' - ENDIF - ENDIF - ENDIF - 20 CONTINUE - 30 CONTINUE -C -C Write out the heading. - WRITE(IUNIT,1000) N, NELT, REAL(NELT)/(N*N) - WRITE(IUNIT,1010) (MOD(I,10),I=1,NMAX) -C -C Write out the character representations matrix elements. - DO 40 IROW = 1, NMAX - WRITE(IUNIT,1020) IROW, CHMAT(IROW)(1:NMAX) - 40 CONTINUE - RETURN -C - 1000 FORMAT(/'**** Picture of Column SLAP matrix follows ****'/ - $ ' N, NELT and Density = ',2I10,D16.7) -C The following assumes MAXORD.le.225. - 1010 FORMAT(4X,225(I1)) - 1020 FORMAT(1X,I3,A) -C------------- LAST LINE OF DCPPLT FOLLOWS ---------------------------- - END diff --git a/slatec/dcscal.f b/slatec/dcscal.f deleted file mode 100644 index 4b8b010..0000000 --- a/slatec/dcscal.f +++ /dev/null @@ -1,98 +0,0 @@ -*DECK DCSCAL - SUBROUTINE DCSCAL (A, NRDA, NROW, NCOL, COLS, COLSAV, ROWS, - + ROWSAV, ANORM, SCALES, ISCALE, IC) -C***BEGIN PROLOGUE DCSCAL -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBVSUP and DSUDS -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (CSCALE-S, DCSCAL-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C This routine scales the matrix A by columns when needed. -C -C***SEE ALSO DBVSUP, DSUDS -C***ROUTINES CALLED DDOT -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 890911 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DCSCAL - DOUBLE PRECISION DDOT - INTEGER IC, IP, ISCALE, J, K, NCOL, NRDA, NROW - DOUBLE PRECISION A(NRDA,*), ALOG2, ANORM, ASCALE, COLS(*), - 1 COLSAV(*), CS, P, ROWS(*), ROWSAV(*), S, - 2 SCALES(*), TEN20, TEN4 -C - SAVE TEN4, TEN20 - DATA TEN4,TEN20 /1.0D4,1.0D20/ -C -C BEGIN BLOCK PERMITTING ...EXITS TO 130 -C BEGIN BLOCK PERMITTING ...EXITS TO 60 -C***FIRST EXECUTABLE STATEMENT DCSCAL - IF (ISCALE .NE. (-1)) GO TO 40 -C - IF (IC .EQ. 0) GO TO 20 - DO 10 K = 1, NCOL - COLS(K) = DDOT(NROW,A(1,K),1,A(1,K),1) - 10 CONTINUE - 20 CONTINUE -C - ASCALE = ANORM/NCOL - DO 30 K = 1, NCOL - CS = COLS(K) -C .........EXIT - IF ((CS .GT. TEN4*ASCALE) .OR. (TEN4*CS .LT. ASCALE)) - 1 GO TO 60 -C .........EXIT - IF ((CS .LT. 1.0D0/TEN20) .OR. (CS .GT. TEN20)) - 1 GO TO 60 - 30 CONTINUE - 40 CONTINUE -C - DO 50 K = 1, NCOL - SCALES(K) = 1.0D0 - 50 CONTINUE -C ......EXIT - GO TO 130 - 60 CONTINUE -C - ALOG2 = LOG(2.0D0) - ANORM = 0.0D0 - DO 110 K = 1, NCOL - CS = COLS(K) - IF (CS .NE. 0.0D0) GO TO 70 - SCALES(K) = 1.0D0 - GO TO 100 - 70 CONTINUE - P = LOG(CS)/ALOG2 - IP = -0.5D0*P - S = 2.0D0**IP - SCALES(K) = S - IF (IC .EQ. 1) GO TO 80 - COLS(K) = S*S*COLS(K) - ANORM = ANORM + COLS(K) - COLSAV(K) = COLS(K) - 80 CONTINUE - DO 90 J = 1, NROW - A(J,K) = S*A(J,K) - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE -C -C ...EXIT - IF (IC .EQ. 0) GO TO 130 -C - DO 120 K = 1, NROW - ROWS(K) = DDOT(NCOL,A(K,1),NRDA,A(K,1),NRDA) - ROWSAV(K) = ROWS(K) - ANORM = ANORM + ROWS(K) - 120 CONTINUE - 130 CONTINUE - RETURN - END diff --git a/slatec/dcsevl.f b/slatec/dcsevl.f deleted file mode 100644 index 7cff406..0000000 --- a/slatec/dcsevl.f +++ /dev/null @@ -1,65 +0,0 @@ -*DECK DCSEVL - DOUBLE PRECISION FUNCTION DCSEVL (X, CS, N) -C***BEGIN PROLOGUE DCSEVL -C***PURPOSE Evaluate a Chebyshev series. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C3A2 -C***TYPE DOUBLE PRECISION (CSEVL-S, DCSEVL-D) -C***KEYWORDS CHEBYSHEV SERIES, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate the N-term Chebyshev series CS at X. Adapted from -C a method presented in the paper by Broucke referenced below. -C -C Input Arguments -- -C X value at which the series is to be evaluated. -C CS array of N terms of a Chebyshev series. In evaluating -C CS, only half the first coefficient is summed. -C N number of terms in array CS. -C -C***REFERENCES R. Broucke, Ten subroutines for the manipulation of -C Chebyshev series, Algorithm 446, Communications of -C the A.C.M. 16, (1973) pp. 254-256. -C L. Fox and I. B. Parker, Chebyshev Polynomials in -C Numerical Analysis, Oxford University Press, 1968, -C page 56. -C***ROUTINES CALLED D1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900329 Prologued revised extensively and code rewritten to allow -C X to be slightly outside interval (-1,+1). (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DCSEVL - DOUBLE PRECISION B0, B1, B2, CS(*), ONEPL, TWOX, X, D1MACH - LOGICAL FIRST - SAVE FIRST, ONEPL - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DCSEVL - IF (FIRST) ONEPL = 1.0D0 + D1MACH(4) - FIRST = .FALSE. - IF (N .LT. 1) CALL XERMSG ('SLATEC', 'DCSEVL', - + 'NUMBER OF TERMS .LE. 0', 2, 2) - IF (N .GT. 1000) CALL XERMSG ('SLATEC', 'DCSEVL', - + 'NUMBER OF TERMS .GT. 1000', 3, 2) - IF (ABS(X) .GT. ONEPL) CALL XERMSG ('SLATEC', 'DCSEVL', - + 'X OUTSIDE THE INTERVAL (-1,+1)', 1, 1) -C - B1 = 0.0D0 - B0 = 0.0D0 - TWOX = 2.0D0*X - DO 10 I = 1,N - B2 = B1 - B1 = B0 - NI = N + 1 - I - B0 = TWOX*B1 - B2 + CS(NI) - 10 CONTINUE -C - DCSEVL = 0.5D0*(B0-B2) -C - RETURN - END diff --git a/slatec/dcv.f b/slatec/dcv.f deleted file mode 100644 index 8c63b2c..0000000 --- a/slatec/dcv.f +++ /dev/null @@ -1,133 +0,0 @@ -*DECK DCV - DOUBLE PRECISION FUNCTION DCV (XVAL, NDATA, NCONST, NORD, NBKPT, - + BKPT, W) -C***BEGIN PROLOGUE DCV -C***PURPOSE Evaluate the variance function of the curve obtained -C by the constrained B-spline fitting subprogram DFC. -C***LIBRARY SLATEC -C***CATEGORY L7A3 -C***TYPE DOUBLE PRECISION (CV-S, DCV-D) -C***KEYWORDS ANALYSIS OF COVARIANCE, B-SPLINE, -C CONSTRAINED LEAST SQUARES, CURVE FITTING -C***AUTHOR Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C DCV( ) is a companion function subprogram for DFC( ). The -C documentation for DFC( ) has complete usage instructions. -C -C DCV( ) is used to evaluate the variance function of the curve -C obtained by the constrained B-spline fitting subprogram, DFC( ). -C The variance function defines the square of the probable error -C of the fitted curve at any point, XVAL. One can use the square -C root of this variance function to determine a probable error band -C around the fitted curve. -C -C DCV( ) is used after a call to DFC( ). MODE, an input variable to -C DFC( ), is used to indicate if the variance function is desired. -C In order to use DCV( ), MODE must equal 2 or 4 on input to DFC( ). -C MODE is also used as an output flag from DFC( ). Check to make -C sure that MODE = 0 after calling DFC( ), indicating a successful -C constrained curve fit. The array SDDATA, as input to DFC( ), must -C also be defined with the standard deviation or uncertainty of the -C Y values to use DCV( ). -C -C To evaluate the variance function after calling DFC( ) as stated -C above, use DCV( ) as shown here -C -C VAR=DCV(XVAL,NDATA,NCONST,NORD,NBKPT,BKPT,W) -C -C The variance function is given by -C -C VAR=(transpose of B(XVAL))*C*B(XVAL)/DBLE(MAX(NDATA-N,1)) -C -C where N = NBKPT - NORD. -C -C The vector B(XVAL) is the B-spline basis function values at -C X=XVAL. The covariance matrix, C, of the solution coefficients -C accounts only for the least squares equations and the explicitly -C stated equality constraints. This fact must be considered when -C interpreting the variance function from a data fitting problem -C that has inequality constraints on the fitted curve. -C -C All the variables in the calling sequence for DCV( ) are used in -C DFC( ) except the variable XVAL. Do not change the values of -C these variables between the call to DFC( ) and the use of DCV( ). -C -C The following is a brief description of the variables -C -C XVAL The point where the variance is desired, a double -C precision variable. -C -C NDATA The number of discrete (X,Y) pairs for which DFC( ) -C calculated a piece-wise polynomial curve. -C -C NCONST The number of conditions that constrained the B-spline in -C DFC( ). -C -C NORD The order of the B-spline used in DFC( ). -C The value of NORD must satisfy 1 < NORD < 20 . -C -C (The order of the spline is one more than the degree of -C the piece-wise polynomial defined on each interval. This -C is consistent with the B-spline package convention. For -C example, NORD=4 when we are using piece-wise cubics.) -C -C NBKPT The number of knots in the array BKPT(*). -C The value of NBKPT must satisfy NBKPT .GE. 2*NORD. -C -C BKPT(*) The double precision array of knots. Normally the problem -C data interval will be included between the limits -C BKPT(NORD) and BKPT(NBKPT-NORD+1). The additional end -C knots BKPT(I),I=1,...,NORD-1 and I=NBKPT-NORD+2,...,NBKPT, -C are required by DFC( ) to compute the functions used to -C fit the data. -C -C W(*) Double precision work array as used in DFC( ). See DFC( ) -C for the required length of W(*). The contents of W(*) -C must not be modified by the user if the variance function -C is desired. -C -C***REFERENCES R. J. Hanson, Constrained least squares curve fitting -C to discrete data using B-splines, a users guide, -C Report SAND78-1291, Sandia Laboratories, December -C 1978. -C***ROUTINES CALLED DDOT, DFSPVN -C***REVISION HISTORY (YYMMDD) -C 780801 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DCV - INTEGER I, ILEFT, IP, IS, LAST, MDG, MDW, N, NBKPT, NCONST, - * NDATA, NORD - DOUBLE PRECISION BKPT, DDOT, V, W, XVAL, ZERO - DIMENSION BKPT(*),W(*),V(40) -C***FIRST EXECUTABLE STATEMENT DCV - ZERO = 0.0D0 - MDG = NBKPT - NORD + 3 - MDW = NBKPT - NORD + 1 + NCONST - IS = MDG*(NORD + 1) + 2*MAX(NDATA,NBKPT) + NBKPT + NORD**2 - LAST = NBKPT - NORD + 1 - ILEFT = NORD - 10 IF (XVAL .LT. BKPT(ILEFT+1) .OR. ILEFT .GE. LAST - 1) GO TO 20 - ILEFT = ILEFT + 1 - GO TO 10 - 20 CONTINUE - CALL DFSPVN(BKPT,NORD,1,XVAL,ILEFT,V(NORD+1)) - ILEFT = ILEFT - NORD + 1 - IP = MDW*(ILEFT - 1) + ILEFT + IS - N = NBKPT - NORD - DO 30 I = 1, NORD - V(I) = DDOT(NORD,W(IP),1,V(NORD+1),1) - IP = IP + MDW - 30 CONTINUE - DCV = MAX(DDOT(NORD,V,1,V(NORD+1),1),ZERO) -C -C SCALE THE VARIANCE SO IT IS AN UNBIASED ESTIMATE. - DCV = DCV/MAX(NDATA-N,1) - RETURN - END diff --git a/slatec/ddaini.f b/slatec/ddaini.f deleted file mode 100644 index edf9104..0000000 --- a/slatec/ddaini.f +++ /dev/null @@ -1,258 +0,0 @@ -*DECK DDAINI - SUBROUTINE DDAINI (X, Y, YPRIME, NEQ, RES, JAC, H, WT, IDID, RPAR, - * IPAR, PHI, DELTA, E, WM, IWM, HMIN, UROUND, NONNEG, NTEMP) -C***BEGIN PROLOGUE DDAINI -C***SUBSIDIARY -C***PURPOSE Initialization routine for DDASSL. -C***LIBRARY SLATEC (DASSL) -C***TYPE DOUBLE PRECISION (SDAINI-S, DDAINI-D) -C***AUTHOR Petzold, Linda R., (LLNL) -C***DESCRIPTION -C----------------------------------------------------------------- -C DDAINI TAKES ONE STEP OF SIZE H OR SMALLER -C WITH THE BACKWARD EULER METHOD, TO -C FIND YPRIME. X AND Y ARE UPDATED TO BE CONSISTENT WITH THE -C NEW STEP. A MODIFIED DAMPED NEWTON ITERATION IS USED TO -C SOLVE THE CORRECTOR ITERATION. -C -C THE INITIAL GUESS FOR YPRIME IS USED IN THE -C PREDICTION, AND IN FORMING THE ITERATION -C MATRIX, BUT IS NOT INVOLVED IN THE -C ERROR TEST. THIS MAY HAVE TROUBLE -C CONVERGING IF THE INITIAL GUESS IS NO -C GOOD, OR IF G(X,Y,YPRIME) DEPENDS -C NONLINEARLY ON YPRIME. -C -C THE PARAMETERS REPRESENT: -C X -- INDEPENDENT VARIABLE -C Y -- SOLUTION VECTOR AT X -C YPRIME -- DERIVATIVE OF SOLUTION VECTOR -C NEQ -- NUMBER OF EQUATIONS -C H -- STEPSIZE. IMDER MAY USE A STEPSIZE -C SMALLER THAN H. -C WT -- VECTOR OF WEIGHTS FOR ERROR -C CRITERION -C IDID -- COMPLETION CODE WITH THE FOLLOWING MEANINGS -C IDID= 1 -- YPRIME WAS FOUND SUCCESSFULLY -C IDID=-12 -- DDAINI FAILED TO FIND YPRIME -C RPAR,IPAR -- REAL AND INTEGER PARAMETER ARRAYS -C THAT ARE NOT ALTERED BY DDAINI -C PHI -- WORK SPACE FOR DDAINI -C DELTA,E -- WORK SPACE FOR DDAINI -C WM,IWM -- REAL AND INTEGER ARRAYS STORING -C MATRIX INFORMATION -C -C----------------------------------------------------------------- -C***ROUTINES CALLED DDAJAC, DDANRM, DDASLV -C***REVISION HISTORY (YYMMDD) -C 830315 DATE WRITTEN -C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) -C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. -C 901026 Added explicit declarations for all variables and minor -C cosmetic changes to prologue. (FNF) -C 901030 Minor corrections to declarations. (FNF) -C***END PROLOGUE DDAINI -C - INTEGER NEQ, IDID, IPAR(*), IWM(*), NONNEG, NTEMP - DOUBLE PRECISION - * X, Y(*), YPRIME(*), H, WT(*), RPAR(*), PHI(NEQ,*), DELTA(*), - * E(*), WM(*), HMIN, UROUND - EXTERNAL RES, JAC -C - EXTERNAL DDAJAC, DDANRM, DDASLV - DOUBLE PRECISION DDANRM -C - INTEGER I, IER, IRES, JCALC, LNJE, LNRE, M, MAXIT, MJAC, NCF, - * NEF, NSF - DOUBLE PRECISION - * CJ, DAMP, DELNRM, ERR, OLDNRM, R, RATE, S, XOLD, YNORM - LOGICAL CONVGD -C - PARAMETER (LNRE=12) - PARAMETER (LNJE=13) -C - DATA MAXIT/10/,MJAC/5/ - DATA DAMP/0.75D0/ -C -C -C--------------------------------------------------- -C BLOCK 1. -C INITIALIZATIONS. -C--------------------------------------------------- -C -C***FIRST EXECUTABLE STATEMENT DDAINI - IDID=1 - NEF=0 - NCF=0 - NSF=0 - XOLD=X - YNORM=DDANRM(NEQ,Y,WT,RPAR,IPAR) -C -C SAVE Y AND YPRIME IN PHI - DO 100 I=1,NEQ - PHI(I,1)=Y(I) -100 PHI(I,2)=YPRIME(I) -C -C -C---------------------------------------------------- -C BLOCK 2. -C DO ONE BACKWARD EULER STEP. -C---------------------------------------------------- -C -C SET UP FOR START OF CORRECTOR ITERATION -200 CJ=1.0D0/H - X=X+H -C -C PREDICT SOLUTION AND DERIVATIVE - DO 250 I=1,NEQ -250 Y(I)=Y(I)+H*YPRIME(I) -C - JCALC=-1 - M=0 - CONVGD=.TRUE. -C -C -C CORRECTOR LOOP. -300 IWM(LNRE)=IWM(LNRE)+1 - IRES=0 -C - CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR) - IF (IRES.LT.0) GO TO 430 -C -C -C EVALUATE THE ITERATION MATRIX - IF (JCALC.NE.-1) GO TO 310 - IWM(LNJE)=IWM(LNJE)+1 - JCALC=0 - CALL DDAJAC(NEQ,X,Y,YPRIME,DELTA,CJ,H, - * IER,WT,E,WM,IWM,RES,IRES, - * UROUND,JAC,RPAR,IPAR,NTEMP) -C - S=1000000.D0 - IF (IRES.LT.0) GO TO 430 - IF (IER.NE.0) GO TO 430 - NSF=0 -C -C -C -C MULTIPLY RESIDUAL BY DAMPING FACTOR -310 CONTINUE - DO 320 I=1,NEQ -320 DELTA(I)=DELTA(I)*DAMP -C -C COMPUTE A NEW ITERATE (BACK SUBSTITUTION) -C STORE THE CORRECTION IN DELTA -C - CALL DDASLV(NEQ,DELTA,WM,IWM) -C -C UPDATE Y AND YPRIME - DO 330 I=1,NEQ - Y(I)=Y(I)-DELTA(I) -330 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) -C -C TEST FOR CONVERGENCE OF THE ITERATION. -C - DELNRM=DDANRM(NEQ,DELTA,WT,RPAR,IPAR) - IF (DELNRM.LE.100.D0*UROUND*YNORM) - * GO TO 400 -C - IF (M.GT.0) GO TO 340 - OLDNRM=DELNRM - GO TO 350 -C -340 RATE=(DELNRM/OLDNRM)**(1.0D0/M) - IF (RATE.GT.0.90D0) GO TO 430 - S=RATE/(1.0D0-RATE) -C -350 IF (S*DELNRM .LE. 0.33D0) GO TO 400 -C -C -C THE CORRECTOR HAS NOT YET CONVERGED. UPDATE -C M AND AND TEST WHETHER THE MAXIMUM -C NUMBER OF ITERATIONS HAVE BEEN TRIED. -C EVERY MJAC ITERATIONS, GET A NEW -C ITERATION MATRIX. -C - M=M+1 - IF (M.GE.MAXIT) GO TO 430 -C - IF ((M/MJAC)*MJAC.EQ.M) JCALC=-1 - GO TO 300 -C -C -C THE ITERATION HAS CONVERGED. -C CHECK NONNEGATIVITY CONSTRAINTS -400 IF (NONNEG.EQ.0) GO TO 450 - DO 410 I=1,NEQ -410 DELTA(I)=MIN(Y(I),0.0D0) -C - DELNRM=DDANRM(NEQ,DELTA,WT,RPAR,IPAR) - IF (DELNRM.GT.0.33D0) GO TO 430 -C - DO 420 I=1,NEQ - Y(I)=Y(I)-DELTA(I) -420 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) - GO TO 450 -C -C -C EXITS FROM CORRECTOR LOOP. -430 CONVGD=.FALSE. -450 IF (.NOT.CONVGD) GO TO 600 -C -C -C -C----------------------------------------------------- -C BLOCK 3. -C THE CORRECTOR ITERATION CONVERGED. -C DO ERROR TEST. -C----------------------------------------------------- -C - DO 510 I=1,NEQ -510 E(I)=Y(I)-PHI(I,1) - ERR=DDANRM(NEQ,E,WT,RPAR,IPAR) -C - IF (ERR.LE.1.0D0) RETURN -C -C -C -C-------------------------------------------------------- -C BLOCK 4. -C THE BACKWARD EULER STEP FAILED. RESTORE X, Y -C AND YPRIME TO THEIR ORIGINAL VALUES. -C REDUCE STEPSIZE AND TRY AGAIN, IF -C POSSIBLE. -C--------------------------------------------------------- -C -600 CONTINUE - X = XOLD - DO 610 I=1,NEQ - Y(I)=PHI(I,1) -610 YPRIME(I)=PHI(I,2) -C - IF (CONVGD) GO TO 640 - IF (IER.EQ.0) GO TO 620 - NSF=NSF+1 - H=H*0.25D0 - IF (NSF.LT.3.AND.ABS(H).GE.HMIN) GO TO 690 - IDID=-12 - RETURN -620 IF (IRES.GT.-2) GO TO 630 - IDID=-12 - RETURN -630 NCF=NCF+1 - H=H*0.25D0 - IF (NCF.LT.10.AND.ABS(H).GE.HMIN) GO TO 690 - IDID=-12 - RETURN -C -640 NEF=NEF+1 - R=0.90D0/(2.0D0*ERR+0.0001D0) - R=MAX(0.1D0,MIN(0.5D0,R)) - H=H*R - IF (ABS(H).GE.HMIN.AND.NEF.LT.10) GO TO 690 - IDID=-12 - RETURN -690 GO TO 200 -C -C-------------END OF SUBROUTINE DDAINI---------------------- - END diff --git a/slatec/ddajac.f b/slatec/ddajac.f deleted file mode 100644 index 6e53190..0000000 --- a/slatec/ddajac.f +++ /dev/null @@ -1,177 +0,0 @@ -*DECK DDAJAC - SUBROUTINE DDAJAC (NEQ, X, Y, YPRIME, DELTA, CJ, H, IER, WT, E, - * WM, IWM, RES, IRES, UROUND, JAC, RPAR, IPAR, NTEMP) -C***BEGIN PROLOGUE DDAJAC -C***SUBSIDIARY -C***PURPOSE Compute the iteration matrix for DDASSL and form the -C LU-decomposition. -C***LIBRARY SLATEC (DASSL) -C***TYPE DOUBLE PRECISION (SDAJAC-S, DDAJAC-D) -C***AUTHOR Petzold, Linda R., (LLNL) -C***DESCRIPTION -C----------------------------------------------------------------------- -C THIS ROUTINE COMPUTES THE ITERATION MATRIX -C PD=DG/DY+CJ*DG/DYPRIME (WHERE G(X,Y,YPRIME)=0). -C HERE PD IS COMPUTED BY THE USER-SUPPLIED -C ROUTINE JAC IF IWM(MTYPE) IS 1 OR 4, AND -C IT IS COMPUTED BY NUMERICAL FINITE DIFFERENCING -C IF IWM(MTYPE)IS 2 OR 5 -C THE PARAMETERS HAVE THE FOLLOWING MEANINGS. -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 -C IF ITERATION MATRIX IS SINGULAR, -C AND 0 OTHERWISE. -C WT = VECTOR OF WEIGHTS FOR COMPUTING NORMS -C E = WORK SPACE (TEMPORARY) OF LENGTH NEQ -C WM = REAL WORK SPACE FOR MATRICES. ON -C OUTPUT IT CONTAINS THE LU DECOMPOSITION -C OF THE ITERATION MATRIX. -C IWM = INTEGER WORK SPACE CONTAINING -C MATRIX INFORMATION -C RES = NAME OF THE EXTERNAL USER-SUPPLIED ROUTINE -C TO EVALUATE THE RESIDUAL FUNCTION G(X,Y,YPRIME) -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 JAC = 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----------------------------------------------------------------------- -C***ROUTINES CALLED DGBFA, DGEFA -C***REVISION HISTORY (YYMMDD) -C 830315 DATE WRITTEN -C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) -C 901010 Modified three MAX calls to be all on one line. (FNF) -C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. -C 901026 Added explicit declarations for all variables and minor -C cosmetic changes to prologue. (FNF) -C 901101 Corrected PURPOSE. (FNF) -C***END PROLOGUE DDAJAC -C - INTEGER NEQ, IER, IWM(*), IRES, IPAR(*), NTEMP - DOUBLE PRECISION - * X, Y(*), YPRIME(*), DELTA(*), CJ, H, WT(*), E(*), WM(*), - * UROUND, RPAR(*) - EXTERNAL RES, JAC -C - EXTERNAL DGBFA, DGEFA -C - INTEGER I, I1, I2, II, IPSAVE, ISAVE, J, K, L, LENPD, LIPVT, - * LML, LMTYPE, LMU, MBA, MBAND, MEB1, MEBAND, MSAVE, MTYPE, N, - * NPD, NPDM1, NROW - DOUBLE PRECISION DEL, DELINV, SQUR, YPSAVE, YSAVE -C - PARAMETER (NPD=1) - PARAMETER (LML=1) - PARAMETER (LMU=2) - PARAMETER (LMTYPE=4) - PARAMETER (LIPVT=21) -C -C***FIRST EXECUTABLE STATEMENT DDAJAC - IER = 0 - NPDM1=NPD-1 - MTYPE=IWM(LMTYPE) - GO TO (100,200,300,400,500),MTYPE -C -C -C DENSE USER-SUPPLIED MATRIX -100 LENPD=NEQ*NEQ - DO 110 I=1,LENPD -110 WM(NPDM1+I)=0.0D0 - CALL JAC(X,Y,YPRIME,WM(NPD),CJ,RPAR,IPAR) - GO TO 230 -C -C -C DENSE FINITE-DIFFERENCE-GENERATED MATRIX -200 IRES=0 - NROW=NPDM1 - SQUR = SQRT(UROUND) - DO 210 I=1,NEQ - DEL=SQUR*MAX(ABS(Y(I)),ABS(H*YPRIME(I)),ABS(WT(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 - CALL RES(X,Y,YPRIME,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 PD -230 CALL DGEFA(WM(NPD),NEQ,NEQ,IWM(LIPVT),IER) - RETURN -C -C -C DUMMY SECTION FOR IWM(MTYPE)=3 -300 RETURN -C -C -C BANDED USER-SUPPLIED MATRIX -400 LENPD=(2*IWM(LML)+IWM(LMU)+1)*NEQ - DO 410 I=1,LENPD -410 WM(NPDM1+I)=0.0D0 - CALL JAC(X,Y,YPRIME,WM(NPD),CJ,RPAR,IPAR) - MEBAND=2*IWM(LML)+IWM(LMU)+1 - GO TO 550 -C -C -C BANDED FINITE-DIFFERENCE-GENERATED MATRIX -500 MBAND=IWM(LML)+IWM(LMU)+1 - MBA=MIN(MBAND,NEQ) - MEBAND=MBAND+IWM(LML) - MEB1=MEBAND-1 - MSAVE=(NEQ/MBAND)+1 - ISAVE=NTEMP-1 - 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(WT(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 - CALL RES(X,Y,YPRIME,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(WT(N))) - DEL=SIGN(DEL,H*YPRIME(N)) - DEL=(Y(N)+DEL)-Y(N) - DELINV=1.0D0/DEL - I1=MAX(1,(N-IWM(LMU))) - I2=MIN(NEQ,(N+IWM(LML))) - II=N*MEB1-IWM(LML)+NPDM1 - 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 PD -550 CALL DGBFA(WM(NPD),MEBAND,NEQ, - * IWM(LML),IWM(LMU),IWM(LIPVT),IER) - RETURN -C------END OF SUBROUTINE DDAJAC------ - END diff --git a/slatec/ddanrm.f b/slatec/ddanrm.f deleted file mode 100644 index 409c65f..0000000 --- a/slatec/ddanrm.f +++ /dev/null @@ -1,46 +0,0 @@ -*DECK DDANRM - DOUBLE PRECISION FUNCTION DDANRM (NEQ, V, WT, RPAR, IPAR) -C***BEGIN PROLOGUE DDANRM -C***SUBSIDIARY -C***PURPOSE Compute vector norm for DDASSL. -C***LIBRARY SLATEC (DASSL) -C***TYPE DOUBLE PRECISION (SDANRM-S, DDANRM-D) -C***AUTHOR Petzold, Linda R., (LLNL) -C***DESCRIPTION -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 WEIGHTS -C CONTAINED IN THE ARRAY WT OF LENGTH NEQ. -C DDANRM=SQRT((1/NEQ)*SUM(V(I)/WT(I))**2) -C----------------------------------------------------------------------- -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 830315 DATE WRITTEN -C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) -C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. -C 901026 Added explicit declarations for all variables and minor -C cosmetic changes to prologue. (FNF) -C***END PROLOGUE DDANRM -C - INTEGER NEQ, IPAR(*) - DOUBLE PRECISION V(NEQ), WT(NEQ), RPAR(*) -C - INTEGER I - DOUBLE PRECISION SUM, VMAX -C -C***FIRST EXECUTABLE STATEMENT DDANRM - DDANRM = 0.0D0 - VMAX = 0.0D0 - DO 10 I = 1,NEQ - IF(ABS(V(I)/WT(I)) .GT. VMAX) VMAX = ABS(V(I)/WT(I)) -10 CONTINUE - IF(VMAX .LE. 0.0D0) GO TO 30 - SUM = 0.0D0 - DO 20 I = 1,NEQ -20 SUM = SUM + ((V(I)/WT(I))/VMAX)**2 - DDANRM = VMAX*SQRT(SUM/NEQ) -30 CONTINUE - RETURN -C------END OF FUNCTION DDANRM------ - END diff --git a/slatec/ddaslv.f b/slatec/ddaslv.f deleted file mode 100644 index 38a80f7..0000000 --- a/slatec/ddaslv.f +++ /dev/null @@ -1,61 +0,0 @@ -*DECK DDASLV - SUBROUTINE DDASLV (NEQ, DELTA, WM, IWM) -C***BEGIN PROLOGUE DDASLV -C***SUBSIDIARY -C***PURPOSE Linear system solver for DDASSL. -C***LIBRARY SLATEC (DASSL) -C***TYPE DOUBLE PRECISION (SDASLV-S, DDASLV-D) -C***AUTHOR Petzold, Linda R., (LLNL) -C***DESCRIPTION -C----------------------------------------------------------------------- -C THIS ROUTINE MANAGES THE SOLUTION OF THE LINEAR -C SYSTEM ARISING IN THE NEWTON ITERATION. -C MATRICES AND REAL TEMPORARY STORAGE AND -C REAL INFORMATION ARE STORED IN THE ARRAY WM. -C INTEGER MATRIX INFORMATION IS STORED IN -C THE ARRAY IWM. -C FOR A DENSE MATRIX, THE LINPACK ROUTINE -C DGESL IS CALLED. -C FOR A BANDED MATRIX,THE LINPACK ROUTINE -C DGBSL IS CALLED. -C----------------------------------------------------------------------- -C***ROUTINES CALLED DGBSL, DGESL -C***REVISION HISTORY (YYMMDD) -C 830315 DATE WRITTEN -C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) -C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. -C 901026 Added explicit declarations for all variables and minor -C cosmetic changes to prologue. (FNF) -C***END PROLOGUE DDASLV -C - INTEGER NEQ, IWM(*) - DOUBLE PRECISION DELTA(*), WM(*) -C - EXTERNAL DGBSL, DGESL -C - INTEGER LIPVT, LML, LMU, LMTYPE, MEBAND, MTYPE, NPD - PARAMETER (NPD=1) - PARAMETER (LML=1) - PARAMETER (LMU=2) - PARAMETER (LMTYPE=4) - PARAMETER (LIPVT=21) -C -C***FIRST EXECUTABLE STATEMENT DDASLV - MTYPE=IWM(LMTYPE) - GO TO(100,100,300,400,400),MTYPE -C -C DENSE MATRIX -100 CALL DGESL(WM(NPD),NEQ,NEQ,IWM(LIPVT),DELTA,0) - RETURN -C -C DUMMY SECTION FOR MTYPE=3 -300 CONTINUE - RETURN -C -C BANDED MATRIX -400 MEBAND=2*IWM(LML)+IWM(LMU)+1 - CALL DGBSL(WM(NPD),MEBAND,NEQ,IWM(LML), - * IWM(LMU),IWM(LIPVT),DELTA,0) - RETURN -C------END OF SUBROUTINE DDASLV------ - END diff --git a/slatec/ddassl.f b/slatec/ddassl.f deleted file mode 100644 index 7f297d5..0000000 --- a/slatec/ddassl.f +++ /dev/null @@ -1,1604 +0,0 @@ -*DECK DDASSL - SUBROUTINE DDASSL (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, - * IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC) -C***BEGIN PROLOGUE DDASSL -C***PURPOSE This code solves a system of differential/algebraic -C equations of the form G(T,Y,YPRIME) = 0. -C***LIBRARY SLATEC (DASSL) -C***CATEGORY I1A2 -C***TYPE DOUBLE PRECISION (SDASSL-S, DDASSL-D) -C***KEYWORDS BACKWARD DIFFERENTIATION FORMULAS, DASSL, -C DIFFERENTIAL/ALGEBRAIC, IMPLICIT DIFFERENTIAL SYSTEMS -C***AUTHOR Petzold, Linda R., (LLNL) -C Computing and Mathematics Research Division -C Lawrence Livermore National Laboratory -C L - 316, P.O. Box 808, -C Livermore, CA. 94550 -C***DESCRIPTION -C -C *Usage: -C -C EXTERNAL RES, JAC -C INTEGER NEQ, INFO(N), IDID, LRW, LIW, IWORK(LIW), IPAR -C DOUBLE PRECISION T, Y(NEQ), YPRIME(NEQ), TOUT, RTOL, ATOL, -C * RWORK(LRW), RPAR -C -C CALL DDASSL (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, -C * IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC) -C -C -C *Arguments: -C (In the following, all real arrays should be type DOUBLE PRECISION.) -C -C RES:EXT This is a subroutine which you provide to define the -C differential/algebraic system. -C -C NEQ:IN This is the number of equations to be solved. -C -C T:INOUT This is the current value of the independent 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 The basic task of the code is to solve the system from T -C to TOUT and return an answer at TOUT. INFO is an integer -C array which is used to communicate exactly how you want -C this task to be carried out. (See below for details.) -C N must be greater than or equal to 15. -C -C RTOL,ATOL:INOUT These quantities represent relative and absolute -C error tolerances which you provide to indicate how -C accurately you wish the solution to be computed. You -C may choose them to be both scalars or else both vectors. -C Caution: In Fortran 77, a scalar is not the same as an -C array of length 1. Some compilers may object -C to using scalars for RTOL,ATOL. -C -C IDID:OUT This scalar quantity is an indicator reporting what the -C code did. You must monitor this integer 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. (See below for required length.) -C -C IWORK:WORK An integer work array of length LIW which provides the -C code with needed storage space. -C -C LIW:IN The length of IWORK. (See below for required length.) -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 subroutine (and the JAC subroutine) -C -C JAC:EXT This is the name of a subroutine which you may choose -C to provide for defining a matrix of partial derivatives -C described below. -C -C Quantities which may be altered by DDASSL are: -C T, Y(*), YPRIME(*), INFO(1), RTOL, ATOL, -C IDID, RWORK(*) AND IWORK(*) -C -C *Description -C -C Subroutine DDASSL uses the backward differentiation formulas of -C orders one through five to solve a system of the above form for Y and -C YPRIME. Values for Y and YPRIME at the initial time must be given as -C input. These values must be consistent, (that is, if T,Y,YPRIME are -C the given initial values, they must satisfy G(T,Y,YPRIME) = 0.). The -C subroutine solves the system from T to TOUT. It is easy to continue -C the solution to get results at additional TOUT. This is the interval -C mode of operation. Intermediate results can also be obtained easily -C by using the intermediate-output capability. -C -C The following detailed description is divided into subsections: -C 1. Input required for the first call to DDASSL. -C 2. Output after any return from DDASSL. -C 3. What to do to continue the integration. -C 4. Error messages. -C -C -C -------- INPUT -- WHAT TO DO ON THE FIRST CALL TO DDASSL ------------ -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 SUBROUTINE RES(T,Y,YPRIME,DELTA,IRES,RPAR,IPAR) -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 -C return the residual of the differential/algebraic -C system -C DELTA = G(T,Y,YPRIME) -C (DELTA(*) is a vector of length NEQ which is -C output for RES.) -C -C Subroutine RES must not alter T,Y or YPRIME. -C You must declare the name RES in an external -C statement in your program that calls DDASSL. -C You must dimension Y,YPRIME and DELTA in RES. -C -C IRES is an integer flag which is always equal to -C zero on input. Subroutine RES should alter IRES -C only if it encounters an illegal value of Y or -C a stop condition. Set IRES = -1 if an input value -C is illegal, and DDASSL will try to solve the problem -C without getting IRES = -1. If IRES = -2, DDASSL -C will return control to the calling program -C 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 DDASSL. 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 differential equations. -C (NEQ .GE. 1) -C -C T -- Set it to the initial point of the integration. -C T must be defined as a variable. -C -C Y(*) -- Set this vector 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 vector to the initial values of the NEQ -C first derivatives of the solution components at the initial -C point. You must dimension YPRIME at least NEQ in your -C calling program. If you do not know initial values of some -C of the solution components, see the explanation of INFO(11). -C -C TOUT -- Set it to the first point at which a solution -C is desired. You can not take TOUT = T. -C integration either forward in T (TOUT .GT. T) or -C backward in T (TOUT .LT. T) is permitted. -C -C The code advances the solution from T to TOUT using -C step sizes which are automatically selected so as to -C achieve the desired accuracy. If you wish, the code will -C return with the solution and its derivative at -C intermediate steps (intermediate-output mode) so that -C you can monitor them, but you still must provide TOUT in -C accord with the basic aim of the code. -C -C The first step taken by the code is a critical one -C because it must reflect how fast the solution changes near -C the initial point. The code automatically selects an -C initial step size which is practically always suitable for -C the problem. By using the fact that the code will not step -C past TOUT in the first step, you could, if necessary, -C restrict the length of the initial step size. -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 -C past TSTOP. In this case any TOUT beyond TSTOP is invalid -C 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 15, though DDASSL uses only the first -C eleven entries. You must respond to all of the following -C items, which are arranged as questions. The simplest use -C of the code corresponds to answering all questions as yes, -C i.e. setting all entries of INFO to 0. -C -C INFO(1) - This parameter enables the code to initialize -C itself. You must set it to indicate the start of every -C new 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 vectors. -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 -C of TOUT by steps. If you wish, it will return the -C computed solution and derivative at the next -C intermediate step (the intermediate-output mode) or -C TOUT, whichever comes first. This is a good way to -C proceed if you want to see the behavior of the solution. -C If you must have solutions at a great many specific -C TOUT points, this 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 not to go past. -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) - To solve differential/algebraic problems it is -C necessary 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. Sometimes numerical differencing -C is cheaper than evaluating derivatives in JAC and -C sometimes it is not - this depends on your problem. -C -C **** Do you want the code to evaluate the partial -C derivatives 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) - DDASSL will perform much better if the matrix of -C partial derivatives, DG/DY + CJ*DG/DYPRIME, -C (here CJ is a scalar determined by DDASSL) -C is banded and the code is told this. In this -C case, the storage needed will be greatly reduced, -C numerical differencing will be performed much cheaper, -C and a number of important algorithms will execute much -C faster. The differential equation is said to have -C half-bandwidths ML (lower) and MU (upper) if equation i -C 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 -C (dense) matrix (and not a special banded -C 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 -C INFO(7) -- You can specify a maximum (absolute value of) -C stepsize, so that the code -C will avoid passing over very -C large regions. -C -C **** Do you want the code to decide -C on its own maximum 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 -C may occasionally suffer from -C severe scaling difficulties on the -C first step. If you know a great deal -C about the scaling of your problem, you can -C help to alleviate this problem by -C specifying an initial stepsize HO. -C -C **** Do you want the code to define -C its own initial stepsize? -C Yes - Set INFO(8)=0 -C No - Set INFO(8)=1 -C and define HO by setting -C RWORK(3)=HO **** -C -C INFO(9) -- If storage is a severe problem, -C you can save some locations by -C restricting the maximum order MAXORD. -C the default value is 5. for each -C order decrease below 5, the code -C requires NEQ fewer locations, however -C it is likely to be slower. In any -C case, you must have 1 .LE. MAXORD .LE. 5 -C **** Do you want the maximum order to -C 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 the solutions to your equations -C will always be nonnegative, it may help to set this -C parameter. However, it is probably best to -C try the code without using this option first, -C and only to use this option if that doesn't -C work very well. -C **** Do you want the code to solve the problem without -C invoking any special nonnegativity constraints? -C Yes - Set INFO(10)=0 -C No - Set INFO(10)=1 -C -C INFO(11) --DDASSL normally requires the initial T, -C Y, and YPRIME to be consistent. That is, -C you must have G(T,Y,YPRIME) = 0 at the initial -C time. If you do not know the initial -C derivative precisely, you can let DDASSL try -C to compute it. -C **** Are the initial T, Y, YPRIME consistent? -C Yes - Set INFO(11) = 0 -C No - Set INFO(11) = 1, -C and set YPRIME to an initial approximation -C to YPRIME. (If you have no idea what -C YPRIME should be, set it to zero. Note -C that the initial Y should be such -C that there must exist a YPRIME so that -C G(T,Y,YPRIME) = 0.) -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. You -C have two choices -- -C Both RTOL and ATOL are scalars. (INFO(2)=0) -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) .LE. RTOL*ABS(Y)+ATOL -C 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 Usually, but not always, the true accuracy of the -C computed Y is comparable to the error tolerances. This -C 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 bigger tolerances. -C -C Setting ATOL=0. results in a pure relative error test on -C 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 much -C bigger than ATOL and to an absolute error test when the -C solution component is smaller than the threshhold ATOL. -C -C The code will not attempt to compute a solution at an -C accuracy unreasonable for the machine being used. It will -C advise you if you ask for too much accuracy and inform -C you as to the maximum accuracy it believes possible. -C -C RWORK(*) -- Dimension this real work array of length LRW in your -C calling program. -C -C LRW -- Set it to the declared length of the RWORK array. -C You must have -C LRW .GE. 40+(MAXORD+4)*NEQ+NEQ**2 -C for the full (dense) JACOBIAN case (when INFO(6)=0), or -C LRW .GE. 40+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ -C for the banded user-defined JACOBIAN case -C (when INFO(5)=1 and INFO(6)=1), or -C LRW .GE. 40+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ -C +2*(NEQ/(ML+MU+1)+1) -C for the banded finite-difference-generated JACOBIAN case -C (when INFO(5)=0 and INFO(6)=1) -C -C IWORK(*) -- Dimension this integer work array of length LIW in -C your calling program. -C -C LIW -- Set it to the declared length of the IWORK array. -C You must have LIW .GE. 20+NEQ -C -C RPAR, IPAR -- These are parameter arrays, of real and integer -C type, respectively. You can use them for communication -C between your program that calls DDASSL and the -C RES subroutine (and the JAC subroutine). They are not -C altered by DDASSL. If you do not need RPAR or IPAR, -C ignore these parameters by treating them as dummy -C arguments. If you do choose to use them, dimension -C them in your calling program and in RES (and in JAC) -C as arrays of appropriate length. -C -C JAC -- If you have set INFO(5)=0, you can ignore this parameter -C by treating it as a dummy argument. Otherwise, you must -C provide a subroutine of the form -C SUBROUTINE JAC(T,Y,YPRIME,PD,CJ,RPAR,IPAR) -C to define the matrix of partial derivatives -C PD=DG/DY+CJ*DG/DYPRIME -C CJ is a scalar which is input to JAC. -C For the given values of T,Y,YPRIME, the -C subroutine must evaluate the non-zero partial -C derivatives for each equation and each solution -C component, and store these values in the -C matrix PD. The elements of PD are set to zero -C before each call to JAC so only non-zero elements -C need to be defined. -C -C Subroutine JAC must not alter T,Y,(*),YPRIME(*), or CJ. -C You must declare the name JAC in an EXTERNAL statement in -C your program that calls DDASSL. You must dimension Y, -C YPRIME and PD in JAC. -C -C The way you must store the elements into the PD matrix -C depends on the structure of the matrix which you -C indicated by INFO(6). -C *** INFO(6)=0 -- Full (dense) matrix *** -C Give PD a first dimension of NEQ. -C When you evaluate the (non-zero) partial derivative -C of equation I with respect to variable J, you must -C store it in PD according to -C PD(I,J) = "DG(I)/DY(J)+CJ*DG(I)/DYPRIME(J)" -C *** INFO(6)=1 -- Banded JACOBIAN with ML lower and MU -C upper diagonal bands (refer to INFO(6) description -C of ML and MU) *** -C Give PD a first dimension of 2*ML+MU+1. -C when you evaluate the (non-zero) partial derivative -C of equation I with respect to variable J, you must -C store it 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 RPAR and IPAR are real and integer parameter arrays -C which you can use for communication between your calling -C program and your JACOBIAN subroutine JAC. They are not -C altered by DDASSL. If you do not need RPAR or IPAR, -C ignore these parameters by treating them as dummy -C arguments. If you do choose to use them, dimension -C them in your calling program and in JAC as arrays of -C appropriate length. -C -C -C OPTIONALLY REPLACEABLE NORM ROUTINE: -C -C DDASSL uses a weighted norm DDANRM to measure the size -C of vectors such as the estimated error in each step. -C A FUNCTION subprogram -C DOUBLE PRECISION FUNCTION DDANRM(NEQ,V,WT,RPAR,IPAR) -C DIMENSION V(NEQ),WT(NEQ) -C is used to define this norm. Here, V is the vector -C whose norm is to be computed, and WT is a vector of -C weights. A DDANRM routine has been included with DDASSL -C which computes the weighted root-mean-square norm -C given by -C DDANRM=SQRT((1/NEQ)*SUM(V(I)/WT(I))**2) -C this norm is suitable for most problems. In some -C special cases, it may be more convenient and/or -C efficient to define your own norm by writing a function -C subprogram to be called instead of DDANRM. This should, -C however, be attempted only after careful thought and -C consideration. -C -C -C -------- OUTPUT -- AFTER ANY RETURN FROM DDASSL --------------------- -C -C The principal aim of the code is to return a computed solution at -C TOUT, although it is also possible to obtain intermediate results -C along the way. To find out whether the code achieved its goal -C or if the integration process was interrupted before the task was -C completed, you must check the IDID parameter. -C -C -C T -- The solution was successfully advanced to the -C output value of T. -C -C Y(*) -- Contains the computed solution approximation at T. -C -C YPRIME(*) -- Contains the computed derivative -C approximation at T. -C -C IDID -- Reports what the code did. -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(*) is obtained by interpolation. -C YPRIME(*) is obtained by interpolation. -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 -C component is zero. Thus, a pure relative error -C test is impossible for this component. -C -C IDID = -6 -- DDASSL had repeated error test -C failures on the last attempted step. -C -C IDID = -7 -- The corrector could not converge. -C -C IDID = -8 -- The matrix of partial derivatives -C is singular. -C -C IDID = -9 -- The corrector could not converge. -C there were repeated error test failures -C in this step. -C -C IDID =-10 -- The corrector could not converge -C because IRES was equal to minus one. -C -C IDID =-11 -- IRES equal to -2 was encountered -C and control is being returned to the -C calling program. -C -C IDID =-12 -- DDASSL failed to compute the initial -C YPRIME. -C -C -C -C IDID = -13,..,-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 -C interest to the user but necessary for subsequent calls. -C However, you may find use for -C -C RWORK(3)--Which contains the step size H to be -C attempted on the next step. -C -C RWORK(4)--Which contains the current value of the -C independent variable, i.e., the farthest point -C integration has reached. This will be different -C from T only when interpolation has been -C performed (IDID=3). -C -C RWORK(7)--Which contains the stepsize used -C on the last successful step. -C -C IWORK(7)--Which contains the order of the method to -C be attempted on the next step. -C -C IWORK(8)--Which contains the order of the method used -C on the last step. -C -C IWORK(11)--Which contains the number of steps taken so -C far. -C -C IWORK(12)--Which contains the number of calls to RES -C so far. -C -C IWORK(13)--Which contains the number of evaluations of -C the matrix of partial derivatives needed so -C far. -C -C IWORK(14)--Which contains the total number -C of error test failures so far. -C -C IWORK(15)--Which contains the total number -C of convergence test failures so far. -C (includes singular iteration matrix -C failures.) -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, -C in particular do not alter NEQ,T,Y(*),YPRIME(*),RWORK(*),IWORK(*) -C or the differential equation in subroutine RES. Any such -C alteration constitutes a new problem and must be treated as such, -C i.e., you must start afresh. -C -C You cannot change from vector to scalar error control or vice -C versa (INFO(2)), but you can change the size of the entries of -C RTOL, 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), IWORK(1), or IWORK(2) -C unless you are going to restart the code. -C -C *** Following a completed task *** -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 *** Following an interrupted task *** -C To show the code that you realize the task was -C interrupted and that you want to continue, you -C must take appropriate action and set INFO(1) = 1 -C If -C IDID = -1, The code has taken about 500 steps. -C If you want to continue, set INFO(1) = 1 and -C call the code again. An additional 500 steps -C will be allowed. -C -C IDID = -2, The error tolerances RTOL, ATOL have been -C increased to values the code estimates appropriate -C for continuing. You may want to change them -C yourself. If you are sure you want to continue -C with relaxed error tolerances, set INFO(1)=1 and -C call the code 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 -C alter the error criterion to use positive values -C for those components of ATOL corresponding to zero -C solution components, then set INFO(1)=1 and call -C the code again. -C -C IDID = -4,-5 --- Cannot occur with this code. -C -C IDID = -6, Repeated error test failures occurred on the -C last attempted step in DDASSL. 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 -C on the last attempted step in DDASSL. An inaccurate -C or ill-conditioned JACOBIAN may be the problem. If -C you are absolutely certain you want to continue, you -C should restart the integration. -C -C IDID = -8, The matrix of partial derivatives is singular. -C Some of your equations may be redundant. -C DDASSL cannot solve the problem as stated. -C It is possible that the redundant equations -C could be removed, and then DDASSL could -C solve the problem. It is also possible -C that a solution to your problem either -C does not exist or is not unique. -C -C IDID = -9, DDASSL had multiple convergence test -C failures, preceded by multiple error -C test failures, on the last attempted step. -C It is possible that your problem -C is ill-posed, and cannot be solved -C using this code. Or, there may be a -C discontinuity or a singularity in the -C solution. If you are absolutely certain -C you want to continue, you should restart -C the integration. -C -C IDID =-10, DDASSL had multiple convergence test failures -C because IRES was equal to minus one. -C If you are absolutely certain you want -C to continue, you should restart the -C integration. -C -C IDID =-11, IRES=-2 was encountered, and control is being -C returned to the calling program. -C -C IDID =-12, DDASSL failed to compute the initial YPRIME. -C This could happen because the initial -C approximation to YPRIME was not very good, or -C if a YPRIME consistent with the initial Y -C does not exist. The problem could also be caused -C by an inaccurate or singular iteration matrix. -C -C IDID = -13,..,-32 --- Cannot occur with this code. -C -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 -C run being terminated. -C -C -C -------- ERROR MESSAGES --------------------------------------------- -C -C The SLATEC error print routine XERMSG is called in the event of -C unsuccessful completion of a task. Most of these are treated as -C "recoverable errors", which means that (unless the user has directed -C otherwise) control will be returned to the calling program for -C possible action after the message has been printed. -C -C In the event of a negative value of IDID other than -33, an appro- -C priate message is printed and the "error number" printed by XERMSG -C is the value of IDID. There are quite a number of illegal input -C errors that can lead to a returned value IDID=-33. The conditions -C and their printed "error numbers" are as follows: -C -C Error number Condition -C -C 1 Some element of INFO vector is not zero or one. -C 2 NEQ .le. 0 -C 3 MAXORD not in range. -C 4 LRW is less than the required length for RWORK. -C 5 LIW is less than the required length for IWORK. -C 6 Some element of RTOL is .lt. 0 -C 7 Some element of ATOL is .lt. 0 -C 8 All elements of RTOL and ATOL are zero. -C 9 INFO(4)=1 and TSTOP is behind TOUT. -C 10 HMAX .lt. 0.0 -C 11 TOUT is behind T. -C 12 INFO(8)=1 and H0=0.0 -C 13 Some element of WT is .le. 0.0 -C 14 TOUT is too close to T to start integration. -C 15 INFO(4)=1 and TSTOP is behind T. -C 16 --( Not used in this version )-- -C 17 ML illegal. Either .lt. 0 or .gt. NEQ -C 18 MU illegal. Either .lt. 0 or .gt. NEQ -C 19 TOUT = T. -C -C If DDASSL is called again without any action taken to remove the -C cause of an unsuccessful return, XERMSG will be called with a fatal -C error flag, which will cause unconditional termination of the -C program. There are two such fatal errors: -C -C Error number -998: The last step was terminated with a negative -C value of IDID other than -33, and no appropriate action was -C taken. -C -C Error number -999: The previous call was terminated because of -C illegal input (IDID=-33) and there is illegal input in the -C present call, as well. (Suspect infinite loop.) -C -C --------------------------------------------------------------------- -C -C***REFERENCES A DESCRIPTION OF DASSL: A DIFFERENTIAL/ALGEBRAIC -C SYSTEM SOLVER, L. R. PETZOLD, SAND82-8637, -C SANDIA NATIONAL LABORATORIES, SEPTEMBER 1982. -C***ROUTINES CALLED D1MACH, DDAINI, DDANRM, DDASTP, DDATRP, DDAWTS, -C XERMSG -C***REVISION HISTORY (YYMMDD) -C 830315 DATE WRITTEN -C 880387 Code changes made. All common statements have been -C replaced by a DATA statement, which defines pointers into -C RWORK, and PARAMETER statements which define pointers -C into IWORK. As well the documentation has gone through -C grammatical changes. -C 881005 The prologue has been changed to mixed case. -C The subordinate routines had revision dates changed to -C this date, although the documentation for these routines -C is all upper case. No code changes. -C 890511 Code changes made. The DATA statement in the declaration -C section of DDASSL was replaced with a PARAMETER -C statement. Also the statement S = 100.D0 was removed -C from the top of the Newton iteration in DDASTP. -C The subordinate routines had revision dates changed to -C this date. -C 890517 The revision date syntax was replaced with the revision -C history syntax. Also the "DECK" comment was added to -C the top of all subroutines. These changes are consistent -C with new SLATEC guidelines. -C The subordinate routines had revision dates changed to -C this date. No code changes. -C 891013 Code changes made. -C Removed all occurrences of FLOAT or DBLE. All operations -C are now performed with "mixed-mode" arithmetic. -C Also, specific function names were replaced with generic -C function names to be consistent with new SLATEC guidelines. -C In particular: -C Replaced DSQRT with SQRT everywhere. -C Replaced DABS with ABS everywhere. -C Replaced DMIN1 with MIN everywhere. -C Replaced MIN0 with MIN everywhere. -C Replaced DMAX1 with MAX everywhere. -C Replaced MAX0 with MAX everywhere. -C Replaced DSIGN with SIGN everywhere. -C Also replaced REVISION DATE with REVISION HISTORY in all -C subordinate routines. -C 901004 Miscellaneous changes to prologue to complete conversion -C to SLATEC 4.0 format. No code changes. (F.N.Fritsch) -C 901009 Corrected GAMS classification code and converted subsidiary -C routines to 4.0 format. No code changes. (F.N.Fritsch) -C 901010 Converted XERRWV calls to XERMSG calls. (R.Clemens, AFWL) -C 901019 Code changes made. -C Merged SLATEC 4.0 changes with previous changes made -C by C. Ulrich. Below is a history of the changes made by -C C. Ulrich. (Changes in subsidiary routines are implied -C by this history) -C 891228 Bug was found and repaired inside the DDASSL -C and DDAINI routines. DDAINI was incorrectly -C returning the initial T with Y and YPRIME -C computed at T+H. The routine now returns T+H -C rather than the initial T. -C Cosmetic changes made to DDASTP. -C 900904 Three modifications were made to fix a bug (inside -C DDASSL) re interpolation for continuation calls and -C cases where TN is very close to TSTOP: -C -C 1) In testing for whether H is too large, just -C compare H to (TSTOP - TN), rather than -C (TSTOP - TN) * (1-4*UROUND), and set H to -C TSTOP - TN. This will force DDASTP to step -C exactly to TSTOP under certain situations -C (i.e. when H returned from DDASTP would otherwise -C take TN beyond TSTOP). -C -C 2) Inside the DDASTP loop, interpolate exactly to -C TSTOP if TN is very close to TSTOP (rather than -C interpolating to within roundoff of TSTOP). -C -C 3) Modified IDID description for IDID = 2 to say -C that the solution is returned by stepping exactly -C to TSTOP, rather than TOUT. (In some cases the -C solution is actually obtained by extrapolating -C over a distance near unit roundoff to TSTOP, -C but this small distance is deemed acceptable in -C these circumstances.) -C 901026 Added explicit declarations for all variables and minor -C cosmetic changes to prologue, removed unreferenced labels, -C and improved XERMSG calls. (FNF) -C 901030 Added ERROR MESSAGES section and reworked other sections to -C be of more uniform format. (FNF) -C 910624 Fixed minor bug related to HMAX (six lines after label -C 525). (LRP) -C***END PROLOGUE DDASSL -C -C**End -C -C Declare arguments. -C - INTEGER NEQ, INFO(15), IDID, LRW, IWORK(*), LIW, IPAR(*) - DOUBLE PRECISION - * T, Y(*), YPRIME(*), TOUT, RTOL(*), ATOL(*), RWORK(*), - * RPAR(*) - EXTERNAL RES, JAC -C -C Declare externals. -C - EXTERNAL D1MACH, DDAINI, DDANRM, DDASTP, DDATRP, DDAWTS, XERMSG - DOUBLE PRECISION D1MACH, DDANRM -C -C Declare local variables. -C - INTEGER I, ITEMP, LALPHA, LBETA, LCJ, LCJOLD, LCTF, LDELTA, - * LENIW, LENPD, LENRW, LE, LETF, LGAMMA, LH, LHMAX, LHOLD, LIPVT, - * LJCALC, LK, LKOLD, LIWM, LML, LMTYPE, LMU, LMXORD, LNJE, LNPD, - * LNRE, LNS, LNST, LNSTL, LPD, LPHASE, LPHI, LPSI, LROUND, LS, - * LSIGMA, LTN, LTSTOP, LWM, LWT, MBAND, MSAVE, MXORD, NPD, NTEMP, - * NZFLG - DOUBLE PRECISION - * ATOLI, H, HMAX, HMIN, HO, R, RH, RTOLI, TDIST, TN, TNEXT, - * TSTOP, UROUND, YPNORM - LOGICAL DONE -C Auxiliary variables for conversion of values to be included in -C error messages. - CHARACTER*8 XERN1, XERN2 - CHARACTER*16 XERN3, XERN4 -C -C SET POINTERS INTO IWORK - PARAMETER (LML=1, LMU=2, LMXORD=3, LMTYPE=4, LNST=11, - * LNRE=12, LNJE=13, LETF=14, LCTF=15, LNPD=16, - * LIPVT=21, LJCALC=5, LPHASE=6, LK=7, LKOLD=8, - * LNS=9, LNSTL=10, LIWM=1) -C -C SET RELATIVE OFFSET INTO RWORK - PARAMETER (NPD=1) -C -C SET POINTERS INTO RWORK - PARAMETER (LTSTOP=1, LHMAX=2, LH=3, LTN=4, - * LCJ=5, LCJOLD=6, LHOLD=7, LS=8, LROUND=9, - * LALPHA=11, LBETA=17, LGAMMA=23, - * LPSI=29, LSIGMA=35, LDELTA=41) -C -C***FIRST EXECUTABLE STATEMENT DDASSL - 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 EITHER ZERO OR ONE. - DO 10 I=2,11 - IF(INFO(I).NE.0.AND.INFO(I).NE.1)GO TO 701 -10 CONTINUE -C - IF(NEQ.LE.0)GO TO 702 -C -C CHECK AND COMPUTE MAXIMUM ORDER - MXORD=5 - IF(INFO(9).EQ.0)GO TO 20 - MXORD=IWORK(LMXORD) - IF(MXORD.LT.1.OR.MXORD.GT.5)GO TO 703 -20 IWORK(LMXORD)=MXORD -C -C COMPUTE MTYPE,LENPD,LENRW.CHECK ML AND MU. - IF(INFO(6).NE.0)GO TO 40 - LENPD=NEQ**2 - LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD - IF(INFO(5).NE.0)GO TO 30 - IWORK(LMTYPE)=2 - GO TO 60 -30 IWORK(LMTYPE)=1 - GO TO 60 -40 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).NE.0)GO TO 50 - IWORK(LMTYPE)=5 - MBAND=IWORK(LML)+IWORK(LMU)+1 - MSAVE=(NEQ/MBAND)+1 - LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD+2*MSAVE - GO TO 60 -50 IWORK(LMTYPE)=4 - LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD -C -C CHECK LENGTHS OF RWORK AND IWORK -60 LENIW=20+NEQ - IWORK(LNPD)=LENPD - IF(LRW.LT.LENRW)GO TO 704 - IF(LIW.LT.LENIW)GO TO 705 -C -C CHECK TO SEE THAT TOUT IS DIFFERENT FROM T - IF(TOUT .EQ. T)GO TO 719 -C -C CHECK HMAX - IF(INFO(7).EQ.0)GO TO 70 - HMAX=RWORK(LHMAX) - IF(HMAX.LE.0.0D0)GO TO 710 -70 CONTINUE -C -C INITIALIZE COUNTERS - IWORK(LNST)=0 - IWORK(LNRE)=0 - IWORK(LNJE)=0 -C - IWORK(LNSTL)=0 - IDID=1 - GO TO 200 -C -C----------------------------------------------------------------------- -C THIS BLOCK IS FOR CONTINUATION CALLS -C ONLY. HERE WE CHECK INFO(1), AND IF THE -C LAST STEP WAS INTERRUPTED WE CHECK WHETHER -C APPROPRIATE ACTION WAS TAKEN. -C----------------------------------------------------------------------- -C -100 CONTINUE - IF(INFO(1).EQ.1)GO TO 110 - IF(INFO(1).NE.-1)GO TO 701 -C -C IF WE ARE HERE, THE LAST STEP WAS INTERRUPTED -C BY AN ERROR CONDITION FROM DDASTP, AND -C APPROPRIATE ACTION WAS NOT TAKEN. THIS -C IS A FATAL ERROR. - WRITE (XERN1, '(I8)') IDID - CALL XERMSG ('SLATEC', 'DDASSL', - * 'THE LAST STEP TERMINATED WITH A NEGATIVE VALUE OF IDID = ' // - * XERN1 // ' AND NO APPROPRIATE ACTION WAS TAKEN. ' // - * 'RUN TERMINATED', -998, 2) - RETURN -110 CONTINUE - IWORK(LNSTL)=IWORK(LNST) -C -C----------------------------------------------------------------------- -C THIS BLOCK IS EXECUTED ON ALL CALLS. -C THE ERROR TOLERANCE PARAMETERS ARE -C CHECKED, AND THE WORK ARRAY POINTERS -C ARE SET. -C----------------------------------------------------------------------- -C -200 CONTINUE -C CHECK RTOL,ATOL - 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 UP RWORK STORAGE.IWORK STORAGE IS FIXED -C IN DATA STATEMENT. - LE=LDELTA+NEQ - LWT=LE+NEQ - LPHI=LWT+NEQ - LPD=LPHI+(IWORK(LMXORD)+1)*NEQ - LWM=LPD - NTEMP=NPD+IWORK(LNPD) - IF(INFO(1).EQ.1)GO TO 400 -C -C----------------------------------------------------------------------- -C THIS BLOCK IS EXECUTED ON THE INITIAL CALL -C ONLY. SET THE INITIAL STEP SIZE, AND -C THE ERROR WEIGHT VECTOR, AND PHI. -C COMPUTE INITIAL YPRIME, IF NECESSARY. -C----------------------------------------------------------------------- -C - TN=T - IDID=1 -C -C SET ERROR WEIGHT VECTOR WT - CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) - DO 305 I = 1,NEQ - IF(RWORK(LWT+I-1).LE.0.0D0) GO TO 713 -305 CONTINUE -C -C COMPUTE UNIT ROUNDOFF AND HMIN - UROUND = D1MACH(4) - RWORK(LROUND) = UROUND - HMIN = 4.0D0*UROUND*MAX(ABS(T),ABS(TOUT)) -C -C CHECK INITIAL INTERVAL TO SEE THAT IT IS LONG ENOUGH - TDIST = ABS(TOUT - T) - IF(TDIST .LT. HMIN) GO TO 714 -C -C CHECK HO, IF THIS WAS INPUT - IF (INFO(8) .EQ. 0) GO TO 310 - HO = RWORK(LH) - IF ((TOUT - T)*HO .LT. 0.0D0) GO TO 711 - IF (HO .EQ. 0.0D0) GO TO 712 - GO TO 320 -310 CONTINUE -C -C COMPUTE INITIAL STEPSIZE, TO BE USED BY EITHER -C DDASTP OR DDAINI, DEPENDING ON INFO(11) - HO = 0.001D0*TDIST - YPNORM = DDANRM(NEQ,YPRIME,RWORK(LWT),RPAR,IPAR) - IF (YPNORM .GT. 0.5D0/HO) HO = 0.5D0/YPNORM - HO = SIGN(HO,TOUT-T) -C ADJUST HO IF NECESSARY TO MEET HMAX BOUND -320 IF (INFO(7) .EQ. 0) GO TO 330 - RH = ABS(HO)/RWORK(LHMAX) - IF (RH .GT. 1.0D0) HO = HO/RH -C COMPUTE TSTOP, IF APPLICABLE -330 IF (INFO(4) .EQ. 0) GO TO 340 - TSTOP = RWORK(LTSTOP) - IF ((TSTOP - T)*HO .LT. 0.0D0) GO TO 715 - IF ((T + HO - TSTOP)*HO .GT. 0.0D0) HO = TSTOP - T - IF ((TSTOP - TOUT)*HO .LT. 0.0D0) GO TO 709 -C -C COMPUTE INITIAL DERIVATIVE, UPDATING TN AND Y, IF APPLICABLE -340 IF (INFO(11) .EQ. 0) GO TO 350 - CALL DDAINI(TN,Y,YPRIME,NEQ, - * RES,JAC,HO,RWORK(LWT),IDID,RPAR,IPAR, - * RWORK(LPHI),RWORK(LDELTA),RWORK(LE), - * RWORK(LWM),IWORK(LIWM),HMIN,RWORK(LROUND), - * INFO(10),NTEMP) - IF (IDID .LT. 0) GO TO 390 -C -C LOAD H WITH HO. STORE H IN RWORK(LH) -350 H = HO - RWORK(LH) = H -C -C LOAD Y AND H*YPRIME INTO PHI(*,1) AND PHI(*,2) - ITEMP = LPHI + NEQ - DO 370 I = 1,NEQ - RWORK(LPHI + I - 1) = Y(I) -370 RWORK(ITEMP + I - 1) = H*YPRIME(I) -C -390 GO TO 500 -C -C------------------------------------------------------- -C THIS BLOCK IS FOR CONTINUATION CALLS ONLY. ITS -C PURPOSE IS TO CHECK STOP CONDITIONS BEFORE -C 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 .GT. 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) - 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) - 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 .GT. 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 CHECK WHETHER WE ARE WITHIN ROUNDOFF OF TSTOP - 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 580 -C -C------------------------------------------------------- -C THE NEXT BLOCK CONTAINS THE CALL TO THE -C ONE-STEP INTEGRATOR DDASTP. -C THIS IS A LOOPING POINT FOR THE INTEGRATION STEPS. -C CHECK FOR TOO MANY STEPS. -C UPDATE WT. -C CHECK FOR TOO MUCH ACCURACY REQUESTED. -C COMPUTE MINIMUM STEPSIZE. -C------------------------------------------------------- -C -500 CONTINUE -C CHECK FOR FAILURE TO COMPUTE INITIAL YPRIME - IF (IDID .EQ. -12) GO TO 527 -C -C CHECK FOR TOO MANY STEPS - IF((IWORK(LNST)-IWORK(LNSTL)).LT.500) - * GO TO 510 - IDID=-1 - GO TO 527 -C -C UPDATE WT -510 CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,RWORK(LPHI), - * RWORK(LWT),RPAR,IPAR) - DO 520 I=1,NEQ - IF(RWORK(I+LWT-1).GT.0.0D0)GO TO 520 - IDID=-3 - GO TO 527 -520 CONTINUE -C -C TEST FOR TOO MUCH ACCURACY REQUESTED. - R=DDANRM(NEQ,RWORK(LPHI),RWORK(LWT),RPAR,IPAR)* - * 100.0D0*UROUND - IF(R.LE.1.0D0)GO TO 525 -C MULTIPLY RTOL AND ATOL BY R AND RETURN - 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 - 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 - CALL DDASTP(TN,Y,YPRIME,NEQ, - * RES,JAC,H,RWORK(LWT),INFO(1),IDID,RPAR,IPAR, - * RWORK(LPHI),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), - * IWORK(LPHASE),IWORK(LJCALC),IWORK(LK), - * IWORK(LKOLD),IWORK(LNS),INFO(10),NTEMP) -527 IF(IDID.LT.0)GO TO 600 -C -C-------------------------------------------------------- -C THIS BLOCK HANDLES THE CASE OF A SUCCESSFUL RETURN -C FROM DDASTP (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 - GO TO 580 -C -C-------------------------------------------------------- -C ALL SUCCESSFUL RETURNS FROM DDASSL ARE MADE FROM -C THIS BLOCK. -C-------------------------------------------------------- -C -580 CONTINUE - RWORK(LTN)=TN - RWORK(LH)=H - RETURN -C -C----------------------------------------------------------------------- -C THIS BLOCK HANDLES ALL UNSUCCESSFUL -C RETURNS OTHER THAN FOR ILLEGAL INPUT. -C----------------------------------------------------------------------- -C -600 CONTINUE - ITEMP=-IDID - GO TO (610,620,630,690,690,640,650,660,670,675, - * 680,685), ITEMP -C -C THE MAXIMUM NUMBER OF STEPS WAS TAKEN BEFORE -C REACHING TOUT -610 WRITE (XERN3, '(1P,D15.6)') TN - CALL XERMSG ('SLATEC', 'DDASSL', - * 'AT CURRENT T = ' // XERN3 // ' 500 STEPS TAKEN ON THIS ' // - * 'CALL BEFORE REACHING TOUT', IDID, 1) - GO TO 690 -C -C TOO MUCH ACCURACY FOR MACHINE PRECISION -620 WRITE (XERN3, '(1P,D15.6)') TN - CALL XERMSG ('SLATEC', 'DDASSL', - * 'AT T = ' // XERN3 // ' TOO MUCH ACCURACY REQUESTED FOR ' // - * 'PRECISION OF MACHINE. RTOL AND ATOL WERE INCREASED TO ' // - * 'APPROPRIATE VALUES', IDID, 1) - GO TO 690 -C -C WT(I) .LE. 0.0 FOR SOME I (NOT AT START OF PROBLEM) -630 WRITE (XERN3, '(1P,D15.6)') TN - CALL XERMSG ('SLATEC', 'DDASSL', - * 'AT T = ' // XERN3 // ' SOME ELEMENT OF WT HAS BECOME .LE. ' // - * '0.0', IDID, 1) - GO TO 690 -C -C ERROR TEST FAILED REPEATEDLY OR WITH H=HMIN -640 WRITE (XERN3, '(1P,D15.6)') TN - WRITE (XERN4, '(1P,D15.6)') H - CALL XERMSG ('SLATEC', 'DDASSL', - * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // - * ' THE ERROR TEST FAILED REPEATEDLY OR WITH ABS(H)=HMIN', - * IDID, 1) - GO TO 690 -C -C CORRECTOR CONVERGENCE FAILED REPEATEDLY OR WITH H=HMIN -650 WRITE (XERN3, '(1P,D15.6)') TN - WRITE (XERN4, '(1P,D15.6)') H - CALL XERMSG ('SLATEC', 'DDASSL', - * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // - * ' THE CORRECTOR FAILED TO CONVERGE REPEATEDLY OR WITH ' // - * 'ABS(H)=HMIN', IDID, 1) - GO TO 690 -C -C THE ITERATION MATRIX IS SINGULAR -660 WRITE (XERN3, '(1P,D15.6)') TN - WRITE (XERN4, '(1P,D15.6)') H - CALL XERMSG ('SLATEC', 'DDASSL', - * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // - * ' THE ITERATION MATRIX IS SINGULAR', IDID, 1) - GO TO 690 -C -C CORRECTOR FAILURE PRECEDED BY ERROR TEST FAILURES. -670 WRITE (XERN3, '(1P,D15.6)') TN - WRITE (XERN4, '(1P,D15.6)') H - CALL XERMSG ('SLATEC', 'DDASSL', - * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // - * ' THE CORRECTOR COULD NOT CONVERGE. ALSO, THE ERROR TEST ' // - * 'FAILED REPEATEDLY.', IDID, 1) - GO TO 690 -C -C CORRECTOR FAILURE BECAUSE IRES = -1 -675 WRITE (XERN3, '(1P,D15.6)') TN - WRITE (XERN4, '(1P,D15.6)') H - CALL XERMSG ('SLATEC', 'DDASSL', - * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // - * ' THE CORRECTOR COULD NOT CONVERGE BECAUSE IRES WAS EQUAL ' // - * 'TO MINUS ONE', IDID, 1) - GO TO 690 -C -C FAILURE BECAUSE IRES = -2 -680 WRITE (XERN3, '(1P,D15.6)') TN - WRITE (XERN4, '(1P,D15.6)') H - CALL XERMSG ('SLATEC', 'DDASSL', - * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // - * ' IRES WAS EQUAL TO MINUS TWO', IDID, 1) - GO TO 690 -C -C FAILED TO COMPUTE INITIAL YPRIME -685 WRITE (XERN3, '(1P,D15.6)') TN - WRITE (XERN4, '(1P,D15.6)') HO - CALL XERMSG ('SLATEC', 'DDASSL', - * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // - * ' THE INITIAL YPRIME COULD NOT BE COMPUTED', IDID, 1) - GO TO 690 -C -690 CONTINUE - INFO(1)=-1 - T=TN - RWORK(LTN)=TN - RWORK(LH)=H - RETURN -C -C----------------------------------------------------------------------- -C THIS BLOCK HANDLES ALL ERROR RETURNS DUE -C TO ILLEGAL INPUT, AS DETECTED BEFORE CALLING -C DDASTP. FIRST THE ERROR MESSAGE ROUTINE IS -C CALLED. IF THIS HAPPENS TWICE IN -C SUCCESSION, EXECUTION IS TERMINATED -C -C----------------------------------------------------------------------- -701 CALL XERMSG ('SLATEC', 'DDASSL', - * 'SOME ELEMENT OF INFO VECTOR IS NOT ZERO OR ONE', 1, 1) - GO TO 750 -C -702 WRITE (XERN1, '(I8)') NEQ - CALL XERMSG ('SLATEC', 'DDASSL', - * 'NEQ = ' // XERN1 // ' .LE. 0', 2, 1) - GO TO 750 -C -703 WRITE (XERN1, '(I8)') MXORD - CALL XERMSG ('SLATEC', 'DDASSL', - * 'MAXORD = ' // XERN1 // ' NOT IN RANGE', 3, 1) - GO TO 750 -C -704 WRITE (XERN1, '(I8)') LENRW - WRITE (XERN2, '(I8)') LRW - CALL XERMSG ('SLATEC', 'DDASSL', - * 'RWORK LENGTH NEEDED, LENRW = ' // XERN1 // - * ', EXCEEDS LRW = ' // XERN2, 4, 1) - GO TO 750 -C -705 WRITE (XERN1, '(I8)') LENIW - WRITE (XERN2, '(I8)') LIW - CALL XERMSG ('SLATEC', 'DDASSL', - * 'IWORK LENGTH NEEDED, LENIW = ' // XERN1 // - * ', EXCEEDS LIW = ' // XERN2, 5, 1) - GO TO 750 -C -706 CALL XERMSG ('SLATEC', 'DDASSL', - * 'SOME ELEMENT OF RTOL IS .LT. 0', 6, 1) - GO TO 750 -C -707 CALL XERMSG ('SLATEC', 'DDASSL', - * 'SOME ELEMENT OF ATOL IS .LT. 0', 7, 1) - GO TO 750 -C -708 CALL XERMSG ('SLATEC', 'DDASSL', - * 'ALL ELEMENTS OF RTOL AND ATOL ARE ZERO', 8, 1) - GO TO 750 -C -709 WRITE (XERN3, '(1P,D15.6)') TSTOP - WRITE (XERN4, '(1P,D15.6)') TOUT - CALL XERMSG ('SLATEC', 'DDASSL', - * 'INFO(4) = 1 AND TSTOP = ' // XERN3 // ' BEHIND TOUT = ' // - * XERN4, 9, 1) - GO TO 750 -C -710 WRITE (XERN3, '(1P,D15.6)') HMAX - CALL XERMSG ('SLATEC', 'DDASSL', - * 'HMAX = ' // XERN3 // ' .LT. 0.0', 10, 1) - GO TO 750 -C -711 WRITE (XERN3, '(1P,D15.6)') TOUT - WRITE (XERN4, '(1P,D15.6)') T - CALL XERMSG ('SLATEC', 'DDASSL', - * 'TOUT = ' // XERN3 // ' BEHIND T = ' // XERN4, 11, 1) - GO TO 750 -C -712 CALL XERMSG ('SLATEC', 'DDASSL', - * 'INFO(8)=1 AND H0=0.0', 12, 1) - GO TO 750 -C -713 CALL XERMSG ('SLATEC', 'DDASSL', - * 'SOME ELEMENT OF WT IS .LE. 0.0', 13, 1) - GO TO 750 -C -714 WRITE (XERN3, '(1P,D15.6)') TOUT - WRITE (XERN4, '(1P,D15.6)') T - CALL XERMSG ('SLATEC', 'DDASSL', - * 'TOUT = ' // XERN3 // ' TOO CLOSE TO T = ' // XERN4 // - * ' TO START INTEGRATION', 14, 1) - GO TO 750 -C -715 WRITE (XERN3, '(1P,D15.6)') TSTOP - WRITE (XERN4, '(1P,D15.6)') T - CALL XERMSG ('SLATEC', 'DDASSL', - * 'INFO(4)=1 AND TSTOP = ' // XERN3 // ' BEHIND T = ' // XERN4, - * 15, 1) - GO TO 750 -C -717 WRITE (XERN1, '(I8)') IWORK(LML) - CALL XERMSG ('SLATEC', 'DDASSL', - * 'ML = ' // XERN1 // ' ILLEGAL. EITHER .LT. 0 OR .GT. NEQ', - * 17, 1) - GO TO 750 -C -718 WRITE (XERN1, '(I8)') IWORK(LMU) - CALL XERMSG ('SLATEC', 'DDASSL', - * 'MU = ' // XERN1 // ' ILLEGAL. EITHER .LT. 0 OR .GT. NEQ', - * 18, 1) - GO TO 750 -C -719 WRITE (XERN3, '(1P,D15.6)') TOUT - CALL XERMSG ('SLATEC', 'DDASSL', - * 'TOUT = T = ' // XERN3, 19, 1) - GO TO 750 -C -750 IDID=-33 - IF(INFO(1).EQ.-1) THEN - CALL XERMSG ('SLATEC', 'DDASSL', - * 'REPEATED OCCURRENCES OF ILLEGAL INPUT$$' // - * 'RUN TERMINATED. APPARENT INFINITE LOOP', -999, 2) - ENDIF -C - INFO(1)=-1 - RETURN -C-----------END OF SUBROUTINE DDASSL------------------------------------ - END diff --git a/slatec/ddastp.f b/slatec/ddastp.f deleted file mode 100644 index 1564046..0000000 --- a/slatec/ddastp.f +++ /dev/null @@ -1,613 +0,0 @@ -*DECK DDASTP - SUBROUTINE DDASTP (X, Y, YPRIME, NEQ, RES, JAC, H, WT, JSTART, - * IDID, RPAR, IPAR, PHI, DELTA, E, WM, IWM, ALPHA, BETA, GAMMA, - * PSI, SIGMA, CJ, CJOLD, HOLD, S, HMIN, UROUND, IPHASE, JCALC, K, - * KOLD, NS, NONNEG, NTEMP) -C***BEGIN PROLOGUE DDASTP -C***SUBSIDIARY -C***PURPOSE Perform one step of the DDASSL integration. -C***LIBRARY SLATEC (DASSL) -C***TYPE DOUBLE PRECISION (SDASTP-S, DDASTP-D) -C***AUTHOR Petzold, Linda R., (LLNL) -C***DESCRIPTION -C----------------------------------------------------------------------- -C DDASTP SOLVES A SYSTEM OF DIFFERENTIAL/ -C ALGEBRAIC EQUATIONS OF THE FORM -C G(X,Y,YPRIME) = 0, FOR ONE STEP (NORMALLY -C FROM X TO X+H). -C -C THE METHODS USED ARE MODIFIED DIVIDED -C DIFFERENCE,FIXED LEADING COEFFICIENT -C FORMS OF BACKWARD DIFFERENTIATION -C FORMULAS. THE CODE ADJUSTS THE STEPSIZE -C AND ORDER TO CONTROL THE LOCAL ERROR PER -C 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. THE CALL IS -C CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR) -C X,Y,YPRIME ARE INPUT. DELTA IS OUTPUT. -C ON INPUT, IRES=0. RES SHOULD ALTER IRES ONLY -C IF IT ENCOUNTERS AN ILLEGAL VALUE OF Y OR A -C STOP CONDITION. SET IRES=-1 IF AN INPUT VALUE -C OF Y IS ILLEGAL, AND DDASTP WILL TRY TO SOLVE -C THE PROBLEM WITHOUT GETTING IRES = -1. IF -C IRES=-2, DDASTP RETURNS CONTROL TO THE CALLING -C PROGRAM WITH IDID = -11. -C JAC -- EXTERNAL USER-SUPPLIED ROUTINE TO EVALUATE -C THE ITERATION MATRIX (THIS IS OPTIONAL) -C THE CALL IS OF THE FORM -C CALL JAC(X,Y,YPRIME,PD,CJ,RPAR,IPAR) -C PD IS THE MATRIX OF PARTIAL DERIVATIVES, -C PD=DG/DY+CJ*DG/DYPRIME -C H -- APPROPRIATE STEP SIZE FOR NEXT STEP. -C NORMALLY DETERMINED BY THE CODE -C WT -- VECTOR OF WEIGHTS FOR ERROR CRITERION. -C JSTART -- INTEGER VARIABLE SET 0 FOR -C FIRST STEP, 1 OTHERWISE. -C IDID -- COMPLETION CODE WITH THE FOLLOWING MEANINGS: -C IDID= 1 -- THE STEP WAS COMPLETED SUCCESSFULLY -C IDID=-6 -- THE ERROR TEST FAILED REPEATEDLY -C IDID=-7 -- THE CORRECTOR COULD NOT CONVERGE -C IDID=-8 -- THE ITERATION MATRIX IS SINGULAR -C IDID=-9 -- THE CORRECTOR COULD NOT CONVERGE. -C THERE WERE REPEATED ERROR TEST -C FAILURES ON THIS STEP. -C IDID=-10-- THE CORRECTOR COULD NOT CONVERGE -C BECAUSE IRES WAS EQUAL TO MINUS ONE -C IDID=-11-- IRES EQUAL TO -2 WAS ENCOUNTERED, -C AND CONTROL IS BEING RETURNED TO -C THE CALLING PROGRAM -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 DDASTP -C PHI -- ARRAY OF DIVIDED DIFFERENCES USED BY -C DDASTP. THE LENGTH IS NEQ*(K+1),WHERE -C K IS THE MAXIMUM ORDER -C DELTA,E -- WORK VECTORS FOR DDASTP 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 -C THE OTHER PARAMETERS ARE INFORMATION -C WHICH IS NEEDED INTERNALLY BY DDASTP TO -C CONTINUE FROM STEP TO STEP. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED DDAJAC, DDANRM, DDASLV, DDATRP -C***REVISION HISTORY (YYMMDD) -C 830315 DATE WRITTEN -C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) -C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. -C 901026 Added explicit declarations for all variables and minor -C cosmetic changes to prologue. (FNF) -C***END PROLOGUE DDASTP -C - INTEGER NEQ, JSTART, IDID, IPAR(*), IWM(*), IPHASE, JCALC, K, - * KOLD, NS, NONNEG, NTEMP - DOUBLE PRECISION - * X, Y(*), YPRIME(*), H, WT(*), RPAR(*), PHI(NEQ,*), DELTA(*), - * E(*), WM(*), ALPHA(*), BETA(*), GAMMA(*), PSI(*), SIGMA(*), CJ, - * CJOLD, HOLD, S, HMIN, UROUND - EXTERNAL RES, JAC -C - EXTERNAL DDAJAC, DDANRM, DDASLV, DDATRP - DOUBLE PRECISION DDANRM -C - INTEGER I, IER, IRES, J, J1, KDIFF, KM1, KNEW, KP1, KP2, LCTF, - * LETF, LMXORD, LNJE, LNRE, LNST, M, MAXIT, NCF, NEF, NSF, NSP1 - DOUBLE PRECISION - * ALPHA0, ALPHAS, CJLAST, CK, DELNRM, ENORM, ERK, ERKM1, - * ERKM2, ERKP1, ERR, EST, HNEW, OLDNRM, PNORM, R, RATE, TEMP1, - * TEMP2, TERK, TERKM1, TERKM2, TERKP1, XOLD, XRATE - LOGICAL CONVGD -C - PARAMETER (LMXORD=3) - PARAMETER (LNST=11) - PARAMETER (LNRE=12) - PARAMETER (LNJE=13) - PARAMETER (LETF=14) - PARAMETER (LCTF=15) -C - DATA MAXIT/4/ - DATA XRATE/0.25D0/ -C -C -C -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***FIRST EXECUTABLE STATEMENT DDASTP - IDID=1 - XOLD=X - NCF=0 - NSF=0 - NEF=0 - IF(JSTART .NE. 0) GO TO 120 -C -C IF THIS IS THE FIRST STEP,PERFORM -C OTHER INITIALIZATIONS - IWM(LETF) = 0 - IWM(LCTF) = 0 - K=1 - KOLD=0 - HOLD=0.0D0 - JSTART=1 - PSI(1)=H - CJOLD = 1.0D0/H - CJ = CJOLD - S = 100.D0 - JCALC = -1 - DELNRM=1.0D0 - 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 - XOLD=X - IF(H.NE.HOLD.OR.K .NE. KOLD) NS = 0 - NS=MIN(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 - 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 - CJLAST = CJ - CJ = -ALPHAS/H -C -C COMPUTE VARIABLE STEPSIZE ERROR COEFFICIENT CK - CK = ABS(ALPHA(KP1) + ALPHAS - ALPHA0) - CK = MAX(CK,ALPHA(KP1)) -C -C DECIDE WHETHER NEW JACOBIAN IS NEEDED - 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 CHANGE PHI TO PHI STAR - 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 - X=X+H -C -C -C -C -C -C----------------------------------------------------------------------- -C BLOCK 3 -C PREDICT THE SOLUTION AND DERIVATIVE, -C AND SOLVE THE CORRECTOR EQUATION -C----------------------------------------------------------------------- -C -C FIRST,PREDICT THE SOLUTION AND DERIVATIVE -300 CONTINUE - 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 = DDANRM (NEQ,Y,WT,RPAR,IPAR) -C -C -C -C SOLVE THE CORRECTOR EQUATION USING A -C MODIFIED NEWTON SCHEME. - CONVGD= .TRUE. - M=0 - IWM(LNRE)=IWM(LNRE)+1 - IRES = 0 - CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR) - IF (IRES .LT. 0) GO TO 380 -C -C -C IF INDICATED,REEVALUATE THE -C ITERATION MATRIX PD = DG/DY + CJ*DG/DYPRIME -C (WHERE G(X,Y,YPRIME)=0). SET -C JCALC TO 0 AS AN INDICATOR THAT -C THIS HAS BEEN DONE. - IF(JCALC .NE. -1)GO TO 340 - IWM(LNJE)=IWM(LNJE)+1 - JCALC=0 - CALL DDAJAC(NEQ,X,Y,YPRIME,DELTA,CJ,H, - * IER,WT,E,WM,IWM,RES,IRES,UROUND,JAC,RPAR, - * IPAR,NTEMP) - CJOLD=CJ - S = 100.D0 - IF (IRES .LT. 0) GO TO 380 - IF(IER .NE. 0)GO TO 380 - NSF=0 -C -C -C INITIALIZE THE ERROR ACCUMULATION VECTOR E. -340 CONTINUE - DO 345 I=1,NEQ -345 E(I)=0.0D0 -C -C -C CORRECTOR LOOP. -350 CONTINUE -C -C MULTIPLY RESIDUAL BY TEMP1 TO ACCELERATE CONVERGENCE - TEMP1 = 2.0D0/(1.0D0 + CJ/CJOLD) - DO 355 I = 1,NEQ -355 DELTA(I) = DELTA(I) * TEMP1 -C -C COMPUTE A NEW ITERATE (BACK-SUBSTITUTION). -C STORE THE CORRECTION IN DELTA. - CALL DDASLV(NEQ,DELTA,WM,IWM) -C -C UPDATE Y, E, AND YPRIME - 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 - DELNRM=DDANRM(NEQ,DELTA,WT,RPAR,IPAR) - IF (DELNRM .LE. 100.D0*UROUND*PNORM) GO TO 375 - IF (M .GT. 0) GO TO 365 - OLDNRM = DELNRM - GO TO 367 -365 RATE = (DELNRM/OLDNRM)**(1.0D0/M) - IF (RATE .GT. 0.90D0) GO TO 370 - S = RATE/(1.0D0 - RATE) -367 IF (S*DELNRM .LE. 0.33D0) GO TO 375 -C -C THE CORRECTOR HAS NOT YET CONVERGED. -C UPDATE M AND TEST WHETHER THE -C MAXIMUM NUMBER OF ITERATIONS HAVE -C BEEN TRIED. - M=M+1 - IF(M.GE.MAXIT)GO TO 370 -C -C EVALUATE THE RESIDUAL -C AND GO BACK TO DO ANOTHER ITERATION - IWM(LNRE)=IWM(LNRE)+1 - IRES = 0 - CALL RES(X,Y,YPRIME,DELTA,IRES, - * RPAR,IPAR) - IF (IRES .LT. 0) GO TO 380 - GO TO 350 -C -C -C THE CORRECTOR FAILED TO CONVERGE IN MAXIT -C ITERATIONS. IF THE ITERATION MATRIX -C IS NOT CURRENT,RE-DO THE STEP WITH -C A NEW ITERATION MATRIX. -370 CONTINUE - IF(JCALC.EQ.0)GO TO 380 - JCALC=-1 - GO TO 300 -C -C -C THE ITERATION HAS CONVERGED. IF NONNEGATIVITY OF SOLUTION IS -C REQUIRED, SET THE SOLUTION NONNEGATIVE, IF THE PERTURBATION -C TO DO IT IS SMALL ENOUGH. IF THE CHANGE IS TOO LARGE, THEN -C CONSIDER THE CORRECTOR ITERATION TO HAVE FAILED. -375 IF(NONNEG .EQ. 0) GO TO 390 - DO 377 I = 1,NEQ -377 DELTA(I) = MIN(Y(I),0.0D0) - DELNRM = DDANRM(NEQ,DELTA,WT,RPAR,IPAR) - IF(DELNRM .GT. 0.33D0) GO TO 380 - DO 378 I = 1,NEQ -378 E(I) = E(I) - DELTA(I) - GO TO 390 -C -C -C EXITS FROM BLOCK 3 -C NO CONVERGENCE WITH CURRENT ITERATION -C MATRIX,OR SINGULAR ITERATION MATRIX -380 CONVGD= .FALSE. -390 JCALC = 1 - IF(.NOT.CONVGD)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 - ENORM = DDANRM(NEQ,E,WT,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)*DDANRM(NEQ,DELTA,WT,RPAR,IPAR) - TERKM1 = K*ERKM1 - IF(K .GT. 2)GO TO 410 - IF(TERKM1 .LE. 0.5D0*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)*DDANRM(NEQ,DELTA,WT,RPAR,IPAR) - TERKM2 = (K-1)*ERKM2 - IF(MAX(TERKM1,TERKM2).GT.TERK)GO TO 430 -C LOWER THE ORDER -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 -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 - 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))*DDANRM(NEQ,DELTA,WT,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 -530 K=KP1 - EST = ERKP1 - GO TO 550 -C -C LOWER ORDER -540 K=KM1 - EST = ERKM1 - GO TO 550 -C -C IF IPHASE = 0, INCREASE ORDER BY ONE AND MULTIPLY STEPSIZE BY -C FACTOR TWO -545 K = KP1 - HNEW = H*2.0D0 - H = HNEW - GO TO 575 -C -C -C DETERMINE THE APPROPRIATE STEPSIZE FOR -C THE NEXT STEP. -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 -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) - 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 - 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 CORRECTOR ITERATION -C OR ERROR TEST - IF(CONVGD)GO TO 660 - IWM(LCTF)=IWM(LCTF)+1 -C -C -C THE NEWTON ITERATION FAILED TO CONVERGE WITH -C A CURRENT ITERATION MATRIX. DETERMINE THE CAUSE -C OF THE FAILURE AND TAKE APPROPRIATE ACTION. - IF(IER.EQ.0)GO TO 650 -C -C THE ITERATION MATRIX IS SINGULAR. REDUCE -C THE STEPSIZE BY A FACTOR OF 4. IF -C THIS HAPPENS THREE TIMES IN A ROW ON -C THE SAME STEP, RETURN WITH AN ERROR FLAG - NSF=NSF+1 - R = 0.25D0 - H=H*R - IF (NSF .LT. 3 .AND. ABS(H) .GE. HMIN) GO TO 690 - IDID=-8 - GO TO 675 -C -C -C THE NEWTON ITERATION FAILED TO CONVERGE FOR A REASON -C OTHER THAN A SINGULAR ITERATION MATRIX. IF IRES = -2, THEN -C RETURN. OTHERWISE, REDUCE THE STEPSIZE AND TRY AGAIN, UNLESS -C TOO MANY FAILURES HAVE OCCURRED. -650 CONTINUE - IF (IRES .GT. -2) GO TO 655 - IDID = -11 - GO TO 675 -655 NCF = NCF + 1 - R = 0.25D0 - H = H*R - IF (NCF .LT. 10 .AND. ABS(H) .GE. HMIN) GO TO 690 - IDID = -7 - IF (IRES .LT. 0) IDID = -10 - IF (NEF .GE. 3) IDID = -9 - GO TO 675 -C -C -C THE NEWTON SCHEME CONVERGED, AND THE CAUSE -C OF THE FAILURE WAS THE ERROR ESTIMATE -C EXCEEDING THE TOLERANCE. -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. - 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 FOUR. -665 IF (NEF .GT. 2) GO TO 670 - K = KNEW - H = 0.25D0*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 FOUR. -670 K = 1 - H = 0.25D0*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 -675 CONTINUE - CALL DDATRP(X,X,Y,YPRIME,NEQ,K,PHI,PSI) - RETURN -C -C -C GO BACK AND TRY THIS STEP AGAIN -690 GO TO 200 -C -C------END OF SUBROUTINE DDASTP------ - END diff --git a/slatec/ddatrp.f b/slatec/ddatrp.f deleted file mode 100644 index ccc3f3c..0000000 --- a/slatec/ddatrp.f +++ /dev/null @@ -1,65 +0,0 @@ -*DECK DDATRP - SUBROUTINE DDATRP (X, XOUT, YOUT, YPOUT, NEQ, KOLD, PHI, PSI) -C***BEGIN PROLOGUE DDATRP -C***SUBSIDIARY -C***PURPOSE Interpolation routine for DDASSL. -C***LIBRARY SLATEC (DASSL) -C***TYPE DOUBLE PRECISION (SDATRP-S, DDATRP-D) -C***AUTHOR Petzold, Linda R., (LLNL) -C***DESCRIPTION -C----------------------------------------------------------------------- -C THE METHODS IN SUBROUTINE DDASTP 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 DDASTP, SO DDATRP CANNOT BE USED ALONE. -C -C THE PARAMETERS ARE: -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***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 830315 DATE WRITTEN -C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) -C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. -C 901026 Added explicit declarations for all variables and minor -C cosmetic changes to prologue. (FNF) -C***END PROLOGUE DDATRP -C - INTEGER NEQ, KOLD - DOUBLE PRECISION X, XOUT, YOUT(*), YPOUT(*), PHI(NEQ,*), PSI(*) -C - INTEGER I, J, KOLDP1 - DOUBLE PRECISION C, D, GAMMA, TEMP1 -C -C***FIRST EXECUTABLE STATEMENT DDATRP - 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 diff --git a/slatec/ddaws.f b/slatec/ddaws.f deleted file mode 100644 index 96f0e86..0000000 --- a/slatec/ddaws.f +++ /dev/null @@ -1,229 +0,0 @@ -*DECK DDAWS - DOUBLE PRECISION FUNCTION DDAWS (X) -C***BEGIN PROLOGUE DDAWS -C***PURPOSE Compute Dawson's function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C8C -C***TYPE DOUBLE PRECISION (DAWS-S, DDAWS-D) -C***KEYWORDS DAWSON'S FUNCTION, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DDAWS(X) calculates the double precision Dawson's integral -C for double precision argument X. -C -C Series for DAW on the interval 0. to 1.00000E+00 -C with weighted error 8.95E-32 -C log weighted error 31.05 -C significant figures required 30.41 -C decimal places required 31.71 -C -C Series for DAW2 on the interval 0. to 1.60000E+01 -C with weighted error 1.61E-32 -C log weighted error 31.79 -C significant figures required 31.40 -C decimal places required 32.62 -C -C Series for DAWA on the interval 0. to 6.25000E-02 -C with weighted error 1.97E-32 -C log weighted error 31.71 -C significant figures required 29.79 -C decimal places required 32.64 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 780401 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 920618 Removed space from variable names. (RWC, WRB) -C***END PROLOGUE DDAWS - DOUBLE PRECISION X, DAWCS(21), DAW2CS(45), DAWACS(75), XBIG, - 1 XMAX, XSML, Y, DCSEVL, D1MACH - LOGICAL FIRST - SAVE DAWCS, DAW2CS, DAWACS, NTDAW, NTDAW2, NTDAWA, - 1 XSML, XBIG, XMAX, FIRST - DATA DAWCS( 1) / -.6351734375 1459492010 6512773629 3 D-2 / - DATA DAWCS( 2) / -.2294071479 6773869398 9982412586 6 D+0 / - DATA DAWCS( 3) / +.2213050093 9084764416 8397916178 6 D-1 / - DATA DAWCS( 4) / -.1549265453 8929850467 4305775337 5 D-2 / - DATA DAWCS( 5) / +.8497327715 6849174567 7754294806 6 D-4 / - DATA DAWCS( 6) / -.3828266270 9720149249 9409952130 9 D-5 / - DATA DAWCS( 7) / +.1462854806 2501631977 5714894953 9 D-6 / - DATA DAWCS( 8) / -.4851982381 8259917988 4671542511 4 D-8 / - DATA DAWCS( 9) / +.1421463577 7591397903 4756818330 4 D-9 / - DATA DAWCS( 10) / -.3728836087 9205965253 3549305408 8 D-11 / - DATA DAWCS( 11) / +.8854942961 7782033701 9456523136 9 D-13 / - DATA DAWCS( 12) / -.1920757131 3502063554 2164841749 3 D-14 / - DATA DAWCS( 13) / +.3834325867 2463275882 4107443925 3 D-16 / - DATA DAWCS( 14) / -.7089154168 1758816335 8409932799 9 D-18 / - DATA DAWCS( 15) / +.1220552135 8894576744 1690112000 0 D-19 / - DATA DAWCS( 16) / -.1966204826 6053487602 9945173333 3 D-21 / - DATA DAWCS( 17) / +.2975845541 3765971891 1317333333 3 D-23 / - DATA DAWCS( 18) / -.4247069514 8005969510 3999999999 9 D-25 / - DATA DAWCS( 19) / +.5734270767 3917427985 0666666666 6 D-27 / - DATA DAWCS( 20) / -.7345836823 1784502613 3333333333 3 D-29 / - DATA DAWCS( 21) / +.8951937667 5165525333 3333333333 3 D-31 / - DATA DAW2CS( 1) / -.5688654410 5215527114 1605337336 74 D-1 / - DATA DAW2CS( 2) / -.3181134699 6168131279 3228780488 22 D+0 / - DATA DAW2CS( 3) / +.2087384541 3642236789 7415801988 58 D+0 / - DATA DAW2CS( 4) / -.1247540991 3779131214 0734983147 84 D+0 / - DATA DAW2CS( 5) / +.6786930518 6676777092 8475164236 76 D-1 / - DATA DAW2CS( 6) / -.3365914489 5270939503 0682309665 87 D-1 / - DATA DAW2CS( 7) / +.1526078127 1987971743 6824603816 40 D-1 / - DATA DAW2CS( 8) / -.6348370962 5962148230 5860947885 35 D-2 / - DATA DAW2CS( 9) / +.2432674092 0748520596 8659661093 43 D-2 / - DATA DAW2CS( 10) / -.8621954149 1065032038 5269835496 37 D-3 / - DATA DAW2CS( 11) / +.2837657333 6321625302 8576365382 95 D-3 / - DATA DAW2CS( 12) / -.8705754987 4170423699 3965814643 35 D-4 / - DATA DAW2CS( 13) / +.2498684998 5481658331 8000441372 76 D-4 / - DATA DAW2CS( 14) / -.6731928676 4160294344 6030503395 20 D-5 / - DATA DAW2CS( 15) / +.1707857878 5573543710 5045240478 44 D-5 / - DATA DAW2CS( 16) / -.4091755122 6475381271 8965924900 38 D-6 / - DATA DAW2CS( 17) / +.9282829221 6755773260 7517853122 73 D-7 / - DATA DAW2CS( 18) / -.1999140361 0147617829 8450963321 98 D-7 / - DATA DAW2CS( 19) / +.4096349064 4082195241 2104878689 17 D-8 / - DATA DAW2CS( 20) / -.8003240954 0993168075 7067817535 61 D-9 / - DATA DAW2CS( 21) / +.1493850312 8761465059 1432255501 10 D-9 / - DATA DAW2CS( 22) / -.2668799988 5622329284 9246510633 39 D-10 / - DATA DAW2CS( 23) / +.4571221698 5159458151 4056177241 03 D-11 / - DATA DAW2CS( 24) / -.7518730522 2043565872 2437273267 71 D-12 / - DATA DAW2CS( 25) / +.1189310005 2629681879 0298289873 02 D-12 / - DATA DAW2CS( 26) / -.1811690793 3852346973 4903182630 84 D-13 / - DATA DAW2CS( 27) / +.2661173368 4358969193 0016121996 26 D-14 / - DATA DAW2CS( 28) / -.3773886305 2129419795 4441099059 30 D-15 / - DATA DAW2CS( 29) / +.5172795378 9087172679 6800822293 29 D-16 / - DATA DAW2CS( 30) / -.6860368408 4077500979 4195646701 02 D-17 / - DATA DAW2CS( 31) / +.8812375135 4161071806 4693373217 45 D-18 / - DATA DAW2CS( 32) / -.1097424824 9996606292 1062996246 52 D-18 / - DATA DAW2CS( 33) / +.1326119932 6367178513 5955458916 35 D-19 / - DATA DAW2CS( 34) / -.1556273276 8137380785 4887765715 62 D-20 / - DATA DAW2CS( 35) / +.1775142558 3655720607 8334155707 73 D-21 / - DATA DAW2CS( 36) / -.1969500696 7006578384 9536087654 39 D-22 / - DATA DAW2CS( 37) / +.2127007489 6998699661 9240101205 33 D-23 / - DATA DAW2CS( 38) / -.2237539812 4627973794 1821139626 66 D-24 / - DATA DAW2CS( 39) / +.2294276857 8582348946 9713831253 33 D-25 / - DATA DAW2CS( 40) / -.2294378884 6552928693 3295923199 99 D-26 / - DATA DAW2CS( 41) / +.2239170210 0592453618 3422976000 00 D-27 / - DATA DAW2CS( 42) / -.2133823061 6608897703 6782250666 66 D-28 / - DATA DAW2CS( 43) / +.1986619658 5123531518 0284586666 66 D-29 / - DATA DAW2CS( 44) / -.1807929586 6694391771 9551999999 99 D-30 / - DATA DAW2CS( 45) / +.1609068601 5283030305 4506666666 66 D-31 / - DATA DAWACS( 1) / +.1690485637 7657037554 2263743884 9 D-1 / - DATA DAWACS( 2) / +.8683252278 4069579905 3610785076 8 D-2 / - DATA DAWACS( 3) / +.2424864042 4177154532 7770345988 9 D-3 / - DATA DAWACS( 4) / +.1261182399 5726900016 5194924037 7 D-4 / - DATA DAWACS( 5) / +.1066453314 6361769557 0569112590 6 D-5 / - DATA DAWACS( 6) / +.1358159794 7907276113 4842450572 8 D-6 / - DATA DAWACS( 7) / +.2171042356 5772983989 0431274474 3 D-7 / - DATA DAWACS( 8) / +.2867010501 8052952703 4367680481 3 D-8 / - DATA DAWACS( 9) / -.1901336393 0358201122 8249237802 4 D-9 / - DATA DAWACS( 10) / -.3097780484 3952011255 3206577426 8 D-9 / - DATA DAWACS( 11) / -.1029414876 0575092473 9813228641 3 D-9 / - DATA DAWACS( 12) / -.6260356459 4595761504 1758728312 1 D-11 / - DATA DAWACS( 13) / +.8563132497 4464512162 6230316627 6 D-11 / - DATA DAWACS( 14) / +.3033045148 0756592929 7626627625 7 D-11 / - DATA DAWACS( 15) / -.2523618306 8092913726 3088693882 6 D-12 / - DATA DAWACS( 16) / -.4210604795 4406645131 7546193451 0 D-12 / - DATA DAWACS( 17) / -.4431140826 6462383121 4342945203 6 D-13 / - DATA DAWACS( 18) / +.4911210272 8412052059 4003706511 7 D-13 / - DATA DAWACS( 19) / +.1235856242 2839034070 7647795473 9 D-13 / - DATA DAWACS( 20) / -.5788733199 0165692469 5576507106 9 D-14 / - DATA DAWACS( 21) / -.2282723294 8073586209 7818395703 0 D-14 / - DATA DAWACS( 22) / +.7637149411 0141264763 1236291759 0 D-15 / - DATA DAWACS( 23) / +.3851546883 5668117287 7759400209 5 D-15 / - DATA DAWACS( 24) / -.1199932056 9282905928 0323728304 5 D-15 / - DATA DAWACS( 25) / -.6313439150 0945723473 3427028525 0 D-16 / - DATA DAWACS( 26) / +.2239559965 9729753752 5491279023 7 D-16 / - DATA DAWACS( 27) / +.9987925830 0764959951 3289120074 9 D-17 / - DATA DAWACS( 28) / -.4681068274 3224953345 3624650725 2 D-17 / - DATA DAWACS( 29) / -.1436303644 3497213372 4162875153 4 D-17 / - DATA DAWACS( 30) / +.1020822731 4105411129 7790803213 0 D-17 / - DATA DAWACS( 31) / +.1538908873 1360920728 3738982237 2 D-18 / - DATA DAWACS( 32) / -.2189157877 6457938888 9479092605 6 D-18 / - DATA DAWACS( 33) / +.2156879197 9386517503 9235915251 7 D-20 / - DATA DAWACS( 34) / +.4370219827 4424498511 3479255739 5 D-19 / - DATA DAWACS( 35) / -.8234581460 9772072410 9892790517 7 D-20 / - DATA DAWACS( 36) / -.7498648721 2564662229 0320283542 0 D-20 / - DATA DAWACS( 37) / +.3282536720 7356716109 5761293003 9 D-20 / - DATA DAWACS( 38) / +.8858064309 5039211160 7656151515 1 D-21 / - DATA DAWACS( 39) / -.9185087111 7270029880 9446053148 5 D-21 / - DATA DAWACS( 40) / +.2978962223 7887489883 1416604579 1 D-22 / - DATA DAWACS( 41) / +.1972132136 6184718831 5950546804 1 D-21 / - DATA DAWACS( 42) / -.5974775596 3629066380 8958499511 7 D-22 / - DATA DAWACS( 43) / -.2834410031 5038509654 4382518244 1 D-22 / - DATA DAWACS( 44) / +.2209560791 1315545147 7715048901 2 D-22 / - DATA DAWACS( 45) / -.5439955741 8971443000 7948030771 1 D-25 / - DATA DAWACS( 46) / -.5213549243 2948486680 1713669647 0 D-23 / - DATA DAWACS( 47) / +.1702350556 8131141990 6567149907 6 D-23 / - DATA DAWACS( 48) / +.6917400860 8361483430 2218566019 7 D-24 / - DATA DAWACS( 49) / -.6540941793 0027525122 3944512580 2 D-24 / - DATA DAWACS( 50) / +.6093576580 4393289603 7182465463 6 D-25 / - DATA DAWACS( 51) / +.1408070432 9051874615 0194508027 2 D-24 / - DATA DAWACS( 52) / -.6785886121 0548463311 6767494375 5 D-25 / - DATA DAWACS( 53) / -.9799732036 2142957117 4158310222 5 D-26 / - DATA DAWACS( 54) / +.2121244903 0990413325 9896093916 0 D-25 / - DATA DAWACS( 55) / -.5954455022 5487909382 3880215448 7 D-26 / - DATA DAWACS( 56) / -.3093088861 8754701778 3884723204 9 D-26 / - DATA DAWACS( 57) / +.2854389216 3445246824 0069198610 4 D-26 / - DATA DAWACS( 58) / -.3951289447 3793055660 2347727181 1 D-27 / - DATA DAWACS( 59) / -.5906000648 6076284781 1684089445 3 D-27 / - DATA DAWACS( 60) / +.3670236964 6686870036 4788998060 9 D-27 / - DATA DAWACS( 61) / -.4839958238 0422762565 9830303894 1 D-29 / - DATA DAWACS( 62) / -.9799265984 2104438695 9740401702 2 D-28 / - DATA DAWACS( 63) / +.4684773732 6121306061 5890880430 0 D-28 / - DATA DAWACS( 64) / +.5030877696 9934610516 4766760315 5 D-29 / - DATA DAWACS( 65) / -.1547395051 7060282392 4755206829 5 D-28 / - DATA DAWACS( 66) / +.6112180185 0864192439 7600566271 4 D-29 / - DATA DAWACS( 67) / +.1357913399 1248116503 4360273615 8 D-29 / - DATA DAWACS( 68) / -.2417687752 7686730883 8530429904 4 D-29 / - DATA DAWACS( 69) / +.8369074582 0742989452 9288758729 1 D-30 / - DATA DAWACS( 70) / +.2665413042 7889791658 3831940156 6 D-30 / - DATA DAWACS( 71) / -.3811653692 3548903369 3569100371 2 D-30 / - DATA DAWACS( 72) / +.1230054721 8849514643 7170687258 5 D-30 / - DATA DAWACS( 73) / +.4622506399 0414935088 0553692998 3 D-31 / - DATA DAWACS( 74) / -.6120087296 8816777229 1143559300 1 D-31 / - DATA DAWACS( 75) / +.1966024640 1931646869 5623021789 6 D-31 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DDAWS - IF (FIRST) THEN - EPS = D1MACH(3) - NTDAW = INITDS (DAWCS, 21, 0.1*EPS) - NTDAW2 = INITDS (DAW2CS, 45, 0.1*EPS) - NTDAWA = INITDS (DAWACS, 75, 0.1*EPS) -C - XSML = SQRT(1.5*EPS) - XBIG = SQRT (0.5/EPS) - XMAX = EXP (MIN (-LOG(2.D0*D1MACH(1)), LOG(D1MACH(2))) - 1 - 0.001D0) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.1.0D0) GO TO 20 -C - DDAWS = X - IF (Y.LE.XSML) RETURN -C - DDAWS = X * (.75D0 + DCSEVL (2.D0*Y*Y-1.D0, DAWCS, NTDAW)) - RETURN -C - 20 IF (Y.GT.4.D0) GO TO 30 - DDAWS = X * (.25D0 + DCSEVL (.125D0*Y*Y-1.D0, DAW2CS, NTDAW2)) - RETURN -C - 30 IF (Y.GT.XMAX) GO TO 40 - DDAWS = 0.5D0/X - IF (Y.GT.XBIG) RETURN -C - DDAWS = (0.5D0 + DCSEVL (32.D0/Y**2-1.D0, DAWACS, NTDAWA)) / X - RETURN -C - 40 CALL XERMSG ('SLATEC', 'DDAWS', 'ABS(X) SO LARGE DAWS UNDERFLOWS', - + 1, 1) - DDAWS = 0.0D0 - RETURN -C - END diff --git a/slatec/ddawts.f b/slatec/ddawts.f deleted file mode 100644 index a1a1cfb..0000000 --- a/slatec/ddawts.f +++ /dev/null @@ -1,43 +0,0 @@ -*DECK DDAWTS - SUBROUTINE DDAWTS (NEQ, IWT, RTOL, ATOL, Y, WT, RPAR, IPAR) -C***BEGIN PROLOGUE DDAWTS -C***SUBSIDIARY -C***PURPOSE Set error weight vector for DDASSL. -C***LIBRARY SLATEC (DASSL) -C***TYPE DOUBLE PRECISION (SDAWTS-S, DDAWTS-D) -C***AUTHOR Petzold, Linda R., (LLNL) -C***DESCRIPTION -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,-,N. -C RTOL AND ATOL ARE SCALARS IF IWT = 0, -C AND VECTORS IF IWT = 1. -C----------------------------------------------------------------------- -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 830315 DATE WRITTEN -C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) -C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. -C 901026 Added explicit declarations for all variables and minor -C cosmetic changes to prologue. (FNF) -C***END PROLOGUE DDAWTS -C - INTEGER NEQ, IWT, IPAR(*) - DOUBLE PRECISION RTOL(*), ATOL(*), Y(*), WT(*), RPAR(*) -C - INTEGER I - DOUBLE PRECISION ATOLI, RTOLI -C -C***FIRST EXECUTABLE STATEMENT DDAWTS - 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-----------END OF SUBROUTINE DDAWTS------------------------------------ - END diff --git a/slatec/ddcor.f b/slatec/ddcor.f deleted file mode 100644 index fede7fb..0000000 --- a/slatec/ddcor.f +++ /dev/null @@ -1,193 +0,0 @@ -*DECK DDCOR - SUBROUTINE DDCOR (DFDY, EL, FA, H, IERROR, IMPL, IPVT, MATDIM, - 8 MITER, ML, MU, N, NDE, NQ, T, USERS, Y, YH, YWT, EVALFA, SAVE1, - 8 SAVE2, A, D, JSTATE) -C***BEGIN PROLOGUE DDCOR -C***SUBSIDIARY -C***PURPOSE Subroutine DDCOR computes corrections to the Y array. -C***LIBRARY SLATEC (SDRIVE) -C***TYPE DOUBLE PRECISION (SDCOR-S, DDCOR-D, CDCOR-C) -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***DESCRIPTION -C -C In the case of functional iteration, update Y directly from the -C result of the last call to F. -C In the case of the chord method, compute the corrector error and -C solve the linear system with that as right hand side and DFDY as -C coefficient matrix, using the LU decomposition if MITER is 1, 2, 4, -C or 5. -C -C***ROUTINES CALLED DGBSL, DGESL, DNRM2 -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE DDCOR - INTEGER I, IERROR, IFLAG, IMPL, J, JSTATE, MATDIM, MITER, ML, MU, - 8 MW, N, NDE, NQ - DOUBLE PRECISION A(MATDIM,*), D, DFDY(MATDIM,*), EL(13,12), H, - 8 SAVE1(*), SAVE2(*), DNRM2, T, Y(*), YH(N,*), YWT(*) - INTEGER IPVT(*) - LOGICAL EVALFA -C***FIRST EXECUTABLE STATEMENT DDCOR - IF (MITER .EQ. 0) THEN - IF (IERROR .EQ. 1 .OR. IERROR .EQ. 5) THEN - DO 100 I = 1,N - 100 SAVE1(I) = (H*SAVE2(I) - YH(I,2) - SAVE1(I))/YWT(I) - ELSE - DO 102 I = 1,N - SAVE1(I) = (H*SAVE2(I) - YH(I,2) - SAVE1(I))/ - 8 MAX(ABS(Y(I)), YWT(I)) - 102 CONTINUE - END IF - D = DNRM2(N, SAVE1, 1)/SQRT(DBLE(N)) - DO 105 I = 1,N - 105 SAVE1(I) = H*SAVE2(I) - YH(I,2) - ELSE IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN - IF (IMPL .EQ. 0) THEN - DO 130 I = 1,N - 130 SAVE2(I) = H*SAVE2(I) - YH(I,2) - SAVE1(I) - ELSE IF (IMPL .EQ. 1) THEN - IF (EVALFA) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - ELSE - EVALFA = .TRUE. - END IF - DO 150 I = 1,N - 150 SAVE2(I) = H*SAVE2(I) - DO 160 J = 1,N - DO 160 I = 1,N - 160 SAVE2(I) = SAVE2(I) - A(I,J)*(YH(J,2) + SAVE1(J)) - ELSE IF (IMPL .EQ. 2) THEN - IF (EVALFA) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - ELSE - EVALFA = .TRUE. - END IF - DO 180 I = 1,N - 180 SAVE2(I) = H*SAVE2(I) - A(I,1)*(YH(I,2) + SAVE1(I)) - ELSE IF (IMPL .EQ. 3) THEN - IF (EVALFA) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - ELSE - EVALFA = .TRUE. - END IF - DO 140 I = 1,N - 140 SAVE2(I) = H*SAVE2(I) - DO 170 J = 1,NDE - DO 170 I = 1,NDE - 170 SAVE2(I) = SAVE2(I) - A(I,J)*(YH(J,2) + SAVE1(J)) - END IF - CALL DGESL (DFDY, MATDIM, N, IPVT, SAVE2, 0) - IF (IERROR .EQ. 1 .OR. IERROR .EQ. 5) THEN - DO 200 I = 1,N - SAVE1(I) = SAVE1(I) + SAVE2(I) - 200 SAVE2(I) = SAVE2(I)/YWT(I) - ELSE - DO 205 I = 1,N - SAVE1(I) = SAVE1(I) + SAVE2(I) - 205 SAVE2(I) = SAVE2(I)/MAX(ABS(Y(I)), YWT(I)) - END IF - D = DNRM2(N, SAVE2, 1)/SQRT(DBLE(N)) - ELSE IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN - IF (IMPL .EQ. 0) THEN - DO 230 I = 1,N - 230 SAVE2(I) = H*SAVE2(I) - YH(I,2) - SAVE1(I) - ELSE IF (IMPL .EQ. 1) THEN - IF (EVALFA) THEN - CALL FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - ELSE - EVALFA = .TRUE. - END IF - DO 250 I = 1,N - 250 SAVE2(I) = H*SAVE2(I) - MW = ML + 1 + MU - DO 260 J = 1,N - DO 260 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) - SAVE2(I+J-MW) = SAVE2(I+J-MW) - 8 - A(I,J)*(YH(J,2) + SAVE1(J)) - 260 CONTINUE - ELSE IF (IMPL .EQ. 2) THEN - IF (EVALFA) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - ELSE - EVALFA = .TRUE. - END IF - DO 280 I = 1,N - 280 SAVE2(I) = H*SAVE2(I) - A(I,1)*(YH(I,2) + SAVE1(I)) - ELSE IF (IMPL .EQ. 3) THEN - IF (EVALFA) THEN - CALL FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - ELSE - EVALFA = .TRUE. - END IF - DO 270 I = 1,N - 270 SAVE2(I) = H*SAVE2(I) - MW = ML + 1 + MU - DO 290 J = 1,NDE - DO 290 I = MAX(ML+1, MW+1-J), MIN(MW+NDE-J, MW+ML) - SAVE2(I+J-MW) = SAVE2(I+J-MW) - 8 - A(I,J)*(YH(J,2) + SAVE1(J)) - 290 CONTINUE - END IF - CALL DGBSL (DFDY, MATDIM, N, ML, MU, IPVT, SAVE2, 0) - IF (IERROR .EQ. 1 .OR. IERROR .EQ. 5) THEN - DO 300 I = 1,N - SAVE1(I) = SAVE1(I) + SAVE2(I) - 300 SAVE2(I) = SAVE2(I)/YWT(I) - ELSE - DO 305 I = 1,N - SAVE1(I) = SAVE1(I) + SAVE2(I) - 305 SAVE2(I) = SAVE2(I)/MAX(ABS(Y(I)), YWT(I)) - END IF - D = DNRM2(N, SAVE2, 1)/SQRT(DBLE(N)) - ELSE IF (MITER .EQ. 3) THEN - IFLAG = 2 - CALL USERS (Y, YH(1,2), YWT, SAVE1, SAVE2, T, H, EL(1,NQ), IMPL, - 8 N, NDE, IFLAG) - IF (N .EQ. 0) THEN - JSTATE = 10 - RETURN - END IF - IF (IERROR .EQ. 1 .OR. IERROR .EQ. 5) THEN - DO 320 I = 1,N - SAVE1(I) = SAVE1(I) + SAVE2(I) - 320 SAVE2(I) = SAVE2(I)/YWT(I) - ELSE - DO 325 I = 1,N - SAVE1(I) = SAVE1(I) + SAVE2(I) - 325 SAVE2(I) = SAVE2(I)/MAX(ABS(Y(I)), YWT(I)) - END IF - D = DNRM2(N, SAVE2, 1)/SQRT(DBLE(N)) - END IF - RETURN - END diff --git a/slatec/ddcst.f b/slatec/ddcst.f deleted file mode 100644 index ff2c418..0000000 --- a/slatec/ddcst.f +++ /dev/null @@ -1,106 +0,0 @@ -*DECK DDCST - SUBROUTINE DDCST (MAXORD, MINT, ISWFLG, EL, TQ) -C***BEGIN PROLOGUE DDCST -C***SUBSIDIARY -C***PURPOSE DDCST sets coefficients used by the core integrator DDSTP. -C***LIBRARY SLATEC (SDRIVE) -C***TYPE DOUBLE PRECISION (SDCST-S, DDCST-D, CDCST-C) -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***DESCRIPTION -C -C DDCST is called by DDNTL. The array EL determines the basic method. -C The array TQ is involved in adjusting the step size in relation -C to truncation error. EL and TQ depend upon MINT, and are calculated -C for orders 1 to MAXORD(.LE. 12). For each order NQ, the coefficients -C EL are calculated from the generating polynomial: -C L(T) = EL(1,NQ) + EL(2,NQ)*T + ... + EL(NQ+1,NQ)*T**NQ. -C For the implicit Adams methods, L(T) is given by -C dL/dT = (1+T)*(2+T)* ... *(NQ-1+T)/K, L(-1) = 0, -C where K = factorial(NQ-1). -C For the Gear methods, -C L(T) = (1+T)*(2+T)* ... *(NQ+T)/K, -C where K = factorial(NQ)*(1 + 1/2 + ... + 1/NQ). -C For each order NQ, there are three components of TQ. -C -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE DDCST - DOUBLE PRECISION EL(13,12), FACTRL(12), GAMMA(14), SUM, TQ(3,12) - INTEGER I, ISWFLG, J, MAXORD, MINT, MXRD -C***FIRST EXECUTABLE STATEMENT DDCST - FACTRL(1) = 1.D0 - DO 10 I = 2,MAXORD - 10 FACTRL(I) = I*FACTRL(I-1) -C Compute Adams coefficients - IF (MINT .EQ. 1) THEN - GAMMA(1) = 1.D0 - DO 40 I = 1,MAXORD+1 - SUM = 0.D0 - DO 30 J = 1,I - 30 SUM = SUM - GAMMA(J)/(I-J+2) - 40 GAMMA(I+1) = SUM - EL(1,1) = 1.D0 - EL(2,1) = 1.D0 - EL(2,2) = 1.D0 - EL(3,2) = 1.D0 - DO 60 J = 3,MAXORD - EL(2,J) = FACTRL(J-1) - DO 50 I = 3,J - 50 EL(I,J) = (J-1)*EL(I,J-1) + EL(I-1,J-1) - 60 EL(J+1,J) = 1.D0 - DO 80 J = 2,MAXORD - EL(1,J) = EL(1,J-1) + GAMMA(J) - EL(2,J) = 1.D0 - DO 80 I = 3,J+1 - 80 EL(I,J) = EL(I,J)/((I-1)*FACTRL(J-1)) - DO 100 J = 1,MAXORD - TQ(1,J) = -1.D0/(FACTRL(J)*GAMMA(J)) - TQ(2,J) = -1.D0/GAMMA(J+1) - 100 TQ(3,J) = -1.D0/GAMMA(J+2) -C Compute Gear coefficients - ELSE IF (MINT .EQ. 2) THEN - EL(1,1) = 1.D0 - EL(2,1) = 1.D0 - DO 130 J = 2,MAXORD - EL(1,J) = FACTRL(J) - DO 120 I = 2,J - 120 EL(I,J) = J*EL(I,J-1) + EL(I-1,J-1) - 130 EL(J+1,J) = 1.D0 - SUM = 1.D0 - DO 150 J = 2,MAXORD - SUM = SUM + 1.D0/J - DO 150 I = 1,J+1 - 150 EL(I,J) = EL(I,J)/(FACTRL(J)*SUM) - DO 170 J = 1,MAXORD - IF (J .GT. 1) TQ(1,J) = 1.D0/FACTRL(J-1) - TQ(2,J) = (J+1)/EL(1,J) - 170 TQ(3,J) = (J+2)/EL(1,J) - END IF -C Compute constants used in the stiffness test. -C These are the ratio of TQ(2,NQ) for the Gear -C methods to those for the Adams methods. - IF (ISWFLG .EQ. 3) THEN - MXRD = MIN(MAXORD, 5) - IF (MINT .EQ. 2) THEN - GAMMA(1) = 1.D0 - DO 190 I = 1,MXRD - SUM = 0.D0 - DO 180 J = 1,I - 180 SUM = SUM - GAMMA(J)/(I-J+2) - 190 GAMMA(I+1) = SUM - END IF - SUM = 1.D0 - DO 200 I = 2,MXRD - SUM = SUM + 1.D0/I - 200 EL(1+I,1) = -(I+1)*SUM*GAMMA(I+1) - END IF - RETURN - END diff --git a/slatec/ddeabm.f b/slatec/ddeabm.f deleted file mode 100644 index dca92b6..0000000 --- a/slatec/ddeabm.f +++ /dev/null @@ -1,688 +0,0 @@ -*DECK DDEABM - SUBROUTINE DDEABM (DF, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, - + RWORK, LRW, IWORK, LIW, RPAR, IPAR) -C***BEGIN PROLOGUE DDEABM -C***PURPOSE Solve an initial value problem in ordinary differential -C equations using an Adams-Bashforth method. -C***LIBRARY SLATEC (DEPAC) -C***CATEGORY I1A1B -C***TYPE DOUBLE PRECISION (DEABM-S, DDEABM-D) -C***KEYWORDS ADAMS-BASHFORTH METHOD, DEPAC, INITIAL VALUE PROBLEMS, -C ODE, ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR -C***AUTHOR Shampine, L. F., (SNLA) -C Watts, H. A., (SNLA) -C***DESCRIPTION -C -C This is the Adams code in the package of differential equation -C solvers DEPAC, consisting of the codes DDERKF, DDEABM, and DDEBDF. -C Design of the package was by L. F. Shampine and H. A. Watts. -C It is documented in -C SAND79-2374 , DEPAC - Design of a User Oriented Package of ODE -C Solvers. -C DDEABM is a driver for a modification of the code ODE written by -C L. F. Shampine and M. K. Gordon -C Sandia Laboratories -C Albuquerque, New Mexico 87185 -C -C ********************************************************************** -C * ABSTRACT * -C ************ -C -C Subroutine DDEABM uses the Adams-Bashforth-Moulton -C Predictor-Corrector formulas of orders one through twelve to -C integrate a system of NEQ first order ordinary differential -C equations of the form -C DU/DX = DF(X,U) -C when the vector Y(*) of initial values for U(*) at X=T is given. -C The subroutine integrates from T to TOUT. It is easy to continue the -C integration to get results at additional TOUT. This is the interval -C mode of operation. It is also easy for the routine to return with -C the solution at each intermediate step on the way to TOUT. This is -C the intermediate-output mode of operation. -C -C DDEABM uses subprograms DDES, DSTEPS, DINTP, DHSTRT, DHVNRM, -C D1MACH, and the error handling routine XERMSG. The only machine -C dependent parameters to be assigned appear in D1MACH. -C -C ********************************************************************** -C * Description of The Arguments To DDEABM (An Overview) * -C ********************************************************************** -C -C The Parameters are -C -C DF -- This is the name of a subroutine which you provide to -C define the differential equations. -C -C NEQ -- This is the number of (first order) differential -C equations to be integrated. -C -C T -- This is a DOUBLE PRECISION value of the independent -C variable. -C -C Y(*) -- This DOUBLE PRECISION array contains the solution -C components at T. -C -C TOUT -- This is a DOUBLE PRECISION point at which a solution is -C desired. -C -C INFO(*) -- The basic task of the code is to integrate the -C differential equations from T to TOUT and return an -C answer at TOUT. INFO(*) is an INTEGER array which is used -C to communicate exactly how you want this task to be -C carried out. -C -C RTOL, ATOL -- These DOUBLE PRECISION quantities represent -C relative and absolute error tolerances which you -C provide to indicate how accurately you wish the -C solution to be computed. You may choose them to be -C both scalars or else both vectors. -C -C IDID -- This scalar quantity is an indicator reporting what -C the code did. You must monitor this INTEGER variable to -C decide what action to take next. -C -C RWORK(*), LRW -- RWORK(*) is a DOUBLE PRECISION work array of -C length LRW which provides the code with needed storage -C space. -C -C IWORK(*), LIW -- IWORK(*) is an INTEGER work array of length LIW -C which provides the code with needed storage space and an -C across call flag. -C -C RPAR, IPAR -- These are DOUBLE PRECISION and INTEGER parameter -C arrays which you can use for communication between your -C calling program and the DF subroutine. -C -C Quantities which are used as input items are -C NEQ, T, Y(*), TOUT, INFO(*), -C RTOL, ATOL, RWORK(1), LRW and LIW. -C -C Quantities which may be altered by the code are -C T, Y(*), INFO(1), RTOL, ATOL, -C IDID, RWORK(*) and IWORK(*). -C -C ********************************************************************** -C * INPUT -- What To Do On The First Call To DDEABM * -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 DF -- Provide a subroutine of the form -C DF(X,U,UPRIME,RPAR,IPAR) -C to define the system of first order differential equations -C which is to be solved. For the given values of X and the -C vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must -C evaluate the NEQ components of the system of differential -C equations DU/DX=DF(X,U) and store the derivatives in the -C array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for -C equations I=1,...,NEQ. -C -C Subroutine DF must NOT alter X or U(*). You must declare -C the name df in an external statement in your program that -C calls DDEABM. You must dimension U and UPRIME in DF. -C -C RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter -C arrays which you can use for communication between your -C calling program and subroutine DF. They are not used or -C altered by DDEABM. If you do not need RPAR or IPAR, -C ignore these parameters by treating them as dummy -C arguments. If you do choose to use them, dimension them in -C your calling program and in DF as arrays of appropriate -C length. -C -C NEQ -- Set it to the number of differential equations. -C (NEQ .GE. 1) -C -C T -- Set it to the initial point of the integration. -C You must use a program variable for T because the code -C changes its value. -C -C Y(*) -- Set this vector to the initial values of the NEQ solution -C components at the initial point. You must dimension Y at -C least NEQ in your calling program. -C -C TOUT -- Set it to the first point at which a solution -C is desired. You can take TOUT = T, in which case the code -C will evaluate the derivative of the solution at T and -C return. Integration either forward in T (TOUT .GT. T) or -C backward in T (TOUT .LT. T) is permitted. -C -C The code advances the solution from T to TOUT using -C step sizes which are automatically selected so as to -C achieve the desired accuracy. If you wish, the code will -C return with the solution and its derivative following -C each intermediate step (intermediate-output mode) so that -C you can monitor them, but you still must provide TOUT in -C accord with the basic aim of the code. -C -C The first step taken by the code is a critical one -C because it must reflect how fast the solution changes near -C the initial point. The code automatically selects an -C initial step size which is practically always suitable for -C the problem. By using the fact that the code will not step -C past TOUT in the first step, you could, if necessary, -C restrict the length of the initial step size. -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 -C past TSTOP. In this case any TOUT beyond TSTOP is invalid -C 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 15 to accommodate other members of -C DEPAC or possible future extensions, though DDEABM uses -C only the first four entries. You must respond to all of -C the following items which are arranged as questions. The -C simplest use of the code corresponds to answering all -C questions as YES ,i.e. setting ALL entries of INFO to 0. -C -C INFO(1) -- This parameter enables the code to initialize -C itself. You must set it to indicate the start of every -C new 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 vectors. -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 -C of TOUT by steps. If you wish, it will return the -C computed solution and derivative at the next -C intermediate step (the intermediate-output mode) or -C TOUT, whichever comes first. This is a good way to -C proceed if you want to see the behavior of the solution. -C If you must have solutions at a great many specific -C TOUT points, this 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 not to go past. -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 RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) -C error tolerances to tell the code how accurately you want -C the solution to be computed. They must be defined as -C program variables because the code may change them. You -C have two choices -- -C Both RTOL and ATOL are scalars. (INFO(2)=0) -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 test -C at each step which requires roughly that -C ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL -C for each vector component. -C (More specifically, a Euclidean norm is used to measure -C the size of vectors, and the error test uses the magnitude -C of the solution at the beginning of the step.) -C -C The true (global) error is the difference between the true -C solution of the initial value problem and the computed -C approximation. Practically all present day codes, -C including this one, control the local error at each step -C and do not even attempt to control the global error -C directly. Roughly speaking, they produce a solution Y(T) -C which satisfies the differential equations with a -C residual R(T), DY(T)/DT = DF(T,Y(T)) + R(T) , -C and, almost always, R(T) is bounded by the error -C tolerances. Usually, but not always, the true accuracy of -C the computed Y is comparable to the error tolerances. This -C code will usually, but not always, deliver a more accurate -C solution if you reduce the tolerances and integrate again. -C By comparing two such solutions you can get a fairly -C reliable idea of the true error in the solution at the -C bigger tolerances. -C -C Setting ATOL=0.D0 results in a pure relative error test on -C that component. Setting RTOL=0. results in a pure absolute -C error test on that component. A mixed test with non-zero -C RTOL and ATOL corresponds roughly to a relative error -C test when the solution component is much bigger than ATOL -C and to an absolute error test when the solution component -C is smaller than the threshold ATOL. -C -C Proper selection of the absolute error control parameters -C ATOL requires you to have some idea of the scale of the -C solution components. To acquire this information may mean -C that you will have to solve the problem more than once. In -C the absence of scale information, you should ask for some -C relative accuracy in all the components (by setting RTOL -C values non-zero) and perhaps impose extremely small -C absolute error tolerances to protect against the danger of -C a solution component becoming zero. -C -C The code will not attempt to compute a solution at an -C accuracy unreasonable for the machine being used. It will -C advise you if you ask for too much accuracy and inform -C you as to the maximum accuracy it believes possible. -C -C RWORK(*) -- Dimension this DOUBLE PRECISION work array of length -C LRW in your calling program. -C -C RWORK(1) -- If you have set INFO(4)=0, you can ignore this -C optional input parameter. Otherwise you must define a -C stopping point TSTOP by setting RWORK(1) = TSTOP. -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.) -C -C LRW -- Set it to the declared length of the RWORK array. -C You must have LRW .GE. 130+21*NEQ -C -C IWORK(*) -- Dimension this INTEGER work array of length LIW in -C your calling program. -C -C LIW -- Set it to the declared length of the IWORK array. -C You must have LIW .GE. 51 -C -C RPAR, IPAR -- These are parameter arrays, of DOUBLE PRECISION and -C INTEGER type, respectively. You can use them for -C communication between your program that calls DDEABM and -C the DF subroutine. They are not used or altered by -C DDEABM. If you do not need RPAR or IPAR, ignore these -C parameters by treating them as dummy arguments. If you do -C choose to use them, dimension them in your calling program -C and in DF as arrays of appropriate length. -C -C ********************************************************************** -C * OUTPUT -- After Any Return From DDEABM * -C ********************************************************************** -C -C The principal aim of the code is to return a computed solution at -C TOUT, although it is also possible to obtain intermediate results -C along the way. To find out whether the code achieved its goal -C or if the integration process was interrupted before the task was -C completed, you must check the IDID parameter. -C -C -C T -- The solution was successfully advanced to the -C output value of T. -C -C Y(*) -- Contains the computed solution approximation at T. -C You may also be interested in the approximate derivative -C of the solution at T. It is contained in -C RWORK(21),...,RWORK(20+NEQ). -C -C IDID -- Reports what the code did -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 TOUT was successfully -C completed (T=TOUT) by stepping exactly to TOUT. -C -C IDID = 3 -- The integration to TOUT was successfully -C completed (T=TOUT) by stepping past TOUT. -C Y(*) is obtained by interpolation. -C -C *** Task Interrupted *** -C Reported by negative values of IDID -C -C IDID = -1 -- A large amount of work has been expended. -C (500 steps attempted) -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 -C component is zero. Thus, a pure relative error -C test is impossible for this component. -C -C IDID = -4 -- The problem appears to be stiff. -C -C IDID = -5,-6,-7,..,-32 -- Not applicable for this code -C but used by other members of DEPAC or possible -C future extensions. -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 be -C appropriate for continuing the integration. However, the -C reported solution at T was obtained using the input values -C of RTOL and ATOL. -C -C RWORK, IWORK -- Contain information which is usually of no -C interest to the user but necessary for subsequent calls. -C However, you may find use for -C -C RWORK(11)--which contains the step size H to be -C attempted on the next step. -C -C RWORK(12)--if the tolerances have been increased by the -C code (IDID = -2) , they were multiplied by the -C value in RWORK(12). -C -C RWORK(13)--Which contains the current value of the -C independent variable, i.e. the farthest point -C integration has reached. This will be different -C from T only when interpolation has been -C performed (IDID=3). -C -C RWORK(20+I)--Which contains the approximate derivative -C of the solution component Y(I). In DDEABM, it -C is obtained by calling subroutine DF to -C evaluate the differential equation using T and -C Y(*) when IDID=1 or 2, and by interpolation -C when IDID=3. -C -C ********************************************************************** -C * INPUT -- What To Do To Continue The Integration * -C * (calls after the first) * -C ********************************************************************** -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, -C in particular do not alter NEQ, T, Y(*), RWORK(*), IWORK(*) or -C the differential equation in subroutine DF. Any such alteration -C constitutes a new problem and must be treated as such, i.e. -C you must start afresh. -C -C You cannot change from vector to scalar error control or vice -C versa (INFO(2)) but you can change the size of the entries of -C RTOL, 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 The parameter INFO(1) is used by the code to indicate the -C beginning of a new problem and to indicate whether integration -C is to be continued. You must input the value INFO(1) = 0 -C when starting a new problem. You must input the value -C INFO(1) = 1 if you wish to continue after an interrupted task. -C Do not set INFO(1) = 0 on a continuation call unless you -C want the code to restart at the current T. -C -C *** Following A Completed Task *** -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 *** Following An Interrupted Task *** -C To show the code that you realize the task was -C interrupted and that you want to continue, you -C must take appropriate action and reset INFO(1) = 1 -C If -C IDID = -1, the code has attempted 500 steps. -C If you want to continue, set INFO(1) = 1 and -C call the code again. An additional 500 steps -C will be allowed. -C -C IDID = -2, the error tolerances RTOL, ATOL have been -C increased to values the code estimates appropriate -C for continuing. You may want to change them -C yourself. If you are sure you want to continue -C with relaxed error tolerances, set INFO(1)=1 and -C call the code 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 -C alter the error criterion to use positive values -C for those components of ATOL corresponding to zero -C solution components, then set INFO(1)=1 and call -C the code again. -C -C IDID = -4, the problem appears to be stiff. It is very -C inefficient to solve such problems with DDEABM. -C The code DDEBDF in DEPAC handles this task -C efficiently. If you are absolutely sure you want -C to continue with DDEABM, set INFO(1)=1 and call -C the code again. -C -C IDID = -5,-6,-7,..,-32 --- cannot occur with this code -C but used by other members of DEPAC or possible -C future extensions. -C -C *** Following A Terminated Task *** -C If -C IDID = -33, you cannot continue the solution of this -C problem. An attempt to do so will result in your -C run being terminated. -C -C ********************************************************************** -C *Long Description: -C -C ********************************************************************** -C * DEPAC Package Overview * -C ********************************************************************** -C -C .... You have a choice of three differential equation solvers from -C .... DEPAC. The following brief descriptions are meant to aid you in -C .... choosing the most appropriate code for your problem. -C -C .... DDERKF is a fifth order Runge-Kutta code. It is the simplest of -C .... the three choices, both algorithmically and in the use of the -C .... code. DDERKF is primarily designed to solve non-stiff and -C .... mildly stiff differential equations when derivative evaluations -C .... are not expensive. It should generally not be used to get high -C .... accuracy results nor answers at a great many specific points. -C .... Because DDERKF has very low overhead costs, it will usually -C .... result in the least expensive integration when solving -C .... problems requiring a modest amount of accuracy and having -C .... equations that are not costly to evaluate. DDERKF attempts to -C .... discover when it is not suitable for the task posed. -C -C .... DDEABM is a variable order (one through twelve) Adams code. -C .... Its complexity lies somewhere between that of DDERKF and -C .... DDEBDF. DDEABM is primarily designed to solve non-stiff and -C .... mildly stiff differential equations when derivative evaluations -C .... are expensive, high accuracy results are needed or answers at -C .... many specific points are required. DDEABM attempts to discover -C .... when it is not suitable for the task posed. -C -C .... DDEBDF is a variable order (one through five) backward -C .... differentiation formula code. it is the most complicated of -C .... the three choices. DDEBDF is primarily designed to solve stiff -C .... differential equations at crude to moderate tolerances. -C .... If the problem is very stiff at all, DDERKF and DDEABM will be -C .... quite inefficient compared to DDEBDF. However, DDEBDF will be -C .... inefficient compared to DDERKF and DDEABM on non-stiff problems -C .... because it uses much more storage, has a much larger overhead, -C .... and the low order formulas will not give high accuracies -C .... efficiently. -C -C .... The concept of stiffness cannot be described in a few words. -C .... If you do not know the problem to be stiff, try either DDERKF -C .... or DDEABM. Both of these codes will inform you of stiffness -C .... when the cost of solving such problems becomes important. -C -C ********************************************************************* -C -C***REFERENCES L. F. Shampine and H. A. Watts, DEPAC - design of a user -C oriented package of ODE solvers, Report SAND79-2374, -C Sandia Laboratories, 1979. -C***ROUTINES CALLED DDES, XERMSG -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891006 Cosmetic changes to prologue. (WRB) -C 891024 Changed references from DVNORM to DHVNRM. (WRB) -C 891024 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DDEABM -C - INTEGER IALPHA, IBETA, IDELSN, IDID, IFOURU, IG, IHOLD, - 1 INFO, IP, IPAR, IPHI, IPSI, ISIG, ITOLD, ITSTAR, ITWOU, - 2 IV, IW, IWORK, IWT, IYP, IYPOUT, IYY, LIW, LRW, NEQ - DOUBLE PRECISION ATOL, RPAR, RTOL, RWORK, T, TOUT, Y - LOGICAL START,PHASE1,NORND,STIFF,INTOUT -C - DIMENSION Y(*),INFO(15),RTOL(*),ATOL(*),RWORK(*),IWORK(*), - 1 RPAR(*),IPAR(*) -C - CHARACTER*8 XERN1 - CHARACTER*16 XERN3 -C - EXTERNAL DF -C -C CHECK FOR AN APPARENT INFINITE LOOP -C -C***FIRST EXECUTABLE STATEMENT DDEABM - IF ( INFO(1) .EQ. 0 ) IWORK(LIW) = 0 - IF (IWORK(LIW) .GE. 5) THEN - IF (T .EQ. RWORK(21 + NEQ)) THEN - WRITE (XERN3, '(1PE15.6)') T - CALL XERMSG ('SLATEC', 'DDEABM', - * 'AN APPARENT INFINITE LOOP HAS BEEN DETECTED.$$' // - * 'YOU HAVE MADE REPEATED CALLS AT T = ' // XERN3 // - * ' AND THE INTEGRATION HAS NOT ADVANCED. CHECK THE ' // - * 'WAY YOU HAVE SET PARAMETERS FOR THE CALL TO THE ' // - * 'CODE, PARTICULARLY INFO(1).', 13, 2) - RETURN - ENDIF - ENDIF -C -C CHECK LRW AND LIW FOR SUFFICIENT STORAGE ALLOCATION -C - IDID=0 - IF (LRW .LT. 130+21*NEQ) THEN - WRITE (XERN1, '(I8)') LRW - CALL XERMSG ('SLATEC', 'DDEABM', 'THE LENGTH OF THE RWORK ' // - * 'ARRAY MUST BE AT LEAST 130 + 21*NEQ.$$' // - * 'YOU HAVE CALLED THE CODE WITH LRW = ' // XERN1, 1, 1) - IDID=-33 - ENDIF -C - IF (LIW .LT. 51) THEN - WRITE (XERN1, '(I8)') LIW - CALL XERMSG ('SLATEC', 'DDEABM', 'THE LENGTH OF THE IWORK ' // - * 'ARRAY MUST BE AT LEAST 51.$$YOU HAVE CALLED THE CODE ' // - * 'WITH LIW = ' // XERN1, 2, 1) - IDID=-33 - ENDIF -C -C COMPUTE THE INDICES FOR THE ARRAYS TO BE STORED IN THE WORK ARRAY -C - IYPOUT = 21 - ITSTAR = NEQ + 21 - IYP = 1 + ITSTAR - IYY = NEQ + IYP - IWT = NEQ + IYY - IP = NEQ + IWT - IPHI = NEQ + IP - IALPHA = (NEQ*16) + IPHI - IBETA = 12 + IALPHA - IPSI = 12 + IBETA - IV = 12 + IPSI - IW = 12 + IV - ISIG = 12 + IW - IG = 13 + ISIG - IGI = 13 + IG - IXOLD = 11 + IGI - IHOLD = 1 + IXOLD - ITOLD = 1 + IHOLD - IDELSN = 1 + ITOLD - ITWOU = 1 + IDELSN - IFOURU = 1 + ITWOU -C - RWORK(ITSTAR) = T - IF (INFO(1) .EQ. 0) GO TO 50 - START = IWORK(21) .NE. (-1) - PHASE1 = IWORK(22) .NE. (-1) - NORND = IWORK(23) .NE. (-1) - STIFF = IWORK(24) .NE. (-1) - INTOUT = IWORK(25) .NE. (-1) -C - 50 CALL DDES(DF,NEQ,T,Y,TOUT,INFO,RTOL,ATOL,IDID,RWORK(IYPOUT), - 1 RWORK(IYP),RWORK(IYY),RWORK(IWT),RWORK(IP),RWORK(IPHI), - 2 RWORK(IALPHA),RWORK(IBETA),RWORK(IPSI),RWORK(IV), - 3 RWORK(IW),RWORK(ISIG),RWORK(IG),RWORK(IGI),RWORK(11), - 4 RWORK(12),RWORK(13),RWORK(IXOLD),RWORK(IHOLD), - 5 RWORK(ITOLD),RWORK(IDELSN),RWORK(1),RWORK(ITWOU), - 5 RWORK(IFOURU),START,PHASE1,NORND,STIFF,INTOUT,IWORK(26), - 6 IWORK(27),IWORK(28),IWORK(29),IWORK(30),IWORK(31), - 7 IWORK(32),IWORK(33),IWORK(34),IWORK(35),IWORK(45), - 8 RPAR,IPAR) -C - IWORK(21) = -1 - IF (START) IWORK(21) = 1 - IWORK(22) = -1 - IF (PHASE1) IWORK(22) = 1 - IWORK(23) = -1 - IF (NORND) IWORK(23) = 1 - IWORK(24) = -1 - IF (STIFF) IWORK(24) = 1 - IWORK(25) = -1 - IF (INTOUT) IWORK(25) = 1 -C - IF (IDID .NE. (-2)) IWORK(LIW) = IWORK(LIW) + 1 - IF (T .NE. RWORK(ITSTAR)) IWORK(LIW) = 0 -C - RETURN - END diff --git a/slatec/ddebdf.f b/slatec/ddebdf.f deleted file mode 100644 index 12e82e5..0000000 --- a/slatec/ddebdf.f +++ /dev/null @@ -1,933 +0,0 @@ -*DECK DDEBDF - SUBROUTINE DDEBDF (DF, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, - + RWORK, LRW, IWORK, LIW, RPAR, IPAR, DJAC) -C***BEGIN PROLOGUE DDEBDF -C***PURPOSE Solve an initial value problem in ordinary differential -C equations using backward differentiation formulas. It is -C intended primarily for stiff problems. -C***LIBRARY SLATEC (DEPAC) -C***CATEGORY I1A2 -C***TYPE DOUBLE PRECISION (DEBDF-S, DDEBDF-D) -C***KEYWORDS BACKWARD DIFFERENTIATION FORMULAS, DEPAC, -C INITIAL VALUE PROBLEMS, ODE, -C ORDINARY DIFFERENTIAL EQUATIONS, STIFF -C***AUTHOR Shampine, L. F., (SNLA) -C Watts, H. A., (SNLA) -C***DESCRIPTION -C -C This is the backward differentiation code in the package of -C differential equation solvers DEPAC, consisting of the codes -C DDERKF, DDEABM, and DDEBDF. Design of the package was by -C L. F. Shampine and H. A. Watts. It is documented in -C SAND-79-2374 , DEPAC - Design of a User Oriented Package of ODE -C Solvers. -C DDEBDF is a driver for a modification of the code LSODE written by -C A. C. Hindmarsh -C Lawrence Livermore Laboratory -C Livermore, California 94550 -C -C ********************************************************************** -C ** DEPAC PACKAGE OVERVIEW ** -C ********************************************************************** -C -C You have a choice of three differential equation solvers from -C DEPAC. The following brief descriptions are meant to aid you -C in choosing the most appropriate code for your problem. -C -C DDERKF is a fifth order Runge-Kutta code. It is the simplest of -C the three choices, both algorithmically and in the use of the -C code. DDERKF is primarily designed to solve non-stiff and mild- -C ly stiff differential equations when derivative evaluations are -C not expensive. It should generally not be used to get high -C accuracy results nor answers at a great many specific points. -C Because DDERKF has very low overhead costs, it will usually -C result in the least expensive integration when solving -C problems requiring a modest amount of accuracy and having -C equations that are not costly to evaluate. DDERKF attempts to -C discover when it is not suitable for the task posed. -C -C DDEABM is a variable order (one through twelve) Adams code. Its -C complexity lies somewhere between that of DDERKF and DDEBDF. -C DDEABM is primarily designed to solve non-stiff and mildly -C stiff differential equations when derivative evaluations are -C expensive, high accuracy results are needed or answers at -C many specific points are required. DDEABM attempts to discover -C when it is not suitable for the task posed. -C -C DDEBDF is a variable order (one through five) backward -C differentiation formula code. It is the most complicated of -C the three choices. DDEBDF is primarily designed to solve stiff -C differential equations at crude to moderate tolerances. -C If the problem is very stiff at all, DDERKF and DDEABM will be -C quite inefficient compared to DDEBDF. However, DDEBDF will be -C inefficient compared to DDERKF and DDEABM on non-stiff problems -C because it uses much more storage, has a much larger overhead, -C and the low order formulas will not give high accuracies -C efficiently. -C -C The concept of stiffness cannot be described in a few words. -C If you do not know the problem to be stiff, try either DDERKF -C or DDEABM. Both of these codes will inform you of stiffness -C when the cost of solving such problems becomes important. -C -C ********************************************************************** -C ** ABSTRACT ** -C ********************************************************************** -C -C Subroutine DDEBDF uses the backward differentiation formulas of -C orders one through five to integrate a system of NEQ first order -C ordinary differential equations of the form -C DU/DX = DF(X,U) -C when the vector Y(*) of initial values for U(*) at X=T is given. -C The subroutine integrates from T to TOUT. It is easy to continue the -C integration to get results at additional TOUT. This is the interval -C mode of operation. It is also easy for the routine to return with -C the solution at each intermediate step on the way to TOUT. This is -C the intermediate-output mode of operation. -C -C ********************************************************************** -C * Description of The Arguments To DDEBDF (An Overview) * -C ********************************************************************** -C -C The Parameters are: -C -C DF -- This is the name of a subroutine which you provide to -C define the differential equations. -C -C NEQ -- This is the number of (first order) differential -C equations to be integrated. -C -C T -- This is a DOUBLE PRECISION value of the independent -C variable. -C -C Y(*) -- This DOUBLE PRECISION array contains the solution -C components at T. -C -C TOUT -- This is a DOUBLE PRECISION point at which a solution is -C desired. -C -C INFO(*) -- The basic task of the code is to integrate the -C differential equations from T to TOUT and return an -C answer at TOUT. INFO(*) is an INTEGER array which is used -C to communicate exactly how you want this task to be -C carried out. -C -C RTOL, ATOL -- These DOUBLE PRECISION quantities -C represent relative and absolute error tolerances which you -C provide to indicate how accurately you wish the solution -C to be computed. You may choose them to be both scalars -C or else both vectors. -C -C IDID -- This scalar quantity is an indicator reporting what -C the code did. You must monitor this INTEGER variable to -C decide what action to take next. -C -C RWORK(*), LRW -- RWORK(*) is a DOUBLE PRECISION work array of -C length LRW which provides the code with needed storage -C space. -C -C IWORK(*), LIW -- IWORK(*) is an INTEGER work array of length LIW -C which provides the code with needed storage space and an -C across call flag. -C -C RPAR, IPAR -- These are DOUBLE PRECISION and INTEGER parameter -C arrays which you can use for communication between your -C calling program and the DF subroutine (and the DJAC -C subroutine). -C -C DJAC -- This is the name of a subroutine which you may choose to -C provide for defining the Jacobian matrix of partial -C derivatives DF/DU. -C -C Quantities which are used as input items are -C NEQ, T, Y(*), TOUT, INFO(*), -C RTOL, ATOL, RWORK(1), LRW, -C IWORK(1), IWORK(2), and LIW. -C -C Quantities which may be altered by the code are -C T, Y(*), INFO(1), RTOL, ATOL, -C IDID, RWORK(*) and IWORK(*). -C -C ********************************************************************** -C * INPUT -- What To Do On The First Call To DDEBDF * -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 DF -- Provide a subroutine of the form -C DF(X,U,UPRIME,RPAR,IPAR) -C to define the system of first order differential equations -C which is to be solved. For the given values of X and the -C vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must -C evaluate the NEQ components of the system of differential -C equations DU/DX=DF(X,U) and store the derivatives in the -C array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for -C equations I=1,...,NEQ. -C -C Subroutine DF must not alter X or U(*). You must declare -C the name DF in an external statement in your program that -C calls DDEBDF. You must dimension U and UPRIME in DF. -C -C RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter -C arrays which you can use for communication between your -C calling program and subroutine DF. They are not used or -C altered by DDEBDF. If you do not need RPAR or IPAR, -C ignore these parameters by treating them as dummy -C arguments. If you do choose to use them, dimension them in -C your calling program and in DF as arrays of appropriate -C length. -C -C NEQ -- Set it to the number of differential equations. -C (NEQ .GE. 1) -C -C T -- Set it to the initial point of the integration. -C You must use a program variable for T because the code -C changes its value. -C -C Y(*) -- Set this vector to the initial values of the NEQ solution -C components at the initial point. You must dimension Y at -C least NEQ in your calling program. -C -C TOUT -- Set it to the first point at which a solution is desired. -C You can take TOUT = T, in which case the code -C will evaluate the derivative of the solution at T and -C return. Integration either forward in T (TOUT .GT. T) -C or backward in T (TOUT .LT. T) is permitted. -C -C The code advances the solution from T to TOUT using -C step sizes which are automatically selected so as to -C achieve the desired accuracy. If you wish, the code will -C return with the solution and its derivative following -C each intermediate step (intermediate-output mode) so that -C you can monitor them, but you still must provide TOUT in -C accord with the basic aim of the code. -C -C The first step taken by the code is a critical one -C because it must reflect how fast the solution changes near -C the initial point. The code automatically selects an -C initial step size which is practically always suitable for -C the problem. By using the fact that the code will not -C step past TOUT in the first step, you could, if necessary, -C restrict the length of the initial step size. -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 -C past TSTOP. In this case any TOUT beyond TSTOP is invalid -C 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 15 to accommodate other members of -C DEPAC or possible future extensions, though DDEBDF uses -C only the first six entries. You must respond to all of -C the following items which are arranged as questions. The -C simplest use of the code corresponds to answering all -C questions as YES ,i.e. setting all entries of INFO to 0. -C -C INFO(1) -- This parameter enables the code to initialize -C itself. You must set it to indicate the start of every -C new 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 vectors. -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 -C of TOUT by steps. If you wish, it will return the -C computed solution and derivative at the next -C intermediate step (the intermediate-output mode) or -C TOUT, whichever comes first. This is a good way to -C proceed if you want to see the behavior of the solution. -C If you must have solutions at a great many specific -C TOUT points, this 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 not to go past. -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) -- To solve stiff problems it is necessary to use the -C Jacobian matrix of partial derivatives of the system -C of differential equations. If you do not provide a -C subroutine to evaluate it analytically (see the -C description of the item DJAC 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 DJAC. Sometimes numerical differencing -C is cheaper than evaluating derivatives in DJAC and -C sometimes it is not - this depends on your problem. -C -C If your problem is linear, i.e. has the form -C DU/DX = DF(X,U) = J(X)*U + G(X) for some matrix J(X) -C and vector G(X), the Jacobian matrix DF/DU = J(X). -C Since you must provide a subroutine to evaluate DF(X,U) -C analytically, it is little extra trouble to provide -C subroutine DJAC for evaluating J(X) analytically. -C Furthermore, in such cases, numerical differencing is -C much more expensive than analytic evaluation. -C -C **** Do you want the code to evaluate the partial -C derivatives automatically by numerical differences ... -C YES -- Set INFO(5)=0 -C NO -- Set INFO(5)=1 -C and provide subroutine DJAC for evaluating the -C Jacobian matrix **** -C -C INFO(6) -- DDEBDF will perform much better if the Jacobian -C matrix is banded and the code is told this. In this -C case, the storage needed will be greatly reduced, -C numerical differencing will be performed more cheaply, -C and a number of important algorithms will execute much -C faster. The differential equation is said to have -C half-bandwidths ML (lower) and MU (upper) if equation I -C 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 Jacobian, -C the code works with a full matrix of NEQ**2 elements -C (stored in the conventional way). Computations with -C 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 Jacobian matrix has a banded structure and -C you want to provide subroutine DJAC to compute the -C partial derivatives, then you must be careful to store -C the elements of the Jacobian matrix in the special form -C indicated in the description of DJAC. -C -C **** Do you want to solve the problem using a full -C (dense) Jacobian matrix (and not a special banded -C 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 RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) -C error tolerances to tell the code how accurately you want -C the solution to be computed. They must be defined as -C program variables because the code may change them. You -C have two choices -- -C Both RTOL and ATOL are scalars. (INFO(2)=0) -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 test -C at each step which requires roughly that -C ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL -C 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 true -C solution of the initial value problem and the computed -C approximation. Practically all present day codes, -C including this one, control the local error at each step -C and do not even attempt to control the global error -C directly. Roughly speaking, they produce a solution Y(T) -C which satisfies the differential equations with a -C residual R(T), DY(T)/DT = DF(T,Y(T)) + R(T) , -C and, almost always, R(T) is bounded by the error -C tolerances. Usually, but not always, the true accuracy of -C the computed Y is comparable to the error tolerances. This -C code will usually, but not always, deliver a more accurate -C solution if you reduce the tolerances and integrate again. -C By comparing two such solutions you can get a fairly -C reliable idea of the true error in the solution at the -C bigger tolerances. -C -C Setting ATOL=0. results in a pure relative error test on -C that component. Setting RTOL=0. results in a pure abso- -C lute error test on that component. A mixed test with non- -C zero RTOL and ATOL corresponds roughly to a relative error -C test when the solution component is much bigger than ATOL -C and to an absolute error test when the solution component -C is smaller than the threshold ATOL. -C -C Proper selection of the absolute error control parameters -C ATOL requires you to have some idea of the scale of the -C solution components. To acquire this information may mean -C that you will have to solve the problem more than once. In -C the absence of scale information, you should ask for some -C relative accuracy in all the components (by setting RTOL -C values non-zero) and perhaps impose extremely small -C absolute error tolerances to protect against the danger of -C a solution component becoming zero. -C -C The code will not attempt to compute a solution at an -C accuracy unreasonable for the machine being used. It will -C advise you if you ask for too much accuracy and inform -C you as to the maximum accuracy it believes possible. -C -C RWORK(*) -- Dimension this DOUBLE PRECISION work array of length -C LRW in your calling program. -C -C RWORK(1) -- If you have set INFO(4)=0, you can ignore this -C optional input parameter. Otherwise you must define a -C stopping point TSTOP by setting RWORK(1) = TSTOP. -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.) -C -C LRW -- Set it to the declared length of the RWORK array. -C You must have -C LRW .GE. 250+10*NEQ+NEQ**2 -C for the full (dense) Jacobian case (when INFO(6)=0), or -C LRW .GE. 250+10*NEQ+(2*ML+MU+1)*NEQ -C for the banded Jacobian case (when INFO(6)=1). -C -C IWORK(*) -- Dimension this INTEGER work array of length LIW in -C your calling program. -C -C IWORK(1), IWORK(2) -- If you have set INFO(6)=0, you can ignore -C these optional input parameters. Otherwise you must define -C the half-bandwidths ML (lower) and MU (upper) of the -C Jacobian matrix by setting IWORK(1) = ML and -C IWORK(2) = MU. (The code will work with a full matrix -C of NEQ**2 elements unless it is told that the problem has -C a banded Jacobian, in which case the code will work with -C a matrix containing at most (2*ML+MU+1)*NEQ elements.) -C -C LIW -- Set it to the declared length of the IWORK array. -C You must have LIW .GE. 56+NEQ. -C -C RPAR, IPAR -- These are parameter arrays, of DOUBLE PRECISION and -C INTEGER type, respectively. You can use them for -C communication between your program that calls DDEBDF and -C the DF subroutine (and the DJAC subroutine). They are not -C used or altered by DDEBDF. If you do not need RPAR or -C IPAR, ignore these parameters by treating them as dummy -C arguments. If you do choose to use them, dimension them in -C your calling program and in DF (and in DJAC) as arrays of -C appropriate length. -C -C DJAC -- If you have set INFO(5)=0, you can ignore this parameter -C by treating it as a dummy argument. (For some compilers -C you may have to write a dummy subroutine named DJAC in -C order to avoid problems associated with missing external -C routine names.) Otherwise, you must provide a subroutine -C of the form -C DJAC(X,U,PD,NROWPD,RPAR,IPAR) -C to define the Jacobian matrix of partial derivatives DF/DU -C of the system of differential equations DU/DX = DF(X,U). -C For the given values of X and the vector -C U(*)=(U(1),U(2),...,U(NEQ)), the subroutine must evaluate -C the non-zero partial derivatives DF(I)/DU(J) for each -C differential equation I=1,...,NEQ and each solution -C component J=1,...,NEQ , and store these values in the -C matrix PD. The elements of PD are set to zero before each -C call to DJAC so only non-zero elements need to be defined. -C -C Subroutine DJAC must not alter X, U(*), or NROWPD. You -C must declare the name DJAC in an external statement in -C your program that calls DDEBDF. NROWPD is the row -C dimension of the PD matrix and is assigned by the code. -C Therefore you must dimension PD in DJAC according to -C DIMENSION PD(NROWPD,1) -C You must also dimension U in DJAC. -C -C The way you must store the elements into the PD matrix -C depends on the structure of the Jacobian which you -C indicated by INFO(6). -C *** INFO(6)=0 -- Full (Dense) Jacobian *** -C When you evaluate the (non-zero) partial derivative -C of equation I with respect to variable J, you must -C store it in PD according to -C PD(I,J) = * DF(I)/DU(J) * -C *** INFO(6)=1 -- Banded Jacobian with ML Lower and MU -C Upper Diagonal Bands (refer to INFO(6) description of -C ML and MU) *** -C When you evaluate the (non-zero) partial derivative -C of equation I with respect to variable J, you must -C store it in PD according to -C IROW = I - J + ML + MU + 1 -C PD(IROW,J) = * DF(I)/DU(J) * -C -C RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter -C arrays which you can use for communication between your -C calling program and your Jacobian subroutine DJAC. They -C are not altered by DDEBDF. If you do not need RPAR or -C IPAR, ignore these parameters by treating them as dummy -C arguments. If you do choose to use them, dimension them -C in your calling program and in DJAC as arrays of -C appropriate length. -C -C ********************************************************************** -C * OUTPUT -- After any return from DDEBDF * -C ********************************************************************** -C -C The principal aim of the code is to return a computed solution at -C TOUT, although it is also possible to obtain intermediate results -C along the way. To find out whether the code achieved its goal -C or if the integration process was interrupted before the task was -C completed, you must check the IDID parameter. -C -C -C T -- The solution was successfully advanced to the -C output value of T. -C -C Y(*) -- Contains the computed solution approximation at T. -C You may also be interested in the approximate derivative -C of the solution at T. It is contained in -C RWORK(21),...,RWORK(20+NEQ). -C -C IDID -- Reports what the code did -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 TOUT was successfully -C completed (T=TOUT) by stepping exactly to TOUT. -C -C IDID = 3 -- The integration to TOUT was successfully -C completed (T=TOUT) by stepping past TOUT. -C Y(*) is obtained by interpolation. -C -C *** Task Interrupted *** -C Reported by negative values of IDID -C -C IDID = -1 -- A large amount of work has been expended. -C (500 steps attempted) -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 -C component is zero. Thus, a pure relative error -C test is impossible for this component. -C -C IDID = -4,-5 -- Not applicable for this code but used -C by other members of DEPAC. -C -C IDID = -6 -- DDEBDF had repeated convergence test failures -C on the last attempted step. -C -C IDID = -7 -- DDEBDF had repeated error test failures on -C the last attempted step. -C -C IDID = -8,..,-32 -- Not applicable for this code but -C used by other members of DEPAC or possible -C future extensions. -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 -C occurs 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 be -C appropriate for continuing the integration. However, the -C reported solution at T was obtained using the input values -C of RTOL and ATOL. -C -C RWORK, IWORK -- Contain information which is usually of no -C interest to the user but necessary for subsequent calls. -C However, you may find use for -C -C RWORK(11)--which contains the step size H to be -C attempted on the next step. -C -C RWORK(12)--If the tolerances have been increased by the -C code (IDID = -2) , they were multiplied by the -C value in RWORK(12). -C -C RWORK(13)--which contains the current value of the -C independent variable, i.e. the farthest point -C integration has reached. This will be -C different from T only when interpolation has -C been performed (IDID=3). -C -C RWORK(20+I)--which contains the approximate derivative -C of the solution component Y(I). In DDEBDF, it -C is never obtained by calling subroutine DF to -C evaluate the differential equation using T and -C Y(*), except at the initial point of -C integration. -C -C ********************************************************************** -C ** INPUT -- What To Do To Continue The Integration ** -C ** (calls after the first) ** -C ********************************************************************** -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, -C in particular do not alter NEQ, T, Y(*), RWORK(*), IWORK(*) or -C the differential equation in subroutine DF. Any such alteration -C constitutes a new problem and must be treated as such, i.e. -C you must start afresh. -C -C You cannot change from vector to scalar error control or vice -C versa (INFO(2)) but you can change the size of the entries of -C RTOL, 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), IWORK(1), or IWORK(2) -C unless you are going to restart the code. -C -C The parameter INFO(1) is used by the code to indicate the -C beginning of a new problem and to indicate whether integration -C is to be continued. You must input the value INFO(1) = 0 -C when starting a new problem. You must input the value -C INFO(1) = 1 if you wish to continue after an interrupted task. -C Do not set INFO(1) = 0 on a continuation call unless you -C want the code to restart at the current T. -C -C *** Following a Completed Task *** -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 *** Following an Interrupted Task *** -C To show the code that you realize the task was -C interrupted and that you want to continue, you -C must take appropriate action and reset INFO(1) = 1 -C If -C IDID = -1, the code has attempted 500 steps. -C If you want to continue, set INFO(1) = 1 and -C call the code again. An additional 500 steps -C will be allowed. -C -C IDID = -2, the error tolerances RTOL, ATOL have been -C increased to values the code estimates appropriate -C for continuing. You may want to change them -C yourself. If you are sure you want to continue -C with relaxed error tolerances, set INFO(1)=1 and -C call the code 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 -C alter the error criterion to use positive values -C for those components of ATOL corresponding to zero -C solution components, then set INFO(1)=1 and call -C the code again. -C -C IDID = -4,-5 --- cannot occur with this code but used -C by other members of DEPAC. -C -C IDID = -6, repeated convergence test failures occurred -C on the last attempted step in DDEBDF. An inaccu- -C rate Jacobian may be the problem. If you are -C absolutely certain you want to continue, restart -C the integration at the current T by setting -C INFO(1)=0 and call the code again. -C -C IDID = -7, repeated error test failures occurred on the -C last attempted step in DDEBDF. A singularity in -C the solution may be present. You should re- -C examine the problem being solved. If you are -C absolutely certain you want to continue, restart -C the integration at the current T by setting -C INFO(1)=0 and call the code again. -C -C IDID = -8,..,-32 --- cannot occur with this code but -C used by other members of DDEPAC or possible future -C extensions. -C -C *** Following a Terminated Task *** -C If -C IDID = -33, you cannot continue the solution of this -C problem. An attempt to do so will result in your -C run being terminated. -C -C ********************************************************************** -C -C ***** Warning ***** -C -C If DDEBDF is to be used in an overlay situation, you must save and -C restore certain items used internally by DDEBDF (values in the -C common block DDEBD1). This can be accomplished as follows. -C -C To save the necessary values upon return from DDEBDF, simply call -C DSVCO(RWORK(22+NEQ),IWORK(21+NEQ)). -C -C To restore the necessary values before the next call to DDEBDF, -C simply call DRSCO(RWORK(22+NEQ),IWORK(21+NEQ)). -C -C***REFERENCES L. F. Shampine and H. A. Watts, DEPAC - design of a user -C oriented package of ODE solvers, Report SAND79-2374, -C Sandia Laboratories, 1979. -C***ROUTINES CALLED DLSOD, XERMSG -C***COMMON BLOCKS DDEBD1 -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891024 Changed references from DVNORM to DHVNRM. (WRB) -C 891024 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900510 Convert XERRWV calls to XERMSG calls, make Prologue comments -C consistent with DEBDF. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DDEBDF - INTEGER IACOR, IBAND, IBEGIN, ICOMI, ICOMR, IDELSN, IDID, IER, - 1 IEWT, IINOUT, IINTEG, IJAC, ILRW, INFO, INIT, - 2 IOWNS, IPAR, IQUIT, ISAVF, ITOL, ITSTAR, ITSTOP, IWM, - 3 IWORK, IYH, IYPOUT, JSTART, KFLAG, KSTEPS, L, LIW, LRW, - 4 MAXORD, METH, MITER, ML, MU, N, NEQ, NFE, NJE, NQ, NQU, - 5 NST - DOUBLE PRECISION ATOL, EL0, H, HMIN, HMXI, HU, ROWNS, RPAR, - 1 RTOL, RWORK, T, TN, TOLD, TOUT, UROUND, Y - LOGICAL INTOUT - CHARACTER*8 XERN1, XERN2 - CHARACTER*16 XERN3 -C - DIMENSION Y(*),INFO(15),RTOL(*),ATOL(*),RWORK(*),IWORK(*), - 1 RPAR(*),IPAR(*) -C - COMMON /DDEBD1/ TOLD,ROWNS(210),EL0,H,HMIN,HMXI,HU,TN,UROUND, - 1 IQUIT,INIT,IYH,IEWT,IACOR,ISAVF,IWM,KSTEPS,IBEGIN, - 2 ITOL,IINTEG,ITSTOP,IJAC,IBAND,IOWNS(6),IER,JSTART, - 3 KFLAG,L,METH,MITER,MAXORD,N,NQ,NST,NFE,NJE,NQU -C - EXTERNAL DF, DJAC -C -C CHECK FOR AN APPARENT INFINITE LOOP -C -C***FIRST EXECUTABLE STATEMENT DDEBDF - IF (INFO(1) .EQ. 0) IWORK(LIW) = 0 -C - IF (IWORK(LIW).GE. 5) THEN - IF (T .EQ. RWORK(21+NEQ)) THEN - WRITE (XERN3, '(1PE15.6)') T - CALL XERMSG ('SLATEC', 'DDEBDF', - * 'AN APPARENT INFINITE LOOP HAS BEEN DETECTED.$$' // - * 'YOU HAVE MADE REPEATED CALLS AT T = ' // XERN3 // - * ' AND THE INTEGRATION HAS NOT ADVANCED. CHECK THE ' // - * 'WAY YOU HAVE SET PARAMETERS FOR THE CALL TO THE ' // - * 'CODE, PARTICULARLY INFO(1).', 13, 2) - RETURN - ENDIF - ENDIF -C - IDID = 0 -C -C CHECK VALIDITY OF INFO PARAMETERS -C - IF (INFO(1) .NE. 0 .AND. INFO(1) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(1) - CALL XERMSG ('SLATEC', 'DDEBDF', 'INFO(1) MUST BE SET TO 0 ' // - * 'FOR THE START OF A NEW PROBLEM, AND MUST BE SET TO 1 ' // - * 'FOLLOWING AN INTERRUPTED TASK. YOU ARE ATTEMPTING TO ' // - * 'CONTINUE THE INTEGRATION ILLEGALLY BY CALLING THE ' // - * 'CODE WITH INFO(1) = ' // XERN1, 3, 1) - IDID = -33 - ENDIF -C - IF (INFO(2) .NE. 0 .AND. INFO(2) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(2) - CALL XERMSG ('SLATEC', 'DDEBDF', 'INFO(2) MUST BE 0 OR 1 ' // - * 'INDICATING SCALAR AND VECTOR ERROR TOLERANCES, ' // - * 'RESPECTIVELY. YOU HAVE CALLED THE CODE WITH INFO(2) = ' // - * XERN1, 4, 1) - IDID = -33 - ENDIF -C - IF (INFO(3) .NE. 0 .AND. INFO(3) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(3) - CALL XERMSG ('SLATEC', 'DDEBDF', 'INFO(3) MUST BE 0 OR 1 ' // - * 'INDICATING THE INTERVAL OR INTERMEDIATE-OUTPUT MODE OF ' // - * 'INTEGRATION, RESPECTIVELY. YOU HAVE CALLED THE CODE ' // - * 'WITH INFO(3) = ' // XERN1, 5, 1) - IDID = -33 - ENDIF -C - IF (INFO(4) .NE. 0 .AND. INFO(4) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(4) - CALL XERMSG ('SLATEC', 'DDEBDF', 'INFO(4) MUST BE 0 OR 1 ' // - * 'INDICATING WHETHER OR NOT THE INTEGRATION INTERVAL IS ' // - * 'TO BE RESTRICTED BY A POINT TSTOP. YOU HAVE CALLED ' // - * 'THE CODE WITH INFO(4) = ' // XERN1, 14, 1) - IDID = -33 - ENDIF -C - IF (INFO(5) .NE. 0 .AND. INFO(5) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(5) - CALL XERMSG ('SLATEC', 'DDEBDF', 'INFO(5) MUST BE 0 OR 1 ' // - * 'INDICATING WHETHER THE CODE IS TOLD TO FORM THE ' // - * 'JACOBIAN MATRIX BY NUMERICAL DIFFERENCING OR YOU ' // - * 'PROVIDE A SUBROUTINE TO EVALUATE IT ANALYTICALLY. ' // - * 'YOU HAVE CALLED THE CODE WITH INFO(5) = ' // XERN1, 15, 1) - IDID = -33 - ENDIF -C - IF (INFO(6) .NE. 0 .AND. INFO(6) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(6) - CALL XERMSG ('SLATEC', 'DDEBDF', 'INFO(6) MUST BE 0 OR 1 ' // - * 'INDICATING WHETHER THE CODE IS TOLD TO TREAT THE ' // - * 'JACOBIAN AS A FULL (DENSE) MATRIX OR AS HAVING A ' // - * 'SPECIAL BANDED STRUCTURE. YOU HAVE CALLED THE CODE ' // - * 'WITH INFO(6) = ' // XERN1, 16, 1) - IDID = -33 - ENDIF -C - ILRW = NEQ - IF (INFO(6) .NE. 0) THEN -C -C CHECK BANDWIDTH PARAMETERS -C - ML = IWORK(1) - MU = IWORK(2) - ILRW = 2*ML + MU + 1 -C - IF (ML.LT.0 .OR. ML.GE.NEQ .OR. MU.LT.0 .OR. MU.GE.NEQ) THEN - WRITE (XERN1, '(I8)') ML - WRITE (XERN2, '(I8)') MU - CALL XERMSG ('SLATEC', 'DDEBDF', 'YOU HAVE SET INFO(6) ' // - * '= 1, TELLING THE CODE THAT THE JACOBIAN MATRIX HAS ' // - * 'A SPECIAL BANDED STRUCTURE. HOWEVER, THE LOWER ' // - * '(UPPER) BANDWIDTHS ML (MU) VIOLATE THE CONSTRAINTS ' // - * 'ML,MU .GE. 0 AND ML,MU .LT. NEQ. YOU HAVE CALLED ' // - * 'THE CODE WITH ML = ' // XERN1 // ' AND MU = ' // XERN2, - * 17, 1) - IDID = -33 - ENDIF - ENDIF -C -C CHECK LRW AND LIW FOR SUFFICIENT STORAGE ALLOCATION -C - IF (LRW .LT. 250 + (10 + ILRW)*NEQ) THEN - WRITE (XERN1, '(I8)') LRW - IF (INFO(6) .EQ. 0) THEN - CALL XERMSG ('SLATEC', 'DDEBDF', 'LENGTH OF ARRAY RWORK ' // - * 'MUST BE AT LEAST 250 + 10*NEQ + NEQ*NEQ.$$' // - * 'YOU HAVE CALLED THE CODE WITH LRW = ' // XERN1, 1, 1) - ELSE - CALL XERMSG ('SLATEC', 'DDEBDF', 'LENGTH OF ARRAY RWORK ' // - * 'MUST BE AT LEAST 250 + 10*NEQ + (2*ML+MU+1)*NEQ.$$' // - * 'YOU HAVE CALLED THE CODE WITH LRW = ' // XERN1, 18, 1) - ENDIF - IDID = -33 - ENDIF -C - IF (LIW .LT. 56 + NEQ) THEN - WRITE (XERN1, '(I8)') LIW - CALL XERMSG ('SLATEC', 'DDEBDF', 'LENGTH OF ARRAY IWORK ' // - * 'BE AT LEAST 56 + NEQ. YOU HAVE CALLED THE CODE WITH ' // - * 'LIW = ' // XERN1, 2, 1) - IDID = -33 - ENDIF -C -C COMPUTE THE INDICES FOR THE ARRAYS TO BE STORED IN THE WORK -C ARRAY AND RESTORE COMMON BLOCK DATA -C - ICOMI = 21 + NEQ - IINOUT = ICOMI + 33 -C - IYPOUT = 21 - ITSTAR = 21 + NEQ - ICOMR = 22 + NEQ -C - IF (INFO(1) .NE. 0) INTOUT = IWORK(IINOUT) .NE. (-1) -C CALL DRSCO(RWORK(ICOMR),IWORK(ICOMI)) -C - IYH = ICOMR + 218 - IEWT = IYH + 6*NEQ - ISAVF = IEWT + NEQ - IACOR = ISAVF + NEQ - IWM = IACOR + NEQ - IDELSN = IWM + 2 + ILRW*NEQ -C - IBEGIN = INFO(1) - ITOL = INFO(2) - IINTEG = INFO(3) - ITSTOP = INFO(4) - IJAC = INFO(5) - IBAND = INFO(6) - RWORK(ITSTAR) = T -C - CALL DLSOD(DF,NEQ,T,Y,TOUT,RTOL,ATOL,IDID,RWORK(IYPOUT), - 1 RWORK(IYH),RWORK(IYH),RWORK(IEWT),RWORK(ISAVF), - 2 RWORK(IACOR),RWORK(IWM),IWORK(1),DJAC,INTOUT, - 3 RWORK(1),RWORK(12),RWORK(IDELSN),RPAR,IPAR) -C - IWORK(IINOUT) = -1 - IF (INTOUT) IWORK(IINOUT) = 1 -C - IF (IDID .NE. (-2)) IWORK(LIW) = IWORK(LIW) + 1 - IF (T .NE. RWORK(ITSTAR)) IWORK(LIW) = 0 -C CALL DSVCO(RWORK(ICOMR),IWORK(ICOMI)) - RWORK(11) = H - RWORK(13) = TN - INFO(1) = IBEGIN -C - RETURN - END diff --git a/slatec/dderkf.f b/slatec/dderkf.f deleted file mode 100644 index 9de5a10..0000000 --- a/slatec/dderkf.f +++ /dev/null @@ -1,698 +0,0 @@ -*DECK DDERKF - SUBROUTINE DDERKF (DF, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, - + RWORK, LRW, IWORK, LIW, RPAR, IPAR) -C***BEGIN PROLOGUE DDERKF -C***PURPOSE Solve an initial value problem in ordinary differential -C equations using a Runge-Kutta-Fehlberg scheme. -C***LIBRARY SLATEC (DEPAC) -C***CATEGORY I1A1A -C***TYPE DOUBLE PRECISION (DERKF-S, DDERKF-D) -C***KEYWORDS DEPAC, INITIAL VALUE PROBLEMS, ODE, -C ORDINARY DIFFERENTIAL EQUATIONS, RKF, -C RUNGE-KUTTA-FEHLBERG METHODS -C***AUTHOR Watts, H. A., (SNLA) -C Shampine, L. F., (SNLA) -C***DESCRIPTION -C -C This is the Runge-Kutta code in the package of differential equation -C solvers DEPAC, consisting of the codes DDERKF, DDEABM, and DDEBDF. -C Design of the package was by L. F. Shampine and H. A. Watts. -C It is documented in -C SAND-79-2374 , DEPAC - Design of a User Oriented Package of ODE -C Solvers. -C DDERKF is a driver for a modification of the code RKF45 written by -C H. A. Watts and L. F. Shampine -C Sandia Laboratories -C Albuquerque, New Mexico 87185 -C -C ********************************************************************** -C ** DDEPAC PACKAGE OVERVIEW ** -C ********************************************************************** -C -C You have a choice of three differential equation solvers from -C DDEPAC. The following brief descriptions are meant to aid you -C in choosing the most appropriate code for your problem. -C -C DDERKF is a fifth order Runge-Kutta code. It is the simplest of -C the three choices, both algorithmically and in the use of the -C code. DDERKF is primarily designed to solve non-stiff and mild- -C ly stiff differential equations when derivative evaluations are -C not expensive. It should generally not be used to get high -C accuracy results nor answers at a great many specific points. -C Because DDERKF has very low overhead costs, it will usually -C result in the least expensive integration when solving -C problems requiring a modest amount of accuracy and having -C equations that are not costly to evaluate. DDERKF attempts to -C discover when it is not suitable for the task posed. -C -C DDEABM is a variable order (one through twelve) Adams code. Its -C complexity lies somewhere between that of DDERKF and DDEBDF. -C DDEABM is primarily designed to solve non-stiff and mildly -C stiff differential equations when derivative evaluations are -C expensive, high accuracy results are needed or answers at -C many specific points are required. DDEABM attempts to discover -C when it is not suitable for the task posed. -C -C DDEBDF is a variable order (one through five) backward -C differentiation formula code. It is the most complicated of -C the three choices. DDEBDF is primarily designed to solve stiff -C differential equations at crude to moderate tolerances. -C If the problem is very stiff at all, DDERKF and DDEABM will be -C quite inefficient compared to DDEBDF. However, DDEBDF will be -C inefficient compared to DDERKF and DDEABM on non-stiff problems -C because it uses much more storage, has a much larger overhead, -C and the low order formulas will not give high accuracies -C efficiently. -C -C The concept of stiffness cannot be described in a few words. -C If you do not know the problem to be stiff, try either DDERKF -C or DDEABM. Both of these codes will inform you of stiffness -C when the cost of solving such problems becomes important. -C -C ********************************************************************** -C ** ABSTRACT ** -C ********************************************************************** -C -C Subroutine DDERKF uses a Runge-Kutta-Fehlberg (4,5) method to -C integrate a system of NEQ first order ordinary differential -C equations of the form -C DU/DX = DF(X,U) -C when the vector Y(*) of initial values for U(*) at X=T is given. -C The subroutine integrates from T to TOUT. It is easy to continue the -C integration to get results at additional TOUT. This is the interval -C mode of operation. It is also easy for the routine to return with -C the solution at each intermediate step on the way to TOUT. This is -C the intermediate-output mode of operation. -C -C DDERKF uses subprograms DRKFS, DFEHL, DHSTRT, DHVNRM, D1MACH, and -C the error handling routine XERMSG. The only machine dependent -C parameters to be assigned appear in D1MACH. -C -C ********************************************************************** -C ** DESCRIPTION OF THE ARGUMENTS TO DDERKF (AN OVERVIEW) ** -C ********************************************************************** -C -C The Parameters are: -C -C DF -- This is the name of a subroutine which you provide to -C define the differential equations. -C -C NEQ -- This is the number of (first order) differential -C equations to be integrated. -C -C T -- This is a DOUBLE PRECISION value of the independent -C variable. -C -C Y(*) -- This DOUBLE PRECISION array contains the solution -C components at T. -C -C TOUT -- This is a DOUBLE PRECISION point at which a solution is -C desired. -C -C INFO(*) -- The basic task of the code is to integrate the -C differential equations from T to TOUT and return an -C answer at TOUT. INFO(*) is an INTEGER array which is used -C to communicate exactly how you want this task to be -C carried out. -C -C RTOL, ATOL -- These DOUBLE PRECISION quantities represent -C relative and absolute error tolerances which you provide -C to indicate how accurately you wish the solution to be -C computed. You may choose them to be both scalars or else -C both vectors. -C -C IDID -- This scalar quantity is an indicator reporting what -C the code did. You must monitor this INTEGER variable to -C decide what action to take next. -C -C RWORK(*), LRW -- RWORK(*) is a DOUBLE PRECISION work array of -C length LRW which provides the code with needed storage -C space. -C -C IWORK(*), LIW -- IWORK(*) is an INTEGER work array of length LIW -C which provides the code with needed storage space and an -C across call flag. -C -C RPAR, IPAR -- These are DOUBLE PRECISION and INTEGER parameter -C arrays which you can use for communication between your -C calling program and the DF subroutine. -C -C Quantities which are used as input items are -C NEQ, T, Y(*), TOUT, INFO(*), -C RTOL, ATOL, LRW and LIW. -C -C Quantities which may be altered by the code are -C T, Y(*), INFO(1), RTOL, ATOL, -C IDID, RWORK(*) and IWORK(*). -C -C ********************************************************************** -C ** INPUT -- What to do On The First Call To DDERKF ** -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 DF -- Provide a subroutine of the form -C DF(X,U,UPRIME,RPAR,IPAR) -C to define the system of first order differential equations -C which is to be solved. For the given values of X and the -C vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must -C evaluate the NEQ components of the system of differential -C equations DU/DX=DF(X,U) and store the derivatives in the -C array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for -C equations I=1,...,NEQ. -C -C Subroutine DF must not alter X or U(*). You must declare -C the name DF in an external statement in your program that -C calls DDERKF. You must dimension U and UPRIME in DF. -C -C RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter -C arrays which you can use for communication between your -C calling program and subroutine DF. They are not used or -C altered by DDERKF. If you do not need RPAR or IPAR, -C ignore these parameters by treating them as dummy -C arguments. If you do choose to use them, dimension them in -C your calling program and in DF as arrays of appropriate -C length. -C -C NEQ -- Set it to the number of differential equations. -C (NEQ .GE. 1) -C -C T -- Set it to the initial point of the integration. -C You must use a program variable for T because the code -C changes its value. -C -C Y(*) -- Set this vector to the initial values of the NEQ solution -C components at the initial point. You must dimension Y at -C least NEQ in your calling program. -C -C TOUT -- Set it to the first point at which a solution -C is desired. You can take TOUT = T, in which case the code -C will evaluate the derivative of the solution at T and -C return. Integration either forward in T (TOUT .GT. T) or -C backward in T (TOUT .LT. T) is permitted. -C -C The code advances the solution from T to TOUT using -C step sizes which are automatically selected so as to -C achieve the desired accuracy. If you wish, the code will -C return with the solution and its derivative following -C each intermediate step (intermediate-output mode) so that -C you can monitor them, but you still must provide TOUT in -C accord with the basic aim of the code. -C -C The first step taken by the code is a critical one -C because it must reflect how fast the solution changes near -C the initial point. The code automatically selects an -C initial step size which is practically always suitable for -C the problem. By using the fact that the code will not -C step past TOUT in the first step, you could, if necessary, -C restrict the length of the initial step size. -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. Since DDERKF will never step past a TOUT point, -C you need only make sure that no TOUT lies beyond TSTOP. -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 15 to accommodate other members of -C DEPAC or possible future extensions, though DDERKF uses -C only the first three entries. You must respond to all of -C the following items which are arranged as questions. The -C simplest use of the code corresponds to answering all -C questions as YES ,i.e. setting all entries of INFO to 0. -C -C INFO(1) -- This parameter enables the code to initialize -C itself. You must set it to indicate the start of every -C new 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 vectors. -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 -C of TOUT by steps. If you wish, it will return the -C computed solution and derivative at the next -C intermediate step (the intermediate-output mode). -C This is a good way to proceed if you want to see the -C behavior of the solution. If you must have solutions at -C a great many specific TOUT points, this code is -C INEFFICIENT. The code DDEABM in DEPAC handles this task -C more 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 RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) -C error tolerances to tell the code how accurately you want -C the solution to be computed. They must be defined as -C program variables because the code may change them. You -C have two choices -- -C Both RTOL and ATOL are scalars. (INFO(2)=0) -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 test -C at each step which requires roughly that -C ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL -C for each vector component. -C (More specifically, a maximum norm is used to measure -C the size of vectors, and the error test uses the average -C of the magnitude of the solution at the beginning and end -C of the step.) -C -C The true (global) error is the difference between the true -C solution of the initial value problem and the computed -C approximation. Practically all present day codes, -C including this one, control the local error at each step -C and do not even attempt to control the global error -C directly. Roughly speaking, they produce a solution Y(T) -C which satisfies the differential equations with a -C residual R(T), DY(T)/DT = DF(T,Y(T)) + R(T) , -C and, almost always, R(T) is bounded by the error -C tolerances. Usually, but not always, the true accuracy of -C the computed Y is comparable to the error tolerances. This -C code will usually, but not always, deliver a more accurate -C solution if you reduce the tolerances and integrate again. -C By comparing two such solutions you can get a fairly -C reliable idea of the true error in the solution at the -C bigger tolerances. -C -C Setting ATOL=0. results in a pure relative error test on -C that component. Setting RTOL=0. yields a pure absolute -C error test on that component. A mixed test with non-zero -C RTOL and ATOL corresponds roughly to a relative error -C test when the solution component is much bigger than ATOL -C and to an absolute error test when the solution component -C is smaller than the threshold ATOL. -C -C Proper selection of the absolute error control parameters -C ATOL requires you to have some idea of the scale of the -C solution components. To acquire this information may mean -C that you will have to solve the problem more than once. In -C the absence of scale information, you should ask for some -C relative accuracy in all the components (by setting RTOL -C values non-zero) and perhaps impose extremely small -C absolute error tolerances to protect against the danger of -C a solution component becoming zero. -C -C The code will not attempt to compute a solution at an -C accuracy unreasonable for the machine being used. It will -C advise you if you ask for too much accuracy and inform -C you as to the maximum accuracy it believes possible. -C If you want relative accuracies smaller than about -C 10**(-8), you should not ordinarily use DDERKF. The code -C DDEABM in DEPAC obtains stringent accuracies more -C efficiently. -C -C RWORK(*) -- Dimension this DOUBLE PRECISION work array of length -C LRW in your calling program. -C -C LRW -- Set it to the declared length of the RWORK array. -C You must have LRW .GE. 33+7*NEQ -C -C IWORK(*) -- Dimension this INTEGER work array of length LIW in -C your calling program. -C -C LIW -- Set it to the declared length of the IWORK array. -C You must have LIW .GE. 34 -C -C RPAR, IPAR -- These are parameter arrays, of DOUBLE PRECISION and -C INTEGER type, respectively. You can use them for -C communication between your program that calls DDERKF and -C the DF subroutine. They are not used or altered by -C DDERKF. If you do not need RPAR or IPAR, ignore these -C parameters by treating them as dummy arguments. If you do -C choose to use them, dimension them in your calling program -C and in DF as arrays of appropriate length. -C -C ********************************************************************** -C ** OUTPUT -- After any return from DDERKF ** -C ********************************************************************** -C -C The principal aim of the code is to return a computed solution at -C TOUT, although it is also possible to obtain intermediate results -C along the way. To find out whether the code achieved its goal -C or if the integration process was interrupted before the task was -C completed, you must check the IDID parameter. -C -C -C T -- The solution was successfully advanced to the -C output value of T. -C -C Y(*) -- Contains the computed solution approximation at T. -C You may also be interested in the approximate derivative -C of the solution at T. It is contained in -C RWORK(21),...,RWORK(20+NEQ). -C -C IDID -- Reports what the code did -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 TOUT was successfully -C completed (T=TOUT) by stepping exactly to TOUT. -C -C *** Task Interrupted *** -C Reported by negative values of IDID -C -C IDID = -1 -- A large amount of work has been expended. -C (500 steps attempted) -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 -C component is zero. Thus, a pure relative error -C test is impossible for this component. -C -C IDID = -4 -- The problem appears to be stiff. -C -C IDID = -5 -- DDERKF is being used very inefficiently -C because the natural step size is being -C restricted by too frequent output. -C -C IDID = -6,-7,..,-32 -- Not applicable for this code but -C used by other members of DEPAC or possible -C future extensions. -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 -C occurs 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 be -C appropriate for continuing the integration. However, the -C reported solution at T was obtained using the input values -C of RTOL and ATOL. -C -C RWORK, IWORK -- Contain information which is usually of no -C interest to the user but necessary for subsequent calls. -C However, you may find use for -C -C RWORK(11)--which contains the step size H to be -C attempted on the next step. -C -C RWORK(12)--If the tolerances have been increased by the -C code (IDID = -2) , they were multiplied by the -C value in RWORK(12). -C -C RWORK(20+I)--which contains the approximate derivative -C of the solution component Y(I). In DDERKF, it -C is always obtained by calling subroutine DF to -C evaluate the differential equation using T and -C Y(*). -C -C ********************************************************************** -C ** INPUT -- What To Do To Continue The Integration ** -C ** (calls after the first) ** -C ********************************************************************** -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 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, -C in particular do not alter NEQ, T, Y(*), RWORK(*), IWORK(*) or -C the differential equation in subroutine DF. Any such alteration -C constitutes a new problem and must be treated as such, i.e. -C you must start afresh. -C -C You cannot change from vector to scalar error control or vice -C versa (INFO(2)) but you can change the size of the entries of -C RTOL, 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 The parameter INFO(1) is used by the code to indicate the -C beginning of a new problem and to indicate whether integration -C is to be continued. You must input the value INFO(1) = 0 -C when starting a new problem. You must input the value -C INFO(1) = 1 if you wish to continue after an interrupted task. -C Do not set INFO(1) = 0 on a continuation call unless you -C want the code to restart at the current T. -C -C *** Following a Completed Task *** -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, 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 *** Following an Interrupted Task *** -C To show the code that you realize the task was -C interrupted and that you want to continue, you -C must take appropriate action and reset INFO(1) = 1 -C If -C IDID = -1, the code has attempted 500 steps. -C If you want to continue, set INFO(1) = 1 and -C call the code again. An additional 500 steps -C will be allowed. -C -C IDID = -2, the error tolerances RTOL, ATOL have been -C increased to values the code estimates appropriate -C for continuing. You may want to change them -C yourself. If you are sure you want to continue -C with relaxed error tolerances, set INFO(1)=1 and -C call the code 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 -C alter the error criterion to use positive values -C for those components of ATOL corresponding to zero -C solution components, then set INFO(1)=1 and call -C the code again. -C -C IDID = -4, the problem appears to be stiff. It is very -C inefficient to solve such problems with DDERKF. -C The code DDEBDF in DEPAC handles this task -C efficiently. If you are absolutely sure you want -C to continue with DDERKF, set INFO(1)=1 and call -C the code again. -C -C IDID = -5, you are using DDERKF very inefficiently by -C choosing output points TOUT so close together that -C the step size is repeatedly forced to be rather -C smaller than necessary. If you are willing to -C accept solutions at the steps chosen by the code, -C a good way to proceed is to use the intermediate -C output mode (setting INFO(3)=1). If you must have -C solutions at so many specific TOUT points, the -C code DDEABM in DEPAC handles this task -C efficiently. If you want to continue with DDERKF, -C set INFO(1)=1 and call the code again. -C -C IDID = -6,-7,..,-32 --- cannot occur with this code but -C used by other members of DEPAC or possible future -C extensions. -C -C *** Following a Terminated Task *** -C If -C IDID = -33, you cannot continue the solution of this -C problem. An attempt to do so will result in your -C run being terminated. -C -C ********************************************************************** -C *Long Description: -C -C ********************************************************************** -C ** DEPAC Package Overview ** -C ********************************************************************** -C -C .... You have a choice of three differential equation solvers from -C .... DEPAC. The following brief descriptions are meant to aid you in -C .... choosing the most appropriate code for your problem. -C -C .... DDERKF is a fifth order Runge-Kutta code. It is the simplest of -C .... the three choices, both algorithmically and in the use of the -C .... code. DDERKF is primarily designed to solve non-stiff and -C .... mildly stiff differential equations when derivative evaluations -C .... are not expensive. It should generally not be used to get high -C .... accuracy results nor answers at a great many specific points. -C .... Because DDERKF has very low overhead costs, it will usually -C .... result in the least expensive integration when solving -C .... problems requiring a modest amount of accuracy and having -C .... equations that are not costly to evaluate. DDERKF attempts to -C .... discover when it is not suitable for the task posed. -C -C .... DDEABM is a variable order (one through twelve) Adams code. -C .... Its complexity lies somewhere between that of DDERKF and -C .... DDEBDF. DDEABM is primarily designed to solve non-stiff and -C .... mildly stiff differential equations when derivative evaluations -C .... are expensive, high accuracy results are needed or answers at -C .... many specific points are required. DDEABM attempts to discover -C .... when it is not suitable for the task posed. -C -C .... DDEBDF is a variable order (one through five) backward -C .... differentiation formula code. it is the most complicated of -C .... the three choices. DDEBDF is primarily designed to solve stiff -C .... differential equations at crude to moderate tolerances. -C .... If the problem is very stiff at all, DDERKF and DDEABM will be -C .... quite inefficient compared to DDEBDF. However, DDEBDF will be -C .... inefficient compared to DDERKF and DDEABM on non-stiff problems -C .... because it uses much more storage, has a much larger overhead, -C .... and the low order formulas will not give high accuracies -C .... efficiently. -C -C .... The concept of stiffness cannot be described in a few words. -C .... If you do not know the problem to be stiff, try either DDERKF -C .... or DDEABM. Both of these codes will inform you of stiffness -C .... when the cost of solving such problems becomes important. -C -C ********************************************************************* -C -C***REFERENCES L. F. Shampine and H. A. Watts, DEPAC - design of a user -C oriented package of ODE solvers, Report SAND79-2374, -C Sandia Laboratories, 1979. -C L. F. Shampine and H. A. Watts, Practical solution of -C ordinary differential equations by Runge-Kutta -C methods, Report SAND76-0585, Sandia Laboratories, -C 1976. -C***ROUTINES CALLED DRKFS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891024 Changed references from DVNORM to DHVNRM. (WRB) -C 891024 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900510 Convert XERRWV calls to XERMSG calls, make Prologue comments -C consistent with DERKF. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DDERKF -C - INTEGER IDID, INFO, IPAR, IWORK, KDI, KF1, KF2, KF3, KF4, KF5, - 1 KH, KRER, KTF, KTO, KTSTAR, KU, KYP, KYS, LIW, LRW, NEQ - DOUBLE PRECISION ATOL, RPAR, RTOL, RWORK, T, TOUT, Y - LOGICAL STIFF,NONSTF -C - DIMENSION Y(*),INFO(15),RTOL(*),ATOL(*),RWORK(*),IWORK(*), - 1 RPAR(*),IPAR(*) - CHARACTER*8 XERN1 - CHARACTER*16 XERN3 -C - EXTERNAL DF -C -C CHECK FOR AN APPARENT INFINITE LOOP -C -C***FIRST EXECUTABLE STATEMENT DDERKF - IF (INFO(1) .EQ. 0) IWORK(LIW) = 0 - IF (IWORK(LIW) .GE. 5) THEN - IF (T .EQ. RWORK(21+NEQ)) THEN - WRITE (XERN3, '(1PE15.6)') T - CALL XERMSG ('SLATEC', 'DDERKF', - * 'AN APPARENT INFINITE LOOP HAS BEEN DETECTED.$$' // - * 'YOU HAVE MADE REPEATED CALLS AT T = ' // XERN3 // - * ' AND THE INTEGRATION HAS NOT ADVANCED. CHECK THE ' // - * 'WAY YOU HAVE SET PARAMETERS FOR THE CALL TO THE ' // - * 'CODE, PARTICULARLY INFO(1).', 13, 2) - RETURN - ENDIF - ENDIF -C -C CHECK LRW AND LIW FOR SUFFICIENT STORAGE ALLOCATION -C - IDID = 0 - IF (LRW .LT. 30 + 7*NEQ) THEN - WRITE (XERN1, '(I8)') LRW - CALL XERMSG ('SLATEC', 'DDERKF', 'LENGTH OF RWORK ARRAY ' // - * 'MUST BE AT LEAST 30 + 7*NEQ. YOU HAVE CALLED THE ' // - * 'CODE WITH LRW = ' // XERN1, 1, 1) - IDID = -33 - ENDIF -C - IF (LIW .LT. 34) THEN - WRITE (XERN1, '(I8)') LIW - CALL XERMSG ('SLATEC', 'DDERKF', 'LENGTH OF IWORK ARRAY ' // - * 'MUST BE AT LEAST 34. YOU HAVE CALLED THE CODE WITH ' // - * 'LIW = ' // XERN1, 2, 1) - IDID = -33 - ENDIF -C -C COMPUTE INDICES FOR THE SPLITTING OF THE RWORK ARRAY -C - KH = 11 - KTF = 12 - KYP = 21 - KTSTAR = KYP + NEQ - KF1 = KTSTAR + 1 - KF2 = KF1 + NEQ - KF3 = KF2 + NEQ - KF4 = KF3 + NEQ - KF5 = KF4 + NEQ - KYS = KF5 + NEQ - KTO = KYS + NEQ - KDI = KTO + 1 - KU = KDI + 1 - KRER = KU + 1 -C -C ********************************************************************** -C THIS INTERFACING ROUTINE MERELY RELIEVES THE USER OF A LONG -C CALLING LIST VIA THE SPLITTING APART OF TWO WORKING STORAGE -C ARRAYS. IF THIS IS NOT COMPATIBLE WITH THE USERS COMPILER, -C S/HE MUST USE DRKFS DIRECTLY. -C ********************************************************************** -C - RWORK(KTSTAR) = T - IF (INFO(1) .NE. 0) THEN - STIFF = (IWORK(25) .EQ. 0) - NONSTF = (IWORK(26) .EQ. 0) - ENDIF -C - CALL DRKFS(DF,NEQ,T,Y,TOUT,INFO,RTOL,ATOL,IDID,RWORK(KH), - 1 RWORK(KTF),RWORK(KYP),RWORK(KF1),RWORK(KF2),RWORK(KF3), - 2 RWORK(KF4),RWORK(KF5),RWORK(KYS),RWORK(KTO),RWORK(KDI), - 3 RWORK(KU),RWORK(KRER),IWORK(21),IWORK(22),IWORK(23), - 4 IWORK(24),STIFF,NONSTF,IWORK(27),IWORK(28),RPAR,IPAR) -C - IWORK(25) = 1 - IF (STIFF) IWORK(25) = 0 - IWORK(26) = 1 - IF (NONSTF) IWORK(26) = 0 -C - IF (IDID .NE. (-2)) IWORK(LIW) = IWORK(LIW) + 1 - IF (T .NE. RWORK(KTSTAR)) IWORK(LIW) = 0 -C - RETURN - END diff --git a/slatec/ddes.f b/slatec/ddes.f deleted file mode 100644 index b883381..0000000 --- a/slatec/ddes.f +++ /dev/null @@ -1,430 +0,0 @@ -*DECK DDES - SUBROUTINE DDES (DF, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, - + YPOUT, YP, YY, WT, P, PHI, ALPHA, BETA, PSI, V, W, SIG, G, GI, - + H, EPS, X, XOLD, HOLD, TOLD, DELSGN, TSTOP, TWOU, FOURU, START, - + PHASE1, NORND, STIFF, INTOUT, NS, KORD, KOLD, INIT, KSTEPS, - + KLE4, IQUIT, KPREV, IVC, IV, KGI, RPAR, IPAR) -C***BEGIN PROLOGUE DDES -C***SUBSIDIARY -C***PURPOSE Subsidiary to DDEABM -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (DES-S, DDES-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C DDEABM merely allocates storage for DDES to relieve the user of the -C inconvenience of a long call list. Consequently DDES is used as -C described in the comments for DDEABM . -C -C***SEE ALSO DDEABM -C***ROUTINES CALLED D1MACH, DINTP, DSTEPS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls, cvt GOTOs to -C IF-THEN-ELSE. (RWC) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DDES -C - INTEGER IDID, INFO, INIT, IPAR, IQUIT, IV, IVC, K, KGI, KLE4, - 1 KOLD, KORD, KPREV, KSTEPS, L, LTOL, MAXNUM, NATOLP, NEQ, - 2 NRTOLP, NS - DOUBLE PRECISION A, ABSDEL, ALPHA, ATOL, BETA, D1MACH, - 1 DEL, DELSGN, DT, EPS, FOURU, G, GI, H, - 2 HA, HOLD, P, PHI, PSI, RPAR, RTOL, SIG, T, TOLD, TOUT, - 3 TSTOP, TWOU, U, V, W, WT, X, XOLD, Y, YP, YPOUT, YY - LOGICAL STIFF,CRASH,START,PHASE1,NORND,INTOUT -C - DIMENSION Y(*),YY(*),WT(*),PHI(NEQ,16),P(*),YP(*), - 1 YPOUT(*),PSI(12),ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13), - 2 GI(11),IV(10),INFO(15),RTOL(*),ATOL(*),RPAR(*),IPAR(*) - CHARACTER*8 XERN1 - CHARACTER*16 XERN3, XERN4 -C - EXTERNAL DF -C -C....................................................................... -C -C THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE -C NUMBER OF STEPS ATTEMPTED. WHEN THIS EXCEEDS MAXNUM, THE COUNTER -C IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE EXCESSIVE -C WORK. -C - SAVE MAXNUM - DATA MAXNUM/500/ -C -C....................................................................... -C -C***FIRST EXECUTABLE STATEMENT DDES - IF (INFO(1) .EQ. 0) THEN -C -C ON THE FIRST CALL , PERFORM INITIALIZATION -- -C DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY U BY CALLING THE -C FUNCTION ROUTINE D1MACH. THE USER MUST MAKE SURE THAT THE -C VALUES SET IN D1MACH ARE RELEVANT TO THE COMPUTER BEING USED. -C - U=D1MACH(4) -C -- SET ASSOCIATED MACHINE DEPENDENT PARAMETERS - TWOU=2.D0*U - FOURU=4.D0*U -C -- SET TERMINATION FLAG - IQUIT=0 -C -- SET INITIALIZATION INDICATOR - INIT=0 -C -- SET COUNTER FOR ATTEMPTED STEPS - KSTEPS=0 -C -- SET INDICATOR FOR INTERMEDIATE-OUTPUT - INTOUT= .FALSE. -C -- SET INDICATOR FOR STIFFNESS DETECTION - STIFF= .FALSE. -C -- SET STEP COUNTER FOR STIFFNESS DETECTION - KLE4=0 -C -- SET INDICATORS FOR STEPS CODE - START= .TRUE. - PHASE1= .TRUE. - NORND= .TRUE. -C -- RESET INFO(1) FOR SUBSEQUENT CALLS - INFO(1)=1 - ENDIF -C -C....................................................................... -C -C CHECK VALIDITY OF INPUT PARAMETERS ON EACH ENTRY -C - IF (INFO(1) .NE. 0 .AND. INFO(1) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(1) - CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, INFO(1) MUST BE ' // - * 'SET TO 0 FOR THE START OF A NEW PROBLEM, AND MUST BE ' // - * 'SET TO 1 FOLLOWING AN INTERRUPTED TASK. YOU ARE ' // - * 'ATTEMPTING TO CONTINUE THE INTEGRATION ILLEGALLY BY ' // - * 'CALLING THE CODE WITH INFO(1) = ' // XERN1, 3, 1) - IDID=-33 - ENDIF -C - IF (INFO(2) .NE. 0 .AND. INFO(2) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(2) - CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, INFO(2) MUST BE ' // - * '0 OR 1 INDICATING SCALAR AND VECTOR ERROR TOLERANCES, ' // - * 'RESPECTIVELY. YOU HAVE CALLED THE CODE WITH INFO(2) = ' // - * XERN1, 4, 1) - IDID=-33 - ENDIF -C - IF (INFO(3) .NE. 0 .AND. INFO(3) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(3) - CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, INFO(3) MUST BE ' // - * '0 OR 1 INDICATING THE INTERVAL OR INTERMEDIATE-OUTPUT ' // - * 'MODE OF INTEGRATION, RESPECTIVELY. YOU HAVE CALLED ' // - * 'THE CODE WITH INFO(3) = ' // XERN1, 5, 1) - IDID=-33 - ENDIF -C - IF (INFO(4) .NE. 0 .AND. INFO(4) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(4) - CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, INFO(4) MUST BE ' // - * '0 OR 1 INDICATING WHETHER OR NOT THE INTEGRATION ' // - * 'INTERVAL IS TO BE RESTRICTED BY A POINT TSTOP. YOU ' // - * 'HAVE CALLED THE CODE WITH INFO(4) = ' // XERN1, 14, 1) - IDID=-33 - ENDIF -C - IF (NEQ .LT. 1) THEN - WRITE (XERN1, '(I8)') NEQ - CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, THE NUMBER OF ' // - * 'EQUATIONS NEQ MUST BE A POSITIVE INTEGER. YOU HAVE ' // - * 'CALLED THE CODE WITH NEQ = ' // XERN1, 6, 1) - IDID=-33 - ENDIF -C - NRTOLP = 0 - NATOLP = 0 - DO 90 K=1,NEQ - IF (NRTOLP .EQ. 0 .AND. RTOL(K) .LT. 0.D0) THEN - WRITE (XERN1, '(I8)') K - WRITE (XERN3, '(1PE15.6)') RTOL(K) - CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, THE RELATIVE ' // - * 'ERROR TOLERANCES RTOL MUST BE NON-NEGATIVE. YOU ' // - * 'HAVE CALLED THE CODE WITH RTOL(' // XERN1 // ') = ' // - * XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // - * 'NO FURTHER CHECKING OF RTOL COMPONENTS IS DONE.', 7, 1) - IDID = -33 - NRTOLP = 1 - ENDIF -C - IF (NATOLP .EQ. 0 .AND. ATOL(K) .LT. 0.D0) THEN - WRITE (XERN1, '(I8)') K - WRITE (XERN3, '(1PE15.6)') ATOL(K) - CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, THE ABSOLUTE ' // - * 'ERROR TOLERANCES ATOL MUST BE NON-NEGATIVE. YOU ' // - * 'HAVE CALLED THE CODE WITH ATOL(' // XERN1 // ') = ' // - * XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // - * 'NO FURTHER CHECKING OF ATOL COMPONENTS IS DONE.', 8, 1) - IDID = -33 - NATOLP = 1 - ENDIF -C - IF (INFO(2) .EQ. 0) GO TO 100 - IF (NATOLP.GT.0 .AND. NRTOLP.GT.0) GO TO 100 - 90 CONTINUE -C - 100 IF (INFO(4) .EQ. 1) THEN - IF (SIGN(1.D0,TOUT-T) .NE. SIGN(1.D0,TSTOP-T) - 1 .OR. ABS(TOUT-T) .GT. ABS(TSTOP-T)) THEN - WRITE (XERN3, '(1PE15.6)') TOUT - WRITE (XERN4, '(1PE15.6)') TSTOP - CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, YOU HAVE ' // - * 'CALLED THE CODE WITH TOUT = ' // XERN3 // ' BUT ' // - * 'YOU HAVE ALSO TOLD THE CODE (INFO(4) = 1) NOT TO ' // - * 'INTEGRATE PAST THE POINT TSTOP = ' // XERN4 // - * ' THESE INSTRUCTIONS CONFLICT.', 14, 1) - IDID=-33 - ENDIF - ENDIF -C -C CHECK SOME CONTINUATION POSSIBILITIES -C - IF (INIT .NE. 0) THEN - IF (T .EQ. TOUT) THEN - WRITE (XERN3, '(1PE15.6)') T - CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, YOU HAVE ' // - * 'CALLED THE CODE WITH T = TOUT = ' // XERN3 // - * '$$THIS IS NOT ALLOWED ON CONTINUATION CALLS.', 9, 1) - IDID=-33 - ENDIF -C - IF (T .NE. TOLD) THEN - WRITE (XERN3, '(1PE15.6)') TOLD - WRITE (XERN4, '(1PE15.6)') T - CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, YOU HAVE ' // - * 'CHANGED THE VALUE OF T FROM ' // XERN3 // ' TO ' // - * XERN4 //' THIS IS NOT ALLOWED ON CONTINUATION CALLS.', - * 10, 1) - IDID=-33 - ENDIF -C - IF (INIT .NE. 1) THEN - IF (DELSGN*(TOUT-T) .LT. 0.D0) THEN - WRITE (XERN3, '(1PE15.6)') TOUT - CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, BY ' // - * 'CALLING THE CODE WITH TOUT = ' // XERN3 // - * ' YOU ARE ATTEMPTING TO CHANGE THE DIRECTION OF ' // - * 'INTEGRATION.$$THIS IS NOT ALLOWED WITHOUT ' // - * 'RESTARTING.', 11, 1) - IDID=-33 - ENDIF - ENDIF - ENDIF -C -C INVALID INPUT DETECTED -C - IF (IDID .EQ. (-33)) THEN - IF (IQUIT .NE. (-33)) THEN - IQUIT = -33 - INFO(1) = -1 - ELSE - CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, INVALID ' // - * 'INPUT WAS DETECTED ON SUCCESSIVE ENTRIES. IT IS ' // - * 'IMPOSSIBLE TO PROCEED BECAUSE YOU HAVE NOT ' // - * 'CORRECTED THE PROBLEM, SO EXECUTION IS BEING ' // - * 'TERMINATED.', 12, 2) - ENDIF - RETURN - ENDIF -C -C....................................................................... -C -C RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND INTERPRETED AS -C ASKING FOR THE MOST ACCURATE SOLUTION POSSIBLE. IN THIS CASE, -C THE RELATIVE ERROR TOLERANCE RTOL IS RESET TO THE SMALLEST VALUE -C FOURU WHICH IS LIKELY TO BE REASONABLE FOR THIS METHOD AND MACHINE -C - DO 180 K=1,NEQ - IF (RTOL(K)+ATOL(K) .GT. 0.D0) GO TO 170 - RTOL(K)=FOURU - IDID=-2 - 170 IF (INFO(2) .EQ. 0) GO TO 190 - 180 CONTINUE -C - 190 IF (IDID .NE. (-2)) GO TO 200 -C RTOL=ATOL=0 ON INPUT, SO RTOL IS CHANGED TO A -C SMALL POSITIVE VALUE - INFO(1)=-1 - RETURN -C -C BRANCH ON STATUS OF INITIALIZATION INDICATOR -C INIT=0 MEANS INITIAL DERIVATIVES AND NOMINAL STEP SIZE -C AND DIRECTION NOT YET SET -C INIT=1 MEANS NOMINAL STEP SIZE AND DIRECTION NOT YET SET -C INIT=2 MEANS NO FURTHER INITIALIZATION REQUIRED -C - 200 IF (INIT .EQ. 0) GO TO 210 - IF (INIT .EQ. 1) GO TO 220 - GO TO 240 -C -C....................................................................... -C -C MORE INITIALIZATION -- -C -- EVALUATE INITIAL DERIVATIVES -C - 210 INIT=1 - A=T - CALL DF(A,Y,YP,RPAR,IPAR) - IF (T .NE. TOUT) GO TO 220 - IDID=2 - DO 215 L = 1,NEQ - 215 YPOUT(L) = YP(L) - TOLD=T - RETURN -C -C -- SET INDEPENDENT AND DEPENDENT VARIABLES -C X AND YY(*) FOR STEPS -C -- SET SIGN OF INTEGRATION DIRECTION -C -- INITIALIZE THE STEP SIZE -C - 220 INIT = 2 - X = T - DO 230 L = 1,NEQ - 230 YY(L) = Y(L) - DELSGN = SIGN(1.0D0,TOUT-T) - H = SIGN(MAX(FOURU*ABS(X),ABS(TOUT-X)),TOUT-X) -C -C....................................................................... -C -C ON EACH CALL SET INFORMATION WHICH DETERMINES THE ALLOWED INTERVAL -C OF INTEGRATION BEFORE RETURNING WITH AN ANSWER AT TOUT -C - 240 DEL = TOUT - T - ABSDEL = ABS(DEL) -C -C....................................................................... -C -C IF ALREADY PAST OUTPUT POINT, INTERPOLATE AND RETURN -C - 250 IF(ABS(X-T) .LT. ABSDEL) GO TO 260 - CALL DINTP(X,YY,TOUT,Y,YPOUT,NEQ,KOLD,PHI,IVC,IV,KGI,GI, - 1 ALPHA,G,W,XOLD,P) - IDID = 3 - IF (X .NE. TOUT) GO TO 255 - IDID = 2 - INTOUT = .FALSE. - 255 T = TOUT - TOLD = T - RETURN -C -C IF CANNOT GO PAST TSTOP AND SUFFICIENTLY CLOSE, -C EXTRAPOLATE AND RETURN -C - 260 IF (INFO(4) .NE. 1) GO TO 280 - IF (ABS(TSTOP-X) .GE. FOURU*ABS(X)) GO TO 280 - DT = TOUT - X - DO 270 L = 1,NEQ - 270 Y(L) = YY(L) + DT*YP(L) - CALL DF(TOUT,Y,YPOUT,RPAR,IPAR) - IDID = 3 - T = TOUT - TOLD = T - RETURN -C - 280 IF (INFO(3) .EQ. 0 .OR. .NOT.INTOUT) GO TO 300 -C -C INTERMEDIATE-OUTPUT MODE -C - IDID = 1 - DO 290 L = 1,NEQ - Y(L)=YY(L) - 290 YPOUT(L) = YP(L) - T = X - TOLD = T - INTOUT = .FALSE. - RETURN -C -C....................................................................... -C -C MONITOR NUMBER OF STEPS ATTEMPTED -C - 300 IF (KSTEPS .LE. MAXNUM) GO TO 330 -C -C A SIGNIFICANT AMOUNT OF WORK HAS BEEN EXPENDED - IDID=-1 - KSTEPS=0 - IF (.NOT. STIFF) GO TO 310 -C -C PROBLEM APPEARS TO BE STIFF - IDID=-4 - STIFF= .FALSE. - KLE4=0 -C - 310 DO 320 L = 1,NEQ - Y(L) = YY(L) - 320 YPOUT(L) = YP(L) - T = X - TOLD = T - INFO(1) = -1 - INTOUT = .FALSE. - RETURN -C -C....................................................................... -C -C LIMIT STEP SIZE, SET WEIGHT VECTOR AND TAKE A STEP -C - 330 HA = ABS(H) - IF (INFO(4) .NE. 1) GO TO 340 - HA = MIN(HA,ABS(TSTOP-X)) - 340 H = SIGN(HA,H) - EPS = 1.0D0 - LTOL = 1 - DO 350 L = 1,NEQ - IF (INFO(2) .EQ. 1) LTOL = L - WT(L) = RTOL(LTOL)*ABS(YY(L)) + ATOL(LTOL) - IF (WT(L) .LE. 0.0D0) GO TO 360 - 350 CONTINUE - GO TO 380 -C -C RELATIVE ERROR CRITERION INAPPROPRIATE - 360 IDID = -3 - DO 370 L = 1,NEQ - Y(L) = YY(L) - 370 YPOUT(L) = YP(L) - T = X - TOLD = T - INFO(1) = -1 - INTOUT = .FALSE. - RETURN -C - 380 CALL DSTEPS(DF,NEQ,YY,X,H,EPS,WT,START,HOLD,KORD,KOLD,CRASH,PHI,P, - 1 YP,PSI,ALPHA,BETA,SIG,V,W,G,PHASE1,NS,NORND,KSTEPS, - 2 TWOU,FOURU,XOLD,KPREV,IVC,IV,KGI,GI,RPAR,IPAR) -C -C....................................................................... -C - IF(.NOT.CRASH) GO TO 420 -C -C TOLERANCES TOO SMALL - IDID = -2 - RTOL(1) = EPS*RTOL(1) - ATOL(1) = EPS*ATOL(1) - IF (INFO(2) .EQ. 0) GO TO 400 - DO 390 L = 2,NEQ - RTOL(L) = EPS*RTOL(L) - 390 ATOL(L) = EPS*ATOL(L) - 400 DO 410 L = 1,NEQ - Y(L) = YY(L) - 410 YPOUT(L) = YP(L) - T = X - TOLD = T - INFO(1) = -1 - INTOUT = .FALSE. - RETURN -C -C (STIFFNESS TEST) COUNT NUMBER OF CONSECUTIVE STEPS TAKEN WITH THE -C ORDER OF THE METHOD BEING LESS OR EQUAL TO FOUR -C - 420 KLE4 = KLE4 + 1 - IF(KOLD .GT. 4) KLE4 = 0 - IF(KLE4 .GE. 50) STIFF = .TRUE. - INTOUT = .TRUE. - GO TO 250 - END diff --git a/slatec/ddntl.f b/slatec/ddntl.f deleted file mode 100644 index b521076..0000000 --- a/slatec/ddntl.f +++ /dev/null @@ -1,182 +0,0 @@ -*DECK DDNTL - SUBROUTINE DDNTL (EPS, F, FA, HMAX, HOLD, IMPL, JTASK, MATDIM, - 8 MAXORD, MINT, MITER, ML, MU, N, NDE, SAVE1, T, UROUND, USERS, - 8 Y, YWT, H, MNTOLD, MTROLD, NFE, RC, YH, A, CONVRG, EL, FAC, - 8 IER, IPVT, NQ, NWAIT, RH, RMAX, SAVE2, TQ, TREND, ISWFLG, - 8 JSTATE) -C***BEGIN PROLOGUE DDNTL -C***SUBSIDIARY -C***PURPOSE Subroutine DDNTL is called to set parameters on the first -C call to DDSTP, on an internal restart, or when the user has -C altered MINT, MITER, and/or H. -C***LIBRARY SLATEC (SDRIVE) -C***TYPE DOUBLE PRECISION (SDNTL-S, DDNTL-D, CDNTL-C) -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***DESCRIPTION -C -C On the first call, the order is set to 1 and the initial derivatives -C are calculated. RMAX is the maximum ratio by which H can be -C increased in one step. It is initially RMINIT to compensate -C for the small initial H, but then is normally equal to RMNORM. -C If a failure occurs (in corrector convergence or error test), RMAX -C is set at RMFAIL for the next increase. -C If the caller has changed MINT, or if JTASK = 0, DDCST is called -C to set the coefficients of the method. If the caller has changed H, -C YH must be rescaled. If H or MINT has been changed, NWAIT is -C reset to NQ + 2 to prevent further increases in H for that many -C steps. Also, RC is reset. RC is the ratio of new to old values of -C the coefficient L(0)*H. If the caller has changed MITER, RC is -C set to 0 to force the partials to be updated, if partials are used. -C -C***ROUTINES CALLED DDCST, DDSCL, DGBFA, DGBSL, DGEFA, DGESL, DNRM2 -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE DDNTL - INTEGER I, IFLAG, IMPL, INFO, ISWFLG, JSTATE, JTASK, MATDIM, - 8 MAXORD, MINT, MITER, ML, MNTOLD, MTROLD, MU, N, NDE, NFE, - 8 NQ, NWAIT - DOUBLE PRECISION A(MATDIM,*), EL(13,12), EPS, FAC(*), H, HMAX, - 8 HOLD, OLDL0, RC, RH, RMAX, RMINIT, SAVE1(*), SAVE2(*), DNRM2, - 8 SUM, T, TQ(3,12), TREND, UROUND, Y(*), YH(N,*), YWT(*) - INTEGER IPVT(*) - LOGICAL CONVRG, IER - PARAMETER(RMINIT = 10000.D0) -C***FIRST EXECUTABLE STATEMENT DDNTL - IER = .FALSE. - IF (JTASK .GE. 0) THEN - IF (JTASK .EQ. 0) THEN - CALL DDCST (MAXORD, MINT, ISWFLG, EL, TQ) - RMAX = RMINIT - END IF - RC = 0.D0 - CONVRG = .FALSE. - TREND = 1.D0 - NQ = 1 - NWAIT = 3 - CALL F (N, T, Y, SAVE2) - IF (N .EQ. 0) THEN - JSTATE = 6 - RETURN - END IF - NFE = NFE + 1 - IF (IMPL .NE. 0) THEN - IF (MITER .EQ. 3) THEN - IFLAG = 0 - CALL USERS (Y, YH, YWT, SAVE1, SAVE2, T, H, EL, IMPL, N, - 8 NDE, IFLAG) - IF (IFLAG .EQ. -1) THEN - IER = .TRUE. - RETURN - END IF - IF (N .EQ. 0) THEN - JSTATE = 10 - RETURN - END IF - ELSE IF (IMPL .EQ. 1) THEN - IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - CALL DGEFA (A, MATDIM, N, IPVT, INFO) - IF (INFO .NE. 0) THEN - IER = .TRUE. - RETURN - END IF - CALL DGESL (A, MATDIM, N, IPVT, SAVE2, 0) - ELSE IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN - CALL FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - CALL DGBFA (A, MATDIM, N, ML, MU, IPVT, INFO) - IF (INFO .NE. 0) THEN - IER = .TRUE. - RETURN - END IF - CALL DGBSL (A, MATDIM, N, ML, MU, IPVT, SAVE2, 0) - END IF - ELSE IF (IMPL .EQ. 2) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - DO 150 I = 1,NDE - IF (A(I,1) .EQ. 0.D0) THEN - IER = .TRUE. - RETURN - ELSE - SAVE2(I) = SAVE2(I)/A(I,1) - END IF - 150 CONTINUE - DO 155 I = NDE+1,N - 155 A(I,1) = 0.D0 - ELSE IF (IMPL .EQ. 3) THEN - IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - CALL DGEFA (A, MATDIM, NDE, IPVT, INFO) - IF (INFO .NE. 0) THEN - IER = .TRUE. - RETURN - END IF - CALL DGESL (A, MATDIM, NDE, IPVT, SAVE2, 0) - ELSE IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN - CALL FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - CALL DGBFA (A, MATDIM, NDE, ML, MU, IPVT, INFO) - IF (INFO .NE. 0) THEN - IER = .TRUE. - RETURN - END IF - CALL DGBSL (A, MATDIM, NDE, ML, MU, IPVT, SAVE2, 0) - END IF - END IF - END IF - DO 170 I = 1,NDE - 170 SAVE1(I) = SAVE2(I)/MAX(1.D0, YWT(I)) - SUM = DNRM2(NDE, SAVE1, 1)/SQRT(DBLE(NDE)) - IF (SUM .GT. EPS/ABS(H)) H = SIGN(EPS/SUM, H) - DO 180 I = 1,N - 180 YH(I,2) = H*SAVE2(I) - IF (MITER .EQ. 2 .OR. MITER .EQ. 5 .OR. ISWFLG .EQ. 3) THEN - DO 20 I = 1,N - 20 FAC(I) = SQRT(UROUND) - END IF - ELSE - IF (MITER .NE. MTROLD) THEN - MTROLD = MITER - RC = 0.D0 - CONVRG = .FALSE. - END IF - IF (MINT .NE. MNTOLD) THEN - MNTOLD = MINT - OLDL0 = EL(1,NQ) - CALL DDCST (MAXORD, MINT, ISWFLG, EL, TQ) - RC = RC*EL(1,NQ)/OLDL0 - NWAIT = NQ + 2 - END IF - IF (H .NE. HOLD) THEN - NWAIT = NQ + 2 - RH = H/HOLD - CALL DDSCL (HMAX, N, NQ, RMAX, HOLD, RC, RH, YH) - END IF - END IF - RETURN - END diff --git a/slatec/ddntp.f b/slatec/ddntp.f deleted file mode 100644 index 7a214cb..0000000 --- a/slatec/ddntp.f +++ /dev/null @@ -1,53 +0,0 @@ -*DECK DDNTP - SUBROUTINE DDNTP (H, K, N, NQ, T, TOUT, YH, Y) -C***BEGIN PROLOGUE DDNTP -C***SUBSIDIARY -C***PURPOSE Subroutine DDNTP interpolates the K-th derivative of Y at -C TOUT, using the data in the YH array. If K has a value -C greater than NQ, the NQ-th derivative is calculated. -C***LIBRARY SLATEC (SDRIVE) -C***TYPE DOUBLE PRECISION (SDNTP-S, DDNTP-D, CDNTP-C) -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE DDNTP - INTEGER I, J, JJ, K, KK, KUSED, N, NQ - DOUBLE PRECISION FACTOR, H, R, T, TOUT, Y(*), YH(N,*) -C***FIRST EXECUTABLE STATEMENT DDNTP - IF (K .EQ. 0) THEN - DO 10 I = 1,N - 10 Y(I) = YH(I,NQ+1) - R = ((TOUT - T)/H) - DO 20 JJ = 1,NQ - J = NQ + 1 - JJ - DO 20 I = 1,N - 20 Y(I) = YH(I,J) + R*Y(I) - ELSE - KUSED = MIN(K, NQ) - FACTOR = 1.D0 - DO 40 KK = 1,KUSED - 40 FACTOR = FACTOR*(NQ+1-KK) - DO 50 I = 1,N - 50 Y(I) = FACTOR*YH(I,NQ+1) - R = ((TOUT - T)/H) - DO 80 JJ = KUSED+1,NQ - J = KUSED + 1 + NQ - JJ - FACTOR = 1.D0 - DO 60 KK = 1,KUSED - 60 FACTOR = FACTOR*(J-KK) - DO 70 I = 1,N - 70 Y(I) = FACTOR*YH(I,J) + R*Y(I) - 80 CONTINUE - DO 100 I = 1,N - 100 Y(I) = Y(I)*H**(-KUSED) - END IF - RETURN - END diff --git a/slatec/ddoglg.f b/slatec/ddoglg.f deleted file mode 100644 index 1140e89..0000000 --- a/slatec/ddoglg.f +++ /dev/null @@ -1,183 +0,0 @@ -*DECK DDOGLG - SUBROUTINE DDOGLG (N, R, LR, DIAG, QTB, DELTA, X, WA1, WA2) -C***BEGIN PROLOGUE DDOGLG -C***SUBSIDIARY -C***PURPOSE Subsidiary to DNSQ and DNSQE -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (DOGLEG-S, DDOGLG-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Given an M by N matrix A, an N by N nonsingular diagonal -C matrix D, an M-vector B, and a positive number DELTA, the -C problem is to determine the convex combination X of the -C Gauss-Newton and scaled gradient directions that minimizes -C (A*X - B) in the least squares sense, subject to the -C restriction that the Euclidean norm of D*X be at most DELTA. -C -C This subroutine completes the solution of the problem -C if it is provided with the necessary information from the -C QR factorization of A. That is, if A = Q*R, where Q has -C orthogonal columns and R is an upper triangular matrix, -C then DDOGLG expects the full upper triangle of R and -C the first N components of (Q transpose)*B. -C -C The subroutine statement is -C -C SUBROUTINE DDOGLG(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2) -C -C where -C -C N is a positive integer input variable set to the order of R. -C -C R is an input array of length LR which must contain the upper -C triangular matrix R stored by rows. -C -C LR is a positive integer input variable not less than -C (N*(N+1))/2. -C -C DIAG is an input array of length N which must contain the -C diagonal elements of the matrix D. -C -C QTB is an input array of length N which must contain the first -C N elements of the vector (Q transpose)*B. -C -C DELTA is a positive input variable which specifies an upper -C bound on the Euclidean norm of D*X. -C -C X is an output array of length N which contains the desired -C convex combination of the Gauss-Newton direction and the -C scaled gradient direction. -C -C WA1 and WA2 are work arrays of length N. -C -C***SEE ALSO DNSQ, DNSQE -C***ROUTINES CALLED D1MACH, DENORM -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DDOGLG - DOUBLE PRECISION D1MACH,DENORM - INTEGER I, J, JJ, JP1, K, L, LR, N - DOUBLE PRECISION ALPHA, BNORM, DELTA, DIAG(*), EPSMCH, GNORM, - 1 ONE, QNORM, QTB(*), R(*), SGNORM, SUM, TEMP, WA1(*), - 2 WA2(*), X(*), ZERO - SAVE ONE, ZERO - DATA ONE,ZERO /1.0D0,0.0D0/ -C -C EPSMCH IS THE MACHINE PRECISION. -C -C***FIRST EXECUTABLE STATEMENT DDOGLG - EPSMCH = D1MACH(4) -C -C FIRST, CALCULATE THE GAUSS-NEWTON DIRECTION. -C - JJ = (N*(N + 1))/2 + 1 - DO 50 K = 1, N - J = N - K + 1 - JP1 = J + 1 - JJ = JJ - K - L = JJ + 1 - SUM = ZERO - IF (N .LT. JP1) GO TO 20 - DO 10 I = JP1, N - SUM = SUM + R(L)*X(I) - L = L + 1 - 10 CONTINUE - 20 CONTINUE - TEMP = R(JJ) - IF (TEMP .NE. ZERO) GO TO 40 - L = J - DO 30 I = 1, J - TEMP = MAX(TEMP,ABS(R(L))) - L = L + N - I - 30 CONTINUE - TEMP = EPSMCH*TEMP - IF (TEMP .EQ. ZERO) TEMP = EPSMCH - 40 CONTINUE - X(J) = (QTB(J) - SUM)/TEMP - 50 CONTINUE -C -C TEST WHETHER THE GAUSS-NEWTON DIRECTION IS ACCEPTABLE. -C - DO 60 J = 1, N - WA1(J) = ZERO - WA2(J) = DIAG(J)*X(J) - 60 CONTINUE - QNORM = DENORM(N,WA2) - IF (QNORM .LE. DELTA) GO TO 140 -C -C THE GAUSS-NEWTON DIRECTION IS NOT ACCEPTABLE. -C NEXT, CALCULATE THE SCALED GRADIENT DIRECTION. -C - L = 1 - DO 80 J = 1, N - TEMP = QTB(J) - DO 70 I = J, N - WA1(I) = WA1(I) + R(L)*TEMP - L = L + 1 - 70 CONTINUE - WA1(J) = WA1(J)/DIAG(J) - 80 CONTINUE -C -C CALCULATE THE NORM OF THE SCALED GRADIENT AND TEST FOR -C THE SPECIAL CASE IN WHICH THE SCALED GRADIENT IS ZERO. -C - GNORM = DENORM(N,WA1) - SGNORM = ZERO - ALPHA = DELTA/QNORM - IF (GNORM .EQ. ZERO) GO TO 120 -C -C CALCULATE THE POINT ALONG THE SCALED GRADIENT -C AT WHICH THE QUADRATIC IS MINIMIZED. -C - DO 90 J = 1, N - WA1(J) = (WA1(J)/GNORM)/DIAG(J) - 90 CONTINUE - L = 1 - DO 110 J = 1, N - SUM = ZERO - DO 100 I = J, N - SUM = SUM + R(L)*WA1(I) - L = L + 1 - 100 CONTINUE - WA2(J) = SUM - 110 CONTINUE - TEMP = DENORM(N,WA2) - SGNORM = (GNORM/TEMP)/TEMP -C -C TEST WHETHER THE SCALED GRADIENT DIRECTION IS ACCEPTABLE. -C - ALPHA = ZERO - IF (SGNORM .GE. DELTA) GO TO 120 -C -C THE SCALED GRADIENT DIRECTION IS NOT ACCEPTABLE. -C FINALLY, CALCULATE THE POINT ALONG THE DOGLEG -C AT WHICH THE QUADRATIC IS MINIMIZED. -C - BNORM = DENORM(N,QTB) - TEMP = (BNORM/GNORM)*(BNORM/QNORM)*(SGNORM/DELTA) - TEMP = TEMP - (DELTA/QNORM)*(SGNORM/DELTA)**2 - 1 + SQRT((TEMP-(DELTA/QNORM))**2 - 2 +(ONE-(DELTA/QNORM)**2)*(ONE-(SGNORM/DELTA)**2)) - ALPHA = ((DELTA/QNORM)*(ONE - (SGNORM/DELTA)**2))/TEMP - 120 CONTINUE -C -C FORM APPROPRIATE CONVEX COMBINATION OF THE GAUSS-NEWTON -C DIRECTION AND THE SCALED GRADIENT DIRECTION. -C - TEMP = (ONE - ALPHA)*MIN(SGNORM,DELTA) - DO 130 J = 1, N - X(J) = TEMP*WA1(J) + ALPHA*X(J) - 130 CONTINUE - 140 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE DDOGLG. -C - END diff --git a/slatec/ddot.f b/slatec/ddot.f deleted file mode 100644 index 1fe83eb..0000000 --- a/slatec/ddot.f +++ /dev/null @@ -1,89 +0,0 @@ -*DECK DDOT - DOUBLE PRECISION FUNCTION DDOT (N, DX, INCX, DY, INCY) -C***BEGIN PROLOGUE DDOT -C***PURPOSE Compute the inner product of two vectors. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A4 -C***TYPE DOUBLE PRECISION (SDOT-S, DDOT-D, CDOTU-C) -C***KEYWORDS BLAS, INNER PRODUCT, 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 DX double precision vector with N elements -C INCX storage spacing between elements of DX -C DY double precision vector with N elements -C INCY storage spacing between elements of DY -C -C --Output-- -C DDOT double precision dot product (zero if N .LE. 0) -C -C Returns the dot product of double precision DX and DY. -C DDOT = sum for I = 0 to N-1 of DX(LX+I*INCX) * DY(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 DDOT - DOUBLE PRECISION DX(*), DY(*) -C***FIRST EXECUTABLE STATEMENT DDOT - DDOT = 0.0D0 - IF (N .LE. 0) RETURN - IF (INCX .EQ. INCY) IF (INCX-1) 5,20,60 -C -C Code for unequal or nonpositive increments. -C - 5 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 - DDOT = DDOT + DX(IX)*DY(IY) - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -C -C Code for both increments equal to 1. -C -C Clean-up loop so remaining vector length is a multiple of 5. -C - 20 M = MOD(N,5) - IF (M .EQ. 0) GO TO 40 - DO 30 I = 1,M - DDOT = DDOT + DX(I)*DY(I) - 30 CONTINUE - IF (N .LT. 5) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,5 - DDOT = DDOT + DX(I)*DY(I) + DX(I+1)*DY(I+1) + DX(I+2)*DY(I+2) + - 1 DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4) - 50 CONTINUE - RETURN -C -C Code for equal, positive, non-unit increments. -C - 60 NS = N*INCX - DO 70 I = 1,NS,INCX - DDOT = DDOT + DX(I)*DY(I) - 70 CONTINUE - RETURN - END diff --git a/slatec/ddpsc.f b/slatec/ddpsc.f deleted file mode 100644 index 9a64c18..0000000 --- a/slatec/ddpsc.f +++ /dev/null @@ -1,40 +0,0 @@ -*DECK DDPSC - SUBROUTINE DDPSC (KSGN, N, NQ, YH) -C***BEGIN PROLOGUE DDPSC -C***SUBSIDIARY -C***PURPOSE Subroutine DDPSC computes the predicted YH values by -C effectively multiplying the YH array by the Pascal triangle -C matrix when KSGN is +1, and performs the inverse function -C when KSGN is -1. -C***LIBRARY SLATEC (SDRIVE) -C***TYPE DOUBLE PRECISION (SDPSC-S, DDPSC-D, CDPSC-C) -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE DDPSC - INTEGER I, J, J1, J2, KSGN, N, NQ - DOUBLE PRECISION YH(N,*) -C***FIRST EXECUTABLE STATEMENT DDPSC - IF (KSGN .GT. 0) THEN - DO 10 J1 = 1,NQ - DO 10 J2 = J1,NQ - J = NQ - J2 + J1 - DO 10 I = 1,N - 10 YH(I,J) = YH(I,J) + YH(I,J+1) - ELSE - DO 30 J1 = 1,NQ - DO 30 J2 = J1,NQ - J = NQ - J2 + J1 - DO 30 I = 1,N - 30 YH(I,J) = YH(I,J) - YH(I,J+1) - END IF - RETURN - END diff --git a/slatec/ddpst.f b/slatec/ddpst.f deleted file mode 100644 index d584acc..0000000 --- a/slatec/ddpst.f +++ /dev/null @@ -1,287 +0,0 @@ -*DECK DDPST - SUBROUTINE DDPST (EL, F, FA, H, IMPL, JACOBN, MATDIM, MITER, ML, - 8 MU, N, NDE, NQ, SAVE2, T, USERS, Y, YH, YWT, UROUND, NFE, NJE, - 8 A, DFDY, FAC, IER, IPVT, SAVE1, ISWFLG, BND, JSTATE) -C***BEGIN PROLOGUE DDPST -C***SUBSIDIARY -C***PURPOSE Subroutine DDPST evaluates the Jacobian matrix of the right -C hand side of the differential equations. -C***LIBRARY SLATEC (SDRIVE) -C***TYPE DOUBLE PRECISION (SDPST-S, DDPST-D, CDPST-C) -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***DESCRIPTION -C -C If MITER is 1, 2, 4, or 5, the matrix -C P = I - L(0)*H*Jacobian is stored in DFDY and subjected to LU -C decomposition, with the results also stored in DFDY. -C -C***ROUTINES CALLED DGBFA, DGEFA, DNRM2 -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE DDPST - INTEGER I, IFLAG, IMAX, IMPL, INFO, ISWFLG, J, J2, JSTATE, K, - 8 MATDIM, MITER, ML, MU, MW, N, NDE, NFE, NJE, NQ - DOUBLE PRECISION A(MATDIM,*), BL, BND, BP, BR, BU, DFDY(MATDIM,*), - 8 DFDYMX, DIFF, DY, EL(13,12), FAC(*), FACMAX, FACMIN, FACTOR, - 8 H, SAVE1(*), SAVE2(*), SCALE, DNRM2, T, UROUND, Y(*), - 8 YH(N,*), YJ, YS, YWT(*) - INTEGER IPVT(*) - LOGICAL IER - PARAMETER(FACMAX = .5D0, BU = 0.5D0) -C***FIRST EXECUTABLE STATEMENT DDPST - NJE = NJE + 1 - IER = .FALSE. - IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN - IF (MITER .EQ. 1) THEN - CALL JACOBN (N, T, Y, DFDY, MATDIM, ML, MU) - IF (N .EQ. 0) THEN - JSTATE = 8 - RETURN - END IF - IF (ISWFLG .EQ. 3) BND = DNRM2(N*N, DFDY, 1) - FACTOR = -EL(1,NQ)*H - DO 110 J = 1,N - DO 110 I = 1,N - 110 DFDY(I,J) = FACTOR*DFDY(I,J) - ELSE IF (MITER .EQ. 2) THEN - BR = UROUND**(.875D0) - BL = UROUND**(.75D0) - BP = UROUND**(-.15D0) - FACMIN = UROUND**(.78D0) - DO 170 J = 1,N - YS = MAX(ABS(YWT(J)), ABS(Y(J))) - 120 DY = FAC(J)*YS - IF (DY .EQ. 0.D0) THEN - IF (FAC(J) .LT. FACMAX) THEN - FAC(J) = MIN(100.D0*FAC(J), FACMAX) - GO TO 120 - ELSE - DY = YS - END IF - END IF - IF (NQ .EQ. 1) THEN - DY = SIGN(DY, SAVE2(J)) - ELSE - DY = SIGN(DY, YH(J,3)) - END IF - DY = (Y(J) + DY) - Y(J) - YJ = Y(J) - Y(J) = Y(J) + DY - CALL F (N, T, Y, SAVE1) - IF (N .EQ. 0) THEN - JSTATE = 6 - RETURN - END IF - Y(J) = YJ - FACTOR = -EL(1,NQ)*H/DY - DO 140 I = 1,N - 140 DFDY(I,J) = (SAVE1(I) - SAVE2(I))*FACTOR -C Step 1 - DIFF = ABS(SAVE2(1) - SAVE1(1)) - IMAX = 1 - DO 150 I = 2,N - IF (ABS(SAVE2(I) - SAVE1(I)) .GT. DIFF) THEN - IMAX = I - DIFF = ABS(SAVE2(I) - SAVE1(I)) - END IF - 150 CONTINUE -C Step 2 - IF (MIN(ABS(SAVE2(IMAX)), ABS(SAVE1(IMAX))) .GT. 0.D0) THEN - SCALE = MAX(ABS(SAVE2(IMAX)), ABS(SAVE1(IMAX))) -C Step 3 - IF (DIFF .GT. BU*SCALE) THEN - FAC(J) = MAX(FACMIN, FAC(J)*.5D0) - ELSE IF (BR*SCALE .LE. DIFF .AND. DIFF .LE. BL*SCALE) THEN - FAC(J) = MIN(FAC(J)*2.D0, FACMAX) -C Step 4 - ELSE IF (DIFF .LT. BR*SCALE) THEN - FAC(J) = MIN(BP*FAC(J), FACMAX) - END IF - END IF - 170 CONTINUE - IF (ISWFLG .EQ. 3) BND = DNRM2(N*N, DFDY, 1)/(-EL(1,NQ)*H) - NFE = NFE + N - END IF - IF (IMPL .EQ. 0) THEN - DO 190 I = 1,N - 190 DFDY(I,I) = DFDY(I,I) + 1.D0 - ELSE IF (IMPL .EQ. 1) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - DO 210 J = 1,N - DO 210 I = 1,N - 210 DFDY(I,J) = DFDY(I,J) + A(I,J) - ELSE IF (IMPL .EQ. 2) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - DO 230 I = 1,NDE - 230 DFDY(I,I) = DFDY(I,I) + A(I,1) - ELSE IF (IMPL .EQ. 3) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - DO 220 J = 1,NDE - DO 220 I = 1,NDE - 220 DFDY(I,J) = DFDY(I,J) + A(I,J) - END IF - CALL DGEFA (DFDY, MATDIM, N, IPVT, INFO) - IF (INFO .NE. 0) IER = .TRUE. - ELSE IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN - IF (MITER .EQ. 4) THEN - CALL JACOBN (N, T, Y, DFDY(ML+1,1), MATDIM, ML, MU) - IF (N .EQ. 0) THEN - JSTATE = 8 - RETURN - END IF - FACTOR = -EL(1,NQ)*H - MW = ML + MU + 1 - DO 260 J = 1,N - DO 260 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) - 260 DFDY(I,J) = FACTOR*DFDY(I,J) - ELSE IF (MITER .EQ. 5) THEN - BR = UROUND**(.875D0) - BL = UROUND**(.75D0) - BP = UROUND**(-.15D0) - FACMIN = UROUND**(.78D0) - MW = ML + MU + 1 - J2 = MIN(MW, N) - DO 340 J = 1,J2 - DO 290 K = J,N,MW - YS = MAX(ABS(YWT(K)), ABS(Y(K))) - 280 DY = FAC(K)*YS - IF (DY .EQ. 0.D0) THEN - IF (FAC(K) .LT. FACMAX) THEN - FAC(K) = MIN(100.D0*FAC(K), FACMAX) - GO TO 280 - ELSE - DY = YS - END IF - END IF - IF (NQ .EQ. 1) THEN - DY = SIGN(DY, SAVE2(K)) - ELSE - DY = SIGN(DY, YH(K,3)) - END IF - DY = (Y(K) + DY) - Y(K) - DFDY(MW,K) = Y(K) - 290 Y(K) = Y(K) + DY - CALL F (N, T, Y, SAVE1) - IF (N .EQ. 0) THEN - JSTATE = 6 - RETURN - END IF - DO 330 K = J,N,MW - Y(K) = DFDY(MW,K) - YS = MAX(ABS(YWT(K)), ABS(Y(K))) - DY = FAC(K)*YS - IF (DY .EQ. 0.D0) DY = YS - IF (NQ .EQ. 1) THEN - DY = SIGN(DY, SAVE2(K)) - ELSE - DY = SIGN(DY, YH(K,3)) - END IF - DY = (Y(K) + DY) - Y(K) - FACTOR = -EL(1,NQ)*H/DY - DO 300 I = MAX(ML+1, MW+1-K), MIN(MW+N-K, MW+ML) - 300 DFDY(I,K) = FACTOR*(SAVE1(I+K-MW) - SAVE2(I+K-MW)) -C Step 1 - IMAX = MAX(1, K - MU) - DIFF = ABS(SAVE2(IMAX) - SAVE1(IMAX)) - DO 310 I = MAX(1, K - MU)+1, MIN(K + ML, N) - IF (ABS(SAVE2(I) - SAVE1(I)) .GT. DIFF) THEN - IMAX = I - DIFF = ABS(SAVE2(I) - SAVE1(I)) - END IF - 310 CONTINUE -C Step 2 - IF (MIN(ABS(SAVE2(IMAX)), ABS(SAVE1(IMAX))) .GT.0.D0) THEN - SCALE = MAX(ABS(SAVE2(IMAX)), ABS(SAVE1(IMAX))) -C Step 3 - IF (DIFF .GT. BU*SCALE) THEN - FAC(J) = MAX(FACMIN, FAC(J)*.5D0) - ELSE IF (BR*SCALE .LE.DIFF .AND. DIFF .LE.BL*SCALE) THEN - FAC(J) = MIN(FAC(J)*2.D0, FACMAX) -C Step 4 - ELSE IF (DIFF .LT. BR*SCALE) THEN - FAC(K) = MIN(BP*FAC(K), FACMAX) - END IF - END IF - 330 CONTINUE - 340 CONTINUE - NFE = NFE + J2 - END IF - IF (ISWFLG .EQ. 3) THEN - DFDYMX = 0.D0 - DO 345 J = 1,N - DO 345 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) - 345 DFDYMX = MAX(DFDYMX, ABS(DFDY(I,J))) - BND = 0.D0 - IF (DFDYMX .NE. 0.D0) THEN - DO 350 J = 1,N - DO 350 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) - 350 BND = BND + (DFDY(I,J)/DFDYMX)**2 - BND = DFDYMX*SQRT(BND)/(-EL(1,NQ)*H) - END IF - END IF - IF (IMPL .EQ. 0) THEN - DO 360 J = 1,N - 360 DFDY(MW,J) = DFDY(MW,J) + 1.D0 - ELSE IF (IMPL .EQ. 1) THEN - CALL FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - DO 380 J = 1,N - DO 380 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) - 380 DFDY(I,J) = DFDY(I,J) + A(I,J) - ELSE IF (IMPL .EQ. 2) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - DO 400 J = 1,NDE - 400 DFDY(MW,J) = DFDY(MW,J) + A(J,1) - ELSE IF (IMPL .EQ. 3) THEN - CALL FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - DO 390 J = 1,NDE - DO 390 I = MAX(ML+1, MW+1-J), MIN(MW+NDE-J, MW+ML) - 390 DFDY(I,J) = DFDY(I,J) + A(I,J) - END IF - CALL DGBFA (DFDY, MATDIM, N, ML, MU, IPVT, INFO) - IF (INFO .NE. 0) IER = .TRUE. - ELSE IF (MITER .EQ. 3) THEN - IFLAG = 1 - CALL USERS (Y, YH(1,2), YWT, SAVE1, SAVE2, T, H, EL(1,NQ), IMPL, - 8 N, NDE, IFLAG) - IF (IFLAG .EQ. -1) THEN - IER = .TRUE. - RETURN - END IF - IF (N .EQ. 0) THEN - JSTATE = 10 - RETURN - END IF - END IF - RETURN - END diff --git a/slatec/ddriv1.f b/slatec/ddriv1.f deleted file mode 100644 index 09e2eb8..0000000 --- a/slatec/ddriv1.f +++ /dev/null @@ -1,365 +0,0 @@ -*DECK DDRIV1 - SUBROUTINE DDRIV1 (N, T, Y, F, TOUT, MSTATE, EPS, WORK, LENW, - 8 IERFLG) -C***BEGIN PROLOGUE DDRIV1 -C***PURPOSE The function of DDRIV1 is to solve N (200 or fewer) -C ordinary differential equations of the form -C dY(I)/dT = F(Y(I),T), given the initial conditions -C Y(I) = YI. DDRIV1 uses double precision arithmetic. -C***LIBRARY SLATEC (SDRIVE) -C***CATEGORY I1A2, I1A1B -C***TYPE DOUBLE PRECISION (SDRIV1-S, DDRIV1-D, CDRIV1-C) -C***KEYWORDS DOUBLE PRECISION, GEAR'S METHOD, INITIAL VALUE PROBLEMS, -C ODE, ORDINARY DIFFERENTIAL EQUATIONS, SDRIVE, STIFF -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***DESCRIPTION -C -C Version 92.1 -C -C I. CHOOSING THE CORRECT ROUTINE ................................... -C -C SDRIV -C DDRIV -C CDRIV -C These are the generic names for three packages for solving -C initial value problems for ordinary differential equations. -C SDRIV uses single precision arithmetic. DDRIV uses double -C precision arithmetic. CDRIV allows complex-valued -C differential equations, integrated with respect to a single, -C real, independent variable. -C -C As an aid in selecting the proper program, the following is a -C discussion of the important options or restrictions associated with -C each program: -C -C A. DDRIV1 should be tried first for those routine problems with -C no more than 200 differential equations (DDRIV2 and DDRIV3 -C have no such restriction.) Internally this routine has two -C important technical defaults: -C 1. Numerical approximation of the Jacobian matrix of the -C right hand side is used. -C 2. The stiff solver option is used. -C Most users of DDRIV1 should not have to concern themselves -C with these details. -C -C B. DDRIV2 should be considered for those problems for which -C DDRIV1 is inadequate. For example, DDRIV1 may have difficulty -C with problems having zero initial conditions and zero -C derivatives. In this case DDRIV2, with an appropriate value -C of the parameter EWT, should perform more efficiently. DDRIV2 -C provides three important additional options: -C 1. The nonstiff equation solver (as well as the stiff -C solver) is available. -C 2. The root-finding option is available. -C 3. The program can dynamically select either the non-stiff -C or the stiff methods. -C Internally this routine also defaults to the numerical -C approximation of the Jacobian matrix of the right hand side. -C -C C. DDRIV3 is the most flexible, and hence the most complex, of -C the programs. Its important additional features include: -C 1. The ability to exploit band structure in the Jacobian -C matrix. -C 2. The ability to solve some implicit differential -C equations, i.e., those having the form: -C A(Y,T)*dY/dT = F(Y,T). -C 3. The option of integrating in the one step mode. -C 4. The option of allowing the user to provide a routine -C which computes the analytic Jacobian matrix of the right -C hand side. -C 5. The option of allowing the user to provide a routine -C which does all the matrix algebra associated with -C corrections to the solution components. -C -C II. PARAMETERS .................................................... -C -C (REMEMBER--To run DDRIV1 correctly in double precision, ALL -C non-integer arguments in the call sequence, including -C arrays, MUST be declared double precision.) -C -C The user should use parameter names in the call sequence of DDRIV1 -C for those quantities whose value may be altered by DDRIV1. The -C parameters in the call sequence are: -C -C N = (Input) The number of differential equations, N .LE. 200 -C -C T = The independent variable. On input for the first call, T -C is the initial point. On output, T is the point at which -C the solution is given. -C -C Y = The vector of dependent variables. Y is used as input on -C the first call, to set the initial values. On output, Y -C is the computed solution vector. This array Y is passed -C in the call sequence of the user-provided routine F. Thus -C parameters required by F can be stored in this array in -C components N+1 and above. (Note: Changes by the user to -C the first N components of this array will take effect only -C after a restart, i.e., after setting MSTATE to +1(-1).) -C -C F = A subroutine supplied by the user. The name must be -C declared EXTERNAL in the user's calling program. This -C subroutine is of the form: -C SUBROUTINE F (N, T, Y, YDOT) -C DOUBLE PRECISION Y(*), YDOT(*) -C . -C . -C YDOT(1) = ... -C . -C . -C YDOT(N) = ... -C END (Sample) -C This computes YDOT = F(Y,T), the right hand side of the -C differential equations. Here Y is a vector of length at -C least N. The actual length of Y is determined by the -C user's declaration in the program which calls DDRIV1. -C Thus the dimensioning of Y in F, while required by FORTRAN -C convention, does not actually allocate any storage. When -C this subroutine is called, the first N components of Y are -C intermediate approximations to the solution components. -C The user should not alter these values. Here YDOT is a -C vector of length N. The user should only compute YDOT(I) -C for I from 1 to N. Normally a return from F passes -C control back to DDRIV1. However, if the user would like -C to abort the calculation, i.e., return control to the -C program which calls DDRIV1, he should set N to zero. -C DDRIV1 will signal this by returning a value of MSTATE -C equal to +5(-5). Altering the value of N in F has no -C effect on the value of N in the call sequence of DDRIV1. -C -C TOUT = (Input) The point at which the solution is desired. -C -C MSTATE = An integer describing the status of integration. The user -C must initialize MSTATE to +1 or -1. If MSTATE is -C positive, the routine will integrate past TOUT and -C interpolate the solution. This is the most efficient -C mode. If MSTATE is negative, the routine will adjust its -C internal step to reach TOUT exactly (useful if a -C singularity exists beyond TOUT.) The meaning of the -C magnitude of MSTATE: -C 1 (Input) Means the first call to the routine. This -C value must be set by the user. On all subsequent -C calls the value of MSTATE should be tested by the -C user. Unless DDRIV1 is to be reinitialized, only the -C sign of MSTATE may be changed by the user. (As a -C convenience to the user who may wish to put out the -C initial conditions, DDRIV1 can be called with -C MSTATE=+1(-1), and TOUT=T. In this case the program -C will return with MSTATE unchanged, i.e., -C MSTATE=+1(-1).) -C 2 (Output) Means a successful integration. If a normal -C continuation is desired (i.e., a further integration -C in the same direction), simply advance TOUT and call -C again. All other parameters are automatically set. -C 3 (Output)(Unsuccessful) Means the integrator has taken -C 1000 steps without reaching TOUT. The user can -C continue the integration by simply calling DDRIV1 -C again. -C 4 (Output)(Unsuccessful) Means too much accuracy has -C been requested. EPS has been increased to a value -C the program estimates is appropriate. The user can -C continue the integration by simply calling DDRIV1 -C again. -C 5 (Output)(Unsuccessful) N has been set to zero in -C SUBROUTINE F. -C 6 (Output)(Successful) For MSTATE negative, T is beyond -C TOUT. The solution was obtained by interpolation. -C The user can continue the integration by simply -C advancing TOUT and calling DDRIV1 again. -C 7 (Output)(Unsuccessful) The solution could not be -C obtained. The value of IERFLG (see description -C below) for a "Recoverable" situation indicates the -C type of difficulty encountered: either an illegal -C value for a parameter or an inability to continue the -C solution. For this condition the user should take -C corrective action and reset MSTATE to +1(-1) before -C calling DDRIV1 again. Otherwise the program will -C terminate the run. -C -C EPS = On input, the requested relative accuracy in all solution -C components. On output, the adjusted relative accuracy if -C the input value was too small. The value of EPS should be -C set as large as is reasonable, because the amount of work -C done by DDRIV1 increases as EPS decreases. -C -C WORK -C LENW = (Input) -C WORK is an array of LENW double precision words used -C internally for temporary storage. The user must allocate -C space for this array in the calling program by a statement -C such as -C DOUBLE PRECISION WORK(...) -C The length of WORK should be at least N*N + 11*N + 300 -C and LENW should be set to the value used. The contents of -C WORK should not be disturbed between calls to DDRIV1. -C -C IERFLG = An error flag. The error number associated with a -C diagnostic message (see Section IV-A below) is the same as -C the corresponding value of IERFLG. The meaning of IERFLG: -C 0 The routine completed successfully. (No message is -C issued.) -C 3 (Warning) The number of steps required to reach TOUT -C exceeds 1000 . -C 4 (Warning) The value of EPS is too small. -C 11 (Warning) For MSTATE negative, T is beyond TOUT. -C The solution was obtained by interpolation. -C 15 (Warning) The integration step size is below the -C roundoff level of T. (The program issues this -C message as a warning but does not return control to -C the user.) -C 21 (Recoverable) N is greater than 200 . -C 22 (Recoverable) N is not positive. -C 26 (Recoverable) The magnitude of MSTATE is either 0 or -C greater than 7 . -C 27 (Recoverable) EPS is less than zero. -C 32 (Recoverable) Insufficient storage has been allocated -C for the WORK array. -C 41 (Recoverable) The integration step size has gone -C to zero. -C 42 (Recoverable) The integration step size has been -C reduced about 50 times without advancing the -C solution. The problem setup may not be correct. -C 999 (Fatal) The magnitude of MSTATE is 7 . -C -C III. USAGE ........................................................ -C -C PROGRAM SAMPLE -C EXTERNAL F -C DOUBLE PRECISION ALFA, EPS, T, TOUT -C C N is the number of equations -C PARAMETER(ALFA = 1.D0, N = 3, LENW = N*N + 11*N + 300) -C DOUBLE PRECISION WORK(LENW), Y(N+1) -C C Initial point -C T = 0.00001D0 -C C Set initial conditions -C Y(1) = 10.D0 -C Y(2) = 0.D0 -C Y(3) = 10.D0 -C C Pass parameter -C Y(4) = ALFA -C TOUT = T -C MSTATE = 1 -C EPS = .001D0 -C 10 CALL DDRIV1 (N, T, Y, F, TOUT, MSTATE, EPS, WORK, LENW, -C 8 IERFLG) -C IF (MSTATE .GT. 2) STOP -C WRITE(*, '(4E12.3)') TOUT, (Y(I), I=1,3) -C TOUT = 10.D0*TOUT -C IF (TOUT .LT. 50.D0) GO TO 10 -C END -C -C SUBROUTINE F (N, T, Y, YDOT) -C DOUBLE PRECISION ALFA, T, Y(*), YDOT(*) -C ALFA = Y(N+1) -C YDOT(1) = 1.D0 + ALFA*(Y(2) - Y(1)) - Y(1)*Y(3) -C YDOT(2) = ALFA*(Y(1) - Y(2)) - Y(2)*Y(3) -C YDOT(3) = 1.D0 - Y(3)*(Y(1) + Y(2)) -C END -C -C IV. OTHER COMMUNICATION TO THE USER ............................... -C -C A. The solver communicates to the user through the parameters -C above. In addition it writes diagnostic messages through the -C standard error handling program XERMSG. A complete description -C of XERMSG is given in "Guide to the SLATEC Common Mathematical -C Library" by Kirby W. Fong et al.. At installations which do not -C have this error handling package the short but serviceable -C routine, XERMSG, available with this package, can be used. That -C program uses the file named OUTPUT to transmit messages. -C -C B. The number of evaluations of the right hand side can be found -C in the WORK array in the location determined by: -C LENW - (N + 50) + 4 -C -C V. REMARKS ........................................................ -C -C For other information, see Section IV of the writeup for DDRIV3. -C -C***REFERENCES C. W. Gear, Numerical Initial Value Problems in -C Ordinary Differential Equations, Prentice-Hall, 1971. -C***ROUTINES CALLED DDRIV3, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE DDRIV1 - EXTERNAL F - DOUBLE PRECISION EPS, EWTCOM(1), HMAX, T, TOUT, WORK(*), Y(*) - INTEGER I, IDLIW, IERFLG, IERROR, IMPL, LENIW, LENW, LENWCM, - 8 LNWCHK, MINT, MITER, ML, MSTATE, MU, MXN, MXORD, MXSTEP, - 8 N, NDE, NROOT, NSTATE, NTASK - PARAMETER(MXN = 200, IDLIW = 50) - INTEGER IWORK(IDLIW+MXN) - CHARACTER INTGR1*8 - PARAMETER(NROOT = 0, IERROR = 2, MINT = 2, MITER = 2, IMPL = 0, - 8 MXORD = 5, MXSTEP = 1000) - DATA EWTCOM(1) /1.D0/ -C***FIRST EXECUTABLE STATEMENT DDRIV1 - IF (ABS(MSTATE) .EQ. 0 .OR. ABS(MSTATE) .GT. 7) THEN - WRITE(INTGR1, '(I8)') MSTATE - IERFLG = 26 - CALL XERMSG('SLATEC', 'DDRIV1', - 8 'Illegal input. The magnitude of MSTATE, '//INTGR1// - 8 ', is not in the range 1 to 6 .', IERFLG, 1) - MSTATE = SIGN(7, MSTATE) - RETURN - ELSE IF (ABS(MSTATE) .EQ. 7) THEN - IERFLG = 999 - CALL XERMSG('SLATEC', 'DDRIV1', - 8 'Illegal input. The magnitude of MSTATE is 7 .', IERFLG, 2) - RETURN - END IF - IF (N .GT. MXN) THEN - WRITE(INTGR1, '(I8)') N - IERFLG = 21 - CALL XERMSG('SLATEC', 'DDRIV1', - 8 'Illegal input. The number of equations, '//INTGR1// - 8 ', is greater than the maximum allowed: 200 .', IERFLG, 1) - MSTATE = SIGN(7, MSTATE) - RETURN - END IF - IF (MSTATE .GT. 0) THEN - NSTATE = MSTATE - NTASK = 1 - ELSE - NSTATE = - MSTATE - NTASK = 3 - END IF - HMAX = 2.D0*ABS(TOUT - T) - LENIW = N + IDLIW - LENWCM = LENW - LENIW - IF (LENWCM .LT. (N*N + 10*N + 250)) THEN - LNWCHK = N*N + 10*N + 250 + LENIW - WRITE(INTGR1, '(I8)') LNWCHK - IERFLG = 32 - CALL XERMSG('SLATEC', 'DDRIV1', - 8 'Insufficient storage allocated for the work array. '// - 8 'The required storage is at least '//INTGR1//' .', IERFLG, 1) - MSTATE = SIGN(7, MSTATE) - RETURN - END IF - IF (NSTATE .NE. 1) THEN - DO 20 I = 1,LENIW - 20 IWORK(I) = WORK(I+LENWCM) - END IF - CALL DDRIV3 (N, T, Y, F, NSTATE, TOUT, NTASK, NROOT, EPS, EWTCOM, - 8 IERROR, MINT, MITER, IMPL, ML, MU, MXORD, HMAX, WORK, - 8 LENWCM, IWORK, LENIW, F, F, NDE, MXSTEP, F, F, - 8 IERFLG) - DO 40 I = 1,LENIW - 40 WORK(I+LENWCM) = IWORK(I) - IF (NSTATE .LE. 4) THEN - MSTATE = SIGN(NSTATE, MSTATE) - ELSE IF (NSTATE .EQ. 6) THEN - MSTATE = SIGN(5, MSTATE) - ELSE IF (IERFLG .EQ. 11) THEN - MSTATE = SIGN(6, MSTATE) - ELSE IF (IERFLG .GT. 11) THEN - MSTATE = SIGN(7, MSTATE) - END IF - RETURN - END diff --git a/slatec/ddriv2.f b/slatec/ddriv2.f deleted file mode 100644 index b001cd9..0000000 --- a/slatec/ddriv2.f +++ /dev/null @@ -1,411 +0,0 @@ -*DECK DDRIV2 - SUBROUTINE DDRIV2 (N, T, Y, F, TOUT, MSTATE, NROOT, EPS, EWT, - 8 MINT, WORK, LENW, IWORK, LENIW, G, IERFLG) -C***BEGIN PROLOGUE DDRIV2 -C***PURPOSE The function of DDRIV2 is to solve N ordinary differential -C equations of the form dY(I)/dT = F(Y(I),T), given the -C initial conditions Y(I) = YI. The program has options to -C allow the solution of both stiff and non-stiff differential -C equations. DDRIV2 uses double precision arithmetic. -C***LIBRARY SLATEC (SDRIVE) -C***CATEGORY I1A2, I1A1B -C***TYPE DOUBLE PRECISION (SDRIV2-S, DDRIV2-D, CDRIV2-C) -C***KEYWORDS DOUBLE PRECISION, GEAR'S METHOD, INITIAL VALUE PROBLEMS, -C ODE, ORDINARY DIFFERENTIAL EQUATIONS, SDRIVE, STIFF -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***DESCRIPTION -C -C I. PARAMETERS ..................................................... -C -C (REMEMBER--To run DDRIV2 correctly in double precision, ALL -C non-integer arguments in the call sequence, including -C arrays, MUST be declared double precision.) -C -C The user should use parameter names in the call sequence of DDRIV2 -C for those quantities whose value may be altered by DDRIV2. The -C parameters in the call sequence are: -C -C N = (Input) The number of differential equations. -C -C T = The independent variable. On input for the first call, T -C is the initial point. On output, T is the point at which -C the solution is given. -C -C Y = The vector of dependent variables. Y is used as input on -C the first call, to set the initial values. On output, Y -C is the computed solution vector. This array Y is passed -C in the call sequence of the user-provided routines F and -C G. Thus parameters required by F and G can be stored in -C this array in components N+1 and above. (Note: Changes -C by the user to the first N components of this array will -C take effect only after a restart, i.e., after setting -C MSTATE to +1(-1).) -C -C F = A subroutine supplied by the user. The name must be -C declared EXTERNAL in the user's calling program. This -C subroutine is of the form: -C SUBROUTINE F (N, T, Y, YDOT) -C DOUBLE PRECISION Y(*), YDOT(*) -C . -C . -C YDOT(1) = ... -C . -C . -C YDOT(N) = ... -C END (Sample) -C This computes YDOT = F(Y,T), the right hand side of the -C differential equations. Here Y is a vector of length at -C least N. The actual length of Y is determined by the -C user's declaration in the program which calls DDRIV2. -C Thus the dimensioning of Y in F, while required by FORTRAN -C convention, does not actually allocate any storage. When -C this subroutine is called, the first N components of Y are -C intermediate approximations to the solution components. -C The user should not alter these values. Here YDOT is a -C vector of length N. The user should only compute YDOT(I) -C for I from 1 to N. Normally a return from F passes -C control back to DDRIV2. However, if the user would like -C to abort the calculation, i.e., return control to the -C program which calls DDRIV2, he should set N to zero. -C DDRIV2 will signal this by returning a value of MSTATE -C equal to +6(-6). Altering the value of N in F has no -C effect on the value of N in the call sequence of DDRIV2. -C -C TOUT = (Input) The point at which the solution is desired. -C -C MSTATE = An integer describing the status of integration. The user -C must initialize MSTATE to +1 or -1. If MSTATE is -C positive, the routine will integrate past TOUT and -C interpolate the solution. This is the most efficient -C mode. If MSTATE is negative, the routine will adjust its -C internal step to reach TOUT exactly (useful if a -C singularity exists beyond TOUT.) The meaning of the -C magnitude of MSTATE: -C 1 (Input) Means the first call to the routine. This -C value must be set by the user. On all subsequent -C calls the value of MSTATE should be tested by the -C user. Unless DDRIV2 is to be reinitialized, only the -C sign of MSTATE may be changed by the user. (As a -C convenience to the user who may wish to put out the -C initial conditions, DDRIV2 can be called with -C MSTATE=+1(-1), and TOUT=T. In this case the program -C will return with MSTATE unchanged, i.e., -C MSTATE=+1(-1).) -C 2 (Output) Means a successful integration. If a normal -C continuation is desired (i.e., a further integration -C in the same direction), simply advance TOUT and call -C again. All other parameters are automatically set. -C 3 (Output)(Unsuccessful) Means the integrator has taken -C 1000 steps without reaching TOUT. The user can -C continue the integration by simply calling DDRIV2 -C again. Other than an error in problem setup, the -C most likely cause for this condition is trying to -C integrate a stiff set of equations with the non-stiff -C integrator option. (See description of MINT below.) -C 4 (Output)(Unsuccessful) Means too much accuracy has -C been requested. EPS has been increased to a value -C the program estimates is appropriate. The user can -C continue the integration by simply calling DDRIV2 -C again. -C 5 (Output) A root was found at a point less than TOUT. -C The user can continue the integration toward TOUT by -C simply calling DDRIV2 again. -C 6 (Output)(Unsuccessful) N has been set to zero in -C SUBROUTINE F. -C 7 (Output)(Unsuccessful) N has been set to zero in -C FUNCTION G. See description of G below. -C 8 (Output)(Successful) For MSTATE negative, T is beyond -C TOUT. The solution was obtained by interpolation. -C The user can continue the integration by simply -C advancing TOUT and calling DDRIV2 again. -C 9 (Output)(Unsuccessful) The solution could not be -C obtained. The value of IERFLG (see description -C below) for a "Recoverable" situation indicates the -C type of difficulty encountered: either an illegal -C value for a parameter or an inability to continue the -C solution. For this condition the user should take -C corrective action and reset MSTATE to +1(-1) before -C calling DDRIV2 again. Otherwise the program will -C terminate the run. -C -C NROOT = (Input) The number of equations whose roots are desired. -C If NROOT is zero, the root search is not active. This -C option is useful for obtaining output at points which are -C not known in advance, but depend upon the solution, e.g., -C when some solution component takes on a specified value. -C The root search is carried out using the user-written -C function G (see description of G below.) DDRIV2 attempts -C to find the value of T at which one of the equations -C changes sign. DDRIV2 can find at most one root per -C equation per internal integration step, and will then -C return the solution either at TOUT or at a root, whichever -C occurs first in the direction of integration. The initial -C point is never reported as a root. The index of the -C equation whose root is being reported is stored in the -C sixth element of IWORK. -C NOTE: NROOT is never altered by this program. -C -C EPS = On input, the requested relative accuracy in all solution -C components. EPS = 0 is allowed. On output, the adjusted -C relative accuracy if the input value was too small. The -C value of EPS should be set as large as is reasonable, -C because the amount of work done by DDRIV2 increases as -C EPS decreases. -C -C EWT = (Input) Problem zero, i.e., the smallest physically -C meaningful value for the solution. This is used inter- -C nally to compute an array YWT(I) = MAX(ABS(Y(I)), EWT). -C One step error estimates divided by YWT(I) are kept less -C than EPS. Setting EWT to zero provides pure relative -C error control. However, setting EWT smaller than -C necessary can adversely affect the running time. -C -C MINT = (Input) The integration method flag. -C MINT = 1 Means the Adams methods, and is used for -C non-stiff problems. -C MINT = 2 Means the stiff methods of Gear (i.e., the -C backward differentiation formulas), and is -C used for stiff problems. -C MINT = 3 Means the program dynamically selects the -C Adams methods when the problem is non-stiff -C and the Gear methods when the problem is -C stiff. -C MINT may not be changed without restarting, i.e., setting -C the magnitude of MSTATE to 1. -C -C WORK -C LENW = (Input) -C WORK is an array of LENW double precision words used -C internally for temporary storage. The user must allocate -C space for this array in the calling program by a statement -C such as -C DOUBLE PRECISION WORK(...) -C The length of WORK should be at least -C 16*N + 2*NROOT + 250 if MINT is 1, or -C N*N + 10*N + 2*NROOT + 250 if MINT is 2, or -C N*N + 17*N + 2*NROOT + 250 if MINT is 3, -C and LENW should be set to the value used. The contents of -C WORK should not be disturbed between calls to DDRIV2. -C -C IWORK -C LENIW = (Input) -C IWORK is an integer array of length LENIW used internally -C for temporary storage. The user must allocate space for -C this array in the calling program by a statement such as -C INTEGER IWORK(...) -C The length of IWORK should be at least -C 50 if MINT is 1, or -C N+50 if MINT is 2 or 3, -C and LENIW should be set to the value used. The contents -C of IWORK should not be disturbed between calls to DDRIV2. -C -C G = A double precision FORTRAN function supplied by the user -C if NROOT is not 0. In this case, the name must be -C declared EXTERNAL in the user's calling program. G is -C repeatedly called with different values of IROOT to -C obtain the value of each of the NROOT equations for which -C a root is desired. G is of the form: -C DOUBLE PRECISION FUNCTION G (N, T, Y, IROOT) -C DOUBLE PRECISION Y(*) -C GO TO (10, ...), IROOT -C 10 G = ... -C . -C . -C END (Sample) -C Here, Y is a vector of length at least N, whose first N -C components are the solution components at the point T. -C The user should not alter these values. The actual length -C of Y is determined by the user's declaration in the -C program which calls DDRIV2. Thus the dimensioning of Y in -C G, while required by FORTRAN convention, does not actually -C allocate any storage. Normally a return from G passes -C control back to DDRIV2. However, if the user would like -C to abort the calculation, i.e., return control to the -C program which calls DDRIV2, he should set N to zero. -C DDRIV2 will signal this by returning a value of MSTATE -C equal to +7(-7). In this case, the index of the equation -C being evaluated is stored in the sixth element of IWORK. -C Altering the value of N in G has no effect on the value of -C N in the call sequence of DDRIV2. -C -C IERFLG = An error flag. The error number associated with a -C diagnostic message (see Section II-A below) is the same as -C the corresponding value of IERFLG. The meaning of IERFLG: -C 0 The routine completed successfully. (No message is -C issued.) -C 3 (Warning) The number of steps required to reach TOUT -C exceeds MXSTEP. -C 4 (Warning) The value of EPS is too small. -C 11 (Warning) For MSTATE negative, T is beyond TOUT. -C The solution was obtained by interpolation. -C 15 (Warning) The integration step size is below the -C roundoff level of T. (The program issues this -C message as a warning but does not return control to -C the user.) -C 22 (Recoverable) N is not positive. -C 23 (Recoverable) MINT is less than 1 or greater than 3 . -C 26 (Recoverable) The magnitude of MSTATE is either 0 or -C greater than 9 . -C 27 (Recoverable) EPS is less than zero. -C 32 (Recoverable) Insufficient storage has been allocated -C for the WORK array. -C 33 (Recoverable) Insufficient storage has been allocated -C for the IWORK array. -C 41 (Recoverable) The integration step size has gone -C to zero. -C 42 (Recoverable) The integration step size has been -C reduced about 50 times without advancing the -C solution. The problem setup may not be correct. -C 999 (Fatal) The magnitude of MSTATE is 9 . -C -C II. OTHER COMMUNICATION TO THE USER ............................... -C -C A. The solver communicates to the user through the parameters -C above. In addition it writes diagnostic messages through the -C standard error handling program XERMSG. A complete description -C of XERMSG is given in "Guide to the SLATEC Common Mathematical -C Library" by Kirby W. Fong et al.. At installations which do not -C have this error handling package the short but serviceable -C routine, XERMSG, available with this package, can be used. That -C program uses the file named OUTPUT to transmit messages. -C -C B. The first three elements of WORK and the first five elements of -C IWORK will contain the following statistical data: -C AVGH The average step size used. -C HUSED The step size last used (successfully). -C AVGORD The average order used. -C IMXERR The index of the element of the solution vector that -C contributed most to the last error test. -C NQUSED The order last used (successfully). -C NSTEP The number of steps taken since last initialization. -C NFE The number of evaluations of the right hand side. -C NJE The number of evaluations of the Jacobian matrix. -C -C III. REMARKS ...................................................... -C -C A. On any return from DDRIV2 all information necessary to continue -C the calculation is contained in the call sequence parameters, -C including the work arrays. Thus it is possible to suspend one -C problem, integrate another, and then return to the first. -C -C B. If this package is to be used in an overlay situation, the user -C must declare in the primary overlay the variables in the call -C sequence to DDRIV2. -C -C C. When the routine G is not required, difficulties associated with -C an unsatisfied external can be avoided by using the name of the -C routine which calculates the right hand side of the differential -C equations in place of G in the call sequence of DDRIV2. -C -C IV. USAGE ......................................................... -C -C PROGRAM SAMPLE -C EXTERNAL F -C PARAMETER(MINT = 1, NROOT = 0, N = ..., -C 8 LENW = 16*N + 2*NROOT + 250, LENIW = 50) -C C N is the number of equations -C DOUBLE PRECISION EPS, EWT, T, TOUT, WORK(LENW), Y(N) -C INTEGER IWORK(LENIW) -C OPEN(FILE='TAPE6', UNIT=6, STATUS='NEW') -C C Initial point -C T = 0. -C C Set initial conditions -C DO 10 I = 1,N -C 10 Y(I) = ... -C TOUT = T -C EWT = ... -C MSTATE = 1 -C EPS = ... -C 20 CALL DDRIV2 (N, T, Y, F, TOUT, MSTATE, NROOT, EPS, EWT, -C 8 MINT, WORK, LENW, IWORK, LENIW, F, IERFLG) -C C Next to last argument is not -C C F if rootfinding is used. -C IF (MSTATE .GT. 2) STOP -C WRITE(6, 100) TOUT, (Y(I), I=1,N) -C TOUT = TOUT + 1. -C IF (TOUT .LE. 10.) GO TO 20 -C 100 FORMAT(...) -C END (Sample) -C -C***REFERENCES C. W. Gear, Numerical Initial Value Problems in -C Ordinary Differential Equations, Prentice-Hall, 1971. -C***ROUTINES CALLED DDRIV3, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE DDRIV2 - EXTERNAL F, G - DOUBLE PRECISION EPS, EWT, EWTCOM(1), G, HMAX, T, TOUT, - 8 WORK(*), Y(*) - INTEGER IWORK(*) - INTEGER IERFLG, IERROR, IMPL, LENIW, LENW, MINT, MITER, ML, - 8 MSTATE, MU, MXORD, MXSTEP, N, NDE, NROOT, NSTATE, NTASK - CHARACTER INTGR1*8 - PARAMETER(IMPL = 0, MXSTEP = 1000) -C***FIRST EXECUTABLE STATEMENT DDRIV2 - IF (ABS(MSTATE) .EQ. 9) THEN - IERFLG = 999 - CALL XERMSG('SLATEC', 'DDRIV2', - 8 'Illegal input. The magnitude of MSTATE IS 9 .', - 8 IERFLG, 2) - RETURN - ELSE IF (ABS(MSTATE) .EQ. 0 .OR. ABS(MSTATE) .GT. 9) THEN - WRITE(INTGR1, '(I8)') MSTATE - IERFLG = 26 - CALL XERMSG('SLATEC', 'DDRIV2', - 8 'Illegal input. The magnitude of MSTATE, '//INTGR1// - 8 ' is not in the range 1 to 8 .', IERFLG, 1) - MSTATE = SIGN(9, MSTATE) - RETURN - END IF - IF (MINT .LT. 1 .OR. MINT .GT. 3) THEN - WRITE(INTGR1, '(I8)') MINT - IERFLG = 23 - CALL XERMSG('SLATEC', 'DDRIV2', - 8 'Illegal input. Improper value for the integration method '// - 8 'flag, '//INTGR1//' .', IERFLG, 1) - MSTATE = SIGN(9, MSTATE) - RETURN - END IF - IF (MSTATE .GE. 0) THEN - NSTATE = MSTATE - NTASK = 1 - ELSE - NSTATE = - MSTATE - NTASK = 3 - END IF - EWTCOM(1) = EWT - IF (EWT .NE. 0.D0) THEN - IERROR = 3 - ELSE - IERROR = 2 - END IF - IF (MINT .EQ. 1) THEN - MITER = 0 - MXORD = 12 - ELSE IF (MINT .EQ. 2) THEN - MITER = 2 - MXORD = 5 - ELSE IF (MINT .EQ. 3) THEN - MITER = 2 - MXORD = 12 - END IF - HMAX = 2.D0*ABS(TOUT - T) - CALL DDRIV3 (N, T, Y, F, NSTATE, TOUT, NTASK, NROOT, EPS, EWTCOM, - 8 IERROR, MINT, MITER, IMPL, ML, MU, MXORD, HMAX, WORK, - 8 LENW, IWORK, LENIW, F, F, NDE, MXSTEP, G, F, IERFLG) - IF (NSTATE .LE. 7) THEN - MSTATE = SIGN(NSTATE, MSTATE) - ELSE IF (NSTATE .EQ. 11) THEN - MSTATE = SIGN(8, MSTATE) - ELSE IF (NSTATE .GT. 11) THEN - MSTATE = SIGN(9, MSTATE) - END IF - RETURN - END diff --git a/slatec/ddriv3.f b/slatec/ddriv3.f deleted file mode 100644 index e35d1b8..0000000 --- a/slatec/ddriv3.f +++ /dev/null @@ -1,1528 +0,0 @@ -*DECK DDRIV3 - SUBROUTINE DDRIV3 (N, T, Y, F, NSTATE, TOUT, NTASK, NROOT, EPS, - 8 EWT, IERROR, MINT, MITER, IMPL, ML, MU, MXORD, HMAX, WORK, - 8 LENW, IWORK, LENIW, JACOBN, FA, NDE, MXSTEP, G, USERS, IERFLG) -C***BEGIN PROLOGUE DDRIV3 -C***PURPOSE The function of DDRIV3 is to solve N ordinary differential -C equations of the form dY(I)/dT = F(Y(I),T), given the -C initial conditions Y(I) = YI. The program has options to -C allow the solution of both stiff and non-stiff differential -C equations. Other important options are available. DDRIV3 -C uses double precision arithmetic. -C***LIBRARY SLATEC (SDRIVE) -C***CATEGORY I1A2, I1A1B -C***TYPE DOUBLE PRECISION (SDRIV3-S, DDRIV3-D, CDRIV3-C) -C***KEYWORDS DOUBLE PRECISION, GEAR'S METHOD, INITIAL VALUE PROBLEMS, -C ODE, ORDINARY DIFFERENTIAL EQUATIONS, SDRIVE, STIFF -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***DESCRIPTION -C -C I. ABSTRACT ....................................................... -C -C The primary function of DDRIV3 is to solve N ordinary differential -C equations of the form dY(I)/dT = F(Y(I),T), given the initial -C conditions Y(I) = YI. The program has options to allow the -C solution of both stiff and non-stiff differential equations. In -C addition, DDRIV3 may be used to solve: -C 1. The initial value problem, A*dY(I)/dT = F(Y(I),T), where A is -C a non-singular matrix depending on Y and T. -C 2. The hybrid differential/algebraic initial value problem, -C A*dY(I)/dT = F(Y(I),T), where A is a vector (whose values may -C depend upon Y and T) some of whose components will be zero -C corresponding to those equations which are algebraic rather -C than differential. -C DDRIV3 is to be called once for each output point of T. -C -C II. PARAMETERS .................................................... -C (REMEMBER--To run DDRIV3 correctly in double precision, ALL -C non-integer arguments in the call sequence, including -C arrays, MUST be declared double precision.) -C -C The user should use parameter names in the call sequence of DDRIV3 -C for those quantities whose value may be altered by DDRIV3. The -C parameters in the call sequence are: -C -C N = (Input) The number of dependent functions whose solution -C is desired. N must not be altered during a problem. -C -C T = The independent variable. On input for the first call, T -C is the initial point. On output, T is the point at which -C the solution is given. -C -C Y = The vector of dependent variables. Y is used as input on -C the first call, to set the initial values. On output, Y -C is the computed solution vector. This array Y is passed -C in the call sequence of the user-provided routines F, -C JACOBN, FA, USERS, and G. Thus parameters required by -C those routines can be stored in this array in components -C N+1 and above. (Note: Changes by the user to the first -C N components of this array will take effect only after a -C restart, i.e., after setting NSTATE to 1 .) -C -C F = A subroutine supplied by the user. The name must be -C declared EXTERNAL in the user's calling program. This -C subroutine is of the form: -C SUBROUTINE F (N, T, Y, YDOT) -C DOUBLE PRECISION Y(*), YDOT(*) -C . -C . -C YDOT(1) = ... -C . -C . -C YDOT(N) = ... -C END (Sample) -C This computes YDOT = F(Y,T), the right hand side of the -C differential equations. Here Y is a vector of length at -C least N. The actual length of Y is determined by the -C user's declaration in the program which calls DDRIV3. -C Thus the dimensioning of Y in F, while required by FORTRAN -C convention, does not actually allocate any storage. When -C this subroutine is called, the first N components of Y are -C intermediate approximations to the solution components. -C The user should not alter these values. Here YDOT is a -C vector of length N. The user should only compute YDOT(I) -C for I from 1 to N. Normally a return from F passes -C control back to DDRIV3. However, if the user would like -C to abort the calculation, i.e., return control to the -C program which calls DDRIV3, he should set N to zero. -C DDRIV3 will signal this by returning a value of NSTATE -C equal to 6 . Altering the value of N in F has no effect -C on the value of N in the call sequence of DDRIV3. -C -C NSTATE = An integer describing the status of integration. The -C meaning of NSTATE is as follows: -C 1 (Input) Means the first call to the routine. This -C value must be set by the user. On all subsequent -C calls the value of NSTATE should be tested by the -C user, but must not be altered. (As a convenience to -C the user who may wish to put out the initial -C conditions, DDRIV3 can be called with NSTATE=1, and -C TOUT=T. In this case the program will return with -C NSTATE unchanged, i.e., NSTATE=1.) -C 2 (Output) Means a successful integration. If a normal -C continuation is desired (i.e., a further integration -C in the same direction), simply advance TOUT and call -C again. All other parameters are automatically set. -C 3 (Output)(Unsuccessful) Means the integrator has taken -C MXSTEP steps without reaching TOUT. The user can -C continue the integration by simply calling DDRIV3 -C again. -C 4 (Output)(Unsuccessful) Means too much accuracy has -C been requested. EPS has been increased to a value -C the program estimates is appropriate. The user can -C continue the integration by simply calling DDRIV3 -C again. -C 5 (Output) A root was found at a point less than TOUT. -C The user can continue the integration toward TOUT by -C simply calling DDRIV3 again. -C 6 (Output)(Unsuccessful) N has been set to zero in -C SUBROUTINE F. -C 7 (Output)(Unsuccessful) N has been set to zero in -C FUNCTION G. See description of G below. -C 8 (Output)(Unsuccessful) N has been set to zero in -C SUBROUTINE JACOBN. See description of JACOBN below. -C 9 (Output)(Unsuccessful) N has been set to zero in -C SUBROUTINE FA. See description of FA below. -C 10 (Output)(Unsuccessful) N has been set to zero in -C SUBROUTINE USERS. See description of USERS below. -C 11 (Output)(Successful) For NTASK = 2 or 3, T is beyond -C TOUT. The solution was obtained by interpolation. -C The user can continue the integration by simply -C advancing TOUT and calling DDRIV3 again. -C 12 (Output)(Unsuccessful) The solution could not be -C obtained. The value of IERFLG (see description -C below) for a "Recoverable" situation indicates the -C type of difficulty encountered: either an illegal -C value for a parameter or an inability to continue the -C solution. For this condition the user should take -C corrective action and reset NSTATE to 1 before -C calling DDRIV3 again. Otherwise the program will -C terminate the run. -C -C TOUT = (Input) The point at which the solution is desired. The -C position of TOUT relative to T on the first call -C determines the direction of integration. -C -C NTASK = (Input) An index specifying the manner of returning the -C solution, according to the following: -C NTASK = 1 Means DDRIV3 will integrate past TOUT and -C interpolate the solution. This is the most -C efficient mode. -C NTASK = 2 Means DDRIV3 will return the solution after -C each internal integration step, or at TOUT, -C whichever comes first. In the latter case, -C the program integrates exactly to TOUT. -C NTASK = 3 Means DDRIV3 will adjust its internal step to -C reach TOUT exactly (useful if a singularity -C exists beyond TOUT.) -C -C NROOT = (Input) The number of equations whose roots are desired. -C If NROOT is zero, the root search is not active. This -C option is useful for obtaining output at points which are -C not known in advance, but depend upon the solution, e.g., -C when some solution component takes on a specified value. -C The root search is carried out using the user-written -C function G (see description of G below.) DDRIV3 attempts -C to find the value of T at which one of the equations -C changes sign. DDRIV3 can find at most one root per -C equation per internal integration step, and will then -C return the solution either at TOUT or at a root, whichever -C occurs first in the direction of integration. The initial -C point is never reported as a root. The index of the -C equation whose root is being reported is stored in the -C sixth element of IWORK. -C NOTE: NROOT is never altered by this program. -C -C EPS = On input, the requested relative accuracy in all solution -C components. EPS = 0 is allowed. On output, the adjusted -C relative accuracy if the input value was too small. The -C value of EPS should be set as large as is reasonable, -C because the amount of work done by DDRIV3 increases as EPS -C decreases. -C -C EWT = (Input) Problem zero, i.e., the smallest, nonzero, -C physically meaningful value for the solution. (Array, -C possibly of length one. See following description of -C IERROR.) Setting EWT smaller than necessary can adversely -C affect the running time. -C -C IERROR = (Input) Error control indicator. A value of 3 is -C suggested for most problems. Other choices and detailed -C explanations of EWT and IERROR are given below for those -C who may need extra flexibility. -C -C These last three input quantities EPS, EWT and IERROR -C control the accuracy of the computed solution. EWT and -C IERROR are used internally to compute an array YWT. One -C step error estimates divided by YWT(I) are kept less than -C EPS in root mean square norm. -C IERROR (Set by the user) = -C 1 Means YWT(I) = 1. (Absolute error control) -C EWT is ignored. -C 2 Means YWT(I) = ABS(Y(I)), (Relative error control) -C EWT is ignored. -C 3 Means YWT(I) = MAX(ABS(Y(I)), EWT(1)). -C 4 Means YWT(I) = MAX(ABS(Y(I)), EWT(I)). -C This choice is useful when the solution components -C have differing scales. -C 5 Means YWT(I) = EWT(I). -C If IERROR is 3, EWT need only be dimensioned one. -C If IERROR is 4 or 5, the user must dimension EWT at least -C N, and set its values. -C -C MINT = (Input) The integration method indicator. -C MINT = 1 Means the Adams methods, and is used for -C non-stiff problems. -C MINT = 2 Means the stiff methods of Gear (i.e., the -C backward differentiation formulas), and is -C used for stiff problems. -C MINT = 3 Means the program dynamically selects the -C Adams methods when the problem is non-stiff -C and the Gear methods when the problem is -C stiff. When using the Adams methods, the -C program uses a value of MITER=0; when using -C the Gear methods, the program uses the value -C of MITER provided by the user. Only a value -C of IMPL = 0 and a value of MITER = 1, 2, 4, or -C 5 is allowed for this option. The user may -C not alter the value of MINT or MITER without -C restarting, i.e., setting NSTATE to 1. -C -C MITER = (Input) The iteration method indicator. -C MITER = 0 Means functional iteration. This value is -C suggested for non-stiff problems. -C MITER = 1 Means chord method with analytic Jacobian. -C In this case, the user supplies subroutine -C JACOBN (see description below). -C MITER = 2 Means chord method with Jacobian calculated -C internally by finite differences. -C MITER = 3 Means chord method with corrections computed -C by the user-written routine USERS (see -C description of USERS below.) This option -C allows all matrix algebra and storage -C decisions to be made by the user. When using -C a value of MITER = 3, the subroutine FA is -C not required, even if IMPL is not 0. For -C further information on using this option, see -C Section IV-E below. -C MITER = 4 Means the same as MITER = 1 but the A and -C Jacobian matrices are assumed to be banded. -C MITER = 5 Means the same as MITER = 2 but the A and -C Jacobian matrices are assumed to be banded. -C -C IMPL = (Input) The implicit method indicator. -C IMPL = 0 Means solving dY(I)/dT = F(Y(I),T). -C IMPL = 1 Means solving A*dY(I)/dT = F(Y(I),T), non- -C singular A (see description of FA below.) -C Only MINT = 1 or 2, and MITER = 1, 2, 3, 4, -C or 5 are allowed for this option. -C IMPL = 2,3 Means solving certain systems of hybrid -C differential/algebraic equations (see -C description of FA below.) Only MINT = 2 and -C MITER = 1, 2, 3, 4, or 5, are allowed for -C this option. -C The value of IMPL must not be changed during a problem. -C -C ML = (Input) The lower half-bandwidth in the case of a banded -C A or Jacobian matrix. (I.e., maximum(R-C) for nonzero -C A(R,C).) -C -C MU = (Input) The upper half-bandwidth in the case of a banded -C A or Jacobian matrix. (I.e., maximum(C-R).) -C -C MXORD = (Input) The maximum order desired. This is .LE. 12 for -C the Adams methods and .LE. 5 for the Gear methods. Normal -C value is 12 and 5, respectively. If MINT is 3, the -C maximum order used will be MIN(MXORD, 12) when using the -C Adams methods, and MIN(MXORD, 5) when using the Gear -C methods. MXORD must not be altered during a problem. -C -C HMAX = (Input) The maximum magnitude of the step size that will -C be used for the problem. This is useful for ensuring that -C important details are not missed. If this is not the -C case, a large value, such as the interval length, is -C suggested. -C -C WORK -C LENW = (Input) -C WORK is an array of LENW double precision words used -C internally for temporary storage. The user must allocate -C space for this array in the calling program by a statement -C such as -C DOUBLE PRECISION WORK(...) -C The following table gives the required minimum value for -C the length of WORK, depending on the value of IMPL and -C MITER. LENW should be set to the value used. The -C contents of WORK should not be disturbed between calls to -C DDRIV3. -C -C IMPL = 0 1 2 3 -C --------------------------------------------------------- -C MITER = 0 (MXORD+4)*N Not allowed Not allowed Not allowed -C + 2*NROOT -C + 250 -C -C 1,2 N*N + 2*N*N + N*N + N*(N + NDE) -C (MXORD+5)*N (MXORD+5)*N (MXORD+6)*N + (MXORD+5)*N -C + 2*NROOT + 2*NROOT + 2*NROOT + 2*NROOT -C + 250 + 250 + 250 + 250 -C -C 3 (MXORD+4)*N (MXORD+4)*N (MXORD+4)*N (MXORD+4)*N -C + 2*NROOT + 2*NROOT + 2*NROOT + 2*NROOT -C + 250 + 250 + 250 + 250 -C -C 4,5 (2*ML+MU+1) 2*(2*ML+MU+1) (2*ML+MU+1) (2*ML+MU+1)* -C *N + *N + *N + (N+NDE) + -C (MXORD+5)*N (MXORD+5)*N (MXORD+6)*N + (MXORD+5)*N -C + 2*NROOT + 2*NROOT + 2*NROOT + 2*NROOT -C + 250 + 250 + 250 + 250 -C --------------------------------------------------------- -C -C IWORK -C LENIW = (Input) -C IWORK is an integer array of length LENIW used internally -C for temporary storage. The user must allocate space for -C this array in the calling program by a statement such as -C INTEGER IWORK(...) -C The length of IWORK should be at least -C 50 if MITER is 0 or 3, or -C N+50 if MITER is 1, 2, 4, or 5, or MINT is 3, -C and LENIW should be set to the value used. The contents -C of IWORK should not be disturbed between calls to DDRIV3. -C -C JACOBN = A subroutine supplied by the user, if MITER is 1 or 4. -C If this is the case, the name must be declared EXTERNAL in -C the user's calling program. Given a system of N -C differential equations, it is meaningful to speak about -C the partial derivative of the I-th right hand side with -C respect to the J-th dependent variable. In general there -C are N*N such quantities. Often however the equations can -C be ordered so that the I-th differential equation only -C involves dependent variables with index near I, e.g., I+1, -C I-2. Such a system is called banded. If, for all I, the -C I-th equation depends on at most the variables -C Y(I-ML), Y(I-ML+1), ... , Y(I), Y(I+1), ... , Y(I+MU) -C then we call ML+MU+1 the bandwidth of the system. In a -C banded system many of the partial derivatives above are -C automatically zero. For the cases MITER = 1, 2, 4, and 5, -C some of these partials are needed. For the cases -C MITER = 2 and 5 the necessary derivatives are -C approximated numerically by DDRIV3, and we only ask the -C user to tell DDRIV3 the value of ML and MU if the system -C is banded. For the cases MITER = 1 and 4 the user must -C derive these partials algebraically and encode them in -C subroutine JACOBN. By computing these derivatives the -C user can often save 20-30 per cent of the computing time. -C Usually, however, the accuracy is not much affected and -C most users will probably forego this option. The optional -C user-written subroutine JACOBN has the form: -C SUBROUTINE JACOBN (N, T, Y, DFDY, MATDIM, ML, MU) -C DOUBLE PRECISION Y(*), DFDY(MATDIM,*) -C . -C . -C Calculate values of DFDY -C . -C . -C END (Sample) -C Here Y is a vector of length at least N. The actual -C length of Y is determined by the user's declaration in the -C program which calls DDRIV3. Thus the dimensioning of Y in -C JACOBN, while required by FORTRAN convention, does not -C actually allocate any storage. When this subroutine is -C called, the first N components of Y are intermediate -C approximations to the solution components. The user -C should not alter these values. If the system is not -C banded (MITER=1), the partials of the I-th equation with -C respect to the J-th dependent function are to be stored in -C DFDY(I,J). Thus partials of the I-th equation are stored -C in the I-th row of DFDY. If the system is banded -C (MITER=4), then the partials of the I-th equation with -C respect to Y(J) are to be stored in DFDY(K,J), where -C K=I-J+MU+1 . Normally a return from JACOBN passes control -C back to DDRIV3. However, if the user would like to abort -C the calculation, i.e., return control to the program which -C calls DDRIV3, he should set N to zero. DDRIV3 will signal -C this by returning a value of NSTATE equal to +8(-8). -C Altering the value of N in JACOBN has no effect on the -C value of N in the call sequence of DDRIV3. -C -C FA = A subroutine supplied by the user if IMPL is not zero, and -C MITER is not 3. If so, the name must be declared EXTERNAL -C in the user's calling program. This subroutine computes -C the array A, where A*dY(I)/dT = F(Y(I),T). -C There are three cases: -C -C IMPL=1. -C Subroutine FA is of the form: -C SUBROUTINE FA (N, T, Y, A, MATDIM, ML, MU, NDE) -C DOUBLE PRECISION Y(*), A(MATDIM,*) -C . -C . -C Calculate ALL values of A -C . -C . -C END (Sample) -C In this case A is assumed to be a nonsingular matrix, -C with the same structure as DFDY (see JACOBN description -C above). Programming considerations prevent complete -C generality. If MITER is 1 or 2, A is assumed to be full -C and the user must compute and store all values of -C A(I,J), I,J=1, ... ,N. If MITER is 4 or 5, A is assumed -C to be banded with lower and upper half bandwidth ML and -C MU. The left hand side of the I-th equation is a linear -C combination of dY(I-ML)/dT, dY(I-ML+1)/dT, ... , -C dY(I)/dT, ... , dY(I+MU-1)/dT, dY(I+MU)/dT. Thus in the -C I-th equation, the coefficient of dY(J)/dT is to be -C stored in A(K,J), where K=I-J+MU+1. -C NOTE: The array A will be altered between calls to FA. -C -C IMPL=2. -C Subroutine FA is of the form: -C SUBROUTINE FA (N, T, Y, A, MATDIM, ML, MU, NDE) -C DOUBLE PRECISION Y(*), A(*) -C . -C . -C Calculate non-zero values of A(1),...,A(NDE) -C . -C . -C END (Sample) -C In this case it is assumed that the system is ordered by -C the user so that the differential equations appear -C first, and the algebraic equations appear last. The -C algebraic equations must be written in the form: -C 0 = F(Y(I),T). When using this option it is up to the -C user to provide initial values for the Y(I) that satisfy -C the algebraic equations as well as possible. It is -C further assumed that A is a vector of length NDE. All -C of the components of A, which may depend on T, Y(I), -C etc., must be set by the user to non-zero values. -C -C IMPL=3. -C Subroutine FA is of the form: -C SUBROUTINE FA (N, T, Y, A, MATDIM, ML, MU, NDE) -C DOUBLE PRECISION Y(*), A(MATDIM,*) -C . -C . -C Calculate ALL values of A -C . -C . -C END (Sample) -C In this case A is assumed to be a nonsingular NDE by NDE -C matrix with the same structure as DFDY (see JACOBN -C description above). Programming considerations prevent -C complete generality. If MITER is 1 or 2, A is assumed -C to be full and the user must compute and store all -C values of A(I,J), I,J=1, ... ,NDE. If MITER is 4 or 5, -C A is assumed to be banded with lower and upper half -C bandwidths ML and MU. The left hand side of the I-th -C equation is a linear combination of dY(I-ML)/dT, -C dY(I-ML+1)/dT, ... , dY(I)/dT, ... , dY(I+MU-1)/dT, -C dY(I+MU)/dT. Thus in the I-th equation, the coefficient -C of dY(J)/dT is to be stored in A(K,J), where K=I-J+MU+1. -C It is assumed that the system is ordered by the user so -C that the differential equations appear first, and the -C algebraic equations appear last. The algebraic -C equations must be written in the form 0 = F(Y(I),T). -C When using this option it is up to the user to provide -C initial values for the Y(I) that satisfy the algebraic -C equations as well as possible. -C NOTE: For IMPL = 3, the array A will be altered between -C calls to FA. -C Here Y is a vector of length at least N. The actual -C length of Y is determined by the user's declaration in the -C program which calls DDRIV3. Thus the dimensioning of Y in -C FA, while required by FORTRAN convention, does not -C actually allocate any storage. When this subroutine is -C called, the first N components of Y are intermediate -C approximations to the solution components. The user -C should not alter these values. FA is always called -C immediately after calling F, with the same values of T -C and Y. Normally a return from FA passes control back to -C DDRIV3. However, if the user would like to abort the -C calculation, i.e., return control to the program which -C calls DDRIV3, he should set N to zero. DDRIV3 will signal -C this by returning a value of NSTATE equal to +9(-9). -C Altering the value of N in FA has no effect on the value -C of N in the call sequence of DDRIV3. -C -C NDE = (Input) The number of differential equations. This is -C required only for IMPL = 2 or 3, with NDE .LT. N. -C -C MXSTEP = (Input) The maximum number of internal steps allowed on -C one call to DDRIV3. -C -C G = A double precision FORTRAN function supplied by the user -C if NROOT is not 0. In this case, the name must be -C declared EXTERNAL in the user's calling program. G is -C repeatedly called with different values of IROOT to obtain -C the value of each of the NROOT equations for which a root -C is desired. G is of the form: -C DOUBLE PRECISION FUNCTION G (N, T, Y, IROOT) -C DOUBLE PRECISION Y(*) -C GO TO (10, ...), IROOT -C 10 G = ... -C . -C . -C END (Sample) -C Here, Y is a vector of length at least N, whose first N -C components are the solution components at the point T. -C The user should not alter these values. The actual length -C of Y is determined by the user's declaration in the -C program which calls DDRIV3. Thus the dimensioning of Y in -C G, while required by FORTRAN convention, does not actually -C allocate any storage. Normally a return from G passes -C control back to DDRIV3. However, if the user would like -C to abort the calculation, i.e., return control to the -C program which calls DDRIV3, he should set N to zero. -C DDRIV3 will signal this by returning a value of NSTATE -C equal to +7(-7). In this case, the index of the equation -C being evaluated is stored in the sixth element of IWORK. -C Altering the value of N in G has no effect on the value of -C N in the call sequence of DDRIV3. -C -C USERS = A subroutine supplied by the user, if MITER is 3. -C If this is the case, the name must be declared EXTERNAL in -C the user's calling program. The routine USERS is called -C by DDRIV3 when certain linear systems must be solved. The -C user may choose any method to form, store and solve these -C systems in order to obtain the solution result that is -C returned to DDRIV3. In particular, this allows sparse -C matrix methods to be used. The call sequence for this -C routine is: -C -C SUBROUTINE USERS (Y, YH, YWT, SAVE1, SAVE2, T, H, EL, -C 8 IMPL, N, NDE, IFLAG) -C DOUBLE PRECISION Y(*), YH(*), YWT(*), SAVE1(*), -C 8 SAVE2(*), T, H, EL -C -C The input variable IFLAG indicates what action is to be -C taken. Subroutine USERS should perform the following -C operations, depending on the value of IFLAG and IMPL. -C -C IFLAG = 0 -C IMPL = 0. USERS is not called. -C IMPL = 1, 2 or 3. Solve the system A*X = SAVE2, -C returning the result in SAVE2. The array SAVE1 can -C be used as a work array. For IMPL = 1, there are N -C components to the system, and for IMPL = 2 or 3, -C there are NDE components to the system. -C -C IFLAG = 1 -C IMPL = 0. Compute, decompose and store the matrix -C (I - H*EL*J), where I is the identity matrix and J -C is the Jacobian matrix of the right hand side. The -C array SAVE1 can be used as a work array. -C IMPL = 1, 2 or 3. Compute, decompose and store the -C matrix (A - H*EL*J). The array SAVE1 can be used as -C a work array. -C -C IFLAG = 2 -C IMPL = 0. Solve the system -C (I - H*EL*J)*X = H*SAVE2 - YH - SAVE1, -C returning the result in SAVE2. -C IMPL = 1, 2 or 3. Solve the system -C (A - H*EL*J)*X = H*SAVE2 - A*(YH + SAVE1) -C returning the result in SAVE2. -C The array SAVE1 should not be altered. -C If IFLAG is 0 and IMPL is 1 or 2 and the matrix A is -C singular, or if IFLAG is 1 and one of the matrices -C (I - H*EL*J), (A - H*EL*J) is singular, the INTEGER -C variable IFLAG is to be set to -1 before RETURNing. -C Normally a return from USERS passes control back to -C DDRIV3. However, if the user would like to abort the -C calculation, i.e., return control to the program which -C calls DDRIV3, he should set N to zero. DDRIV3 will signal -C this by returning a value of NSTATE equal to +10(-10). -C Altering the value of N in USERS has no effect on the -C value of N in the call sequence of DDRIV3. -C -C IERFLG = An error flag. The error number associated with a -C diagnostic message (see Section III-A below) is the same -C as the corresponding value of IERFLG. The meaning of -C IERFLG: -C 0 The routine completed successfully. (No message is -C issued.) -C 3 (Warning) The number of steps required to reach TOUT -C exceeds MXSTEP. -C 4 (Warning) The value of EPS is too small. -C 11 (Warning) For NTASK = 2 or 3, T is beyond TOUT. -C The solution was obtained by interpolation. -C 15 (Warning) The integration step size is below the -C roundoff level of T. (The program issues this -C message as a warning but does not return control to -C the user.) -C 22 (Recoverable) N is not positive. -C 23 (Recoverable) MINT is less than 1 or greater than 3 . -C 24 (Recoverable) MITER is less than 0 or greater than -C 5 . -C 25 (Recoverable) IMPL is less than 0 or greater than 3 . -C 26 (Recoverable) The value of NSTATE is less than 1 or -C greater than 12 . -C 27 (Recoverable) EPS is less than zero. -C 28 (Recoverable) MXORD is not positive. -C 29 (Recoverable) For MINT = 3, either MITER = 0 or 3, or -C IMPL = 0 . -C 30 (Recoverable) For MITER = 0, IMPL is not 0 . -C 31 (Recoverable) For MINT = 1, IMPL is 2 or 3 . -C 32 (Recoverable) Insufficient storage has been allocated -C for the WORK array. -C 33 (Recoverable) Insufficient storage has been allocated -C for the IWORK array. -C 41 (Recoverable) The integration step size has gone -C to zero. -C 42 (Recoverable) The integration step size has been -C reduced about 50 times without advancing the -C solution. The problem setup may not be correct. -C 43 (Recoverable) For IMPL greater than 0, the matrix A -C is singular. -C 999 (Fatal) The value of NSTATE is 12 . -C -C III. OTHER COMMUNICATION TO THE USER .............................. -C -C A. The solver communicates to the user through the parameters -C above. In addition it writes diagnostic messages through the -C standard error handling program XERMSG. A complete description -C of XERMSG is given in "Guide to the SLATEC Common Mathematical -C Library" by Kirby W. Fong et al.. At installations which do not -C have this error handling package the short but serviceable -C routine, XERMSG, available with this package, can be used. That -C program uses the file named OUTPUT to transmit messages. -C -C B. The first three elements of WORK and the first five elements of -C IWORK will contain the following statistical data: -C AVGH The average step size used. -C HUSED The step size last used (successfully). -C AVGORD The average order used. -C IMXERR The index of the element of the solution vector that -C contributed most to the last error test. -C NQUSED The order last used (successfully). -C NSTEP The number of steps taken since last initialization. -C NFE The number of evaluations of the right hand side. -C NJE The number of evaluations of the Jacobian matrix. -C -C IV. REMARKS ....................................................... -C -C A. Other routines used: -C DDNTP, DDZRO, DDSTP, DDNTL, DDPST, DDCOR, DDCST, -C DDPSC, and DDSCL; -C DGEFA, DGESL, DGBFA, DGBSL, and DNRM2 (from LINPACK) -C D1MACH (from the Bell Laboratories Machine Constants Package) -C XERMSG (from the SLATEC Common Math Library) -C The last seven routines above, not having been written by the -C present authors, are not explicitly part of this package. -C -C B. On any return from DDRIV3 all information necessary to continue -C the calculation is contained in the call sequence parameters, -C including the work arrays. Thus it is possible to suspend one -C problem, integrate another, and then return to the first. -C -C C. If this package is to be used in an overlay situation, the user -C must declare in the primary overlay the variables in the call -C sequence to DDRIV3. -C -C D. Changing parameters during an integration. -C The value of NROOT, EPS, EWT, IERROR, MINT, MITER, or HMAX may -C be altered by the user between calls to DDRIV3. For example, if -C too much accuracy has been requested (the program returns with -C NSTATE = 4 and an increased value of EPS) the user may wish to -C increase EPS further. In general, prudence is necessary when -C making changes in parameters since such changes are not -C implemented until the next integration step, which is not -C necessarily the next call to DDRIV3. This can happen if the -C program has already integrated to a point which is beyond the -C new point TOUT. -C -C E. As the price for complete control of matrix algebra, the DDRIV3 -C USERS option puts all responsibility for Jacobian matrix -C evaluation on the user. It is often useful to approximate -C numerically all or part of the Jacobian matrix. However this -C must be done carefully. The FORTRAN sequence below illustrates -C the method we recommend. It can be inserted directly into -C subroutine USERS to approximate Jacobian elements in rows I1 -C to I2 and columns J1 to J2. -C DOUBLE PRECISION DFDY(N,N), EPSJ, H, R, D1MACH, -C 8 SAVE1(N), SAVE2(N), T, UROUND, Y(N), YJ, YWT(N) -C UROUND = D1MACH(4) -C EPSJ = SQRT(UROUND) -C DO 30 J = J1,J2 -C R = EPSJ*MAX(ABS(YWT(J)), ABS(Y(J))) -C IF (R .EQ. 0.D0) R = YWT(J) -C YJ = Y(J) -C Y(J) = Y(J) + R -C CALL F (N, T, Y, SAVE1) -C IF (N .EQ. 0) RETURN -C Y(J) = YJ -C DO 20 I = I1,I2 -C 20 DFDY(I,J) = (SAVE1(I) - SAVE2(I))/R -C 30 CONTINUE -C Many problems give rise to structured sparse Jacobians, e.g., -C block banded. It is possible to approximate them with fewer -C function evaluations than the above procedure uses; see Curtis, -C Powell and Reid, J. Inst. Maths Applics, (1974), Vol. 13, -C pp. 117-119. -C -C F. When any of the routines JACOBN, FA, G, or USERS, is not -C required, difficulties associated with unsatisfied externals can -C be avoided by using the name of the routine which calculates the -C right hand side of the differential equations in place of the -C corresponding name in the call sequence of DDRIV3. -C -C***REFERENCES C. W. Gear, Numerical Initial Value Problems in -C Ordinary Differential Equations, Prentice-Hall, 1971. -C***ROUTINES CALLED D1MACH, DDNTP, DDSTP, DDZRO, DGBFA, DGBSL, DGEFA, -C DGESL, DNRM2, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE DDRIV3 - EXTERNAL F, JACOBN, FA, G, USERS - DOUBLE PRECISION AE, BIG, EPS, EWT(*), G, GLAST, GNOW, H, HMAX, - 8 HSIGN, HUSED, NROUND, RE, D1MACH, SIZE, DNRM2, SUM, T, TLAST, - 8 TOUT, TROOT, UROUND, WORK(*), Y(*) - INTEGER I, IA, IAVGH, IAVGRD, ICNVRG, IDFDY, IEL, IERFLG, IERROR, - 8 IFAC, IFLAG, IGNOW, IH, IHMAX, IHOLD, IHSIGN, IHUSED, - 8 IJROOT, IJSTPL, IJTASK, IMNT, IMNTLD, IMPL, IMTR, IMTRLD, - 8 IMTRSV, IMXERR, IMXORD, IMXRDS, INDMXR, INDPRT, INDPVT, - 8 INDTRT, INFE, INFO, INJE, INQ, INQUSE, INROOT, INRTLD, - 8 INSTEP, INWAIT, IRC, IRMAX, IROOT, IMACH1, IMACH4, ISAVE1, - 8 ISAVE2, IT, ITOUT, ITQ, ITREND, ITROOT, IWORK(*), IYH, - 8 IYWT, J, JSTATE, JTROOT, LENCHK, LENIW, LENW, LIWCHK, - 8 MATDIM, MAXORD, MINT, MITER, ML, MU, MXORD, MXSTEP, N, - 8 NDE, NDECOM, NPAR, NROOT, NSTATE, NSTEPL, NTASK - LOGICAL CONVRG - CHARACTER INTGR1*8, INTGR2*8, RL1*16, RL2*16 - PARAMETER(NROUND = 20.D0) - PARAMETER(IAVGH = 1, IHUSED = 2, IAVGRD = 3, - 8 IEL = 4, IH = 160, IHMAX = 161, IHOLD = 162, - 8 IHSIGN = 163, IRC = 164, IRMAX = 165, IT = 166, - 8 ITOUT = 167, ITQ = 168, ITREND = 204, IMACH1 = 205, - 8 IMACH4 = 206, IYH = 251, - 8 INDMXR = 1, INQUSE = 2, INSTEP = 3, INFE = 4, INJE = 5, - 8 INROOT = 6, ICNVRG = 7, IJROOT = 8, IJTASK = 9, - 8 IMNTLD = 10, IMTRLD = 11, INQ = 12, INRTLD = 13, - 8 INDTRT = 14, INWAIT = 15, IMNT = 16, IMTRSV = 17, - 8 IMTR = 18, IMXRDS = 19, IMXORD = 20, INDPRT = 21, - 8 IJSTPL = 22, INDPVT = 51) -C***FIRST EXECUTABLE STATEMENT DDRIV3 - IF (NSTATE .EQ. 12) THEN - IERFLG = 999 - CALL XERMSG('SLATEC', 'DDRIV3', - 8 'Illegal input. The value of NSTATE is 12 .', IERFLG, 2) - RETURN - ELSE IF (NSTATE .LT. 1 .OR. NSTATE .GT. 12) THEN - WRITE(INTGR1, '(I8)') NSTATE - IERFLG = 26 - CALL XERMSG('SLATEC', 'DDRIV3', - 8 'Illegal input. Improper value for NSTATE(= '//INTGR1//').', - 8 IERFLG, 1) - NSTATE = 12 - RETURN - END IF - NPAR = N - IF (EPS .LT. 0.D0) THEN - WRITE(RL1, '(D16.8)') EPS - IERFLG = 27 - CALL XERMSG('SLATEC', 'DDRIV3', - 8 'Illegal input. EPS, '//RL1//', is negative.', IERFLG, 1) - NSTATE = 12 - RETURN - END IF - IF (N .LE. 0) THEN - WRITE(INTGR1, '(I8)') N - IERFLG = 22 - CALL XERMSG('SLATEC', 'DDRIV3', - 8 'Illegal input. Number of equations, '//INTGR1// - 8 ', is not positive.', IERFLG, 1) - NSTATE = 12 - RETURN - END IF - IF (MXORD .LE. 0) THEN - WRITE(INTGR1, '(I8)') MXORD - IERFLG = 28 - CALL XERMSG('SLATEC', 'DDRIV3', - 8 'Illegal input. Maximum order, '//INTGR1// - 8 ', is not positive.', IERFLG, 1) - NSTATE = 12 - RETURN - END IF - IF (MINT .LT. 1 .OR. MINT .GT. 3) THEN - WRITE(INTGR1, '(I8)') MINT - IERFLG = 23 - CALL XERMSG('SLATEC', 'DDRIV3', - 8 'Illegal input. Improper value for the integration method '// - 8 'flag, '//INTGR1//' .', IERFLG, 1) - NSTATE = 12 - RETURN - ELSE IF (MITER .LT. 0 .OR. MITER .GT. 5) THEN - WRITE(INTGR1, '(I8)') MITER - IERFLG = 24 - CALL XERMSG('SLATEC', 'DDRIV3', - 8 'Illegal input. Improper value for MITER(= '//INTGR1//').', - 8 IERFLG, 1) - NSTATE = 12 - RETURN - ELSE IF (IMPL .LT. 0 .OR. IMPL .GT. 3) THEN - WRITE(INTGR1, '(I8)') IMPL - IERFLG = 25 - CALL XERMSG('SLATEC', 'DDRIV3', - 8 'Illegal input. Improper value for IMPL(= '//INTGR1//').', - 8 IERFLG, 1) - NSTATE = 12 - RETURN - ELSE IF (MINT .EQ. 3 .AND. - 8 (MITER .EQ. 0 .OR. MITER .EQ. 3 .OR. IMPL .NE. 0)) THEN - WRITE(INTGR1, '(I8)') MITER - WRITE(INTGR2, '(I8)') IMPL - IERFLG = 29 - CALL XERMSG('SLATEC', 'DDRIV3', - 8 'Illegal input. For MINT = 3, the value of MITER, '//INTGR1// - 8 ', and/or IMPL, '//INTGR2//', is not allowed.', IERFLG, 1) - NSTATE = 12 - RETURN - ELSE IF ((IMPL .GE. 1 .AND. IMPL .LE. 3) .AND. MITER .EQ. 0) THEN - WRITE(INTGR1, '(I8)') IMPL - IERFLG = 30 - CALL XERMSG('SLATEC', 'DDRIV3', - 8 'Illegal input. For MITER = 0, the value of IMPL, '//INTGR1// - 8 ', is not allowed.', IERFLG, 1) - NSTATE = 12 - RETURN - ELSE IF ((IMPL .EQ. 2 .OR. IMPL .EQ. 3) .AND. MINT .EQ. 1) THEN - WRITE(INTGR1, '(I8)') IMPL - IERFLG = 31 - CALL XERMSG('SLATEC', 'DDRIV3', - 8 'Illegal input. For MINT = 1, the value of IMPL, '//INTGR1// - 8 ', is not allowed.', IERFLG, 1) - NSTATE = 12 - RETURN - END IF - IF (MITER .EQ. 0 .OR. MITER .EQ. 3) THEN - LIWCHK = INDPVT - 1 - ELSE IF (MITER .EQ. 1 .OR. MITER .EQ. 2 .OR. MITER .EQ. 4 .OR. - 8 MITER .EQ. 5) THEN - LIWCHK = INDPVT + N - 1 - END IF - IF (LENIW .LT. LIWCHK) THEN - WRITE(INTGR1, '(I8)') LIWCHK - IERFLG = 33 - CALL XERMSG('SLATEC', 'DDRIV3', - 8 'Illegal input. Insufficient storage allocated for the '// - 8 'IWORK array. Based on the value of the input parameters '// - 8 'involved, the required storage is '//INTGR1//' .', IERFLG, 1) - NSTATE = 12 - RETURN - END IF -C Allocate the WORK array -C IYH is the index of YH in WORK - IF (MINT .EQ. 1 .OR. MINT .EQ. 3) THEN - MAXORD = MIN(MXORD, 12) - ELSE IF (MINT .EQ. 2) THEN - MAXORD = MIN(MXORD, 5) - END IF - IDFDY = IYH + (MAXORD + 1)*N -C IDFDY is the index of DFDY -C - IF (MITER .EQ. 0 .OR. MITER .EQ. 3) THEN - IYWT = IDFDY - ELSE IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN - IYWT = IDFDY + N*N - ELSE IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN - IYWT = IDFDY + (2*ML + MU + 1)*N - END IF -C IYWT is the index of YWT - ISAVE1 = IYWT + N -C ISAVE1 is the index of SAVE1 - ISAVE2 = ISAVE1 + N -C ISAVE2 is the index of SAVE2 - IGNOW = ISAVE2 + N -C IGNOW is the index of GNOW - ITROOT = IGNOW + NROOT -C ITROOT is the index of TROOT - IFAC = ITROOT + NROOT -C IFAC is the index of FAC - IF (MITER .EQ. 2 .OR. MITER .EQ. 5 .OR. MINT .EQ. 3) THEN - IA = IFAC + N - ELSE - IA = IFAC - END IF -C IA is the index of A - IF (IMPL .EQ. 0 .OR. MITER .EQ. 3) THEN - LENCHK = IA - 1 - ELSE IF (IMPL .EQ. 1 .AND. (MITER .EQ. 1 .OR. MITER .EQ. 2)) THEN - LENCHK = IA - 1 + N*N - ELSE IF (IMPL .EQ. 1 .AND. (MITER .EQ. 4 .OR. MITER .EQ. 5)) THEN - LENCHK = IA - 1 + (2*ML + MU + 1)*N - ELSE IF (IMPL .EQ. 2 .AND. MITER .NE. 3) THEN - LENCHK = IA - 1 + N - ELSE IF (IMPL .EQ. 3 .AND. (MITER .EQ. 1 .OR. MITER .EQ. 2)) THEN - LENCHK = IA - 1 + N*NDE - ELSE IF (IMPL .EQ. 3 .AND. (MITER .EQ. 4 .OR. MITER .EQ. 5)) THEN - LENCHK = IA - 1 + (2*ML + MU + 1)*NDE - END IF - IF (LENW .LT. LENCHK) THEN - WRITE(INTGR1, '(I8)') LENCHK - IERFLG = 32 - CALL XERMSG('SLATEC', 'DDRIV3', - 8 'Illegal input. Insufficient storage allocated for the '// - 8 'WORK array. Based on the value of the input parameters '// - 8 'involved, the required storage is '//INTGR1//' .', IERFLG, 1) - NSTATE = 12 - RETURN - END IF - IF (MITER .EQ. 0 .OR. MITER .EQ. 3) THEN - MATDIM = 1 - ELSE IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN - MATDIM = N - ELSE IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN - MATDIM = 2*ML + MU + 1 - END IF - IF (IMPL .EQ. 0 .OR. IMPL .EQ. 1) THEN - NDECOM = N - ELSE IF (IMPL .EQ. 2 .OR. IMPL .EQ. 3) THEN - NDECOM = NDE - END IF - IF (NSTATE .EQ. 1) THEN -C Initialize parameters - IF (MINT .EQ. 1 .OR. MINT .EQ. 3) THEN - IWORK(IMXORD) = MIN(MXORD, 12) - ELSE IF (MINT .EQ. 2) THEN - IWORK(IMXORD) = MIN(MXORD, 5) - END IF - IWORK(IMXRDS) = MXORD - IF (MINT .EQ. 1 .OR. MINT .EQ. 2) THEN - IWORK(IMNT) = MINT - IWORK(IMTR) = MITER - IWORK(IMNTLD) = MINT - IWORK(IMTRLD) = MITER - ELSE IF (MINT .EQ. 3) THEN - IWORK(IMNT) = 1 - IWORK(IMTR) = 0 - IWORK(IMNTLD) = IWORK(IMNT) - IWORK(IMTRLD) = IWORK(IMTR) - IWORK(IMTRSV) = MITER - END IF - WORK(IHMAX) = HMAX - UROUND = D1MACH (4) - WORK(IMACH4) = UROUND - WORK(IMACH1) = D1MACH (1) - IF (NROOT .NE. 0) THEN - RE = UROUND - AE = WORK(IMACH1) - END IF - H = (TOUT - T)*(1.D0 - 4.D0*UROUND) - H = SIGN(MIN(ABS(H), HMAX), H) - WORK(IH) = H - HSIGN = SIGN(1.D0, H) - WORK(IHSIGN) = HSIGN - IWORK(IJTASK) = 0 - WORK(IAVGH) = 0.D0 - WORK(IHUSED) = 0.D0 - WORK(IAVGRD) = 0.D0 - IWORK(INDMXR) = 0 - IWORK(INQUSE) = 0 - IWORK(INSTEP) = 0 - IWORK(IJSTPL) = 0 - IWORK(INFE) = 0 - IWORK(INJE) = 0 - IWORK(INROOT) = 0 - WORK(IT) = T - IWORK(ICNVRG) = 0 - IWORK(INDPRT) = 0 -C Set initial conditions - DO 30 I = 1,N - 30 WORK(I+IYH-1) = Y(I) - IF (T .EQ. TOUT) RETURN - GO TO 180 - ELSE - UROUND = WORK(IMACH4) - IF (NROOT .NE. 0) THEN - RE = UROUND - AE = WORK(IMACH1) - END IF - END IF -C On a continuation, check -C that output points have -C been or will be overtaken. - IF (IWORK(ICNVRG) .EQ. 1) THEN - CONVRG = .TRUE. - ELSE - CONVRG = .FALSE. - END IF - T = WORK(IT) - H = WORK(IH) - HSIGN = WORK(IHSIGN) - IF (IWORK(IJTASK) .EQ. 0) GO TO 180 -C -C IWORK(IJROOT) flags unreported -C roots, and is set to the value of -C NTASK when a root was last selected. -C It is set to zero when all roots -C have been reported. IWORK(INROOT) -C contains the index and WORK(ITOUT) -C contains the value of the root last -C selected to be reported. -C IWORK(INRTLD) contains the value of -C NROOT and IWORK(INDTRT) contains -C the value of ITROOT when the array -C of roots was last calculated. - IF (NROOT .NE. 0) THEN - IF (IWORK(IJROOT) .GT. 0) THEN -C TOUT has just been reported. -C If TROOT .LE. TOUT, report TROOT. - IF (NSTATE .NE. 5) THEN - IF (TOUT*HSIGN .GE. WORK(ITOUT)*HSIGN) THEN - TROOT = WORK(ITOUT) - CALL DDNTP (H, 0, N, IWORK(INQ), T, TROOT, WORK(IYH), Y) - T = TROOT - NSTATE = 5 - IERFLG = 0 - GO TO 580 - END IF -C A root has just been reported. -C Select the next root. - ELSE - TROOT = T - IROOT = 0 - DO 50 I = 1,IWORK(INRTLD) - JTROOT = I + IWORK(INDTRT) - 1 - IF (WORK(JTROOT)*HSIGN .LE. TROOT*HSIGN) THEN -C -C Check for multiple roots. -C - IF (WORK(JTROOT) .EQ. WORK(ITOUT) .AND. - 8 I .GT. IWORK(INROOT)) THEN - IROOT = I - TROOT = WORK(JTROOT) - GO TO 60 - END IF - IF (WORK(JTROOT)*HSIGN .GT. WORK(ITOUT)*HSIGN) THEN - IROOT = I - TROOT = WORK(JTROOT) - END IF - END IF - 50 CONTINUE - 60 IWORK(INROOT) = IROOT - WORK(ITOUT) = TROOT - IWORK(IJROOT) = NTASK - IF (NTASK .EQ. 1) THEN - IF (IROOT .EQ. 0) THEN - IWORK(IJROOT) = 0 - ELSE - IF (TOUT*HSIGN .GE. TROOT*HSIGN) THEN - CALL DDNTP (H, 0, N, IWORK(INQ), T, TROOT, WORK(IYH), - 8 Y) - NSTATE = 5 - T = TROOT - IERFLG = 0 - GO TO 580 - END IF - END IF - ELSE IF (NTASK .EQ. 2 .OR. NTASK .EQ. 3) THEN -C -C If there are no more roots, or the -C user has altered TOUT to be less -C than a root, set IJROOT to zero. -C - IF (IROOT .EQ. 0 .OR. (TOUT*HSIGN .LT. TROOT*HSIGN)) THEN - IWORK(IJROOT) = 0 - ELSE - CALL DDNTP (H, 0, N, IWORK(INQ), T, TROOT, WORK(IYH), - 8 Y) - NSTATE = 5 - IERFLG = 0 - T = TROOT - GO TO 580 - END IF - END IF - END IF - END IF - END IF -C - IF (NTASK .EQ. 1) THEN - NSTATE = 2 - IF (T*HSIGN .GE. TOUT*HSIGN) THEN - CALL DDNTP (H, 0, N, IWORK(INQ), T, TOUT, WORK(IYH), Y) - T = TOUT - IERFLG = 0 - GO TO 580 - END IF - ELSE IF (NTASK .EQ. 2) THEN -C Check if TOUT has -C been reset .LT. T - IF (T*HSIGN .GT. TOUT*HSIGN) THEN - WRITE(RL1, '(D16.8)') T - WRITE(RL2, '(D16.8)') TOUT - IERFLG = 11 - CALL XERMSG('SLATEC', 'DDRIV3', - 8 'While integrating exactly to TOUT, T, '//RL1// - 8 ', was beyond TOUT, '//RL2//' . Solution obtained by '// - 8 'interpolation.', IERFLG, 0) - NSTATE = 11 - CALL DDNTP (H, 0, N, IWORK(INQ), T, TOUT, WORK(IYH), Y) - T = TOUT - GO TO 580 - END IF -C Determine if TOUT has been overtaken -C - IF (ABS(TOUT - T).LE.NROUND*UROUND*MAX(ABS(T), ABS(TOUT))) THEN - T = TOUT - NSTATE = 2 - IERFLG = 0 - GO TO 560 - END IF -C If there are no more roots -C to report, report T. - IF (NSTATE .EQ. 5) THEN - NSTATE = 2 - IERFLG = 0 - GO TO 560 - END IF - NSTATE = 2 -C See if TOUT will -C be overtaken. - IF ((T + H)*HSIGN .GT. TOUT*HSIGN) THEN - H = TOUT - T - IF ((T + H)*HSIGN .GT. TOUT*HSIGN) H = H*(1.D0 - 4.D0*UROUND) - WORK(IH) = H - IF (H .EQ. 0.D0) GO TO 670 - IWORK(IJTASK) = -1 - END IF - ELSE IF (NTASK .EQ. 3) THEN - NSTATE = 2 - IF (T*HSIGN .GT. TOUT*HSIGN) THEN - WRITE(RL1, '(D16.8)') T - WRITE(RL2, '(D16.8)') TOUT - IERFLG = 11 - CALL XERMSG('SLATEC', 'DDRIV3', - 8 'While integrating exactly to TOUT, T, '//RL1// - 8 ', was beyond TOUT, '//RL2//' . Solution obtained by '// - 8 'interpolation.', IERFLG, 0) - NSTATE = 11 - CALL DDNTP (H, 0, N, IWORK(INQ), T, TOUT, WORK(IYH), Y) - T = TOUT - GO TO 580 - END IF - IF (ABS(TOUT - T).LE.NROUND*UROUND*MAX(ABS(T), ABS(TOUT))) THEN - T = TOUT - IERFLG = 0 - GO TO 560 - END IF - IF ((T + H)*HSIGN .GT. TOUT*HSIGN) THEN - H = TOUT - T - IF ((T + H)*HSIGN .GT. TOUT*HSIGN) H = H*(1.D0 - 4.D0*UROUND) - WORK(IH) = H - IF (H .EQ. 0.D0) GO TO 670 - IWORK(IJTASK) = -1 - END IF - END IF -C Implement changes in MINT, MITER, and/or HMAX. -C - IF ((MINT .NE. IWORK(IMNTLD) .OR. MITER .NE. IWORK(IMTRLD)) .AND. - 8 MINT .NE. 3 .AND. IWORK(IMNTLD) .NE. 3) IWORK(IJTASK) = -1 - IF (HMAX .NE. WORK(IHMAX)) THEN - H = SIGN(MIN(ABS(H), HMAX), H) - IF (H .NE. WORK(IH)) THEN - IWORK(IJTASK) = -1 - WORK(IH) = H - END IF - WORK(IHMAX) = HMAX - END IF -C - 180 NSTEPL = IWORK(INSTEP) - DO 190 I = 1,N - 190 Y(I) = WORK(I+IYH-1) - IF (NROOT .NE. 0) THEN - DO 200 I = 1,NROOT - WORK(I+IGNOW-1) = G (NPAR, T, Y, I) - IF (NPAR .EQ. 0) THEN - IWORK(INROOT) = I - NSTATE = 7 - RETURN - END IF - 200 CONTINUE - END IF - IF (IERROR .EQ. 1) THEN - DO 230 I = 1,N - 230 WORK(I+IYWT-1) = 1.D0 - GO TO 410 - ELSE IF (IERROR .EQ. 5) THEN - DO 250 I = 1,N - 250 WORK(I+IYWT-1) = EWT(I) - GO TO 410 - END IF -C Reset YWT array. Looping point. - 260 IF (IERROR .EQ. 2) THEN - DO 280 I = 1,N - IF (Y(I) .EQ. 0.D0) GO TO 290 - 280 WORK(I+IYWT-1) = ABS(Y(I)) - GO TO 410 - 290 IF (IWORK(IJTASK) .EQ. 0) THEN - CALL F (NPAR, T, Y, WORK(ISAVE2)) - IF (NPAR .EQ. 0) THEN - NSTATE = 6 - RETURN - END IF - IWORK(INFE) = IWORK(INFE) + 1 - IF (MITER .EQ. 3 .AND. IMPL .NE. 0) THEN - IFLAG = 0 - CALL USERS (Y, WORK(IYH), WORK(IYWT), WORK(ISAVE1), - 8 WORK(ISAVE2), T, H, WORK(IEL), IMPL, NPAR, - 8 NDECOM, IFLAG) - IF (IFLAG .EQ. -1) GO TO 690 - IF (NPAR .EQ. 0) THEN - NSTATE = 10 - RETURN - END IF - ELSE IF (IMPL .EQ. 1) THEN - IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN - CALL FA (NPAR, T, Y, WORK(IA), MATDIM, ML, MU, NDECOM) - IF (NPAR .EQ. 0) THEN - NSTATE = 9 - RETURN - END IF - CALL DGEFA (WORK(IA), MATDIM, N, IWORK(INDPVT), INFO) - IF (INFO .NE. 0) GO TO 690 - CALL DGESL (WORK(IA), MATDIM, N, IWORK(INDPVT), - 8 WORK(ISAVE2), 0) - ELSE IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN - CALL FA (NPAR, T, Y, WORK(IA+ML), MATDIM, ML, MU, NDECOM) - IF (NPAR .EQ. 0) THEN - NSTATE = 9 - RETURN - END IF - CALL DGBFA (WORK(IA), MATDIM, N, ML, MU, IWORK(INDPVT), - 8 INFO) - IF (INFO .NE. 0) GO TO 690 - CALL DGBSL (WORK(IA), MATDIM, N, ML, MU, IWORK(INDPVT), - 8 WORK(ISAVE2), 0) - END IF - ELSE IF (IMPL .EQ. 2) THEN - CALL FA (NPAR, T, Y, WORK(IA), MATDIM, ML, MU, NDECOM) - IF (NPAR .EQ. 0) THEN - NSTATE = 9 - RETURN - END IF - DO 340 I = 1,NDECOM - IF (WORK(I+IA-1) .EQ. 0.D0) GO TO 690 - 340 WORK(I+ISAVE2-1) = WORK(I+ISAVE2-1)/WORK(I+IA-1) - ELSE IF (IMPL .EQ. 3) THEN - IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN - CALL FA (NPAR, T, Y, WORK(IA), MATDIM, ML, MU, NDECOM) - IF (NPAR .EQ. 0) THEN - NSTATE = 9 - RETURN - END IF - CALL DGEFA (WORK(IA), MATDIM, NDE, IWORK(INDPVT), INFO) - IF (INFO .NE. 0) GO TO 690 - CALL DGESL (WORK(IA), MATDIM, NDE, IWORK(INDPVT), - 8 WORK(ISAVE2), 0) - ELSE IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN - CALL FA (NPAR, T, Y, WORK(IA+ML), MATDIM, ML, MU, NDECOM) - IF (NPAR .EQ. 0) THEN - NSTATE = 9 - RETURN - END IF - CALL DGBFA (WORK(IA), MATDIM, NDE, ML, MU, IWORK(INDPVT), - 8 INFO) - IF (INFO .NE. 0) GO TO 690 - CALL DGBSL (WORK(IA), MATDIM, NDE, ML, MU, IWORK(INDPVT), - 8 WORK(ISAVE2), 0) - END IF - END IF - END IF - DO 360 J = I,N - IF (Y(J) .NE. 0.D0) THEN - WORK(J+IYWT-1) = ABS(Y(J)) - ELSE - IF (IWORK(IJTASK) .EQ. 0) THEN - WORK(J+IYWT-1) = ABS(H*WORK(J+ISAVE2-1)) - ELSE - WORK(J+IYWT-1) = ABS(WORK(J+IYH+N-1)) - END IF - END IF - IF (WORK(J+IYWT-1) .EQ. 0.D0) WORK(J+IYWT-1) = UROUND - 360 CONTINUE - ELSE IF (IERROR .EQ. 3) THEN - DO 380 I = 1,N - 380 WORK(I+IYWT-1) = MAX(EWT(1), ABS(Y(I))) - ELSE IF (IERROR .EQ. 4) THEN - DO 400 I = 1,N - 400 WORK(I+IYWT-1) = MAX(EWT(I), ABS(Y(I))) - END IF -C - 410 DO 420 I = 1,N - 420 WORK(I+ISAVE2-1) = Y(I)/WORK(I+IYWT-1) - SUM = DNRM2(N, WORK(ISAVE2), 1)/SQRT(DBLE(N)) - SUM = MAX(1.D0, SUM) - IF (EPS .LT. SUM*UROUND) THEN - EPS = SUM*UROUND*(1.D0 + 10.D0*UROUND) - WRITE(RL1, '(D16.8)') T - WRITE(RL2, '(D16.8)') EPS - IERFLG = 4 - CALL XERMSG('SLATEC', 'DDRIV3', - 8 'At T, '//RL1//', the requested accuracy, EPS, was not '// - 8 'obtainable with the machine precision. EPS has been '// - 8 'increased to '//RL2//' .', IERFLG, 0) - NSTATE = 4 - GO TO 560 - END IF - IF (ABS(H) .GE. UROUND*ABS(T)) THEN - IWORK(INDPRT) = 0 - ELSE IF (IWORK(INDPRT) .EQ. 0) THEN - WRITE(RL1, '(D16.8)') T - WRITE(RL2, '(D16.8)') H - IERFLG = 15 - CALL XERMSG('SLATEC', 'DDRIV3', - 8 'At T, '//RL1//', the step size, '//RL2//', is smaller '// - 8 'than the roundoff level of T. This may occur if there is '// - 8 'an abrupt change in the right hand side of the '// - 8 'differential equations.', IERFLG, 0) - IWORK(INDPRT) = 1 - END IF - IF (NTASK.NE.2) THEN - IF ((IWORK(INSTEP)-NSTEPL) .EQ. MXSTEP) THEN - WRITE(RL1, '(D16.8)') T - WRITE(INTGR1, '(I8)') MXSTEP - WRITE(RL2, '(D16.8)') TOUT - IERFLG = 3 - CALL XERMSG('SLATEC', 'DDRIV3', - 8 'At T, '//RL1//', '//INTGR1//' steps have been taken '// - 8 'without reaching TOUT, '//RL2//' .', IERFLG, 0) - NSTATE = 3 - GO TO 560 - END IF - END IF -C -C CALL DDSTP (EPS, F, FA, HMAX, IMPL, IERROR, JACOBN, MATDIM, -C 8 MAXORD, MINT, MITER, ML, MU, N, NDE, YWT, UROUND, -C 8 USERS, AVGH, AVGORD, H, HUSED, JTASK, MNTOLD, MTROLD, -C 8 NFE, NJE, NQUSED, NSTEP, T, Y, YH, A, CONVRG, -C 8 DFDY, EL, FAC, HOLD, IPVT, JSTATE, JSTEPL, NQ, NWAIT, -C 8 RC, RMAX, SAVE1, SAVE2, TQ, TREND, ISWFLG, MTRSV, -C 8 MXRDSV) -C - CALL DDSTP (EPS, F, FA, WORK(IHMAX), IMPL, IERROR, JACOBN, - 8 MATDIM, IWORK(IMXORD), IWORK(IMNT), IWORK(IMTR), ML, - 8 MU, NPAR, NDECOM, WORK(IYWT), UROUND, USERS, - 8 WORK(IAVGH), WORK(IAVGRD), WORK(IH), HUSED, - 8 IWORK(IJTASK), IWORK(IMNTLD), IWORK(IMTRLD), - 8 IWORK(INFE), IWORK(INJE), IWORK(INQUSE), - 8 IWORK(INSTEP), WORK(IT), Y, WORK(IYH), WORK(IA), - 8 CONVRG, WORK(IDFDY), WORK(IEL), WORK(IFAC), - 8 WORK(IHOLD), IWORK(INDPVT), JSTATE, IWORK(IJSTPL), - 8 IWORK(INQ), IWORK(INWAIT), WORK(IRC), WORK(IRMAX), - 8 WORK(ISAVE1), WORK(ISAVE2), WORK(ITQ), WORK(ITREND), - 8 MINT, IWORK(IMTRSV), IWORK(IMXRDS)) - T = WORK(IT) - H = WORK(IH) - IF (CONVRG) THEN - IWORK(ICNVRG) = 1 - ELSE - IWORK(ICNVRG) = 0 - END IF - GO TO (470, 670, 680, 690, 690, 660, 660, 660, 660, 660), JSTATE - 470 IWORK(IJTASK) = 1 -C Determine if a root has been overtaken - IF (NROOT .NE. 0) THEN - IROOT = 0 - DO 500 I = 1,NROOT - GLAST = WORK(I+IGNOW-1) - GNOW = G (NPAR, T, Y, I) - IF (NPAR .EQ. 0) THEN - IWORK(INROOT) = I - NSTATE = 7 - RETURN - END IF - WORK(I+IGNOW-1) = GNOW - IF (GLAST*GNOW .GT. 0.D0) THEN - WORK(I+ITROOT-1) = T + H - ELSE - IF (GNOW .EQ. 0.D0) THEN - WORK(I+ITROOT-1) = T - IROOT = I - ELSE - IF (GLAST .EQ. 0.D0) THEN - WORK(I+ITROOT-1) = T + H - ELSE - IF (ABS(HUSED) .GE. UROUND*ABS(T)) THEN - TLAST = T - HUSED - IROOT = I - TROOT = T - CALL DDZRO (AE, G, H, NPAR, IWORK(INQ), IROOT, RE, T, - 8 WORK(IYH), UROUND, TROOT, TLAST, - 8 GNOW, GLAST, Y) - DO 480 J = 1,N - 480 Y(J) = WORK(IYH+J-1) - IF (NPAR .EQ. 0) THEN - IWORK(INROOT) = I - NSTATE = 7 - RETURN - END IF - WORK(I+ITROOT-1) = TROOT - ELSE - WORK(I+ITROOT-1) = T - IROOT = I - END IF - END IF - END IF - END IF - 500 CONTINUE - IF (IROOT .EQ. 0) THEN - IWORK(IJROOT) = 0 -C Select the first root - ELSE - IWORK(IJROOT) = NTASK - IWORK(INRTLD) = NROOT - IWORK(INDTRT) = ITROOT - TROOT = T + H - DO 510 I = 1,NROOT - IF (WORK(I+ITROOT-1)*HSIGN .LT. TROOT*HSIGN) THEN - TROOT = WORK(I+ITROOT-1) - IROOT = I - END IF - 510 CONTINUE - IWORK(INROOT) = IROOT - WORK(ITOUT) = TROOT - IF (TROOT*HSIGN .LE. TOUT*HSIGN) THEN - CALL DDNTP (H, 0, N, IWORK(INQ), T, TROOT, WORK(IYH), Y) - NSTATE = 5 - T = TROOT - IERFLG = 0 - GO TO 580 - END IF - END IF - END IF -C Test for NTASK condition to be satisfied - NSTATE = 2 - IF (NTASK .EQ. 1) THEN - IF (T*HSIGN .LT. TOUT*HSIGN) GO TO 260 - CALL DDNTP (H, 0, N, IWORK(INQ), T, TOUT, WORK(IYH), Y) - T = TOUT - IERFLG = 0 - GO TO 580 -C TOUT is assumed to have been attained -C exactly if T is within twenty roundoff -C units of TOUT, relative to MAX(TOUT, T). -C - ELSE IF (NTASK .EQ. 2) THEN - IF (ABS(TOUT - T).LE.NROUND*UROUND*MAX(ABS(T), ABS(TOUT))) THEN - T = TOUT - ELSE - IF ((T + H)*HSIGN .GT. TOUT*HSIGN) THEN - H = TOUT - T - IF ((T + H)*HSIGN.GT.TOUT*HSIGN) H = H*(1.D0 - 4.D0*UROUND) - WORK(IH) = H - IF (H .EQ. 0.D0) GO TO 670 - IWORK(IJTASK) = -1 - END IF - END IF - ELSE IF (NTASK .EQ. 3) THEN - IF (ABS(TOUT - T).LE.NROUND*UROUND*MAX(ABS(T), ABS(TOUT))) THEN - T = TOUT - ELSE - IF ((T + H)*HSIGN .GT. TOUT*HSIGN) THEN - H = TOUT - T - IF ((T + H)*HSIGN.GT.TOUT*HSIGN) H = H*(1.D0 - 4.D0*UROUND) - WORK(IH) = H - IF (H .EQ. 0.D0) GO TO 670 - IWORK(IJTASK) = -1 - END IF - GO TO 260 - END IF - END IF - IERFLG = 0 -C All returns are made through this -C section. IMXERR is determined. - 560 DO 570 I = 1,N - 570 Y(I) = WORK(I+IYH-1) - 580 IF (IWORK(IJTASK) .EQ. 0) RETURN - BIG = 0.D0 - IMXERR = 1 - DO 590 I = 1,N -C SIZE = ABS(ERROR(I)/YWT(I)) - SIZE = ABS(WORK(I+ISAVE1-1)/WORK(I+IYWT-1)) - IF (BIG .LT. SIZE) THEN - BIG = SIZE - IMXERR = I - END IF - 590 CONTINUE - IWORK(INDMXR) = IMXERR - WORK(IHUSED) = HUSED - RETURN -C - 660 NSTATE = JSTATE - RETURN -C Fatal errors are processed here -C - 670 WRITE(RL1, '(D16.8)') T - IERFLG = 41 - CALL XERMSG('SLATEC', 'DDRIV3', - 8 'At T, '//RL1//', the attempted step size has gone to '// - 8 'zero. Often this occurs if the problem setup is incorrect.', - 8 IERFLG, 1) - NSTATE = 12 - RETURN -C - 680 WRITE(RL1, '(D16.8)') T - IERFLG = 42 - CALL XERMSG('SLATEC', 'DDRIV3', - 8 'At T, '//RL1//', the step size has been reduced about 50 '// - 8 'times without advancing the solution. Often this occurs '// - 8 'if the problem setup is incorrect.', IERFLG, 1) - NSTATE = 12 - RETURN -C - 690 WRITE(RL1, '(D16.8)') T - IERFLG = 43 - CALL XERMSG('SLATEC', 'DDRIV3', - 8 'At T, '//RL1//', while solving A*YDOT = F, A is singular.', - 8 IERFLG, 1) - NSTATE = 12 - RETURN - END diff --git a/slatec/ddscl.f b/slatec/ddscl.f deleted file mode 100644 index e30a379..0000000 --- a/slatec/ddscl.f +++ /dev/null @@ -1,37 +0,0 @@ -*DECK DDSCL - SUBROUTINE DDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) -C***BEGIN PROLOGUE DDSCL -C***SUBSIDIARY -C***PURPOSE Subroutine DDSCL rescales the YH array whenever the step -C size is changed. -C***LIBRARY SLATEC (SDRIVE) -C***TYPE DOUBLE PRECISION (SDSCL-S, DDSCL-D, CDSCL-C) -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE DDSCL - INTEGER I, J, N, NQ - DOUBLE PRECISION H, HMAX, RC, RH, RMAX, R1, YH(N,*) -C***FIRST EXECUTABLE STATEMENT DDSCL - IF (H .LT. 1.D0) THEN - RH = MIN(ABS(H)*RH, ABS(H)*RMAX, HMAX)/ABS(H) - ELSE - RH = MIN(RH, RMAX, HMAX/ABS(H)) - END IF - R1 = 1.D0 - DO 10 J = 1,NQ - R1 = R1*RH - DO 10 I = 1,N - 10 YH(I,J+1) = YH(I,J+1)*R1 - H = H*RH - RC = RC*RH - RETURN - END diff --git a/slatec/ddstp.f b/slatec/ddstp.f deleted file mode 100644 index 4efdcfa..0000000 --- a/slatec/ddstp.f +++ /dev/null @@ -1,459 +0,0 @@ -*DECK DDSTP - SUBROUTINE DDSTP (EPS, F, FA, HMAX, IMPL, IERROR, JACOBN, MATDIM, - 8 MAXORD, MINT, MITER, ML, MU, N, NDE, YWT, UROUND, USERS, AVGH, - 8 AVGORD, H, HUSED, JTASK, MNTOLD, MTROLD, NFE, NJE, NQUSED, - 8 NSTEP, T, Y, YH, A, CONVRG, DFDY, EL, FAC, HOLD, IPVT, JSTATE, - 8 JSTEPL, NQ, NWAIT, RC, RMAX, SAVE1, SAVE2, TQ, TREND, ISWFLG, - 8 MTRSV, MXRDSV) -C***BEGIN PROLOGUE DDSTP -C***SUBSIDIARY -C***PURPOSE DDSTP performs one step of the integration of an initial -C value problem for a system of ordinary differential -C equations. -C***LIBRARY SLATEC (SDRIVE) -C***TYPE DOUBLE PRECISION (SDSTP-S, DDSTP-D, CDSTP-C) -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***DESCRIPTION -C -C Communication with DDSTP is done with the following variables: -C -C YH An N by MAXORD+1 array containing the dependent variables -C and their scaled derivatives. MAXORD, the maximum order -C used, is currently 12 for the Adams methods and 5 for the -C Gear methods. YH(I,J+1) contains the J-th derivative of -C Y(I), scaled by H**J/factorial(J). Only Y(I), -C 1 .LE. I .LE. N, need be set by the calling program on -C the first entry. The YH array should not be altered by -C the calling program. When referencing YH as a -C 2-dimensional array, use a column length of N, as this is -C the value used in DDSTP. -C DFDY A block of locations used for partial derivatives if MITER -C is not 0. If MITER is 1 or 2 its length must be at least -C N*N. If MITER is 4 or 5 its length must be at least -C (2*ML+MU+1)*N. -C YWT An array of N locations used in convergence and error tests -C SAVE1 -C SAVE2 Arrays of length N used for temporary storage. -C IPVT An integer array of length N used by the linear system -C solvers for the storage of row interchange information. -C A A block of locations used to store the matrix A, when using -C the implicit method. If IMPL is 1, A is a MATDIM by N -C array. If MITER is 1 or 2 MATDIM is N, and if MITER is 4 -C or 5 MATDIM is 2*ML+MU+1. If IMPL is 2 its length is N. -C If IMPL is 3, A is a MATDIM by NDE array. -C JTASK An integer used on input. -C It has the following values and meanings: -C .EQ. 0 Perform the first step. This value enables -C the subroutine to initialize itself. -C .GT. 0 Take a new step continuing from the last. -C Assumes the last step was successful and -C user has not changed any parameters. -C .LT. 0 Take a new step with a new value of H and/or -C MINT and/or MITER. -C JSTATE A completion code with the following meanings: -C 1 The step was successful. -C 2 A solution could not be obtained with H .NE. 0. -C 3 A solution was not obtained in MXTRY attempts. -C 4 For IMPL .NE. 0, the matrix A is singular. -C On a return with JSTATE .GT. 1, the values of T and -C the YH array are as of the beginning of the last -C step, and H is the last step size attempted. -C -C***ROUTINES CALLED DDCOR, DDCST, DDNTL, DDPSC, DDPST, DDSCL, DNRM2 -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE DDSTP - EXTERNAL F, JACOBN, FA, USERS - INTEGER I, IERROR, IMPL, IPVT(*), ISWFLG, ITER, J, JSTATE, JSTEPL, - 8 JTASK, MATDIM, MAXORD, MINT, MITER, ML, MNTOLD, MTROLD, - 8 MTRSV, MU, MXFAIL, MXITER, MXRDSV, MXTRY, N, NDE, NDJSTP, - 8 NFAIL, NFE, NJE, NQ, NQUSED, NSTEP, NSV, NTRY, NWAIT - DOUBLE PRECISION A(MATDIM,*), AVGH, AVGORD, BIAS1, BIAS2, BIAS3, - 8 BND, CTEST, D, DENOM, DFDY(MATDIM,*), D1, EL(13,12), EPS, - 8 ERDN, ERUP, ETEST, FAC(*), H, HMAX, HN, HOLD, HS, HUSED, - 8 NUMER, RC, RCTEST, RH, RH1, RH2, RH3, RMAX, RMFAIL, RMNORM, - 8 SAVE1(*), SAVE2(*), DNRM2, T, TOLD, TQ(3,12), TREND, TRSHLD, - 8 UROUND, Y(*), YH(N,*), YWT(*), Y0NRM - LOGICAL CONVRG, EVALFA, EVALJC, IER, SWITCH - PARAMETER(BIAS1 = 1.3D0, BIAS2 = 1.2D0, BIAS3 = 1.4D0, MXFAIL = 3, - 8 MXITER = 3, MXTRY = 50, RCTEST = .3D0, RMFAIL = 2.D0, - 8 RMNORM = 10.D0, TRSHLD = 1.D0) - PARAMETER (NDJSTP = 10) - DATA IER /.FALSE./ -C***FIRST EXECUTABLE STATEMENT DDSTP - NSV = N - BND = 0.D0 - SWITCH = .FALSE. - NTRY = 0 - TOLD = T - NFAIL = 0 - IF (JTASK .LE. 0) THEN - CALL DDNTL (EPS, F, FA, HMAX, HOLD, IMPL, JTASK, MATDIM, - 8 MAXORD, MINT, MITER, ML, MU, N, NDE, SAVE1, T, - 8 UROUND, USERS, Y, YWT, H, MNTOLD, MTROLD, NFE, RC, - 8 YH, A, CONVRG, EL, FAC, IER, IPVT, NQ, NWAIT, RH, - 8 RMAX, SAVE2, TQ, TREND, ISWFLG, JSTATE) - IF (N .EQ. 0) GO TO 440 - IF (H .EQ. 0.D0) GO TO 400 - IF (IER) GO TO 420 - END IF - 100 NTRY = NTRY + 1 - IF (NTRY .GT. MXTRY) GO TO 410 - T = T + H - CALL DDPSC (1, N, NQ, YH) - EVALJC = (((ABS(RC - 1.D0) .GT. RCTEST) .OR. - 8 (NSTEP .GE. JSTEPL + NDJSTP)) .AND. (MITER .NE. 0)) - EVALFA = .NOT. EVALJC -C - 110 ITER = 0 - DO 115 I = 1,N - 115 Y(I) = YH(I,1) - CALL F (N, T, Y, SAVE2) - IF (N .EQ. 0) THEN - JSTATE = 6 - GO TO 430 - END IF - NFE = NFE + 1 - IF (EVALJC .OR. IER) THEN - CALL DDPST (EL, F, FA, H, IMPL, JACOBN, MATDIM, MITER, ML, - 8 MU, N, NDE, NQ, SAVE2, T, USERS, Y, YH, YWT, UROUND, - 8 NFE, NJE, A, DFDY, FAC, IER, IPVT, SAVE1, ISWFLG, - 8 BND, JSTATE) - IF (N .EQ. 0) GO TO 430 - IF (IER) GO TO 160 - CONVRG = .FALSE. - RC = 1.D0 - JSTEPL = NSTEP - END IF - DO 125 I = 1,N - 125 SAVE1(I) = 0.D0 -C Up to MXITER corrector iterations are taken. -C Convergence is tested by requiring the r.m.s. -C norm of changes to be less than EPS. The sum of -C the corrections is accumulated in the vector -C SAVE1(I). It is approximately equal to the L-th -C derivative of Y multiplied by -C H**L/(factorial(L-1)*EL(L,NQ)), and is thus -C proportional to the actual errors to the lowest -C power of H present (H**L). The YH array is not -C altered in the correction loop. The norm of the -C iterate difference is stored in D. If -C ITER .GT. 0, an estimate of the convergence rate -C constant is stored in TREND, and this is used in -C the convergence test. -C - 130 CALL DDCOR (DFDY, EL, FA, H, IERROR, IMPL, IPVT, MATDIM, MITER, - 8 ML, MU, N, NDE, NQ, T, USERS, Y, YH, YWT, EVALFA, - 8 SAVE1, SAVE2, A, D, JSTATE) - IF (N .EQ. 0) GO TO 430 - IF (ISWFLG .EQ. 3 .AND. MINT .EQ. 1) THEN - IF (ITER .EQ. 0) THEN - NUMER = DNRM2(N, SAVE1, 1) - DO 132 I = 1,N - 132 DFDY(1,I) = SAVE1(I) - Y0NRM = DNRM2(N, YH, 1) - ELSE - DENOM = NUMER - DO 134 I = 1,N - 134 DFDY(1,I) = SAVE1(I) - DFDY(1,I) - NUMER = DNRM2(N, DFDY, MATDIM) - IF (EL(1,NQ)*NUMER .LE. 100.D0*UROUND*Y0NRM) THEN - IF (RMAX .EQ. RMFAIL) THEN - SWITCH = .TRUE. - GO TO 170 - END IF - END IF - DO 136 I = 1,N - 136 DFDY(1,I) = SAVE1(I) - IF (DENOM .NE. 0.D0) - 8 BND = MAX(BND, NUMER/(DENOM*ABS(H)*EL(1,NQ))) - END IF - END IF - IF (ITER .GT. 0) TREND = MAX(.9D0*TREND, D/D1) - D1 = D - CTEST = MIN(2.D0*TREND, 1.D0)*D - IF (CTEST .LE. EPS) GO TO 170 - ITER = ITER + 1 - IF (ITER .LT. MXITER) THEN - DO 140 I = 1,N - 140 Y(I) = YH(I,1) + EL(1,NQ)*SAVE1(I) - CALL F (N, T, Y, SAVE2) - IF (N .EQ. 0) THEN - JSTATE = 6 - GO TO 430 - END IF - NFE = NFE + 1 - GO TO 130 - END IF -C The corrector iteration failed to converge in -C MXITER tries. If partials are involved but are -C not up to date, they are reevaluated for the next -C try. Otherwise the YH array is retracted to its -C values before prediction, and H is reduced, if -C possible. If not, a no-convergence exit is taken. - IF (CONVRG) THEN - EVALJC = .TRUE. - EVALFA = .FALSE. - GO TO 110 - END IF - 160 T = TOLD - CALL DDPSC (-1, N, NQ, YH) - NWAIT = NQ + 2 - IF (JTASK .NE. 0 .AND. JTASK .NE. 2) RMAX = RMFAIL - IF (ITER .EQ. 0) THEN - RH = .3D0 - ELSE - RH = .9D0*(EPS/CTEST)**(.2D0) - END IF - IF (RH*H .EQ. 0.D0) GO TO 400 - CALL DDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) - GO TO 100 -C The corrector has converged. CONVRG is set -C to .TRUE. if partial derivatives were used, -C to indicate that they may need updating on -C subsequent steps. The error test is made. - 170 CONVRG = (MITER .NE. 0) - IF (IERROR .EQ. 1 .OR. IERROR .EQ. 5) THEN - DO 180 I = 1,NDE - 180 SAVE2(I) = SAVE1(I)/YWT(I) - ELSE - DO 185 I = 1,NDE - 185 SAVE2(I) = SAVE1(I)/MAX(ABS(Y(I)), YWT(I)) - END IF - ETEST = DNRM2(NDE, SAVE2, 1)/(TQ(2,NQ)*SQRT(DBLE(NDE))) -C -C The error test failed. NFAIL keeps track of -C multiple failures. Restore T and the YH -C array to their previous values, and prepare -C to try the step again. Compute the optimum -C step size for this or one lower order. - IF (ETEST .GT. EPS) THEN - T = TOLD - CALL DDPSC (-1, N, NQ, YH) - NFAIL = NFAIL + 1 - IF (NFAIL .LT. MXFAIL .OR. NQ .EQ. 1) THEN - IF (JTASK .NE. 0 .AND. JTASK .NE. 2) RMAX = RMFAIL - RH2 = 1.D0/(BIAS2*(ETEST/EPS)**(1.D0/(NQ+1))) - IF (NQ .GT. 1) THEN - IF (IERROR .EQ. 1 .OR. IERROR .EQ. 5) THEN - DO 190 I = 1,NDE - 190 SAVE2(I) = YH(I,NQ+1)/YWT(I) - ELSE - DO 195 I = 1,NDE - 195 SAVE2(I) = YH(I,NQ+1)/MAX(ABS(Y(I)), YWT(I)) - END IF - ERDN = DNRM2(NDE, SAVE2, 1)/(TQ(1,NQ)*SQRT(DBLE(NDE))) - RH1 = 1.D0/MAX(1.D0, BIAS1*(ERDN/EPS)**(1.D0/NQ)) - IF (RH2 .LT. RH1) THEN - NQ = NQ - 1 - RC = RC*EL(1,NQ)/EL(1,NQ+1) - RH = RH1 - ELSE - RH = RH2 - END IF - ELSE - RH = RH2 - END IF - NWAIT = NQ + 2 - IF (RH*H .EQ. 0.D0) GO TO 400 - CALL DDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) - GO TO 100 - END IF -C Control reaches this section if the error test has -C failed MXFAIL or more times. It is assumed that the -C derivatives that have accumulated in the YH array have -C errors of the wrong order. Hence the first derivative -C is recomputed, the order is set to 1, and the step is -C retried. - NFAIL = 0 - JTASK = 2 - DO 215 I = 1,N - 215 Y(I) = YH(I,1) - CALL DDNTL (EPS, F, FA, HMAX, HOLD, IMPL, JTASK, MATDIM, - 8 MAXORD, MINT, MITER, ML, MU, N, NDE, SAVE1, T, - 8 UROUND, USERS, Y, YWT, H, MNTOLD, MTROLD, NFE, RC, - 8 YH, A, CONVRG, EL, FAC, IER, IPVT, NQ, NWAIT, RH, - 8 RMAX, SAVE2, TQ, TREND, ISWFLG, JSTATE) - RMAX = RMNORM - IF (N .EQ. 0) GO TO 440 - IF (H .EQ. 0.D0) GO TO 400 - IF (IER) GO TO 420 - GO TO 100 - END IF -C After a successful step, update the YH array. - NSTEP = NSTEP + 1 - HUSED = H - NQUSED = NQ - AVGH = ((NSTEP-1)*AVGH + H)/NSTEP - AVGORD = ((NSTEP-1)*AVGORD + NQ)/NSTEP - DO 230 J = 1,NQ+1 - DO 230 I = 1,N - 230 YH(I,J) = YH(I,J) + EL(J,NQ)*SAVE1(I) - DO 235 I = 1,N - 235 Y(I) = YH(I,1) -C If ISWFLG is 3, consider -C changing integration methods. - IF (ISWFLG .EQ. 3) THEN - IF (BND .NE. 0.D0) THEN - IF (MINT .EQ. 1 .AND. NQ .LE. 5) THEN - HN = ABS(H)/MAX(UROUND, (ETEST/EPS)**(1.D0/(NQ+1))) - HN = MIN(HN, 1.D0/(2.D0*EL(1,NQ)*BND)) - HS = ABS(H)/MAX(UROUND, - 8 (ETEST/(EPS*EL(NQ+1,1)))**(1.D0/(NQ+1))) - IF (HS .GT. 1.2D0*HN) THEN - MINT = 2 - MNTOLD = MINT - MITER = MTRSV - MTROLD = MITER - MAXORD = MIN(MXRDSV, 5) - RC = 0.D0 - RMAX = RMNORM - TREND = 1.D0 - CALL DDCST (MAXORD, MINT, ISWFLG, EL, TQ) - NWAIT = NQ + 2 - END IF - ELSE IF (MINT .EQ. 2) THEN - HS = ABS(H)/MAX(UROUND, (ETEST/EPS)**(1.D0/(NQ+1))) - HN = ABS(H)/MAX(UROUND, - 8 (ETEST*EL(NQ+1,1)/EPS)**(1.D0/(NQ+1))) - HN = MIN(HN, 1.D0/(2.D0*EL(1,NQ)*BND)) - IF (HN .GE. HS) THEN - MINT = 1 - MNTOLD = MINT - MITER = 0 - MTROLD = MITER - MAXORD = MIN(MXRDSV, 12) - RMAX = RMNORM - TREND = 1.D0 - CONVRG = .FALSE. - CALL DDCST (MAXORD, MINT, ISWFLG, EL, TQ) - NWAIT = NQ + 2 - END IF - END IF - END IF - END IF - IF (SWITCH) THEN - MINT = 2 - MNTOLD = MINT - MITER = MTRSV - MTROLD = MITER - MAXORD = MIN(MXRDSV, 5) - NQ = MIN(NQ, MAXORD) - RC = 0.D0 - RMAX = RMNORM - TREND = 1.D0 - CALL DDCST (MAXORD, MINT, ISWFLG, EL, TQ) - NWAIT = NQ + 2 - END IF -C Consider changing H if NWAIT = 1. Otherwise -C decrease NWAIT by 1. If NWAIT is then 1 and -C NQ.LT.MAXORD, then SAVE1 is saved for use in -C a possible order increase on the next step. -C - IF (JTASK .EQ. 0 .OR. JTASK .EQ. 2) THEN - RH = 1.D0/MAX(UROUND, BIAS2*(ETEST/EPS)**(1.D0/(NQ+1))) - IF (RH.GT.TRSHLD) CALL DDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) - ELSE IF (NWAIT .GT. 1) THEN - NWAIT = NWAIT - 1 - IF (NWAIT .EQ. 1 .AND. NQ .LT. MAXORD) THEN - DO 250 I = 1,NDE - 250 YH(I,MAXORD+1) = SAVE1(I) - END IF -C If a change in H is considered, an increase or decrease in -C order by one is considered also. A change in H is made -C only if it is by a factor of at least TRSHLD. Factors -C RH1, RH2, and RH3 are computed, by which H could be -C multiplied at order NQ - 1, order NQ, or order NQ + 1, -C respectively. The largest of these is determined and the -C new order chosen accordingly. If the order is to be -C increased, we compute one additional scaled derivative. -C If there is a change of order, reset NQ and the -C coefficients. In any case H is reset according to RH and -C the YH array is rescaled. - ELSE - IF (NQ .EQ. 1) THEN - RH1 = 0.D0 - ELSE - IF (IERROR .EQ. 1 .OR. IERROR .EQ. 5) THEN - DO 270 I = 1,NDE - 270 SAVE2(I) = YH(I,NQ+1)/YWT(I) - ELSE - DO 275 I = 1,NDE - 275 SAVE2(I) = YH(I,NQ+1)/MAX(ABS(Y(I)), YWT(I)) - END IF - ERDN = DNRM2(NDE, SAVE2, 1)/(TQ(1,NQ)*SQRT(DBLE(NDE))) - RH1 = 1.D0/MAX(UROUND, BIAS1*(ERDN/EPS)**(1.D0/NQ)) - END IF - RH2 = 1.D0/MAX(UROUND, BIAS2*(ETEST/EPS)**(1.D0/(NQ+1))) - IF (NQ .EQ. MAXORD) THEN - RH3 = 0.D0 - ELSE - IF (IERROR .EQ. 1 .OR. IERROR .EQ. 5) THEN - DO 290 I = 1,NDE - 290 SAVE2(I) = (SAVE1(I) - YH(I,MAXORD+1))/YWT(I) - ELSE - DO 295 I = 1,NDE - SAVE2(I) = (SAVE1(I) - YH(I,MAXORD+1))/ - 8 MAX(ABS(Y(I)), YWT(I)) - 295 CONTINUE - END IF - ERUP = DNRM2(NDE, SAVE2, 1)/(TQ(3,NQ)*SQRT(DBLE(NDE))) - RH3 = 1.D0/MAX(UROUND, BIAS3*(ERUP/EPS)**(1.D0/(NQ+2))) - END IF - IF (RH1 .GT. RH2 .AND. RH1 .GE. RH3) THEN - RH = RH1 - IF (RH .LE. TRSHLD) GO TO 380 - NQ = NQ - 1 - RC = RC*EL(1,NQ)/EL(1,NQ+1) - ELSE IF (RH2 .GE. RH1 .AND. RH2 .GE. RH3) THEN - RH = RH2 - IF (RH .LE. TRSHLD) GO TO 380 - ELSE - RH = RH3 - IF (RH .LE. TRSHLD) GO TO 380 - DO 360 I = 1,N - 360 YH(I,NQ+2) = SAVE1(I)*EL(NQ+1,NQ)/(NQ+1) - NQ = NQ + 1 - RC = RC*EL(1,NQ)/EL(1,NQ-1) - END IF - IF (ISWFLG .EQ. 3 .AND. MINT .EQ. 1) THEN - IF (BND.NE.0.D0) RH = MIN(RH, 1.D0/(2.D0*EL(1,NQ)*BND*ABS(H))) - END IF - CALL DDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) - RMAX = RMNORM - 380 NWAIT = NQ + 2 - END IF -C All returns are made through this section. H is saved -C in HOLD to allow the caller to change H on the next step - JSTATE = 1 - HOLD = H - RETURN -C - 400 JSTATE = 2 - HOLD = H - DO 405 I = 1,N - 405 Y(I) = YH(I,1) - RETURN -C - 410 JSTATE = 3 - HOLD = H - RETURN -C - 420 JSTATE = 4 - HOLD = H - RETURN -C - 430 T = TOLD - CALL DDPSC (-1, NSV, NQ, YH) - DO 435 I = 1,NSV - 435 Y(I) = YH(I,1) - 440 HOLD = H - RETURN - END diff --git a/slatec/ddzro.f b/slatec/ddzro.f deleted file mode 100644 index 7f3bd3b..0000000 --- a/slatec/ddzro.f +++ /dev/null @@ -1,134 +0,0 @@ -*DECK DDZRO - SUBROUTINE DDZRO (AE, F, H, N, NQ, IROOT, RE, T, YH, UROUND, B, C, - 8 FB, FC, Y) -C***BEGIN PROLOGUE DDZRO -C***SUBSIDIARY -C***PURPOSE DDZRO searches for a zero of a function F(N, T, Y, IROOT) -C between the given values B and C until the width of the -C interval (B, C) has collapsed to within a tolerance -C specified by the stopping criterion, -C ABS(B - C) .LE. 2.*(RW*ABS(B) + AE). -C***LIBRARY SLATEC (SDRIVE) -C***TYPE DOUBLE PRECISION (SDZRO-S, DDZRO-D, CDZRO-C) -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***DESCRIPTION -C -C This is a special purpose version of ZEROIN, modified for use with -C the DDRIV package. -C -C Sandia Mathematical Program Library -C Mathematical Computing Services Division 5422 -C Sandia Laboratories -C P. O. Box 5800 -C Albuquerque, New Mexico 87115 -C Control Data 6600 Version 4.5, 1 November 1971 -C -C PARAMETERS -C F - Name of the external function, which returns a -C double precision result. This name must be in an -C EXTERNAL statement in the calling program. -C B - One end of the interval (B, C). The value returned for -C B usually is the better approximation to a zero of F. -C C - The other end of the interval (B, C). -C RE - Relative error used for RW in the stopping criterion. -C If the requested RE is less than machine precision, -C then RW is set to approximately machine precision. -C AE - Absolute error used in the stopping criterion. If the -C given interval (B, C) contains the origin, then a -C nonzero value should be chosen for AE. -C -C***REFERENCES L. F. Shampine and H. A. Watts, ZEROIN, a root-solving -C routine, SC-TM-70-631, Sept 1970. -C T. J. Dekker, Finding a zero by means of successive -C linear interpolation, Constructive Aspects of the -C Fundamental Theorem of Algebra, edited by B. Dejon -C and P. Henrici, 1969. -C***ROUTINES CALLED DDNTP -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE DDZRO - INTEGER IC, IROOT, KOUNT, N, NQ - DOUBLE PRECISION A, ACBS, ACMB, AE, B, C, CMB, ER, F, FA, FB, FC, - 8 H, P, Q, RE, RW, T, TOL, UROUND, Y(*), YH(N,*) -C***FIRST EXECUTABLE STATEMENT DDZRO - ER = 4.D0*UROUND - RW = MAX(RE, ER) - IC = 0 - ACBS = ABS(B - C) - A = C - FA = FC - KOUNT = 0 -C Perform interchange - 10 IF (ABS(FC) .LT. ABS(FB)) THEN - A = B - FA = FB - B = C - FB = FC - C = A - FC = FA - END IF - CMB = 0.5D0*(C - B) - ACMB = ABS(CMB) - TOL = RW*ABS(B) + AE -C Test stopping criterion - IF (ACMB .LE. TOL) RETURN - IF (KOUNT .GT. 50) RETURN -C Calculate new iterate implicitly as -C B + P/Q, where we arrange P .GE. 0. -C The implicit form is used to prevent overflow. - P = (B - A)*FB - Q = FA - FB - IF (P .LT. 0.D0) THEN - P = -P - Q = -Q - END IF -C Update A and check for satisfactory reduction -C in the size of our bounding interval. - A = B - FA = FB - IC = IC + 1 - IF (IC .GE. 4) THEN - IF (8.D0*ACMB .GE. ACBS) THEN -C Bisect - B = 0.5D0*(C + B) - GO TO 20 - END IF - IC = 0 - END IF - ACBS = ACMB -C Test for too small a change - IF (P .LE. ABS(Q)*TOL) THEN -C Increment by tolerance - B = B + SIGN(TOL, CMB) -C Root ought to be between -C B and (C + B)/2. - ELSE IF (P .LT. CMB*Q) THEN -C Interpolate - B = B + P/Q - ELSE -C Bisect - B = 0.5D0*(C + B) - END IF -C Have completed computation -C for new iterate B. - 20 CALL DDNTP (H, 0, N, NQ, T, B, YH, Y) - FB = F(N, B, Y, IROOT) - IF (N .EQ. 0) RETURN - IF (FB .EQ. 0.D0) RETURN - KOUNT = KOUNT + 1 -C -C Decide whether next step is interpolation or extrapolation -C - IF (SIGN(1.0D0, FB) .EQ. SIGN(1.0D0, FC)) THEN - C = A - FC = FA - END IF - GO TO 10 - END diff --git a/slatec/de1.f b/slatec/de1.f deleted file mode 100644 index b7ca77e..0000000 --- a/slatec/de1.f +++ /dev/null @@ -1,459 +0,0 @@ -*DECK DE1 - DOUBLE PRECISION FUNCTION DE1 (X) -C***BEGIN PROLOGUE DE1 -C***PURPOSE Compute the exponential integral E1(X). -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C5 -C***TYPE DOUBLE PRECISION (E1-S, DE1-D) -C***KEYWORDS E1 FUNCTION, EXPONENTIAL INTEGRAL, FNLIB, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DE1 calculates the double precision exponential integral, E1(X), for -C positive double precision argument X and the Cauchy principal value -C for negative X. If principal values are used everywhere, then, for -C all X, -C -C E1(X) = -Ei(-X) -C or -C Ei(X) = -E1(-X). -C -C -C Series for AE10 on the interval -3.12500E-02 to 0. -C with weighted error 4.62E-32 -C log weighted error 31.34 -C significant figures required 29.70 -C decimal places required 32.18 -C -C -C Series for AE11 on the interval -1.25000E-01 to -3.12500E-02 -C with weighted error 2.22E-32 -C log weighted error 31.65 -C significant figures required 30.75 -C decimal places required 32.54 -C -C -C Series for AE12 on the interval -2.50000E-01 to -1.25000E-01 -C with weighted error 5.19E-32 -C log weighted error 31.28 -C significant figures required 30.82 -C decimal places required 32.09 -C -C -C Series for E11 on the interval -4.00000E+00 to -1.00000E+00 -C with weighted error 8.49E-34 -C log weighted error 33.07 -C significant figures required 34.13 -C decimal places required 33.80 -C -C -C Series for E12 on the interval -1.00000E+00 to 1.00000E+00 -C with weighted error 8.08E-33 -C log weighted error 32.09 -C approx significant figures required 30.4 -C decimal places required 32.79 -C -C -C Series for AE13 on the interval 2.50000E-01 to 1.00000E+00 -C with weighted error 6.65E-32 -C log weighted error 31.18 -C significant figures required 30.69 -C decimal places required 32.03 -C -C -C Series for AE14 on the interval 0. to 2.50000E-01 -C with weighted error 5.07E-32 -C log weighted error 31.30 -C significant figures required 30.40 -C decimal places required 32.20 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891115 Modified prologue description. (WRB) -C 891115 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 920618 Removed space from variable names. (RWC, WRB) -C***END PROLOGUE DE1 - DOUBLE PRECISION X, AE10CS(50), AE11CS(60), AE12CS(41), E11CS(29), - 1 E12CS(25), AE13CS(50), AE14CS(64), XMAX, XMAXT, D1MACH, DCSEVL - LOGICAL FIRST - SAVE AE10CS, AE11CS, AE12CS, E11CS, E12CS, AE13CS, AE14CS, - 1 NTAE10, NTAE11, NTAE12, NTE11, NTE12, NTAE13, NTAE14, XMAX, - 2 FIRST - DATA AE10CS( 1) / +.3284394579 6166990878 7384420188 1 D-1 / - DATA AE10CS( 2) / -.1669920452 0313628514 7618434338 7 D-1 / - DATA AE10CS( 3) / +.2845284724 3613468074 2489985325 2 D-3 / - DATA AE10CS( 4) / -.7563944358 5162064894 8786693853 3 D-5 / - DATA AE10CS( 5) / +.2798971289 4508591575 0484318087 9 D-6 / - DATA AE10CS( 6) / -.1357901828 5345310695 2556392625 5 D-7 / - DATA AE10CS( 7) / +.8343596202 0404692558 5610290490 6 D-9 / - DATA AE10CS( 8) / -.6370971727 6402484382 7524298853 2 D-10 / - DATA AE10CS( 9) / +.6007247608 8118612357 6083156158 4 D-11 / - DATA AE10CS( 10) / -.7022876174 6797735907 5062615008 8 D-12 / - DATA AE10CS( 11) / +.1018302673 7036876930 9665234688 3 D-12 / - DATA AE10CS( 12) / -.1761812903 4308800404 0630996642 2 D-13 / - DATA AE10CS( 13) / +.3250828614 2353606942 4403035387 7 D-14 / - DATA AE10CS( 14) / -.5071770025 5058186788 2487225904 4 D-15 / - DATA AE10CS( 15) / +.1665177387 0432942981 7248608415 6 D-16 / - DATA AE10CS( 16) / +.3166753890 7975144006 7700353655 5 D-16 / - DATA AE10CS( 17) / -.1588403763 6641415151 3311834353 8 D-16 / - DATA AE10CS( 18) / +.4175513256 1380188330 0303461848 4 D-17 / - DATA AE10CS( 19) / -.2892347749 7071419067 1071447885 2 D-18 / - DATA AE10CS( 20) / -.2800625903 3966081035 0634058966 9 D-18 / - DATA AE10CS( 21) / +.1322938639 5392709037 0758002378 1 D-18 / - DATA AE10CS( 22) / -.1804447444 1773016272 8388783355 7 D-19 / - DATA AE10CS( 23) / -.7905384086 5226160762 9164481760 4 D-20 / - DATA AE10CS( 24) / +.4435711366 3695701039 4623583802 7 D-20 / - DATA AE10CS( 25) / -.4264103994 9781208688 6530920655 5 D-21 / - DATA AE10CS( 26) / -.3920101766 9371175415 5371316204 8 D-21 / - DATA AE10CS( 27) / +.1527378051 3439942663 4375232697 1 D-21 / - DATA AE10CS( 28) / +.1024849527 0493723393 1030878311 7 D-22 / - DATA AE10CS( 29) / -.2134907874 7714335762 6271140588 2 D-22 / - DATA AE10CS( 30) / +.3239139475 1600282670 6169470036 6 D-23 / - DATA AE10CS( 31) / +.2142183762 2998899547 6264316829 6 D-23 / - DATA AE10CS( 32) / -.8234609419 6010184147 0034808231 2 D-24 / - DATA AE10CS( 33) / -.1524652829 6458094796 1369440114 0 D-24 / - DATA AE10CS( 34) / +.1378208282 4606391346 6848036432 5 D-24 / - DATA AE10CS( 35) / +.2131311202 8339478795 2322499925 3 D-26 / - DATA AE10CS( 36) / -.2012649651 5264841218 1746676312 7 D-25 / - DATA AE10CS( 37) / +.1995535662 2633580161 0631178267 3 D-26 / - DATA AE10CS( 38) / +.2798995808 9840034649 4868652031 9 D-26 / - DATA AE10CS( 39) / -.5534511845 3896266376 4081927782 3 D-27 / - DATA AE10CS( 40) / -.3884995396 1599688616 8254402614 6 D-27 / - DATA AE10CS( 41) / +.1121304434 5073593828 5068035467 9 D-27 / - DATA AE10CS( 42) / +.5566568152 4237409482 5656383351 4 D-28 / - DATA AE10CS( 43) / -.2045482929 8104997004 4853393817 6 D-28 / - DATA AE10CS( 44) / -.8453813992 7123362334 1145749367 4 D-29 / - DATA AE10CS( 45) / +.3565758433 4312915628 1611111628 7 D-29 / - DATA AE10CS( 46) / +.1383653872 1256347055 3994909887 1 D-29 / - DATA AE10CS( 47) / -.6062167864 4513724365 8453376477 8 D-30 / - DATA AE10CS( 48) / -.2447198043 9893132674 3765511918 9 D-30 / - DATA AE10CS( 49) / +.1006850640 9339983480 1154818048 0 D-30 / - DATA AE10CS( 50) / +.4623685555 0148690156 6434146167 4 D-31 / - DATA AE11CS( 1) / +.2026315064 7078889499 4012365173 81 D+0 / - DATA AE11CS( 2) / -.7365514099 1203130439 5368987280 34 D-1 / - DATA AE11CS( 3) / +.6390934911 8361915862 7532838400 20 D-2 / - DATA AE11CS( 4) / -.6079725270 5247911780 6531533639 99 D-3 / - DATA AE11CS( 5) / -.7370649862 0176629330 6814114934 84 D-4 / - DATA AE11CS( 6) / +.4873285744 9450183453 4649924880 76 D-4 / - DATA AE11CS( 7) / -.2383706484 0448290766 5884894602 35 D-5 / - DATA AE11CS( 8) / -.3051861262 8561521027 0273322461 21 D-5 / - DATA AE11CS( 9) / +.1705033157 2564559009 6880329929 07 D-6 / - DATA AE11CS( 10) / +.2383420452 7487747258 6015981364 03 D-6 / - DATA AE11CS( 11) / +.1078177255 6163166562 5968723640 20 D-7 / - DATA AE11CS( 12) / -.1795569284 7399102653 6426914465 99 D-7 / - DATA AE11CS( 13) / -.4128407234 1950457727 9123946404 36 D-8 / - DATA AE11CS( 14) / +.6862214858 8631968618 3468445266 64 D-9 / - DATA AE11CS( 15) / +.5313018312 0506356147 6020096759 61 D-9 / - DATA AE11CS( 16) / +.7879688026 1490694831 3050228935 15 D-10 / - DATA AE11CS( 17) / -.2626176232 9356522290 3416752712 32 D-10 / - DATA AE11CS( 18) / -.1548368763 6308261963 1257562941 00 D-10 / - DATA AE11CS( 19) / -.2581896237 7261390492 8024051225 91 D-11 / - DATA AE11CS( 20) / +.5954287919 1591072658 9035299593 52 D-12 / - DATA AE11CS( 21) / +.4645140038 7681525833 7849193214 05 D-12 / - DATA AE11CS( 22) / +.1155785502 3255861496 2880062037 31 D-12 / - DATA AE11CS( 23) / -.1047523687 0835799012 3175471896 70 D-14 / - DATA AE11CS( 24) / -.1189665350 2709004368 1044892609 29 D-13 / - DATA AE11CS( 25) / -.4774907749 0261778752 6430193499 50 D-14 / - DATA AE11CS( 26) / -.8107764961 5772777976 2497347541 35 D-15 / - DATA AE11CS( 27) / +.1343556925 0031554199 3769879981 78 D-15 / - DATA AE11CS( 28) / +.1413453002 2913106260 2488738812 87 D-15 / - DATA AE11CS( 29) / +.4945159257 3953173115 5206632328 83 D-16 / - DATA AE11CS( 30) / +.7988404848 0080665648 8585873993 67 D-17 / - DATA AE11CS( 31) / -.1400863218 8089809829 2487119353 93 D-17 / - DATA AE11CS( 32) / -.1481424695 8417372107 7228040016 80 D-17 / - DATA AE11CS( 33) / -.5582617364 6025601904 0106939371 13 D-18 / - DATA AE11CS( 34) / -.1144207454 2191647264 7830725445 98 D-18 / - DATA AE11CS( 35) / +.2537182387 9566853500 5240184799 23 D-20 / - DATA AE11CS( 36) / +.1320532815 4805359813 2788633890 97 D-19 / - DATA AE11CS( 37) / +.6293026108 1586809166 2874267894 85 D-20 / - DATA AE11CS( 38) / +.1768827042 4882713734 9992613325 48 D-20 / - DATA AE11CS( 39) / +.2326618798 5146045209 6742968874 32 D-21 / - DATA AE11CS( 40) / -.6780306081 1125233043 7738318441 13 D-22 / - DATA AE11CS( 41) / -.5944087695 9676373802 8741505318 91 D-22 / - DATA AE11CS( 42) / -.2361821453 1184415968 5325925034 66 D-22 / - DATA AE11CS( 43) / -.6021449972 4601478214 1684787445 76 D-23 / - DATA AE11CS( 44) / -.6551790647 4348299071 3704441446 39 D-24 / - DATA AE11CS( 45) / +.2938875529 7497724587 0420386993 49 D-24 / - DATA AE11CS( 46) / +.2260160620 0642115173 2157287585 10 D-24 / - DATA AE11CS( 47) / +.8953436924 5958628745 0912068730 87 D-25 / - DATA AE11CS( 48) / +.2401592347 1098457555 7720674577 06 D-25 / - DATA AE11CS( 49) / +.3411837688 8907172955 6664230434 13 D-26 / - DATA AE11CS( 50) / -.7161707169 4630342052 3550133452 79 D-27 / - DATA AE11CS( 51) / -.7562039065 9281725157 9286519807 99 D-27 / - DATA AE11CS( 52) / -.3377461215 7467324637 9529207808 00 D-27 / - DATA AE11CS( 53) / -.1047932570 3300941711 5264303322 45 D-27 / - DATA AE11CS( 54) / -.2165455025 2170342240 8548802013 86 D-28 / - DATA AE11CS( 55) / -.7529712574 5288269994 6892984320 00 D-30 / - DATA AE11CS( 56) / +.1910317939 2798935768 6380840004 26 D-29 / - DATA AE11CS( 57) / +.1149210496 6530338547 7907288337 06 D-29 / - DATA AE11CS( 58) / +.4389697058 2661751514 4103591936 00 D-30 / - DATA AE11CS( 59) / +.1232088323 9205686471 6471577258 66 D-30 / - DATA AE11CS( 60) / +.2222017445 7553175317 5385811626 66 D-31 / - DATA AE12CS( 1) / +.6362958979 6747038767 1298878068 03 D+0 / - DATA AE12CS( 2) / -.1308116867 5067634385 8126711211 35 D+0 / - DATA AE12CS( 3) / -.8436741021 3053930014 4876621297 52 D-2 / - DATA AE12CS( 4) / +.2656849153 1006685413 0294280689 06 D-2 / - DATA AE12CS( 5) / +.3282272178 1658133778 7921701425 17 D-3 / - DATA AE12CS( 6) / -.2378344777 1430248269 5798078510 50 D-4 / - DATA AE12CS( 7) / -.1143980430 8100055514 4470767970 47 D-4 / - DATA AE12CS( 8) / -.1440594343 3238338455 2397176993 23 D-5 / - DATA AE12CS( 9) / +.5241595665 1148829963 7728180616 64 D-8 / - DATA AE12CS( 10) / +.3840730640 7844323480 9792030597 16 D-7 / - DATA AE12CS( 11) / +.8588024486 0267195879 6605157593 44 D-8 / - DATA AE12CS( 12) / +.1021922662 5855003286 3399695539 11 D-8 / - DATA AE12CS( 13) / +.2174913232 3289724542 8213398059 92 D-10 / - DATA AE12CS( 14) / -.2209023814 2623144809 5235038117 41 D-10 / - DATA AE12CS( 15) / -.6345753354 4928753294 3836222088 01 D-11 / - DATA AE12CS( 16) / -.1083774656 6857661115 3405397329 19 D-11 / - DATA AE12CS( 17) / -.1190982287 2222586730 2622004402 77 D-12 / - DATA AE12CS( 18) / -.2843868238 9265590299 5087660086 61 D-14 / - DATA AE12CS( 19) / +.2508032702 6686769668 5871954875 46 D-14 / - DATA AE12CS( 20) / +.7872964152 8559842431 5977264212 65 D-15 / - DATA AE12CS( 21) / +.1547506634 7785217148 4843346373 29 D-15 / - DATA AE12CS( 22) / +.2257532283 1665075055 2726081972 90 D-16 / - DATA AE12CS( 23) / +.2223335286 7266608760 2813808366 93 D-17 / - DATA AE12CS( 24) / +.1696781956 3544153513 4641946623 99 D-19 / - DATA AE12CS( 25) / -.5760831625 5947682105 3100873045 33 D-19 / - DATA AE12CS( 26) / -.1759123577 4646878055 6253694088 53 D-19 / - DATA AE12CS( 27) / -.3628605637 5103174394 7553286826 66 D-20 / - DATA AE12CS( 28) / -.5923556979 7328991652 5581434880 00 D-21 / - DATA AE12CS( 29) / -.7603038092 6310191114 4291368959 99 D-22 / - DATA AE12CS( 30) / -.6254784352 1711763842 6414284799 99 D-23 / - DATA AE12CS( 31) / +.2548336075 9307648606 0376064000 00 D-24 / - DATA AE12CS( 32) / +.2559861573 1739857020 1688746666 66 D-24 / - DATA AE12CS( 33) / +.7137623935 7899318800 2070528000 00 D-25 / - DATA AE12CS( 34) / +.1470375993 9567568181 5789568000 00 D-25 / - DATA AE12CS( 35) / +.2510552476 5386733555 1986346666 66 D-26 / - DATA AE12CS( 36) / +.3588666638 7790890886 5836373333 33 D-27 / - DATA AE12CS( 37) / +.3988603515 6771301763 3177599999 99 D-28 / - DATA AE12CS( 38) / +.2176367694 7356220478 8053333333 33 D-29 / - DATA AE12CS( 39) / -.4614699848 7618942367 6074666666 66 D-30 / - DATA AE12CS( 40) / -.2071351787 7481987707 1530666666 66 D-30 / - DATA AE12CS( 41) / -.5189037856 3534371596 9706666666 66 D-31 / - DATA E11CS( 1) / -.1611346165 5571494025 7206639275 66180 D+2 / - DATA E11CS( 2) / +.7794072778 7426802769 2722458917 41497 D+1 / - DATA E11CS( 3) / -.1955405818 8631419507 1272838128 14491 D+1 / - DATA E11CS( 4) / +.3733729386 6277945611 5171908656 90209 D+0 / - DATA E11CS( 5) / -.5692503191 0929019385 2638922200 51166 D-1 / - DATA E11CS( 6) / +.7211077769 6600918537 8477248126 35813 D-2 / - DATA E11CS( 7) / -.7810490144 9841593997 7151840890 64148 D-3 / - DATA E11CS( 8) / +.7388093356 2621681878 9748813661 77858 D-4 / - DATA E11CS( 9) / -.6202861875 8082045134 3581336079 09712 D-5 / - DATA E11CS( 10) / +.4681600230 3176735524 4058238683 62657 D-6 / - DATA E11CS( 11) / -.3209288853 3298649524 0725530272 28719 D-7 / - DATA E11CS( 12) / +.2015199748 7404533394 8262622130 19548 D-8 / - DATA E11CS( 13) / -.1167368681 6697793105 3562716950 15419 D-9 / - DATA E11CS( 14) / +.6276270667 2039943397 7887483796 15573 D-11 / - DATA E11CS( 15) / -.3148154167 2275441045 2467818023 93600 D-12 / - DATA E11CS( 16) / +.1479904174 4493474210 8944722517 33333 D-13 / - DATA E11CS( 17) / -.6545709158 3979673774 2634015880 53333 D-15 / - DATA E11CS( 18) / +.2733687222 3137291142 5080127487 99999 D-16 / - DATA E11CS( 19) / -.1081352434 9754406876 7217276245 33333 D-17 / - DATA E11CS( 20) / +.4062832804 0434303295 3003485866 66666 D-19 / - DATA E11CS( 21) / -.1453553935 8960455858 9143722666 66666 D-20 / - DATA E11CS( 22) / +.4963274618 1648636830 1984426666 66666 D-22 / - DATA E11CS( 23) / -.1620861269 6636044604 8665600000 00000 D-23 / - DATA E11CS( 24) / +.5072144803 8607422226 4319999999 99999 D-25 / - DATA E11CS( 25) / -.1523581113 3372207813 9733333333 33333 D-26 / - DATA E11CS( 26) / +.4400151125 6103618696 5333333333 33333 D-28 / - DATA E11CS( 27) / -.1223614194 5416231594 6666666666 66666 D-29 / - DATA E11CS( 28) / +.3280921666 1066001066 6666666666 66666 D-31 / - DATA E11CS( 29) / -.8493345226 8306432000 0000000000 00000 D-33 / - DATA E12CS( 1) / -.3739021479 22027951166 869820482 7 D-1 / - DATA E12CS( 2) / +.4272398606 2209577260 4917917652 8 D-1 / - DATA E12CS( 3) / -.1303182079 8497005441 5392055219 726 D+0 / - DATA E12CS( 4) / +.1441912402 4698890734 1095893982 137 D-1 / - DATA E12CS( 5) / -.1346170780 5106802211 6121527983 553 D-2 / - DATA E12CS( 6) / +.1073102925 3063779997 6115850970 073 D-3 / - DATA E12CS( 7) / -.7429999516 1194364961 0283062223 163 D-5 / - DATA E12CS( 8) / +.4537732569 0753713938 6383211511 827 D-6 / - DATA E12CS( 9) / -.2476417211 3906013184 6547423802 912 D-7 / - DATA E12CS( 10) / +.1220765813 7459095370 0228167846 102 D-8 / - DATA E12CS( 11) / -.5485141480 6409239382 1357398028 261 D-10 / - DATA E12CS( 12) / +.2263621421 3007879929 3688162377 002 D-11 / - DATA E12CS( 13) / -.8635897271 6980097940 4172916282 240 D-13 / - DATA E12CS( 14) / +.3062915536 6933299758 1032894881 279 D-14 / - DATA E12CS( 15) / -.1014857188 5594414755 7128906734 933 D-15 / - DATA E12CS( 16) / +.3154821740 3406987754 6855328426 666 D-17 / - DATA E12CS( 17) / -.9236042407 6924095448 4015923200 000 D-19 / - DATA E12CS( 18) / +.2555042679 7081400244 0435029333 333 D-20 / - DATA E12CS( 19) / -.6699128056 8456684721 7882453333 333 D-22 / - DATA E12CS( 20) / +.1669254054 3538731943 1987199999 999 D-23 / - DATA E12CS( 21) / -.3962549251 8437964185 6000000000 000 D-25 / - DATA E12CS( 22) / +.8981358965 9851133201 0666666666 666 D-27 / - DATA E12CS( 23) / -.1947633669 9301643332 2666666666 666 D-28 / - DATA E12CS( 24) / +.4048360190 2463003306 6666666666 666 D-30 / - DATA E12CS( 25) / -.8079815676 9984512000 0000000000 000 D-32 / - DATA AE13CS( 1) / -.6057732466 4060345999 3193827377 47 D+0 / - DATA AE13CS( 2) / -.1125352434 8366090030 6497688527 18 D+0 / - DATA AE13CS( 3) / +.1343226624 7902779492 4878593294 14 D-1 / - DATA AE13CS( 4) / -.1926845187 3811457249 2468389913 03 D-2 / - DATA AE13CS( 5) / +.3091183377 2060318335 5867374753 68 D-3 / - DATA AE13CS( 6) / -.5356413212 9618418776 3935597951 47 D-4 / - DATA AE13CS( 7) / +.9827812880 2474923952 4918827172 37 D-5 / - DATA AE13CS( 8) / -.1885368984 9165182826 9028919389 10 D-5 / - DATA AE13CS( 9) / +.3749431935 6894735406 9640421905 31 D-6 / - DATA AE13CS( 10) / -.7682345587 0552639273 7334656805 56 D-7 / - DATA AE13CS( 11) / +.1614327056 7198777552 9563000608 68 D-7 / - DATA AE13CS( 12) / -.3466802211 4907354566 3090602260 27 D-8 / - DATA AE13CS( 13) / +.7587542091 9036277572 8897470541 14 D-9 / - DATA AE13CS( 14) / -.1688643332 9881412573 5145266367 03 D-9 / - DATA AE13CS( 15) / +.3814570674 9552265682 8042509272 72 D-10 / - DATA AE13CS( 16) / -.8733026632 4446292706 8517182723 34 D-11 / - DATA AE13CS( 17) / +.2023672864 5867960961 7943110643 30 D-11 / - DATA AE13CS( 18) / -.4741328303 9555834655 2103408201 60 D-12 / - DATA AE13CS( 19) / +.1122117204 8389864324 7317999289 20 D-12 / - DATA AE13CS( 20) / -.2680422543 4840309912 8268090933 95 D-13 / - DATA AE13CS( 21) / +.6457851441 7716530343 5803690672 12 D-14 / - DATA AE13CS( 22) / -.1568276050 1666478830 3057028491 94 D-14 / - DATA AE13CS( 23) / +.3836786539 9315404861 8215164414 08 D-15 / - DATA AE13CS( 24) / -.9451717302 7579130478 8710489325 56 D-16 / - DATA AE13CS( 25) / +.2343481228 8949573293 8966664391 33 D-16 / - DATA AE13CS( 26) / -.5845866158 0214714576 1231944198 82 D-17 / - DATA AE13CS( 27) / +.1466622986 7947778605 8736174191 95 D-17 / - DATA AE13CS( 28) / -.3699392347 6444472706 5925382744 74 D-18 / - DATA AE13CS( 29) / +.9379015993 6721242136 0142918178 13 D-19 / - DATA AE13CS( 30) / -.2389367322 1937873136 3082240873 81 D-19 / - DATA AE13CS( 31) / +.6115062462 9497608051 9342238378 66 D-20 / - DATA AE13CS( 32) / -.1571858532 7554025507 7198532881 06 D-20 / - DATA AE13CS( 33) / +.4057238728 5585397769 5192944913 06 D-21 / - DATA AE13CS( 34) / -.1051402655 4738034990 5663671227 73 D-21 / - DATA AE13CS( 35) / +.2734966493 0638667785 8060031317 33 D-22 / - DATA AE13CS( 36) / -.7140160408 0205796099 3555742719 99 D-23 / - DATA AE13CS( 37) / +.1870555243 2235079986 7569242111 99 D-23 / - DATA AE13CS( 38) / -.4916746816 6870480520 4780209493 33 D-24 / - DATA AE13CS( 39) / +.1296498811 9684031730 9160871253 33 D-24 / - DATA AE13CS( 40) / -.3429251568 8362864461 6239404373 33 D-25 / - DATA AE13CS( 41) / +.9097224164 3887034329 1048209066 66 D-26 / - DATA AE13CS( 42) / -.2420211231 4316856489 9348479999 99 D-26 / - DATA AE13CS( 43) / +.6456361293 4639510757 6704750933 33 D-27 / - DATA AE13CS( 44) / -.1726913273 5340541122 3159876266 66 D-27 / - DATA AE13CS( 45) / +.4630861165 9151500715 1942314666 66 D-28 / - DATA AE13CS( 46) / -.1244870363 7214131241 7551701333 33 D-28 / - DATA AE13CS( 47) / +.3354457409 0520678532 9070079999 99 D-29 / - DATA AE13CS( 48) / -.9059886852 1070774437 5439359999 99 D-30 / - DATA AE13CS( 49) / +.2452414705 1474238587 2732160000 00 D-30 / - DATA AE13CS( 50) / -.6652817873 3552062817 1079679999 99 D-31 / - DATA AE14CS( 1) / -.1892918000 7530168254 9567994282 0 D+0 / - DATA AE14CS( 2) / -.8648117855 2598714899 6881705682 4 D-1 / - DATA AE14CS( 3) / +.7224101543 7465947470 2151483918 4 D-2 / - DATA AE14CS( 4) / -.8097559457 5573861971 5965561018 1 D-3 / - DATA AE14CS( 5) / +.1099913443 2661388671 7925115700 2 D-3 / - DATA AE14CS( 6) / -.1717332998 9377673714 9535881448 7 D-4 / - DATA AE14CS( 7) / +.2985627514 4792833228 2534249500 3 D-5 / - DATA AE14CS( 8) / -.5659649145 7719300565 6016726715 5 D-6 / - DATA AE14CS( 9) / +.1152680839 7141400192 2658350166 3 D-6 / - DATA AE14CS( 10) / -.2495030440 2693382288 4212876506 5 D-7 / - DATA AE14CS( 11) / +.5692324201 8337543670 3937036814 0 D-8 / - DATA AE14CS( 12) / -.1359957664 8056003384 9003093917 6 D-8 / - DATA AE14CS( 13) / +.3384662888 7608845901 8451292585 9 D-9 / - DATA AE14CS( 14) / -.8737853904 4746819523 5084931658 0 D-10 / - DATA AE14CS( 15) / +.2331588663 2226597186 1261340047 0 D-10 / - DATA AE14CS( 16) / -.6411481049 2137859697 5316519632 6 D-11 / - DATA AE14CS( 17) / +.1812246980 2048164333 8435948468 2 D-11 / - DATA AE14CS( 18) / -.5253831761 5584606888 1940384046 6 D-12 / - DATA AE14CS( 19) / +.1559218272 5919256988 5502860982 5 D-12 / - DATA AE14CS( 20) / -.4729168297 0803987184 7642936946 6 D-13 / - DATA AE14CS( 21) / +.1463761864 3932435020 7619949380 8 D-13 / - DATA AE14CS( 22) / -.4617388988 7129241022 3217362360 4 D-14 / - DATA AE14CS( 23) / +.1482710348 2893693237 8923966037 1 D-14 / - DATA AE14CS( 24) / -.4841672496 2392291469 7316573441 7 D-15 / - DATA AE14CS( 25) / +.1606215575 7002904081 1657196618 8 D-15 / - DATA AE14CS( 26) / -.5408917538 9571709478 9502378425 2 D-16 / - DATA AE14CS( 27) / +.1847470159 3468978813 7023140231 0 D-16 / - DATA AE14CS( 28) / -.6395830792 7590944705 0061042505 0 D-17 / - DATA AE14CS( 29) / +.2242780721 6997594572 5023327617 0 D-17 / - DATA AE14CS( 30) / -.7961369173 9839475527 4455530864 6 D-18 / - DATA AE14CS( 31) / +.2859308111 5401974598 0861992927 2 D-18 / - DATA AE14CS( 32) / -.1038450244 7011371459 0069713744 6 D-18 / - DATA AE14CS( 33) / +.3812040607 0979757808 6684100831 9 D-19 / - DATA AE14CS( 34) / -.1413795417 7172007687 1756272369 6 D-19 / - DATA AE14CS( 35) / +.5295367865 1827409583 0544259481 5 D-20 / - DATA AE14CS( 36) / -.2002264245 0268259021 3721113143 9 D-20 / - DATA AE14CS( 37) / +.7640262751 2751960147 3684861091 8 D-21 / - DATA AE14CS( 38) / -.2941119006 8687878833 1126352336 2 D-21 / - DATA AE14CS( 39) / +.1141823539 0789271930 3769148358 6 D-21 / - DATA AE14CS( 40) / -.4469308475 9552984252 4702071848 9 D-22 / - DATA AE14CS( 41) / +.1763262410 5717507706 3049140852 0 D-22 / - DATA AE14CS( 42) / -.7009968187 9259023563 5151826234 0 D-23 / - DATA AE14CS( 43) / +.2807573556 5583789222 8775750751 5 D-23 / - DATA AE14CS( 44) / -.1132560944 9810864321 4188889156 2 D-23 / - DATA AE14CS( 45) / +.4600574684 3750179461 5676423372 7 D-24 / - DATA AE14CS( 46) / -.1881448598 9761334598 6460914810 8 D-24 / - DATA AE14CS( 47) / +.7744916111 5077308454 4432847803 7 D-25 / - DATA AE14CS( 48) / -.3208512760 5853689267 0270382626 1 D-25 / - DATA AE14CS( 49) / +.1337445542 9108397606 1993042138 4 D-25 / - DATA AE14CS( 50) / -.5608671881 8022170488 9477173521 0 D-26 / - DATA AE14CS( 51) / +.2365839716 5285374837 1006947327 9 D-26 / - DATA AE14CS( 52) / -.1003656195 0253053340 6583452685 6 D-26 / - DATA AE14CS( 53) / +.4281490878 0941611312 8664255692 7 D-27 / - DATA AE14CS( 54) / -.1836345261 8153181996 9132695825 0 D-27 / - DATA AE14CS( 55) / +.7917798231 3495400000 9746867814 4 D-28 / - DATA AE14CS( 56) / -.3431542358 7422203610 2501577523 1 D-28 / - DATA AE14CS( 57) / +.1494705493 8971032374 7506600891 7 D-28 / - DATA AE14CS( 58) / -.6542620279 8657054397 3904242005 3 D-29 / - DATA AE14CS( 59) / +.2877581395 1991711143 4048735368 5 D-29 / - DATA AE14CS( 60) / -.1271557211 7960247110 2798120004 2 D-29 / - DATA AE14CS( 61) / +.5644615555 6487225223 8804462250 6 D-30 / - DATA AE14CS( 62) / -.2516994994 2840951060 8061683029 3 D-30 / - DATA AE14CS( 63) / +.1127259818 9275102063 7036880418 1 D-30 / - DATA AE14CS( 64) / -.5069814875 8004608555 6258471936 0 D-31 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DE1 - IF (FIRST) THEN - ETA = 0.1*REAL(D1MACH(3)) - NTAE10 = INITDS (AE10CS, 50, ETA) - NTAE11 = INITDS (AE11CS, 60, ETA) - NTAE12 = INITDS (AE12CS, 41, ETA) - NTE11 = INITDS (E11CS, 29, ETA) - NTE12 = INITDS (E12CS, 25, ETA) - NTAE13 = INITDS (AE13CS, 50, ETA) - NTAE14 = INITDS (AE14CS, 64, ETA) -C - XMAXT = -LOG(D1MACH(1)) - XMAX = XMAXT - LOG(XMAXT) - ENDIF - FIRST = .FALSE. -C - IF (X.GT.(-1.D0)) GO TO 50 - IF (X.GT.(-32.D0)) GO TO 20 - DE1 = EXP(-X)/X * (1.D0 + DCSEVL (64.D0/X+1.D0, AE10CS, NTAE10)) - RETURN -C - 20 IF (X.GT.(-8.D0)) GO TO 30 - DE1 = EXP(-X)/X * (1.D0 + DCSEVL ((64.D0/X+5.D0)/3.D0, AE11CS, - 1 NTAE11)) - RETURN -C - 30 IF (X.GT.(-4.D0)) GO TO 40 - DE1 = EXP(-X)/X * (1.D0 + DCSEVL (16.D0/X+3.D0, AE12CS, NTAE12)) - RETURN -C - 40 DE1 = -LOG(-X) + DCSEVL ((2.D0*X+5.D0)/3.D0, E11CS, NTE11) - RETURN -C - 50 IF (X.GT.1.0D0) GO TO 60 - IF (X .EQ. 0.D0) CALL XERMSG ('SLATEC', 'DE1', 'X IS 0', 2, 2) - DE1 = (-LOG(ABS(X)) - 0.6875D0 + X) + DCSEVL (X, E12CS, NTE12) - RETURN -C - 60 IF (X.GT.4.0D0) GO TO 70 - DE1 = EXP(-X)/X * (1.D0 + DCSEVL ((8.D0/X-5.D0)/3.D0, AE13CS, - 1 NTAE13)) - RETURN -C - 70 IF (X.GT.XMAX) GO TO 80 - DE1 = EXP(-X)/X * (1.D0 + DCSEVL (8.D0/X-1.D0, AE14CS, NTAE14)) - RETURN -C - 80 CALL XERMSG ('SLATEC', 'DE1', 'X SO BIG E1 UNDERFLOWS', 1, 1) - DE1 = 0.D0 - RETURN -C - END diff --git a/slatec/deabm.f b/slatec/deabm.f deleted file mode 100644 index 63813f1..0000000 --- a/slatec/deabm.f +++ /dev/null @@ -1,671 +0,0 @@ -*DECK DEABM - SUBROUTINE DEABM (F, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, - + RWORK, LRW, IWORK, LIW, RPAR, IPAR) -C***BEGIN PROLOGUE DEABM -C***PURPOSE Solve an initial value problem in ordinary differential -C equations using an Adams-Bashforth method. -C***LIBRARY SLATEC (DEPAC) -C***CATEGORY I1A1B -C***TYPE SINGLE PRECISION (DEABM-S, DDEABM-D) -C***KEYWORDS ADAMS-BASHFORTH METHOD, DEPAC, INITIAL VALUE PROBLEMS, -C ODE, ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR -C***AUTHOR Shampine, L. F., (SNLA) -C Watts, H. A., (SNLA) -C***DESCRIPTION -C -C This is the Adams code in the package of differential equation -C solvers DEPAC, consisting of the codes DERKF, DEABM, and DEBDF. -C Design of the package was by L. F. Shampine and H. A. Watts. -C It is documented in -C SAND79-2374 , DEPAC - Design of a User Oriented Package of ODE -C Solvers. -C DEABM is a driver for a modification of the code ODE written by -C L. F. Shampine and M. K. Gordon -C Sandia Laboratories -C Albuquerque, New Mexico 87185 -C -C ********************************************************************** -C ** DEPAC PACKAGE OVERVIEW ** -C ************************************************** -C -C You have a choice of three differential equation solvers from -C DEPAC. The following brief descriptions are meant to aid you -C in choosing the most appropriate code for your problem. -C -C DERKF is a fifth order Runge-Kutta code. It is the simplest of -C the three choices, both algorithmically and in the use of the -C code. DERKF is primarily designed to solve non-stiff and mild- -C ly stiff differential equations when derivative evaluations are -C not expensive. It should generally not be used to get high -C accuracy results nor answers at a great many specific points. -C Because DERKF has very low overhead costs, it will usually -C result in the least expensive integration when solving -C problems requiring a modest amount of accuracy and having -C equations that are not costly to evaluate. DERKF attempts to -C discover when it is not suitable for the task posed. -C -C DEABM is a variable order (one through twelve) Adams code. -C Its complexity lies somewhere between that of DERKF and DEBDF. -C DEABM is primarily designed to solve non-stiff and mildly stiff -C differential equations when derivative evaluations are -C expensive, high accuracy results are needed or answers at -C many specific points are required. DEABM attempts to discover -C when it is not suitable for the task posed. -C -C DEBDF is a variable order (one through five) backward -C differentiation formula code. It is the most complicated of -C the three choices. DEBDF is primarily designed to solve stiff -C differential equations at crude to moderate tolerances. -C If the problem is very stiff at all, DERKF and DEABM will be -C quite inefficient compared to DEBDF. However, DEBDF will be -C inefficient compared to DERKF and DEABM on non-stiff problems -C because it uses much more storage, has a much larger overhead, -C and the low order formulas will not give high accuracies -C efficiently. -C -C The concept of stiffness cannot be described in a few words. -C If you do not know the problem to be stiff, try either DERKF -C or DEABM. Both of these codes will inform you of stiffness -C when the cost of solving such problems becomes important. -C -C ********************************************************************** -C ** ABSTRACT ** -C ************** -C -C Subroutine DEABM uses the Adams-Bashforth-Moulton predictor- -C corrector formulas of orders one through twelve to integrate a -C system of NEQ first order ordinary differential equations of the -C form -C DU/DX = F(X,U) -C when the vector Y(*) of initial values for U(*) at X=T is given. The -C subroutine integrates from T to TOUT. It is easy to continue the -C integration to get results at additional TOUT. This is the interval -C mode of operation. It is also easy for the routine to return with -C the solution at each intermediate step on the way to TOUT. This is -C the intermediate-output mode of operation. -C -C DEABM uses subprograms DES, STEPS, SINTRP, HSTART, HVNRM, R1MACH and -C the error handling routine XERMSG. The only machine dependent -C parameters to be assigned appear in R1MACH. -C -C ********************************************************************** -C ** DESCRIPTION OF THE ARGUMENTS TO DEABM (AN OVERVIEW) ** -C ********************************************************* -C -C The parameters are -C -C F -- This is the name of a subroutine which you provide to -C define the differential equations. -C -C NEQ -- This is the number of (first order) differential -C equations to be integrated. -C -C T -- This is a value of the independent variable. -C -C Y(*) -- This array contains the solution components at T. -C -C TOUT -- This is a point at which a solution is desired. -C -C INFO(*) -- The basic task of the code is to integrate the -C differential equations from T to TOUT and return an -C answer at TOUT. INFO(*) is an integer array which is used -C to communicate exactly how you want this task to be -C carried out. -C -C RTOL, ATOL -- These quantities represent relative and absolute -C error tolerances which you provide to indicate how -C accurately you wish the solution to be computed. You may -C choose them to be both scalars or else both vectors. -C -C IDID -- This scalar quantity is an indicator reporting what -C the code did. You must monitor this integer variable to -C decide what action to take next. -C -C RWORK(*), LRW -- RWORK(*) is a real work array of length LRW -C which provides the code with needed storage space. -C -C IWORK(*), LIW -- IWORK(*) is an integer work array of length LIW -C which provides the code with needed storage space and an -C across call flag. -C -C RPAR, IPAR -- These are real and integer parameter arrays which -C you can use for communication between your calling -C program and the F subroutine. -C -C Quantities which are used as input items are -C NEQ, T, Y(*), TOUT, INFO(*), -C RTOL, ATOL, RWORK(1), LRW and LIW. -C -C Quantities which may be altered by the code are -C T, Y(*), INFO(1), RTOL, ATOL, -C IDID, RWORK(*) and IWORK(*). -C -C ********************************************************************** -C ** INPUT -- WHAT TO DO ON THE FIRST CALL TO DEABM ** -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 F -- Provide a subroutine of the form -C F(X,U,UPRIME,RPAR,IPAR) -C to define the system of first order differential equations -C which is to be solved. For the given values of X and the -C vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must -C evaluate the NEQ components of the system of differential -C equations DU/DX = F(X,U) and store the derivatives in -C array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for -C equations I=1,...,NEQ. -C -C Subroutine F must not alter X or U(*). You must declare -C the name F in an external statement in your program that -C calls DEABM. You must dimension U and UPRIME in F. -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 F. They are not used or altered by DEABM. -C If you do not need RPAR or IPAR, ignore these parameters -C by treating them as dummy arguments. If you do choose to -C use them, dimension them in your calling program and in F -C as arrays of appropriate length. -C -C NEQ -- Set it to the number of differential equations. -C (NEQ .GE. 1) -C -C T -- Set it to the initial point of the integration. -C You must use a program variable for T because the code -C changes its value. -C -C Y(*) -- Set this vector to the initial values of the NEQ solution -C components at the initial point. You must dimension Y at -C least NEQ in your calling program. -C -C TOUT -- Set it to the first point at which a solution -C is desired. You can take TOUT = T, in which case the code -C will evaluate the derivative of the solution at T and -C return. Integration either forward in T (TOUT .GT. T) -C or backward in T (TOUT .LT. T) is permitted. -C -C The code advances the solution from T to TOUT using -C step sizes which are automatically selected so as to -C achieve the desired accuracy. If you wish, the code will -C return with the solution and its derivative following -C each intermediate step (intermediate-output mode) so that -C you can monitor them, but you still must provide TOUT in -C accord with the basic aim of the code. -C -C The first step taken by the code is a critical one -C because it must reflect how fast the solution changes near -C the initial point. The code automatically selects an -C initial step size which is practically always suitable for -C the problem. By using the fact that the code will not -C step past TOUT in the first step, you could, if necessary, -C restrict the length of the initial step size. -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 -C past TSTOP. In this case any TOUT beyond TSTOP is invalid -C 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 15 to accommodate other members of -C DEPAC or possible future extensions, though DEABM uses -C only the first four entries. You must respond to all of -C the following items which are arranged as questions. The -C simplest use of the code corresponds to answering all -C questions as YES ,i.e. setting all entries of INFO to 0. -C -C INFO(1) -- This parameter enables the code to initialize -C itself. You must set it to indicate the start of every -C new 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 vectors. -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 -C of TOUT by steps. If you wish, it will return the -C computed solution and derivative at the next -C intermediate step (the intermediate-output mode) or -C TOUT, whichever comes first. This is a good way to -C proceed if you want to see the behavior of the solution. -C If you must have solutions at a great many specific -C TOUT points, this 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 not to go past. -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 RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) -C error tolerances to tell the code how accurately you want -C the solution to be computed. They must be defined as -C program variables because the code may change them. You -C have two choices -- -C both RTOL and ATOL are scalars. (INFO(2)=0) -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 test -C at each step which requires roughly that -C ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL -C for each vector component. -C (More specifically, a Euclidean norm is used to measure -C the size of vectors, and the error test uses the magnitude -C of the solution at the beginning of the step.) -C -C The true (global) error is the difference between the true -C solution of the initial value problem and the computed -C approximation. Practically all present day codes, -C including this one, control the local error at each step -C and do not even attempt to control the global error -C directly. Roughly speaking, they produce a solution Y(T) -C which satisfies the differential equations with a -C residual R(T), DY(T)/DT = F(T,Y(T)) + R(T) , -C and, almost always, R(T) is bounded by the error -C tolerances. Usually, but not always, the true accuracy of -C the computed Y is comparable to the error tolerances. This -C code will usually, but not always, deliver a more accurate -C solution if you reduce the tolerances and integrate again. -C By comparing two such solutions you can get a fairly -C reliable idea of the true error in the solution at the -C bigger tolerances. -C -C Setting ATOL=0.0 results in a pure relative error test on -C that component. Setting RTOL=0.0 results in a pure abso- -C lute error test on that component. A mixed test with non- -C zero RTOL and ATOL corresponds roughly to a relative error -C test when the solution component is much bigger than ATOL -C and to an absolute error test when the solution component -C is smaller than the threshold ATOL. -C -C Proper selection of the absolute error control parameters -C ATOL requires you to have some idea of the scale of the -C solution components. To acquire this information may mean -C that you will have to solve the problem more than once. -C In the absence of scale information, you should ask for -C some relative accuracy in all the components (by setting -C RTOL values non-zero) and perhaps impose extremely small -C absolute error tolerances to protect against the danger of -C a solution component becoming zero. -C -C The code will not attempt to compute a solution at an -C accuracy unreasonable for the machine being used. It will -C advise you if you ask for too much accuracy and inform -C you as to the maximum accuracy it believes possible. -C -C RWORK(*) -- Dimension this real work array of length LRW in your -C calling program. -C -C RWORK(1) -- If you have set INFO(4)=0, you can ignore this -C optional input parameter. Otherwise you must define a -C stopping point TSTOP by setting RWORK(1) = TSTOP. -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.) -C -C LRW -- Set it to the declared length of the RWORK array. -C You must have LRW .GE. 130+21*NEQ -C -C IWORK(*) -- Dimension this integer work array of length LIW in -C your calling program. -C -C LIW -- Set it to the declared length of the IWORK array. -C You must have LIW .GE. 51 -C -C RPAR, IPAR -- These are parameter arrays, of real and integer -C type, respectively. You can use them for communication -C between your program that calls DEABM and the F -C subroutine. They are not used or altered by DEABM. If -C you do not need RPAR or IPAR, ignore these parameters by -C treating them as dummy arguments. If you do choose to use -C them, dimension them in your calling program and in F as -C arrays of appropriate length. -C -C ********************************************************************** -C ** OUTPUT -- AFTER ANY RETURN FROM DEABM ** -C ******************************************* -C -C The principal aim of the code is to return a computed solution at -C TOUT, although it is also possible to obtain intermediate results -C along the way. To find out whether the code achieved its goal -C or if the integration process was interrupted before the task was -C completed, you must check the IDID parameter. -C -C -C T -- The solution was successfully advanced to the -C output value of T. -C -C Y(*) -- Contains the computed solution approximation at T. -C You may also be interested in the approximate derivative -C of the solution at T. It is contained in -C RWORK(21),...,RWORK(20+NEQ). -C -C IDID -- Reports what the code did -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 TOUT was successfully -C completed (T=TOUT) by stepping exactly to TOUT. -C -C IDID = 3 -- The integration to TOUT was successfully -C completed (T=TOUT) by stepping past TOUT. -C Y(*) is obtained by interpolation. -C -C *** Task Interrupted *** -C reported by negative values of IDID -C -C IDID = -1 -- A large amount of work has been expended. -C (500 steps attempted) -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 -C component is zero. Thus, a pure relative error -C test is impossible for this component. -C -C IDID = -4 -- The problem appears to be stiff. -C -C IDID = -5,-6,-7,..,-32 -- Not applicable for this code -C but used by other members of DEPAC or possible -C future extensions. -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 -C occurs 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 be -C appropriate for continuing the integration. However, the -C reported solution at T was obtained using the input values -C of RTOL and ATOL. -C -C RWORK, IWORK -- Contain information which is usually of no -C interest to the user but necessary for subsequent calls. -C However, you may find use for -C -C RWORK(11)--Which contains the step size H to be -C attempted on the next step. -C -C RWORK(12)--If the tolerances have been increased by the -C code (IDID = -2) , they were multiplied by the -C value in RWORK(12). -C -C RWORK(13)--Which contains the current value of the -C independent variable, i.e. the farthest point -C integration has reached. This will be dif- -C ferent from T only when interpolation has been -C performed (IDID=3). -C -C RWORK(20+I)--Which contains the approximate derivative of -C the solution component Y(I). In DEABM, it is -C obtained by calling subroutine F to evaluate -C the differential equation using T and Y(*) when -C IDID=1 or 2, and by interpolation when IDID=3. -C -C ********************************************************************** -C ** INPUT -- WHAT TO DO TO CONTINUE THE INTEGRATION ** -C ** (CALLS AFTER THE FIRST) ** -C ***************************************************** -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 -C determine 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, -C in particular do not alter NEQ, T, Y(*), RWORK(*), IWORK(*) or -C the differential equation in subroutine F. Any such alteration -C constitutes a new problem and must be treated as such, i.e. -C you must start afresh. -C -C You cannot change from vector to scalar error control or vice -C versa (INFO(2)) but you can change the size of the entries of -C RTOL, 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 The parameter INFO(1) is used by the code to indicate the -C beginning of a new problem and to indicate whether integration -C is to be continued. You must input the value INFO(1) = 0 -C when starting a new problem. You must input the value -C INFO(1) = 1 if you wish to continue after an interrupted task. -C Do not set INFO(1) = 0 on a continuation call unless you -C want the code to restart at the current T. -C -C *** Following a Completed Task *** -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 *** Following an Interrupted Task *** -C To show the code that you realize the task was -C interrupted and that you want to continue, you -C must take appropriate action and reset INFO(1) = 1 -C If -C IDID = -1, the code has attempted 500 steps. -C If you want to continue, set INFO(1) = 1 and -C call the code again. An additional 500 steps -C will be allowed. -C -C IDID = -2, the error tolerances RTOL, ATOL have been -C increased to values the code estimates appropriate -C for continuing. You may want to change them -C yourself. If you are sure you want to continue -C with relaxed error tolerances, set INFO(1)=1 and -C call the code 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 -C alter the error criterion to use positive values -C for those components of ATOL corresponding to zero -C solution components, then set INFO(1)=1 and call -C the code again. -C -C IDID = -4, the problem appears to be stiff. It is very -C inefficient to solve such problems with DEABM. The -C code DEBDF in DEPAC handles this task efficiently. -C If you are absolutely sure you want to continue -C with DEABM, set INFO(1)=1 and call the code again. -C -C IDID = -5,-6,-7,..,-32 --- cannot occur with this code -C but used by other members of DEPAC or possible -C future extensions. -C -C *** Following a Terminated Task *** -C If -C IDID = -33, you cannot continue the solution of this -C problem. An attempt to do so will result in your -C run being terminated. -C -C ********************************************************************** -C -C***REFERENCES L. F. Shampine and H. A. Watts, DEPAC - design of a user -C oriented package of ODE solvers, Report SAND79-2374, -C Sandia Laboratories, 1979. -C***ROUTINES CALLED DES, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800501 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891024 Changed references from VNORM to HVNRM. (WRB) -C 891024 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DEABM -C - LOGICAL START,PHASE1,NORND,STIFF,INTOUT -C - DIMENSION Y(*),INFO(15),RTOL(*),ATOL(*),RWORK(*),IWORK(*), - 1 RPAR(*),IPAR(*) -C - CHARACTER*8 XERN1 - CHARACTER*16 XERN3 -C - EXTERNAL F -C -C CHECK FOR AN APPARENT INFINITE LOOP -C -C***FIRST EXECUTABLE STATEMENT DEABM - IF ( INFO(1) .EQ. 0 ) IWORK(LIW) = 0 - IF (IWORK(LIW) .GE. 5) THEN - IF (T .EQ. RWORK(21 + NEQ)) THEN - WRITE (XERN3, '(1PE15.6)') T - CALL XERMSG ('SLATEC', 'DEABM', - * 'AN APPARENT INFINITE LOOP HAS BEEN DETECTED.$$' // - * 'YOU HAVE MADE REPEATED CALLS AT T = ' // XERN3 // - * ' AND THE INTEGRATION HAS NOT ADVANCED. CHECK THE ' // - * 'WAY YOU HAVE SET PARAMETERS FOR THE CALL TO THE ' // - * 'CODE, PARTICULARLY INFO(1).', 13, 2) - RETURN - ENDIF - ENDIF -C -C CHECK LRW AND LIW FOR SUFFICIENT STORAGE ALLOCATION -C - IDID=0 - IF (LRW .LT. 130+21*NEQ) THEN - WRITE (XERN1, '(I8)') LRW - CALL XERMSG ('SLATEC', 'DEABM', 'THE LENGTH OF THE RWORK ' // - * 'ARRAY MUST BE AT LEAST 130 + 21*NEQ.$$' // - * 'YOU HAVE CALLED THE CODE WITH LRW = ' // XERN1, 1, 1) - IDID=-33 - ENDIF -C - IF (LIW .LT. 51) THEN - WRITE (XERN1, '(I8)') LIW - CALL XERMSG ('SLATEC', 'DEABM', 'THE LENGTH OF THE IWORK ' // - * 'ARRAY MUST BE AT LEAST 51.$$YOU HAVE CALLED THE CODE ' // - * 'WITH LIW = ' // XERN1, 2, 1) - IDID=-33 - ENDIF -C -C COMPUTE THE INDICES FOR THE ARRAYS TO BE STORED IN THE WORK ARRAY -C - IYPOUT = 21 - ITSTAR = NEQ + 21 - IYP = 1 + ITSTAR - IYY = NEQ + IYP - IWT = NEQ + IYY - IP = NEQ + IWT - IPHI = NEQ + IP - IALPHA = (NEQ*16) + IPHI - IBETA = 12 + IALPHA - IPSI = 12 + IBETA - IV = 12 + IPSI - IW = 12 + IV - ISIG = 12 + IW - IG = 13 + ISIG - IGI = 13 + IG - IXOLD = 11 + IGI - IHOLD = 1 + IXOLD - ITOLD = 1 + IHOLD - IDELSN = 1 + ITOLD - ITWOU = 1 + IDELSN - IFOURU = 1 + ITWOU -C - RWORK(ITSTAR) = T - IF (INFO(1) .EQ. 0) GO TO 50 - START = IWORK(21) .NE. (-1) - PHASE1 = IWORK(22) .NE. (-1) - NORND = IWORK(23) .NE. (-1) - STIFF = IWORK(24) .NE. (-1) - INTOUT = IWORK(25) .NE. (-1) -C - 50 CALL DES(F,NEQ,T,Y,TOUT,INFO,RTOL,ATOL,IDID,RWORK(IYPOUT), - 1 RWORK(IYP),RWORK(IYY),RWORK(IWT),RWORK(IP),RWORK(IPHI), - 2 RWORK(IALPHA),RWORK(IBETA),RWORK(IPSI),RWORK(IV), - 3 RWORK(IW),RWORK(ISIG),RWORK(IG),RWORK(IGI),RWORK(11), - 4 RWORK(12),RWORK(13),RWORK(IXOLD),RWORK(IHOLD), - 5 RWORK(ITOLD),RWORK(IDELSN),RWORK(1),RWORK(ITWOU), - 5 RWORK(IFOURU),START,PHASE1,NORND,STIFF,INTOUT,IWORK(26), - 6 IWORK(27),IWORK(28),IWORK(29),IWORK(30),IWORK(31), - 7 IWORK(32),IWORK(33),IWORK(34),IWORK(35),IWORK(45), - 8 RPAR,IPAR) -C - IWORK(21) = -1 - IF (START) IWORK(21) = 1 - IWORK(22) = -1 - IF (PHASE1) IWORK(22) = 1 - IWORK(23) = -1 - IF (NORND) IWORK(23) = 1 - IWORK(24) = -1 - IF (STIFF) IWORK(24) = 1 - IWORK(25) = -1 - IF (INTOUT) IWORK(25) = 1 -C - IF (IDID .NE. (-2)) IWORK(LIW) = IWORK(LIW) + 1 - IF (T .NE. RWORK(ITSTAR)) IWORK(LIW) = 0 -C - RETURN - END diff --git a/slatec/debdf.f b/slatec/debdf.f deleted file mode 100644 index 8757bc3..0000000 --- a/slatec/debdf.f +++ /dev/null @@ -1,925 +0,0 @@ -*DECK DEBDF - SUBROUTINE DEBDF (F, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, - + RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC) -C***BEGIN PROLOGUE DEBDF -C***PURPOSE Solve an initial value problem in ordinary differential -C equations using backward differentiation formulas. It is -C intended primarily for stiff problems. -C***LIBRARY SLATEC (DEPAC) -C***CATEGORY I1A2 -C***TYPE SINGLE PRECISION (DEBDF-S, DDEBDF-D) -C***KEYWORDS BACKWARD DIFFERENTIATION FORMULAS, DEPAC, -C INITIAL VALUE PROBLEMS, ODE, -C ORDINARY DIFFERENTIAL EQUATIONS, STIFF -C***AUTHOR Shampine, L. F., (SNLA) -C Watts, H. A., (SNLA) -C***DESCRIPTION -C -C This is the backward differentiation code in the package of -C differential equation solvers DEPAC, consisting of the codes -C DERKF, DEABM, and DEBDF. Design of the package was by -C L. F. Shampine and H. A. Watts. It is documented in -C SAND-79-2374 , DEPAC - Design of a User Oriented Package of ODE -C Solvers. -C DEBDF is a driver for a modification of the code LSODE written by -C A. C. Hindmarsh -C Lawrence Livermore Laboratory -C Livermore, California 94550 -C -C ********************************************************************** -C ** DEPAC PACKAGE OVERVIEW ** -C ********************************************************************** -C -C You have a choice of three differential equation solvers from -C DEPAC. The following brief descriptions are meant to aid you -C in choosing the most appropriate code for your problem. -C -C DERKF is a fifth order Runge-Kutta code. It is the simplest of -C the three choices, both algorithmically and in the use of the -C code. DERKF is primarily designed to solve non-stiff and mild- -C ly stiff differential equations when derivative evaluations are -C not expensive. It should generally not be used to get high -C accuracy results nor answers at a great many specific points. -C Because DERKF has very low overhead costs, it will usually -C result in the least expensive integration when solving -C problems requiring a modest amount of accuracy and having -C equations that are not costly to evaluate. DERKF attempts to -C discover when it is not suitable for the task posed. -C -C DEABM is a variable order (one through twelve) Adams code. -C Its complexity lies somewhere between that of DERKF and DEBDF. -C DEABM is primarily designed to solve non-stiff and mildly -C stiff differential equations when derivative evaluations are -C expensive, high accuracy results are needed or answers at -C many specific points are required. DEABM attempts to discover -C when it is not suitable for the task posed. -C -C DEBDF is a variable order (one through five) backward -C differentiation formula code. It is the most complicated of -C the three choices. DEBDF is primarily designed to solve stiff -C differential equations at crude to moderate tolerances. -C If the problem is very stiff at all, DERKF and DEABM will be -C quite inefficient compared to DEBDF. However, DEBDF will be -C inefficient compared to DERKF and DEABM on non-stiff problems -C because it uses much more storage, has a much larger overhead, -C and the low order formulas will not give high accuracies -C efficiently. -C -C The concept of stiffness cannot be described in a few words. -C If you do not know the problem to be stiff, try either DERKF -C or DEABM. Both of these codes will inform you of stiffness -C when the cost of solving such problems becomes important. -C -C ********************************************************************** -C ** ABSTRACT ** -C ********************************************************************** -C -C Subroutine DEBDF uses the backward differentiation formulas of -C orders one through five to integrate a system of NEQ first order -C ordinary differential equations of the form -C DU/DX = F(X,U) -C when the vector Y(*) of initial values for U(*) at X=T is given. The -C subroutine integrates from T to TOUT. It is easy to continue the -C integration to get results at additional TOUT. This is the interval -C mode of operation. It is also easy for the routine to return with -C The solution at each intermediate step on the way to TOUT. This is -C the intermediate-output mode of operation. -C -C ********************************************************************** -C ** DESCRIPTION OF THE ARGUMENTS TO DEBDF (AN OVERVIEW) ** -C ********************************************************************** -C -C The Parameters are: -C -C F -- This is the name of a subroutine which you provide to -C define the differential equations. -C -C NEQ -- This is the number of (first order) differential -C equations to be integrated. -C -C T -- This is a value of the independent variable. -C -C Y(*) -- This array contains the solution components at T. -C -C TOUT -- This is a point at which a solution is desired. -C -C INFO(*) -- The basic task of the code is to integrate the -C differential equations from T to TOUT and return an -C answer at TOUT. INFO(*) is an INTEGER array which is used -C to communicate exactly how you want this task to be -C carried out. -C -C RTOL, ATOL -- These quantities -C represent relative and absolute error tolerances which you -C provide to indicate how accurately you wish the solution -C to be computed. You may choose them to be both scalars -C or else both vectors. -C -C IDID -- This scalar quantity is an indicator reporting what -C the code did. You must monitor this INTEGER variable to -C decide what action to take next. -C -C RWORK(*), LRW -- RWORK(*) is a REAL work array of -C length LRW which provides the code with needed storage -C space. -C -C IWORK(*), LIW -- IWORK(*) is an INTEGER work array of length LIW -C which provides the code with needed storage space and an -C across call flag. -C -C RPAR, IPAR -- These are REAL and INTEGER parameter -C arrays which you can use for communication between your -C calling program and the F subroutine (and the JAC -C subroutine). -C -C JAC -- This is the name of a subroutine which you may choose to -C provide for defining the Jacobian matrix of partial -C derivatives DF/DU. -C -C Quantities which are used as input items are -C NEQ, T, Y(*), TOUT, INFO(*), -C RTOL, ATOL, RWORK(1), LRW, -C IWORK(1), IWORK(2), and LIW. -C -C Quantities which may be altered by the code are -C T, Y(*), INFO(1), RTOL, ATOL, -C IDID, RWORK(*) and IWORK(*). -C -C ********************************************************************** -C * INPUT -- What To Do On The First Call To DEBDF * -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 F -- provide a subroutine of the form -C F(X,U,UPRIME,RPAR,IPAR) -C to define the system of first order differential equations -C which is to be solved. For the given values of X and the -C vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must -C evaluate the NEQ components of the system of differential -C equations DU/DX=F(X,U) and store the derivatives in the -C array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for -C equations I=1,...,NEQ. -C -C Subroutine F must not alter X or U(*). You must declare -C the name F in an external statement in your program that -C calls DEBDF. You must dimension U and UPRIME in F. -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 F. They are not used or altered by DEBDF. -C If you do not need RPAR or IPAR, ignore these parameters -C by treating them as dummy arguments. If you do choose to -C use them, dimension them in your calling program and in F -C as arrays of appropriate length. -C -C NEQ -- Set it to the number of differential equations. -C (NEQ .GE. 1) -C -C T -- Set it to the initial point of the integration. -C You must use a program variable for T because the code -C changes its value. -C -C Y(*) -- Set this vector to the initial values of the NEQ solution -C components at the initial point. You must dimension Y at -C least NEQ in your calling program. -C -C TOUT -- Set it to the first point at which a solution is desired. -C You can take TOUT = T, in which case the code -C will evaluate the derivative of the solution at T and -C return. Integration either forward in T (TOUT .GT. T) -C or backward in T (TOUT .LT. T) is permitted. -C -C The code advances the solution from T to TOUT using -C step sizes which are automatically selected so as to -C achieve the desired accuracy. If you wish, the code will -C return with the solution and its derivative following -C each intermediate step (intermediate-output mode) so that -C you can monitor them, but you still must provide TOUT in -C accord with the basic aim of the code. -C -C The first step taken by the code is a critical one -C because it must reflect how fast the solution changes near -C the initial point. The code automatically selects an -C initial step size which is practically always suitable for -C the problem. By using the fact that the code will not -C step past TOUT in the first step, you could, if necessary, -C restrict the length of the initial step size. -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 -C past TSTOP. In this case any TOUT beyond TSTOP is invalid -C 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 15 to accommodate other members of -C DEPAC or possible future extensions, though DEBDF uses -C only the first six entries. You must respond to all of -C the following items which are arranged as questions. The -C simplest use of the code corresponds to answering all -C questions as YES ,i.e. setting all entries of INFO to 0. -C -C INFO(1) -- This parameter enables the code to initialize -C itself. You must set it to indicate the start of every -C new 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 vectors. -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 -C of TOUT by steps. If you wish, it will return the -C computed solution and derivative at the next -C intermediate step (the intermediate-output mode) or -C TOUT, whichever comes first. This is a good way to -C proceed if you want to see the behavior of the solution. -C If you must have solutions at a great many specific -C TOUT points, this 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 not to go past. -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) -- To solve stiff problems it is necessary to use the -C Jacobian matrix of partial derivatives of the system -C of differential equations. If you do not provide a -C subroutine to evaluate it analytically (see the -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. Sometimes numerical differencing -C is cheaper than evaluating derivatives in JAC and -C sometimes it is not - this depends on your problem. -C -C If your problem is linear, i.e. has the form -C DU/DX = F(X,U) = J(X)*U + G(X) for some matrix J(X) -C and vector G(X), the Jacobian matrix DF/DU = J(X). -C Since you must provide a subroutine to evaluate F(X,U) -C analytically, it is little extra trouble to provide -C subroutine JAC for evaluating J(X) analytically. -C Furthermore, in such cases, numerical differencing is -C much more expensive than analytic evaluation. -C -C **** Do you want the code to evaluate the partial -C derivatives 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 Jacobian matrix **** -C -C INFO(6) -- DEBDF will perform much better if the Jacobian -C matrix is banded and the code is told this. In this -C case, the storage needed will be greatly reduced, -C numerical differencing will be performed more cheaply, -C and a number of important algorithms will execute much -C faster. The differential equation is said to have -C half-bandwidths ML (lower) and MU (upper) if equation I -C 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 Jacobian, -C the code works with a full matrix of NEQ**2 elements -C (stored in the conventional way). Computations with -C 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 Jacobian matrix has a banded structure and -C you want to provide subroutine JAC to compute the -C partial derivatives, then you must be careful to store -C the elements of the Jacobian matrix in the special form -C indicated in the description of JAC. -C -C **** Do you want to solve the problem using a full -C (dense) Jacobian matrix (and not a special banded -C 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 RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) -C error tolerances to tell the code how accurately you want -C the solution to be computed. They must be defined as -C program variables because the code may change them. You -C have two choices -- -C Both RTOL and ATOL are scalars. (INFO(2)=0) -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 test -C at each step which requires roughly that -C ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL -C 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 true -C solution of the initial value problem and the computed -C approximation. Practically all present day codes, -C including this one, control the local error at each step -C and do not even attempt to control the global error -C directly. Roughly speaking, they produce a solution Y(T) -C which satisfies the differential equations with a -C residual R(T), DY(T)/DT = F(T,Y(T)) + R(T) , -C and, almost always, R(T) is bounded by the error -C tolerances. Usually, but not always, the true accuracy of -C the computed Y is comparable to the error tolerances. This -C code will usually, but not always, deliver a more accurate -C solution if you reduce the tolerances and integrate again. -C By comparing two such solutions you can get a fairly -C reliable idea of the true error in the solution at the -C bigger tolerances. -C -C Setting ATOL=0. results in a pure relative error test on -C that component. Setting RTOL=0. results in a pure abso- -C lute error test on that component. A mixed test with non- -C zero RTOL and ATOL corresponds roughly to a relative error -C test when the solution component is much bigger than ATOL -C and to an absolute error test when the solution component -C is smaller than the threshold ATOL. -C -C Proper selection of the absolute error control parameters -C ATOL requires you to have some idea of the scale of the -C solution components. To acquire this information may mean -C that you will have to solve the problem more than once. In -C the absence of scale information, you should ask for some -C relative accuracy in all the components (by setting RTOL -C values non-zero) and perhaps impose extremely small -C absolute error tolerances to protect against the danger of -C a solution component becoming zero. -C -C The code will not attempt to compute a solution at an -C accuracy unreasonable for the machine being used. It will -C advise you if you ask for too much accuracy and inform -C you as to the maximum accuracy it believes possible. -C -C RWORK(*) -- Dimension this REAL work array of length LRW in your -C calling program. -C -C RWORK(1) -- If you have set INFO(4)=0, you can ignore this -C optional input parameter. Otherwise you must define a -C stopping point TSTOP by setting RWORK(1) = TSTOP. -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.) -C -C LRW -- Set it to the declared length of the RWORK array. -C You must have -C LRW .GE. 250+10*NEQ+NEQ**2 -C for the full (dense) Jacobian case (when INFO(6)=0), or -C LRW .GE. 250+10*NEQ+(2*ML+MU+1)*NEQ -C for the banded Jacobian case (when INFO(6)=1). -C -C IWORK(*) -- Dimension this INTEGER work array of length LIW in -C your calling program. -C -C IWORK(1), IWORK(2) -- If you have set INFO(6)=0, you can ignore -C these optional input parameters. Otherwise you must define -C the half-bandwidths ML (lower) and MU (upper) of the -C Jacobian matrix by setting IWORK(1) = ML and -C IWORK(2) = MU. (The code will work with a full matrix -C of NEQ**2 elements unless it is told that the problem has -C a banded Jacobian, in which case the code will work with -C a matrix containing at most (2*ML+MU+1)*NEQ elements.) -C -C LIW -- Set it to the declared length of the IWORK array. -C You must have LIW .GE. 56+NEQ. -C -C RPAR, IPAR -- These are parameter arrays, of REAL and INTEGER -C type, respectively. You can use them for communication -C between your program that calls DEBDF and the F -C subroutine (and the JAC subroutine). They are not used or -C altered by DEBDF. If you do not need RPAR or IPAR, ignore -C these parameters by treating them as dummy arguments. If -C you do choose to use them, dimension them in your calling -C program and in F (and in JAC) as arrays of appropriate -C length. -C -C JAC -- If you have set INFO(5)=0, you can ignore this parameter -C by treating it as a dummy argument. (For some compilers -C you may have to write a dummy subroutine named JAC in -C order to avoid problems associated with missing external -C routine names.) Otherwise, you must provide a subroutine -C of the form -C JAC(X,U,PD,NROWPD,RPAR,IPAR) -C to define the Jacobian matrix of partial derivatives DF/DU -C of the system of differential equations DU/DX = F(X,U). -C For the given values of X and the vector -C U(*)=(U(1),U(2),...,U(NEQ)), the subroutine must evaluate -C the non-zero partial derivatives DF(I)/DU(J) for each -C differential equation I=1,...,NEQ and each solution -C component J=1,...,NEQ , and store these values in the -C matrix PD. The elements of PD are set to zero before each -C call to JAC so only non-zero elements need to be defined. -C -C Subroutine JAC must not alter X, U(*), or NROWPD. You -C must declare the name JAC in an EXTERNAL statement in your -C program that calls DEBDF. NROWPD is the row dimension of -C the PD matrix and is assigned by the code. Therefore you -C must dimension PD in JAC according to -C DIMENSION PD(NROWPD,1) -C You must also dimension U in JAC. -C -C The way you must store the elements into the PD matrix -C depends on the structure of the Jacobian which you -C indicated by INFO(6). -C *** INFO(6)=0 -- Full (Dense) Jacobian *** -C When you evaluate the (non-zero) partial derivative -C of equation I with respect to variable J, you must -C store it in PD according to -C PD(I,J) = * DF(I)/DU(J) * -C *** INFO(6)=1 -- Banded Jacobian with ML Lower and MU -C Upper Diagonal Bands (refer to INFO(6) description of -C ML and MU) *** -C When you evaluate the (non-zero) partial derivative -C of equation I with respect to variable J, you must -C store it in PD according to -C IROW = I - J + ML + MU + 1 -C PD(IROW,J) = * DF(I)/DU(J) * -C -C RPAR and IPAR are REAL and INTEGER parameter -C arrays which you can use for communication between your -C calling program and your Jacobian subroutine JAC. They -C are not altered by DEBDF. If you do not need RPAR or -C IPAR, ignore these parameters by treating them as dummy -C arguments. If you do choose to use them, dimension them -C in your calling program and in JAC as arrays of -C appropriate length. -C -C ********************************************************************** -C * OUTPUT -- After any return from DDEBDF * -C ********************************************************************** -C -C The principal aim of the code is to return a computed solution at -C TOUT, although it is also possible to obtain intermediate results -C along the way. To find out whether the code achieved its goal -C or if the integration process was interrupted before the task was -C completed, you must check the IDID parameter. -C -C -C T -- The solution was successfully advanced to the -C output value of T. -C -C Y(*) -- Contains the computed solution approximation at T. -C You may also be interested in the approximate derivative -C of the solution at T. It is contained in -C RWORK(21),...,RWORK(20+NEQ). -C -C IDID -- Reports what the code did -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 TOUT was successfully -C completed (T=TOUT) by stepping exactly to TOUT. -C -C IDID = 3 -- The integration to TOUT was successfully -C completed (T=TOUT) by stepping past TOUT. -C Y(*) is obtained by interpolation. -C -C *** Task Interrupted *** -C Reported by negative values of IDID -C -C IDID = -1 -- A large amount of work has been expended. -C (500 steps attempted) -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 -C component is zero. Thus, a pure relative error -C test is impossible for this component. -C -C IDID = -4,-5 -- Not applicable for this code but used -C by other members of DEPAC. -C -C IDID = -6 -- DEBDF had repeated convergence test failures -C on the last attempted step. -C -C IDID = -7 -- DEBDF had repeated error test failures on -C the last attempted step. -C -C IDID = -8,..,-32 -- Not applicable for this code but -C used by other members of DEPAC or possible -C future extensions. -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 -C occurs 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 be -C appropriate for continuing the integration. However, the -C reported solution at T was obtained using the input values -C of RTOL and ATOL. -C -C RWORK, IWORK -- Contain information which is usually of no -C interest to the user but necessary for subsequent calls. -C However, you may find use for -C -C RWORK(11)--which contains the step size H to be -C attempted on the next step. -C -C RWORK(12)--If the tolerances have been increased by the -C code (IDID = -2) , they were multiplied by the -C value in RWORK(12). -C -C RWORK(13)--which contains the current value of the -C independent variable, i.e. the farthest point -C integration has reached. This will be -C different from T only when interpolation has -C been performed (IDID=3). -C -C RWORK(20+I)--which contains the approximate derivative -C of the solution component Y(I). In DEBDF, it -C is never obtained by calling subroutine F to -C evaluate the differential equation using T and -C Y(*), except at the initial point of -C integration. -C -C ********************************************************************** -C ** INPUT -- What To Do To Continue The Integration ** -C ** (calls after the first) ** -C ********************************************************************** -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, -C in particular do not alter NEQ, T, Y(*), RWORK(*), IWORK(*) or -C the differential equation in subroutine F. Any such alteration -C constitutes a new problem and must be treated as such, i.e. -C you must start afresh. -C -C You cannot change from vector to scalar error control or vice -C versa (INFO(2)) but you can change the size of the entries of -C RTOL, 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), IWORK(1), or IWORK(2) -C unless you are going to restart the code. -C -C The parameter INFO(1) is used by the code to indicate the -C beginning of a new problem and to indicate whether integration -C is to be continued. You must input the value INFO(1) = 0 -C when starting a new problem. You must input the value -C INFO(1) = 1 if you wish to continue after an interrupted task. -C Do not set INFO(1) = 0 on a continuation call unless you -C want the code to restart at the current T. -C -C *** Following a Completed Task *** -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 *** Following an Interrupted Task *** -C To show the code that you realize the task was -C interrupted and that you want to continue, you -C must take appropriate action and reset INFO(1) = 1 -C If -C IDID = -1, the code has attempted 500 steps. -C If you want to continue, set INFO(1) = 1 and -C call the code again. An additional 500 steps -C will be allowed. -C -C IDID = -2, the error tolerances RTOL, ATOL have been -C increased to values the code estimates appropriate -C for continuing. You may want to change them -C yourself. If you are sure you want to continue -C with relaxed error tolerances, set INFO(1)=1 and -C call the code 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 -C alter the error criterion to use positive values -C for those components of ATOL corresponding to zero -C solution components, then set INFO(1)=1 and call -C the code again. -C -C IDID = -4,-5 --- cannot occur with this code but used -C by other members of DEPAC. -C -C IDID = -6, repeated convergence test failures occurred -C on the last attempted step in DEBDF. An inaccu- -C rate Jacobian may be the problem. If you are -C absolutely certain you want to continue, restart -C the integration at the current T by setting -C INFO(1)=0 and call the code again. -C -C IDID = -7, repeated error test failures occurred on the -C last attempted step in DEBDF. A singularity in -C the solution may be present. You should re- -C examine the problem being solved. If you are -C absolutely certain you want to continue, restart -C the integration at the current T by setting -C INFO(1)=0 and call the code again. -C -C IDID = -8,..,-32 --- cannot occur with this code but -C used by other members of DEPAC or possible future -C extensions. -C -C *** Following a Terminated Task *** -C If -C IDID = -33, you cannot continue the solution of this -C problem. An attempt to do so will result in your -C run being terminated. -C -C ********************************************************************** -C -C ***** Warning ***** -C -C If DEBDF is to be used in an overlay situation, you must save and -C restore certain items used internally by DEBDF (values in the -C common block DEBDF1). This can be accomplished as follows. -C -C To save the necessary values upon return from DEBDF, simply call -C SVCO(RWORK(22+NEQ),IWORK(21+NEQ)). -C -C To restore the necessary values before the next call to DEBDF, -C simply call RSCO(RWORK(22+NEQ),IWORK(21+NEQ)). -C -C***REFERENCES L. F. Shampine and H. A. Watts, DEPAC - design of a user -C oriented package of ODE solvers, Report SAND79-2374, -C Sandia Laboratories, 1979. -C***ROUTINES CALLED LSOD, XERMSG -C***COMMON BLOCKS DEBDF1 -C***REVISION HISTORY (YYMMDD) -C 800901 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891024 Changed references from VNORM to HVNRM. (WRB) -C 891024 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900510 Convert XERRWV calls to XERMSG calls, change Prologue -C comments to agree with DDEBDF. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DEBDF -C -C - LOGICAL INTOUT - CHARACTER*8 XERN1, XERN2 - CHARACTER*16 XERN3 -C - DIMENSION Y(*),INFO(15),RTOL(*),ATOL(*),RWORK(*),IWORK(*), - 1 RPAR(*),IPAR(*) -C - COMMON /DEBDF1/ TOLD, ROWNS(210), - 1 EL0, H, HMIN, HMXI, HU, TN, UROUND, - 2 IQUIT, INIT, IYH, IEWT, IACOR, ISAVF, IWM, KSTEPS, - 3 IBEGIN, ITOL, IINTEG, ITSTOP, IJAC, IBAND, IOWNS(6), - 4 IER, JSTART, KFLAG, L, METH, MITER, MAXORD, N, NQ, NST, NFE, - 5 NJE, NQU -C - EXTERNAL F, JAC -C -C CHECK FOR AN APPARENT INFINITE LOOP -C -C***FIRST EXECUTABLE STATEMENT DEBDF - IF (INFO(1) .EQ. 0) IWORK(LIW) = 0 -C - IF (IWORK(LIW).GE. 5) THEN - IF (T .EQ. RWORK(21+NEQ)) THEN - WRITE (XERN3, '(1PE15.6)') T - CALL XERMSG ('SLATEC', 'DEBDF', - * 'AN APPARENT INFINITE LOOP HAS BEEN DETECTED.$$' // - * 'YOU HAVE MADE REPEATED CALLS AT T = ' // XERN3 // - * ' AND THE INTEGRATION HAS NOT ADVANCED. CHECK THE ' // - * 'WAY YOU HAVE SET PARAMETERS FOR THE CALL TO THE ' // - * 'CODE PARTICULARLY INFO(1).', 13, 2) - RETURN - ENDIF - ENDIF -C - IDID = 0 -C -C CHECK VALIDITY OF INFO PARAMETERS -C - IF (INFO(1) .NE. 0 .AND. INFO(1) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(1) - CALL XERMSG ('SLATEC', 'DEBDF', 'INFO(1) MUST BE SET TO 0 ' // - * 'FOR THE START OF A NEW PROBLEM, AND MUST BE SET TO 1 ' // - * 'FOLLOWING AN INTERRUPTED TASK. YOU ARE ATTEMPTING TO ' // - * 'CONTINUE THE INTEGRATION ILLEGALLY BY CALLING THE ' // - * 'CODE WITH INFO(1) = ' // XERN1, 3, 1) - IDID = -33 - ENDIF -C - IF (INFO(2) .NE. 0 .AND. INFO(2) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(2) - CALL XERMSG ('SLATEC', 'DEBDF', 'INFO(2) MUST BE 0 OR 1 ' // - * 'INDICATING SCALAR AND VECTOR ERROR TOLERANCES, ' // - * 'RESPECTIVELY. YOU HAVE CALLED THE CODE WITH INFO(2) = ' // - * XERN1, 4, 1) - IDID = -33 - ENDIF -C - IF (INFO(3) .NE. 0 .AND. INFO(3) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(3) - CALL XERMSG ('SLATEC', 'DEBDF', 'INFO(3) MUST BE 0 OR 1 ' // - * 'INDICATING THE INTERVAL OR INTERMEDIATE-OUTPUT MODE OF ' // - * 'INTEGRATION, RESPECTIVELY. YOU HAVE CALLED THE CODE ' // - * 'WITH INFO(3) = ' // XERN1, 5, 1) - IDID = -33 - ENDIF -C - IF (INFO(4) .NE. 0 .AND. INFO(4) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(4) - CALL XERMSG ('SLATEC', 'DEBDF', 'INFO(4) MUST BE 0 OR 1 ' // - * 'INDICATING WHETHER OR NOT THE INTEGRATION INTERVAL IS ' // - * 'TO BE RESTRICTED BY A POINT TSTOP. YOU HAVE CALLED ' // - * 'THE CODE WITH INFO(4) = ' // XERN1, 14, 1) - IDID = -33 - ENDIF -C - IF (INFO(5) .NE. 0 .AND. INFO(5) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(5) - CALL XERMSG ('SLATEC', 'DEBDF', 'INFO(5) MUST BE 0 OR 1 ' // - * 'INDICATING WHETHER THE CODE IS TOLD TO FORM THE ' // - * 'JACOBIAN MATRIX BY NUMERICAL DIFFERENCING OR YOU ' // - * 'PROVIDE A SUBROUTINE TO EVALUATE IT ANALYTICALLY. ' // - * 'YOU HAVE CALLED THE CODE WITH INFO(5) = ' // XERN1, 15, 1) - IDID = -33 - ENDIF -C - IF (INFO(6) .NE. 0 .AND. INFO(6) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(6) - CALL XERMSG ('SLATEC', 'DEBDF', 'INFO(6) MUST BE 0 OR 1 ' // - * 'INDICATING WHETHER THE CODE IS TOLD TO TREAT THE ' // - * 'JACOBIAN AS A FULL (DENSE) MATRIX OR AS HAVING A ' // - * 'SPECIAL BANDED STRUCTURE. YOU HAVE CALLED THE CODE ' // - * 'WITH INFO(6) = ' // XERN1, 16, 1) - IDID = -33 - ENDIF -C - ILRW = NEQ - IF (INFO(6) .NE. 0) THEN -C -C CHECK BANDWIDTH PARAMETERS -C - ML = IWORK(1) - MU = IWORK(2) - ILRW = 2*ML + MU + 1 -C - IF (ML.LT.0 .OR. ML.GE.NEQ .OR. MU.LT.0 .OR. MU.GE.NEQ) THEN - WRITE (XERN1, '(I8)') ML - WRITE (XERN2, '(I8)') MU - CALL XERMSG ('SLATEC', 'DEBDF', 'YOU HAVE SET INFO(6) ' // - * '= 1, TELLING THE CODE THAT THE JACOBIAN MATRIX HAS ' // - * 'A SPECIAL BANDED STRUCTURE. HOWEVER, THE LOWER ' // - * '(UPPER) BANDWIDTHS ML (MU) VIOLATE THE CONSTRAINTS ' // - * 'ML,MU .GE. 0 AND ML,MU .LT. NEQ. YOU HAVE CALLED ' // - * 'THE CODE WITH ML = ' // XERN1 // ' AND MU = ' // XERN2, - * 17, 1) - IDID = -33 - ENDIF - ENDIF -C -C CHECK LRW AND LIW FOR SUFFICIENT STORAGE ALLOCATION -C - IF (LRW .LT. 250 + (10 + ILRW)*NEQ) THEN - WRITE (XERN1, '(I8)') LRW - IF (INFO(6) .EQ. 0) THEN - CALL XERMSG ('SLATEC', 'DEBDF', 'LENGTH OF ARRAY RWORK ' // - * 'MUST BE AT LEAST 250 + 10*NEQ + NEQ*NEQ.$$' // - * 'YOU HAVE CALLED THE CODE WITH LRW = ' // XERN1, 1, 1) - ELSE - CALL XERMSG ('SLATEC', 'DEBDF', 'LENGTH OF ARRAY RWORK ' // - * 'MUST BE AT LEAST 250 + 10*NEQ + (2*ML+MU+1)*NEQ.$$' // - * 'YOU HAVE CALLED THE CODE WITH LRW = ' // XERN1, 18, 1) - ENDIF - IDID = -33 - ENDIF -C - IF (LIW .LT. 56 + NEQ) THEN - WRITE (XERN1, '(I8)') LIW - CALL XERMSG ('SLATEC', 'DEBDF', 'LENGTH OF ARRAY IWORK ' // - * 'BE AT LEAST 56 + NEQ. YOU HAVE CALLED THE CODE WITH ' // - * 'LIW = ' // XERN1, 2, 1) - IDID = -33 - ENDIF -C -C COMPUTE THE INDICES FOR THE ARRAYS TO BE STORED IN THE WORK -C ARRAY AND RESTORE COMMON BLOCK DATA -C - ICOMI = 21 + NEQ - IINOUT = ICOMI + 33 -C - IYPOUT = 21 - ITSTAR = 21 + NEQ - ICOMR = 22 + NEQ -C - IF (INFO(1) .NE. 0) INTOUT = IWORK(IINOUT) .NE. (-1) -C CALL RSCO(RWORK(ICOMR),IWORK(ICOMI)) -C - IYH = ICOMR + 218 - IEWT = IYH + 6*NEQ - ISAVF = IEWT + NEQ - IACOR = ISAVF + NEQ - IWM = IACOR + NEQ - IDELSN = IWM + 2 + ILRW*NEQ -C - IBEGIN = INFO(1) - ITOL = INFO(2) - IINTEG = INFO(3) - ITSTOP = INFO(4) - IJAC = INFO(5) - IBAND = INFO(6) - RWORK(ITSTAR) = T -C - CALL LSOD(F,NEQ,T,Y,TOUT,RTOL,ATOL,IDID,RWORK(IYPOUT), - 1 RWORK(IYH),RWORK(IYH),RWORK(IEWT),RWORK(ISAVF), - 2 RWORK(IACOR),RWORK(IWM),IWORK(1),JAC,INTOUT, - 3 RWORK(1),RWORK(12),RWORK(IDELSN),RPAR,IPAR) -C - IWORK(IINOUT) = -1 - IF (INTOUT) IWORK(IINOUT) = 1 -C - IF (IDID .NE. (-2)) IWORK(LIW) = IWORK(LIW) + 1 - IF (T .NE. RWORK(ITSTAR)) IWORK(LIW) = 0 -C CALL SVCO(RWORK(ICOMR),IWORK(ICOMI)) - RWORK(11) = H - RWORK(13) = TN - INFO(1) = IBEGIN -C - RETURN - END diff --git a/slatec/defc.f b/slatec/defc.f deleted file mode 100644 index ded6e84..0000000 --- a/slatec/defc.f +++ /dev/null @@ -1,268 +0,0 @@ -*DECK DEFC - SUBROUTINE DEFC (NDATA, XDATA, YDATA, SDDATA, NORD, NBKPT, BKPT, - + MDEIN, MDEOUT, COEFF, LW, W) -C***BEGIN PROLOGUE DEFC -C***PURPOSE Fit a piecewise polynomial curve to discrete data. -C The piecewise polynomials are represented as B-splines. -C The fitting is done in a weighted least squares sense. -C***LIBRARY SLATEC -C***CATEGORY K1A1A1, K1A2A, L8A3 -C***TYPE DOUBLE PRECISION (EFC-S, DEFC-D) -C***KEYWORDS B-SPLINE, CONSTRAINED LEAST SQUARES, CURVE FITTING -C***AUTHOR Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C This subprogram fits a piecewise polynomial curve -C to discrete data. The piecewise polynomials are -C represented as B-splines. -C The fitting is done in a weighted least squares sense. -C -C The data can be processed in groups of modest size. -C The size of the group is chosen by the user. This feature -C may be necessary for purposes of using constrained curve fitting -C with subprogram DFC( ) on a very large data set. -C -C For a description of the B-splines and usage instructions to -C evaluate them, see -C -C C. W. de Boor, Package for Calculating with B-Splines. -C SIAM J. Numer. Anal., p. 441, (June, 1977). -C -C For further discussion of (constrained) curve fitting using -C B-splines, see -C -C R. J. Hanson, Constrained Least Squares Curve Fitting -C to Discrete Data Using B-Splines, a User's -C Guide. Sandia Labs. Tech. Rept. SAND-78-1291, -C December, (1978). -C -C Input.. All TYPE REAL variables are DOUBLE PRECISION -C NDATA,XDATA(*), -C YDATA(*), -C SDDATA(*) -C The NDATA discrete (X,Y) pairs and the Y value -C standard deviation or uncertainty, SD, are in -C the respective arrays XDATA(*), YDATA(*), and -C SDDATA(*). No sorting of XDATA(*) is -C required. Any non-negative value of NDATA is -C allowed. A negative value of NDATA is an -C error. A zero value for any entry of -C SDDATA(*) will weight that data point as 1. -C Otherwise the weight of that data point is -C the reciprocal of this entry. -C -C NORD,NBKPT, -C BKPT(*) -C The NBKPT knots of the B-spline of order NORD -C are in the array BKPT(*). Normally the -C problem data interval will be included between -C the limits BKPT(NORD) and BKPT(NBKPT-NORD+1). -C The additional end knots BKPT(I),I=1,..., -C NORD-1 and I=NBKPT-NORD+2,...,NBKPT, are -C required to compute the functions used to fit -C the data. No sorting of BKPT(*) is required. -C Internal to DEFC( ) the extreme end knots may -C be reduced and increased respectively to -C accommodate any data values that are exterior -C to the given knot values. The contents of -C BKPT(*) is not changed. -C -C NORD must be in the range 1 .LE. NORD .LE. 20. -C The value of NBKPT must satisfy the condition -C NBKPT .GE. 2*NORD. -C Other values are considered errors. -C -C (The order of the spline is one more than the -C degree of the piecewise polynomial defined on -C each interval. This is consistent with the -C B-spline package convention. For example, -C NORD=4 when we are using piecewise cubics.) -C -C MDEIN -C An integer flag, with one of two possible -C values (1 or 2), that directs the subprogram -C action with regard to new data points provided -C by the user. -C -C =1 The first time that DEFC( ) has been -C entered. There are NDATA points to process. -C -C =2 This is another entry to DEFC(). The sub- -C program DEFC( ) has been entered with MDEIN=1 -C exactly once before for this problem. There -C are NDATA new additional points to merge and -C process with any previous points. -C (When using DEFC( ) with MDEIN=2 it is import- -C ant that the set of knots remain fixed at the -C same values for all entries to DEFC( ).) -C LW -C The amount of working storage actually -C allocated for the working array W(*). -C This quantity is compared with the -C actual amount of storage needed in DEFC( ). -C Insufficient storage allocated for W(*) is -C an error. This feature was included in DEFC -C because misreading the storage formula -C for W(*) might very well lead to subtle -C and hard-to-find programming bugs. -C -C The length of the array W(*) must satisfy -C -C LW .GE. (NBKPT-NORD+3)*(NORD+1)+ -C (NBKPT+1)*(NORD+1)+ -C 2*MAX(NDATA,NBKPT)+NBKPT+NORD**2 -C -C Output.. All TYPE REAL variables are DOUBLE PRECISION -C MDEOUT -C An output flag that indicates the status -C of the curve fit. -C -C =-1 A usage error of DEFC( ) occurred. The -C offending condition is noted with the SLATEC -C library error processor, XERMSG( ). In case -C the working array W(*) is not long enough, the -C minimal acceptable length is printed. -C -C =1 The B-spline coefficients for the fitted -C curve have been returned in array COEFF(*). -C -C =2 Not enough data has been processed to -C determine the B-spline coefficients. -C The user has one of two options. Continue -C to process more data until a unique set -C of coefficients is obtained, or use the -C subprogram DFC( ) to obtain a specific -C set of coefficients. The user should read -C the usage instructions for DFC( ) for further -C details if this second option is chosen. -C COEFF(*) -C If the output value of MDEOUT=1, this array -C contains the unknowns obtained from the least -C squares fitting process. These N=NBKPT-NORD -C parameters are the B-spline coefficients. -C For MDEOUT=2, not enough data was processed to -C uniquely determine the B-spline coefficients. -C In this case, and also when MDEOUT=-1, all -C values of COEFF(*) are set to zero. -C -C If the user is not satisfied with the fitted -C curve returned by DEFC( ), the constrained -C least squares curve fitting subprogram DFC( ) -C may be required. The work done within DEFC( ) -C to accumulate the data can be utilized by -C the user, if so desired. This involves -C saving the first (NBKPT-NORD+3)*(NORD+1) -C entries of W(*) and providing this data -C to DFC( ) with the "old problem" designation. -C The user should read the usage instructions -C for subprogram DFC( ) for further details. -C -C Working Array.. All TYPE REAL variables are DOUBLE PRECISION -C W(*) -C This array is typed DOUBLE PRECISION. -C Its length is specified as an input parameter -C in LW as noted above. The contents of W(*) -C must not be modified by the user between calls -C to DEFC( ) with values of MDEIN=1,2,2,... . -C The first (NBKPT-NORD+3)*(NORD+1) entries of -C W(*) are acceptable as direct input to DFC( ) -C for an "old problem" only when MDEOUT=1 or 2. -C -C Evaluating the -C Fitted Curve.. -C To evaluate derivative number IDER at XVAL, -C use the function subprogram DBVALU( ). -C -C F = DBVALU(BKPT,COEFF,NBKPT-NORD,NORD,IDER, -C XVAL,INBV,WORKB) -C -C The output of this subprogram will not be -C defined unless an output value of MDEOUT=1 -C was obtained from DEFC( ), XVAL is in the data -C interval, and IDER is nonnegative and .LT. -C NORD. -C -C The first time DBVALU( ) is called, INBV=1 -C must be specified. This value of INBV is the -C overwritten by DBVALU( ). The array WORKB(*) -C must be of length at least 3*NORD, and must -C not be the same as the W(*) array used in the -C call to DEFC( ). -C -C DBVALU( ) expects the breakpoint array BKPT(*) -C to be sorted. -C -C***REFERENCES R. J. Hanson, Constrained least squares curve fitting -C to discrete data using B-splines, a users guide, -C Report SAND78-1291, Sandia Laboratories, December -C 1978. -C***ROUTINES CALLED DEFCMN -C***REVISION HISTORY (YYMMDD) -C 800801 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 900510 Change Prologue comments to refer to XERMSG. (RWC) -C 900607 Editorial changes to Prologue to make Prologues for EFC, -C DEFC, FC, and DFC look as much the same as possible. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DEFC -C -C SUBROUTINE FUNCTION/REMARKS -C -C DBSPVN( ) COMPUTE FUNCTION VALUES OF B-SPLINES. FROM -C THE B-SPLINE PACKAGE OF DE BOOR NOTED ABOVE. -C -C DBNDAC( ), BANDED LEAST SQUARES MATRIX PROCESSORS. -C DBNDSL( ) FROM LAWSON-HANSON, SOLVING LEAST -C SQUARES PROBLEMS. -C -C DSORT( ) DATA SORTING SUBROUTINE, FROM THE -C SANDIA MATH. LIBRARY, SAND77-1441. -C -C XERMSG( ) ERROR HANDLING ROUTINE -C FOR THE SLATEC MATH. LIBRARY. -C SEE SAND78-1189, BY R. E. JONES. -C -C DCOPY( ),DSCAL( ) SUBROUTINES FROM THE BLAS PACKAGE. -C -C WRITTEN BY R. HANSON, SANDIA NATL. LABS., -C ALB., N. M., AUGUST-SEPTEMBER, 1980. -C - DOUBLE PRECISION BKPT(*),COEFF(*),W(*),SDDATA(*),XDATA(*),YDATA(*) - INTEGER LW, MDEIN, MDEOUT, NBKPT, NDATA, NORD -C - EXTERNAL DEFCMN -C - INTEGER LBF, LBKPT, LG, LPTEMP, LWW, LXTEMP, MDG, MDW -C -C***FIRST EXECUTABLE STATEMENT DEFC -C LWW=1 USAGE IN DEFCMN( ) OF W(*).. -C LWW,...,LG-1 W(*,*) -C -C LG,...,LXTEMP-1 G(*,*) -C -C LXTEMP,...,LPTEMP-1 XTEMP(*) -C -C LPTEMP,...,LBKPT-1 PTEMP(*) -C -C LBKPT,...,LBF BKPT(*) (LOCAL TO DEFCMN( )) -C -C LBF,...,LBF+NORD**2 BF(*,*) -C - MDG = NBKPT+1 - MDW = NBKPT-NORD+3 - LWW = 1 - LG = LWW + MDW*(NORD+1) - LXTEMP = LG + MDG*(NORD+1) - LPTEMP = LXTEMP + MAX(NDATA,NBKPT) - LBKPT = LPTEMP + MAX(NDATA,NBKPT) - LBF = LBKPT + NBKPT - CALL DEFCMN(NDATA,XDATA,YDATA,SDDATA, - 1 NORD,NBKPT,BKPT, - 2 MDEIN,MDEOUT, - 3 COEFF, - 4 W(LBF),W(LXTEMP),W(LPTEMP),W(LBKPT), - 5 W(LG),MDG,W(LWW),MDW,LW) - RETURN - END diff --git a/slatec/defcmn.f b/slatec/defcmn.f deleted file mode 100644 index 5d5673a..0000000 --- a/slatec/defcmn.f +++ /dev/null @@ -1,236 +0,0 @@ -*DECK DEFCMN - SUBROUTINE DEFCMN (NDATA, XDATA, YDATA, SDDATA, NORD, NBKPT, - + BKPTIN, MDEIN, MDEOUT, COEFF, BF, XTEMP, PTEMP, BKPT, G, MDG, - + W, MDW, LW) -C***BEGIN PROLOGUE DEFCMN -C***SUBSIDIARY -C***PURPOSE Subsidiary to DEFC -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (EFCMN-S, DEFCMN-D) -C***AUTHOR Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C This is a companion subprogram to DEFC( ). -C This subprogram does weighted least squares fitting of data by -C B-spline curves. -C The documentation for DEFC( ) has complete usage instructions. -C -C***SEE ALSO DEFC -C***ROUTINES CALLED DBNDAC, DBNDSL, DCOPY, DFSPVN, DSCAL, DSORT, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800801 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and extensively revised (WRB & RWC) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C 900604 DP version created from SP version. (RWC) -C***END PROLOGUE DEFCMN - INTEGER LW, MDEIN, MDEOUT, MDG, MDW, NBKPT, NDATA, NORD - DOUBLE PRECISION BF(NORD,*), BKPT(*), BKPTIN(*), COEFF(*), - * G(MDG,*), PTEMP(*), SDDATA(*), W(MDW,*), XDATA(*), XTEMP(*), - * YDATA(*) -C - EXTERNAL DBNDAC, DBNDSL, DCOPY, DFSPVN, DSCAL, DSORT, XERMSG -C - DOUBLE PRECISION DUMMY, RNORM, XMAX, XMIN, XVAL - INTEGER I, IDATA, ILEFT, INTSEQ, IP, IR, IROW, L, MT, N, NB, - * NORDM1, NORDP1, NP1 - CHARACTER*8 XERN1, XERN2 -C -C***FIRST EXECUTABLE STATEMENT DEFCMN -C -C Initialize variables and analyze input. -C - N = NBKPT - NORD - NP1 = N + 1 -C -C Initially set all output coefficients to zero. -C - CALL DCOPY (N, 0.D0, 0, COEFF, 1) - MDEOUT = -1 - IF (NORD.LT.1 .OR. NORD.GT.20) THEN - CALL XERMSG ('SLATEC', 'DEFCMN', - + 'IN DEFC, THE ORDER OF THE B-SPLINE MUST BE 1 THRU 20.', - + 3, 1) - RETURN - ENDIF -C - IF (NBKPT.LT.2*NORD) THEN - CALL XERMSG ('SLATEC', 'DEFCMN', - + 'IN DEFC, THE NUMBER OF KNOTS MUST BE AT LEAST TWICE ' // - + 'THE B-SPLINE ORDER.', 4, 1) - RETURN - ENDIF -C - IF (NDATA.LT.0) THEN - CALL XERMSG ('SLATEC', 'DEFCMN', - + 'IN DEFC, THE NUMBER OF DATA POINTS MUST BE NONNEGATIVE.', - + 5, 1) - RETURN - ENDIF -C - NB = (NBKPT-NORD+3)*(NORD+1) + (NBKPT+1)*(NORD+1) + - + 2*MAX(NBKPT,NDATA) + NBKPT + NORD**2 - IF (LW .LT. NB) THEN - WRITE (XERN1, '(I8)') NB - WRITE (XERN2, '(I8)') LW - CALL XERMSG ('SLATEC', 'DEFCMN', - * 'IN DEFC, INSUFFICIENT STORAGE FOR W(*). CHECK FORMULA ' // - * 'THAT READS LW.GE. ... . NEED = ' // XERN1 // - * ' GIVEN = ' // XERN2, 6, 1) - MDEOUT = -1 - RETURN - ENDIF -C - IF (MDEIN.NE.1 .AND. MDEIN.NE.2) THEN - CALL XERMSG ('SLATEC', 'DEFCMN', - + 'IN DEFC, INPUT VALUE OF MDEIN MUST BE 1-2.', 7, 1) - RETURN - ENDIF -C -C Sort the breakpoints. -C - CALL DCOPY (NBKPT, BKPTIN, 1, BKPT, 1) - CALL DSORT (BKPT, DUMMY, NBKPT, 1) -C -C Save interval containing knots. -C - XMIN = BKPT(NORD) - XMAX = BKPT(NP1) - NORDM1 = NORD - 1 - NORDP1 = NORD + 1 -C -C Process least squares equations. -C -C Sort data and an array of pointers. -C - CALL DCOPY (NDATA, XDATA, 1, XTEMP, 1) - DO 100 I = 1,NDATA - PTEMP(I) = I - 100 CONTINUE -C - IF (NDATA.GT.0) THEN - CALL DSORT (XTEMP, PTEMP, NDATA, 2) - XMIN = MIN(XMIN,XTEMP(1)) - XMAX = MAX(XMAX,XTEMP(NDATA)) - ENDIF -C -C Fix breakpoint array if needed. This should only involve very -C minor differences with the input array of breakpoints. -C - DO 110 I = 1,NORD - BKPT(I) = MIN(BKPT(I),XMIN) - 110 CONTINUE -C - DO 120 I = NP1,NBKPT - BKPT(I) = MAX(BKPT(I),XMAX) - 120 CONTINUE -C -C Initialize parameters of banded matrix processor, DBNDAC( ). -C - MT = 0 - IP = 1 - IR = 1 - ILEFT = NORD - INTSEQ = 1 - DO 150 IDATA = 1,NDATA -C -C Sorted indices are in PTEMP(*). -C - L = PTEMP(IDATA) - XVAL = XDATA(L) -C -C When interval changes, process equations in the last block. -C - IF (XVAL.GE.BKPT(ILEFT+1)) THEN - CALL DBNDAC (G, MDG, NORD, IP, IR, MT, ILEFT-NORDM1) - MT = 0 -C -C Move pointer up to have BKPT(ILEFT).LE.XVAL, ILEFT.LE.N. -C - DO 130 ILEFT = ILEFT,N - IF (XVAL.LT.BKPT(ILEFT+1)) GO TO 140 - IF (MDEIN.EQ.2) THEN -C -C Data is being sequentially accumulated. -C Transfer previously accumulated rows from W(*,*) to -C G(*,*) and process them. -C - CALL DCOPY (NORDP1, W(INTSEQ,1), MDW, G(IR,1), MDG) - CALL DBNDAC (G, MDG, NORD, IP, IR, 1, INTSEQ) - INTSEQ = INTSEQ + 1 - ENDIF - 130 CONTINUE - ENDIF -C -C Obtain B-spline function value. -C - 140 CALL DFSPVN (BKPT, NORD, 1, XVAL, ILEFT, BF) -C -C Move row into place. -C - IROW = IR + MT - MT = MT + 1 - CALL DCOPY (NORD, BF, 1, G(IROW,1), MDG) - G(IROW,NORDP1) = YDATA(L) -C -C Scale data if uncertainty is nonzero. -C - IF (SDDATA(L).NE.0.D0) CALL DSCAL (NORDP1, 1.D0/SDDATA(L), - + G(IROW,1), MDG) -C -C When staging work area is exhausted, process rows. -C - IF (IROW.EQ.MDG-1) THEN - CALL DBNDAC (G, MDG, NORD, IP, IR, MT, ILEFT-NORDM1) - MT = 0 - ENDIF - 150 CONTINUE -C -C Process last block of equations. -C - CALL DBNDAC (G, MDG, NORD, IP, IR, MT, ILEFT-NORDM1) -C -C Finish processing any previously accumulated rows from W(*,*) -C to G(*,*). -C - IF (MDEIN.EQ.2) THEN - DO 160 I = INTSEQ,NP1 - CALL DCOPY (NORDP1, W(I,1), MDW, G(IR,1), MDG) - CALL DBNDAC (G, MDG, NORD, IP, IR, 1, MIN(N,I)) - 160 CONTINUE - ENDIF -C -C Last call to adjust block positioning. -C - CALL DCOPY (NORDP1, 0.D0, 0, G(IR,1), MDG) - CALL DBNDAC (G, MDG, NORD, IP, IR, 1, NP1) -C -C Transfer accumulated rows from G(*,*) to W(*,*) for -C possible later sequential accumulation. -C - DO 170 I = 1,NP1 - CALL DCOPY (NORDP1, G(I,1), MDG, W(I,1), MDW) - 170 CONTINUE -C -C Solve for coefficients when possible. -C - DO 180 I = 1,N - IF (G(I,1).EQ.0.D0) THEN - MDEOUT = 2 - RETURN - ENDIF - 180 CONTINUE -C -C All the diagonal terms in the accumulated triangular -C matrix are nonzero. The solution can be computed but -C it may be unsuitable for further use due to poor -C conditioning or the lack of constraints. No checking -C for either of these is done here. -C - CALL DBNDSL (1, G, MDG, NORD, IP, IR, COEFF, N, RNORM) - MDEOUT = 1 - RETURN - END diff --git a/slatec/defe4.f b/slatec/defe4.f deleted file mode 100644 index 7bba0aa..0000000 --- a/slatec/defe4.f +++ /dev/null @@ -1,73 +0,0 @@ -*DECK DEFE4 - SUBROUTINE DEFE4 (COFX, IDMN, USOL, GRHS) -C***BEGIN PROLOGUE DEFE4 -C***SUBSIDIARY -C***PURPOSE Subsidiary to SEPX4 -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (DEFE4-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This subroutine first approximates the truncation error given by -C TRUN1(X,Y)=DLX**2*TX+DLY**2*TY where -C TX=AFUN(X)*UXXXX/12.0+BFUN(X)*UXXX/6.0 on the interior and -C at the boundaries if periodic (here UXXX,UXXXX are the third -C and fourth partial derivatives of U with respect to X). -C TX is of the form AFUN(X)/3.0*(UXXXX/4.0+UXXX/DLX) -C at X=A or X=B if the boundary condition there is mixed. -C TX=0.0 along specified boundaries. TY has symmetric form -C in Y with X,AFUN(X),BFUN(X) replaced by Y,DFUN(Y),EFUN(Y). -C The second order solution in USOL is used to approximate -C (via second order finite differencing) the truncation error -C and the result is added to the right hand side in GRHS -C and then transferred to USOL to be used as a new right -C hand side when calling BLKTRI for a fourth order solution. -C -C***SEE ALSO SEPX4 -C***ROUTINES CALLED DX4, DY4 -C***COMMON BLOCKS SPL4 -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE DEFE4 -C - COMMON /SPL4/ KSWX ,KSWY ,K ,L , - 1 AIT ,BIT ,CIT ,DIT , - 2 MIT ,NIT ,IS ,MS , - 3 JS ,NS ,DLX ,DLY , - 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 - DIMENSION GRHS(IDMN,*) ,USOL(IDMN,*) - EXTERNAL COFX -C***FIRST EXECUTABLE STATEMENT DEFE4 - DO 30 I=IS,MS - XI = AIT+(I-1)*DLX - CALL COFX (XI,AI,BI,CI) - DO 30 J=JS,NS -C -C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT (XI,YJ) -C - CALL DX4(USOL,IDMN,I,J,UXXX,UXXXX) - CALL DY4(USOL,IDMN,I,J,UYYY,UYYYY) - TX = AI*UXXXX/12.0+BI*UXXX/6.0 - TY=UYYYY/12.0 -C -C RESET FORM OF TRUNCATION IF AT BOUNDARY WHICH IS NON-PERIODIC -C - IF (KSWX.EQ.1 .OR. (I.GT.1 .AND. I.LT.K)) GO TO 10 - TX = AI/3.0*(UXXXX/4.0+UXXX/DLX) - 10 IF (KSWY.EQ.1 .OR. (J.GT.1 .AND. J.LT.L)) GO TO 20 - TY = (UYYYY/4.0+UYYY/DLY)/3.0 - 20 GRHS(I,J)=GRHS(I,J)+DLY**2*(DLX**2*TX+DLY**2*TY) - 30 CONTINUE -C -C RESET THE RIGHT HAND SIDE IN USOL -C - DO 60 I=IS,MS - DO 50 J=JS,NS - USOL(I,J) = GRHS(I,J) - 50 CONTINUE - 60 CONTINUE - RETURN - END diff --git a/slatec/defehl.f b/slatec/defehl.f deleted file mode 100644 index 7b666f7..0000000 --- a/slatec/defehl.f +++ /dev/null @@ -1,91 +0,0 @@ -*DECK DEFEHL - SUBROUTINE DEFEHL (F, NEQ, T, Y, H, YP, F1, F2, F3, F4, F5, YS, - + RPAR, IPAR) -C***BEGIN PROLOGUE DEFEHL -C***SUBSIDIARY -C***PURPOSE Subsidiary to DERKF -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (DEFEHL-S, DFEHL-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C Fehlberg Fourth-Fifth order Runge-Kutta Method -C ********************************************************************** -C -C DEFEHL integrates a system of NEQ first order -C ordinary differential equations of the form -C dU/DX = F(X,U) -C over one step when the vector Y(*) of initial values for U(*) and -C the vector YP(*) of initial derivatives, satisfying YP = F(T,Y), -C are given at the starting point X=T. -C -C DEFEHL advances the solution over the fixed step H and returns -C the fifth order (sixth order accurate locally) solution -C approximation at T+H in the array YS(*). -C F1,---,F5 are arrays of dimension NEQ which are needed -C for internal storage. -C The formulas have been grouped to control loss of significance. -C DEFEHL should be called with an H not smaller than 13 units of -C roundoff in T so that the various independent arguments can be -C distinguished. -C -C This subroutine has been written with all variables and statement -C numbers entirely compatible with DERKFS. For greater efficiency, -C the call to DEFEHL can be replaced by the module beginning with -C line 222 and extending to the last line just before the return -C statement. -C -C ********************************************************************** -C -C***SEE ALSO DERKF -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 800501 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891009 Removed unreferenced statement label. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DEFEHL -C -C - DIMENSION Y(*),YP(*),F1(*),F2(*),F3(*),F4(*),F5(*), - 1 YS(*),RPAR(*),IPAR(*) -C -C***FIRST EXECUTABLE STATEMENT DEFEHL - CH=H/4. - DO 230 K=1,NEQ - 230 YS(K)=Y(K)+CH*YP(K) - CALL F(T+CH,YS,F1,RPAR,IPAR) -C - CH=3.*H/32. - DO 240 K=1,NEQ - 240 YS(K)=Y(K)+CH*(YP(K)+3.*F1(K)) - CALL F(T+3.*H/8.,YS,F2,RPAR,IPAR) -C - CH=H/2197. - DO 250 K=1,NEQ - 250 YS(K)=Y(K)+CH*(1932.*YP(K)+(7296.*F2(K)-7200.*F1(K))) - CALL F(T+12.*H/13.,YS,F3,RPAR,IPAR) -C - CH=H/4104. - DO 260 K=1,NEQ - 260 YS(K)=Y(K)+CH*((8341.*YP(K)-845.*F3(K))+ - 1 (29440.*F2(K)-32832.*F1(K))) - CALL F(T+H,YS,F4,RPAR,IPAR) -C - CH=H/20520. - DO 270 K=1,NEQ - 270 YS(K)=Y(K)+CH*((-6080.*YP(K)+(9295.*F3(K)-5643.*F4(K)))+ - 1 (41040.*F1(K)-28352.*F2(K))) - CALL F(T+H/2.,YS,F5,RPAR,IPAR) -C -C COMPUTE APPROXIMATE SOLUTION AT T+H -C - CH=H/7618050. - DO 290 K=1,NEQ - 290 YS(K)=Y(K)+CH*((902880.*YP(K)+(3855735.*F3(K)-1371249.*F4(K)))+ - 1 (3953664.*F2(K)+277020.*F5(K))) -C - RETURN - END diff --git a/slatec/defer.f b/slatec/defer.f deleted file mode 100644 index 0a8bf5f..0000000 --- a/slatec/defer.f +++ /dev/null @@ -1,76 +0,0 @@ -*DECK DEFER - SUBROUTINE DEFER (COFX, COFY, IDMN, USOL, GRHS) -C***BEGIN PROLOGUE DEFER -C***SUBSIDIARY -C***PURPOSE Subsidiary to SEPELI -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (DEFER-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This subroutine first approximates the truncation error given by -C TRUN1(X,Y)=DLX**2*TX+DLY**2*TY where -C TX=AFUN(X)*UXXXX/12.0+BFUN(X)*UXXX/6.0 on the interior and -C at the boundaries if periodic (here UXXX,UXXXX are the third -C and fourth partial derivatives of U with respect to X). -C TX is of the form AFUN(X)/3.0*(UXXXX/4.0+UXXX/DLX) -C at X=A or X=B if the boundary condition there is mixed. -C TX=0.0 along specified boundaries. TY has symmetric form -C in Y with X,AFUN(X),BFUN(X) replaced by Y,DFUN(Y),EFUN(Y). -C The second order solution in USOL is used to approximate -C (via second order finite differencing) the truncation error -C and the result is added to the right hand side in GRHS -C and then transferred to USOL to be used as a new right -C hand side when calling BLKTRI for a fourth order solution. -C -C***SEE ALSO SEPELI -C***ROUTINES CALLED DX, DY -C***COMMON BLOCKS SPLPCM -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE DEFER -C - COMMON /SPLPCM/ KSWX ,KSWY ,K ,L , - 1 AIT ,BIT ,CIT ,DIT , - 2 MIT ,NIT ,IS ,MS , - 3 JS ,NS ,DLX ,DLY , - 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 - DIMENSION GRHS(IDMN,*) ,USOL(IDMN,*) - EXTERNAL COFX ,COFY -C***FIRST EXECUTABLE STATEMENT DEFER - DO 40 J=JS,NS - YJ = CIT+(J-1)*DLY - CALL COFY (YJ,DJ,EJ,FJ) - DO 30 I=IS,MS - XI = AIT+(I-1)*DLX - CALL COFX (XI,AI,BI,CI) -C -C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT (XI,YJ) -C - CALL DX (USOL,IDMN,I,J,UXXX,UXXXX) - CALL DY (USOL,IDMN,I,J,UYYY,UYYYY) - TX = AI*UXXXX/12.0+BI*UXXX/6.0 - TY = DJ*UYYYY/12.0+EJ*UYYY/6.0 -C -C RESET FORM OF TRUNCATION IF AT BOUNDARY WHICH IS NON-PERIODIC -C - IF (KSWX.EQ.1 .OR. (I.GT.1 .AND. I.LT.K)) GO TO 10 - TX = AI/3.0*(UXXXX/4.0+UXXX/DLX) - 10 IF (KSWY.EQ.1 .OR. (J.GT.1 .AND. J.LT.L)) GO TO 20 - TY = DJ/3.0*(UYYYY/4.0+UYYY/DLY) - 20 GRHS(I,J) = GRHS(I,J)+DLX**2*TX+DLY**2*TY - 30 CONTINUE - 40 CONTINUE -C -C RESET THE RIGHT HAND SIDE IN USOL -C - DO 60 I=IS,MS - DO 50 J=JS,NS - USOL(I,J) = GRHS(I,J) - 50 CONTINUE - 60 CONTINUE - RETURN - END diff --git a/slatec/dei.f b/slatec/dei.f deleted file mode 100644 index 4609ab8..0000000 --- a/slatec/dei.f +++ /dev/null @@ -1,35 +0,0 @@ -*DECK DEI - DOUBLE PRECISION FUNCTION DEI (X) -C***BEGIN PROLOGUE DEI -C***PURPOSE Compute the exponential integral Ei(X). -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C5 -C***TYPE DOUBLE PRECISION (EI-S, DEI-D) -C***KEYWORDS EI FUNCTION, EXPONENTIAL INTEGRAL, FNLIB, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DEI calculates the double precision exponential integral, Ei(X), for -C positive double precision argument X and the Cauchy principal value -C for negative X. If principal values are used everywhere, then, for -C all X, -C -C Ei(X) = -E1(-X) -C or -C E1(X) = -Ei(-X). -C -C***REFERENCES (NONE) -C***ROUTINES CALLED DE1 -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 891115 Modified prologue description. (WRB) -C 891115 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE DEI - DOUBLE PRECISION X, DE1 -C***FIRST EXECUTABLE STATEMENT DEI - DEI = -DE1(-X) -C - RETURN - END diff --git a/slatec/denorm.f b/slatec/denorm.f deleted file mode 100644 index 3ce3fdb..0000000 --- a/slatec/denorm.f +++ /dev/null @@ -1,116 +0,0 @@ -*DECK DENORM - DOUBLE PRECISION FUNCTION DENORM (N, X) -C***BEGIN PROLOGUE DENORM -C***SUBSIDIARY -C***PURPOSE Subsidiary to DNSQ and DNSQE -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (ENORM-S, DENORM-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Given an N-vector X, this function calculates the -C Euclidean norm of X. -C -C The Euclidean norm is computed by accumulating the sum of -C squares in three different sums. The sums of squares for the -C small and large components are scaled so that no overflows -C occur. Non-destructive underflows are permitted. Underflows -C and overflows do not occur in the computation of the unscaled -C sum of squares for the intermediate components. -C The definitions of small, intermediate and large components -C depend on two constants, RDWARF and RGIANT. The main -C restrictions on these constants are that RDWARF**2 not -C underflow and RGIANT**2 not overflow. The constants -C given here are suitable for every known computer. -C -C The function statement is -C -C DOUBLE PRECISION FUNCTION DENORM(N,X) -C -C where -C -C N is a positive integer input variable. -C -C X is an input array of length N. -C -C***SEE ALSO DNSQ, DNSQE -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DENORM - INTEGER I, N - DOUBLE PRECISION AGIANT, FLOATN, ONE, RDWARF, RGIANT, S1, S2, S3, - 1 X(*), X1MAX, X3MAX, XABS, ZERO - SAVE ONE, ZERO, RDWARF, RGIANT - DATA ONE,ZERO,RDWARF,RGIANT /1.0D0,0.0D0,3.834D-20,1.304D19/ -C***FIRST EXECUTABLE STATEMENT DENORM - S1 = ZERO - S2 = ZERO - S3 = ZERO - X1MAX = ZERO - X3MAX = ZERO - FLOATN = N - AGIANT = RGIANT/FLOATN - DO 90 I = 1, N - XABS = ABS(X(I)) - IF (XABS .GT. RDWARF .AND. XABS .LT. AGIANT) GO TO 70 - IF (XABS .LE. RDWARF) GO TO 30 -C -C SUM FOR LARGE COMPONENTS. -C - IF (XABS .LE. X1MAX) GO TO 10 - S1 = ONE + S1*(X1MAX/XABS)**2 - X1MAX = XABS - GO TO 20 - 10 CONTINUE - S1 = S1 + (XABS/X1MAX)**2 - 20 CONTINUE - GO TO 60 - 30 CONTINUE -C -C SUM FOR SMALL COMPONENTS. -C - IF (XABS .LE. X3MAX) GO TO 40 - S3 = ONE + S3*(X3MAX/XABS)**2 - X3MAX = XABS - GO TO 50 - 40 CONTINUE - IF (XABS .NE. ZERO) S3 = S3 + (XABS/X3MAX)**2 - 50 CONTINUE - 60 CONTINUE - GO TO 80 - 70 CONTINUE -C -C SUM FOR INTERMEDIATE COMPONENTS. -C - S2 = S2 + XABS**2 - 80 CONTINUE - 90 CONTINUE -C -C CALCULATION OF NORM. -C - IF (S1 .EQ. ZERO) GO TO 100 - DENORM = X1MAX*SQRT(S1+(S2/X1MAX)/X1MAX) - GO TO 130 - 100 CONTINUE - IF (S2 .EQ. ZERO) GO TO 110 - IF (S2 .GE. X3MAX) - 1 DENORM = SQRT(S2*(ONE+(X3MAX/S2)*(X3MAX*S3))) - IF (S2 .LT. X3MAX) - 1 DENORM = SQRT(X3MAX*((S2/X3MAX)+(X3MAX*S3))) - GO TO 120 - 110 CONTINUE - DENORM = X3MAX*SQRT(S3) - 120 CONTINUE - 130 CONTINUE - RETURN -C -C LAST CARD OF FUNCTION DENORM. -C - END diff --git a/slatec/derf.f b/slatec/derf.f deleted file mode 100644 index 60d05fd..0000000 --- a/slatec/derf.f +++ /dev/null @@ -1,83 +0,0 @@ -*DECK DERF - DOUBLE PRECISION FUNCTION DERF (X) -C***BEGIN PROLOGUE DERF -C***PURPOSE Compute the error function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C8A, L5A1E -C***TYPE DOUBLE PRECISION (ERF-S, DERF-D) -C***KEYWORDS ERF, ERROR FUNCTION, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DERF(X) calculates the double precision error function for double -C precision argument X. -C -C Series for ERF on the interval 0. to 1.00000E+00 -C with weighted error 1.28E-32 -C log weighted error 31.89 -C significant figures required 31.05 -C decimal places required 32.55 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DCSEVL, DERFC, INITDS -C***REVISION HISTORY (YYMMDD) -C 770701 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 900727 Added EXTERNAL statement. (WRB) -C 920618 Removed space from variable name. (RWC, WRB) -C***END PROLOGUE DERF - DOUBLE PRECISION X, ERFCS(21), SQEPS, SQRTPI, XBIG, Y, D1MACH, - 1 DCSEVL, DERFC - LOGICAL FIRST - EXTERNAL DERFC - SAVE ERFCS, SQRTPI, NTERF, XBIG, SQEPS, FIRST - DATA ERFCS( 1) / -.4904612123 4691808039 9845440333 76 D-1 / - DATA ERFCS( 2) / -.1422612051 0371364237 8247418996 31 D+0 / - DATA ERFCS( 3) / +.1003558218 7599795575 7546767129 33 D-1 / - DATA ERFCS( 4) / -.5768764699 7674847650 8270255091 67 D-3 / - DATA ERFCS( 5) / +.2741993125 2196061034 4221607914 71 D-4 / - DATA ERFCS( 6) / -.1104317550 7344507604 1353812959 05 D-5 / - DATA ERFCS( 7) / +.3848875542 0345036949 9613114981 74 D-7 / - DATA ERFCS( 8) / -.1180858253 3875466969 6317518015 81 D-8 / - DATA ERFCS( 9) / +.3233421582 6050909646 4029309533 54 D-10 / - DATA ERFCS( 10) / -.7991015947 0045487581 6073747085 95 D-12 / - DATA ERFCS( 11) / +.1799072511 3961455611 9672454866 34 D-13 / - DATA ERFCS( 12) / -.3718635487 8186926382 3168282094 93 D-15 / - DATA ERFCS( 13) / +.7103599003 7142529711 6899083946 66 D-17 / - DATA ERFCS( 14) / -.1261245511 9155225832 4954248533 33 D-18 / - DATA ERFCS( 15) / +.2091640694 1769294369 1705002666 66 D-20 / - DATA ERFCS( 16) / -.3253973102 9314072982 3641600000 00 D-22 / - DATA ERFCS( 17) / +.4766867209 7976748332 3733333333 33 D-24 / - DATA ERFCS( 18) / -.6598012078 2851343155 1999999999 99 D-26 / - DATA ERFCS( 19) / +.8655011469 9637626197 3333333333 33 D-28 / - DATA ERFCS( 20) / -.1078892517 7498064213 3333333333 33 D-29 / - DATA ERFCS( 21) / +.1281188399 3017002666 6666666666 66 D-31 / - DATA SQRTPI / 1.772453850 9055160272 9816748334 115D0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DERF - IF (FIRST) THEN - NTERF = INITDS (ERFCS, 21, 0.1*REAL(D1MACH(3))) - XBIG = SQRT(-LOG(SQRTPI*D1MACH(3))) - SQEPS = SQRT(2.0D0*D1MACH(3)) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.1.D0) GO TO 20 -C -C ERF(X) = 1.0 - ERFC(X) FOR -1.0 .LE. X .LE. 1.0 -C - IF (Y.LE.SQEPS) DERF = 2.0D0*X*X/SQRTPI - IF (Y.GT.SQEPS) DERF = X*(1.0D0 + DCSEVL (2.D0*X*X-1.D0, - 1 ERFCS, NTERF)) - RETURN -C -C ERF(X) = 1.0 - ERFC(X) FOR ABS(X) .GT. 1.0 -C - 20 IF (Y.LE.XBIG) DERF = SIGN (1.0D0-DERFC(Y), X) - IF (Y.GT.XBIG) DERF = SIGN (1.0D0, X) -C - RETURN - END diff --git a/slatec/derfc.f b/slatec/derfc.f deleted file mode 100644 index 9d1326e..0000000 --- a/slatec/derfc.f +++ /dev/null @@ -1,226 +0,0 @@ -*DECK DERFC - DOUBLE PRECISION FUNCTION DERFC (X) -C***BEGIN PROLOGUE DERFC -C***PURPOSE Compute the complementary error function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C8A, L5A1E -C***TYPE DOUBLE PRECISION (ERFC-S, DERFC-D) -C***KEYWORDS COMPLEMENTARY ERROR FUNCTION, ERFC, FNLIB, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DERFC(X) calculates the double precision complementary error function -C for double precision argument X. -C -C Series for ERF on the interval 0. to 1.00000E+00 -C with weighted Error 1.28E-32 -C log weighted Error 31.89 -C significant figures required 31.05 -C decimal places required 32.55 -C -C Series for ERC2 on the interval 2.50000E-01 to 1.00000E+00 -C with weighted Error 2.67E-32 -C log weighted Error 31.57 -C significant figures required 30.31 -C decimal places required 32.42 -C -C Series for ERFC on the interval 0. to 2.50000E-01 -C with weighted error 1.53E-31 -C log weighted error 30.82 -C significant figures required 29.47 -C decimal places required 31.70 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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 920618 Removed space from variable names. (RWC, WRB) -C***END PROLOGUE DERFC - DOUBLE PRECISION X, ERFCS(21), ERFCCS(59), ERC2CS(49), SQEPS, - 1 SQRTPI, XMAX, TXMAX, XSML, Y, D1MACH, DCSEVL - LOGICAL FIRST - SAVE ERFCS, ERC2CS, ERFCCS, SQRTPI, NTERF, - 1 NTERFC, NTERC2, XSML, XMAX, SQEPS, FIRST - DATA ERFCS( 1) / -.4904612123 4691808039 9845440333 76 D-1 / - DATA ERFCS( 2) / -.1422612051 0371364237 8247418996 31 D+0 / - DATA ERFCS( 3) / +.1003558218 7599795575 7546767129 33 D-1 / - DATA ERFCS( 4) / -.5768764699 7674847650 8270255091 67 D-3 / - DATA ERFCS( 5) / +.2741993125 2196061034 4221607914 71 D-4 / - DATA ERFCS( 6) / -.1104317550 7344507604 1353812959 05 D-5 / - DATA ERFCS( 7) / +.3848875542 0345036949 9613114981 74 D-7 / - DATA ERFCS( 8) / -.1180858253 3875466969 6317518015 81 D-8 / - DATA ERFCS( 9) / +.3233421582 6050909646 4029309533 54 D-10 / - DATA ERFCS( 10) / -.7991015947 0045487581 6073747085 95 D-12 / - DATA ERFCS( 11) / +.1799072511 3961455611 9672454866 34 D-13 / - DATA ERFCS( 12) / -.3718635487 8186926382 3168282094 93 D-15 / - DATA ERFCS( 13) / +.7103599003 7142529711 6899083946 66 D-17 / - DATA ERFCS( 14) / -.1261245511 9155225832 4954248533 33 D-18 / - DATA ERFCS( 15) / +.2091640694 1769294369 1705002666 66 D-20 / - DATA ERFCS( 16) / -.3253973102 9314072982 3641600000 00 D-22 / - DATA ERFCS( 17) / +.4766867209 7976748332 3733333333 33 D-24 / - DATA ERFCS( 18) / -.6598012078 2851343155 1999999999 99 D-26 / - DATA ERFCS( 19) / +.8655011469 9637626197 3333333333 33 D-28 / - DATA ERFCS( 20) / -.1078892517 7498064213 3333333333 33 D-29 / - DATA ERFCS( 21) / +.1281188399 3017002666 6666666666 66 D-31 / - DATA ERC2CS( 1) / -.6960134660 2309501127 3915082619 7 D-1 / - DATA ERC2CS( 2) / -.4110133936 2620893489 8221208466 6 D-1 / - DATA ERC2CS( 3) / +.3914495866 6896268815 6114370524 4 D-2 / - DATA ERC2CS( 4) / -.4906395650 5489791612 8093545077 4 D-3 / - DATA ERC2CS( 5) / +.7157479001 3770363807 6089414182 5 D-4 / - DATA ERC2CS( 6) / -.1153071634 1312328338 0823284791 2 D-4 / - DATA ERC2CS( 7) / +.1994670590 2019976350 5231486770 9 D-5 / - DATA ERC2CS( 8) / -.3642666471 5992228739 3611843071 1 D-6 / - DATA ERC2CS( 9) / +.6944372610 0050125899 3127721463 3 D-7 / - DATA ERC2CS( 10) / -.1371220902 1043660195 3460514121 0 D-7 / - DATA ERC2CS( 11) / +.2788389661 0071371319 6386034808 7 D-8 / - DATA ERC2CS( 12) / -.5814164724 3311615518 6479105031 6 D-9 / - DATA ERC2CS( 13) / +.1238920491 7527531811 8016881795 0 D-9 / - DATA ERC2CS( 14) / -.2690639145 3067434323 9042493788 9 D-10 / - DATA ERC2CS( 15) / +.5942614350 8479109824 4470968384 0 D-11 / - DATA ERC2CS( 16) / -.1332386735 7581195792 8775442057 0 D-11 / - DATA ERC2CS( 17) / +.3028046806 1771320171 7369724330 4 D-12 / - DATA ERC2CS( 18) / -.6966648814 9410325887 9586758895 4 D-13 / - DATA ERC2CS( 19) / +.1620854541 0539229698 1289322762 8 D-13 / - DATA ERC2CS( 20) / -.3809934465 2504919998 7691305772 9 D-14 / - DATA ERC2CS( 21) / +.9040487815 9788311493 6897101297 5 D-15 / - DATA ERC2CS( 22) / -.2164006195 0896073478 0981204700 3 D-15 / - DATA ERC2CS( 23) / +.5222102233 9958549846 0798024417 2 D-16 / - DATA ERC2CS( 24) / -.1269729602 3645553363 7241552778 0 D-16 / - DATA ERC2CS( 25) / +.3109145504 2761975838 3622741295 1 D-17 / - DATA ERC2CS( 26) / -.7663762920 3203855240 0956671481 1 D-18 / - DATA ERC2CS( 27) / +.1900819251 3627452025 3692973329 0 D-18 / - DATA ERC2CS( 28) / -.4742207279 0690395452 2565599996 5 D-19 / - DATA ERC2CS( 29) / +.1189649200 0765283828 8068307845 1 D-19 / - DATA ERC2CS( 30) / -.3000035590 3257802568 4527131306 6 D-20 / - DATA ERC2CS( 31) / +.7602993453 0432461730 1938527709 8 D-21 / - DATA ERC2CS( 32) / -.1935909447 6068728815 6981104913 0 D-21 / - DATA ERC2CS( 33) / +.4951399124 7733378810 0004238677 3 D-22 / - DATA ERC2CS( 34) / -.1271807481 3363718796 0862198988 8 D-22 / - DATA ERC2CS( 35) / +.3280049600 4695130433 1584165205 3 D-23 / - DATA ERC2CS( 36) / -.8492320176 8228965689 2479242239 9 D-24 / - DATA ERC2CS( 37) / +.2206917892 8075602235 1987998719 9 D-24 / - DATA ERC2CS( 38) / -.5755617245 6965284983 1281950719 9 D-25 / - DATA ERC2CS( 39) / +.1506191533 6392342503 5414405119 9 D-25 / - DATA ERC2CS( 40) / -.3954502959 0187969531 0428569599 9 D-26 / - DATA ERC2CS( 41) / +.1041529704 1515009799 8464505173 3 D-26 / - DATA ERC2CS( 42) / -.2751487795 2787650794 5017890133 3 D-27 / - DATA ERC2CS( 43) / +.7290058205 4975574089 9770368000 0 D-28 / - DATA ERC2CS( 44) / -.1936939645 9159478040 7750109866 6 D-28 / - DATA ERC2CS( 45) / +.5160357112 0514872983 7005482666 6 D-29 / - DATA ERC2CS( 46) / -.1378419322 1930940993 8964480000 0 D-29 / - DATA ERC2CS( 47) / +.3691326793 1070690422 5109333333 3 D-30 / - DATA ERC2CS( 48) / -.9909389590 6243654206 5322666666 6 D-31 / - DATA ERC2CS( 49) / +.2666491705 1953884133 2394666666 6 D-31 / - DATA ERFCCS( 1) / +.7151793102 0292477450 3697709496 D-1 / - DATA ERFCCS( 2) / -.2653243433 7606715755 8893386681 D-1 / - DATA ERFCCS( 3) / +.1711153977 9208558833 2699194606 D-2 / - DATA ERFCCS( 4) / -.1637516634 5851788416 3746404749 D-3 / - DATA ERFCCS( 5) / +.1987129350 0552036499 5974806758 D-4 / - DATA ERFCCS( 6) / -.2843712412 7665550875 0175183152 D-5 / - DATA ERFCCS( 7) / +.4606161308 9631303696 9379968464 D-6 / - DATA ERFCCS( 8) / -.8227753025 8792084205 7766536366 D-7 / - DATA ERFCCS( 9) / +.1592141872 7709011298 9358340826 D-7 / - DATA ERFCCS( 10) / -.3295071362 2528432148 6631665072 D-8 / - DATA ERFCCS( 11) / +.7223439760 4005554658 1261153890 D-9 / - DATA ERFCCS( 12) / -.1664855813 3987295934 4695966886 D-9 / - DATA ERFCCS( 13) / +.4010392588 2376648207 7671768814 D-10 / - DATA ERFCCS( 14) / -.1004816214 4257311327 2170176283 D-10 / - DATA ERFCCS( 15) / +.2608275913 3003338085 9341009439 D-11 / - DATA ERFCCS( 16) / -.6991110560 4040248655 7697812476 D-12 / - DATA ERFCCS( 17) / +.1929492333 2617070862 4205749803 D-12 / - DATA ERFCCS( 18) / -.5470131188 7543310649 0125085271 D-13 / - DATA ERFCCS( 19) / +.1589663309 7626974483 9084032762 D-13 / - DATA ERFCCS( 20) / -.4726893980 1975548392 0369584290 D-14 / - DATA ERFCCS( 21) / +.1435873376 7849847867 2873997840 D-14 / - DATA ERFCCS( 22) / -.4449510561 8173583941 7250062829 D-15 / - DATA ERFCCS( 23) / +.1404810884 7682334373 7305537466 D-15 / - DATA ERFCCS( 24) / -.4513818387 7642108962 5963281623 D-16 / - DATA ERFCCS( 25) / +.1474521541 0451330778 7018713262 D-16 / - DATA ERFCCS( 26) / -.4892621406 9457761543 6841552532 D-17 / - DATA ERFCCS( 27) / +.1647612141 4106467389 5301522827 D-17 / - DATA ERFCCS( 28) / -.5626817176 3294080929 9928521323 D-18 / - DATA ERFCCS( 29) / +.1947443382 2320785142 9197867821 D-18 / - DATA ERFCCS( 30) / -.6826305642 9484207295 6664144723 D-19 / - DATA ERFCCS( 31) / +.2421988887 2986492401 8301125438 D-19 / - DATA ERFCCS( 32) / -.8693414133 5030704256 3800861857 D-20 / - DATA ERFCCS( 33) / +.3155180346 2280855712 2363401262 D-20 / - DATA ERFCCS( 34) / -.1157372324 0496087426 1239486742 D-20 / - DATA ERFCCS( 35) / +.4288947161 6056539462 3737097442 D-21 / - DATA ERFCCS( 36) / -.1605030742 0576168500 5737770964 D-21 / - DATA ERFCCS( 37) / +.6063298757 4538026449 5069923027 D-22 / - DATA ERFCCS( 38) / -.2311404251 6979584909 8840801367 D-22 / - DATA ERFCCS( 39) / +.8888778540 6618855255 4702955697 D-23 / - DATA ERFCCS( 40) / -.3447260576 6513765223 0718495566 D-23 / - DATA ERFCCS( 41) / +.1347865460 2069650682 7582774181 D-23 / - DATA ERFCCS( 42) / -.5311794071 1250217364 5873201807 D-24 / - DATA ERFCCS( 43) / +.2109341058 6197831682 8954734537 D-24 / - DATA ERFCCS( 44) / -.8438365587 9237891159 8133256738 D-25 / - DATA ERFCCS( 45) / +.3399982524 9452089062 7359576337 D-25 / - DATA ERFCCS( 46) / -.1379452388 0732420900 2238377110 D-25 / - DATA ERFCCS( 47) / +.5634490311 8332526151 3392634811 D-26 / - DATA ERFCCS( 48) / -.2316490434 4770654482 3427752700 D-26 / - DATA ERFCCS( 49) / +.9584462844 6018101526 3158381226 D-27 / - DATA ERFCCS( 50) / -.3990722880 3301097262 4224850193 D-27 / - DATA ERFCCS( 51) / +.1672129225 9444773601 7228709669 D-27 / - DATA ERFCCS( 52) / -.7045991522 7660138563 8803782587 D-28 / - DATA ERFCCS( 53) / +.2979768402 8642063541 2357989444 D-28 / - DATA ERFCCS( 54) / -.1262522466 4606192972 2422632994 D-28 / - DATA ERFCCS( 55) / +.5395438704 5424879398 5299653154 D-29 / - DATA ERFCCS( 56) / -.2380992882 5314591867 5346190062 D-29 / - DATA ERFCCS( 57) / +.1099052830 1027615735 9726683750 D-29 / - DATA ERFCCS( 58) / -.4867713741 6449657273 2518677435 D-30 / - DATA ERFCCS( 59) / +.1525877264 1103575676 3200828211 D-30 / - DATA SQRTPI / 1.772453850 9055160272 9816748334 115D0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DERFC - IF (FIRST) THEN - ETA = 0.1*REAL(D1MACH(3)) - NTERF = INITDS (ERFCS, 21, ETA) - NTERFC = INITDS (ERFCCS, 59, ETA) - NTERC2 = INITDS (ERC2CS, 49, ETA) -C - XSML = -SQRT(-LOG(SQRTPI*D1MACH(3))) - TXMAX = SQRT(-LOG(SQRTPI*D1MACH(1))) - XMAX = TXMAX - 0.5D0*LOG(TXMAX)/TXMAX - 0.01D0 - SQEPS = SQRT(2.0D0*D1MACH(3)) - ENDIF - FIRST = .FALSE. -C - IF (X.GT.XSML) GO TO 20 -C -C ERFC(X) = 1.0 - ERF(X) FOR X .LT. XSML -C - DERFC = 2.0D0 - RETURN -C - 20 IF (X.GT.XMAX) GO TO 40 - Y = ABS(X) - IF (Y.GT.1.0D0) GO TO 30 -C -C ERFC(X) = 1.0 - ERF(X) FOR ABS(X) .LE. 1.0 -C - IF (Y.LT.SQEPS) DERFC = 1.0D0 - 2.0D0*X/SQRTPI - IF (Y.GE.SQEPS) DERFC = 1.0D0 - X*(1.0D0 + DCSEVL (2.D0*X*X-1.D0, - 1 ERFCS, NTERF)) - RETURN -C -C ERFC(X) = 1.0 - ERF(X) FOR 1.0 .LT. ABS(X) .LE. XMAX -C - 30 Y = Y*Y - IF (Y.LE.4.D0) DERFC = EXP(-Y)/ABS(X) * (0.5D0 + DCSEVL ( - 1 (8.D0/Y-5.D0)/3.D0, ERC2CS, NTERC2) ) - IF (Y.GT.4.D0) DERFC = EXP(-Y)/ABS(X) * (0.5D0 + DCSEVL ( - 1 8.D0/Y-1.D0, ERFCCS, NTERFC) ) - IF (X.LT.0.D0) DERFC = 2.0D0 - DERFC - RETURN -C - 40 CALL XERMSG ('SLATEC', 'DERFC', 'X SO BIG ERFC UNDERFLOWS', 1, 1) - DERFC = 0.D0 - RETURN -C - END diff --git a/slatec/derkf.f b/slatec/derkf.f deleted file mode 100644 index 7d4274a..0000000 --- a/slatec/derkf.f +++ /dev/null @@ -1,688 +0,0 @@ -*DECK DERKF - SUBROUTINE DERKF (F, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, - + RWORK, LRW, IWORK, LIW, RPAR, IPAR) -C***BEGIN PROLOGUE DERKF -C***PURPOSE Solve an initial value problem in ordinary differential -C equations using a Runge-Kutta-Fehlberg scheme. -C***LIBRARY SLATEC (DEPAC) -C***CATEGORY I1A1A -C***TYPE SINGLE PRECISION (DERKF-S, DDERKF-D) -C***KEYWORDS DEPAC, INITIAL VALUE PROBLEMS, ODE, -C ORDINARY DIFFERENTIAL EQUATIONS, RKF, -C RUNGE-KUTTA-FEHLBERG METHODS -C***AUTHOR Watts, H. A., (SNLA) -C Shampine, L. F., (SNLA) -C***DESCRIPTION -C -C This is the Runge-Kutta code in the package of differential equation -C solvers DEPAC, consisting of the codes DERKF, DEABM, and DEBDF. -C Design of the package was by L. F. Shampine and H. A. Watts. -C It is documented in -C SAND-79-2374 , DEPAC - Design of a User Oriented Package of ODE -C Solvers. -C DERKF is a driver for a modification of the code RKF45 written by -C H. A. Watts and L. F. Shampine -C Sandia Laboratories -C Albuquerque, New Mexico 87185 -C -C ********************************************************************** -C ** DEPAC PACKAGE OVERVIEW ** -C ********************************************************************** -C -C You have a choice of three differential equation solvers from -C DEPAC. The following brief descriptions are meant to aid you -C in choosing the most appropriate code for your problem. -C -C DERKF is a fifth order Runge-Kutta code. It is the simplest of -C the three choices, both algorithmically and in the use of the -C code. DERKF is primarily designed to solve non-stiff and mild- -C ly stiff differential equations when derivative evaluations are -C not expensive. It should generally not be used to get high -C accuracy results nor answers at a great many specific points. -C Because DERKF has very low overhead costs, it will usually -C result in the least expensive integration when solving -C problems requiring a modest amount of accuracy and having -C equations that are not costly to evaluate. DERKF attempts to -C discover when it is not suitable for the task posed. -C -C DEABM is a variable order (one through twelve) Adams code. Its -C complexity lies somewhere between that of DERKF and DEBDF. -C DEABM is primarily designed to solve non-stiff and mildly -C stiff differential equations when derivative evaluations are -C expensive, high accuracy results are needed or answers at -C many specific points are required. DEABM attempts to discover -C when it is not suitable for the task posed. -C -C DEBDF is a variable order (one through five) backward -C differentiation formula code. It is the most complicated of -C the three choices. DEBDF is primarily designed to solve stiff -C differential equations at crude to moderate tolerances. -C If the problem is very stiff at all, DERKF and DEABM will be -C quite inefficient compared to DEBDF. However, DEBDF will be -C inefficient compared to DERKF and DEABM on non-stiff problems -C because it uses much more storage, has a much larger overhead, -C and the low order formulas will not give high accuracies -C efficiently. -C -C The concept of stiffness cannot be described in a few words. -C If you do not know the problem to be stiff, try either DERKF -C or DEABM. Both of these codes will inform you of stiffness -C when the cost of solving such problems becomes important. -C -C ********************************************************************** -C ** ABSTRACT ** -C ********************************************************************** -C -C Subroutine DERKF uses a Runge-Kutta-Fehlberg (4,5) method to -C integrate a system of NEQ first order ordinary differential -C equations of the form -C DU/DX = F(X,U) -C when the vector Y(*) of initial values for U(*) at X=T is given. -C The subroutine integrates from T to TOUT. It is easy to continue the -C integration to get results at additional TOUT. This is the interval -C mode of operation. It is also easy for the routine to return with -C the solution at each intermediate step on the way to TOUT. This is -C the intermediate-output mode of operation. -C -C DERKF uses subprograms DERKFS, DEFEHL, HSTART, HVNRM, R1MACH, and -C the error handling routine XERMSG. The only machine dependent -C parameters to be assigned appear in R1MACH. -C -C ********************************************************************** -C ** DESCRIPTION OF THE ARGUMENTS TO DERKF (AN OVERVIEW) ** -C ********************************************************************** -C -C The Parameters are: -C -C F -- This is the name of a subroutine which you provide to -C define the differential equations. -C -C NEQ -- This is the number of (first order) differential -C equations to be integrated. -C -C T -- This is a value of the independent variable. -C -C Y(*) -- This array contains the solution components at T. -C -C TOUT -- This is a point at which a solution is desired. -C -C INFO(*) -- The basic task of the code is to integrate the -C differential equations from T to TOUT and return an -C answer at TOUT. INFO(*) is an INTEGER array which is used -C to communicate exactly how you want this task to be -C carried out. -C -C RTOL, ATOL -- These quantities represent relative and absolute -C error tolerances which you provide to indicate how -C accurately you wish the solution to be computed. You may -C choose them to be both scalars or else both vectors. -C -C IDID -- This scalar quantity is an indicator reporting what -C the code did. You must monitor this INTEGER variable to -C decide what action to take next. -C -C RWORK(*), LRW -- RWORK(*) is a REAL work array of length LRW -C which provides the code with needed storage space. -C -C IWORK(*), LIW -- IWORK(*) is an INTEGER work array of length LIW -C which provides the code with needed storage space and an -C across call flag. -C -C RPAR, IPAR -- These are REAL and INTEGER parameter arrays which -C you can use for communication between your calling -C program and the F subroutine. -C -C Quantities which are used as input items are -C NEQ, T, Y(*), TOUT, INFO(*), -C RTOL, ATOL, LRW and LIW. -C -C Quantities which may be altered by the code are -C T, Y(*), INFO(1), RTOL, ATOL, -C IDID, RWORK(*) and IWORK(*). -C -C ********************************************************************** -C ** INPUT -- What to do On The First Call To DERKF ** -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 F -- Provide a subroutine of the form -C F(X,U,UPRIME,RPAR,IPAR) -C to define the system of first order differential equations -C which is to be solved. For the given values of X and the -C vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must -C evaluate the NEQ components of the system of differential -C equations DU/DX=F(X,U) and store the derivatives in the -C array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for -C equations I=1,...,NEQ. -C -C Subroutine F must not alter X or U(*). You must declare -C the name F in an external statement in your program that -C calls DERKF. You must dimension U and UPRIME in F. -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 F. They are not used or altered by DERKF. -C If you do not need RPAR or IPAR, ignore these parameters -C by treating them as dummy arguments. If you do choose to -C use them, dimension them in your calling program and in F -C as arrays of appropriate length. -C -C NEQ -- Set it to the number of differential equations. -C (NEQ .GE. 1) -C -C T -- Set it to the initial point of the integration. -C You must use a program variable for T because the code -C changes its value. -C -C Y(*) -- Set this vector to the initial values of the NEQ solution -C components at the initial point. You must dimension Y at -C least NEQ in your calling program. -C -C TOUT -- Set it to the first point at which a solution -C is desired. You can take TOUT = T, in which case the code -C will evaluate the derivative of the solution at T and -C return. Integration either forward in T (TOUT .GT. T) or -C backward in T (TOUT .LT. T) is permitted. -C -C The code advances the solution from T to TOUT using -C step sizes which are automatically selected so as to -C achieve the desired accuracy. If you wish, the code will -C return with the solution and its derivative following -C each intermediate step (intermediate-output mode) so that -C you can monitor them, but you still must provide TOUT in -C accord with the basic aim of the code. -C -C The first step taken by the code is a critical one -C because it must reflect how fast the solution changes near -C the initial point. The code automatically selects an -C initial step size which is practically always suitable for -C the problem. By using the fact that the code will not -C step past TOUT in the first step, you could, if necessary, -C restrict the length of the initial step size. -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. Since DERKF will never step past a TOUT point, -C you need only make sure that no TOUT lies beyond TSTOP. -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 15 to accommodate other members of -C DEPAC or possible future extensions, though DERKF uses -C only the first three entries. You must respond to all of -C the following items which are arranged as questions. The -C simplest use of the code corresponds to answering all -C questions as YES ,i.e. setting all entries of INFO to 0. -C -C INFO(1) -- This parameter enables the code to initialize -C itself. You must set it to indicate the start of every -C new 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 vectors. -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 -C of TOUT by steps. If you wish, it will return the -C computed solution and derivative at the next -C intermediate step (the intermediate-output mode). -C This is a good way to proceed if you want to see the -C behavior of the solution. If you must have solutions at -C a great many specific TOUT points, this code is -C INEFFICIENT. The code DEABM in DEPAC handles this task -C more 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 RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) -C error tolerances to tell the code how accurately you want -C the solution to be computed. They must be defined as -C program variables because the code may change them. You -C have two choices -- -C Both RTOL and ATOL are scalars. (INFO(2)=0) -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 test -C at each step which requires roughly that -C ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL -C for each vector component. -C (More specifically, a maximum norm is used to measure -C the size of vectors, and the error test uses the average -C of the magnitude of the solution at the beginning and end -C of the step.) -C -C The true (global) error is the difference between the true -C solution of the initial value problem and the computed -C approximation. Practically all present day codes, -C including this one, control the local error at each step -C and do not even attempt to control the global error -C directly. Roughly speaking, they produce a solution Y(T) -C which satisfies the differential equations with a -C residual R(T), DY(T)/DT = F(T,Y(T)) + R(T) , -C and, almost always, R(T) is bounded by the error -C tolerances. Usually, but not always, the true accuracy of -C the computed Y is comparable to the error tolerances. This -C code will usually, but not always, deliver a more accurate -C solution if you reduce the tolerances and integrate again. -C By comparing two such solutions you can get a fairly -C reliable idea of the true error in the solution at the -C bigger tolerances. -C -C Setting ATOL=0. results in a pure relative error test on -C that component. Setting RTOL=0. yields a pure absolute -C error test on that component. A mixed test with non-zero -C RTOL and ATOL corresponds roughly to a relative error -C test when the solution component is much bigger than ATOL -C and to an absolute error test when the solution component -C is smaller than the threshold ATOL. -C -C Proper selection of the absolute error control parameters -C ATOL requires you to have some idea of the scale of the -C solution components. To acquire this information may mean -C that you will have to solve the problem more than once. In -C the absence of scale information, you should ask for some -C relative accuracy in all the components (by setting RTOL -C values non-zero) and perhaps impose extremely small -C absolute error tolerances to protect against the danger of -C a solution component becoming zero. -C -C The code will not attempt to compute a solution at an -C accuracy unreasonable for the machine being used. It will -C advise you if you ask for too much accuracy and inform -C you as to the maximum accuracy it believes possible. -C If you want relative accuracies smaller than about -C 10**(-8), you should not ordinarily use DERKF. The code -C DEABM in DEPAC obtains stringent accuracies more -C efficiently. -C -C RWORK(*) -- Dimension this REAL work array of length LRW in your -C calling program. -C -C LRW -- Set it to the declared length of the RWORK array. -C You must have LRW .GE. 33+7*NEQ -C -C IWORK(*) -- Dimension this INTEGER work array of length LIW in -C your calling program. -C -C LIW -- Set it to the declared length of the IWORK array. -C You must have LIW .GE. 34 -C -C RPAR, IPAR -- These are parameter arrays, of REAL and INTEGER -C type, respectively. You can use them for communication -C between your program that calls DERKF and the F -C subroutine. They are not used or altered by DERKF. If -C you do not need RPAR or IPAR, ignore these parameters by -C treating them as dummy arguments. If you do choose to use -C them, dimension them in your calling program and in F as -C arrays of appropriate length. -C -C ********************************************************************** -C ** OUTPUT -- After any return from DERKF ** -C ********************************************************************** -C -C The principal aim of the code is to return a computed solution at -C TOUT, although it is also possible to obtain intermediate results -C along the way. To find out whether the code achieved its goal -C or if the integration process was interrupted before the task was -C completed, you must check the IDID parameter. -C -C -C T -- The solution was successfully advanced to the -C output value of T. -C -C Y(*) -- Contains the computed solution approximation at T. -C You may also be interested in the approximate derivative -C of the solution at T. It is contained in -C RWORK(21),...,RWORK(20+NEQ). -C -C IDID -- Reports what the code did -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 TOUT was successfully -C completed (T=TOUT) by stepping exactly to TOUT. -C -C *** Task Interrupted *** -C Reported by negative values of IDID -C -C IDID = -1 -- A large amount of work has been expended. -C (500 steps attempted) -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 -C component is zero. Thus, a pure relative error -C test is impossible for this component. -C -C IDID = -4 -- The problem appears to be stiff. -C -C IDID = -5 -- DERKF is being used very inefficiently -C because the natural step size is being -C restricted by too frequent output. -C -C IDID = -6,-7,..,-32 -- Not applicable for this code but -C used by other members of DEPAC or possible -C future extensions. -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 -C occurs 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 be -C appropriate for continuing the integration. However, the -C reported solution at T was obtained using the input values -C of RTOL and ATOL. -C -C RWORK, IWORK -- Contain information which is usually of no -C interest to the user but necessary for subsequent calls. -C However, you may find use for -C -C RWORK(11)--which contains the step size H to be -C attempted on the next step. -C -C RWORK(12)--If the tolerances have been increased by the -C code (IDID = -2) , they were multiplied by the -C value in RWORK(12). -C -C RWORK(20+I)--which contains the approximate derivative -C of the solution component Y(I). In DERKF, it -C is always obtained by calling subroutine F to -C evaluate the differential equation using T and -C Y(*). -C -C ********************************************************************** -C ** INPUT -- What To Do To Continue The Integration ** -C ** (calls after the first) ** -C ********************************************************************** -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 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, -C in particular do not alter NEQ, T, Y(*), RWORK(*), IWORK(*) or -C the differential equation in subroutine F. Any such alteration -C constitutes a new problem and must be treated as such, i.e. -C you must start afresh. -C -C You cannot change from vector to scalar error control or vice -C versa (INFO(2)) but you can change the size of the entries of -C RTOL, 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 The parameter INFO(1) is used by the code to indicate the -C beginning of a new problem and to indicate whether integration -C is to be continued. You must input the value INFO(1) = 0 -C when starting a new problem. You must input the value -C INFO(1) = 1 if you wish to continue after an interrupted task. -C Do not set INFO(1) = 0 on a continuation call unless you -C want the code to restart at the current T. -C -C *** Following a Completed Task *** -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, 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 *** Following an Interrupted Task *** -C To show the code that you realize the task was -C interrupted and that you want to continue, you -C must take appropriate action and reset INFO(1) = 1 -C If -C IDID = -1, the code has attempted 500 steps. -C If you want to continue, set INFO(1) = 1 and -C call the code again. An additional 500 steps -C will be allowed. -C -C IDID = -2, the error tolerances RTOL, ATOL have been -C increased to values the code estimates appropriate -C for continuing. You may want to change them -C yourself. If you are sure you want to continue -C with relaxed error tolerances, set INFO(1)=1 and -C call the code 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 -C alter the error criterion to use positive values -C for those components of ATOL corresponding to zero -C solution components, then set INFO(1)=1 and call -C the code again. -C -C IDID = -4, the problem appears to be stiff. It is very -C inefficient to solve such problems with DERKF. -C Code DEBDF in DEPAC handles this task efficiently. -C If you are absolutely sure you want to continue -C with DERKF, set INFO(1)=1 and call the code again. -C -C IDID = -5, you are using DERKF very inefficiently by -C choosing output points TOUT so close together that -C the step size is repeatedly forced to be rather -C smaller than necessary. If you are willing to -C accept solutions at the steps chosen by the code, -C a good way to proceed is to use the intermediate -C output mode (setting INFO(3)=1). If you must have -C solutions at so many specific TOUT points, the -C code DEABM in DEPAC handles this task -C efficiently. If you want to continue with DERKF, -C set INFO(1)=1 and call the code again. -C -C IDID = -6,-7,..,-32 --- cannot occur with this code but -C used by other members of DEPAC or possible future -C extensions. -C -C *** Following a Terminated Task *** -C If -C IDID = -33, you cannot continue the solution of this -C problem. An attempt to do so will result in your -C run being terminated. -C -C ********************************************************************** -C *Long Description: -C -C ********************************************************************** -C ** DEPAC Package Overview ** -C ********************************************************************** -C -C .... You have a choice of three differential equation solvers from -C .... DEPAC. The following brief descriptions are meant to aid you in -C .... choosing the most appropriate code for your problem. -C -C .... DERKF is a fifth order Runge-Kutta code. It is the simplest of -C .... the three choices, both algorithmically and in the use of the -C .... code. DERKF is primarily designed to solve non-stiff and -C .... mildly stiff differential equations when derivative evaluations -C .... are not expensive. It should generally not be used to get high -C .... accuracy results nor answers at a great many specific points. -C .... Because DERKF has very low overhead costs, it will usually -C .... result in the least expensive integration when solving -C .... problems requiring a modest amount of accuracy and having -C .... equations that are not costly to evaluate. DERKF attempts to -C .... discover when it is not suitable for the task posed. -C -C .... DEABM is a variable order (one through twelve) Adams code. -C .... Its complexity lies somewhere between that of DERKF and -C .... DEBDF. DEABM is primarily designed to solve non-stiff and -C .... mildly stiff differential equations when derivative evaluations -C .... are expensive, high accuracy results are needed or answers at -C .... many specific points are required. DEABM attempts to discover -C .... when it is not suitable for the task posed. -C -C .... DEBDF is a variable order (one through five) backward -C .... differentiation formula code. it is the most complicated of -C .... the three choices. DEBDF is primarily designed to solve stiff -C .... differential equations at crude to moderate tolerances. -C .... If the problem is very stiff at all, DERKF and DEABM will be -C .... quite inefficient compared to DEBDF. However, DEBDF will be -C .... inefficient compared to DERKF and DEABM on non-stiff problems -C .... because it uses much more storage, has a much larger overhead, -C .... and the low order formulas will not give high accuracies -C .... efficiently. -C -C .... The concept of stiffness cannot be described in a few words. -C .... If you do not know the problem to be stiff, try either DERKF -C .... or DEABM. Both of these codes will inform you of stiffness -C .... when the cost of solving such problems becomes important. -C -C ********************************************************************* -C -C***REFERENCES L. F. Shampine and H. A. Watts, DEPAC - design of a user -C oriented package of ODE solvers, Report SAND79-2374, -C Sandia Laboratories, 1979. -C L. F. Shampine and H. A. Watts, Practical solution of -C ordinary differential equations by Runge-Kutta -C methods, Report SAND76-0585, Sandia Laboratories, -C 1976. -C***ROUTINES CALLED DERKFS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800501 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891024 Changed references from VNORM to HVNRM. (WRB) -C 891024 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900510 Convert XERRWV calls to XERMSG calls, change Prologue -C comments to agree with DDERKF. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DERKF -C - LOGICAL STIFF,NONSTF - CHARACTER*8 XERN1 - CHARACTER*16 XERN3 -C - DIMENSION Y(*),INFO(15),RTOL(*),ATOL(*),RWORK(*),IWORK(*), - 1 RPAR(*),IPAR(*) -C - EXTERNAL F -C -C CHECK FOR AN APPARENT INFINITE LOOP -C -C***FIRST EXECUTABLE STATEMENT DERKF - IF (INFO(1) .EQ. 0) IWORK(LIW) = 0 - IF (IWORK(LIW) .GE. 5) THEN - IF (T .EQ. RWORK(21+NEQ)) THEN - WRITE (XERN3, '(1PE15.6)') T - CALL XERMSG ('SLATEC', 'DERKF', - * 'AN APPARENT INFINITE LOOP HAS BEEN DETECTED.$$' // - * 'YOU HAVE MADE REPEATED CALLS AT T = ' // XERN3 // - * ' AND THE INTEGRATION HAS NOT ADVANCED. CHECK THE ' // - * 'WAY YOU HAVE SET PARAMETERS FOR THE CALL TO THE ' // - * 'CODE, PARTICULARLY INFO(1).', 13, 2) - RETURN - ENDIF - ENDIF -C -C CHECK LRW AND LIW FOR SUFFICIENT STORAGE ALLOCATION -C - IDID = 0 - IF (LRW .LT. 30 + 7*NEQ) THEN - WRITE (XERN1, '(I8)') LRW - CALL XERMSG ('SLATEC', 'DERKF', 'LENGTH OF RWORK ARRAY ' // - * 'MUST BE AT LEAST 30 + 7*NEQ. YOU HAVE CALLED THE ' // - * 'CODE WITH LRW = ' // XERN1, 1, 1) - IDID = -33 - ENDIF -C - IF (LIW .LT. 34) THEN - WRITE (XERN1, '(I8)') LIW - CALL XERMSG ('SLATEC', 'DERKF', 'LENGTH OF IWORK ARRAY ' // - * 'MUST BE AT LEAST 34. YOU HAVE CALLED THE CODE WITH ' // - * 'LIW = ' // XERN1, 2, 1) - IDID = -33 - ENDIF -C -C COMPUTE INDICES FOR THE SPLITTING OF THE RWORK ARRAY -C - KH = 11 - KTF = 12 - KYP = 21 - KTSTAR = KYP + NEQ - KF1 = KTSTAR + 1 - KF2 = KF1 + NEQ - KF3 = KF2 + NEQ - KF4 = KF3 + NEQ - KF5 = KF4 + NEQ - KYS = KF5 + NEQ - KTO = KYS + NEQ - KDI = KTO + 1 - KU = KDI + 1 - KRER = KU + 1 -C -C ********************************************************************** -C THIS INTERFACING ROUTINE MERELY RELIEVES THE USER OF A LONG -C CALLING LIST VIA THE SPLITTING APART OF TWO WORKING STORAGE -C ARRAYS. IF THIS IS NOT COMPATIBLE WITH THE USERS COMPILER, -C S/HE MUST USE DERKFS DIRECTLY. -C ********************************************************************** -C - RWORK(KTSTAR) = T - IF (INFO(1) .NE. 0) THEN - STIFF = (IWORK(25) .EQ. 0) - NONSTF = (IWORK(26) .EQ. 0) - ENDIF -C - CALL DERKFS(F,NEQ,T,Y,TOUT,INFO,RTOL,ATOL,IDID,RWORK(KH), - 1 RWORK(KTF),RWORK(KYP),RWORK(KF1),RWORK(KF2),RWORK(KF3), - 2 RWORK(KF4),RWORK(KF5),RWORK(KYS),RWORK(KTO),RWORK(KDI), - 3 RWORK(KU),RWORK(KRER),IWORK(21),IWORK(22),IWORK(23), - 4 IWORK(24),STIFF,NONSTF,IWORK(27),IWORK(28),RPAR,IPAR) -C - IWORK(25) = 1 - IF (STIFF) IWORK(25) = 0 - IWORK(26) = 1 - IF (NONSTF) IWORK(26) = 0 -C - IF (IDID .NE. (-2)) IWORK(LIW) = IWORK(LIW) + 1 - IF (T .NE. RWORK(KTSTAR)) IWORK(LIW) = 0 -C - RETURN - END diff --git a/slatec/derkfs.f b/slatec/derkfs.f deleted file mode 100644 index 1f5e940..0000000 --- a/slatec/derkfs.f +++ /dev/null @@ -1,592 +0,0 @@ -*DECK DERKFS - SUBROUTINE DERKFS (F, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, H, - + TOLFAC, YP, F1, F2, F3, F4, F5, YS, TOLD, DTSIGN, U26, RER, - + INIT, KSTEPS, KOP, IQUIT, STIFF, NONSTF, NTSTEP, NSTIFS, RPAR, - + IPAR) -C***BEGIN PROLOGUE DERKFS -C***SUBSIDIARY -C***PURPOSE Subsidiary to DERKF -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (DERKFS-S, DRKFS-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C Fehlberg Fourth-Fifth order Runge-Kutta Method -C ********************************************************************** -C -C DERKFS integrates a system of first order ordinary differential -C equations as described in the comments for DERKF . -C -C The arrays YP,F1,F2,F3,F4,F5,and YS (of length at least NEQ) -C appear in the call list for variable dimensioning purposes. -C -C The variables H,TOLFAC,TOLD,DTSIGN,U26,RER,INIT,KSTEPS,KOP,IQUIT, -C STIFF,NONSTF,NTSTEP, and NSTIFS are used internally by the code -C and appear in the call list to eliminate local retention of -C variables between calls. Accordingly, these variables and the -C array YP should not be altered. -C Items of possible interest are -C H - An appropriate step size to be used for the next step -C TOLFAC - Factor of change in the tolerances -C YP - Derivative of solution vector at T -C KSTEPS - Counter on the number of steps attempted -C -C ********************************************************************** -C -C***SEE ALSO DERKF -C***ROUTINES CALLED DEFEHL, HSTART, HVNRM, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800501 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891024 Changed references from VNORM to HVNRM. (WRB) -C 891024 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls, replace GOTOs with -C IF-THEN-ELSEs. (RWC) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DERKFS -C - LOGICAL HFAILD,OUTPUT,STIFF,NONSTF - CHARACTER*8 XERN1 - CHARACTER*16 XERN3, XERN4 -C - DIMENSION Y(*),YP(*),F1(*),F2(*),F3(*),F4(*),F5(*), - 1 YS(*),INFO(15),RTOL(*),ATOL(*),RPAR(*),IPAR(*) -C - EXTERNAL F -C -C....................................................................... -C -C A FIFTH ORDER METHOD WILL GENERALLY NOT BE CAPABLE OF DELIVERING -C ACCURACIES NEAR LIMITING PRECISION ON COMPUTERS WITH LONG -C WORDLENGTHS. TO PROTECT AGAINST LIMITING PRECISION DIFFICULTIES -C ARISING FROM UNREASONABLE ACCURACY REQUESTS, AN APPROPRIATE -C TOLERANCE THRESHOLD REMIN IS ASSIGNED FOR THIS METHOD. THIS VALUE -C SHOULD NOT BE CHANGED ACROSS DIFFERENT MACHINES. -C - SAVE REMIN, MXSTEP, MXKOP - DATA REMIN/1.E-12/ -C -C....................................................................... -C -C THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE -C NUMBER OF STEPS ATTEMPTED. WHEN THIS EXCEEDS MXSTEP, THE COUNTER -C IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE EXCESSIVE -C WORK. -C - DATA MXSTEP/500/ -C -C....................................................................... -C -C INEFFICIENCY CAUSED BY TOO FREQUENT OUTPUT IS MONITORED BY COUNTING -C THE NUMBER OF STEP SIZES WHICH ARE SEVERELY SHORTENED DUE SOLELY TO -C THE CHOICE OF OUTPUT POINTS. WHEN THE NUMBER OF ABUSES EXCEED MXKOP, -C THE COUNTER IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE -C MISUSE OF THE CODE. -C - DATA MXKOP/100/ -C -C....................................................................... -C -C***FIRST EXECUTABLE STATEMENT DERKFS - IF (INFO(1) .EQ. 0) THEN -C -C ON THE FIRST CALL , PERFORM INITIALIZATION -- -C DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY U BY CALLING THE -C FUNCTION ROUTINE R1MACH. THE USER MUST MAKE SURE THAT THE -C VALUES SET IN R1MACH ARE RELEVANT TO THE COMPUTER BEING USED. -C - U = R1MACH(4) -C -- SET ASSOCIATED MACHINE DEPENDENT PARAMETERS - U26 = 26.*U - RER = 2.*U+REMIN -C -- SET TERMINATION FLAG - IQUIT = 0 -C -- SET INITIALIZATION INDICATOR - INIT = 0 -C -- SET COUNTER FOR IMPACT OF OUTPUT POINTS - KOP = 0 -C -- SET COUNTER FOR ATTEMPTED STEPS - KSTEPS = 0 -C -- SET INDICATORS FOR STIFFNESS DETECTION - STIFF = .FALSE. - NONSTF = .FALSE. -C -- SET STEP COUNTERS FOR STIFFNESS DETECTION - NTSTEP = 0 - NSTIFS = 0 -C -- RESET INFO(1) FOR SUBSEQUENT CALLS - INFO(1) = 1 - ENDIF -C -C....................................................................... -C -C CHECK VALIDITY OF INPUT PARAMETERS ON EACH ENTRY -C - IF (INFO(1) .NE. 0 .AND. INFO(1) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(1) - CALL XERMSG ('SLATEC', 'DERKFS', - * 'IN DERKF, INFO(1) MUST BE SET TO 0 ' // - * 'FOR THE START OF A NEW PROBLEM, AND MUST BE SET TO 1 ' // - * 'FOLLOWING AN INTERRUPTED TASK. YOU ARE ATTEMPTING TO ' // - * 'CONTINUE THE INTEGRATION ILLEGALLY BY CALLING THE CODE ' // - * 'WITH INFO(1) = ' // XERN1, 3, 1) - IDID = -33 - ENDIF -C - IF (INFO(2) .NE. 0 .AND. INFO(2) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(2) - CALL XERMSG ('SLATEC', 'DERKFS', - * 'IN DERKF, INFO(2) MUST BE 0 OR 1 INDICATING SCALAR ' // - * 'AND VECTOR ERROR TOLERANCES, RESPECTIVELY. YOU HAVE ' // - * 'CALLED THE CODE WITH INFO(2) = ' // XERN1, 4, 1) - IDID = -33 - ENDIF -C - IF (INFO(3) .NE. 0 .AND. INFO(3) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(3) - CALL XERMSG ('SLATEC', 'DERKFS', - * 'IN DERKF, INFO(3) MUST BE 0 OR 1 INDICATING THE ' // - * 'OR INTERMEDIATE-OUTPUT MODE OF INTEGRATION, ' // - * 'RESPECTIVELY. YOU HAVE CALLED THE CODE ' // - * 'WITH INFO(3) = ' // XERN1, 5, 1) - IDID = -33 - ENDIF -C - IF (NEQ .LT. 1) THEN - WRITE (XERN1, '(I8)') NEQ - CALL XERMSG ('SLATEC', 'DERKFS', - * 'IN DERKF, THE NUMBER OF EQUATIONS NEQ MUST BE A ' // - * 'POSITIVE INTEGER. YOU HAVE CALLED THE ' // - * 'CODE WITH NEQ = ' // XERN1, 6, 1) - IDID = -33 - ENDIF -C - NRTOLP = 0 - NATOLP = 0 - DO 10 K=1,NEQ - IF (NRTOLP .EQ. 0 .AND. RTOL(K) .LT. 0.D0) THEN - WRITE (XERN1, '(I8)') K - WRITE (XERN3, '(1PE15.6)') RTOL(K) - CALL XERMSG ('SLATEC', 'DERKFS', - * 'IN DERKF, THE RELATIVE ERROR ' // - * 'TOLERANCES RTOL MUST BE NON-NEGATIVE. YOU HAVE ' // - * 'CALLED THE CODE WITH RTOL(' // XERN1 // ') = ' // - * XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // - * 'NO FURTHER CHECKING OF RTOL COMPONENTS IS DONE.', 7, 1) - IDID = -33 - NRTOLP = 1 - ENDIF -C - IF (NATOLP .EQ. 0 .AND. ATOL(K) .LT. 0.D0) THEN - WRITE (XERN1, '(I8)') K - WRITE (XERN3, '(1PE15.6)') ATOL(K) - CALL XERMSG ('SLATEC', 'DERKFS', - * 'IN DERKF, THE ABSOLUTE ERROR ' // - * 'TOLERANCES ATOL MUST BE NON-NEGATIVE. YOU HAVE ' // - * 'CALLED THE CODE WITH ATOL(' // XERN1 // ') = ' // - * XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // - * 'NO FURTHER CHECKING OF ATOL COMPONENTS IS DONE.', 8, 1) - IDID = -33 - NATOLP = 1 - ENDIF -C - IF (INFO(2) .EQ. 0) GO TO 20 - IF (NATOLP.GT.0 .AND. NRTOLP.GT.0) GO TO 20 - 10 CONTINUE -C -C -C CHECK SOME CONTINUATION POSSIBILITIES -C - 20 IF (INIT .NE. 0) THEN - IF (T .EQ. TOUT) THEN - WRITE (XERN3, '(1PE15.6)') T - CALL XERMSG ('SLATEC', 'DERKFS', - * 'IN DERKF, YOU HAVE CALLED THE ' // - * 'CODE WITH T = TOUT = ' // XERN3 // '$$THIS IS NOT ' // - * 'ALLOWED ON CONTINUATION CALLS.', 9, 1) - IDID=-33 - ENDIF -C - IF (T .NE. TOLD) THEN - WRITE (XERN3, '(1PE15.6)') TOLD - WRITE (XERN4, '(1PE15.6)') T - CALL XERMSG ('SLATEC', 'DERKFS', - * 'IN DERKF, YOU HAVE CHANGED THE ' // - * 'VALUE OF T FROM ' // XERN3 // ' TO ' // XERN4 // - * '$$THIS IS NOT ALLOWED ON CONTINUATION CALLS.', 10, 1) - IDID=-33 - ENDIF -C - IF (INIT .NE. 1) THEN - IF (DTSIGN*(TOUT-T) .LT. 0.D0) THEN - WRITE (XERN3, '(1PE15.6)') TOUT - CALL XERMSG ('SLATEC', 'DERKFS', - * 'IN DERKF, BY CALLING THE CODE ' // - * 'WITH TOUT = ' // XERN3 // ' YOU ARE ATTEMPTING ' // - * 'TO CHANGE THE DIRECTION OF INTEGRATION.$$THIS IS ' // - * 'NOT ALLOWED WITHOUT RESTARTING.', 11, 1) - IDID=-33 - ENDIF - ENDIF - ENDIF -C -C INVALID INPUT DETECTED -C - IF (IDID .EQ. (-33)) THEN - IF (IQUIT .NE. (-33)) THEN - IQUIT = -33 - GOTO 909 - ELSE - CALL XERMSG ('SLATEC', 'DERKFS', - * 'IN DERKF, INVALID INPUT WAS ' // - * 'DETECTED ON SUCCESSIVE ENTRIES. IT IS IMPOSSIBLE ' // - * 'TO PROCEED BECAUSE YOU HAVE NOT CORRECTED THE ' // - * 'PROBLEM, SO EXECUTION IS BEING TERMINATED.', 12, 2) - RETURN - ENDIF - ENDIF -C -C....................................................................... -C -C RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND INTERPRETED AS -C ASKING FOR THE MOST ACCURATE SOLUTION POSSIBLE. IN THIS CASE, -C THE RELATIVE ERROR TOLERANCE RTOL IS RESET TO THE SMALLEST VALUE -C RER WHICH IS LIKELY TO BE REASONABLE FOR THIS METHOD AND MACHINE. -C - DO 50 K=1,NEQ - IF (RTOL(K)+ATOL(K) .GT. 0.) GO TO 45 - RTOL(K)=RER - IDID=-2 - 45 IF (INFO(2) .EQ. 0) GO TO 55 - 50 CONTINUE -C - 55 IF (IDID .NE. (-2)) GO TO 60 -C -C RTOL=ATOL=0 ON INPUT, SO RTOL WAS CHANGED TO A -C SMALL POSITIVE VALUE - TOLFAC=1. - GO TO 909 -C -C BRANCH ON STATUS OF INITIALIZATION INDICATOR -C INIT=0 MEANS INITIAL DERIVATIVES AND STARTING STEP SIZE -C NOT YET COMPUTED -C INIT=1 MEANS STARTING STEP SIZE NOT YET COMPUTED -C INIT=2 MEANS NO FURTHER INITIALIZATION REQUIRED -C - 60 IF (INIT .EQ. 0) GO TO 65 - IF (INIT .EQ. 1) GO TO 70 - GO TO 80 -C -C....................................................................... -C -C MORE INITIALIZATION -- -C -- EVALUATE INITIAL DERIVATIVES -C - 65 INIT=1 - A=T - CALL F(A,Y,YP,RPAR,IPAR) - IF (T .EQ. TOUT) GO TO 666 -C -C -- SET SIGN OF INTEGRATION DIRECTION AND -C -- ESTIMATE STARTING STEP SIZE -C - 70 INIT=2 - DTSIGN=SIGN(1.,TOUT-T) - U=R1MACH(4) - BIG=SQRT(R1MACH(2)) - UTE=U**0.375 - DY=UTE*HVNRM(Y,NEQ) - IF (DY .EQ. 0.) DY=UTE - KTOL=1 - DO 75 K=1,NEQ - IF (INFO(2) .EQ. 1) KTOL=K - TOL=RTOL(KTOL)*ABS(Y(K))+ATOL(KTOL) - IF (TOL .EQ. 0.) TOL=DY*RTOL(KTOL) - 75 F1(K)=TOL -C - CALL HSTART (F,NEQ,T,TOUT,Y,YP,F1,4,U,BIG,F2,F3,F4,F5,RPAR,IPAR,H) -C -C....................................................................... -C -C SET STEP SIZE FOR INTEGRATION IN THE DIRECTION FROM T TO TOUT -C AND SET OUTPUT POINT INDICATOR -C - 80 DT=TOUT-T - H=SIGN(H,DT) - OUTPUT= .FALSE. -C -C TEST TO SEE IF DERKF IS BEING SEVERELY IMPACTED BY TOO MANY -C OUTPUT POINTS -C - IF (ABS(H) .GE. 2.*ABS(DT)) KOP=KOP+1 - IF (KOP .LE. MXKOP) GO TO 85 -C -C UNNECESSARY FREQUENCY OF OUTPUT IS RESTRICTING -C THE STEP SIZE CHOICE - IDID=-5 - KOP=0 - GO TO 909 -C - 85 IF (ABS(DT) .GT. U26*ABS(T)) GO TO 100 -C -C IF TOO CLOSE TO OUTPUT POINT,EXTRAPOLATE AND RETURN -C - DO 90 K=1,NEQ - 90 Y(K)=Y(K)+DT*YP(K) - A=TOUT - CALL F(A,Y,YP,RPAR,IPAR) - KSTEPS=KSTEPS+1 - GO TO 666 -C -C ********************************************************************** -C ********************************************************************** -C STEP BY STEP INTEGRATION -C - 100 HFAILD= .FALSE. -C -C TO PROTECT AGAINST IMPOSSIBLE ACCURACY REQUESTS, COMPUTE A -C TOLERANCE FACTOR BASED ON THE REQUESTED ERROR TOLERANCE AND A -C LEVEL OF ACCURACY ACHIEVABLE AT LIMITING PRECISION -C - TOLFAC=0. - KTOL=1 - DO 125 K=1,NEQ - IF (INFO(2) .EQ. 1) KTOL=K - ET=RTOL(KTOL)*ABS(Y(K))+ATOL(KTOL) - IF (ET .GT. 0.) GO TO 120 - TOLFAC=MAX(TOLFAC,RER/RTOL(KTOL)) - GO TO 125 - 120 TOLFAC=MAX(TOLFAC,ABS(Y(K))*(RER/ET)) - 125 CONTINUE - IF (TOLFAC .LE. 1.) GO TO 150 -C -C REQUESTED ERROR UNATTAINABLE DUE TO LIMITED -C PRECISION AVAILABLE - TOLFAC=2.*TOLFAC - IDID=-2 - GO TO 909 -C -C SET SMALLEST ALLOWABLE STEP SIZE -C - 150 HMIN=U26*ABS(T) -C -C ADJUST STEP SIZE IF NECESSARY TO HIT THE OUTPUT POINT -- -C LOOK AHEAD TWO STEPS TO AVOID DRASTIC CHANGES IN THE STEP SIZE AND -C THUS LESSEN THE IMPACT OF OUTPUT POINTS ON THE CODE. -C STRETCH THE STEP SIZE BY, AT MOST, AN AMOUNT EQUAL TO THE -C SAFETY FACTOR OF 9/10. -C - DT=TOUT-T - IF (ABS(DT) .GE. 2.*ABS(H)) GO TO 200 - IF (ABS(DT) .GT. ABS(H)/0.9) GO TO 175 -C -C THE NEXT STEP, IF SUCCESSFUL, WILL COMPLETE THE INTEGRATION TO -C THE OUTPUT POINT -C - OUTPUT= .TRUE. - H=DT - GO TO 200 -C - 175 H=0.5*DT -C -C -C ********************************************************************** -C CORE INTEGRATOR FOR TAKING A SINGLE STEP -C ********************************************************************** -C TO AVOID PROBLEMS WITH ZERO CROSSINGS, RELATIVE ERROR IS MEASURED -C USING THE AVERAGE OF THE MAGNITUDES OF THE SOLUTION AT THE -C BEGINNING AND END OF A STEP. -C THE ERROR ESTIMATE FORMULA HAS BEEN GROUPED TO CONTROL LOSS OF -C SIGNIFICANCE. -C LOCAL ERROR ESTIMATES FOR A FIRST ORDER METHOD USING THE SAME -C STEP SIZE AS THE FEHLBERG METHOD ARE CALCULATED AS PART OF THE -C TEST FOR STIFFNESS. -C TO DISTINGUISH THE VARIOUS ARGUMENTS, H IS NOT PERMITTED -C TO BECOME SMALLER THAN 26 UNITS OF ROUNDOFF IN T. -C PRACTICAL LIMITS ON THE CHANGE IN THE STEP SIZE ARE ENFORCED TO -C SMOOTH THE STEP SIZE SELECTION PROCESS AND TO AVOID EXCESSIVE -C CHATTERING ON PROBLEMS HAVING DISCONTINUITIES. -C TO PREVENT UNNECESSARY FAILURES, THE CODE USES 9/10 THE STEP SIZE -C IT ESTIMATES WILL SUCCEED. -C AFTER A STEP FAILURE, THE STEP SIZE IS NOT ALLOWED TO INCREASE FOR -C THE NEXT ATTEMPTED STEP. THIS MAKES THE CODE MORE EFFICIENT ON -C PROBLEMS HAVING DISCONTINUITIES AND MORE EFFECTIVE IN GENERAL -C SINCE LOCAL EXTRAPOLATION IS BEING USED AND EXTRA CAUTION SEEMS -C WARRANTED. -C....................................................................... -C -C MONITOR NUMBER OF STEPS ATTEMPTED -C - 200 IF (KSTEPS .LE. MXSTEP) GO TO 222 -C -C A SIGNIFICANT AMOUNT OF WORK HAS BEEN EXPENDED - IDID=-1 - KSTEPS=0 - IF (.NOT. STIFF) GO TO 909 -C -C PROBLEM APPEARS TO BE STIFF - IDID=-4 - STIFF= .FALSE. - NONSTF= .FALSE. - NTSTEP=0 - NSTIFS=0 - GO TO 909 -C -C ADVANCE AN APPROXIMATE SOLUTION OVER ONE STEP OF LENGTH H -C - 222 CALL DEFEHL(F,NEQ,T,Y,H,YP,F1,F2,F3,F4,F5,YS,RPAR,IPAR) - KSTEPS=KSTEPS+1 -C -C....................................................................... -C -C COMPUTE AND TEST ALLOWABLE TOLERANCES VERSUS LOCAL ERROR -C ESTIMATES. NOTE THAT RELATIVE ERROR IS MEASURED WITH RESPECT TO -C THE AVERAGE OF THE MAGNITUDES OF THE SOLUTION AT THE BEGINNING -C AND END OF THE STEP. -C LOCAL ERROR ESTIMATES FOR A SPECIAL FIRST ORDER METHOD ARE -C CALCULATED ONLY WHEN THE STIFFNESS DETECTION IS TURNED ON. -C - EEOET=0. - ESTIFF=0. - KTOL=1 - DO 350 K=1,NEQ - YAVG=0.5*(ABS(Y(K))+ABS(YS(K))) - IF (INFO(2) .EQ. 1) KTOL=K - ET=RTOL(KTOL)*YAVG+ATOL(KTOL) - IF (ET .GT. 0.) GO TO 325 -C -C PURE RELATIVE ERROR INAPPROPRIATE WHEN SOLUTION -C VANISHES - IDID=-3 - GO TO 909 -C - 325 EE=ABS((-2090.*YP(K)+(21970.*F3(K)-15048.*F4(K)))+ - 1 (22528.*F2(K)-27360.*F5(K))) - IF (STIFF .OR. NONSTF) GO TO 350 - ES=ABS(H*(0.055455*YP(K)-0.035493*F1(K)-0.036571*F2(K)+ - 1 0.023107*F3(K)-0.009515*F4(K)+0.003017*F5(K))) - ESTIFF=MAX(ESTIFF,ES/ET) - 350 EEOET=MAX(EEOET,EE/ET) -C - ESTTOL=ABS(H)*EEOET/752400. -C - IF (ESTTOL .LE. 1.) GO TO 500 -C -C....................................................................... -C -C UNSUCCESSFUL STEP -C - IF (ABS(H) .GT. HMIN) GO TO 400 -C -C REQUESTED ERROR UNATTAINABLE AT SMALLEST -C ALLOWABLE STEP SIZE - TOLFAC=1.69*ESTTOL - IDID=-2 - GO TO 909 -C -C REDUCE THE STEP SIZE , TRY AGAIN -C THE DECREASE IS LIMITED TO A FACTOR OF 1/10 -C - 400 HFAILD= .TRUE. - OUTPUT= .FALSE. - S=0.1 - IF (ESTTOL .LT. 59049.) S=0.9/ESTTOL**0.2 - H=SIGN(MAX(S*ABS(H),HMIN),H) - GO TO 200 -C -C....................................................................... -C -C SUCCESSFUL STEP -C STORE SOLUTION AT T+H -C AND EVALUATE DERIVATIVES THERE -C - 500 T=T+H - DO 525 K=1,NEQ - 525 Y(K)=YS(K) - A=T - CALL F(A,Y,YP,RPAR,IPAR) -C -C CHOOSE NEXT STEP SIZE -C THE INCREASE IS LIMITED TO A FACTOR OF 5 -C IF STEP FAILURE HAS JUST OCCURRED, NEXT -C STEP SIZE IS NOT ALLOWED TO INCREASE -C - S=5. - IF (ESTTOL .GT. 1.889568E-4) S=0.9/ESTTOL**0.2 - IF (HFAILD) S=MIN(S,1.) - H=SIGN(MAX(S*ABS(H),HMIN),H) -C -C....................................................................... -C -C CHECK FOR STIFFNESS (IF NOT ALREADY DETECTED) -C -C IN A SEQUENCE OF 50 SUCCESSFUL STEPS BY THE FEHLBERG METHOD, 25 -C SUCCESSFUL STEPS BY THE FIRST ORDER METHOD INDICATES STIFFNESS -C AND TURNS THE TEST OFF. IF 26 FAILURES BY THE FIRST ORDER METHOD -C OCCUR, THE TEST IS TURNED OFF UNTIL THIS SEQUENCE OF 50 STEPS -C BY THE FEHLBERG METHOD IS COMPLETED. -C - IF (STIFF) GO TO 600 - NTSTEP=MOD(NTSTEP+1,50) - IF (NTSTEP .EQ. 1) NONSTF= .FALSE. - IF (NONSTF) GO TO 600 - IF (ESTIFF .GT. 1.) GO TO 550 -C -C SUCCESSFUL STEP WITH FIRST ORDER METHOD - NSTIFS=NSTIFS+1 -C TURN TEST OFF AFTER 25 INDICATIONS OF STIFFNESS - IF (NSTIFS .EQ. 25) STIFF= .TRUE. - GO TO 600 -C -C UNSUCCESSFUL STEP WITH FIRST ORDER METHOD - 550 IF (NTSTEP-NSTIFS .LE. 25) GO TO 600 -C TURN STIFFNESS DETECTION OFF FOR THIS BLOCK OF -C FIFTY STEPS - NONSTF= .TRUE. -C RESET STIFF STEP COUNTER - NSTIFS=0 -C -C ********************************************************************** -C END OF CORE INTEGRATOR -C ********************************************************************** -C -C -C SHOULD WE TAKE ANOTHER STEP -C - 600 IF (OUTPUT) GO TO 666 - IF (INFO(3) .EQ. 0) GO TO 100 -C -C ********************************************************************** -C ********************************************************************** -C -C INTEGRATION SUCCESSFULLY COMPLETED -C -C ONE-STEP MODE - IDID=1 - TOLD=T - RETURN -C -C INTERVAL MODE - 666 IDID=2 - T=TOUT - TOLD=T - RETURN -C -C INTEGRATION TASK INTERRUPTED -C - 909 INFO(1)=-1 - TOLD=T - IF (IDID .NE. (-2)) RETURN -C -C THE ERROR TOLERANCES ARE INCREASED TO VALUES -C WHICH ARE APPROPRIATE FOR CONTINUING - RTOL(1)=TOLFAC*RTOL(1) - ATOL(1)=TOLFAC*ATOL(1) - IF (INFO(2) .EQ. 0) RETURN - DO 939 K=2,NEQ - RTOL(K)=TOLFAC*RTOL(K) - 939 ATOL(K)=TOLFAC*ATOL(K) - RETURN - END diff --git a/slatec/des.f b/slatec/des.f deleted file mode 100644 index 7e8ce1d..0000000 --- a/slatec/des.f +++ /dev/null @@ -1,433 +0,0 @@ -*DECK DES - SUBROUTINE DES (F, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, YPOUT, - + YP, YY, WT, P, PHI, ALPHA, BETA, PSI, V, W, SIG, G, GI, H, EPS, - + X, XOLD, HOLD, TOLD, DELSGN, TSTOP, TWOU, FOURU, START, PHASE1, - + NORND, STIFF, INTOUT, NS, KORD, KOLD, INIT, KSTEPS, KLE4, - + IQUIT, KPREV, IVC, IV, KGI, RPAR, IPAR) -C***BEGIN PROLOGUE DES -C***SUBSIDIARY -C***PURPOSE Subsidiary to DEABM -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (DES-S, DDES-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C DEABM merely allocates storage for DES to relieve the user of the -C inconvenience of a long call list. Consequently DES is used as -C described in the comments for DEABM . -C -C***SEE ALSO DEABM -C***ROUTINES CALLED R1MACH, SINTRP, STEPS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800501 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls, replace GOTOs with -C IF-THEN-ELSEs. (RWC) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DES -C - LOGICAL STIFF,CRASH,START,PHASE1,NORND,INTOUT -C - DIMENSION Y(*),YY(*),WT(*),PHI(NEQ,16),P(*),YP(*), - 1 YPOUT(*),PSI(12),ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13), - 2 GI(11),IV(10),INFO(15),RTOL(*),ATOL(*),RPAR(*),IPAR(*) - CHARACTER*8 XERN1 - CHARACTER*16 XERN3, XERN4 -C - EXTERNAL F -C -C....................................................................... -C -C THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE -C NUMBER OF STEPS ATTEMPTED. WHEN THIS EXCEEDS MAXNUM, THE COUNTER -C IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE EXCESSIVE -C WORK. -C - SAVE MAXNUM - DATA MAXNUM/500/ -C -C....................................................................... -C -C***FIRST EXECUTABLE STATEMENT DES - IF (INFO(1) .EQ. 0) THEN -C -C ON THE FIRST CALL , PERFORM INITIALIZATION -- -C DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY U BY CALLING THE -C FUNCTION ROUTINE R1MACH. THE USER MUST MAKE SURE THAT THE -C VALUES SET IN R1MACH ARE RELEVANT TO THE COMPUTER BEING USED. -C - U=R1MACH(4) -C -- SET ASSOCIATED MACHINE DEPENDENT PARAMETERS - TWOU=2.*U - FOURU=4.*U -C -- SET TERMINATION FLAG - IQUIT=0 -C -- SET INITIALIZATION INDICATOR - INIT=0 -C -- SET COUNTER FOR ATTEMPTED STEPS - KSTEPS=0 -C -- SET INDICATOR FOR INTERMEDIATE-OUTPUT - INTOUT= .FALSE. -C -- SET INDICATOR FOR STIFFNESS DETECTION - STIFF= .FALSE. -C -- SET STEP COUNTER FOR STIFFNESS DETECTION - KLE4=0 -C -- SET INDICATORS FOR STEPS CODE - START= .TRUE. - PHASE1= .TRUE. - NORND= .TRUE. -C -- RESET INFO(1) FOR SUBSEQUENT CALLS - INFO(1)=1 - ENDIF -C -C....................................................................... -C -C CHECK VALIDITY OF INPUT PARAMETERS ON EACH ENTRY -C - IF (INFO(1) .NE. 0 .AND. INFO(1) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(1) - CALL XERMSG ('SLATEC', 'DES', - * 'IN DEABM, INFO(1) MUST BE ' // - * 'SET TO 0 FOR THE START OF A NEW PROBLEM, AND MUST BE ' // - * 'SET TO 1 FOLLOWING AN INTERRUPTED TASK. YOU ARE ' // - * 'ATTEMPTING TO CONTINUE THE INTEGRATION ILLEGALLY BY ' // - * 'CALLING THE CODE WITH INFO(1) = ' // XERN1, 3, 1) - IDID=-33 - ENDIF -C - IF (INFO(2) .NE. 0 .AND. INFO(2) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(2) - CALL XERMSG ('SLATEC', 'DES', - * 'IN DEABM, INFO(2) MUST BE 0 OR 1 ' // - * 'INDICATING SCALAR AND VECTOR ERROR TOLERANCES, ' // - * 'RESPECTIVELY. YOU HAVE CALLED THE CODE WITH INFO(2) = ' // - * XERN1, 4, 1) - IDID=-33 - ENDIF -C - IF (INFO(3) .NE. 0 .AND. INFO(3) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(3) - CALL XERMSG ('SLATEC', 'DES', - * 'IN DEABM, INFO(3) MUST BE 0 OR 1 ' // - * 'INDICATING THE INTERVAL OR INTERMEDIATE-OUTPUT MODE OF ' // - * 'INTEGRATION, RESPECTIVELY. YOU HAVE CALLED THE CODE ' // - * 'WITH INFO(3) = ' // XERN1, 5, 1) - IDID=-33 - ENDIF -C - IF (INFO(4) .NE. 0 .AND. INFO(4) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(4) - CALL XERMSG ('SLATEC', 'DES', - * 'IN DEABM, INFO(4) MUST BE 0 OR 1 ' // - * 'INDICATING WHETHER OR NOT THE INTEGRATION INTERVAL IS ' // - * 'TO BE RESTRICTED BY A POINT TSTOP. YOU HAVE CALLED ' // - * 'THE CODE WITH INFO(4) = ' // XERN1, 14, 1) - IDID=-33 - ENDIF -C - IF (NEQ .LT. 1) THEN - WRITE (XERN1, '(I8)') NEQ - CALL XERMSG ('SLATEC', 'DES', - * 'IN DEABM, THE NUMBER OF EQUATIONS ' // - * 'NEQ MUST BE A POSITIVE INTEGER. YOU HAVE CALLED THE ' // - * 'CODE WITH NEQ = ' // XERN1, 6, 1) - IDID=-33 - ENDIF -C - NRTOLP = 0 - NATOLP = 0 - DO 90 K=1,NEQ - IF (NRTOLP .EQ. 0 .AND. RTOL(K) .LT. 0.) THEN - WRITE (XERN1, '(I8)') K - WRITE (XERN3, '(1PE15.6)') RTOL(K) - CALL XERMSG ('SLATEC', 'DES', - * 'IN DEABM, THE RELATIVE ERROR ' // - * 'TOLERANCES RTOL MUST BE NON-NEGATIVE. YOU HAVE ' // - * 'CALLED THE CODE WITH RTOL(' // XERN1 // ') = ' // - * XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // - * 'NO FURTHER CHECKING OF RTOL COMPONENTS IS DONE.', 7, 1) - IDID = -33 - NRTOLP = 1 - ENDIF -C - IF (NATOLP .EQ. 0 .AND. ATOL(K) .LT. 0.) THEN - WRITE (XERN1, '(I8)') K - WRITE (XERN3, '(1PE15.6)') ATOL(K) - CALL XERMSG ('SLATEC', 'DES', - * 'IN DEABM, THE ABSOLUTE ERROR ' // - * 'TOLERANCES ATOL MUST BE NON-NEGATIVE. YOU HAVE ' // - * 'CALLED THE CODE WITH ATOL(' // XERN1 // ') = ' // - * XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // - * 'NO FURTHER CHECKING OF ATOL COMPONENTS IS DONE.', 8, 1) - IDID = -33 - NATOLP = 1 - ENDIF -C - IF (INFO(2) .EQ. 0) GO TO 100 - IF (NATOLP.GT.0 .AND. NRTOLP.GT.0) GO TO 100 - 90 CONTINUE -C - 100 IF (INFO(4) .EQ. 1) THEN - IF (SIGN(1.,TOUT-T) .NE. SIGN(1.,TSTOP-T) - 1 .OR. ABS(TOUT-T) .GT. ABS(TSTOP-T)) THEN - WRITE (XERN3, '(1PE15.6)') TOUT - WRITE (XERN4, '(1PE15.6)') TSTOP - CALL XERMSG ('SLATEC', 'DES', - * 'IN DEABM, YOU HAVE CALLED THE ' // - * 'CODE WITH TOUT = ' // XERN3 // ' BUT YOU HAVE ' // - * 'ALSO TOLD THE CODE (INFO(4) = 1) NOT TO INTEGRATE ' // - * 'PAST THE POINT TSTOP = ' // XERN4 // ' THESE ' // - * 'INSTRUCTIONS CONFLICT.', 14, 1) - IDID=-33 - ENDIF - ENDIF -C -C CHECK SOME CONTINUATION POSSIBILITIES -C - IF (INIT .NE. 0) THEN - IF (T .EQ. TOUT) THEN - WRITE (XERN3, '(1PE15.6)') T - CALL XERMSG ('SLATEC', 'DES', - * 'IN DEABM, YOU HAVE CALLED THE ' // - * 'CODE WITH T = TOUT = ' // XERN3 // '$$THIS IS NOT ' // - * 'ALLOWED ON CONTINUATION CALLS.', 9, 1) - IDID=-33 - ENDIF -C - IF (T .NE. TOLD) THEN - WRITE (XERN3, '(1PE15.6)') TOLD - WRITE (XERN4, '(1PE15.6)') T - CALL XERMSG ('SLATEC', 'DES', - * 'IN DEABM, YOU HAVE CHANGED THE ' // - * 'VALUE OF T FROM ' // XERN3 // ' TO ' // XERN4 // - * ' THIS IS NOT ALLOWED ON CONTINUATION CALLS.', 10, 1) - IDID=-33 - ENDIF -C - IF (INIT .NE. 1) THEN - IF (DELSGN*(TOUT-T) .LT. 0.) THEN - WRITE (XERN3, '(1PE15.6)') TOUT - CALL XERMSG ('SLATEC', 'DES', - * 'IN DEABM, BY CALLING THE ' // - * 'CODE WITH TOUT = ' // XERN3 // ' YOU ARE ' // - * 'ATTEMPTING TO CHANGE THE DIRECTION OF ' // - * 'INTEGRATION.$$THIS IS NOT ALLOWED WITHOUT ' // - * 'RESTARTING.', 11, 1) - IDID=-33 - ENDIF - ENDIF - ENDIF -C -C INVALID INPUT DETECTED -C - IF (IDID .EQ. (-33)) THEN - IF (IQUIT .NE. (-33)) THEN - IQUIT = -33 - INFO(1) = -1 - ELSE - CALL XERMSG ('SLATEC', 'DES', - * 'IN DEABM, INVALID INPUT WAS ' // - * 'DETECTED ON SUCCESSIVE ENTRIES. IT IS IMPOSSIBLE ' // - * 'TO PROCEED BECAUSE YOU HAVE NOT CORRECTED THE ' // - * 'PROBLEM, SO EXECUTION IS BEING TERMINATED.', 12, 2) - ENDIF - RETURN - ENDIF -C -C....................................................................... -C -C RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND INTERPRETED AS -C ASKING FOR THE MOST ACCURATE SOLUTION POSSIBLE. IN THIS CASE, -C THE RELATIVE ERROR TOLERANCE RTOL IS RESET TO THE SMALLEST VALUE -C FOURU WHICH IS LIKELY TO BE REASONABLE FOR THIS METHOD AND MACHINE -C - DO 180 K=1,NEQ - IF (RTOL(K)+ATOL(K) .GT. 0.) GO TO 170 - RTOL(K)=FOURU - IDID=-2 - 170 IF (INFO(2) .EQ. 0) GO TO 190 - 180 CONTINUE -C - 190 IF (IDID .NE. (-2)) GO TO 200 -C RTOL=ATOL=0 ON INPUT, SO RTOL IS CHANGED TO A -C SMALL POSITIVE VALUE - INFO(1)=-1 - RETURN -C -C BRANCH ON STATUS OF INITIALIZATION INDICATOR -C INIT=0 MEANS INITIAL DERIVATIVES AND NOMINAL STEP SIZE -C AND DIRECTION NOT YET SET -C INIT=1 MEANS NOMINAL STEP SIZE AND DIRECTION NOT YET SET -C INIT=2 MEANS NO FURTHER INITIALIZATION REQUIRED -C - 200 IF (INIT .EQ. 0) GO TO 210 - IF (INIT .EQ. 1) GO TO 220 - GO TO 240 -C -C....................................................................... -C -C MORE INITIALIZATION -- -C -- EVALUATE INITIAL DERIVATIVES -C - 210 INIT=1 - A=T - CALL F(A,Y,YP,RPAR,IPAR) - IF (T .NE. TOUT) GO TO 220 - IDID=2 - DO 215 L = 1,NEQ - 215 YPOUT(L) = YP(L) - TOLD=T - RETURN -C -C -- SET INDEPENDENT AND DEPENDENT VARIABLES -C X AND YY(*) FOR STEPS -C -- SET SIGN OF INTEGRATION DIRECTION -C -- INITIALIZE THE STEP SIZE -C - 220 INIT = 2 - X = T - DO 230 L = 1,NEQ - 230 YY(L) = Y(L) - DELSGN = SIGN(1.0,TOUT-T) - H = SIGN(MAX(FOURU*ABS(X),ABS(TOUT-X)),TOUT-X) -C -C....................................................................... -C -C ON EACH CALL SET INFORMATION WHICH DETERMINES THE ALLOWED INTERVAL -C OF INTEGRATION BEFORE RETURNING WITH AN ANSWER AT TOUT -C - 240 DEL = TOUT - T - ABSDEL = ABS(DEL) -C -C....................................................................... -C -C IF ALREADY PAST OUTPUT POINT, INTERPOLATE AND RETURN -C - 250 IF(ABS(X-T) .LT. ABSDEL) GO TO 260 - CALL SINTRP(X,YY,TOUT,Y,YPOUT,NEQ,KOLD,PHI,IVC,IV,KGI,GI, - 1 ALPHA,G,W,XOLD,P) - IDID = 3 - IF (X .NE. TOUT) GO TO 255 - IDID = 2 - INTOUT = .FALSE. - 255 T = TOUT - TOLD = T - RETURN -C -C IF CANNOT GO PAST TSTOP AND SUFFICIENTLY CLOSE, -C EXTRAPOLATE AND RETURN -C - 260 IF (INFO(4) .NE. 1) GO TO 280 - IF (ABS(TSTOP-X) .GE. FOURU*ABS(X)) GO TO 280 - DT = TOUT - X - DO 270 L = 1,NEQ - 270 Y(L) = YY(L) + DT*YP(L) - CALL F(TOUT,Y,YPOUT,RPAR,IPAR) - IDID = 3 - T = TOUT - TOLD = T - RETURN -C - 280 IF (INFO(3) .EQ. 0 .OR. .NOT.INTOUT) GO TO 300 -C -C INTERMEDIATE-OUTPUT MODE -C - IDID = 1 - DO 290 L = 1,NEQ - Y(L)=YY(L) - 290 YPOUT(L) = YP(L) - T = X - TOLD = T - INTOUT = .FALSE. - RETURN -C -C....................................................................... -C -C MONITOR NUMBER OF STEPS ATTEMPTED -C - 300 IF (KSTEPS .LE. MAXNUM) GO TO 330 -C -C A SIGNIFICANT AMOUNT OF WORK HAS BEEN EXPENDED - IDID=-1 - KSTEPS=0 - IF (.NOT. STIFF) GO TO 310 -C -C PROBLEM APPEARS TO BE STIFF - IDID=-4 - STIFF= .FALSE. - KLE4=0 -C - 310 DO 320 L = 1,NEQ - Y(L) = YY(L) - 320 YPOUT(L) = YP(L) - T = X - TOLD = T - INFO(1) = -1 - INTOUT = .FALSE. - RETURN -C -C....................................................................... -C -C LIMIT STEP SIZE, SET WEIGHT VECTOR AND TAKE A STEP -C - 330 HA = ABS(H) - IF (INFO(4) .NE. 1) GO TO 340 - HA = MIN(HA,ABS(TSTOP-X)) - 340 H = SIGN(HA,H) - EPS = 1.0 - LTOL = 1 - DO 350 L = 1,NEQ - IF (INFO(2) .EQ. 1) LTOL = L - WT(L) = RTOL(LTOL)*ABS(YY(L)) + ATOL(LTOL) - IF (WT(L) .LE. 0.0) GO TO 360 - 350 CONTINUE - GO TO 380 -C -C RELATIVE ERROR CRITERION INAPPROPRIATE - 360 IDID = -3 - DO 370 L = 1,NEQ - Y(L) = YY(L) - 370 YPOUT(L) = YP(L) - T = X - TOLD = T - INFO(1) = -1 - INTOUT = .FALSE. - RETURN -C - 380 CALL STEPS(F,NEQ,YY,X,H,EPS,WT,START,HOLD,KORD,KOLD,CRASH,PHI,P, - 1 YP,PSI,ALPHA,BETA,SIG,V,W,G,PHASE1,NS,NORND,KSTEPS, - 2 TWOU,FOURU,XOLD,KPREV,IVC,IV,KGI,GI,RPAR,IPAR) -C -C....................................................................... -C - IF(.NOT.CRASH) GO TO 420 -C -C TOLERANCES TOO SMALL - IDID = -2 - RTOL(1) = EPS*RTOL(1) - ATOL(1) = EPS*ATOL(1) - IF (INFO(2) .EQ. 0) GO TO 400 - DO 390 L = 2,NEQ - RTOL(L) = EPS*RTOL(L) - 390 ATOL(L) = EPS*ATOL(L) - 400 DO 410 L = 1,NEQ - Y(L) = YY(L) - 410 YPOUT(L) = YP(L) - T = X - TOLD = T - INFO(1) = -1 - INTOUT = .FALSE. - RETURN -C -C (STIFFNESS TEST) COUNT NUMBER OF CONSECUTIVE STEPS TAKEN WITH THE -C ORDER OF THE METHOD BEING LESS OR EQUAL TO FOUR -C - 420 KLE4 = KLE4 + 1 - IF(KOLD .GT. 4) KLE4 = 0 - IF(KLE4 .GE. 50) STIFF = .TRUE. - INTOUT = .TRUE. - GO TO 250 - END diff --git a/slatec/dexbvp.f b/slatec/dexbvp.f deleted file mode 100644 index 5e6bc58..0000000 --- a/slatec/dexbvp.f +++ /dev/null @@ -1,117 +0,0 @@ -*DECK DEXBVP - SUBROUTINE DEXBVP (Y, NROWY, XPTS, A, NROWA, ALPHA, B, NROWB, - + BETA, IFLAG, WORK, IWORK) -C***BEGIN PROLOGUE DEXBVP -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBVSUP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (EXBVP-S, DEXBVP-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C This subroutine is used to execute the basic technique for solving -C the two-point boundary value problem. -C -C***SEE ALSO DBVSUP -C***ROUTINES CALLED DBVPOR, XERMSG -C***COMMON BLOCKS DML15T, DML17B, DML18J, DML5MC, DML8SZ -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 890921 Realigned order of variables in certain COMMON blocks. -C (WRB) -C 890921 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DEXBVP -C - INTEGER ICOCO, IEXP, IFLAG, IGOFX, INC, INDPVT, INFO, INHOMO, - 1 INTEG, ISTKOP, IVP, IWORK(*), K1, K10, K11, K2, K3, - 2 K4, K5, K6, K7, K8, K9, KKKINT, KKKZPW, KNSWOT, KOP, KOTC, - 3 L1, L2, LLLINT, LOTJP, LPAR, MNSWOT, MXNON, NCOMP, NDISK, - 4 NEEDIW, NEEDW, NEQ, NEQIVP, NFC, NFCC, NIC, NOPG, - 5 NPS, NROWA, NROWB, NROWY, NSAFIW, NSAFW, NSWOT, NTAPE, NTP, - 6 NUMORT, NXPTS - DOUBLE PRECISION A(NROWA,*), AE, ALPHA(*), B(NROWB,*), BETA(*), - 1 C, EPS, FOURU, PWCND, PX, RE, SQOVFL, SRU, TND, TOL, TWOU, - 2 URO, WORK(*), X, XBEG, XEND, XL, XOP, XOT, XPTS(*), XSAV, - 3 Y(NROWY,*), ZQUIT - CHARACTER*8 XERN1, XERN2 -C -C ****************************************************************** -C - COMMON /DML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMP,NFC - COMMON /DML18J/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ, - 1 INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,NFCC, - 2 ICOCO - COMMON /DML15T/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP, - 1 KNSWOT,KOP,LOTJP,MNSWOT,NSWOT - COMMON /DML17B/ KKKZPW,NEEDW,NEEDIW,K1,K2,K3,K4,K5,K6,K7,K8,K9, - 1 K10,K11,L1,L2,KKKINT,LLLINT -C - COMMON /DML5MC/ URO,SRU,EPS,SQOVFL,TWOU,FOURU,LPAR -C -C***FIRST EXECUTABLE STATEMENT DEXBVP - KOTC = 1 - IEXP = 0 - IF (IWORK(7) .EQ. -1) IEXP = IWORK(8) -C -C COMPUTE ORTHONORMALIZATION TOLERANCES. -C - 10 TOL = 10.0D0**((-LPAR - IEXP)*2) -C - IWORK(8) = IEXP - MXNON = IWORK(2) -C -C ********************************************************************** -C ********************************************************************** -C - CALL DBVPOR(Y,NROWY,NCOMP,XPTS,NXPTS,A,NROWA,ALPHA,NIC,B, - 1 NROWB,BETA,NFC,IFLAG,WORK(1),MXNON,WORK(K1),NTP, - 2 IWORK(18),WORK(K2),IWORK(16),WORK(K3),WORK(K4), - 3 WORK(K5),WORK(K6),WORK(K7),WORK(K8),WORK(K9), - 4 WORK(K10),IWORK(L1),NFCC) -C -C ********************************************************************** -C ********************************************************************** -C IF DMGSBV RETURNS WITH MESSAGE OF DEPENDENT VECTORS, WE REDUCE -C ORTHONORMALIZATION TOLERANCE AND TRY AGAIN. THIS IS DONE -C A MAXIMUM OF 2 TIMES. -C - IF (IFLAG .NE. 30) GO TO 20 - IF (KOTC .EQ. 3 .OR. NOPG .EQ. 1) GO TO 30 - KOTC = KOTC + 1 - IEXP = IEXP - 2 - GO TO 10 -C -C ********************************************************************** -C IF DBVPOR RETURNS MESSAGE THAT THE MAXIMUM NUMBER OF -C ORTHONORMALIZATIONS HAS BEEN ATTAINED AND WE CANNOT CONTINUE, THEN -C WE ESTIMATE THE NEW STORAGE REQUIREMENTS IN ORDER TO SOLVE PROBLEM -C - 20 IF (IFLAG .NE. 13) GO TO 30 - XL = ABS(XEND-XBEG) - ZQUIT = ABS(X-XBEG) - INC = 1.5D0*XL/ZQUIT * (MXNON+1) - IF (NDISK .NE. 1) THEN - NSAFW = INC*KKKZPW + NEEDW - NSAFIW = INC*NFCC + NEEDIW - ELSE - NSAFW = NEEDW + INC - NSAFIW = NEEDIW - ENDIF -C - WRITE (XERN1, '(I8)') NSAFW - WRITE (XERN2, '(I8)') NSAFIW - CALL XERMSG ('SLATEC', 'DEXBVP', - * 'IN DBVSUP, PREDICTED STORAGE ALLOCATION FOR WORK ARRAY IS ' // - * XERN1 // ', PREDICTED STORAGE ALLOCATION FOR IWORK ARRAY IS ' - * // XERN2, 1, 0) -C - 30 IWORK(1) = MXNON - RETURN - END diff --git a/slatec/dexint.f b/slatec/dexint.f deleted file mode 100644 index 26e8146..0000000 --- a/slatec/dexint.f +++ /dev/null @@ -1,336 +0,0 @@ -*DECK DEXINT - SUBROUTINE DEXINT (X, N, KODE, M, TOL, EN, NZ, IERR) -C***BEGIN PROLOGUE DEXINT -C***PURPOSE Compute an M member sequence of exponential integrals -C E(N+K,X), K=0,1,...,M-1 for N .GE. 1 and X .GE. 0. -C***LIBRARY SLATEC -C***CATEGORY C5 -C***TYPE DOUBLE PRECISION (EXINT-S, DEXINT-D) -C***KEYWORDS EXPONENTIAL INTEGRAL, SPECIAL FUNCTIONS -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C DEXINT computes M member sequences of exponential integrals -C E(N+K,X), K=0,1,...,M-1 for N .GE. 1 and X .GE. 0. The -C exponential integral is defined by -C -C E(N,X)=integral on (1,infinity) of EXP(-XT)/T**N -C -C where X=0.0 and N=1 cannot occur simultaneously. Formulas -C and notation are found in the NBS Handbook of Mathematical -C Functions (ref. 1). -C -C The power series is implemented for X .LE. XCUT and the -C confluent hypergeometric representation -C -C E(A,X) = EXP(-X)*(X**(A-1))*U(A,A,X) -C -C is computed for X .GT. XCUT. Since sequences are computed in -C a stable fashion by recurring away from X, A is selected as -C the integer closest to X within the constraint N .LE. A .LE. -C N+M-1. For the U computation, A is further modified to be the -C nearest even integer. Indices are carried forward or -C backward by the two term recursion relation -C -C K*E(K+1,X) + X*E(K,X) = EXP(-X) -C -C once E(A,X) is computed. The U function is computed by means -C of the backward recursive Miller algorithm applied to the -C three term contiguous relation for U(A+K,A,X), K=0,1,... -C This produces accurate ratios and determines U(A+K,A,X), and -C hence E(A,X), to within a multiplicative constant C. -C Another contiguous relation applied to C*U(A,A,X) and -C C*U(A+1,A,X) gets C*U(A+1,A+1,X), a quantity proportional to -C E(A+1,X). The normalizing constant C is obtained from the -C two term recursion relation above with K=A. -C -C The maximum number of significant digits obtainable -C is the smaller of 14 and the number of digits carried in -C double precision arithmetic. -C -C Description of Arguments -C -C Input * X and TOL are double precision * -C X X .GT. 0.0 for N=1 and X .GE. 0.0 for N .GE. 2 -C N order of the first member of the sequence, N .GE. 1 -C (X=0.0 and N=1 is an error) -C KODE a selection parameter for scaled values -C KODE=1 returns E(N+K,X), K=0,1,...,M-1. -C =2 returns EXP(X)*E(N+K,X), K=0,1,...,M-1. -C M number of exponential integrals in the sequence, -C M .GE. 1 -C TOL relative accuracy wanted, ETOL .LE. TOL .LE. 0.1 -C ETOL is the larger of double precision unit -C roundoff = D1MACH(4) and 1.0D-18 -C -C Output * EN is a double precision vector * -C EN a vector of dimension at least M containing values -C EN(K) = E(N+K-1,X) or EXP(X)*E(N+K-1,X), K=1,M -C depending on KODE -C NZ underflow indicator -C NZ=0 a normal return -C NZ=M X exceeds XLIM and an underflow occurs. -C EN(K)=0.0D0 , K=1,M returned on KODE=1 -C IERR error flag -C IERR=0, normal return, computation completed -C IERR=1, input error, no computation -C IERR=2, error, no computation -C algorithm termination condition not met -C -C***REFERENCES M. Abramowitz and I. A. Stegun, Handbook of -C Mathematical Functions, NBS AMS Series 55, U.S. Dept. -C of Commerce, 1955. -C D. E. Amos, Computation of exponential integrals, ACM -C Transactions on Mathematical Software 6, (1980), -C pp. 365-377 and pp. 420-428. -C***ROUTINES CALLED D1MACH, DPSIXN, I1MACH -C***REVISION HISTORY (YYMMDD) -C 800501 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 910408 Updated the REFERENCES section. (WRB) -C 920207 Updated with code with a revision date of 880811 from -C D. Amos. Included correction of argument list. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DEXINT - DOUBLE PRECISION A,AA,AAMS,AH,AK,AT,B,BK,BT,CC,CNORM,CT,EM,EMX,EN, - 1 ETOL,FNM,FX,PT,P1,P2,S,TOL,TX,X,XCUT,XLIM,XTOL,Y, - 2 YT,Y1,Y2 - DOUBLE PRECISION D1MACH,DPSIXN - INTEGER I,IC,ICASE,ICT,IERR,IK,IND,IX,I1M,JSET,K,KK,KN,KODE,KS,M, - 1 ML,MU,N,ND,NM,NZ - INTEGER I1MACH - DIMENSION EN(*), A(99), B(99), Y(2) - SAVE XCUT - DATA XCUT / 2.0D0 / -C***FIRST EXECUTABLE STATEMENT DEXINT - IERR = 0 - NZ = 0 - ETOL = MAX(D1MACH(4),0.5D-18) - IF (X.LT.0.0D0) IERR = 1 - IF (N.LT.1) IERR = 1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR = 1 - IF (M.LT.1) IERR = 1 - IF (TOL.LT.ETOL .OR. TOL.GT.0.1D0) IERR = 1 - IF (X.EQ.0.0D0 .AND. N.EQ.1) IERR = 1 - IF(IERR.NE.0) RETURN - I1M = -I1MACH(15) - PT = 2.3026D0*I1M*D1MACH(5) - XLIM = PT - 6.907755D0 - BT = PT + (N+M-1) - IF (BT.GT.1000.0D0) XLIM = PT - LOG(BT) -C - IF (X.GT.XCUT) GO TO 100 - IF (X.EQ.0.0D0 .AND. N.GT.1) GO TO 80 -C----------------------------------------------------------------------- -C SERIES FOR E(N,X) FOR X.LE.XCUT -C----------------------------------------------------------------------- - TX = X + 0.5D0 - IX = TX -C----------------------------------------------------------------------- -C ICASE=1 MEANS INTEGER CLOSEST TO X IS 2 AND N=1 -C ICASE=2 MEANS INTEGER CLOSEST TO X IS 0,1, OR 2 AND N.GE.2 -C----------------------------------------------------------------------- - ICASE = 2 - IF (IX.GT.N) ICASE = 1 - NM = N - ICASE + 1 - ND = NM + 1 - IND = 3 - ICASE - MU = M - IND - ML = 1 - KS = ND - FNM = NM - S = 0.0D0 - XTOL = 3.0D0*TOL - IF (ND.EQ.1) GO TO 10 - XTOL = 0.3333D0*TOL - S = 1.0D0/FNM - 10 CONTINUE - AA = 1.0D0 - AK = 1.0D0 - IC = 35 - IF (X.LT.ETOL) IC = 1 - DO 50 I=1,IC - AA = -AA*X/AK - IF (I.EQ.NM) GO TO 30 - S = S - AA/(AK-FNM) - IF (ABS(AA).LE.XTOL*ABS(S)) GO TO 20 - AK = AK + 1.0D0 - GO TO 50 - 20 CONTINUE - IF (I.LT.2) GO TO 40 - IF (ND-2.GT.I .OR. I.GT.ND-1) GO TO 60 - AK = AK + 1.0D0 - GO TO 50 - 30 S = S + AA*(-LOG(X)+DPSIXN(ND)) - XTOL = 3.0D0*TOL - 40 AK = AK + 1.0D0 - 50 CONTINUE - IF (IC.NE.1) GO TO 340 - 60 IF (ND.EQ.1) S = S + (-LOG(X)+DPSIXN(1)) - IF (KODE.EQ.2) S = S*EXP(X) - EN(1) = S - EMX = 1.0D0 - IF (M.EQ.1) GO TO 70 - EN(IND) = S - AA = KS - IF (KODE.EQ.1) EMX = EXP(-X) - GO TO (220, 240), ICASE - 70 IF (ICASE.EQ.2) RETURN - IF (KODE.EQ.1) EMX = EXP(-X) - EN(1) = (EMX-S)/X - RETURN - 80 CONTINUE - DO 90 I=1,M - EN(I) = 1.0D0/(N+I-2) - 90 CONTINUE - RETURN -C----------------------------------------------------------------------- -C BACKWARD RECURSIVE MILLER ALGORITHM FOR -C E(N,X)=EXP(-X)*(X**(N-1))*U(N,N,X) -C WITH RECURSION AWAY FROM N=INTEGER CLOSEST TO X. -C U(A,B,X) IS THE SECOND CONFLUENT HYPERGEOMETRIC FUNCTION -C----------------------------------------------------------------------- - 100 CONTINUE - EMX = 1.0D0 - IF (KODE.EQ.2) GO TO 130 - IF (X.LE.XLIM) GO TO 120 - NZ = M - DO 110 I=1,M - EN(I) = 0.0D0 - 110 CONTINUE - RETURN - 120 EMX = EXP(-X) - 130 CONTINUE - TX = X + 0.5D0 - IX = TX - KN = N + M - 1 - IF (KN.LE.IX) GO TO 140 - IF (N.LT.IX .AND. IX.LT.KN) GO TO 170 - IF (N.GE.IX) GO TO 160 - GO TO 340 - 140 ICASE = 1 - KS = KN - ML = M - 1 - MU = -1 - IND = M - IF (KN.GT.1) GO TO 180 - 150 KS = 2 - ICASE = 3 - GO TO 180 - 160 ICASE = 2 - IND = 1 - KS = N - MU = M - 1 - IF (N.GT.1) GO TO 180 - IF (KN.EQ.1) GO TO 150 - IX = 2 - 170 ICASE = 1 - KS = IX - ML = IX - N - IND = ML + 1 - MU = KN - IX - 180 CONTINUE - IK = KS/2 - AH = IK - JSET = 1 + KS - (IK+IK) -C----------------------------------------------------------------------- -C START COMPUTATION FOR -C EN(IND) = C*U( A , A ,X) JSET=1 -C EN(IND) = C*U(A+1,A+1,X) JSET=2 -C FOR AN EVEN INTEGER A. -C----------------------------------------------------------------------- - IC = 0 - AA = AH + AH - AAMS = AA - 1.0D0 - AAMS = AAMS*AAMS - TX = X + X - FX = TX + TX - AK = AH - XTOL = TOL - IF (TOL.LE.1.0D-3) XTOL = 20.0D0*TOL - CT = AAMS + FX*AH - EM = (AH+1.0D0)/((X+AA)*XTOL*SQRT(CT)) - BK = AA - CC = AH*AH -C----------------------------------------------------------------------- -C FORWARD RECURSION FOR P(IC),P(IC+1) AND INDEX IC FOR BACKWARD -C RECURSION -C----------------------------------------------------------------------- - P1 = 0.0D0 - P2 = 1.0D0 - 190 CONTINUE - IF (IC.EQ.99) GO TO 340 - IC = IC + 1 - AK = AK + 1.0D0 - AT = BK/(BK+AK+CC+IC) - BK = BK + AK + AK - A(IC) = AT - BT = (AK+AK+X)/(AK+1.0D0) - B(IC) = BT - PT = P2 - P2 = BT*P2 - AT*P1 - P1 = PT - CT = CT + FX - EM = EM*AT*(1.0D0-TX/CT) - IF (EM*(AK+1.0D0).GT.P1*P1) GO TO 190 - ICT = IC - KK = IC + 1 - BT = TX/(CT+FX) - Y2 = (BK/(BK+CC+KK))*(P1/P2)*(1.0D0-BT+0.375D0*BT*BT) - Y1 = 1.0D0 -C----------------------------------------------------------------------- -C BACKWARD RECURRENCE FOR -C Y1= C*U( A ,A,X) -C Y2= C*(A/(1+A/2))*U(A+1,A,X) -C----------------------------------------------------------------------- - DO 200 K=1,ICT - KK = KK - 1 - YT = Y1 - Y1 = (B(KK)*Y1-Y2)/A(KK) - Y2 = YT - 200 CONTINUE -C----------------------------------------------------------------------- -C THE CONTIGUOUS RELATION -C X*U(B,C+1,X)=(C-B)*U(B,C,X)+U(B-1,C,X) -C WITH B=A+1 , C=A IS USED FOR -C Y(2) = C * U(A+1,A+1,X) -C X IS INCORPORATED INTO THE NORMALIZING RELATION -C----------------------------------------------------------------------- - PT = Y2/Y1 - CNORM = 1.0E0 - PT*(AH+1.0E0)/AA - Y(1) = 1.0E0/(CNORM*AA+X) - Y(2) = CNORM*Y(1) - IF (ICASE.EQ.3) GO TO 210 - EN(IND) = EMX*Y(JSET) - IF (M.EQ.1) RETURN - AA = KS - GO TO (220, 240), ICASE -C----------------------------------------------------------------------- -C RECURSION SECTION N*E(N+1,X) + X*E(N,X)=EMX -C----------------------------------------------------------------------- - 210 EN(1) = EMX*(1.0E0-Y(1))/X - RETURN - 220 K = IND - 1 - DO 230 I=1,ML - AA = AA - 1.0D0 - EN(K) = (EMX-AA*EN(K+1))/X - K = K - 1 - 230 CONTINUE - IF (MU.LE.0) RETURN - AA = KS - 240 K = IND - DO 250 I=1,MU - EN(K+1) = (EMX-X*EN(K))/AA - AA = AA + 1.0D0 - K = K + 1 - 250 CONTINUE - RETURN - 340 CONTINUE - IERR = 2 - RETURN - END diff --git a/slatec/dexprl.f b/slatec/dexprl.f deleted file mode 100644 index 613f03e..0000000 --- a/slatec/dexprl.f +++ /dev/null @@ -1,55 +0,0 @@ -*DECK DEXPRL - DOUBLE PRECISION FUNCTION DEXPRL (X) -C***BEGIN PROLOGUE DEXPRL -C***PURPOSE Calculate the relative error exponential (EXP(X)-1)/X. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4B -C***TYPE DOUBLE PRECISION (EXPREL-S, DEXPRL-D, CEXPRL-C) -C***KEYWORDS ELEMENTARY FUNCTIONS, EXPONENTIAL, FIRST ORDER, FNLIB -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate EXPREL(X) = (EXP(X) - 1.0) / X. For small ABS(X) the -C Taylor series is used. If X is negative the reflection formula -C EXPREL(X) = EXP(X) * EXPREL(ABS(X)) -C may be used. This reflection formula will be of use when the -C evaluation for small ABS(X) is done by Chebyshev series rather than -C Taylor series. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH -C***REVISION HISTORY (YYMMDD) -C 770801 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 890911 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE DEXPRL - DOUBLE PRECISION X, ABSX, ALNEPS, XBND, XLN, XN, D1MACH - LOGICAL FIRST - SAVE NTERMS, XBND, FIRST - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DEXPRL - IF (FIRST) THEN - ALNEPS = LOG(D1MACH(3)) - XN = 3.72D0 - 0.3D0*ALNEPS - XLN = LOG((XN+1.0D0)/1.36D0) - NTERMS = XN - (XN*XLN+ALNEPS)/(XLN+1.36D0) + 1.5D0 - XBND = D1MACH(3) - ENDIF - FIRST = .FALSE. -C - ABSX = ABS(X) - IF (ABSX.GT.0.5D0) DEXPRL = (EXP(X)-1.0D0)/X - IF (ABSX.GT.0.5D0) RETURN -C - DEXPRL = 1.0D0 - IF (ABSX.LT.XBND) RETURN -C - DEXPRL = 0.0D0 - DO 20 I=1,NTERMS - DEXPRL = 1.0D0 + DEXPRL*X/(NTERMS+2-I) - 20 CONTINUE -C - RETURN - END diff --git a/slatec/dfac.f b/slatec/dfac.f deleted file mode 100644 index 1480424..0000000 --- a/slatec/dfac.f +++ /dev/null @@ -1,77 +0,0 @@ -*DECK DFAC - DOUBLE PRECISION FUNCTION DFAC (N) -C***BEGIN PROLOGUE DFAC -C***PURPOSE Compute the factorial function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C1 -C***TYPE DOUBLE PRECISION (FAC-S, DFAC-D) -C***KEYWORDS FACTORIAL, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DFAC(N) calculates the double precision factorial for integer -C argument N. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D9LGMC, DGAMLM, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 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***END PROLOGUE DFAC - DOUBLE PRECISION FACN(31), SQ2PIL, X, XMAX, XMIN, D9LGMC - SAVE FACN, SQ2PIL, NMAX - DATA FACN ( 1) / +.1000000000 0000000000 0000000000 000 D+1 / - DATA FACN ( 2) / +.1000000000 0000000000 0000000000 000 D+1 / - DATA FACN ( 3) / +.2000000000 0000000000 0000000000 000 D+1 / - DATA FACN ( 4) / +.6000000000 0000000000 0000000000 000 D+1 / - DATA FACN ( 5) / +.2400000000 0000000000 0000000000 000 D+2 / - DATA FACN ( 6) / +.1200000000 0000000000 0000000000 000 D+3 / - DATA FACN ( 7) / +.7200000000 0000000000 0000000000 000 D+3 / - DATA FACN ( 8) / +.5040000000 0000000000 0000000000 000 D+4 / - DATA FACN ( 9) / +.4032000000 0000000000 0000000000 000 D+5 / - DATA FACN ( 10) / +.3628800000 0000000000 0000000000 000 D+6 / - DATA FACN ( 11) / +.3628800000 0000000000 0000000000 000 D+7 / - DATA FACN ( 12) / +.3991680000 0000000000 0000000000 000 D+8 / - DATA FACN ( 13) / +.4790016000 0000000000 0000000000 000 D+9 / - DATA FACN ( 14) / +.6227020800 0000000000 0000000000 000 D+10 / - DATA FACN ( 15) / +.8717829120 0000000000 0000000000 000 D+11 / - DATA FACN ( 16) / +.1307674368 0000000000 0000000000 000 D+13 / - DATA FACN ( 17) / +.2092278988 8000000000 0000000000 000 D+14 / - DATA FACN ( 18) / +.3556874280 9600000000 0000000000 000 D+15 / - DATA FACN ( 19) / +.6402373705 7280000000 0000000000 000 D+16 / - DATA FACN ( 20) / +.1216451004 0883200000 0000000000 000 D+18 / - DATA FACN ( 21) / +.2432902008 1766400000 0000000000 000 D+19 / - DATA FACN ( 22) / +.5109094217 1709440000 0000000000 000 D+20 / - DATA FACN ( 23) / +.1124000727 7776076800 0000000000 000 D+22 / - DATA FACN ( 24) / +.2585201673 8884976640 0000000000 000 D+23 / - DATA FACN ( 25) / +.6204484017 3323943936 0000000000 000 D+24 / - DATA FACN ( 26) / +.1551121004 3330985984 0000000000 000 D+26 / - DATA FACN ( 27) / +.4032914611 2660563558 4000000000 000 D+27 / - DATA FACN ( 28) / +.1088886945 0418352160 7680000000 000 D+29 / - DATA FACN ( 29) / +.3048883446 1171386050 1504000000 000 D+30 / - DATA FACN ( 30) / +.8841761993 7397019545 4361600000 000 D+31 / - DATA FACN ( 31) / +.2652528598 1219105863 6308480000 000 D+33 / - DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 / - DATA NMAX / 0 / -C***FIRST EXECUTABLE STATEMENT DFAC - IF (NMAX.NE.0) GO TO 10 - CALL DGAMLM (XMIN, XMAX) - NMAX = XMAX - 1.D0 -C - 10 IF (N .LT. 0) CALL XERMSG ('SLATEC', 'DFAC', - + 'FACTORIAL OF NEGATIVE INTEGER UNDEFINED', 1, 2) -C - IF (N.LE.30) DFAC = FACN(N+1) - IF (N.LE.30) RETURN -C - IF (N .GT. NMAX) CALL XERMSG ('SLATEC', 'DFAC', - + 'N SO BIG FACTORIAL(N) OVERFLOWS', 2, 2) -C - X = N + 1 - DFAC = EXP ((X-0.5D0)*LOG(X) - X + SQ2PIL + D9LGMC(X) ) -C - RETURN - END diff --git a/slatec/dfc.f b/slatec/dfc.f deleted file mode 100644 index e69136d..0000000 --- a/slatec/dfc.f +++ /dev/null @@ -1,412 +0,0 @@ -*DECK DFC - SUBROUTINE DFC (NDATA, XDATA, YDATA, SDDATA, NORD, NBKPT, BKPT, - + NCONST, XCONST, YCONST, NDERIV, MODE, COEFF, W, IW) -C***BEGIN PROLOGUE DFC -C***PURPOSE Fit a piecewise polynomial curve to discrete data. -C The piecewise polynomials are represented as B-splines. -C The fitting is done in a weighted least squares sense. -C Equality and inequality constraints can be imposed on the -C fitted curve. -C***LIBRARY SLATEC -C***CATEGORY K1A1A1, K1A2A, L8A3 -C***TYPE DOUBLE PRECISION (FC-S, DFC-D) -C***KEYWORDS B-SPLINE, CONSTRAINED LEAST SQUARES, CURVE FITTING, -C WEIGHTED LEAST SQUARES -C***AUTHOR Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C This subprogram fits a piecewise polynomial curve -C to discrete data. The piecewise polynomials are -C represented as B-splines. -C The fitting is done in a weighted least squares sense. -C Equality and inequality constraints can be imposed on the -C fitted curve. -C -C For a description of the B-splines and usage instructions to -C evaluate them, see -C -C C. W. de Boor, Package for Calculating with B-Splines. -C SIAM J. Numer. Anal., p. 441, (June, 1977). -C -C For further documentation and discussion of constrained -C curve fitting using B-splines, see -C -C R. J. Hanson, Constrained Least Squares Curve Fitting -C to Discrete Data Using B-Splines, a User's -C Guide. Sandia Labs. Tech. Rept. SAND-78-1291, -C December, (1978). -C -C Input.. All TYPE REAL variables are DOUBLE PRECISION -C NDATA,XDATA(*), -C YDATA(*), -C SDDATA(*) -C The NDATA discrete (X,Y) pairs and the Y value -C standard deviation or uncertainty, SD, are in -C the respective arrays XDATA(*), YDATA(*), and -C SDDATA(*). No sorting of XDATA(*) is -C required. Any non-negative value of NDATA is -C allowed. A negative value of NDATA is an -C error. A zero value for any entry of -C SDDATA(*) will weight that data point as 1. -C Otherwise the weight of that data point is -C the reciprocal of this entry. -C -C NORD,NBKPT, -C BKPT(*) -C The NBKPT knots of the B-spline of order NORD -C are in the array BKPT(*). Normally the -C problem data interval will be included between -C the limits BKPT(NORD) and BKPT(NBKPT-NORD+1). -C The additional end knots BKPT(I),I=1,..., -C NORD-1 and I=NBKPT-NORD+2,...,NBKPT, are -C required to compute the functions used to fit -C the data. No sorting of BKPT(*) is required. -C Internal to DFC( ) the extreme end knots may -C be reduced and increased respectively to -C accommodate any data values that are exterior -C to the given knot values. The contents of -C BKPT(*) is not changed. -C -C NORD must be in the range 1 .LE. NORD .LE. 20. -C The value of NBKPT must satisfy the condition -C NBKPT .GE. 2*NORD. -C Other values are considered errors. -C -C (The order of the spline is one more than the -C degree of the piecewise polynomial defined on -C each interval. This is consistent with the -C B-spline package convention. For example, -C NORD=4 when we are using piecewise cubics.) -C -C NCONST,XCONST(*), -C YCONST(*),NDERIV(*) -C The number of conditions that constrain the -C B-spline is NCONST. A constraint is specified -C by an (X,Y) pair in the arrays XCONST(*) and -C YCONST(*), and by the type of constraint and -C derivative value encoded in the array -C NDERIV(*). No sorting of XCONST(*) is -C required. The value of NDERIV(*) is -C determined as follows. Suppose the I-th -C constraint applies to the J-th derivative -C of the B-spline. (Any non-negative value of -C J < NORD is permitted. In particular the -C value J=0 refers to the B-spline itself.) -C For this I-th constraint, set -C XCONST(I)=X, -C YCONST(I)=Y, and -C NDERIV(I)=ITYPE+4*J, where -C -C ITYPE = 0, if (J-th deriv. at X) .LE. Y. -C = 1, if (J-th deriv. at X) .GE. Y. -C = 2, if (J-th deriv. at X) .EQ. Y. -C = 3, if (J-th deriv. at X) .EQ. -C (J-th deriv. at Y). -C (A value of NDERIV(I)=-1 will cause this -C constraint to be ignored. This subprogram -C feature is often useful when temporarily -C suppressing a constraint while still -C retaining the source code of the calling -C program.) -C -C MODE -C An input flag that directs the least squares -C solution method used by DFC( ). -C -C The variance function, referred to below, -C defines the square of the probable error of -C the fitted curve at any point, XVAL. -C This feature of DFC( ) allows one to use the -C square root of this variance function to -C determine a probable error band around the -C fitted curve. -C -C =1 a new problem. No variance function. -C -C =2 a new problem. Want variance function. -C -C =3 an old problem. No variance function. -C -C =4 an old problem. Want variance function. -C -C Any value of MODE other than 1-4 is an error. -C -C The user with a new problem can skip directly -C to the description of the input parameters -C IW(1), IW(2). -C -C If the user correctly specifies the new or old -C problem status, the subprogram DFC( ) will -C perform more efficiently. -C By an old problem it is meant that subprogram -C DFC( ) was last called with this same set of -C knots, data points and weights. -C -C Another often useful deployment of this old -C problem designation can occur when one has -C previously obtained a Q-R orthogonal -C decomposition of the matrix resulting from -C B-spline fitting of data (without constraints) -C at the breakpoints BKPT(I), I=1,...,NBKPT. -C For example, this matrix could be the result -C of sequential accumulation of the least -C squares equations for a very large data set. -C The user writes this code in a manner -C convenient for the application. For the -C discussion here let -C -C N=NBKPT-NORD, and K=N+3 -C -C Let us assume that an equivalent least squares -C system -C -C RC=D -C -C has been obtained. Here R is an N+1 by N -C matrix and D is a vector with N+1 components. -C The last row of R is zero. The matrix R is -C upper triangular and banded. At most NORD of -C the diagonals are nonzero. -C The contents of R and D can be copied to the -C working array W(*) as follows. -C -C The I-th diagonal of R, which has N-I+1 -C elements, is copied to W(*) starting at -C -C W((I-1)*K+1), -C -C for I=1,...,NORD. -C The vector D is copied to W(*) starting at -C -C W(NORD*K+1) -C -C The input value used for NDATA is arbitrary -C when an old problem is designated. Because -C of the feature of DFC( ) that checks the -C working storage array lengths, a value not -C exceeding NBKPT should be used. For example, -C use NDATA=0. -C -C (The constraints or variance function request -C can change in each call to DFC( ).) A new -C problem is anything other than an old problem. -C -C IW(1),IW(2) -C The amounts of working storage actually -C allocated for the working arrays W(*) and -C IW(*). These quantities are compared with the -C actual amounts of storage needed in DFC( ). -C Insufficient storage allocated for either -C W(*) or IW(*) is an error. This feature was -C included in DFC( ) because misreading the -C storage formulas for W(*) and IW(*) might very -C well lead to subtle and hard-to-find -C programming bugs. -C -C The length of W(*) must be at least -C -C NB=(NBKPT-NORD+3)*(NORD+1)+ -C 2*MAX(NDATA,NBKPT)+NBKPT+NORD**2 -C -C Whenever possible the code uses banded matrix -C processors DBNDAC( ) and DBNDSL( ). These -C are utilized if there are no constraints, -C no variance function is required, and there -C is sufficient data to uniquely determine the -C B-spline coefficients. If the band processors -C cannot be used to determine the solution, -C then the constrained least squares code DLSEI -C is used. In this case the subprogram requires -C an additional block of storage in W(*). For -C the discussion here define the integers NEQCON -C and NINCON respectively as the number of -C equality (ITYPE=2,3) and inequality -C (ITYPE=0,1) constraints imposed on the fitted -C curve. Define -C -C L=NBKPT-NORD+1 -C -C and note that -C -C NCONST=NEQCON+NINCON. -C -C When the subprogram DFC( ) uses DLSEI( ) the -C length of the working array W(*) must be at -C least -C -C LW=NB+(L+NCONST)*L+ -C 2*(NEQCON+L)+(NINCON+L)+(NINCON+2)*(L+6) -C -C The length of the array IW(*) must be at least -C -C IW1=NINCON+2*L -C -C in any case. -C -C Output.. All TYPE REAL variables are DOUBLE PRECISION -C MODE -C An output flag that indicates the status -C of the constrained curve fit. -C -C =-1 a usage error of DFC( ) occurred. The -C offending condition is noted with the -C SLATEC library error processor, XERMSG. -C In case the working arrays W(*) or IW(*) -C are not long enough, the minimal -C acceptable length is printed. -C -C = 0 successful constrained curve fit. -C -C = 1 the requested equality constraints -C are contradictory. -C -C = 2 the requested inequality constraints -C are contradictory. -C -C = 3 both equality and inequality constraints -C are contradictory. -C -C COEFF(*) -C If the output value of MODE=0 or 1, this array -C contains the unknowns obtained from the least -C squares fitting process. These N=NBKPT-NORD -C parameters are the B-spline coefficients. -C For MODE=1, the equality constraints are -C contradictory. To make the fitting process -C more robust, the equality constraints are -C satisfied in a least squares sense. In this -C case the array COEFF(*) contains B-spline -C coefficients for this extended concept of a -C solution. If MODE=-1,2 or 3 on output, the -C array COEFF(*) is undefined. -C -C Working Arrays.. All Type REAL variables are DOUBLE PRECISION -C W(*),IW(*) -C These arrays are respectively typed DOUBLE -C PRECISION and INTEGER. -C Their required lengths are specified as input -C parameters in IW(1), IW(2) noted above. The -C contents of W(*) must not be modified by the -C user if the variance function is desired. -C -C Evaluating the -C Variance Function.. -C To evaluate the variance function (assuming -C that the uncertainties of the Y values were -C provided to DFC( ) and an input value of -C MODE=2 or 4 was used), use the function -C subprogram DCV( ) -C -C VAR=DCV(XVAL,NDATA,NCONST,NORD,NBKPT, -C BKPT,W) -C -C Here XVAL is the point where the variance is -C desired. The other arguments have the same -C meaning as in the usage of DFC( ). -C -C For those users employing the old problem -C designation, let MDATA be the number of data -C points in the problem. (This may be different -C from NDATA if the old problem designation -C feature was used.) The value, VAR, should be -C multiplied by the quantity -C -C DBLE(MAX(NDATA-N,1))/DBLE(MAX(MDATA-N,1)) -C -C The output of this subprogram is not defined -C if an input value of MODE=1 or 3 was used in -C FC( ) or if an output value of MODE=-1, 2, or -C 3 was obtained. The variance function, except -C for the scaling factor noted above, is given -C by -C -C VAR=(transpose of B(XVAL))*C*B(XVAL) -C -C The vector B(XVAL) is the B-spline basis -C function values at X=XVAL. -C The covariance matrix, C, of the solution -C coefficients accounts only for the least -C squares equations and the explicitly stated -C equality constraints. This fact must be -C considered when interpreting the variance -C function from a data fitting problem that has -C inequality constraints on the fitted curve. -C -C Evaluating the -C Fitted Curve.. -C To evaluate derivative number IDER at XVAL, -C use the function subprogram DBVALU( ) -C -C F = DBVALU(BKPT,COEFF,NBKPT-NORD,NORD,IDER, -C XVAL,INBV,WORKB) -C -C The output of this subprogram will not be -C defined unless an output value of MODE=0 or 1 -C was obtained from DFC( ), XVAL is in the data -C interval, and IDER is nonnegative and .LT. -C NORD. -C -C The first time DBVALU( ) is called, INBV=1 -C must be specified. This value of INBV is the -C overwritten by DBVALU( ). The array WORKB(*) -C must be of length at least 3*NORD, and must -C not be the same as the W(*) array used in -C the call to DFC( ). -C -C DBVALU( ) expects the breakpoint array BKPT(*) -C to be sorted. -C -C***REFERENCES R. J. Hanson, Constrained least squares curve fitting -C to discrete data using B-splines, a users guide, -C Report SAND78-1291, Sandia Laboratories, December -C 1978. -C***ROUTINES CALLED DFCMN -C***REVISION HISTORY (YYMMDD) -C 780801 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 900510 Convert references to XERRWV to references to XERMSG. (RWC) -C 900607 Editorial changes to Prologue to make Prologues for EFC, -C DEFC, FC, and DFC look as much the same as possible. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DFC - DOUBLE PRECISION BKPT(*), COEFF(*), SDDATA(*), W(*), XCONST(*), - * XDATA(*), YCONST(*), YDATA(*) - INTEGER IW(*), MODE, NBKPT, NCONST, NDATA, NDERIV(*), NORD -C - EXTERNAL DFCMN -C - INTEGER I1, I2, I3, I4, I5, I6, I7, MDG, MDW -C -C***FIRST EXECUTABLE STATEMENT DFC - MDG = NBKPT - NORD + 3 - MDW = NBKPT - NORD + 1 + NCONST -C USAGE IN DFCMN( ) OF W(*).. -C I1,...,I2-1 G(*,*) -C -C I2,...,I3-1 XTEMP(*) -C -C I3,...,I4-1 PTEMP(*) -C -C I4,...,I5-1 BKPT(*) (LOCAL TO DFCMN( )) -C -C I5,...,I6-1 BF(*,*) -C -C I6,...,I7-1 W(*,*) -C -C I7,... WORK(*) FOR DLSEI( ) -C - I1 = 1 - I2 = I1 + MDG*(NORD+1) - I3 = I2 + MAX(NDATA,NBKPT) - I4 = I3 + MAX(NDATA,NBKPT) - I5 = I4 + NBKPT - I6 = I5 + NORD*NORD - I7 = I6 + MDW*(NBKPT-NORD+1) - CALL DFCMN(NDATA, XDATA, YDATA, SDDATA, NORD, NBKPT, BKPT, NCONST, - 1 XCONST, YCONST, NDERIV, MODE, COEFF, W(I5), W(I2), W(I3), - 2 W(I4), W(I1), MDG, W(I6), MDW, W(I7), IW) - RETURN - END diff --git a/slatec/dfcmn.f b/slatec/dfcmn.f deleted file mode 100644 index d34b419..0000000 --- a/slatec/dfcmn.f +++ /dev/null @@ -1,395 +0,0 @@ -*DECK DFCMN - SUBROUTINE DFCMN (NDATA, XDATA, YDATA, SDDATA, NORD, NBKPT, - + BKPTIN, NCONST, XCONST, YCONST, NDERIV, MODE, COEFF, BF, XTEMP, - + PTEMP, BKPT, G, MDG, W, MDW, WORK, IWORK) -C***BEGIN PROLOGUE DFCMN -C***SUBSIDIARY -C***PURPOSE Subsidiary to FC -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (FCMN-S, DFCMN-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This is a companion subprogram to DFC( ). -C The documentation for DFC( ) has complete usage instructions. -C -C***SEE ALSO DFC -C***ROUTINES CALLED DAXPY, DBNDAC, DBNDSL, DCOPY, DFSPVD, DFSPVN, -C DLSEI, DSCAL, DSORT, XERMSG -C***REVISION HISTORY (YYMMDD) -C 780801 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and extensively revised (WRB & RWC) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C 900604 DP version created from SP version. (RWC) -C***END PROLOGUE DFCMN - INTEGER IWORK(*), MDG, MDW, MODE, NBKPT, NCONST, NDATA, NDERIV(*), - * NORD - DOUBLE PRECISION BF(NORD,*), BKPT(*), BKPTIN(*), COEFF(*), - * G(MDG,*), PTEMP(*), SDDATA(*), W(MDW,*), WORK(*), - * XCONST(*), XDATA(*), XTEMP(*), YCONST(*), YDATA(*) -C - EXTERNAL DAXPY, DBNDAC, DBNDSL, DCOPY, DFSPVD, DFSPVN, DLSEI, - * DSCAL, DSORT, XERMSG -C - DOUBLE PRECISION DUMMY, PRGOPT(10), RNORM, RNORME, RNORML, XMAX, - * XMIN, XVAL, YVAL - INTEGER I, IDATA, IDERIV, ILEFT, INTRVL, INTW1, IP, IR, IROW, - * ITYPE, IW1, IW2, L, LW, MT, N, NB, NEQCON, NINCON, NORDM1, - * NORDP1, NP1 - LOGICAL BAND, NEW, VAR - CHARACTER*8 XERN1 -C -C***FIRST EXECUTABLE STATEMENT DFCMN -C -C Analyze input. -C - IF (NORD.LT.1 .OR. NORD.GT.20) THEN - CALL XERMSG ('SLATEC', 'DFCMN', - + 'IN DFC, THE ORDER OF THE B-SPLINE MUST BE 1 THRU 20.', - + 2, 1) - MODE = -1 - RETURN -C - ELSEIF (NBKPT.LT.2*NORD) THEN - CALL XERMSG ('SLATEC', 'DFCMN', - + 'IN DFC, THE NUMBER OF KNOTS MUST BE AT LEAST TWICE ' // - + 'THE B-SPLINE ORDER.', 2, 1) - MODE = -1 - RETURN - ENDIF -C - IF (NDATA.LT.0) THEN - CALL XERMSG ('SLATEC', 'DFCMN', - + 'IN DFC, THE NUMBER OF DATA POINTS MUST BE NONNEGATIVE.', - + 2, 1) - MODE = -1 - RETURN - ENDIF -C -C Amount of storage allocated for W(*), IW(*). -C - IW1 = IWORK(1) - IW2 = IWORK(2) - NB = (NBKPT-NORD+3)*(NORD+1) + 2*MAX(NDATA,NBKPT) + NBKPT + - + NORD**2 -C -C See if sufficient storage has been allocated. -C - IF (IW1.LT.NB) THEN - WRITE (XERN1, '(I8)') NB - CALL XERMSG ('SLATEC', 'DFCMN', - * 'IN DFC, INSUFFICIENT STORAGE FOR W(*). CHECK NB = ' // - * XERN1, 2, 1) - MODE = -1 - RETURN - ENDIF -C - IF (MODE.EQ.1) THEN - BAND = .TRUE. - VAR = .FALSE. - NEW = .TRUE. - ELSEIF (MODE.EQ.2) THEN - BAND = .FALSE. - VAR = .TRUE. - NEW = .TRUE. - ELSEIF (MODE.EQ.3) THEN - BAND = .TRUE. - VAR = .FALSE. - NEW = .FALSE. - ELSEIF (MODE.EQ.4) THEN - BAND = .FALSE. - VAR = .TRUE. - NEW = .FALSE. - ELSE - CALL XERMSG ('SLATEC', 'DFCMN', - + 'IN DFC, INPUT VALUE OF MODE MUST BE 1-4.', 2, 1) - MODE = -1 - RETURN - ENDIF - MODE = 0 -C -C Sort the breakpoints. -C - CALL DCOPY (NBKPT, BKPTIN, 1, BKPT, 1) - CALL DSORT (BKPT, DUMMY, NBKPT, 1) -C -C Initialize variables. -C - NEQCON = 0 - NINCON = 0 - DO 100 I = 1,NCONST - L = NDERIV(I) - ITYPE = MOD(L,4) - IF (ITYPE.LT.2) THEN - NINCON = NINCON + 1 - ELSE - NEQCON = NEQCON + 1 - ENDIF - 100 CONTINUE -C -C Compute the number of variables. -C - N = NBKPT - NORD - NP1 = N + 1 - LW = NB + (NP1+NCONST)*NP1 + 2*(NEQCON+NP1) + (NINCON+NP1) + - + (NINCON+2)*(NP1+6) - INTW1 = NINCON + 2*NP1 -C -C Save interval containing knots. -C - XMIN = BKPT(NORD) - XMAX = BKPT(NP1) -C -C Find the smallest referenced independent variable value in any -C constraint. -C - DO 110 I = 1,NCONST - XMIN = MIN(XMIN,XCONST(I)) - XMAX = MAX(XMAX,XCONST(I)) - 110 CONTINUE - NORDM1 = NORD - 1 - NORDP1 = NORD + 1 -C -C Define the option vector PRGOPT(1-10) for use in DLSEI( ). -C - PRGOPT(1) = 4 -C -C Set the covariance matrix computation flag. -C - PRGOPT(2) = 1 - IF (VAR) THEN - PRGOPT(3) = 1 - ELSE - PRGOPT(3) = 0 - ENDIF -C -C Increase the rank determination tolerances for both equality -C constraint equations and least squares equations. -C - PRGOPT(4) = 7 - PRGOPT(5) = 4 - PRGOPT(6) = 1.D-4 -C - PRGOPT(7) = 10 - PRGOPT(8) = 5 - PRGOPT(9) = 1.D-4 -C - PRGOPT(10) = 1 -C -C Turn off work array length checking in DLSEI( ). -C - IWORK(1) = 0 - IWORK(2) = 0 -C -C Initialize variables and analyze input. -C - IF (NEW) THEN -C -C To process least squares equations sort data and an array of -C pointers. -C - CALL DCOPY (NDATA, XDATA, 1, XTEMP, 1) - DO 120 I = 1,NDATA - PTEMP(I) = I - 120 CONTINUE -C - IF (NDATA.GT.0) THEN - CALL DSORT (XTEMP, PTEMP, NDATA, 2) - XMIN = MIN(XMIN,XTEMP(1)) - XMAX = MAX(XMAX,XTEMP(NDATA)) - ENDIF -C -C Fix breakpoint array if needed. -C - DO 130 I = 1,NORD - BKPT(I) = MIN(BKPT(I),XMIN) - 130 CONTINUE -C - DO 140 I = NP1,NBKPT - BKPT(I) = MAX(BKPT(I),XMAX) - 140 CONTINUE -C -C Initialize parameters of banded matrix processor, DBNDAC( ). -C - MT = 0 - IP = 1 - IR = 1 - ILEFT = NORD - DO 160 IDATA = 1,NDATA -C -C Sorted indices are in PTEMP(*). -C - L = PTEMP(IDATA) - XVAL = XDATA(L) -C -C When interval changes, process equations in the last block. -C - IF (XVAL.GE.BKPT(ILEFT+1)) THEN - CALL DBNDAC (G, MDG, NORD, IP, IR, MT, ILEFT-NORDM1) - MT = 0 -C -C Move pointer up to have BKPT(ILEFT).LE.XVAL, -C ILEFT.LT.NP1. -C - 150 IF (XVAL.GE.BKPT(ILEFT+1) .AND. ILEFT.LT.N) THEN - ILEFT = ILEFT + 1 - GO TO 150 - ENDIF - ENDIF -C -C Obtain B-spline function value. -C - CALL DFSPVN (BKPT, NORD, 1, XVAL, ILEFT, BF) -C -C Move row into place. -C - IROW = IR + MT - MT = MT + 1 - CALL DCOPY (NORD, BF, 1, G(IROW,1), MDG) - G(IROW,NORDP1) = YDATA(L) -C -C Scale data if uncertainty is nonzero. -C - IF (SDDATA(L).NE.0.D0) CALL DSCAL (NORDP1, 1.D0/SDDATA(L), - + G(IROW,1), MDG) -C -C When staging work area is exhausted, process rows. -C - IF (IROW.EQ.MDG-1) THEN - CALL DBNDAC (G, MDG, NORD, IP, IR, MT, ILEFT-NORDM1) - MT = 0 - ENDIF - 160 CONTINUE -C -C Process last block of equations. -C - CALL DBNDAC (G, MDG, NORD, IP, IR, MT, ILEFT-NORDM1) -C -C Last call to adjust block positioning. -C - CALL DCOPY (NORDP1, 0.D0, 0, G(IR,1), MDG) - CALL DBNDAC (G, MDG, NORD, IP, IR, 1, NP1) - ENDIF -C - BAND = BAND .AND. NCONST.EQ.0 - DO 170 I = 1,N - BAND = BAND .AND. G(I,1).NE.0.D0 - 170 CONTINUE -C -C Process banded least squares equations. -C - IF (BAND) THEN - CALL DBNDSL (1, G, MDG, NORD, IP, IR, COEFF, N, RNORM) - RETURN - ENDIF -C -C Check further for sufficient storage in working arrays. -C - IF (IW1.LT.LW) THEN - WRITE (XERN1, '(I8)') LW - CALL XERMSG ('SLATEC', 'DFCMN', - * 'IN DFC, INSUFFICIENT STORAGE FOR W(*). CHECK LW = ' // - * XERN1, 2, 1) - MODE = -1 - RETURN - ENDIF -C - IF (IW2.LT.INTW1) THEN - WRITE (XERN1, '(I8)') INTW1 - CALL XERMSG ('SLATEC', 'DFCMN', - * 'IN DFC, INSUFFICIENT STORAGE FOR IW(*). CHECK IW1 = ' // - * XERN1, 2, 1) - MODE = -1 - RETURN - ENDIF -C -C Write equality constraints. -C Analyze constraint indicators for an equality constraint. -C - NEQCON = 0 - DO 220 IDATA = 1,NCONST - L = NDERIV(IDATA) - ITYPE = MOD(L,4) - IF (ITYPE.GT.1) THEN - IDERIV = L/4 - NEQCON = NEQCON + 1 - ILEFT = NORD - XVAL = XCONST(IDATA) -C - 180 IF (XVAL.LT.BKPT(ILEFT+1) .OR. ILEFT.GE.N) GO TO 190 - ILEFT = ILEFT + 1 - GO TO 180 -C - 190 CALL DFSPVD (BKPT, NORD, XVAL, ILEFT, BF, IDERIV+1) - CALL DCOPY (NP1, 0.D0, 0, W(NEQCON,1), MDW) - CALL DCOPY (NORD, BF(1,IDERIV+1), 1, W(NEQCON,ILEFT-NORDM1), - + MDW) -C - IF (ITYPE.EQ.2) THEN - W(NEQCON,NP1) = YCONST(IDATA) - ELSE - ILEFT = NORD - YVAL = YCONST(IDATA) -C - 200 IF (YVAL.LT.BKPT(ILEFT+1) .OR. ILEFT.GE.N) GO TO 210 - ILEFT = ILEFT + 1 - GO TO 200 -C - 210 CALL DFSPVD (BKPT, NORD, YVAL, ILEFT, BF, IDERIV+1) - CALL DAXPY (NORD, -1.D0, BF(1, IDERIV+1), 1, - + W(NEQCON, ILEFT-NORDM1), MDW) - ENDIF - ENDIF - 220 CONTINUE -C -C Transfer least squares data. -C - DO 230 I = 1,NP1 - IROW = I + NEQCON - CALL DCOPY (N, 0.D0, 0, W(IROW,1), MDW) - CALL DCOPY (MIN(NP1-I, NORD), G(I,1), MDG, W(IROW,I), MDW) - W(IROW,NP1) = G(I,NORDP1) - 230 CONTINUE -C -C Write inequality constraints. -C Analyze constraint indicators for inequality constraints. -C - NINCON = 0 - DO 260 IDATA = 1,NCONST - L = NDERIV(IDATA) - ITYPE = MOD(L,4) - IF (ITYPE.LT.2) THEN - IDERIV = L/4 - NINCON = NINCON + 1 - ILEFT = NORD - XVAL = XCONST(IDATA) -C - 240 IF (XVAL.LT.BKPT(ILEFT+1) .OR. ILEFT.GE.N) GO TO 250 - ILEFT = ILEFT + 1 - GO TO 240 -C - 250 CALL DFSPVD (BKPT, NORD, XVAL, ILEFT, BF, IDERIV+1) - IROW = NEQCON + NP1 + NINCON - CALL DCOPY (N, 0.D0, 0, W(IROW,1), MDW) - INTRVL = ILEFT - NORDM1 - CALL DCOPY (NORD, BF(1, IDERIV+1), 1, W(IROW, INTRVL), MDW) -C - IF (ITYPE.EQ.1) THEN - W(IROW,NP1) = YCONST(IDATA) - ELSE - W(IROW,NP1) = -YCONST(IDATA) - CALL DSCAL (NORD, -1.D0, W(IROW, INTRVL), MDW) - ENDIF - ENDIF - 260 CONTINUE -C -C Solve constrained least squares equations. -C - CALL DLSEI(W, MDW, NEQCON, NP1, NINCON, N, PRGOPT, COEFF, RNORME, - + RNORML, MODE, WORK, IWORK) - RETURN - END diff --git a/slatec/dfdjc1.f b/slatec/dfdjc1.f deleted file mode 100644 index c57217f..0000000 --- a/slatec/dfdjc1.f +++ /dev/null @@ -1,155 +0,0 @@ -*DECK DFDJC1 - SUBROUTINE DFDJC1 (FCN, N, X, FVEC, FJAC, LDFJAC, IFLAG, ML, MU, - + EPSFCN, WA1, WA2) -C***BEGIN PROLOGUE DFDJC1 -C***SUBSIDIARY -C***PURPOSE Subsidiary to DNSQ and DNSQE -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (FDJAC1-S, DFDJC1-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This subroutine computes a forward-difference approximation -C to the N by N Jacobian matrix associated with a specified -C problem of N functions in N variables. If the Jacobian has -C a banded form, then function evaluations are saved by only -C approximating the nonzero terms. -C -C The subroutine statement is -C -C SUBROUTINE DFDJC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN, -C WA1,WA2) -C -C where -C -C FCN is the name of the user-supplied subroutine which -C calculates the functions. FCN must be declared -C in an EXTERNAL statement in the user calling -C program, and should be written as follows. -C -C SUBROUTINE FCN(N,X,FVEC,IFLAG) -C INTEGER N,IFLAG -C DOUBLE PRECISION X(N),FVEC(N) -C ---------- -C Calculate the functions at X and -C return this vector in FVEC. -C ---------- -C RETURN -C -C The value of IFLAG should not be changed by FCN unless -C the user wants to terminate execution of DFDJC1. -C In this case set IFLAG to a negative integer. -C -C N is a positive integer input variable set to the number -C of functions and variables. -C -C X is an input array of length N. -C -C FVEC is an input array of length N which must contain the -C functions evaluated at X. -C -C FJAC is an output N by N array which contains the -C approximation to the Jacobian matrix evaluated at X. -C -C LDFJAC is a positive integer input variable not less than N -C which specifies the leading dimension of the array FJAC. -C -C IFLAG is an integer variable which can be used to terminate -C the execution of DFDJC1. See description of FCN. -C -C ML is a nonnegative integer input variable which specifies -C the number of subdiagonals within the band of the -C Jacobian matrix. If the Jacobian is not banded, set -C ML to at least N - 1. -C -C EPSFCN is an input variable used in determining a suitable -C step length for the forward-difference approximation. This -C approximation assumes that the relative errors in the -C functions are of the order of EPSFCN. If EPSFCN is less -C than the machine precision, it is assumed that the relative -C errors in the functions are of the order of the machine -C precision. -C -C MU is a nonnegative integer input variable which specifies -C the number of superdiagonals within the band of the -C Jacobian matrix. If the Jacobian is not banded, set -C MU to at least N - 1. -C -C WA1 and WA2 are work arrays of length N. If ML + MU + 1 is at -C least N, then the Jacobian is considered dense, and WA2 is -C not referenced. -C -C***SEE ALSO DNSQ, DNSQE -C***ROUTINES CALLED D1MACH -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DFDJC1 - DOUBLE PRECISION D1MACH - INTEGER I, IFLAG, J, K, LDFJAC, ML, MSUM, MU, N - DOUBLE PRECISION EPS, EPSFCN, EPSMCH, FJAC(LDFJAC,*), - 1 FVEC(*), H, TEMP, WA1(*), WA2(*), X(*), ZERO - SAVE ZERO - DATA ZERO /0.0D0/ -C -C EPSMCH IS THE MACHINE PRECISION. -C -C***FIRST EXECUTABLE STATEMENT DFDJC1 - EPSMCH = D1MACH(4) -C - EPS = SQRT(MAX(EPSFCN,EPSMCH)) - MSUM = ML + MU + 1 - IF (MSUM .LT. N) GO TO 40 -C -C COMPUTATION OF DENSE APPROXIMATE JACOBIAN. -C - DO 20 J = 1, N - TEMP = X(J) - H = EPS*ABS(TEMP) - IF (H .EQ. ZERO) H = EPS - X(J) = TEMP + H - CALL FCN(N,X,WA1,IFLAG) - IF (IFLAG .LT. 0) GO TO 30 - X(J) = TEMP - DO 10 I = 1, N - FJAC(I,J) = (WA1(I) - FVEC(I))/H - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - GO TO 110 - 40 CONTINUE -C -C COMPUTATION OF BANDED APPROXIMATE JACOBIAN. -C - DO 90 K = 1, MSUM - DO 60 J = K, N, MSUM - WA2(J) = X(J) - H = EPS*ABS(WA2(J)) - IF (H .EQ. ZERO) H = EPS - X(J) = WA2(J) + H - 60 CONTINUE - CALL FCN(N,X,WA1,IFLAG) - IF (IFLAG .LT. 0) GO TO 100 - DO 80 J = K, N, MSUM - X(J) = WA2(J) - H = EPS*ABS(WA2(J)) - IF (H .EQ. ZERO) H = EPS - DO 70 I = 1, N - FJAC(I,J) = ZERO - IF (I .GE. J - MU .AND. I .LE. J + ML) - 1 FJAC(I,J) = (WA1(I) - FVEC(I))/H - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE DFDJC1. -C - END diff --git a/slatec/dfdjc3.f b/slatec/dfdjc3.f deleted file mode 100644 index b410972..0000000 --- a/slatec/dfdjc3.f +++ /dev/null @@ -1,116 +0,0 @@ -*DECK DFDJC3 - SUBROUTINE DFDJC3 (FCN, M, N, X, FVEC, FJAC, LDFJAC, IFLAG, - + EPSFCN, WA) -C***BEGIN PROLOGUE DFDJC3 -C***SUBSIDIARY -C***PURPOSE Subsidiary to DNLS1 and DNLS1E -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (FDJAC3-S, DFDJC3-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C **** Double Precision version of FDJAC3 **** -C -C This subroutine computes a forward-difference approximation -C to the M by N Jacobian matrix associated with a specified -C problem of M functions in N variables. -C -C The subroutine statement is -C -C SUBROUTINE DFDJC3(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA) -C -C where -C -C FCN is the name of the user-supplied subroutine which -C calculates the functions. FCN must be declared -C in an external statement in the user calling -C program, and should be written as follows. -C -C SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) -C INTEGER LDFJAC,M,N,IFLAG -C DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N) -C ---------- -C When IFLAG.EQ.1 calculate the functions at X and -C return this vector in FVEC. -C ---------- -C RETURN -C END -C -C The value of IFLAG should not be changed by FCN unless -C the user wants to terminate execution of DFDJC3. -C In this case set IFLAG to a negative integer. -C -C M is a positive integer input variable set to the number -C of functions. -C -C N is a positive integer input variable set to the number -C of variables. N must not exceed M. -C -C X is an input array of length N. -C -C FVEC is an input array of length M which must contain the -C functions evaluated at X. -C -C FJAC is an output M by N array which contains the -C approximation to the Jacobian matrix evaluated at X. -C -C LDFJAC is a positive integer input variable not less than M -C which specifies the leading dimension of the array FJAC. -C -C IFLAG is an integer variable which can be used to terminate -C THE EXECUTION OF DFDJC3. See description of FCN. -C -C EPSFCN is an input variable used in determining a suitable -C step length for the forward-difference approximation. This -C approximation assumes that the relative errors in the -C functions are of the order of EPSFCN. If EPSFCN is less -C than the machine precision, it is assumed that the relative -C errors in the functions are of the order of the machine -C precision. -C -C WA is a work array of length M. -C -C***SEE ALSO DNLS1, DNLS1E -C***ROUTINES CALLED D1MACH -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DFDJC3 - INTEGER M,N,LDFJAC,IFLAG - DOUBLE PRECISION EPSFCN - DOUBLE PRECISION X(*),FVEC(*),FJAC(LDFJAC,*),WA(*) - INTEGER I,J - DOUBLE PRECISION EPS,EPSMCH,H,TEMP,ZERO - DOUBLE PRECISION D1MACH - SAVE ZERO - DATA ZERO /0.0D0/ -C***FIRST EXECUTABLE STATEMENT DFDJC3 - EPSMCH = D1MACH(4) -C - EPS = SQRT(MAX(EPSFCN,EPSMCH)) -C SET IFLAG=1 TO INDICATE THAT FUNCTION VALUES -C ARE TO BE RETURNED BY FCN. - IFLAG = 1 - DO 20 J = 1, N - TEMP = X(J) - H = EPS*ABS(TEMP) - IF (H .EQ. ZERO) H = EPS - X(J) = TEMP + H - CALL FCN(IFLAG,M,N,X,WA,FJAC,LDFJAC) - IF (IFLAG .LT. 0) GO TO 30 - X(J) = TEMP - DO 10 I = 1, M - FJAC(I,J) = (WA(I) - FVEC(I))/H - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE DFDJC3. -C - END diff --git a/slatec/dfehl.f b/slatec/dfehl.f deleted file mode 100644 index fcfb032..0000000 --- a/slatec/dfehl.f +++ /dev/null @@ -1,107 +0,0 @@ -*DECK DFEHL - SUBROUTINE DFEHL (DF, NEQ, T, Y, H, YP, F1, F2, F3, F4, F5, YS, - + RPAR, IPAR) -C***BEGIN PROLOGUE DFEHL -C***SUBSIDIARY -C***PURPOSE Subsidiary to DDERKF -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (DEFEHL-S, DFEHL-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C Fehlberg Fourth-Fifth Order Runge-Kutta Method -C ********************************************************************** -C -C DFEHL integrates a system of NEQ first order -C ordinary differential equations of the form -C DU/DX = DF(X,U) -C over one step when the vector Y(*) of initial values for U(*) and -C the vector YP(*) of initial derivatives, satisfying YP = DF(T,Y), -C are given at the starting point X=T. -C -C DFEHL advances the solution over the fixed step H and returns -C the fifth order (sixth order accurate locally) solution -C approximation at T+H in the array YS(*). -C F1,---,F5 are arrays of dimension NEQ which are needed -C for internal storage. -C The formulas have been grouped to control loss of significance. -C DFEHL should be called with an H not smaller than 13 units of -C roundoff in T so that the various independent arguments can be -C distinguished. -C -C This subroutine has been written with all variables and statement -C numbers entirely compatible with DRKFS. For greater efficiency, -C the call to DFEHL can be replaced by the module beginning with -C line 222 and extending to the last line just before the return -C statement. -C -C ********************************************************************** -C -C***SEE ALSO DDERKF -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DFEHL -C - INTEGER IPAR, K, NEQ - DOUBLE PRECISION CH, F1, F2, F3, F4, F5, H, RPAR, T, Y, YP, YS - DIMENSION Y(*),YP(*),F1(*),F2(*),F3(*),F4(*),F5(*), - 1 YS(*),RPAR(*),IPAR(*) -C -C***FIRST EXECUTABLE STATEMENT DFEHL - CH = H/4.0D0 - DO 10 K = 1, NEQ - YS(K) = Y(K) + CH*YP(K) - 10 CONTINUE - CALL DF(T+CH,YS,F1,RPAR,IPAR) -C - CH = 3.0D0*H/32.0D0 - DO 20 K = 1, NEQ - YS(K) = Y(K) + CH*(YP(K) + 3.0D0*F1(K)) - 20 CONTINUE - CALL DF(T+3.0D0*H/8.0D0,YS,F2,RPAR,IPAR) -C - CH = H/2197.0D0 - DO 30 K = 1, NEQ - YS(K) = Y(K) - 1 + CH - 2 *(1932.0D0*YP(K) + (7296.0D0*F2(K) - 7200.0D0*F1(K))) - 30 CONTINUE - CALL DF(T+12.0D0*H/13.0D0,YS,F3,RPAR,IPAR) -C - CH = H/4104.0D0 - DO 40 K = 1, NEQ - YS(K) = Y(K) - 1 + CH - 2 *((8341.0D0*YP(K) - 845.0D0*F3(K)) - 3 + (29440.0D0*F2(K) - 32832.0D0*F1(K))) - 40 CONTINUE - CALL DF(T+H,YS,F4,RPAR,IPAR) -C - CH = H/20520.0D0 - DO 50 K = 1, NEQ - YS(K) = Y(K) - 1 + CH - 2 *((-6080.0D0*YP(K) - 3 + (9295.0D0*F3(K) - 5643.0D0*F4(K))) - 4 + (41040.0D0*F1(K) - 28352.0D0*F2(K))) - 50 CONTINUE - CALL DF(T+H/2.0D0,YS,F5,RPAR,IPAR) -C -C COMPUTE APPROXIMATE SOLUTION AT T+H -C - CH = H/7618050.0D0 - DO 60 K = 1, NEQ - YS(K) = Y(K) - 1 + CH - 2 *((902880.0D0*YP(K) - 3 + (3855735.0D0*F3(K) - 1371249.0D0*F4(K))) - 4 + (3953664.0D0*F2(K) + 277020.0D0*F5(K))) - 60 CONTINUE -C - RETURN - END diff --git a/slatec/dfspvd.f b/slatec/dfspvd.f deleted file mode 100644 index 76a1b75..0000000 --- a/slatec/dfspvd.f +++ /dev/null @@ -1,73 +0,0 @@ -*DECK DFSPVD - SUBROUTINE DFSPVD (T, K, X, ILEFT, VNIKX, NDERIV) -C***BEGIN PROLOGUE DFSPVD -C***SUBSIDIARY -C***PURPOSE Subsidiary to DFC -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (BSPLVD-S, DFSPVD-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C **** Double Precision Version of BSPLVD **** -C Calculates value and deriv.s of all B-splines which do not vanish at X -C -C Fill VNIKX(J,IDERIV), J=IDERIV, ... ,K with nonzero values of -C B-splines of order K+1-IDERIV , IDERIV=NDERIV, ... ,1, by repeated -C calls to DFSPVN -C -C***SEE ALSO DFC -C***ROUTINES CALLED DFSPVN -C***REVISION HISTORY (YYMMDD) -C 780801 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DFSPVD - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION T(*),VNIKX(K,*) - DIMENSION A(20,20) -C***FIRST EXECUTABLE STATEMENT DFSPVD - CALL DFSPVN(T,K+1-NDERIV,1,X,ILEFT,VNIKX(NDERIV,NDERIV)) - IF (NDERIV .LE. 1) GO TO 99 - IDERIV = NDERIV - DO 15 I=2,NDERIV - IDERVM = IDERIV-1 - DO 11 J=IDERIV,K - 11 VNIKX(J-1,IDERVM) = VNIKX(J,IDERIV) - IDERIV = IDERVM - CALL DFSPVN(T,0,2,X,ILEFT,VNIKX(IDERIV,IDERIV)) - 15 CONTINUE -C - DO 20 I=1,K - DO 19 J=1,K - 19 A(I,J) = 0.D0 - 20 A(I,I) = 1.D0 - KMD = K - DO 40 M=2,NDERIV - KMD = KMD-1 - FKMD = KMD - I = ILEFT - J = K - 21 JM1 = J-1 - IPKMD = I + KMD - DIFF = T(IPKMD) - T(I) - IF (JM1 .EQ. 0) GO TO 26 - IF (DIFF .EQ. 0.D0) GO TO 25 - DO 24 L=1,J - 24 A(L,J) = (A(L,J) - A(L,J-1))/DIFF*FKMD - 25 J = JM1 - I = I - 1 - GO TO 21 - 26 IF (DIFF .EQ. 0.) GO TO 30 - A(1,1) = A(1,1)/DIFF*FKMD -C - 30 DO 40 I=1,K - V = 0.D0 - JLOW = MAX(I,M) - DO 35 J=JLOW,K - 35 V = A(I,J)*VNIKX(J,M) + V - 40 VNIKX(I,M) = V - 99 RETURN - END diff --git a/slatec/dfspvn.f b/slatec/dfspvn.f deleted file mode 100644 index 9b9c466..0000000 --- a/slatec/dfspvn.f +++ /dev/null @@ -1,50 +0,0 @@ -*DECK DFSPVN - SUBROUTINE DFSPVN (T, JHIGH, INDEX, X, ILEFT, VNIKX) -C***BEGIN PROLOGUE DFSPVN -C***SUBSIDIARY -C***PURPOSE Subsidiary to DFC -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (BSPLVN-S, DFSPVN-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C **** Double Precision version of BSPLVN **** -C -C Calculates the value of all possibly nonzero B-splines at *X* of -C order MAX(JHIGH,(J+1)(INDEX-1)) on *T*. -C -C***SEE ALSO DFC -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 780801 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DFSPVN - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION T(*),VNIKX(*) - DIMENSION DELTAM(20),DELTAP(20) - SAVE J, DELTAM, DELTAP - DATA J/1/,(DELTAM(I),I=1,20),(DELTAP(I),I=1,20)/40*0.0D0/ -C***FIRST EXECUTABLE STATEMENT DFSPVN - GO TO (10,20),INDEX - 10 J = 1 - VNIKX(1) = 1.D0 - IF (J .GE. JHIGH) GO TO 99 -C - 20 IPJ = ILEFT+J - DELTAP(J) = T(IPJ) - X - IMJP1 = ILEFT-J+1 - DELTAM(J) = X - T(IMJP1) - VMPREV = 0.D0 - JP1 = J+1 - DO 26 L=1,J - JP1ML = JP1-L - VM = VNIKX(L)/(DELTAP(L) + DELTAM(JP1ML)) - VNIKX(L) = VM*DELTAP(L) + VMPREV - 26 VMPREV = VM*DELTAM(JP1ML) - VNIKX(JP1) = VMPREV - J = JP1 - IF (J .LT. JHIGH) GO TO 20 -C - 99 RETURN - END diff --git a/slatec/dfulmt.f b/slatec/dfulmt.f deleted file mode 100644 index 120f5b5..0000000 --- a/slatec/dfulmt.f +++ /dev/null @@ -1,86 +0,0 @@ -*DECK DFULMT - SUBROUTINE DFULMT (I, J, AIJ, INDCAT, PRGOPT, DATTRV, IFLAG) -C***BEGIN PROLOGUE DFULMT -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSPLP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (FULMAT-S, DFULMT-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C DECODES A STANDARD TWO-DIMENSIONAL FORTRAN ARRAY PASSED -C IN THE ARRAY DATTRV(IA,*). THE ROW DIMENSION IA AND THE -C MATRIX DIMENSIONS MRELAS AND NVARS MUST SIMULTANEOUSLY BE -C PASSED USING THE OPTION ARRAY, PRGOPT(*). IT IS AN ERROR -C IF THIS DATA IS NOT PASSED TO DFULMT( ). -C EXAMPLE-- (FOR USE TOGETHER WITH DSPLP().) -C EXTERNAL DUSRMT -C DIMENSION DATTRV(IA,*) -C PRGOPT(01)=7 -C PRGOPT(02)=68 -C PRGOPT(03)=1 -C PRGOPT(04)=IA -C PRGOPT(05)=MRELAS -C PRGOPT(06)=NVARS -C PRGOPT(07)=1 -C CALL DSPLP( ... DFULMT INSTEAD OF DUSRMT...) -C -C***SEE ALSO DSPLP -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DFULMT - DOUBLE PRECISION AIJ,ZERO,DATTRV(*),PRGOPT(*) - INTEGER IFLAG(10) - SAVE ZERO -C***FIRST EXECUTABLE STATEMENT DFULMT - IF (.NOT.(IFLAG(1).EQ.1)) GO TO 50 -C INITIALIZE POINTERS TO PROCESS FULL TWO-DIMENSIONAL FORTRAN -C ARRAYS. - ZERO = 0.D0 - LP = 1 - 10 NEXT = PRGOPT(LP) - IF (.NOT.(NEXT.LE.1)) GO TO 20 - NERR = 29 - LEVEL = 1 - CALL XERMSG ('SLATEC', 'DFULMT', - + 'IN DSPLP, ROW DIM., MRELAS, NVARS ARE MISSING FROM PRGOPT.', - + NERR, LEVEL) - IFLAG(1) = 3 - GO TO 110 - 20 KEY = PRGOPT(LP+1) - IF (.NOT.(KEY.NE.68)) GO TO 30 - LP = NEXT - GO TO 10 - 30 IF (.NOT.(PRGOPT(LP+2).EQ.ZERO)) GO TO 40 - LP = NEXT - GO TO 10 - 40 IFLAG(2) = 1 - IFLAG(3) = 1 - IFLAG(4) = PRGOPT(LP+3) - IFLAG(5) = PRGOPT(LP+4) - IFLAG(6) = PRGOPT(LP+5) - GO TO 110 - 50 IF (.NOT.(IFLAG(1).EQ.2)) GO TO 100 - 60 I = IFLAG(2) - J = IFLAG(3) - IF (.NOT.(J.GT.IFLAG(6))) GO TO 70 - IFLAG(1) = 3 - GO TO 110 - 70 IF (.NOT.(I.GT.IFLAG(5))) GO TO 80 - IFLAG(2) = 1 - IFLAG(3) = J + 1 - GO TO 60 - 80 AIJ = DATTRV(IFLAG(4)*(J-1)+I) - IFLAG(2) = I + 1 - IF (.NOT.(AIJ.EQ.ZERO)) GO TO 90 - GO TO 60 - 90 INDCAT = 0 - GO TO 110 - 100 CONTINUE - 110 RETURN - END diff --git a/slatec/dfzero.f b/slatec/dfzero.f deleted file mode 100644 index 5943818..0000000 --- a/slatec/dfzero.f +++ /dev/null @@ -1,225 +0,0 @@ -*DECK DFZERO - SUBROUTINE DFZERO (F, B, C, R, RE, AE, IFLAG) -C***BEGIN PROLOGUE DFZERO -C***PURPOSE Search for a zero of a function F(X) in a given interval -C (B,C). It is designed primarily for problems where F(B) -C and F(C) have opposite signs. -C***LIBRARY SLATEC -C***CATEGORY F1B -C***TYPE DOUBLE PRECISION (FZERO-S, DFZERO-D) -C***KEYWORDS BISECTION, NONLINEAR, ROOTS, ZEROS -C***AUTHOR Shampine, L. F., (SNLA) -C Watts, H. A., (SNLA) -C***DESCRIPTION -C -C DFZERO searches for a zero of a DOUBLE PRECISION function F(X) -C between the given DOUBLE PRECISION values B and C until the width -C of the interval (B,C) has collapsed to within a tolerance -C specified by the stopping criterion, -C ABS(B-C) .LE. 2.*(RW*ABS(B)+AE). -C The method used is an efficient combination of bisection and the -C secant rule and is due to T. J. Dekker. -C -C Description Of Arguments -C -C F :EXT - Name of the DOUBLE PRECISION external function. This -C name must be in an EXTERNAL statement in the calling -C program. F must be a function of one DOUBLE -C PRECISION argument. -C -C B :INOUT - One end of the DOUBLE PRECISION interval (B,C). The -C value returned for B usually is the better -C approximation to a zero of F. -C -C C :INOUT - The other end of the DOUBLE PRECISION interval (B,C) -C -C R :IN - A (better) DOUBLE PRECISION guess of a zero of F -C which could help in speeding up convergence. If F(B) -C and F(R) have opposite signs, a root will be found in -C the interval (B,R); if not, but F(R) and F(C) have -C opposite signs, a root will be found in the interval -C (R,C); otherwise, the interval (B,C) will be -C searched for a possible root. When no better guess -C is known, it is recommended that R be set to B or C, -C since if R is not interior to the interval (B,C), it -C will be ignored. -C -C RE :IN - Relative error used for RW in the stopping criterion. -C If the requested RE is less than machine precision, -C then RW is set to approximately machine precision. -C -C AE :IN - Absolute error used in the stopping criterion. If -C the given interval (B,C) contains the origin, then a -C nonzero value should be chosen for AE. -C -C IFLAG :OUT - A status code. User must check IFLAG after each -C call. Control returns to the user from DFZERO in all -C cases. -C -C 1 B is within the requested tolerance of a zero. -C The interval (B,C) collapsed to the requested -C tolerance, the function changes sign in (B,C), and -C F(X) decreased in magnitude as (B,C) collapsed. -C -C 2 F(B) = 0. However, the interval (B,C) may not have -C collapsed to the requested tolerance. -C -C 3 B may be near a singular point of F(X). -C The interval (B,C) collapsed to the requested tol- -C erance and the function changes sign in (B,C), but -C F(X) increased in magnitude as (B,C) collapsed, i.e. -C ABS(F(B out)) .GT. MAX(ABS(F(B in)),ABS(F(C in))) -C -C 4 No change in sign of F(X) was found although the -C interval (B,C) collapsed to the requested tolerance. -C The user must examine this case and decide whether -C B is near a local minimum of F(X), or B is near a -C zero of even multiplicity, or neither of these. -C -C 5 Too many (.GT. 500) function evaluations used. -C -C***REFERENCES L. F. Shampine and H. A. Watts, FZERO, a root-solving -C code, Report SC-TM-70-631, Sandia Laboratories, -C September 1970. -C T. J. Dekker, Finding a zero by means of successive -C linear interpolation, Constructive Aspects of the -C Fundamental Theorem of Algebra, edited by B. Dejon -C and P. Henrici, Wiley-Interscience, 1969. -C***ROUTINES CALLED D1MACH -C***REVISION HISTORY (YYMMDD) -C 700901 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 DFZERO - DOUBLE PRECISION A,ACBS,ACMB,AE,AW,B,C,CMB,D1MACH,ER, - + F,FA,FB,FC,FX,FZ,P,Q,R,RE,RW,T,TOL,Z - INTEGER IC,IFLAG,KOUNT -C -C***FIRST EXECUTABLE STATEMENT DFZERO -C -C ER is two times the computer unit roundoff value which is defined -C here by the function D1MACH. -C - ER = 2.0D0 * D1MACH(4) -C -C Initialize. -C - Z = R - IF (R .LE. MIN(B,C) .OR. R .GE. MAX(B,C)) Z = C - RW = MAX(RE,ER) - AW = MAX(AE,0.D0) - IC = 0 - T = Z - FZ = F(T) - FC = FZ - T = B - FB = F(T) - KOUNT = 2 - IF (SIGN(1.0D0,FZ) .EQ. SIGN(1.0D0,FB)) GO TO 1 - C = Z - GO TO 2 - 1 IF (Z .EQ. C) GO TO 2 - T = C - FC = F(T) - KOUNT = 3 - IF (SIGN(1.0D0,FZ) .EQ. SIGN(1.0D0,FC)) GO TO 2 - B = Z - FB = FZ - 2 A = C - FA = FC - ACBS = ABS(B-C) - FX = MAX(ABS(FB),ABS(FC)) -C - 3 IF (ABS(FC) .GE. ABS(FB)) GO TO 4 -C -C Perform interchange. -C - A = B - FA = FB - B = C - FB = FC - C = A - FC = FA -C - 4 CMB = 0.5D0*(C-B) - ACMB = ABS(CMB) - TOL = RW*ABS(B) + AW -C -C Test stopping criterion and function count. -C - IF (ACMB .LE. TOL) GO TO 10 - IF (FB .EQ. 0.D0) GO TO 11 - IF (KOUNT .GE. 500) GO TO 14 -C -C Calculate new iterate implicitly as B+P/Q, where we arrange -C P .GE. 0. The implicit form is used to prevent overflow. -C - P = (B-A)*FB - Q = FA - FB - IF (P .GE. 0.D0) GO TO 5 - P = -P - Q = -Q -C -C Update A and check for satisfactory reduction in the size of the -C bracketing interval. If not, perform bisection. -C - 5 A = B - FA = FB - IC = IC + 1 - IF (IC .LT. 4) GO TO 6 - IF (8.0D0*ACMB .GE. ACBS) GO TO 8 - IC = 0 - ACBS = ACMB -C -C Test for too small a change. -C - 6 IF (P .GT. ABS(Q)*TOL) GO TO 7 -C -C Increment by TOLerance. -C - B = B + SIGN(TOL,CMB) - GO TO 9 -C -C Root ought to be between B and (C+B)/2. -C - 7 IF (P .GE. CMB*Q) GO TO 8 -C -C Use secant rule. -C - B = B + P/Q - GO TO 9 -C -C Use bisection (C+B)/2. -C - 8 B = B + CMB -C -C Have completed computation for new iterate B. -C - 9 T = B - FB = F(T) - KOUNT = KOUNT + 1 -C -C Decide whether next step is interpolation or extrapolation. -C - IF (SIGN(1.0D0,FB) .NE. SIGN(1.0D0,FC)) GO TO 3 - C = A - FC = FA - GO TO 3 -C -C Finished. Process results for proper setting of IFLAG. -C - 10 IF (SIGN(1.0D0,FB) .EQ. SIGN(1.0D0,FC)) GO TO 13 - IF (ABS(FB) .GT. FX) GO TO 12 - IFLAG = 1 - RETURN - 11 IFLAG = 2 - RETURN - 12 IFLAG = 3 - RETURN - 13 IFLAG = 4 - RETURN - 14 IFLAG = 5 - RETURN - END diff --git a/slatec/dgami.f b/slatec/dgami.f deleted file mode 100644 index 4c4eccf..0000000 --- a/slatec/dgami.f +++ /dev/null @@ -1,46 +0,0 @@ -*DECK DGAMI - DOUBLE PRECISION FUNCTION DGAMI (A, X) -C***BEGIN PROLOGUE DGAMI -C***PURPOSE Evaluate the incomplete Gamma function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE DOUBLE PRECISION (GAMI-S, DGAMI-D) -C***KEYWORDS FNLIB, INCOMPLETE GAMMA FUNCTION, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate the incomplete gamma function defined by -C -C DGAMI = integral from T = 0 to X of EXP(-T) * T**(A-1.0) . -C -C DGAMI is evaluated for positive values of A and non-negative values -C of X. A slight deterioration of 2 or 3 digits accuracy will occur -C when DGAMI is very large or very small, because logarithmic variables -C are used. The function and both arguments are double precision. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED DGAMIT, DLNGAM, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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***END PROLOGUE DGAMI - DOUBLE PRECISION A, X, FACTOR, DLNGAM, DGAMIT -C***FIRST EXECUTABLE STATEMENT DGAMI - IF (A .LE. 0.D0) CALL XERMSG ('SLATEC', 'DGAMI', - + 'A MUST BE GT ZERO', 1, 2) - IF (X .LT. 0.D0) CALL XERMSG ('SLATEC', 'DGAMI', - + 'X MUST BE GE ZERO', 2, 2) -C - DGAMI = 0.D0 - IF (X.EQ.0.0D0) RETURN -C -C THE ONLY ERROR POSSIBLE IN THE EXPRESSION BELOW IS A FATAL OVERFLOW. - FACTOR = EXP (DLNGAM(A) + A*LOG(X)) -C - DGAMI = FACTOR * DGAMIT (A, X) -C - RETURN - END diff --git a/slatec/dgamic.f b/slatec/dgamic.f deleted file mode 100644 index 4efb975..0000000 --- a/slatec/dgamic.f +++ /dev/null @@ -1,129 +0,0 @@ -*DECK DGAMIC - DOUBLE PRECISION FUNCTION DGAMIC (A, X) -C***BEGIN PROLOGUE DGAMIC -C***PURPOSE Calculate the complementary incomplete Gamma function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE DOUBLE PRECISION (GAMIC-S, DGAMIC-D) -C***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate the complementary incomplete Gamma function -C -C DGAMIC = integral from X to infinity of EXP(-T) * T**(A-1.) . -C -C DGAMIC is evaluated for arbitrary real values of A and for non- -C negative values of X (even though DGAMIC is defined for X .LT. -C 0.0), except that for X = 0 and A .LE. 0.0, DGAMIC is undefined. -C -C DGAMIC, A, and X are DOUBLE PRECISION. -C -C A slight deterioration of 2 or 3 digits accuracy will occur when -C DGAMIC is very large or very small in absolute value, because log- -C arithmic variables are used. Also, if the parameter A is very close -C to a negative INTEGER (but not a negative integer), there is a loss -C of accuracy, which is reported if the result is less than half -C machine precision. -C -C***REFERENCES W. Gautschi, A computational procedure for incomplete -C gamma functions, ACM Transactions on Mathematical -C Software 5, 4 (December 1979), pp. 466-481. -C W. Gautschi, Incomplete gamma functions, Algorithm 542, -C ACM Transactions on Mathematical Software 5, 4 -C (December 1979), pp. 482-489. -C***ROUTINES CALLED D1MACH, D9GMIC, D9GMIT, D9LGIC, D9LGIT, DLGAMS, -C DLNGAM, XERCLR, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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 920528 DESCRIPTION and REFERENCES sections revised. (WRB) -C***END PROLOGUE DGAMIC - DOUBLE PRECISION A, X, AEPS, AINTA, ALGAP1, ALNEPS, ALNGS, ALX, - 1 BOT, E, EPS, GSTAR, H, SGA, SGNG, SGNGAM, SGNGS, SQEPS, T, - 2 D1MACH, DLNGAM, D9GMIC, D9GMIT, D9LGIC, D9LGIT - LOGICAL FIRST - SAVE EPS, SQEPS, ALNEPS, BOT, FIRST - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DGAMIC - IF (FIRST) THEN - EPS = 0.5D0*D1MACH(3) - SQEPS = SQRT(D1MACH(4)) - ALNEPS = -LOG (D1MACH(3)) - BOT = LOG (D1MACH(1)) - ENDIF - FIRST = .FALSE. -C - IF (X .LT. 0.D0) CALL XERMSG ('SLATEC', 'DGAMIC', 'X IS NEGATIVE' - + , 2, 2) -C - IF (X.GT.0.D0) GO TO 20 - IF (A .LE. 0.D0) CALL XERMSG ('SLATEC', 'DGAMIC', - + 'X = 0 AND A LE 0 SO DGAMIC IS UNDEFINED', 3, 2) -C - DGAMIC = EXP (DLNGAM(A+1.D0) - LOG(A)) - RETURN -C - 20 ALX = LOG (X) - SGA = 1.0D0 - IF (A.NE.0.D0) SGA = SIGN (1.0D0, A) - AINTA = AINT (A + 0.5D0*SGA) - AEPS = A - AINTA -C - IZERO = 0 - IF (X.GE.1.0D0) GO TO 40 -C - IF (A.GT.0.5D0 .OR. ABS(AEPS).GT.0.001D0) GO TO 30 - E = 2.0D0 - IF (-AINTA.GT.1.D0) E = 2.D0*(-AINTA+2.D0)/(AINTA*AINTA-1.0D0) - E = E - ALX * X**(-0.001D0) - IF (E*ABS(AEPS).GT.EPS) GO TO 30 -C - DGAMIC = D9GMIC (A, X, ALX) - RETURN -C - 30 CALL DLGAMS (A+1.0D0, ALGAP1, SGNGAM) - GSTAR = D9GMIT (A, X, ALGAP1, SGNGAM, ALX) - IF (GSTAR.EQ.0.D0) IZERO = 1 - IF (GSTAR.NE.0.D0) ALNGS = LOG (ABS(GSTAR)) - IF (GSTAR.NE.0.D0) SGNGS = SIGN (1.0D0, GSTAR) - GO TO 50 -C - 40 IF (A.LT.X) DGAMIC = EXP (D9LGIC(A, X, ALX)) - IF (A.LT.X) RETURN -C - SGNGAM = 1.0D0 - ALGAP1 = DLNGAM (A+1.0D0) - SGNGS = 1.0D0 - ALNGS = D9LGIT (A, X, ALGAP1) -C -C EVALUATION OF DGAMIC(A,X) IN TERMS OF TRICOMI-S INCOMPLETE GAMMA FN. -C - 50 H = 1.D0 - IF (IZERO.EQ.1) GO TO 60 -C - T = A*ALX + ALNGS - IF (T.GT.ALNEPS) GO TO 70 - IF (T.GT.(-ALNEPS)) H = 1.0D0 - SGNGS*EXP(T) -C - IF (ABS(H).LT.SQEPS) CALL XERCLR - IF (ABS(H) .LT. SQEPS) CALL XERMSG ('SLATEC', 'DGAMIC', - + 'RESULT LT HALF PRECISION', 1, 1) -C - 60 SGNG = SIGN (1.0D0, H) * SGA * SGNGAM - T = LOG(ABS(H)) + ALGAP1 - LOG(ABS(A)) - IF (T.LT.BOT) CALL XERCLR - DGAMIC = SGNG * EXP(T) - RETURN -C - 70 SGNG = -SGNGS * SGA * SGNGAM - T = T + ALGAP1 - LOG(ABS(A)) - IF (T.LT.BOT) CALL XERCLR - DGAMIC = SGNG * EXP(T) - RETURN -C - END diff --git a/slatec/dgamit.f b/slatec/dgamit.f deleted file mode 100644 index 68c0092..0000000 --- a/slatec/dgamit.f +++ /dev/null @@ -1,119 +0,0 @@ -*DECK DGAMIT - DOUBLE PRECISION FUNCTION DGAMIT (A, X) -C***BEGIN PROLOGUE DGAMIT -C***PURPOSE Calculate Tricomi's form of the incomplete Gamma function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE DOUBLE PRECISION (GAMIT-S, DGAMIT-D) -C***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, -C SPECIAL FUNCTIONS, TRICOMI -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate Tricomi's incomplete Gamma function defined by -C -C DGAMIT = X**(-A)/GAMMA(A) * integral from 0 to X of EXP(-T) * -C T**(A-1.) -C -C for A .GT. 0.0 and by analytic continuation for A .LE. 0.0. -C GAMMA(X) is the complete gamma function of X. -C -C DGAMIT is evaluated for arbitrary real values of A and for non- -C negative values of X (even though DGAMIT is defined for X .LT. -C 0.0), except that for X = 0 and A .LE. 0.0, DGAMIT is infinite, -C which is a fatal error. -C -C The function and both arguments are DOUBLE PRECISION. -C -C A slight deterioration of 2 or 3 digits accuracy will occur when -C DGAMIT is very large or very small in absolute value, because log- -C arithmic variables are used. Also, if the parameter A is very -C close to a negative integer (but not a negative integer), there is -C a loss of accuracy, which is reported if the result is less than -C half machine precision. -C -C***REFERENCES W. Gautschi, A computational procedure for incomplete -C gamma functions, ACM Transactions on Mathematical -C Software 5, 4 (December 1979), pp. 466-481. -C W. Gautschi, Incomplete gamma functions, Algorithm 542, -C ACM Transactions on Mathematical Software 5, 4 -C (December 1979), pp. 482-489. -C***ROUTINES CALLED D1MACH, D9GMIT, D9LGIC, D9LGIT, DGAMR, DLGAMS, -C DLNGAM, XERCLR, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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 920528 DESCRIPTION and REFERENCES sections revised. (WRB) -C***END PROLOGUE DGAMIT - DOUBLE PRECISION A, X, AEPS, AINTA, ALGAP1, ALNEPS, ALNG, ALX, - 1 BOT, H, SGA, SGNGAM, SQEPS, T, D1MACH, DGAMR, D9GMIT, D9LGIT, - 2 DLNGAM, D9LGIC - LOGICAL FIRST - SAVE ALNEPS, SQEPS, BOT, FIRST - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DGAMIT - IF (FIRST) THEN - ALNEPS = -LOG (D1MACH(3)) - SQEPS = SQRT(D1MACH(4)) - BOT = LOG (D1MACH(1)) - ENDIF - FIRST = .FALSE. -C - IF (X .LT. 0.D0) CALL XERMSG ('SLATEC', 'DGAMIT', 'X IS NEGATIVE' - + , 2, 2) -C - IF (X.NE.0.D0) ALX = LOG (X) - SGA = 1.0D0 - IF (A.NE.0.D0) SGA = SIGN (1.0D0, A) - AINTA = AINT (A + 0.5D0*SGA) - AEPS = A - AINTA -C - IF (X.GT.0.D0) GO TO 20 - DGAMIT = 0.0D0 - IF (AINTA.GT.0.D0 .OR. AEPS.NE.0.D0) DGAMIT = DGAMR(A+1.0D0) - RETURN -C - 20 IF (X.GT.1.D0) GO TO 30 - IF (A.GE.(-0.5D0) .OR. AEPS.NE.0.D0) CALL DLGAMS (A+1.0D0, ALGAP1, - 1 SGNGAM) - DGAMIT = D9GMIT (A, X, ALGAP1, SGNGAM, ALX) - RETURN -C - 30 IF (A.LT.X) GO TO 40 - T = D9LGIT (A, X, DLNGAM(A+1.0D0)) - IF (T.LT.BOT) CALL XERCLR - DGAMIT = EXP (T) - RETURN -C - 40 ALNG = D9LGIC (A, X, ALX) -C -C EVALUATE DGAMIT IN TERMS OF LOG (DGAMIC (A, X)) -C - H = 1.0D0 - IF (AEPS.EQ.0.D0 .AND. AINTA.LE.0.D0) GO TO 50 -C - CALL DLGAMS (A+1.0D0, ALGAP1, SGNGAM) - T = LOG (ABS(A)) + ALNG - ALGAP1 - IF (T.GT.ALNEPS) GO TO 60 -C - IF (T.GT.(-ALNEPS)) H = 1.0D0 - SGA * SGNGAM * EXP(T) - IF (ABS(H).GT.SQEPS) GO TO 50 -C - CALL XERCLR - CALL XERMSG ('SLATEC', 'DGAMIT', 'RESULT LT HALF PRECISION', 1, - + 1) -C - 50 T = -A*ALX + LOG(ABS(H)) - IF (T.LT.BOT) CALL XERCLR - DGAMIT = SIGN (EXP(T), H) - RETURN -C - 60 T = T - A*ALX - IF (T.LT.BOT) CALL XERCLR - DGAMIT = -SGA * SGNGAM * EXP(T) - RETURN -C - END diff --git a/slatec/dgamlm.f b/slatec/dgamlm.f deleted file mode 100644 index 7604c88..0000000 --- a/slatec/dgamlm.f +++ /dev/null @@ -1,62 +0,0 @@ -*DECK DGAMLM - SUBROUTINE DGAMLM (XMIN, XMAX) -C***BEGIN PROLOGUE DGAMLM -C***PURPOSE Compute the minimum and maximum bounds for the argument in -C the Gamma function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7A, R2 -C***TYPE DOUBLE PRECISION (GAMLIM-S, DGAMLM-D) -C***KEYWORDS COMPLETE GAMMA FUNCTION, FNLIB, LIMITS, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Calculate the minimum and maximum legal bounds for X in gamma(X). -C XMIN and XMAX are not the only bounds, but they are the only non- -C trivial ones to calculate. -C -C Output Arguments -- -C XMIN double precision minimum legal value of X in gamma(X). Any -C smaller value of X might result in underflow. -C XMAX double precision maximum legal value of X in gamma(X). Any -C larger value of X might cause overflow. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 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***END PROLOGUE DGAMLM - DOUBLE PRECISION XMIN, XMAX, ALNBIG, ALNSML, XLN, XOLD, D1MACH -C***FIRST EXECUTABLE STATEMENT DGAMLM - ALNSML = LOG(D1MACH(1)) - XMIN = -ALNSML - DO 10 I=1,10 - XOLD = XMIN - XLN = LOG(XMIN) - XMIN = XMIN - XMIN*((XMIN+0.5D0)*XLN - XMIN - 0.2258D0 + ALNSML) - 1 / (XMIN*XLN+0.5D0) - IF (ABS(XMIN-XOLD).LT.0.005D0) GO TO 20 - 10 CONTINUE - CALL XERMSG ('SLATEC', 'DGAMLM', 'UNABLE TO FIND XMIN', 1, 2) -C - 20 XMIN = -XMIN + 0.01D0 -C - ALNBIG = LOG (D1MACH(2)) - XMAX = ALNBIG - DO 30 I=1,10 - XOLD = XMAX - XLN = LOG(XMAX) - XMAX = XMAX - XMAX*((XMAX-0.5D0)*XLN - XMAX + 0.9189D0 - ALNBIG) - 1 / (XMAX*XLN-0.5D0) - IF (ABS(XMAX-XOLD).LT.0.005D0) GO TO 40 - 30 CONTINUE - CALL XERMSG ('SLATEC', 'DGAMLM', 'UNABLE TO FIND XMAX', 2, 2) -C - 40 XMAX = XMAX - 0.01D0 - XMIN = MAX (XMIN, -XMAX+1.D0) -C - RETURN - END diff --git a/slatec/dgamln.f b/slatec/dgamln.f deleted file mode 100644 index bd2131f..0000000 --- a/slatec/dgamln.f +++ /dev/null @@ -1,198 +0,0 @@ -*DECK DGAMLN - DOUBLE PRECISION FUNCTION DGAMLN (Z, IERR) -C***BEGIN PROLOGUE DGAMLN -C***SUBSIDIARY -C***PURPOSE Compute the logarithm of the Gamma function -C***LIBRARY SLATEC -C***CATEGORY C7A -C***TYPE DOUBLE PRECISION (GAMLN-S, DGAMLN-D) -C***KEYWORDS LOGARITHM OF GAMMA FUNCTION -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C **** A DOUBLE PRECISION ROUTINE **** -C DGAMLN COMPUTES THE NATURAL LOG OF THE GAMMA FUNCTION FOR -C Z.GT.0. THE ASYMPTOTIC EXPANSION IS USED TO GENERATE VALUES -C GREATER THAN ZMIN WHICH ARE ADJUSTED BY THE RECURSION -C G(Z+1)=Z*G(Z) FOR Z.LE.ZMIN. THE FUNCTION WAS MADE AS -C PORTABLE AS POSSIBLE BY COMPUTING ZMIN FROM THE NUMBER OF BASE -C 10 DIGITS IN A WORD, RLN=MAX(-ALOG10(R1MACH(4)),0.5E-18) -C LIMITED TO 18 DIGITS OF (RELATIVE) ACCURACY. -C -C SINCE INTEGER ARGUMENTS ARE COMMON, A TABLE LOOK UP ON 100 -C VALUES IS USED FOR SPEED OF EXECUTION. -C -C DESCRIPTION OF ARGUMENTS -C -C INPUT Z IS D0UBLE PRECISION -C Z - ARGUMENT, Z.GT.0.0D0 -C -C OUTPUT DGAMLN IS DOUBLE PRECISION -C DGAMLN - NATURAL LOG OF THE GAMMA FUNCTION AT Z.NE.0.0D0 -C IERR - ERROR FLAG -C IERR=0, NORMAL RETURN, COMPUTATION COMPLETED -C IERR=1, Z.LE.0.0D0, NO COMPUTATION -C -C -C***REFERENCES COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT -C BY D. E. AMOS, SAND83-0083, MAY, 1983. -C***ROUTINES CALLED D1MACH, I1MACH -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 830501 REVISION DATE from Version 3.2 -C 910415 Prologue converted to Version 4.0 format. (BAB) -C 920128 Category corrected. (WRB) -C 921215 DGAMLN defined for Z negative. (WRB) -C***END PROLOGUE DGAMLN - DOUBLE PRECISION CF, CON, FLN, FZ, GLN, RLN, S, TLG, TRM, TST, - * T1, WDTOL, Z, ZDMY, ZINC, ZM, ZMIN, ZP, ZSQ, D1MACH - INTEGER I, IERR, I1M, K, MZ, NZ, I1MACH - DIMENSION CF(22), GLN(100) -C LNGAMMA(N), N=1,100 - DATA GLN(1), GLN(2), GLN(3), GLN(4), GLN(5), GLN(6), GLN(7), - 1 GLN(8), GLN(9), GLN(10), GLN(11), GLN(12), GLN(13), GLN(14), - 2 GLN(15), GLN(16), GLN(17), GLN(18), GLN(19), GLN(20), - 3 GLN(21), GLN(22)/ - 4 0.00000000000000000D+00, 0.00000000000000000D+00, - 5 6.93147180559945309D-01, 1.79175946922805500D+00, - 6 3.17805383034794562D+00, 4.78749174278204599D+00, - 7 6.57925121201010100D+00, 8.52516136106541430D+00, - 8 1.06046029027452502D+01, 1.28018274800814696D+01, - 9 1.51044125730755153D+01, 1.75023078458738858D+01, - A 1.99872144956618861D+01, 2.25521638531234229D+01, - B 2.51912211827386815D+01, 2.78992713838408916D+01, - C 3.06718601060806728D+01, 3.35050734501368889D+01, - D 3.63954452080330536D+01, 3.93398841871994940D+01, - E 4.23356164607534850D+01, 4.53801388984769080D+01/ - DATA GLN(23), GLN(24), GLN(25), GLN(26), GLN(27), GLN(28), - 1 GLN(29), GLN(30), GLN(31), GLN(32), GLN(33), GLN(34), - 2 GLN(35), GLN(36), GLN(37), GLN(38), GLN(39), GLN(40), - 3 GLN(41), GLN(42), GLN(43), GLN(44)/ - 4 4.84711813518352239D+01, 5.16066755677643736D+01, - 5 5.47847293981123192D+01, 5.80036052229805199D+01, - 6 6.12617017610020020D+01, 6.45575386270063311D+01, - 7 6.78897431371815350D+01, 7.12570389671680090D+01, - 8 7.46582363488301644D+01, 7.80922235533153106D+01, - 9 8.15579594561150372D+01, 8.50544670175815174D+01, - A 8.85808275421976788D+01, 9.21361756036870925D+01, - B 9.57196945421432025D+01, 9.93306124547874269D+01, - C 1.02968198614513813D+02, 1.06631760260643459D+02, - D 1.10320639714757395D+02, 1.14034211781461703D+02, - E 1.17771881399745072D+02, 1.21533081515438634D+02/ - DATA GLN(45), GLN(46), GLN(47), GLN(48), GLN(49), GLN(50), - 1 GLN(51), GLN(52), GLN(53), GLN(54), GLN(55), GLN(56), - 2 GLN(57), GLN(58), GLN(59), GLN(60), GLN(61), GLN(62), - 3 GLN(63), GLN(64), GLN(65), GLN(66)/ - 4 1.25317271149356895D+02, 1.29123933639127215D+02, - 5 1.32952575035616310D+02, 1.36802722637326368D+02, - 6 1.40673923648234259D+02, 1.44565743946344886D+02, - 7 1.48477766951773032D+02, 1.52409592584497358D+02, - 8 1.56360836303078785D+02, 1.60331128216630907D+02, - 9 1.64320112263195181D+02, 1.68327445448427652D+02, - A 1.72352797139162802D+02, 1.76395848406997352D+02, - B 1.80456291417543771D+02, 1.84533828861449491D+02, - C 1.88628173423671591D+02, 1.92739047287844902D+02, - D 1.96866181672889994D+02, 2.01009316399281527D+02, - E 2.05168199482641199D+02, 2.09342586752536836D+02/ - DATA GLN(67), GLN(68), GLN(69), GLN(70), GLN(71), GLN(72), - 1 GLN(73), GLN(74), GLN(75), GLN(76), GLN(77), GLN(78), - 2 GLN(79), GLN(80), GLN(81), GLN(82), GLN(83), GLN(84), - 3 GLN(85), GLN(86), GLN(87), GLN(88)/ - 4 2.13532241494563261D+02, 2.17736934113954227D+02, - 5 2.21956441819130334D+02, 2.26190548323727593D+02, - 6 2.30439043565776952D+02, 2.34701723442818268D+02, - 7 2.38978389561834323D+02, 2.43268849002982714D+02, - 8 2.47572914096186884D+02, 2.51890402209723194D+02, - 9 2.56221135550009525D+02, 2.60564940971863209D+02, - A 2.64921649798552801D+02, 2.69291097651019823D+02, - B 2.73673124285693704D+02, 2.78067573440366143D+02, - C 2.82474292687630396D+02, 2.86893133295426994D+02, - D 2.91323950094270308D+02, 2.95766601350760624D+02, - E 3.00220948647014132D+02, 3.04686856765668715D+02/ - DATA GLN(89), GLN(90), GLN(91), GLN(92), GLN(93), GLN(94), - 1 GLN(95), GLN(96), GLN(97), GLN(98), GLN(99), GLN(100)/ - 2 3.09164193580146922D+02, 3.13652829949879062D+02, - 3 3.18152639620209327D+02, 3.22663499126726177D+02, - 4 3.27185287703775217D+02, 3.31717887196928473D+02, - 5 3.36261181979198477D+02, 3.40815058870799018D+02, - 6 3.45379407062266854D+02, 3.49954118040770237D+02, - 7 3.54539085519440809D+02, 3.59134205369575399D+02/ -C COEFFICIENTS OF ASYMPTOTIC EXPANSION - DATA CF(1), CF(2), CF(3), CF(4), CF(5), CF(6), CF(7), CF(8), - 1 CF(9), CF(10), CF(11), CF(12), CF(13), CF(14), CF(15), - 2 CF(16), CF(17), CF(18), CF(19), CF(20), CF(21), CF(22)/ - 3 8.33333333333333333D-02, -2.77777777777777778D-03, - 4 7.93650793650793651D-04, -5.95238095238095238D-04, - 5 8.41750841750841751D-04, -1.91752691752691753D-03, - 6 6.41025641025641026D-03, -2.95506535947712418D-02, - 7 1.79644372368830573D-01, -1.39243221690590112D+00, - 8 1.34028640441683920D+01, -1.56848284626002017D+02, - 9 2.19310333333333333D+03, -3.61087712537249894D+04, - A 6.91472268851313067D+05, -1.52382215394074162D+07, - B 3.82900751391414141D+08, -1.08822660357843911D+10, - C 3.47320283765002252D+11, -1.23696021422692745D+13, - D 4.88788064793079335D+14, -2.13203339609193739D+16/ -C -C LN(2*PI) - DATA CON / 1.83787706640934548D+00/ -C -C***FIRST EXECUTABLE STATEMENT DGAMLN - IERR=0 - IF (Z.LE.0.0D0) GO TO 70 - IF (Z.GT.101.0D0) GO TO 10 - NZ = Z - FZ = Z - NZ - IF (FZ.GT.0.0D0) GO TO 10 - IF (NZ.GT.100) GO TO 10 - DGAMLN = GLN(NZ) - RETURN - 10 CONTINUE - WDTOL = D1MACH(4) - WDTOL = MAX(WDTOL,0.5D-18) - I1M = I1MACH(14) - RLN = D1MACH(5)*I1M - FLN = MIN(RLN,20.0D0) - FLN = MAX(FLN,3.0D0) - FLN = FLN - 3.0D0 - ZM = 1.8000D0 + 0.3875D0*FLN - MZ = ZM + 1 - ZMIN = MZ - ZDMY = Z - ZINC = 0.0D0 - IF (Z.GE.ZMIN) GO TO 20 - ZINC = ZMIN - NZ - ZDMY = Z + ZINC - 20 CONTINUE - ZP = 1.0D0/ZDMY - T1 = CF(1)*ZP - S = T1 - IF (ZP.LT.WDTOL) GO TO 40 - ZSQ = ZP*ZP - TST = T1*WDTOL - DO 30 K=2,22 - ZP = ZP*ZSQ - TRM = CF(K)*ZP - IF (ABS(TRM).LT.TST) GO TO 40 - S = S + TRM - 30 CONTINUE - 40 CONTINUE - IF (ZINC.NE.0.0D0) GO TO 50 - TLG = LOG(Z) - DGAMLN = Z*(TLG-1.0D0) + 0.5D0*(CON-TLG) + S - RETURN - 50 CONTINUE - ZP = 1.0D0 - NZ = ZINC - DO 60 I=1,NZ - ZP = ZP*(Z+(I-1)) - 60 CONTINUE - TLG = LOG(ZDMY) - DGAMLN = ZDMY*(TLG-1.0D0) - LOG(ZP) + 0.5D0*(CON-TLG) + S - RETURN -C -C - 70 CONTINUE - DGAMLN = D1MACH(2) - IERR=1 - RETURN - END diff --git a/slatec/dgamma.f b/slatec/dgamma.f deleted file mode 100644 index 7b2c183..0000000 --- a/slatec/dgamma.f +++ /dev/null @@ -1,153 +0,0 @@ -*DECK DGAMMA - DOUBLE PRECISION FUNCTION DGAMMA (X) -C***BEGIN PROLOGUE DGAMMA -C***PURPOSE Compute the complete Gamma function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7A -C***TYPE DOUBLE PRECISION (GAMMA-S, DGAMMA-D, CGAMMA-C) -C***KEYWORDS COMPLETE GAMMA FUNCTION, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DGAMMA(X) calculates the double precision complete Gamma function -C for double precision argument X. -C -C Series for GAM on the interval 0. to 1.00000E+00 -C with weighted error 5.79E-32 -C log weighted error 31.24 -C significant figures required 30.00 -C decimal places required 32.05 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, D9LGMC, DCSEVL, DGAMLM, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 890911 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 920618 Removed space from variable name. (RWC, WRB) -C***END PROLOGUE DGAMMA - DOUBLE PRECISION X, GAMCS(42), DXREL, PI, SINPIY, SQ2PIL, XMAX, - 1 XMIN, Y, D9LGMC, DCSEVL, D1MACH - LOGICAL FIRST -C - SAVE GAMCS, PI, SQ2PIL, NGAM, XMIN, XMAX, DXREL, FIRST - DATA GAMCS( 1) / +.8571195590 9893314219 2006239994 2 D-2 / - DATA GAMCS( 2) / +.4415381324 8410067571 9131577165 2 D-2 / - DATA GAMCS( 3) / +.5685043681 5993633786 3266458878 9 D-1 / - DATA GAMCS( 4) / -.4219835396 4185605010 1250018662 4 D-2 / - DATA GAMCS( 5) / +.1326808181 2124602205 8400679635 2 D-2 / - DATA GAMCS( 6) / -.1893024529 7988804325 2394702388 6 D-3 / - DATA GAMCS( 7) / +.3606925327 4412452565 7808221722 5 D-4 / - DATA GAMCS( 8) / -.6056761904 4608642184 8554829036 5 D-5 / - DATA GAMCS( 9) / +.1055829546 3022833447 3182350909 3 D-5 / - DATA GAMCS( 10) / -.1811967365 5423840482 9185589116 6 D-6 / - DATA GAMCS( 11) / +.3117724964 7153222777 9025459316 9 D-7 / - DATA GAMCS( 12) / -.5354219639 0196871408 7408102434 7 D-8 / - DATA GAMCS( 13) / +.9193275519 8595889468 8778682594 0 D-9 / - DATA GAMCS( 14) / -.1577941280 2883397617 6742327395 3 D-9 / - DATA GAMCS( 15) / +.2707980622 9349545432 6654043308 9 D-10 / - DATA GAMCS( 16) / -.4646818653 8257301440 8166105893 3 D-11 / - DATA GAMCS( 17) / +.7973350192 0074196564 6076717535 9 D-12 / - DATA GAMCS( 18) / -.1368078209 8309160257 9949917230 9 D-12 / - DATA GAMCS( 19) / +.2347319486 5638006572 3347177168 8 D-13 / - DATA GAMCS( 20) / -.4027432614 9490669327 6657053469 9 D-14 / - DATA GAMCS( 21) / +.6910051747 3721009121 3833697525 7 D-15 / - DATA GAMCS( 22) / -.1185584500 2219929070 5238712619 2 D-15 / - DATA GAMCS( 23) / +.2034148542 4963739552 0102605193 2 D-16 / - DATA GAMCS( 24) / -.3490054341 7174058492 7401294910 8 D-17 / - DATA GAMCS( 25) / +.5987993856 4853055671 3505106602 6 D-18 / - DATA GAMCS( 26) / -.1027378057 8722280744 9006977843 1 D-18 / - DATA GAMCS( 27) / +.1762702816 0605298249 4275966074 8 D-19 / - DATA GAMCS( 28) / -.3024320653 7353062609 5877211204 2 D-20 / - DATA GAMCS( 29) / +.5188914660 2183978397 1783355050 6 D-21 / - DATA GAMCS( 30) / -.8902770842 4565766924 4925160106 6 D-22 / - DATA GAMCS( 31) / +.1527474068 4933426022 7459689130 6 D-22 / - DATA GAMCS( 32) / -.2620731256 1873629002 5732833279 9 D-23 / - DATA GAMCS( 33) / +.4496464047 8305386703 3104657066 6 D-24 / - DATA GAMCS( 34) / -.7714712731 3368779117 0390152533 3 D-25 / - DATA GAMCS( 35) / +.1323635453 1260440364 8657271466 6 D-25 / - DATA GAMCS( 36) / -.2270999412 9429288167 0231381333 3 D-26 / - DATA GAMCS( 37) / +.3896418998 0039914493 2081663999 9 D-27 / - DATA GAMCS( 38) / -.6685198115 1259533277 9212799999 9 D-28 / - DATA GAMCS( 39) / +.1146998663 1400243843 4761386666 6 D-28 / - DATA GAMCS( 40) / -.1967938586 3451346772 9510399999 9 D-29 / - DATA GAMCS( 41) / +.3376448816 5853380903 3489066666 6 D-30 / - DATA GAMCS( 42) / -.5793070335 7821357846 2549333333 3 D-31 / - DATA PI / 3.1415926535 8979323846 2643383279 50 D0 / - DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DGAMMA - IF (FIRST) THEN - NGAM = INITDS (GAMCS, 42, 0.1*REAL(D1MACH(3)) ) -C - CALL DGAMLM (XMIN, XMAX) - DXREL = SQRT(D1MACH(4)) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.10.D0) GO TO 50 -C -C COMPUTE GAMMA(X) FOR -XBND .LE. X .LE. XBND. REDUCE INTERVAL AND FIND -C GAMMA(1+Y) FOR 0.0 .LE. Y .LT. 1.0 FIRST OF ALL. -C - N = X - IF (X.LT.0.D0) N = N - 1 - Y = X - N - N = N - 1 - DGAMMA = 0.9375D0 + DCSEVL (2.D0*Y-1.D0, GAMCS, NGAM) - IF (N.EQ.0) RETURN -C - IF (N.GT.0) GO TO 30 -C -C COMPUTE GAMMA(X) FOR X .LT. 1.0 -C - N = -N - IF (X .EQ. 0.D0) CALL XERMSG ('SLATEC', 'DGAMMA', 'X IS 0', 4, 2) - IF (X .LT. 0.0 .AND. X+N-2 .EQ. 0.D0) CALL XERMSG ('SLATEC', - + 'DGAMMA', 'X IS A NEGATIVE INTEGER', 4, 2) - IF (X .LT. (-0.5D0) .AND. ABS((X-AINT(X-0.5D0))/X) .LT. DXREL) - + CALL XERMSG ('SLATEC', 'DGAMMA', - + 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER', - + 1, 1) -C - DO 20 I=1,N - DGAMMA = DGAMMA/(X+I-1 ) - 20 CONTINUE - RETURN -C -C GAMMA(X) FOR X .GE. 2.0 AND X .LE. 10.0 -C - 30 DO 40 I=1,N - DGAMMA = (Y+I) * DGAMMA - 40 CONTINUE - RETURN -C -C GAMMA(X) FOR ABS(X) .GT. 10.0. RECALL Y = ABS(X). -C - 50 IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'DGAMMA', - + 'X SO BIG GAMMA OVERFLOWS', 3, 2) -C - DGAMMA = 0.D0 - IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'DGAMMA', - + 'X SO SMALL GAMMA UNDERFLOWS', 2, 1) - IF (X.LT.XMIN) RETURN -C - DGAMMA = EXP ((Y-0.5D0)*LOG(Y) - Y + SQ2PIL + D9LGMC(Y) ) - IF (X.GT.0.D0) RETURN -C - IF (ABS((X-AINT(X-0.5D0))/X) .LT. DXREL) CALL XERMSG ('SLATEC', - + 'DGAMMA', - + 'ANSWER LT HALF PRECISION, X TOO NEAR NEGATIVE INTEGER', 1, 1) -C - SINPIY = SIN (PI*Y) - IF (SINPIY .EQ. 0.D0) CALL XERMSG ('SLATEC', 'DGAMMA', - + 'X IS A NEGATIVE INTEGER', 4, 2) -C - DGAMMA = -PI/(Y*SINPIY*DGAMMA) -C - RETURN - END diff --git a/slatec/dgamr.f b/slatec/dgamr.f deleted file mode 100644 index 9572a33..0000000 --- a/slatec/dgamr.f +++ /dev/null @@ -1,44 +0,0 @@ -*DECK DGAMR - DOUBLE PRECISION FUNCTION DGAMR (X) -C***BEGIN PROLOGUE DGAMR -C***PURPOSE Compute the reciprocal of the Gamma function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7A -C***TYPE DOUBLE PRECISION (GAMR-S, DGAMR-D, CGAMR-C) -C***KEYWORDS FNLIB, RECIPROCAL GAMMA FUNCTION, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DGAMR(X) calculates the double precision reciprocal of the -C complete Gamma function for double precision argument X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED DGAMMA, DLGAMS, XERCLR, XGETF, XSETF -C***REVISION HISTORY (YYMMDD) -C 770701 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 900727 Added EXTERNAL statement. (WRB) -C***END PROLOGUE DGAMR - DOUBLE PRECISION X, ALNGX, SGNGX, DGAMMA - EXTERNAL DGAMMA -C***FIRST EXECUTABLE STATEMENT DGAMR - DGAMR = 0.0D0 - IF (X.LE.0.0D0 .AND. AINT(X).EQ.X) RETURN -C - CALL XGETF (IROLD) - CALL XSETF (1) - IF (ABS(X).GT.10.0D0) GO TO 10 - DGAMR = 1.0D0/DGAMMA(X) - CALL XERCLR - CALL XSETF (IROLD) - RETURN -C - 10 CALL DLGAMS (X, ALNGX, SGNGX) - CALL XERCLR - CALL XSETF (IROLD) - DGAMR = SGNGX * EXP(-ALNGX) - RETURN -C - END diff --git a/slatec/dgamrn.f b/slatec/dgamrn.f deleted file mode 100644 index bbd685e..0000000 --- a/slatec/dgamrn.f +++ /dev/null @@ -1,107 +0,0 @@ -*DECK DGAMRN - DOUBLE PRECISION FUNCTION DGAMRN (X) -C***BEGIN PROLOGUE DGAMRN -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBSKIN -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (GAMRN-S, DGAMRN-D) -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Abstract * A Double Precision Routine * -C DGAMRN computes the GAMMA function ratio GAMMA(X)/GAMMA(X+0.5) -C for real X.gt.0. If X.ge.XMIN, an asymptotic expansion is -C evaluated. If X.lt.XMIN, an integer is added to X to form a -C new value of X.ge.XMIN and the asymptotic expansion is eval- -C uated for this new value of X. Successive application of the -C recurrence relation -C -C W(X)=W(X+1)*(1+0.5/X) -C -C reduces the argument to its original value. XMIN and comp- -C utational tolerances are computed as a function of the number -C of digits carried in a word by calls to I1MACH and D1MACH. -C However, the computational accuracy is limited to the max- -C imum of unit roundoff (=D1MACH(4)) and 1.0D-18 since critical -C constants are given to only 18 digits. -C -C Input X is Double Precision -C X - Argument, X.gt.0.0D0 -C -C Output DGAMRN is DOUBLE PRECISION -C DGAMRN - Ratio GAMMA(X)/GAMMA(X+0.5) -C -C***SEE ALSO DBSKIN -C***REFERENCES Y. L. Luke, The Special Functions and Their -C Approximations, Vol. 1, Math In Sci. And -C Eng. Series 53, Academic Press, New York, 1969, -C pp. 34-35. -C***ROUTINES CALLED D1MACH, I1MACH -C***REVISION HISTORY (YYMMDD) -C 820601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C 920520 Added REFERENCES section. (WRB) -C***END PROLOGUE DGAMRN - INTEGER I, I1M11, K, MX, NX - INTEGER I1MACH - DOUBLE PRECISION FLN, GR, RLN, S, TOL, TRM, X, XDMY, XINC, XM, - * XMIN, XP, XSQ - DOUBLE PRECISION D1MACH - DIMENSION GR(12) - SAVE GR -C - DATA GR(1), GR(2), GR(3), GR(4), GR(5), GR(6), GR(7), GR(8), - * GR(9), GR(10), GR(11), GR(12) /1.00000000000000000D+00, - * -1.56250000000000000D-02,2.56347656250000000D-03, - * -1.27983093261718750D-03,1.34351104497909546D-03, - * -2.43289663922041655D-03,6.75423753364157164D-03, - * -2.66369606131178216D-02,1.41527455519564332D-01, - * -9.74384543032201613D-01,8.43686251229783675D+00, - * -8.97258321640552515D+01/ -C -C***FIRST EXECUTABLE STATEMENT DGAMRN - NX = INT(X) - TOL = MAX(D1MACH(4),1.0D-18) - I1M11 = I1MACH(14) - RLN = D1MACH(5)*I1M11 - FLN = MIN(RLN,20.0D0) - FLN = MAX(FLN,3.0D0) - FLN = FLN - 3.0D0 - XM = 2.0D0 + FLN*(0.2366D0+0.01723D0*FLN) - MX = INT(XM) + 1 - XMIN = MX - XDMY = X - 0.25D0 - XINC = 0.0D0 - IF (X.GE.XMIN) GO TO 10 - XINC = XMIN - NX - XDMY = XDMY + XINC - 10 CONTINUE - S = 1.0D0 - IF (XDMY*TOL.GT.1.0D0) GO TO 30 - XSQ = 1.0D0/(XDMY*XDMY) - XP = XSQ - DO 20 K=2,12 - TRM = GR(K)*XP - IF (ABS(TRM).LT.TOL) GO TO 30 - S = S + TRM - XP = XP*XSQ - 20 CONTINUE - 30 CONTINUE - S = S/SQRT(XDMY) - IF (XINC.NE.0.0D0) GO TO 40 - DGAMRN = S - RETURN - 40 CONTINUE - NX = INT(XINC) - XP = 0.0D0 - DO 50 I=1,NX - S = S*(1.0D0+0.5D0/(X+XP)) - XP = XP + 1.0D0 - 50 CONTINUE - DGAMRN = S - RETURN - END diff --git a/slatec/dgaus8.f b/slatec/dgaus8.f deleted file mode 100644 index ad4a1cb..0000000 --- a/slatec/dgaus8.f +++ /dev/null @@ -1,201 +0,0 @@ -*DECK DGAUS8 - SUBROUTINE DGAUS8 (FUN, A, B, ERR, ANS, IERR) -C***BEGIN PROLOGUE DGAUS8 -C***PURPOSE Integrate a real function of one variable over a finite -C interval using an adaptive 8-point Legendre-Gauss -C algorithm. Intended primarily for high accuracy -C integration or integration of smooth functions. -C***LIBRARY SLATEC -C***CATEGORY H2A1A1 -C***TYPE DOUBLE PRECISION (GAUS8-S, DGAUS8-D) -C***KEYWORDS ADAPTIVE QUADRATURE, AUTOMATIC INTEGRATOR, -C GAUSS QUADRATURE, NUMERICAL INTEGRATION -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract *** a DOUBLE PRECISION routine *** -C DGAUS8 integrates real functions of one variable over finite -C intervals using an adaptive 8-point Legendre-Gauss algorithm. -C DGAUS8 is intended primarily for high accuracy integration -C or integration of smooth functions. -C -C The maximum number of significant digits obtainable in ANS -C is the smaller of 18 and the number of digits carried in -C double precision arithmetic. -C -C Description of Arguments -C -C Input--* FUN, A, B, ERR are DOUBLE PRECISION * -C FUN - name of external function to be integrated. This name -C must be in an EXTERNAL statement in the calling program. -C FUN must be a DOUBLE PRECISION function of one DOUBLE -C PRECISION argument. The value of the argument to FUN -C is the variable of integration which ranges from A to B. -C A - lower limit of integration -C B - upper limit of integration (may be less than A) -C ERR - is a requested pseudorelative error tolerance. Normally -C pick a value of ABS(ERR) so that DTOL .LT. ABS(ERR) .LE. -C 1.0D-3 where DTOL is the larger of 1.0D-18 and the -C double precision unit roundoff D1MACH(4). ANS will -C normally have no more error than ABS(ERR) times the -C integral of the absolute value of FUN(X). Usually, -C smaller values of ERR yield more accuracy and require -C more function evaluations. -C -C A negative value for ERR causes an estimate of the -C absolute error in ANS to be returned in ERR. Note that -C ERR must be a variable (not a constant) in this case. -C Note also that the user must reset the value of ERR -C before making any more calls that use the variable ERR. -C -C Output--* ERR,ANS are double precision * -C ERR - will be an estimate of the absolute error in ANS if the -C input value of ERR was negative. (ERR is unchanged if -C the input value of ERR was non-negative.) The estimated -C error is solely for information to the user and should -C not be used as a correction to the computed integral. -C ANS - computed value of integral -C IERR- a status code -C --Normal codes -C 1 ANS most likely meets requested error tolerance, -C or A=B. -C -1 A and B are too nearly equal to allow normal -C integration. ANS is set to zero. -C --Abnormal code -C 2 ANS probably does not meet requested error tolerance. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, I1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 810223 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 890911 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE DGAUS8 - INTEGER IERR, K, KML, KMX, L, LMN, LMX, LR, MXL, NBITS, - 1 NIB, NLMN, NLMX - INTEGER I1MACH - DOUBLE PRECISION A,AA,AE,ANIB,ANS,AREA,B,C,CE,EE,EF, - 1 EPS, ERR, EST, GL, GLR, GR, HH, SQ2, TOL, VL, VR, W1, W2, W3, - 2 W4, X1, X2, X3, X4, X, H - DOUBLE PRECISION D1MACH, G8, FUN - DIMENSION AA(60), HH(60), LR(60), VL(60), GR(60) - SAVE X1, X2, X3, X4, W1, W2, W3, W4, SQ2, - 1 NLMN, KMX, KML - DATA X1, X2, X3, X4/ - 1 1.83434642495649805D-01, 5.25532409916328986D-01, - 2 7.96666477413626740D-01, 9.60289856497536232D-01/ - DATA W1, W2, W3, W4/ - 1 3.62683783378361983D-01, 3.13706645877887287D-01, - 2 2.22381034453374471D-01, 1.01228536290376259D-01/ - DATA SQ2/1.41421356D0/ - DATA NLMN/1/,KMX/5000/,KML/6/ - G8(X,H)=H*((W1*(FUN(X-X1*H) + FUN(X+X1*H)) - 1 +W2*(FUN(X-X2*H) + FUN(X+X2*H))) - 2 +(W3*(FUN(X-X3*H) + FUN(X+X3*H)) - 3 +W4*(FUN(X-X4*H) + FUN(X+X4*H)))) -C***FIRST EXECUTABLE STATEMENT DGAUS8 -C -C Initialize -C - K = I1MACH(14) - ANIB = D1MACH(5)*K/0.30102000D0 - NBITS = ANIB - NLMX = MIN(60,(NBITS*5)/8) - ANS = 0.0D0 - IERR = 1 - CE = 0.0D0 - IF (A .EQ. B) GO TO 140 - LMX = NLMX - LMN = NLMN - IF (B .EQ. 0.0D0) GO TO 10 - IF (SIGN(1.0D0,B)*A .LE. 0.0D0) GO TO 10 - C = ABS(1.0D0-A/B) - IF (C .GT. 0.1D0) GO TO 10 - IF (C .LE. 0.0D0) GO TO 140 - ANIB = 0.5D0 - LOG(C)/0.69314718D0 - NIB = ANIB - LMX = MIN(NLMX,NBITS-NIB-7) - IF (LMX .LT. 1) GO TO 130 - LMN = MIN(LMN,LMX) - 10 TOL = MAX(ABS(ERR),2.0D0**(5-NBITS))/2.0D0 - IF (ERR .EQ. 0.0D0) TOL = SQRT(D1MACH(4)) - EPS = TOL - HH(1) = (B-A)/4.0D0 - AA(1) = A - LR(1) = 1 - L = 1 - EST = G8(AA(L)+2.0D0*HH(L),2.0D0*HH(L)) - K = 8 - AREA = ABS(EST) - EF = 0.5D0 - MXL = 0 -C -C Compute refined estimates, estimate the error, etc. -C - 20 GL = G8(AA(L)+HH(L),HH(L)) - GR(L) = G8(AA(L)+3.0D0*HH(L),HH(L)) - K = K + 16 - AREA = AREA + (ABS(GL)+ABS(GR(L))-ABS(EST)) -C IF (L .LT .LMN) GO TO 11 - GLR = GL + GR(L) - EE = ABS(EST-GLR)*EF - AE = MAX(EPS*AREA,TOL*ABS(GLR)) - IF (EE-AE) 40, 40, 50 - 30 MXL = 1 - 40 CE = CE + (EST-GLR) - IF (LR(L)) 60, 60, 80 -C -C Consider the left half of this level -C - 50 IF (K .GT. KMX) LMX = KML - IF (L .GE. LMX) GO TO 30 - L = L + 1 - EPS = EPS*0.5D0 - EF = EF/SQ2 - HH(L) = HH(L-1)*0.5D0 - LR(L) = -1 - AA(L) = AA(L-1) - EST = GL - GO TO 20 -C -C Proceed to right half at this level -C - 60 VL(L) = GLR - 70 EST = GR(L-1) - LR(L) = 1 - AA(L) = AA(L) + 4.0D0*HH(L) - GO TO 20 -C -C Return one level -C - 80 VR = GLR - 90 IF (L .LE. 1) GO TO 120 - L = L - 1 - EPS = EPS*2.0D0 - EF = EF*SQ2 - IF (LR(L)) 100, 100, 110 - 100 VL(L) = VL(L+1) + VR - GO TO 70 - 110 VR = VL(L+1) + VR - GO TO 90 -C -C Exit -C - 120 ANS = VR - IF ((MXL.EQ.0) .OR. (ABS(CE).LE.2.0D0*TOL*AREA)) GO TO 140 - IERR = 2 - CALL XERMSG ('SLATEC', 'DGAUS8', - + 'ANS is probably insufficiently accurate.', 3, 1) - GO TO 140 - 130 IERR = -1 - CALL XERMSG ('SLATEC', 'DGAUS8', - + 'A and B are too nearly equal to allow normal integration. $$' - + // 'ANS is set to zero and IERR to -1.', 1, -1) - 140 IF (ERR .LT. 0.0D0) ERR = CE - RETURN - END diff --git a/slatec/dgbco.f b/slatec/dgbco.f deleted file mode 100644 index 2a5efd4..0000000 --- a/slatec/dgbco.f +++ /dev/null @@ -1,278 +0,0 @@ -*DECK DGBCO - SUBROUTINE DGBCO (ABD, LDA, N, ML, MU, IPVT, RCOND, Z) -C***BEGIN PROLOGUE DGBCO -C***PURPOSE Factor a band matrix by Gaussian elimination and -C estimate the condition number of the matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2A2 -C***TYPE DOUBLE PRECISION (SGBCO-S, DGBCO-D, CGBCO-C) -C***KEYWORDS BANDED, CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, -C MATRIX FACTORIZATION -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -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 = MAX(1, J-MU) -C I2 = MIN(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***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DASUM, DAXPY, DDOT, DGBFA, DSCAL -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DGBCO - INTEGER LDA,N,ML,MU,IPVT(*) - DOUBLE PRECISION ABD(LDA,*),Z(*) - DOUBLE PRECISION RCOND -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 COMPUTE 1-NORM OF A -C -C***FIRST EXECUTABLE STATEMENT DGBCO - ANORM = 0.0D0 - L = ML + 1 - IS = L + MU - DO 10 J = 1, N - ANORM = MAX(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 = SIGN(EK,-Z(K)) - IF (ABS(EK-Z(K)) .LE. ABS(ABD(M,K))) GO TO 30 - S = ABS(ABD(M,K))/ABS(EK-Z(K)) - CALL DSCAL(N,S,Z,1) - EK = S*EK - 30 CONTINUE - WK = EK - Z(K) - WKM = -EK - Z(K) - S = ABS(WK) - SM = ABS(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 = MIN(MAX(JU,MU+IPVT(K)),N) - MM = M - IF (KP1 .GT. JU) GO TO 90 - DO 60 J = KP1, JU - MM = MM - 1 - SM = SM + ABS(Z(J)+WKM*ABD(MM,J)) - Z(J) = Z(J) + WK*ABD(MM,J) - S = S + ABS(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 = MIN(ML,N-K) - IF (K .LT. N) Z(K) = Z(K) + DDOT(LM,ABD(M+1,K),1,Z(K+1),1) - IF (ABS(Z(K)) .LE. 1.0D0) GO TO 110 - S = 1.0D0/ABS(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 = MIN(ML,N-K) - IF (K .LT. N) CALL DAXPY(LM,T,ABD(M+1,K),1,Z(K+1),1) - IF (ABS(Z(K)) .LE. 1.0D0) GO TO 130 - S = 1.0D0/ABS(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 (ABS(Z(K)) .LE. ABS(ABD(M,K))) GO TO 150 - S = ABS(ABD(M,K))/ABS(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 = MIN(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 diff --git a/slatec/dgbdi.f b/slatec/dgbdi.f deleted file mode 100644 index 83e0713..0000000 --- a/slatec/dgbdi.f +++ /dev/null @@ -1,86 +0,0 @@ -*DECK DGBDI - SUBROUTINE DGBDI (ABD, LDA, N, ML, MU, IPVT, DET) -C***BEGIN PROLOGUE DGBDI -C***PURPOSE Compute the determinant of a band matrix using the factors -C computed by DGBCO or DGBFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D3A2 -C***TYPE DOUBLE PRECISION (SGBDI-S, DGBDI-D, CGBDI-C) -C***KEYWORDS BANDED, DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, -C MATRIX -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C DGBDI computes the determinant of a band matrix -C using the factors computed by DGBCO or DGBFA. -C If the inverse is needed, use DGBSL N times. -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 On Return -C -C DET DOUBLE PRECISION(2) -C determinant of original matrix. -C Determinant = DET(1) * 10.0**DET(2) -C with 1.0 .LE. ABS(DET(1)) .LT. 10.0 -C or DET(1) = 0.0 . -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DGBDI - INTEGER LDA,N,ML,MU,IPVT(*) - DOUBLE PRECISION ABD(LDA,*),DET(2) -C - DOUBLE PRECISION TEN - INTEGER I,M -C***FIRST EXECUTABLE STATEMENT DGBDI - M = ML + MU + 1 - 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) = ABD(M,I)*DET(1) - IF (DET(1) .EQ. 0.0D0) GO TO 60 - 10 IF (ABS(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 (ABS(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 - RETURN - END diff --git a/slatec/dgbfa.f b/slatec/dgbfa.f deleted file mode 100644 index a8a0d6d..0000000 --- a/slatec/dgbfa.f +++ /dev/null @@ -1,187 +0,0 @@ -*DECK DGBFA - SUBROUTINE DGBFA (ABD, LDA, N, ML, MU, IPVT, INFO) -C***BEGIN PROLOGUE DGBFA -C***PURPOSE Factor a band matrix using Gaussian elimination. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2A2 -C***TYPE DOUBLE PRECISION (SGBFA-S, DGBFA-D, CGBFA-C) -C***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -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 = MAX(1, J-MU) -C I2 = MIN(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***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DSCAL, IDAMAX -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DGBFA - INTEGER LDA,N,ML,MU,IPVT(*),INFO - DOUBLE PRECISION ABD(LDA,*) -C - DOUBLE PRECISION T - INTEGER I,IDAMAX,I0,J,JU,JZ,J0,J1,K,KP1,L,LM,M,MM,NM1 -C -C***FIRST EXECUTABLE STATEMENT DGBFA - M = ML + MU + 1 - INFO = 0 -C -C ZERO INITIAL FILL-IN COLUMNS -C - J0 = MU + 2 - J1 = MIN(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 = MIN(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 = MIN(MAX(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/slatec/dgbmv.f b/slatec/dgbmv.f deleted file mode 100644 index 683c692..0000000 --- a/slatec/dgbmv.f +++ /dev/null @@ -1,307 +0,0 @@ -*DECK DGBMV - SUBROUTINE DGBMV (TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY) -C***BEGIN PROLOGUE DGBMV -C***PURPOSE Perform one of the matrix-vector operations. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE DOUBLE PRECISION (SGBMV-S, DGBMV-D, CGBMV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C DGBMV performs one of the matrix-vector operations -C -C y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, -C -C where alpha and beta are scalars, x and y are vectors and A is an -C m by n band matrix, with kl sub-diagonals and ku super-diagonals. -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the operation to be performed as -C follows: -C -C TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -C -C TRANS = 'T' or 't' y := alpha*A'*x + beta*y. -C -C TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. -C -C Unchanged on exit. -C -C M - INTEGER. -C On entry, M specifies the number of rows of the matrix A. -C M must be at least zero. -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the number of columns of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C KL - INTEGER. -C On entry, KL specifies the number of sub-diagonals of the -C matrix A. KL must satisfy 0 .le. KL. -C Unchanged on exit. -C -C KU - INTEGER. -C On entry, KU specifies the number of super-diagonals of the -C matrix A. KU must satisfy 0 .le. KU. -C Unchanged on exit. -C -C ALPHA - DOUBLE PRECISION. -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -C Before entry, the leading ( kl + ku + 1 ) by n part of the -C array A must contain the matrix of coefficients, supplied -C column by column, with the leading diagonal of the matrix in -C row ( ku + 1 ) of the array, the first super-diagonal -C starting at position 2 in row ku, the first sub-diagonal -C starting at position 1 in row ( ku + 2 ), and so on. -C Elements in the array A that do not correspond to elements -C in the band matrix (such as the top left ku by ku triangle) -C are not referenced. -C The following program segment will transfer a band matrix -C from conventional full matrix storage to band storage: -C -C DO 20, J = 1, N -C K = KU + 1 - J -C DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) -C A( K + I, J ) = matrix( I, J ) -C 10 CONTINUE -C 20 CONTINUE -C -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C ( kl + ku + 1 ). -C Unchanged on exit. -C -C X - DOUBLE PRECISION array of DIMENSION at least -C ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -C and at least -C ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -C Before entry, the incremented array X must contain the -C vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C BETA - DOUBLE PRECISION. -C On entry, BETA specifies the scalar beta. When BETA is -C supplied as zero then Y need not be set on input. -C Unchanged on exit. -C -C Y - DOUBLE PRECISION array of DIMENSION at least -C ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -C and at least -C ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -C Before entry, the incremented array Y must contain the -C vector y. On exit, Y is overwritten by the updated vector y. -C -C INCY - INTEGER. -C On entry, INCY specifies the increment for the elements of -C Y. INCY must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE DGBMV -C .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA - INTEGER INCX, INCY, KL, KU, LDA, M, N - CHARACTER*1 TRANS -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -C .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, IY, J, JX, JY, K, KUP1, KX, KY, - $ LENX, LENY -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C***FIRST EXECUTABLE STATEMENT DGBMV -C -C Test the input parameters. -C - 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 -C -C Quick return if possible. -C - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C Set LENX and LENY, the lengths of the vectors x and y, and set -C up the start points in X and Y. -C - 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 -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through the band part of A. -C -C First form y := beta*y. -C - 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 -C -C Form y := alpha*A*x + y. -C - 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 -C -C Form y := alpha*A'*x + y. -C - 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 -C - RETURN -C -C End of DGBMV . -C - END diff --git a/slatec/dgbsl.f b/slatec/dgbsl.f deleted file mode 100644 index ff73ad6..0000000 --- a/slatec/dgbsl.f +++ /dev/null @@ -1,149 +0,0 @@ -*DECK DGBSL - SUBROUTINE DGBSL (ABD, LDA, N, ML, MU, IPVT, B, JOB) -C***BEGIN PROLOGUE DGBSL -C***PURPOSE Solve the real band system A*X=B or TRANS(A)*X=B using -C the factors computed by DGBCO or DGBFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2A2 -C***TYPE DOUBLE PRECISION (SGBSL-S, DGBSL-D, CGBSL-C) -C***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -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***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DDOT -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DGBSL - INTEGER LDA,N,ML,MU,IPVT(*),JOB - DOUBLE PRECISION ABD(LDA,*),B(*) -C - DOUBLE PRECISION DDOT,T - INTEGER K,KB,L,LA,LB,LM,M,NM1 -C***FIRST EXECUTABLE STATEMENT DGBSL - 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 = MIN(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 = MIN(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 = MIN(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 = MIN(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/slatec/dgeco.f b/slatec/dgeco.f deleted file mode 100644 index 3f56183..0000000 --- a/slatec/dgeco.f +++ /dev/null @@ -1,207 +0,0 @@ -*DECK DGECO - SUBROUTINE DGECO (A, LDA, N, IPVT, RCOND, Z) -C***BEGIN PROLOGUE DGECO -C***PURPOSE Factor a matrix using Gaussian elimination and estimate -C the condition number of the matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2A1 -C***TYPE DOUBLE PRECISION (SGECO-S, DGECO-D, CGECO-C) -C***KEYWORDS CONDITION NUMBER, GENERAL MATRIX, LINEAR ALGEBRA, LINPACK, -C MATRIX FACTORIZATION -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -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***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DASUM, DAXPY, DDOT, DGEFA, DSCAL -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DGECO - INTEGER LDA,N,IPVT(*) - DOUBLE PRECISION A(LDA,*),Z(*) - DOUBLE PRECISION RCOND -C - DOUBLE PRECISION DDOT,EK,T,WK,WKM - DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM - INTEGER INFO,J,K,KB,KP1,L -C -C COMPUTE 1-NORM OF A -C -C***FIRST EXECUTABLE STATEMENT DGECO - ANORM = 0.0D0 - DO 10 J = 1, N - ANORM = MAX(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 = SIGN(EK,-Z(K)) - IF (ABS(EK-Z(K)) .LE. ABS(A(K,K))) GO TO 30 - S = ABS(A(K,K))/ABS(EK-Z(K)) - CALL DSCAL(N,S,Z,1) - EK = S*EK - 30 CONTINUE - WK = EK - Z(K) - WKM = -EK - Z(K) - S = ABS(WK) - SM = ABS(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 + ABS(Z(J)+WKM*A(K,J)) - Z(J) = Z(J) + WK*A(K,J) - S = S + ABS(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 (ABS(Z(K)) .LE. 1.0D0) GO TO 110 - S = 1.0D0/ABS(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 (ABS(Z(K)) .LE. 1.0D0) GO TO 130 - S = 1.0D0/ABS(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 (ABS(Z(K)) .LE. ABS(A(K,K))) GO TO 150 - S = ABS(A(K,K))/ABS(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 diff --git a/slatec/dgedi.f b/slatec/dgedi.f deleted file mode 100644 index d91693b..0000000 --- a/slatec/dgedi.f +++ /dev/null @@ -1,141 +0,0 @@ -*DECK DGEDI - SUBROUTINE DGEDI (A, LDA, N, IPVT, DET, WORK, JOB) -C***BEGIN PROLOGUE DGEDI -C***PURPOSE Compute the determinant and inverse of a matrix using the -C factors computed by DGECO or DGEFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D3A1, D2A1 -C***TYPE DOUBLE PRECISION (SGEDI-S, DGEDI-D, CGEDI-C) -C***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -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. ABS(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***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DSCAL, DSWAP -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DGEDI - INTEGER LDA,N,IPVT(*),JOB - DOUBLE PRECISION A(LDA,*),DET(2),WORK(*) -C - DOUBLE PRECISION T - DOUBLE PRECISION TEN - INTEGER I,J,K,KB,KP1,L,NM1 -C***FIRST EXECUTABLE STATEMENT DGEDI -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) - IF (DET(1) .EQ. 0.0D0) GO TO 60 - 10 IF (ABS(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 (ABS(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/slatec/dgefa.f b/slatec/dgefa.f deleted file mode 100644 index 57d9105..0000000 --- a/slatec/dgefa.f +++ /dev/null @@ -1,117 +0,0 @@ -*DECK DGEFA - SUBROUTINE DGEFA (A, LDA, N, IPVT, INFO) -C***BEGIN PROLOGUE DGEFA -C***PURPOSE Factor a matrix using Gaussian elimination. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2A1 -C***TYPE DOUBLE PRECISION (SGEFA-S, DGEFA-D, CGEFA-C) -C***KEYWORDS GENERAL MATRIX, LINEAR ALGEBRA, LINPACK, -C MATRIX FACTORIZATION -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -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***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DSCAL, IDAMAX -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DGEFA - INTEGER LDA,N,IPVT(*),INFO - DOUBLE PRECISION A(LDA,*) -C - DOUBLE PRECISION T - INTEGER IDAMAX,J,K,KP1,L,NM1 -C -C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING -C -C***FIRST EXECUTABLE STATEMENT DGEFA - 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/slatec/dgefs.f b/slatec/dgefs.f deleted file mode 100644 index 3dc6fb0..0000000 --- a/slatec/dgefs.f +++ /dev/null @@ -1,165 +0,0 @@ -*DECK DGEFS - SUBROUTINE DGEFS (A, LDA, N, V, ITASK, IND, WORK, IWORK) -C***BEGIN PROLOGUE DGEFS -C***PURPOSE Solve a general system of linear equations. -C***LIBRARY SLATEC -C***CATEGORY D2A1 -C***TYPE DOUBLE PRECISION (SGEFS-S, DGEFS-D, CGEFS-C) -C***KEYWORDS COMPLEX LINEAR EQUATIONS, GENERAL MATRIX, -C GENERAL SYSTEM OF LINEAR EQUATIONS -C***AUTHOR Voorhees, E. A., (LANL) -C***DESCRIPTION -C -C Subroutine DGEFS solves a general NxN system of double -C precision linear equations using LINPACK subroutines DGECO -C and DGESL. That is, if A is an NxN double precision matrix -C and if X and B are double precision N-vectors, then DGEFS -C solves the equation -C -C A*X=B. -C -C The matrix A is first factored into upper and lower tri- -C angular matrices U and L using partial pivoting. These -C factors and the pivoting information are used to find the -C solution vector X. An approximate condition number is -C calculated to provide a rough estimate of the number of -C digits of accuracy in the computed solution. -C -C If the equation A*X=B is to be solved for more than one vector -C B, the factoring of A does not need to be performed again and -C the option to only solve (ITASK.GT.1) will be faster for -C the succeeding solutions. In this case, the contents of A, -C LDA, N and IWORK must not have been altered by the user follow- -C ing factorization (ITASK=1). IND will not be changed by DGEFS -C in this case. -C -C Argument Description *** -C -C A DOUBLE PRECISION(LDA,N) -C on entry, the doubly subscripted array with dimension -C (LDA,N) which contains the coefficient matrix. -C on return, an upper triangular matrix U and the -C multipliers necessary to construct a matrix L -C so that A=L*U. -C LDA INTEGER -C the leading dimension of the array A. LDA must be great- -C er than or equal to N. (terminal error message IND=-1) -C N INTEGER -C the order of the matrix A. The first N elements of -C the array A are the elements of the first column of -C the matrix A. N must be greater than or equal to 1. -C (terminal error message IND=-2) -C V DOUBLE PRECISION(N) -C on entry, the singly subscripted array(vector) of di- -C mension N which contains the right hand side B of a -C system of simultaneous linear equations A*X=B. -C on return, V contains the solution vector, X . -C ITASK INTEGER -C If ITASK=1, the matrix A is factored and then the -C linear equation is solved. -C If ITASK .GT. 1, the equation is solved using the existing -C factored matrix A and IWORK. -C If ITASK .LT. 1, then terminal error message IND=-3 is -C printed. -C IND INTEGER -C GT. 0 IND is a rough estimate of the number of digits -C of accuracy in the solution, X. -C LT. 0 see error message corresponding to IND below. -C WORK DOUBLE PRECISION(N) -C a singly subscripted array of dimension at least N. -C IWORK INTEGER(N) -C a singly subscripted array of dimension at least N. -C -C Error Messages Printed *** -C -C IND=-1 terminal N is greater than LDA. -C IND=-2 terminal N is less than 1. -C IND=-3 terminal ITASK is less than 1. -C IND=-4 terminal The matrix A is computationally singular. -C A solution has not been computed. -C IND=-10 warning The solution has no apparent significance. -C The solution may be inaccurate or the matrix -C A may be poorly scaled. -C -C Note- The above terminal(*fatal*) error messages are -C designed to be handled by XERMSG in which -C LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 -C for warning error messages from XERMSG. Unless -C the user provides otherwise, an error message -C will be printed followed by an abort. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED D1MACH, DGECO, DGESL, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800326 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 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 DGEFS -C - INTEGER LDA,N,ITASK,IND,IWORK(*) - DOUBLE PRECISION A(LDA,*),V(*),WORK(*),D1MACH - DOUBLE PRECISION RCOND - CHARACTER*8 XERN1, XERN2 -C***FIRST EXECUTABLE STATEMENT DGEFS - IF (LDA.LT.N) THEN - IND = -1 - WRITE (XERN1, '(I8)') LDA - WRITE (XERN2, '(I8)') N - CALL XERMSG ('SLATEC', 'DGEFS', 'LDA = ' // XERN1 // - * ' IS LESS THAN N = ' // XERN2, -1, 1) - RETURN - ENDIF -C - IF (N.LE.0) THEN - IND = -2 - WRITE (XERN1, '(I8)') N - CALL XERMSG ('SLATEC', 'DGEFS', 'N = ' // XERN1 // - * ' IS LESS THAN 1', -2, 1) - RETURN - ENDIF -C - IF (ITASK.LT.1) THEN - IND = -3 - WRITE (XERN1, '(I8)') ITASK - CALL XERMSG ('SLATEC', 'DGEFS', 'ITASK = ' // XERN1 // - * ' IS LESS THAN 1', -3, 1) - RETURN - ENDIF -C - IF (ITASK.EQ.1) THEN -C -C FACTOR MATRIX A INTO LU -C - CALL DGECO(A,LDA,N,IWORK,RCOND,WORK) -C -C CHECK FOR COMPUTATIONALLY SINGULAR MATRIX -C - IF (RCOND.EQ.0.0D0) THEN - IND = -4 - CALL XERMSG ('SLATEC', 'DGEFS', - * 'SINGULAR MATRIX A - NO SOLUTION', -4, 1) - RETURN - ENDIF -C -C COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) -C AND CHECK FOR IND GREATER THAN ZERO -C - IND = -LOG10(D1MACH(4)/RCOND) - IF (IND.LE.0) THEN - IND=-10 - CALL XERMSG ('SLATEC', 'DGEFS', - * 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) - ENDIF - ENDIF -C -C SOLVE AFTER FACTORING -C - CALL DGESL(A,LDA,N,IWORK,V,0) - RETURN - END diff --git a/slatec/dgemm.f b/slatec/dgemm.f deleted file mode 100644 index a94e657..0000000 --- a/slatec/dgemm.f +++ /dev/null @@ -1,319 +0,0 @@ -*DECK DGEMM - SUBROUTINE DGEMM (TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC) -C***BEGIN PROLOGUE DGEMM -C***PURPOSE Perform one of the matrix-matrix operations. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B6 -C***TYPE DOUBLE PRECISION (SGEMM-S, DGEMM-D, CGEMM-C) -C***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J., (ANL) -C Duff, I., (AERE) -C Du Croz, J., (NAG) -C Hammarling, S. (NAG) -C***DESCRIPTION -C -C DGEMM performs one of the matrix-matrix operations -C -C C := alpha*op( A )*op( B ) + beta*C, -C -C where op( X ) is one of -C -C op( X ) = X or op( X ) = X', -C -C alpha and beta are scalars, and A, B and C are matrices, with op( A ) -C an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. -C -C Parameters -C ========== -C -C TRANSA - CHARACTER*1. -C On entry, TRANSA specifies the form of op( A ) to be used in -C the matrix multiplication as follows: -C -C TRANSA = 'N' or 'n', op( A ) = A. -C -C TRANSA = 'T' or 't', op( A ) = A'. -C -C TRANSA = 'C' or 'c', op( A ) = A'. -C -C Unchanged on exit. -C -C TRANSB - CHARACTER*1. -C On entry, TRANSB specifies the form of op( B ) to be used in -C the matrix multiplication as follows: -C -C TRANSB = 'N' or 'n', op( B ) = B. -C -C TRANSB = 'T' or 't', op( B ) = B'. -C -C TRANSB = 'C' or 'c', op( B ) = B'. -C -C Unchanged on exit. -C -C M - INTEGER. -C On entry, M specifies the number of rows of the matrix -C op( A ) and of the matrix C. M must be at least zero. -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the number of columns of the matrix -C op( B ) and the number of columns of the matrix C. N must be -C at least zero. -C Unchanged on exit. -C -C K - INTEGER. -C On entry, K specifies the number of columns of the matrix -C op( A ) and the number of rows of the matrix op( B ). K must -C be at least zero. -C Unchanged on exit. -C -C ALPHA - DOUBLE PRECISION. -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is -C k when TRANSA = 'N' or 'n', and is m otherwise. -C Before entry with TRANSA = 'N' or 'n', the leading m by k -C part of the array A must contain the matrix A, otherwise -C the leading k by m part of the array A must contain the -C matrix A. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. When TRANSA = 'N' or 'n' then -C LDA must be at least max( 1, m ), otherwise LDA must be at -C least max( 1, k ). -C Unchanged on exit. -C -C B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is -C n when TRANSB = 'N' or 'n', and is k otherwise. -C Before entry with TRANSB = 'N' or 'n', the leading k by n -C part of the array B must contain the matrix B, otherwise -C the leading n by k part of the array B must contain the -C matrix B. -C Unchanged on exit. -C -C LDB - INTEGER. -C On entry, LDB specifies the first dimension of B as declared -C in the calling (sub) program. When TRANSB = 'N' or 'n' then -C LDB must be at least max( 1, k ), otherwise LDB must be at -C least max( 1, n ). -C Unchanged on exit. -C -C BETA - DOUBLE PRECISION. -C On entry, BETA specifies the scalar beta. When BETA is -C supplied as zero then C need not be set on input. -C Unchanged on exit. -C -C C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). -C Before entry, the leading m by n part of the array C must -C contain the matrix C, except when beta is zero, in which -C case C need not be set on entry. -C On exit, the array C is overwritten by the m by n matrix -C ( alpha*op( A )*op( B ) + beta*C ). -C -C LDC - INTEGER. -C On entry, LDC specifies the first dimension of C as declared -C in the calling (sub) program. LDC must be at least -C max( 1, m ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. -C A set of level 3 basic linear algebra subprograms. -C ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 890208 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE DGEMM -C .. Scalar Arguments .. - CHARACTER*1 TRANSA, TRANSB - INTEGER M, N, K, LDA, LDB, LDC - DOUBLE PRECISION ALPHA, BETA -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Local Scalars .. - LOGICAL NOTA, NOTB - INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB - DOUBLE PRECISION TEMP -C .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -C***FIRST EXECUTABLE STATEMENT DGEMM -C -C Set NOTA and NOTB as true if A and B respectively are not -C transposed and set NROWA, NCOLA and NROWB as the number of rows -C and columns of A and the number of rows of B respectively. -C - 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 -C -C Test the input parameters. -C - 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 -C -C Quick return if possible. -C - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C And if alpha.eq.zero. -C - 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 -C -C Start the operations. -C - IF( NOTB )THEN - IF( NOTA )THEN -C -C Form C := alpha*A*B + beta*C. -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 -C -C Form C := alpha*A'*B + beta*C -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 -C -C Form C := alpha*A*B' + beta*C -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 -C -C Form C := alpha*A'*B' + beta*C -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 -C - RETURN -C -C End of DGEMM . -C - END diff --git a/slatec/dgemv.f b/slatec/dgemv.f deleted file mode 100644 index ab99448..0000000 --- a/slatec/dgemv.f +++ /dev/null @@ -1,268 +0,0 @@ -*DECK DGEMV - SUBROUTINE DGEMV (TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, - $ INCY) -C***BEGIN PROLOGUE DGEMV -C***PURPOSE Perform one of the matrix-vector operations. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE DOUBLE PRECISION (SGEMV-S, DGEMV-D, CGEMV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C DGEMV performs one of the matrix-vector operations -C -C y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, -C -C where alpha and beta are scalars, x and y are vectors and A is an -C m by n matrix. -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the operation to be performed as -C follows: -C -C TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -C -C TRANS = 'T' or 't' y := alpha*A'*x + beta*y. -C -C TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. -C -C Unchanged on exit. -C -C M - INTEGER. -C On entry, M specifies the number of rows of the matrix A. -C M must be at least zero. -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the number of columns of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - DOUBLE PRECISION. -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -C Before entry, the leading m by n part of the array A must -C contain the matrix of coefficients. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C max( 1, m ). -C Unchanged on exit. -C -C X - DOUBLE PRECISION array of DIMENSION at least -C ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -C and at least -C ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -C Before entry, the incremented array X must contain the -C vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C BETA - DOUBLE PRECISION. -C On entry, BETA specifies the scalar beta. When BETA is -C supplied as zero then Y need not be set on input. -C Unchanged on exit. -C -C Y - DOUBLE PRECISION array of DIMENSION at least -C ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -C and at least -C ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -C Before entry with BETA non-zero, the incremented array Y -C must contain the vector y. On exit, Y is overwritten by the -C updated vector y. -C -C INCY - INTEGER. -C On entry, INCY specifies the increment for the elements of -C Y. INCY must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE DGEMV -C .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA - INTEGER INCX, INCY, LDA, M, N - CHARACTER*1 TRANS -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -C .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -C .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C***FIRST EXECUTABLE STATEMENT DGEMV -C -C Test the input parameters. -C - 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 -C -C Quick return if possible. -C - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C Set LENX and LENY, the lengths of the vectors x and y, and set -C up the start points in X and Y. -C - 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 -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through A. -C -C First form y := beta*y. -C - 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 -C -C Form y := alpha*A*x + y. -C - 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 -C -C Form y := alpha*A'*x + y. -C - 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 -C - RETURN -C -C End of DGEMV . -C - END diff --git a/slatec/dger.f b/slatec/dger.f deleted file mode 100644 index 6499739..0000000 --- a/slatec/dger.f +++ /dev/null @@ -1,164 +0,0 @@ -*DECK DGER - SUBROUTINE DGER (M, N, ALPHA, X, INCX, Y, INCY, A, LDA) -C***BEGIN PROLOGUE DGER -C***PURPOSE Perform the rank 1 operation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE DOUBLE PRECISION (DGER-D) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C DGER performs the rank 1 operation -C -C A := alpha*x*y' + A, -C -C where alpha is a scalar, x is an m element vector, y is an n element -C vector and A is an m by n matrix. -C -C Parameters -C ========== -C -C M - INTEGER. -C On entry, M specifies the number of rows of the matrix A. -C M must be at least zero. -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the number of columns of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - DOUBLE PRECISION. -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C X - DOUBLE PRECISION array of dimension at least -C ( 1 + ( m - 1)*abs( INCX)). -C Before entry, the incremented array X must contain the m -C element vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C Y - DOUBLE PRECISION array of dimension at least -C ( 1 + ( n - 1 )*abs( INCY ) ). -C Before entry, the incremented array Y must contain the n -C element vector y. -C Unchanged on exit. -C -C INCY - INTEGER. -C On entry, INCY specifies the increment for the elements of -C Y. INCY must not be zero. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -C Before entry, the leading m by n part of the array A must -C contain the matrix of coefficients. On exit, A is -C overwritten by the updated matrix. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C max( 1, m ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE DGER -C .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, INCY, LDA, M, N -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -C .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JY, KX -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C***FIRST EXECUTABLE STATEMENT DGER -C -C Test the input parameters. -C - 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 -C -C Quick return if possible. -C - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through A. -C - 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 -C - RETURN -C -C End of DGER . -C - END diff --git a/slatec/dgesl.f b/slatec/dgesl.f deleted file mode 100644 index 0059359..0000000 --- a/slatec/dgesl.f +++ /dev/null @@ -1,131 +0,0 @@ -*DECK DGESL - SUBROUTINE DGESL (A, LDA, N, IPVT, B, JOB) -C***BEGIN PROLOGUE DGESL -C***PURPOSE Solve the real system A*X=B or TRANS(A)*X=B using the -C factors computed by DGECO or DGEFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2A1 -C***TYPE DOUBLE PRECISION (SGESL-S, DGESL-D, CGESL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -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***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DDOT -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DGESL - INTEGER LDA,N,IPVT(*),JOB - DOUBLE PRECISION A(LDA,*),B(*) -C - DOUBLE PRECISION DDOT,T - INTEGER K,KB,L,NM1 -C***FIRST EXECUTABLE STATEMENT DGESL - 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/slatec/dglss.f b/slatec/dglss.f deleted file mode 100644 index 10e1d33..0000000 --- a/slatec/dglss.f +++ /dev/null @@ -1,146 +0,0 @@ -*DECK DGLSS - SUBROUTINE DGLSS (A, MDA, M, N, B, MDB, NB, RNORM, WORK, LW, - + IWORK, LIW, INFO) -C***BEGIN PROLOGUE DGLSS -C***PURPOSE Solve a linear least squares problems by performing a QR -C factorization of the input matrix using Householder -C transformations. Emphasis is put on detecting possible -C rank deficiency. -C***LIBRARY SLATEC -C***CATEGORY D9, D5 -C***TYPE DOUBLE PRECISION (SGLSS-S, DGLSS-D) -C***KEYWORDS LINEAR LEAST SQUARES, LQ FACTORIZATION, QR FACTORIZATION, -C UNDERDETERMINED LINEAR SYSTEMS -C***AUTHOR Manteuffel, T. A., (LANL) -C***DESCRIPTION -C -C DGLSS solves both underdetermined and overdetermined -C LINEAR systems AX = B, where A is an M by N matrix -C and B is an M by NB matrix of right hand sides. If -C M.GE.N, the least squares solution is computed by -C decomposing the matrix A into the product of an -C orthogonal matrix Q and an upper triangular matrix -C R (QR factorization). If M.LT.N, the minimal -C length solution is computed by factoring the -C matrix A into the product of a lower triangular -C matrix L and an orthogonal matrix Q (LQ factor- -C ization). If the matrix A is determined to be rank -C deficient, that is the rank of A is less than -C MIN(M,N), then the minimal length least squares -C solution is computed. -C -C DGLSS assumes full machine precision in the data. -C If more control over the uncertainty in the data -C is desired, the codes DLLSIA and DULSIA are -C recommended. -C -C DGLSS requires MDA*N + (MDB + 1)*NB + 5*MIN(M,N) dimensioned -C real space and M+N dimensioned integer space. -C -C -C ****************************************************************** -C * * -C * WARNING - All input arrays are changed on exit. * -C * * -C ****************************************************************** -C SUBROUTINE DGLSS(A,MDA,M,N,B,MDB,NB,RNORM,WORK,LW,IWORK,LIW,INFO) -C -C Input..All TYPE REAL variables are DOUBLE PRECISION -C -C A(,) Linear coefficient matrix of AX=B, with MDA the -C MDA,M,N actual first dimension of A in the calling program. -C M is the row dimension (no. of EQUATIONS of the -C problem) and N the col dimension (no. of UNKNOWNS). -C -C B(,) Right hand side(s), with MDB the actual first -C MDB,NB dimension of B in the calling program. NB is the -C number of M by 1 right hand sides. Must have -C MDB.GE.MAX(M,N). If NB = 0, B is never accessed. -C -C -C RNORM() Vector of length at least NB. On input the contents -C of RNORM are unused. -C -C WORK() A real work array dimensioned 5*MIN(M,N). -C -C LW Actual dimension of WORK. -C -C IWORK() Integer work array dimensioned at least N+M. -C -C LIW Actual dimension of IWORK. -C -C -C INFO A flag which provides for the efficient -C solution of subsequent problems involving the -C same A but different B. -C If INFO = 0 original call -C INFO = 1 subsequent calls -C On subsequent calls, the user must supply A, INFO, -C LW, IWORK, LIW, and the first 2*MIN(M,N) locations -C of WORK as output by the original call to DGLSS. -C -C -C Output..All TYPE REAL variables are DOUBLE PRECISION -C -C A(,) Contains the triangular part of the reduced matrix -C and the transformation information. It together with -C the first 2*MIN(M,N) elements of WORK (see below) -C completely specify the factorization of A. -C -C B(,) Contains the N by NB solution matrix X. -C -C -C RNORM() Contains the Euclidean length of the NB residual -C vectors B(I)-AX(I), I=1,NB. -C -C WORK() The first 2*MIN(M,N) locations of WORK contain value -C necessary to reproduce the factorization of A. -C -C IWORK() The first M+N locations contain the order in -C which the rows and columns of A were used. -C If M.GE.N columns then rows. If M.LT.N rows -C then columns. -C -C INFO Flag to indicate status of computation on completion -C -1 Parameter error(s) -C 0 - Full rank -C N.GT.0 - Reduced rank rank=MIN(M,N)-INFO -C -C***REFERENCES T. Manteuffel, An interval analysis approach to rank -C determination in linear least squares problems, -C Report SAND80-0655, Sandia Laboratories, June 1980. -C***ROUTINES CALLED DLLSIA, DULSIA -C***REVISION HISTORY (YYMMDD) -C 810801 DATE WRITTEN -C 890831 Modified array declarations. (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 DGLSS - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION A(MDA,*),B(MDB,*),RNORM(*),WORK(*) - INTEGER IWORK(*) -C -C***FIRST EXECUTABLE STATEMENT DGLSS - RE=0.D0 - AE=0.D0 - KEY=0 - MODE=2 - NP=0 -C -C IF M.GE.N CALL DLLSIA -C IF M.LT.N CALL DULSIA -C - IF(M.LT.N) GO TO 10 - CALL DLLSIA(A,MDA,M,N,B,MDB,NB,RE,AE,KEY,MODE,NP, - 1 KRANK,KSURE,RNORM,WORK,LW,IWORK,LIW,INFO) - IF(INFO.EQ.-1) RETURN - INFO=N-KRANK - RETURN - 10 CALL DULSIA(A,MDA,M,N,B,MDB,NB,RE,AE,KEY,MODE,NP, - 1 KRANK,KSURE,RNORM,WORK,LW,IWORK,LIW,INFO) - IF(INFO.EQ.-1) RETURN - INFO=M-KRANK - RETURN - END diff --git a/slatec/dgmres.f b/slatec/dgmres.f deleted file mode 100644 index 44d5ad9..0000000 --- a/slatec/dgmres.f +++ /dev/null @@ -1,553 +0,0 @@ -*DECK DGMRES - SUBROUTINE DGMRES (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, - + ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, SB, SX, RGWK, LRGW, - + IGWK, LIGW, RWORK, IWORK) -C***BEGIN PROLOGUE DGMRES -C***PURPOSE Preconditioned GMRES iterative sparse Ax=b solver. -C This routine uses the generalized minimum residual -C (GMRES) method with preconditioning to solve -C non-symmetric linear systems of the form: Ax = b. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (SGMRES-S, DGMRES-D) -C***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov -C Hindmarsh, Alan, (LLNL), alanh@llnl.gov -C Seager, Mark K., (LLNL), seager@llnl.gov -C Lawrence Livermore National Laboratory -C PO Box 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LRGW, IGWK(LIGW), LIGW -C INTEGER IWORK(USER DEFINED) -C DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, SB(N), SX(N) -C DOUBLE PRECISION RGWK(LRGW), RWORK(USER DEFINED) -C EXTERNAL MATVEC, MSOLVE -C -C CALL DGMRES(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, -C $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, SB, SX, -C $ RGWK, LRGW, IGWK, LIGW, RWORK, IWORK) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right-hand side vector. -C X :INOUT Double Precision X(N). -C On input X is your initial guess for the solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Double Precision A(NELT). -C These arrays contain the matrix data structure for A. -C It could take any form. See "Description", below, -C for more details. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C MATVEC :EXT External. -C Name of a routine which performs the matrix vector multiply -C Y = A*X given A and X. The name of the MATVEC routine must -C be declared external in the calling program. The calling -C sequence to MATVEC is: -C CALL MATVEC(N, X, Y, NELT, IA, JA, A, ISYM) -C where N is the number of unknowns, Y is the product A*X -C upon return, X is an input vector, and NELT is the number of -C non-zeros in the SLAP IA, JA, A storage for the matrix A. -C ISYM is a flag which, if non-zero, denotes that A is -C symmetric and only the lower or upper triangle is stored. -C MSOLVE :EXT External. -C Name of the routine which solves a linear system Mz = r for -C z given r with the preconditioning matrix M (M is supplied via -C RWORK and IWORK arrays. The name of the MSOLVE routine must -C be declared external in the calling program. The calling -C sequence to MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, R is the right-hand side -C vector and Z is the solution upon return. NELT, IA, JA, A and -C ISYM are defined as above. RWORK is a double precision array -C that can be used to pass necessary preconditioning information -C and/or workspace to MSOLVE. IWORK is an integer work array -C for the same purpose as RWORK. -C ITOL :IN Integer. -C Flag to indicate the type of convergence criterion used. -C ITOL=0 Means the iteration stops when the test described -C below on the residual RL is satisfied. This is -C the "Natural Stopping Criteria" for this routine. -C Other values of ITOL cause extra, otherwise -C unnecessary, computation per iteration and are -C therefore much less efficient. See ISDGMR (the -C stop test routine) for more information. -C ITOL=1 Means the iteration stops when the first test -C described below on the residual RL is satisfied, -C and there is either right or no preconditioning -C being used. -C ITOL=2 Implies that the user is using left -C preconditioning, and the second stopping criterion -C below is used. -C ITOL=3 Means the iteration stops when the third test -C described below on Minv*Residual is satisfied, and -C there is either left or no preconditioning being -C used. -C ITOL=11 is often useful for checking and comparing -C different routines. For this case, the user must -C supply the "exact" solution or a very accurate -C approximation (one with an error much less than -C TOL) through a common block, -C COMMON /DSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the -C difference between the iterative approximation and -C the user-supplied solution divided by the 2-norm -C of the user-supplied solution is less than TOL. -C Note that this requires the user to set up the -C "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling -C routine. The routine with this declaration should -C be loaded before the stop test so that the correct -C length is used by the loader. This procedure is -C not standard Fortran and may not work correctly on -C your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 -C then this common block is indeed standard Fortran. -C TOL :INOUT Double Precision. -C Convergence criterion, as described below. If TOL is set -C to zero on input, then a default value of 500*(the smallest -C positive magnitude, machine epsilon) is used. -C ITMAX :DUMMY Integer. -C Maximum number of iterations in most SLAP routines. In -C this routine this does not make sense. The maximum number -C of iterations here is given by ITMAX = MAXL*(NRMAX+1). -C See IGWK for definitions of MAXL and NRMAX. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Double Precision. -C Error estimate of error in final approximate solution, as -C defined by ITOL. Letting norm() denote the Euclidean -C norm, ERR is defined as follows.. -C -C If ITOL=0, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), -C for right or no preconditioning, and -C ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ -C norm(SB*(M-inverse)*B), -C for left preconditioning. -C If ITOL=1, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), -C since right or no preconditioning -C being used. -C If ITOL=2, then ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ -C norm(SB*(M-inverse)*B), -C since left preconditioning is being -C used. -C If ITOL=3, then ERR = Max |(Minv*(B-A*X(L)))(i)/x(i)| -C i=1,n -C If ITOL=11, then ERR = norm(SB*(X(L)-SOLN))/norm(SB*SOLN). -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient storage allocated for -C RGWK or IGWK. -C IERR = 2 => Routine DGMRES failed to reduce the norm -C of the current residual on its last call, -C and so the iteration has stalled. In -C this case, X equals the last computed -C approximation. The user must either -C increase MAXL, or choose a different -C initial guess. -C IERR =-1 => Insufficient length for RGWK array. -C IGWK(6) contains the required minimum -C length of the RGWK array. -C IERR =-2 => Illegal value of ITOL, or ITOL and JPRE -C values are inconsistent. -C For IERR <= 2, RGWK(1) = RHOL, which is the norm on the -C left-hand-side of the relevant stopping test defined -C below associated with the residual for the current -C approximation X(L). -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C SB :IN Double Precision SB(N). -C Array of length N containing scale factors for the right -C hand side vector B. If JSCAL.eq.0 (see below), SB need -C not be supplied. -C SX :IN Double Precision SX(N). -C Array of length N containing scale factors for the solution -C vector X. If JSCAL.eq.0 (see below), SX need not be -C supplied. SB and SX can be the same array in the calling -C program if desired. -C RGWK :INOUT Double Precision RGWK(LRGW). -C Double Precision array used for workspace by DGMRES. -C On return, RGWK(1) = RHOL. See IERR for definition of RHOL. -C LRGW :IN Integer. -C Length of the double precision workspace, RGWK. -C LRGW >= 1 + N*(MAXL+6) + MAXL*(MAXL+3). -C See below for definition of MAXL. -C For the default values, RGWK has size at least 131 + 16*N. -C IGWK :INOUT Integer IGWK(LIGW). -C The following IGWK parameters should be set by the user -C before calling this routine. -C IGWK(1) = MAXL. Maximum dimension of Krylov subspace in -C which X - X0 is to be found (where, X0 is the initial -C guess). The default value of MAXL is 10. -C IGWK(2) = KMP. Maximum number of previous Krylov basis -C vectors to which each new basis vector is made orthogonal. -C The default value of KMP is MAXL. -C IGWK(3) = JSCAL. Flag indicating whether the scaling -C arrays SB and SX are to be used. -C JSCAL = 0 => SB and SX are not used and the algorithm -C will perform as if all SB(I) = 1 and SX(I) = 1. -C JSCAL = 1 => Only SX is used, and the algorithm -C performs as if all SB(I) = 1. -C JSCAL = 2 => Only SB is used, and the algorithm -C performs as if all SX(I) = 1. -C JSCAL = 3 => Both SB and SX are used. -C IGWK(4) = JPRE. Flag indicating whether preconditioning -C is being used. -C JPRE = 0 => There is no preconditioning. -C JPRE > 0 => There is preconditioning on the right -C only, and the solver will call routine MSOLVE. -C JPRE < 0 => There is preconditioning on the left -C only, and the solver will call routine MSOLVE. -C IGWK(5) = NRMAX. Maximum number of restarts of the -C Krylov iteration. The default value of NRMAX = 10. -C if IWORK(5) = -1, then no restarts are performed (in -C this case, NRMAX is set to zero internally). -C The following IWORK parameters are diagnostic information -C made available to the user after this routine completes. -C IGWK(6) = MLWK. Required minimum length of RGWK array. -C IGWK(7) = NMS. The total number of calls to MSOLVE. -C LIGW :IN Integer. -C Length of the integer workspace, IGWK. LIGW >= 20. -C RWORK :WORK Double Precision RWORK(USER DEFINED). -C Double Precision array that can be used for workspace in -C MSOLVE. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used for workspace in MSOLVE. -C -C *Description: -C DGMRES solves a linear system A*X = B rewritten in the form: -C -C (SB*A*(M-inverse)*(SX-inverse))*(SX*M*X) = SB*B, -C -C with right preconditioning, or -C -C (SB*(M-inverse)*A*(SX-inverse))*(SX*X) = SB*(M-inverse)*B, -C -C with left preconditioning, where A is an N-by-N double precision -C matrix, X and B are N-vectors, SB and SX are diagonal scaling -C matrices, and M is a preconditioning matrix. It uses -C preconditioned Krylov subpace methods based on the -C generalized minimum residual method (GMRES). This routine -C optionally performs either the full orthogonalization -C version of the GMRES algorithm or an incomplete variant of -C it. Both versions use restarting of the linear iteration by -C default, although the user can disable this feature. -C -C The GMRES algorithm generates a sequence of approximations -C X(L) to the true solution of the above linear system. The -C convergence criteria for stopping the iteration is based on -C the size of the scaled norm of the residual R(L) = B - -C A*X(L). The actual stopping test is either: -C -C norm(SB*(B-A*X(L))) .le. TOL*norm(SB*B), -C -C for right preconditioning, or -C -C norm(SB*(M-inverse)*(B-A*X(L))) .le. -C TOL*norm(SB*(M-inverse)*B), -C -C for left preconditioning, where norm() denotes the Euclidean -C norm, and TOL is a positive scalar less than one input by -C the user. If TOL equals zero when DGMRES is called, then a -C default value of 500*(the smallest positive magnitude, -C machine epsilon) is used. If the scaling arrays SB and SX -C are used, then ideally they should be chosen so that the -C vectors SX*X(or SX*M*X) and SB*B have all their components -C approximately equal to one in magnitude. If one wants to -C use the same scaling in X and B, then SB and SX can be the -C same array in the calling program. -C -C The following is a list of the other routines and their -C functions used by DGMRES: -C DPIGMR Contains the main iteration loop for GMRES. -C DORTH Orthogonalizes a new vector against older basis vectors. -C DHEQR Computes a QR decomposition of a Hessenberg matrix. -C DHELS Solves a Hessenberg least-squares system, using QR -C factors. -C DRLCAL Computes the scaled residual RL. -C DXLCAL Computes the solution XL. -C ISDGMR User-replaceable stopping routine. -C -C This routine does not care what matrix data structure is -C used for A and M. It simply calls the MATVEC and MSOLVE -C routines, with the arguments as described above. The user -C could write any type of structure and the appropriate MATVEC -C and MSOLVE routines. It is assumed that A is stored in the -C IA, JA, A arrays in some fashion and that M (or INV(M)) is -C stored in IWORK and RWORK in some fashion. The SLAP -C routines DSDCG and DSICCG are examples of this procedure. -C -C Two examples of matrix data structures are the: 1) SLAP -C Triad format and 2) SLAP Column format. -C -C =================== S L A P Triad format =================== -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***REFERENCES 1. Peter N. Brown and A. C. Hindmarsh, Reduced Storage -C Matrix Methods in Stiff ODE Systems, Lawrence Liver- -C more National Laboratory Report UCRL-95088, Rev. 1, -C Livermore, California, June 1987. -C 2. Mark K. Seager, A SLAP for the Masses, in -C G. F. Carey, Ed., Parallel Supercomputing: Methods, -C Algorithms and Applications, Wiley, 1989, pp.135-155. -C***ROUTINES CALLED D1MACH, DCOPY, DNRM2, DPIGMR -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 891004 Added new reference. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910506 Corrected errors in C***ROUTINES CALLED list. (FNF) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of references. (FNF) -C 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) -C 921026 Added check for valid value of ITOL. (FNF) -C***END PROLOGUE DGMRES -C The following is for optimized compilation on LLNL/LTSS Crays. -CLLL. OPTIMIZE -C .. Scalar Arguments .. - DOUBLE PRECISION ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LIGW, LRGW, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), B(N), RGWK(LRGW), RWORK(*), SB(N), - + SX(N), X(N) - INTEGER IA(NELT), IGWK(LIGW), IWORK(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MATVEC, MSOLVE -C .. Local Scalars .. - DOUBLE PRECISION BNRM, RHOL, SUM - INTEGER I, IFLAG, JPRE, JSCAL, KMP, LDL, LGMR, LHES, LQ, LR, LV, - + LW, LXL, LZ, LZM1, MAXL, MAXLP1, NMS, NMSL, NRMAX, NRSTS -C .. External Functions .. - DOUBLE PRECISION D1MACH, DNRM2 - EXTERNAL D1MACH, DNRM2 -C .. External Subroutines .. - EXTERNAL DCOPY, DPIGMR -C .. Intrinsic Functions .. - INTRINSIC SQRT -C***FIRST EXECUTABLE STATEMENT DGMRES - IERR = 0 -C ------------------------------------------------------------------ -C Load method parameters with user values or defaults. -C ------------------------------------------------------------------ - MAXL = IGWK(1) - IF (MAXL .EQ. 0) MAXL = 10 - IF (MAXL .GT. N) MAXL = N - KMP = IGWK(2) - IF (KMP .EQ. 0) KMP = MAXL - IF (KMP .GT. MAXL) KMP = MAXL - JSCAL = IGWK(3) - JPRE = IGWK(4) -C Check for valid value of ITOL. - IF( (ITOL.LT.0) .OR. ((ITOL.GT.3).AND.(ITOL.NE.11)) ) GOTO 650 -C Check for consistent values of ITOL and JPRE. - IF( ITOL.EQ.1 .AND. JPRE.LT.0 ) GOTO 650 - IF( ITOL.EQ.2 .AND. JPRE.GE.0 ) GOTO 650 - NRMAX = IGWK(5) - IF( NRMAX.EQ.0 ) NRMAX = 10 -C If NRMAX .eq. -1, then set NRMAX = 0 to turn off restarting. - IF( NRMAX.EQ.-1 ) NRMAX = 0 -C If input value of TOL is zero, set it to its default value. - IF( TOL.EQ.0.0D0 ) TOL = 500*D1MACH(3) -C -C Initialize counters. - ITER = 0 - NMS = 0 - NRSTS = 0 -C ------------------------------------------------------------------ -C Form work array segment pointers. -C ------------------------------------------------------------------ - MAXLP1 = MAXL + 1 - LV = 1 - LR = LV + N*MAXLP1 - LHES = LR + N + 1 - LQ = LHES + MAXL*MAXLP1 - LDL = LQ + 2*MAXL - LW = LDL + N - LXL = LW + N - LZ = LXL + N -C -C Load IGWK(6) with required minimum length of the RGWK array. - IGWK(6) = LZ + N - 1 - IF( LZ+N-1.GT.LRGW ) GOTO 640 -C ------------------------------------------------------------------ -C Calculate scaled-preconditioned norm of RHS vector b. -C ------------------------------------------------------------------ - IF (JPRE .LT. 0) THEN - CALL MSOLVE(N, B, RGWK(LR), NELT, IA, JA, A, ISYM, - $ RWORK, IWORK) - NMS = NMS + 1 - ELSE - CALL DCOPY(N, B, 1, RGWK(LR), 1) - ENDIF - IF( JSCAL.EQ.2 .OR. JSCAL.EQ.3 ) THEN - SUM = 0 - DO 10 I = 1,N - SUM = SUM + (RGWK(LR-1+I)*SB(I))**2 - 10 CONTINUE - BNRM = SQRT(SUM) - ELSE - BNRM = DNRM2(N,RGWK(LR),1) - ENDIF -C ------------------------------------------------------------------ -C Calculate initial residual. -C ------------------------------------------------------------------ - CALL MATVEC(N, X, RGWK(LR), NELT, IA, JA, A, ISYM) - DO 50 I = 1,N - RGWK(LR-1+I) = B(I) - RGWK(LR-1+I) - 50 CONTINUE -C ------------------------------------------------------------------ -C If performing restarting, then load the residual into the -C correct location in the RGWK array. -C ------------------------------------------------------------------ - 100 CONTINUE - IF( NRSTS.GT.NRMAX ) GOTO 610 - IF( NRSTS.GT.0 ) THEN -C Copy the current residual to a different location in the RGWK -C array. - CALL DCOPY(N, RGWK(LDL), 1, RGWK(LR), 1) - ENDIF -C ------------------------------------------------------------------ -C Use the DPIGMR algorithm to solve the linear system A*Z = R. -C ------------------------------------------------------------------ - CALL DPIGMR(N, RGWK(LR), SB, SX, JSCAL, MAXL, MAXLP1, KMP, - $ NRSTS, JPRE, MATVEC, MSOLVE, NMSL, RGWK(LZ), RGWK(LV), - $ RGWK(LHES), RGWK(LQ), LGMR, RWORK, IWORK, RGWK(LW), - $ RGWK(LDL), RHOL, NRMAX, B, BNRM, X, RGWK(LXL), ITOL, - $ TOL, NELT, IA, JA, A, ISYM, IUNIT, IFLAG, ERR) - ITER = ITER + LGMR - NMS = NMS + NMSL -C -C Increment X by the current approximate solution Z of A*Z = R. -C - LZM1 = LZ - 1 - DO 110 I = 1,N - X(I) = X(I) + RGWK(LZM1+I) - 110 CONTINUE - IF( IFLAG.EQ.0 ) GOTO 600 - IF( IFLAG.EQ.1 ) THEN - NRSTS = NRSTS + 1 - GOTO 100 - ENDIF - IF( IFLAG.EQ.2 ) GOTO 620 -C ------------------------------------------------------------------ -C All returns are made through this section. -C ------------------------------------------------------------------ -C The iteration has converged. -C - 600 CONTINUE - IGWK(7) = NMS - RGWK(1) = RHOL - IERR = 0 - RETURN -C -C Max number((NRMAX+1)*MAXL) of linear iterations performed. - 610 CONTINUE - IGWK(7) = NMS - RGWK(1) = RHOL - IERR = 1 - RETURN -C -C GMRES failed to reduce last residual in MAXL iterations. -C The iteration has stalled. - 620 CONTINUE - IGWK(7) = NMS - RGWK(1) = RHOL - IERR = 2 - RETURN -C Error return. Insufficient length for RGWK array. - 640 CONTINUE - ERR = TOL - IERR = -1 - RETURN -C Error return. Inconsistent ITOL and JPRE values. - 650 CONTINUE - ERR = TOL - IERR = -2 - RETURN -C------------- LAST LINE OF DGMRES FOLLOWS ---------------------------- - END diff --git a/slatec/dgtsl.f b/slatec/dgtsl.f deleted file mode 100644 index 08b3e1d..0000000 --- a/slatec/dgtsl.f +++ /dev/null @@ -1,132 +0,0 @@ -*DECK DGTSL - SUBROUTINE DGTSL (N, C, D, E, B, INFO) -C***BEGIN PROLOGUE DGTSL -C***PURPOSE Solve a tridiagonal linear system. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2A2A -C***TYPE DOUBLE PRECISION (SGTSL-S, DGTSL-D, CGTSL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE, TRIDIAGONAL -C***AUTHOR Dongarra, J., (ANL) -C***DESCRIPTION -C -C DGTSL given a general tridiagonal matrix and a right hand -C side will find the solution. -C -C On Entry -C -C N INTEGER -C is the order of the tridiagonal matrix. -C -C C DOUBLE PRECISION(N) -C is the subdiagonal of the tridiagonal matrix. -C C(2) through C(N) should contain the subdiagonal. -C On output C is destroyed. -C -C D DOUBLE PRECISION(N) -C is the diagonal of the tridiagonal matrix. -C On output D is destroyed. -C -C E DOUBLE PRECISION(N) -C is the superdiagonal of the tridiagonal matrix. -C E(1) through E(N-1) should contain the superdiagonal. -C On output E is destroyed. -C -C B DOUBLE PRECISION(N) -C is the right hand side vector. -C -C On Return -C -C B is the solution vector. -C -C INFO INTEGER -C = 0 normal value. -C = K if the K-th element of the diagonal becomes -C exactly zero. The subroutine returns when -C this is detected. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DGTSL - INTEGER N,INFO - DOUBLE PRECISION C(*),D(*),E(*),B(*) -C - INTEGER K,KB,KP1,NM1,NM2 - DOUBLE PRECISION T -C***FIRST EXECUTABLE STATEMENT DGTSL - INFO = 0 - C(1) = D(1) - NM1 = N - 1 - IF (NM1 .LT. 1) GO TO 40 - D(1) = E(1) - E(1) = 0.0D0 - E(N) = 0.0D0 -C - DO 30 K = 1, NM1 - KP1 = K + 1 -C -C FIND THE LARGEST OF THE TWO ROWS -C - IF (ABS(C(KP1)) .LT. ABS(C(K))) GO TO 10 -C -C INTERCHANGE ROW -C - T = C(KP1) - C(KP1) = C(K) - C(K) = T - T = D(KP1) - D(KP1) = D(K) - D(K) = T - T = E(KP1) - E(KP1) = E(K) - E(K) = T - T = B(KP1) - B(KP1) = B(K) - B(K) = T - 10 CONTINUE -C -C ZERO ELEMENTS -C - IF (C(K) .NE. 0.0D0) GO TO 20 - INFO = K - GO TO 100 - 20 CONTINUE - T = -C(KP1)/C(K) - C(KP1) = D(KP1) + T*D(K) - D(KP1) = E(KP1) + T*E(K) - E(KP1) = 0.0D0 - B(KP1) = B(KP1) + T*B(K) - 30 CONTINUE - 40 CONTINUE - IF (C(N) .NE. 0.0D0) GO TO 50 - INFO = N - GO TO 90 - 50 CONTINUE -C -C BACK SOLVE -C - NM2 = N - 2 - B(N) = B(N)/C(N) - IF (N .EQ. 1) GO TO 80 - B(NM1) = (B(NM1) - D(NM1)*B(N))/C(NM1) - IF (NM2 .LT. 1) GO TO 70 - DO 60 KB = 1, NM2 - K = NM2 - KB + 1 - B(K) = (B(K) - D(K)*B(K+1) - E(K)*B(K+2))/C(K) - 60 CONTINUE - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE -C - RETURN - END diff --git a/slatec/dh12.f b/slatec/dh12.f deleted file mode 100644 index d1b85ee..0000000 --- a/slatec/dh12.f +++ /dev/null @@ -1,143 +0,0 @@ -*DECK DH12 - SUBROUTINE DH12 (MODE, LPIVOT, L1, M, U, IUE, UP, C, ICE, ICV, - + NCV) -C***BEGIN PROLOGUE DH12 -C***SUBSIDIARY -C***PURPOSE Subsidiary to DHFTI, DLSEI and DWNNLS -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (H12-S, DH12-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C *** DOUBLE PRECISION VERSION OF H12 ****** -C -C C.L.Lawson and R.J.Hanson, Jet Propulsion Laboratory, 1973 Jun 12 -C to appear in 'Solving Least Squares Problems', Prentice-Hall, 1974 -C -C Construction and/or application of a single -C Householder transformation.. Q = I + U*(U**T)/B -C -C MODE = 1 or 2 to select algorithm H1 or H2 . -C LPIVOT is the index of the pivot element. -C L1,M If L1 .LE. M the transformation will be constructed to -C zero elements indexed from L1 through M. If L1 GT. M -C THE SUBROUTINE DOES AN IDENTITY TRANSFORMATION. -C U(),IUE,UP On entry to H1 U() contains the pivot vector. -C IUE is the storage increment between elements. -C On exit from H1 U() and UP -C contain quantities defining the vector U of the -C Householder transformation. On entry to H2 U() -C and UP should contain quantities previously computed -C by H1. These will not be modified by H2. -C C() On entry to H1 or H2 C() contains a matrix which will be -C regarded as a set of vectors to which the Householder -C transformation is to be applied. On exit C() contains the -C set of transformed vectors. -C ICE Storage increment between elements of vectors in C(). -C ICV Storage increment between vectors in C(). -C NCV Number of vectors in C() to be transformed. If NCV .LE. 0 -C no operations will be done on C(). -C -C***SEE ALSO DHFTI, DLSEI, DWNNLS -C***ROUTINES CALLED DAXPY, DDOT, DSWAP -C***REVISION HISTORY (YYMMDD) -C 790101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900911 Added DDOT to DOUBLE PRECISION statement. (WRB) -C***END PROLOGUE DH12 - INTEGER I, I2, I3, I4, ICE, ICV, INCR, IUE, J, KL1, KL2, KLP, - * L1, L1M1, LPIVOT, M, MML1P2, MODE, NCV - DOUBLE PRECISION B, C, CL, CLINV, ONE, UL1M1, SM, U, UP, DDOT - DIMENSION U(IUE,*), C(*) -C BEGIN BLOCK PERMITTING ...EXITS TO 140 -C***FIRST EXECUTABLE STATEMENT DH12 - ONE = 1.0D0 -C -C ...EXIT - IF (0 .GE. LPIVOT .OR. LPIVOT .GE. L1 .OR. L1 .GT. M) GO TO 140 - CL = ABS(U(1,LPIVOT)) - IF (MODE .EQ. 2) GO TO 40 -C ****** CONSTRUCT THE TRANSFORMATION. ****** - DO 10 J = L1, M - CL = MAX(ABS(U(1,J)),CL) - 10 CONTINUE - IF (CL .GT. 0.0D0) GO TO 20 -C .........EXIT - GO TO 140 - 20 CONTINUE - CLINV = ONE/CL - SM = (U(1,LPIVOT)*CLINV)**2 - DO 30 J = L1, M - SM = SM + (U(1,J)*CLINV)**2 - 30 CONTINUE - CL = CL*SQRT(SM) - IF (U(1,LPIVOT) .GT. 0.0D0) CL = -CL - UP = U(1,LPIVOT) - CL - U(1,LPIVOT) = CL - GO TO 50 - 40 CONTINUE -C ****** APPLY THE TRANSFORMATION I+U*(U**T)/B TO C. ****** -C - IF (CL .GT. 0.0D0) GO TO 50 -C ......EXIT - GO TO 140 - 50 CONTINUE -C ...EXIT - IF (NCV .LE. 0) GO TO 140 - B = UP*U(1,LPIVOT) -C B MUST BE NONPOSITIVE HERE. IF B = 0., RETURN. -C - IF (B .LT. 0.0D0) GO TO 60 -C ......EXIT - GO TO 140 - 60 CONTINUE - B = ONE/B - MML1P2 = M - L1 + 2 - IF (MML1P2 .LE. 20) GO TO 80 - L1M1 = L1 - 1 - KL1 = 1 + (L1M1 - 1)*ICE - KL2 = KL1 - KLP = 1 + (LPIVOT - 1)*ICE - UL1M1 = U(1,L1M1) - U(1,L1M1) = UP - IF (LPIVOT .NE. L1M1) CALL DSWAP(NCV,C(KL1),ICV,C(KLP),ICV) - DO 70 J = 1, NCV - SM = DDOT(MML1P2,U(1,L1M1),IUE,C(KL1),ICE) - SM = SM*B - CALL DAXPY(MML1P2,SM,U(1,L1M1),IUE,C(KL1),ICE) - KL1 = KL1 + ICV - 70 CONTINUE - U(1,L1M1) = UL1M1 -C ......EXIT - IF (LPIVOT .EQ. L1M1) GO TO 140 - KL1 = KL2 - CALL DSWAP(NCV,C(KL1),ICV,C(KLP),ICV) - GO TO 130 - 80 CONTINUE - I2 = 1 - ICV + ICE*(LPIVOT - 1) - INCR = ICE*(L1 - LPIVOT) - DO 120 J = 1, NCV - I2 = I2 + ICV - I3 = I2 + INCR - I4 = I3 - SM = C(I2)*UP - DO 90 I = L1, M - SM = SM + C(I3)*U(1,I) - I3 = I3 + ICE - 90 CONTINUE - IF (SM .EQ. 0.0D0) GO TO 110 - SM = SM*B - C(I2) = C(I2) + SM*UP - DO 100 I = L1, M - C(I4) = C(I4) + SM*U(1,I) - I4 = I4 + ICE - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE - 130 CONTINUE - 140 CONTINUE - RETURN - END diff --git a/slatec/dhels.f b/slatec/dhels.f deleted file mode 100644 index ce3c8c9..0000000 --- a/slatec/dhels.f +++ /dev/null @@ -1,98 +0,0 @@ -*DECK DHELS - SUBROUTINE DHELS (A, LDA, N, Q, B) -C***BEGIN PROLOGUE DHELS -C***SUBSIDIARY -C***PURPOSE Internal routine for DGMRES. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (SHELS-S, DHELS-D) -C***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov -C Hindmarsh, Alan, (LLNL), alanh@llnl.gov -C Seager, Mark K., (LLNL), seager@llnl.gov -C Lawrence Livermore National Laboratory -C PO Box 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C***DESCRIPTION -C This routine is extracted from the LINPACK routine SGESL with -C changes due to the fact that 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 *Usage: -C INTEGER LDA, N -C DOUBLE PRECISION A(LDA,N), Q(2*N), B(N+1) -C -C CALL DHELS(A, LDA, N, Q, B) -C -C *Arguments: -C A :IN Double Precision A(LDA,N) -C The output from DHEQR which contains the upper -C triangular factor R in the QR decomposition of A. -C LDA :IN Integer -C The leading dimension of the array A. -C N :IN Integer -C A is originally an (N+1) by N matrix. -C Q :IN Double Precision Q(2*N) -C The coefficients of the N Givens rotations -C used in the QR factorization of A. -C B :INOUT Double Precision B(N+1) -C On input, B is the right hand side vector. -C On output, B is the solution vector X. -C -C***SEE ALSO DGMRES -C***ROUTINES CALLED DAXPY -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Added C***FIRST EXECUTABLE STATEMENT line. (FNF) -C 910506 Made subsidiary to DGMRES. (FNF) -C 920511 Added complete declaration section. (WRB) -C***END PROLOGUE DHELS -C The following is for optimized compilation on LLNL/LTSS Crays. -CLLL. OPTIMIZE -C .. Scalar Arguments .. - INTEGER LDA, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(*), Q(*) -C .. Local Scalars .. - DOUBLE PRECISION C, S, T, T1, T2 - INTEGER IQ, K, KB, KP1 -C .. External Subroutines .. - EXTERNAL DAXPY -C***FIRST EXECUTABLE STATEMENT DHELS -C -C Minimize(B-A*X,B-A*X). 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------------- LAST LINE OF DHELS FOLLOWS ---------------------------- - END diff --git a/slatec/dheqr.f b/slatec/dheqr.f deleted file mode 100644 index 0c485a7..0000000 --- a/slatec/dheqr.f +++ /dev/null @@ -1,178 +0,0 @@ -*DECK DHEQR - SUBROUTINE DHEQR (A, LDA, N, Q, INFO, IJOB) -C***BEGIN PROLOGUE DHEQR -C***SUBSIDIARY -C***PURPOSE Internal routine for DGMRES. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (SHEQR-S, DHEQR-D) -C***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov -C Hindmarsh, Alan, (LLNL), alanh@llnl.gov -C Seager, Mark K., (LLNL), seager@llnl.gov -C Lawrence Livermore National Laboratory -C PO Box 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C***DESCRIPTION -C This routine performs a QR decomposition of an upper -C Hessenberg matrix A using Givens rotations. There are two -C options available: 1) Performing a fresh decomposition 2) -C updating the QR factors by adding a row and a column to the -C matrix A. -C -C *Usage: -C INTEGER LDA, N, INFO, IJOB -C DOUBLE PRECISION A(LDA,N), Q(2*N) -C -C CALL DHEQR(A, LDA, N, Q, INFO, IJOB) -C -C *Arguments: -C A :INOUT Double Precision A(LDA,N) -C On input, the matrix to be decomposed. -C On output, 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 LDA :IN Integer -C The leading dimension of the array A. -C N :IN Integer -C A is an (N+1) by N Hessenberg matrix. -C Q :OUT Double Precision Q(2*N) -C The factors c and s of each Givens rotation used -C in decomposing A. -C INFO :OUT 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 IJOB :IN 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 -C***SEE ALSO DGMRES -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910506 Made subsidiary to DGMRES. (FNF) -C 920511 Added complete declaration section. (WRB) -C***END PROLOGUE DHEQR -C The following is for optimized compilation on LLNL/LTSS Crays. -CLLL. OPTIMIZE -C .. Scalar Arguments .. - INTEGER IJOB, INFO, LDA, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), Q(*) -C .. Local Scalars .. - DOUBLE PRECISION C, S, T, T1, T2 - INTEGER I, IQ, J, K, KM1, KP1, NM1 -C .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -C***FIRST EXECUTABLE STATEMENT DHEQR - IF (IJOB .GT. 1) GO TO 70 -C ------------------------------------------------------------------- -C A new factorization is desired. -C ------------------------------------------------------------------- -C QR decomposition without pivoting. -C - INFO = 0 - DO 60 K = 1, N - KM1 = K - 1 - KP1 = K + 1 -C -C Compute K-th column of R. -C First, multiply the K-th 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.EQ.0.0D0 ) THEN - C = 1 - S = 0 - ELSEIF( ABS(T2).GE.ABS(T1) ) THEN - T = T1/T2 - S = -1.0D0/SQRT(1.0D0+T*T) - C = -S*T - ELSE - T = T2/T1 - C = 1.0D0/SQRT(1.0D0+T*T) - S = -C*T - ENDIF - 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 -C column has been added to the matrix A. N by N-1 is now -C 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 -C rotation, and multiplying it times the column -C vector(A(N,N),A(NP1,N)). -C ------------------------------------------------------------------- - INFO = 0 - T1 = A(N,N) - T2 = A(N+1,N) - IF ( T2.EQ.0.0D0 ) THEN - C = 1 - S = 0 - ELSEIF( ABS(T2).GE.ABS(T1) ) THEN - T = T1/T2 - S = -1.0D0/SQRT(1.0D0+T*T) - C = -S*T - ELSE - T = T2/T1 - C = 1.0D0/SQRT(1.0D0+T*T) - S = -C*T - ENDIF - 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------------- LAST LINE OF DHEQR FOLLOWS ---------------------------- - END diff --git a/slatec/dhfti.f b/slatec/dhfti.f deleted file mode 100644 index 0583a4b..0000000 --- a/slatec/dhfti.f +++ /dev/null @@ -1,331 +0,0 @@ -*DECK DHFTI - SUBROUTINE DHFTI (A, MDA, M, N, B, MDB, NB, TAU, KRANK, RNORM, H, - + G, IP) -C***BEGIN PROLOGUE DHFTI -C***PURPOSE Solve a least squares problem for banded matrices using -C sequential accumulation of rows of the data matrix. -C Exactly one right-hand side vector is permitted. -C***LIBRARY SLATEC -C***CATEGORY D9 -C***TYPE DOUBLE PRECISION (HFTI-S, DHFTI-D) -C***KEYWORDS CURVE FITTING, LEAST SQUARES -C***AUTHOR Lawson, C. L., (JPL) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C DIMENSION A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N) -C -C This subroutine solves a linear least squares problem or a set of -C linear least squares problems having the same matrix but different -C right-side vectors. The problem data consists of an M by N matrix -C A, an M by NB matrix B, and an absolute tolerance parameter TAU -C whose usage is described below. The NB column vectors of B -C represent right-side vectors for NB distinct linear least squares -C problems. -C -C This set of problems can also be written as the matrix least -C squares problem -C -C AX = B, -C -C where X is the N by NB solution matrix. -C -C Note that if B is the M by M identity matrix, then X will be the -C pseudo-inverse of A. -C -C This subroutine first transforms the augmented matrix (A B) to a -C matrix (R C) using premultiplying Householder transformations with -C column interchanges. All subdiagonal elements in the matrix R are -C zero and its diagonal elements satisfy -C -C ABS(R(I,I)).GE.ABS(R(I+1,I+1)), -C -C I = 1,...,L-1, where -C -C L = MIN(M,N). -C -C The subroutine will compute an integer, KRANK, equal to the number -C of diagonal terms of R that exceed TAU in magnitude. Then a -C solution of minimum Euclidean length is computed using the first -C KRANK rows of (R C). -C -C To be specific we suggest that the user consider an easily -C computable matrix norm, such as, the maximum of all column sums of -C magnitudes. -C -C Now if the relative uncertainty of B is EPS, (norm of uncertainty/ -C norm of B), it is suggested that TAU be set approximately equal to -C EPS*(norm of A). -C -C The user must dimension all arrays appearing in the call list.. -C A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N). This -C permits the solution of a range of problems in the same array -C space. -C -C The entire set of parameters for DHFTI are -C -C INPUT.. All TYPE REAL variables are DOUBLE PRECISION -C -C A(*,*),MDA,M,N The array A(*,*) initially contains the M by N -C matrix A of the least squares problem AX = B. -C The first dimensioning parameter of the array -C A(*,*) is MDA, which must satisfy MDA.GE.M -C Either M.GE.N or M.LT.N is permitted. There -C is no restriction on the rank of A. The -C condition MDA.LT.M is considered an error. -C -C B(*),MDB,NB If NB = 0 the subroutine will perform the -C orthogonal decomposition but will make no -C references to the array B(*). If NB.GT.0 -C the array B(*) must initially contain the M by -C NB matrix B of the least squares problem AX = -C B. If NB.GE.2 the array B(*) must be doubly -C subscripted with first dimensioning parameter -C MDB.GE.MAX(M,N). If NB = 1 the array B(*) may -C be either doubly or singly subscripted. In -C the latter case the value of MDB is arbitrary -C but it should be set to some valid integer -C value such as MDB = M. -C -C The condition of NB.GT.1.AND.MDB.LT. MAX(M,N) -C is considered an error. -C -C TAU Absolute tolerance parameter provided by user -C for pseudorank determination. -C -C H(*),G(*),IP(*) Arrays of working space used by DHFTI. -C -C OUTPUT.. All TYPE REAL variables are DOUBLE PRECISION -C -C A(*,*) The contents of the array A(*,*) will be -C modified by the subroutine. These contents -C are not generally required by the user. -C -C B(*) On return the array B(*) will contain the N by -C NB solution matrix X. -C -C KRANK Set by the subroutine to indicate the -C pseudorank of A. -C -C RNORM(*) On return, RNORM(J) will contain the Euclidean -C norm of the residual vector for the problem -C defined by the J-th column vector of the array -C B(*,*) for J = 1,...,NB. -C -C H(*),G(*) On return these arrays respectively contain -C elements of the pre- and post-multiplying -C Householder transformations used to compute -C the minimum Euclidean length solution. -C -C IP(*) Array in which the subroutine records indices -C describing the permutation of column vectors. -C The contents of arrays H(*),G(*) and IP(*) -C are not generally required by the user. -C -C***REFERENCES C. L. Lawson and R. J. Hanson, Solving Least Squares -C Problems, Prentice-Hall, Inc., 1974, Chapter 14. -C***ROUTINES CALLED D1MACH, DH12, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790101 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 901005 Replace usage of DDIFF with usage of D1MACH. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DHFTI - INTEGER I, II, IOPT, IP(*), IP1, J, JB, JJ, K, KP1, KRANK, L, - * LDIAG, LMAX, M, MDA, MDB, N, NB, NERR - DOUBLE PRECISION A, B, D1MACH, DZERO, FACTOR, - * G, H, HMAX, RELEPS, RNORM, SM, SM1, SZERO, TAU, TMP - DIMENSION A(MDA,*),B(MDB,*),H(*),G(*),RNORM(*) - SAVE RELEPS - DATA RELEPS /0.D0/ -C BEGIN BLOCK PERMITTING ...EXITS TO 360 -C***FIRST EXECUTABLE STATEMENT DHFTI - IF (RELEPS.EQ.0.D0) RELEPS = D1MACH(4) - SZERO = 0.0D0 - DZERO = 0.0D0 - FACTOR = 0.001D0 -C - K = 0 - LDIAG = MIN(M,N) - IF (LDIAG .LE. 0) GO TO 350 -C BEGIN BLOCK PERMITTING ...EXITS TO 130 -C BEGIN BLOCK PERMITTING ...EXITS TO 120 - IF (MDA .GE. M) GO TO 10 - NERR = 1 - IOPT = 2 - CALL XERMSG ('SLATEC', 'DHFTI', - + 'MDA.LT.M, PROBABLE ERROR.', - + NERR, IOPT) -C ...............EXIT - GO TO 360 - 10 CONTINUE -C - IF (NB .LE. 1 .OR. MAX(M,N) .LE. MDB) GO TO 20 - NERR = 2 - IOPT = 2 - CALL XERMSG ('SLATEC', 'DHFTI', - + 'MDB.LT.MAX(M,N).AND.NB.GT.1. PROBABLE ERROR.', - + NERR, IOPT) -C ...............EXIT - GO TO 360 - 20 CONTINUE -C - DO 100 J = 1, LDIAG -C BEGIN BLOCK PERMITTING ...EXITS TO 70 - IF (J .EQ. 1) GO TO 40 -C -C UPDATE SQUARED COLUMN LENGTHS AND FIND LMAX -C .. - LMAX = J - DO 30 L = J, N - H(L) = H(L) - A(J-1,L)**2 - IF (H(L) .GT. H(LMAX)) LMAX = L - 30 CONTINUE -C ......EXIT - IF (FACTOR*H(LMAX) .GT. HMAX*RELEPS) GO TO 70 - 40 CONTINUE -C -C COMPUTE SQUARED COLUMN LENGTHS AND FIND LMAX -C .. - LMAX = J - DO 60 L = J, N - H(L) = 0.0D0 - DO 50 I = J, M - H(L) = H(L) + A(I,L)**2 - 50 CONTINUE - IF (H(L) .GT. H(LMAX)) LMAX = L - 60 CONTINUE - HMAX = H(LMAX) - 70 CONTINUE -C .. -C LMAX HAS BEEN DETERMINED -C -C DO COLUMN INTERCHANGES IF NEEDED. -C .. - IP(J) = LMAX - IF (IP(J) .EQ. J) GO TO 90 - DO 80 I = 1, M - TMP = A(I,J) - A(I,J) = A(I,LMAX) - A(I,LMAX) = TMP - 80 CONTINUE - H(LMAX) = H(J) - 90 CONTINUE -C -C COMPUTE THE J-TH TRANSFORMATION AND APPLY IT TO A -C AND B. -C .. - CALL DH12(1,J,J+1,M,A(1,J),1,H(J),A(1,J+1),1,MDA, - * N-J) - CALL DH12(2,J,J+1,M,A(1,J),1,H(J),B,1,MDB,NB) - 100 CONTINUE -C -C DETERMINE THE PSEUDORANK, K, USING THE TOLERANCE, -C TAU. -C .. - DO 110 J = 1, LDIAG -C ......EXIT - IF (ABS(A(J,J)) .LE. TAU) GO TO 120 - 110 CONTINUE - K = LDIAG -C ......EXIT - GO TO 130 - 120 CONTINUE - K = J - 1 - 130 CONTINUE - KP1 = K + 1 -C -C COMPUTE THE NORMS OF THE RESIDUAL VECTORS. -C - IF (NB .LT. 1) GO TO 170 - DO 160 JB = 1, NB - TMP = SZERO - IF (M .LT. KP1) GO TO 150 - DO 140 I = KP1, M - TMP = TMP + B(I,JB)**2 - 140 CONTINUE - 150 CONTINUE - RNORM(JB) = SQRT(TMP) - 160 CONTINUE - 170 CONTINUE -C SPECIAL FOR PSEUDORANK = 0 - IF (K .GT. 0) GO TO 210 - IF (NB .LT. 1) GO TO 200 - DO 190 JB = 1, NB - DO 180 I = 1, N - B(I,JB) = SZERO - 180 CONTINUE - 190 CONTINUE - 200 CONTINUE - GO TO 340 - 210 CONTINUE -C -C IF THE PSEUDORANK IS LESS THAN N COMPUTE HOUSEHOLDER -C DECOMPOSITION OF FIRST K ROWS. -C .. - IF (K .EQ. N) GO TO 230 - DO 220 II = 1, K - I = KP1 - II - CALL DH12(1,I,KP1,N,A(I,1),MDA,G(I),A,MDA,1,I-1) - 220 CONTINUE - 230 CONTINUE -C -C - IF (NB .LT. 1) GO TO 330 - DO 320 JB = 1, NB -C -C SOLVE THE K BY K TRIANGULAR SYSTEM. -C .. - DO 260 L = 1, K - SM = DZERO - I = KP1 - L - IP1 = I + 1 - IF (K .LT. IP1) GO TO 250 - DO 240 J = IP1, K - SM = SM + A(I,J)*B(J,JB) - 240 CONTINUE - 250 CONTINUE - SM1 = SM - B(I,JB) = (B(I,JB) - SM1)/A(I,I) - 260 CONTINUE -C -C COMPLETE COMPUTATION OF SOLUTION VECTOR. -C .. - IF (K .EQ. N) GO TO 290 - DO 270 J = KP1, N - B(J,JB) = SZERO - 270 CONTINUE - DO 280 I = 1, K - CALL DH12(2,I,KP1,N,A(I,1),MDA,G(I),B(1,JB),1, - * MDB,1) - 280 CONTINUE - 290 CONTINUE -C -C RE-ORDER THE SOLUTION VECTOR TO COMPENSATE FOR THE -C COLUMN INTERCHANGES. -C .. - DO 310 JJ = 1, LDIAG - J = LDIAG + 1 - JJ - IF (IP(J) .EQ. J) GO TO 300 - L = IP(J) - TMP = B(L,JB) - B(L,JB) = B(J,JB) - B(J,JB) = TMP - 300 CONTINUE - 310 CONTINUE - 320 CONTINUE - 330 CONTINUE - 340 CONTINUE - 350 CONTINUE -C .. -C THE SOLUTION VECTORS, X, ARE NOW -C IN THE FIRST N ROWS OF THE ARRAY B(,). -C - KRANK = K - 360 CONTINUE - RETURN - END diff --git a/slatec/dhkseq.f b/slatec/dhkseq.f deleted file mode 100644 index beecd09..0000000 --- a/slatec/dhkseq.f +++ /dev/null @@ -1,159 +0,0 @@ -*DECK DHKSEQ - SUBROUTINE DHKSEQ (X, M, H, IERR) -C***BEGIN PROLOGUE DHKSEQ -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBSKIN -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (HKSEQ-S, DHKSEQ-D) -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C DHKSEQ is an adaptation of subroutine DPSIFN described in the -C reference below. DHKSEQ generates the sequence -C H(K,X) = (-X)**(K+1)*(PSI(K,X) PSI(K,X+0.5))/GAMMA(K+1), for -C K=0,...,M. -C -C***SEE ALSO DBSKIN -C***REFERENCES D. E. Amos, A portable Fortran subroutine for -C derivatives of the Psi function, Algorithm 610, ACM -C Transactions on Mathematical Software 9, 4 (1983), -C pp. 494-502. -C***ROUTINES CALLED D1MACH, I1MACH -C***REVISION HISTORY (YYMMDD) -C 820601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C 920528 DESCRIPTION and REFERENCES sections revised. (WRB) -C***END PROLOGUE DHKSEQ - INTEGER I, IERR, J, K, M, MX, NX - INTEGER I1MACH - DOUBLE PRECISION B, FK, FLN, FN, FNP, H, HRX, RLN, RXSQ, R1M5, S, - * SLOPE, T, TK, TRM, TRMH, TRMR, TST, U, V, WDTOL, X, XDMY, XH, - * XINC, XM, XMIN, YINT - DOUBLE PRECISION D1MACH - DIMENSION B(22), TRM(22), TRMR(25), TRMH(25), U(25), V(25), H(*) - SAVE B -C----------------------------------------------------------------------- -C SCALED BERNOULLI NUMBERS 2.0*B(2K)*(1-2**(-2K)) -C----------------------------------------------------------------------- - DATA B(1), B(2), B(3), B(4), B(5), B(6), B(7), B(8), B(9), B(10), - * B(11), B(12), B(13), B(14), B(15), B(16), B(17), B(18), B(19), - * B(20), B(21), B(22) /1.00000000000000000D+00, - * -5.00000000000000000D-01,2.50000000000000000D-01, - * -6.25000000000000000D-02,4.68750000000000000D-02, - * -6.64062500000000000D-02,1.51367187500000000D-01, - * -5.06103515625000000D-01,2.33319091796875000D+00, - * -1.41840972900390625D+01,1.09941936492919922D+02, - * -1.05824747562408447D+03,1.23842434241771698D+04, - * -1.73160495905935764D+05,2.85103429084961116D+06, - * -5.45964619322445132D+07,1.20316174668075304D+09, - * -3.02326315271452307D+10,8.59229286072319606D+11, - * -2.74233104097776039D+13,9.76664637943633248D+14, - * -3.85931586838450360D+16/ -C -C***FIRST EXECUTABLE STATEMENT DHKSEQ - IERR=0 - WDTOL = MAX(D1MACH(4),1.0D-18) - FN = M - 1 - FNP = FN + 1.0D0 -C----------------------------------------------------------------------- -C COMPUTE XMIN -C----------------------------------------------------------------------- - R1M5 = D1MACH(5) - RLN = R1M5*I1MACH(14) - RLN = MIN(RLN,18.06D0) - FLN = MAX(RLN,3.0D0) - 3.0D0 - YINT = 3.50D0 + 0.40D0*FLN - SLOPE = 0.21D0 + FLN*(0.0006038D0*FLN+0.008677D0) - XM = YINT + SLOPE*FN - MX = INT(XM) + 1 - XMIN = MX -C----------------------------------------------------------------------- -C GENERATE H(M-1,XDMY)*XDMY**(M) BY THE ASYMPTOTIC EXPANSION -C----------------------------------------------------------------------- - XDMY = X - XINC = 0.0D0 - IF (X.GE.XMIN) GO TO 10 - NX = INT(X) - XINC = XMIN - NX - XDMY = X + XINC - 10 CONTINUE - RXSQ = 1.0D0/(XDMY*XDMY) - HRX = 0.5D0/XDMY - TST = 0.5D0*WDTOL - T = FNP*HRX -C----------------------------------------------------------------------- -C INITIALIZE COEFFICIENT ARRAY -C----------------------------------------------------------------------- - S = T*B(3) - IF (ABS(S).LT.TST) GO TO 30 - TK = 2.0D0 - DO 20 K=4,22 - T = T*((TK+FN+1.0D0)/(TK+1.0D0))*((TK+FN)/(TK+2.0D0))*RXSQ - TRM(K) = T*B(K) - IF (ABS(TRM(K)).LT.TST) GO TO 30 - S = S + TRM(K) - TK = TK + 2.0D0 - 20 CONTINUE - GO TO 110 - 30 CONTINUE - H(M) = S + 0.5D0 - IF (M.EQ.1) GO TO 70 -C----------------------------------------------------------------------- -C GENERATE LOWER DERIVATIVES, I.LT.M-1 -C----------------------------------------------------------------------- - DO 60 I=2,M - FNP = FN - FN = FN - 1.0D0 - S = FNP*HRX*B(3) - IF (ABS(S).LT.TST) GO TO 50 - FK = FNP + 3.0D0 - DO 40 K=4,22 - TRM(K) = TRM(K)*FNP/FK - IF (ABS(TRM(K)).LT.TST) GO TO 50 - S = S + TRM(K) - FK = FK + 2.0D0 - 40 CONTINUE - GO TO 110 - 50 CONTINUE - MX = M - I + 1 - H(MX) = S + 0.5D0 - 60 CONTINUE - 70 CONTINUE - IF (XINC.EQ.0.0D0) RETURN -C----------------------------------------------------------------------- -C RECUR BACKWARD FROM XDMY TO X -C----------------------------------------------------------------------- - XH = X + 0.5D0 - S = 0.0D0 - NX = INT(XINC) - DO 80 I=1,NX - TRMR(I) = X/(X+NX-I) - U(I) = TRMR(I) - TRMH(I) = X/(XH+NX-I) - V(I) = TRMH(I) - S = S + U(I) - V(I) - 80 CONTINUE - MX = NX + 1 - TRMR(MX) = X/XDMY - U(MX) = TRMR(MX) - H(1) = H(1)*TRMR(MX) + S - IF (M.EQ.1) RETURN - DO 100 J=2,M - S = 0.0D0 - DO 90 I=1,NX - TRMR(I) = TRMR(I)*U(I) - TRMH(I) = TRMH(I)*V(I) - S = S + TRMR(I) - TRMH(I) - 90 CONTINUE - TRMR(MX) = TRMR(MX)*U(MX) - H(J) = H(J)*TRMR(MX) + S - 100 CONTINUE - RETURN - 110 CONTINUE - IERR=2 - RETURN - END diff --git a/slatec/dhstrt.f b/slatec/dhstrt.f deleted file mode 100644 index 965d7ec..0000000 --- a/slatec/dhstrt.f +++ /dev/null @@ -1,350 +0,0 @@ -*DECK DHSTRT - SUBROUTINE DHSTRT (DF, NEQ, A, B, Y, YPRIME, ETOL, MORDER, SMALL, - + BIG, SPY, PV, YP, SF, RPAR, IPAR, H) -C***BEGIN PROLOGUE DHSTRT -C***SUBSIDIARY -C***PURPOSE Subsidiary to DDEABM, DDEBDF and DDERKF -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (HSTART-S, DHSTRT-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C DHSTRT computes a starting step size to be used in solving initial -C value problems in ordinary differential equations. -C -C ********************************************************************** -C ABSTRACT -C -C Subroutine DHSTRT computes a starting step size to be used by an -C initial value method in solving ordinary differential equations. -C It is based on an estimate of the local Lipschitz constant for the -C differential equation (lower bound on a norm of the Jacobian) , -C a bound on the differential equation (first derivative) , and -C a bound on the partial derivative of the equation with respect to -C the independent variable. -C (all approximated near the initial point A) -C -C Subroutine DHSTRT uses a function subprogram DHVNRM for computing -C a vector norm. The maximum norm is presently utilized though it -C can easily be replaced by any other vector norm. It is presumed -C that any replacement norm routine would be carefully coded to -C prevent unnecessary underflows or overflows from occurring, and -C also, would not alter the vector or number of components. -C -C ********************************************************************** -C On input you must provide the following -C -C DF -- This is a subroutine of the form -C DF(X,U,UPRIME,RPAR,IPAR) -C which defines the system of first order differential -C equations to be solved. For the given values of X and the -C vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must -C evaluate the NEQ components of the system of differential -C equations DU/DX=DF(X,U) and store the derivatives in the -C array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for -C equations I=1,...,NEQ. -C -C Subroutine DF must not alter X or U(*). You must declare -C the name DF in an external statement in your program that -C calls DHSTRT. You must dimension U and UPRIME in DF. -C -C RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter -C arrays which you can use for communication between your -C program and subroutine DF. They are not used or altered by -C DHSTRT. If you do not need RPAR or IPAR, ignore these -C parameters by treating them as dummy arguments. If you do -C choose to use them, dimension them in your program and in -C DF as arrays of appropriate length. -C -C NEQ -- This is the number of (first order) differential equations -C to be integrated. -C -C A -- This is the initial point of integration. -C -C B -- This is a value of the independent variable used to define -C the direction of integration. A reasonable choice is to -C set B to the first point at which a solution is desired. -C You can also use B, if necessary, to restrict the length -C of the first integration step because the algorithm will -C not compute a starting step length which is bigger than -C ABS(B-A), unless B has been chosen too close to A. -C (it is presumed that DHSTRT has been called with B -C different from A on the machine being used. Also see the -C discussion about the parameter SMALL.) -C -C Y(*) -- This is the vector of initial values of the NEQ solution -C components at the initial point A. -C -C YPRIME(*) -- This is the vector of derivatives of the NEQ -C solution components at the initial point A. -C (defined by the differential equations in subroutine DF) -C -C ETOL -- This is the vector of error tolerances corresponding to -C the NEQ solution components. It is assumed that all -C elements are positive. Following the first integration -C step, the tolerances are expected to be used by the -C integrator in an error test which roughly requires that -C ABS(LOCAL ERROR) .LE. ETOL -C for each vector component. -C -C MORDER -- This is the order of the formula which will be used by -C the initial value method for taking the first integration -C step. -C -C SMALL -- This is a small positive machine dependent constant -C which is used for protecting against computations with -C numbers which are too small relative to the precision of -C floating point arithmetic. SMALL should be set to -C (approximately) the smallest positive DOUBLE PRECISION -C number such that (1.+SMALL) .GT. 1. on the machine being -C used. The quantity SMALL**(3/8) is used in computing -C increments of variables for approximating derivatives by -C differences. Also the algorithm will not compute a -C starting step length which is smaller than -C 100*SMALL*ABS(A). -C -C BIG -- This is a large positive machine dependent constant which -C is used for preventing machine overflows. A reasonable -C choice is to set big to (approximately) the square root of -C the largest DOUBLE PRECISION number which can be held in -C the machine. -C -C SPY(*),PV(*),YP(*),SF(*) -- These are DOUBLE PRECISION work -C arrays of length NEQ which provide the routine with needed -C storage space. -C -C RPAR,IPAR -- These are parameter arrays, of DOUBLE PRECISION and -C INTEGER type, respectively, which can be used for -C communication between your program and the DF subroutine. -C They are not used or altered by DHSTRT. -C -C ********************************************************************** -C On Output (after the return from DHSTRT), -C -C H -- is an appropriate starting step size to be attempted by the -C differential equation method. -C -C All parameters in the call list remain unchanged except for -C the working arrays SPY(*),PV(*),YP(*), and SF(*). -C -C ********************************************************************** -C -C***SEE ALSO DDEABM, DDEBDF, DDERKF -C***ROUTINES CALLED DHVNRM -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 891024 Changed references from DVNORM to DHVNRM. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DHSTRT -C - INTEGER IPAR, J, K, LK, MORDER, NEQ - DOUBLE PRECISION A, ABSDX, B, BIG, DA, DELF, DELY, - 1 DFDUB, DFDXB, DHVNRM, - 2 DX, DY, ETOL, FBND, H, PV, RELPER, RPAR, SF, SMALL, SPY, - 3 SRYDPB, TOLEXP, TOLMIN, TOLP, TOLSUM, Y, YDPB, YP, YPRIME - DIMENSION Y(*),YPRIME(*),ETOL(*),SPY(*),PV(*),YP(*), - 1 SF(*),RPAR(*),IPAR(*) - EXTERNAL DF -C -C .................................................................. -C -C BEGIN BLOCK PERMITTING ...EXITS TO 160 -C***FIRST EXECUTABLE STATEMENT DHSTRT - DX = B - A - ABSDX = ABS(DX) - RELPER = SMALL**0.375D0 -C -C ............................................................... -C -C COMPUTE AN APPROXIMATE BOUND (DFDXB) ON THE PARTIAL -C DERIVATIVE OF THE EQUATION WITH RESPECT TO THE -C INDEPENDENT VARIABLE. PROTECT AGAINST AN OVERFLOW. -C ALSO COMPUTE A BOUND (FBND) ON THE FIRST DERIVATIVE -C LOCALLY. -C - DA = SIGN(MAX(MIN(RELPER*ABS(A),ABSDX), - 1 100.0D0*SMALL*ABS(A)),DX) - IF (DA .EQ. 0.0D0) DA = RELPER*DX - CALL DF(A+DA,Y,SF,RPAR,IPAR) - DO 10 J = 1, NEQ - YP(J) = SF(J) - YPRIME(J) - 10 CONTINUE - DELF = DHVNRM(YP,NEQ) - DFDXB = BIG - IF (DELF .LT. BIG*ABS(DA)) DFDXB = DELF/ABS(DA) - FBND = DHVNRM(SF,NEQ) -C -C ............................................................... -C -C COMPUTE AN ESTIMATE (DFDUB) OF THE LOCAL LIPSCHITZ -C CONSTANT FOR THE SYSTEM OF DIFFERENTIAL EQUATIONS. THIS -C ALSO REPRESENTS AN ESTIMATE OF THE NORM OF THE JACOBIAN -C LOCALLY. THREE ITERATIONS (TWO WHEN NEQ=1) ARE USED TO -C ESTIMATE THE LIPSCHITZ CONSTANT BY NUMERICAL DIFFERENCES. -C THE FIRST PERTURBATION VECTOR IS BASED ON THE INITIAL -C DERIVATIVES AND DIRECTION OF INTEGRATION. THE SECOND -C PERTURBATION VECTOR IS FORMED USING ANOTHER EVALUATION OF -C THE DIFFERENTIAL EQUATION. THE THIRD PERTURBATION VECTOR -C IS FORMED USING PERTURBATIONS BASED ONLY ON THE INITIAL -C VALUES. COMPONENTS THAT ARE ZERO ARE ALWAYS CHANGED TO -C NON-ZERO VALUES (EXCEPT ON THE FIRST ITERATION). WHEN -C INFORMATION IS AVAILABLE, CARE IS TAKEN TO ENSURE THAT -C COMPONENTS OF THE PERTURBATION VECTOR HAVE SIGNS WHICH ARE -C CONSISTENT WITH THE SLOPES OF LOCAL SOLUTION CURVES. -C ALSO CHOOSE THE LARGEST BOUND (FBND) FOR THE FIRST -C DERIVATIVE. -C -C PERTURBATION VECTOR SIZE IS HELD -C CONSTANT FOR ALL ITERATIONS. COMPUTE -C THIS CHANGE FROM THE -C SIZE OF THE VECTOR OF INITIAL -C VALUES. - DELY = RELPER*DHVNRM(Y,NEQ) - IF (DELY .EQ. 0.0D0) DELY = RELPER - DELY = SIGN(DELY,DX) - DELF = DHVNRM(YPRIME,NEQ) - FBND = MAX(FBND,DELF) - IF (DELF .EQ. 0.0D0) GO TO 30 -C USE INITIAL DERIVATIVES FOR FIRST PERTURBATION - DO 20 J = 1, NEQ - SPY(J) = YPRIME(J) - YP(J) = YPRIME(J) - 20 CONTINUE - GO TO 50 - 30 CONTINUE -C CANNOT HAVE A NULL PERTURBATION VECTOR - DO 40 J = 1, NEQ - SPY(J) = 0.0D0 - YP(J) = 1.0D0 - 40 CONTINUE - DELF = DHVNRM(YP,NEQ) - 50 CONTINUE -C - DFDUB = 0.0D0 - LK = MIN(NEQ+1,3) - DO 140 K = 1, LK -C DEFINE PERTURBED VECTOR OF INITIAL VALUES - DO 60 J = 1, NEQ - PV(J) = Y(J) + DELY*(YP(J)/DELF) - 60 CONTINUE - IF (K .EQ. 2) GO TO 80 -C EVALUATE DERIVATIVES ASSOCIATED WITH PERTURBED -C VECTOR AND COMPUTE CORRESPONDING DIFFERENCES - CALL DF(A,PV,YP,RPAR,IPAR) - DO 70 J = 1, NEQ - PV(J) = YP(J) - YPRIME(J) - 70 CONTINUE - GO TO 100 - 80 CONTINUE -C USE A SHIFTED VALUE OF THE INDEPENDENT VARIABLE -C IN COMPUTING ONE ESTIMATE - CALL DF(A+DA,PV,YP,RPAR,IPAR) - DO 90 J = 1, NEQ - PV(J) = YP(J) - SF(J) - 90 CONTINUE - 100 CONTINUE -C CHOOSE LARGEST BOUNDS ON THE FIRST DERIVATIVE -C AND A LOCAL LIPSCHITZ CONSTANT - FBND = MAX(FBND,DHVNRM(YP,NEQ)) - DELF = DHVNRM(PV,NEQ) -C ...EXIT - IF (DELF .GE. BIG*ABS(DELY)) GO TO 150 - DFDUB = MAX(DFDUB,DELF/ABS(DELY)) -C ......EXIT - IF (K .EQ. LK) GO TO 160 -C CHOOSE NEXT PERTURBATION VECTOR - IF (DELF .EQ. 0.0D0) DELF = 1.0D0 - DO 130 J = 1, NEQ - IF (K .EQ. 2) GO TO 110 - DY = ABS(PV(J)) - IF (DY .EQ. 0.0D0) DY = DELF - GO TO 120 - 110 CONTINUE - DY = Y(J) - IF (DY .EQ. 0.0D0) DY = DELY/RELPER - 120 CONTINUE - IF (SPY(J) .EQ. 0.0D0) SPY(J) = YP(J) - IF (SPY(J) .NE. 0.0D0) DY = SIGN(DY,SPY(J)) - YP(J) = DY - 130 CONTINUE - DELF = DHVNRM(YP,NEQ) - 140 CONTINUE - 150 CONTINUE -C -C PROTECT AGAINST AN OVERFLOW - DFDUB = BIG - 160 CONTINUE -C -C .................................................................. -C -C COMPUTE A BOUND (YDPB) ON THE NORM OF THE SECOND DERIVATIVE -C - YDPB = DFDXB + DFDUB*FBND -C -C .................................................................. -C -C DEFINE THE TOLERANCE PARAMETER UPON WHICH THE STARTING STEP -C SIZE IS TO BE BASED. A VALUE IN THE MIDDLE OF THE ERROR -C TOLERANCE RANGE IS SELECTED. -C - TOLMIN = BIG - TOLSUM = 0.0D0 - DO 170 K = 1, NEQ - TOLEXP = LOG10(ETOL(K)) - TOLMIN = MIN(TOLMIN,TOLEXP) - TOLSUM = TOLSUM + TOLEXP - 170 CONTINUE - TOLP = 10.0D0**(0.5D0*(TOLSUM/NEQ + TOLMIN)/(MORDER+1)) -C -C .................................................................. -C -C COMPUTE A STARTING STEP SIZE BASED ON THE ABOVE FIRST AND -C SECOND DERIVATIVE INFORMATION -C -C RESTRICT THE STEP LENGTH TO BE NOT BIGGER -C THAN ABS(B-A). (UNLESS B IS TOO CLOSE -C TO A) - H = ABSDX -C - IF (YDPB .NE. 0.0D0 .OR. FBND .NE. 0.0D0) GO TO 180 -C -C BOTH FIRST DERIVATIVE TERM (FBND) AND SECOND -C DERIVATIVE TERM (YDPB) ARE ZERO - IF (TOLP .LT. 1.0D0) H = ABSDX*TOLP - GO TO 200 - 180 CONTINUE -C - IF (YDPB .NE. 0.0D0) GO TO 190 -C -C ONLY SECOND DERIVATIVE TERM (YDPB) IS ZERO - IF (TOLP .LT. FBND*ABSDX) H = TOLP/FBND - GO TO 200 - 190 CONTINUE -C -C SECOND DERIVATIVE TERM (YDPB) IS NON-ZERO - SRYDPB = SQRT(0.5D0*YDPB) - IF (TOLP .LT. SRYDPB*ABSDX) H = TOLP/SRYDPB - 200 CONTINUE -C -C FURTHER RESTRICT THE STEP LENGTH TO BE NOT -C BIGGER THAN 1/DFDUB - IF (H*DFDUB .GT. 1.0D0) H = 1.0D0/DFDUB -C -C FINALLY, RESTRICT THE STEP LENGTH TO BE NOT -C SMALLER THAN 100*SMALL*ABS(A). HOWEVER, IF -C A=0. AND THE COMPUTED H UNDERFLOWED TO ZERO, -C THE ALGORITHM RETURNS SMALL*ABS(B) FOR THE -C STEP LENGTH. - H = MAX(H,100.0D0*SMALL*ABS(A)) - IF (H .EQ. 0.0D0) H = SMALL*ABS(B) -C -C NOW SET DIRECTION OF INTEGRATION - H = SIGN(H,DX) -C - RETURN - END diff --git a/slatec/dhvnrm.f b/slatec/dhvnrm.f deleted file mode 100644 index 1128d9d..0000000 --- a/slatec/dhvnrm.f +++ /dev/null @@ -1,36 +0,0 @@ -*DECK DHVNRM - DOUBLE PRECISION FUNCTION DHVNRM (V, NCOMP) -C***BEGIN PROLOGUE DHVNRM -C***SUBSIDIARY -C***PURPOSE Subsidiary to DDEABM, DDEBDF and DDERKF -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (HVNRM-S, DHVNRM-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C Compute the maximum norm of the vector V(*) of length NCOMP and -C return the result as DHVNRM -C -C***SEE ALSO DDEABM, DDEBDF, DDERKF -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891024 Changed references from DVNORM to DHVNRM. (WRB) -C 891024 Changed routine name from DVNORM to DHVNRM. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DHVNRM -C - INTEGER K, NCOMP - DOUBLE PRECISION V - DIMENSION V(*) -C***FIRST EXECUTABLE STATEMENT DHVNRM - DHVNRM = 0.0D0 - DO 10 K = 1, NCOMP - DHVNRM = MAX(DHVNRM,ABS(V(K))) - 10 CONTINUE - RETURN - END diff --git a/slatec/dintp.f b/slatec/dintp.f deleted file mode 100644 index 594f8ea..0000000 --- a/slatec/dintp.f +++ /dev/null @@ -1,141 +0,0 @@ -*DECK DINTP - SUBROUTINE DINTP (X, Y, XOUT, YOUT, YPOUT, NEQN, KOLD, PHI, IVC, - + IV, KGI, GI, ALPHA, OG, OW, OX, OY) -C***BEGIN PROLOGUE DINTP -C***PURPOSE Approximate the solution at XOUT by evaluating the -C polynomial computed in DSTEPS at XOUT. Must be used in -C conjunction with DSTEPS. -C***LIBRARY SLATEC (DEPAC) -C***CATEGORY I1A1B -C***TYPE DOUBLE PRECISION (SINTRP-S, DINTP-D) -C***KEYWORDS ADAMS METHOD, DEPAC, INITIAL VALUE PROBLEMS, ODE, -C ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR, -C SMOOTH INTERPOLANT -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C The methods in subroutine DSTEPS approximate the solution near X -C by a polynomial. Subroutine DINTP approximates the solution at -C XOUT by evaluating the polynomial there. Information defining this -C polynomial is passed from DSTEPS so DINTP cannot be used alone. -C -C Subroutine DSTEPS is completely explained and documented in the text -C "Computer Solution of Ordinary Differential Equations, the Initial -C Value Problem" by L. F. Shampine and M. K. Gordon. -C -C Input to DINTP -- -C -C The user provides storage in the calling program for the arrays in -C the call list -C DIMENSION Y(NEQN),YOUT(NEQN),YPOUT(NEQN),PHI(NEQN,16),OY(NEQN) -C AND ALPHA(12),OG(13),OW(12),GI(11),IV(10) -C and defines -C XOUT -- point at which solution is desired. -C The remaining parameters are defined in DSTEPS and passed to -C DINTP from that subroutine -C -C Output from DINTP -- -C -C YOUT(*) -- solution at XOUT -C YPOUT(*) -- derivative of solution at XOUT -C The remaining parameters are returned unaltered from their input -C values. Integration with DSTEPS may be continued. -C -C***REFERENCES H. A. Watts, A smoother interpolant for DE/STEP, INTRP -C II, Report SAND84-0293, Sandia Laboratories, 1984. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 840201 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DINTP -C - INTEGER I, IQ, IV, IVC, IW, J, JQ, KGI, KOLD, KP1, KP2, - 1 L, M, NEQN - DOUBLE PRECISION ALP, ALPHA, C, G, GDI, GDIF, GI, GAMMA, H, HI, - 1 HMU, OG, OW, OX, OY, PHI, RMU, SIGMA, TEMP1, TEMP2, TEMP3, - 2 W, X, XI, XIM1, XIQ, XOUT, Y, YOUT, YPOUT -C - DIMENSION Y(*),YOUT(*),YPOUT(*),PHI(NEQN,16),OY(*) - DIMENSION G(13),C(13),W(13),OG(13),OW(12),ALPHA(12),GI(11),IV(10) -C -C***FIRST EXECUTABLE STATEMENT DINTP - KP1 = KOLD + 1 - KP2 = KOLD + 2 -C - HI = XOUT - OX - H = X - OX - XI = HI/H - XIM1 = XI - 1.D0 -C -C INITIALIZE W(*) FOR COMPUTING G(*) -C - XIQ = XI - DO 10 IQ = 1,KP1 - XIQ = XI*XIQ - TEMP1 = IQ*(IQ+1) - 10 W(IQ) = XIQ/TEMP1 -C -C COMPUTE THE DOUBLE INTEGRAL TERM GDI -C - IF (KOLD .LE. KGI) GO TO 50 - IF (IVC .GT. 0) GO TO 20 - GDI = 1.0D0/TEMP1 - M = 2 - GO TO 30 - 20 IW = IV(IVC) - GDI = OW(IW) - M = KOLD - IW + 3 - 30 IF (M .GT. KOLD) GO TO 60 - DO 40 I = M,KOLD - 40 GDI = OW(KP2-I) - ALPHA(I)*GDI - GO TO 60 - 50 GDI = GI(KOLD) -C -C COMPUTE G(*) AND C(*) -C - 60 G(1) = XI - G(2) = 0.5D0*XI*XI - C(1) = 1.0D0 - C(2) = XI - IF (KOLD .LT. 2) GO TO 90 - DO 80 I = 2,KOLD - ALP = ALPHA(I) - GAMMA = 1.0D0 + XIM1*ALP - L = KP2 - I - DO 70 JQ = 1,L - 70 W(JQ) = GAMMA*W(JQ) - ALP*W(JQ+1) - G(I+1) = W(1) - 80 C(I+1) = GAMMA*C(I) -C -C DEFINE INTERPOLATION PARAMETERS -C - 90 SIGMA = (W(2) - XIM1*W(1))/GDI - RMU = XIM1*C(KP1)/GDI - HMU = RMU/H -C -C INTERPOLATE FOR THE SOLUTION -- YOUT -C AND FOR THE DERIVATIVE OF THE SOLUTION -- YPOUT -C - DO 100 L = 1,NEQN - YOUT(L) = 0.0D0 - 100 YPOUT(L) = 0.0D0 - DO 120 J = 1,KOLD - I = KP2 - J - GDIF = OG(I) - OG(I-1) - TEMP2 = (G(I) - G(I-1)) - SIGMA*GDIF - TEMP3 = (C(I) - C(I-1)) + RMU*GDIF - DO 110 L = 1,NEQN - YOUT(L) = YOUT(L) + TEMP2*PHI(L,I) - 110 YPOUT(L) = YPOUT(L) + TEMP3*PHI(L,I) - 120 CONTINUE - DO 130 L = 1,NEQN - YOUT(L) = ((1.0D0 - SIGMA)*OY(L) + SIGMA*Y(L)) + - 1 H*(YOUT(L) + (G(1) - SIGMA*OG(1))*PHI(L,1)) - 130 YPOUT(L) = HMU*(OY(L) - Y(L)) + - 1 (YPOUT(L) + (C(1) + RMU*OG(1))*PHI(L,1)) -C - RETURN - END diff --git a/slatec/dintrv.f b/slatec/dintrv.f deleted file mode 100644 index 960b591..0000000 --- a/slatec/dintrv.f +++ /dev/null @@ -1,118 +0,0 @@ -*DECK DINTRV - SUBROUTINE DINTRV (XT, LXT, X, ILO, ILEFT, MFLAG) -C***BEGIN PROLOGUE DINTRV -C***PURPOSE Compute the largest integer ILEFT in 1 .LE. ILEFT .LE. LXT -C such that XT(ILEFT) .LE. X where XT(*) is a subdivision of -C the X interval. -C***LIBRARY SLATEC -C***CATEGORY E3, K6 -C***TYPE DOUBLE PRECISION (INTRV-S, DINTRV-D) -C***KEYWORDS B-SPLINE, DATA FITTING, INTERPOLATION, SPLINES -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Written by Carl de Boor and modified by D. E. Amos -C -C Abstract **** a double precision routine **** -C DINTRV is the INTERV routine of the reference. -C -C DINTRV computes the largest integer ILEFT in 1 .LE. ILEFT .LE. -C LXT such that XT(ILEFT) .LE. X where XT(*) is a subdivision of -C the X interval. Precisely, -C -C X .LT. XT(1) 1 -1 -C if XT(I) .LE. X .LT. XT(I+1) then ILEFT=I , MFLAG=0 -C XT(LXT) .LE. X LXT 1, -C -C That is, when multiplicities are present in the break point -C to the left of X, the largest index is taken for ILEFT. -C -C Description of Arguments -C -C Input XT,X are double precision -C XT - XT is a knot or break point vector of length LXT -C LXT - length of the XT vector -C X - argument -C ILO - an initialization parameter which must be set -C to 1 the first time the spline array XT is -C processed by DINTRV. -C -C Output -C ILO - ILO contains information for efficient process- -C ing after the initial call and ILO must not be -C changed by the user. Distinct splines require -C distinct ILO parameters. -C ILEFT - largest integer satisfying XT(ILEFT) .LE. X -C MFLAG - signals when X lies out of bounds -C -C Error Conditions -C None -C -C***REFERENCES Carl de Boor, Package for calculating with B-splines, -C SIAM Journal on Numerical Analysis 14, 3 (June 1977), -C pp. 441-472. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 800901 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DINTRV -C - INTEGER IHI, ILEFT, ILO, ISTEP, LXT, MFLAG, MIDDLE - DOUBLE PRECISION X, XT - DIMENSION XT(*) -C***FIRST EXECUTABLE STATEMENT DINTRV - IHI = ILO + 1 - IF (IHI.LT.LXT) GO TO 10 - IF (X.GE.XT(LXT)) GO TO 110 - IF (LXT.LE.1) GO TO 90 - ILO = LXT - 1 - IHI = LXT -C - 10 IF (X.GE.XT(IHI)) GO TO 40 - IF (X.GE.XT(ILO)) GO TO 100 -C -C *** NOW X .LT. XT(IHI) . FIND LOWER BOUND - ISTEP = 1 - 20 IHI = ILO - ILO = IHI - ISTEP - IF (ILO.LE.1) GO TO 30 - IF (X.GE.XT(ILO)) GO TO 70 - ISTEP = ISTEP*2 - GO TO 20 - 30 ILO = 1 - IF (X.LT.XT(1)) GO TO 90 - GO TO 70 -C *** NOW X .GE. XT(ILO) . FIND UPPER BOUND - 40 ISTEP = 1 - 50 ILO = IHI - IHI = ILO + ISTEP - IF (IHI.GE.LXT) GO TO 60 - IF (X.LT.XT(IHI)) GO TO 70 - ISTEP = ISTEP*2 - GO TO 50 - 60 IF (X.GE.XT(LXT)) GO TO 110 - IHI = LXT -C -C *** NOW XT(ILO) .LE. X .LT. XT(IHI) . NARROW THE INTERVAL - 70 MIDDLE = (ILO+IHI)/2 - IF (MIDDLE.EQ.ILO) GO TO 100 -C NOTE. IT IS ASSUMED THAT MIDDLE = ILO IN CASE IHI = ILO+1 - IF (X.LT.XT(MIDDLE)) GO TO 80 - ILO = MIDDLE - GO TO 70 - 80 IHI = MIDDLE - GO TO 70 -C *** SET OUTPUT AND RETURN - 90 MFLAG = -1 - ILEFT = 1 - RETURN - 100 MFLAG = 0 - ILEFT = ILO - RETURN - 110 MFLAG = 1 - ILEFT = LXT - RETURN - END diff --git a/slatec/dintyd.f b/slatec/dintyd.f deleted file mode 100644 index 6514ef3..0000000 --- a/slatec/dintyd.f +++ /dev/null @@ -1,112 +0,0 @@ -*DECK DINTYD - SUBROUTINE DINTYD (T, K, YH, NYH, DKY, IFLAG) -C***BEGIN PROLOGUE DINTYD -C***SUBSIDIARY -C***PURPOSE Subsidiary to DDEBDF -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (INTYD-S, DINTYD-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C DINTYD approximates the solution and derivatives at T by polynomial -C interpolation. Must be used in conjunction with the integrator -C package DDEBDF. -C ---------------------------------------------------------------------- -C DINTYD computes interpolated values of the K-th derivative of the -C dependent variable vector Y, and stores it in DKY. -C This routine is called by DDEBDF with K = 0,1 and T = TOUT, but may -C also be called by the user for any K up to the current order. -C (see detailed instructions in LSODE usage documentation.) -C ---------------------------------------------------------------------- -C The computed values in DKY are gotten by interpolation using the -C Nordsieck history array YH. This array corresponds uniquely to a -C vector-valued polynomial of degree NQCUR or less, and DKY is set -C to the K-th derivative of this polynomial at T. -C The formula for DKY is.. -C Q -C DKY(I) = Sum C(J,K) * (T - TN)**(J-K) * H**(-J) * YH(I,J+1) -C J=K -C where C(J,K) = J*(J-1)*...*(J-K+1), Q = NQCUR, TN = TCUR, H = HCUR. -C The quantities NQ = NQCUR, L = NQ+1, N = NEQ, TN, and H are -C communicated by common. The above sum is done in reverse order. -C IFLAG is returned negative if either K or T is out of bounds. -C ---------------------------------------------------------------------- -C -C***SEE ALSO DDEBDF -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS DDEBD1 -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890911 Removed unnecessary intrinsics. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DINTYD -C - INTEGER I, IC, IER, IFLAG, IOWND, IOWNS, J, JB, JB2, JJ, JJ1, - 1 JP1, JSTART, K, KFLAG, L, MAXORD, METH, MITER, N, NFE, - 2 NJE, NQ, NQU, NST, NYH - DOUBLE PRECISION C, DKY, EL0, H, HMIN, HMXI, HU, R, ROWND, - 1 ROWNS, S, T, TN, TP, UROUND, YH - DIMENSION YH(NYH,*),DKY(*) - COMMON /DDEBD1/ ROWND,ROWNS(210),EL0,H,HMIN,HMXI,HU,TN,UROUND, - 1 IOWND(14),IOWNS(6),IER,JSTART,KFLAG,L,METH,MITER, - 2 MAXORD,N,NQ,NST,NFE,NJE,NQU -C -C BEGIN BLOCK PERMITTING ...EXITS TO 130 -C***FIRST EXECUTABLE STATEMENT DINTYD - IFLAG = 0 - IF (K .LT. 0 .OR. K .GT. NQ) GO TO 110 - TP = TN - HU*(1.0D0 + 100.0D0*UROUND) - IF ((T - TP)*(T - TN) .LE. 0.0D0) GO TO 10 - IFLAG = -2 -C .........EXIT - GO TO 130 - 10 CONTINUE -C - S = (T - TN)/H - IC = 1 - IF (K .EQ. 0) GO TO 30 - JJ1 = L - K - DO 20 JJ = JJ1, NQ - IC = IC*JJ - 20 CONTINUE - 30 CONTINUE - C = IC - DO 40 I = 1, N - DKY(I) = C*YH(I,L) - 40 CONTINUE - IF (K .EQ. NQ) GO TO 90 - JB2 = NQ - K - DO 80 JB = 1, JB2 - J = NQ - JB - JP1 = J + 1 - IC = 1 - IF (K .EQ. 0) GO TO 60 - JJ1 = JP1 - K - DO 50 JJ = JJ1, J - IC = IC*JJ - 50 CONTINUE - 60 CONTINUE - C = IC - DO 70 I = 1, N - DKY(I) = C*YH(I,JP1) + S*DKY(I) - 70 CONTINUE - 80 CONTINUE -C .........EXIT - IF (K .EQ. 0) GO TO 130 - 90 CONTINUE - R = H**(-K) - DO 100 I = 1, N - DKY(I) = R*DKY(I) - 100 CONTINUE - GO TO 120 - 110 CONTINUE -C - IFLAG = -1 - 120 CONTINUE - 130 CONTINUE - RETURN -C ----------------------- END OF SUBROUTINE DINTYD -C ----------------------- - END diff --git a/slatec/dir.f b/slatec/dir.f deleted file mode 100644 index db28200..0000000 --- a/slatec/dir.f +++ /dev/null @@ -1,332 +0,0 @@ -*DECK DIR - SUBROUTINE DIR (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, - + ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, - + IWORK) -C***BEGIN PROLOGUE DIR -C***PURPOSE Preconditioned Iterative Refinement Sparse Ax = b Solver. -C Routine to solve a general linear system Ax = b using -C iterative refinement with a matrix splitting. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (SIR-S, DIR-D) -C***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) -C DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N), DZ(N) -C DOUBLE PRECISION RWORK(USER DEFINED) -C EXTERNAL MATVEC, MSOLVE -C -C CALL DIR(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, ITOL, -C $ TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, IWORK) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right-hand side vector. -C X :INOUT Double Precision X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Double Precision A(NELT). -C These arrays contain the matrix data structure for A. -C It could take any form. See "Description", below, -C for more details. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C MATVEC :EXT External. -C Name of a routine which performs the matrix vector multiply -C Y = A*X given A and X. The name of the MATVEC routine must -C be declared external in the calling program. The calling -C sequence to MATVEC is: -C CALL MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) -C Where N is the number of unknowns, Y is the product A*X -C upon return, X is an input vector, NELT is the number of -C non-zeros in the SLAP IA, JA, A storage for the matrix A. -C ISYM is a flag which, if non-zero, denotes that A is -C symmetric and only the lower or upper triangle is stored. -C MSOLVE :EXT External. -C Name of a routine which solves a linear system MZ = R for -C Z given R with the preconditioning matrix M (M is supplied via -C RWORK and IWORK arrays). The name of the MSOLVE routine must -C be declared external in the calling program. The calling -C sequence to MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, R is the right-hand side -C vector and Z is the solution upon return. NELT, IA, JA, A and -C ISYM are defined as above. RWORK is a double precision array -C that can be used to pass necessary preconditioning information -C and/or workspace to MSOLVE. IWORK is an integer work array -C for the same purpose as RWORK. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /DSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Double Precision. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Double Precision. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*D1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C R :WORK Double Precision R(N). -C Z :WORK Double Precision Z(N). -C DZ :WORK Double Precision DZ(N). -C Double Precision arrays used for workspace. -C RWORK :WORK Double Precision RWORK(USER DEFINED). -C Double Precision array that can be used by MSOLVE. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used by MSOLVE. -C -C *Description: -C The basic algorithm for iterative refinement (also known as -C iterative improvement) is: -C -C n+1 n -1 n -C X = X + M (B - AX ). -C -C -1 -1 -C If M = A then this is the standard iterative refinement -C algorithm and the "subtraction" in the residual calculation -C should be done in double precision (which it is not in this -C routine). -C If M = DIAG(A), the diagonal of A, then iterative refinement -C is known as Jacobi's method. The SLAP routine DSJAC -C implements this iterative strategy. -C If M = L, the lower triangle of A, then iterative refinement -C is known as Gauss-Seidel. The SLAP routine DSGS implements -C this iterative strategy. -C -C This routine does not care what matrix data structure is -C used for A and M. It simply calls the MATVEC and MSOLVE -C routines, with the arguments as described above. The user -C could write any type of structure and the appropriate MATVEC -C and MSOLVE routines. It is assumed that A is stored in the -C IA, JA, A arrays in some fashion and that M (or INV(M)) is -C stored in IWORK and RWORK) in some fashion. The SLAP -C routines DSJAC and DSGS are examples of this procedure. -C -C Two examples of matrix data structures are the: 1) SLAP -C Triad format and 2) SLAP Column format. -C -C =================== S L A P Triad format =================== -C -C In this format only the non-zeros are stored. They may -C appear in *ANY* order. The user supplies three arrays of -C length NELT, where NELT is the number of non-zeros in the -C matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero -C the user puts the row and column index of that matrix -C element in the IA and JA arrays. The value of the non-zero -C matrix element is placed in the corresponding location of -C the A array. This is an extremely easy data structure to -C generate. On the other hand it is not too efficient on -C vector computers for the iterative solution of linear -C systems. Hence, SLAP changes this input data structure to -C the SLAP Column format for the iteration (but does not -C change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C In this format the non-zeros are stored counting down -C columns (except for the diagonal entry, which must appear -C first in each "column") and are stored in the double pre- -C cision array A. In other words, for each column in the -C matrix first put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)),A(JA(ICOL)) are the first elements of the ICOL- -C th column in IA and A, and IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) -C are the last elements of the ICOL-th column. Note that we -C always have JA(N+1)=NELT+1, where N is the number of columns -C in the matrix and NELT is the number of non-zeros in the -C matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Examples: -C See the SLAP routines DSJAC, DSGS -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO DSJAC, DSGS -C***REFERENCES 1. Gene Golub and Charles Van Loan, Matrix Computations, -C Johns Hopkins University Press, Baltimore, Maryland, -C 1983. -C 2. Mark K. Seager, A SLAP for the Masses, in -C G. F. Carey, Ed., Parallel Supercomputing: Methods, -C Algorithms and Applications, Wiley, 1989, pp.135-155. -C***ROUTINES CALLED D1MACH, ISDIR -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 891004 Added new reference. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MATVEC and MSOLVE from ROUTINES CALLED list. (FNF) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of references. (FNF) -C 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) -C***END PROLOGUE DIR -C .. Scalar Arguments .. - DOUBLE PRECISION ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), B(N), DZ(N), R(N), RWORK(*), X(N), Z(N) - INTEGER IA(NELT), IWORK(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MATVEC, MSOLVE -C .. Local Scalars .. - DOUBLE PRECISION BNRM, SOLNRM, TOLMIN - INTEGER I, K -C .. External Functions .. - DOUBLE PRECISION D1MACH - INTEGER ISDIR - EXTERNAL D1MACH, ISDIR -C***FIRST EXECUTABLE STATEMENT DIR -C -C Check some of the input data. -C - ITER = 0 - IERR = 0 - IF( N.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF - TOLMIN = 500*D1MACH(3) - IF( TOL.LT.TOLMIN ) THEN - TOL = TOLMIN - IERR = 4 - ENDIF -C -C Calculate initial residual and pseudo-residual, and check -C stopping criterion. - CALL MATVEC(N, X, R, NELT, IA, JA, A, ISYM) - DO 10 I = 1, N - R(I) = B(I) - R(I) - 10 CONTINUE - CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C - IF( ISDIR(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, - $ ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, - $ IWORK, BNRM, SOLNRM) .NE. 0 ) GO TO 200 - IF( IERR.NE.0 ) RETURN -C -C ***** iteration loop ***** -C - DO 100 K=1,ITMAX - ITER = K -C -C Calculate new iterate x, new residual r, and new -C pseudo-residual z. - DO 20 I = 1, N - X(I) = X(I) + Z(I) - 20 CONTINUE - CALL MATVEC(N, X, R, NELT, IA, JA, A, ISYM) - DO 30 I = 1, N - R(I) = B(I) - R(I) - 30 CONTINUE - CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C -C check stopping criterion. - IF( ISDIR(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, - $ ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, - $ IWORK, BNRM, SOLNRM) .NE. 0 ) GO TO 200 -C - 100 CONTINUE -C -C ***** end of loop ***** -C Stopping criterion not satisfied. - ITER = ITMAX + 1 - IERR = 2 -C - 200 RETURN -C------------- LAST LINE OF DIR FOLLOWS ------------------------------- - END diff --git a/slatec/djairy.f b/slatec/djairy.f deleted file mode 100644 index 0ad691d..0000000 --- a/slatec/djairy.f +++ /dev/null @@ -1,346 +0,0 @@ -*DECK DJAIRY - SUBROUTINE DJAIRY (X, RX, C, AI, DAI) -C***BEGIN PROLOGUE DJAIRY -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBESJ and DBESY -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (JAIRY-S, DJAIRY-D) -C***AUTHOR Amos, D. E., (SNLA) -C Daniel, S. L., (SNLA) -C Weston, M. K., (SNLA) -C***DESCRIPTION -C -C DJAIRY computes the Airy function AI(X) -C and its derivative DAI(X) for DASYJY -C -C INPUT -C -C X - Argument, computed by DASYJY, X unrestricted -C RX - RX=SQRT(ABS(X)), computed by DASYJY -C C - C=2.*(ABS(X)**1.5)/3., computed by DASYJY -C -C OUTPUT -C -C AI - Value of function AI(X) -C DAI - Value of the derivative DAI(X) -C -C***SEE ALSO DBESJ, DBESY -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891009 Removed unreferenced variable. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910408 Updated the AUTHOR section. (WRB) -C***END PROLOGUE DJAIRY -C - INTEGER I, J, M1, M1D, M2, M2D, M3, M3D, M4, M4D, N1, N1D, N2, - 1 N2D, N3, N3D, N4, N4D - DOUBLE PRECISION A,AI,AJN,AJP,AK1,AK2,AK3,B,C,CCV,CON2, - 1 CON3, CON4, CON5, CV, DA, DAI, DAJN, DAJP, DAK1, DAK2, DAK3, - 2 DB, EC, E1, E2, FPI12, F1, F2, RTRX, RX, SCV, T, TEMP1, TEMP2, - 3 TT, X - DIMENSION AJP(19), AJN(19), A(15), B(15) - DIMENSION AK1(14), AK2(23), AK3(14) - DIMENSION DAJP(19), DAJN(19), DA(15), DB(15) - DIMENSION DAK1(14), DAK2(24), DAK3(14) - SAVE N1, N2, N3, N4, M1, M2, M3, M4, FPI12, CON2, CON3, - 1 CON4, CON5, AK1, AK2, AK3, AJP, AJN, A, B, - 2 N1D, N2D, N3D, N4D, M1D, M2D, M3D, M4D, DAK1, DAK2, DAK3, - 3 DAJP, DAJN, DA, DB - DATA N1,N2,N3,N4/14,23,19,15/ - DATA M1,M2,M3,M4/12,21,17,13/ - DATA FPI12,CON2,CON3,CON4,CON5/ - 1 1.30899693899575D+00, 5.03154716196777D+00, 3.80004589867293D-01, - 2 8.33333333333333D-01, 8.66025403784439D-01/ - DATA AK1(1), AK1(2), AK1(3), AK1(4), AK1(5), AK1(6), AK1(7), - 1 AK1(8), AK1(9), AK1(10),AK1(11),AK1(12),AK1(13), - 2 AK1(14) / 2.20423090987793D-01,-1.25290242787700D-01, - 3 1.03881163359194D-02, 8.22844152006343D-04,-2.34614345891226D-04, - 4 1.63824280172116D-05, 3.06902589573189D-07,-1.29621999359332D-07, - 5 8.22908158823668D-09, 1.53963968623298D-11,-3.39165465615682D-11, - 6 2.03253257423626D-12,-1.10679546097884D-14,-5.16169497785080D-15/ - DATA AK2(1), AK2(2), AK2(3), AK2(4), AK2(5), AK2(6), AK2(7), - 1 AK2(8), AK2(9), AK2(10),AK2(11),AK2(12),AK2(13),AK2(14), - 2 AK2(15),AK2(16),AK2(17),AK2(18),AK2(19),AK2(20),AK2(21), - 3 AK2(22),AK2(23) / 2.74366150869598D-01, 5.39790969736903D-03, - 4-1.57339220621190D-03, 4.27427528248750D-04,-1.12124917399925D-04, - 5 2.88763171318904D-05,-7.36804225370554D-06, 1.87290209741024D-06, - 6-4.75892793962291D-07, 1.21130416955909D-07,-3.09245374270614D-08, - 7 7.92454705282654D-09,-2.03902447167914D-09, 5.26863056595742D-10, - 8-1.36704767639569D-10, 3.56141039013708D-11,-9.31388296548430D-12, - 9 2.44464450473635D-12,-6.43840261990955D-13, 1.70106030559349D-13, - 1-4.50760104503281D-14, 1.19774799164811D-14,-3.19077040865066D-15/ - DATA AK3(1), AK3(2), AK3(3), AK3(4), AK3(5), AK3(6), AK3(7), - 1 AK3(8), AK3(9), AK3(10),AK3(11),AK3(12),AK3(13), - 2 AK3(14) / 2.80271447340791D-01,-1.78127042844379D-03, - 3 4.03422579628999D-05,-1.63249965269003D-06, 9.21181482476768D-08, - 4-6.52294330229155D-09, 5.47138404576546D-10,-5.24408251800260D-11, - 5 5.60477904117209D-12,-6.56375244639313D-13, 8.31285761966247D-14, - 6-1.12705134691063D-14, 1.62267976598129D-15,-2.46480324312426D-16/ - DATA AJP(1), AJP(2), AJP(3), AJP(4), AJP(5), AJP(6), AJP(7), - 1 AJP(8), AJP(9), AJP(10),AJP(11),AJP(12),AJP(13),AJP(14), - 2 AJP(15),AJP(16),AJP(17),AJP(18), - 3 AJP(19) / 7.78952966437581D-02,-1.84356363456801D-01, - 4 3.01412605216174D-02, 3.05342724277608D-02,-4.95424702513079D-03, - 5-1.72749552563952D-03, 2.43137637839190D-04, 5.04564777517082D-05, - 6-6.16316582695208D-06,-9.03986745510768D-07, 9.70243778355884D-08, - 7 1.09639453305205D-08,-1.04716330588766D-09,-9.60359441344646D-11, - 8 8.25358789454134D-12, 6.36123439018768D-13,-4.96629614116015D-14, - 9-3.29810288929615D-15, 2.35798252031104D-16/ - DATA AJN(1), AJN(2), AJN(3), AJN(4), AJN(5), AJN(6), AJN(7), - 1 AJN(8), AJN(9), AJN(10),AJN(11),AJN(12),AJN(13),AJN(14), - 2 AJN(15),AJN(16),AJN(17),AJN(18), - 3 AJN(19) / 3.80497887617242D-02,-2.45319541845546D-01, - 4 1.65820623702696D-01, 7.49330045818789D-02,-2.63476288106641D-02, - 5-5.92535597304981D-03, 1.44744409589804D-03, 2.18311831322215D-04, - 6-4.10662077680304D-05,-4.66874994171766D-06, 7.15218807277160D-07, - 7 6.52964770854633D-08,-8.44284027565946D-09,-6.44186158976978D-10, - 8 7.20802286505285D-11, 4.72465431717846D-12,-4.66022632547045D-13, - 9-2.67762710389189D-14, 2.36161316570019D-15/ - DATA A(1), A(2), A(3), A(4), A(5), A(6), A(7), - 1 A(8), A(9), A(10), A(11), A(12), A(13), A(14), - 2 A(15) / 4.90275424742791D-01, 1.57647277946204D-03, - 3-9.66195963140306D-05, 1.35916080268815D-07, 2.98157342654859D-07, - 4-1.86824767559979D-08,-1.03685737667141D-09, 3.28660818434328D-10, - 5-2.57091410632780D-11,-2.32357655300677D-12, 9.57523279048255D-13, - 6-1.20340828049719D-13,-2.90907716770715D-15, 4.55656454580149D-15, - 7-9.99003874810259D-16/ - DATA B(1), B(2), B(3), B(4), B(5), B(6), B(7), - 1 B(8), B(9), B(10), B(11), B(12), B(13), B(14), - 2 B(15) / 2.78593552803079D-01,-3.52915691882584D-03, - 3-2.31149677384994D-05, 4.71317842263560D-06,-1.12415907931333D-07, - 4-2.00100301184339D-08, 2.60948075302193D-09,-3.55098136101216D-11, - 5-3.50849978423875D-11, 5.83007187954202D-12,-2.04644828753326D-13, - 6-1.10529179476742D-13, 2.87724778038775D-14,-2.88205111009939D-15, - 7-3.32656311696166D-16/ - DATA N1D,N2D,N3D,N4D/14,24,19,15/ - DATA M1D,M2D,M3D,M4D/12,22,17,13/ - DATA DAK1(1), DAK1(2), DAK1(3), DAK1(4), DAK1(5), DAK1(6), - 1 DAK1(7), DAK1(8), DAK1(9), DAK1(10),DAK1(11),DAK1(12), - 2 DAK1(13),DAK1(14)/ 2.04567842307887D-01,-6.61322739905664D-02, - 3-8.49845800989287D-03, 3.12183491556289D-03,-2.70016489829432D-04, - 4-6.35636298679387D-06, 3.02397712409509D-06,-2.18311195330088D-07, - 5-5.36194289332826D-10, 1.13098035622310D-09,-7.43023834629073D-11, - 6 4.28804170826891D-13, 2.23810925754539D-13,-1.39140135641182D-14/ - DATA DAK2(1), DAK2(2), DAK2(3), DAK2(4), DAK2(5), DAK2(6), - 1 DAK2(7), DAK2(8), DAK2(9), DAK2(10),DAK2(11),DAK2(12), - 2 DAK2(13),DAK2(14),DAK2(15),DAK2(16),DAK2(17),DAK2(18), - 3 DAK2(19),DAK2(20),DAK2(21),DAK2(22),DAK2(23), - 4 DAK2(24) / 2.93332343883230D-01,-8.06196784743112D-03, - 5 2.42540172333140D-03,-6.82297548850235D-04, 1.85786427751181D-04, - 6-4.97457447684059D-05, 1.32090681239497D-05,-3.49528240444943D-06, - 7 9.24362451078835D-07,-2.44732671521867D-07, 6.49307837648910D-08, - 8-1.72717621501538D-08, 4.60725763604656D-09,-1.23249055291550D-09, - 9 3.30620409488102D-10,-8.89252099772401D-11, 2.39773319878298D-11, - 1-6.48013921153450D-12, 1.75510132023731D-12,-4.76303829833637D-13, - 2 1.29498241100810D-13,-3.52679622210430D-14, 9.62005151585923D-15, - 3-2.62786914342292D-15/ - DATA DAK3(1), DAK3(2), DAK3(3), DAK3(4), DAK3(5), DAK3(6), - 1 DAK3(7), DAK3(8), DAK3(9), DAK3(10),DAK3(11),DAK3(12), - 2 DAK3(13),DAK3(14)/ 2.84675828811349D-01, 2.53073072619080D-03, - 3-4.83481130337976D-05, 1.84907283946343D-06,-1.01418491178576D-07, - 4 7.05925634457153D-09,-5.85325291400382D-10, 5.56357688831339D-11, - 5-5.90889094779500D-12, 6.88574353784436D-13,-8.68588256452194D-14, - 6 1.17374762617213D-14,-1.68523146510923D-15, 2.55374773097056D-16/ - DATA DAJP(1), DAJP(2), DAJP(3), DAJP(4), DAJP(5), DAJP(6), - 1 DAJP(7), DAJP(8), DAJP(9), DAJP(10),DAJP(11),DAJP(12), - 2 DAJP(13),DAJP(14),DAJP(15),DAJP(16),DAJP(17),DAJP(18), - 3 DAJP(19) / 6.53219131311457D-02,-1.20262933688823D-01, - 4 9.78010236263823D-03, 1.67948429230505D-02,-1.97146140182132D-03, - 5-8.45560295098867D-04, 9.42889620701976D-05, 2.25827860945475D-05, - 6-2.29067870915987D-06,-3.76343991136919D-07, 3.45663933559565D-08, - 7 4.29611332003007D-09,-3.58673691214989D-10,-3.57245881361895D-11, - 8 2.72696091066336D-12, 2.26120653095771D-13,-1.58763205238303D-14, - 9-1.12604374485125D-15, 7.31327529515367D-17/ - DATA DAJN(1), DAJN(2), DAJN(3), DAJN(4), DAJN(5), DAJN(6), - 1 DAJN(7), DAJN(8), DAJN(9), DAJN(10),DAJN(11),DAJN(12), - 2 DAJN(13),DAJN(14),DAJN(15),DAJN(16),DAJN(17),DAJN(18), - 3 DAJN(19) / 1.08594539632967D-02, 8.53313194857091D-02, - 4-3.15277068113058D-01,-8.78420725294257D-02, 5.53251906976048D-02, - 5 9.41674060503241D-03,-3.32187026018996D-03,-4.11157343156826D-04, - 6 1.01297326891346D-04, 9.87633682208396D-06,-1.87312969812393D-06, - 7-1.50798500131468D-07, 2.32687669525394D-08, 1.59599917419225D-09, - 8-2.07665922668385D-10,-1.24103350500302D-11, 1.39631765331043D-12, - 9 7.39400971155740D-14,-7.32887475627500D-15/ - DATA DA(1), DA(2), DA(3), DA(4), DA(5), DA(6), DA(7), - 1 DA(8), DA(9), DA(10), DA(11), DA(12), DA(13), DA(14), - 2 DA(15) / 4.91627321104601D-01, 3.11164930427489D-03, - 3 8.23140762854081D-05,-4.61769776172142D-06,-6.13158880534626D-08, - 4 2.87295804656520D-08,-1.81959715372117D-09,-1.44752826642035D-10, - 5 4.53724043420422D-11,-3.99655065847223D-12,-3.24089119830323D-13, - 6 1.62098952568741D-13,-2.40765247974057D-14, 1.69384811284491D-16, - 7 8.17900786477396D-16/ - DATA DB(1), DB(2), DB(3), DB(4), DB(5), DB(6), DB(7), - 1 DB(8), DB(9), DB(10), DB(11), DB(12), DB(13), DB(14), - 2 DB(15) /-2.77571356944231D-01, 4.44212833419920D-03, - 3-8.42328522190089D-05,-2.58040318418710D-06, 3.42389720217621D-07, - 4-6.24286894709776D-09,-2.36377836844577D-09, 3.16991042656673D-10, - 5-4.40995691658191D-12,-5.18674221093575D-12, 9.64874015137022D-13, - 6-4.90190576608710D-14,-1.77253430678112D-14, 5.55950610442662D-15, - 7-7.11793337579530D-16/ -C***FIRST EXECUTABLE STATEMENT DJAIRY - IF (X.LT.0.0D0) GO TO 90 - IF (C.GT.5.0D0) GO TO 60 - IF (X.GT.1.20D0) GO TO 30 - T = (X+X-1.2D0)*CON4 - TT = T + T - J = N1 - F1 = AK1(J) - F2 = 0.0D0 - DO 10 I=1,M1 - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + AK1(J) - F2 = TEMP1 - 10 CONTINUE - AI = T*F1 - F2 + AK1(1) -C - J = N1D - F1 = DAK1(J) - F2 = 0.0D0 - DO 20 I=1,M1D - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + DAK1(J) - F2 = TEMP1 - 20 CONTINUE - DAI = -(T*F1-F2+DAK1(1)) - RETURN -C - 30 CONTINUE - T = (X+X-CON2)*CON3 - TT = T + T - J = N2 - F1 = AK2(J) - F2 = 0.0D0 - DO 40 I=1,M2 - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + AK2(J) - F2 = TEMP1 - 40 CONTINUE - RTRX = SQRT(RX) - EC = EXP(-C) - AI = EC*(T*F1-F2+AK2(1))/RTRX - J = N2D - F1 = DAK2(J) - F2 = 0.0D0 - DO 50 I=1,M2D - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + DAK2(J) - F2 = TEMP1 - 50 CONTINUE - DAI = -EC*(T*F1-F2+DAK2(1))*RTRX - RETURN -C - 60 CONTINUE - T = 10.0D0/C - 1.0D0 - TT = T + T - J = N1 - F1 = AK3(J) - F2 = 0.0D0 - DO 70 I=1,M1 - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + AK3(J) - F2 = TEMP1 - 70 CONTINUE - RTRX = SQRT(RX) - EC = EXP(-C) - AI = EC*(T*F1-F2+AK3(1))/RTRX - J = N1D - F1 = DAK3(J) - F2 = 0.0D0 - DO 80 I=1,M1D - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + DAK3(J) - F2 = TEMP1 - 80 CONTINUE - DAI = -RTRX*EC*(T*F1-F2+DAK3(1)) - RETURN -C - 90 CONTINUE - IF (C.GT.5.0D0) GO TO 120 - T = 0.4D0*C - 1.0D0 - TT = T + T - J = N3 - F1 = AJP(J) - E1 = AJN(J) - F2 = 0.0D0 - E2 = 0.0D0 - DO 100 I=1,M3 - J = J - 1 - TEMP1 = F1 - TEMP2 = E1 - F1 = TT*F1 - F2 + AJP(J) - E1 = TT*E1 - E2 + AJN(J) - F2 = TEMP1 - E2 = TEMP2 - 100 CONTINUE - AI = (T*E1-E2+AJN(1)) - X*(T*F1-F2+AJP(1)) - J = N3D - F1 = DAJP(J) - E1 = DAJN(J) - F2 = 0.0D0 - E2 = 0.0D0 - DO 110 I=1,M3D - J = J - 1 - TEMP1 = F1 - TEMP2 = E1 - F1 = TT*F1 - F2 + DAJP(J) - E1 = TT*E1 - E2 + DAJN(J) - F2 = TEMP1 - E2 = TEMP2 - 110 CONTINUE - DAI = X*X*(T*F1-F2+DAJP(1)) + (T*E1-E2+DAJN(1)) - RETURN -C - 120 CONTINUE - T = 10.0D0/C - 1.0D0 - TT = T + T - J = N4 - F1 = A(J) - E1 = B(J) - F2 = 0.0D0 - E2 = 0.0D0 - DO 130 I=1,M4 - J = J - 1 - TEMP1 = F1 - TEMP2 = E1 - F1 = TT*F1 - F2 + A(J) - E1 = TT*E1 - E2 + B(J) - F2 = TEMP1 - E2 = TEMP2 - 130 CONTINUE - TEMP1 = T*F1 - F2 + A(1) - TEMP2 = T*E1 - E2 + B(1) - RTRX = SQRT(RX) - CV = C - FPI12 - CCV = COS(CV) - SCV = SIN(CV) - AI = (TEMP1*CCV-TEMP2*SCV)/RTRX - J = N4D - F1 = DA(J) - E1 = DB(J) - F2 = 0.0D0 - E2 = 0.0D0 - DO 140 I=1,M4D - J = J - 1 - TEMP1 = F1 - TEMP2 = E1 - F1 = TT*F1 - F2 + DA(J) - E1 = TT*E1 - E2 + DB(J) - F2 = TEMP1 - E2 = TEMP2 - 140 CONTINUE - TEMP1 = T*F1 - F2 + DA(1) - TEMP2 = T*E1 - E2 + DB(1) - E1 = CCV*CON5 + 0.5D0*SCV - E2 = SCV*CON5 - 0.5D0*CCV - DAI = (TEMP1*E1-TEMP2*E2)*RTRX - RETURN - END diff --git a/slatec/dlbeta.f b/slatec/dlbeta.f deleted file mode 100644 index f5b0853..0000000 --- a/slatec/dlbeta.f +++ /dev/null @@ -1,62 +0,0 @@ -*DECK DLBETA - DOUBLE PRECISION FUNCTION DLBETA (A, B) -C***BEGIN PROLOGUE DLBETA -C***PURPOSE Compute the natural logarithm of the complete Beta -C function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7B -C***TYPE DOUBLE PRECISION (ALBETA-S, DLBETA-D, CLBETA-C) -C***KEYWORDS FNLIB, LOGARITHM OF THE COMPLETE BETA FUNCTION, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DLBETA(A,B) calculates the double precision natural logarithm of -C the complete beta function for double precision arguments -C A and B. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D9LGMC, DGAMMA, DLNGAM, DLNREL, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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 900727 Added EXTERNAL statement. (WRB) -C***END PROLOGUE DLBETA - DOUBLE PRECISION A, B, P, Q, CORR, SQ2PIL, D9LGMC, DGAMMA, DLNGAM, - 1 DLNREL - EXTERNAL DGAMMA - SAVE SQ2PIL - DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 / -C***FIRST EXECUTABLE STATEMENT DLBETA - P = MIN (A, B) - Q = MAX (A, B) -C - IF (P .LE. 0.D0) CALL XERMSG ('SLATEC', 'DLBETA', - + 'BOTH ARGUMENTS MUST BE GT ZERO', 1, 2) -C - IF (P.GE.10.D0) GO TO 30 - IF (Q.GE.10.D0) GO TO 20 -C -C P AND Q ARE SMALL. -C - DLBETA = LOG (DGAMMA(P) * (DGAMMA(Q)/DGAMMA(P+Q)) ) - RETURN -C -C P IS SMALL, BUT Q IS BIG. -C - 20 CORR = D9LGMC(Q) - D9LGMC(P+Q) - DLBETA = DLNGAM(P) + CORR + P - P*LOG(P+Q) - 1 + (Q-0.5D0)*DLNREL(-P/(P+Q)) - RETURN -C -C P AND Q ARE BIG. -C - 30 CORR = D9LGMC(P) + D9LGMC(Q) - D9LGMC(P+Q) - DLBETA = -0.5D0*LOG(Q) + SQ2PIL + CORR + (P-0.5D0)*LOG(P/(P+Q)) - 1 + Q*DLNREL(-P/(P+Q)) - RETURN -C - END diff --git a/slatec/dlgams.f b/slatec/dlgams.f deleted file mode 100644 index c14828a..0000000 --- a/slatec/dlgams.f +++ /dev/null @@ -1,37 +0,0 @@ -*DECK DLGAMS - SUBROUTINE DLGAMS (X, DLGAM, SGNGAM) -C***BEGIN PROLOGUE DLGAMS -C***PURPOSE Compute the logarithm of the absolute value of the Gamma -C function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7A -C***TYPE DOUBLE PRECISION (ALGAMS-S, DLGAMS-D) -C***KEYWORDS ABSOLUTE VALUE OF THE LOGARITHM OF THE GAMMA FUNCTION, -C FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DLGAMS(X,DLGAM,SGNGAM) calculates the double precision natural -C logarithm of the absolute value of the Gamma function for -C double precision argument X and stores the result in double -C precision argument DLGAM. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED DLNGAM -C***REVISION HISTORY (YYMMDD) -C 770701 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***END PROLOGUE DLGAMS - DOUBLE PRECISION X, DLGAM, SGNGAM, DLNGAM -C***FIRST EXECUTABLE STATEMENT DLGAMS - DLGAM = DLNGAM(X) - SGNGAM = 1.0D0 - IF (X.GT.0.D0) RETURN -C - INT = MOD (-AINT(X), 2.0D0) + 0.1D0 - IF (INT.EQ.0) SGNGAM = -1.0D0 -C - RETURN - END diff --git a/slatec/dli.f b/slatec/dli.f deleted file mode 100644 index b62f7dc..0000000 --- a/slatec/dli.f +++ /dev/null @@ -1,34 +0,0 @@ -*DECK DLI - DOUBLE PRECISION FUNCTION DLI (X) -C***BEGIN PROLOGUE DLI -C***PURPOSE Compute the logarithmic integral. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C5 -C***TYPE DOUBLE PRECISION (ALI-S, DLI-D) -C***KEYWORDS FNLIB, LOGARITHMIC INTEGRAL, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DLI(X) calculates the double precision logarithmic integral -C for double precision argument X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED DEI, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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***END PROLOGUE DLI - DOUBLE PRECISION X, DEI -C***FIRST EXECUTABLE STATEMENT DLI - IF (X .LE. 0.D0) CALL XERMSG ('SLATEC', 'DLI', - + 'LOG INTEGRAL UNDEFINED FOR X LE 0', 1, 2) - IF (X .EQ. 1.D0) CALL XERMSG ('SLATEC', 'DLI', - + 'LOG INTEGRAL UNDEFINED FOR X = 0', 2, 2) -C - DLI = DEI (LOG(X)) -C - RETURN - END diff --git a/slatec/dllsia.f b/slatec/dllsia.f deleted file mode 100644 index 4a9f4f6..0000000 --- a/slatec/dllsia.f +++ /dev/null @@ -1,315 +0,0 @@ -*DECK DLLSIA - SUBROUTINE DLLSIA (A, MDA, M, N, B, MDB, NB, RE, AE, KEY, MODE, - + NP, KRANK, KSURE, RNORM, W, LW, IWORK, LIW, INFO) -C***BEGIN PROLOGUE DLLSIA -C***PURPOSE Solve linear least squares problems by performing a QR -C factorization of the input matrix using Householder -C transformations. Emphasis is put on detecting possible -C rank deficiency. -C***LIBRARY SLATEC -C***CATEGORY D9, D5 -C***TYPE DOUBLE PRECISION (LLSIA-S, DLLSIA-D) -C***KEYWORDS LINEAR LEAST SQUARES, QR FACTORIZATION -C***AUTHOR Manteuffel, T. A., (LANL) -C***DESCRIPTION -C -C DLLSIA computes the least squares solution(s) to the problem AX=B -C where A is an M by N matrix with M.GE.N and B is the M by NB -C matrix of right hand sides. User input bounds on the uncertainty -C in the elements of A are used to detect numerical rank deficiency. -C The algorithm employs a row and column pivot strategy to -C minimize the growth of uncertainty and round-off errors. -C -C DLLSIA requires (MDA+6)*N + (MDB+1)*NB + M dimensioned space -C -C ****************************************************************** -C * * -C * WARNING - All input arrays are changed on exit. * -C * * -C ****************************************************************** -C SUBROUTINE DLLSIA(A,MDA,M,N,B,MDB,NB,RE,AE,KEY,MODE,NP, -C 1 KRANK,KSURE,RNORM,W,LW,IWORK,LIW,INFO) -C -C Input..All TYPE REAL variables are DOUBLE PRECISION -C -C A(,) Linear coefficient matrix of AX=B, with MDA the -C MDA,M,N actual first dimension of A in the calling program. -C M is the row dimension (no. of EQUATIONS of the -C problem) and N the col dimension (no. of UNKNOWNS). -C Must have MDA.GE.M and M.GE.N. -C -C B(,) Right hand side(s), with MDB the actual first -C MDB,NB dimension of B in the calling program. NB is the -C number of M by 1 right hand sides. Must have -C MDB.GE.M. If NB = 0, B is never accessed. -C -C ****************************************************************** -C * * -C * Note - Use of RE and AE are what make this * -C * code significantly different from * -C * other linear least squares solvers. * -C * However, the inexperienced user is * -C * advised to set RE=0.,AE=0.,KEY=0. * -C * * -C ****************************************************************** -C RE(),AE(),KEY -C RE() RE() is a vector of length N such that RE(I) is -C the maximum relative uncertainty in column I of -C the matrix A. The values of RE() must be between -C 0 and 1. A minimum of 10*machine precision will -C be enforced. -C -C AE() AE() is a vector of length N such that AE(I) is -C the maximum absolute uncertainty in column I of -C the matrix A. The values of AE() must be greater -C than or equal to 0. -C -C KEY For ease of use, RE and AE may be input as either -C vectors or scalars. If a scalar is input, the algo- -C rithm will use that value for each column of A. -C The parameter key indicates whether scalars or -C vectors are being input. -C KEY=0 RE scalar AE scalar -C KEY=1 RE vector AE scalar -C KEY=2 RE scalar AE vector -C KEY=3 RE vector AE vector -C -C MODE The integer mode indicates how the routine -C is to react if rank deficiency is detected. -C If MODE = 0 return immediately, no solution -C 1 compute truncated solution -C 2 compute minimal length solution -C The inexperienced user is advised to set MODE=0 -C -C NP The first NP columns of A will not be interchanged -C with other columns even though the pivot strategy -C would suggest otherwise. -C The inexperienced user is advised to set NP=0. -C -C WORK() A real work array dimensioned 5*N. However, if -C RE or AE have been specified as vectors, dimension -C WORK 4*N. If both RE and AE have been specified -C as vectors, dimension WORK 3*N. -C -C LW Actual dimension of WORK -C -C IWORK() Integer work array dimensioned at least N+M. -C -C LIW Actual dimension of IWORK. -C -C INFO Is a flag which provides for the efficient -C solution of subsequent problems involving the -C same A but different B. -C If INFO = 0 original call -C INFO = 1 subsequent calls -C On subsequent calls, the user must supply A, KRANK, -C LW, IWORK, LIW, and the first 2*N locations of WORK -C as output by the original call to DLLSIA. MODE must -C be equal to the value of MODE in the original call. -C If MODE.LT.2, only the first N locations of WORK -C are accessed. AE, RE, KEY, and NP are not accessed. -C -C Output..All TYPE REAL variable are DOUBLE PRECISION -C -C A(,) Contains the upper triangular part of the reduced -C matrix and the transformation information. It togeth -C with the first N elements of WORK (see below) -C completely specify the QR factorization of A. -C -C B(,) Contains the N by NB solution matrix for X. -C -C KRANK,KSURE The numerical rank of A, based upon the relative -C and absolute bounds on uncertainty, is bounded -C above by KRANK and below by KSURE. The algorithm -C returns a solution based on KRANK. KSURE provides -C an indication of the precision of the rank. -C -C RNORM() Contains the Euclidean length of the NB residual -C vectors B(I)-AX(I), I=1,NB. -C -C WORK() The first N locations of WORK contain values -C necessary to reproduce the Householder -C transformation. -C -C IWORK() The first N locations contain the order in -C which the columns of A were used. The next -C M locations contain the order in which the -C rows of A were used. -C -C INFO Flag to indicate status of computation on completion -C -1 Parameter error(s) -C 0 - Rank deficient, no solution -C 1 - Rank deficient, truncated solution -C 2 - Rank deficient, minimal length solution -C 3 - Numerical rank 0, zero solution -C 4 - Rank .LT. NP -C 5 - Full rank -C -C***REFERENCES T. Manteuffel, An interval analysis approach to rank -C determination in linear least squares problems, -C Report SAND80-0655, Sandia Laboratories, June 1980. -C***ROUTINES CALLED D1MACH, DU11LS, DU12LS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 810801 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891006 Cosmetic changes to prologue. (WRB) -C 891009 Removed unreferenced variable. (WRB) -C 891009 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 Fixed an error message. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DLLSIA - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DOUBLE PRECISION D1MACH - DIMENSION A(MDA,*),B(MDB,*),RE(*),AE(*),RNORM(*),W(*) - INTEGER IWORK(*) -C -C***FIRST EXECUTABLE STATEMENT DLLSIA - IF(INFO.LT.0 .OR. INFO.GT.1) GO TO 514 - IT=INFO - INFO=-1 - IF(NB.EQ.0 .AND. IT.EQ.1) GO TO 501 - IF(M.LT.1) GO TO 502 - IF(N.LT.1) GO TO 503 - IF(N.GT.M) GO TO 504 - IF(MDA.LT.M) GO TO 505 - IF(LIW.LT.M+N) GO TO 506 - IF(MODE.LT.0 .OR. MODE.GT.3) GO TO 515 - IF(NB.EQ.0) GO TO 4 - IF(NB.LT.0) GO TO 507 - IF(MDB.LT.M) GO TO 508 - IF(IT.EQ.0) GO TO 4 - GO TO 400 - 4 IF(KEY.LT.0.OR.KEY.GT.3) GO TO 509 - IF(KEY.EQ.0 .AND. LW.LT.5*N) GO TO 510 - IF(KEY.EQ.1 .AND. LW.LT.4*N) GO TO 510 - IF(KEY.EQ.2 .AND. LW.LT.4*N) GO TO 510 - IF(KEY.EQ.3 .AND. LW.LT.3*N) GO TO 510 - IF(NP.LT.0 .OR. NP.GT.N) GO TO 516 -C - EPS=10.*D1MACH(3) - N1=1 - N2=N1+N - N3=N2+N - N4=N3+N - N5=N4+N -C - IF(KEY.EQ.1) GO TO 100 - IF(KEY.EQ.2) GO TO 200 - IF(KEY.EQ.3) GO TO 300 -C - IF(RE(1).LT.0.0D0) GO TO 511 - IF(RE(1).GT.1.0D0) GO TO 512 - IF(RE(1).LT.EPS) RE(1)=EPS - IF(AE(1).LT.0.0D0) GO TO 513 - DO 20 I=1,N - W(N4-1+I)=RE(1) - W(N5-1+I)=AE(1) - 20 CONTINUE - CALL DU11LS(A,MDA,M,N,W(N4),W(N5),MODE,NP,KRANK,KSURE, - 1 W(N1),W(N2),W(N3),IWORK(N1),IWORK(N2)) - GO TO 400 -C - 100 CONTINUE - IF(AE(1).LT.0.0D0) GO TO 513 - DO 120 I=1,N - IF(RE(I).LT.0.0D0) GO TO 511 - IF(RE(I).GT.1.0D0) GO TO 512 - IF(RE(I).LT.EPS) RE(I)=EPS - W(N4-1+I)=AE(1) - 120 CONTINUE - CALL DU11LS(A,MDA,M,N,RE,W(N4),MODE,NP,KRANK,KSURE, - 1 W(N1),W(N2),W(N3),IWORK(N1),IWORK(N2)) - GO TO 400 -C - 200 CONTINUE - IF(RE(1).LT.0.0D0) GO TO 511 - IF(RE(1).GT.1.0D0) GO TO 512 - IF(RE(1).LT.EPS) RE(1)=EPS - DO 220 I=1,N - W(N4-1+I)=RE(1) - IF(AE(I).LT.0.0D0) GO TO 513 - 220 CONTINUE - CALL DU11LS(A,MDA,M,N,W(N4),AE,MODE,NP,KRANK,KSURE, - 1 W(N1),W(N2),W(N3),IWORK(N1),IWORK(N2)) - GO TO 400 -C - 300 CONTINUE - DO 320 I=1,N - IF(RE(I).LT.0.0D0) GO TO 511 - IF(RE(I).GT.1.0D0) GO TO 512 - IF(RE(I).LT.EPS) RE(I)=EPS - IF(AE(I).LT.0.0D0) GO TO 513 - 320 CONTINUE - CALL DU11LS(A,MDA,M,N,RE,AE,MODE,NP,KRANK,KSURE, - 1 W(N1),W(N2),W(N3),IWORK(N1),IWORK(N2)) -C -C DETERMINE INFO -C - 400 IF(KRANK.NE.N) GO TO 402 - INFO=5 - GO TO 410 - 402 IF(KRANK.NE.0) GO TO 404 - INFO=3 - GO TO 410 - 404 IF(KRANK.GE.NP) GO TO 406 - INFO=4 - RETURN - 406 INFO=MODE - IF(MODE.EQ.0) RETURN - 410 IF(NB.EQ.0) RETURN -C -C SOLUTION PHASE -C - N1=1 - N2=N1+N - N3=N2+N - IF(INFO.EQ.2) GO TO 420 - IF(LW.LT.N2-1) GO TO 510 - CALL DU12LS(A,MDA,M,N,B,MDB,NB,MODE,KRANK, - 1 RNORM,W(N1),W(N1),IWORK(N1),IWORK(N2)) - RETURN -C - 420 IF(LW.LT.N3-1) GO TO 510 - CALL DU12LS(A,MDA,M,N,B,MDB,NB,MODE,KRANK, - 1 RNORM,W(N1),W(N2),IWORK(N1),IWORK(N2)) - RETURN -C -C ERROR MESSAGES -C - 501 CALL XERMSG ('SLATEC', 'DLLSIA', - + 'SOLUTION ONLY (INFO=1) BUT NO RIGHT HAND SIDE (NB=0)', 1, 0) - RETURN - 502 CALL XERMSG ('SLATEC', 'DLLSIA', 'M.LT.1', 2, 1) - RETURN - 503 CALL XERMSG ('SLATEC', 'DLLSIA', 'N.LT.1', 2, 1) - RETURN - 504 CALL XERMSG ('SLATEC', 'DLLSIA', 'N.GT.M', 2, 1) - RETURN - 505 CALL XERMSG ('SLATEC', 'DLLSIA', 'MDA.LT.M', 2, 1) - RETURN - 506 CALL XERMSG ('SLATEC', 'DLLSIA', 'LIW.LT.M+N', 2, 1) - RETURN - 507 CALL XERMSG ('SLATEC', 'DLLSIA', 'NB.LT.0', 2, 1) - RETURN - 508 CALL XERMSG ('SLATEC', 'DLLSIA', 'MDB.LT.M', 2, 1) - RETURN - 509 CALL XERMSG ('SLATEC', 'DLLSIA', 'KEY OUT OF RANGE', 2, 1) - RETURN - 510 CALL XERMSG ('SLATEC', 'DLLSIA', 'INSUFFICIENT WORK SPACE', 8, 1) - INFO=-1 - RETURN - 511 CALL XERMSG ('SLATEC', 'DLLSIA', 'RE(I) .LT. 0', 2, 1) - RETURN - 512 CALL XERMSG ('SLATEC', 'DLLSIA', 'RE(I) .GT. 1', 2, 1) - RETURN - 513 CALL XERMSG ('SLATEC', 'DLLSIA', 'AE(I) .LT. 0', 2, 1) - RETURN - 514 CALL XERMSG ('SLATEC', 'DLLSIA', 'INFO OUT OF RANGE', 2, 1) - RETURN - 515 CALL XERMSG ('SLATEC', 'DLLSIA', 'MODE OUT OF RANGE', 2, 1) - RETURN - 516 CALL XERMSG ('SLATEC', 'DLLSIA', 'NP OUT OF RANGE', 2, 1) - RETURN - END diff --git a/slatec/dllti2.f b/slatec/dllti2.f deleted file mode 100644 index a091ce6..0000000 --- a/slatec/dllti2.f +++ /dev/null @@ -1,168 +0,0 @@ -*DECK DLLTI2 - SUBROUTINE DLLTI2 (N, B, X, NEL, IEL, JEL, EL, DINV) -C***BEGIN PROLOGUE DLLTI2 -C***PURPOSE SLAP Backsolve routine for LDL' Factorization. -C Routine to solve a system of the form L*D*L' X = B, -C where L is a unit lower triangular matrix and D is a -C diagonal matrix and ' means transpose. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE DOUBLE PRECISION (SLLTI2-S, DLLTI2-D) -C***KEYWORDS INCOMPLETE FACTORIZATION, ITERATIVE PRECONDITION, SLAP, -C SPARSE, SYMMETRIC LINEAR SYSTEM SOLVE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NEL, IEL(NEL), JEL(NEL) -C DOUBLE PRECISION B(N), X(N), EL(NEL), DINV(N) -C -C CALL DLLTI2( N, B, X, NEL, IEL, JEL, EL, DINV ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right hand side vector. -C X :OUT Double Precision X(N). -C Solution to L*D*L' x = b. -C NEL :IN Integer. -C Number of non-zeros in the EL array. -C IEL :IN Integer IEL(NEL). -C JEL :IN Integer JEL(NEL). -C EL :IN Double Precision EL(NEL). -C IEL, JEL, EL contain the unit lower triangular factor of -C the incomplete decomposition of the A matrix stored in -C SLAP Row format. The diagonal of ones *IS* stored. This -C structure can be set up by the DS2LT routine. See the -C "Description", below for more details about the SLAP Row -C format. -C DINV :IN Double Precision DINV(N). -C Inverse of the diagonal matrix D. -C -C *Description: -C This routine is supplied with the SLAP package as a routine -C to perform the MSOLVE operation in the SCG iteration routine -C for the driver routine DSICCG. It must be called via the -C SLAP MSOLVE calling sequence convention interface routine -C DSLLI. -C **** THIS ROUTINE ITSELF DOES NOT CONFORM TO THE **** -C **** SLAP MSOLVE CALLING CONVENTION **** -C -C IEL, JEL, EL should contain the unit lower triangular factor -C of the incomplete decomposition of the A matrix stored in -C SLAP Row format. This IC factorization can be computed by -C the DSICS routine. The diagonal (which is all one's) is -C stored. -C -C ==================== S L A P Row format ==================== -C -C This routine requires that the matrix A be stored in the -C SLAP Row format. In this format the non-zeros are stored -C counting across rows (except for the diagonal entry, which -C must appear first in each "row") and are stored in the -C double precision array A. In other words, for each row in -C the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going across the row (except the -C diagonal) in order. The JA array holds the column index for -C each non-zero. The IA array holds the offsets into the JA, -C A arrays for the beginning of each row. That is, -C JA(IA(IROW)),A(IA(IROW)) are the first elements of the IROW- -C th row in JA and A, and JA(IA(IROW+1)-1), A(IA(IROW+1)-1) -C are the last elements of the IROW-th row. Note that we -C always have IA(N+1) = NELT+1, where N is the number of rows -C in the matrix and NELT is the number of non-zeros in the -C matrix. -C -C Here is an example of the SLAP Row storage format for a 5x5 -C Matrix (in the A and JA arrays '|' denotes the end of a row): -C -C 5x5 Matrix SLAP Row format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 12 15 | 22 21 | 33 35 | 44 | 55 51 53 -C |21 22 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| IA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C With the SLAP Row format the "inner loop" of this routine -C should vectorize on machines with hardware support for -C vector gather/scatter operations. Your compiler may require -C a compiler directive to convince it that there are no -C implicit vector dependencies. Compiler directives for the -C Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied -C with the standard SLAP distribution. -C -C***SEE ALSO DSICCG, DSICS -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE DLLTI2 -C .. Scalar Arguments .. - INTEGER N, NEL -C .. Array Arguments .. - DOUBLE PRECISION B(N), DINV(N), EL(NEL), X(N) - INTEGER IEL(NEL), JEL(NEL) -C .. Local Scalars .. - INTEGER I, IBGN, IEND, IROW -C***FIRST EXECUTABLE STATEMENT DLLTI2 -C -C Solve L*y = b, storing result in x. -C - DO 10 I=1,N - X(I) = B(I) - 10 CONTINUE - DO 30 IROW = 1, N - IBGN = IEL(IROW) + 1 - IEND = IEL(IROW+1) - 1 - IF( IBGN.LE.IEND ) THEN -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ NOCONCUR -CVD$ NODEPCHK - DO 20 I = IBGN, IEND - X(IROW) = X(IROW) - EL(I)*X(JEL(I)) - 20 CONTINUE - ENDIF - 30 CONTINUE -C -C Solve D*Z = Y, storing result in X. -C - DO 40 I=1,N - X(I) = X(I)*DINV(I) - 40 CONTINUE -C -C Solve L-trans*X = Z. -C - DO 60 IROW = N, 2, -1 - IBGN = IEL(IROW) + 1 - IEND = IEL(IROW+1) - 1 - IF( IBGN.LE.IEND ) THEN -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ NOCONCUR -CVD$ NODEPCHK - DO 50 I = IBGN, IEND - X(JEL(I)) = X(JEL(I)) - EL(I)*X(IROW) - 50 CONTINUE - ENDIF - 60 CONTINUE -C - RETURN -C------------- LAST LINE OF DLLTI2 FOLLOWS ---------------------------- - END diff --git a/slatec/dlngam.f b/slatec/dlngam.f deleted file mode 100644 index 3755450..0000000 --- a/slatec/dlngam.f +++ /dev/null @@ -1,73 +0,0 @@ -*DECK DLNGAM - DOUBLE PRECISION FUNCTION DLNGAM (X) -C***BEGIN PROLOGUE DLNGAM -C***PURPOSE Compute the logarithm of the absolute value of the Gamma -C function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7A -C***TYPE DOUBLE PRECISION (ALNGAM-S, DLNGAM-D, CLNGAM-C) -C***KEYWORDS ABSOLUTE VALUE, COMPLETE GAMMA FUNCTION, FNLIB, LOGARITHM, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DLNGAM(X) calculates the double precision logarithm of the -C absolute value of the Gamma function for double precision -C argument X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, D9LGMC, DGAMMA, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 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 900727 Added EXTERNAL statement. (WRB) -C***END PROLOGUE DLNGAM - DOUBLE PRECISION X, DXREL, PI, SINPIY, SQPI2L, SQ2PIL, XMAX, - 1 Y, DGAMMA, D9LGMC, D1MACH, TEMP - LOGICAL FIRST - EXTERNAL DGAMMA - SAVE SQ2PIL, SQPI2L, PI, XMAX, DXREL, FIRST - DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 / - DATA SQPI2L / +.2257913526 4472743236 3097614947 441 D+0 / - DATA PI / 3.1415926535 8979323846 2643383279 50 D0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DLNGAM - IF (FIRST) THEN - TEMP = 1.D0/LOG(D1MACH(2)) - XMAX = TEMP*D1MACH(2) - DXREL = SQRT(D1MACH(4)) - ENDIF - FIRST = .FALSE. -C - Y = ABS (X) - IF (Y.GT.10.D0) GO TO 20 -C -C LOG (ABS (DGAMMA(X)) ) FOR ABS(X) .LE. 10.0 -C - DLNGAM = LOG (ABS (DGAMMA(X)) ) - RETURN -C -C LOG ( ABS (DGAMMA(X)) ) FOR ABS(X) .GT. 10.0 -C - 20 IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'DLNGAM', - + 'ABS(X) SO BIG DLNGAM OVERFLOWS', 2, 2) -C - IF (X.GT.0.D0) DLNGAM = SQ2PIL + (X-0.5D0)*LOG(X) - X + D9LGMC(Y) - IF (X.GT.0.D0) RETURN -C - SINPIY = ABS (SIN(PI*Y)) - IF (SINPIY .EQ. 0.D0) CALL XERMSG ('SLATEC', 'DLNGAM', - + 'X IS A NEGATIVE INTEGER', 3, 2) -C - IF (ABS((X-AINT(X-0.5D0))/X) .LT. DXREL) CALL XERMSG ('SLATEC', - + 'DLNGAM', - + 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER', - + 1, 1) -C - DLNGAM = SQPI2L + (X-0.5D0)*LOG(Y) - X - LOG(SINPIY) - D9LGMC(Y) - RETURN -C - END diff --git a/slatec/dlnrel.f b/slatec/dlnrel.f deleted file mode 100644 index 403232d..0000000 --- a/slatec/dlnrel.f +++ /dev/null @@ -1,98 +0,0 @@ -*DECK DLNREL - DOUBLE PRECISION FUNCTION DLNREL (X) -C***BEGIN PROLOGUE DLNREL -C***PURPOSE Evaluate ln(1+X) accurate in the sense of relative error. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4B -C***TYPE DOUBLE PRECISION (ALNREL-S, DLNREL-D, CLNREL-C) -C***KEYWORDS ELEMENTARY FUNCTIONS, FNLIB, LOGARITHM -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DLNREL(X) calculates the double precision natural logarithm of -C (1.0+X) for double precision argument X. This routine should -C be used when X is small and accurate to calculate the logarithm -C accurately (in the relative error sense) in the neighborhood -C of 1.0. -C -C Series for ALNR on the interval -3.75000E-01 to 3.75000E-01 -C with weighted error 6.35E-32 -C log weighted error 31.20 -C significant figures required 30.93 -C decimal places required 32.01 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 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***END PROLOGUE DLNREL - DOUBLE PRECISION ALNRCS(43), X, XMIN, DCSEVL, D1MACH - LOGICAL FIRST - SAVE ALNRCS, NLNREL, XMIN, FIRST - DATA ALNRCS( 1) / +.1037869356 2743769800 6862677190 98 D+1 / - DATA ALNRCS( 2) / -.1336430150 4908918098 7660415531 33 D+0 / - DATA ALNRCS( 3) / +.1940824913 5520563357 9261993747 50 D-1 / - DATA ALNRCS( 4) / -.3010755112 7535777690 3765377765 92 D-2 / - DATA ALNRCS( 5) / +.4869461479 7154850090 4563665091 37 D-3 / - DATA ALNRCS( 6) / -.8105488189 3175356066 8099430086 22 D-4 / - DATA ALNRCS( 7) / +.1377884779 9559524782 9382514960 59 D-4 / - DATA ALNRCS( 8) / -.2380221089 4358970251 3699929149 35 D-5 / - DATA ALNRCS( 9) / +.4164041621 3865183476 3918599019 89 D-6 / - DATA ALNRCS( 10) / -.7359582837 8075994984 2668370319 98 D-7 / - DATA ALNRCS( 11) / +.1311761187 6241674949 1522943450 11 D-7 / - DATA ALNRCS( 12) / -.2354670931 7742425136 6960923301 75 D-8 / - DATA ALNRCS( 13) / +.4252277327 6034997775 6380529625 67 D-9 / - DATA ALNRCS( 14) / -.7719089413 4840796826 1081074933 00 D-10 / - DATA ALNRCS( 15) / +.1407574648 1359069909 2153564721 91 D-10 / - DATA ALNRCS( 16) / -.2576907205 8024680627 5370786275 84 D-11 / - DATA ALNRCS( 17) / +.4734240666 6294421849 1543950059 38 D-12 / - DATA ALNRCS( 18) / -.8724901267 4742641745 3012632926 75 D-13 / - DATA ALNRCS( 19) / +.1612461490 2740551465 7398331191 15 D-13 / - DATA ALNRCS( 20) / -.2987565201 5665773006 7107924168 15 D-14 / - DATA ALNRCS( 21) / +.5548070120 9082887983 0413216972 79 D-15 / - DATA ALNRCS( 22) / -.1032461915 8271569595 1413339619 32 D-15 / - DATA ALNRCS( 23) / +.1925023920 3049851177 8785032448 68 D-16 / - DATA ALNRCS( 24) / -.3595507346 5265150011 1897078442 66 D-17 / - DATA ALNRCS( 25) / +.6726454253 7876857892 1945742267 73 D-18 / - DATA ALNRCS( 26) / -.1260262416 8735219252 0824256375 46 D-18 / - DATA ALNRCS( 27) / +.2364488440 8606210044 9161589555 19 D-19 / - DATA ALNRCS( 28) / -.4441937705 0807936898 8783891797 33 D-20 / - DATA ALNRCS( 29) / +.8354659446 4034259016 2412939946 66 D-21 / - DATA ALNRCS( 30) / -.1573155941 6479562574 8992535210 66 D-21 / - DATA ALNRCS( 31) / +.2965312874 0247422686 1543697066 66 D-22 / - DATA ALNRCS( 32) / -.5594958348 1815947292 1560132266 66 D-23 / - DATA ALNRCS( 33) / +.1056635426 8835681048 1872841386 66 D-23 / - DATA ALNRCS( 34) / -.1997248368 0670204548 3149994666 66 D-24 / - DATA ALNRCS( 35) / +.3778297781 8839361421 0498559999 99 D-25 / - DATA ALNRCS( 36) / -.7153158688 9081740345 0381653333 33 D-26 / - DATA ALNRCS( 37) / +.1355248846 3674213646 5020245333 33 D-26 / - DATA ALNRCS( 38) / -.2569467304 8487567430 0798293333 33 D-27 / - DATA ALNRCS( 39) / +.4874775606 6216949076 4595199999 99 D-28 / - DATA ALNRCS( 40) / -.9254211253 0849715321 1323733333 33 D-29 / - DATA ALNRCS( 41) / +.1757859784 1760239233 2697600000 00 D-29 / - DATA ALNRCS( 42) / -.3341002667 7731010351 3770666666 66 D-30 / - DATA ALNRCS( 43) / +.6353393618 0236187354 1802666666 66 D-31 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DLNREL - IF (FIRST) THEN - NLNREL = INITDS (ALNRCS, 43, 0.1*REAL(D1MACH(3))) - XMIN = -1.0D0 + SQRT(D1MACH(4)) - ENDIF - FIRST = .FALSE. -C - IF (X .LE. (-1.D0)) CALL XERMSG ('SLATEC', 'DLNREL', 'X IS LE -1' - + , 2, 2) - IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'DLNREL', - + 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR -1', 1, 1) -C - IF (ABS(X).LE.0.375D0) DLNREL = X*(1.D0 - - 1 X*DCSEVL (X/.375D0, ALNRCS, NLNREL)) -C - IF (ABS(X).GT.0.375D0) DLNREL = LOG (1.0D0+X) -C - RETURN - END diff --git a/slatec/dlpdoc.f b/slatec/dlpdoc.f deleted file mode 100644 index f18ecf4..0000000 --- a/slatec/dlpdoc.f +++ /dev/null @@ -1,460 +0,0 @@ -*DECK DLPDOC - SUBROUTINE DLPDOC -C***BEGIN PROLOGUE DLPDOC -C***PURPOSE Sparse Linear Algebra Package Version 2.0.2 Documentation. -C Routines to solve large sparse symmetric and nonsymmetric -C positive definite linear systems, Ax = b, using precondi- -C tioned iterative methods. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4, Z -C***TYPE DOUBLE PRECISION (SLPDOC-S, DLPDOC-D) -C***KEYWORDS BICONJUGATE GRADIENT SQUARED, DOCUMENTATION, -C GENERALIZED MINIMUM RESIDUAL, ITERATIVE IMPROVEMENT, -C NORMAL EQUATIONS, ORTHOMIN, -C PRECONDITIONED CONJUGATE GRADIENT, SLAP, -C SPARSE ITERATIVE METHODS -C***AUTHOR Seager, Mark. K., (LLNL) -C User Systems Division -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 -C (FTS) 543-3141, (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C The -C Sparse Linear Algebra Package -C Double Precision Routines -C -C @@@@@@@ @ @@@ @@@@@@@@ -C @ @ @ @ @ @ @ -C @ @ @ @ @ @ -C @@@@@@@ @ @ @ @@@@@@@@ -C @ @ @@@@@@@@@ @ -C @ @ @ @ @ @ -C @@@@@@@ @@@@@@@@@ @ @ @ -C -C @ @ @@@@@@@ @@@@@ -C @ @ @ @ @ @@ -C @ @ @@@@@@@ @ @@ @ @ @ @ -C @ @ @ @ @@ @ @@@@@@ @ @ @ -C @ @ @@@@@@@@@ @ @ @ @ @ -C @ @ @ @ @ @@@ @@ @ -C @@@ @@@@@@@ @ @@@@@@@@@ @@@ @@@@@ -C -C -C ================================================================= -C ========================== Introduction ========================= -C ================================================================= -C This package was originally derived from a set of iterative -C routines written by Anne Greenbaum, as announced in "Routines -C for Solving Large Sparse Linear Systems", Tentacle, Lawrence -C Livermore National Laboratory, Livermore Computing Center -C (January 1986), pp 15-21. -C -C This document contains the specifications for the SLAP Version -C 2.0 package, a Fortran 77 package for the solution of large -C sparse linear systems, Ax = b, via preconditioned iterative -C methods. Included in this package are "core" routines to do -C Iterative Refinement (Jacobi's method), Conjugate Gradient, -C Conjugate Gradient on the normal equations, AA'y = b, (where x = -C A'y and A' denotes the transpose of A), BiConjugate Gradient, -C BiConjugate Gradient Squared, Orthomin and Generalized Minimum -C Residual Iteration. These "core" routines do not require a -C "fixed" data structure for storing the matrix A and the -C preconditioning matrix M. The user is free to choose any -C structure that facilitates efficient solution of the problem at -C hand. The drawback to this approach is that the user must also -C supply at least two routines (MATVEC and MSOLVE, say). MATVEC -C must calculate, y = Ax, given x and the user's data structure for -C A. MSOLVE must solve, r = Mz, for z (*NOT* r) given r and the -C user's data structure for M (or its inverse). The user should -C choose M so that inv(M)*A is approximately the identity and the -C solution step r = Mz is "easy" to solve. For some of the "core" -C routines (Orthomin, BiConjugate Gradient and Conjugate Gradient -C on the normal equations) the user must also supply a matrix -C transpose times vector routine (MTTVEC, say) and (possibly, -C depending on the "core" method) a routine that solves the -C transpose of the preconditioning step (MTSOLV, say). -C Specifically, MTTVEC is a routine which calculates y = A'x, given -C x and the user's data structure for A (A' is the transpose of A). -C MTSOLV is a routine which solves the system r = M'z for z given r -C and the user's data structure for M. -C -C This process of writing the matrix vector operations can be time -C consuming and error prone. To alleviate these problems we have -C written drivers for the "core" methods that assume the user -C supplies one of two specific data structures (SLAP Triad and SLAP -C Column format), see below. Utilizing these data structures we -C have augmented each "core" method with two preconditioners: -C Diagonal Scaling and Incomplete Factorization. Diagonal scaling -C is easy to implement, vectorizes very well and for problems that -C are not too ill-conditioned reduces the number of iterations -C enough to warrant its use. On the other hand, an Incomplete -C factorization (Incomplete Cholesky for symmetric systems and -C Incomplete LU for nonsymmetric systems) may take much longer to -C calculate, but it reduces the iteration count (for most problems) -C significantly. Our implementations of IC and ILU vectorize for -C machines with hardware gather scatter, but the vector lengths can -C be quite short if the number of non-zeros in a column is not -C large. -C -C ================================================================= -C ==================== Supplied Data Structures =================== -C ================================================================= -C The following describes the data structures supplied with the -C package: SLAP Triad and Column formats. -C -C ====================== S L A P Triad format ===================== -C -C In the SLAP Triad format only the non-zeros are stored. They may -C appear in *ANY* order. The user supplies three arrays of length -C NELT, where NELT is the number of non-zeros in the matrix: -C (IA(NELT), JA(NELT), A(NELT)). If the matrix is symmetric then -C one need only store the lower triangle (including the diagonal) -C and NELT would be the corresponding number of non-zeros stored. -C For each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding location -C of the A array. This is an extremely easy data structure to -C generate. On the other hand, it is not very efficient on vector -C computers for the iterative solution of linear systems. Hence, -C SLAP changes this input data structure to the SLAP Column format -C for the iteration (but does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C nonsymmetric 5x5 Matrix. NELT=11. Recall that the entries may -C appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C ====================== S L A P Column format ==================== -C -C In the SLAP Column format the non-zeros are stored counting down -C columns (except for the diagonal entry, which must appear first -C in each "column") and are stored in the double precision array A. -C In other words, for each column in the matrix first put the -C diagonal entry in A. Then put in the other non-zero elements -C going down the column (except the diagonal) in order. The IA -C array holds the row index for each non-zero. The JA array holds -C the offsets into the IA, A arrays for the beginning of each -C column. That is, IA(JA(ICOL)), A(JA(ICOL)) are the first elements -C of the ICOL-th column in IA and A, and IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) are the last elements of the ICOL-th column. Note -C that we always have JA(N+1) = NELT+1, where N is the number of -C columns in the matrix and NELT is the number of non-zeros in the -C matrix. If the matrix is symmetric one need only store the lower -C triangle (including the diagonal) and NELT would be the corre- -C sponding number of non-zeros stored. -C -C Here is an example of the SLAP Column storage format for a -C nonsymmetric 5x5 Matrix (in the A and IA arrays '|' denotes the -C end of a column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C ================================================================= -C ====================== Which Method To Use ====================== -C ================================================================= -C -C BACKGROUND -C In solving a large sparse linear system Ax = b using an iterative -C method, it is not necessary to actually store the matrix A. -C Rather, what is needed is a procedure for multiplying the matrix -C A times a given vector y to obtain the matrix-vector product, Ay. -C SLAP has been written to take advantage of this fact. The higher -C level routines in the package require storage only of the non-zero -C elements of A (and their positions), and even this can be -C avoided, if the user writes his own subroutine for multiplying -C the matrix times a vector and calls the lower-level iterative -C routines in the package. -C -C If the matrix A is ill-conditioned, then most iterative methods -C will be slow to converge (if they converge at all!). To improve -C the convergence rate, one may use a "matrix splitting," or, -C "preconditioning matrix," say, M. It is then necessary to solve, -C at each iteration, a linear system with coefficient matrix M. A -C good preconditioner M should have two properties: (1) M should -C "approximate" A, in the sense that the matrix inv(M)*A (or some -C variant thereof) is better conditioned than the original matrix -C A; and (2) linear systems with coefficient matrix M should be -C much easier to solve than the original system with coefficient -C matrix A. Preconditioning routines in the SLAP package are -C separate from the iterative routines, so that any of the -C preconditioners provided in the package, or one that the user -C codes himself, can be used with any of the iterative routines. -C -C CHOICE OF PRECONDITIONER -C If you willing to live with either the SLAP Triad or Column -C matrix data structure you can then choose one of two types of -C preconditioners to use: diagonal scaling or incomplete -C factorization. To choose between these two methods requires -C knowing something about the computer you're going to run these -C codes on and how well incomplete factorization approximates the -C inverse of your matrix. -C -C Let us suppose you have a scalar machine. Then, unless the -C incomplete factorization is very, very poor this is *GENERALLY* -C the method to choose. It will reduce the number of iterations -C significantly and is not all that expensive to compute. So if -C you have just one linear system to solve and "just want to get -C the job done" then try incomplete factorization first. If you -C are thinking of integrating some SLAP iterative method into your -C favorite "production code" then try incomplete factorization -C first, but also check to see that diagonal scaling is indeed -C slower for a large sample of test problems. -C -C Let us now suppose you have a vector computer with hardware -C gather/scatter support (Cray X-MP, Y-MP, SCS-40 or Cyber 205, ETA -C 10, ETA Piper, Convex C-1, etc.). Then it is much harder to -C choose between the two methods. The versions of incomplete -C factorization in SLAP do in fact vectorize, but have short vector -C lengths and the factorization step is relatively more expensive. -C Hence, for most problems (i.e., unless your problem is ill -C conditioned, sic!) diagonal scaling is faster, with its very -C fast set up time and vectorized (with long vectors) -C preconditioning step (even though it may take more iterations). -C If you have several systems (or right hand sides) to solve that -C can utilize the same preconditioner then the cost of the -C incomplete factorization can be amortized over these several -C solutions. This situation gives more advantage to the incomplete -C factorization methods. If you have a vector machine without -C hardware gather/scatter (Cray 1, Cray 2 & Cray 3) then the -C advantages for incomplete factorization are even less. -C -C If you're trying to shoehorn SLAP into your favorite "production -C code" and can not easily generate either the SLAP Triad or Column -C format then you are left to your own devices in terms of -C preconditioning. Also, you may find that the preconditioners -C supplied with SLAP are not sufficient for your problem. In this -C situation we would recommend that you talk with a numerical -C analyst versed in iterative methods about writing other -C preconditioning subroutines (e.g., polynomial preconditioning, -C shifted incomplete factorization, SOR or SSOR iteration). You -C can always "roll your own" by using the "core" iterative methods -C and supplying your own MSOLVE and MATVEC (and possibly MTSOLV and -C MTTVEC) routines. -C -C SYMMETRIC SYSTEMS -C If your matrix is symmetric then you would want to use one of the -C symmetric system solvers. If your system is also positive -C definite, (Ax,x) (Ax dot product with x) is positive for all -C non-zero vectors x, then use Conjugate Gradient (DCG, DSDCG, -C DSICSG). If you're not sure it's SPD (symmetric and Positive -C Definite) then try DCG anyway and if it works, fine. If you're -C sure your matrix is not positive definite then you may want to -C try the iterative refinement methods (DIR) or the GMRES code -C (DGMRES) if DIR converges too slowly. -C -C NONSYMMETRIC SYSTEMS -C This is currently an area of active research in numerical -C analysis and there are new strategies being developed. -C Consequently take the following advice with a grain of salt. If -C you matrix is positive definite, (Ax,x) (Ax dot product with x -C is positive for all non-zero vectors x), then you can use any of -C the methods for nonsymmetric systems (Orthomin, GMRES, -C BiConjugate Gradient, BiConjugate Gradient Squared and Conjugate -C Gradient applied to the normal equations). If your system is not -C too ill conditioned then try BiConjugate Gradient Squared (BCGS) -C or GMRES (DGMRES). Both of these methods converge very quickly -C and do not require A' or M' (' denotes transpose) information. -C DGMRES does require some additional storage, though. If the -C system is very ill conditioned or nearly positive indefinite -C ((Ax,x) is positive, but may be very small), then GMRES should -C be the first choice, but try the other methods if you have to -C fine tune the solution process for a "production code". If you -C have a great preconditioner for the normal equations (i.e., M is -C an approximation to the inverse of AA' rather than just A) then -C this is not a bad route to travel. Old wisdom would say that the -C normal equations are a disaster (since it squares the condition -C number of the system and DCG convergence is linked to this number -C of infamy), but some preconditioners (like incomplete -C factorization) can reduce the condition number back below that of -C the original system. -C -C ================================================================= -C ======================= Naming Conventions ====================== -C ================================================================= -C SLAP iterative methods, matrix vector and preconditioner -C calculation routines follow a naming convention which, when -C understood, allows one to determine the iterative method and data -C structure(s) used. The subroutine naming convention takes the -C following form: -C P[S][M]DESC -C where -C P stands for the precision (or data type) of the routine and -C is required in all names, -C S denotes whether or not the routine requires the SLAP Triad -C or Column format (it does if the second letter of the name -C is S and does not otherwise), -C M stands for the type of preconditioner used (only appears -C in drivers for "core" routines), and -C DESC is some number of letters describing the method or purpose -C of the routine. The following is a list of the "DESC" -C fields for iterative methods and their meaning: -C BCG,BC: BiConjugate Gradient -C CG: Conjugate Gradient -C CGN,CN: Conjugate Gradient on the Normal equations -C CGS,CS: biConjugate Gradient Squared -C GMRES,GMR,GM: Generalized Minimum RESidual -C IR,R: Iterative Refinement -C JAC: JACobi's method -C GS: Gauss-Seidel -C OMN,OM: OrthoMiN -C -C In the double precision version of SLAP, all routine names start -C with a D. The brackets around the S and M designate that these -C fields are optional. -C -C Here are some examples of the routines: -C 1) DBCG: Double precision BiConjugate Gradient "core" routine. -C One can deduce that this is a "core" routine, because the S and -C M fields are missing and BiConjugate Gradient is an iterative -C method. -C 2) DSDBCG: Double precision, SLAP data structure BCG with Diagonal -C scaling. -C 3) DSLUBC: Double precision, SLAP data structure BCG with incom- -C plete LU factorization as the preconditioning. -C 4) DCG: Double precision Conjugate Gradient "core" routine. -C 5) DSDCG: Double precision, SLAP data structure Conjugate Gradient -C with Diagonal scaling. -C 6) DSICCG: Double precision, SLAP data structure Conjugate Gra- -C dient with Incomplete Cholesky factorization preconditioning. -C -C -C ================================================================= -C ===================== USER CALLABLE ROUTINES ==================== -C ================================================================= -C The following is a list of the "user callable" SLAP routines and -C their one line descriptions. The headers denote the file names -C where the routines can be found, as distributed for UNIX systems. -C -C Note: Each core routine, DXXX, has a corresponding stop routine, -C ISDXXX. If the stop routine does not have the specific stop -C test the user requires (e.g., weighted infinity norm), then -C the user should modify the source for ISDXXX accordingly. -C -C ============================= dir.f ============================= -C DIR: Preconditioned Iterative Refinement Sparse Ax = b Solver. -C DSJAC: Jacobi's Method Iterative Sparse Ax = b Solver. -C DSGS: Gauss-Seidel Method Iterative Sparse Ax = b Solver. -C DSILUR: Incomplete LU Iterative Refinement Sparse Ax = b Solver. -C -C ============================= dcg.f ============================= -C DCG: Preconditioned Conjugate Gradient Sparse Ax=b Solver. -C DSDCG: Diagonally Scaled Conjugate Gradient Sparse Ax=b Solver. -C DSICCG: Incomplete Cholesky Conjugate Gradient Sparse Ax=b Solver. -C -C ============================= dcgn.f ============================ -C DCGN: Preconditioned CG Sparse Ax=b Solver for Normal Equations. -C DSDCGN: Diagonally Scaled CG Sparse Ax=b Solver for Normal Eqn's. -C DSLUCN: Incomplete LU CG Sparse Ax=b Solver for Normal Equations. -C -C ============================= dbcg.f ============================ -C DBCG: Preconditioned BiConjugate Gradient Sparse Ax = b Solver. -C DSDBCG: Diagonally Scaled BiConjugate Gradient Sparse Ax=b Solver. -C DSLUBC: Incomplete LU BiConjugate Gradient Sparse Ax=b Solver. -C -C ============================= dcgs.f ============================ -C DCGS: Preconditioned BiConjugate Gradient Squared Ax=b Solver. -C DSDCGS: Diagonally Scaled CGS Sparse Ax=b Solver. -C DSLUCS: Incomplete LU BiConjugate Gradient Squared Ax=b Solver. -C -C ============================= domn.f ============================ -C DOMN: Preconditioned Orthomin Sparse Iterative Ax=b Solver. -C DSDOMN: Diagonally Scaled Orthomin Sparse Iterative Ax=b Solver. -C DSLUOM: Incomplete LU Orthomin Sparse Iterative Ax=b Solver. -C -C ============================ dgmres.f =========================== -C DGMRES: Preconditioned GMRES Iterative Sparse Ax=b Solver. -C DSDGMR: Diagonally Scaled GMRES Iterative Sparse Ax=b Solver. -C DSLUGM: Incomplete LU GMRES Iterative Sparse Ax=b Solver. -C -C ============================ dmset.f ============================ -C The following routines are used to set up preconditioners. -C -C DSDS: Diagonal Scaling Preconditioner SLAP Set Up. -C DSDSCL: Diagonally Scales/Unscales a SLAP Column Matrix. -C DSD2S: Diagonal Scaling Preconditioner SLAP Normal Eqns Set Up. -C DS2LT: Lower Triangle Preconditioner SLAP Set Up. -C DSICS: Incomplete Cholesky Decomp. Preconditioner SLAP Set Up. -C DSILUS: Incomplete LU Decomposition Preconditioner SLAP Set Up. -C -C ============================ dmvops.f =========================== -C Most of the incomplete factorization (LL' and LDU) solvers -C in this file require an intermediate routine to translate -C from the SLAP MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, -C IWORK) calling convention to the calling sequence required -C by the solve routine. This generally is accomplished by -C fishing out pointers to the preconditioner (stored in RWORK) -C from the IWORK array and then making a call to the routine -C that actually does the backsolve. -C -C DSMV: SLAP Column Format Sparse Matrix Vector Product. -C DSMTV: SLAP Column Format Sparse Matrix (transpose) Vector Prod. -C DSDI: Diagonal Matrix Vector Multiply. -C DSLI: SLAP MSOLVE for Lower Triangle Matrix (set up for DSLI2). -C DSLI2: Lower Triangle Matrix Backsolve. -C DSLLTI: SLAP MSOLVE for LDL' (IC) Fact. (set up for DLLTI2). -C DLLTI2: Backsolve routine for LDL' Factorization. -C DSLUI: SLAP MSOLVE for LDU Factorization (set up for DSLUI2). -C DSLUI2: SLAP Backsolve for LDU Factorization. -C DSLUTI: SLAP MTSOLV for LDU Factorization (set up for DSLUI4). -C DSLUI4: SLAP Backsolve for LDU Factorization. -C DSMMTI: SLAP MSOLVE for LDU Fact of Normal Eq (set up for DSMMI2). -C DSMMI2: SLAP Backsolve for LDU Factorization of Normal Equations. -C -C =========================== dlaputil.f ========================== -C The following utility routines are useful additions to SLAP. -C -C DBHIN: Read Sparse Linear System in the Boeing/Harwell Format. -C DCHKW: SLAP WORK/IWORK Array Bounds Checker. -C DCPPLT: Printer Plot of SLAP Column Format Matrix. -C DS2Y: SLAP Triad to SLAP Column Format Converter. -C QS2I1D: Quick Sort Integer array, moving integer and DP arrays. -C (Used by DS2Y.) -C DTIN: Read in SLAP Triad Format Linear System. -C DTOUT: Write out SLAP Triad Format Linear System. -C -C -C***REFERENCES 1. Mark K. Seager, A SLAP for the Masses, in -C G. F. Carey, Ed., Parallel Supercomputing: Methods, -C Algorithms and Applications, Wiley, 1989, pp.135-155. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C -----( This produced Version 2.0.1. )----- -C 891003 Rearranged list of user callable routines to agree with -C order in source deck. (FNF) -C 891004 Updated reference. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C -----( This produced Version 2.0.2. )----- -C 910506 Minor improvements to prologue. (FNF) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of reference. (FNF) -C 921019 Improved one-line descriptions, reordering some. (FNF) -C***END PROLOGUE DLPDOC -C***FIRST EXECUTABLE STATEMENT DLPDOC -C -C This is a *DUMMY* subroutine and should never be called. -C - RETURN -C------------- LAST LINE OF DLPDOC FOLLOWS ----------------------------- - END diff --git a/slatec/dlpdp.f b/slatec/dlpdp.f deleted file mode 100644 index 6906c12..0000000 --- a/slatec/dlpdp.f +++ /dev/null @@ -1,208 +0,0 @@ -*DECK DLPDP - SUBROUTINE DLPDP (A, MDA, M, N1, N2, PRGOPT, X, WNORM, MODE, WS, - + IS) -C***BEGIN PROLOGUE DLPDP -C***SUBSIDIARY -C***PURPOSE Subsidiary to DLSEI -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (LPDP-S, DLPDP-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C **** Double Precision version of LPDP **** -C DIMENSION A(MDA,N+1),PRGOPT(*),X(N),WS((M+2)*(N+7)),IS(M+N+1), -C where N=N1+N2. This is a slight overestimate for WS(*). -C -C Determine an N1-vector W, and -C an N2-vector Z -C which minimizes the Euclidean length of W -C subject to G*W+H*Z .GE. Y. -C This is the least projected distance problem, LPDP. -C The matrices G and H are of respective -C dimensions M by N1 and M by N2. -C -C Called by subprogram DLSI( ). -C -C The matrix -C (G H Y) -C -C occupies rows 1,...,M and cols 1,...,N1+N2+1 of A(*,*). -C -C The solution (W) is returned in X(*). -C (Z) -C -C The value of MODE indicates the status of -C the computation after returning to the user. -C -C MODE=1 The solution was successfully obtained. -C -C MODE=2 The inequalities are inconsistent. -C -C***SEE ALSO DLSEI -C***ROUTINES CALLED DCOPY, DDOT, DNRM2, DSCAL, DWNNLS -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910408 Updated the AUTHOR section. (WRB) -C***END PROLOGUE DLPDP -C - INTEGER I, IS(*), IW, IX, J, L, M, MDA, MODE, MODEW, N, N1, N2, - * NP1 - DOUBLE PRECISION A(MDA,*), DDOT, DNRM2, FAC, ONE, - * PRGOPT(*), RNORM, SC, WNORM, WS(*), X(*), YNORM, ZERO - SAVE ZERO, ONE, FAC - DATA ZERO,ONE /0.0D0,1.0D0/, FAC /0.1D0/ -C***FIRST EXECUTABLE STATEMENT DLPDP - N = N1 + N2 - MODE = 1 - IF (M .GT. 0) GO TO 20 - IF (N .LE. 0) GO TO 10 - X(1) = ZERO - CALL DCOPY(N,X,0,X,1) - 10 CONTINUE - WNORM = ZERO - GO TO 200 - 20 CONTINUE -C BEGIN BLOCK PERMITTING ...EXITS TO 190 - NP1 = N + 1 -C -C SCALE NONZERO ROWS OF INEQUALITY MATRIX TO HAVE LENGTH ONE. - DO 40 I = 1, M - SC = DNRM2(N,A(I,1),MDA) - IF (SC .EQ. ZERO) GO TO 30 - SC = ONE/SC - CALL DSCAL(NP1,SC,A(I,1),MDA) - 30 CONTINUE - 40 CONTINUE -C -C SCALE RT.-SIDE VECTOR TO HAVE LENGTH ONE (OR ZERO). - YNORM = DNRM2(M,A(1,NP1),1) - IF (YNORM .EQ. ZERO) GO TO 50 - SC = ONE/YNORM - CALL DSCAL(M,SC,A(1,NP1),1) - 50 CONTINUE -C -C SCALE COLS OF MATRIX H. - J = N1 + 1 - 60 IF (J .GT. N) GO TO 70 - SC = DNRM2(M,A(1,J),1) - IF (SC .NE. ZERO) SC = ONE/SC - CALL DSCAL(M,SC,A(1,J),1) - X(J) = SC - J = J + 1 - GO TO 60 - 70 CONTINUE - IF (N1 .LE. 0) GO TO 130 -C -C COPY TRANSPOSE OF (H G Y) TO WORK ARRAY WS(*). - IW = 0 - DO 80 I = 1, M -C -C MOVE COL OF TRANSPOSE OF H INTO WORK ARRAY. - CALL DCOPY(N2,A(I,N1+1),MDA,WS(IW+1),1) - IW = IW + N2 -C -C MOVE COL OF TRANSPOSE OF G INTO WORK ARRAY. - CALL DCOPY(N1,A(I,1),MDA,WS(IW+1),1) - IW = IW + N1 -C -C MOVE COMPONENT OF VECTOR Y INTO WORK ARRAY. - WS(IW+1) = A(I,NP1) - IW = IW + 1 - 80 CONTINUE - WS(IW+1) = ZERO - CALL DCOPY(N,WS(IW+1),0,WS(IW+1),1) - IW = IW + N - WS(IW+1) = ONE - IW = IW + 1 -C -C SOLVE EU=F SUBJECT TO (TRANSPOSE OF H)U=0, U.GE.0. THE -C MATRIX E = TRANSPOSE OF (G Y), AND THE (N+1)-VECTOR -C F = TRANSPOSE OF (0,...,0,1). - IX = IW + 1 - IW = IW + M -C -C DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF -C DWNNLS( ). - IS(1) = 0 - IS(2) = 0 - CALL DWNNLS(WS,NP1,N2,NP1-N2,M,0,PRGOPT,WS(IX),RNORM, - * MODEW,IS,WS(IW+1)) -C -C COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY W. - SC = ONE - DDOT(M,A(1,NP1),1,WS(IX),1) - IF (ONE + FAC*ABS(SC) .EQ. ONE .OR. RNORM .LE. ZERO) - * GO TO 110 - SC = ONE/SC - DO 90 J = 1, N1 - X(J) = SC*DDOT(M,A(1,J),1,WS(IX),1) - 90 CONTINUE -C -C COMPUTE THE VECTOR Q=Y-GW. OVERWRITE Y WITH THIS -C VECTOR. - DO 100 I = 1, M - A(I,NP1) = A(I,NP1) - DDOT(N1,A(I,1),MDA,X,1) - 100 CONTINUE - GO TO 120 - 110 CONTINUE - MODE = 2 -C .........EXIT - GO TO 190 - 120 CONTINUE - 130 CONTINUE - IF (N2 .LE. 0) GO TO 180 -C -C COPY TRANSPOSE OF (H Q) TO WORK ARRAY WS(*). - IW = 0 - DO 140 I = 1, M - CALL DCOPY(N2,A(I,N1+1),MDA,WS(IW+1),1) - IW = IW + N2 - WS(IW+1) = A(I,NP1) - IW = IW + 1 - 140 CONTINUE - WS(IW+1) = ZERO - CALL DCOPY(N2,WS(IW+1),0,WS(IW+1),1) - IW = IW + N2 - WS(IW+1) = ONE - IW = IW + 1 - IX = IW + 1 - IW = IW + M -C -C SOLVE RV=S SUBJECT TO V.GE.0. THE MATRIX R =(TRANSPOSE -C OF (H Q)), WHERE Q=Y-GW. THE (N2+1)-VECTOR S =(TRANSPOSE -C OF (0,...,0,1)). -C -C DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF -C DWNNLS( ). - IS(1) = 0 - IS(2) = 0 - CALL DWNNLS(WS,N2+1,0,N2+1,M,0,PRGOPT,WS(IX),RNORM,MODEW, - * IS,WS(IW+1)) -C -C COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY Z. - SC = ONE - DDOT(M,A(1,NP1),1,WS(IX),1) - IF (ONE + FAC*ABS(SC) .EQ. ONE .OR. RNORM .LE. ZERO) - * GO TO 160 - SC = ONE/SC - DO 150 J = 1, N2 - L = N1 + J - X(L) = SC*DDOT(M,A(1,L),1,WS(IX),1)*X(L) - 150 CONTINUE - GO TO 170 - 160 CONTINUE - MODE = 2 -C .........EXIT - GO TO 190 - 170 CONTINUE - 180 CONTINUE -C -C ACCOUNT FOR SCALING OF RT.-SIDE VECTOR IN SOLUTION. - CALL DSCAL(N,YNORM,X,1) - WNORM = DNRM2(N1,X,1) - 190 CONTINUE - 200 CONTINUE - RETURN - END diff --git a/slatec/dlsei.f b/slatec/dlsei.f deleted file mode 100644 index be31d82..0000000 --- a/slatec/dlsei.f +++ /dev/null @@ -1,735 +0,0 @@ -*DECK DLSEI - SUBROUTINE DLSEI (W, MDW, ME, MA, MG, N, PRGOPT, X, RNORME, - + RNORML, MODE, WS, IP) -C***BEGIN PROLOGUE DLSEI -C***PURPOSE Solve a linearly constrained least squares problem with -C equality and inequality constraints, and optionally compute -C a covariance matrix. -C***LIBRARY SLATEC -C***CATEGORY K1A2A, D9 -C***TYPE DOUBLE PRECISION (LSEI-S, DLSEI-D) -C***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, -C EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, -C QUADRATIC PROGRAMMING -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C Abstract -C -C This subprogram solves a linearly constrained least squares -C problem with both equality and inequality constraints, and, if the -C user requests, obtains a covariance matrix of the solution -C parameters. -C -C Suppose there are given matrices E, A and G of respective -C dimensions ME by N, MA by N and MG by N, and vectors F, B and H of -C respective lengths ME, MA and MG. This subroutine solves the -C linearly constrained least squares problem -C -C EX = F, (E ME by N) (equations to be exactly -C satisfied) -C AX = B, (A MA by N) (equations to be -C approximately satisfied, -C least squares sense) -C GX .GE. H,(G MG by N) (inequality constraints) -C -C The inequalities GX .GE. H mean that every component of the -C product GX must be .GE. the corresponding component of H. -C -C In case the equality constraints cannot be satisfied, a -C generalized inverse solution residual vector length is obtained -C for F-EX. This is the minimal length possible for F-EX. -C -C Any values ME .GE. 0, MA .GE. 0, or MG .GE. 0 are permitted. The -C rank of the matrix E is estimated during the computation. We call -C this value KRANKE. It is an output parameter in IP(1) defined -C below. Using a generalized inverse solution of EX=F, a reduced -C least squares problem with inequality constraints is obtained. -C The tolerances used in these tests for determining the rank -C of E and the rank of the reduced least squares problem are -C given in Sandia Tech. Rept. SAND-78-1290. They can be -C modified by the user if new values are provided in -C the option list of the array PRGOPT(*). -C -C The user must dimension all arrays appearing in the call list.. -C W(MDW,N+1),PRGOPT(*),X(N),WS(2*(ME+N)+K+(MG+2)*(N+7)),IP(MG+2*N+2) -C where K=MAX(MA+MG,N). This allows for a solution of a range of -C problems in the given working space. The dimension of WS(*) -C given is a necessary overestimate. Once a particular problem -C has been run, the output parameter IP(3) gives the actual -C dimension required for that problem. -C -C The parameters for DLSEI( ) are -C -C Input.. All TYPE REAL variables are DOUBLE PRECISION -C -C W(*,*),MDW, The array W(*,*) is doubly subscripted with -C ME,MA,MG,N first dimensioning parameter equal to MDW. -C For this discussion let us call M = ME+MA+MG. Then -C MDW must satisfy MDW .GE. M. The condition -C MDW .LT. M is an error. -C -C The array W(*,*) contains the matrices and vectors -C -C (E F) -C (A B) -C (G H) -C -C in rows and columns 1,...,M and 1,...,N+1 -C respectively. -C -C The integers ME, MA, and MG are the -C respective matrix row dimensions -C of E, A and G. Each matrix has N columns. -C -C PRGOPT(*) This real-valued array is the option vector. -C If the user is satisfied with the nominal -C subprogram features set -C -C PRGOPT(1)=1 (or PRGOPT(1)=1.0) -C -C Otherwise PRGOPT(*) is a linked list consisting of -C groups of data of the following form -C -C LINK -C KEY -C DATA SET -C -C The parameters LINK and KEY are each one word. -C The DATA SET can be comprised of several words. -C The number of items depends on the value of KEY. -C The value of LINK points to the first -C entry of the next group of data within -C PRGOPT(*). The exception is when there are -C no more options to change. In that -C case, LINK=1 and the values KEY and DATA SET -C are not referenced. The general layout of -C PRGOPT(*) is as follows. -C -C ...PRGOPT(1) = LINK1 (link to first entry of next group) -C . PRGOPT(2) = KEY1 (key to the option change) -C . PRGOPT(3) = data value (data value for this change) -C . . -C . . -C . . -C ...PRGOPT(LINK1) = LINK2 (link to the first entry of -C . next group) -C . PRGOPT(LINK1+1) = KEY2 (key to the option change) -C . PRGOPT(LINK1+2) = data value -C ... . -C . . -C . . -C ...PRGOPT(LINK) = 1 (no more options to change) -C -C Values of LINK that are nonpositive are errors. -C A value of LINK .GT. NLINK=100000 is also an error. -C This helps prevent using invalid but positive -C values of LINK that will probably extend -C beyond the program limits of PRGOPT(*). -C Unrecognized values of KEY are ignored. The -C order of the options is arbitrary and any number -C of options can be changed with the following -C restriction. To prevent cycling in the -C processing of the option array, a count of the -C number of options changed is maintained. -C Whenever this count exceeds NOPT=1000, an error -C message is printed and the subprogram returns. -C -C Options.. -C -C KEY=1 -C Compute in W(*,*) the N by N -C covariance matrix of the solution variables -C as an output parameter. Nominally the -C covariance matrix will not be computed. -C (This requires no user input.) -C The data set for this option is a single value. -C It must be nonzero when the covariance matrix -C is desired. If it is zero, the covariance -C matrix is not computed. When the covariance matrix -C is computed, the first dimensioning parameter -C of the array W(*,*) must satisfy MDW .GE. MAX(M,N). -C -C KEY=10 -C Suppress scaling of the inverse of the -C normal matrix by the scale factor RNORM**2/ -C MAX(1, no. of degrees of freedom). This option -C only applies when the option for computing the -C covariance matrix (KEY=1) is used. With KEY=1 and -C KEY=10 used as options the unscaled inverse of the -C normal matrix is returned in W(*,*). -C The data set for this option is a single value. -C When it is nonzero no scaling is done. When it is -C zero scaling is done. The nominal case is to do -C scaling so if option (KEY=1) is used alone, the -C matrix will be scaled on output. -C -C KEY=2 -C Scale the nonzero columns of the -C entire data matrix. -C (E) -C (A) -C (G) -C -C to have length one. The data set for this -C option is a single value. It must be -C nonzero if unit length column scaling -C is desired. -C -C KEY=3 -C Scale columns of the entire data matrix -C (E) -C (A) -C (G) -C -C with a user-provided diagonal matrix. -C The data set for this option consists -C of the N diagonal scaling factors, one for -C each matrix column. -C -C KEY=4 -C Change the rank determination tolerance for -C the equality constraint equations from -C the nominal value of SQRT(DRELPR). This quantity can -C be no smaller than DRELPR, the arithmetic- -C storage precision. The quantity DRELPR is the -C largest positive number such that T=1.+DRELPR -C satisfies T .EQ. 1. The quantity used -C here is internally restricted to be at -C least DRELPR. The data set for this option -C is the new tolerance. -C -C KEY=5 -C Change the rank determination tolerance for -C the reduced least squares equations from -C the nominal value of SQRT(DRELPR). This quantity can -C be no smaller than DRELPR, the arithmetic- -C storage precision. The quantity used -C here is internally restricted to be at -C least DRELPR. The data set for this option -C is the new tolerance. -C -C For example, suppose we want to change -C the tolerance for the reduced least squares -C problem, compute the covariance matrix of -C the solution parameters, and provide -C column scaling for the data matrix. For -C these options the dimension of PRGOPT(*) -C must be at least N+9. The Fortran statements -C defining these options would be as follows: -C -C PRGOPT(1)=4 (link to entry 4 in PRGOPT(*)) -C PRGOPT(2)=1 (covariance matrix key) -C PRGOPT(3)=1 (covariance matrix wanted) -C -C PRGOPT(4)=7 (link to entry 7 in PRGOPT(*)) -C PRGOPT(5)=5 (least squares equas. tolerance key) -C PRGOPT(6)=... (new value of the tolerance) -C -C PRGOPT(7)=N+9 (link to entry N+9 in PRGOPT(*)) -C PRGOPT(8)=3 (user-provided column scaling key) -C -C CALL DCOPY (N, D, 1, PRGOPT(9), 1) (Copy the N -C scaling factors from the user array D(*) -C to PRGOPT(9)-PRGOPT(N+8)) -C -C PRGOPT(N+9)=1 (no more options to change) -C -C The contents of PRGOPT(*) are not modified -C by the subprogram. -C The options for WNNLS( ) can also be included -C in this array. The values of KEY recognized -C by WNNLS( ) are 6, 7 and 8. Their functions -C are documented in the usage instructions for -C subroutine WNNLS( ). Normally these options -C do not need to be modified when using DLSEI( ). -C -C IP(1), The amounts of working storage actually -C IP(2) allocated for the working arrays WS(*) and -C IP(*), respectively. These quantities are -C compared with the actual amounts of storage -C needed by DLSEI( ). Insufficient storage -C allocated for either WS(*) or IP(*) is an -C error. This feature was included in DLSEI( ) -C because miscalculating the storage formulas -C for WS(*) and IP(*) might very well lead to -C subtle and hard-to-find execution errors. -C -C The length of WS(*) must be at least -C -C LW = 2*(ME+N)+K+(MG+2)*(N+7) -C -C where K = max(MA+MG,N) -C This test will not be made if IP(1).LE.0. -C -C The length of IP(*) must be at least -C -C LIP = MG+2*N+2 -C This test will not be made if IP(2).LE.0. -C -C Output.. All TYPE REAL variables are DOUBLE PRECISION -C -C X(*),RNORME, The array X(*) contains the solution parameters -C RNORML if the integer output flag MODE = 0 or 1. -C The definition of MODE is given directly below. -C When MODE = 0 or 1, RNORME and RNORML -C respectively contain the residual vector -C Euclidean lengths of F - EX and B - AX. When -C MODE=1 the equality constraint equations EX=F -C are contradictory, so RNORME .NE. 0. The residual -C vector F-EX has minimal Euclidean length. For -C MODE .GE. 2, none of these parameters is defined. -C -C MODE Integer flag that indicates the subprogram -C status after completion. If MODE .GE. 2, no -C solution has been computed. -C -C MODE = -C -C 0 Both equality and inequality constraints -C are compatible and have been satisfied. -C -C 1 Equality constraints are contradictory. -C A generalized inverse solution of EX=F was used -C to minimize the residual vector length F-EX. -C In this sense, the solution is still meaningful. -C -C 2 Inequality constraints are contradictory. -C -C 3 Both equality and inequality constraints -C are contradictory. -C -C The following interpretation of -C MODE=1,2 or 3 must be made. The -C sets consisting of all solutions -C of the equality constraints EX=F -C and all vectors satisfying GX .GE. H -C have no points in common. (In -C particular this does not say that -C each individual set has no points -C at all, although this could be the -C case.) -C -C 4 Usage error occurred. The value -C of MDW is .LT. ME+MA+MG, MDW is -C .LT. N and a covariance matrix is -C requested, or the option vector -C PRGOPT(*) is not properly defined, -C or the lengths of the working arrays -C WS(*) and IP(*), when specified in -C IP(1) and IP(2) respectively, are not -C long enough. -C -C W(*,*) The array W(*,*) contains the N by N symmetric -C covariance matrix of the solution parameters, -C provided this was requested on input with -C the option vector PRGOPT(*) and the output -C flag is returned with MODE = 0 or 1. -C -C IP(*) The integer working array has three entries -C that provide rank and working array length -C information after completion. -C -C IP(1) = rank of equality constraint -C matrix. Define this quantity -C as KRANKE. -C -C IP(2) = rank of reduced least squares -C problem. -C -C IP(3) = the amount of storage in the -C working array WS(*) that was -C actually used by the subprogram. -C The formula given above for the length -C of WS(*) is a necessary overestimate. -C If exactly the same problem matrices -C are used in subsequent executions, -C the declared dimension of WS(*) can -C be reduced to this output value. -C User Designated -C Working Arrays.. -C -C WS(*),IP(*) These are respectively type real -C and type integer working arrays. -C Their required minimal lengths are -C given above. -C -C***REFERENCES K. H. Haskell and R. J. Hanson, An algorithm for -C linear least squares problems with equality and -C nonnegativity constraints, Report SAND77-0552, Sandia -C Laboratories, June 1978. -C K. H. Haskell and R. J. Hanson, Selected algorithms for -C the linearly constrained least squares problem - a -C users guide, Report SAND78-1290, Sandia Laboratories, -C August 1979. -C K. H. Haskell and R. J. Hanson, An algorithm for -C linear least squares problems with equality and -C nonnegativity constraints, Mathematical Programming -C 21 (1981), pp. 98-118. -C R. J. Hanson and K. H. Haskell, Two algorithms for the -C linearly constrained least squares problem, ACM -C Transactions on Mathematical Software, September 1982. -C***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DLSI, -C DNRM2, DSCAL, DSWAP, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and extensively revised (WRB & RWC) -C 890831 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 900604 DP version created from SP version. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DLSEI - INTEGER IP(3), MA, MDW, ME, MG, MODE, N - DOUBLE PRECISION PRGOPT(*), RNORME, RNORML, W(MDW,*), WS(*), X(*) -C - EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DLSI, DNRM2, - * DSCAL, DSWAP, XERMSG - DOUBLE PRECISION D1MACH, DASUM, DDOT, DNRM2 -C - DOUBLE PRECISION DRELPR, ENORM, FNORM, GAM, RB, RN, RNMAX, SIZE, - * SN, SNMAX, T, TAU, UJ, UP, VJ, XNORM, XNRME - INTEGER I, IMAX, J, JP1, K, KEY, KRANKE, LAST, LCHK, LINK, M, - * MAPKE1, MDEQC, MEND, MEP1, N1, N2, NEXT, NLINK, NOPT, NP1, - * NTIMES - LOGICAL COV, FIRST - CHARACTER*8 XERN1, XERN2, XERN3, XERN4 - SAVE FIRST, DRELPR -C - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DLSEI -C -C Set the nominal tolerance used in the code for the equality -C constraint equations. -C - IF (FIRST) DRELPR = D1MACH(4) - FIRST = .FALSE. - TAU = SQRT(DRELPR) -C -C Check that enough storage was allocated in WS(*) and IP(*). -C - MODE = 4 - IF (MIN(N,ME,MA,MG) .LT. 0) THEN - WRITE (XERN1, '(I8)') N - WRITE (XERN2, '(I8)') ME - WRITE (XERN3, '(I8)') MA - WRITE (XERN4, '(I8)') MG - CALL XERMSG ('SLATEC', 'LSEI', 'ALL OF THE VARIABLES N, ME,' // - * ' MA, MG MUST BE .GE. 0$$ENTERED ROUTINE WITH' // - * '$$N = ' // XERN1 // - * '$$ME = ' // XERN2 // - * '$$MA = ' // XERN3 // - * '$$MG = ' // XERN4, 2, 1) - RETURN - ENDIF -C - IF (IP(1).GT.0) THEN - LCHK = 2*(ME+N) + MAX(MA+MG,N) + (MG+2)*(N+7) - IF (IP(1).LT.LCHK) THEN - WRITE (XERN1, '(I8)') LCHK - CALL XERMSG ('SLATEC', 'DLSEI', 'INSUFFICIENT STORAGE ' // - * 'ALLOCATED FOR WS(*), NEED LW = ' // XERN1, 2, 1) - RETURN - ENDIF - ENDIF -C - IF (IP(2).GT.0) THEN - LCHK = MG + 2*N + 2 - IF (IP(2).LT.LCHK) THEN - WRITE (XERN1, '(I8)') LCHK - CALL XERMSG ('SLATEC', 'DLSEI', 'INSUFFICIENT STORAGE ' // - * 'ALLOCATED FOR IP(*), NEED LIP = ' // XERN1, 2, 1) - RETURN - ENDIF - ENDIF -C -C Compute number of possible right multiplying Householder -C transformations. -C - M = ME + MA + MG - IF (N.LE.0 .OR. M.LE.0) THEN - MODE = 0 - RNORME = 0 - RNORML = 0 - RETURN - ENDIF -C - IF (MDW.LT.M) THEN - CALL XERMSG ('SLATEC', 'DLSEI', 'MDW.LT.ME+MA+MG IS AN ERROR', - + 2, 1) - RETURN - ENDIF -C - NP1 = N + 1 - KRANKE = MIN(ME,N) - N1 = 2*KRANKE + 1 - N2 = N1 + N -C -C Set nominal values. -C -C The nominal column scaling used in the code is -C the identity scaling. -C - CALL DCOPY (N, 1.D0, 0, WS(N1), 1) -C -C No covariance matrix is nominally computed. -C - COV = .FALSE. -C -C Process option vector. -C Define bound for number of options to change. -C - NOPT = 1000 - NTIMES = 0 -C -C Define bound for positive values of LINK. -C - NLINK = 100000 - LAST = 1 - LINK = PRGOPT(1) - IF (LINK.EQ.0 .OR. LINK.GT.NLINK) THEN - CALL XERMSG ('SLATEC', 'DLSEI', - + 'THE OPTION VECTOR IS UNDEFINED', 2, 1) - RETURN - ENDIF -C - 100 IF (LINK.GT.1) THEN - NTIMES = NTIMES + 1 - IF (NTIMES.GT.NOPT) THEN - CALL XERMSG ('SLATEC', 'DLSEI', - + 'THE LINKS IN THE OPTION VECTOR ARE CYCLING.', 2, 1) - RETURN - ENDIF -C - KEY = PRGOPT(LAST+1) - IF (KEY.EQ.1) THEN - COV = PRGOPT(LAST+2) .NE. 0.D0 - ELSEIF (KEY.EQ.2 .AND. PRGOPT(LAST+2).NE.0.D0) THEN - DO 110 J = 1,N - T = DNRM2(M,W(1,J),1) - IF (T.NE.0.D0) T = 1.D0/T - WS(J+N1-1) = T - 110 CONTINUE - ELSEIF (KEY.EQ.3) THEN - CALL DCOPY (N, PRGOPT(LAST+2), 1, WS(N1), 1) - ELSEIF (KEY.EQ.4) THEN - TAU = MAX(DRELPR,PRGOPT(LAST+2)) - ENDIF -C - NEXT = PRGOPT(LINK) - IF (NEXT.LE.0 .OR. NEXT.GT.NLINK) THEN - CALL XERMSG ('SLATEC', 'DLSEI', - + 'THE OPTION VECTOR IS UNDEFINED', 2, 1) - RETURN - ENDIF -C - LAST = LINK - LINK = NEXT - GO TO 100 - ENDIF -C - DO 120 J = 1,N - CALL DSCAL (M, WS(N1+J-1), W(1,J), 1) - 120 CONTINUE -C - IF (COV .AND. MDW.LT.N) THEN - CALL XERMSG ('SLATEC', 'DLSEI', - + 'MDW .LT. N WHEN COV MATRIX NEEDED, IS AN ERROR', 2, 1) - RETURN - ENDIF -C -C Problem definition and option vector OK. -C - MODE = 0 -C -C Compute norm of equality constraint matrix and right side. -C - ENORM = 0.D0 - DO 130 J = 1,N - ENORM = MAX(ENORM,DASUM(ME,W(1,J),1)) - 130 CONTINUE -C - FNORM = DASUM(ME,W(1,NP1),1) - SNMAX = 0.D0 - RNMAX = 0.D0 - DO 150 I = 1,KRANKE -C -C Compute maximum ratio of vector lengths. Partition is at -C column I. -C - DO 140 K = I,ME - SN = DDOT(N-I+1,W(K,I),MDW,W(K,I),MDW) - RN = DDOT(I-1,W(K,1),MDW,W(K,1),MDW) - IF (RN.EQ.0.D0 .AND. SN.GT.SNMAX) THEN - SNMAX = SN - IMAX = K - ELSEIF (K.EQ.I .OR. SN*RNMAX.GT.RN*SNMAX) THEN - SNMAX = SN - RNMAX = RN - IMAX = K - ENDIF - 140 CONTINUE -C -C Interchange rows if necessary. -C - IF (I.NE.IMAX) CALL DSWAP (NP1, W(I,1), MDW, W(IMAX,1), MDW) - IF (SNMAX.GT.RNMAX*TAU**2) THEN -C -C Eliminate elements I+1,...,N in row I. -C - CALL DH12 (1, I, I+1, N, W(I,1), MDW, WS(I), W(I+1,1), MDW, - + 1, M-I) - ELSE - KRANKE = I - 1 - GO TO 160 - ENDIF - 150 CONTINUE -C -C Save diagonal terms of lower trapezoidal matrix. -C - 160 CALL DCOPY (KRANKE, W, MDW+1, WS(KRANKE+1), 1) -C -C Use Householder transformation from left to achieve -C KRANKE by KRANKE upper triangular form. -C - IF (KRANKE.LT.ME) THEN - DO 170 K = KRANKE,1,-1 -C -C Apply transformation to matrix cols. 1,...,K-1. -C - CALL DH12 (1, K, KRANKE+1, ME, W(1,K), 1, UP, W, 1, MDW, - * K-1) -C -C Apply to rt side vector. -C - CALL DH12 (2, K, KRANKE+1, ME, W(1,K), 1, UP, W(1,NP1), 1, - + 1, 1) - 170 CONTINUE - ENDIF -C -C Solve for variables 1,...,KRANKE in new coordinates. -C - CALL DCOPY (KRANKE, W(1, NP1), 1, X, 1) - DO 180 I = 1,KRANKE - X(I) = (X(I)-DDOT(I-1,W(I,1),MDW,X,1))/W(I,I) - 180 CONTINUE -C -C Compute residuals for reduced problem. -C - MEP1 = ME + 1 - RNORML = 0.D0 - DO 190 I = MEP1,M - W(I,NP1) = W(I,NP1) - DDOT(KRANKE,W(I,1),MDW,X,1) - SN = DDOT(KRANKE,W(I,1),MDW,W(I,1),MDW) - RN = DDOT(N-KRANKE,W(I,KRANKE+1),MDW,W(I,KRANKE+1),MDW) - IF (RN.LE.SN*TAU**2 .AND. KRANKE.LT.N) - * CALL DCOPY (N-KRANKE, 0.D0, 0, W(I,KRANKE+1), MDW) - 190 CONTINUE -C -C Compute equality constraint equations residual length. -C - RNORME = DNRM2(ME-KRANKE,W(KRANKE+1,NP1),1) -C -C Move reduced problem data upward if KRANKE.LT.ME. -C - IF (KRANKE.LT.ME) THEN - DO 200 J = 1,NP1 - CALL DCOPY (M-ME, W(ME+1,J), 1, W(KRANKE+1,J), 1) - 200 CONTINUE - ENDIF -C -C Compute solution of reduced problem. -C - CALL DLSI(W(KRANKE+1, KRANKE+1), MDW, MA, MG, N-KRANKE, PRGOPT, - + X(KRANKE+1), RNORML, MODE, WS(N2), IP(2)) -C -C Test for consistency of equality constraints. -C - IF (ME.GT.0) THEN - MDEQC = 0 - XNRME = DASUM(KRANKE,W(1,NP1),1) - IF (RNORME.GT.TAU*(ENORM*XNRME+FNORM)) MDEQC = 1 - MODE = MODE + MDEQC -C -C Check if solution to equality constraints satisfies inequality -C constraints when there are no degrees of freedom left. -C - IF (KRANKE.EQ.N .AND. MG.GT.0) THEN - XNORM = DASUM(N,X,1) - MAPKE1 = MA + KRANKE + 1 - MEND = MA + KRANKE + MG - DO 210 I = MAPKE1,MEND - SIZE = DASUM(N,W(I,1),MDW)*XNORM + ABS(W(I,NP1)) - IF (W(I,NP1).GT.TAU*SIZE) THEN - MODE = MODE + 2 - GO TO 290 - ENDIF - 210 CONTINUE - ENDIF - ENDIF -C -C Replace diagonal terms of lower trapezoidal matrix. -C - IF (KRANKE.GT.0) THEN - CALL DCOPY (KRANKE, WS(KRANKE+1), 1, W, MDW+1) -C -C Reapply transformation to put solution in original coordinates. -C - DO 220 I = KRANKE,1,-1 - CALL DH12 (2, I, I+1, N, W(I,1), MDW, WS(I), X, 1, 1, 1) - 220 CONTINUE -C -C Compute covariance matrix of equality constrained problem. -C - IF (COV) THEN - DO 270 J = MIN(KRANKE,N-1),1,-1 - RB = WS(J)*W(J,J) - IF (RB.NE.0.D0) RB = 1.D0/RB - JP1 = J + 1 - DO 230 I = JP1,N - W(I,J) = RB*DDOT(N-J,W(I,JP1),MDW,W(J,JP1),MDW) - 230 CONTINUE -C - GAM = 0.5D0*RB*DDOT(N-J,W(JP1,J),1,W(J,JP1),MDW) - CALL DAXPY (N-J, GAM, W(J,JP1), MDW, W(JP1,J), 1) - DO 250 I = JP1,N - DO 240 K = I,N - W(I,K) = W(I,K) + W(J,I)*W(K,J) + W(I,J)*W(J,K) - W(K,I) = W(I,K) - 240 CONTINUE - 250 CONTINUE - UJ = WS(J) - VJ = GAM*UJ - W(J,J) = UJ*VJ + UJ*VJ - DO 260 I = JP1,N - W(J,I) = UJ*W(I,J) + VJ*W(J,I) - 260 CONTINUE - CALL DCOPY (N-J, W(J, JP1), MDW, W(JP1,J), 1) - 270 CONTINUE - ENDIF - ENDIF -C -C Apply the scaling to the covariance matrix. -C - IF (COV) THEN - DO 280 I = 1,N - CALL DSCAL (N, WS(I+N1-1), W(I,1), MDW) - CALL DSCAL (N, WS(I+N1-1), W(1,I), 1) - 280 CONTINUE - ENDIF -C -C Rescale solution vector. -C - 290 IF (MODE.LE.1) THEN - DO 300 J = 1,N - X(J) = X(J)*WS(N1+J-1) - 300 CONTINUE - ENDIF -C - IP(1) = KRANKE - IP(3) = IP(3) + 2*KRANKE + N - RETURN - END diff --git a/slatec/dlsi.f b/slatec/dlsi.f deleted file mode 100644 index 71d393f..0000000 --- a/slatec/dlsi.f +++ /dev/null @@ -1,338 +0,0 @@ -*DECK DLSI - SUBROUTINE DLSI (W, MDW, MA, MG, N, PRGOPT, X, RNORM, MODE, WS, - + IP) -C***BEGIN PROLOGUE DLSI -C***SUBSIDIARY -C***PURPOSE Subsidiary to DLSEI -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (LSI-S, DLSI-D) -C***AUTHOR Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C This is a companion subprogram to DLSEI. The documentation for -C DLSEI has complete usage instructions. -C -C Solve.. -C AX = B, A MA by N (least squares equations) -C subject to.. -C -C GX.GE.H, G MG by N (inequality constraints) -C -C Input.. -C -C W(*,*) contains (A B) in rows 1,...,MA+MG, cols 1,...,N+1. -C (G H) -C -C MDW,MA,MG,N -C contain (resp) var. dimension of W(*,*), -C and matrix dimensions. -C -C PRGOPT(*), -C Program option vector. -C -C OUTPUT.. -C -C X(*),RNORM -C -C Solution vector(unless MODE=2), length of AX-B. -C -C MODE -C =0 Inequality constraints are compatible. -C =2 Inequality constraints contradictory. -C -C WS(*), -C Working storage of dimension K+N+(MG+2)*(N+7), -C where K=MAX(MA+MG,N). -C IP(MG+2*N+1) -C Integer working storage -C -C***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DHFTI, -C DLPDP, DSCAL, DSWAP -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and extensively revised (WRB & RWC) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900604 DP version created from SP version. (RWC) -C 920422 Changed CALL to DHFTI to include variable MA. (WRB) -C***END PROLOGUE DLSI - INTEGER IP(*), MA, MDW, MG, MODE, N - DOUBLE PRECISION PRGOPT(*), RNORM, W(MDW,*), WS(*), X(*) -C - EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DHFTI, DLPDP, - * DSCAL, DSWAP - DOUBLE PRECISION D1MACH, DASUM, DDOT -C - DOUBLE PRECISION ANORM, DRELPR, FAC, GAM, RB, TAU, TOL, XNORM - INTEGER I, J, K, KEY, KRANK, KRM1, KRP1, L, LAST, LINK, M, MAP1, - * MDLPDP, MINMAN, N1, N2, N3, NEXT, NP1 - LOGICAL COV, FIRST, SCLCOV -C - SAVE DRELPR, FIRST - DATA FIRST /.TRUE./ -C -C***FIRST EXECUTABLE STATEMENT DLSI -C -C Set the nominal tolerance used in the code. -C - IF (FIRST) DRELPR = D1MACH(4) - FIRST = .FALSE. - TOL = SQRT(DRELPR) -C - MODE = 0 - RNORM = 0.D0 - M = MA + MG - NP1 = N + 1 - KRANK = 0 - IF (N.LE.0 .OR. M.LE.0) GO TO 370 -C -C To process option vector. -C - COV = .FALSE. - SCLCOV = .TRUE. - LAST = 1 - LINK = PRGOPT(1) -C - 100 IF (LINK.GT.1) THEN - KEY = PRGOPT(LAST+1) - IF (KEY.EQ.1) COV = PRGOPT(LAST+2) .NE. 0.D0 - IF (KEY.EQ.10) SCLCOV = PRGOPT(LAST+2) .EQ. 0.D0 - IF (KEY.EQ.5) TOL = MAX(DRELPR,PRGOPT(LAST+2)) - NEXT = PRGOPT(LINK) - LAST = LINK - LINK = NEXT - GO TO 100 - ENDIF -C -C Compute matrix norm of least squares equations. -C - ANORM = 0.D0 - DO 110 J = 1,N - ANORM = MAX(ANORM,DASUM(MA,W(1,J),1)) - 110 CONTINUE -C -C Set tolerance for DHFTI( ) rank test. -C - TAU = TOL*ANORM -C -C Compute Householder orthogonal decomposition of matrix. -C - CALL DCOPY (N, 0.D0, 0, WS, 1) - CALL DCOPY (MA, W(1, NP1), 1, WS, 1) - K = MAX(M,N) - MINMAN = MIN(MA,N) - N1 = K + 1 - N2 = N1 + N - CALL DHFTI (W, MDW, MA, N, WS, MA, 1, TAU, KRANK, RNORM, WS(N2), - + WS(N1), IP) - FAC = 1.D0 - GAM = MA - KRANK - IF (KRANK.LT.MA .AND. SCLCOV) FAC = RNORM**2/GAM -C -C Reduce to DLPDP and solve. -C - MAP1 = MA + 1 -C -C Compute inequality rt-hand side for DLPDP. -C - IF (MA.LT.M) THEN - IF (MINMAN.GT.0) THEN - DO 120 I = MAP1,M - W(I,NP1) = W(I,NP1) - DDOT(N,W(I,1),MDW,WS,1) - 120 CONTINUE -C -C Apply permutations to col. of inequality constraint matrix. -C - DO 130 I = 1,MINMAN - CALL DSWAP (MG, W(MAP1,I), 1, W(MAP1,IP(I)), 1) - 130 CONTINUE -C -C Apply Householder transformations to constraint matrix. -C - IF (KRANK.GT.0 .AND. KRANK.LT.N) THEN - DO 140 I = KRANK,1,-1 - CALL DH12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1), - + W(MAP1,1), MDW, 1, MG) - 140 CONTINUE - ENDIF -C -C Compute permuted inequality constraint matrix times r-inv. -C - DO 160 I = MAP1,M - DO 150 J = 1,KRANK - W(I,J) = (W(I,J)-DDOT(J-1,W(1,J),1,W(I,1),MDW))/W(J,J) - 150 CONTINUE - 160 CONTINUE - ENDIF -C -C Solve the reduced problem with DLPDP algorithm, -C the least projected distance problem. -C - CALL DLPDP(W(MAP1,1), MDW, MG, KRANK, N-KRANK, PRGOPT, X, - + XNORM, MDLPDP, WS(N2), IP(N+1)) -C -C Compute solution in original coordinates. -C - IF (MDLPDP.EQ.1) THEN - DO 170 I = KRANK,1,-1 - X(I) = (X(I)-DDOT(KRANK-I,W(I,I+1),MDW,X(I+1),1))/W(I,I) - 170 CONTINUE -C -C Apply Householder transformation to solution vector. -C - IF (KRANK.LT.N) THEN - DO 180 I = 1,KRANK - CALL DH12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1), - + X, 1, 1, 1) - 180 CONTINUE - ENDIF -C -C Repermute variables to their input order. -C - IF (MINMAN.GT.0) THEN - DO 190 I = MINMAN,1,-1 - CALL DSWAP (1, X(I), 1, X(IP(I)), 1) - 190 CONTINUE -C -C Variables are now in original coordinates. -C Add solution of unconstrained problem. -C - DO 200 I = 1,N - X(I) = X(I) + WS(I) - 200 CONTINUE -C -C Compute the residual vector norm. -C - RNORM = SQRT(RNORM**2+XNORM**2) - ENDIF - ELSE - MODE = 2 - ENDIF - ELSE - CALL DCOPY (N, WS, 1, X, 1) - ENDIF -C -C Compute covariance matrix based on the orthogonal decomposition -C from DHFTI( ). -C - IF (.NOT.COV .OR. KRANK.LE.0) GO TO 370 - KRM1 = KRANK - 1 - KRP1 = KRANK + 1 -C -C Copy diagonal terms to working array. -C - CALL DCOPY (KRANK, W, MDW+1, WS(N2), 1) -C -C Reciprocate diagonal terms. -C - DO 210 J = 1,KRANK - W(J,J) = 1.D0/W(J,J) - 210 CONTINUE -C -C Invert the upper triangular QR factor on itself. -C - IF (KRANK.GT.1) THEN - DO 230 I = 1,KRM1 - DO 220 J = I+1,KRANK - W(I,J) = -DDOT(J-I,W(I,I),MDW,W(I,J),1)*W(J,J) - 220 CONTINUE - 230 CONTINUE - ENDIF -C -C Compute the inverted factor times its transpose. -C - DO 250 I = 1,KRANK - DO 240 J = I,KRANK - W(I,J) = DDOT(KRANK+1-J,W(I,J),MDW,W(J,J),MDW) - 240 CONTINUE - 250 CONTINUE -C -C Zero out lower trapezoidal part. -C Copy upper triangular to lower triangular part. -C - IF (KRANK.LT.N) THEN - DO 260 J = 1,KRANK - CALL DCOPY (J, W(1,J), 1, W(J,1), MDW) - 260 CONTINUE -C - DO 270 I = KRP1,N - CALL DCOPY (I, 0.D0, 0, W(I,1), MDW) - 270 CONTINUE -C -C Apply right side transformations to lower triangle. -C - N3 = N2 + KRP1 - DO 330 I = 1,KRANK - L = N1 + I - K = N2 + I - RB = WS(L-1)*WS(K-1) -C -C If RB.GE.0.D0, transformation can be regarded as zero. -C - IF (RB.LT.0.D0) THEN - RB = 1.D0/RB -C -C Store unscaled rank one Householder update in work array. -C - CALL DCOPY (N, 0.D0, 0, WS(N3), 1) - L = N1 + I - K = N3 + I - WS(K-1) = WS(L-1) -C - DO 280 J = KRP1,N - WS(N3+J-1) = W(I,J) - 280 CONTINUE -C - DO 290 J = 1,N - WS(J) = RB*(DDOT(J-I,W(J,I),MDW,WS(N3+I-1),1)+ - + DDOT(N-J+1,W(J,J),1,WS(N3+J-1),1)) - 290 CONTINUE -C - L = N3 + I - GAM = 0.5D0*RB*DDOT(N-I+1,WS(L-1),1,WS(I),1) - CALL DAXPY (N-I+1, GAM, WS(L-1), 1, WS(I), 1) - DO 320 J = I,N - DO 300 L = 1,I-1 - W(J,L) = W(J,L) + WS(N3+J-1)*WS(L) - 300 CONTINUE -C - DO 310 L = I,J - W(J,L) = W(J,L) + WS(J)*WS(N3+L-1)+WS(L)*WS(N3+J-1) - 310 CONTINUE - 320 CONTINUE - ENDIF - 330 CONTINUE -C -C Copy lower triangle to upper triangle to symmetrize the -C covariance matrix. -C - DO 340 I = 1,N - CALL DCOPY (I, W(I,1), MDW, W(1,I), 1) - 340 CONTINUE - ENDIF -C -C Repermute rows and columns. -C - DO 350 I = MINMAN,1,-1 - K = IP(I) - IF (I.NE.K) THEN - CALL DSWAP (1, W(I,I), 1, W(K,K), 1) - CALL DSWAP (I-1, W(1,I), 1, W(1,K), 1) - CALL DSWAP (K-I-1, W(I,I+1), MDW, W(I+1,K), 1) - CALL DSWAP (N-K, W(I, K+1), MDW, W(K, K+1), MDW) - ENDIF - 350 CONTINUE -C -C Put in normalized residual sum of squares scale factor -C and symmetrize the resulting covariance matrix. -C - DO 360 J = 1,N - CALL DSCAL (J, FAC, W(1,J), 1) - CALL DCOPY (J, W(1,J), 1, W(J,1), MDW) - 360 CONTINUE -C - 370 IP(1) = KRANK - IP(2) = N + MAX(M,N) + (MG+2)*(N+7) - RETURN - END diff --git a/slatec/dlsod.f b/slatec/dlsod.f deleted file mode 100644 index 325e8ac..0000000 --- a/slatec/dlsod.f +++ /dev/null @@ -1,473 +0,0 @@ -*DECK DLSOD - SUBROUTINE DLSOD (DF, NEQ, T, Y, TOUT, RTOL, ATOL, IDID, YPOUT, - + YH, YH1, EWT, SAVF, ACOR, WM, IWM, DJAC, INTOUT, TSTOP, TOLFAC, - + DELSGN, RPAR, IPAR) -C***BEGIN PROLOGUE DLSOD -C***SUBSIDIARY -C***PURPOSE Subsidiary to DDEBDF -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (LSOD-S, DLSOD-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C DDEBDF merely allocates storage for DLSOD to relieve the user of -C the inconvenience of a long call list. Consequently DLSOD is used -C as described in the comments for DDEBDF . -C -C***SEE ALSO DDEBDF -C***ROUTINES CALLED D1MACH, DHSTRT, DINTYD, DSTOD, DVNRMS, XERMSG -C***COMMON BLOCKS DDEBD1 -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C***END PROLOGUE DLSOD -C - INTEGER IBAND, IBEGIN, IDID, IER, IINTEG, IJAC, INIT, INTFLG, - 1 IOWNS, IPAR, IQUIT, ITOL, ITSTOP, IWM, JSTART, K, KFLAG, - 2 KSTEPS, L, LACOR, LDUM, LEWT, LSAVF, LTOL, LWM, LYH, MAXNUM, - 3 MAXORD, METH, MITER, N, NATOLP, NEQ, NFE, NJE, NQ, NQU, - 4 NRTOLP, NST - DOUBLE PRECISION ABSDEL, ACOR, ATOL, BIG, D1MACH, DEL, - 1 DELSGN, DT, DVNRMS, EL0, EWT, - 2 H, HA, HMIN, HMXI, HU, ROWNS, RPAR, RTOL, SAVF, T, TOL, - 3 TOLD, TOLFAC, TOUT, TSTOP, U, WM, X, Y, YH, YH1, YPOUT - LOGICAL INTOUT - CHARACTER*8 XERN1 - CHARACTER*16 XERN3, XERN4 -C - DIMENSION Y(*),YPOUT(*),YH(NEQ,6),YH1(*),EWT(*),SAVF(*), - 1 ACOR(*),WM(*),IWM(*),RTOL(*),ATOL(*),RPAR(*),IPAR(*) -C -C - COMMON /DDEBD1/ TOLD,ROWNS(210),EL0,H,HMIN,HMXI,HU,X,U,IQUIT,INIT, - 1 LYH,LEWT,LACOR,LSAVF,LWM,KSTEPS,IBEGIN,ITOL, - 2 IINTEG,ITSTOP,IJAC,IBAND,IOWNS(6),IER,JSTART, - 3 KFLAG,LDUM,METH,MITER,MAXORD,N,NQ,NST,NFE,NJE,NQU -C - EXTERNAL DF, DJAC -C -C .................................................................. -C -C THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE -C NUMBER OF STEPS ATTEMPTED. WHEN THIS EXCEEDS MAXNUM, THE -C COUNTER IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE -C EXCESSIVE WORK. - SAVE MAXNUM -C - DATA MAXNUM /500/ -C -C .................................................................. -C -C***FIRST EXECUTABLE STATEMENT DLSOD - IF (IBEGIN .EQ. 0) THEN -C -C ON THE FIRST CALL , PERFORM INITIALIZATION -- -C DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY U BY CALLING THE -C FUNCTION ROUTINE D1MACH. THE USER MUST MAKE SURE THAT THE -C VALUES SET IN D1MACH ARE RELEVANT TO THE COMPUTER BEING USED. -C - U = D1MACH(4) -C -- SET ASSOCIATED MACHINE DEPENDENT PARAMETER - WM(1) = SQRT(U) -C -- SET TERMINATION FLAG - IQUIT = 0 -C -- SET INITIALIZATION INDICATOR - INIT = 0 -C -- SET COUNTER FOR ATTEMPTED STEPS - KSTEPS = 0 -C -- SET INDICATOR FOR INTERMEDIATE-OUTPUT - INTOUT = .FALSE. -C -- SET START INDICATOR FOR DSTOD CODE - JSTART = 0 -C -- SET BDF METHOD INDICATOR - METH = 2 -C -- SET MAXIMUM ORDER FOR BDF METHOD - MAXORD = 5 -C -- SET ITERATION MATRIX INDICATOR -C - IF (IJAC .EQ. 0 .AND. IBAND .EQ. 0) MITER = 2 - IF (IJAC .EQ. 1 .AND. IBAND .EQ. 0) MITER = 1 - IF (IJAC .EQ. 0 .AND. IBAND .EQ. 1) MITER = 5 - IF (IJAC .EQ. 1 .AND. IBAND .EQ. 1) MITER = 4 -C -C -- SET OTHER NECESSARY ITEMS IN COMMON BLOCK - N = NEQ - NST = 0 - NJE = 0 - HMXI = 0.0D0 - NQ = 1 - H = 1.0D0 -C -- RESET IBEGIN FOR SUBSEQUENT CALLS - IBEGIN = 1 - ENDIF -C -C .................................................................. -C -C CHECK VALIDITY OF INPUT PARAMETERS ON EACH ENTRY -C - IF (NEQ .LT. 1) THEN - WRITE (XERN1, '(I8)') NEQ - CALL XERMSG ('SLATEC', 'DLSOD', - * 'IN DDEBDF, THE NUMBER OF EQUATIONS MUST BE A ' // - * 'POSITIVE INTEGER.$$YOU HAVE CALLED THE CODE WITH NEQ = ' // - * XERN1, 6, 1) - IDID=-33 - ENDIF -C - NRTOLP = 0 - NATOLP = 0 - DO 60 K = 1, NEQ - IF (NRTOLP .LE. 0) THEN - IF (RTOL(K) .LT. 0.) THEN - WRITE (XERN1, '(I8)') K - WRITE (XERN3, '(1PE15.6)') RTOL(K) - CALL XERMSG ('SLATEC', 'DLSOD', - * 'IN DDEBDF, THE RELATIVE ERROR TOLERANCES MUST ' // - * 'BE NON-NEGATIVE.$$YOU HAVE CALLED THE CODE WITH ' // - * 'RTOL(' // XERN1 // ') = ' // XERN3 // '$$IN THE ' // - * 'CASE OF VECTOR ERROR TOLERANCES, NO FURTHER ' // - * 'CHECKING OF RTOL COMPONENTS IS DONE.', 7, 1) - IDID = -33 - IF (NATOLP .GT. 0) GO TO 70 - NRTOLP = 1 - ELSEIF (NATOLP .GT. 0) THEN - GO TO 50 - ENDIF - ENDIF -C - IF (ATOL(K) .LT. 0.) THEN - WRITE (XERN1, '(I8)') K - WRITE (XERN3, '(1PE15.6)') ATOL(K) - CALL XERMSG ('SLATEC', 'DLSOD', - * 'IN DDEBDF, THE ABSOLUTE ERROR ' // - * 'TOLERANCES MUST BE NON-NEGATIVE.$$YOU HAVE CALLED ' // - * 'THE CODE WITH ATOL(' // XERN1 // ') = ' // XERN3 // - * '$$IN THE CASE OF VECTOR ERROR TOLERANCES, NO FURTHER ' - * // 'CHECKING OF ATOL COMPONENTS IS DONE.', 8, 1) - IDID=-33 - IF (NRTOLP .GT. 0) GO TO 70 - NATOLP=1 - ENDIF - 50 IF (ITOL .EQ. 0) GO TO 70 - 60 CONTINUE -C - 70 IF (ITSTOP .EQ. 1) THEN - IF (SIGN(1.0D0,TOUT-T) .NE. SIGN(1.0D0,TSTOP-T) .OR. - 1 ABS(TOUT-T) .GT. ABS(TSTOP-T)) THEN - WRITE (XERN3, '(1PE15.6)') TOUT - WRITE (XERN4, '(1PE15.6)') TSTOP - CALL XERMSG ('SLATEC', 'DLSOD', - * 'IN DDEBDF, YOU HAVE CALLED THE ' // - * 'CODE WITH TOUT = ' // XERN3 // '$$BUT YOU HAVE ' // - * 'ALSO TOLD THE CODE NOT TO INTEGRATE PAST THE POINT ' // - * 'TSTOP = ' // XERN4 // ' BY SETTING INFO(4) = 1.$$' // - * 'THESE INSTRUCTIONS CONFLICT.', 14, 1) - IDID=-33 - ENDIF - ENDIF -C -C CHECK SOME CONTINUATION POSSIBILITIES -C - IF (INIT .NE. 0) THEN - IF (T .EQ. TOUT) THEN - WRITE (XERN3, '(1PE15.6)') T - CALL XERMSG ('SLATEC', 'DLSOD', - * 'IN DDEBDF, YOU HAVE CALLED THE CODE WITH T = TOUT = ' // - * XERN3 // '$$THIS IS NOT ALLOWED ON CONTINUATION CALLS.', - * 9, 1) - IDID=-33 - ENDIF -C - IF (T .NE. TOLD) THEN - WRITE (XERN3, '(1PE15.6)') TOLD - WRITE (XERN4, '(1PE15.6)') T - CALL XERMSG ('SLATEC', 'DLSOD', - * 'IN DDEBDF, YOU HAVE CHANGED THE VALUE OF T FROM ' // - * XERN3 // ' TO ' // XERN4 // - * ' THIS IS NOT ALLOWED ON CONTINUATION CALLS.', 10, 1) - IDID=-33 - ENDIF -C - IF (INIT .NE. 1) THEN - IF (DELSGN*(TOUT-T) .LT. 0.0D0) THEN - WRITE (XERN3, '(1PE15.6)') TOUT - CALL XERMSG ('SLATEC', 'DLSOD', - * 'IN DDEBDF, BY CALLING THE CODE WITH TOUT = ' // - * XERN3 // ' YOU ARE ATTEMPTING TO CHANGE THE ' // - * 'DIRECTION OF INTEGRATION.$$THIS IS NOT ALLOWED ' // - * 'WITHOUT RESTARTING.', 11, 1) - IDID=-33 - ENDIF - ENDIF - ENDIF -C - IF (IDID .EQ. (-33)) THEN - IF (IQUIT .NE. (-33)) THEN -C INVALID INPUT DETECTED - IQUIT=-33 - IBEGIN=-1 - ELSE - CALL XERMSG ('SLATEC', 'DLSOD', - * 'IN DDEBDF, INVALID INPUT WAS DETECTED ON ' // - * 'SUCCESSIVE ENTRIES. IT IS IMPOSSIBLE TO PROCEED ' // - * 'BECAUSE YOU HAVE NOT CORRECTED THE PROBLEM, ' // - * 'SO EXECUTION IS BEING TERMINATED.', 12, 2) - ENDIF - RETURN - ENDIF -C -C ............................................................... -C -C RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND INTERPRETED -C AS ASKING FOR THE MOST ACCURATE SOLUTION POSSIBLE. IN THIS -C CASE, THE RELATIVE ERROR TOLERANCE RTOL IS RESET TO THE -C SMALLEST VALUE 100*U WHICH IS LIKELY TO BE REASONABLE FOR -C THIS METHOD AND MACHINE -C - DO 180 K = 1, NEQ - IF (RTOL(K) + ATOL(K) .GT. 0.0D0) GO TO 170 - RTOL(K) = 100.0D0*U - IDID = -2 - 170 CONTINUE -C ...EXIT - IF (ITOL .EQ. 0) GO TO 190 - 180 CONTINUE - 190 CONTINUE -C - IF (IDID .NE. (-2)) GO TO 200 -C RTOL=ATOL=0 ON INPUT, SO RTOL IS CHANGED TO A -C SMALL POSITIVE VALUE - IBEGIN = -1 - GO TO 460 - 200 CONTINUE -C BEGIN BLOCK PERMITTING ...EXITS TO 450 -C BEGIN BLOCK PERMITTING ...EXITS TO 430 -C BEGIN BLOCK PERMITTING ...EXITS TO 260 -C BEGIN BLOCK PERMITTING ...EXITS TO 230 -C -C BRANCH ON STATUS OF INITIALIZATION INDICATOR -C INIT=0 MEANS INITIAL DERIVATIVES AND -C NOMINAL STEP SIZE -C AND DIRECTION NOT YET SET -C INIT=1 MEANS NOMINAL STEP SIZE AND -C DIRECTION NOT YET SET INIT=2 MEANS NO -C FURTHER INITIALIZATION REQUIRED -C - IF (INIT .EQ. 0) GO TO 210 -C ......EXIT - IF (INIT .EQ. 1) GO TO 230 -C .........EXIT - GO TO 260 - 210 CONTINUE -C -C ................................................ -C -C MORE INITIALIZATION -- -C -- EVALUATE INITIAL -C DERIVATIVES -C - INIT = 1 - CALL DF(T,Y,YH(1,2),RPAR,IPAR) - NFE = 1 -C ...EXIT - IF (T .NE. TOUT) GO TO 230 - IDID = 2 - DO 220 L = 1, NEQ - YPOUT(L) = YH(L,2) - 220 CONTINUE - TOLD = T -C ............EXIT - GO TO 450 - 230 CONTINUE -C -C -- COMPUTE INITIAL STEP SIZE -C -- SAVE SIGN OF INTEGRATION DIRECTION -C -- SET INDEPENDENT AND DEPENDENT VARIABLES -C X AND YH(*) FOR DSTOD -C - LTOL = 1 - DO 240 L = 1, NEQ - IF (ITOL .EQ. 1) LTOL = L - TOL = RTOL(LTOL)*ABS(Y(L)) + ATOL(LTOL) - IF (TOL .EQ. 0.0D0) GO TO 390 - EWT(L) = TOL - 240 CONTINUE -C - BIG = SQRT(D1MACH(2)) - CALL DHSTRT(DF,NEQ,T,TOUT,Y,YH(1,2),EWT,1,U,BIG, - 1 YH(1,3),YH(1,4),YH(1,5),YH(1,6),RPAR, - 2 IPAR,H) -C - DELSGN = SIGN(1.0D0,TOUT-T) - X = T - DO 250 L = 1, NEQ - YH(L,1) = Y(L) - YH(L,2) = H*YH(L,2) - 250 CONTINUE - INIT = 2 - 260 CONTINUE -C -C ...................................................... -C -C ON EACH CALL SET INFORMATION WHICH DETERMINES THE -C ALLOWED INTERVAL OF INTEGRATION BEFORE RETURNING -C WITH AN ANSWER AT TOUT -C - DEL = TOUT - T - ABSDEL = ABS(DEL) -C -C ...................................................... -C -C IF ALREADY PAST OUTPUT POINT, INTERPOLATE AND -C RETURN -C - 270 CONTINUE -C BEGIN BLOCK PERMITTING ...EXITS TO 400 -C BEGIN BLOCK PERMITTING ...EXITS TO 380 - IF (ABS(X-T) .LT. ABSDEL) GO TO 290 - CALL DINTYD(TOUT,0,YH,NEQ,Y,INTFLG) - CALL DINTYD(TOUT,1,YH,NEQ,YPOUT,INTFLG) - IDID = 3 - IF (X .NE. TOUT) GO TO 280 - IDID = 2 - INTOUT = .FALSE. - 280 CONTINUE - T = TOUT - TOLD = T -C ..................EXIT - GO TO 450 - 290 CONTINUE -C -C IF CANNOT GO PAST TSTOP AND SUFFICIENTLY -C CLOSE, EXTRAPOLATE AND RETURN -C - IF (ITSTOP .NE. 1) GO TO 310 - IF (ABS(TSTOP-X) .GE. 100.0D0*U*ABS(X)) - 1 GO TO 310 - DT = TOUT - X - DO 300 L = 1, NEQ - Y(L) = YH(L,1) + (DT/H)*YH(L,2) - 300 CONTINUE - CALL DF(TOUT,Y,YPOUT,RPAR,IPAR) - NFE = NFE + 1 - IDID = 3 - T = TOUT - TOLD = T -C ..................EXIT - GO TO 450 - 310 CONTINUE -C - IF (IINTEG .EQ. 0 .OR. .NOT.INTOUT) GO TO 320 -C -C INTERMEDIATE-OUTPUT MODE -C - IDID = 1 - GO TO 370 - 320 CONTINUE -C -C ............................................. -C -C MONITOR NUMBER OF STEPS ATTEMPTED -C - IF (KSTEPS .LE. MAXNUM) GO TO 330 -C -C A SIGNIFICANT AMOUNT OF WORK HAS BEEN -C EXPENDED - IDID = -1 - KSTEPS = 0 - IBEGIN = -1 - GO TO 370 - 330 CONTINUE -C -C .......................................... -C -C LIMIT STEP SIZE AND SET WEIGHT VECTOR -C - HMIN = 100.0D0*U*ABS(X) - HA = MAX(ABS(H),HMIN) - IF (ITSTOP .EQ. 1) - 1 HA = MIN(HA,ABS(TSTOP-X)) - H = SIGN(HA,H) - LTOL = 1 - DO 340 L = 1, NEQ - IF (ITOL .EQ. 1) LTOL = L - EWT(L) = RTOL(LTOL)*ABS(YH(L,1)) - 1 + ATOL(LTOL) -C .........EXIT - IF (EWT(L) .LE. 0.0D0) GO TO 380 - 340 CONTINUE - TOLFAC = U*DVNRMS(NEQ,YH,EWT) -C .........EXIT - IF (TOLFAC .LE. 1.0D0) GO TO 400 -C -C TOLERANCES TOO SMALL - IDID = -2 - TOLFAC = 2.0D0*TOLFAC - RTOL(1) = TOLFAC*RTOL(1) - ATOL(1) = TOLFAC*ATOL(1) - IF (ITOL .EQ. 0) GO TO 360 - DO 350 L = 2, NEQ - RTOL(L) = TOLFAC*RTOL(L) - ATOL(L) = TOLFAC*ATOL(L) - 350 CONTINUE - 360 CONTINUE - IBEGIN = -1 - 370 CONTINUE -C ............EXIT - GO TO 430 - 380 CONTINUE -C -C RELATIVE ERROR CRITERION INAPPROPRIATE - 390 CONTINUE - IDID = -3 - IBEGIN = -1 -C .........EXIT - GO TO 430 - 400 CONTINUE -C -C ................................................... -C -C TAKE A STEP -C - CALL DSTOD(NEQ,Y,YH,NEQ,YH1,EWT,SAVF,ACOR,WM,IWM, - 1 DF,DJAC,RPAR,IPAR) -C - JSTART = -2 - INTOUT = .TRUE. - IF (KFLAG .EQ. 0) GO TO 270 -C -C ...................................................... -C - IF (KFLAG .EQ. -1) GO TO 410 -C -C REPEATED CORRECTOR CONVERGENCE FAILURES - IDID = -6 - IBEGIN = -1 - GO TO 420 - 410 CONTINUE -C -C REPEATED ERROR TEST FAILURES - IDID = -7 - IBEGIN = -1 - 420 CONTINUE - 430 CONTINUE -C -C ......................................................... -C -C STORE VALUES BEFORE RETURNING TO -C DDEBDF - DO 440 L = 1, NEQ - Y(L) = YH(L,1) - YPOUT(L) = YH(L,2)/H - 440 CONTINUE - T = X - TOLD = T - INTOUT = .FALSE. - 450 CONTINUE - 460 CONTINUE - RETURN - END diff --git a/slatec/dlssud.f b/slatec/dlssud.f deleted file mode 100644 index e298dd0..0000000 --- a/slatec/dlssud.f +++ /dev/null @@ -1,318 +0,0 @@ -*DECK DLSSUD - SUBROUTINE DLSSUD (A, X, B, N, M, NRDA, U, NRDU, IFLAG, MLSO, - + IRANK, ISCALE, Q, DIAG, KPIVOT, S, DIV, TD, ISFLG, SCALES) -C***BEGIN PROLOGUE DLSSUD -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBVSUP and DSUDS -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (LSSUDS-S, DLSSUD-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C DLSSUD solves the underdetermined system of equations A Z = B, -C where A is N by M and N .LE. M. In particular, if rank A equals -C IRA, a vector X and a matrix U are determined such that X is the -C UNIQUE solution of smallest length, satisfying A X = B, and the -C columns of U form an orthonormal basis for the null space of A, -C satisfying A U = 0 . Then all solutions Z are given by -C Z = X + C(1)*U(1) + ..... + C(M-IRA)*U(M-IRA) -C where U(J) represents the J-th column of U and the C(J) are -C arbitrary constants. -C If the system of equations are not compatible, only the least -C squares solution of minimal length is computed. -C -C ********************************************************************* -C INPUT -C ********************************************************************* -C -C A -- Contains the matrix of N equations in M unknowns, A remains -C unchanged, must be dimensioned NRDA by M. -C X -- Solution array of length at least M. -C B -- Given constant vector of length N, B remains unchanged. -C N -- Number of equations, N greater or equal to 1. -C M -- Number of unknowns, M greater or equal to N. -C NRDA -- Row dimension of A, NRDA greater or equal to N. -C U -- Matrix used for solution, must be dimensioned NRDU by -C (M - rank of A). -C (storage for U may be ignored when only the minimal length -C solution X is desired) -C NRDU -- Row dimension of U, NRDU greater or equal to M. -C (if only the minimal length solution is wanted, -C NRDU=0 is acceptable) -C IFLAG -- Status indicator -C =0 for the first call (and for each new problem defined by -C a new matrix A) when the matrix data is treated as exact -C =-K for the first call (and for each new problem defined by -C a new matrix A) when the matrix data is assumed to be -C accurate to about K digits. -C =1 for subsequent calls whenever the matrix A has already -C been decomposed (problems with new vectors B but -C same matrix A can be handled efficiently). -C MLSO -- =0 if only the minimal length solution is wanted. -C =1 if the complete solution is wanted, includes the -C linear space defined by the matrix U. -C IRANK -- Variable used for the rank of A, set by the code. -C ISCALE -- Scaling indicator -C =-1 if the matrix A is to be pre-scaled by -C columns when appropriate. -C If the scaling indicator is not equal to -1 -C no scaling will be attempted. -C For most problems scaling will probably not be necessary. -C Q -- Matrix used for the transformation, must be dimensioned -C NRDA by M. -C DIAG,KPIVOT,S, -- Arrays of length at least N used for internal -C DIV,TD,SCALES storage (except for SCALES which is M). -C ISFLG -- Storage for an internal variable. -C -C ********************************************************************* -C OUTPUT -C ********************************************************************* -C -C IFLAG -- Status indicator -C =1 if solution was obtained. -C =2 if improper input is detected. -C =3 if rank of matrix is less than N. -C To continue, simply reset IFLAG=1 and call DLSSUD again. -C =4 if the system of equations appears to be inconsistent. -C However, the least squares solution of minimal length -C was obtained. -C X -- Minimal length least squares solution of A Z = B -C IRANK -- Numerically determined rank of A, must not be altered -C on succeeding calls with input values of IFLAG=1. -C U -- Matrix whose M-IRANK columns are mutually orthogonal unit -C vectors which span the null space of A. This is to be ignored -C when MLSO was set to zero or IFLAG=4 on output. -C Q -- Contains the strictly upper triangular part of the reduced -C matrix and transformation information. -C DIAG -- Contains the diagonal elements of the triangular reduced -C matrix. -C KPIVOT -- Contains the pivotal information. The row interchanges -C performed on the original matrix are recorded here. -C S -- Contains the solution of the lower triangular system. -C DIV,TD -- Contains transformation information for rank -C deficient problems. -C SCALES -- Contains the column scaling parameters. -C -C ********************************************************************* -C -C***SEE ALSO DBVSUP, DSUDS -C***REFERENCES H. A. Watts, Solving linear least squares problems -C using SODS/SUDS/CODS, Sandia Report SAND77-0683, -C Sandia Laboratories, 1977. -C***ROUTINES CALLED D1MACH, DDOT, DOHTRL, DORTHR, J4SAVE, XERMAX, -C XERMSG, XGETF, XSETF -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 910408 Updated the AUTHOR and REFERENCES sections. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DLSSUD - INTEGER J4SAVE - DOUBLE PRECISION DDOT, D1MACH - INTEGER I, IFLAG, IRANK, IRP, ISCALE, ISFLG, J, JR, K, KP, - 1 KPIVOT(*), L, M, MAXMES, MJ, MLSO, N, NFAT, NFATAL, NMIR, - 2 NRDA, NRDU, NU - DOUBLE PRECISION A(NRDA,*), B(*), DIAG(*), DIV(*), GAM, GAMMA, - 1 Q(NRDA,*), RES, S(*), SCALES(*), SS, TD(*), U(NRDU,*), URO, - 2 X(*) -C -C ****************************************************************** -C -C MACHINE PRECISION (COMPUTER UNIT ROUNDOFF VALUE) IS DEFINED -C BY THE FUNCTION D1MACH. -C -C ****************************************************************** -C -C BEGIN BLOCK PERMITTING ...EXITS TO 310 -C BEGIN BLOCK PERMITTING ...EXITS TO 80 -C***FIRST EXECUTABLE STATEMENT DLSSUD - URO = D1MACH(4) -C - IF (N .LT. 1 .OR. M .LT. N .OR. NRDA .LT. N) GO TO 70 - IF (NRDU .NE. 0 .AND. NRDU .LT. M) GO TO 70 - IF (IFLAG .GT. 0) GO TO 60 -C - CALL XGETF(NFATAL) - MAXMES = J4SAVE(4,0,.FALSE.) - ISFLG = -15 - IF (IFLAG .EQ. 0) GO TO 10 - ISFLG = IFLAG - NFAT = -1 - IF (NFATAL .EQ. 0) NFAT = 0 - CALL XSETF(NFAT) - CALL XERMAX(1) - 10 CONTINUE -C -C COPY MATRIX A INTO MATRIX Q -C - DO 30 K = 1, M - DO 20 J = 1, N - Q(J,K) = A(J,K) - 20 CONTINUE - 30 CONTINUE -C -C USE ORTHOGONAL TRANSFORMATIONS TO REDUCE Q TO LOWER -C TRIANGULAR FORM -C - CALL DORTHR(Q,N,M,NRDA,IFLAG,IRANK,ISCALE,DIAG,KPIVOT, - 1 SCALES,DIV,TD) -C - CALL XSETF(NFATAL) - CALL XERMAX(MAXMES) - IF (IRANK .EQ. N) GO TO 40 -C -C FOR RANK DEFICIENT PROBLEMS USE ADDITIONAL -C ORTHOGONAL TRANSFORMATIONS TO FURTHER REDUCE Q -C - IF (IRANK .NE. 0) - 1 CALL DOHTRL(Q,N,NRDA,DIAG,IRANK,DIV,TD) -C ...............EXIT - GO TO 310 - 40 CONTINUE -C -C STORE DIVISORS FOR THE TRIANGULAR SOLUTION -C - DO 50 K = 1, N - DIV(K) = DIAG(K) - 50 CONTINUE -C .........EXIT - GO TO 80 - 60 CONTINUE -C ......EXIT - IF (IFLAG .EQ. 1) GO TO 80 - 70 CONTINUE -C -C INVALID INPUT FOR DLSSUD - IFLAG = 2 - CALL XERMSG ('SLATEC', 'DLSSUD', - + 'INVALID IMPUT PARAMETERS.', 2, 1) -C ......EXIT - GO TO 310 - 80 CONTINUE -C -C - IF (IRANK .GT. 0) GO TO 130 -C -C SPECIAL CASE FOR THE NULL MATRIX - DO 110 K = 1, M - X(K) = 0.0D0 - IF (MLSO .EQ. 0) GO TO 100 - U(K,K) = 1.0D0 - DO 90 J = 1, M - IF (J .NE. K) U(J,K) = 0.0D0 - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE - DO 120 K = 1, N - IF (B(K) .GT. 0.0D0) IFLAG = 4 - 120 CONTINUE - GO TO 300 - 130 CONTINUE -C BEGIN BLOCK PERMITTING ...EXITS TO 180 -C -C COPY CONSTANT VECTOR INTO S AFTER FIRST INTERCHANGING -C THE ELEMENTS ACCORDING TO THE PIVOTAL SEQUENCE -C - DO 140 K = 1, N - KP = KPIVOT(K) - X(K) = B(KP) - 140 CONTINUE - DO 150 K = 1, N - S(K) = X(K) - 150 CONTINUE -C - IRP = IRANK + 1 - NU = 1 - IF (MLSO .EQ. 0) NU = 0 -C ...EXIT - IF (IRANK .EQ. N) GO TO 180 -C -C FOR RANK DEFICIENT PROBLEMS WE MUST APPLY THE -C ORTHOGONAL TRANSFORMATION TO S -C WE ALSO CHECK TO SEE IF THE SYSTEM APPEARS TO BE -C INCONSISTENT -C - NMIR = N - IRANK - SS = DDOT(N,S(1),1,S(1),1) - DO 170 L = 1, IRANK - K = IRP - L - GAM = ((TD(K)*S(K)) + DDOT(NMIR,Q(IRP,K),1,S(IRP),1)) - 1 /(TD(K)*DIV(K)) - S(K) = S(K) + GAM*TD(K) - DO 160 J = IRP, N - S(J) = S(J) + GAM*Q(J,K) - 160 CONTINUE - 170 CONTINUE - RES = DDOT(NMIR,S(IRP),1,S(IRP),1) -C ...EXIT - IF (RES - 1 .LE. SS*(10.0D0*MAX(10.0D0**ISFLG,10.0D0*URO))**2) - 2 GO TO 180 -C -C INCONSISTENT SYSTEM - IFLAG = 4 - NU = 0 - 180 CONTINUE -C -C APPLY FORWARD SUBSTITUTION TO SOLVE LOWER TRIANGULAR SYSTEM -C - S(1) = S(1)/DIV(1) - IF (IRANK .LT. 2) GO TO 200 - DO 190 K = 2, IRANK - S(K) = (S(K) - DDOT(K-1,Q(K,1),NRDA,S(1),1))/DIV(K) - 190 CONTINUE - 200 CONTINUE -C -C INITIALIZE X VECTOR AND THEN APPLY ORTHOGONAL TRANSFORMATION -C - DO 210 K = 1, M - X(K) = 0.0D0 - IF (K .LE. IRANK) X(K) = S(K) - 210 CONTINUE -C - DO 230 JR = 1, IRANK - J = IRP - JR - MJ = M - J + 1 - GAMMA = DDOT(MJ,Q(J,J),NRDA,X(J),1)/(DIAG(J)*Q(J,J)) - DO 220 K = J, M - X(K) = X(K) + GAMMA*Q(J,K) - 220 CONTINUE - 230 CONTINUE -C -C RESCALE ANSWERS AS DICTATED -C - DO 240 K = 1, M - X(K) = X(K)*SCALES(K) - 240 CONTINUE -C - IF (NU .EQ. 0 .OR. M .EQ. IRANK) GO TO 290 -C -C INITIALIZE U MATRIX AND THEN APPLY ORTHOGONAL -C TRANSFORMATION -C - L = M - IRANK - DO 280 K = 1, L - DO 250 I = 1, M - U(I,K) = 0.0D0 - IF (I .EQ. IRANK + K) U(I,K) = 1.0D0 - 250 CONTINUE -C - DO 270 JR = 1, IRANK - J = IRP - JR - MJ = M - J + 1 - GAMMA = DDOT(MJ,Q(J,J),NRDA,U(J,K),1) - 1 /(DIAG(J)*Q(J,J)) - DO 260 I = J, M - U(I,K) = U(I,K) + GAMMA*Q(J,I) - 260 CONTINUE - 270 CONTINUE - 280 CONTINUE - 290 CONTINUE - 300 CONTINUE - 310 CONTINUE -C - RETURN - END diff --git a/slatec/dmacon.f b/slatec/dmacon.f deleted file mode 100644 index 8de68ae..0000000 --- a/slatec/dmacon.f +++ /dev/null @@ -1,35 +0,0 @@ -*DECK DMACON - SUBROUTINE DMACON -C***BEGIN PROLOGUE DMACON -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBVSUP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (MACON-S, DMACON-D) -C***AUTHOR (UNKNOWN) -C***SEE ALSO DBVSUP -C***ROUTINES CALLED D1MACH -C***COMMON BLOCKS DML5MC -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890921 Realigned order of variables in certain COMMON blocks. -C (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DMACON - DOUBLE PRECISION D1MACH - INTEGER KE, LPAR - DOUBLE PRECISION DD, EPS, FOURU, SQOVFL, SRU, TWOU, URO - COMMON /DML5MC/ URO,SRU,EPS,SQOVFL,TWOU,FOURU,LPAR -C***FIRST EXECUTABLE STATEMENT DMACON - URO = D1MACH(4) - SRU = SQRT(URO) - DD = -LOG10(URO) - LPAR = 0.5D0*DD - KE = 0.5D0 + 0.75D0*DD - EPS = 10.0D0**(-2*KE) - SQOVFL = SQRT(D1MACH(2)) - TWOU = 2.0D0*URO - FOURU = 4.0D0*URO - RETURN - END diff --git a/slatec/dmgsbv.f b/slatec/dmgsbv.f deleted file mode 100644 index d405266..0000000 --- a/slatec/dmgsbv.f +++ /dev/null @@ -1,309 +0,0 @@ -*DECK DMGSBV - SUBROUTINE DMGSBV (M, N, A, IA, NIV, IFLAG, S, P, IP, INHOMO, V, - + W, WCND) -C***BEGIN PROLOGUE DMGSBV -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBVSUP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (MGSBV-S, DMGSBV-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C ********************************************************************** -C Orthogonalize a set of N double precision vectors and determine their -C rank. -C -C ********************************************************************** -C INPUT -C ********************************************************************** -C M = dimension of vectors. -C N = no. of vectors. -C A = array whose first N cols contain the vectors. -C IA = first dimension of array A (col length). -C NIV = number of independent vectors needed. -C INHOMO = 1 corresponds to having a non-zero particular solution. -C V = particular solution vector (not included in the pivoting). -C INDPVT = 1 means pivoting will not be used. -C -C ********************************************************************** -C OUTPUT -C ********************************************************************** -C NIV = no. of linear independent vectors in input set. -C A = matrix whose first NIV cols. contain NIV orthogonal vectors -C which span the vector space determined by the input vectors. -C IFLAG -C = 0 success -C = 1 incorrect input -C = 2 rank of new vectors less than N -C P = decomposition matrix. P is upper triangular and -C (old vectors) = (new vectors) * P. -C The old vectors will be reordered due to pivoting. -C The dimension of P must be .GE. N*(N+1)/2. -C ( N*(2*N+1) when N .NE. NFCC ) -C IP = pivoting vector. The dimension of IP must be .GE. N. -C ( 2*N when N .NE. NFCC ) -C S = square of norms of incoming vectors. -C V = vector which is orthogonal to the vectors of A. -C W = orthogonalization information for the vector V. -C WCND = worst case (smallest) norm decrement value of the -C vectors being orthogonalized (represents a test -C for linear dependence of the vectors). -C ********************************************************************** -C -C***SEE ALSO DBVSUP -C***ROUTINES CALLED DDOT, DPRVEC -C***COMMON BLOCKS DML18J, DML5MC -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 890921 Realigned order of variables in certain COMMON blocks. -C (WRB) -C 890921 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DMGSBV -C - DOUBLE PRECISION DDOT, DPRVEC - INTEGER I, IA, ICOCO, IFLAG, INDPVT, INHOMO, INTEG, IP(*), IP1, - 1 IX, IZ, J, JK, JP, JQ, JY, JZ, K, KD, KJ, KP, L, LIX, LPAR, - 2 LR, M, M2, MXNON, N, NDISK, NEQ, NEQIVP, NFCC, NIC, NIV, - 3 NIVN, NMNR, NN, NOPG, NP1, NPS, NR, NRM1, NTAPE, NTP, - 4 NUMORT, NXPTS - DOUBLE PRECISION A(IA,*), AE, DOT, EPS, FOURU, P(*), PJP, PSAVE, - 1 RE, RY, S(*), SQOVFL, SRU, SV, T, TOL, TWOU, URO, V(*), VL, - 2 VNORM, W(*), WCND, Y -C -C - COMMON /DML18J/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ, - 1 INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,NFCC, - 2 ICOCO -C - COMMON /DML5MC/ URO,SRU,EPS,SQOVFL,TWOU,FOURU,LPAR -C -C***FIRST EXECUTABLE STATEMENT DMGSBV - IF (M .GT. 0 .AND. N .GT. 0 .AND. IA .GE. M) GO TO 10 - IFLAG = 1 - GO TO 280 - 10 CONTINUE -C BEGIN BLOCK PERMITTING ...EXITS TO 270 -C BEGIN BLOCK PERMITTING ...EXITS TO 260 -C - JP = 0 - IFLAG = 0 - NP1 = N + 1 - Y = 0.0D0 - M2 = M/2 -C -C CALCULATE SQUARE OF NORMS OF INCOMING VECTORS AND SEARCH -C FOR VECTOR WITH LARGEST MAGNITUDE -C - J = 0 - DO 40 I = 1, N - VL = DDOT(M,A(1,I),1,A(1,I),1) - S(I) = VL - IF (N .EQ. NFCC) GO TO 20 - J = 2*I - 1 - P(J) = VL - IP(J) = J - 20 CONTINUE - J = J + 1 - P(J) = VL - IP(J) = J - IF (VL .LE. Y) GO TO 30 - Y = VL - IX = I - 30 CONTINUE - 40 CONTINUE - IF (INDPVT .NE. 1) GO TO 50 - IX = 1 - Y = P(1) - 50 CONTINUE - LIX = IX - IF (N .NE. NFCC) LIX = 2*IX - 1 - P(LIX) = P(1) - S(NP1) = 0.0D0 - IF (INHOMO .EQ. 1) S(NP1) = DDOT(M,V,1,V,1) - WCND = 1.0D0 - NIVN = NIV - NIV = 0 -C -C ...EXIT - IF (Y .EQ. 0.0D0) GO TO 260 -C ********************************************************* - DO 240 NR = 1, N -C BEGIN BLOCK PERMITTING ...EXITS TO 230 -C ......EXIT - IF (NIVN .EQ. NIV) GO TO 250 - NIV = NR - IF (IX .EQ. NR) GO TO 130 -C -C PIVOTING OF COLUMNS OF P MATRIX -C - NN = N - LIX = IX - LR = NR - IF (N .EQ. NFCC) GO TO 60 - NN = NFCC - LIX = 2*IX - 1 - LR = 2*NR - 1 - 60 CONTINUE - IF (NR .EQ. 1) GO TO 80 - KD = LIX - LR - KJ = LR - NRM1 = LR - 1 - DO 70 J = 1, NRM1 - PSAVE = P(KJ) - JK = KJ + KD - P(KJ) = P(JK) - P(JK) = PSAVE - KJ = KJ + NN - J - 70 CONTINUE - JY = JK + NMNR - JZ = JY - KD - P(JY) = P(JZ) - 80 CONTINUE - IZ = IP(LIX) - IP(LIX) = IP(LR) - IP(LR) = IZ - SV = S(IX) - S(IX) = S(NR) - S(NR) = SV - IF (N .EQ. NFCC) GO TO 110 - IF (NR .EQ. 1) GO TO 100 - KJ = LR + 1 - DO 90 K = 1, NRM1 - PSAVE = P(KJ) - JK = KJ + KD - P(KJ) = P(JK) - P(JK) = PSAVE - KJ = KJ + NFCC - K - 90 CONTINUE - 100 CONTINUE - IZ = IP(LIX+1) - IP(LIX+1) = IP(LR+1) - IP(LR+1) = IZ - 110 CONTINUE -C -C PIVOTING OF COLUMNS OF VECTORS -C - DO 120 L = 1, M - T = A(L,IX) - A(L,IX) = A(L,NR) - A(L,NR) = T - 120 CONTINUE - 130 CONTINUE -C -C CALCULATE P(NR,NR) AS NORM SQUARED OF PIVOTAL -C VECTOR -C - JP = JP + 1 - P(JP) = Y - RY = 1.0D0/Y - NMNR = N - NR - IF (N .EQ. NFCC) GO TO 140 - NMNR = NFCC - (2*NR - 1) - JP = JP + 1 - P(JP) = 0.0D0 - KP = JP + NMNR - P(KP) = Y - 140 CONTINUE - IF (NR .EQ. N .OR. NIVN .EQ. NIV) GO TO 200 -C -C CALCULATE ORTHOGONAL PROJECTION VECTORS AND -C SEARCH FOR LARGEST NORM -C - Y = 0.0D0 - IP1 = NR + 1 - IX = IP1 -C ************************************************ - DO 190 J = IP1, N - DOT = DDOT(M,A(1,NR),1,A(1,J),1) - JP = JP + 1 - JQ = JP + NMNR - IF (N .NE. NFCC) JQ = JQ + NMNR - 1 - P(JQ) = P(JP) - DOT*(DOT*RY) - P(JP) = DOT*RY - DO 150 I = 1, M - A(I,J) = A(I,J) - P(JP)*A(I,NR) - 150 CONTINUE - IF (N .EQ. NFCC) GO TO 170 - KP = JP + NMNR - JP = JP + 1 - PJP = RY*DPRVEC(M,A(1,NR),A(1,J)) - P(JP) = PJP - P(KP) = -PJP - KP = KP + 1 - P(KP) = RY*DOT - DO 160 K = 1, M2 - L = M2 + K - A(K,J) = A(K,J) - PJP*A(L,NR) - A(L,J) = A(L,J) + PJP*A(K,NR) - 160 CONTINUE - P(JQ) = P(JQ) - PJP*(PJP/RY) - 170 CONTINUE -C -C TEST FOR CANCELLATION IN RECURRENCE RELATION -C - IF (P(JQ) .LE. S(J)*SRU) - 1 P(JQ) = DDOT(M,A(1,J),1,A(1,J),1) - IF (P(JQ) .LE. Y) GO TO 180 - Y = P(JQ) - IX = J - 180 CONTINUE - 190 CONTINUE - IF (N .NE. NFCC) JP = KP -C ************************************************ - IF (INDPVT .EQ. 1) IX = IP1 -C -C RECOMPUTE NORM SQUARED OF PIVOTAL VECTOR WITH -C SCALAR PRODUCT -C - Y = DDOT(M,A(1,IX),1,A(1,IX),1) -C ............EXIT - IF (Y .LE. EPS*S(IX)) GO TO 260 - WCND = MIN(WCND,Y/S(IX)) - 200 CONTINUE -C -C COMPUTE ORTHOGONAL PROJECTION OF PARTICULAR -C SOLUTION -C -C ...EXIT - IF (INHOMO .NE. 1) GO TO 230 - LR = NR - IF (N .NE. NFCC) LR = 2*NR - 1 - W(LR) = DDOT(M,A(1,NR),1,V,1)*RY - DO 210 I = 1, M - V(I) = V(I) - W(LR)*A(I,NR) - 210 CONTINUE -C ...EXIT - IF (N .EQ. NFCC) GO TO 230 - LR = 2*NR - W(LR) = RY*DPRVEC(M,V,A(1,NR)) - DO 220 K = 1, M2 - L = M2 + K - V(K) = V(K) + W(LR)*A(L,NR) - V(L) = V(L) - W(LR)*A(K,NR) - 220 CONTINUE - 230 CONTINUE - 240 CONTINUE - 250 CONTINUE -C ********************************************************* -C -C TEST FOR LINEAR DEPENDENCE OF PARTICULAR SOLUTION -C -C ......EXIT - IF (INHOMO .NE. 1) GO TO 270 - IF ((N .GT. 1) .AND. (S(NP1) .LT. 1.0)) GO TO 270 - VNORM = DDOT(M,V,1,V,1) - IF (S(NP1) .NE. 0.0D0) WCND = MIN(WCND,VNORM/S(NP1)) -C ......EXIT - IF (VNORM .GE. EPS*S(NP1)) GO TO 270 - 260 CONTINUE - IFLAG = 2 - WCND = EPS - 270 CONTINUE - 280 CONTINUE - RETURN - END diff --git a/slatec/dmout.f b/slatec/dmout.f deleted file mode 100644 index ca94359..0000000 --- a/slatec/dmout.f +++ /dev/null @@ -1,185 +0,0 @@ -*DECK DMOUT - SUBROUTINE DMOUT (M, N, LDA, A, IFMT, IDIGIT) -C***BEGIN PROLOGUE DMOUT -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBOCLS and DFC -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (SMOUT-S, DMOUT-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C -C DOUBLE PRECISION MATRIX OUTPUT ROUTINE. -C -C INPUT.. -C -C M,N,LDA,A(*,*) PRINT THE DOUBLE PRECISION ARRAY A(I,J),I = 1,...,M, -C J=1,...,N, ON OUTPUT UNIT LOUT=6. LDA IS THE DECLARED -C FIRST DIMENSION OF A(*,*) AS SPECIFIED IN THE CALLING -C PROGRAM. THE HEADING IN THE FORTRAN FORMAT STATEMENT -C IFMT(*), DESCRIBED BELOW, IS PRINTED AS A FIRST STEP. -C THE COMPONENTS A(I,J) ARE INDEXED, ON OUTPUT, IN A -C PLEASANT FORMAT. -C IFMT(*) A FORTRAN FORMAT STATEMENT. THIS IS PRINTED ON -C OUTPUT UNIT LOUT=6 WITH THE VARIABLE FORMAT FORTRAN -C STATEMENT -C WRITE(LOUT,IFMT). -C IDIGIT PRINT AT LEAST ABS(IDIGIT) DECIMAL DIGITS PER NUMBER. -C THE SUBPROGRAM WILL CHOOSE THAT INTEGER 4,6,14,20 OR -C 28 WHICH WILL PRINT AT LEAST ABS(IDIGIT) NUMBER OF -C PLACES. IF IDIGIT.LT.0, 72 PRINTING COLUMNS ARE -C UTILIZED TO WRITE EACH LINE OF OUTPUT OF THE ARRAY -C A(*,*). (THIS CAN BE USED ON MOST TIME-SHARING -C TERMINALS). IF IDIGIT.GE.0, 133 PRINTING COLUMNS ARE -C UTILIZED. (THIS CAN BE USED ON MOST LINE PRINTERS). -C -C EXAMPLE.. -C -C PRINT AN ARRAY CALLED (SIMPLEX TABLEAU ) OF SIZE 10 BY 20 SHOWING -C 6 DECIMAL DIGITS PER NUMBER. THE USER IS RUNNING ON A TIME-SHARING -C SYSTEM WITH A 72 COLUMN OUTPUT DEVICE. -C -C DOUBLE PRECISION TABLEU(20,20) -C M = 10 -C N = 20 -C LDTABL = 20 -C IDIGIT = -6 -C CALL DMOUT(M,N,LDTABL,TABLEU,21H(16H1SIMPLEX TABLEAU),IDIGIT) -C -C***SEE ALSO DBOCLS, DFC -C***ROUTINES CALLED I1MACH -C***REVISION HISTORY (YYMMDD) -C 821220 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891107 Added comma after 1P edit descriptor in FORMAT -C statements. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910403 Updated AUTHOR section. (WRB) -C***END PROLOGUE DMOUT - DOUBLE PRECISION A(LDA,*) - CHARACTER IFMT*(*),ICOL*3 - SAVE ICOL - DATA ICOL /'COL'/ -C***FIRST EXECUTABLE STATEMENT DMOUT - LOUT=I1MACH(2) - WRITE(LOUT,IFMT) - IF(M.LE.0.OR.N.LE.0.OR.LDA.LE.0) RETURN - NDIGIT = IDIGIT - IF(IDIGIT.EQ.0) NDIGIT = 4 - IF(IDIGIT.GE.0) GO TO 80 -C - NDIGIT = -IDIGIT - IF(NDIGIT.GT.4) GO TO 9 -C - DO 5 K1=1,N,5 - K2 = MIN(N,K1+4) - WRITE(LOUT,1010) (ICOL,I,I = K1, K2) - DO 5 I = 1, M - WRITE(LOUT,1009) I,(A(I,J),J = K1, K2) - 5 CONTINUE - RETURN -C - 9 CONTINUE - IF(NDIGIT.GT.6) GO TO 20 -C - DO 10 K1=1,N,4 - K2 = MIN(N,K1+3) - WRITE(LOUT,1000) (ICOL,I,I = K1, K2) - DO 10 I = 1, M - WRITE(LOUT,1004) I,(A(I,J),J = K1, K2) - 10 CONTINUE - RETURN -C - 20 CONTINUE - IF(NDIGIT.GT.14) GO TO 40 -C - DO 30 K1=1,N,2 - K2 = MIN(N,K1+1) - WRITE(LOUT,1001) (ICOL,I,I = K1, K2) - DO 30 I = 1, M - WRITE(LOUT,1005) I,(A(I,J),J = K1, K2) - 30 CONTINUE - RETURN -C - 40 CONTINUE - IF(NDIGIT.GT.20) GO TO 60 -C - DO 50 K1=1,N,2 - K2=MIN(N,K1+1) - WRITE(LOUT,1002) (ICOL,I,I = K1, K2) - DO 50 I = 1, M - WRITE(LOUT,1006) I,(A(I,J),J = K1, K2) - 50 CONTINUE - RETURN -C - 60 CONTINUE - DO 70 K1=1,N - K2 = K1 - WRITE(LOUT,1003) (ICOL,I,I = K1, K2) - DO 70 I = 1, M - WRITE(LOUT,1007) I,(A(I,J),J = K1, K2) - 70 CONTINUE - RETURN -C - 80 CONTINUE - IF(NDIGIT.GT.4) GO TO 86 -C - DO 85 K1=1,N,10 - K2 = MIN(N,K1+9) - WRITE(LOUT,1000) (ICOL,I,I = K1, K2) - DO 85 I = 1, M - WRITE(LOUT,1009) I,(A(I,J),J = K1, K2) - 85 CONTINUE -C -86 IF (NDIGIT.GT.6) GO TO 100 -C - DO 90 K1=1,N,8 - K2 = MIN(N,K1+7) - WRITE(LOUT,1000) (ICOL,I,I = K1, K2) - DO 90 I = 1, M - WRITE(LOUT,1004) I,(A(I,J),J = K1, K2) - 90 CONTINUE - RETURN -C - 100 CONTINUE - IF(NDIGIT.GT.14) GO TO 120 -C - DO 110 K1=1,N,5 - K2 = MIN(N,K1+4) - WRITE(LOUT,1001) (ICOL,I,I = K1, K2) - DO 110 I = 1, M - WRITE(LOUT,1005) I,(A(I,J),J = K1, K2) - 110 CONTINUE - RETURN -C - 120 CONTINUE - IF(NDIGIT.GT.20) GO TO 140 -C - DO 130 K1=1,N,4 - K2 = MIN(N,K1+3) - WRITE(LOUT,1002) (ICOL,I,I = K1, K2) - DO 130 I = 1, M - WRITE(LOUT,1006) I,(A(I,J),J = K1, K2) - 130 CONTINUE - RETURN -C - 140 CONTINUE - DO 150 K1=1,N,3 - K2 = MIN(N,K1+2) - WRITE(LOUT,1003) (ICOL,I,I = K1, K2) - DO 150 I = 1, M - WRITE(LOUT,1007) I,(A(I,J),J = K1, K2) - 150 CONTINUE - RETURN - 1000 FORMAT(10X,8(5X,A,I4,2X)) - 1001 FORMAT(10X,5(9X,A,I4,6X)) - 1002 FORMAT(10X,4(12X,A,I4,9X)) - 1003 FORMAT(10X,3(16X,A,I4,13X)) - 1004 FORMAT(1X,3HROW,I4,2X,1P,8D14.5) - 1005 FORMAT(1X,3HROW,I4,2X,1P,5D22.13) - 1006 FORMAT(1X,3HROW,I4,2X,1P,4D28.19) - 1007 FORMAT(1X,3HROW,I4,2X,1P,3D36.27) - 1009 FORMAT(1X,3HROW,I4,2X,1P,10D12.3) - 1010 FORMAT(10X,10(4X,A,I4,1X)) - END diff --git a/slatec/dmpar.f b/slatec/dmpar.f deleted file mode 100644 index 29f53b5..0000000 --- a/slatec/dmpar.f +++ /dev/null @@ -1,271 +0,0 @@ -*DECK DMPAR - SUBROUTINE DMPAR (N, R, LDR, IPVT, DIAG, QTB, DELTA, PAR, X, - + SIGMA, WA1, WA2) -C***BEGIN PROLOGUE DMPAR -C***SUBSIDIARY -C***PURPOSE Subsidiary to DNLS1 and DNLS1E -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (LMPAR-S, DMPAR-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C **** Double Precision version of LMPAR **** -C -C Given an M by N matrix A, an N by N nonsingular DIAGONAL -C matrix D, an M-vector B, and a positive number DELTA, -C the problem is to determine a value for the parameter -C PAR such that if X solves the system -C -C A*X = B , SQRT(PAR)*D*X = 0 , -C -C in the least squares sense, and DXNORM is the Euclidean -C norm of D*X, then either PAR is zero and -C -C (DXNORM-DELTA) .LE. 0.1*DELTA , -C -C or PAR is positive and -C -C ABS(DXNORM-DELTA) .LE. 0.1*DELTA . -C -C This subroutine completes the solution of the problem -C if it is provided with the necessary information from the -C QR factorization, with column pivoting, of A. That is, if -C A*P = Q*R, where P is a permutation matrix, Q has orthogonal -C columns, and R is an upper triangular matrix with diagonal -C elements of nonincreasing magnitude, then DMPAR expects -C the full upper triangle of R, the permutation matrix P, -C and the first N components of (Q TRANSPOSE)*B. On output -C DMPAR also provides an upper triangular matrix S such that -C -C T T T -C P *(A *A + PAR*D*D)*P = S *S . -C -C S is employed within DMPAR and may be of separate interest. -C -C Only a few iterations are generally needed for convergence -C of the algorithm. If, however, the limit of 10 iterations -C is reached, then the output PAR will contain the best -C value obtained so far. -C -C The subroutine statement is -C -C SUBROUTINE DMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SIGMA, -C WA1,WA2) -C -C where -C -C N is a positive integer input variable set to the order of R. -C -C R is an N by N array. On input the full upper triangle -C must contain the full upper triangle of the matrix R. -C On output the full upper triangle is unaltered, and the -C strict lower triangle contains the strict upper triangle -C (transposed) of the upper triangular matrix S. -C -C LDR is a positive integer input variable not less than N -C which specifies the leading dimension of the array R. -C -C IPVT is an integer input array of length N which defines the -C permutation matrix P such that A*P = Q*R. Column J of P -C is column IPVT(J) of the identity matrix. -C -C DIAG is an input array of length N which must contain the -C diagonal elements of the matrix D. -C -C QTB is an input array of length N which must contain the first -C N elements of the vector (Q TRANSPOSE)*B. -C -C DELTA is a positive input variable which specifies an upper -C bound on the Euclidean norm of D*X. -C -C PAR is a nonnegative variable. On input PAR contains an -C initial estimate of the Levenberg-Marquardt parameter. -C On output PAR contains the final estimate. -C -C X is an output array of length N which contains the least -C squares solution of the system A*X = B, SQRT(PAR)*D*X = 0, -C for the output PAR. -C -C SIGMA is an output array of length N which contains the -C diagonal elements of the upper triangular matrix S. -C -C WA1 and WA2 are work arrays of length N. -C -C***SEE ALSO DNLS1, DNLS1E -C***ROUTINES CALLED D1MACH, DENORM, DQRSLV -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DMPAR - INTEGER N,LDR - INTEGER IPVT(*) - DOUBLE PRECISION DELTA,PAR - DOUBLE PRECISION R(LDR,*),DIAG(*),QTB(*),X(*),SIGMA(*),WA1(*), - 1 WA2(*) - INTEGER I,ITER,J,JM1,JP1,K,L,NSING - DOUBLE PRECISION DXNORM,DWARF,FP,GNORM,PARC,PARL,PARU,P1,P001, - 1 SUM,TEMP,ZERO - DOUBLE PRECISION D1MACH,DENORM - SAVE P1, P001, ZERO - DATA P1,P001,ZERO /1.0D-1,1.0D-3,0.0D0/ -C***FIRST EXECUTABLE STATEMENT DMPAR - DWARF = D1MACH(1) -C -C COMPUTE AND STORE IN X THE GAUSS-NEWTON DIRECTION. IF THE -C JACOBIAN IS RANK-DEFICIENT, OBTAIN A LEAST SQUARES SOLUTION. -C - NSING = N - DO 10 J = 1, N - WA1(J) = QTB(J) - IF (R(J,J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1 - IF (NSING .LT. N) WA1(J) = ZERO - 10 CONTINUE - IF (NSING .LT. 1) GO TO 50 - DO 40 K = 1, NSING - J = NSING - K + 1 - WA1(J) = WA1(J)/R(J,J) - TEMP = WA1(J) - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 30 - DO 20 I = 1, JM1 - WA1(I) = WA1(I) - R(I,J)*TEMP - 20 CONTINUE - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - DO 60 J = 1, N - L = IPVT(J) - X(L) = WA1(J) - 60 CONTINUE -C -C INITIALIZE THE ITERATION COUNTER. -C EVALUATE THE FUNCTION AT THE ORIGIN, AND TEST -C FOR ACCEPTANCE OF THE GAUSS-NEWTON DIRECTION. -C - ITER = 0 - DO 70 J = 1, N - WA2(J) = DIAG(J)*X(J) - 70 CONTINUE - DXNORM = DENORM(N,WA2) - FP = DXNORM - DELTA - IF (FP .LE. P1*DELTA) GO TO 220 -C -C IF THE JACOBIAN IS NOT RANK DEFICIENT, THE NEWTON -C STEP PROVIDES A LOWER BOUND, PARL, FOR THE ZERO OF -C THE FUNCTION. OTHERWISE SET THIS BOUND TO ZERO. -C - PARL = ZERO - IF (NSING .LT. N) GO TO 120 - DO 80 J = 1, N - L = IPVT(J) - WA1(J) = DIAG(L)*(WA2(L)/DXNORM) - 80 CONTINUE - DO 110 J = 1, N - SUM = ZERO - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 100 - DO 90 I = 1, JM1 - SUM = SUM + R(I,J)*WA1(I) - 90 CONTINUE - 100 CONTINUE - WA1(J) = (WA1(J) - SUM)/R(J,J) - 110 CONTINUE - TEMP = DENORM(N,WA1) - PARL = ((FP/DELTA)/TEMP)/TEMP - 120 CONTINUE -C -C CALCULATE AN UPPER BOUND, PARU, FOR THE ZERO OF THE FUNCTION. -C - DO 140 J = 1, N - SUM = ZERO - DO 130 I = 1, J - SUM = SUM + R(I,J)*QTB(I) - 130 CONTINUE - L = IPVT(J) - WA1(J) = SUM/DIAG(L) - 140 CONTINUE - GNORM = DENORM(N,WA1) - PARU = GNORM/DELTA - IF (PARU .EQ. ZERO) PARU = DWARF/MIN(DELTA,P1) -C -C IF THE INPUT PAR LIES OUTSIDE OF THE INTERVAL (PARL,PARU), -C SET PAR TO THE CLOSER ENDPOINT. -C - PAR = MAX(PAR,PARL) - PAR = MIN(PAR,PARU) - IF (PAR .EQ. ZERO) PAR = GNORM/DXNORM -C -C BEGINNING OF AN ITERATION. -C - 150 CONTINUE - ITER = ITER + 1 -C -C EVALUATE THE FUNCTION AT THE CURRENT VALUE OF PAR. -C - IF (PAR .EQ. ZERO) PAR = MAX(DWARF,P001*PARU) - TEMP = SQRT(PAR) - DO 160 J = 1, N - WA1(J) = TEMP*DIAG(J) - 160 CONTINUE - CALL DQRSLV(N,R,LDR,IPVT,WA1,QTB,X,SIGMA,WA2) - DO 170 J = 1, N - WA2(J) = DIAG(J)*X(J) - 170 CONTINUE - DXNORM = DENORM(N,WA2) - TEMP = FP - FP = DXNORM - DELTA -C -C IF THE FUNCTION IS SMALL ENOUGH, ACCEPT THE CURRENT VALUE -C OF PAR. ALSO TEST FOR THE EXCEPTIONAL CASES WHERE PARL -C IS ZERO OR THE NUMBER OF ITERATIONS HAS REACHED 10. -C - IF (ABS(FP) .LE. P1*DELTA - 1 .OR. PARL .EQ. ZERO .AND. FP .LE. TEMP - 2 .AND. TEMP .LT. ZERO .OR. ITER .EQ. 10) GO TO 220 -C -C COMPUTE THE NEWTON CORRECTION. -C - DO 180 J = 1, N - L = IPVT(J) - WA1(J) = DIAG(L)*(WA2(L)/DXNORM) - 180 CONTINUE - DO 210 J = 1, N - WA1(J) = WA1(J)/SIGMA(J) - TEMP = WA1(J) - JP1 = J + 1 - IF (N .LT. JP1) GO TO 200 - DO 190 I = JP1, N - WA1(I) = WA1(I) - R(I,J)*TEMP - 190 CONTINUE - 200 CONTINUE - 210 CONTINUE - TEMP = DENORM(N,WA1) - PARC = ((FP/DELTA)/TEMP)/TEMP -C -C DEPENDING ON THE SIGN OF THE FUNCTION, UPDATE PARL OR PARU. -C - IF (FP .GT. ZERO) PARL = MAX(PARL,PAR) - IF (FP .LT. ZERO) PARU = MIN(PARU,PAR) -C -C COMPUTE AN IMPROVED ESTIMATE FOR PAR. -C - PAR = MAX(PARL,PAR+PARC) -C -C END OF AN ITERATION. -C - GO TO 150 - 220 CONTINUE -C -C TERMINATION. -C - IF (ITER .EQ. 0) PAR = ZERO - RETURN -C -C LAST CARD OF SUBROUTINE DMPAR. -C - END diff --git a/slatec/dnbco.f b/slatec/dnbco.f deleted file mode 100644 index 14d19b8..0000000 --- a/slatec/dnbco.f +++ /dev/null @@ -1,273 +0,0 @@ -*DECK DNBCO - SUBROUTINE DNBCO (ABE, LDA, N, ML, MU, IPVT, RCOND, Z) -C***BEGIN PROLOGUE DNBCO -C***PURPOSE Factor a band matrix using Gaussian elimination and -C estimate the condition number. -C***LIBRARY SLATEC -C***CATEGORY D2A2 -C***TYPE DOUBLE PRECISION (SNBCO-S, DNBCO-D, CNBCO-C) -C***KEYWORDS BANDED, LINEAR EQUATIONS, MATRIX FACTORIZATION, -C NONSYMMETRIC -C***AUTHOR Voorhees, E. A., (LANL) -C***DESCRIPTION -C -C DNBCO factors a double precision band matrix by Gaussian -C elimination and estimates the condition of the matrix. -C -C If RCOND is not needed, DNBFA is slightly faster. -C To solve A*X = B , follow DNBCO by DNBSL. -C To compute INVERSE(A)*C , follow DNBCO by DNBSL. -C To compute DETERMINANT(A) , follow DNBCO by DNBDI. -C -C On Entry -C -C ABE DOUBLE PRECISION(LDA, NC) -C contains the matrix in band storage. The rows -C of the original matrix are stored in the rows -C of ABE and the diagonals of the original matrix -C are stored in columns 1 through ML+MU+1 of ABE. -C NC must be .GE. 2*ML+MU+1 . -C See the comments below for details. -C -C LDA INTEGER -C the leading dimension of the array ABE. -C LDA must be .GE. N . -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 ABE an upper triangular matrix in band storage -C and 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 DO 20 I = 1, N -C J1 = MAX(1, I-ML) -C J2 = MIN(N, I+MU) -C DO 10 J = J1, J2 -C K = J - I + ML + 1 -C ABE(I,K) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C This uses columns 1 through ML+MU+1 of ABE . -C Furthermore, ML additional columns are needed in -C ABE starting with column ML+MU+2 for elements -C generated during the triangularization. The total -C number of columns needed in ABE is 2*ML+MU+1 . -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 ABE should contain -C -C * 11 12 13 + , * = not used -C 21 22 23 24 + , + = used for pivoting -C 32 33 34 35 + -C 43 44 45 46 + -C 54 55 56 * + -C 65 66 * * + -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DASUM, DAXPY, DDOT, DNBFA, DSCAL -C***REVISION HISTORY (YYMMDD) -C 800728 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DNBCO - INTEGER LDA,N,ML,MU,IPVT(*) - DOUBLE PRECISION ABE(LDA,*),Z(*) - DOUBLE PRECISION RCOND -C - DOUBLE PRECISION DDOT,EK,T,WK,WKM - DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM - INTEGER I,INFO,J,JU,K,KB,KP1,L,LDB,LM,LZ,M,ML1,MM,NL,NU -C***FIRST EXECUTABLE STATEMENT DNBCO - ML1=ML+1 - LDB = LDA - 1 - ANORM = 0.0D0 - DO 10 J = 1, N - NU = MIN(MU,J-1) - NL = MIN(ML,N-J) - L = 1 + NU + NL - ANORM = MAX(ANORM,DASUM(L,ABE(J+NL,ML1-NL),LDB)) - 10 CONTINUE -C -C FACTOR -C - CALL DNBFA(ABE,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 = SIGN(EK,-Z(K)) - IF (ABS(EK-Z(K)) .LE. ABS(ABE(K,ML1))) GO TO 30 - S = ABS(ABE(K,ML1))/ABS(EK-Z(K)) - CALL DSCAL(N,S,Z,1) - EK = S*EK - 30 CONTINUE - WK = EK - Z(K) - WKM = -EK - Z(K) - S = ABS(WK) - SM = ABS(WKM) - IF (ABE(K,ML1) .EQ. 0.0D0) GO TO 40 - WK = WK/ABE(K,ML1) - WKM = WKM/ABE(K,ML1) - GO TO 50 - 40 CONTINUE - WK = 1.0D0 - WKM = 1.0D0 - 50 CONTINUE - KP1 = K + 1 - JU = MIN(MAX(JU,MU+IPVT(K)),N) - MM = ML1 - IF (KP1 .GT. JU) GO TO 90 - DO 60 I = KP1, JU - MM = MM + 1 - SM = SM + ABS(Z(I)+WKM*ABE(K,MM)) - Z(I) = Z(I) + WK*ABE(K,MM) - S = S + ABS(Z(I)) - 60 CONTINUE - IF (S .GE. SM) GO TO 80 - T = WKM -WK - WK = WKM - MM = ML1 - DO 70 I = KP1, JU - MM = MM + 1 - Z(I) = Z(I) + T*ABE(K,MM) - 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 - NL = MIN(ML,N-K) - IF (K .LT. N) Z(K) = Z(K) + DDOT(NL,ABE(K+NL,ML1-NL),-LDB,Z(K+1) - 1 ,1) - IF (ABS(Z(K)) .LE. 1.0D0) GO TO 110 - S = 1.0D0/ABS(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 - NL = MIN(ML,N-K) - IF (K .LT. N) CALL DAXPY(NL,T,ABE(K+NL,ML1-NL),-LDB,Z(K+1),1) - IF (ABS(Z(K)) .LE. 1.0D0) GO TO 130 - S = 1.0D0/ABS(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 (ABS(Z(K)) .LE. ABS(ABE(K,ML1))) GO TO 150 - S = ABS(ABE(K,ML1))/ABS(Z(K)) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM - 150 CONTINUE - IF (ABE(K,ML1) .NE. 0.0D0) Z(K) = Z(K)/ABE(K,ML1) - IF (ABE(K,ML1) .EQ. 0.0D0) Z(K) = 1.0D0 - LM = MIN(K,M) - 1 - LZ = K - LM - T = -Z(K) - CALL DAXPY(LM,T,ABE(K-1,ML+2),-LDB,Z(LZ),1) - 160 CONTINUE -C MAKE ZNORM = 1.0D0 - 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 diff --git a/slatec/dnbdi.f b/slatec/dnbdi.f deleted file mode 100644 index 7a814cb..0000000 --- a/slatec/dnbdi.f +++ /dev/null @@ -1,83 +0,0 @@ -*DECK DNBDI - SUBROUTINE DNBDI (ABE, LDA, N, ML, MU, IPVT, DET) -C***BEGIN PROLOGUE DNBDI -C***PURPOSE Compute the determinant of a band matrix using the factors -C computed by DNBCO or DNBFA. -C***LIBRARY SLATEC -C***CATEGORY D3A2 -C***TYPE DOUBLE PRECISION (SNBDI-S, DNBDI-D, CNBDI-C) -C***KEYWORDS BANDED, DETERMINANT, LINEAR EQUATIONS, NONSYMMETRIC -C***AUTHOR Voorhees, E. A., (LANL) -C***DESCRIPTION -C -C DNBDI computes the determinant of a band matrix -C using the factors computed by DNBCO or DNBFA. -C If the inverse is needed, use DNBSL N times. -C -C On Entry -C -C ABE DOUBLE PRECISION(LDA, NC) -C the output from DNBCO or DNBFA. -C NC must be .GE. 2*ML+MU+1 . -C -C LDA INTEGER -C the leading dimension of the array ABE . -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 DNBCO or DNBFA. -C -C On Return -C -C DET DOUBLE PRECISION(2) -C determinant of original matrix. -C Determinant = DET(1) * 10.0**DET(2) -C with 1.0 .LE. ABS(DET(1)) .LT. 10.0 -C or DET(1) = 0.0 . -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 800728 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DNBDI - INTEGER LDA,N,ML,MU,IPVT(*) - DOUBLE PRECISION ABE(LDA,*),DET(2) -C - DOUBLE PRECISION TEN - INTEGER I -C***FIRST EXECUTABLE STATEMENT DNBDI - 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) = ABE(I,ML+1)*DET(1) - IF (DET(1) .EQ. 0.0D0) GO TO 60 - 10 IF (ABS(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 (ABS(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 - RETURN - END diff --git a/slatec/dnbfa.f b/slatec/dnbfa.f deleted file mode 100644 index 6203a4d..0000000 --- a/slatec/dnbfa.f +++ /dev/null @@ -1,179 +0,0 @@ -*DECK DNBFA - SUBROUTINE DNBFA (ABE, LDA, N, ML, MU, IPVT, INFO) -C***BEGIN PROLOGUE DNBFA -C***PURPOSE Factor a band matrix by elimination. -C***LIBRARY SLATEC -C***CATEGORY D2A2 -C***TYPE DOUBLE PRECISION (SNBFA-S, DNBFA-D, CNBFA-C) -C***KEYWORDS BANDED, LINEAR EQUATIONS, MATRIX FACTORIZATION, -C NONSYMMETRIC -C***AUTHOR Voorhees, E. A., (LANL) -C***DESCRIPTION -C -C DNBFA factors a double precision band matrix by elimination. -C -C DNBFA is usually called by DNBCO, but it can be called -C directly with a saving in time if RCOND is not needed. -C -C On Entry -C -C ABE DOUBLE PRECISION(LDA, NC) -C contains the matrix in band storage. The rows -C of the original matrix are stored in the rows -C of ABE and the diagonals of the original matrix -C are stored in columns 1 through ML+MU+1 of ABE. -C NC must be .GE. 2*ML+MU+1 . -C See the comments below for details. -C -C LDA INTEGER -C the leading dimension of the array ABE. -C LDA must be .GE. N . -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 ABE an upper triangular matrix in band storage -C and 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 DNBSL will divide by zero if -C called. Use RCOND in DNBCO 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 DO 20 I = 1, N -C J1 = MAX(1, I-ML) -C J2 = MIN(N, I+MU) -C DO 10 J = J1, J2 -C K = J - I + ML + 1 -C ABE(I,K) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C This uses columns 1 through ML+MU+1 of ABE . -C Furthermore, ML additional columns are needed in -C ABE starting with column ML+MU+2 for elements -C generated during the triangularization. The total -C number of columns needed in ABE is 2*ML+MU+1 . -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 ABE should contain -C -C * 11 12 13 + , * = not used -C 21 22 23 24 + , + = used for pivoting -C 32 33 34 35 + -C 43 44 45 46 + -C 54 55 56 * + -C 65 66 * * + -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DSCAL, DSWAP, IDAMAX -C***REVISION HISTORY (YYMMDD) -C 800728 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DNBFA - INTEGER LDA,N,ML,MU,IPVT(*),INFO - DOUBLE PRECISION ABE(LDA,*) -C - INTEGER ML1,MB,M,N1,LDB,I,J,K,L,LM,LM1,LM2,MP,IDAMAX - DOUBLE PRECISION T -C***FIRST EXECUTABLE STATEMENT DNBFA - ML1=ML+1 - MB=ML+MU - M=ML+MU+1 - N1=N-1 - LDB=LDA-1 - INFO=0 -C -C SET FILL-IN COLUMNS TO ZERO -C - IF(N.LE.1)GO TO 50 - IF(ML.LE.0)GO TO 7 - DO 6 J=1,ML - DO 5 I=1,N - ABE(I,M+J)=0.0D0 - 5 CONTINUE - 6 CONTINUE - 7 CONTINUE -C -C GAUSSIAN ELIMINATION WITH PARTIAL ELIMINATION -C - DO 40 K=1,N1 - LM=MIN(N-K,ML) - LM1=LM+1 - LM2=ML1-LM -C -C SEARCH FOR PIVOT INDEX -C - L=-IDAMAX(LM1,ABE(LM+K,LM2),LDB)+LM1+K - IPVT(K)=L - MP=MIN(MB,N-K) -C -C SWAP ROWS IF NECESSARY -C - IF(L.NE.K)CALL DSWAP(MP+1,ABE(K,ML1),LDA,ABE(L,ML1+K-L),LDA) -C -C SKIP COLUMN REDUCTION IF PIVOT IS ZERO -C - IF(ABE(K,ML1).EQ.0.0D0) GO TO 20 -C -C COMPUTE MULTIPLIERS -C - T=-1.0/ABE(K,ML1) - CALL DSCAL(LM,T,ABE(LM+K,LM2),LDB) -C -C ROW ELIMINATION WITH COLUMN INDEXING -C - DO 10 J=1,MP - CALL DAXPY (LM,ABE(K,ML1+J),ABE(LM+K,LM2),LDB,ABE(LM+K,LM2+J), - 1 LDB) - 10 CONTINUE - GO TO 30 - 20 CONTINUE - INFO=K - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - IPVT(N)=N - IF(ABE(N,ML1).EQ.0.0D0) INFO=N - RETURN - END diff --git a/slatec/dnbfs.f b/slatec/dnbfs.f deleted file mode 100644 index 86cd273..0000000 --- a/slatec/dnbfs.f +++ /dev/null @@ -1,250 +0,0 @@ -*DECK DNBFS - SUBROUTINE DNBFS (ABE, LDA, N, ML, MU, V, ITASK, IND, WORK, IWORK) -C***BEGIN PROLOGUE DNBFS -C***PURPOSE Solve a general nonsymmetric banded system of linear -C equations. -C***LIBRARY SLATEC -C***CATEGORY D2A2 -C***TYPE DOUBLE PRECISION (SNBFS-S, DNBFS-D, CNBFS-C) -C***KEYWORDS BANDED, LINEAR EQUATIONS, NONSYMMETRIC -C***AUTHOR Voorhees, E. A., (LANL) -C***DESCRIPTION -C -C Subroutine DNBFS solves a general nonsymmetric banded NxN -C system of double precision real linear equations using -C SLATEC subroutines DNBCO and DNBSL. These are adaptations -C of the LINPACK subroutines DGBCO and DGBSL which require -C a different format for storing the matrix elements. If -C A is an NxN double precision matrix and if X and B are -C double precision N-vectors, then DNBFS solves the equation -C -C A*X=B. -C -C A band matrix is a matrix whose nonzero elements are all -C fairly near the main diagonal, specifically A(I,J) = 0 -C if I-J is greater than ML or J-I is greater than -C MU . The integers ML and MU are called the lower and upper -C band widths and M = ML+MU+1 is the total band width. -C DNBFS uses less time and storage than the corresponding -C program for general matrices (DGEFS) if 2*ML+MU .LT. N . -C -C The matrix A is first factored into upper and lower tri- -C angular matrices U and L using partial pivoting. These -C factors and the pivoting information are used to find the -C solution vector X. An approximate condition number is -C calculated to provide a rough estimate of the number of -C digits of accuracy in the computed solution. -C -C If the equation A*X=B is to be solved for more than one vector -C B, the factoring of A does not need to be performed again and -C the option to only solve (ITASK .GT. 1) will be faster for -C the succeeding solutions. In this case, the contents of A, -C LDA, N and IWORK must not have been altered by the user follow- -C ing factorization (ITASK=1). IND will not be changed by DNBFS -C in this case. -C -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 DO 20 I = 1, N -C J1 = MAX(1, I-ML) -C J2 = MIN(N, I+MU) -C DO 10 J = J1, J2 -C K = J - I + ML + 1 -C ABE(I,K) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C This uses columns 1 through ML+MU+1 of ABE . -C Furthermore, ML additional columns are needed in -C ABE starting with column ML+MU+2 for elements -C generated during the triangularization. The total -C number of columns needed in ABE is 2*ML+MU+1 . -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 ABE should contain -C -C * 11 12 13 + , * = not used -C 21 22 23 24 + , + = used for pivoting -C 32 33 34 35 + -C 43 44 45 46 + -C 54 55 56 * + -C 65 66 * * + -C -C -C Argument Description *** -C -C ABE DOUBLE PRECISION(LDA,NC) -C on entry, contains the matrix in band storage as -C described above. NC must not be less than -C 2*ML+MU+1 . The user is cautioned to specify NC -C with care since it is not an argument and cannot -C be checked by DNBFS. The rows of the original -C matrix are stored in the rows of ABE and the -C diagonals of the original matrix are stored in -C columns 1 through ML+MU+1 of ABE . -C on return, contains an upper triangular matrix U and -C the multipliers necessary to construct a matrix L -C so that A=L*U. -C LDA INTEGER -C the leading dimension of array ABE. LDA must be great- -C er than or equal to N. (terminal error message IND=-1) -C N INTEGER -C the order of the matrix A. N must be greater -C than or equal to 1 . (terminal error message IND=-2) -C ML INTEGER -C the number of diagonals below the main diagonal. -C ML must not be less than zero nor greater than or -C equal to N . (terminal error message IND=-5) -C MU INTEGER -C the number of diagonals above the main diagonal. -C MU must not be less than zero nor greater than or -C equal to N . (terminal error message IND=-6) -C V DOUBLE PRECISION(N) -C on entry, the singly subscripted array(vector) of di- -C mension N which contains the right hand side B of a -C system of simultaneous linear equations A*X=B. -C on return, V contains the solution vector, X . -C ITASK INTEGER -C If ITASK=1, the matrix A is factored and then the -C linear equation is solved. -C If ITASK .GT. 1, the equation is solved using the existing -C factored matrix A and IWORK. -C If ITASK .LT. 1, then terminal error message IND=-3 is -C printed. -C IND INTEGER -C GT. 0 IND is a rough estimate of the number of digits -C of accuracy in the solution, X. -C LT. 0 See error message corresponding to IND below. -C WORK DOUBLE PRECISION(N) -C a singly subscripted array of dimension at least N. -C IWORK INTEGER(N) -C a singly subscripted array of dimension at least N. -C -C Error Messages Printed *** -C -C IND=-1 terminal N is greater than LDA. -C IND=-2 terminal N is less than 1. -C IND=-3 terminal ITASK is less than 1. -C IND=-4 terminal The matrix A is computationally singular. -C A solution has not been computed. -C IND=-5 terminal ML is less than zero or is greater than -C or equal to N . -C IND=-6 terminal MU is less than zero or is greater than -C or equal to N . -C IND=-10 warning The solution has no apparent significance. -C The solution may be inaccurate or the matrix -C A may be poorly scaled. -C -C Note- The above terminal(*fatal*) error messages are -C designed to be handled by XERMSG in which -C LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 -C for warning error messages from XERMSG. Unless -C the user provides otherwise, an error message -C will be printed followed by an abort. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED D1MACH, DNBCO, DNBSL, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800812 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900510 Convert XERRWV calls to XERMSG calls, changed GOTOs to -C IF-THEN-ELSEs. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DNBFS -C - INTEGER LDA,N,ITASK,IND,IWORK(*),ML,MU - DOUBLE PRECISION ABE(LDA,*),V(*),WORK(*),D1MACH - DOUBLE PRECISION RCOND - CHARACTER*8 XERN1, XERN2 -C***FIRST EXECUTABLE STATEMENT DNBFS - IF (LDA.LT.N) THEN - IND = -1 - WRITE (XERN1, '(I8)') LDA - WRITE (XERN2, '(I8)') N - CALL XERMSG ('SLATEC', 'DNBFS', 'LDA = ' // XERN1 // - * ' IS LESS THAN N = ' // XERN2, -1, 1) - RETURN - ENDIF -C - IF (N.LE.0) THEN - IND = -2 - WRITE (XERN1, '(I8)') N - CALL XERMSG ('SLATEC', 'DNBFS', 'N = ' // XERN1 // - * ' IS LESS THAN 1', -2, 1) - RETURN - ENDIF -C - IF (ITASK.LT.1) THEN - IND = -3 - WRITE (XERN1, '(I8)') ITASK - CALL XERMSG ('SLATEC', 'DNBFS', 'ITASK = ' // XERN1 // - * ' IS LESS THAN 1', -3, 1) - RETURN - ENDIF -C - IF (ML.LT.0 .OR. ML.GE.N) THEN - IND = -5 - WRITE (XERN1, '(I8)') ML - CALL XERMSG ('SLATEC', 'DNBFS', - * 'ML = ' // XERN1 // ' IS OUT OF RANGE', -5, 1) - RETURN - ENDIF -C - IF (MU.LT.0 .OR. MU.GE.N) THEN - IND = -6 - WRITE (XERN1, '(I8)') MU - CALL XERMSG ('SLATEC', 'DNBFS', - * 'MU = ' // XERN1 // ' IS OUT OF RANGE', -6, 1) - RETURN - ENDIF -C - IF (ITASK.EQ.1) THEN -C -C FACTOR MATRIX A INTO LU -C - CALL DNBCO(ABE,LDA,N,ML,MU,IWORK,RCOND,WORK) -C -C CHECK FOR COMPUTATIONALLY SINGULAR MATRIX -C - IF (RCOND.EQ.0.0D0) THEN - IND = -4 - CALL XERMSG ('SLATEC', 'DNBFS', - * 'SINGULAR MATRIX A - NO SOLUTION', -4, 1) - RETURN - ENDIF -C -C COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) -C AND CHECK FOR IND GREATER THAN ZERO -C - IND = -LOG10(D1MACH(4)/RCOND) - IF (IND.LE.0) THEN - IND = -10 - CALL XERMSG ('SLATEC', 'DNBFS', - * 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) - ENDIF - ENDIF -C -C SOLVE AFTER FACTORING -C - CALL DNBSL(ABE,LDA,N,ML,MU,IWORK,V,0) - RETURN - END diff --git a/slatec/dnbsl.f b/slatec/dnbsl.f deleted file mode 100644 index 9781deb..0000000 --- a/slatec/dnbsl.f +++ /dev/null @@ -1,149 +0,0 @@ -*DECK DNBSL - SUBROUTINE DNBSL (ABE, LDA, N, ML, MU, IPVT, B, JOB) -C***BEGIN PROLOGUE DNBSL -C***PURPOSE Solve a real band system using the factors computed by -C DNBCO or DNBFA. -C***LIBRARY SLATEC -C***CATEGORY D2A2 -C***TYPE DOUBLE PRECISION (SNBSL-S, DNBSL-D, CNBSL-C) -C***KEYWORDS BANDED, LINEAR EQUATIONS, NONSYMMETRIC, SOLVE -C***AUTHOR Voorhees, E. A., (LANL) -C***DESCRIPTION -C -C DNBSL solves the double precision band system -C A * X = B or TRANS(A) * X = B -C using the factors computed by DNBCO or DNBFA. -C -C On Entry -C -C ABE DOUBLE PRECISION(LDA, NC) -C the output from DNBCO or DNBFA. -C NC must be .GE. 2*ML+MU+1 . -C -C LDA INTEGER -C the leading dimension of the array ABE . -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 DNBCO or DNBFA. -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 DNBCO has set RCOND .GT. 0.0 -C or DNBFA has set INFO .EQ. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL DNBCO(ABE,LDA,N,ML,MU,IPVT,RCOND,Z) -C IF (RCOND is too small) GO TO ... -C DO 10 J = 1, P -C CALL DNBSL(ABE,LDA,N,ML,MU,IPVT,C(1,J),0) -C 10 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DDOT -C***REVISION HISTORY (YYMMDD) -C 800728 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DNBSL - INTEGER LDA,N,ML,MU,IPVT(*),JOB - DOUBLE PRECISION ABE(LDA,*),B(*) -C - DOUBLE PRECISION DDOT,T - INTEGER K,KB,L,LB,LDB,LM,M,MLM,NM1 -C***FIRST EXECUTABLE STATEMENT DNBSL - M=MU+ML+1 - NM1=N-1 - LDB=1-LDA - 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=MIN(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 - MLM=ML-(LM-1) - CALL DAXPY(LM,T,ABE(K+LM,MLM),LDB,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)/ABE(K,ML+1) - LM=MIN(K,M)-1 - LB=K-LM - T=-B(K) - CALL DAXPY(LM,T,ABE(K-1,ML+2),LDB,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 = MIN(K,M) - 1 - LB = K - LM - T = DDOT(LM,ABE(K-1,ML+2),LDB,B(LB),1) - B(K) = (B(K) - T)/ABE(K,ML+1) - 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 = MIN(ML,N-K) - MLM = ML - (LM - 1) - B(K) = B(K) + DDOT(LM,ABE(K+LM,MLM),LDB,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/slatec/dnls1.f b/slatec/dnls1.f deleted file mode 100644 index 575ec85..0000000 --- a/slatec/dnls1.f +++ /dev/null @@ -1,1018 +0,0 @@ -*DECK DNLS1 - SUBROUTINE DNLS1 (FCN, IOPT, M, N, X, FVEC, FJAC, LDFJAC, FTOL, - + XTOL, GTOL, MAXFEV, EPSFCN, DIAG, MODE, FACTOR, NPRINT, INFO, - + NFEV, NJEV, IPVT, QTF, WA1, WA2, WA3, WA4) -C***BEGIN PROLOGUE DNLS1 -C***PURPOSE Minimize the sum of the squares of M nonlinear functions -C in N variables by a modification of the Levenberg-Marquardt -C algorithm. -C***LIBRARY SLATEC -C***CATEGORY K1B1A1, K1B1A2 -C***TYPE DOUBLE PRECISION (SNLS1-S, DNLS1-D) -C***KEYWORDS LEVENBERG-MARQUARDT, NONLINEAR DATA FITTING, -C NONLINEAR LEAST SQUARES -C***AUTHOR Hiebert, K. L., (SNLA) -C***DESCRIPTION -C -C 1. Purpose. -C -C The purpose of DNLS1 is to minimize the sum of the squares of M -C nonlinear functions in N variables by a modification of the -C Levenberg-Marquardt algorithm. The user must provide a subrou- -C tine which calculates the functions. The user has the option -C of how the Jacobian will be supplied. The user can supply the -C full Jacobian, or the rows of the Jacobian (to avoid storing -C the full Jacobian), or let the code approximate the Jacobian by -C forward-differencing. This code is the combination of the -C MINPACK codes (Argonne) LMDER, LMDIF, and LMSTR. -C -C -C 2. Subroutine and Type Statements. -C -C SUBROUTINE DNLS1(FCN,IOPT,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL, -C * GTOL,MAXFEV,EPSFCN,DIAG,MODE,FACTOR,NPRINT,INFO -C * ,NFEV,NJEV,IPVT,QTF,WA1,WA2,WA3,WA4) -C INTEGER IOPT,M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV -C INTEGER IPVT(N) -C DOUBLE PRECISION FTOL,XTOL,GTOL,EPSFCN,FACTOR -C DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N), -C * WA1(N),WA2(N),WA3(N),WA4(M) -C -C -C 3. Parameters. -C -C Parameters designated as input parameters must be specified on -C entry to DNLS1 and are not changed on exit, while parameters -C designated as output parameters need not be specified on entry -C and are set to appropriate values on exit from DNLS1. -C -C FCN is the name of the user-supplied subroutine which calculate -C the functions. If the user wants to supply the Jacobian -C (IOPT=2 or 3), then FCN must be written to calculate the -C Jacobian, as well as the functions. See the explanation -C of the IOPT argument below. -C If the user wants the iterates printed (NPRINT positive), then -C FCN must do the printing. See the explanation of NPRINT -C below. FCN must be declared in an EXTERNAL statement in the -C calling program and should be written as follows. -C -C -C SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) -C INTEGER IFLAG,LDFJAC,M,N -C DOUBLE PRECISION X(N),FVEC(M) -C ---------- -C FJAC and LDFJAC may be ignored , if IOPT=1. -C DOUBLE PRECISION FJAC(LDFJAC,N) , if IOPT=2. -C DOUBLE PRECISION FJAC(N) , if IOPT=3. -C ---------- -C If IFLAG=0, the values in X and FVEC are available -C for printing. See the explanation of NPRINT below. -C IFLAG will never be zero unless NPRINT is positive. -C The values of X and FVEC must not be changed. -C RETURN -C ---------- -C If IFLAG=1, calculate the functions at X and return -C this vector in FVEC. -C RETURN -C ---------- -C If IFLAG=2, calculate the full Jacobian at X and return -C this matrix in FJAC. Note that IFLAG will never be 2 unless -C IOPT=2. FVEC contains the function values at X and must -C not be altered. FJAC(I,J) must be set to the derivative -C of FVEC(I) with respect to X(J). -C RETURN -C ---------- -C If IFLAG=3, calculate the LDFJAC-th row of the Jacobian -C and return this vector in FJAC. Note that IFLAG will -C never be 3 unless IOPT=3. FVEC contains the function -C values at X and must not be altered. FJAC(J) must be -C set to the derivative of FVEC(LDFJAC) with respect to X(J). -C RETURN -C ---------- -C END -C -C -C The value of IFLAG should not be changed by FCN unless the -C user wants to terminate execution of DNLS1. In this case, set -C IFLAG to a negative integer. -C -C -C IOPT is an input variable which specifies how the Jacobian will -C be calculated. If IOPT=2 or 3, then the user must supply the -C Jacobian, as well as the function values, through the -C subroutine FCN. If IOPT=2, the user supplies the full -C Jacobian with one call to FCN. If IOPT=3, the user supplies -C one row of the Jacobian with each call. (In this manner, -C storage can be saved because the full Jacobian is not stored.) -C If IOPT=1, the code will approximate the Jacobian by forward -C differencing. -C -C M is a positive integer input variable set to the number of -C functions. -C -C N is a positive integer input variable set to the number of -C variables. N must not exceed M. -C -C X is an array of length N. On input, X must contain an initial -C estimate of the solution vector. On output, X contains the -C final estimate of the solution vector. -C -C FVEC is an output array of length M which contains the functions -C evaluated at the output X. -C -C FJAC is an output array. For IOPT=1 and 2, FJAC is an M by N -C array. For IOPT=3, FJAC is an N by N array. The upper N by N -C submatrix of FJAC contains an upper triangular matrix R with -C diagonal elements of nonincreasing magnitude such that -C -C T T T -C P *(JAC *JAC)*P = R *R, -C -C where P is a permutation matrix and JAC is the final calcu- -C lated Jacobian. Column J of P is column IPVT(J) (see below) -C of the identity matrix. The lower part of FJAC contains -C information generated during the computation of R. -C -C LDFJAC is a positive integer input variable which specifies -C the leading dimension of the array FJAC. For IOPT=1 and 2, -C LDFJAC must not be less than M. For IOPT=3, LDFJAC must not -C be less than N. -C -C FTOL is a non-negative input variable. Termination occurs when -C both the actual and predicted relative reductions in the sum -C of squares are at most FTOL. Therefore, FTOL measures the -C relative error desired in the sum of squares. Section 4 con- -C tains more details about FTOL. -C -C XTOL is a non-negative input variable. Termination occurs when -C the relative error between two consecutive iterates is at most -C XTOL. Therefore, XTOL measures the relative error desired in -C the approximate solution. Section 4 contains more details -C about XTOL. -C -C GTOL is a non-negative input variable. Termination occurs when -C the cosine of the angle between FVEC and any column of the -C Jacobian is at most GTOL in absolute value. Therefore, GTOL -C measures the orthogonality desired between the function vector -C and the columns of the Jacobian. Section 4 contains more -C details about GTOL. -C -C MAXFEV is a positive integer input variable. Termination occurs -C when the number of calls to FCN to evaluate the functions -C has reached MAXFEV. -C -C EPSFCN is an input variable used in determining a suitable step -C for the forward-difference approximation. This approximation -C assumes that the relative errors in the functions are of the -C order of EPSFCN. If EPSFCN is less than the machine preci- -C sion, it is assumed that the relative errors in the functions -C are of the order of the machine precision. If IOPT=2 or 3, -C then EPSFCN can be ignored (treat it as a dummy argument). -C -C DIAG is an array of length N. If MODE = 1 (see below), DIAG is -C internally set. If MODE = 2, DIAG must contain positive -C entries that serve as implicit (multiplicative) scale factors -C for the variables. -C -C MODE is an integer input variable. If MODE = 1, the variables -C will be scaled internally. If MODE = 2, the scaling is speci- -C fied by the input DIAG. Other values of MODE are equivalent -C to MODE = 1. -C -C FACTOR is a positive input variable used in determining the ini- -C tial step bound. This bound is set to the product of FACTOR -C and the Euclidean norm of DIAG*X if nonzero, or else to FACTOR -C itself. In most cases FACTOR should lie in the interval -C (.1,100.). 100. is a generally recommended value. -C -C NPRINT is an integer input variable that enables controlled -C printing of iterates if it is positive. In this case, FCN is -C called with IFLAG = 0 at the beginning of the first iteration -C and every NPRINT iterations thereafter and immediately prior -C to return, with X and FVEC available for printing. Appropriate -C print statements must be added to FCN (see example) and -C FVEC should not be altered. If NPRINT is not positive, no -C special calls to FCN with IFLAG = 0 are made. -C -C INFO is an integer output variable. If the user has terminated -C execution, INFO is set to the (negative) value of IFLAG. See -C description of FCN and JAC. Otherwise, INFO is set as follows -C -C INFO = 0 improper input parameters. -C -C INFO = 1 both actual and predicted relative reductions in the -C sum of squares are at most FTOL. -C -C INFO = 2 relative error between two consecutive iterates is -C at most XTOL. -C -C INFO = 3 conditions for INFO = 1 and INFO = 2 both hold. -C -C INFO = 4 the cosine of the angle between FVEC and any column -C of the Jacobian is at most GTOL in absolute value. -C -C INFO = 5 number of calls to FCN for function evaluation -C has reached MAXFEV. -C -C INFO = 6 FTOL is too small. No further reduction in the sum -C of squares is possible. -C -C INFO = 7 XTOL is too small. No further improvement in the -C approximate solution X is possible. -C -C INFO = 8 GTOL is too small. FVEC is orthogonal to the -C columns of the Jacobian to machine precision. -C -C Sections 4 and 5 contain more details about INFO. -C -C NFEV is an integer output variable set to the number of calls to -C FCN for function evaluation. -C -C NJEV is an integer output variable set to the number of -C evaluations of the full Jacobian. If IOPT=2, only one call to -C FCN is required for each evaluation of the full Jacobian. -C If IOPT=3, the M calls to FCN are required. -C If IOPT=1, then NJEV is set to zero. -C -C IPVT is an integer output array of length N. IPVT defines a -C permutation matrix P such that JAC*P = Q*R, where JAC is the -C final calculated Jacobian, Q is orthogonal (not stored), and R -C is upper triangular with diagonal elements of nonincreasing -C magnitude. Column J of P is column IPVT(J) of the identity -C matrix. -C -C QTF is an output array of length N which contains the first N -C elements of the vector (Q transpose)*FVEC. -C -C WA1, WA2, and WA3 are work arrays of length N. -C -C WA4 is a work array of length M. -C -C -C 4. Successful Completion. -C -C The accuracy of DNLS1 is controlled by the convergence parame- -C ters FTOL, XTOL, and GTOL. These parameters are used in tests -C which make three types of comparisons between the approximation -C X and a solution XSOL. DNLS1 terminates when any of the tests -C is satisfied. If any of the convergence parameters is less than -C the machine precision (as defined by the function R1MACH(4)), -C then DNLS1 only attempts to satisfy the test defined by the -C machine precision. Further progress is not usually possible. -C -C The tests assume that the functions are reasonably well behaved, -C and, if the Jacobian is supplied by the user, that the functions -C and the Jacobian are coded consistently. If these conditions -C are not satisfied, then DNLS1 may incorrectly indicate conver- -C gence. If the Jacobian is coded correctly or IOPT=1, -C then the validity of the answer can be checked, for example, by -C rerunning DNLS1 with tighter tolerances. -C -C First Convergence Test. If ENORM(Z) denotes the Euclidean norm -C of a vector Z, then this test attempts to guarantee that -C -C ENORM(FVEC) .LE. (1+FTOL)*ENORM(FVECS), -C -C where FVECS denotes the functions evaluated at XSOL. If this -C condition is satisfied with FTOL = 10**(-K), then the final -C residual norm ENORM(FVEC) has K significant decimal digits and -C INFO is set to 1 (or to 3 if the second test is also satis- -C fied). Unless high precision solutions are required, the -C recommended value for FTOL is the square root of the machine -C precision. -C -C Second Convergence Test. If D is the diagonal matrix whose -C entries are defined by the array DIAG, then this test attempts -C to guarantee that -C -C ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL). -C -C If this condition is satisfied with XTOL = 10**(-K), then the -C larger components of D*X have K significant decimal digits and -C INFO is set to 2 (or to 3 if the first test is also satis- -C fied). There is a danger that the smaller components of D*X -C may have large relative errors, but if MODE = 1, then the -C accuracy of the components of X is usually related to their -C sensitivity. Unless high precision solutions are required, -C the recommended value for XTOL is the square root of the -C machine precision. -C -C Third Convergence Test. This test is satisfied when the cosine -C of the angle between FVEC and any column of the Jacobian at X -C is at most GTOL in absolute value. There is no clear rela- -C tionship between this test and the accuracy of DNLS1, and -C furthermore, the test is equally well satisfied at other crit- -C ical points, namely maximizers and saddle points. Therefore, -C termination caused by this test (INFO = 4) should be examined -C carefully. The recommended value for GTOL is zero. -C -C -C 5. Unsuccessful Completion. -C -C Unsuccessful termination of DNLS1 can be due to improper input -C parameters, arithmetic interrupts, or an excessive number of -C function evaluations. -C -C Improper Input Parameters. INFO is set to 0 if IOPT .LT. 1 -C or IOPT .GT. 3, or N .LE. 0, or M .LT. N, or for IOPT=1 or 2 -C LDFJAC .LT. M, or for IOPT=3 LDFJAC .LT. N, or FTOL .LT. 0.E0, -C or XTOL .LT. 0.E0, or GTOL .LT. 0.E0, or MAXFEV .LE. 0, or -C FACTOR .LE. 0.E0. -C -C Arithmetic Interrupts. If these interrupts occur in the FCN -C subroutine during an early stage of the computation, they may -C be caused by an unacceptable choice of X by DNLS1. In this -C case, it may be possible to remedy the situation by rerunning -C DNLS1 with a smaller value of FACTOR. -C -C Excessive Number of Function Evaluations. A reasonable value -C for MAXFEV is 100*(N+1) for IOPT=2 or 3 and 200*(N+1) for -C IOPT=1. If the number of calls to FCN reaches MAXFEV, then -C this indicates that the routine is converging very slowly -C as measured by the progress of FVEC, and INFO is set to 5. -C In this case, it may be helpful to restart DNLS1 with MODE -C set to 1. -C -C -C 6. Characteristics of the Algorithm. -C -C DNLS1 is a modification of the Levenberg-Marquardt algorithm. -C Two of its main characteristics involve the proper use of -C implicitly scaled variables (if MODE = 1) and an optimal choice -C for the correction. The use of implicitly scaled variables -C achieves scale invariance of DNLS1 and limits the size of the -C correction in any direction where the functions are changing -C rapidly. The optimal choice of the correction guarantees (under -C reasonable conditions) global convergence from starting points -C far from the solution and a fast rate of convergence for -C problems with small residuals. -C -C Timing. The time required by DNLS1 to solve a given problem -C depends on M and N, the behavior of the functions, the accu- -C racy requested, and the starting point. The number of arith- -C metic operations needed by DNLS1 is about N**3 to process each -C evaluation of the functions (call to FCN) and to process each -C evaluation of the Jacobian it takes M*N**2 for IOPT=2 (one -C call to FCN), M*N**2 for IOPT=1 (N calls to FCN) and -C 1.5*M*N**2 for IOPT=3 (M calls to FCN). Unless FCN -C can be evaluated quickly, the timing of DNLS1 will be -C strongly influenced by the time spent in FCN. -C -C Storage. DNLS1 requires (M*N + 2*M + 6*N) for IOPT=1 or 2 and -C (N**2 + 2*M + 6*N) for IOPT=3 single precision storage -C locations and N integer storage locations, in addition to -C the storage required by the program. There are no internally -C declared storage arrays. -C -C *Long Description: -C -C 7. Example. -C -C The problem is to determine the values of X(1), X(2), and X(3) -C which provide the best fit (in the least squares sense) of -C -C X(1) + U(I)/(V(I)*X(2) + W(I)*X(3)), I = 1, 15 -C -C to the data -C -C Y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, -C 0.37,0.58,0.73,0.96,1.34,2.10,4.39), -C -C where U(I) = I, V(I) = 16 - I, and W(I) = MIN(U(I),V(I)). The -C I-th component of FVEC is thus defined by -C -C Y(I) - (X(1) + U(I)/(V(I)*X(2) + W(I)*X(3))). -C -C ********** -C -C PROGRAM TEST -C C -C C Driver for DNLS1 example. -C C -C INTEGER J,IOPT,M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV, -C * NWRITE -C INTEGER IPVT(3) -C DOUBLE PRECISION FTOL,XTOL,GTOL,FACTOR,FNORM,EPSFCN -C DOUBLE PRECISION X(3),FVEC(15),FJAC(15,3),DIAG(3),QTF(3), -C * WA1(3),WA2(3),WA3(3),WA4(15) -C DOUBLE PRECISION DENORM,D1MACH -C EXTERNAL FCN -C DATA NWRITE /6/ -C C -C IOPT = 1 -C M = 15 -C N = 3 -C C -C C The following starting values provide a rough fit. -C C -C X(1) = 1.E0 -C X(2) = 1.E0 -C X(3) = 1.E0 -C C -C LDFJAC = 15 -C C -C C Set FTOL and XTOL to the square root of the machine precision -C C and GTOL to zero. Unless high precision solutions are -C C required, these are the recommended settings. -C C -C FTOL = SQRT(R1MACH(4)) -C XTOL = SQRT(R1MACH(4)) -C GTOL = 0.E0 -C C -C MAXFEV = 400 -C EPSFCN = 0.0 -C MODE = 1 -C FACTOR = 1.E2 -C NPRINT = 0 -C C -C CALL DNLS1(FCN,IOPT,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL, -C * GTOL,MAXFEV,EPSFCN,DIAG,MODE,FACTOR,NPRINT, -C * INFO,NFEV,NJEV,IPVT,QTF,WA1,WA2,WA3,WA4) -C FNORM = ENORM(M,FVEC) -C WRITE (NWRITE,1000) FNORM,NFEV,NJEV,INFO,(X(J),J=1,N) -C STOP -C 1000 FORMAT (5X,' FINAL L2 NORM OF THE RESIDUALS',E15.7 // -C * 5X,' NUMBER OF FUNCTION EVALUATIONS',I10 // -C * 5X,' NUMBER OF JACOBIAN EVALUATIONS',I10 // -C * 5X,' EXIT PARAMETER',16X,I10 // -C * 5X,' FINAL APPROXIMATE SOLUTION' // 5X,3E15.7) -C END -C SUBROUTINE FCN(IFLAG,M,N,X,FVEC,DUM,IDUM) -C C This is the form of the FCN routine if IOPT=1, -C C that is, if the user does not calculate the Jacobian. -C INTEGER I,M,N,IFLAG -C DOUBLE PRECISION X(N),FVEC(M),Y(15) -C DOUBLE PRECISION TMP1,TMP2,TMP3,TMP4 -C DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), -C * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) -C * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, -C * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ -C C -C IF (IFLAG .NE. 0) GO TO 5 -C C -C C Insert print statements here when NPRINT is positive. -C C -C RETURN -C 5 CONTINUE -C DO 10 I = 1, M -C TMP1 = I -C TMP2 = 16 - I -C TMP3 = TMP1 -C IF (I .GT. 8) TMP3 = TMP2 -C FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) -C 10 CONTINUE -C RETURN -C END -C -C -C Results obtained with different compilers or machines -C may be slightly different. -C -C FINAL L2 NORM OF THE RESIDUALS 0.9063596E-01 -C -C NUMBER OF FUNCTION EVALUATIONS 25 -C -C NUMBER OF JACOBIAN EVALUATIONS 0 -C -C EXIT PARAMETER 1 -C -C FINAL APPROXIMATE SOLUTION -C -C 0.8241058E-01 0.1133037E+01 0.2343695E+01 -C -C -C For IOPT=2, FCN would be modified as follows to also -C calculate the full Jacobian when IFLAG=2. -C -C SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) -C C -C C This is the form of the FCN routine if IOPT=2, -C C that is, if the user calculates the full Jacobian. -C C -C INTEGER I,LDFJAC,M,N,IFLAG -C DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),Y(15) -C DOUBLE PRECISION TMP1,TMP2,TMP3,TMP4 -C DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), -C * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) -C * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, -C * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ -C C -C IF (IFLAG .NE. 0) GO TO 5 -C C -C C Insert print statements here when NPRINT is positive. -C C -C RETURN -C 5 CONTINUE -C IF(IFLAG.NE.1) GO TO 20 -C DO 10 I = 1, M -C TMP1 = I -C TMP2 = 16 - I -C TMP3 = TMP1 -C IF (I .GT. 8) TMP3 = TMP2 -C FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) -C 10 CONTINUE -C RETURN -C C -C C Below, calculate the full Jacobian. -C C -C 20 CONTINUE -C C -C DO 30 I = 1, M -C TMP1 = I -C TMP2 = 16 - I -C TMP3 = TMP1 -C IF (I .GT. 8) TMP3 = TMP2 -C TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 -C FJAC(I,1) = -1.E0 -C FJAC(I,2) = TMP1*TMP2/TMP4 -C FJAC(I,3) = TMP1*TMP3/TMP4 -C 30 CONTINUE -C RETURN -C END -C -C -C For IOPT = 3, FJAC would be dimensioned as FJAC(3,3), -C LDFJAC would be set to 3, and FCN would be written as -C follows to calculate a row of the Jacobian when IFLAG=3. -C -C SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) -C C This is the form of the FCN routine if IOPT=3, -C C that is, if the user calculates the Jacobian row by row. -C INTEGER I,M,N,IFLAG -C DOUBLE PRECISION X(N),FVEC(M),FJAC(N),Y(15) -C DOUBLE PRECISION TMP1,TMP2,TMP3,TMP4 -C DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), -C * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) -C * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, -C * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ -C C -C IF (IFLAG .NE. 0) GO TO 5 -C C -C C Insert print statements here when NPRINT is positive. -C C -C RETURN -C 5 CONTINUE -C IF( IFLAG.NE.1) GO TO 20 -C DO 10 I = 1, M -C TMP1 = I -C TMP2 = 16 - I -C TMP3 = TMP1 -C IF (I .GT. 8) TMP3 = TMP2 -C FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) -C 10 CONTINUE -C RETURN -C C -C C Below, calculate the LDFJAC-th row of the Jacobian. -C C -C 20 CONTINUE -C -C I = LDFJAC -C TMP1 = I -C TMP2 = 16 - I -C TMP3 = TMP1 -C IF (I .GT. 8) TMP3 = TMP2 -C TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 -C FJAC(1) = -1.E0 -C FJAC(2) = TMP1*TMP2/TMP4 -C FJAC(3) = TMP1*TMP3/TMP4 -C RETURN -C END -C -C***REFERENCES Jorge J. More, The Levenberg-Marquardt algorithm: -C implementation and theory. In Numerical Analysis -C Proceedings (Dundee, June 28 - July 1, 1977, G. A. -C Watson, Editor), Lecture Notes in Mathematics 630, -C Springer-Verlag, 1978. -C***ROUTINES CALLED D1MACH, DCKDER, DENORM, DFDJC3, DMPAR, DQRFAC, -C DWUPDT, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (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 920205 Corrected XERN1 declaration. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DNLS1 - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - INTEGER IOPT,M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV - INTEGER IJUNK,NROW,IPVT(*) - DOUBLE PRECISION FTOL,XTOL,GTOL,FACTOR,EPSFCN - DOUBLE PRECISION X(*),FVEC(*),FJAC(LDFJAC,*),DIAG(*),QTF(*), - 1 WA1(*),WA2(*),WA3(*),WA4(*) - LOGICAL SING - EXTERNAL FCN - INTEGER I,IFLAG,ITER,J,L,MODECH - DOUBLE PRECISION ACTRED,DELTA,DIRDER,EPSMCH,FNORM,FNORM1,GNORM, - 1 ONE,PAR,PNORM,PRERED,P1,P5,P25,P75,P0001,RATIO,SUM,TEMP, - 2 TEMP1,TEMP2,XNORM,ZERO - DOUBLE PRECISION D1MACH,DENORM,ERR,CHKLIM - CHARACTER*8 XERN1 - CHARACTER*16 XERN3 - SAVE CHKLIM, ONE, P1, P5, P25, P75, P0001, ZERO -C - DATA CHKLIM/.1D0/ - DATA ONE,P1,P5,P25,P75,P0001,ZERO - 1 /1.0D0,1.0D-1,5.0D-1,2.5D-1,7.5D-1,1.0D-4,0.0D0/ -C***FIRST EXECUTABLE STATEMENT DNLS1 - EPSMCH = D1MACH(4) -C - INFO = 0 - IFLAG = 0 - NFEV = 0 - NJEV = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C - IF (IOPT .LT. 1 .OR. IOPT .GT. 3 .OR. N .LE. 0 .OR. - 1 M .LT. N .OR. LDFJAC .LT. N .OR. FTOL .LT. ZERO - 2 .OR. XTOL .LT. ZERO .OR. GTOL .LT. ZERO - 3 .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO) GO TO 300 - IF (IOPT .LT. 3 .AND. LDFJAC .LT. M) GO TO 300 - IF (MODE .NE. 2) GO TO 20 - DO 10 J = 1, N - IF (DIAG(J) .LE. ZERO) GO TO 300 - 10 CONTINUE - 20 CONTINUE -C -C EVALUATE THE FUNCTION AT THE STARTING POINT -C AND CALCULATE ITS NORM. -C - IFLAG = 1 - IJUNK = 1 - CALL FCN(IFLAG,M,N,X,FVEC,FJAC,IJUNK) - NFEV = 1 - IF (IFLAG .LT. 0) GO TO 300 - FNORM = DENORM(M,FVEC) -C -C INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER. -C - PAR = ZERO - ITER = 1 -C -C BEGINNING OF THE OUTER LOOP. -C - 30 CONTINUE -C -C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. -C - IF (NPRINT .LE. 0) GO TO 40 - IFLAG = 0 - IF (MOD(ITER-1,NPRINT) .EQ. 0) - 1 CALL FCN(IFLAG,M,N,X,FVEC,FJAC,IJUNK) - IF (IFLAG .LT. 0) GO TO 300 - 40 CONTINUE -C -C CALCULATE THE JACOBIAN MATRIX. -C - IF (IOPT .EQ. 3) GO TO 475 -C -C STORE THE FULL JACOBIAN USING M*N STORAGE -C - IF (IOPT .EQ. 1) GO TO 410 -C -C THE USER SUPPLIES THE JACOBIAN -C - IFLAG = 2 - CALL FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) - NJEV = NJEV + 1 -C -C ON THE FIRST ITERATION, CHECK THE USER SUPPLIED JACOBIAN -C - IF (ITER .LE. 1) THEN - IF (IFLAG .LT. 0) GO TO 300 -C -C GET THE INCREMENTED X-VALUES INTO WA1(*). -C - MODECH = 1 - CALL DCKDER(M,N,X,FVEC,FJAC,LDFJAC,WA1,WA4,MODECH,ERR) -C -C EVALUATE FUNCTION AT INCREMENTED VALUE AND PUT IN WA4(*). -C - IFLAG = 1 - CALL FCN(IFLAG,M,N,WA1,WA4,FJAC,LDFJAC) - NFEV = NFEV + 1 - IF(IFLAG .LT. 0) GO TO 300 - DO 350 I = 1, M - MODECH = 2 - CALL DCKDER(1,N,X,FVEC(I),FJAC(I,1),LDFJAC,WA1, - 1 WA4(I),MODECH,ERR) - IF (ERR .LT. CHKLIM) THEN - WRITE (XERN1, '(I8)') I - WRITE (XERN3, '(1PE15.6)') ERR - CALL XERMSG ('SLATEC', 'DNLS1', 'DERIVATIVE OF ' // - * 'FUNCTION ' // XERN1 // ' MAY BE WRONG, ERR = ' // - * XERN3 // ' TOO CLOSE TO 0.', 7, 0) - ENDIF - 350 CONTINUE - ENDIF -C - GO TO 420 -C -C THE CODE APPROXIMATES THE JACOBIAN -C -410 IFLAG = 1 - CALL DFDJC3(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA4) - NFEV = NFEV + N - 420 IF (IFLAG .LT. 0) GO TO 300 -C -C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. -C - CALL DQRFAC(M,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3) -C -C FORM (Q TRANSPOSE)*FVEC AND STORE THE FIRST N COMPONENTS IN -C QTF. -C - DO 430 I = 1, M - WA4(I) = FVEC(I) - 430 CONTINUE - DO 470 J = 1, N - IF (FJAC(J,J) .EQ. ZERO) GO TO 460 - SUM = ZERO - DO 440 I = J, M - SUM = SUM + FJAC(I,J)*WA4(I) - 440 CONTINUE - TEMP = -SUM/FJAC(J,J) - DO 450 I = J, M - WA4(I) = WA4(I) + FJAC(I,J)*TEMP - 450 CONTINUE - 460 CONTINUE - FJAC(J,J) = WA1(J) - QTF(J) = WA4(J) - 470 CONTINUE - GO TO 560 -C -C ACCUMULATE THE JACOBIAN BY ROWS IN ORDER TO SAVE STORAGE. -C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN MATRIX -C CALCULATED ONE ROW AT A TIME, WHILE SIMULTANEOUSLY -C FORMING (Q TRANSPOSE)*FVEC AND STORING THE FIRST -C N COMPONENTS IN QTF. -C - 475 DO 490 J = 1, N - QTF(J) = ZERO - DO 480 I = 1, N - FJAC(I,J) = ZERO - 480 CONTINUE - 490 CONTINUE - DO 500 I = 1, M - NROW = I - IFLAG = 3 - CALL FCN(IFLAG,M,N,X,FVEC,WA3,NROW) - IF (IFLAG .LT. 0) GO TO 300 -C -C ON THE FIRST ITERATION, CHECK THE USER SUPPLIED JACOBIAN. -C - IF(ITER .GT. 1) GO TO 498 -C -C GET THE INCREMENTED X-VALUES INTO WA1(*). -C - MODECH = 1 - CALL DCKDER(M,N,X,FVEC,FJAC,LDFJAC,WA1,WA4,MODECH,ERR) -C -C EVALUATE AT INCREMENTED VALUES, IF NOT ALREADY EVALUATED. -C - IF(I .NE. 1) GO TO 495 -C -C EVALUATE FUNCTION AT INCREMENTED VALUE AND PUT INTO WA4(*). -C - IFLAG = 1 - CALL FCN(IFLAG,M,N,WA1,WA4,FJAC,NROW) - NFEV = NFEV + 1 - IF(IFLAG .LT. 0) GO TO 300 -495 CONTINUE - MODECH = 2 - CALL DCKDER(1,N,X,FVEC(I),WA3,1,WA1,WA4(I),MODECH,ERR) - IF (ERR .LT. CHKLIM) THEN - WRITE (XERN1, '(I8)') I - WRITE (XERN3, '(1PE15.6)') ERR - CALL XERMSG ('SLATEC', 'DNLS1', 'DERIVATIVE OF FUNCTION ' - * // XERN1 // ' MAY BE WRONG, ERR = ' // XERN3 // - * ' TOO CLOSE TO 0.', 7, 0) - ENDIF -498 CONTINUE -C - TEMP = FVEC(I) - CALL DWUPDT(N,FJAC,LDFJAC,WA3,QTF,TEMP,WA1,WA2) - 500 CONTINUE - NJEV = NJEV + 1 -C -C IF THE JACOBIAN IS RANK DEFICIENT, CALL DQRFAC TO -C REORDER ITS COLUMNS AND UPDATE THE COMPONENTS OF QTF. -C - SING = .FALSE. - DO 510 J = 1, N - IF (FJAC(J,J) .EQ. ZERO) SING = .TRUE. - IPVT(J) = J - WA2(J) = DENORM(J,FJAC(1,J)) - 510 CONTINUE - IF (.NOT.SING) GO TO 560 - CALL DQRFAC(N,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3) - DO 550 J = 1, N - IF (FJAC(J,J) .EQ. ZERO) GO TO 540 - SUM = ZERO - DO 520 I = J, N - SUM = SUM + FJAC(I,J)*QTF(I) - 520 CONTINUE - TEMP = -SUM/FJAC(J,J) - DO 530 I = J, N - QTF(I) = QTF(I) + FJAC(I,J)*TEMP - 530 CONTINUE - 540 CONTINUE - FJAC(J,J) = WA1(J) - 550 CONTINUE - 560 CONTINUE -C -C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING -C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. -C - IF (ITER .NE. 1) GO TO 80 - IF (MODE .EQ. 2) GO TO 60 - DO 50 J = 1, N - DIAG(J) = WA2(J) - IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE - 50 CONTINUE - 60 CONTINUE -C -C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X -C AND INITIALIZE THE STEP BOUND DELTA. -C - DO 70 J = 1, N - WA3(J) = DIAG(J)*X(J) - 70 CONTINUE - XNORM = DENORM(N,WA3) - DELTA = FACTOR*XNORM - IF (DELTA .EQ. ZERO) DELTA = FACTOR - 80 CONTINUE -C -C COMPUTE THE NORM OF THE SCALED GRADIENT. -C - GNORM = ZERO - IF (FNORM .EQ. ZERO) GO TO 170 - DO 160 J = 1, N - L = IPVT(J) - IF (WA2(L) .EQ. ZERO) GO TO 150 - SUM = ZERO - DO 140 I = 1, J - SUM = SUM + FJAC(I,J)*(QTF(I)/FNORM) - 140 CONTINUE - GNORM = MAX(GNORM,ABS(SUM/WA2(L))) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE -C -C TEST FOR CONVERGENCE OF THE GRADIENT NORM. -C - IF (GNORM .LE. GTOL) INFO = 4 - IF (INFO .NE. 0) GO TO 300 -C -C RESCALE IF NECESSARY. -C - IF (MODE .EQ. 2) GO TO 190 - DO 180 J = 1, N - DIAG(J) = MAX(DIAG(J),WA2(J)) - 180 CONTINUE - 190 CONTINUE -C -C BEGINNING OF THE INNER LOOP. -C - 200 CONTINUE -C -C DETERMINE THE LEVENBERG-MARQUARDT PARAMETER. -C - CALL DMPAR(N,FJAC,LDFJAC,IPVT,DIAG,QTF,DELTA,PAR,WA1,WA2, - 1 WA3,WA4) -C -C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. -C - DO 210 J = 1, N - WA1(J) = -WA1(J) - WA2(J) = X(J) + WA1(J) - WA3(J) = DIAG(J)*WA1(J) - 210 CONTINUE - PNORM = DENORM(N,WA3) -C -C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. -C - IF (ITER .EQ. 1) DELTA = MIN(DELTA,PNORM) -C -C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. -C - IFLAG = 1 - CALL FCN(IFLAG,M,N,WA2,WA4,FJAC,IJUNK) - NFEV = NFEV + 1 - IF (IFLAG .LT. 0) GO TO 300 - FNORM1 = DENORM(M,WA4) -C -C COMPUTE THE SCALED ACTUAL REDUCTION. -C - ACTRED = -ONE - IF (P1*FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 -C -C COMPUTE THE SCALED PREDICTED REDUCTION AND -C THE SCALED DIRECTIONAL DERIVATIVE. -C - DO 230 J = 1, N - WA3(J) = ZERO - L = IPVT(J) - TEMP = WA1(L) - DO 220 I = 1, J - WA3(I) = WA3(I) + FJAC(I,J)*TEMP - 220 CONTINUE - 230 CONTINUE - TEMP1 = DENORM(N,WA3)/FNORM - TEMP2 = (SQRT(PAR)*PNORM)/FNORM - PRERED = TEMP1**2 + TEMP2**2/P5 - DIRDER = -(TEMP1**2 + TEMP2**2) -C -C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED -C REDUCTION. -C - RATIO = ZERO - IF (PRERED .NE. ZERO) RATIO = ACTRED/PRERED -C -C UPDATE THE STEP BOUND. -C - IF (RATIO .GT. P25) GO TO 240 - IF (ACTRED .GE. ZERO) TEMP = P5 - IF (ACTRED .LT. ZERO) - 1 TEMP = P5*DIRDER/(DIRDER + P5*ACTRED) - IF (P1*FNORM1 .GE. FNORM .OR. TEMP .LT. P1) TEMP = P1 - DELTA = TEMP*MIN(DELTA,PNORM/P1) - PAR = PAR/TEMP - GO TO 260 - 240 CONTINUE - IF (PAR .NE. ZERO .AND. RATIO .LT. P75) GO TO 250 - DELTA = PNORM/P5 - PAR = P5*PAR - 250 CONTINUE - 260 CONTINUE -C -C TEST FOR SUCCESSFUL ITERATION. -C - IF (RATIO .LT. P0001) GO TO 290 -C -C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. -C - DO 270 J = 1, N - X(J) = WA2(J) - WA2(J) = DIAG(J)*X(J) - 270 CONTINUE - DO 280 I = 1, M - FVEC(I) = WA4(I) - 280 CONTINUE - XNORM = DENORM(N,WA2) - FNORM = FNORM1 - ITER = ITER + 1 - 290 CONTINUE -C -C TESTS FOR CONVERGENCE. -C - IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL - 1 .AND. P5*RATIO .LE. ONE) INFO = 1 - IF (DELTA .LE. XTOL*XNORM) INFO = 2 - IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL - 1 .AND. P5*RATIO .LE. ONE .AND. INFO .EQ. 2) INFO = 3 - IF (INFO .NE. 0) GO TO 300 -C -C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. -C - IF (NFEV .GE. MAXFEV) INFO = 5 - IF (ABS(ACTRED) .LE. EPSMCH .AND. PRERED .LE. EPSMCH - 1 .AND. P5*RATIO .LE. ONE) INFO = 6 - IF (DELTA .LE. EPSMCH*XNORM) INFO = 7 - IF (GNORM .LE. EPSMCH) INFO = 8 - IF (INFO .NE. 0) GO TO 300 -C -C END OF THE INNER LOOP. REPEAT IF ITERATION UNSUCCESSFUL. -C - IF (RATIO .LT. P0001) GO TO 200 -C -C END OF THE OUTER LOOP. -C - GO TO 30 - 300 CONTINUE -C -C TERMINATION, EITHER NORMAL OR USER IMPOSED. -C - IF (IFLAG .LT. 0) INFO = IFLAG - IFLAG = 0 - IF (NPRINT .GT. 0) CALL FCN(IFLAG,M,N,X,FVEC,FJAC,IJUNK) - IF (INFO .LT. 0) CALL XERMSG ('SLATEC', 'DNLS1', - + 'EXECUTION TERMINATED BECAUSE USER SET IFLAG NEGATIVE.', 1, 1) - IF (INFO .EQ. 0) CALL XERMSG ('SLATEC', 'DNLS1', - + 'INVALID INPUT PARAMETER.', 2, 1) - IF (INFO .EQ. 4) CALL XERMSG ('SLATEC', 'DNLS1', - + 'THIRD CONVERGENCE CONDITION, CHECK RESULTS BEFORE ACCEPTING.', - + 1, 1) - IF (INFO .EQ. 5) CALL XERMSG ('SLATEC', 'DNLS1', - + 'TOO MANY FUNCTION EVALUATIONS.', 9, 1) - IF (INFO .GE. 6) CALL XERMSG ('SLATEC', 'DNLS1', - + 'TOLERANCES TOO SMALL, NO FURTHER IMPROVEMENT POSSIBLE.', 3, 1) - RETURN -C -C LAST CARD OF SUBROUTINE DNLS1. -C - END diff --git a/slatec/dnls1e.f b/slatec/dnls1e.f deleted file mode 100644 index 668b516..0000000 --- a/slatec/dnls1e.f +++ /dev/null @@ -1,536 +0,0 @@ -*DECK DNLS1E - SUBROUTINE DNLS1E (FCN, IOPT, M, N, X, FVEC, TOL, NPRINT, INFO, - + IW, WA, LWA) -C***BEGIN PROLOGUE DNLS1E -C***PURPOSE An easy-to-use code which minimizes the sum of the squares -C of M nonlinear functions in N variables by a modification -C of the Levenberg-Marquardt algorithm. -C***LIBRARY SLATEC -C***CATEGORY K1B1A1, K1B1A2 -C***TYPE DOUBLE PRECISION (SNLS1E-S, DNLS1E-D) -C***KEYWORDS EASY-TO-USE, LEVENBERG-MARQUARDT, NONLINEAR DATA FITTING, -C NONLINEAR LEAST SQUARES -C***AUTHOR Hiebert, K. L., (SNLA) -C***DESCRIPTION -C -C 1. Purpose. -C -C The purpose of DNLS1E is to minimize the sum of the squares of M -C nonlinear functions in N variables by a modification of the -C Levenberg-Marquardt algorithm. This is done by using the more -C general least-squares solver DNLS1. The user must provide a -C subroutine which calculates the functions. The user has the -C option of how the Jacobian will be supplied. The user can -C supply the full Jacobian, or the rows of the Jacobian (to avoid -C storing the full Jacobian), or let the code approximate the -C Jacobian by forward-differencing. This code is the combination -C of the MINPACK codes (Argonne) LMDER1, LMDIF1, and LMSTR1. -C -C -C 2. Subroutine and Type Statements. -C -C SUBROUTINE DNLS1E(FCN,IOPT,M,N,X,FVEC,TOL,NPRINT, -C * INFO,IW,WA,LWA) -C INTEGER IOPT,M,N,NPRINT,INFO,LWAC,IW(N) -C DOUBLE PRECISION TOL,X(N),FVEC(M),WA(LWA) -C EXTERNAL FCN -C -C -C 3. Parameters. ALL TYPE REAL parameters are DOUBLE PRECISION -C -C Parameters designated as input parameters must be specified on -C entry to DNLS1E and are not changed on exit, while parameters -C designated as output parameters need not be specified on entry -C and are set to appropriate values on exit from DNLS1E. -C -C FCN is the name of the user-supplied subroutine which calculates -C the functions. If the user wants to supply the Jacobian -C (IOPT=2 or 3), then FCN must be written to calculate the -C Jacobian, as well as the functions. See the explanation -C of the IOPT argument below. -C If the user wants the iterates printed (NPRINT positive), then -C FCN must do the printing. See the explanation of NPRINT -C below. FCN must be declared in an EXTERNAL statement in the -C calling program and should be written as follows. -C -C -C SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) -C INTEGER IFLAG,LDFJAC,M,N -C DOUBLE PRECISION X(N),FVEC(M) -C ---------- -C FJAC and LDFJAC may be ignored , if IOPT=1. -C DOUBLE PRECISION FJAC(LDFJAC,N) , if IOPT=2. -C DOUBLE PRECISION FJAC(N) , if IOPT=3. -C ---------- -C If IFLAG=0, the values in X and FVEC are available -C for printing. See the explanation of NPRINT below. -C IFLAG will never be zero unless NPRINT is positive. -C The values of X and FVEC must not be changed. -C RETURN -C ---------- -C If IFLAG=1, calculate the functions at X and return -C this vector in FVEC. -C RETURN -C ---------- -C If IFLAG=2, calculate the full Jacobian at X and return -C this matrix in FJAC. Note that IFLAG will never be 2 unless -C IOPT=2. FVEC contains the function values at X and must -C not be altered. FJAC(I,J) must be set to the derivative -C of FVEC(I) with respect to X(J). -C RETURN -C ---------- -C If IFLAG=3, calculate the LDFJAC-th row of the Jacobian -C and return this vector in FJAC. Note that IFLAG will -C never be 3 unless IOPT=3. FVEC contains the function -C values at X and must not be altered. FJAC(J) must be -C set to the derivative of FVEC(LDFJAC) with respect to X(J). -C RETURN -C ---------- -C END -C -C -C The value of IFLAG should not be changed by FCN unless the -C user wants to terminate execution of DNLS1E. In this case, -C set IFLAG to a negative integer. -C -C -C IOPT is an input variable which specifies how the Jacobian will -C be calculated. If IOPT=2 or 3, then the user must supply the -C Jacobian, as well as the function values, through the -C subroutine FCN. If IOPT=2, the user supplies the full -C Jacobian with one call to FCN. If IOPT=3, the user supplies -C one row of the Jacobian with each call. (In this manner, -C storage can be saved because the full Jacobian is not stored.) -C If IOPT=1, the code will approximate the Jacobian by forward -C differencing. -C -C M is a positive integer input variable set to the number of -C functions. -C -C N is a positive integer input variable set to the number of -C variables. N must not exceed M. -C -C X is an array of length N. On input, X must contain an initial -C estimate of the solution vector. On output, X contains the -C final estimate of the solution vector. -C -C FVEC is an output array of length M which contains the functions -C evaluated at the output X. -C -C TOL is a non-negative input variable. Termination occurs when -C the algorithm estimates either that the relative error in the -C sum of squares is at most TOL or that the relative error -C between X and the solution is at most TOL. Section 4 contains -C more details about TOL. -C -C NPRINT is an integer input variable that enables controlled -C printing of iterates if it is positive. In this case, FCN is -C called with IFLAG = 0 at the beginning of the first iteration -C and every NPRINT iterations thereafter and immediately prior -C to return, with X and FVEC available for printing. Appropriate -C print statements must be added to FCN (see example) and -C FVEC should not be altered. If NPRINT is not positive, no -C special calls of FCN with IFLAG = 0 are made. -C -C INFO is an integer output variable. If the user has terminated -C execution, INFO is set to the (negative) value of IFLAG. See -C description of FCN and JAC. Otherwise, INFO is set as follows. -C -C INFO = 0 improper input parameters. -C -C INFO = 1 algorithm estimates that the relative error in the -C sum of squares is at most TOL. -C -C INFO = 2 algorithm estimates that the relative error between -C X and the solution is at most TOL. -C -C INFO = 3 conditions for INFO = 1 and INFO = 2 both hold. -C -C INFO = 4 FVEC is orthogonal to the columns of the Jacobian to -C machine precision. -C -C INFO = 5 number of calls to FCN has reached 100*(N+1) -C for IOPT=2 or 3 or 200*(N+1) for IOPT=1. -C -C INFO = 6 TOL is too small. No further reduction in the sum -C of squares is possible. -C -C INFO = 7 TOL is too small. No further improvement in the -C approximate solution X is possible. -C -C Sections 4 and 5 contain more details about INFO. -C -C IW is an INTEGER work array of length N. -C -C WA is a work array of length LWA. -C -C LWA is a positive integer input variable not less than -C N*(M+5)+M for IOPT=1 and 2 or N*(N+5)+M for IOPT=3. -C -C -C 4. Successful Completion. -C -C The accuracy of DNLS1E is controlled by the convergence parame- -C ter TOL. This parameter is used in tests which make three types -C of comparisons between the approximation X and a solution XSOL. -C DNLS1E terminates when any of the tests is satisfied. If TOL is -C less than the machine precision (as defined by the function -C R1MACH(4)), then DNLS1E only attempts to satisfy the test -C defined by the machine precision. Further progress is not usu- -C ally possible. Unless high precision solutions are required, -C the recommended value for TOL is the square root of the machine -C precision. -C -C The tests assume that the functions are reasonably well behaved, -C and, if the Jacobian is supplied by the user, that the functions -C and the Jacobian are coded consistently. If these conditions -C are not satisfied, then DNLS1E may incorrectly indicate conver- -C gence. If the Jacobian is coded correctly or IOPT=1, -C then the validity of the answer can be checked, for example, by -C rerunning DNLS1E with tighter tolerances. -C -C First Convergence Test. If ENORM(Z) denotes the Euclidean norm -C of a vector Z, then this test attempts to guarantee that -C -C ENORM(FVEC) .LE. (1+TOL)*ENORM(FVECS), -C -C where FVECS denotes the functions evaluated at XSOL. If this -C condition is satisfied with TOL = 10**(-K), then the final -C residual norm ENORM(FVEC) has K significant decimal digits and -C INFO is set to 1 (or to 3 if the second test is also satis- -C fied). -C -C Second Convergence Test. If D is a diagonal matrix (implicitly -C generated by DNLS1E) whose entries contain scale factors for -C the variables, then this test attempts to guarantee that -C -C ENORM(D*(X-XSOL)) .LE. TOL*ENORM(D*XSOL). -C -C If this condition is satisfied with TOL = 10**(-K), then the -C larger components of D*X have K significant decimal digits and -C INFO is set to 2 (or to 3 if the first test is also satis- -C fied). There is a danger that the smaller components of D*X -C may have large relative errors, but the choice of D is such -C that the accuracy of the components of X is usually related to -C their sensitivity. -C -C Third Convergence Test. This test is satisfied when FVEC is -C orthogonal to the columns of the Jacobian to machine preci- -C sion. There is no clear relationship between this test and -C the accuracy of DNLS1E, and furthermore, the test is equally -C well satisfied at other critical points, namely maximizers and -C saddle points. Therefore, termination caused by this test -C (INFO = 4) should be examined carefully. -C -C -C 5. Unsuccessful Completion. -C -C Unsuccessful termination of DNLS1E can be due to improper input -C parameters, arithmetic interrupts, or an excessive number of -C function evaluations. -C -C Improper Input Parameters. INFO is set to 0 if IOPT .LT. 1 -C or IOPT .GT. 3, or N .LE. 0, or M .LT. N, or TOL .LT. 0.E0, -C or for IOPT=1 or 2 LWA .LT. N*(M+5)+M, or for IOPT=3 -C LWA .LT. N*(N+5)+M. -C -C Arithmetic Interrupts. If these interrupts occur in the FCN -C subroutine during an early stage of the computation, they may -C be caused by an unacceptable choice of X by DNLS1E. In this -C case, it may be possible to remedy the situation by not evalu- -C ating the functions here, but instead setting the components -C of FVEC to numbers that exceed those in the initial FVEC. -C -C Excessive Number of Function Evaluations. If the number of -C calls to FCN reaches 100*(N+1) for IOPT=2 or 3 or 200*(N+1) -C for IOPT=1, then this indicates that the routine is converging -C very slowly as measured by the progress of FVEC, and INFO is -C set to 5. In this case, it may be helpful to restart DNLS1E, -C thereby forcing it to disregard old (and possibly harmful) -C information. -C -C -C 6. Characteristics of the Algorithm. -C -C DNLS1E is a modification of the Levenberg-Marquardt algorithm. -C Two of its main characteristics involve the proper use of -C implicitly scaled variables and an optimal choice for the cor- -C rection. The use of implicitly scaled variables achieves scale -C invariance of DNLS1E and limits the size of the correction in -C any direction where the functions are changing rapidly. The -C optimal choice of the correction guarantees (under reasonable -C conditions) global convergence from starting points far from the -C solution and a fast rate of convergence for problems with small -C residuals. -C -C Timing. The time required by DNLS1E to solve a given problem -C depends on M and N, the behavior of the functions, the accu- -C racy requested, and the starting point. The number of arith- -C metic operations needed by DNLS1E is about N**3 to process -C each evaluation of the functions (call to FCN) and to process -C each evaluation of the Jacobian DNLS1E takes M*N**2 for IOPT=2 -C (one call to JAC), M*N**2 for IOPT=1 (N calls to FCN) and -C 1.5*M*N**2 for IOPT=3 (M calls to FCN). Unless FCN -C can be evaluated quickly, the timing of DNLS1E will be -C strongly influenced by the time spent in FCN. -C -C Storage. DNLS1E requires (M*N + 2*M + 6*N) for IOPT=1 or 2 and -C (N**2 + 2*M + 6*N) for IOPT=3 single precision storage -C locations and N integer storage locations, in addition to -C the storage required by the program. There are no internally -C declared storage arrays. -C -C *Long Description: -C -C 7. Example. -C -C The problem is to determine the values of X(1), X(2), and X(3) -C which provide the best fit (in the least squares sense) of -C -C X(1) + U(I)/(V(I)*X(2) + W(I)*X(3)), I = 1, 15 -C -C to the data -C -C Y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, -C 0.37,0.58,0.73,0.96,1.34,2.10,4.39), -C -C where U(I) = I, V(I) = 16 - I, and W(I) = MIN(U(I),V(I)). The -C I-th component of FVEC is thus defined by -C -C Y(I) - (X(1) + U(I)/(V(I)*X(2) + W(I)*X(3))). -C -C ********** -C -C PROGRAM TEST -C C -C C Driver for DNLS1E example. -C C -C INTEGER I,IOPT,M,N,NPRINT,JNFO,LWA,NWRITE -C INTEGER IW(3) -C DOUBLE PRECISION TOL,FNORM,X(3),FVEC(15),WA(75) -C DOUBLE PRECISION DENORM,D1MACH -C EXTERNAL FCN -C DATA NWRITE /6/ -C C -C IOPT = 1 -C M = 15 -C N = 3 -C C -C C The following starting values provide a rough fit. -C C -C X(1) = 1.E0 -C X(2) = 1.E0 -C X(3) = 1.E0 -C C -C LWA = 75 -C NPRINT = 0 -C C -C C Set TOL to the square root of the machine precision. -C C Unless high precision solutions are required, -C C this is the recommended setting. -C C -C TOL = SQRT(R1MACH(4)) -C C -C CALL DNLS1E(FCN,IOPT,M,N,X,FVEC,TOL,NPRINT, -C * INFO,IW,WA,LWA) -C FNORM = ENORM(M,FVEC) -C WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) -C STOP -C 1000 FORMAT (5X,' FINAL L2 NORM OF THE RESIDUALS',E15.7 // -C * 5X,' EXIT -C * 5X,' FINAL APPROXIMATE SOLUTION' // 5X,3E15.7) -C END -C SUBROUTINE FCN(IFLAG,M,N,X,FVEC,DUM,IDUM) -C C This is the form of the FCN routine if IOPT=1, -C C that is, if the user does not calculate the Jacobian. -C INTEGER I,M,N,IFLAG -C DOUBLE PRECISION X(N),FVEC(M),Y(15) -C DOUBLE PRECISION TMP1,TMP2,TMP3,TMP4 -C DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), -C * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) -C * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, -C * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ -C C -C IF (IFLAG .NE. 0) GO TO 5 -C C -C C Insert print statements here when NPRINT is positive. -C C -C RETURN -C 5 CONTINUE -C DO 10 I = 1, M -C TMP1 = I -C TMP2 = 16 - I -C TMP3 = TMP1 -C IF (I .GT. 8) TMP3 = TMP2 -C FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) -C 10 CONTINUE -C RETURN -C END -C -C -C Results obtained with different compilers or machines -C may be slightly different. -C -C FINAL L2 NORM OF THE RESIDUALS 0.9063596E-01 -C -C EXIT PARAMETER 1 -C -C FINAL APPROXIMATE SOLUTION -C -C 0.8241058E-01 0.1133037E+01 0.2343695E+01 -C -C -C For IOPT=2, FCN would be modified as follows to also -C calculate the full Jacobian when IFLAG=2. -C -C SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) -C C -C C This is the form of the FCN routine if IOPT=2, -C C that is, if the user calculates the full Jacobian. -C C -C INTEGER I,LDFJAC,M,N,IFLAG -C DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),Y(15) -C DOUBLE PRECISION TMP1,TMP2,TMP3,TMP4 -C DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), -C * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) -C * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, -C * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ -C C -C IF (IFLAG .NE. 0) GO TO 5 -C C -C C Insert print statements here when NPRINT is positive. -C C -C RETURN -C 5 CONTINUE -C IF(IFLAG.NE.1) GO TO 20 -C DO 10 I = 1, M -C TMP1 = I -C TMP2 = 16 - I -C TMP3 = TMP1 -C IF (I .GT. 8) TMP3 = TMP2 -C FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) -C 10 CONTINUE -C RETURN -C C -C C Below, calculate the full Jacobian. -C C -C 20 CONTINUE -C C -C DO 30 I = 1, M -C TMP1 = I -C TMP2 = 16 - I -C TMP3 = TMP1 -C IF (I .GT. 8) TMP3 = TMP2 -C TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 -C FJAC(I,1) = -1.E0 -C FJAC(I,2) = TMP1*TMP2/TMP4 -C FJAC(I,3) = TMP1*TMP3/TMP4 -C 30 CONTINUE -C RETURN -C END -C -C -C For IOPT = 3, FJAC would be dimensioned as FJAC(3,3), -C LDFJAC would be set to 3, and FCN would be written as -C follows to calculate a row of the Jacobian when IFLAG=3. -C -C SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) -C C This is the form of the FCN routine if IOPT=3, -C C that is, if the user calculates the Jacobian row by row. -C INTEGER I,M,N,IFLAG -C DOUBLE PRECISION X(N),FVEC(M),FJAC(N),Y(15) -C DOUBLE PRECISION TMP1,TMP2,TMP3,TMP4 -C DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), -C * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) -C * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, -C * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ -C C -C IF (IFLAG .NE. 0) GO TO 5 -C C -C C Insert print statements here when NPRINT is positive. -C C -C RETURN -C 5 CONTINUE -C IF( IFLAG.NE.1) GO TO 20 -C DO 10 I = 1, M -C TMP1 = I -C TMP2 = 16 - I -C TMP3 = TMP1 -C IF (I .GT. 8) TMP3 = TMP2 -C FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) -C 10 CONTINUE -C RETURN -C C -C C Below, calculate the LDFJAC-th row of the Jacobian. -C C -C 20 CONTINUE -C -C I = LDFJAC -C TMP1 = I -C TMP2 = 16 - I -C TMP3 = TMP1 -C IF (I .GT. 8) TMP3 = TMP2 -C TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 -C FJAC(1) = -1.E0 -C FJAC(2) = TMP1*TMP2/TMP4 -C FJAC(3) = TMP1*TMP3/TMP4 -C RETURN -C END -C -C***REFERENCES Jorge J. More, The Levenberg-Marquardt algorithm: -C implementation and theory. In Numerical Analysis -C Proceedings (Dundee, June 28 - July 1, 1977, G. A. -C Watson, Editor), Lecture Notes in Mathematics 630, -C Springer-Verlag, 1978. -C***ROUTINES CALLED DNLS1, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890831 Modified array declarations. (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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DNLS1E - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - INTEGER M,N,NPRINT,INFO,LWA,IOPT - INTEGER INDEX,IW(*) - DOUBLE PRECISION TOL - DOUBLE PRECISION X(*),FVEC(*),WA(*) - EXTERNAL FCN - INTEGER MAXFEV,MODE,NFEV,NJEV - DOUBLE PRECISION FACTOR,FTOL,GTOL,XTOL,ZERO,EPSFCN - SAVE FACTOR, ZERO - DATA FACTOR,ZERO /1.0D2,0.0D0/ -C***FIRST EXECUTABLE STATEMENT DNLS1E - INFO = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C - IF (IOPT .LT. 1 .OR. IOPT .GT. 3 .OR. - 1 N .LE. 0 .OR. M .LT. N .OR. TOL .LT. ZERO - 2 .OR. LWA .LT. N*(N+5) + M) GO TO 10 - IF (IOPT .LT. 3 .AND. LWA .LT. N*(M+5) + M) GO TO 10 -C -C CALL DNLS1. -C - MAXFEV = 100*(N + 1) - IF (IOPT .EQ. 1) MAXFEV = 2*MAXFEV - FTOL = TOL - XTOL = TOL - GTOL = ZERO - EPSFCN = ZERO - MODE = 1 - INDEX = 5*N+M - CALL DNLS1(FCN,IOPT,M,N,X,FVEC,WA(INDEX+1),M,FTOL,XTOL,GTOL, - 1 MAXFEV,EPSFCN,WA(1),MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, - 2 IW,WA(N+1),WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) - IF (INFO .EQ. 8) INFO = 4 - 10 CONTINUE - IF (INFO .EQ. 0) CALL XERMSG ('SLATEC', 'DNLS1E', - + 'INVALID INPUT PARAMETER.', 2, 1) - RETURN -C -C LAST CARD OF SUBROUTINE DNLS1E. -C - END diff --git a/slatec/dnrm2.f b/slatec/dnrm2.f deleted file mode 100644 index 22e0226..0000000 --- a/slatec/dnrm2.f +++ /dev/null @@ -1,162 +0,0 @@ -*DECK DNRM2 - DOUBLE PRECISION FUNCTION DNRM2 (N, DX, INCX) -C***BEGIN PROLOGUE DNRM2 -C***PURPOSE Compute the Euclidean length (L2 norm) of a vector. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A3B -C***TYPE DOUBLE PRECISION (SNRM2-S, DNRM2-D, SCNRM2-C) -C***KEYWORDS BLAS, EUCLIDEAN LENGTH, EUCLIDEAN NORM, L2, -C LINEAR ALGEBRA, UNITARY, 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 DX double precision vector with N elements -C INCX storage spacing between elements of DX -C -C --Output-- -C DNRM2 double precision result (zero if N .LE. 0) -C -C Euclidean norm of the N-vector stored in DX with storage -C increment INCX. -C If N .LE. 0, return with result = 0. -C If N .GE. 1, then INCX must be .GE. 1 -C -C Four phase method using two built-in constants that are -C hopefully applicable to all machines. -C CUTLO = maximum of SQRT(U/EPS) over all known machines. -C CUTHI = minimum of SQRT(V) over all known machines. -C where -C EPS = smallest no. such that EPS + 1. .GT. 1. -C U = smallest positive no. (underflow limit) -C V = largest no. (overflow limit) -C -C Brief outline of algorithm. -C -C Phase 1 scans zero components. -C move to phase 2 when a component is nonzero and .LE. CUTLO -C move to phase 3 when a component is .GT. CUTLO -C move to phase 4 when a component is .GE. CUTHI/M -C where M = N for X() real and M = 2*N for complex. -C -C Values for CUTLO and CUTHI. -C From the environmental parameters listed in the IMSL converter -C document the limiting values are as follows: -C CUTLO, S.P. U/EPS = 2**(-102) for Honeywell. Close seconds are -C Univac and DEC at 2**(-103) -C Thus CUTLO = 2**(-51) = 4.44089E-16 -C CUTHI, S.P. V = 2**127 for Univac, Honeywell, and DEC. -C Thus CUTHI = 2**(63.5) = 1.30438E19 -C CUTLO, D.P. U/EPS = 2**(-67) for Honeywell and DEC. -C Thus CUTLO = 2**(-33.5) = 8.23181D-11 -C CUTHI, D.P. same as S.P. CUTHI = 1.30438D19 -C DATA CUTLO, CUTHI /8.232D-11, 1.304D19/ -C DATA CUTLO, CUTHI /4.441E-16, 1.304E19/ -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 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DNRM2 - INTEGER NEXT - DOUBLE PRECISION DX(*), CUTLO, CUTHI, HITEST, SUM, XMAX, ZERO, - + ONE - SAVE CUTLO, CUTHI, ZERO, ONE - DATA ZERO, ONE /0.0D0, 1.0D0/ -C - DATA CUTLO, CUTHI /8.232D-11, 1.304D19/ -C***FIRST EXECUTABLE STATEMENT DNRM2 - IF (N .GT. 0) GO TO 10 - DNRM2 = ZERO - GO TO 300 -C - 10 ASSIGN 30 TO NEXT - SUM = ZERO - NN = N * INCX -C -C BEGIN MAIN LOOP -C - I = 1 - 20 GO TO NEXT,(30, 50, 70, 110) - 30 IF (ABS(DX(I)) .GT. CUTLO) GO TO 85 - ASSIGN 50 TO NEXT - XMAX = ZERO -C -C PHASE 1. SUM IS ZERO -C - 50 IF (DX(I) .EQ. ZERO) GO TO 200 - IF (ABS(DX(I)) .GT. CUTLO) GO TO 85 -C -C PREPARE FOR PHASE 2. -C - ASSIGN 70 TO NEXT - GO TO 105 -C -C PREPARE FOR PHASE 4. -C - 100 I = J - ASSIGN 110 TO NEXT - SUM = (SUM / DX(I)) / DX(I) - 105 XMAX = ABS(DX(I)) - GO TO 115 -C -C PHASE 2. SUM IS SMALL. -C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. -C - 70 IF (ABS(DX(I)) .GT. CUTLO) GO TO 75 -C -C COMMON CODE FOR PHASES 2 AND 4. -C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. -C - 110 IF (ABS(DX(I)) .LE. XMAX) GO TO 115 - SUM = ONE + SUM * (XMAX / DX(I))**2 - XMAX = ABS(DX(I)) - GO TO 200 -C - 115 SUM = SUM + (DX(I)/XMAX)**2 - GO TO 200 -C -C PREPARE FOR PHASE 3. -C - 75 SUM = (SUM * XMAX) * XMAX -C -C FOR REAL OR D.P. SET HITEST = CUTHI/N -C FOR COMPLEX SET HITEST = CUTHI/(2*N) -C - 85 HITEST = CUTHI / N -C -C PHASE 3. SUM IS MID-RANGE. NO SCALING. -C - DO 95 J = I,NN,INCX - IF (ABS(DX(J)) .GE. HITEST) GO TO 100 - 95 SUM = SUM + DX(J)**2 - DNRM2 = SQRT(SUM) - GO TO 300 -C - 200 CONTINUE - I = I + INCX - IF (I .LE. NN) GO TO 20 -C -C END OF MAIN LOOP. -C -C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. -C - DNRM2 = XMAX * SQRT(SUM) - 300 CONTINUE - RETURN - END diff --git a/slatec/dnsq.f b/slatec/dnsq.f deleted file mode 100644 index 32e20f3..0000000 --- a/slatec/dnsq.f +++ /dev/null @@ -1,752 +0,0 @@ -*DECK DNSQ - SUBROUTINE DNSQ (FCN, JAC, IOPT, N, X, FVEC, FJAC, LDFJAC, XTOL, - + MAXFEV, ML, MU, EPSFCN, DIAG, MODE, FACTOR, NPRINT, INFO, NFEV, - + NJEV, R, LR, QTF, WA1, WA2, WA3, WA4) -C***BEGIN PROLOGUE DNSQ -C***PURPOSE Find a zero of a system of a N nonlinear functions in N -C variables by a modification of the Powell hybrid method. -C***LIBRARY SLATEC -C***CATEGORY F2A -C***TYPE DOUBLE PRECISION (SNSQ-S, DNSQ-D) -C***KEYWORDS NONLINEAR SQUARE SYSTEM, POWELL HYBRID METHOD, ZEROS -C***AUTHOR Hiebert, K. L. (SNLA) -C***DESCRIPTION -C -C 1. Purpose. -C -C The purpose of DNSQ is to find a zero of a system of N nonlinear -C functions in N variables by a modification of the Powell -C hybrid method. The user must provide a subroutine which -C calculates the functions. The user has the option of either to -C provide a subroutine which calculates the Jacobian or to let the -C code calculate it by a forward-difference approximation. -C This code is the combination of the MINPACK codes (Argonne) -C HYBRD and HYBRDJ. -C -C 2. Subroutine and Type Statements. -C -C SUBROUTINE DNSQ(FCN,JAC,IOPT,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV, -C * ML,MU,EPSFCN,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV, -C * NJEV,R,LR,QTF,WA1,WA2,WA3,WA4) -C INTEGER IOPT,N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,NJEV,LR -C DOUBLE PRECISION XTOL,EPSFCN,FACTOR -C DOUBLE PRECISION -C X(N),FVEC(N),DIAG(N),FJAC(LDFJAC,N),R(LR),QTF(N), -C * WA1(N),WA2(N),WA3(N),WA4(N) -C EXTERNAL FCN,JAC -C -C 3. Parameters. -C -C Parameters designated as input parameters must be specified on -C entry to DNSQ and are not changed on exit, while parameters -C designated as output parameters need not be specified on entry -C and are set to appropriate values on exit from DNSQ. -C -C FCN is the name of the user-supplied subroutine which calculates -C the functions. FCN must be declared in an EXTERNAL statement -C in the user calling program, and should be written as follows. -C -C SUBROUTINE FCN(N,X,FVEC,IFLAG) -C INTEGER N,IFLAG -C DOUBLE PRECISION X(N),FVEC(N) -C ---------- -C CALCULATE THE FUNCTIONS AT X AND -C RETURN THIS VECTOR IN FVEC. -C ---------- -C RETURN -C END -C -C The value of IFLAG should not be changed by FCN unless the -C user wants to terminate execution of DNSQ. In this case set -C IFLAG to a negative integer. -C -C JAC is the name of the user-supplied subroutine which calculates -C the Jacobian. If IOPT=1, then JAC must be declared in an -C EXTERNAL statement in the user calling program, and should be -C written as follows. -C -C SUBROUTINE JAC(N,X,FVEC,FJAC,LDFJAC,IFLAG) -C INTEGER N,LDFJAC,IFLAG -C DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N) -C ---------- -C Calculate the Jacobian at X and return this -C matrix in FJAC. FVEC contains the function -C values at X and should not be altered. -C ---------- -C RETURN -C END -C -C The value of IFLAG should not be changed by JAC unless the -C user wants to terminate execution of DNSQ. In this case set -C IFLAG to a negative integer. -C -C If IOPT=2, JAC can be ignored (treat it as a dummy argument). -C -C IOPT is an input variable which specifies how the Jacobian will -C be calculated. If IOPT=1, then the user must supply the -C Jacobian through the subroutine JAC. If IOPT=2, then the -C code will approximate the Jacobian by forward-differencing. -C -C N is a positive integer input variable set to the number of -C functions and variables. -C -C X is an array of length N. On input X must contain an initial -C estimate of the solution vector. On output X contains the -C final estimate of the solution vector. -C -C FVEC is an output array of length N which contains the functions -C evaluated at the output X. -C -C FJAC is an output N by N array which contains the orthogonal -C matrix Q produced by the QR factorization of the final -C approximate Jacobian. -C -C LDFJAC is a positive integer input variable not less than N -C which specifies the leading dimension of the array FJAC. -C -C XTOL is a nonnegative input variable. Termination occurs when -C the relative error between two consecutive iterates is at most -C XTOL. Therefore, XTOL measures the relative error desired in -C the approximate solution. Section 4 contains more details -C about XTOL. -C -C MAXFEV is a positive integer input variable. Termination occurs -C when the number of calls to FCN is at least MAXFEV by the end -C of an iteration. -C -C ML is a nonnegative integer input variable which specifies the -C number of subdiagonals within the band of the Jacobian matrix. -C If the Jacobian is not banded or IOPT=1, set ML to at -C least N - 1. -C -C MU is a nonnegative integer input variable which specifies the -C number of superdiagonals within the band of the Jacobian -C matrix. If the Jacobian is not banded or IOPT=1, set MU to at -C least N - 1. -C -C EPSFCN is an input variable used in determining a suitable step -C for the forward-difference approximation. This approximation -C assumes that the relative errors in the functions are of the -C order of EPSFCN. If EPSFCN is less than the machine -C precision, it is assumed that the relative errors in the -C functions are of the order of the machine precision. If -C IOPT=1, then EPSFCN can be ignored (treat it as a dummy -C argument). -C -C DIAG is an array of length N. If MODE = 1 (see below), DIAG is -C internally set. If MODE = 2, DIAG must contain positive -C entries that serve as implicit (multiplicative) scale factors -C for the variables. -C -C MODE is an integer input variable. If MODE = 1, the variables -C will be scaled internally. If MODE = 2, the scaling is -C specified by the input DIAG. Other values of MODE are -C equivalent to MODE = 1. -C -C FACTOR is a positive input variable used in determining the -C initial step bound. This bound is set to the product of -C FACTOR and the Euclidean norm of DIAG*X if nonzero, or else to -C FACTOR itself. In most cases FACTOR should lie in the -C interval (.1,100.). 100. is a generally recommended value. -C -C NPRINT is an integer input variable that enables controlled -C printing of iterates if it is positive. In this case, FCN is -C called with IFLAG = 0 at the beginning of the first iteration -C and every NPRINT iterations thereafter and immediately prior -C to return, with X and FVEC available for printing. appropriate -C print statements must be added to FCN(see example). If NPRINT -C is not positive, no special calls of FCN with IFLAG = 0 are -C made. -C -C INFO is an integer output variable. If the user has terminated -C execution, INFO is set to the (negative) value of IFLAG. See -C description of FCN and JAC. Otherwise, INFO is set as follows. -C -C INFO = 0 Improper input parameters. -C -C INFO = 1 Relative error between two consecutive iterates is -C at most XTOL. -C -C INFO = 2 Number of calls to FCN has reached or exceeded -C MAXFEV. -C -C INFO = 3 XTOL is too small. No further improvement in the -C approximate solution X is possible. -C -C INFO = 4 Iteration is not making good progress, as measured -C by the improvement from the last five Jacobian -C evaluations. -C -C INFO = 5 Iteration is not making good progress, as measured -C by the improvement from the last ten iterations. -C -C Sections 4 and 5 contain more details about INFO. -C -C NFEV is an integer output variable set to the number of calls to -C FCN. -C -C NJEV is an integer output variable set to the number of calls to -C JAC. (If IOPT=2, then NJEV is set to zero.) -C -C R is an output array of length LR which contains the upper -C triangular matrix produced by the QR factorization of the -C final approximate Jacobian, stored rowwise. -C -C LR is a positive integer input variable not less than -C (N*(N+1))/2. -C -C QTF is an output array of length N which contains the vector -C (Q transpose)*FVEC. -C -C WA1, WA2, WA3, and WA4 are work arrays of length N. -C -C -C 4. Successful completion. -C -C The accuracy of DNSQ is controlled by the convergence parameter -C XTOL. This parameter is used in a test which makes a comparison -C between the approximation X and a solution XSOL. DNSQ -C terminates when the test is satisfied. If the convergence -C parameter is less than the machine precision (as defined by the -C function D1MACH(4)), then DNSQ only attempts to satisfy the test -C defined by the machine precision. Further progress is not -C usually possible. -C -C The test assumes that the functions are reasonably well behaved, -C and, if the Jacobian is supplied by the user, that the functions -C and the Jacobian are coded consistently. If these conditions -C are not satisfied, then DNSQ may incorrectly indicate -C convergence. The coding of the Jacobian can be checked by the -C subroutine DCKDER. If the Jacobian is coded correctly or IOPT=2, -C then the validity of the answer can be checked, for example, by -C rerunning DNSQ with a tighter tolerance. -C -C Convergence Test. If DENORM(Z) denotes the Euclidean norm of a -C vector Z and D is the diagonal matrix whose entries are -C defined by the array DIAG, then this test attempts to -C guarantee that -C -C DENORM(D*(X-XSOL)) .LE. XTOL*DENORM(D*XSOL). -C -C If this condition is satisfied with XTOL = 10**(-K), then the -C larger components of D*X have K significant decimal digits and -C INFO is set to 1. There is a danger that the smaller -C components of D*X may have large relative errors, but the fast -C rate of convergence of DNSQ usually avoids this possibility. -C Unless high precision solutions are required, the recommended -C value for XTOL is the square root of the machine precision. -C -C -C 5. Unsuccessful Completion. -C -C Unsuccessful termination of DNSQ can be due to improper input -C parameters, arithmetic interrupts, an excessive number of -C function evaluations, or lack of good progress. -C -C Improper Input Parameters. INFO is set to 0 if IOPT .LT .1, -C or IOPT .GT. 2, or N .LE. 0, or LDFJAC .LT. N, or -C XTOL .LT. 0.E0, or MAXFEV .LE. 0, or ML .LT. 0, or MU .LT. 0, -C or FACTOR .LE. 0.E0, or LR .LT. (N*(N+1))/2. -C -C Arithmetic Interrupts. If these interrupts occur in the FCN -C subroutine during an early stage of the computation, they may -C be caused by an unacceptable choice of X by DNSQ. In this -C case, it may be possible to remedy the situation by rerunning -C DNSQ with a smaller value of FACTOR. -C -C Excessive Number of Function Evaluations. A reasonable value -C for MAXFEV is 100*(N+1) for IOPT=1 and 200*(N+1) for IOPT=2. -C If the number of calls to FCN reaches MAXFEV, then this -C indicates that the routine is converging very slowly as -C measured by the progress of FVEC, and INFO is set to 2. This -C situation should be unusual because, as indicated below, lack -C of good progress is usually diagnosed earlier by DNSQ, -C causing termination with info = 4 or INFO = 5. -C -C Lack of Good Progress. DNSQ searches for a zero of the system -C by minimizing the sum of the squares of the functions. In so -C doing, it can become trapped in a region where the minimum -C does not correspond to a zero of the system and, in this -C situation, the iteration eventually fails to make good -C progress. In particular, this will happen if the system does -C not have a zero. If the system has a zero, rerunning DNSQ -C from a different starting point may be helpful. -C -C -C 6. Characteristics of The Algorithm. -C -C DNSQ is a modification of the Powell Hybrid method. Two of its -C main characteristics involve the choice of the correction as a -C convex combination of the Newton and scaled gradient directions, -C and the updating of the Jacobian by the rank-1 method of -C Broyden. The choice of the correction guarantees (under -C reasonable conditions) global convergence for starting points -C far from the solution and a fast rate of convergence. The -C Jacobian is calculated at the starting point by either the -C user-supplied subroutine or a forward-difference approximation, -C but it is not recalculated until the rank-1 method fails to -C produce satisfactory progress. -C -C Timing. The time required by DNSQ to solve a given problem -C depends on N, the behavior of the functions, the accuracy -C requested, and the starting point. The number of arithmetic -C operations needed by DNSQ is about 11.5*(N**2) to process -C each evaluation of the functions (call to FCN) and 1.3*(N**3) -C to process each evaluation of the Jacobian (call to JAC, -C if IOPT = 1). Unless FCN and JAC can be evaluated quickly, -C the timing of DNSQ will be strongly influenced by the time -C spent in FCN and JAC. -C -C Storage. DNSQ requires (3*N**2 + 17*N)/2 single precision -C storage locations, in addition to the storage required by the -C program. There are no internally declared storage arrays. -C -C *Long Description: -C -C 7. Example. -C -C The problem is to determine the values of X(1), X(2), ..., X(9), -C which solve the system of tridiagonal equations -C -C (3-2*X(1))*X(1) -2*X(2) = -1 -C -X(I-1) + (3-2*X(I))*X(I) -2*X(I+1) = -1, I=2-8 -C -X(8) + (3-2*X(9))*X(9) = -1 -C C ********** -C -C PROGRAM TEST -C C -C C Driver for DNSQ example. -C C -C INTEGER J,IOPT,N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,LR, -C * NWRITE -C DOUBLE PRECISION XTOL,EPSFCN,FACTOR,FNORM -C DOUBLE PRECISION X(9),FVEC(9),DIAG(9),FJAC(9,9),R(45),QTF(9), -C * WA1(9),WA2(9),WA3(9),WA4(9) -C DOUBLE PRECISION DENORM,D1MACH -C EXTERNAL FCN -C DATA NWRITE /6/ -C C -C IOPT = 2 -C N = 9 -C C -C C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION. -C C -C DO 10 J = 1, 9 -C X(J) = -1.E0 -C 10 CONTINUE -C C -C LDFJAC = 9 -C LR = 45 -C C -C C SET XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. -C C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, -C C THIS IS THE RECOMMENDED SETTING. -C C -C XTOL = SQRT(D1MACH(4)) -C C -C MAXFEV = 2000 -C ML = 1 -C MU = 1 -C EPSFCN = 0.E0 -C MODE = 2 -C DO 20 J = 1, 9 -C DIAG(J) = 1.E0 -C 20 CONTINUE -C FACTOR = 1.E2 -C NPRINT = 0 -C C -C CALL DNSQ(FCN,JAC,IOPT,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,ML,MU, -C * EPSFCN,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, -C * R,LR,QTF,WA1,WA2,WA3,WA4) -C FNORM = DENORM(N,FVEC) -C WRITE (NWRITE,1000) FNORM,NFEV,INFO,(X(J),J=1,N) -C STOP -C 1000 FORMAT (5X,' FINAL L2 NORM OF THE RESIDUALS',E15.7 // -C * 5X,' NUMBER OF FUNCTION EVALUATIONS',I10 // -C * 5X,' EXIT PARAMETER',16X,I10 // -C * 5X,' FINAL APPROXIMATE SOLUTION' // (5X,3E15.7)) -C END -C SUBROUTINE FCN(N,X,FVEC,IFLAG) -C INTEGER N,IFLAG -C DOUBLE PRECISION X(N),FVEC(N) -C INTEGER K -C DOUBLE PRECISION ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO -C DATA ZERO,ONE,TWO,THREE /0.E0,1.E0,2.E0,3.E0/ -C C -C IF (IFLAG .NE. 0) GO TO 5 -C C -C C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE. -C C -C RETURN -C 5 CONTINUE -C DO 10 K = 1, N -C TEMP = (THREE - TWO*X(K))*X(K) -C TEMP1 = ZERO -C IF (K .NE. 1) TEMP1 = X(K-1) -C TEMP2 = ZERO -C IF (K .NE. N) TEMP2 = X(K+1) -C FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE -C 10 CONTINUE -C RETURN -C END -C -C Results obtained with different compilers or machines -C may be slightly different. -C -C Final L2 norm of the residuals 0.1192636E-07 -C -C Number of function evaluations 14 -C -C Exit parameter 1 -C -C Final approximate solution -C -C -0.5706545E+00 -0.6816283E+00 -0.7017325E+00 -C -0.7042129E+00 -0.7013690E+00 -0.6918656E+00 -C -0.6657920E+00 -0.5960342E+00 -0.4164121E+00 -C -C***REFERENCES M. J. D. Powell, A hybrid method for nonlinear equa- -C tions. In Numerical Methods for Nonlinear Algebraic -C Equations, P. Rabinowitz, Editor. Gordon and Breach, -C 1988. -C***ROUTINES CALLED D1MACH, D1MPYQ, D1UPDT, DDOGLG, DENORM, DFDJC1, -C DQFORM, DQRFAC, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DNSQ - DOUBLE PRECISION D1MACH,DENORM - INTEGER I, IFLAG, INFO, IOPT, ITER, IWA(1), J, JM1, L, LDFJAC, - 1 LR, MAXFEV, ML, MODE, MU, N, NCFAIL, NCSUC, NFEV, NJEV, - 2 NPRINT, NSLOW1, NSLOW2 - DOUBLE PRECISION ACTRED, DELTA, DIAG(*), EPSFCN, EPSMCH, FACTOR, - 1 FJAC(LDFJAC,*), FNORM, FNORM1, FVEC(*), ONE, P0001, P001, - 2 P1, P5, PNORM, PRERED, QTF(*), R(*), RATIO, SUM, TEMP, - 3 WA1(*), WA2(*), WA3(*), WA4(*), X(*), XNORM, XTOL, ZERO - EXTERNAL FCN - LOGICAL JEVAL,SING - SAVE ONE, P1, P5, P001, P0001, ZERO - DATA ONE,P1,P5,P001,P0001,ZERO - 1 /1.0D0,1.0D-1,5.0D-1,1.0D-3,1.0D-4,0.0D0/ -C -C BEGIN BLOCK PERMITTING ...EXITS TO 320 -C***FIRST EXECUTABLE STATEMENT DNSQ - EPSMCH = D1MACH(4) -C - INFO = 0 - IFLAG = 0 - NFEV = 0 - NJEV = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C -C ...EXIT - IF (IOPT .LT. 1 .OR. IOPT .GT. 2 .OR. N .LE. 0 - 1 .OR. XTOL .LT. ZERO .OR. MAXFEV .LE. 0 .OR. ML .LT. 0 - 2 .OR. MU .LT. 0 .OR. FACTOR .LE. ZERO .OR. LDFJAC .LT. N - 3 .OR. LR .LT. (N*(N + 1))/2) GO TO 320 - IF (MODE .NE. 2) GO TO 20 - DO 10 J = 1, N -C .........EXIT - IF (DIAG(J) .LE. ZERO) GO TO 320 - 10 CONTINUE - 20 CONTINUE -C -C EVALUATE THE FUNCTION AT THE STARTING POINT -C AND CALCULATE ITS NORM. -C - IFLAG = 1 - CALL FCN(N,X,FVEC,IFLAG) - NFEV = 1 -C ...EXIT - IF (IFLAG .LT. 0) GO TO 320 - FNORM = DENORM(N,FVEC) -C -C INITIALIZE ITERATION COUNTER AND MONITORS. -C - ITER = 1 - NCSUC = 0 - NCFAIL = 0 - NSLOW1 = 0 - NSLOW2 = 0 -C -C BEGINNING OF THE OUTER LOOP. -C - 30 CONTINUE -C BEGIN BLOCK PERMITTING ...EXITS TO 90 - JEVAL = .TRUE. -C -C CALCULATE THE JACOBIAN MATRIX. -C - IF (IOPT .EQ. 2) GO TO 40 -C -C USER SUPPLIES JACOBIAN -C - CALL JAC(N,X,FVEC,FJAC,LDFJAC,IFLAG) - NJEV = NJEV + 1 - GO TO 50 - 40 CONTINUE -C -C CODE APPROXIMATES THE JACOBIAN -C - IFLAG = 2 - CALL DFDJC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU, - 1 EPSFCN,WA1,WA2) - NFEV = NFEV + MIN(ML+MU+1,N) - 50 CONTINUE -C -C .........EXIT - IF (IFLAG .LT. 0) GO TO 320 -C -C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. -C - CALL DQRFAC(N,N,FJAC,LDFJAC,.FALSE.,IWA,1,WA1,WA2,WA3) -C -C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING -C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. -C -C ...EXIT - IF (ITER .NE. 1) GO TO 90 - IF (MODE .EQ. 2) GO TO 70 - DO 60 J = 1, N - DIAG(J) = WA2(J) - IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE - 60 CONTINUE - 70 CONTINUE -C -C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED -C X AND INITIALIZE THE STEP BOUND DELTA. -C - DO 80 J = 1, N - WA3(J) = DIAG(J)*X(J) - 80 CONTINUE - XNORM = DENORM(N,WA3) - DELTA = FACTOR*XNORM - IF (DELTA .EQ. ZERO) DELTA = FACTOR - 90 CONTINUE -C -C FORM (Q TRANSPOSE)*FVEC AND STORE IN QTF. -C - DO 100 I = 1, N - QTF(I) = FVEC(I) - 100 CONTINUE - DO 140 J = 1, N - IF (FJAC(J,J) .EQ. ZERO) GO TO 130 - SUM = ZERO - DO 110 I = J, N - SUM = SUM + FJAC(I,J)*QTF(I) - 110 CONTINUE - TEMP = -SUM/FJAC(J,J) - DO 120 I = J, N - QTF(I) = QTF(I) + FJAC(I,J)*TEMP - 120 CONTINUE - 130 CONTINUE - 140 CONTINUE -C -C COPY THE TRIANGULAR FACTOR OF THE QR FACTORIZATION INTO R. -C - SING = .FALSE. - DO 170 J = 1, N - L = J - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 160 - DO 150 I = 1, JM1 - R(L) = FJAC(I,J) - L = L + N - I - 150 CONTINUE - 160 CONTINUE - R(L) = WA1(J) - IF (WA1(J) .EQ. ZERO) SING = .TRUE. - 170 CONTINUE -C -C ACCUMULATE THE ORTHOGONAL FACTOR IN FJAC. -C - CALL DQFORM(N,N,FJAC,LDFJAC,WA1) -C -C RESCALE IF NECESSARY. -C - IF (MODE .EQ. 2) GO TO 190 - DO 180 J = 1, N - DIAG(J) = MAX(DIAG(J),WA2(J)) - 180 CONTINUE - 190 CONTINUE -C -C BEGINNING OF THE INNER LOOP. -C - 200 CONTINUE -C -C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. -C - IF (NPRINT .LE. 0) GO TO 210 - IFLAG = 0 - IF (MOD(ITER-1,NPRINT) .EQ. 0) - 1 CALL FCN(N,X,FVEC,IFLAG) -C ............EXIT - IF (IFLAG .LT. 0) GO TO 320 - 210 CONTINUE -C -C DETERMINE THE DIRECTION P. -C - CALL DDOGLG(N,R,LR,DIAG,QTF,DELTA,WA1,WA2,WA3) -C -C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. -C - DO 220 J = 1, N - WA1(J) = -WA1(J) - WA2(J) = X(J) + WA1(J) - WA3(J) = DIAG(J)*WA1(J) - 220 CONTINUE - PNORM = DENORM(N,WA3) -C -C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. -C - IF (ITER .EQ. 1) DELTA = MIN(DELTA,PNORM) -C -C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. -C - IFLAG = 1 - CALL FCN(N,WA2,WA4,IFLAG) - NFEV = NFEV + 1 -C .........EXIT - IF (IFLAG .LT. 0) GO TO 320 - FNORM1 = DENORM(N,WA4) -C -C COMPUTE THE SCALED ACTUAL REDUCTION. -C - ACTRED = -ONE - IF (FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 -C -C COMPUTE THE SCALED PREDICTED REDUCTION. -C - L = 1 - DO 240 I = 1, N - SUM = ZERO - DO 230 J = I, N - SUM = SUM + R(L)*WA1(J) - L = L + 1 - 230 CONTINUE - WA3(I) = QTF(I) + SUM - 240 CONTINUE - TEMP = DENORM(N,WA3) - PRERED = ZERO - IF (TEMP .LT. FNORM) PRERED = ONE - (TEMP/FNORM)**2 -C -C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED -C REDUCTION. -C - RATIO = ZERO - IF (PRERED .GT. ZERO) RATIO = ACTRED/PRERED -C -C UPDATE THE STEP BOUND. -C - IF (RATIO .GE. P1) GO TO 250 - NCSUC = 0 - NCFAIL = NCFAIL + 1 - DELTA = P5*DELTA - GO TO 260 - 250 CONTINUE - NCFAIL = 0 - NCSUC = NCSUC + 1 - IF (RATIO .GE. P5 .OR. NCSUC .GT. 1) - 1 DELTA = MAX(DELTA,PNORM/P5) - IF (ABS(RATIO-ONE) .LE. P1) DELTA = PNORM/P5 - 260 CONTINUE -C -C TEST FOR SUCCESSFUL ITERATION. -C - IF (RATIO .LT. P0001) GO TO 280 -C -C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. -C - DO 270 J = 1, N - X(J) = WA2(J) - WA2(J) = DIAG(J)*X(J) - FVEC(J) = WA4(J) - 270 CONTINUE - XNORM = DENORM(N,WA2) - FNORM = FNORM1 - ITER = ITER + 1 - 280 CONTINUE -C -C DETERMINE THE PROGRESS OF THE ITERATION. -C - NSLOW1 = NSLOW1 + 1 - IF (ACTRED .GE. P001) NSLOW1 = 0 - IF (JEVAL) NSLOW2 = NSLOW2 + 1 - IF (ACTRED .GE. P1) NSLOW2 = 0 -C -C TEST FOR CONVERGENCE. -C - IF (DELTA .LE. XTOL*XNORM .OR. FNORM .EQ. ZERO) INFO = 1 -C .........EXIT - IF (INFO .NE. 0) GO TO 320 -C -C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. -C - IF (NFEV .GE. MAXFEV) INFO = 2 - IF (P1*MAX(P1*DELTA,PNORM) .LE. EPSMCH*XNORM) INFO = 3 - IF (NSLOW2 .EQ. 5) INFO = 4 - IF (NSLOW1 .EQ. 10) INFO = 5 -C .........EXIT - IF (INFO .NE. 0) GO TO 320 -C -C CRITERION FOR RECALCULATING JACOBIAN -C -C ...EXIT - IF (NCFAIL .EQ. 2) GO TO 310 -C -C CALCULATE THE RANK ONE MODIFICATION TO THE JACOBIAN -C AND UPDATE QTF IF NECESSARY. -C - DO 300 J = 1, N - SUM = ZERO - DO 290 I = 1, N - SUM = SUM + FJAC(I,J)*WA4(I) - 290 CONTINUE - WA2(J) = (SUM - WA3(J))/PNORM - WA1(J) = DIAG(J)*((DIAG(J)*WA1(J))/PNORM) - IF (RATIO .GE. P0001) QTF(J) = SUM - 300 CONTINUE -C -C COMPUTE THE QR FACTORIZATION OF THE UPDATED JACOBIAN. -C - CALL D1UPDT(N,N,R,LR,WA1,WA2,WA3,SING) - CALL D1MPYQ(N,N,FJAC,LDFJAC,WA2,WA3) - CALL D1MPYQ(1,N,QTF,1,WA2,WA3) -C -C END OF THE INNER LOOP. -C - JEVAL = .FALSE. - GO TO 200 - 310 CONTINUE -C -C END OF THE OUTER LOOP. -C - GO TO 30 - 320 CONTINUE -C -C TERMINATION, EITHER NORMAL OR USER IMPOSED. -C - IF (IFLAG .LT. 0) INFO = IFLAG - IFLAG = 0 - IF (NPRINT .GT. 0) CALL FCN(N,X,FVEC,IFLAG) - IF (INFO .LT. 0) CALL XERMSG ('SLATEC', 'DNSQ', - + 'EXECUTION TERMINATED BECAUSE USER SET IFLAG NEGATIVE.', 1, 1) - IF (INFO .EQ. 0) CALL XERMSG ('SLATEC', 'DNSQ', - + 'INVALID INPUT PARAMETER.', 2, 1) - IF (INFO .EQ. 2) CALL XERMSG ('SLATEC', 'DNSQ', - + 'TOO MANY FUNCTION EVALUATIONS.', 9, 1) - IF (INFO .EQ. 3) CALL XERMSG ('SLATEC', 'DNSQ', - + 'XTOL TOO SMALL. NO FURTHER IMPROVEMENT POSSIBLE.', 3, 1) - IF (INFO .GT. 4) CALL XERMSG ('SLATEC', 'DNSQ', - + 'ITERATION NOT MAKING GOOD PROGRESS.', 1, 1) - RETURN -C -C LAST CARD OF SUBROUTINE DNSQ. -C - END diff --git a/slatec/dnsqe.f b/slatec/dnsqe.f deleted file mode 100644 index 8c0c6b5..0000000 --- a/slatec/dnsqe.f +++ /dev/null @@ -1,380 +0,0 @@ -*DECK DNSQE - SUBROUTINE DNSQE (FCN, JAC, IOPT, N, X, FVEC, TOL, NPRINT, INFO, - + WA, LWA) -C***BEGIN PROLOGUE DNSQE -C***PURPOSE An easy-to-use code to find a zero of a system of N -C nonlinear functions in N variables by a modification of -C the Powell hybrid method. -C***LIBRARY SLATEC -C***CATEGORY F2A -C***TYPE DOUBLE PRECISION (SNSQE-S, DNSQE-D) -C***KEYWORDS EASY-TO-USE, NONLINEAR SQUARE SYSTEM, -C POWELL HYBRID METHOD, ZEROS -C***AUTHOR Hiebert, K. L. (SNLA) -C***DESCRIPTION -C -C 1. Purpose. -C -C The purpose of DNSQE is to find a zero of a system of N -C nonlinear functions in N variables by a modification of the -C Powell hybrid method. This is done by using the more general -C nonlinear equation solver DNSQ. The user must provide a -C subroutine which calculates the functions. The user has the -C option of either to provide a subroutine which calculates the -C Jacobian or to let the code calculate it by a forward-difference -C approximation. This code is the combination of the MINPACK -C codes (Argonne) HYBRD1 and HYBRJ1. -C -C 2. Subroutine and Type Statements. -C -C SUBROUTINE DNSQE(FCN,JAC,IOPT,N,X,FVEC,TOL,NPRINT,INFO, -C * WA,LWA) -C INTEGER IOPT,N,NPRINT,INFO,LWA -C DOUBLE PRECISION TOL -C DOUBLE PRECISION X(N),FVEC(N),WA(LWA) -C EXTERNAL FCN,JAC -C -C 3. Parameters. -C -C Parameters designated as input parameters must be specified on -C entry to DNSQE and are not changed on exit, while parameters -C designated as output parameters need not be specified on entry -C and are set to appropriate values on exit from DNSQE. -C -C FCN is the name of the user-supplied subroutine which calculates -C the functions. FCN must be declared in an external statement -C in the user calling program, and should be written as follows. -C -C SUBROUTINE FCN(N,X,FVEC,IFLAG) -C INTEGER N,IFLAG -C DOUBLE PRECISION X(N),FVEC(N) -C ---------- -C Calculate the functions at X and -C return this vector in FVEC. -C ---------- -C RETURN -C END -C -C The value of IFLAG should not be changed by FCN unless the -C user wants to terminate execution of DNSQE. In this case set -C IFLAG to a negative integer. -C -C JAC is the name of the user-supplied subroutine which calculates -C the Jacobian. If IOPT=1, then JAC must be declared in an -C external statement in the user calling program, and should be -C written as follows. -C -C SUBROUTINE JAC(N,X,FVEC,FJAC,LDFJAC,IFLAG) -C INTEGER N,LDFJAC,IFLAG -C DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N) -C ---------- -C Calculate the Jacobian at X and return this -C matrix in FJAC. FVEC contains the function -C values at X and should not be altered. -C ---------- -C RETURN -C END -C -C The value of IFLAG should not be changed by JAC unless the -C user wants to terminate execution of DNSQE. In this case set -C IFLAG to a negative integer. -C -C If IOPT=2, JAC can be ignored (treat it as a dummy argument). -C -C IOPT is an input variable which specifies how the Jacobian will -C be calculated. If IOPT=1, then the user must supply the -C Jacobian through the subroutine JAC. If IOPT=2, then the -C code will approximate the Jacobian by forward-differencing. -C -C N is a positive integer input variable set to the number of -C functions and variables. -C -C X is an array of length N. On input X must contain an initial -C estimate of the solution vector. On output X contains the -C final estimate of the solution vector. -C -C FVEC is an output array of length N which contains the functions -C evaluated at the output X. -C -C TOL is a nonnegative input variable. Termination occurs when -C the algorithm estimates that the relative error between X and -C the solution is at most TOL. Section 4 contains more details -C about TOL. -C -C NPRINT is an integer input variable that enables controlled -C printing of iterates if it is positive. In this case, FCN is -C called with IFLAG = 0 at the beginning of the first iteration -C and every NPRINT iterations thereafter and immediately prior -C to return, with X and FVEC available for printing. Appropriate -C print statements must be added to FCN(see example). If NPRINT -C is not positive, no special calls of FCN with IFLAG = 0 are -C made. -C -C INFO is an integer output variable. If the user has terminated -C execution, INFO is set to the (negative) value of IFLAG. See -C description of FCN and JAC. Otherwise, INFO is set as follows. -C -C INFO = 0 Improper input parameters. -C -C INFO = 1 Algorithm estimates that the relative error between -C X and the solution is at most TOL. -C -C INFO = 2 Number of calls to FCN has reached or exceeded -C 100*(N+1) for IOPT=1 or 200*(N+1) for IOPT=2. -C -C INFO = 3 TOL is too small. No further improvement in the -C approximate solution X is possible. -C -C INFO = 4 Iteration is not making good progress. -C -C Sections 4 and 5 contain more details about INFO. -C -C WA is a work array of length LWA. -C -C LWA is a positive integer input variable not less than -C (3*N**2+13*N))/2. -C -C 4. Successful Completion. -C -C The accuracy of DNSQE is controlled by the convergence parameter -C TOL. This parameter is used in a test which makes a comparison -C between the approximation X and a solution XSOL. DNSQE -C terminates when the test is satisfied. If TOL is less than the -C machine precision (as defined by the function D1MACH(4)), then -C DNSQE only attempts to satisfy the test defined by the machine -C precision. Further progress is not usually possible. Unless -C high precision solutions are required, the recommended value -C for TOL is the square root of the machine precision. -C -C The test assumes that the functions are reasonably well behaved, -C and, if the Jacobian is supplied by the user, that the functions -C and the Jacobian are coded consistently. If these conditions are -C not satisfied, then DNSQE may incorrectly indicate convergence. -C The coding of the Jacobian can be checked by the subroutine -C DCKDER. If the Jacobian is coded correctly or IOPT=2, then -C the validity of the answer can be checked, for example, by -C rerunning DNSQE with a tighter tolerance. -C -C Convergence Test. If DENORM(Z) denotes the Euclidean norm of a -C vector Z, then this test attempts to guarantee that -C -C DENORM(X-XSOL) .LE. TOL*DENORM(XSOL). -C -C If this condition is satisfied with TOL = 10**(-K), then the -C larger components of X have K significant decimal digits and -C INFO is set to 1. There is a danger that the smaller -C components of X may have large relative errors, but the fast -C rate of convergence of DNSQE usually avoids this possibility. -C -C 5. Unsuccessful Completion. -C -C Unsuccessful termination of DNSQE can be due to improper input -C parameters, arithmetic interrupts, an excessive number of -C function evaluations, errors in the functions, or lack of good -C progress. -C -C Improper Input Parameters. INFO is set to 0 if IOPT .LT. 1, or -C IOPT .GT. 2, or N .LE. 0, or TOL .LT. 0.E0, or -C LWA .LT. (3*N**2+13*N)/2. -C -C Arithmetic Interrupts. If these interrupts occur in the FCN -C subroutine during an early stage of the computation, they may -C be caused by an unacceptable choice of X by DNSQE. In this -C case, it may be possible to remedy the situation by not -C evaluating the functions here, but instead setting the -C components of FVEC to numbers that exceed those in the initial -C FVEC. -C -C Excessive Number of Function Evaluations. If the number of -C calls to FCN reaches 100*(N+1) for IOPT=1 or 200*(N+1) for -C IOPT=2, then this indicates that the routine is converging -C very slowly as measured by the progress of FVEC, and INFO is -C set to 2. This situation should be unusual because, as -C indicated below, lack of good progress is usually diagnosed -C earlier by DNSQE, causing termination with INFO = 4. -C -C Errors In the Functions. When IOPT=2, the choice of step length -C in the forward-difference approximation to the Jacobian -C assumes that the relative errors in the functions are of the -C order of the machine precision. If this is not the case, -C DNSQE may fail (usually with INFO = 4). The user should -C then either use DNSQ and set the step length or use IOPT=1 -C and supply the Jacobian. -C -C Lack of Good Progress. DNSQE searches for a zero of the system -C by minimizing the sum of the squares of the functions. In so -C doing, it can become trapped in a region where the minimum -C does not correspond to a zero of the system and, in this -C situation, the iteration eventually fails to make good -C progress. In particular, this will happen if the system does -C not have a zero. If the system has a zero, rerunning DNSQE -C from a different starting point may be helpful. -C -C 6. Characteristics of The Algorithm. -C -C DNSQE is a modification of the Powell Hybrid method. Two of -C its main characteristics involve the choice of the correction as -C a convex combination of the Newton and scaled gradient -C directions, and the updating of the Jacobian by the rank-1 -C method of Broyden. The choice of the correction guarantees -C (under reasonable conditions) global convergence for starting -C points far from the solution and a fast rate of convergence. -C The Jacobian is calculated at the starting point by either the -C user-supplied subroutine or a forward-difference approximation, -C but it is not recalculated until the rank-1 method fails to -C produce satisfactory progress. -C -C Timing. The time required by DNSQE to solve a given problem -C depends on N, the behavior of the functions, the accuracy -C requested, and the starting point. The number of arithmetic -C operations needed by DNSQE is about 11.5*(N**2) to process -C each evaluation of the functions (call to FCN) and 1.3*(N**3) -C to process each evaluation of the Jacobian (call to JAC, -C if IOPT = 1). Unless FCN and JAC can be evaluated quickly, -C the timing of DNSQE will be strongly influenced by the time -C spent in FCN and JAC. -C -C Storage. DNSQE requires (3*N**2 + 17*N)/2 single precision -C storage locations, in addition to the storage required by the -C program. There are no internally declared storage arrays. -C -C *Long Description: -C -C 7. Example. -C -C The problem is to determine the values of X(1), X(2), ..., X(9), -C which solve the system of tridiagonal equations -C -C (3-2*X(1))*X(1) -2*X(2) = -1 -C -X(I-1) + (3-2*X(I))*X(I) -2*X(I+1) = -1, I=2-8 -C -X(8) + (3-2*X(9))*X(9) = -1 -C -C ********** -C -C PROGRAM TEST -C C -C C DRIVER FOR DNSQE EXAMPLE. -C C -C INTEGER J,N,IOPT,NPRINT,INFO,LWA,NWRITE -C DOUBLE PRECISION TOL,FNORM -C DOUBLE PRECISION X(9),FVEC(9),WA(180) -C DOUBLE PRECISION DENORM,D1MACH -C EXTERNAL FCN -C DATA NWRITE /6/ -C C -C IOPT = 2 -C N = 9 -C C -C C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION. -C C -C DO 10 J = 1, 9 -C X(J) = -1.E0 -C 10 CONTINUE -C -C LWA = 180 -C NPRINT = 0 -C C -C C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. -C C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, -C C THIS IS THE RECOMMENDED SETTING. -C C -C TOL = SQRT(D1MACH(4)) -C C -C CALL DNSQE(FCN,JAC,IOPT,N,X,FVEC,TOL,NPRINT,INFO,WA,LWA) -C FNORM = DENORM(N,FVEC) -C WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) -C STOP -C 1000 FORMAT (5X,' FINAL L2 NORM OF THE RESIDUALS',E15.7 // -C * 5X,' EXIT PARAMETER',16X,I10 // -C * 5X,' FINAL APPROXIMATE SOLUTION' // (5X,3E15.7)) -C END -C SUBROUTINE FCN(N,X,FVEC,IFLAG) -C INTEGER N,IFLAG -C DOUBLE PRECISION X(N),FVEC(N) -C INTEGER K -C DOUBLE PRECISION ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO -C DATA ZERO,ONE,TWO,THREE /0.E0,1.E0,2.E0,3.E0/ -C C -C DO 10 K = 1, N -C TEMP = (THREE - TWO*X(K))*X(K) -C TEMP1 = ZERO -C IF (K .NE. 1) TEMP1 = X(K-1) -C TEMP2 = ZERO -C IF (K .NE. N) TEMP2 = X(K+1) -C FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE -C 10 CONTINUE -C RETURN -C END -C -C RESULTS OBTAINED WITH DIFFERENT COMPILERS OR MACHINES -C MAY BE SLIGHTLY DIFFERENT. -C -C FINAL L2 NORM OF THE RESIDUALS 0.1192636E-07 -C -C EXIT PARAMETER 1 -C -C FINAL APPROXIMATE SOLUTION -C -C -0.5706545E+00 -0.6816283E+00 -0.7017325E+00 -C -0.7042129E+00 -0.7013690E+00 -0.6918656E+00 -C -0.6657920E+00 -0.5960342E+00 -0.4164121E+00 -C -C***REFERENCES M. J. D. Powell, A hybrid method for nonlinear equa- -C tions. In Numerical Methods for Nonlinear Algebraic -C Equations, P. Rabinowitz, Editor. Gordon and Breach, -C 1988. -C***ROUTINES CALLED DNSQ, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DNSQE - INTEGER INDEX, INFO, IOPT, J, LR, LWA, MAXFEV, ML, MODE, MU, N, - 1 NFEV, NJEV, NPRINT - DOUBLE PRECISION EPSFCN, FACTOR, FVEC(*), ONE, TOL, WA(*), - 1 X(*), XTOL, ZERO - EXTERNAL FCN, JAC - SAVE FACTOR, ONE, ZERO - DATA FACTOR,ONE,ZERO /1.0D2,1.0D0,0.0D0/ -C BEGIN BLOCK PERMITTING ...EXITS TO 20 -C***FIRST EXECUTABLE STATEMENT DNSQE - INFO = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C -C ...EXIT - IF (IOPT .LT. 1 .OR. IOPT .GT. 2 .OR. N .LE. 0 - 1 .OR. TOL .LT. ZERO .OR. LWA .LT. (3*N**2 + 13*N)/2) - 2 GO TO 20 -C -C CALL DNSQ. -C - MAXFEV = 100*(N + 1) - IF (IOPT .EQ. 2) MAXFEV = 2*MAXFEV - XTOL = TOL - ML = N - 1 - MU = N - 1 - EPSFCN = ZERO - MODE = 2 - DO 10 J = 1, N - WA(J) = ONE - 10 CONTINUE - LR = (N*(N + 1))/2 - INDEX = 6*N + LR - CALL DNSQ(FCN,JAC,IOPT,N,X,FVEC,WA(INDEX+1),N,XTOL,MAXFEV,ML, - 1 MU,EPSFCN,WA(1),MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, - 2 WA(6*N+1),LR,WA(N+1),WA(2*N+1),WA(3*N+1),WA(4*N+1), - 3 WA(5*N+1)) - IF (INFO .EQ. 5) INFO = 4 - 20 CONTINUE - IF (INFO .EQ. 0) CALL XERMSG ('SLATEC', 'DNSQE', - + 'INVALID INPUT PARAMETER.', 2, 1) - RETURN -C -C LAST CARD OF SUBROUTINE DNSQE. -C - END diff --git a/slatec/dogleg.f b/slatec/dogleg.f deleted file mode 100644 index c2b74f7..0000000 --- a/slatec/dogleg.f +++ /dev/null @@ -1,181 +0,0 @@ -*DECK DOGLEG - SUBROUTINE DOGLEG (N, R, LR, DIAG, QTB, DELTA, X, WA1, WA2) -C***BEGIN PROLOGUE DOGLEG -C***SUBSIDIARY -C***PURPOSE Subsidiary to SNSQ and SNSQE -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (DOGLEG-S, DDOGLG-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Given an M by N matrix A, an N by N nonsingular DIAGONAL -C matrix D, an M-vector B, and a positive number DELTA, the -C problem is to determine the convex combination X of the -C Gauss-Newton and scaled gradient directions that minimizes -C (A*X - B) in the least squares sense, subject to the -C restriction that the Euclidean norm of D*X be at most DELTA. -C -C This subroutine completes the solution of the problem -C if it is provided with the necessary information from the -C QR factorization of A. That is, if A = Q*R, where Q has -C orthogonal columns and R is an upper triangular matrix, -C then DOGLEG expects the full upper triangle of R and -C the first N components of (Q TRANSPOSE)*B. -C -C The subroutine statement is -C -C SUBROUTINE DOGLEG(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2) -C -C where -C -C N is a positive integer input variable set to the order of R. -C -C R is an input array of length LR which must contain the upper -C triangular matrix R stored by rows. -C -C LR is a positive integer input variable not less than -C (N*(N+1))/2. -C -C DIAG is an input array of length N which must contain the -C diagonal elements of the matrix D. -C -C QTB is an input array of length N which must contain the first -C N elements of the vector (Q TRANSPOSE)*B. -C -C DELTA is a positive input variable which specifies an upper -C bound on the Euclidean norm of D*X. -C -C X is an output array of length N which contains the desired -C convex combination of the Gauss-Newton direction and the -C scaled gradient direction. -C -C WA1 and WA2 are work arrays of length N. -C -C***SEE ALSO SNSQ, SNSQE -C***ROUTINES CALLED ENORM, R1MACH -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DOGLEG - INTEGER N,LR - REAL DELTA - REAL R(LR),DIAG(*),QTB(*),X(*),WA1(*),WA2(*) - INTEGER I,J,JJ,JP1,K,L - REAL ALPHA,BNORM,EPSMCH,GNORM,ONE,QNORM,SGNORM,SUM,TEMP,ZERO - REAL R1MACH,ENORM - SAVE ONE, ZERO - DATA ONE,ZERO /1.0E0,0.0E0/ -C***FIRST EXECUTABLE STATEMENT DOGLEG - EPSMCH = R1MACH(4) -C -C FIRST, CALCULATE THE GAUSS-NEWTON DIRECTION. -C - JJ = (N*(N + 1))/2 + 1 - DO 50 K = 1, N - J = N - K + 1 - JP1 = J + 1 - JJ = JJ - K - L = JJ + 1 - SUM = ZERO - IF (N .LT. JP1) GO TO 20 - DO 10 I = JP1, N - SUM = SUM + R(L)*X(I) - L = L + 1 - 10 CONTINUE - 20 CONTINUE - TEMP = R(JJ) - IF (TEMP .NE. ZERO) GO TO 40 - L = J - DO 30 I = 1, J - TEMP = MAX(TEMP,ABS(R(L))) - L = L + N - I - 30 CONTINUE - TEMP = EPSMCH*TEMP - IF (TEMP .EQ. ZERO) TEMP = EPSMCH - 40 CONTINUE - X(J) = (QTB(J) - SUM)/TEMP - 50 CONTINUE -C -C TEST WHETHER THE GAUSS-NEWTON DIRECTION IS ACCEPTABLE. -C - DO 60 J = 1, N - WA1(J) = ZERO - WA2(J) = DIAG(J)*X(J) - 60 CONTINUE - QNORM = ENORM(N,WA2) - IF (QNORM .LE. DELTA) GO TO 140 -C -C THE GAUSS-NEWTON DIRECTION IS NOT ACCEPTABLE. -C NEXT, CALCULATE THE SCALED GRADIENT DIRECTION. -C - L = 1 - DO 80 J = 1, N - TEMP = QTB(J) - DO 70 I = J, N - WA1(I) = WA1(I) + R(L)*TEMP - L = L + 1 - 70 CONTINUE - WA1(J) = WA1(J)/DIAG(J) - 80 CONTINUE -C -C CALCULATE THE NORM OF THE SCALED GRADIENT DIRECTION, -C NORMALIZE, AND RESCALE THE GRADIENT. -C - GNORM = ENORM(N,WA1) - SGNORM = ZERO - ALPHA = DELTA/QNORM - IF (GNORM .EQ. ZERO) GO TO 120 - DO 90 J = 1, N - WA1(J) = (WA1(J)/GNORM)/DIAG(J) - 90 CONTINUE -C -C CALCULATE THE POINT ALONG THE SCALED GRADIENT -C AT WHICH THE QUADRATIC IS MINIMIZED. -C - L = 1 - DO 110 J = 1, N - SUM = ZERO - DO 100 I = J, N - SUM = SUM + R(L)*WA1(I) - L = L + 1 - 100 CONTINUE - WA2(J) = SUM - 110 CONTINUE - TEMP = ENORM(N,WA2) - SGNORM = (GNORM/TEMP)/TEMP -C -C TEST WHETHER THE SCALED GRADIENT DIRECTION IS ACCEPTABLE. -C - ALPHA = ZERO - IF (SGNORM .GE. DELTA) GO TO 120 -C -C THE SCALED GRADIENT DIRECTION IS NOT ACCEPTABLE. -C FINALLY, CALCULATE THE POINT ALONG THE DOGLEG -C AT WHICH THE QUADRATIC IS MINIMIZED. -C - BNORM = ENORM(N,QTB) - TEMP = (BNORM/GNORM)*(BNORM/QNORM)*(SGNORM/DELTA) - TEMP = TEMP - (DELTA/QNORM)*(SGNORM/DELTA)**2 - 1 + SQRT((TEMP-(DELTA/QNORM))**2 - 2 +(ONE-(DELTA/QNORM)**2)*(ONE-(SGNORM/DELTA)**2)) - ALPHA = ((DELTA/QNORM)*(ONE - (SGNORM/DELTA)**2))/TEMP - 120 CONTINUE -C -C FORM APPROPRIATE CONVEX COMBINATION OF THE GAUSS-NEWTON -C DIRECTION AND THE SCALED GRADIENT DIRECTION. -C - TEMP = (ONE - ALPHA)*MIN(SGNORM,DELTA) - DO 130 J = 1, N - X(J) = TEMP*WA1(J) + ALPHA*X(J) - 130 CONTINUE - 140 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE DOGLEG. -C - END diff --git a/slatec/dohtrl.f b/slatec/dohtrl.f deleted file mode 100644 index 4f6e116..0000000 --- a/slatec/dohtrl.f +++ /dev/null @@ -1,58 +0,0 @@ -*DECK DOHTRL - SUBROUTINE DOHTRL (Q, N, NRDA, DIAG, IRANK, DIV, TD) -C***BEGIN PROLOGUE DOHTRL -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBVSUP and DSUDS -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (OHTROL-S, DOHTRL-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C For a rank deficient problem, additional orthogonal -C HOUSEHOLDER transformations are applied to the left side -C of Q to further reduce the triangular form. -C Thus, after application of the routines DORTHR and DOHTRL -C to the original matrix, the result is a nonsingular -C triangular matrix while the remainder of the matrix -C has been zeroed out. -C -C***SEE ALSO DBVSUP, DSUDS -C***ROUTINES CALLED DDOT -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DOHTRL - DOUBLE PRECISION DDOT - INTEGER IRANK, IRP, J, K, KIR, KIRM, L, N, NMIR, NRDA - DOUBLE PRECISION DD, DIAG(*), DIAGK, DIV(*), Q(NRDA,*), QS, SIG, - 1 SQD, TD(*), TDV -C***FIRST EXECUTABLE STATEMENT DOHTRL - NMIR = N - IRANK - IRP = IRANK + 1 - DO 40 K = 1, IRANK - KIR = IRP - K - DIAGK = DIAG(KIR) - SIG = (DIAGK*DIAGK) + DDOT(NMIR,Q(IRP,KIR),1,Q(IRP,KIR),1) - DD = SIGN(SQRT(SIG),-DIAGK) - DIV(KIR) = DD - TDV = DIAGK - DD - TD(KIR) = TDV - IF (K .EQ. IRANK) GO TO 30 - KIRM = KIR - 1 - SQD = DD*DIAGK - SIG - DO 20 J = 1, KIRM - QS = ((TDV*Q(KIR,J)) - 1 + DDOT(NMIR,Q(IRP,J),1,Q(IRP,KIR),1))/SQD - Q(KIR,J) = Q(KIR,J) + QS*TDV - DO 10 L = IRP, N - Q(L,J) = Q(L,J) + QS*Q(L,KIR) - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - 40 CONTINUE - RETURN - END diff --git a/slatec/domn.f b/slatec/domn.f deleted file mode 100644 index 3228285..0000000 --- a/slatec/domn.f +++ /dev/null @@ -1,364 +0,0 @@ -*DECK DOMN - SUBROUTINE DOMN (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, - + NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, AP, - + EMAP, DZ, CSAV, RWORK, IWORK) -C***BEGIN PROLOGUE DOMN -C***PURPOSE Preconditioned Orthomin Sparse Iterative Ax=b Solver. -C Routine to solve a general linear system Ax = b using -C the Preconditioned Orthomin method. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (SOMN-S, DOMN-D) -C***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, -C ORTHOMIN, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NSAVE, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) -C DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N) -C DOUBLE PRECISION P(N,0:NSAVE), AP(N,0:NSAVE), EMAP(N,0:NSAVE) -C DOUBLE PRECISION DZ(N), CSAV(NSAVE), RWORK(USER DEFINED) -C EXTERNAL MATVEC, MSOLVE -C -C CALL DOMN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, -C $ NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, -C $ Z, P, AP, EMAP, DZ, CSAV, RWORK, IWORK) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right-hand side vector. -C X :INOUT Double Precision X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Double Precision A(NELT). -C These arrays contain the matrix data structure for A. -C It could take any form. See "Description", below, for more -C details. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C MATVEC :EXT External. -C Name of a routine which performs the matrix vector multiply -C Y = A*X given A and X. The name of the MATVEC routine must -C be declared external in the calling program. The calling -C sequence to MATVEC is: -C CALL MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) -C Where N is the number of unknowns, Y is the product A*X -C upon return X is an input vector, NELT is the number of -C non-zeros in the SLAP IA, JA, A storage for the matrix A. -C ISYM is a flag which, if non-zero, denotest that A is -C symmetric and only the lower or upper triangle is stored. -C MSOLVE :EXT External. -C Name of a routine which solves a linear system MZ = R for -C Z given R with the preconditioning matrix M (M is supplied via -C RWORK and IWORK arrays). The name of the MSOLVE routine must -C be declared external in the calling program. The calling -C sequence to MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, R is the right-hand side -C vector and Z is the solution upon return. NELT, IA, JA, A and -C ISYM are defined as above. RWORK is a double precision array -C that can be used to pass necessary preconditioning information -C and/or workspace to MSOLVE. IWORK is an integer work array -C for the same purpose as RWORK. -C NSAVE :IN Integer. -C Number of direction vectors to save and orthogonalize -C against. NSAVE >= 0. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /DSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Double Precision. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Double Precision. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*D1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Breakdown of method detected. -C (p,Ap) < epsilon**2. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C R :WORK Double Precision R(N). -C Z :WORK Double Precision Z(N). -C P :WORK Double Precision P(N,0:NSAVE). -C AP :WORK Double Precision AP(N,0:NSAVE). -C EMAP :WORK Double Precision EMAP(N,0:NSAVE). -C DZ :WORK Double Precision DZ(N). -C CSAV :WORK Double Precision CSAV(NSAVE) -C Double Precision arrays used for workspace. -C RWORK :WORK Double Precision RWORK(USER DEFINED). -C Double Precision array that can be used for workspace in -C MSOLVE. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used for workspace in MSOLVE. -C -C *Description -C This routine does not care what matrix data structure is -C used for A and M. It simply calls the MATVEC and MSOLVE -C routines, with the arguments as described above. The user -C could write any type of structure and the appropriate MATVEC -C and MSOLVE routines. It is assumed that A is stored in the -C IA, JA, A arrays in some fashion and that M (or INV(M)) is -C stored in IWORK and RWORK) in some fashion. The SLAP -C routines DSDOMN and DSLUOM are examples of this procedure. -C -C Two examples of matrix data structures are the: 1) SLAP -C Triad format and 2) SLAP Column format. -C -C =================== S L A P Triad format =================== -C In this format only the non-zeros are stored. They may -C appear in *ANY* order. The user supplies three arrays of -C length NELT, where NELT is the number of non-zeros in the -C matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero -C the user puts the row and column index of that matrix -C element in the IA and JA arrays. The value of the non-zero -C matrix element is placed in the corresponding location of -C the A array. This is an extremely easy data structure to -C generate. On the other hand it is not too efficient on -C vector computers for the iterative solution of linear -C systems. Hence, SLAP changes this input data structure to -C the SLAP Column format for the iteration (but does not -C change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C In this format the non-zeros are stored counting down -C columns (except for the diagonal entry, which must appear -C first in each "column") and are stored in the double pre- -C cision array A. In other words, for each column in the -C matrix first put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)),A(JA(ICOL)) are the first elements of the ICOL- -C th column in IA and A, and IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) -C are the last elements of the ICOL-th column. Note that we -C always have JA(N+1)=NELT+1, where N is the number of columns -C in the matrix and NELT is the number of non-zeros in the -C matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO DSDOMN, DSLUOM, ISDOMN -C***REFERENCES 1. Mark K. Seager, A SLAP for the Masses, in -C G. F. Carey, Ed., Parallel Supercomputing: Methods, -C Algorithms and Applications, Wiley, 1989, pp.135-155. -C***ROUTINES CALLED D1MACH, DAXPY, DCOPY, DDOT, ISDOMN -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 891004 Added new reference. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MATVEC and MSOLVE from ROUTINES CALLED list. (FNF) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of reference. (FNF) -C 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) -C 921113 Corrected C***CATEGORY line. (FNF) -C 930326 Removed unused variable. (FNF) -C***END PROLOGUE DOMN -C .. Scalar Arguments .. - DOUBLE PRECISION ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT, NSAVE -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), AP(N,0:NSAVE), B(N), CSAV(NSAVE), - + DZ(N), EMAP(N,0:NSAVE), P(N,0:NSAVE), R(N), - + RWORK(*), X(N), Z(N) - INTEGER IA(NELT), IWORK(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MATVEC, MSOLVE -C .. Local Scalars .. - DOUBLE PRECISION AK, AKDEN, AKNUM, BKL, BNRM, FUZZ, SOLNRM - INTEGER I, IP, IPO, K, L, LMAX -C .. External Functions .. - DOUBLE PRECISION D1MACH, DDOT - INTEGER ISDOMN - EXTERNAL D1MACH, DDOT, ISDOMN -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY -C .. Intrinsic Functions .. - INTRINSIC ABS, MIN, MOD -C***FIRST EXECUTABLE STATEMENT DOMN -C -C Check some of the input data. -C - ITER = 0 - IERR = 0 - IF( N.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF - FUZZ = D1MACH(3) - IF( TOL.LT.500*FUZZ ) THEN - TOL = 500*FUZZ - IERR = 4 - ENDIF - FUZZ = FUZZ*FUZZ -C -C Calculate initial residual and pseudo-residual, and check -C stopping criterion. - CALL MATVEC(N, X, R, NELT, IA, JA, A, ISYM) - DO 10 I = 1, N - R(I) = B(I) - R(I) - 10 CONTINUE - CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C - IF( ISDOMN(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, NSAVE, - $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, - $ R, Z, P, AP, EMAP, DZ, CSAV, - $ RWORK, IWORK, AK, BNRM, SOLNRM) .NE. 0 ) GO TO 200 - IF( IERR.NE.0 ) RETURN -C -C -C ***** iteration loop ***** -C -CVD$R NOVECTOR -CVD$R NOCONCUR - DO 100 K = 1, ITMAX - ITER = K - IP = MOD( ITER-1, NSAVE+1 ) -C -C calculate direction vector p, a*p, and (m-inv)*a*p, -C and save if desired. - CALL DCOPY(N, Z, 1, P(1,IP), 1) - CALL MATVEC(N, P(1,IP), AP(1,IP), NELT, IA, JA, A, ISYM) - CALL MSOLVE(N, AP(1,IP), EMAP(1,IP), NELT, IA, JA, A, ISYM, - $ RWORK, IWORK) - IF( NSAVE.EQ.0 ) THEN - AKDEN = DDOT(N, EMAP, 1, EMAP, 1) - ELSE - IF( ITER.GT.1 ) THEN - LMAX = MIN( NSAVE, ITER-1 ) - DO 20 L = 1, LMAX - IPO = MOD(IP+(NSAVE+1-L),NSAVE+1) - BKL = DDOT(N, EMAP(1,IP), 1, EMAP(1,IPO), 1) - BKL = BKL*CSAV(L) - CALL DAXPY(N, -BKL, P(1,IPO), 1, P(1,IP), 1) - CALL DAXPY(N, -BKL, AP(1,IPO), 1, AP(1,IP), 1) - CALL DAXPY(N, -BKL, EMAP(1,IPO), 1, EMAP(1,IP), 1) - 20 CONTINUE - IF( NSAVE.GT.1 ) THEN - DO 30 L = NSAVE-1, 1, -1 - CSAV(L+1) = CSAV(L) - 30 CONTINUE - ENDIF - ENDIF - AKDEN = DDOT(N, EMAP(1,IP), 1, EMAP(1,IP), 1) - IF( ABS(AKDEN).LT.FUZZ ) THEN - IERR = 6 - RETURN - ENDIF - CSAV(1) = 1.0D0/AKDEN -C -C calculate coefficient ak, new iterate x, new residual r, and -C new pseudo-residual z. - ENDIF - AKNUM = DDOT(N, Z, 1, EMAP(1,IP), 1) - AK = AKNUM/AKDEN - CALL DAXPY(N, AK, P(1,IP), 1, X, 1) - CALL DAXPY(N, -AK, AP(1,IP), 1, R, 1) - CALL DAXPY(N, -AK, EMAP(1,IP), 1, Z, 1) -C -C check stopping criterion. - IF( ISDOMN(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, NSAVE, - $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, - $ R, Z, P, AP, EMAP, DZ, CSAV, - $ RWORK, IWORK, AK, BNRM, SOLNRM) .NE. 0 ) GO TO 200 -C - 100 CONTINUE -C -C ***** end of loop ***** -C -C Stopping criterion not satisfied. - ITER = ITMAX + 1 - IERR = 2 -C - 200 RETURN -C------------- LAST LINE OF DOMN FOLLOWS ---------------------------- - END diff --git a/slatec/dorth.f b/slatec/dorth.f deleted file mode 100644 index 5e61626..0000000 --- a/slatec/dorth.f +++ /dev/null @@ -1,125 +0,0 @@ -*DECK DORTH - SUBROUTINE DORTH (VNEW, V, HES, N, LL, LDHES, KMP, SNORMW) -C***BEGIN PROLOGUE DORTH -C***SUBSIDIARY -C***PURPOSE Internal routine for DGMRES. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (SORTH-S, DORTH-D) -C***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov -C Hindmarsh, Alan, (LLNL), alanh@llnl.gov -C Seager, Mark K., (LLNL), seager@llnl.gov -C Lawrence Livermore National Laboratory -C PO Box 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C***DESCRIPTION -C This routine orthogonalizes the vector VNEW against the -C previous KMP vectors in the V array. It uses a modified -C Gram-Schmidt orthogonalization procedure with conditional -C reorthogonalization. -C -C *Usage: -C INTEGER N, LL, LDHES, KMP -C DOUBLE PRECISION VNEW(N), V(N,LL), HES(LDHES,LL), SNORMW -C -C CALL DORTH(VNEW, V, HES, N, LL, LDHES, KMP, SNORMW) -C -C *Arguments: -C VNEW :INOUT Double Precision VNEW(N) -C On input, the vector of length N containing a scaled -C product of the Jacobian and the vector V(*,LL). -C On output, the new vector orthogonal to V(*,i0) to V(*,LL), -C where i0 = max(1, LL-KMP+1). -C V :IN Double Precision V(N,LL) -C The N x LL array containing the previous LL -C orthogonal vectors V(*,1) to V(*,LL). -C HES :INOUT Double Precision HES(LDHES,LL) -C On input, an LL x LL upper Hessenberg matrix containing, -C in HES(I,K), K.lt.LL, the scaled inner products of -C A*V(*,K) and V(*,i). -C On return, column LL of HES is filled in with -C the scaled inner products of A*V(*,LL) and V(*,i). -C N :IN Integer -C The order of the matrix A, and the length of VNEW. -C LL :IN Integer -C The current order of the matrix HES. -C LDHES :IN Integer -C The leading dimension of the HES array. -C KMP :IN Integer -C The number of previous vectors the new vector VNEW -C must be made orthogonal to (KMP .le. MAXL). -C SNORMW :OUT DOUBLE PRECISION -C Scalar containing the l-2 norm of VNEW. -C -C***SEE ALSO DGMRES -C***ROUTINES CALLED DAXPY, DDOT, DNRM2 -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910506 Made subsidiary to DGMRES. (FNF) -C 920511 Added complete declaration section. (WRB) -C***END PROLOGUE DORTH -C The following is for optimized compilation on LLNL/LTSS Crays. -CLLL. OPTIMIZE -C .. Scalar Arguments .. - DOUBLE PRECISION SNORMW - INTEGER KMP, LDHES, LL, N -C .. Array Arguments .. - DOUBLE PRECISION HES(LDHES,*), V(N,*), VNEW(*) -C .. Local Scalars .. - DOUBLE PRECISION ARG, SUMDSQ, TEM, VNRM - INTEGER I, I0 -C .. External Functions .. - DOUBLE PRECISION DDOT, DNRM2 - EXTERNAL DDOT, DNRM2 -C .. External Subroutines .. - EXTERNAL DAXPY -C .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -C***FIRST EXECUTABLE STATEMENT DORTH -C -C Get norm of unaltered VNEW for later use. -C - VNRM = DNRM2(N, VNEW, 1) -C ------------------------------------------------------------------- -C Perform the modified Gram-Schmidt procedure 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 = MAX(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. If VNEW is small compared -C to its input value (in norm), then reorthogonalize VNEW to -C V(*,1) through V(*,LL). Correct if relative correction -C exceeds 1000*(unit roundoff). Finally, correct SNORMW using -C the dot products involved. -C ------------------------------------------------------------------- - SNORMW = DNRM2(N, VNEW, 1) - IF (VNRM + 0.001D0*SNORMW .NE. VNRM) RETURN - SUMDSQ = 0 - 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) -C - RETURN -C------------- LAST LINE OF DORTH FOLLOWS ---------------------------- - END diff --git a/slatec/dorthr.f b/slatec/dorthr.f deleted file mode 100644 index c1d3c48..0000000 --- a/slatec/dorthr.f +++ /dev/null @@ -1,204 +0,0 @@ -*DECK DORTHR - SUBROUTINE DORTHR (A, N, M, NRDA, IFLAG, IRANK, ISCALE, DIAG, - + KPIVOT, SCALES, ROWS, RS) -C***BEGIN PROLOGUE DORTHR -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBVSUP and DSUDS -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (ORTHOR-S, DORTHR-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C Reduction of the matrix A to lower triangular form by a sequence of -C orthogonal HOUSEHOLDER transformations post-multiplying A. -C -C ********************************************************************* -C INPUT -C ********************************************************************* -C -C A -- Contains the matrix to be decomposed, must be dimensioned -C NRDA by N. -C N -- Number of rows in the matrix, N greater or equal to 1. -C M -- Number of columns in the matrix, M greater or equal to N. -C IFLAG -- Indicates the uncertainty in the matrix data. -C = 0 when the data is to be treated as exact. -C =-K when the data is assumed to be accurate to about -C K digits. -C ISCALE -- Scaling indicator. -C =-1 if the matrix is to be pre-scaled by -C columns when appropriate. -C Otherwise no scaling will be attempted. -C NRDA -- Row dimension of A, NRDA greater or equal to N. -C DIAG,KPIVOT,ROWS, -- Arrays of length at least N used internally -C RS,SCALES (except for SCALES which is M). -C -C ********************************************************************* -C OUTPUT -C ********************************************************************* -C -C IFLAG - Status indicator -C =1 for successful decomposition. -C =2 if improper input is detected. -C =3 if rank of the matrix is less than N. -C A -- Contains the reduced matrix in the strictly lower triangular -C part and transformation information. -C IRANK -- Contains the numerically determined matrix rank. -C DIAG -- Contains the diagonal elements of the reduced -C triangular matrix. -C KPIVOT -- Contains the pivotal information, the column -C interchanges performed on the original matrix are -C recorded here. -C SCALES -- Contains the column scaling parameters. -C -C ********************************************************************* -C -C***SEE ALSO DBVSUP, DSUDS -C***REFERENCES G. Golub, Numerical methods for solving linear least -C squares problems, Numerische Mathematik 7, (1965), -C pp. 206-216. -C P. Businger and G. Golub, Linear least squares -C solutions by Householder transformations, Numerische -C Mathematik 7, (1965), pp. 269-276. -C***ROUTINES CALLED D1MACH, DCSCAL, DDOT, XERMSG -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 910408 Updated the AUTHOR and REFERENCES sections. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DORTHR - DOUBLE PRECISION DDOT, D1MACH - INTEGER IFLAG, IRANK, ISCALE, J, JROW, K, KP, KPIVOT(*), L, M, - 1 MK, N, NRDA - DOUBLE PRECISION A(NRDA,*), ACC, AKK, ANORM, AS, ASAVE, DIAG(*), - 1 DIAGK, DUM, ROWS(*), RS(*), RSS, SAD, SCALES(*), SIG, SIGMA, - 2 SRURO, URO -C -C ****************************************************************** -C -C MACHINE PRECISION (COMPUTER UNIT ROUNDOFF VALUE) IS DEFINED -C BY THE FUNCTION D1MACH. -C -C ****************************************************************** -C -C***FIRST EXECUTABLE STATEMENT DORTHR - URO = D1MACH(4) - IF (M .GE. N .AND. N .GE. 1 .AND. NRDA .GE. N) GO TO 10 - IFLAG = 2 - CALL XERMSG ('SLATEC', 'DORTHR', 'INVALID INPUT PARAMETERS.', - + 2, 1) - GO TO 150 - 10 CONTINUE -C - ACC = 10.0D0*URO - IF (IFLAG .LT. 0) ACC = MAX(ACC,10.0D0**IFLAG) - SRURO = SQRT(URO) - IFLAG = 1 - IRANK = N -C -C COMPUTE NORM**2 OF JTH ROW AND A MATRIX NORM -C - ANORM = 0.0D0 - DO 20 J = 1, N - KPIVOT(J) = J - ROWS(J) = DDOT(M,A(J,1),NRDA,A(J,1),NRDA) - RS(J) = ROWS(J) - ANORM = ANORM + ROWS(J) - 20 CONTINUE -C -C PERFORM COLUMN SCALING ON A WHEN SPECIFIED -C - CALL DCSCAL(A,NRDA,N,M,SCALES,DUM,ROWS,RS,ANORM,SCALES,ISCALE, - 1 1) -C - ANORM = SQRT(ANORM) -C -C -C CONSTRUCTION OF LOWER TRIANGULAR MATRIX AND RECORDING OF -C ORTHOGONAL TRANSFORMATIONS -C -C - DO 130 K = 1, N -C BEGIN BLOCK PERMITTING ...EXITS TO 80 - MK = M - K + 1 -C ...EXIT - IF (K .EQ. N) GO TO 80 - KP = K + 1 -C -C SEARCHING FOR PIVOTAL ROW -C - DO 60 J = K, N -C BEGIN BLOCK PERMITTING ...EXITS TO 50 - IF (ROWS(J) .GE. SRURO*RS(J)) GO TO 30 - ROWS(J) = DDOT(MK,A(J,K),NRDA,A(J,K),NRDA) - RS(J) = ROWS(J) - 30 CONTINUE - IF (J .EQ. K) GO TO 40 -C ......EXIT - IF (SIGMA .GE. 0.99D0*ROWS(J)) GO TO 50 - 40 CONTINUE - SIGMA = ROWS(J) - JROW = J - 50 CONTINUE - 60 CONTINUE -C ...EXIT - IF (JROW .EQ. K) GO TO 80 -C -C PERFORM ROW INTERCHANGE -C - L = KPIVOT(K) - KPIVOT(K) = KPIVOT(JROW) - KPIVOT(JROW) = L - ROWS(JROW) = ROWS(K) - ROWS(K) = SIGMA - RSS = RS(K) - RS(K) = RS(JROW) - RS(JROW) = RSS - DO 70 L = 1, M - ASAVE = A(K,L) - A(K,L) = A(JROW,L) - A(JROW,L) = ASAVE - 70 CONTINUE - 80 CONTINUE -C -C CHECK RANK OF THE MATRIX -C - SIG = DDOT(MK,A(K,K),NRDA,A(K,K),NRDA) - DIAGK = SQRT(SIG) - IF (DIAGK .GT. ACC*ANORM) GO TO 90 -C -C RANK DEFICIENT PROBLEM - IFLAG = 3 - IRANK = K - 1 - CALL XERMSG ('SLATEC', 'DORTHR', - + 'RANK OF MATRIX IS LESS THAN THE NUMBER OF ROWS.', 1, - + 1) -C ......EXIT - GO TO 140 - 90 CONTINUE -C -C CONSTRUCT AND APPLY TRANSFORMATION TO MATRIX A -C - AKK = A(K,K) - IF (AKK .GT. 0.0D0) DIAGK = -DIAGK - DIAG(K) = DIAGK - A(K,K) = AKK - DIAGK - IF (K .EQ. N) GO TO 120 - SAD = DIAGK*AKK - SIG - DO 110 J = KP, N - AS = DDOT(MK,A(K,K),NRDA,A(J,K),NRDA)/SAD - DO 100 L = K, M - A(J,L) = A(J,L) + AS*A(K,L) - 100 CONTINUE - ROWS(J) = ROWS(J) - A(J,K)**2 - 110 CONTINUE - 120 CONTINUE - 130 CONTINUE - 140 CONTINUE - 150 CONTINUE -C -C - RETURN - END diff --git a/slatec/dp1vlu.f b/slatec/dp1vlu.f deleted file mode 100644 index 1af92d2..0000000 --- a/slatec/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/slatec/dpbco.f b/slatec/dpbco.f deleted file mode 100644 index 4dbca32..0000000 --- a/slatec/dpbco.f +++ /dev/null @@ -1,263 +0,0 @@ -*DECK DPBCO - SUBROUTINE DPBCO (ABD, LDA, N, M, RCOND, Z, INFO) -C***BEGIN PROLOGUE DPBCO -C***PURPOSE Factor a real symmetric positive definite matrix stored in -C band form and estimate the condition number of the matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B2 -C***TYPE DOUBLE PRECISION (SPBCO-S, DPBCO-D, CPBCO-C) -C***KEYWORDS BANDED, CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, -C MATRIX FACTORIZATION, POSITIVE DEFINITE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C DPBCO factors a double precision symmetric positive definite -C matrix stored in band form and estimates the condition of the -C matrix. -C -C If RCOND is not needed, DPBFA is slightly faster. -C To solve A*X = B , follow DPBCO by DPBSL. -C To compute INVERSE(A)*C , follow DPBCO by DPBSL. -C To compute DETERMINANT(A) , follow DPBCO by DPBDI. -C -C On Entry -C -C ABD DOUBLE PRECISION(LDA, N) -C the matrix to be factored. The columns of the upper -C triangle are stored in the columns of ABD and the -C diagonals of the upper triangle are stored in the -C rows of ABD . See the comments below for details. -C -C LDA INTEGER -C the leading dimension of the array ABD . -C LDA must be .GE. M + 1 . -C -C N INTEGER -C the order of the matrix A . -C -C M INTEGER -C the number of diagonals above the main diagonal. -C 0 .LE. M .LT. N . -C -C On Return -C -C ABD an upper triangular matrix R , stored in band -C form, so that A = TRANS(R)*R . -C If INFO .NE. 0 , the factorization is not complete. -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. If INFO .NE. 0 , RCOND is unchanged. -C -C Z DOUBLE PRECISION(N) -C a work vector whose contents are usually unimportant. -C If A is singular to working precision, then Z is -C an approximate null vector in the sense that -C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . -C If INFO .NE. 0 , Z is unchanged. -C -C INFO INTEGER -C = 0 for normal return. -C = K signals an error condition. The leading minor -C of order K is not positive definite. -C -C Band Storage -C -C If A is a symmetric positive definite band matrix, -C the following program segment will set up the input. -C -C M = (band width above diagonal) -C DO 20 J = 1, N -C I1 = MAX(1, J-M) -C DO 10 I = I1, J -C K = I-J+M+1 -C ABD(K,J) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C This uses M + 1 rows of A , except for the M by M -C upper left triangle, which is ignored. -C -C Example: If the original matrix is -C -C 11 12 13 0 0 0 -C 12 22 23 24 0 0 -C 13 23 33 34 35 0 -C 0 24 34 44 45 46 -C 0 0 35 45 55 56 -C 0 0 0 46 56 66 -C -C then N = 6 , M = 2 and ABD should contain -C -C * * 13 24 35 46 -C * 12 23 34 45 56 -C 11 22 33 44 55 66 -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DASUM, DAXPY, DDOT, DPBFA, DSCAL -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DPBCO - INTEGER LDA,N,M,INFO - DOUBLE PRECISION ABD(LDA,*),Z(*) - DOUBLE PRECISION RCOND -C - DOUBLE PRECISION DDOT,EK,T,WK,WKM - DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM - INTEGER I,J,J2,K,KB,KP1,L,LA,LB,LM,MU -C -C FIND NORM OF A -C -C***FIRST EXECUTABLE STATEMENT DPBCO - DO 30 J = 1, N - L = MIN(J,M+1) - MU = MAX(M+2-J,1) - Z(J) = DASUM(L,ABD(MU,J),1) - K = J - L - IF (M .LT. MU) GO TO 20 - DO 10 I = MU, M - K = K + 1 - Z(K) = Z(K) + ABS(ABD(I,J)) - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - ANORM = 0.0D0 - DO 40 J = 1, N - ANORM = MAX(ANORM,Z(J)) - 40 CONTINUE -C -C FACTOR -C - CALL DPBFA(ABD,LDA,N,M,INFO) - IF (INFO .NE. 0) GO TO 180 -C -C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . -C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . -C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL -C GROWTH IN THE ELEMENTS OF W WHERE TRANS(R)*W = E . -C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. -C -C SOLVE TRANS(R)*W = E -C - EK = 1.0D0 - DO 50 J = 1, N - Z(J) = 0.0D0 - 50 CONTINUE - DO 110 K = 1, N - IF (Z(K) .NE. 0.0D0) EK = SIGN(EK,-Z(K)) - IF (ABS(EK-Z(K)) .LE. ABD(M+1,K)) GO TO 60 - S = ABD(M+1,K)/ABS(EK-Z(K)) - CALL DSCAL(N,S,Z,1) - EK = S*EK - 60 CONTINUE - WK = EK - Z(K) - WKM = -EK - Z(K) - S = ABS(WK) - SM = ABS(WKM) - WK = WK/ABD(M+1,K) - WKM = WKM/ABD(M+1,K) - KP1 = K + 1 - J2 = MIN(K+M,N) - I = M + 1 - IF (KP1 .GT. J2) GO TO 100 - DO 70 J = KP1, J2 - I = I - 1 - SM = SM + ABS(Z(J)+WKM*ABD(I,J)) - Z(J) = Z(J) + WK*ABD(I,J) - S = S + ABS(Z(J)) - 70 CONTINUE - IF (S .GE. SM) GO TO 90 - T = WKM - WK - WK = WKM - I = M + 1 - DO 80 J = KP1, J2 - I = I - 1 - Z(J) = Z(J) + T*ABD(I,J) - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - Z(K) = WK - 110 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) -C -C SOLVE R*Y = W -C - DO 130 KB = 1, N - K = N + 1 - KB - IF (ABS(Z(K)) .LE. ABD(M+1,K)) GO TO 120 - S = ABD(M+1,K)/ABS(Z(K)) - CALL DSCAL(N,S,Z,1) - 120 CONTINUE - Z(K) = Z(K)/ABD(M+1,K) - LM = MIN(K-1,M) - LA = M + 1 - LM - LB = K - LM - T = -Z(K) - CALL DAXPY(LM,T,ABD(LA,K),1,Z(LB),1) - 130 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) -C - YNORM = 1.0D0 -C -C SOLVE TRANS(R)*V = Y -C - DO 150 K = 1, N - LM = MIN(K-1,M) - LA = M + 1 - LM - LB = K - LM - Z(K) = Z(K) - DDOT(LM,ABD(LA,K),1,Z(LB),1) - IF (ABS(Z(K)) .LE. ABD(M+1,K)) GO TO 140 - S = ABD(M+1,K)/ABS(Z(K)) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM - 140 CONTINUE - Z(K) = Z(K)/ABD(M+1,K) - 150 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE R*Z = W -C - DO 170 KB = 1, N - K = N + 1 - KB - IF (ABS(Z(K)) .LE. ABD(M+1,K)) GO TO 160 - S = ABD(M+1,K)/ABS(Z(K)) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM - 160 CONTINUE - Z(K) = Z(K)/ABD(M+1,K) - LM = MIN(K-1,M) - LA = M + 1 - LM - LB = K - LM - T = -Z(K) - CALL DAXPY(LM,T,ABD(LA,K),1,Z(LB),1) - 170 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 - 180 CONTINUE - RETURN - END diff --git a/slatec/dpbdi.f b/slatec/dpbdi.f deleted file mode 100644 index 90f0d7d..0000000 --- a/slatec/dpbdi.f +++ /dev/null @@ -1,82 +0,0 @@ -*DECK DPBDI - SUBROUTINE DPBDI (ABD, LDA, N, M, DET) -C***BEGIN PROLOGUE DPBDI -C***PURPOSE Compute the determinant of a symmetric positive definite -C band matrix using the factors computed by DPBCO or DPBFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D3B2 -C***TYPE DOUBLE PRECISION (SPBDI-S, DPBDI-D, CPBDI-C) -C***KEYWORDS BANDED, DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, -C MATRIX, POSITIVE DEFINITE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C DPBDI computes the determinant -C of a double precision symmetric positive definite band matrix -C using the factors computed by DPBCO or DPBFA. -C If the inverse is needed, use DPBSL N times. -C -C On Entry -C -C ABD DOUBLE PRECISION(LDA, N) -C the output from DPBCO or DPBFA. -C -C LDA INTEGER -C the leading dimension of the array ABD . -C -C N INTEGER -C the order of the matrix A . -C -C M INTEGER -C the number of diagonals above the main diagonal. -C -C On Return -C -C DET DOUBLE PRECISION(2) -C determinant of original matrix in the form -C DETERMINANT = DET(1) * 10.0**DET(2) -C with 1.0 .LE. DET(1) .LT. 10.0 -C or DET(1) .EQ. 0.0 . -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DPBDI - INTEGER LDA,N,M - DOUBLE PRECISION ABD(LDA,*) - DOUBLE PRECISION DET(2) -C - DOUBLE PRECISION S - INTEGER I -C***FIRST EXECUTABLE STATEMENT DPBDI -C -C COMPUTE DETERMINANT -C - DET(1) = 1.0D0 - DET(2) = 0.0D0 - S = 10.0D0 - DO 50 I = 1, N - DET(1) = ABD(M+1,I)**2*DET(1) - IF (DET(1) .EQ. 0.0D0) GO TO 60 - 10 IF (DET(1) .GE. 1.0D0) GO TO 20 - DET(1) = S*DET(1) - DET(2) = DET(2) - 1.0D0 - GO TO 10 - 20 CONTINUE - 30 IF (DET(1) .LT. S) GO TO 40 - DET(1) = DET(1)/S - DET(2) = DET(2) + 1.0D0 - GO TO 30 - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE - RETURN - END diff --git a/slatec/dpbfa.f b/slatec/dpbfa.f deleted file mode 100644 index 9f3df2b..0000000 --- a/slatec/dpbfa.f +++ /dev/null @@ -1,106 +0,0 @@ -*DECK DPBFA - SUBROUTINE DPBFA (ABD, LDA, N, M, INFO) -C***BEGIN PROLOGUE DPBFA -C***PURPOSE Factor a real symmetric positive definite matrix stored in -C in band form. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B2 -C***TYPE DOUBLE PRECISION (SPBFA-S, DPBFA-D, CPBFA-C) -C***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, -C POSITIVE DEFINITE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C DPBFA factors a double precision symmetric positive definite -C matrix stored in band form. -C -C DPBFA is usually called by DPBCO, 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 the matrix to be factored. The columns of the upper -C triangle are stored in the columns of ABD and the -C diagonals of the upper triangle are stored in the -C rows of ABD . See the comments below for details. -C -C LDA INTEGER -C the leading dimension of the array ABD . -C LDA must be .GE. M + 1 . -C -C N INTEGER -C the order of the matrix A . -C -C M INTEGER -C the number of diagonals above the main diagonal. -C 0 .LE. M .LT. N . -C -C On Return -C -C ABD an upper triangular matrix R , stored in band -C form, so that A = TRANS(R)*R . -C -C INFO INTEGER -C = 0 for normal return. -C = K if the leading minor of order K is not -C positive definite. -C -C Band Storage -C -C If A is a symmetric positive definite band matrix, -C the following program segment will set up the input. -C -C M = (band width above diagonal) -C DO 20 J = 1, N -C I1 = MAX(1, J-M) -C DO 10 I = I1, J -C K = I-J+M+1 -C ABD(K,J) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DDOT -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DPBFA - INTEGER LDA,N,M,INFO - DOUBLE PRECISION ABD(LDA,*) -C - DOUBLE PRECISION DDOT,T - DOUBLE PRECISION S - INTEGER IK,J,JK,K,MU -C***FIRST EXECUTABLE STATEMENT DPBFA - DO 30 J = 1, N - INFO = J - S = 0.0D0 - IK = M + 1 - JK = MAX(J-M,1) - MU = MAX(M+2-J,1) - IF (M .LT. MU) GO TO 20 - DO 10 K = MU, M - T = ABD(K,J) - DDOT(K-MU,ABD(IK,JK),1,ABD(MU,J),1) - T = T/ABD(M+1,JK) - ABD(K,J) = T - S = S + T*T - IK = IK - 1 - JK = JK + 1 - 10 CONTINUE - 20 CONTINUE - S = ABD(M+1,J) - S - IF (S .LE. 0.0D0) GO TO 40 - ABD(M+1,J) = SQRT(S) - 30 CONTINUE - INFO = 0 - 40 CONTINUE - RETURN - END diff --git a/slatec/dpbsl.f b/slatec/dpbsl.f deleted file mode 100644 index 087970d..0000000 --- a/slatec/dpbsl.f +++ /dev/null @@ -1,97 +0,0 @@ -*DECK DPBSL - SUBROUTINE DPBSL (ABD, LDA, N, M, B) -C***BEGIN PROLOGUE DPBSL -C***PURPOSE Solve a real symmetric positive definite band system -C using the factors computed by DPBCO or DPBFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B2 -C***TYPE DOUBLE PRECISION (SPBSL-S, DPBSL-D, CPBSL-C) -C***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX, -C POSITIVE DEFINITE, SOLVE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C DPBSL solves the double precision symmetric positive definite -C band system A*X = B -C using the factors computed by DPBCO or DPBFA. -C -C On Entry -C -C ABD DOUBLE PRECISION(LDA, N) -C the output from DPBCO or DPBFA. -C -C LDA INTEGER -C the leading dimension of the array ABD . -C -C N INTEGER -C the order of the matrix A . -C -C M INTEGER -C the number of diagonals above the main diagonal. -C -C B DOUBLE PRECISION(N) -C the right hand side vector. -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 -C a zero on the diagonal. Technically this indicates -C singularity, but it is usually caused by improper subroutine -C arguments. It will not occur if the subroutines are called -C correctly, and INFO .EQ. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL DPBCO(ABD,LDA,N,RCOND,Z,INFO) -C IF (RCOND is too small .OR. INFO .NE. 0) GO TO ... -C DO 10 J = 1, P -C CALL DPBSL(ABD,LDA,N,C(1,J)) -C 10 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DDOT -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DPBSL - INTEGER LDA,N,M - DOUBLE PRECISION ABD(LDA,*),B(*) -C - DOUBLE PRECISION DDOT,T - INTEGER K,KB,LA,LB,LM -C -C SOLVE TRANS(R)*Y = B -C -C***FIRST EXECUTABLE STATEMENT DPBSL - DO 10 K = 1, N - LM = MIN(K-1,M) - LA = M + 1 - LM - LB = K - LM - T = DDOT(LM,ABD(LA,K),1,B(LB),1) - B(K) = (B(K) - T)/ABD(M+1,K) - 10 CONTINUE -C -C SOLVE R*X = Y -C - DO 20 KB = 1, N - K = N + 1 - KB - LM = MIN(K-1,M) - LA = M + 1 - LM - LB = K - LM - B(K) = B(K)/ABD(M+1,K) - T = -B(K) - CALL DAXPY(LM,T,ABD(LA,K),1,B(LB),1) - 20 CONTINUE - RETURN - END diff --git a/slatec/dpchbs.f b/slatec/dpchbs.f deleted file mode 100644 index 4313392..0000000 --- a/slatec/dpchbs.f +++ /dev/null @@ -1,217 +0,0 @@ -*DECK DPCHBS - SUBROUTINE DPCHBS (N, X, F, D, INCFD, KNOTYP, NKNOTS, T, BCOEF, - + NDIM, KORD, IERR) -C***BEGIN PROLOGUE DPCHBS -C***PURPOSE Piecewise Cubic Hermite to B-Spline converter. -C***LIBRARY SLATEC (PCHIP) -C***CATEGORY E3 -C***TYPE DOUBLE PRECISION (PCHBS-S, DPCHBS-D) -C***KEYWORDS B-SPLINES, CONVERSION, CUBIC HERMITE INTERPOLATION, -C PIECEWISE CUBIC INTERPOLATION -C***AUTHOR Fritsch, F. N., (LLNL) -C Computing and Mathematics Research Division -C Lawrence Livermore National Laboratory -C P.O. Box 808 (L-316) -C Livermore, CA 94550 -C FTS 532-4275, (510) 422-4275 -C***DESCRIPTION -C -C *Usage: -C -C INTEGER N, INCFD, KNOTYP, NKNOTS, NDIM, KORD, IERR -C PARAMETER (INCFD = ...) -C DOUBLE PRECISION X(nmax), F(INCFD,nmax), D(INCFD,nmax), -C * T(2*nmax+4), BCOEF(2*nmax) -C -C CALL DPCHBS (N, X, F, D, INCFD, KNOTYP, NKNOTS, T, BCOEF, -C * NDIM, KORD, IERR) -C -C *Arguments: -C -C N:IN is the number of data points, N.ge.2 . (not checked) -C -C X:IN is the real array of independent variable values. The -C elements of X must be strictly increasing: -C X(I-1) .LT. X(I), I = 2(1)N. (not checked) -C nmax, the dimension of X, must be .ge.N. -C -C F:IN is the real array of dependent variable values. -C F(1+(I-1)*INCFD) is the value corresponding to X(I). -C nmax, the second dimension of F, must be .ge.N. -C -C D:IN is the real array of derivative values at the data points. -C D(1+(I-1)*INCFD) is the value corresponding to X(I). -C nmax, the second dimension of D, must be .ge.N. -C -C INCFD:IN is the increment between successive values in F and D. -C This argument is provided primarily for 2-D applications. -C It may have the value 1 for one-dimensional applications, -C in which case F and D may be singly-subscripted arrays. -C -C KNOTYP:IN is a flag to control the knot sequence. -C The knot sequence T is normally computed from X by putting -C a double knot at each X and setting the end knot pairs -C according to the value of KNOTYP: -C KNOTYP = 0: Quadruple knots at X(1) and X(N). (default) -C KNOTYP = 1: Replicate lengths of extreme subintervals: -C T( 1 ) = T( 2 ) = X(1) - (X(2)-X(1)) ; -C T(M+4) = T(M+3) = X(N) + (X(N)-X(N-1)). -C KNOTYP = 2: Periodic placement of boundary knots: -C T( 1 ) = T( 2 ) = X(1) - (X(N)-X(N-1)); -C T(M+4) = T(M+3) = X(N) + (X(2)-X(1)) . -C Here M=NDIM=2*N. -C If the input value of KNOTYP is negative, however, it is -C assumed that NKNOTS and T were set in a previous call. -C This option is provided for improved efficiency when used -C in a parametric setting. -C -C NKNOTS:INOUT is the number of knots. -C If KNOTYP.GE.0, then NKNOTS will be set to NDIM+4. -C If KNOTYP.LT.0, then NKNOTS is an input variable, and an -C error return will be taken if it is not equal to NDIM+4. -C -C T:INOUT is the array of 2*N+4 knots for the B-representation. -C If KNOTYP.GE.0, T will be returned by DPCHBS with the -C interior double knots equal to the X-values and the -C boundary knots set as indicated above. -C If KNOTYP.LT.0, it is assumed that T was set by a -C previous call to DPCHBS. (This routine does **not** -C verify that T forms a legitimate knot sequence.) -C -C BCOEF:OUT is the array of 2*N B-spline coefficients. -C -C NDIM:OUT is the dimension of the B-spline space. (Set to 2*N.) -C -C KORD:OUT is the order of the B-spline. (Set to 4.) -C -C IERR:OUT is an error flag. -C Normal return: -C IERR = 0 (no errors). -C "Recoverable" errors: -C IERR = -4 if KNOTYP.GT.2 . -C IERR = -5 if KNOTYP.LT.0 and NKNOTS.NE.(2*N+4). -C -C *Description: -C DPCHBS computes the B-spline representation of the PCH function -C determined by N,X,F,D. To be compatible with the rest of PCHIP, -C DPCHBS includes INCFD, the increment between successive values of -C the F- and D-arrays. -C -C The output is the B-representation for the function: NKNOTS, T, -C BCOEF, NDIM, KORD. -C -C *Caution: -C Since it is assumed that the input PCH function has been -C computed by one of the other routines in the package PCHIP, -C input arguments N, X, INCFD are **not** checked for validity. -C -C *Restrictions/assumptions: -C 1. N.GE.2 . (not checked) -C 2. X(i).LT.X(i+1), i=1,...,N . (not checked) -C 3. INCFD.GT.0 . (not checked) -C 4. KNOTYP.LE.2 . (error return if not) -C *5. NKNOTS = NDIM+4 = 2*N+4 . (error return if not) -C *6. T(2*k+1) = T(2*k) = X(k), k=1,...,N . (not checked) -C -C * Indicates this applies only if KNOTYP.LT.0 . -C -C *Portability: -C Argument INCFD is used only to cause the compiler to generate -C efficient code for the subscript expressions (1+(I-1)*INCFD) . -C The normal usage, in which DPCHBS is called with one-dimensional -C arrays F and D, is probably non-Fortran 77, in the strict sense, -C but it works on all systems on which DPCHBS has been tested. -C -C *See Also: -C PCHIC, PCHIM, or PCHSP can be used to determine an interpolating -C PCH function from a set of data. -C The B-spline routine DBVALU can be used to evaluate the -C B-representation that is output by DPCHBS. -C (See BSPDOC for more information.) -C -C***REFERENCES F. N. Fritsch, "Representations for parametric cubic -C splines," Computer Aided Geometric Design 6 (1989), -C pp.79-82. -C***ROUTINES CALLED DPCHKT, XERMSG -C***REVISION HISTORY (YYMMDD) -C 870701 DATE WRITTEN -C 900405 Converted Fortran to upper case. -C 900405 Removed requirement that X be dimensioned N+1. -C 900406 Modified to make PCHKT a subsidiary routine to simplify -C usage. In the process, added argument INCFD to be com- -C patible with the rest of PCHIP. -C 900410 Converted prologue to SLATEC 4.0 format. -C 900410 Added calls to XERMSG and changed constant 3. to 3 to -C reduce single/double differences. -C 900411 Added reference. -C 900430 Produced double precision version. -C 900501 Corrected declarations. -C 930317 Minor cosmetic changes. (FNF) -C 930514 Corrected problems with dimensioning of arguments and -C clarified DESCRIPTION. (FNF) -C 930604 Removed NKNOTS from DPCHKT call list. (FNF) -C***END PROLOGUE DPCHBS -C -C*Internal Notes: -C -C**End -C -C Declare arguments. -C - INTEGER N, INCFD, KNOTYP, NKNOTS, NDIM, KORD, IERR - DOUBLE PRECISION X(*), F(INCFD,*), D(INCFD,*), T(*), BCOEF(*) -C -C Declare local variables. -C - INTEGER K, KK - DOUBLE PRECISION DOV3, HNEW, HOLD - CHARACTER*8 LIBNAM, SUBNAM -C***FIRST EXECUTABLE STATEMENT DPCHBS -C -C Initialize. -C - NDIM = 2*N - KORD = 4 - IERR = 0 - LIBNAM = 'SLATEC' - SUBNAM = 'DPCHBS' -C -C Check argument validity. Set up knot sequence if OK. -C - IF ( KNOTYP.GT.2 ) THEN - IERR = -1 - CALL XERMSG (LIBNAM, SUBNAM, 'KNOTYP GREATER THAN 2', IERR, 1) - RETURN - ENDIF - IF ( KNOTYP.LT.0 ) THEN - IF ( NKNOTS.NE.NDIM+4 ) THEN - IERR = -2 - CALL XERMSG (LIBNAM, SUBNAM, - * 'KNOTYP.LT.0 AND NKNOTS.NE.(2*N+4)', IERR, 1) - RETURN - ENDIF - ELSE -C Set up knot sequence. - NKNOTS = NDIM + 4 - CALL DPCHKT (N, X, KNOTYP, T) - ENDIF -C -C Compute B-spline coefficients. -C - HNEW = T(3) - T(1) - DO 40 K = 1, N - KK = 2*K - HOLD = HNEW -C The following requires mixed mode arithmetic. - DOV3 = D(1,K)/3 - BCOEF(KK-1) = F(1,K) - HOLD*DOV3 -C The following assumes T(2*K+1) = X(K). - HNEW = T(KK+3) - T(KK+1) - BCOEF(KK) = F(1,K) + HNEW*DOV3 - 40 CONTINUE -C -C Terminate. -C - RETURN -C------------- LAST LINE OF DPCHBS FOLLOWS ----------------------------- - END diff --git a/slatec/dpchce.f b/slatec/dpchce.f deleted file mode 100644 index 3f55f94..0000000 --- a/slatec/dpchce.f +++ /dev/null @@ -1,247 +0,0 @@ -*DECK DPCHCE - SUBROUTINE DPCHCE (IC, VC, N, X, H, SLOPE, D, INCFD, IERR) -C***BEGIN PROLOGUE DPCHCE -C***SUBSIDIARY -C***PURPOSE Set boundary conditions for DPCHIC -C***LIBRARY SLATEC (PCHIP) -C***TYPE DOUBLE PRECISION (PCHCE-S, DPCHCE-D) -C***AUTHOR Fritsch, F. N., (LLNL) -C***DESCRIPTION -C -C DPCHCE: DPCHIC End Derivative Setter. -C -C Called by DPCHIC to set end derivatives as requested by the user. -C It must be called after interior derivative values have been set. -C ----- -C -C To facilitate two-dimensional applications, includes an increment -C between successive values of the D-array. -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C PARAMETER (INCFD = ...) -C INTEGER IC(2), N, IERR -C DOUBLE PRECISION VC(2), X(N), H(N), SLOPE(N), D(INCFD,N) -C -C CALL DPCHCE (IC, VC, N, X, H, SLOPE, D, INCFD, IERR) -C -C Parameters: -C -C IC -- (input) integer array of length 2 specifying desired -C boundary conditions: -C IC(1) = IBEG, desired condition at beginning of data. -C IC(2) = IEND, desired condition at end of data. -C ( see prologue to DPCHIC for details. ) -C -C VC -- (input) real*8 array of length 2 specifying desired boundary -C values. VC(1) need be set only if IC(1) = 2 or 3 . -C VC(2) need be set only if IC(2) = 2 or 3 . -C -C N -- (input) number of data points. (assumes N.GE.2) -C -C X -- (input) real*8 array of independent variable values. (the -C elements of X are assumed to be strictly increasing.) -C -C H -- (input) real*8 array of interval lengths. -C SLOPE -- (input) real*8 array of data slopes. -C If the data are (X(I),Y(I)), I=1(1)N, then these inputs are: -C H(I) = X(I+1)-X(I), -C SLOPE(I) = (Y(I+1)-Y(I))/H(I), I=1(1)N-1. -C -C D -- (input) real*8 array of derivative values at the data points. -C The value corresponding to X(I) must be stored in -C D(1+(I-1)*INCFD), I=1(1)N. -C (output) the value of D at X(1) and/or X(N) is changed, if -C necessary, to produce the requested boundary conditions. -C no other entries in D are changed. -C -C INCFD -- (input) increment between successive values in D. -C This argument is provided primarily for 2-D applications. -C -C IERR -- (output) error flag. -C Normal return: -C IERR = 0 (no errors). -C Warning errors: -C IERR = 1 if IBEG.LT.0 and D(1) had to be adjusted for -C monotonicity. -C IERR = 2 if IEND.LT.0 and D(1+(N-1)*INCFD) had to be -C adjusted for monotonicity. -C IERR = 3 if both of the above are true. -C -C ------- -C WARNING: This routine does no validity-checking of arguments. -C ------- -C -C Fortran intrinsics used: ABS. -C -C***SEE ALSO DPCHIC -C***ROUTINES CALLED DPCHDF, DPCHST, XERMSG -C***REVISION HISTORY (YYMMDD) -C 820218 DATE WRITTEN -C 820805 Converted to SLATEC library version. -C 870707 Corrected XERROR calls for d.p. name(s). -C 890206 Corrected XERROR calls. -C 890411 Added SAVE statements (Vers. 3.2). -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 910408 Updated AUTHOR section in prologue. (WRB) -C 930503 Improved purpose. (FNF) -C***END PROLOGUE DPCHCE -C -C Programming notes: -C 1. The function DPCHST(ARG1,ARG2) is assumed to return zero if -C either argument is zero, +1 if they are of the same sign, and -C -1 if they are of opposite sign. -C 2. One could reduce the number of arguments and amount of local -C storage, at the expense of reduced code clarity, by passing in -C the array WK (rather than splitting it into H and SLOPE) and -C increasing its length enough to incorporate STEMP and XTEMP. -C 3. The two monotonicity checks only use the sufficient conditions. -C Thus, it is possible (but unlikely) for a boundary condition to -C be changed, even though the original interpolant was monotonic. -C (At least the result is a continuous function of the data.) -C**End -C -C DECLARE ARGUMENTS. -C - INTEGER IC(2), N, INCFD, IERR - DOUBLE PRECISION VC(2), X(*), H(*), SLOPE(*), D(INCFD,*) -C -C DECLARE LOCAL VARIABLES. -C - INTEGER IBEG, IEND, IERF, INDEX, J, K - DOUBLE PRECISION HALF, STEMP(3), THREE, TWO, XTEMP(4), ZERO - SAVE ZERO, HALF, TWO, THREE - DOUBLE PRECISION DPCHDF, DPCHST -C -C INITIALIZE. -C - DATA ZERO /0.D0/, HALF/.5D0/, TWO/2.D0/, THREE/3.D0/ -C -C***FIRST EXECUTABLE STATEMENT DPCHCE - IBEG = IC(1) - IEND = IC(2) - IERR = 0 -C -C SET TO DEFAULT BOUNDARY CONDITIONS IF N IS TOO SMALL. -C - IF ( ABS(IBEG).GT.N ) IBEG = 0 - IF ( ABS(IEND).GT.N ) IEND = 0 -C -C TREAT BEGINNING BOUNDARY CONDITION. -C - IF (IBEG .EQ. 0) GO TO 2000 - K = ABS(IBEG) - IF (K .EQ. 1) THEN -C BOUNDARY VALUE PROVIDED. - D(1,1) = VC(1) - ELSE IF (K .EQ. 2) THEN -C BOUNDARY SECOND DERIVATIVE PROVIDED. - D(1,1) = HALF*( (THREE*SLOPE(1) - D(1,2)) - HALF*VC(1)*H(1) ) - ELSE IF (K .LT. 5) THEN -C USE K-POINT DERIVATIVE FORMULA. -C PICK UP FIRST K POINTS, IN REVERSE ORDER. - DO 10 J = 1, K - INDEX = K-J+1 -C INDEX RUNS FROM K DOWN TO 1. - XTEMP(J) = X(INDEX) - IF (J .LT. K) STEMP(J) = SLOPE(INDEX-1) - 10 CONTINUE -C ----------------------------- - D(1,1) = DPCHDF (K, XTEMP, STEMP, IERF) -C ----------------------------- - IF (IERF .NE. 0) GO TO 5001 - ELSE -C USE 'NOT A KNOT' CONDITION. - D(1,1) = ( THREE*(H(1)*SLOPE(2) + H(2)*SLOPE(1)) - * - TWO*(H(1)+H(2))*D(1,2) - H(1)*D(1,3) ) / H(2) - ENDIF -C - IF (IBEG .GT. 0) GO TO 2000 -C -C CHECK D(1,1) FOR COMPATIBILITY WITH MONOTONICITY. -C - IF (SLOPE(1) .EQ. ZERO) THEN - IF (D(1,1) .NE. ZERO) THEN - D(1,1) = ZERO - IERR = IERR + 1 - ENDIF - ELSE IF ( DPCHST(D(1,1),SLOPE(1)) .LT. ZERO) THEN - D(1,1) = ZERO - IERR = IERR + 1 - ELSE IF ( ABS(D(1,1)) .GT. THREE*ABS(SLOPE(1)) ) THEN - D(1,1) = THREE*SLOPE(1) - IERR = IERR + 1 - ENDIF -C -C TREAT END BOUNDARY CONDITION. -C - 2000 CONTINUE - IF (IEND .EQ. 0) GO TO 5000 - K = ABS(IEND) - IF (K .EQ. 1) THEN -C BOUNDARY VALUE PROVIDED. - D(1,N) = VC(2) - ELSE IF (K .EQ. 2) THEN -C BOUNDARY SECOND DERIVATIVE PROVIDED. - D(1,N) = HALF*( (THREE*SLOPE(N-1) - D(1,N-1)) + - * HALF*VC(2)*H(N-1) ) - ELSE IF (K .LT. 5) THEN -C USE K-POINT DERIVATIVE FORMULA. -C PICK UP LAST K POINTS. - DO 2010 J = 1, K - INDEX = N-K+J -C INDEX RUNS FROM N+1-K UP TO N. - XTEMP(J) = X(INDEX) - IF (J .LT. K) STEMP(J) = SLOPE(INDEX) - 2010 CONTINUE -C ----------------------------- - D(1,N) = DPCHDF (K, XTEMP, STEMP, IERF) -C ----------------------------- - IF (IERF .NE. 0) GO TO 5001 - ELSE -C USE 'NOT A KNOT' CONDITION. - D(1,N) = ( THREE*(H(N-1)*SLOPE(N-2) + H(N-2)*SLOPE(N-1)) - * - TWO*(H(N-1)+H(N-2))*D(1,N-1) - H(N-1)*D(1,N-2) ) - * / H(N-2) - ENDIF -C - IF (IEND .GT. 0) GO TO 5000 -C -C CHECK D(1,N) FOR COMPATIBILITY WITH MONOTONICITY. -C - IF (SLOPE(N-1) .EQ. ZERO) THEN - IF (D(1,N) .NE. ZERO) THEN - D(1,N) = ZERO - IERR = IERR + 2 - ENDIF - ELSE IF ( DPCHST(D(1,N),SLOPE(N-1)) .LT. ZERO) THEN - D(1,N) = ZERO - IERR = IERR + 2 - ELSE IF ( ABS(D(1,N)) .GT. THREE*ABS(SLOPE(N-1)) ) THEN - D(1,N) = THREE*SLOPE(N-1) - IERR = IERR + 2 - ENDIF -C -C NORMAL RETURN. -C - 5000 CONTINUE - RETURN -C -C ERROR RETURN. -C - 5001 CONTINUE -C ERROR RETURN FROM DPCHDF. -C *** THIS CASE SHOULD NEVER OCCUR *** - IERR = -1 - CALL XERMSG ('SLATEC', 'DPCHCE', 'ERROR RETURN FROM DPCHDF', - + IERR, 1) - RETURN -C------------- LAST LINE OF DPCHCE FOLLOWS ----------------------------- - END diff --git a/slatec/dpchci.f b/slatec/dpchci.f deleted file mode 100644 index fcf03c4..0000000 --- a/slatec/dpchci.f +++ /dev/null @@ -1,185 +0,0 @@ -*DECK DPCHCI - SUBROUTINE DPCHCI (N, H, SLOPE, D, INCFD) -C***BEGIN PROLOGUE DPCHCI -C***SUBSIDIARY -C***PURPOSE Set interior derivatives for DPCHIC -C***LIBRARY SLATEC (PCHIP) -C***TYPE DOUBLE PRECISION (PCHCI-S, DPCHCI-D) -C***AUTHOR Fritsch, F. N., (LLNL) -C***DESCRIPTION -C -C DPCHCI: DPCHIC Initial Derivative Setter. -C -C Called by DPCHIC to set derivatives needed to determine a monotone -C piecewise cubic Hermite interpolant to the data. -C -C Default boundary conditions are provided which are compatible -C with monotonicity. If the data are only piecewise monotonic, the -C interpolant will have an extremum at each point where monotonicity -C switches direction. -C -C To facilitate two-dimensional applications, includes an increment -C between successive values of the D-array. -C -C The resulting piecewise cubic Hermite function should be identical -C (within roundoff error) to that produced by DPCHIM. -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C PARAMETER (INCFD = ...) -C INTEGER N -C DOUBLE PRECISION H(N), SLOPE(N), D(INCFD,N) -C -C CALL DPCHCI (N, H, SLOPE, D, INCFD) -C -C Parameters: -C -C N -- (input) number of data points. -C If N=2, simply does linear interpolation. -C -C H -- (input) real*8 array of interval lengths. -C SLOPE -- (input) real*8 array of data slopes. -C If the data are (X(I),Y(I)), I=1(1)N, then these inputs are: -C H(I) = X(I+1)-X(I), -C SLOPE(I) = (Y(I+1)-Y(I))/H(I), I=1(1)N-1. -C -C D -- (output) real*8 array of derivative values at data points. -C If the data are monotonic, these values will determine a -C a monotone cubic Hermite function. -C The value corresponding to X(I) is stored in -C D(1+(I-1)*INCFD), I=1(1)N. -C No other entries in D are changed. -C -C INCFD -- (input) increment between successive values in D. -C This argument is provided primarily for 2-D applications. -C -C ------- -C WARNING: This routine does no validity-checking of arguments. -C ------- -C -C Fortran intrinsics used: ABS, MAX, MIN. -C -C***SEE ALSO DPCHIC -C***ROUTINES CALLED DPCHST -C***REVISION HISTORY (YYMMDD) -C 820218 DATE WRITTEN -C 820601 Modified end conditions to be continuous functions of -C data when monotonicity switches in next interval. -C 820602 1. Modified formulas so end conditions are less prone -C to over/underflow problems. -C 2. Minor modification to HSUM calculation. -C 820805 Converted to SLATEC library version. -C 870813 Minor cosmetic changes. -C 890411 Added SAVE statements (Vers. 3.2). -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900328 Added TYPE section. (WRB) -C 910408 Updated AUTHOR section in prologue. (WRB) -C 930503 Improved purpose. (FNF) -C***END PROLOGUE DPCHCI -C -C Programming notes: -C 1. The function DPCHST(ARG1,ARG2) is assumed to return zero if -C either argument is zero, +1 if they are of the same sign, and -C -1 if they are of opposite sign. -C**End -C -C DECLARE ARGUMENTS. -C - INTEGER N, INCFD - DOUBLE PRECISION H(*), SLOPE(*), D(INCFD,*) -C -C DECLARE LOCAL VARIABLES. -C - INTEGER I, NLESS1 - DOUBLE PRECISION DEL1, DEL2, DMAX, DMIN, DRAT1, DRAT2, HSUM, - * HSUMT3, THREE, W1, W2, ZERO - SAVE ZERO, THREE - DOUBLE PRECISION DPCHST -C -C INITIALIZE. -C - DATA ZERO /0.D0/, THREE/3.D0/ -C***FIRST EXECUTABLE STATEMENT DPCHCI - NLESS1 = N - 1 - DEL1 = SLOPE(1) -C -C SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION. -C - IF (NLESS1 .GT. 1) GO TO 10 - D(1,1) = DEL1 - D(1,N) = DEL1 - GO TO 5000 -C -C NORMAL CASE (N .GE. 3). -C - 10 CONTINUE - DEL2 = SLOPE(2) -C -C SET D(1) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE -C SHAPE-PRESERVING. -C - HSUM = H(1) + H(2) - W1 = (H(1) + HSUM)/HSUM - W2 = -H(1)/HSUM - D(1,1) = W1*DEL1 + W2*DEL2 - IF ( DPCHST(D(1,1),DEL1) .LE. ZERO) THEN - D(1,1) = ZERO - ELSE IF ( DPCHST(DEL1,DEL2) .LT. ZERO) THEN -C NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. - DMAX = THREE*DEL1 - IF (ABS(D(1,1)) .GT. ABS(DMAX)) D(1,1) = DMAX - ENDIF -C -C LOOP THROUGH INTERIOR POINTS. -C - DO 50 I = 2, NLESS1 - IF (I .EQ. 2) GO TO 40 -C - HSUM = H(I-1) + H(I) - DEL1 = DEL2 - DEL2 = SLOPE(I) - 40 CONTINUE -C -C SET D(I)=0 UNLESS DATA ARE STRICTLY MONOTONIC. -C - D(1,I) = ZERO - IF ( DPCHST(DEL1,DEL2) .LE. ZERO) GO TO 50 -C -C USE BRODLIE MODIFICATION OF BUTLAND FORMULA. -C - HSUMT3 = HSUM+HSUM+HSUM - W1 = (HSUM + H(I-1))/HSUMT3 - W2 = (HSUM + H(I) )/HSUMT3 - DMAX = MAX( ABS(DEL1), ABS(DEL2) ) - DMIN = MIN( ABS(DEL1), ABS(DEL2) ) - DRAT1 = DEL1/DMAX - DRAT2 = DEL2/DMAX - D(1,I) = DMIN/(W1*DRAT1 + W2*DRAT2) -C - 50 CONTINUE -C -C SET D(N) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE -C SHAPE-PRESERVING. -C - W1 = -H(N-1)/HSUM - W2 = (H(N-1) + HSUM)/HSUM - D(1,N) = W1*DEL1 + W2*DEL2 - IF ( DPCHST(D(1,N),DEL2) .LE. ZERO) THEN - D(1,N) = ZERO - ELSE IF ( DPCHST(DEL1,DEL2) .LT. ZERO) THEN -C NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. - DMAX = THREE*DEL2 - IF (ABS(D(1,N)) .GT. ABS(DMAX)) D(1,N) = DMAX - ENDIF -C -C NORMAL RETURN. -C - 5000 CONTINUE - RETURN -C------------- LAST LINE OF DPCHCI FOLLOWS ----------------------------- - END diff --git a/slatec/dpchcm.f b/slatec/dpchcm.f deleted file mode 100644 index 1dbcbcb..0000000 --- a/slatec/dpchcm.f +++ /dev/null @@ -1,237 +0,0 @@ -*DECK DPCHCM - SUBROUTINE DPCHCM (N, X, F, D, INCFD, SKIP, ISMON, IERR) -C***BEGIN PROLOGUE DPCHCM -C***PURPOSE Check a cubic Hermite function for monotonicity. -C***LIBRARY SLATEC (PCHIP) -C***CATEGORY E3 -C***TYPE DOUBLE PRECISION (PCHCM-S, DPCHCM-D) -C***KEYWORDS CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION, -C PCHIP, PIECEWISE CUBIC INTERPOLATION, UTILITY ROUTINE -C***AUTHOR Fritsch, F. N., (LLNL) -C Computing & Mathematics Research Division -C Lawrence Livermore National Laboratory -C P.O. Box 808 (L-316) -C Livermore, CA 94550 -C FTS 532-4275, (510) 422-4275 -C***DESCRIPTION -C -C *Usage: -C -C PARAMETER (INCFD = ...) -C INTEGER N, ISMON(N), IERR -C DOUBLE PRECISION X(N), F(INCFD,N), D(INCFD,N) -C LOGICAL SKIP -C -C CALL DPCHCM (N, X, F, D, INCFD, SKIP, ISMON, IERR) -C -C *Arguments: -C -C N:IN is the number of data points. (Error return if N.LT.2 .) -C -C X:IN is a real*8 array of independent variable values. The -C elements of X must be strictly increasing: -C X(I-1) .LT. X(I), I = 2(1)N. -C (Error return if not.) -C -C F:IN is a real*8 array of function values. F(1+(I-1)*INCFD) is -C the value corresponding to X(I). -C -C D:IN is a real*8 array of derivative values. D(1+(I-1)*INCFD) is -C is the value corresponding to X(I). -C -C INCFD:IN is the increment between successive values in F and D. -C (Error return if INCFD.LT.1 .) -C -C SKIP:INOUT is a logical variable which should be set to -C .TRUE. if the user wishes to skip checks for validity of -C preceding parameters, or to .FALSE. otherwise. -C This will save time in case these checks have already -C been performed. -C SKIP will be set to .TRUE. on normal return. -C -C ISMON:OUT is an integer array indicating on which intervals the -C PCH function defined by N, X, F, D is monotonic. -C For data interval [X(I),X(I+1)], -C ISMON(I) = -3 if function is probably decreasing; -C ISMON(I) = -1 if function is strictly decreasing; -C ISMON(I) = 0 if function is constant; -C ISMON(I) = 1 if function is strictly increasing; -C ISMON(I) = 2 if function is non-monotonic; -C ISMON(I) = 3 if function is probably increasing. -C If ABS(ISMON)=3, this means that the D-values are near -C the boundary of the monotonicity region. A small -C increase produces non-monotonicity; decrease, strict -C monotonicity. -C The above applies to I=1(1)N-1. ISMON(N) indicates whether -C the entire function is monotonic on [X(1),X(N)]. -C -C IERR:OUT is an error flag. -C Normal return: -C IERR = 0 (no errors). -C "Recoverable" errors: -C IERR = -1 if N.LT.2 . -C IERR = -2 if INCFD.LT.1 . -C IERR = -3 if the X-array is not strictly increasing. -C (The ISMON-array has not been changed in any of these cases.) -C NOTE: The above errors are checked in the order listed, -C and following arguments have **NOT** been validated. -C -C *Description: -C -C DPCHCM: Piecewise Cubic Hermite -- Check Monotonicity. -C -C Checks the piecewise cubic Hermite function defined by N,X,F,D -C for monotonicity. -C -C To provide compatibility with DPCHIM and DPCHIC, includes an -C increment between successive values of the F- and D-arrays. -C -C *Cautions: -C This provides the same capability as old DPCHMC, except that a -C new output value, -3, was added February 1989. (Formerly, -3 -C and +3 were lumped together in the single value 3.) Codes that -C flag nonmonotonicity by "IF (ISMON.EQ.2)" need not be changed. -C Codes that check via "IF (ISMON.GE.3)" should change the test to -C "IF (IABS(ISMON).GE.3)". Codes that declare monotonicity via -C "IF (ISMON.LE.1)" should change to "IF (IABS(ISMON).LE.1)". -C -C***REFERENCES F. N. Fritsch and R. E. Carlson, Monotone piecewise -C cubic interpolation, SIAM Journal on Numerical Ana- -C lysis 17, 2 (April 1980), pp. 238-246. -C***ROUTINES CALLED DCHFCM, XERMSG -C***REVISION HISTORY (YYMMDD) -C 820518 DATE WRITTEN -C 820804 Converted to SLATEC library version. -C 831201 Reversed order of subscripts of F and D, so that the -C routine will work properly when INCFD.GT.1 . (Bug!) -C 870707 Corrected XERROR calls for d.p. name(s). -C 890206 Corrected XERROR calls. -C 890209 Added possible ISMON value of -3 and modified code so -C that 1,3,-1 produces ISMON(N)=2, rather than 3. -C 890306 Added caution about changed output. -C 890407 Changed name from DPCHMC to DPCHCM, as requested at the -C March 1989 SLATEC CML meeting, and made a few other -C minor modifications necessitated by this change. -C 890407 Converted to new SLATEC format. -C 890407 Modified DESCRIPTION to LDOC format. -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 920429 Revised format and order of references. (WRB,FNF) -C***END PROLOGUE DPCHCM -C -C Fortran intrinsics used: ISIGN. -C Other routines used: CHFCM, XERMSG. -C -C ---------------------------------------------------------------------- -C -C Programming notes: -C -C An alternate organization would have separate loops for computing -C ISMON(i), i=1,...,NSEG, and for the computation of ISMON(N). The -C first loop can be readily parallelized, since the NSEG calls to -C CHFCM are independent. The second loop can be cut short if -C ISMON(N) is ever equal to 2, for it cannot be changed further. -C -C To produce a single precision version, simply: -C a. Change DPCHCM to PCHCM wherever it occurs, -C b. Change DCHFCM to CHFCM wherever it occurs, and -C c. Change the double precision declarations to real. -C -C DECLARE ARGUMENTS. -C - INTEGER N, INCFD, ISMON(N), IERR - DOUBLE PRECISION X(N), F(INCFD,N), D(INCFD,N) - LOGICAL SKIP -C -C DECLARE LOCAL VARIABLES. -C - INTEGER I, NSEG - DOUBLE PRECISION DELTA - INTEGER DCHFCM -C -C VALIDITY-CHECK ARGUMENTS. -C -C***FIRST EXECUTABLE STATEMENT DPCHCM - IF (SKIP) GO TO 5 -C - IF ( N.LT.2 ) GO TO 5001 - IF ( INCFD.LT.1 ) GO TO 5002 - DO 1 I = 2, N - IF ( X(I).LE.X(I-1) ) GO TO 5003 - 1 CONTINUE - SKIP = .TRUE. -C -C FUNCTION DEFINITION IS OK -- GO ON. -C - 5 CONTINUE - NSEG = N - 1 - DO 90 I = 1, NSEG - DELTA = (F(1,I+1)-F(1,I))/(X(I+1)-X(I)) -C ------------------------------- - ISMON(I) = DCHFCM (D(1,I), D(1,I+1), DELTA) -C ------------------------------- - IF (I .EQ. 1) THEN - ISMON(N) = ISMON(1) - ELSE -C Need to figure out cumulative monotonicity from following -C "multiplication table": -C -C + I S M O N (I) -C + -3 -1 0 1 3 2 -C +------------------------+ -C I -3 I -3 -3 -3 2 2 2 I -C S -1 I -3 -1 -1 2 2 2 I -C M 0 I -3 -1 0 1 3 2 I -C O 1 I 2 2 1 1 3 2 I -C N 3 I 2 2 3 3 3 2 I -C (N) 2 I 2 2 2 2 2 2 I -C +------------------------+ -C Note that the 2 row and column are out of order so as not -C to obscure the symmetry in the rest of the table. -C -C No change needed if equal or constant on this interval or -C already declared nonmonotonic. - IF ( (ISMON(I).NE.ISMON(N)) .AND. (ISMON(I).NE.0) - . .AND. (ISMON(N).NE.2) ) THEN - IF ( (ISMON(I).EQ.2) .OR. (ISMON(N).EQ.0) ) THEN - ISMON(N) = ISMON(I) - ELSE IF (ISMON(I)*ISMON(N) .LT. 0) THEN -C This interval has opposite sense from curve so far. - ISMON(N) = 2 - ELSE -C At this point, both are nonzero with same sign, and -C we have already eliminated case both +-1. - ISMON(N) = ISIGN (3, ISMON(N)) - ENDIF - ENDIF - ENDIF - 90 CONTINUE -C -C NORMAL RETURN. -C - IERR = 0 - RETURN -C -C ERROR RETURNS. -C - 5001 CONTINUE -C N.LT.2 RETURN. - IERR = -1 - CALL XERMSG ('SLATEC', 'DPCHCM', - + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) - RETURN -C - 5002 CONTINUE -C INCFD.LT.1 RETURN. - IERR = -2 - CALL XERMSG ('SLATEC', 'DPCHCM', 'INCREMENT LESS THAN ONE', IERR, - + 1) - RETURN -C - 5003 CONTINUE -C X-ARRAY NOT STRICTLY INCREASING. - IERR = -3 - CALL XERMSG ('SLATEC', 'DPCHCM', - + 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) - RETURN -C------------- LAST LINE OF DPCHCM FOLLOWS ----------------------------- - END diff --git a/slatec/dpchcs.f b/slatec/dpchcs.f deleted file mode 100644 index 5375e2b..0000000 --- a/slatec/dpchcs.f +++ /dev/null @@ -1,237 +0,0 @@ -*DECK DPCHCS - SUBROUTINE DPCHCS (SWITCH, N, H, SLOPE, D, INCFD, IERR) -C***BEGIN PROLOGUE DPCHCS -C***SUBSIDIARY -C***PURPOSE Adjusts derivative values for DPCHIC -C***LIBRARY SLATEC (PCHIP) -C***TYPE DOUBLE PRECISION (PCHCS-S, DPCHCS-D) -C***AUTHOR Fritsch, F. N., (LLNL) -C***DESCRIPTION -C -C DPCHCS: DPCHIC Monotonicity Switch Derivative Setter. -C -C Called by DPCHIC to adjust the values of D in the vicinity of a -C switch in direction of monotonicity, to produce a more "visually -C pleasing" curve than that given by DPCHIM . -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C PARAMETER (INCFD = ...) -C INTEGER N, IERR -C DOUBLE PRECISION SWITCH, H(N), SLOPE(N), D(INCFD,N) -C -C CALL DPCHCS (SWITCH, N, H, SLOPE, D, INCFD, IERR) -C -C Parameters: -C -C SWITCH -- (input) indicates the amount of control desired over -C local excursions from data. -C -C N -- (input) number of data points. (assumes N.GT.2 .) -C -C H -- (input) real*8 array of interval lengths. -C SLOPE -- (input) real*8 array of data slopes. -C If the data are (X(I),Y(I)), I=1(1)N, then these inputs are: -C H(I) = X(I+1)-X(I), -C SLOPE(I) = (Y(I+1)-Y(I))/H(I), I=1(1)N-1. -C -C D -- (input) real*8 array of derivative values at the data points, -C as determined by DPCHCI. -C (output) derivatives in the vicinity of switches in direction -C of monotonicity may be adjusted to produce a more "visually -C pleasing" curve. -C The value corresponding to X(I) is stored in -C D(1+(I-1)*INCFD), I=1(1)N. -C No other entries in D are changed. -C -C INCFD -- (input) increment between successive values in D. -C This argument is provided primarily for 2-D applications. -C -C IERR -- (output) error flag. should be zero. -C If negative, trouble in DPCHSW. (should never happen.) -C -C ------- -C WARNING: This routine does no validity-checking of arguments. -C ------- -C -C Fortran intrinsics used: ABS, MAX, MIN. -C -C***SEE ALSO DPCHIC -C***ROUTINES CALLED DPCHST, DPCHSW -C***REVISION HISTORY (YYMMDD) -C 820218 DATE WRITTEN -C 820617 Redesigned to (1) fix problem with lack of continuity -C approaching a flat-topped peak (2) be cleaner and -C easier to verify. -C Eliminated subroutines PCHSA and PCHSX in the process. -C 820622 1. Limited fact to not exceed one, so computed D is a -C convex combination of DPCHCI value and DPCHSD value. -C 2. Changed fudge from 1 to 4 (based on experiments). -C 820623 Moved PCHSD to an inline function (eliminating MSWTYP). -C 820805 Converted to SLATEC library version. -C 870707 Corrected conversion to double precision. -C 870813 Minor cosmetic changes. -C 890411 Added SAVE statements (Vers. 3.2). -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891006 Modified spacing in computation of DFLOC. (WRB) -C 891006 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910408 Updated AUTHOR section in prologue. (WRB) -C 930503 Improved purpose. (FNF) -C***END PROLOGUE DPCHCS -C -C Programming notes: -C 1. The function DPCHST(ARG1,ARG2) is assumed to return zero if -C either argument is zero, +1 if they are of the same sign, and -C -1 if they are of opposite sign. -C**End -C -C DECLARE ARGUMENTS. -C - INTEGER N, INCFD, IERR - DOUBLE PRECISION SWITCH, H(*), SLOPE(*), D(INCFD,*) -C -C DECLARE LOCAL VARIABLES. -C - INTEGER I, INDX, K, NLESS1 - DOUBLE PRECISION DEL(3), DEXT, DFLOC, DFMX, FACT, FUDGE, ONE, - * SLMAX, WTAVE(2), ZERO - SAVE ZERO, ONE, FUDGE - DOUBLE PRECISION DPCHST -C -C DEFINE INLINE FUNCTION FOR WEIGHTED AVERAGE OF SLOPES. -C - DOUBLE PRECISION DPCHSD, S1, S2, H1, H2 - DPCHSD(S1,S2,H1,H2) = (H2/(H1+H2))*S1 + (H1/(H1+H2))*S2 -C -C INITIALIZE. -C - DATA ZERO /0.D0/, ONE/1.D0/ - DATA FUDGE /4.D0/ -C***FIRST EXECUTABLE STATEMENT DPCHCS - IERR = 0 - NLESS1 = N - 1 -C -C LOOP OVER SEGMENTS. -C - DO 900 I = 2, NLESS1 - IF ( DPCHST(SLOPE(I-1),SLOPE(I)) ) 100, 300, 900 -C -------------------------- -C - 100 CONTINUE -C -C....... SLOPE SWITCHES MONOTONICITY AT I-TH POINT ..................... -C -C DO NOT CHANGE D IF 'UP-DOWN-UP'. - IF (I .GT. 2) THEN - IF ( DPCHST(SLOPE(I-2),SLOPE(I)) .GT. ZERO) GO TO 900 -C -------------------------- - ENDIF - IF (I .LT. NLESS1) THEN - IF ( DPCHST(SLOPE(I+1),SLOPE(I-1)) .GT. ZERO) GO TO 900 -C ---------------------------- - ENDIF -C -C ....... COMPUTE PROVISIONAL VALUE FOR D(1,I). -C - DEXT = DPCHSD (SLOPE(I-1), SLOPE(I), H(I-1), H(I)) -C -C ....... DETERMINE WHICH INTERVAL CONTAINS THE EXTREMUM. -C - IF ( DPCHST(DEXT, SLOPE(I-1)) ) 200, 900, 250 -C ----------------------- -C - 200 CONTINUE -C DEXT AND SLOPE(I-1) HAVE OPPOSITE SIGNS -- -C EXTREMUM IS IN (X(I-1),X(I)). - K = I-1 -C SET UP TO COMPUTE NEW VALUES FOR D(1,I-1) AND D(1,I). - WTAVE(2) = DEXT - IF (K .GT. 1) - * WTAVE(1) = DPCHSD (SLOPE(K-1), SLOPE(K), H(K-1), H(K)) - GO TO 400 -C - 250 CONTINUE -C DEXT AND SLOPE(I) HAVE OPPOSITE SIGNS -- -C EXTREMUM IS IN (X(I),X(I+1)). - K = I -C SET UP TO COMPUTE NEW VALUES FOR D(1,I) AND D(1,I+1). - WTAVE(1) = DEXT - IF (K .LT. NLESS1) - * WTAVE(2) = DPCHSD (SLOPE(K), SLOPE(K+1), H(K), H(K+1)) - GO TO 400 -C - 300 CONTINUE -C -C....... AT LEAST ONE OF SLOPE(I-1) AND SLOPE(I) IS ZERO -- -C CHECK FOR FLAT-TOPPED PEAK ....................... -C - IF (I .EQ. NLESS1) GO TO 900 - IF ( DPCHST(SLOPE(I-1), SLOPE(I+1)) .GE. ZERO) GO TO 900 -C ----------------------------- -C -C WE HAVE FLAT-TOPPED PEAK ON (X(I),X(I+1)). - K = I -C SET UP TO COMPUTE NEW VALUES FOR D(1,I) AND D(1,I+1). - WTAVE(1) = DPCHSD (SLOPE(K-1), SLOPE(K), H(K-1), H(K)) - WTAVE(2) = DPCHSD (SLOPE(K), SLOPE(K+1), H(K), H(K+1)) -C - 400 CONTINUE -C -C....... AT THIS POINT WE HAVE DETERMINED THAT THERE WILL BE AN EXTREMUM -C ON (X(K),X(K+1)), WHERE K=I OR I-1, AND HAVE SET ARRAY WTAVE-- -C WTAVE(1) IS A WEIGHTED AVERAGE OF SLOPE(K-1) AND SLOPE(K), -C IF K.GT.1 -C WTAVE(2) IS A WEIGHTED AVERAGE OF SLOPE(K) AND SLOPE(K+1), -C IF K.LT.N-1 -C - SLMAX = ABS(SLOPE(K)) - IF (K .GT. 1) SLMAX = MAX( SLMAX, ABS(SLOPE(K-1)) ) - IF (K.LT.NLESS1) SLMAX = MAX( SLMAX, ABS(SLOPE(K+1)) ) -C - IF (K .GT. 1) DEL(1) = SLOPE(K-1) / SLMAX - DEL(2) = SLOPE(K) / SLMAX - IF (K.LT.NLESS1) DEL(3) = SLOPE(K+1) / SLMAX -C - IF ((K.GT.1) .AND. (K.LT.NLESS1)) THEN -C NORMAL CASE -- EXTREMUM IS NOT IN A BOUNDARY INTERVAL. - FACT = FUDGE* ABS(DEL(3)*(DEL(1)-DEL(2))*(WTAVE(2)/SLMAX)) - D(1,K) = D(1,K) + MIN(FACT,ONE)*(WTAVE(1) - D(1,K)) - FACT = FUDGE* ABS(DEL(1)*(DEL(3)-DEL(2))*(WTAVE(1)/SLMAX)) - D(1,K+1) = D(1,K+1) + MIN(FACT,ONE)*(WTAVE(2) - D(1,K+1)) - ELSE -C SPECIAL CASE K=1 (WHICH CAN OCCUR ONLY IF I=2) OR -C K=NLESS1 (WHICH CAN OCCUR ONLY IF I=NLESS1). - FACT = FUDGE* ABS(DEL(2)) - D(1,I) = MIN(FACT,ONE) * WTAVE(I-K+1) -C NOTE THAT I-K+1 = 1 IF K=I (=NLESS1), -C I-K+1 = 2 IF K=I-1(=1). - ENDIF -C -C -C....... ADJUST IF NECESSARY TO LIMIT EXCURSIONS FROM DATA. -C - IF (SWITCH .LE. ZERO) GO TO 900 -C - DFLOC = H(K)*ABS(SLOPE(K)) - IF (K .GT. 1) DFLOC = MAX( DFLOC, H(K-1)*ABS(SLOPE(K-1)) ) - IF (K.LT.NLESS1) DFLOC = MAX( DFLOC, H(K+1)*ABS(SLOPE(K+1)) ) - DFMX = SWITCH*DFLOC - INDX = I-K+1 -C INDX = 1 IF K=I, 2 IF K=I-1. -C --------------------------------------------------------------- - CALL DPCHSW(DFMX, INDX, D(1,K), D(1,K+1), H(K), SLOPE(K), IERR) -C --------------------------------------------------------------- - IF (IERR .NE. 0) RETURN -C -C....... END OF SEGMENT LOOP. -C - 900 CONTINUE -C - RETURN -C------------- LAST LINE OF DPCHCS FOLLOWS ----------------------------- - END diff --git a/slatec/dpchdf.f b/slatec/dpchdf.f deleted file mode 100644 index 53994fb..0000000 --- a/slatec/dpchdf.f +++ /dev/null @@ -1,108 +0,0 @@ -*DECK DPCHDF - DOUBLE PRECISION FUNCTION DPCHDF (K, X, S, IERR) -C***BEGIN PROLOGUE DPCHDF -C***SUBSIDIARY -C***PURPOSE Computes divided differences for DPCHCE and DPCHSP -C***LIBRARY SLATEC (PCHIP) -C***TYPE DOUBLE PRECISION (PCHDF-S, DPCHDF-D) -C***AUTHOR Fritsch, F. N., (LLNL) -C***DESCRIPTION -C -C DPCHDF: DPCHIP Finite Difference Formula -C -C Uses a divided difference formulation to compute a K-point approx- -C imation to the derivative at X(K) based on the data in X and S. -C -C Called by DPCHCE and DPCHSP to compute 3- and 4-point boundary -C derivative approximations. -C -C ---------------------------------------------------------------------- -C -C On input: -C K is the order of the desired derivative approximation. -C K must be at least 3 (error return if not). -C X contains the K values of the independent variable. -C X need not be ordered, but the values **MUST** be -C distinct. (Not checked here.) -C S contains the associated slope values: -C S(I) = (F(I+1)-F(I))/(X(I+1)-X(I)), I=1(1)K-1. -C (Note that S need only be of length K-1.) -C -C On return: -C S will be destroyed. -C IERR will be set to -1 if K.LT.2 . -C DPCHDF will be set to the desired derivative approximation if -C IERR=0 or to zero if IERR=-1. -C -C ---------------------------------------------------------------------- -C -C***SEE ALSO DPCHCE, DPCHSP -C***REFERENCES Carl de Boor, A Practical Guide to Splines, Springer- -C Verlag, New York, 1978, pp. 10-16. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 820503 DATE WRITTEN -C 820805 Converted to SLATEC library version. -C 870707 Corrected XERROR calls for d.p. name(s). -C 870813 Minor cosmetic changes. -C 890206 Corrected XERROR calls. -C 890411 Added SAVE statements (Vers. 3.2). -C 890411 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 900328 Added TYPE section. (WRB) -C 910408 Updated AUTHOR and DATE WRITTEN sections in prologue. (WRB) -C 920429 Revised format and order of references. (WRB,FNF) -C 930503 Improved purpose. (FNF) -C***END PROLOGUE DPCHDF -C -C**End -C -C DECLARE ARGUMENTS. -C - INTEGER K, IERR - DOUBLE PRECISION X(K), S(K) -C -C DECLARE LOCAL VARIABLES. -C - INTEGER I, J - DOUBLE PRECISION VALUE, ZERO - SAVE ZERO - DATA ZERO /0.D0/ -C -C CHECK FOR LEGAL VALUE OF K. -C -C***FIRST EXECUTABLE STATEMENT DPCHDF - IF (K .LT. 3) GO TO 5001 -C -C COMPUTE COEFFICIENTS OF INTERPOLATING POLYNOMIAL. -C - DO 10 J = 2, K-1 - DO 9 I = 1, K-J - S(I) = (S(I+1)-S(I))/(X(I+J)-X(I)) - 9 CONTINUE - 10 CONTINUE -C -C EVALUATE DERIVATIVE AT X(K). -C - VALUE = S(1) - DO 20 I = 2, K-1 - VALUE = S(I) + VALUE*(X(K)-X(I)) - 20 CONTINUE -C -C NORMAL RETURN. -C - IERR = 0 - DPCHDF = VALUE - RETURN -C -C ERROR RETURN. -C - 5001 CONTINUE -C K.LT.3 RETURN. - IERR = -1 - CALL XERMSG ('SLATEC', 'DPCHDF', 'K LESS THAN THREE', IERR, 1) - DPCHDF = ZERO - RETURN -C------------- LAST LINE OF DPCHDF FOLLOWS ----------------------------- - END diff --git a/slatec/dpchfd.f b/slatec/dpchfd.f deleted file mode 100644 index f3e7f3d..0000000 --- a/slatec/dpchfd.f +++ /dev/null @@ -1,324 +0,0 @@ -*DECK DPCHFD - SUBROUTINE DPCHFD (N, X, F, D, INCFD, SKIP, NE, XE, FE, DE, IERR) -C***BEGIN PROLOGUE DPCHFD -C***PURPOSE Evaluate a piecewise cubic Hermite function and its first -C derivative at an array of points. May be used by itself -C for Hermite interpolation, or as an evaluator for DPCHIM -C or DPCHIC. If only function values are required, use -C DPCHFE instead. -C***LIBRARY SLATEC (PCHIP) -C***CATEGORY E3, H1 -C***TYPE DOUBLE PRECISION (PCHFD-S, DPCHFD-D) -C***KEYWORDS CUBIC HERMITE DIFFERENTIATION, CUBIC HERMITE EVALUATION, -C HERMITE INTERPOLATION, PCHIP, PIECEWISE CUBIC EVALUATION -C***AUTHOR Fritsch, F. N., (LLNL) -C Lawrence Livermore National Laboratory -C P.O. Box 808 (L-316) -C Livermore, CA 94550 -C FTS 532-4275, (510) 422-4275 -C***DESCRIPTION -C -C DPCHFD: Piecewise Cubic Hermite Function and Derivative -C evaluator -C -C Evaluates the cubic Hermite function defined by N, X, F, D, to- -C gether with its first derivative, at the points XE(J), J=1(1)NE. -C -C If only function values are required, use DPCHFE, instead. -C -C To provide compatibility with DPCHIM and DPCHIC, includes an -C increment between successive values of the F- and D-arrays. -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C PARAMETER (INCFD = ...) -C INTEGER N, NE, IERR -C DOUBLE PRECISION X(N), F(INCFD,N), D(INCFD,N), XE(NE), FE(NE), -C DE(NE) -C LOGICAL SKIP -C -C CALL DPCHFD (N, X, F, D, INCFD, SKIP, NE, XE, FE, DE, IERR) -C -C Parameters: -C -C N -- (input) number of data points. (Error return if N.LT.2 .) -C -C X -- (input) real*8 array of independent variable values. The -C elements of X must be strictly increasing: -C X(I-1) .LT. X(I), I = 2(1)N. -C (Error return if not.) -C -C F -- (input) real*8 array of function values. F(1+(I-1)*INCFD) is -C the value corresponding to X(I). -C -C D -- (input) real*8 array of derivative values. D(1+(I-1)*INCFD) -C is the value corresponding to X(I). -C -C INCFD -- (input) increment between successive values in F and D. -C (Error return if INCFD.LT.1 .) -C -C SKIP -- (input/output) logical variable which should be set to -C .TRUE. if the user wishes to skip checks for validity of -C preceding parameters, or to .FALSE. otherwise. -C This will save time in case these checks have already -C been performed (say, in DPCHIM or DPCHIC). -C SKIP will be set to .TRUE. on normal return. -C -C NE -- (input) number of evaluation points. (Error return if -C NE.LT.1 .) -C -C XE -- (input) real*8 array of points at which the functions are to -C be evaluated. -C -C -C NOTES: -C 1. The evaluation will be most efficient if the elements -C of XE are increasing relative to X; -C that is, XE(J) .GE. X(I) -C implies XE(K) .GE. X(I), all K.GE.J . -C 2. If any of the XE are outside the interval [X(1),X(N)], -C values are extrapolated from the nearest extreme cubic, -C and a warning error is returned. -C -C FE -- (output) real*8 array of values of the cubic Hermite -C function defined by N, X, F, D at the points XE. -C -C DE -- (output) real*8 array of values of the first derivative of -C the same function at the points XE. -C -C IERR -- (output) error flag. -C Normal return: -C IERR = 0 (no errors). -C Warning error: -C IERR.GT.0 means that extrapolation was performed at -C IERR points. -C "Recoverable" errors: -C IERR = -1 if N.LT.2 . -C IERR = -2 if INCFD.LT.1 . -C IERR = -3 if the X-array is not strictly increasing. -C IERR = -4 if NE.LT.1 . -C (Output arrays have not been changed in any of these cases.) -C NOTE: The above errors are checked in the order listed, -C and following arguments have **NOT** been validated. -C IERR = -5 if an error has occurred in the lower-level -C routine DCHFDV. NB: this should never happen. -C Notify the author **IMMEDIATELY** if it does. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED DCHFDV, XERMSG -C***REVISION HISTORY (YYMMDD) -C 811020 DATE WRITTEN -C 820803 Minor cosmetic changes for release 1. -C 870707 Corrected XERROR calls for d.p. name(s). -C 890206 Corrected XERROR calls. -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (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***END PROLOGUE DPCHFD -C Programming notes: -C -C 1. To produce a single precision version, simply: -C a. Change DPCHFD to PCHFD, and DCHFDV to CHFDV, wherever they -C occur, -C b. Change the double precision declaration to real, -C -C 2. Most of the coding between the call to DCHFDV and the end of -C the IR-loop could be eliminated if it were permissible to -C assume that XE is ordered relative to X. -C -C 3. DCHFDV does not assume that X1 is less than X2. thus, it would -C be possible to write a version of DPCHFD that assumes a strict- -C ly decreasing X-array by simply running the IR-loop backwards -C (and reversing the order of appropriate tests). -C -C 4. The present code has a minor bug, which I have decided is not -C worth the effort that would be required to fix it. -C If XE contains points in [X(N-1),X(N)], followed by points .LT. -C X(N-1), followed by points .GT.X(N), the extrapolation points -C will be counted (at least) twice in the total returned in IERR. -C -C DECLARE ARGUMENTS. -C - INTEGER N, INCFD, NE, IERR - DOUBLE PRECISION X(*), F(INCFD,*), D(INCFD,*), XE(*), FE(*), - * DE(*) - LOGICAL SKIP -C -C DECLARE LOCAL VARIABLES. -C - INTEGER I, IERC, IR, J, JFIRST, NEXT(2), NJ -C -C VALIDITY-CHECK ARGUMENTS. -C -C***FIRST EXECUTABLE STATEMENT DPCHFD - IF (SKIP) GO TO 5 -C - IF ( N.LT.2 ) GO TO 5001 - IF ( INCFD.LT.1 ) GO TO 5002 - DO 1 I = 2, N - IF ( X(I).LE.X(I-1) ) GO TO 5003 - 1 CONTINUE -C -C FUNCTION DEFINITION IS OK, GO ON. -C - 5 CONTINUE - IF ( NE.LT.1 ) GO TO 5004 - IERR = 0 - SKIP = .TRUE. -C -C LOOP OVER INTERVALS. ( INTERVAL INDEX IS IL = IR-1 . ) -C ( INTERVAL IS X(IL).LE.X.LT.X(IR) . ) - JFIRST = 1 - IR = 2 - 10 CONTINUE -C -C SKIP OUT OF LOOP IF HAVE PROCESSED ALL EVALUATION POINTS. -C - IF (JFIRST .GT. NE) GO TO 5000 -C -C LOCATE ALL POINTS IN INTERVAL. -C - DO 20 J = JFIRST, NE - IF (XE(J) .GE. X(IR)) GO TO 30 - 20 CONTINUE - J = NE + 1 - GO TO 40 -C -C HAVE LOCATED FIRST POINT BEYOND INTERVAL. -C - 30 CONTINUE - IF (IR .EQ. N) J = NE + 1 -C - 40 CONTINUE - NJ = J - JFIRST -C -C SKIP EVALUATION IF NO POINTS IN INTERVAL. -C - IF (NJ .EQ. 0) GO TO 50 -C -C EVALUATE CUBIC AT XE(I), I = JFIRST (1) J-1 . -C -C ---------------------------------------------------------------- - CALL DCHFDV (X(IR-1),X(IR), F(1,IR-1),F(1,IR), D(1,IR-1),D(1,IR) - * ,NJ, XE(JFIRST), FE(JFIRST), DE(JFIRST), NEXT, IERC) -C ---------------------------------------------------------------- - IF (IERC .LT. 0) GO TO 5005 -C - IF (NEXT(2) .EQ. 0) GO TO 42 -C IF (NEXT(2) .GT. 0) THEN -C IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(2) TO THE -C RIGHT OF X(IR). -C - IF (IR .LT. N) GO TO 41 -C IF (IR .EQ. N) THEN -C THESE ARE ACTUALLY EXTRAPOLATION POINTS. - IERR = IERR + NEXT(2) - GO TO 42 - 41 CONTINUE -C ELSE -C WE SHOULD NEVER HAVE GOTTEN HERE. - GO TO 5005 -C ENDIF -C ENDIF - 42 CONTINUE -C - IF (NEXT(1) .EQ. 0) GO TO 49 -C IF (NEXT(1) .GT. 0) THEN -C IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(1) TO THE -C LEFT OF X(IR-1). -C - IF (IR .GT. 2) GO TO 43 -C IF (IR .EQ. 2) THEN -C THESE ARE ACTUALLY EXTRAPOLATION POINTS. - IERR = IERR + NEXT(1) - GO TO 49 - 43 CONTINUE -C ELSE -C XE IS NOT ORDERED RELATIVE TO X, SO MUST ADJUST -C EVALUATION INTERVAL. -C -C FIRST, LOCATE FIRST POINT TO LEFT OF X(IR-1). - DO 44 I = JFIRST, J-1 - IF (XE(I) .LT. X(IR-1)) GO TO 45 - 44 CONTINUE -C NOTE-- CANNOT DROP THROUGH HERE UNLESS THERE IS AN ERROR -C IN DCHFDV. - GO TO 5005 -C - 45 CONTINUE -C RESET J. (THIS WILL BE THE NEW JFIRST.) - J = I -C -C NOW FIND OUT HOW FAR TO BACK UP IN THE X-ARRAY. - DO 46 I = 1, IR-1 - IF (XE(J) .LT. X(I)) GO TO 47 - 46 CONTINUE -C NB-- CAN NEVER DROP THROUGH HERE, SINCE XE(J).LT.X(IR-1). -C - 47 CONTINUE -C AT THIS POINT, EITHER XE(J) .LT. X(1) -C OR X(I-1) .LE. XE(J) .LT. X(I) . -C RESET IR, RECOGNIZING THAT IT WILL BE INCREMENTED BEFORE -C CYCLING. - IR = MAX(1, I-1) -C ENDIF -C ENDIF - 49 CONTINUE -C - JFIRST = J -C -C END OF IR-LOOP. -C - 50 CONTINUE - IR = IR + 1 - IF (IR .LE. N) GO TO 10 -C -C NORMAL RETURN. -C - 5000 CONTINUE - RETURN -C -C ERROR RETURNS. -C - 5001 CONTINUE -C N.LT.2 RETURN. - IERR = -1 - CALL XERMSG ('SLATEC', 'DPCHFD', - + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) - RETURN -C - 5002 CONTINUE -C INCFD.LT.1 RETURN. - IERR = -2 - CALL XERMSG ('SLATEC', 'DPCHFD', 'INCREMENT LESS THAN ONE', IERR, - + 1) - RETURN -C - 5003 CONTINUE -C X-ARRAY NOT STRICTLY INCREASING. - IERR = -3 - CALL XERMSG ('SLATEC', 'DPCHFD', - + 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) - RETURN -C - 5004 CONTINUE -C NE.LT.1 RETURN. - IERR = -4 - CALL XERMSG ('SLATEC', 'DPCHFD', - + 'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1) - RETURN -C - 5005 CONTINUE -C ERROR RETURN FROM DCHFDV. -C *** THIS CASE SHOULD NEVER OCCUR *** - IERR = -5 - CALL XERMSG ('SLATEC', 'DPCHFD', - + 'ERROR RETURN FROM DCHFDV -- FATAL', IERR, 2) - RETURN -C------------- LAST LINE OF DPCHFD FOLLOWS ----------------------------- - END diff --git a/slatec/dpchfe.f b/slatec/dpchfe.f deleted file mode 100644 index 7ce9108..0000000 --- a/slatec/dpchfe.f +++ /dev/null @@ -1,310 +0,0 @@ -*DECK DPCHFE - SUBROUTINE DPCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR) -C***BEGIN PROLOGUE DPCHFE -C***PURPOSE Evaluate a piecewise cubic Hermite function at an array of -C points. May be used by itself for Hermite interpolation, -C or as an evaluator for DPCHIM or DPCHIC. -C***LIBRARY SLATEC (PCHIP) -C***CATEGORY E3 -C***TYPE DOUBLE PRECISION (PCHFE-S, DPCHFE-D) -C***KEYWORDS CUBIC HERMITE EVALUATION, HERMITE INTERPOLATION, PCHIP, -C PIECEWISE CUBIC EVALUATION -C***AUTHOR Fritsch, F. N., (LLNL) -C Lawrence Livermore National Laboratory -C P.O. Box 808 (L-316) -C Livermore, CA 94550 -C FTS 532-4275, (510) 422-4275 -C***DESCRIPTION -C -C DPCHFE: Piecewise Cubic Hermite Function Evaluator -C -C Evaluates the cubic Hermite function defined by N, X, F, D at -C the points XE(J), J=1(1)NE. -C -C To provide compatibility with DPCHIM and DPCHIC, includes an -C increment between successive values of the F- and D-arrays. -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C PARAMETER (INCFD = ...) -C INTEGER N, NE, IERR -C DOUBLE PRECISION X(N), F(INCFD,N), D(INCFD,N), XE(NE), FE(NE) -C LOGICAL SKIP -C -C CALL DPCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR) -C -C Parameters: -C -C N -- (input) number of data points. (Error return if N.LT.2 .) -C -C X -- (input) real*8 array of independent variable values. The -C elements of X must be strictly increasing: -C X(I-1) .LT. X(I), I = 2(1)N. -C (Error return if not.) -C -C F -- (input) real*8 array of function values. F(1+(I-1)*INCFD) is -C the value corresponding to X(I). -C -C D -- (input) real*8 array of derivative values. D(1+(I-1)*INCFD) -C is the value corresponding to X(I). -C -C INCFD -- (input) increment between successive values in F and D. -C (Error return if INCFD.LT.1 .) -C -C SKIP -- (input/output) logical variable which should be set to -C .TRUE. if the user wishes to skip checks for validity of -C preceding parameters, or to .FALSE. otherwise. -C This will save time in case these checks have already -C been performed (say, in DPCHIM or DPCHIC). -C SKIP will be set to .TRUE. on normal return. -C -C NE -- (input) number of evaluation points. (Error return if -C NE.LT.1 .) -C -C XE -- (input) real*8 array of points at which the function is to -C be evaluated. -C -C NOTES: -C 1. The evaluation will be most efficient if the elements -C of XE are increasing relative to X; -C that is, XE(J) .GE. X(I) -C implies XE(K) .GE. X(I), all K.GE.J . -C 2. If any of the XE are outside the interval [X(1),X(N)], -C values are extrapolated from the nearest extreme cubic, -C and a warning error is returned. -C -C FE -- (output) real*8 array of values of the cubic Hermite -C function defined by N, X, F, D at the points XE. -C -C IERR -- (output) error flag. -C Normal return: -C IERR = 0 (no errors). -C Warning error: -C IERR.GT.0 means that extrapolation was performed at -C IERR points. -C "Recoverable" errors: -C IERR = -1 if N.LT.2 . -C IERR = -2 if INCFD.LT.1 . -C IERR = -3 if the X-array is not strictly increasing. -C IERR = -4 if NE.LT.1 . -C (The FE-array has not been changed in any of these cases.) -C NOTE: The above errors are checked in the order listed, -C and following arguments have **NOT** been validated. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED DCHFEV, XERMSG -C***REVISION HISTORY (YYMMDD) -C 811020 DATE WRITTEN -C 820803 Minor cosmetic changes for release 1. -C 870707 Corrected XERROR calls for d.p. name(s). -C 890206 Corrected XERROR calls. -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (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***END PROLOGUE DPCHFE -C Programming notes: -C -C 1. To produce a single precision version, simply: -C a. Change DPCHFE to PCHFE, and DCHFEV to CHFEV, wherever they -C occur, -C b. Change the double precision declaration to real, -C -C 2. Most of the coding between the call to DCHFEV and the end of -C the IR-loop could be eliminated if it were permissible to -C assume that XE is ordered relative to X. -C -C 3. DCHFEV does not assume that X1 is less than X2. thus, it would -C be possible to write a version of DPCHFE that assumes a -C decreasing X-array by simply running the IR-loop backwards -C (and reversing the order of appropriate tests). -C -C 4. The present code has a minor bug, which I have decided is not -C worth the effort that would be required to fix it. -C If XE contains points in [X(N-1),X(N)], followed by points .LT. -C X(N-1), followed by points .GT.X(N), the extrapolation points -C will be counted (at least) twice in the total returned in IERR. -C -C DECLARE ARGUMENTS. -C - INTEGER N, INCFD, NE, IERR - DOUBLE PRECISION X(*), F(INCFD,*), D(INCFD,*), XE(*), FE(*) - LOGICAL SKIP -C -C DECLARE LOCAL VARIABLES. -C - INTEGER I, IERC, IR, J, JFIRST, NEXT(2), NJ -C -C VALIDITY-CHECK ARGUMENTS. -C -C***FIRST EXECUTABLE STATEMENT DPCHFE - IF (SKIP) GO TO 5 -C - IF ( N.LT.2 ) GO TO 5001 - IF ( INCFD.LT.1 ) GO TO 5002 - DO 1 I = 2, N - IF ( X(I).LE.X(I-1) ) GO TO 5003 - 1 CONTINUE -C -C FUNCTION DEFINITION IS OK, GO ON. -C - 5 CONTINUE - IF ( NE.LT.1 ) GO TO 5004 - IERR = 0 - SKIP = .TRUE. -C -C LOOP OVER INTERVALS. ( INTERVAL INDEX IS IL = IR-1 . ) -C ( INTERVAL IS X(IL).LE.X.LT.X(IR) . ) - JFIRST = 1 - IR = 2 - 10 CONTINUE -C -C SKIP OUT OF LOOP IF HAVE PROCESSED ALL EVALUATION POINTS. -C - IF (JFIRST .GT. NE) GO TO 5000 -C -C LOCATE ALL POINTS IN INTERVAL. -C - DO 20 J = JFIRST, NE - IF (XE(J) .GE. X(IR)) GO TO 30 - 20 CONTINUE - J = NE + 1 - GO TO 40 -C -C HAVE LOCATED FIRST POINT BEYOND INTERVAL. -C - 30 CONTINUE - IF (IR .EQ. N) J = NE + 1 -C - 40 CONTINUE - NJ = J - JFIRST -C -C SKIP EVALUATION IF NO POINTS IN INTERVAL. -C - IF (NJ .EQ. 0) GO TO 50 -C -C EVALUATE CUBIC AT XE(I), I = JFIRST (1) J-1 . -C -C ---------------------------------------------------------------- - CALL DCHFEV (X(IR-1),X(IR), F(1,IR-1),F(1,IR), D(1,IR-1),D(1,IR) - * ,NJ, XE(JFIRST), FE(JFIRST), NEXT, IERC) -C ---------------------------------------------------------------- - IF (IERC .LT. 0) GO TO 5005 -C - IF (NEXT(2) .EQ. 0) GO TO 42 -C IF (NEXT(2) .GT. 0) THEN -C IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(2) TO THE -C RIGHT OF X(IR). -C - IF (IR .LT. N) GO TO 41 -C IF (IR .EQ. N) THEN -C THESE ARE ACTUALLY EXTRAPOLATION POINTS. - IERR = IERR + NEXT(2) - GO TO 42 - 41 CONTINUE -C ELSE -C WE SHOULD NEVER HAVE GOTTEN HERE. - GO TO 5005 -C ENDIF -C ENDIF - 42 CONTINUE -C - IF (NEXT(1) .EQ. 0) GO TO 49 -C IF (NEXT(1) .GT. 0) THEN -C IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(1) TO THE -C LEFT OF X(IR-1). -C - IF (IR .GT. 2) GO TO 43 -C IF (IR .EQ. 2) THEN -C THESE ARE ACTUALLY EXTRAPOLATION POINTS. - IERR = IERR + NEXT(1) - GO TO 49 - 43 CONTINUE -C ELSE -C XE IS NOT ORDERED RELATIVE TO X, SO MUST ADJUST -C EVALUATION INTERVAL. -C -C FIRST, LOCATE FIRST POINT TO LEFT OF X(IR-1). - DO 44 I = JFIRST, J-1 - IF (XE(I) .LT. X(IR-1)) GO TO 45 - 44 CONTINUE -C NOTE-- CANNOT DROP THROUGH HERE UNLESS THERE IS AN ERROR -C IN DCHFEV. - GO TO 5005 -C - 45 CONTINUE -C RESET J. (THIS WILL BE THE NEW JFIRST.) - J = I -C -C NOW FIND OUT HOW FAR TO BACK UP IN THE X-ARRAY. - DO 46 I = 1, IR-1 - IF (XE(J) .LT. X(I)) GO TO 47 - 46 CONTINUE -C NB-- CAN NEVER DROP THROUGH HERE, SINCE XE(J).LT.X(IR-1). -C - 47 CONTINUE -C AT THIS POINT, EITHER XE(J) .LT. X(1) -C OR X(I-1) .LE. XE(J) .LT. X(I) . -C RESET IR, RECOGNIZING THAT IT WILL BE INCREMENTED BEFORE -C CYCLING. - IR = MAX(1, I-1) -C ENDIF -C ENDIF - 49 CONTINUE -C - JFIRST = J -C -C END OF IR-LOOP. -C - 50 CONTINUE - IR = IR + 1 - IF (IR .LE. N) GO TO 10 -C -C NORMAL RETURN. -C - 5000 CONTINUE - RETURN -C -C ERROR RETURNS. -C - 5001 CONTINUE -C N.LT.2 RETURN. - IERR = -1 - CALL XERMSG ('SLATEC', 'DPCHFE', - + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) - RETURN -C - 5002 CONTINUE -C INCFD.LT.1 RETURN. - IERR = -2 - CALL XERMSG ('SLATEC', 'DPCHFE', 'INCREMENT LESS THAN ONE', IERR, - + 1) - RETURN -C - 5003 CONTINUE -C X-ARRAY NOT STRICTLY INCREASING. - IERR = -3 - CALL XERMSG ('SLATEC', 'DPCHFE', - + 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) - RETURN -C - 5004 CONTINUE -C NE.LT.1 RETURN. - IERR = -4 - CALL XERMSG ('SLATEC', 'DPCHFE', - + 'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1) - RETURN -C - 5005 CONTINUE -C ERROR RETURN FROM DCHFEV. -C *** THIS CASE SHOULD NEVER OCCUR *** - IERR = -5 - CALL XERMSG ('SLATEC', 'DPCHFE', - + 'ERROR RETURN FROM DCHFEV -- FATAL', IERR, 2) - RETURN -C------------- LAST LINE OF DPCHFE FOLLOWS ----------------------------- - END diff --git a/slatec/dpchia.f b/slatec/dpchia.f deleted file mode 100644 index 7607d52..0000000 --- a/slatec/dpchia.f +++ /dev/null @@ -1,269 +0,0 @@ -*DECK DPCHIA - DOUBLE PRECISION FUNCTION DPCHIA (N, X, F, D, INCFD, SKIP, A, B, - + IERR) -C***BEGIN PROLOGUE DPCHIA -C***PURPOSE Evaluate the definite integral of a piecewise cubic -C Hermite function over an arbitrary interval. -C***LIBRARY SLATEC (PCHIP) -C***CATEGORY E3, H2A1B2 -C***TYPE DOUBLE PRECISION (PCHIA-S, DPCHIA-D) -C***KEYWORDS CUBIC HERMITE INTERPOLATION, NUMERICAL INTEGRATION, PCHIP, -C QUADRATURE -C***AUTHOR Fritsch, F. N., (LLNL) -C Lawrence Livermore National Laboratory -C P.O. Box 808 (L-316) -C Livermore, CA 94550 -C FTS 532-4275, (510) 422-4275 -C***DESCRIPTION -C -C DPCHIA: Piecewise Cubic Hermite Integrator, Arbitrary limits -C -C Evaluates the definite integral of the cubic Hermite function -C defined by N, X, F, D over the interval [A, B]. -C -C To provide compatibility with DPCHIM and DPCHIC, includes an -C increment between successive values of the F- and D-arrays. -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C PARAMETER (INCFD = ...) -C INTEGER N, IERR -C DOUBLE PRECISION X(N), F(INCFD,N), D(INCFD,N), A, B -C DOUBLE PRECISION VALUE, DPCHIA -C LOGICAL SKIP -C -C VALUE = DPCHIA (N, X, F, D, INCFD, SKIP, A, B, IERR) -C -C Parameters: -C -C VALUE -- (output) value of the requested integral. -C -C N -- (input) number of data points. (Error return if N.LT.2 .) -C -C X -- (input) real*8 array of independent variable values. The -C elements of X must be strictly increasing: -C X(I-1) .LT. X(I), I = 2(1)N. -C (Error return if not.) -C -C F -- (input) real*8 array of function values. F(1+(I-1)*INCFD) is -C the value corresponding to X(I). -C -C D -- (input) real*8 array of derivative values. D(1+(I-1)*INCFD) -C is the value corresponding to X(I). -C -C INCFD -- (input) increment between successive values in F and D. -C (Error return if INCFD.LT.1 .) -C -C SKIP -- (input/output) logical variable which should be set to -C .TRUE. if the user wishes to skip checks for validity of -C preceding parameters, or to .FALSE. otherwise. -C This will save time in case these checks have already -C been performed (say, in DPCHIM or DPCHIC). -C SKIP will be set to .TRUE. on return with IERR.GE.0 . -C -C A,B -- (input) the limits of integration. -C NOTE: There is no requirement that [A,B] be contained in -C [X(1),X(N)]. However, the resulting integral value -C will be highly suspect, if not. -C -C IERR -- (output) error flag. -C Normal return: -C IERR = 0 (no errors). -C Warning errors: -C IERR = 1 if A is outside the interval [X(1),X(N)]. -C IERR = 2 if B is outside the interval [X(1),X(N)]. -C IERR = 3 if both of the above are true. (Note that this -C means that either [A,B] contains data interval -C or the intervals do not intersect at all.) -C "Recoverable" errors: -C IERR = -1 if N.LT.2 . -C IERR = -2 if INCFD.LT.1 . -C IERR = -3 if the X-array is not strictly increasing. -C (VALUE will be zero in any of these cases.) -C NOTE: The above errors are checked in the order listed, -C and following arguments have **NOT** been validated. -C IERR = -4 in case of an error return from DPCHID (which -C should never occur). -C -C***REFERENCES (NONE) -C***ROUTINES CALLED DCHFIE, DPCHID, XERMSG -C***REVISION HISTORY (YYMMDD) -C 820730 DATE WRITTEN -C 820804 Converted to SLATEC library version. -C 870707 Corrected XERROR calls for d.p. name(s). -C 870707 Corrected conversion to double precision. -C 870813 Minor cosmetic changes. -C 890206 Corrected XERROR calls. -C 890411 Added SAVE statements (Vers. 3.2). -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890703 Corrected category record. (WRB) -C 890831 Modified array declarations. (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 930503 Corrected to set VALUE=0 when IERR.lt.0. (FNF) -C 930504 Changed DCHFIV to DCHFIE. (FNF) -C***END PROLOGUE DPCHIA -C -C Programming notes: -C 1. The error flag from DPCHID is tested, because a logic flaw -C could conceivably result in IERD=-4, which should be reported. -C**End -C -C DECLARE ARGUMENTS. -C - INTEGER N, INCFD, IERR - DOUBLE PRECISION X(*), F(INCFD,*), D(INCFD,*), A, B - LOGICAL SKIP -C -C DECLARE LOCAL VARIABLES. -C - INTEGER I, IA, IB, IERD, IL, IR - DOUBLE PRECISION VALUE, XA, XB, ZERO - SAVE ZERO - DOUBLE PRECISION DCHFIE, DPCHID -C -C INITIALIZE. -C - DATA ZERO /0.D0/ -C***FIRST EXECUTABLE STATEMENT DPCHIA - VALUE = ZERO -C -C VALIDITY-CHECK ARGUMENTS. -C - IF (SKIP) GO TO 5 -C - IF ( N.LT.2 ) GO TO 5001 - IF ( INCFD.LT.1 ) GO TO 5002 - DO 1 I = 2, N - IF ( X(I).LE.X(I-1) ) GO TO 5003 - 1 CONTINUE -C -C FUNCTION DEFINITION IS OK, GO ON. -C - 5 CONTINUE - SKIP = .TRUE. - IERR = 0 - IF ( (A.LT.X(1)) .OR. (A.GT.X(N)) ) IERR = IERR + 1 - IF ( (B.LT.X(1)) .OR. (B.GT.X(N)) ) IERR = IERR + 2 -C -C COMPUTE INTEGRAL VALUE. -C - IF (A .NE. B) THEN - XA = MIN (A, B) - XB = MAX (A, B) - IF (XB .LE. X(2)) THEN -C INTERVAL IS TO LEFT OF X(2), SO USE FIRST CUBIC. -C --------------------------------------- - VALUE = DCHFIE (X(1),X(2), F(1,1),F(1,2), - + D(1,1),D(1,2), A, B) -C --------------------------------------- - ELSE IF (XA .GE. X(N-1)) THEN -C INTERVAL IS TO RIGHT OF X(N-1), SO USE LAST CUBIC. -C ------------------------------------------ - VALUE = DCHFIE(X(N-1),X(N), F(1,N-1),F(1,N), - + D(1,N-1),D(1,N), A, B) -C ------------------------------------------ - ELSE -C 'NORMAL' CASE -- XA.LT.XB, XA.LT.X(N-1), XB.GT.X(2). -C ......LOCATE IA AND IB SUCH THAT -C X(IA-1).LT.XA.LE.X(IA).LE.X(IB).LE.XB.LE.X(IB+1) - IA = 1 - DO 10 I = 1, N-1 - IF (XA .GT. X(I)) IA = I + 1 - 10 CONTINUE -C IA = 1 IMPLIES XA.LT.X(1) . OTHERWISE, -C IA IS LARGEST INDEX SUCH THAT X(IA-1).LT.XA,. -C - IB = N - DO 20 I = N, IA, -1 - IF (XB .LT. X(I)) IB = I - 1 - 20 CONTINUE -C IB = N IMPLIES XB.GT.X(N) . OTHERWISE, -C IB IS SMALLEST INDEX SUCH THAT XB.LT.X(IB+1) . -C -C ......COMPUTE THE INTEGRAL. - IF (IB .LT. IA) THEN -C THIS MEANS IB = IA-1 AND -C (A,B) IS A SUBSET OF (X(IB),X(IA)). -C ------------------------------------------- - VALUE = DCHFIE (X(IB),X(IA), F(1,IB),F(1,IA), - + D(1,IB),D(1,IA), A, B) -C ------------------------------------------- - ELSE -C -C FIRST COMPUTE INTEGRAL OVER (X(IA),X(IB)). -C (Case (IB .EQ. IA) is taken care of by initialization -C of VALUE to ZERO.) - IF (IB .GT. IA) THEN -C --------------------------------------------- - VALUE = DPCHID (N, X, F, D, INCFD, SKIP, IA, IB, IERD) -C --------------------------------------------- - IF (IERD .LT. 0) GO TO 5004 - ENDIF -C -C THEN ADD ON INTEGRAL OVER (XA,X(IA)). - IF (XA .LT. X(IA)) THEN - IL = MAX(1, IA-1) - IR = IL + 1 -C ------------------------------------- - VALUE = VALUE + DCHFIE (X(IL),X(IR), F(1,IL),F(1,IR), - + D(1,IL),D(1,IR), XA, X(IA)) -C ------------------------------------- - ENDIF -C -C THEN ADD ON INTEGRAL OVER (X(IB),XB). - IF (XB .GT. X(IB)) THEN - IR = MIN (IB+1, N) - IL = IR - 1 -C ------------------------------------- - VALUE = VALUE + DCHFIE (X(IL),X(IR), F(1,IL),F(1,IR), - + D(1,IL),D(1,IR), X(IB), XB) -C ------------------------------------- - ENDIF -C -C FINALLY, ADJUST SIGN IF NECESSARY. - IF (A .GT. B) VALUE = -VALUE - ENDIF - ENDIF - ENDIF -C -C NORMAL RETURN. -C - 5000 CONTINUE - DPCHIA = VALUE - RETURN -C -C ERROR RETURNS. -C - 5001 CONTINUE -C N.LT.2 RETURN. - IERR = -1 - CALL XERMSG ('SLATEC', 'DPCHIA', - + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) - GO TO 5000 -C - 5002 CONTINUE -C INCFD.LT.1 RETURN. - IERR = -2 - CALL XERMSG ('SLATEC', 'DPCHIA', 'INCREMENT LESS THAN ONE', IERR, - + 1) - GO TO 5000 -C - 5003 CONTINUE -C X-ARRAY NOT STRICTLY INCREASING. - IERR = -3 - CALL XERMSG ('SLATEC', 'DPCHIA', - + 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) - GO TO 5000 -C - 5004 CONTINUE -C TROUBLE IN DPCHID. (SHOULD NEVER OCCUR.) - IERR = -4 - CALL XERMSG ('SLATEC', 'DPCHIA', 'TROUBLE IN DPCHID', IERR, 1) - GO TO 5000 -C------------- LAST LINE OF DPCHIA FOLLOWS ----------------------------- - END diff --git a/slatec/dpchic.f b/slatec/dpchic.f deleted file mode 100644 index 49367ee..0000000 --- a/slatec/dpchic.f +++ /dev/null @@ -1,347 +0,0 @@ -*DECK DPCHIC - SUBROUTINE DPCHIC (IC, VC, SWITCH, N, X, F, D, INCFD, WK, NWK, - + IERR) -C***BEGIN PROLOGUE DPCHIC -C***PURPOSE Set derivatives needed to determine a piecewise monotone -C piecewise cubic Hermite interpolant to given data. -C User control is available over boundary conditions and/or -C treatment of points where monotonicity switches direction. -C***LIBRARY SLATEC (PCHIP) -C***CATEGORY E1A -C***TYPE DOUBLE PRECISION (PCHIC-S, DPCHIC-D) -C***KEYWORDS CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION, -C PCHIP, PIECEWISE CUBIC INTERPOLATION, -C SHAPE-PRESERVING INTERPOLATION -C***AUTHOR Fritsch, F. N., (LLNL) -C Lawrence Livermore National Laboratory -C P.O. Box 808 (L-316) -C Livermore, CA 94550 -C FTS 532-4275, (510) 422-4275 -C***DESCRIPTION -C -C DPCHIC: Piecewise Cubic Hermite Interpolation Coefficients. -C -C Sets derivatives needed to determine a piecewise monotone piece- -C wise cubic interpolant to the data given in X and F satisfying the -C boundary conditions specified by IC and VC. -C -C The treatment of points where monotonicity switches direction is -C controlled by argument SWITCH. -C -C To facilitate two-dimensional applications, includes an increment -C between successive values of the F- and D-arrays. -C -C The resulting piecewise cubic Hermite function may be evaluated -C by DPCHFE or DPCHFD. -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C PARAMETER (INCFD = ...) -C INTEGER IC(2), N, NWK, IERR -C DOUBLE PRECISION VC(2), SWITCH, X(N), F(INCFD,N), D(INCFD,N), -C WK(NWK) -C -C CALL DPCHIC (IC, VC, SWITCH, N, X, F, D, INCFD, WK, NWK, IERR) -C -C Parameters: -C -C IC -- (input) integer array of length 2 specifying desired -C boundary conditions: -C IC(1) = IBEG, desired condition at beginning of data. -C IC(2) = IEND, desired condition at end of data. -C -C IBEG = 0 for the default boundary condition (the same as -C used by DPCHIM). -C If IBEG.NE.0, then its sign indicates whether the boundary -C derivative is to be adjusted, if necessary, to be -C compatible with monotonicity: -C IBEG.GT.0 if no adjustment is to be performed. -C IBEG.LT.0 if the derivative is to be adjusted for -C monotonicity. -C -C Allowable values for the magnitude of IBEG are: -C IBEG = 1 if first derivative at X(1) is given in VC(1). -C IBEG = 2 if second derivative at X(1) is given in VC(1). -C IBEG = 3 to use the 3-point difference formula for D(1). -C (Reverts to the default b.c. if N.LT.3 .) -C IBEG = 4 to use the 4-point difference formula for D(1). -C (Reverts to the default b.c. if N.LT.4 .) -C IBEG = 5 to set D(1) so that the second derivative is con- -C tinuous at X(2). (Reverts to the default b.c. if N.LT.4.) -C This option is somewhat analogous to the "not a knot" -C boundary condition provided by DPCHSP. -C -C NOTES (IBEG): -C 1. An error return is taken if ABS(IBEG).GT.5 . -C 2. Only in case IBEG.LE.0 is it guaranteed that the -C interpolant will be monotonic in the first interval. -C If the returned value of D(1) lies between zero and -C 3*SLOPE(1), the interpolant will be monotonic. This -C is **NOT** checked if IBEG.GT.0 . -C 3. If IBEG.LT.0 and D(1) had to be changed to achieve mono- -C tonicity, a warning error is returned. -C -C IEND may take on the same values as IBEG, but applied to -C derivative at X(N). In case IEND = 1 or 2, the value is -C given in VC(2). -C -C NOTES (IEND): -C 1. An error return is taken if ABS(IEND).GT.5 . -C 2. Only in case IEND.LE.0 is it guaranteed that the -C interpolant will be monotonic in the last interval. -C If the returned value of D(1+(N-1)*INCFD) lies between -C zero and 3*SLOPE(N-1), the interpolant will be monotonic. -C This is **NOT** checked if IEND.GT.0 . -C 3. If IEND.LT.0 and D(1+(N-1)*INCFD) had to be changed to -C achieve monotonicity, a warning error is returned. -C -C VC -- (input) real*8 array of length 2 specifying desired boundary -C values, as indicated above. -C VC(1) need be set only if IC(1) = 1 or 2 . -C VC(2) need be set only if IC(2) = 1 or 2 . -C -C SWITCH -- (input) indicates desired treatment of points where -C direction of monotonicity switches: -C Set SWITCH to zero if interpolant is required to be mono- -C tonic in each interval, regardless of monotonicity of data. -C NOTES: -C 1. This will cause D to be set to zero at all switch -C points, thus forcing extrema there. -C 2. The result of using this option with the default boun- -C dary conditions will be identical to using DPCHIM, but -C will generally cost more compute time. -C This option is provided only to facilitate comparison -C of different switch and/or boundary conditions. -C Set SWITCH nonzero to use a formula based on the 3-point -C difference formula in the vicinity of switch points. -C If SWITCH is positive, the interpolant on each interval -C containing an extremum is controlled to not deviate from -C the data by more than SWITCH*DFLOC, where DFLOC is the -C maximum of the change of F on this interval and its two -C immediate neighbors. -C If SWITCH is negative, no such control is to be imposed. -C -C N -- (input) number of data points. (Error return if N.LT.2 .) -C -C X -- (input) real*8 array of independent variable values. The -C elements of X must be strictly increasing: -C X(I-1) .LT. X(I), I = 2(1)N. -C (Error return if not.) -C -C F -- (input) real*8 array of dependent variable values to be -C interpolated. F(1+(I-1)*INCFD) is value corresponding to -C X(I). -C -C D -- (output) real*8 array of derivative values at the data -C points. These values will determine a monotone cubic -C Hermite function on each subinterval on which the data -C are monotonic, except possibly adjacent to switches in -C monotonicity. The value corresponding to X(I) is stored in -C D(1+(I-1)*INCFD), I=1(1)N. -C No other entries in D are changed. -C -C INCFD -- (input) increment between successive values in F and D. -C This argument is provided primarily for 2-D applications. -C (Error return if INCFD.LT.1 .) -C -C WK -- (scratch) real*8 array of working storage. The user may -C wish to know that the returned values are: -C WK(I) = H(I) = X(I+1) - X(I) ; -C WK(N-1+I) = SLOPE(I) = (F(1,I+1) - F(1,I)) / H(I) -C for I = 1(1)N-1. -C -C NWK -- (input) length of work array. -C (Error return if NWK.LT.2*(N-1) .) -C -C IERR -- (output) error flag. -C Normal return: -C IERR = 0 (no errors). -C Warning errors: -C IERR = 1 if IBEG.LT.0 and D(1) had to be adjusted for -C monotonicity. -C IERR = 2 if IEND.LT.0 and D(1+(N-1)*INCFD) had to be -C adjusted for monotonicity. -C IERR = 3 if both of the above are true. -C "Recoverable" errors: -C IERR = -1 if N.LT.2 . -C IERR = -2 if INCFD.LT.1 . -C IERR = -3 if the X-array is not strictly increasing. -C IERR = -4 if ABS(IBEG).GT.5 . -C IERR = -5 if ABS(IEND).GT.5 . -C IERR = -6 if both of the above are true. -C IERR = -7 if NWK.LT.2*(N-1) . -C (The D-array has not been changed in any of these cases.) -C NOTE: The above errors are checked in the order listed, -C and following arguments have **NOT** been validated. -C -C***REFERENCES 1. F. N. Fritsch, Piecewise Cubic Hermite Interpolation -C Package, Report UCRL-87285, Lawrence Livermore Natio- -C nal Laboratory, July 1982. [Poster presented at the -C SIAM 30th Anniversary Meeting, 19-23 July 1982.] -C 2. F. N. Fritsch and J. Butland, A method for construc- -C ting local monotone piecewise cubic interpolants, SIAM -C Journal on Scientific and Statistical Computing 5, 2 -C (June 1984), pp. 300-304. -C 3. F. N. Fritsch and R. E. Carlson, Monotone piecewise -C cubic interpolation, SIAM Journal on Numerical Ana- -C lysis 17, 2 (April 1980), pp. 238-246. -C***ROUTINES CALLED DPCHCE, DPCHCI, DPCHCS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 820218 DATE WRITTEN -C 820804 Converted to SLATEC library version. -C 870707 Corrected XERROR calls for d.p. name(s). -C 870813 Updated Reference 2. -C 890206 Corrected XERROR calls. -C 890411 Added SAVE statements (Vers. 3.2). -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890703 Corrected category record. (WRB) -C 890831 Modified array declarations. (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 920429 Revised format and order of references. (WRB,FNF) -C***END PROLOGUE DPCHIC -C Programming notes: -C -C To produce a single precision version, simply: -C a. Change DPCHIC to PCHIC wherever it occurs, -C b. Change DPCHCE to PCHCE wherever it occurs, -C c. Change DPCHCI to PCHCI wherever it occurs, -C d. Change DPCHCS to PCHCS wherever it occurs, -C e. Change the double precision declarations to real, and -C f. Change the constant ZERO to single precision. -C -C DECLARE ARGUMENTS. -C - INTEGER IC(2), N, INCFD, NWK, IERR - DOUBLE PRECISION VC(2), SWITCH, X(*), F(INCFD,*), D(INCFD,*), - * WK(NWK) -C -C DECLARE LOCAL VARIABLES. -C - INTEGER I, IBEG, IEND, NLESS1 - DOUBLE PRECISION ZERO - SAVE ZERO - DATA ZERO /0.D0/ -C -C VALIDITY-CHECK ARGUMENTS. -C -C***FIRST EXECUTABLE STATEMENT DPCHIC - IF ( N.LT.2 ) GO TO 5001 - IF ( INCFD.LT.1 ) GO TO 5002 - DO 1 I = 2, N - IF ( X(I).LE.X(I-1) ) GO TO 5003 - 1 CONTINUE -C - IBEG = IC(1) - IEND = IC(2) - IERR = 0 - IF (ABS(IBEG) .GT. 5) IERR = IERR - 1 - IF (ABS(IEND) .GT. 5) IERR = IERR - 2 - IF (IERR .LT. 0) GO TO 5004 -C -C FUNCTION DEFINITION IS OK -- GO ON. -C - NLESS1 = N - 1 - IF ( NWK .LT. 2*NLESS1 ) GO TO 5007 -C -C SET UP H AND SLOPE ARRAYS. -C - DO 20 I = 1, NLESS1 - WK(I) = X(I+1) - X(I) - WK(NLESS1+I) = (F(1,I+1) - F(1,I)) / WK(I) - 20 CONTINUE -C -C SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION. -C - IF (NLESS1 .GT. 1) GO TO 1000 - D(1,1) = WK(2) - D(1,N) = WK(2) - GO TO 3000 -C -C NORMAL CASE (N .GE. 3) . -C - 1000 CONTINUE -C -C SET INTERIOR DERIVATIVES AND DEFAULT END CONDITIONS. -C -C -------------------------------------- - CALL DPCHCI (N, WK(1), WK(N), D, INCFD) -C -------------------------------------- -C -C SET DERIVATIVES AT POINTS WHERE MONOTONICITY SWITCHES DIRECTION. -C - IF (SWITCH .EQ. ZERO) GO TO 3000 -C ---------------------------------------------------- - CALL DPCHCS (SWITCH, N, WK(1), WK(N), D, INCFD, IERR) -C ---------------------------------------------------- - IF (IERR .NE. 0) GO TO 5008 -C -C SET END CONDITIONS. -C - 3000 CONTINUE - IF ( (IBEG.EQ.0) .AND. (IEND.EQ.0) ) GO TO 5000 -C ------------------------------------------------------- - CALL DPCHCE (IC, VC, N, X, WK(1), WK(N), D, INCFD, IERR) -C ------------------------------------------------------- - IF (IERR .LT. 0) GO TO 5009 -C -C NORMAL RETURN. -C - 5000 CONTINUE - RETURN -C -C ERROR RETURNS. -C - 5001 CONTINUE -C N.LT.2 RETURN. - IERR = -1 - CALL XERMSG ('SLATEC', 'DPCHIC', - + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) - RETURN -C - 5002 CONTINUE -C INCFD.LT.1 RETURN. - IERR = -2 - CALL XERMSG ('SLATEC', 'DPCHIC', 'INCREMENT LESS THAN ONE', IERR, - + 1) - RETURN -C - 5003 CONTINUE -C X-ARRAY NOT STRICTLY INCREASING. - IERR = -3 - CALL XERMSG ('SLATEC', 'DPCHIC', - + 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) - RETURN -C - 5004 CONTINUE -C IC OUT OF RANGE RETURN. - IERR = IERR - 3 - CALL XERMSG ('SLATEC', 'DPCHIC', 'IC OUT OF RANGE', IERR, 1) - RETURN -C - 5007 CONTINUE -C NWK .LT. 2*(N-1) RETURN. - IERR = -7 - CALL XERMSG ('SLATEC', 'DPCHIC', 'WORK ARRAY TOO SMALL', IERR, 1) - RETURN -C - 5008 CONTINUE -C ERROR RETURN FROM DPCHCS. - IERR = -8 - CALL XERMSG ('SLATEC', 'DPCHIC', 'ERROR RETURN FROM DPCHCS', - + IERR, 1) - RETURN -C - 5009 CONTINUE -C ERROR RETURN FROM DPCHCE. -C *** THIS CASE SHOULD NEVER OCCUR *** - IERR = -9 - CALL XERMSG ('SLATEC', 'DPCHIC', 'ERROR RETURN FROM DPCHCE', - + IERR, 1) - RETURN -C------------- LAST LINE OF DPCHIC FOLLOWS ----------------------------- - END diff --git a/slatec/dpchid.f b/slatec/dpchid.f deleted file mode 100644 index 47e231c..0000000 --- a/slatec/dpchid.f +++ /dev/null @@ -1,195 +0,0 @@ -*DECK DPCHID - DOUBLE PRECISION FUNCTION DPCHID (N, X, F, D, INCFD, SKIP, IA, IB, - + IERR) -C***BEGIN PROLOGUE DPCHID -C***PURPOSE Evaluate the definite integral of a piecewise cubic -C Hermite function over an interval whose endpoints are data -C points. -C***LIBRARY SLATEC (PCHIP) -C***CATEGORY E3, H2A1B2 -C***TYPE DOUBLE PRECISION (PCHID-S, DPCHID-D) -C***KEYWORDS CUBIC HERMITE INTERPOLATION, NUMERICAL INTEGRATION, PCHIP, -C QUADRATURE -C***AUTHOR Fritsch, F. N., (LLNL) -C Lawrence Livermore National Laboratory -C P.O. Box 808 (L-316) -C Livermore, CA 94550 -C FTS 532-4275, (510) 422-4275 -C***DESCRIPTION -C -C DPCHID: Piecewise Cubic Hermite Integrator, Data limits -C -C Evaluates the definite integral of the cubic Hermite function -C defined by N, X, F, D over the interval [X(IA), X(IB)]. -C -C To provide compatibility with DPCHIM and DPCHIC, includes an -C increment between successive values of the F- and D-arrays. -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C PARAMETER (INCFD = ...) -C INTEGER N, IA, IB, IERR -C DOUBLE PRECISION X(N), F(INCFD,N), D(INCFD,N) -C LOGICAL SKIP -C -C VALUE = DPCHID (N, X, F, D, INCFD, SKIP, IA, IB, IERR) -C -C Parameters: -C -C VALUE -- (output) value of the requested integral. -C -C N -- (input) number of data points. (Error return if N.LT.2 .) -C -C X -- (input) real*8 array of independent variable values. The -C elements of X must be strictly increasing: -C X(I-1) .LT. X(I), I = 2(1)N. -C (Error return if not.) -C -C F -- (input) real*8 array of function values. F(1+(I-1)*INCFD) is -C the value corresponding to X(I). -C -C D -- (input) real*8 array of derivative values. D(1+(I-1)*INCFD) -C is the value corresponding to X(I). -C -C INCFD -- (input) increment between successive values in F and D. -C (Error return if INCFD.LT.1 .) -C -C SKIP -- (input/output) logical variable which should be set to -C .TRUE. if the user wishes to skip checks for validity of -C preceding parameters, or to .FALSE. otherwise. -C This will save time in case these checks have already -C been performed (say, in DPCHIM or DPCHIC). -C SKIP will be set to .TRUE. on return with IERR = 0 or -4. -C -C IA,IB -- (input) indices in X-array for the limits of integration. -C both must be in the range [1,N]. (Error return if not.) -C No restrictions on their relative values. -C -C IERR -- (output) error flag. -C Normal return: -C IERR = 0 (no errors). -C "Recoverable" errors: -C IERR = -1 if N.LT.2 . -C IERR = -2 if INCFD.LT.1 . -C IERR = -3 if the X-array is not strictly increasing. -C IERR = -4 if IA or IB is out of range. -C (VALUE will be zero in any of these cases.) -C NOTE: The above errors are checked in the order listed, -C and following arguments have **NOT** been validated. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 820723 DATE WRITTEN -C 820804 Converted to SLATEC library version. -C 870707 Corrected XERROR calls for d.p. name(s). -C 870813 Minor cosmetic changes. -C 890206 Corrected XERROR calls. -C 890411 Added SAVE statements (Vers. 3.2). -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890703 Corrected category record. (WRB) -C 890831 Modified array declarations. (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 930504 Corrected to set VALUE=0 when IERR.ne.0. (FNF) -C***END PROLOGUE DPCHID -C -C Programming notes: -C 1. This routine uses a special formula that is valid only for -C integrals whose limits coincide with data values. This is -C mathematically equivalent to, but much more efficient than, -C calls to DCHFIE. -C**End -C -C DECLARE ARGUMENTS. -C - INTEGER N, INCFD, IA, IB, IERR - DOUBLE PRECISION X(*), F(INCFD,*), D(INCFD,*) - LOGICAL SKIP -C -C DECLARE LOCAL VARIABLES. -C - INTEGER I, IUP, LOW - DOUBLE PRECISION H, HALF, SIX, SUM, VALUE, ZERO - SAVE ZERO, HALF, SIX -C -C INITIALIZE. -C - DATA ZERO /0.D0/, HALF/.5D0/, SIX/6.D0/ -C***FIRST EXECUTABLE STATEMENT DPCHID - VALUE = ZERO -C -C VALIDITY-CHECK ARGUMENTS. -C - IF (SKIP) GO TO 5 -C - IF ( N.LT.2 ) GO TO 5001 - IF ( INCFD.LT.1 ) GO TO 5002 - DO 1 I = 2, N - IF ( X(I).LE.X(I-1) ) GO TO 5003 - 1 CONTINUE -C -C FUNCTION DEFINITION IS OK, GO ON. -C - 5 CONTINUE - SKIP = .TRUE. - IF ((IA.LT.1) .OR. (IA.GT.N)) GO TO 5004 - IF ((IB.LT.1) .OR. (IB.GT.N)) GO TO 5004 - IERR = 0 -C -C COMPUTE INTEGRAL VALUE. -C - IF (IA .NE. IB) THEN - LOW = MIN(IA, IB) - IUP = MAX(IA, IB) - 1 - SUM = ZERO - DO 10 I = LOW, IUP - H = X(I+1) - X(I) - SUM = SUM + H*( (F(1,I) + F(1,I+1)) + - * (D(1,I) - D(1,I+1))*(H/SIX) ) - 10 CONTINUE - VALUE = HALF * SUM - IF (IA .GT. IB) VALUE = -VALUE - ENDIF -C -C NORMAL RETURN. -C - 5000 CONTINUE - DPCHID = VALUE - RETURN -C -C ERROR RETURNS. -C - 5001 CONTINUE -C N.LT.2 RETURN. - IERR = -1 - CALL XERMSG ('SLATEC', 'DPCHID', - + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) - GO TO 5000 -C - 5002 CONTINUE -C INCFD.LT.1 RETURN. - IERR = -2 - CALL XERMSG ('SLATEC', 'DPCHID', 'INCREMENT LESS THAN ONE', IERR, - + 1) - GO TO 5000 -C - 5003 CONTINUE -C X-ARRAY NOT STRICTLY INCREASING. - IERR = -3 - CALL XERMSG ('SLATEC', 'DPCHID', - + 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) - GO TO 5000 -C - 5004 CONTINUE -C IA OR IB OUT OF RANGE RETURN. - IERR = -4 - CALL XERMSG ('SLATEC', 'DPCHID', 'IA OR IB OUT OF RANGE', IERR, - + 1) - GO TO 5000 -C------------- LAST LINE OF DPCHID FOLLOWS ----------------------------- - END diff --git a/slatec/dpchim.f b/slatec/dpchim.f deleted file mode 100644 index a391b21..0000000 --- a/slatec/dpchim.f +++ /dev/null @@ -1,283 +0,0 @@ -*DECK DPCHIM - SUBROUTINE DPCHIM (N, X, F, D, INCFD, IERR) -C***BEGIN PROLOGUE DPCHIM -C***PURPOSE Set derivatives needed to determine a monotone piecewise -C cubic Hermite interpolant to given data. Boundary values -C are provided which are compatible with monotonicity. The -C interpolant will have an extremum at each point where mono- -C tonicity switches direction. (See DPCHIC if user control -C is desired over boundary or switch conditions.) -C***LIBRARY SLATEC (PCHIP) -C***CATEGORY E1A -C***TYPE DOUBLE PRECISION (PCHIM-S, DPCHIM-D) -C***KEYWORDS CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION, -C PCHIP, PIECEWISE CUBIC INTERPOLATION -C***AUTHOR Fritsch, F. N., (LLNL) -C Lawrence Livermore National Laboratory -C P.O. Box 808 (L-316) -C Livermore, CA 94550 -C FTS 532-4275, (510) 422-4275 -C***DESCRIPTION -C -C DPCHIM: Piecewise Cubic Hermite Interpolation to -C Monotone data. -C -C Sets derivatives needed to determine a monotone piecewise cubic -C Hermite interpolant to the data given in X and F. -C -C Default boundary conditions are provided which are compatible -C with monotonicity. (See DPCHIC if user control of boundary con- -C ditions is desired.) -C -C If the data are only piecewise monotonic, the interpolant will -C have an extremum at each point where monotonicity switches direc- -C tion. (See DPCHIC if user control is desired in such cases.) -C -C To facilitate two-dimensional applications, includes an increment -C between successive values of the F- and D-arrays. -C -C The resulting piecewise cubic Hermite function may be evaluated -C by DPCHFE or DPCHFD. -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C PARAMETER (INCFD = ...) -C INTEGER N, IERR -C DOUBLE PRECISION X(N), F(INCFD,N), D(INCFD,N) -C -C CALL DPCHIM (N, X, F, D, INCFD, IERR) -C -C Parameters: -C -C N -- (input) number of data points. (Error return if N.LT.2 .) -C If N=2, simply does linear interpolation. -C -C X -- (input) real*8 array of independent variable values. The -C elements of X must be strictly increasing: -C X(I-1) .LT. X(I), I = 2(1)N. -C (Error return if not.) -C -C F -- (input) real*8 array of dependent variable values to be -C interpolated. F(1+(I-1)*INCFD) is value corresponding to -C X(I). DPCHIM is designed for monotonic data, but it will -C work for any F-array. It will force extrema at points where -C monotonicity switches direction. If some other treatment of -C switch points is desired, DPCHIC should be used instead. -C ----- -C D -- (output) real*8 array of derivative values at the data -C points. If the data are monotonic, these values will -C determine a monotone cubic Hermite function. -C The value corresponding to X(I) is stored in -C D(1+(I-1)*INCFD), I=1(1)N. -C No other entries in D are changed. -C -C INCFD -- (input) increment between successive values in F and D. -C This argument is provided primarily for 2-D applications. -C (Error return if INCFD.LT.1 .) -C -C IERR -- (output) error flag. -C Normal return: -C IERR = 0 (no errors). -C Warning error: -C IERR.GT.0 means that IERR switches in the direction -C of monotonicity were detected. -C "Recoverable" errors: -C IERR = -1 if N.LT.2 . -C IERR = -2 if INCFD.LT.1 . -C IERR = -3 if the X-array is not strictly increasing. -C (The D-array has not been changed in any of these cases.) -C NOTE: The above errors are checked in the order listed, -C and following arguments have **NOT** been validated. -C -C***REFERENCES 1. F. N. Fritsch and J. Butland, A method for construc- -C ting local monotone piecewise cubic interpolants, SIAM -C Journal on Scientific and Statistical Computing 5, 2 -C (June 1984), pp. 300-304. -C 2. F. N. Fritsch and R. E. Carlson, Monotone piecewise -C cubic interpolation, SIAM Journal on Numerical Ana- -C lysis 17, 2 (April 1980), pp. 238-246. -C***ROUTINES CALLED DPCHST, XERMSG -C***REVISION HISTORY (YYMMDD) -C 811103 DATE WRITTEN -C 820201 1. Introduced DPCHST to reduce possible over/under- -C flow problems. -C 2. Rearranged derivative formula for same reason. -C 820602 1. Modified end conditions to be continuous functions -C of data when monotonicity switches in next interval. -C 2. Modified formulas so end conditions are less prone -C of over/underflow problems. -C 820803 Minor cosmetic changes for release 1. -C 870707 Corrected XERROR calls for d.p. name(s). -C 870813 Updated Reference 1. -C 890206 Corrected XERROR calls. -C 890411 Added SAVE statements (Vers. 3.2). -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890703 Corrected category record. (WRB) -C 890831 Modified array declarations. (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 920429 Revised format and order of references. (WRB,FNF) -C***END PROLOGUE DPCHIM -C Programming notes: -C -C 1. The function DPCHST(ARG1,ARG2) is assumed to return zero if -C either argument is zero, +1 if they are of the same sign, and -C -1 if they are of opposite sign. -C 2. To produce a single precision version, simply: -C a. Change DPCHIM to PCHIM wherever it occurs, -C b. Change DPCHST to PCHST wherever it occurs, -C c. Change all references to the Fortran intrinsics to their -C single precision equivalents, -C d. Change the double precision declarations to real, and -C e. Change the constants ZERO and THREE to single precision. -C -C DECLARE ARGUMENTS. -C - INTEGER N, INCFD, IERR - DOUBLE PRECISION X(*), F(INCFD,*), D(INCFD,*) -C -C DECLARE LOCAL VARIABLES. -C - INTEGER I, NLESS1 - DOUBLE PRECISION DEL1, DEL2, DMAX, DMIN, DRAT1, DRAT2, DSAVE, - * H1, H2, HSUM, HSUMT3, THREE, W1, W2, ZERO - SAVE ZERO, THREE - DOUBLE PRECISION DPCHST - DATA ZERO /0.D0/, THREE/3.D0/ -C -C VALIDITY-CHECK ARGUMENTS. -C -C***FIRST EXECUTABLE STATEMENT DPCHIM - IF ( N.LT.2 ) GO TO 5001 - IF ( INCFD.LT.1 ) GO TO 5002 - DO 1 I = 2, N - IF ( X(I).LE.X(I-1) ) GO TO 5003 - 1 CONTINUE -C -C FUNCTION DEFINITION IS OK, GO ON. -C - IERR = 0 - NLESS1 = N - 1 - H1 = X(2) - X(1) - DEL1 = (F(1,2) - F(1,1))/H1 - DSAVE = DEL1 -C -C SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION. -C - IF (NLESS1 .GT. 1) GO TO 10 - D(1,1) = DEL1 - D(1,N) = DEL1 - GO TO 5000 -C -C NORMAL CASE (N .GE. 3). -C - 10 CONTINUE - H2 = X(3) - X(2) - DEL2 = (F(1,3) - F(1,2))/H2 -C -C SET D(1) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE -C SHAPE-PRESERVING. -C - HSUM = H1 + H2 - W1 = (H1 + HSUM)/HSUM - W2 = -H1/HSUM - D(1,1) = W1*DEL1 + W2*DEL2 - IF ( DPCHST(D(1,1),DEL1) .LE. ZERO) THEN - D(1,1) = ZERO - ELSE IF ( DPCHST(DEL1,DEL2) .LT. ZERO) THEN -C NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. - DMAX = THREE*DEL1 - IF (ABS(D(1,1)) .GT. ABS(DMAX)) D(1,1) = DMAX - ENDIF -C -C LOOP THROUGH INTERIOR POINTS. -C - DO 50 I = 2, NLESS1 - IF (I .EQ. 2) GO TO 40 -C - H1 = H2 - H2 = X(I+1) - X(I) - HSUM = H1 + H2 - DEL1 = DEL2 - DEL2 = (F(1,I+1) - F(1,I))/H2 - 40 CONTINUE -C -C SET D(I)=0 UNLESS DATA ARE STRICTLY MONOTONIC. -C - D(1,I) = ZERO - IF ( DPCHST(DEL1,DEL2) ) 42, 41, 45 -C -C COUNT NUMBER OF CHANGES IN DIRECTION OF MONOTONICITY. -C - 41 CONTINUE - IF (DEL2 .EQ. ZERO) GO TO 50 - IF ( DPCHST(DSAVE,DEL2) .LT. ZERO) IERR = IERR + 1 - DSAVE = DEL2 - GO TO 50 -C - 42 CONTINUE - IERR = IERR + 1 - DSAVE = DEL2 - GO TO 50 -C -C USE BRODLIE MODIFICATION OF BUTLAND FORMULA. -C - 45 CONTINUE - HSUMT3 = HSUM+HSUM+HSUM - W1 = (HSUM + H1)/HSUMT3 - W2 = (HSUM + H2)/HSUMT3 - DMAX = MAX( ABS(DEL1), ABS(DEL2) ) - DMIN = MIN( ABS(DEL1), ABS(DEL2) ) - DRAT1 = DEL1/DMAX - DRAT2 = DEL2/DMAX - D(1,I) = DMIN/(W1*DRAT1 + W2*DRAT2) -C - 50 CONTINUE -C -C SET D(N) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE -C SHAPE-PRESERVING. -C - W1 = -H2/HSUM - W2 = (H2 + HSUM)/HSUM - D(1,N) = W1*DEL1 + W2*DEL2 - IF ( DPCHST(D(1,N),DEL2) .LE. ZERO) THEN - D(1,N) = ZERO - ELSE IF ( DPCHST(DEL1,DEL2) .LT. ZERO) THEN -C NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. - DMAX = THREE*DEL2 - IF (ABS(D(1,N)) .GT. ABS(DMAX)) D(1,N) = DMAX - ENDIF -C -C NORMAL RETURN. -C - 5000 CONTINUE - RETURN -C -C ERROR RETURNS. -C - 5001 CONTINUE -C N.LT.2 RETURN. - IERR = -1 - CALL XERMSG ('SLATEC', 'DPCHIM', - + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) - RETURN -C - 5002 CONTINUE -C INCFD.LT.1 RETURN. - IERR = -2 - CALL XERMSG ('SLATEC', 'DPCHIM', 'INCREMENT LESS THAN ONE', IERR, - + 1) - RETURN -C - 5003 CONTINUE -C X-ARRAY NOT STRICTLY INCREASING. - IERR = -3 - CALL XERMSG ('SLATEC', 'DPCHIM', - + 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) - RETURN -C------------- LAST LINE OF DPCHIM FOLLOWS ----------------------------- - END diff --git a/slatec/dpchkt.f b/slatec/dpchkt.f deleted file mode 100644 index 634609b..0000000 --- a/slatec/dpchkt.f +++ /dev/null @@ -1,96 +0,0 @@ -*DECK DPCHKT - SUBROUTINE DPCHKT (N, X, KNOTYP, T) -C***BEGIN PROLOGUE DPCHKT -C***SUBSIDIARY -C***PURPOSE Compute B-spline knot sequence for DPCHBS. -C***LIBRARY SLATEC (PCHIP) -C***CATEGORY E3 -C***TYPE DOUBLE PRECISION (PCHKT-S, DPCHKT-D) -C***AUTHOR Fritsch, F. N., (LLNL) -C***DESCRIPTION -C -C Set a knot sequence for the B-spline representation of a PCH -C function with breakpoints X. All knots will be at least double. -C Endknots are set as: -C (1) quadruple knots at endpoints if KNOTYP=0; -C (2) extrapolate the length of end interval if KNOTYP=1; -C (3) periodic if KNOTYP=2. -C -C Input arguments: N, X, KNOTYP. -C Output arguments: T. -C -C Restrictions/assumptions: -C 1. N.GE.2 . (not checked) -C 2. X(i).LT.X(i+1), i=1,...,N . (not checked) -C 3. 0.LE.KNOTYP.LE.2 . (Acts like KNOTYP=0 for any other value.) -C -C***SEE ALSO DPCHBS -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 870701 DATE WRITTEN -C 900405 Converted Fortran to upper case. -C 900410 Converted prologue to SLATEC 4.0 format. -C 900410 Minor cosmetic changes. -C 900430 Produced double precision version. -C 930514 Changed NKNOTS from an output to an input variable. (FNF) -C 930604 Removed unused variable NKNOTS from argument list. (FNF) -C***END PROLOGUE DPCHKT -C -C*Internal Notes: -C -C Since this is subsidiary to DPCHBS, which validates its input before -C calling, it is unnecessary for such validation to be done here. -C -C**End -C -C Declare arguments. -C - INTEGER N, KNOTYP - DOUBLE PRECISION X(*), T(*) -C -C Declare local variables. -C - INTEGER J, K, NDIM - DOUBLE PRECISION HBEG, HEND -C***FIRST EXECUTABLE STATEMENT DPCHKT -C -C Initialize. -C - NDIM = 2*N -C -C Set interior knots. -C - J = 1 - DO 20 K = 1, N - J = J + 2 - T(J) = X(K) - T(J+1) = T(J) - 20 CONTINUE -C Assertion: At this point T(3),...,T(NDIM+2) have been set and -C J=NDIM+1. -C -C Set end knots according to KNOTYP. -C - HBEG = X(2) - X(1) - HEND = X(N) - X(N-1) - IF (KNOTYP.EQ.1 ) THEN -C Extrapolate. - T(2) = X(1) - HBEG - T(NDIM+3) = X(N) + HEND - ELSE IF ( KNOTYP.EQ.2 ) THEN -C Periodic. - T(2) = X(1) - HEND - T(NDIM+3) = X(N) + HBEG - ELSE -C Quadruple end knots. - T(2) = X(1) - T(NDIM+3) = X(N) - ENDIF - T(1) = T(2) - T(NDIM+4) = T(NDIM+3) -C -C Terminate. -C - RETURN -C------------- LAST LINE OF DPCHKT FOLLOWS ----------------------------- - END diff --git a/slatec/dpchng.f b/slatec/dpchng.f deleted file mode 100644 index 493afa3..0000000 --- a/slatec/dpchng.f +++ /dev/null @@ -1,257 +0,0 @@ -*DECK DPCHNG - SUBROUTINE DPCHNG (II, XVAL, IPLACE, SX, IX, IRCX) -C***BEGIN PROLOGUE DPCHNG -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSPLP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (PCHNGS-S, DPCHNG-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C -C SUBROUTINE DPCHNG CHANGES ELEMENT II IN VECTOR +/- IRCX TO THE -C VALUE XVAL. -C DPCHNG LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SCHEME. -C SPARSE MATRIX ELEMENT ALTERATION SUBROUTINE. -C -C II THE ABSOLUTE VALUE OF THIS INTEGER IS THE SUBSCRIPT FOR -C THE ELEMENT TO BE CHANGED. -C XVAL NEW VALUE OF THE MATRIX ELEMENT BEING CHANGED. -C IPLACE POINTER INFORMATION WHICH IS MAINTAINED BY THE PACKAGE. -C SX(*),IX(*) THE WORK ARRAYS WHICH ARE USED TO STORE THE SPARSE -C MATRIX. THESE ARRAYS ARE AUTOMATICALLY MAINTAINED BY THE -C PACKAGE FOR THE USER. -C IRCX POINTS TO THE VECTOR OF THE MATRIX BEING UPDATED. -C A NEGATIVE VALUE OF IRCX INDICATES THAT ROW -IRCX IS -C BEING UPDATED. A POSITIVE VALUE OF IRCX INDICATES THAT -C COLUMN IRCX IS BEING UPDATED. A ZERO VALUE OF IRCX IS -C AN ERROR. -C -C SINCE DATA ITEMS ARE KEPT SORTED IN THE SEQUENTIAL DATA STRUCTURE, -C CHANGING A MATRIX ELEMENT CAN REQUIRE THE MOVEMENT OF ALL THE DATA -C ITEMS IN THE MATRIX. FOR THIS REASON, IT IS SUGGESTED THAT DATA -C ITEMS BE ADDED A COL. AT A TIME, IN ASCENDING COL. SEQUENCE. -C FURTHERMORE, SINCE DELETING ITEMS FROM THE DATA STRUCTURE MAY ALSO -C REQUIRE MOVING LARGE AMOUNTS OF DATA, ZERO ELEMENTS ARE EXPLICITLY -C STORED IN THE MATRIX. -C -C THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LCHNGS, -C SANDIA LABS. REPT. SAND78-0785. -C MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON -C REVISED 811130-1000 -C REVISED YYMMDD-HHMM -C -C***SEE ALSO DSPLP -C***ROUTINES CALLED DPRWPG, IDLOC, XERMSG -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890606 Changed references from IPLOC to IDLOC. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 910403 Updated AUTHOR and DESCRIPTION sections. (WRB) -C***END PROLOGUE DPCHNG - DIMENSION IX(*) - INTEGER IDLOC - DOUBLE PRECISION SX(*),XVAL,ZERO,ONE,SXLAST,SXVAL - SAVE ZERO, ONE - DATA ZERO,ONE /0.D0,1.D0/ -C***FIRST EXECUTABLE STATEMENT DPCHNG - IOPT=1 -C -C DETERMINE NULL-CASES.. - IF(II.EQ.0) RETURN -C -C CHECK VALIDITY OF ROW/COL. INDEX. -C - IF (.NOT.(IRCX.EQ.0)) GO TO 20002 - NERR=55 - CALL XERMSG ('SLATEC', 'DPCHNG', 'IRCX=0', NERR, IOPT) -20002 LMX = IX(1) -C -C LMX IS THE LENGTH OF THE IN-MEMORY STORAGE AREA. -C - IF (.NOT.(IRCX.LT.0)) GO TO 20005 -C -C CHECK SUBSCRIPTS OF THE ROW. THE ROW NUMBER MUST BE .LE. M AND -C THE INDEX MUST BE .LE. N. -C - IF (.NOT.(IX(2).LT.-IRCX .OR. IX(3).LT.ABS(II))) GO TO 20008 - NERR=55 - CALL XERMSG ('SLATEC', 'DPCHNG', - + 'SUBSCRIPTS FOR ARRAY ELEMENT TO BE ACCESSED WERE OUT OF ' // - + 'BOUNDS', NERR, IOPT) -20008 GO TO 20006 -C -C CHECK SUBSCRIPTS OF THE COLUMN. THE COL. NUMBER MUST BE .LE. N AND -C THE INDEX MUST BE .LE. M. -C -20005 IF (.NOT.(IX(3).LT.IRCX .OR. IX(2).LT.ABS(II))) GO TO 20011 - NERR=55 - CALL XERMSG ('SLATEC', 'DPCHNG', - + 'SUBSCRIPTS FOR ARRAY ELEMENT TO BE ACCESSED WERE OUT OF ' // - + 'BOUNDS', NERR, IOPT) -20011 CONTINUE -C -C SET I TO BE THE ELEMENT OF ROW/COLUMN J TO BE CHANGED. -C -20006 IF (.NOT.(IRCX.GT.0)) GO TO 20014 - I = ABS(II) - J = ABS(IRCX) - GO TO 20015 -20014 I = ABS(IRCX) - J = ABS(II) -C -C THE INTEGER LL POINTS TO THE START OF THE MATRIX ELEMENT DATA. -C -20015 LL=IX(3)+4 - II = ABS(II) - LPG = LMX - LL -C -C SET IPLACE TO START OUR SCAN FOR THE ELEMENT AT THE BEGINNING -C OF THE VECTOR. -C - IF (.NOT.(J.EQ.1)) GO TO 20017 - IPLACE=LL+1 - GO TO 20018 -20017 IPLACE=IX(J+3)+1 -C -C IEND POINTS TO THE LAST ELEMENT OF THE VECTOR TO BE SCANNED. -C -20018 IEND = IX(J+4) -C -C SCAN THROUGH SEVERAL PAGES, IF NECESSARY, TO FIND MATRIX ELEMENT. -C - IPL = IDLOC(IPLACE,SX,IX) - NP = ABS(IX(LMX-1)) - GO TO 20021 -20020 IF (ILAST.EQ.IEND) GO TO 20022 -C -C THE VIRTUAL END OF DATA FOR THIS PAGE IS ILAST. -C -20021 ILAST = MIN(IEND,NP*LPG+LL-2) -C -C THE RELATIVE END OF DATA FOR THIS PAGE IS IL. -C SEARCH FOR A MATRIX VALUE WITH AN INDEX .GE. I ON THE PRESENT -C PAGE. -C - IL = IDLOC(ILAST,SX,IX) - IL = MIN(IL,LMX-2) -20023 IF (.NOT.(.NOT.(IPL.GE.IL .OR. IX(IPL).GE.I))) GO TO 20024 - IPL=IPL+1 - GO TO 20023 -C -C SET IPLACE AND STORE DATA ITEM IF FOUND. -C -20024 IF (.NOT.(IX(IPL).EQ.I .AND. IPL.LE.IL)) GO TO 20025 - SX(IPL) = XVAL - SX(LMX) = ONE - RETURN -C -C EXIT FROM LOOP IF ITEM WAS FOUND. -C -20025 IF(IX(IPL).GT.I .AND. IPL.LE.IL) ILAST = IEND - IF (.NOT.(ILAST.NE.IEND)) GO TO 20028 - IPL = LL + 1 - NP = NP + 1 -20028 GO TO 20020 -C -C INSERT NEW DATA ITEM INTO LOCATION AT IPLACE(IPL). -C -20022 IF (.NOT.(IPL.GT.IL.OR.(IPL.EQ.IL.AND.I.GT.IX(IPL)))) GO TO 20031 - IPL = IL + 1 - IF(IPL.EQ.LMX-1) IPL = IPL + 2 -20031 IPLACE = (NP-1)*LPG + IPL -C -C GO TO A NEW PAGE, IF NECESSARY, TO INSERT THE ITEM. -C - IF (.NOT.(IPL.LE.LMX .OR. IX(LMX-1).GE.0)) GO TO 20034 - IPL=IDLOC(IPLACE,SX,IX) -20034 IEND = IX(LL) - NP = ABS(IX(LMX-1)) - SXVAL = XVAL -C -C LOOP THROUGH ALL SUBSEQUENT PAGES OF THE MATRIX MOVING DATA DOWN. -C THIS IS NECESSARY TO MAKE ROOM FOR THE NEW MATRIX ELEMENT AND -C KEEP THE ENTRIES SORTED. -C - GO TO 20038 -20037 IF (IX(LMX-1).LE.0) GO TO 20039 -20038 ILAST = MIN(IEND,NP*LPG+LL-2) - IL = IDLOC(ILAST,SX,IX) - IL = MIN(IL,LMX-2) - SXLAST = SX(IL) - IXLAST = IX(IL) - ISTART = IPL + 1 - IF (.NOT.(ISTART.LE.IL)) GO TO 20040 - K = ISTART + IL - DO 50 JJ=ISTART,IL - SX(K-JJ) = SX(K-JJ-1) - IX(K-JJ) = IX(K-JJ-1) -50 CONTINUE - SX(LMX) = ONE -20040 IF (.NOT.(IPL.LE.LMX)) GO TO 20043 - SX(IPL) = SXVAL - IX(IPL) = I - SXVAL = SXLAST - I = IXLAST - SX(LMX) = ONE - IF (.NOT.(IX(LMX-1).GT.0)) GO TO 20046 - IPL = LL + 1 - NP = NP + 1 -20046 CONTINUE -20043 GO TO 20037 -20039 NP = ABS(IX(LMX-1)) -C -C DETERMINE IF A NEW PAGE IS TO BE CREATED FOR THE LAST ELEMENT -C MOVED DOWN. -C - IL = IL + 1 - IF (.NOT.(IL.EQ.LMX-1)) GO TO 20049 -C -C CREATE A NEW PAGE. -C - IX(LMX-1) = NP -C -C WRITE THE OLD PAGE. -C - SX(LMX) = ZERO - KEY = 2 - CALL DPRWPG(KEY,NP,LPG,SX,IX) - SX(LMX) = ONE -C -C STORE LAST ELEMENT MOVED DOWN IN A NEW PAGE. -C - IPL = LL + 1 - NP = NP + 1 - IX(LMX-1) = -NP - SX(IPL) = SXVAL - IX(IPL) = I - GO TO 20050 -C -C LAST ELEMENT MOVED REMAINED ON THE OLD PAGE. -C -20049 IF (.NOT.(IPL.NE.IL)) GO TO 20052 - SX(IL) = SXVAL - IX(IL) = I - SX(LMX) = ONE -20052 CONTINUE -C -C INCREMENT POINTERS TO LAST ELEMENT IN VECTORS J,J+1,... . -C -20050 JSTART = J + 4 - JJ=JSTART - N20055=LL - GO TO 20056 -20055 JJ=JJ+1 -20056 IF ((N20055-JJ).LT.0) GO TO 20057 - IX(JJ) = IX(JJ) + 1 - IF(MOD(IX(JJ)-LL,LPG).EQ.LPG-1) IX(JJ) = IX(JJ) + 2 - GO TO 20055 -C -C IPLACE POINTS TO THE INSERTED DATA ITEM. -C -20057 IPL=IDLOC(IPLACE,SX,IX) - RETURN - END diff --git a/slatec/dpchsp.f b/slatec/dpchsp.f deleted file mode 100644 index 244d152..0000000 --- a/slatec/dpchsp.f +++ /dev/null @@ -1,392 +0,0 @@ -*DECK DPCHSP - SUBROUTINE DPCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR) -C***BEGIN PROLOGUE DPCHSP -C***PURPOSE Set derivatives needed to determine the Hermite represen- -C tation of the cubic spline interpolant to given data, with -C specified boundary conditions. -C***LIBRARY SLATEC (PCHIP) -C***CATEGORY E1A -C***TYPE DOUBLE PRECISION (PCHSP-S, DPCHSP-D) -C***KEYWORDS CUBIC HERMITE INTERPOLATION, PCHIP, -C PIECEWISE CUBIC INTERPOLATION, SPLINE INTERPOLATION -C***AUTHOR Fritsch, F. N., (LLNL) -C Lawrence Livermore National Laboratory -C P.O. Box 808 (L-316) -C Livermore, CA 94550 -C FTS 532-4275, (510) 422-4275 -C***DESCRIPTION -C -C DPCHSP: Piecewise Cubic Hermite Spline -C -C Computes the Hermite representation of the cubic spline inter- -C polant to the data given in X and F satisfying the boundary -C conditions specified by IC and VC. -C -C To facilitate two-dimensional applications, includes an increment -C between successive values of the F- and D-arrays. -C -C The resulting piecewise cubic Hermite function may be evaluated -C by DPCHFE or DPCHFD. -C -C NOTE: This is a modified version of C. de Boor's cubic spline -C routine CUBSPL. -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C PARAMETER (INCFD = ...) -C INTEGER IC(2), N, NWK, IERR -C DOUBLE PRECISION VC(2), X(N), F(INCFD,N), D(INCFD,N), WK(NWK) -C -C CALL DPCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR) -C -C Parameters: -C -C IC -- (input) integer array of length 2 specifying desired -C boundary conditions: -C IC(1) = IBEG, desired condition at beginning of data. -C IC(2) = IEND, desired condition at end of data. -C -C IBEG = 0 to set D(1) so that the third derivative is con- -C tinuous at X(2). This is the "not a knot" condition -C provided by de Boor's cubic spline routine CUBSPL. -C < This is the default boundary condition. > -C IBEG = 1 if first derivative at X(1) is given in VC(1). -C IBEG = 2 if second derivative at X(1) is given in VC(1). -C IBEG = 3 to use the 3-point difference formula for D(1). -C (Reverts to the default b.c. if N.LT.3 .) -C IBEG = 4 to use the 4-point difference formula for D(1). -C (Reverts to the default b.c. if N.LT.4 .) -C NOTES: -C 1. An error return is taken if IBEG is out of range. -C 2. For the "natural" boundary condition, use IBEG=2 and -C VC(1)=0. -C -C IEND may take on the same values as IBEG, but applied to -C derivative at X(N). In case IEND = 1 or 2, the value is -C given in VC(2). -C -C NOTES: -C 1. An error return is taken if IEND is out of range. -C 2. For the "natural" boundary condition, use IEND=2 and -C VC(2)=0. -C -C VC -- (input) real*8 array of length 2 specifying desired boundary -C values, as indicated above. -C VC(1) need be set only if IC(1) = 1 or 2 . -C VC(2) need be set only if IC(2) = 1 or 2 . -C -C N -- (input) number of data points. (Error return if N.LT.2 .) -C -C X -- (input) real*8 array of independent variable values. The -C elements of X must be strictly increasing: -C X(I-1) .LT. X(I), I = 2(1)N. -C (Error return if not.) -C -C F -- (input) real*8 array of dependent variable values to be -C interpolated. F(1+(I-1)*INCFD) is value corresponding to -C X(I). -C -C D -- (output) real*8 array of derivative values at the data -C points. These values will determine the cubic spline -C interpolant with the requested boundary conditions. -C The value corresponding to X(I) is stored in -C D(1+(I-1)*INCFD), I=1(1)N. -C No other entries in D are changed. -C -C INCFD -- (input) increment between successive values in F and D. -C This argument is provided primarily for 2-D applications. -C (Error return if INCFD.LT.1 .) -C -C WK -- (scratch) real*8 array of working storage. -C -C NWK -- (input) length of work array. -C (Error return if NWK.LT.2*N .) -C -C IERR -- (output) error flag. -C Normal return: -C IERR = 0 (no errors). -C "Recoverable" errors: -C IERR = -1 if N.LT.2 . -C IERR = -2 if INCFD.LT.1 . -C IERR = -3 if the X-array is not strictly increasing. -C IERR = -4 if IBEG.LT.0 or IBEG.GT.4 . -C IERR = -5 if IEND.LT.0 of IEND.GT.4 . -C IERR = -6 if both of the above are true. -C IERR = -7 if NWK is too small. -C NOTE: The above errors are checked in the order listed, -C and following arguments have **NOT** been validated. -C (The D-array has not been changed in any of these cases.) -C IERR = -8 in case of trouble solving the linear system -C for the interior derivative values. -C (The D-array may have been changed in this case.) -C ( Do **NOT** use it! ) -C -C***REFERENCES Carl de Boor, A Practical Guide to Splines, Springer- -C Verlag, New York, 1978, pp. 53-59. -C***ROUTINES CALLED DPCHDF, XERMSG -C***REVISION HISTORY (YYMMDD) -C 820503 DATE WRITTEN -C 820804 Converted to SLATEC library version. -C 870707 Corrected XERROR calls for d.p. name(s). -C 890206 Corrected XERROR calls. -C 890411 Added SAVE statements (Vers. 3.2). -C 890703 Corrected category record. (WRB) -C 890831 Modified array declarations. (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 920429 Revised format and order of references. (WRB,FNF) -C***END PROLOGUE DPCHSP -C Programming notes: -C -C To produce a single precision version, simply: -C a. Change DPCHSP to PCHSP wherever it occurs, -C b. Change the double precision declarations to real, and -C c. Change the constants ZERO, HALF, ... to single precision. -C -C DECLARE ARGUMENTS. -C - INTEGER IC(2), N, INCFD, NWK, IERR - DOUBLE PRECISION VC(2), X(*), F(INCFD,*), D(INCFD,*), WK(2,*) -C -C DECLARE LOCAL VARIABLES. -C - INTEGER IBEG, IEND, INDEX, J, NM1 - DOUBLE PRECISION G, HALF, ONE, STEMP(3), THREE, TWO, XTEMP(4), - * ZERO - SAVE ZERO, HALF, ONE, TWO, THREE - DOUBLE PRECISION DPCHDF -C - DATA ZERO /0.D0/, HALF/.5D0/, ONE/1.D0/, TWO/2.D0/, THREE/3.D0/ -C -C VALIDITY-CHECK ARGUMENTS. -C -C***FIRST EXECUTABLE STATEMENT DPCHSP - IF ( N.LT.2 ) GO TO 5001 - IF ( INCFD.LT.1 ) GO TO 5002 - DO 1 J = 2, N - IF ( X(J).LE.X(J-1) ) GO TO 5003 - 1 CONTINUE -C - IBEG = IC(1) - IEND = IC(2) - IERR = 0 - IF ( (IBEG.LT.0).OR.(IBEG.GT.4) ) IERR = IERR - 1 - IF ( (IEND.LT.0).OR.(IEND.GT.4) ) IERR = IERR - 2 - IF ( IERR.LT.0 ) GO TO 5004 -C -C FUNCTION DEFINITION IS OK -- GO ON. -C - IF ( NWK .LT. 2*N ) GO TO 5007 -C -C COMPUTE FIRST DIFFERENCES OF X SEQUENCE AND STORE IN WK(1,.). ALSO, -C COMPUTE FIRST DIVIDED DIFFERENCE OF DATA AND STORE IN WK(2,.). - DO 5 J=2,N - WK(1,J) = X(J) - X(J-1) - WK(2,J) = (F(1,J) - F(1,J-1))/WK(1,J) - 5 CONTINUE -C -C SET TO DEFAULT BOUNDARY CONDITIONS IF N IS TOO SMALL. -C - IF ( IBEG.GT.N ) IBEG = 0 - IF ( IEND.GT.N ) IEND = 0 -C -C SET UP FOR BOUNDARY CONDITIONS. -C - IF ( (IBEG.EQ.1).OR.(IBEG.EQ.2) ) THEN - D(1,1) = VC(1) - ELSE IF (IBEG .GT. 2) THEN -C PICK UP FIRST IBEG POINTS, IN REVERSE ORDER. - DO 10 J = 1, IBEG - INDEX = IBEG-J+1 -C INDEX RUNS FROM IBEG DOWN TO 1. - XTEMP(J) = X(INDEX) - IF (J .LT. IBEG) STEMP(J) = WK(2,INDEX) - 10 CONTINUE -C -------------------------------- - D(1,1) = DPCHDF (IBEG, XTEMP, STEMP, IERR) -C -------------------------------- - IF (IERR .NE. 0) GO TO 5009 - IBEG = 1 - ENDIF -C - IF ( (IEND.EQ.1).OR.(IEND.EQ.2) ) THEN - D(1,N) = VC(2) - ELSE IF (IEND .GT. 2) THEN -C PICK UP LAST IEND POINTS. - DO 15 J = 1, IEND - INDEX = N-IEND+J -C INDEX RUNS FROM N+1-IEND UP TO N. - XTEMP(J) = X(INDEX) - IF (J .LT. IEND) STEMP(J) = WK(2,INDEX+1) - 15 CONTINUE -C -------------------------------- - D(1,N) = DPCHDF (IEND, XTEMP, STEMP, IERR) -C -------------------------------- - IF (IERR .NE. 0) GO TO 5009 - IEND = 1 - ENDIF -C -C --------------------( BEGIN CODING FROM CUBSPL )-------------------- -C -C **** A TRIDIAGONAL LINEAR SYSTEM FOR THE UNKNOWN SLOPES S(J) OF -C F AT X(J), J=1,...,N, IS GENERATED AND THEN SOLVED BY GAUSS ELIM- -C INATION, WITH S(J) ENDING UP IN D(1,J), ALL J. -C WK(1,.) AND WK(2,.) ARE USED FOR TEMPORARY STORAGE. -C -C CONSTRUCT FIRST EQUATION FROM FIRST BOUNDARY CONDITION, OF THE FORM -C WK(2,1)*S(1) + WK(1,1)*S(2) = D(1,1) -C - IF (IBEG .EQ. 0) THEN - IF (N .EQ. 2) THEN -C NO CONDITION AT LEFT END AND N = 2. - WK(2,1) = ONE - WK(1,1) = ONE - D(1,1) = TWO*WK(2,2) - ELSE -C NOT-A-KNOT CONDITION AT LEFT END AND N .GT. 2. - WK(2,1) = WK(1,3) - WK(1,1) = WK(1,2) + WK(1,3) - D(1,1) =((WK(1,2) + TWO*WK(1,1))*WK(2,2)*WK(1,3) - * + WK(1,2)**2*WK(2,3)) / WK(1,1) - ENDIF - ELSE IF (IBEG .EQ. 1) THEN -C SLOPE PRESCRIBED AT LEFT END. - WK(2,1) = ONE - WK(1,1) = ZERO - ELSE -C SECOND DERIVATIVE PRESCRIBED AT LEFT END. - WK(2,1) = TWO - WK(1,1) = ONE - D(1,1) = THREE*WK(2,2) - HALF*WK(1,2)*D(1,1) - ENDIF -C -C IF THERE ARE INTERIOR KNOTS, GENERATE THE CORRESPONDING EQUATIONS AND -C CARRY OUT THE FORWARD PASS OF GAUSS ELIMINATION, AFTER WHICH THE J-TH -C EQUATION READS WK(2,J)*S(J) + WK(1,J)*S(J+1) = D(1,J). -C - NM1 = N-1 - IF (NM1 .GT. 1) THEN - DO 20 J=2,NM1 - IF (WK(2,J-1) .EQ. ZERO) GO TO 5008 - G = -WK(1,J+1)/WK(2,J-1) - D(1,J) = G*D(1,J-1) - * + THREE*(WK(1,J)*WK(2,J+1) + WK(1,J+1)*WK(2,J)) - WK(2,J) = G*WK(1,J-1) + TWO*(WK(1,J) + WK(1,J+1)) - 20 CONTINUE - ENDIF -C -C CONSTRUCT LAST EQUATION FROM SECOND BOUNDARY CONDITION, OF THE FORM -C (-G*WK(2,N-1))*S(N-1) + WK(2,N)*S(N) = D(1,N) -C -C IF SLOPE IS PRESCRIBED AT RIGHT END, ONE CAN GO DIRECTLY TO BACK- -C SUBSTITUTION, SINCE ARRAYS HAPPEN TO BE SET UP JUST RIGHT FOR IT -C AT THIS POINT. - IF (IEND .EQ. 1) GO TO 30 -C - IF (IEND .EQ. 0) THEN - IF (N.EQ.2 .AND. IBEG.EQ.0) THEN -C NOT-A-KNOT AT RIGHT ENDPOINT AND AT LEFT ENDPOINT AND N = 2. - D(1,2) = WK(2,2) - GO TO 30 - ELSE IF ((N.EQ.2) .OR. (N.EQ.3 .AND. IBEG.EQ.0)) THEN -C EITHER (N=3 AND NOT-A-KNOT ALSO AT LEFT) OR (N=2 AND *NOT* -C NOT-A-KNOT AT LEFT END POINT). - D(1,N) = TWO*WK(2,N) - WK(2,N) = ONE - IF (WK(2,N-1) .EQ. ZERO) GO TO 5008 - G = -ONE/WK(2,N-1) - ELSE -C NOT-A-KNOT AND N .GE. 3, AND EITHER N.GT.3 OR ALSO NOT-A- -C KNOT AT LEFT END POINT. - G = WK(1,N-1) + WK(1,N) -C DO NOT NEED TO CHECK FOLLOWING DENOMINATORS (X-DIFFERENCES). - D(1,N) = ((WK(1,N)+TWO*G)*WK(2,N)*WK(1,N-1) - * + WK(1,N)**2*(F(1,N-1)-F(1,N-2))/WK(1,N-1))/G - IF (WK(2,N-1) .EQ. ZERO) GO TO 5008 - G = -G/WK(2,N-1) - WK(2,N) = WK(1,N-1) - ENDIF - ELSE -C SECOND DERIVATIVE PRESCRIBED AT RIGHT ENDPOINT. - D(1,N) = THREE*WK(2,N) + HALF*WK(1,N)*D(1,N) - WK(2,N) = TWO - IF (WK(2,N-1) .EQ. ZERO) GO TO 5008 - G = -ONE/WK(2,N-1) - ENDIF -C -C COMPLETE FORWARD PASS OF GAUSS ELIMINATION. -C - WK(2,N) = G*WK(1,N-1) + WK(2,N) - IF (WK(2,N) .EQ. ZERO) GO TO 5008 - D(1,N) = (G*D(1,N-1) + D(1,N))/WK(2,N) -C -C CARRY OUT BACK SUBSTITUTION -C - 30 CONTINUE - DO 40 J=NM1,1,-1 - IF (WK(2,J) .EQ. ZERO) GO TO 5008 - D(1,J) = (D(1,J) - WK(1,J)*D(1,J+1))/WK(2,J) - 40 CONTINUE -C --------------------( END CODING FROM CUBSPL )-------------------- -C -C NORMAL RETURN. -C - RETURN -C -C ERROR RETURNS. -C - 5001 CONTINUE -C N.LT.2 RETURN. - IERR = -1 - CALL XERMSG ('SLATEC', 'DPCHSP', - + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) - RETURN -C - 5002 CONTINUE -C INCFD.LT.1 RETURN. - IERR = -2 - CALL XERMSG ('SLATEC', 'DPCHSP', 'INCREMENT LESS THAN ONE', IERR, - + 1) - RETURN -C - 5003 CONTINUE -C X-ARRAY NOT STRICTLY INCREASING. - IERR = -3 - CALL XERMSG ('SLATEC', 'DPCHSP', - + 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) - RETURN -C - 5004 CONTINUE -C IC OUT OF RANGE RETURN. - IERR = IERR - 3 - CALL XERMSG ('SLATEC', 'DPCHSP', 'IC OUT OF RANGE', IERR, 1) - RETURN -C - 5007 CONTINUE -C NWK TOO SMALL RETURN. - IERR = -7 - CALL XERMSG ('SLATEC', 'DPCHSP', 'WORK ARRAY TOO SMALL', IERR, 1) - RETURN -C - 5008 CONTINUE -C SINGULAR SYSTEM. -C *** THEORETICALLY, THIS CAN ONLY OCCUR IF SUCCESSIVE X-VALUES *** -C *** ARE EQUAL, WHICH SHOULD ALREADY HAVE BEEN CAUGHT (IERR=-3). *** - IERR = -8 - CALL XERMSG ('SLATEC', 'DPCHSP', 'SINGULAR LINEAR SYSTEM', IERR, - + 1) - RETURN -C - 5009 CONTINUE -C ERROR RETURN FROM DPCHDF. -C *** THIS CASE SHOULD NEVER OCCUR *** - IERR = -9 - CALL XERMSG ('SLATEC', 'DPCHSP', 'ERROR RETURN FROM DPCHDF', - + IERR, 1) - RETURN -C------------- LAST LINE OF DPCHSP FOLLOWS ----------------------------- - END diff --git a/slatec/dpchst.f b/slatec/dpchst.f deleted file mode 100644 index 9fc3894..0000000 --- a/slatec/dpchst.f +++ /dev/null @@ -1,59 +0,0 @@ -*DECK DPCHST - DOUBLE PRECISION FUNCTION DPCHST (ARG1, ARG2) -C***BEGIN PROLOGUE DPCHST -C***SUBSIDIARY -C***PURPOSE DPCHIP Sign-Testing Routine -C***LIBRARY SLATEC (PCHIP) -C***TYPE DOUBLE PRECISION (PCHST-S, DPCHST-D) -C***AUTHOR Fritsch, F. N., (LLNL) -C***DESCRIPTION -C -C DPCHST: DPCHIP Sign-Testing Routine. -C -C -C Returns: -C -1. if ARG1 and ARG2 are of opposite sign. -C 0. if either argument is zero. -C +1. if ARG1 and ARG2 are of the same sign. -C -C The object is to do this without multiplying ARG1*ARG2, to avoid -C possible over/underflow problems. -C -C Fortran intrinsics used: SIGN. -C -C***SEE ALSO DPCHCE, DPCHCI, DPCHCS, DPCHIM -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 811103 DATE WRITTEN -C 820805 Converted to SLATEC library version. -C 870813 Minor cosmetic changes. -C 890411 Added SAVE statements (Vers. 3.2). -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 900328 Added TYPE section. (WRB) -C 910408 Updated AUTHOR and DATE WRITTEN sections in prologue. (WRB) -C 930503 Improved purpose. (FNF) -C***END PROLOGUE DPCHST -C -C**End -C -C DECLARE ARGUMENTS. -C - DOUBLE PRECISION ARG1, ARG2 -C -C DECLARE LOCAL VARIABLES. -C - DOUBLE PRECISION ONE, ZERO - SAVE ZERO, ONE - DATA ZERO /0.D0/, ONE/1.D0/ -C -C PERFORM THE TEST. -C -C***FIRST EXECUTABLE STATEMENT DPCHST - DPCHST = SIGN(ONE,ARG1) * SIGN(ONE,ARG2) - IF ((ARG1.EQ.ZERO) .OR. (ARG2.EQ.ZERO)) DPCHST = ZERO -C - RETURN -C------------- LAST LINE OF DPCHST FOLLOWS ----------------------------- - END diff --git a/slatec/dpchsw.f b/slatec/dpchsw.f deleted file mode 100644 index 1960f93..0000000 --- a/slatec/dpchsw.f +++ /dev/null @@ -1,197 +0,0 @@ -*DECK DPCHSW - SUBROUTINE DPCHSW (DFMAX, IEXTRM, D1, D2, H, SLOPE, IERR) -C***BEGIN PROLOGUE DPCHSW -C***SUBSIDIARY -C***PURPOSE Limits excursion from data for DPCHCS -C***LIBRARY SLATEC (PCHIP) -C***TYPE DOUBLE PRECISION (PCHSW-S, DPCHSW-D) -C***AUTHOR Fritsch, F. N., (LLNL) -C***DESCRIPTION -C -C DPCHSW: DPCHCS Switch Excursion Limiter. -C -C Called by DPCHCS to adjust D1 and D2 if necessary to insure that -C the extremum on this interval is not further than DFMAX from the -C extreme data value. -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C INTEGER IEXTRM, IERR -C DOUBLE PRECISION DFMAX, D1, D2, H, SLOPE -C -C CALL DPCHSW (DFMAX, IEXTRM, D1, D2, H, SLOPE, IERR) -C -C Parameters: -C -C DFMAX -- (input) maximum allowed difference between F(IEXTRM) and -C the cubic determined by derivative values D1,D2. (assumes -C DFMAX.GT.0.) -C -C IEXTRM -- (input) index of the extreme data value. (assumes -C IEXTRM = 1 or 2 . Any value .NE.1 is treated as 2.) -C -C D1,D2 -- (input) derivative values at the ends of the interval. -C (Assumes D1*D2 .LE. 0.) -C (output) may be modified if necessary to meet the restriction -C imposed by DFMAX. -C -C H -- (input) interval length. (Assumes H.GT.0.) -C -C SLOPE -- (input) data slope on the interval. -C -C IERR -- (output) error flag. should be zero. -C If IERR=-1, assumption on D1 and D2 is not satisfied. -C If IERR=-2, quadratic equation locating extremum has -C negative discriminant (should never occur). -C -C ------- -C WARNING: This routine does no validity-checking of arguments. -C ------- -C -C Fortran intrinsics used: ABS, SIGN, SQRT. -C -C***SEE ALSO DPCHCS -C***ROUTINES CALLED D1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 820218 DATE WRITTEN -C 820805 Converted to SLATEC library version. -C 870707 Corrected XERROR calls for d.p. name(s). -C 870707 Replaced DATA statement for SMALL with a use of D1MACH. -C 870813 Minor cosmetic changes. -C 890206 Corrected XERROR calls. -C 890411 1. Added SAVE statements (Vers. 3.2). -C 2. Added DOUBLE PRECISION declaration for D1MACH. -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 900328 Added TYPE section. (WRB) -C 910408 Updated AUTHOR and DATE WRITTEN sections in prologue. (WRB) -C 920526 Eliminated possible divide by zero problem. (FNF) -C 930503 Improved purpose. (FNF) -C***END PROLOGUE DPCHSW -C -C**End -C -C DECLARE ARGUMENTS. -C - INTEGER IEXTRM, IERR - DOUBLE PRECISION DFMAX, D1, D2, H, SLOPE -C -C DECLARE LOCAL VARIABLES. -C - DOUBLE PRECISION CP, FACT, HPHI, LAMBDA, NU, ONE, PHI, RADCAL, - * RHO, SIGMA, SMALL, THAT, THIRD, THREE, TWO, ZERO - SAVE ZERO, ONE, TWO, THREE, FACT - SAVE THIRD - DOUBLE PRECISION D1MACH -C - DATA ZERO /0.D0/, ONE /1.D0/, TWO /2.D0/, THREE /3.D0/, - * FACT /100.D0/ -C THIRD SHOULD BE SLIGHTLY LESS THAN 1/3. - DATA THIRD /0.33333D0/ -C -C NOTATION AND GENERAL REMARKS. -C -C RHO IS THE RATIO OF THE DATA SLOPE TO THE DERIVATIVE BEING TESTED. -C LAMBDA IS THE RATIO OF D2 TO D1. -C THAT = T-HAT(RHO) IS THE NORMALIZED LOCATION OF THE EXTREMUM. -C PHI IS THE NORMALIZED VALUE OF P(X)-F1 AT X = XHAT = X-HAT(RHO), -C WHERE THAT = (XHAT - X1)/H . -C THAT IS, P(XHAT)-F1 = D*H*PHI, WHERE D=D1 OR D2. -C SIMILARLY, P(XHAT)-F2 = D*H*(PHI-RHO) . -C -C SMALL SHOULD BE A FEW ORDERS OF MAGNITUDE GREATER THAN MACHEPS. -C***FIRST EXECUTABLE STATEMENT DPCHSW - SMALL = FACT*D1MACH(4) -C -C DO MAIN CALCULATION. -C - IF (D1 .EQ. ZERO) THEN -C -C SPECIAL CASE -- D1.EQ.ZERO . -C -C IF D2 IS ALSO ZERO, THIS ROUTINE SHOULD NOT HAVE BEEN CALLED. - IF (D2 .EQ. ZERO) GO TO 5001 -C - RHO = SLOPE/D2 -C EXTREMUM IS OUTSIDE INTERVAL WHEN RHO .GE. 1/3 . - IF (RHO .GE. THIRD) GO TO 5000 - THAT = (TWO*(THREE*RHO-ONE)) / (THREE*(TWO*RHO-ONE)) - PHI = THAT**2 * ((THREE*RHO-ONE)/THREE) -C -C CONVERT TO DISTANCE FROM F2 IF IEXTRM.NE.1 . - IF (IEXTRM .NE. 1) PHI = PHI - RHO -C -C TEST FOR EXCEEDING LIMIT, AND ADJUST ACCORDINGLY. - HPHI = H * ABS(PHI) - IF (HPHI*ABS(D2) .GT. DFMAX) THEN -C AT THIS POINT, HPHI.GT.0, SO DIVIDE IS OK. - D2 = SIGN (DFMAX/HPHI, D2) - ENDIF - ELSE -C - RHO = SLOPE/D1 - LAMBDA = -D2/D1 - IF (D2 .EQ. ZERO) THEN -C -C SPECIAL CASE -- D2.EQ.ZERO . -C -C EXTREMUM IS OUTSIDE INTERVAL WHEN RHO .GE. 1/3 . - IF (RHO .GE. THIRD) GO TO 5000 - CP = TWO - THREE*RHO - NU = ONE - TWO*RHO - THAT = ONE / (THREE*NU) - ELSE - IF (LAMBDA .LE. ZERO) GO TO 5001 -C -C NORMAL CASE -- D1 AND D2 BOTH NONZERO, OPPOSITE SIGNS. -C - NU = ONE - LAMBDA - TWO*RHO - SIGMA = ONE - RHO - CP = NU + SIGMA - IF (ABS(NU) .GT. SMALL) THEN - RADCAL = (NU - (TWO*RHO+ONE))*NU + SIGMA**2 - IF (RADCAL .LT. ZERO) GO TO 5002 - THAT = (CP - SQRT(RADCAL)) / (THREE*NU) - ELSE - THAT = ONE/(TWO*SIGMA) - ENDIF - ENDIF - PHI = THAT*((NU*THAT - CP)*THAT + ONE) -C -C CONVERT TO DISTANCE FROM F2 IF IEXTRM.NE.1 . - IF (IEXTRM .NE. 1) PHI = PHI - RHO -C -C TEST FOR EXCEEDING LIMIT, AND ADJUST ACCORDINGLY. - HPHI = H * ABS(PHI) - IF (HPHI*ABS(D1) .GT. DFMAX) THEN -C AT THIS POINT, HPHI.GT.0, SO DIVIDE IS OK. - D1 = SIGN (DFMAX/HPHI, D1) - D2 = -LAMBDA*D1 - ENDIF - ENDIF -C -C NORMAL RETURN. -C - 5000 CONTINUE - IERR = 0 - RETURN -C -C ERROR RETURNS. -C - 5001 CONTINUE -C D1 AND D2 BOTH ZERO, OR BOTH NONZERO AND SAME SIGN. - IERR = -1 - CALL XERMSG ('SLATEC', 'DPCHSW', 'D1 AND/OR D2 INVALID', IERR, 1) - RETURN -C - 5002 CONTINUE -C NEGATIVE VALUE OF RADICAL (SHOULD NEVER OCCUR). - IERR = -2 - CALL XERMSG ('SLATEC', 'DPCHSW', 'NEGATIVE RADICAL', IERR, 1) - RETURN -C------------- LAST LINE OF DPCHSW FOLLOWS ----------------------------- - END diff --git a/slatec/dpcoef.f b/slatec/dpcoef.f deleted file mode 100644 index 074a342..0000000 --- a/slatec/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/slatec/dpfqad.f b/slatec/dpfqad.f deleted file mode 100644 index dcbc6db..0000000 --- a/slatec/dpfqad.f +++ /dev/null @@ -1,133 +0,0 @@ -*DECK DPFQAD - SUBROUTINE DPFQAD (F, LDC, C, XI, LXI, K, ID, X1, X2, TOL, QUAD, - + IERR) -C***BEGIN PROLOGUE DPFQAD -C***PURPOSE Compute the integral on (X1,X2) of a product of a -C function F and the ID-th derivative of a B-spline, -C (PP-representation). -C***LIBRARY SLATEC -C***CATEGORY H2A2A1, E3, K6 -C***TYPE DOUBLE PRECISION (PFQAD-S, DPFQAD-D) -C***KEYWORDS B-SPLINE, DATA FITTING, INTERPOLATION, QUADRATURE, SPLINES -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Abstract **** a double precision routine **** -C DPFQAD computes the integral on (X1,X2) of a product of a -C function F and the ID-th derivative of a B-spline, using the -C PP-representation (C,XI,LXI,K). (X1,X2) is normally a sub- -C interval of XI(1) .LE. X .LE. XI(LXI+1). An integration -C routine, DPPGQ8 (a modification of GAUS8), integrates the -C product on subintervals of (X1,X2) formed by the included -C break points. Integration outside of (XI(1),XI(LXI+1)) is -C permitted provided F is defined. -C -C The maximum number of significant digits obtainable in -C DBSQAD is the smaller of 18 and the number of digits -C carried in double precision arithmetic. -C -C Description of arguments -C Input F,C,XI,X1,X2,TOL are double precision -C F - external function of one argument for the -C integrand PF(X)=F(X)*DPPVAL(LDC,C,XI,LXI,K,ID,X, -C INPPV) -C LDC - leading dimension of matrix C, LDC .GE. K -C C(I,J) - right Taylor derivatives at XI(J), I=1,K , J=1,LXI -C XI(*) - break point array of length LXI+1 -C LXI - number of polynomial pieces -C K - order of B-spline, K .GE. 1 -C ID - order of the spline derivative, 0 .LE. ID .LE. K-1 -C ID=0 gives the spline function -C X1,X2 - end points of quadrature interval, normally in -C XI(1) .LE. X .LE. XI(LXI+1) -C TOL - desired accuracy for the quadrature, suggest -C 10.*DTOL .LT. TOL .LE. 0.1 where DTOL is the -C maximum of 1.0D-18 and double precision unit -C roundoff for the machine = D1MACH(4) -C -C Output QUAD is double precision -C QUAD - integral of PF(X) on (X1,X2) -C IERR - a status code -C IERR=1 normal return -C 2 some quadrature does not meet the -C requested tolerance -C -C Error Conditions -C Improper input is a fatal error. -C Some quadrature does not meet the requested tolerance. -C -C***REFERENCES D. E. Amos, Quadrature subroutines for splines and -C B-splines, Report SAND79-1825, Sandia Laboratories, -C December 1979. -C***ROUTINES CALLED D1MACH, DINTRV, DPPGQ8, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800901 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DPFQAD -C - INTEGER ID,IERR,IFLG,ILO,IL1,IL2,INPPV,K,LDC,LEFT,LXI,MF1,MF2 - DOUBLE PRECISION A,AA,ANS,B,BB,C,Q,QUAD,TA,TB,TOL,WTOL,XI,X1,X2 - DOUBLE PRECISION D1MACH, F - DIMENSION XI(*), C(LDC,*) - EXTERNAL F -C -C***FIRST EXECUTABLE STATEMENT DPFQAD - IERR = 1 - QUAD = 0.0D0 - IF(K.LT.1) GO TO 100 - IF(LDC.LT.K) GO TO 105 - IF(ID.LT.0 .OR. ID.GE.K) GO TO 110 - IF(LXI.LT.1) GO TO 115 - WTOL = D1MACH(4) - WTOL = MAX(WTOL,1.0D-18) - IF (TOL.LT.WTOL .OR. TOL.GT.0.1D0) GO TO 20 - AA = MIN(X1,X2) - BB = MAX(X1,X2) - IF (AA.EQ.BB) RETURN - ILO = 1 - CALL DINTRV(XI, LXI, AA, ILO, IL1, MF1) - CALL DINTRV(XI, LXI, BB, ILO, IL2, MF2) - Q = 0.0D0 - INPPV = 1 - DO 10 LEFT=IL1,IL2 - TA = XI(LEFT) - A = MAX(AA,TA) - IF (LEFT.EQ.1) A = AA - TB = BB - IF (LEFT.LT.LXI) TB = XI(LEFT+1) - B = MIN(BB,TB) - CALL DPPGQ8(F,LDC,C,XI,LXI,K,ID,A,B,INPPV,TOL,ANS,IFLG) - IF (IFLG.GT.1) IERR = 2 - Q = Q + ANS - 10 CONTINUE - IF (X1.GT.X2) Q = -Q - QUAD = Q - RETURN -C - 20 CONTINUE - CALL XERMSG ('SLATEC', 'DPFQAD', - + 'TOL IS LESS DTOL OR GREATER THAN 0.1', 2, 1) - RETURN - 100 CONTINUE - CALL XERMSG ('SLATEC', 'DPFQAD', 'K DOES NOT SATISFY K.GE.1', 2, - + 1) - RETURN - 105 CONTINUE - CALL XERMSG ('SLATEC', 'DPFQAD', 'LDC DOES NOT SATISFY LDC.GE.K', - + 2, 1) - RETURN - 110 CONTINUE - CALL XERMSG ('SLATEC', 'DPFQAD', - + 'ID DOES NOT SATISFY 0.LE.ID.LT.K', 2, 1) - RETURN - 115 CONTINUE - CALL XERMSG ('SLATEC', 'DPFQAD', 'LXI DOES NOT SATISFY LXI.GE.1', - + 2, 1) - RETURN - END diff --git a/slatec/dpigmr.f b/slatec/dpigmr.f deleted file mode 100644 index 957ab09..0000000 --- a/slatec/dpigmr.f +++ /dev/null @@ -1,439 +0,0 @@ -*DECK DPIGMR - SUBROUTINE DPIGMR (N, R0, SR, SZ, JSCAL, MAXL, MAXLP1, KMP, NRSTS, - + JPRE, MATVEC, MSOLVE, NMSL, Z, V, HES, Q, LGMR, RPAR, IPAR, WK, - + DL, RHOL, NRMAX, B, BNRM, X, XL, ITOL, TOL, NELT, IA, JA, A, - + ISYM, IUNIT, IFLAG, ERR) -C***BEGIN PROLOGUE DPIGMR -C***SUBSIDIARY -C***PURPOSE Internal routine for DGMRES. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (SPIGMR-S, DPIGMR-D) -C***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov -C Hindmarsh, Alan, (LLNL), alanh@llnl.gov -C Seager, Mark K., (LLNL), seager@llnl.gov -C Lawrence Livermore National Laboratory -C PO Box 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C***DESCRIPTION -C This routine solves the linear system A * Z = R0 using a -C scaled preconditioned version of the generalized minimum -C residual method. An initial guess of Z = 0 is assumed. -C -C *Usage: -C INTEGER N, JSCAL, MAXL, MAXLP1, KMP, NRSTS, JPRE, NMSL, LGMR -C INTEGER IPAR(USER DEFINED), NRMAX, ITOL, NELT, IA(NELT), JA(NELT) -C INTEGER ISYM, IUNIT, IFLAG -C DOUBLE PRECISION R0(N), SR(N), SZ(N), Z(N), V(N,MAXLP1), -C $ HES(MAXLP1,MAXL), Q(2*MAXL), RPAR(USER DEFINED), -C $ WK(N), DL(N), RHOL, B(N), BNRM, X(N), XL(N), -C $ TOL, A(NELT), ERR -C EXTERNAL MATVEC, MSOLVE -C -C CALL DPIGMR(N, R0, SR, SZ, JSCAL, MAXL, MAXLP1, KMP, -C $ NRSTS, JPRE, MATVEC, MSOLVE, NMSL, Z, V, HES, Q, LGMR, -C $ RPAR, IPAR, WK, DL, RHOL, NRMAX, B, BNRM, X, XL, -C $ ITOL, TOL, NELT, IA, JA, A, ISYM, IUNIT, IFLAG, ERR) -C -C *Arguments: -C N :IN Integer -C The order of the matrix A, and the lengths -C of the vectors SR, SZ, R0 and Z. -C R0 :IN Double Precision R0(N) -C R0 = the right hand side of the system A*Z = R0. -C R0 is also used as workspace when computing -C the final approximation. -C (R0 is the same as V(*,MAXL+1) in the call to DPIGMR.) -C SR :IN Double Precision SR(N) -C SR is a vector of length N containing the non-zero -C elements of the diagonal scaling matrix for R0. -C SZ :IN Double Precision SZ(N) -C SZ is a vector of length N containing the non-zero -C elements of the diagonal scaling matrix for Z. -C JSCAL :IN Integer -C A flag indicating whether arrays SR and SZ are used. -C JSCAL=0 means SR and SZ are not used and the -C algorithm will perform as if all -C SR(i) = 1 and SZ(i) = 1. -C JSCAL=1 means only SZ is used, and the algorithm -C performs as if all SR(i) = 1. -C JSCAL=2 means only SR is used, and the algorithm -C performs as if all SZ(i) = 1. -C JSCAL=3 means both SR and SZ are used. -C MAXL :IN Integer -C The maximum allowable order of the matrix H. -C MAXLP1 :IN Integer -C MAXPL1 = MAXL + 1, used for dynamic dimensioning of HES. -C KMP :IN Integer -C The number of previous vectors the new vector VNEW -C must be made orthogonal to. (KMP .le. MAXL) -C NRSTS :IN Integer -C Counter for the number of restarts on the current -C call to DGMRES. If NRSTS .gt. 0, then the residual -C R0 is already scaled, and so scaling of it is -C not necessary. -C JPRE :IN Integer -C Preconditioner type flag. -C MATVEC :EXT External. -C Name of a routine which performs the matrix vector multiply -C Y = A*X given A and X. The name of the MATVEC routine must -C be declared external in the calling program. The calling -C sequence to MATVEC is: -C CALL MATVEC(N, X, Y, NELT, IA, JA, A, ISYM) -C where N is the number of unknowns, Y is the product A*X -C upon return, X is an input vector, and NELT is the number of -C non-zeros in the SLAP IA, JA, A storage for the matrix A. -C ISYM is a flag which, if non-zero, denotes that A is -C symmetric and only the lower or upper triangle is stored. -C MSOLVE :EXT External. -C Name of the routine which solves a linear system Mz = r for -C z given r with the preconditioning matrix M (M is supplied via -C RPAR and IPAR arrays. The name of the MSOLVE routine must -C be declared external in the calling program. The calling -C sequence to MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RPAR, IPAR) -C Where N is the number of unknowns, R is the right-hand side -C vector and Z is the solution upon return. NELT, IA, JA, A and -C ISYM are defined as below. RPAR is a double precision array -C that can be used to pass necessary preconditioning information -C and/or workspace to MSOLVE. IPAR is an integer work array -C for the same purpose as RPAR. -C NMSL :OUT Integer -C The number of calls to MSOLVE. -C Z :OUT Double Precision Z(N) -C The final computed approximation to the solution -C of the system A*Z = R0. -C V :OUT Double Precision V(N,MAXLP1) -C The N by (LGMR+1) array containing the LGMR -C orthogonal vectors V(*,1) to V(*,LGMR). -C HES :OUT Double Precision HES(MAXLP1,MAXL) -C 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 Q :OUT Double Precision Q(2*MAXL) -C A double precision array of length 2*MAXL containing the -C components of the Givens rotations used in the QR -C decomposition of HES. It is loaded in DHEQR and used in -C DHELS. -C LGMR :OUT Integer -C The number of iterations performed and -C the current order of the upper Hessenberg -C matrix HES. -C RPAR :IN Double Precision RPAR(USER DEFINED) -C Double Precision workspace passed directly to the MSOLVE -C routine. -C IPAR :IN Integer IPAR(USER DEFINED) -C Integer workspace passed directly to the MSOLVE routine. -C WK :IN Double Precision WK(N) -C A double precision work array of length N used by routines -C MATVEC and MSOLVE. -C DL :INOUT Double Precision DL(N) -C On input, a double precision work array of length N used for -C calculation of the residual norm RHO when the method is -C incomplete (KMP.lt.MAXL), and/or when using restarting. -C On output, the scaled residual vector RL. It is only loaded -C when performing restarts of the Krylov iteration. -C RHOL :OUT Double Precision -C A double precision scalar containing the norm of the final -C residual. -C NRMAX :IN Integer -C The maximum number of restarts of the Krylov iteration. -C NRMAX .gt. 0 means restarting is active, while -C NRMAX = 0 means restarting is not being used. -C B :IN Double Precision B(N) -C The right hand side of the linear system A*X = b. -C BNRM :IN Double Precision -C The scaled norm of b. -C X :IN Double Precision X(N) -C The current approximate solution as of the last -C restart. -C XL :IN Double Precision XL(N) -C An array of length N used to hold the approximate -C solution X(L) when ITOL=11. -C ITOL :IN Integer -C A flag to indicate the type of convergence criterion -C used. See the driver for its description. -C TOL :IN Double Precision -C The tolerance on residuals R0-A*Z in scaled norm. -C NELT :IN Integer -C The length of arrays IA, JA and A. -C IA :IN Integer IA(NELT) -C An integer array of length NELT containing matrix data. -C It is passed directly to the MATVEC and MSOLVE routines. -C JA :IN Integer JA(NELT) -C An integer array of length NELT containing matrix data. -C It is passed directly to the MATVEC and MSOLVE routines. -C A :IN Double Precision A(NELT) -C A double precision array of length NELT containing matrix -C data. It is passed directly to the MATVEC and MSOLVE routines. -C ISYM :IN Integer -C A flag to indicate symmetric matrix storage. -C If ISYM=0, all non-zero entries of the matrix are -C stored. If ISYM=1, the matrix is symmetric and -C only the upper or lower triangular part is stored. -C IUNIT :IN Integer -C The i/o unit number for writing intermediate residual -C norm values. -C IFLAG :OUT Integer -C An 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 residual norm is .lt. norm(R0), -C and so Z is computed. -C 2 means the convergence test did not pass in MAXL -C iterations, residual .ge. norm(R0), and Z = 0. -C ERR :OUT Double Precision. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO DGMRES -C***ROUTINES CALLED DAXPY, DCOPY, DHELS, DHEQR, DNRM2, DORTH, DRLCAL, -C DSCAL, ISDGMR -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MATVEC and MSOLVE from ROUTINES CALLED list. (FNF) -C 910506 Made subsidiary to DGMRES. (FNF) -C 920511 Added complete declaration section. (WRB) -C***END PROLOGUE DPIGMR -C The following is for optimized compilation on LLNL/LTSS Crays. -CLLL. OPTIMIZE -C .. Scalar Arguments .. - DOUBLE PRECISION BNRM, ERR, RHOL, TOL - INTEGER IFLAG, ISYM, ITOL, IUNIT, JPRE, JSCAL, KMP, LGMR, MAXL, - + MAXLP1, N, NELT, NMSL, NRMAX, NRSTS -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), B(*), DL(*), HES(MAXLP1,*), Q(*), R0(*), - + RPAR(*), SR(*), SZ(*), V(N,*), WK(*), X(*), - + XL(*), Z(*) - INTEGER IA(NELT), IPAR(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MATVEC, MSOLVE -C .. Local Scalars .. - DOUBLE PRECISION C, DLNRM, PROD, R0NRM, RHO, S, SNORMW, TEM - INTEGER I, I2, INFO, IP1, ITER, ITMAX, J, K, LL, LLP1 -C .. External Functions .. - DOUBLE PRECISION DNRM2 - INTEGER ISDGMR - EXTERNAL DNRM2, ISDGMR -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DHELS, DHEQR, DORTH, DRLCAL, DSCAL -C .. Intrinsic Functions .. - INTRINSIC ABS -C***FIRST EXECUTABLE STATEMENT DPIGMR -C -C Zero out the Z array. -C - DO 5 I = 1,N - Z(I) = 0 - 5 CONTINUE -C - IFLAG = 0 - LGMR = 0 - NMSL = 0 -C Load ITMAX, the maximum number of iterations. - ITMAX =(NRMAX+1)*MAXL -C ------------------------------------------------------------------- -C The initial residual is the vector R0. -C Apply left precon. if JPRE < 0 and this is not a restart. -C Apply scaling to R0 if JSCAL = 2 or 3. -C ------------------------------------------------------------------- - IF ((JPRE .LT. 0) .AND.(NRSTS .EQ. 0)) THEN - CALL DCOPY(N, R0, 1, WK, 1) - CALL MSOLVE(N, WK, R0, NELT, IA, JA, A, ISYM, RPAR, IPAR) - NMSL = NMSL + 1 - ENDIF - IF (((JSCAL.EQ.2) .OR.(JSCAL.EQ.3)) .AND.(NRSTS.EQ.0)) THEN - DO 10 I = 1,N - V(I,1) = R0(I)*SR(I) - 10 CONTINUE - ELSE - DO 20 I = 1,N - V(I,1) = R0(I) - 20 CONTINUE - ENDIF - R0NRM = DNRM2(N, V, 1) - ITER = NRSTS*MAXL -C -C Call stopping routine ISDGMR. -C - IF (ISDGMR(N, B, X, XL, NELT, IA, JA, A, ISYM, MSOLVE, - $ NMSL, ITOL, TOL, ITMAX, ITER, ERR, IUNIT, V(1,1), Z, WK, - $ RPAR, IPAR, R0NRM, BNRM, SR, SZ, JSCAL, - $ KMP, LGMR, MAXL, MAXLP1, V, Q, SNORMW, PROD, R0NRM, - $ HES, JPRE) .NE. 0) RETURN - TEM = 1.0D0/R0NRM - CALL DSCAL(N, TEM, V(1,1), 1) -C -C Zero out the HES array. -C - DO 50 J = 1,MAXL - DO 40 I = 1,MAXLP1 - HES(I,J) = 0 - 40 CONTINUE - 50 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 - DO 90 LL = 1,MAXL - LGMR = LL -C ------------------------------------------------------------------- -C Unscale the current V(LL) and store in WK. Call routine -C MSOLVE to compute(M-inverse)*WK, where M is the -C preconditioner matrix. Save the answer in Z. Call routine -C MATVEC to compute VNEW = A*Z, where A is the the system -C matrix. save the answer in V(LL+1). Scale V(LL+1). Call -C routine DORTH to orthogonalize the new vector VNEW = -C V(*,LL+1). Call routine DHEQR to update the factors of HES. -C ------------------------------------------------------------------- - IF ((JSCAL .EQ. 1) .OR.(JSCAL .EQ. 3)) THEN - DO 60 I = 1,N - WK(I) = V(I,LL)/SZ(I) - 60 CONTINUE - ELSE - CALL DCOPY(N, V(1,LL), 1, WK, 1) - ENDIF - IF (JPRE .GT. 0) THEN - CALL MSOLVE(N, WK, Z, NELT, IA, JA, A, ISYM, RPAR, IPAR) - NMSL = NMSL + 1 - CALL MATVEC(N, Z, V(1,LL+1), NELT, IA, JA, A, ISYM) - ELSE - CALL MATVEC(N, WK, V(1,LL+1), NELT, IA, JA, A, ISYM) - ENDIF - IF (JPRE .LT. 0) THEN - CALL DCOPY(N, V(1,LL+1), 1, WK, 1) - CALL MSOLVE(N,WK,V(1,LL+1),NELT,IA,JA,A,ISYM,RPAR,IPAR) - NMSL = NMSL + 1 - ENDIF - IF ((JSCAL .EQ. 2) .OR.(JSCAL .EQ. 3)) THEN - DO 65 I = 1,N - V(I,LL+1) = V(I,LL+1)*SR(I) - 65 CONTINUE - ENDIF - CALL DORTH(V(1,LL+1), V, HES, N, 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 R0-A*ZL. -C If KMP < MAXL, then the vectors V(*,1),...,V(*,LL+1) are not -C necessarily orthogonal for LL > 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*R0NRM) - IF ((LL.GT.KMP) .AND.(KMP.LT.MAXL)) THEN - IF (LL .EQ. KMP+1) THEN - CALL DCOPY(N, 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,N - DL(K) = S*DL(K) + C*V(K,IP1) - 70 CONTINUE - 75 CONTINUE - ENDIF - S = Q(2*LL) - C = Q(2*LL-1)/SNORMW - LLP1 = LL + 1 - DO 80 K = 1,N - DL(K) = S*DL(K) + C*V(K,LLP1) - 80 CONTINUE - DLNRM = DNRM2(N, DL, 1) - RHO = RHO*DLNRM - ENDIF - RHOL = RHO -C ------------------------------------------------------------------- -C Test for convergence. If passed, compute approximation ZL. -C If failed and LL < MAXL, then continue iterating. -C ------------------------------------------------------------------- - ITER = NRSTS*MAXL + LGMR - IF (ISDGMR(N, B, X, XL, NELT, IA, JA, A, ISYM, MSOLVE, - $ NMSL, ITOL, TOL, ITMAX, ITER, ERR, IUNIT, DL, Z, WK, - $ RPAR, IPAR, RHOL, BNRM, SR, SZ, JSCAL, - $ KMP, LGMR, MAXL, MAXLP1, V, Q, SNORMW, PROD, R0NRM, - $ HES, JPRE) .NE. 0) 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(N, TEM, V(1,LL+1), 1) - 90 CONTINUE - 100 CONTINUE - IF (RHO .LT. R0NRM) GO TO 150 - 120 CONTINUE - IFLAG = 2 -C -C Load approximate solution with zero. -C - DO 130 I = 1,N - Z(I) = 0 - 130 CONTINUE - RETURN - 150 IFLAG = 1 -C -C Tolerance not met, but residual norm reduced. -C - IF (NRMAX .GT. 0) THEN -C -C If performing restarting (NRMAX > 0) calculate the residual -C vector RL and store it in the DL array. If the incomplete -C version is being used (KMP < MAXL) then DL has already been -C calculated up to a scaling factor. Use DRLCAL to calculate -C the scaled residual vector. -C - CALL DRLCAL(N, KMP, MAXL, MAXL, V, Q, DL, SNORMW, PROD, - $ R0NRM) - ENDIF -C ------------------------------------------------------------------- -C Compute the approximation ZL to the solution. Since the -C vector Z was used as workspace, and the initial guess -C of the linear iteration is zero, Z must be reset to zero. -C ------------------------------------------------------------------- - 200 CONTINUE - LL = LGMR - LLP1 = LL + 1 - DO 210 K = 1,LLP1 - R0(K) = 0 - 210 CONTINUE - R0(1) = R0NRM - CALL DHELS(HES, MAXLP1, LL, Q, R0) - DO 220 K = 1,N - Z(K) = 0 - 220 CONTINUE - DO 230 I = 1,LL - CALL DAXPY(N, R0(I), V(1,I), 1, Z, 1) - 230 CONTINUE - IF ((JSCAL .EQ. 1) .OR.(JSCAL .EQ. 3)) THEN - DO 240 I = 1,N - Z(I) = Z(I)/SZ(I) - 240 CONTINUE - ENDIF - IF (JPRE .GT. 0) THEN - CALL DCOPY(N, Z, 1, WK, 1) - CALL MSOLVE(N, WK, Z, NELT, IA, JA, A, ISYM, RPAR, IPAR) - NMSL = NMSL + 1 - ENDIF - RETURN -C------------- LAST LINE OF DPIGMR FOLLOWS ---------------------------- - END diff --git a/slatec/dpincw.f b/slatec/dpincw.f deleted file mode 100644 index 7f7bf24..0000000 --- a/slatec/dpincw.f +++ /dev/null @@ -1,135 +0,0 @@ -*DECK DPINCW - SUBROUTINE DPINCW (MRELAS, NVARS, LMX, LBM, NPP, JSTRT, IBASIS, - + IMAT, IBRC, IPR, IWR, IND, IBB, COSTSC, GG, ERDNRM, DULNRM, - + AMAT, BASMAT, CSC, WR, WW, RZ, RG, COSTS, COLNRM, DUALS, - + STPEDG) -C***BEGIN PROLOGUE DPINCW -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSPLP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (SPINCW-S, DPINCW-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO -C DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. -C -C USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/, -C REAL (12 BLANKS)/DOUBLE PRECISION/,/SCOPY/DCOPY/,/SDOT/DDOT/. -C -C THIS SUBPROGRAM IS PART OF THE DSPLP( ) PACKAGE. -C IT IMPLEMENTS THE PROCEDURE (INITIALIZE REDUCED COSTS AND -C STEEPEST EDGE WEIGHTS). -C -C***SEE ALSO DSPLP -C***ROUTINES CALLED DCOPY, DDOT, DPRWPG, IDLOC, LA05BD -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890605 Removed unreferenced labels. (WRB) -C 890606 Changed references from IPLOC to IDLOC. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DPINCW - INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*) - DOUBLE PRECISION AMAT(*),BASMAT(*),CSC(*),WR(*),WW(*),RZ(*),RG(*), - * COSTS(*),COLNRM(*),DUALS(*),COSTSC,ERDNRM,DULNRM,GG,ONE,RZJ, - * SCALR,ZERO,RCOST,CNORM - DOUBLE PRECISION DDOT - LOGICAL STPEDG,PAGEPL,TRANS -C***FIRST EXECUTABLE STATEMENT DPINCW - LPG=LMX-(NVARS+4) - ZERO=0.D0 - ONE=1.D0 -C -C FORM REDUCED COSTS, RZ(*), AND STEEPEST EDGE WEIGHTS, RG(*). - PAGEPL=.TRUE. - RZ(1)=ZERO - CALL DCOPY(NVARS+MRELAS,RZ,0,RZ,1) - RG(1)=ONE - CALL DCOPY(NVARS+MRELAS,RG,0,RG,1) - NNEGRC=0 - J=JSTRT -20002 IF (.NOT.(IBB(J).LE.0)) GO TO 20004 - PAGEPL=.TRUE. - GO TO 20005 -C -C THESE ARE NONBASIC INDEPENDENT VARIABLES. THE COLS. ARE IN SPARSE -C MATRIX FORMAT. -20004 IF (.NOT.(J.LE.NVARS)) GO TO 20007 - RZJ=COSTSC*COSTS(J) - WW(1)=ZERO - CALL DCOPY(MRELAS,WW,0,WW,1) - IF (.NOT.(J.EQ.1)) GO TO 20010 - ILOW=NVARS+5 - GO TO 20011 -20010 ILOW=IMAT(J+3)+1 -20011 CONTINUE - IF (.NOT.(PAGEPL)) GO TO 20013 - IL1=IDLOC(ILOW,AMAT,IMAT) - IF (.NOT.(IL1.GE.LMX-1)) GO TO 20016 - ILOW=ILOW+2 - IL1=IDLOC(ILOW,AMAT,IMAT) -20016 CONTINUE - IPAGE=ABS(IMAT(LMX-1)) - GO TO 20014 -20013 IL1=IHI+1 -20014 CONTINUE - IHI=IMAT(J+4)-(ILOW-IL1) -20019 IU1=MIN(LMX-2,IHI) - IF (.NOT.(IL1.GT.IU1)) GO TO 20021 - GO TO 20020 -20021 CONTINUE - DO 60 I=IL1,IU1 - RZJ=RZJ-AMAT(I)*DUALS(IMAT(I)) - WW(IMAT(I))=AMAT(I)*CSC(J) -60 CONTINUE - IF (.NOT.(IHI.LE.LMX-2)) GO TO 20024 - GO TO 20020 -20024 CONTINUE - IPAGE=IPAGE+1 - KEY=1 - CALL DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT) - IL1=NVARS+5 - IHI=IHI-LPG - GO TO 20019 -20020 PAGEPL=IHI.EQ.(LMX-2) - RZ(J)=RZJ*CSC(J) - IF (.NOT.(STPEDG)) GO TO 20027 - TRANS=.FALSE. - CALL LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) - RG(J)=DDOT(MRELAS,WW,1,WW,1)+ONE -20027 CONTINUE -C -C THESE ARE NONBASIC DEPENDENT VARIABLES. THE COLS. ARE IMPLICITLY -C DEFINED. - GO TO 20008 -20007 PAGEPL=.TRUE. - WW(1)=ZERO - CALL DCOPY(MRELAS,WW,0,WW,1) - SCALR=-ONE - IF (IND(J).EQ.2) SCALR=ONE - I=J-NVARS - RZ(J)=-SCALR*DUALS(I) - WW(I)=SCALR - IF (.NOT.(STPEDG)) GO TO 20030 - TRANS=.FALSE. - CALL LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) - RG(J)=DDOT(MRELAS,WW,1,WW,1)+ONE -20030 CONTINUE - CONTINUE -20008 CONTINUE -C -20005 RCOST=RZ(J) - IF (MOD(IBB(J),2).EQ.0) RCOST=-RCOST - IF (IND(J).EQ.4) RCOST=-ABS(RCOST) - CNORM=ONE - IF (J.LE.NVARS) CNORM=COLNRM(J) - IF (RCOST+ERDNRM*DULNRM*CNORM.LT.ZERO) NNEGRC=NNEGRC+1 - J=MOD(J,MRELAS+NVARS)+1 - IF (.NOT.(NNEGRC.GE.NPP .OR. J.EQ.JSTRT)) GO TO 20033 - GO TO 20003 -20033 GO TO 20002 -20003 JSTRT=J - RETURN - END diff --git a/slatec/dpinit.f b/slatec/dpinit.f deleted file mode 100644 index 6fcb24d..0000000 --- a/slatec/dpinit.f +++ /dev/null @@ -1,231 +0,0 @@ -*DECK DPINIT - SUBROUTINE DPINIT (MRELAS, NVARS, COSTS, BL, BU, IND, PRIMAL, - + INFO, AMAT, CSC, COSTSC, COLNRM, XLAMDA, ANORM, RHS, RHSNRM, - + IBASIS, IBB, IMAT, LOPT) -C***BEGIN PROLOGUE DPINIT -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSPLP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (SPINIT-S, DPINIT-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO -C DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. -C -C USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. -C /REAL (12 BLANKS)/DOUBLE PRECISION/,/SCOPY/DCOPY/ -C REVISED 810519-0900 -C REVISED YYMMDD-HHMM -C -C INITIALIZATION SUBROUTINE FOR DSPLP(*) PACKAGE. -C -C***SEE ALSO DSPLP -C***ROUTINES CALLED DASUM, DCOPY, DPNNZR -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890605 Removed unreferenced labels. (WRB) -C 891009 Removed unreferenced variable. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DPINIT - DOUBLE PRECISION AIJ,AMAT(*),ANORM,BL(*),BU(*),CMAX, - * COLNRM(*),COSTS(*),COSTSC,CSC(*),CSUM,ONE,PRIMAL(*), - * RHS(*),RHSNRM,SCALR,TESTSC,XLAMDA,ZERO - DOUBLE PRECISION DASUM - INTEGER IBASIS(*),IBB(*),IMAT(*),IND(*) - LOGICAL CONTIN,USRBAS,COLSCP,CSTSCP,MINPRB,LOPT(8) -C -C***FIRST EXECUTABLE STATEMENT DPINIT - ZERO=0.D0 - ONE=1.D0 - CONTIN=LOPT(1) - USRBAS=LOPT(2) - COLSCP=LOPT(5) - CSTSCP=LOPT(6) - MINPRB=LOPT(7) -C -C SCALE DATA. NORMALIZE BOUNDS. FORM COLUMN CHECK SUMS. - GO TO 30001 -C -C INITIALIZE ACTIVE BASIS MATRIX. -20002 CONTINUE - GO TO 30002 -20003 RETURN -C -C PROCEDURE (SCALE DATA. NORMALIZE BOUNDS. FORM COLUMN CHECK SUMS) -C -C DO COLUMN SCALING IF NOT PROVIDED BY THE USER. -30001 IF (.NOT.(.NOT. COLSCP)) GO TO 20004 - J=1 - N20007=NVARS - GO TO 20008 -20007 J=J+1 -20008 IF ((N20007-J).LT.0) GO TO 20009 - CMAX=ZERO - I=0 -20011 CALL DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,J) - IF (.NOT.(I.EQ.0)) GO TO 20013 - GO TO 20012 -20013 CONTINUE - CMAX=MAX(CMAX,ABS(AIJ)) - GO TO 20011 -20012 IF (.NOT.(CMAX.EQ.ZERO)) GO TO 20016 - CSC(J)=ONE - GO TO 20017 -20016 CSC(J)=ONE/CMAX -20017 CONTINUE - GO TO 20007 -20009 CONTINUE -C -C FORM CHECK SUMS OF COLUMNS. COMPUTE MATRIX NORM OF SCALED MATRIX. -20004 ANORM = ZERO - J=1 - N20019=NVARS - GO TO 20020 -20019 J=J+1 -20020 IF ((N20019-J).LT.0) GO TO 20021 - PRIMAL(J)=ZERO - CSUM = ZERO - I=0 -20023 CALL DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,J) - IF (.NOT.(I.LE.0)) GO TO 20025 - GO TO 20024 -20025 CONTINUE - PRIMAL(J)=PRIMAL(J)+AIJ - CSUM = CSUM+ABS(AIJ) - GO TO 20023 -20024 IF (IND(J).EQ.2) CSC(J)=-CSC(J) - PRIMAL(J)=PRIMAL(J)*CSC(J) - COLNRM(J)=ABS(CSC(J)*CSUM) - ANORM = MAX(ANORM,COLNRM(J)) - GO TO 20019 -C -C IF THE USER HAS NOT PROVIDED COST VECTOR SCALING THEN SCALE IT -C USING THE MAX. NORM OF THE TRANSFORMED COST VECTOR, IF NONZERO. -20021 TESTSC=ZERO - J=1 - N20028=NVARS - GO TO 20029 -20028 J=J+1 -20029 IF ((N20028-J).LT.0) GO TO 20030 - TESTSC=MAX(TESTSC,ABS(CSC(J)*COSTS(J))) - GO TO 20028 -20030 IF (.NOT.(.NOT.CSTSCP)) GO TO 20032 - IF (.NOT.(TESTSC.GT.ZERO)) GO TO 20035 - COSTSC=ONE/TESTSC - GO TO 20036 -20035 COSTSC=ONE -20036 CONTINUE - CONTINUE -20032 XLAMDA=(COSTSC+COSTSC)*TESTSC - IF (XLAMDA.EQ.ZERO) XLAMDA=ONE -C -C IF MAXIMIZATION PROBLEM, THEN CHANGE SIGN OF COSTSC AND LAMDA -C =WEIGHT FOR PENALTY-FEASIBILITY METHOD. - IF (.NOT.(.NOT.MINPRB)) GO TO 20038 - COSTSC=-COSTSC -20038 GO TO 20002 -C:CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (INITIALIZE RHS(*),IBASIS(*), AND IBB(*)) -C -C INITIALLY SET RIGHT-HAND SIDE VECTOR TO ZERO. -30002 CALL DCOPY(MRELAS,ZERO,0,RHS,1) -C -C TRANSLATE RHS ACCORDING TO CLASSIFICATION OF INDEPENDENT VARIABLES - J=1 - N20041=NVARS - GO TO 20042 -20041 J=J+1 -20042 IF ((N20041-J).LT.0) GO TO 20043 - IF (.NOT.(IND(J).EQ.1)) GO TO 20045 - SCALR=-BL(J) - GO TO 20046 -20045 IF (.NOT.(IND(J).EQ.2)) GO TO 10001 - SCALR=-BU(J) - GO TO 20046 -10001 IF (.NOT.(IND(J).EQ.3)) GO TO 10002 - SCALR=-BL(J) - GO TO 20046 -10002 IF (.NOT.(IND(J).EQ.4)) GO TO 10003 - SCALR=ZERO -10003 CONTINUE -20046 CONTINUE - IF (.NOT.(SCALR.NE.ZERO)) GO TO 20048 - I=0 -20051 CALL DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,J) - IF (.NOT.(I.LE.0)) GO TO 20053 - GO TO 20052 -20053 CONTINUE - RHS(I)=SCALR*AIJ+RHS(I) - GO TO 20051 -20052 CONTINUE -20048 CONTINUE - GO TO 20041 -C -C TRANSLATE RHS ACCORDING TO CLASSIFICATION OF DEPENDENT VARIABLES. -20043 I=NVARS+1 - N20056=NVARS+MRELAS - GO TO 20057 -20056 I=I+1 -20057 IF ((N20056-I).LT.0) GO TO 20058 - IF (.NOT.(IND(I).EQ.1)) GO TO 20060 - SCALR=BL(I) - GO TO 20061 -20060 IF (.NOT.(IND(I).EQ.2)) GO TO 10004 - SCALR=BU(I) - GO TO 20061 -10004 IF (.NOT.(IND(I).EQ.3)) GO TO 10005 - SCALR=BL(I) - GO TO 20061 -10005 IF (.NOT.(IND(I).EQ.4)) GO TO 10006 - SCALR=ZERO -10006 CONTINUE -20061 CONTINUE - RHS(I-NVARS)=RHS(I-NVARS)+SCALR - GO TO 20056 -20058 RHSNRM=DASUM(MRELAS,RHS,1) -C -C IF THIS IS NOT A CONTINUATION OR THE USER HAS NOT PROVIDED THE -C INITIAL BASIS, THEN THE INITIAL BASIS IS COMPRISED OF THE -C DEPENDENT VARIABLES. - IF (.NOT.(.NOT.(CONTIN .OR. USRBAS))) GO TO 20063 - J=1 - N20066=MRELAS - GO TO 20067 -20066 J=J+1 -20067 IF ((N20066-J).LT.0) GO TO 20068 - IBASIS(J)=NVARS+J - GO TO 20066 -20068 CONTINUE -C -C DEFINE THE ARRAY IBB(*) -20063 J=1 - N20070=NVARS+MRELAS - GO TO 20071 -20070 J=J+1 -20071 IF ((N20070-J).LT.0) GO TO 20072 - IBB(J)=1 - GO TO 20070 -20072 J=1 - N20074=MRELAS - GO TO 20075 -20074 J=J+1 -20075 IF ((N20074-J).LT.0) GO TO 20076 - IBB(IBASIS(J))=-1 - GO TO 20074 -C -C DEFINE THE REST OF IBASIS(*) -20076 IP=MRELAS - J=1 - N20078=NVARS+MRELAS - GO TO 20079 -20078 J=J+1 -20079 IF ((N20078-J).LT.0) GO TO 20080 - IF (.NOT.(IBB(J).GT.0)) GO TO 20082 - IP=IP+1 - IBASIS(IP)=J -20082 GO TO 20078 -20080 GO TO 20003 - END diff --git a/slatec/dpintm.f b/slatec/dpintm.f deleted file mode 100644 index 8d54f69..0000000 --- a/slatec/dpintm.f +++ /dev/null @@ -1,105 +0,0 @@ -*DECK DPINTM - SUBROUTINE DPINTM (M, N, SX, IX, LMX, IPAGEF) -C***BEGIN PROLOGUE DPINTM -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSPLP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (PINITM-S, DPINTM-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C -C DPINTM LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SCHEME. -C THE MATRIX IS STORED BY COLUMNS. -C SPARSE MATRIX INITIALIZATION SUBROUTINE. -C -C M=NUMBER OF ROWS OF THE MATRIX. -C N=NUMBER OF COLUMNS OF THE MATRIX. -C SX(*),IX(*)=THE WORK ARRAYS WHICH ARE USED TO STORE THE SPARSE -C MATRIX. THESE ARRAYS ARE AUTOMATICALLY MAINTAINED BY -C THE PACKAGE FOR THE USER. -C LMX=LENGTH OF THE WORK ARRAY SX(*). -C LMX MUST BE AT LEAST N+7 WHERE -C FOR GREATEST EFFICIENCY LMX SHOULD BE AT LEAST N+NZ+6 -C WHERE NZ IS THE MAXIMUM NUMBER OF NONZEROES TO BE -C STORED IN THE MATRIX. VALUES OF LMX BETWEEN N+7 AND -C N+NZ+6 WILL CAUSE DEMAND PAGING TO OCCUR. -C THIS IS IMPLEMENTED BY THE PACKAGE. -C IX(*) MUST BE DIMENSIONED AT LEAST LMX -C IPAGEF=UNIT NUMBER WHERE DEMAND PAGES WILL BE STORED. -C -C THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LINITM, -C SANDIA LABS. REPT. SAND78-0785. -C MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON -C REVISED 811130-1000 -C REVISED YYMMDD-HHMM -C -C***SEE ALSO DSPLP -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 910403 Updated AUTHOR and DESCRIPTION sections. (WRB) -C***END PROLOGUE DPINTM - DOUBLE PRECISION SX(*),ZERO,ONE - DIMENSION IX(*) - SAVE ZERO, ONE - DATA ZERO,ONE /0.D0,1.D0/ -C***FIRST EXECUTABLE STATEMENT DPINTM - IOPT=1 -C -C CHECK FOR INPUT ERRORS. -C - IF (.NOT.(M.LE.0 .OR. N.LE.0)) GO TO 20002 - NERR=55 - CALL XERMSG ('SLATEC', 'DPINTM', - + 'MATRIX DIMENSION M OR N .LE. 0', NERR, IOPT) -C -C VERIFY IF VALUE OF LMX IS LARGE ENOUGH. -C -20002 IF (.NOT.(LMX.LT.N+7)) GO TO 20005 - NERR=55 - CALL XERMSG ('SLATEC', 'DPINTM', - + 'THE VALUE OF LMX IS TOO SMALL', NERR, IOPT) -C -C INITIALIZE DATA STRUCTURE INDEPENDENT VALUES. -C -20005 SX(1)=ZERO - SX(2)=ZERO - SX(3)=IPAGEF - IX(1)=LMX - IX(2)=M - IX(3)=N - IX(4)=0 - SX(LMX-1)=ZERO - SX(LMX)=-ONE - IX(LMX-1)=-1 - LP4=N+4 -C -C INITIALIZE DATA STRUCTURE DEPENDENT VALUES. -C - I=4 - N20008=LP4 - GO TO 20009 -20008 I=I+1 -20009 IF ((N20008-I).LT.0) GO TO 20010 - SX(I)=ZERO - GO TO 20008 -20010 I=5 - N20012=LP4 - GO TO 20013 -20012 I=I+1 -20013 IF ((N20012-I).LT.0) GO TO 20014 - IX(I)=LP4 - GO TO 20012 -20014 SX(N+5)=ZERO - IX(N+5)=0 - IX(LMX)=0 -C -C INITIALIZATION COMPLETE. -C - RETURN - END diff --git a/slatec/dpjac.f b/slatec/dpjac.f deleted file mode 100644 index 2d6bc8b..0000000 --- a/slatec/dpjac.f +++ /dev/null @@ -1,227 +0,0 @@ -*DECK DPJAC - SUBROUTINE DPJAC (NEQ, Y, YH, NYH, EWT, FTEM, SAVF, WM, IWM, DF, - + DJAC, RPAR, IPAR) -C***BEGIN PROLOGUE DPJAC -C***SUBSIDIARY -C***PURPOSE Subsidiary to DDEBDF -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (PJAC-S, DPJAC-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C DPJAC sets up the iteration matrix (involving the Jacobian) for the -C integration package DDEBDF. -C -C***SEE ALSO DDEBDF -C***ROUTINES CALLED DGBFA, DGEFA, DVNRMS -C***COMMON BLOCKS DDEBD1 -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C 920422 Changed DIMENSION statement. (WRB) -C***END PROLOGUE DPJAC -C - INTEGER I, I1, I2, IER, II, IOWND, IOWNS, IPAR, IWM, J, J1, - 1 JJ, JSTART, KFLAG, L, LENP, MAXORD, MBA, MBAND, - 2 MEB1, MEBAND, METH, MITER, ML, ML3, MU, N, NEQ, - 3 NFE, NJE, NQ, NQU, NST, NYH - DOUBLE PRECISION CON, DI, DVNRMS, EL0, EWT, - 1 FAC, FTEM, H, HL0, HMIN, HMXI, HU, R, R0, ROWND, ROWNS, - 2 RPAR, SAVF, SRUR, TN, UROUND, WM, Y, YH, YI, YJ, YJJ - EXTERNAL DF, DJAC - DIMENSION Y(*),YH(NYH,*),EWT(*),FTEM(*),SAVF(*),WM(*),IWM(*), - 1 RPAR(*),IPAR(*) - COMMON /DDEBD1/ ROWND,ROWNS(210),EL0,H,HMIN,HMXI,HU,TN,UROUND, - 1 IOWND(14),IOWNS(6),IER,JSTART,KFLAG,L,METH,MITER, - 2 MAXORD,N,NQ,NST,NFE,NJE,NQU -C ------------------------------------------------------------------ -C DPJAC IS CALLED BY DSTOD TO COMPUTE AND PROCESS THE MATRIX -C P = I - H*EL(1)*J , WHERE J IS AN APPROXIMATION TO THE JACOBIAN. -C HERE J IS COMPUTED BY THE USER-SUPPLIED ROUTINE DJAC IF -C MITER = 1 OR 4, OR BY FINITE DIFFERENCING IF MITER = 2, 3, OR 5. -C IF MITER = 3, A DIAGONAL APPROXIMATION TO J IS USED. -C J IS STORED IN WM AND REPLACED BY P. IF MITER .NE. 3, P IS THEN -C SUBJECTED TO LU DECOMPOSITION IN PREPARATION FOR LATER SOLUTION -C OF LINEAR SYSTEMS WITH P AS COEFFICIENT MATRIX. THIS IS DONE -C BY DGEFA IF MITER = 1 OR 2, AND BY DGBFA IF MITER = 4 OR 5. -C -C IN ADDITION TO VARIABLES DESCRIBED PREVIOUSLY, COMMUNICATION -C WITH DPJAC USES THE FOLLOWING.. -C Y = ARRAY CONTAINING PREDICTED VALUES ON ENTRY. -C FTEM = WORK ARRAY OF LENGTH N (ACOR IN DSTOD ). -C SAVF = ARRAY CONTAINING DF EVALUATED AT PREDICTED Y. -C WM = DOUBLE PRECISION WORK SPACE FOR MATRICES. ON OUTPUT IT -C CONTAINS THE -C INVERSE DIAGONAL MATRIX IF MITER = 3 AND THE LU -C DECOMPOSITION OF P IF MITER IS 1, 2 , 4, OR 5. -C STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). -C WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA.. -C WM(1) = SQRT(UROUND), USED IN NUMERICAL JACOBIAN -C INCREMENTS. WM(2) = H*EL0, SAVED FOR LATER USE IF MITER = -C 3. -C IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING -C AT IWM(21), IF MITER IS 1, 2, 4, OR 5. IWM ALSO CONTAINS -C THE BAND PARAMETERS ML = IWM(1) AND MU = IWM(2) IF MITER -C IS 4 OR 5. -C EL0 = EL(1) (INPUT). -C IER = OUTPUT ERROR FLAG, = 0 IF NO TROUBLE, .NE. 0 IF -C P MATRIX FOUND TO BE SINGULAR. -C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, TN, UROUND, -C MITER, N, NFE, AND NJE. -C----------------------------------------------------------------------- -C BEGIN BLOCK PERMITTING ...EXITS TO 240 -C BEGIN BLOCK PERMITTING ...EXITS TO 220 -C BEGIN BLOCK PERMITTING ...EXITS TO 130 -C BEGIN BLOCK PERMITTING ...EXITS TO 70 -C***FIRST EXECUTABLE STATEMENT DPJAC - NJE = NJE + 1 - HL0 = H*EL0 - GO TO (10,40,90,140,170), MITER -C IF MITER = 1, CALL DJAC AND MULTIPLY BY SCALAR. -C ----------------------- - 10 CONTINUE - LENP = N*N - DO 20 I = 1, LENP - WM(I+2) = 0.0D0 - 20 CONTINUE - CALL DJAC(TN,Y,WM(3),N,RPAR,IPAR) - CON = -HL0 - DO 30 I = 1, LENP - WM(I+2) = WM(I+2)*CON - 30 CONTINUE -C ...EXIT - GO TO 70 -C IF MITER = 2, MAKE N CALLS TO DF TO APPROXIMATE J. -C -------------------- - 40 CONTINUE - FAC = DVNRMS(N,SAVF,EWT) - R0 = 1000.0D0*ABS(H)*UROUND*N*FAC - IF (R0 .EQ. 0.0D0) R0 = 1.0D0 - SRUR = WM(1) - J1 = 2 - DO 60 J = 1, N - YJ = Y(J) - R = MAX(SRUR*ABS(YJ),R0*EWT(J)) - Y(J) = Y(J) + R - FAC = -HL0/R - CALL DF(TN,Y,FTEM,RPAR,IPAR) - DO 50 I = 1, N - WM(I+J1) = (FTEM(I) - SAVF(I))*FAC - 50 CONTINUE - Y(J) = YJ - J1 = J1 + N - 60 CONTINUE - NFE = NFE + N - 70 CONTINUE -C ADD IDENTITY MATRIX. -C ------------------------------------------------- - J = 3 - DO 80 I = 1, N - WM(J) = WM(J) + 1.0D0 - J = J + (N + 1) - 80 CONTINUE -C DO LU DECOMPOSITION ON P. -C -------------------------------------------- - CALL DGEFA(WM(3),N,N,IWM(21),IER) -C .........EXIT - GO TO 240 -C IF MITER = 3, CONSTRUCT A DIAGONAL APPROXIMATION TO J AND -C P. --------- - 90 CONTINUE - WM(2) = HL0 - IER = 0 - R = EL0*0.1D0 - DO 100 I = 1, N - Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) - 100 CONTINUE - CALL DF(TN,Y,WM(3),RPAR,IPAR) - NFE = NFE + 1 - DO 120 I = 1, N - R0 = H*SAVF(I) - YH(I,2) - DI = 0.1D0*R0 - H*(WM(I+2) - SAVF(I)) - WM(I+2) = 1.0D0 - IF (ABS(R0) .LT. UROUND*EWT(I)) GO TO 110 -C .........EXIT - IF (ABS(DI) .EQ. 0.0D0) GO TO 130 - WM(I+2) = 0.1D0*R0/DI - 110 CONTINUE - 120 CONTINUE -C .........EXIT - GO TO 240 - 130 CONTINUE - IER = -1 -C ......EXIT - GO TO 240 -C IF MITER = 4, CALL DJAC AND MULTIPLY BY SCALAR. -C ----------------------- - 140 CONTINUE - ML = IWM(1) - MU = IWM(2) - ML3 = 3 - MBAND = ML + MU + 1 - MEBAND = MBAND + ML - LENP = MEBAND*N - DO 150 I = 1, LENP - WM(I+2) = 0.0D0 - 150 CONTINUE - CALL DJAC(TN,Y,WM(ML3),MEBAND,RPAR,IPAR) - CON = -HL0 - DO 160 I = 1, LENP - WM(I+2) = WM(I+2)*CON - 160 CONTINUE -C ...EXIT - GO TO 220 -C IF MITER = 5, MAKE MBAND CALLS TO DF TO APPROXIMATE J. -C ---------------- - 170 CONTINUE - ML = IWM(1) - MU = IWM(2) - MBAND = ML + MU + 1 - MBA = MIN(MBAND,N) - MEBAND = MBAND + ML - MEB1 = MEBAND - 1 - SRUR = WM(1) - FAC = DVNRMS(N,SAVF,EWT) - R0 = 1000.0D0*ABS(H)*UROUND*N*FAC - IF (R0 .EQ. 0.0D0) R0 = 1.0D0 - DO 210 J = 1, MBA - DO 180 I = J, N, MBAND - YI = Y(I) - R = MAX(SRUR*ABS(YI),R0*EWT(I)) - Y(I) = Y(I) + R - 180 CONTINUE - CALL DF(TN,Y,FTEM,RPAR,IPAR) - DO 200 JJ = J, N, MBAND - Y(JJ) = YH(JJ,1) - YJJ = Y(JJ) - R = MAX(SRUR*ABS(YJJ),R0*EWT(JJ)) - FAC = -HL0/R - I1 = MAX(JJ-MU,1) - I2 = MIN(JJ+ML,N) - II = JJ*MEB1 - ML + 2 - DO 190 I = I1, I2 - WM(II+I) = (FTEM(I) - SAVF(I))*FAC - 190 CONTINUE - 200 CONTINUE - 210 CONTINUE - NFE = NFE + MBA - 220 CONTINUE -C ADD IDENTITY MATRIX. -C ------------------------------------------------- - II = MBAND + 2 - DO 230 I = 1, N - WM(II) = WM(II) + 1.0D0 - II = II + MEBAND - 230 CONTINUE -C DO LU DECOMPOSITION OF P. -C -------------------------------------------- - CALL DGBFA(WM(3),MEBAND,N,ML,MU,IWM(21),IER) - 240 CONTINUE - RETURN -C ----------------------- END OF SUBROUTINE DPJAC -C ----------------------- - END diff --git a/slatec/dplint.f b/slatec/dplint.f deleted file mode 100644 index b29f1e7..0000000 --- a/slatec/dplint.f +++ /dev/null @@ -1,63 +0,0 @@ -*DECK DPLINT - SUBROUTINE DPLINT (N, X, Y, C) -C***BEGIN PROLOGUE DPLINT -C***PURPOSE Produce the polynomial which interpolates a set of discrete -C data points. -C***LIBRARY SLATEC -C***CATEGORY E1B -C***TYPE DOUBLE PRECISION (POLINT-S, DPLINT-D) -C***KEYWORDS POLYNOMIAL INTERPOLATION -C***AUTHOR Huddleston, R. E., (SNLL) -C***DESCRIPTION -C -C Abstract -C Subroutine DPLINT is designed to produce the polynomial which -C interpolates the data (X(I),Y(I)), I=1,...,N. DPLINT sets up -C information in the array C which can be used by subroutine DPOLVL -C to evaluate the polynomial and its derivatives and by subroutine -C DPOLCF to produce the coefficients. -C -C Formal Parameters -C *** All TYPE REAL variables are DOUBLE PRECISION *** -C N - the number of data points (N .GE. 1) -C X - the array of abscissas (all of which must be distinct) -C Y - the array of ordinates -C C - an array of information used by subroutines -C ******* Dimensioning Information ******* -C Arrays X,Y, and C must be dimensioned at least N in the calling -C 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 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DPLINT - INTEGER I,K,KM1,N - DOUBLE PRECISION DIF,C(*),X(*),Y(*) -C***FIRST EXECUTABLE STATEMENT DPLINT - IF (N .LE. 0) GO TO 91 - C(1)=Y(1) - IF(N .EQ. 1) RETURN - DO 10010 K=2,N - C(K)=Y(K) - KM1=K-1 - DO 10010 I=1,KM1 -C CHECK FOR DISTINCT X VALUES - DIF = X(I)-X(K) - IF (DIF .EQ. 0.0) GO TO 92 - C(K) = (C(I)-C(K))/DIF -10010 CONTINUE - RETURN - 91 CALL XERMSG ('SLATEC', 'DPLINT', 'N IS ZERO OR NEGATIVE.', 2, 1) - RETURN - 92 CALL XERMSG ('SLATEC', 'DPLINT', - + 'THE ABSCISSAS ARE NOT DISTINCT.', 2, 1) - RETURN - END diff --git a/slatec/dplpce.f b/slatec/dplpce.f deleted file mode 100644 index 577f19d..0000000 --- a/slatec/dplpce.f +++ /dev/null @@ -1,184 +0,0 @@ -*DECK DPLPCE - SUBROUTINE DPLPCE (MRELAS, NVARS, LMX, LBM, ITLP, ITBRC, IBASIS, - + IMAT, IBRC, IPR, IWR, IND, IBB, ERDNRM, EPS, TUNE, GG, AMAT, - + BASMAT, CSC, WR, WW, PRIMAL, ERD, ERP, SINGLR, REDBAS) -C***BEGIN PROLOGUE DPLPCE -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSPLP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (SPLPCE-S, DPLPCE-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO -C DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. -C -C USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. -C /REAL (12 BLANKS)/DOUBLE PRECISION/, -C /SASUM/DASUM/,/DCOPY/,DCOPY/. -C -C REVISED 811219-1630 -C REVISED YYMMDD-HHMM -C -C THIS SUBPROGRAM IS FROM THE DSPLP( ) PACKAGE. IT CALCULATES -C THE APPROXIMATE ERROR IN THE PRIMAL AND DUAL SYSTEMS. IT IS -C THE MAIN PART OF THE PROCEDURE (COMPUTE ERROR IN DUAL AND PRIMAL -C SYSTEMS). -C -C***SEE ALSO DSPLP -C***ROUTINES CALLED DASUM, DCOPY, DPRWPG, IDLOC, LA05BD -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890605 Removed unreferenced labels. (WRB) -C 890606 Changed references from IPLOC to IDLOC. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DPLPCE - INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*) - DOUBLE PRECISION AMAT(*),BASMAT(*),CSC(*),WR(*),WW(*),PRIMAL(*), - * ERD(*),ERP(*),EPS,ERDNRM,FACTOR,GG,ONE,ZERO,TEN,TUNE - DOUBLE PRECISION DASUM - LOGICAL SINGLR,REDBAS,TRANS,PAGEPL -C***FIRST EXECUTABLE STATEMENT DPLPCE - ZERO=0.D0 - ONE=1.D0 - TEN=10.D0 - LPG=LMX-(NVARS+4) - SINGLR=.FALSE. - FACTOR=0.01 -C -C COPY COLSUMS IN WW(*), AND SOLVE TRANSPOSED SYSTEM. - I=1 - N20002=MRELAS - GO TO 20003 -20002 I=I+1 -20003 IF ((N20002-I).LT.0) GO TO 20004 - J=IBASIS(I) - IF (.NOT.(J.LE.NVARS)) GO TO 20006 - WW(I) = PRIMAL(J) - GO TO 20007 -20006 IF (.NOT.(IND(J).EQ.2)) GO TO 20009 - WW(I)=ONE - GO TO 20010 -20009 WW(I)=-ONE -20010 CONTINUE -20007 CONTINUE - GO TO 20002 -C -C PERTURB RIGHT-SIDE IN UNITS OF LAST BITS TO BETTER REFLECT -C ERRORS IN THE CHECK SUM SOLNS. -20004 I=1 - N20012=MRELAS - GO TO 20013 -20012 I=I+1 -20013 IF ((N20012-I).LT.0) GO TO 20014 - WW(I)=WW(I)+TEN*EPS*WW(I) - GO TO 20012 -20014 TRANS = .TRUE. - CALL LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) - I=1 - N20016=MRELAS - GO TO 20017 -20016 I=I+1 -20017 IF ((N20016-I).LT.0) GO TO 20018 - ERD(I)=MAX(ABS(WW(I)-ONE),EPS)*TUNE -C -C SYSTEM BECOMES SINGULAR WHEN ACCURACY OF SOLUTION IS .GT. FACTOR. -C THIS VALUE (FACTOR) MIGHT NEED TO BE CHANGED. - SINGLR=SINGLR.OR.(ERD(I).GE.FACTOR) - GO TO 20016 -20018 ERDNRM=DASUM(MRELAS,ERD,1) -C -C RECALCULATE ROW CHECK SUMS EVERY ITBRC ITERATIONS OR WHEN -C A REDECOMPOSITION HAS OCCURRED. - IF (.NOT.(MOD(ITLP,ITBRC).EQ.0 .OR. REDBAS)) GO TO 20020 -C -C COMPUTE ROW SUMS, STORE IN WW(*), SOLVE PRIMAL SYSTEM. - WW(1)=ZERO - CALL DCOPY(MRELAS,WW,0,WW,1) - PAGEPL=.TRUE. - J=1 - N20023=NVARS - GO TO 20024 -20023 J=J+1 -20024 IF ((N20023-J).LT.0) GO TO 20025 - IF (.NOT.(IBB(J).GE.ZERO)) GO TO 20027 -C -C THE VARIABLE IS NON-BASIC. - PAGEPL=.TRUE. - GO TO 20023 -20027 IF (.NOT.(J.EQ.1)) GO TO 20030 - ILOW=NVARS+5 - GO TO 20031 -20030 ILOW=IMAT(J+3)+1 -20031 IF (.NOT.(PAGEPL)) GO TO 20033 - IL1=IDLOC(ILOW,AMAT,IMAT) - IF (.NOT.(IL1.GE.LMX-1)) GO TO 20036 - ILOW=ILOW+2 - IL1=IDLOC(ILOW,AMAT,IMAT) -20036 CONTINUE - IPAGE=ABS(IMAT(LMX-1)) - GO TO 20034 -20033 IL1=IHI+1 -20034 IHI=IMAT(J+4)-(ILOW-IL1) -20039 IU1=MIN(LMX-2,IHI) - IF (.NOT.(IL1.GT.IU1)) GO TO 20041 - GO TO 20040 -20041 CONTINUE - DO 20 I=IL1,IU1 - WW(IMAT(I))=WW(IMAT(I))+AMAT(I)*CSC(J) -20 CONTINUE - IF (.NOT.(IHI.LE.LMX-2)) GO TO 20044 - GO TO 20040 -20044 CONTINUE - IPAGE=IPAGE+1 - KEY=1 - CALL DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT) - IL1=NVARS+5 - IHI=IHI-LPG - GO TO 20039 -20040 PAGEPL=IHI.EQ.(LMX-2) - GO TO 20023 -20025 L=1 - N20047=MRELAS - GO TO 20048 -20047 L=L+1 -20048 IF ((N20047-L).LT.0) GO TO 20049 - J=IBASIS(L) - IF (.NOT.(J.GT.NVARS)) GO TO 20051 - I=J-NVARS - IF (.NOT.(IND(J).EQ.2)) GO TO 20054 - WW(I)=WW(I)+ONE - GO TO 20055 -20054 WW(I)=WW(I)-ONE -20055 CONTINUE - CONTINUE -20051 CONTINUE - GO TO 20047 -C -C PERTURB RIGHT-SIDE IN UNITS OF LAST BIT POSITIONS. -20049 I=1 - N20057=MRELAS - GO TO 20058 -20057 I=I+1 -20058 IF ((N20057-I).LT.0) GO TO 20059 - WW(I)=WW(I)+TEN*EPS*WW(I) - GO TO 20057 -20059 TRANS = .FALSE. - CALL LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) - I=1 - N20061=MRELAS - GO TO 20062 -20061 I=I+1 -20062 IF ((N20061-I).LT.0) GO TO 20063 - ERP(I)=MAX(ABS(WW(I)-ONE),EPS)*TUNE -C -C SYSTEM BECOMES SINGULAR WHEN ACCURACY OF SOLUTION IS .GT. FACTOR. -C THIS VALUE (FACTOR) MIGHT NEED TO BE CHANGED. - SINGLR=SINGLR.OR.(ERP(I).GE.FACTOR) - GO TO 20061 -20063 CONTINUE -C -20020 RETURN - END diff --git a/slatec/dplpdm.f b/slatec/dplpdm.f deleted file mode 100644 index f1e7225..0000000 --- a/slatec/dplpdm.f +++ /dev/null @@ -1,113 +0,0 @@ -*DECK DPLPDM - SUBROUTINE DPLPDM (MRELAS, NVARS, LMX, LBM, NREDC, INFO, IOPT, - + IBASIS, IMAT, IBRC, IPR, IWR, IND, IBB, ANORM, EPS, UU, GG, - + AMAT, BASMAT, CSC, WR, SINGLR, REDBAS) -C***BEGIN PROLOGUE DPLPDM -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSPLP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (SPLPDM-S, DPLPDM-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THIS SUBPROGRAM IS FROM THE DSPLP( ) PACKAGE. IT PERFORMS THE -C TASK OF DEFINING THE ENTRIES OF THE BASIS MATRIX AND -C DECOMPOSING IT USING THE LA05 PACKAGE. -C IT IS THE MAIN PART OF THE PROCEDURE (DECOMPOSE BASIS MATRIX). -C -C***SEE ALSO DSPLP -C***ROUTINES CALLED DASUM, DPNNZR, LA05AD, XERMSG -C***COMMON BLOCKS LA05DD -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890605 Added DASUM to list of DOUBLE PRECISION variables. -C 890605 Removed unreferenced labels. (WRB) -C 891009 Removed unreferenced variable. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls, convert do-it-yourself -C DO loops to DO loops. (RWC) -C***END PROLOGUE DPLPDM - INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*) - DOUBLE PRECISION AIJ,AMAT(*),BASMAT(*),CSC(*),WR(*),ANORM,DASUM, - * EPS,GG,ONE,SMALL,UU,ZERO - LOGICAL SINGLR,REDBAS - CHARACTER*16 XERN3 -C -C COMMON BLOCK USED BY LA05 () PACKAGE.. - COMMON /LA05DD/ SMALL,LP,LENL,LENU,NCP,LROW,LCOL -C -C***FIRST EXECUTABLE STATEMENT DPLPDM - ZERO = 0.D0 - ONE = 1.D0 -C -C DEFINE BASIS MATRIX BY COLUMNS FOR SPARSE MATRIX EQUATION SOLVER. -C THE LA05AD() SUBPROGRAM REQUIRES THE NONZERO ENTRIES OF THE MATRIX -C TOGETHER WITH THE ROW AND COLUMN INDICES. -C - NZBM = 0 -C -C DEFINE DEPENDENT VARIABLE COLUMNS. THESE ARE -C COLS. OF THE IDENTITY MATRIX AND IMPLICITLY GENERATED. -C - DO 20 K = 1,MRELAS - J = IBASIS(K) - IF (J.GT.NVARS) THEN - NZBM = NZBM+1 - IF (IND(J).EQ.2) THEN - BASMAT(NZBM) = ONE - ELSE - BASMAT(NZBM) = -ONE - ENDIF - IBRC(NZBM,1) = J-NVARS - IBRC(NZBM,2) = K - ELSE -C -C DEFINE THE INDEP. VARIABLE COLS. THIS REQUIRES RETRIEVING -C THE COLS. FROM THE SPARSE MATRIX DATA STRUCTURE. -C - I = 0 - 10 CALL DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,J) - IF (I.GT.0) THEN - NZBM = NZBM+1 - BASMAT(NZBM) = AIJ*CSC(J) - IBRC(NZBM,1) = I - IBRC(NZBM,2) = K - GO TO 10 - ENDIF - ENDIF - 20 CONTINUE -C - SINGLR = .FALSE. -C -C RECOMPUTE MATRIX NORM USING CRUDE NORM = SUM OF MAGNITUDES. -C - ANORM = DASUM(NZBM,BASMAT,1) - SMALL = EPS*ANORM -C -C GET AN L-U FACTORIZATION OF THE BASIS MATRIX. -C - NREDC = NREDC+1 - REDBAS = .TRUE. - CALL LA05AD(BASMAT,IBRC,NZBM,LBM,MRELAS,IPR,IWR,WR,GG,UU) -C -C CHECK RETURN VALUE OF ERROR FLAG, GG. -C - IF (GG.GE.ZERO) RETURN - IF (GG.EQ.(-7.)) THEN - CALL XERMSG ('SLATEC', 'DPLPDM', - * 'IN DSPLP, SHORT ON STORAGE FOR LA05AD. ' // - * 'USE PRGOPT(*) TO GIVE MORE.', 28, IOPT) - INFO = -28 - ELSEIF (GG.EQ.(-5.)) THEN - SINGLR = .TRUE. - ELSE - WRITE (XERN3, '(1PE15.6)') GG - CALL XERMSG ('SLATEC', 'DPLPDM', - * 'IN DSPLP, LA05AD RETURNED ERROR FLAG = ' // XERN3, - * 27, IOPT) - INFO = -27 - ENDIF - RETURN - END diff --git a/slatec/dplpfe.f b/slatec/dplpfe.f deleted file mode 100644 index 37be513..0000000 --- a/slatec/dplpfe.f +++ /dev/null @@ -1,164 +0,0 @@ -*DECK DPLPFE - SUBROUTINE DPLPFE (MRELAS, NVARS, LMX, LBM, IENTER, IBASIS, IMAT, - + IBRC, IPR, IWR, IND, IBB, ERDNRM, EPS, GG, DULNRM, DIRNRM, - + AMAT, BASMAT, CSC, WR, WW, BL, BU, RZ, RG, COLNRM, DUALS, - + FOUND) -C***BEGIN PROLOGUE DPLPFE -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSPLP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (SPLPFE-S, DPLPFE-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO -C DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. -C -C USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. -C /REAL (12 BLANKS)/DOUBLE PRECISION/,/SASUM/DASUM/, -C /SCOPY/DCOPY/. -C -C THIS SUBPROGRAM IS PART OF THE DSPLP( ) PACKAGE. -C IT IMPLEMENTS THE PROCEDURE (FIND VARIABLE TO ENTER BASIS -C AND GET SEARCH DIRECTION). -C REVISED 811130-1100 -C REVISED YYMMDD-HHMM -C -C***SEE ALSO DSPLP -C***ROUTINES CALLED DASUM, DCOPY, DPRWPG, IDLOC, LA05BD -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890605 Removed unreferenced labels. (WRB) -C 890606 Changed references from IPLOC to IDLOC. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DPLPFE - INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*) - DOUBLE PRECISION AMAT(*),BASMAT(*),CSC(*),WR(*),WW(*),BL(*),BU(*), - * RZ(*),RG(*),COLNRM(*),DUALS(*),CNORM,DIRNRM,DULNRM,EPS,ERDNRM,GG, - * ONE,RATIO,RCOST,RMAX,ZERO - DOUBLE PRECISION DASUM - LOGICAL FOUND,TRANS -C***FIRST EXECUTABLE STATEMENT DPLPFE - LPG=LMX-(NVARS+4) - ZERO=0.D0 - ONE=1.D0 - RMAX=ZERO - FOUND=.FALSE. - I=MRELAS+1 - N20002=MRELAS+NVARS - GO TO 20003 -20002 I=I+1 -20003 IF ((N20002-I).LT.0) GO TO 20004 - J=IBASIS(I) -C -C IF J=IBASIS(I) .LT. 0 THEN THE VARIABLE LEFT AT A ZERO LEVEL -C AND IS NOT CONSIDERED AS A CANDIDATE TO ENTER. - IF (.NOT.(J.GT.0)) GO TO 20006 -C -C DO NOT CONSIDER VARIABLES CORRESPONDING TO UNBOUNDED STEP LENGTHS. - IF (.NOT.(IBB(J).EQ.0)) GO TO 20009 - GO TO 20002 -20009 CONTINUE -C -C IF A VARIABLE CORRESPONDS TO AN EQUATION(IND=3 AND BL=BU), -C THEN DO NOT CONSIDER IT AS A CANDIDATE TO ENTER. - IF (.NOT.(IND(J).EQ.3)) GO TO 20012 - IF (.NOT.((BU(J)-BL(J)).LE.EPS*(ABS(BL(J))+ABS(BU(J))))) - *GO TO 20015 - GO TO 20002 -20015 CONTINUE - CONTINUE -20012 CONTINUE - RCOST=RZ(J) -C -C IF VARIABLE IS AT UPPER BOUND IT CAN ONLY DECREASE. THIS -C ACCOUNTS FOR THE POSSIBLE CHANGE OF SIGN. - IF(MOD(IBB(J),2).EQ.0) RCOST=-RCOST -C -C IF THE VARIABLE IS FREE, USE THE NEGATIVE MAGNITUDE OF THE -C REDUCED COST FOR THAT VARIABLE. - IF(IND(J).EQ.4) RCOST=-ABS(RCOST) - CNORM=ONE - IF(J.LE.NVARS)CNORM=COLNRM(J) -C -C TEST FOR NEGATIVITY OF REDUCED COSTS. - IF (.NOT.(RCOST+ERDNRM*DULNRM*CNORM.LT.ZERO)) GO TO 20018 - FOUND=.TRUE. - RATIO=RCOST**2/RG(J) - IF (.NOT.(RATIO.GT.RMAX)) GO TO 20021 - RMAX=RATIO - IENTER=I -20021 CONTINUE - CONTINUE -20018 CONTINUE - CONTINUE -20006 GO TO 20002 -C -C USE COL. CHOSEN TO COMPUTE SEARCH DIRECTION. -20004 IF (.NOT.(FOUND)) GO TO 20024 - J=IBASIS(IENTER) - WW(1)=ZERO - CALL DCOPY(MRELAS,WW,0,WW,1) - IF (.NOT.(J.LE.NVARS)) GO TO 20027 - IF (.NOT.(J.EQ.1)) GO TO 20030 - ILOW=NVARS+5 - GO TO 20031 -20030 ILOW=IMAT(J+3)+1 -20031 CONTINUE - IL1=IDLOC(ILOW,AMAT,IMAT) - IF (.NOT.(IL1.GE.LMX-1)) GO TO 20033 - ILOW=ILOW+2 - IL1=IDLOC(ILOW,AMAT,IMAT) -20033 CONTINUE - IPAGE=ABS(IMAT(LMX-1)) - IHI=IMAT(J+4)-(ILOW-IL1) -20036 IU1=MIN(LMX-2,IHI) - IF (.NOT.(IL1.GT.IU1)) GO TO 20038 - GO TO 20037 -20038 CONTINUE - DO 30 I=IL1,IU1 - WW(IMAT(I))=AMAT(I)*CSC(J) -30 CONTINUE - IF (.NOT.(IHI.LE.LMX-2)) GO TO 20041 - GO TO 20037 -20041 CONTINUE - IPAGE=IPAGE+1 - KEY=1 - CALL DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT) - IL1=NVARS+5 - IHI=IHI-LPG - GO TO 20036 -20037 GO TO 20028 -20027 IF (.NOT.(IND(J).EQ.2)) GO TO 20044 - WW(J-NVARS)=ONE - GO TO 20045 -20044 WW(J-NVARS)=-ONE -20045 CONTINUE - CONTINUE -C -C COMPUTE SEARCH DIRECTION. -20028 TRANS=.FALSE. - CALL LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) -C -C THE SEARCH DIRECTION REQUIRES THE FOLLOWING SIGN CHANGE IF EITHER -C VARIABLE ENTERING IS AT ITS UPPER BOUND OR IS FREE AND HAS -C POSITIVE REDUCED COST. - IF (.NOT.(MOD(IBB(J),2).EQ.0.OR.(IND(J).EQ.4 .AND. RZ(J).GT.ZERO)) - *) GO TO 20047 - I=1 - N20050=MRELAS - GO TO 20051 -20050 I=I+1 -20051 IF ((N20050-I).LT.0) GO TO 20052 - WW(I)=-WW(I) - GO TO 20050 -20052 CONTINUE -20047 DIRNRM=DASUM(MRELAS,WW,1) -C -C COPY CONTENTS OF WR(*) TO DUALS(*) FOR USE IN -C ADD-DROP (EXCHANGE) STEP, LA05CD( ). - CALL DCOPY(MRELAS,WR,1,DUALS,1) -20024 RETURN - END diff --git a/slatec/dplpfl.f b/slatec/dplpfl.f deleted file mode 100644 index 94d00a1..0000000 --- a/slatec/dplpfl.f +++ /dev/null @@ -1,157 +0,0 @@ -*DECK DPLPFL - SUBROUTINE DPLPFL (MRELAS, NVARS, IENTER, ILEAVE, IBASIS, IND, - + IBB, THETA, DIRNRM, RPRNRM, CSC, WW, BL, BU, ERP, RPRIM, - + PRIMAL, FINITE, ZEROLV) -C***BEGIN PROLOGUE DPLPFL -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSPLP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (SPLPFL-S, DPLPFL-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO -C DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. -C -C USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. -C /REAL (12 BLANKS)/DOUBLE PRECISION/. -C -C THIS SUBPROGRAM IS PART OF THE DSPLP( ) PACKAGE. -C IT IMPLEMENTS THE PROCEDURE (CHOOSE VARIABLE TO LEAVE BASIS). -C REVISED 811130-1045 -C REVISED YYMMDD-HHMM -C -C***SEE ALSO DSPLP -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890605 Removed unreferenced labels. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DPLPFL - INTEGER IBASIS(*),IND(*),IBB(*) - DOUBLE PRECISION CSC(*),WW(*),BL(*),BU(*),ERP(*),RPRIM(*), - * PRIMAL(*),BOUND,DIRNRM,RATIO,RPRNRM,THETA,ZERO - LOGICAL FINITE,ZEROLV -C***FIRST EXECUTABLE STATEMENT DPLPFL - ZERO=0.D0 -C -C SEE IF THE ENTERING VARIABLE IS RESTRICTING THE STEP LENGTH -C BECAUSE OF AN UPPER BOUND. - FINITE=.FALSE. - J=IBASIS(IENTER) - IF (.NOT.(IND(J).EQ.3)) GO TO 20002 - THETA=BU(J)-BL(J) - IF(J.LE.NVARS)THETA=THETA/CSC(J) - FINITE=.TRUE. - ILEAVE=IENTER -C -C NOW USE THE BASIC VARIABLES TO POSSIBLY RESTRICT THE STEP -C LENGTH EVEN FURTHER. -20002 I=1 - N20005=MRELAS - GO TO 20006 -20005 I=I+1 -20006 IF ((N20005-I).LT.0) GO TO 20007 - J=IBASIS(I) -C -C IF THIS IS A FREE VARIABLE, DO NOT USE IT TO -C RESTRICT THE STEP LENGTH. - IF (.NOT.(IND(J).EQ.4)) GO TO 20009 - GO TO 20005 -C -C IF DIRECTION COMPONENT IS ABOUT ZERO, IGNORE IT FOR COMPUTING -C THE STEP LENGTH. -20009 IF (.NOT.(ABS(WW(I)).LE.DIRNRM*ERP(I))) GO TO 20012 - GO TO 20005 -20012 IF (.NOT.(WW(I).GT.ZERO)) GO TO 20015 -C -C IF RPRIM(I) IS ESSENTIALLY ZERO, SET RATIO TO ZERO AND EXIT LOOP. - IF (.NOT.(ABS(RPRIM(I)).LE.RPRNRM*ERP(I))) GO TO 20018 - THETA=ZERO - ILEAVE=I - FINITE=.TRUE. - GO TO 20008 -C -C THE VALUE OF RPRIM(I) WILL DECREASE ONLY TO ITS LOWER BOUND OR -C ONLY TO ITS UPPER BOUND. IF IT DECREASES TO ITS -C UPPER BOUND, THEN RPRIM(I) HAS ALREADY BEEN TRANSLATED -C TO ITS UPPER BOUND AND NOTHING NEEDS TO BE DONE TO IBB(J). -20018 IF (.NOT.(RPRIM(I).GT.ZERO)) GO TO 10001 - RATIO=RPRIM(I)/WW(I) - IF (.NOT.(.NOT.FINITE)) GO TO 20021 - ILEAVE=I - THETA=RATIO - FINITE=.TRUE. - GO TO 20022 -20021 IF (.NOT.(RATIO.LT.THETA)) GO TO 10002 - ILEAVE=I - THETA=RATIO -10002 CONTINUE -20022 CONTINUE - GO TO 20019 -C -C THE VALUE RPRIM(I).LT.ZERO WILL NOT RESTRICT THE STEP. -10001 CONTINUE -C -C THE DIRECTION COMPONENT IS NEGATIVE, THEREFORE THE VARIABLE WILL -C INCREASE. -20019 GO TO 20016 -C -C IF THE VARIABLE IS LESS THAN ITS LOWER BOUND, IT CAN -C INCREASE ONLY TO ITS LOWER BOUND. -20015 IF (.NOT.(PRIMAL(I+NVARS).LT.ZERO)) GO TO 20024 - RATIO=RPRIM(I)/WW(I) - IF (RATIO.LT.ZERO) RATIO=ZERO - IF (.NOT.(.NOT.FINITE)) GO TO 20027 - ILEAVE=I - THETA=RATIO - FINITE=.TRUE. - GO TO 20028 -20027 IF (.NOT.(RATIO.LT.THETA)) GO TO 10003 - ILEAVE=I - THETA=RATIO -10003 CONTINUE -20028 CONTINUE -C -C IF THE BASIC VARIABLE IS FEASIBLE AND IS NOT AT ITS UPPER BOUND, -C THEN IT CAN INCREASE TO ITS UPPER BOUND. - GO TO 20025 -20024 IF (.NOT.(IND(J).EQ.3 .AND. PRIMAL(I+NVARS).EQ.ZERO)) GO TO 10004 - BOUND=BU(J)-BL(J) - IF(J.LE.NVARS) BOUND=BOUND/CSC(J) - RATIO=(BOUND-RPRIM(I))/(-WW(I)) - IF (.NOT.(.NOT.FINITE)) GO TO 20030 - ILEAVE=-I - THETA=RATIO - FINITE=.TRUE. - GO TO 20031 -20030 IF (.NOT.(RATIO.LT.THETA)) GO TO 10005 - ILEAVE=-I - THETA=RATIO -10005 CONTINUE -20031 CONTINUE - CONTINUE -10004 CONTINUE -20025 CONTINUE -20016 GO TO 20005 -20007 CONTINUE -C -C IF STEP LENGTH IS FINITE, SEE IF STEP LENGTH IS ABOUT ZERO. -20008 IF (.NOT.(FINITE)) GO TO 20033 - ZEROLV=.TRUE. - I=1 - N20036=MRELAS - GO TO 20037 -20036 I=I+1 -20037 IF ((N20036-I).LT.0) GO TO 20038 - ZEROLV=ZEROLV.AND. ABS(THETA*WW(I)).LE.ERP(I)*RPRNRM - IF (.NOT.(.NOT. ZEROLV)) GO TO 20040 - GO TO 20039 -20040 GO TO 20036 -20038 CONTINUE -20039 CONTINUE -20033 CONTINUE - RETURN - END diff --git a/slatec/dplpmn.f b/slatec/dplpmn.f deleted file mode 100644 index b3814f3..0000000 --- a/slatec/dplpmn.f +++ /dev/null @@ -1,988 +0,0 @@ -*DECK DPLPMN - SUBROUTINE DPLPMN (DUSRMT, MRELAS, NVARS, COSTS, PRGOPT, DATTRV, - + BL, BU, IND, INFO, PRIMAL, DUALS, AMAT, CSC, COLNRM, ERD, ERP, - + BASMAT, WR, RZ, RG, RPRIM, RHS, WW, LMX, LBM, IBASIS, IBB, - + IMAT, IBRC, IPR, IWR) -C***BEGIN PROLOGUE DPLPMN -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSPLP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (SPLPMN-S, DPLPMN-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C MARVEL OPTION(S).. OUTPUT=YES/NO TO ELIMINATE PRINTED OUTPUT. -C THIS DOES NOT APPLY TO THE CALLS TO THE ERROR PROCESSOR. -C -C MAIN SUBROUTINE FOR DSPLP PACKAGE. -C -C***SEE ALSO DSPLP -C***ROUTINES CALLED DASUM, DCOPY, DDOT, DPINCW, DPINIT, DPINTM, DPLPCE, -C DPLPDM, DPLPFE, DPLPFL, DPLPMU, DPLPUP, DPNNZR, -C DPOPT, DPRWPG, DVOUT, IVOUT, LA05BD, SCLOSM, XERMSG -C***COMMON BLOCKS LA05DD -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890605 Removed unreferenced labels. (WRB) -C 891009 Removed unreferenced variable. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C***END PROLOGUE DPLPMN - DOUBLE PRECISION ABIG,AIJ,AMAT(*),ANORM,ASMALL,BASMAT(*), - * BL(*),BU(*),COLNRM(*),COSTS(*),COSTSC,CSC(*),DATTRV(*), - * DIRNRM,DUALS(*),DULNRM,EPS,TUNE,ERD(*),ERDNRM,ERP(*),FACTOR,GG, - * ONE,PRGOPT(*),PRIMAL(*),RESNRM,RG(*),RHS(*),RHSNRM,ROPT(07), - * RPRIM(*),RPRNRM,RZ(*),RZJ,SCALR,SCOSTS,SIZE,SMALL,THETA, - * TOLLS,UPBND,UU,WR(*),WW(*),XLAMDA,XVAL,ZERO,RDUM(01),TOLABS - DOUBLE PRECISION DDOT,DASUM -C - INTEGER IBASIS(*),IBB(*),IBRC(LBM,2),IMAT(*),IND(*), - * IPR(*),IWR(*),INTOPT(08),IDUM(01) -C -C ARRAY LOCAL VARIABLES -C NAME(LENGTH) DESCRIPTION -C -C COSTS(NVARS) COST COEFFICIENTS -C PRGOPT( ) OPTION VECTOR -C DATTRV( ) DATA TRANSFER VECTOR -C PRIMAL(NVARS+MRELAS) AS OUTPUT IT IS PRIMAL SOLUTION OF LP. -C INTERNALLY, THE FIRST NVARS POSITIONS HOLD -C THE COLUMN CHECK SUMS. THE NEXT MRELAS -C POSITIONS HOLD THE CLASSIFICATION FOR THE -C BASIC VARIABLES -1 VIOLATES LOWER -C BOUND, 0 FEASIBLE, +1 VIOLATES UPPER BOUND -C DUALS(MRELAS+NVARS) DUAL SOLUTION. INTERNALLY HOLDS R.H. SIDE -C AS FIRST MRELAS ENTRIES. -C AMAT(LMX) SPARSE FORM OF DATA MATRIX -C IMAT(LMX) SPARSE FORM OF DATA MATRIX -C BL(NVARS+MRELAS) LOWER BOUNDS FOR VARIABLES -C BU(NVARS+MRELAS) UPPER BOUNDS FOR VARIABLES -C IND(NVARS+MRELAS) INDICATOR FOR VARIABLES -C CSC(NVARS) COLUMN SCALING -C IBASIS(NVARS+MRELAS) COLS. 1-MRELAS ARE BASIC, REST ARE NON-BASIC -C IBB(NVARS+MRELAS) INDICATOR FOR NON-BASIC VARS., POLARITY OF -C VARS., AND POTENTIALLY INFINITE VARS. -C IF IBB(J).LT.0, VARIABLE J IS BASIC -C IF IBB(J).GT.0, VARIABLE J IS NON-BASIC -C IF IBB(J).EQ.0, VARIABLE J HAS TO BE IGNORED -C BECAUSE IT WOULD CAUSE UNBOUNDED SOLN. -C WHEN MOD(IBB(J),2).EQ.0, VARIABLE IS AT ITS -C UPPER BOUND, OTHERWISE IT IS AT ITS LOWER -C BOUND -C COLNRM(NVARS) NORM OF COLUMNS -C ERD(MRELAS) ERRORS IN DUAL VARIABLES -C ERP(MRELAS) ERRORS IN PRIMAL VARIABLES -C BASMAT(LBM) BASIS MATRIX FOR HARWELL SPARSE CODE -C IBRC(LBM,2) ROW AND COLUMN POINTERS FOR BASMAT(*) -C IPR(2*MRELAS) WORK ARRAY FOR HARWELL SPARSE CODE -C IWR(8*MRELAS) WORK ARRAY FOR HARWELL SPARSE CODE -C WR(MRELAS) WORK ARRAY FOR HARWELL SPARSE CODE -C RZ(NVARS+MRELAS) REDUCED COSTS -C RPRIM(MRELAS) INTERNAL PRIMAL SOLUTION -C RG(NVARS+MRELAS) COLUMN WEIGHTS -C WW(MRELAS) WORK ARRAY -C RHS(MRELAS) HOLDS TRANSLATED RIGHT HAND SIDE -C -C SCALAR LOCAL VARIABLES -C NAME TYPE DESCRIPTION -C -C LMX INTEGER LENGTH OF AMAT(*) -C LPG INTEGER LENGTH OF PAGE FOR AMAT(*) -C EPS DOUBLE MACHINE PRECISION -C TUNE DOUBLE PARAMETER TO SCALE ERROR ESTIMATES -C TOLLS DOUBLE RELATIVE TOLERANCE FOR SMALL RESIDUALS -C TOLABS DOUBLE ABSOLUTE TOLERANCE FOR SMALL RESIDUALS. -C USED IF RELATIVE ERROR TEST FAILS. -C IN CONSTRAINT EQUATIONS -C FACTOR DOUBLE .01--DETERMINES IF BASIS IS SINGULAR -C OR COMPONENT IS FEASIBLE. MAY NEED TO -C BE INCREASED TO 1.D0 ON SHORT WORD -C LENGTH MACHINES. -C ASMALL DOUBLE LOWER BOUND FOR NON-ZERO MAGN. IN AMAT(*) -C ABIG DOUBLE UPPER BOUND FOR NON-ZERO MAGN. IN AMAT(*) -C MXITLP INTEGER MAXIMUM NUMBER OF ITERATIONS FOR LP -C ITLP INTEGER ITERATION COUNTER FOR TOTAL LP ITERS -C COSTSC DOUBLE COSTS(*) SCALING -C SCOSTS DOUBLE TEMP LOC. FOR COSTSC. -C XLAMDA DOUBLE WEIGHT PARAMETER FOR PEN. METHOD. -C ANORM DOUBLE NORM OF DATA MATRIX AMAT(*) -C RPRNRM DOUBLE NORM OF THE SOLUTION -C DULNRM DOUBLE NORM OF THE DUALS -C ERDNRM DOUBLE NORM OF ERROR IN DUAL VARIABLES -C DIRNRM DOUBLE NORM OF THE DIRECTION VECTOR -C RHSNRM DOUBLE NORM OF TRANSLATED RIGHT HAND SIDE VECTOR -C RESNRM DOUBLE NORM OF RESIDUAL VECTOR FOR CHECKING -C FEASIBILITY -C NZBM INTEGER NUMBER OF NON-ZEROS IN BASMAT(*) -C LBM INTEGER LENGTH OF BASMAT(*) -C SMALL DOUBLE EPS*ANORM USED IN HARWELL SPARSE CODE -C LP INTEGER USED IN HARWELL LA05*() PACK AS OUTPUT -C FILE NUMBER. SET=I1MACH(4) NOW. -C UU DOUBLE 0.1--USED IN HARWELL SPARSE CODE -C FOR RELATIVE PIVOTING TOLERANCE. -C GG DOUBLE OUTPUT INFO FLAG IN HARWELL SPARSE CODE -C IPLACE INTEGER INTEGER USED BY SPARSE MATRIX CODES -C IENTER INTEGER NEXT COLUMN TO ENTER BASIS -C NREDC INTEGER NO. OF FULL REDECOMPOSITIONS -C KPRINT INTEGER LEVEL OF OUTPUT, =0-3 -C IDG INTEGER FORMAT AND PRECISION OF OUTPUT -C ITBRC INTEGER NO. OF ITERS. BETWEEN RECALCULATING -C THE ERROR IN THE PRIMAL SOLUTION. -C NPP INTEGER NO. OF NEGATIVE REDUCED COSTS REQUIRED -C IN PARTIAL PRICING -C JSTRT INTEGER STARTING PLACE FOR PARTIAL PRICING. -C - LOGICAL COLSCP,SAVEDT,CONTIN,CSTSCP,UNBND, - * FEAS,FINITE,FOUND,MINPRB,REDBAS, - * SINGLR,SIZEUP,STPEDG,TRANS,USRBAS,ZEROLV,LOPT(08) - CHARACTER*8 XERN1, XERN2 - EQUIVALENCE (CONTIN,LOPT(1)),(USRBAS,LOPT(2)), - * (SIZEUP,LOPT(3)),(SAVEDT,LOPT(4)),(COLSCP,LOPT(5)), - * (CSTSCP,LOPT(6)),(MINPRB,LOPT(7)),(STPEDG,LOPT(8)), - * (IDG,INTOPT(1)),(IPAGEF,INTOPT(2)),(ISAVE,INTOPT(3)), - * (MXITLP,INTOPT(4)),(KPRINT,INTOPT(5)),(ITBRC,INTOPT(6)), - * (NPP,INTOPT(7)),(LPRG,INTOPT(8)),(EPS,ROPT(1)),(ASMALL,ROPT(2)), - * (ABIG,ROPT(3)),(COSTSC,ROPT(4)),(TOLLS,ROPT(5)),(TUNE,ROPT(6)), - * (TOLABS,ROPT(7)) -C -C COMMON BLOCK USED BY LA05 () PACKAGE.. - COMMON /LA05DD/ SMALL,LP,LENL,LENU,NCP,LROW,LCOL - EXTERNAL DUSRMT -C -C SET LP=0 SO NO ERROR MESSAGES WILL PRINT WITHIN LA05 () PACKAGE. -C***FIRST EXECUTABLE STATEMENT DPLPMN - LP=0 -C -C THE VALUES ZERO AND ONE. - ZERO=0.D0 - ONE=1.D0 - FACTOR=0.01D0 - LPG=LMX-(NVARS+4) - IOPT=1 - INFO=0 - UNBND=.FALSE. - JSTRT=1 -C -C PROCESS USER OPTIONS IN PRGOPT(*). -C CHECK THAT ANY USER-GIVEN CHANGES ARE WELL-DEFINED. - CALL DPOPT(PRGOPT,MRELAS,NVARS,INFO,CSC,IBASIS,ROPT,INTOPT,LOPT) - IF (.NOT.(INFO.LT.0)) GO TO 20002 - GO TO 30001 -20002 IF (.NOT.(CONTIN)) GO TO 20003 - GO TO 30002 -20006 GO TO 20004 -C -C INITIALIZE SPARSE DATA MATRIX, AMAT(*) AND IMAT(*). -20003 CALL DPINTM(MRELAS,NVARS,AMAT,IMAT,LMX,IPAGEF) -C -C UPDATE MATRIX DATA AND CHECK BOUNDS FOR CONSISTENCY. -20004 CALL DPLPUP(DUSRMT,MRELAS,NVARS,PRGOPT,DATTRV, - * BL,BU,IND,INFO,AMAT,IMAT,SIZEUP,ASMALL,ABIG) - IF (.NOT.(INFO.LT.0)) GO TO 20007 - GO TO 30001 -C -C++ CODE FOR OUTPUT=YES IS ACTIVE -20007 IF (.NOT.(KPRINT.GE.1)) GO TO 20008 - GO TO 30003 -20011 CONTINUE -C++ CODE FOR OUTPUT=NO IS INACTIVE -C++ END -C -C INITIALIZATION. SCALE DATA, NORMALIZE BOUNDS, FORM COLUMN -C CHECK SUMS, AND FORM INITIAL BASIS MATRIX. -20008 CALL DPINIT(MRELAS,NVARS,COSTS,BL,BU,IND,PRIMAL,INFO, - * AMAT,CSC,COSTSC,COLNRM,XLAMDA,ANORM,RHS,RHSNRM, - * IBASIS,IBB,IMAT,LOPT) - IF (.NOT.(INFO.LT.0)) GO TO 20012 - GO TO 30001 -C -20012 NREDC=0 - ASSIGN 20013 TO NPR004 - GO TO 30004 -20013 IF (.NOT.(SINGLR)) GO TO 20014 - NERR=23 - CALL XERMSG ('SLATEC', 'DPLPMN', - + 'IN DSPLP, A SINGULAR INITIAL BASIS WAS ENCOUNTERED.', NERR, - + IOPT) - INFO=-NERR - GO TO 30001 -20014 ASSIGN 20018 TO NPR005 - GO TO 30005 -20018 ASSIGN 20019 TO NPR006 - GO TO 30006 -20019 ASSIGN 20020 TO NPR007 - GO TO 30007 -20020 IF (.NOT.(USRBAS)) GO TO 20021 - ASSIGN 20024 TO NPR008 - GO TO 30008 -20024 IF (.NOT.(.NOT.FEAS)) GO TO 20025 - NERR=24 - CALL XERMSG ('SLATEC', 'DPLPMN', - + 'IN DSPLP, AN INFEASIBLE INITIAL BASIS WAS ENCOUNTERED.', - + NERR, IOPT) - INFO=-NERR - GO TO 30001 -20025 CONTINUE -20021 ITLP=0 -C -C LAMDA HAS BEEN SET TO A CONSTANT, PERFORM PENALTY METHOD. - ASSIGN 20029 TO NPR009 - GO TO 30009 -20029 ASSIGN 20030 TO NPR010 - GO TO 30010 -20030 ASSIGN 20031 TO NPR006 - GO TO 30006 -20031 ASSIGN 20032 TO NPR008 - GO TO 30008 -20032 IF (.NOT.(.NOT.FEAS)) GO TO 20033 -C -C SET LAMDA TO INFINITY BY SETTING COSTSC TO ZERO (SAVE THE VALUE OF -C COSTSC) AND PERFORM STANDARD PHASE-1. - IF(KPRINT.GE.2)CALL IVOUT(0,IDUM,'('' ENTER STANDARD PHASE-1'')', - *IDG) - SCOSTS=COSTSC - COSTSC=ZERO - ASSIGN 20036 TO NPR007 - GO TO 30007 -20036 ASSIGN 20037 TO NPR009 - GO TO 30009 -20037 ASSIGN 20038 TO NPR010 - GO TO 30010 -20038 ASSIGN 20039 TO NPR006 - GO TO 30006 -20039 ASSIGN 20040 TO NPR008 - GO TO 30008 -20040 IF (.NOT.(FEAS)) GO TO 20041 -C -C SET LAMDA TO ZERO, COSTSC=SCOSTS, PERFORM STANDARD PHASE-2. - IF(KPRINT.GT.1)CALL IVOUT(0,IDUM,'('' ENTER STANDARD PHASE-2'')', - *IDG) - XLAMDA=ZERO - COSTSC=SCOSTS - ASSIGN 20044 TO NPR009 - GO TO 30009 -20044 CONTINUE -20041 GO TO 20034 -C CHECK IF ANY BASIC VARIABLES ARE STILL CLASSIFIED AS -C INFEASIBLE. IF ANY ARE, THEN THIS MAY NOT YET BE AN -C OPTIMAL POINT. THEREFORE SET LAMDA TO ZERO AND TRY -C TO PERFORM MORE SIMPLEX STEPS. -20033 I=1 - N20046=MRELAS - GO TO 20047 -20046 I=I+1 -20047 IF ((N20046-I).LT.0) GO TO 20048 - IF (PRIMAL(I+NVARS).NE.ZERO) GO TO 20045 - GO TO 20046 -20048 GO TO 20035 -20045 XLAMDA=ZERO - ASSIGN 20050 TO NPR009 - GO TO 30009 -20050 CONTINUE -20034 CONTINUE -C -20035 ASSIGN 20051 TO NPR011 - GO TO 30011 -20051 IF (.NOT.(FEAS.AND.(.NOT.UNBND))) GO TO 20052 - INFO=1 - GO TO 20053 -20052 IF (.NOT.((.NOT.FEAS).AND.(.NOT.UNBND))) GO TO 10001 - NERR=1 - CALL XERMSG ('SLATEC', 'DPLPMN', - + 'IN DSPLP, THE PROBLEM APPEARS TO BE INFEASIBLE', NERR, IOPT) - INFO=-NERR - GO TO 20053 -10001 IF (.NOT.(FEAS .AND. UNBND)) GO TO 10002 - NERR=2 - CALL XERMSG ('SLATEC', 'DPLPMN', - + 'IN DSPLP, THE PROBLEM APPEARS TO HAVE NO FINITE SOLUTION.', - + NERR, IOPT) - INFO=-NERR - GO TO 20053 -10002 IF (.NOT.((.NOT.FEAS).AND.UNBND)) GO TO 10003 - NERR=3 - CALL XERMSG ('SLATEC', 'DPLPMN', - + 'IN DSPLP, THE PROBLEM APPEARS TO BE INFEASIBLE AND TO ' // - + 'HAVE NO FINITE SOLN.', NERR, IOPT) - INFO=-NERR -10003 CONTINUE -20053 CONTINUE -C - IF (.NOT.(INFO.EQ.(-1) .OR. INFO.EQ.(-3))) GO TO 20055 - SIZE=DASUM(NVARS,PRIMAL,1)*ANORM - SIZE=SIZE/DASUM(NVARS,CSC,1) - SIZE=SIZE+DASUM(MRELAS,PRIMAL(NVARS+1),1) - I=1 - N20058=NVARS+MRELAS - GO TO 20059 -20058 I=I+1 -20059 IF ((N20058-I).LT.0) GO TO 20060 - NX0066=IND(I) - IF (NX0066.LT.1.OR.NX0066.GT.4) GO TO 20066 - GO TO (20062,20063,20064,20065), NX0066 -20062 IF (.NOT.(SIZE+ABS(PRIMAL(I)-BL(I))*FACTOR.EQ.SIZE)) GO TO 20068 - GO TO 20058 -20068 IF (.NOT.(PRIMAL(I).GT.BL(I))) GO TO 10004 - GO TO 20058 -10004 IND(I)=-4 - GO TO 20067 -20063 IF (.NOT.(SIZE+ABS(PRIMAL(I)-BU(I))*FACTOR.EQ.SIZE)) GO TO 20071 - GO TO 20058 -20071 IF (.NOT.(PRIMAL(I).LT.BU(I))) GO TO 10005 - GO TO 20058 -10005 IND(I)=-4 - GO TO 20067 -20064 IF (.NOT.(SIZE+ABS(PRIMAL(I)-BL(I))*FACTOR.EQ.SIZE)) GO TO 20074 - GO TO 20058 -20074 IF (.NOT.(PRIMAL(I).LT.BL(I))) GO TO 10006 - IND(I)=-4 - GO TO 20075 -10006 IF (.NOT.(SIZE+ABS(PRIMAL(I)-BU(I))*FACTOR.EQ.SIZE)) GO TO 10007 - GO TO 20058 -10007 IF (.NOT.(PRIMAL(I).GT.BU(I))) GO TO 10008 - IND(I)=-4 - GO TO 20075 -10008 GO TO 20058 -20075 GO TO 20067 -20065 GO TO 20058 -20066 CONTINUE -20067 GO TO 20058 -20060 CONTINUE -20055 CONTINUE -C - IF (.NOT.(INFO.EQ.(-2) .OR. INFO.EQ.(-3))) GO TO 20077 - J=1 - N20080=NVARS - GO TO 20081 -20080 J=J+1 -20081 IF ((N20080-J).LT.0) GO TO 20082 - IF (.NOT.(IBB(J).EQ.0)) GO TO 20084 - NX0091=IND(J) - IF (NX0091.LT.1.OR.NX0091.GT.4) GO TO 20091 - GO TO (20087,20088,20089,20090), NX0091 -20087 BU(J)=BL(J) - IND(J)=-3 - GO TO 20092 -20088 BL(J)=BU(J) - IND(J)=-3 - GO TO 20092 -20089 GO TO 20080 -20090 BL(J)=ZERO - BU(J)=ZERO - IND(J)=-3 -20091 CONTINUE -20092 CONTINUE -20084 GO TO 20080 -20082 CONTINUE -20077 CONTINUE -C++ CODE FOR OUTPUT=YES IS ACTIVE - IF (.NOT.(KPRINT.GE.1)) GO TO 20093 - ASSIGN 20096 TO NPR012 - GO TO 30012 -20096 CONTINUE -20093 CONTINUE -C++ CODE FOR OUTPUT=NO IS INACTIVE -C++ END - GO TO 30001 -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (COMPUTE RIGHT HAND SIDE) -30010 RHS(1)=ZERO - CALL DCOPY(MRELAS,RHS,0,RHS,1) - J=1 - N20098=NVARS+MRELAS - GO TO 20099 -20098 J=J+1 -20099 IF ((N20098-J).LT.0) GO TO 20100 - NX0106=IND(J) - IF (NX0106.LT.1.OR.NX0106.GT.4) GO TO 20106 - GO TO (20102,20103,20104,20105), NX0106 -20102 SCALR=-BL(J) - GO TO 20107 -20103 SCALR=-BU(J) - GO TO 20107 -20104 SCALR=-BL(J) - GO TO 20107 -20105 SCALR=ZERO -20106 CONTINUE -20107 IF (.NOT.(SCALR.NE.ZERO)) GO TO 20108 - IF (.NOT.(J.LE.NVARS)) GO TO 20111 - I=0 -20114 CALL DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,J) - IF (.NOT.(I.LE.0)) GO TO 20116 - GO TO 20115 -20116 RHS(I)=RHS(I)+AIJ*SCALR - GO TO 20114 -20115 GO TO 20112 -20111 RHS(J-NVARS)=RHS(J-NVARS)-SCALR -20112 CONTINUE -20108 GO TO 20098 -20100 J=1 - N20119=NVARS+MRELAS - GO TO 20120 -20119 J=J+1 -20120 IF ((N20119-J).LT.0) GO TO 20121 - SCALR=ZERO - IF(IND(J).EQ.3.AND.MOD(IBB(J),2).EQ.0) SCALR=BU(J)-BL(J) - IF (.NOT.(SCALR.NE.ZERO)) GO TO 20123 - IF (.NOT.(J.LE.NVARS)) GO TO 20126 - I=0 -20129 CALL DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,J) - IF (.NOT.(I.LE.0)) GO TO 20131 - GO TO 20130 -20131 RHS(I)=RHS(I)-AIJ*SCALR - GO TO 20129 -20130 GO TO 20127 -20126 RHS(J-NVARS)=RHS(J-NVARS)+SCALR -20127 CONTINUE -20123 GO TO 20119 -20121 CONTINUE - GO TO NPR010, (20030,20038) -C PROCEDURE (PERFORM SIMPLEX STEPS) -30009 ASSIGN 20134 TO NPR013 - GO TO 30013 -20134 ASSIGN 20135 TO NPR014 - GO TO 30014 -20135 IF (.NOT.(KPRINT.GT.2)) GO TO 20136 - CALL DVOUT(MRELAS,DUALS,'('' BASIC (INTERNAL) DUAL SOLN.'')',IDG) - CALL DVOUT(NVARS+MRELAS,RZ,'('' REDUCED COSTS'')',IDG) -20136 CONTINUE -20139 ASSIGN 20141 TO NPR015 - GO TO 30015 -20141 IF (.NOT.(.NOT. FOUND)) GO TO 20142 - GO TO 30016 -20145 CONTINUE -20142 IF (.NOT.(FOUND)) GO TO 20146 - IF (KPRINT.GE.3) CALL DVOUT(MRELAS,WW,'('' SEARCH DIRECTION'')', - *IDG) - GO TO 30017 -20149 IF (.NOT.(FINITE)) GO TO 20150 - GO TO 30018 -20153 ASSIGN 20154 TO NPR005 - GO TO 30005 -20154 GO TO 20151 -20150 UNBND=.TRUE. - IBB(IBASIS(IENTER))=0 -20151 GO TO 20147 -20146 GO TO 20140 -20147 ITLP=ITLP+1 - GO TO 30019 -20155 GO TO 20139 -20140 CONTINUE - GO TO NPR009, (20029,20037,20044,20050) -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (RETRIEVE SAVED DATA FROM FILE ISAVE) -30002 LPR=NVARS+4 - REWIND ISAVE - READ(ISAVE) (AMAT(I),I=1,LPR),(IMAT(I),I=1,LPR) - KEY=2 - IPAGE=1 - GO TO 20157 -20156 IF (NP.LT.0) GO TO 20158 -20157 LPR1=LPR+1 - READ(ISAVE) (AMAT(I),I=LPR1,LMX),(IMAT(I),I=LPR1,LMX) - CALL DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT) - NP=IMAT(LMX-1) - IPAGE=IPAGE+1 - GO TO 20156 -20158 NPARM=NVARS+MRELAS - READ(ISAVE) (IBASIS(I),I=1,NPARM) - REWIND ISAVE - GO TO 20006 -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (SAVE DATA ON FILE ISAVE) -C -C SOME PAGES MAY NOT BE WRITTEN YET. -30020 IF (.NOT.(AMAT(LMX).EQ.ONE)) GO TO 20159 - AMAT(LMX)=ZERO - KEY=2 - IPAGE=ABS(IMAT(LMX-1)) - CALL DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT) -C -C FORCE PAGE FILE TO BE OPENED ON RESTARTS. -20159 KEY=AMAT(4) - AMAT(4)=ZERO - LPR=NVARS+4 - WRITE(ISAVE) (AMAT(I),I=1,LPR),(IMAT(I),I=1,LPR) - AMAT(4)=KEY - IPAGE=1 - KEY=1 - GO TO 20163 -20162 IF (NP.LT.0) GO TO 20164 -20163 CALL DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT) - LPR1=LPR+1 - WRITE(ISAVE) (AMAT(I),I=LPR1,LMX),(IMAT(I),I=LPR1,LMX) - NP=IMAT(LMX-1) - IPAGE=IPAGE+1 - GO TO 20162 -20164 NPARM=NVARS+MRELAS - WRITE(ISAVE) (IBASIS(I),I=1,NPARM) - ENDFILE ISAVE -C -C CLOSE FILE, IPAGEF, WHERE PAGES ARE STORED. THIS IS NEEDED SO THAT -C THE PAGES MAY BE RESTORED AT A CONTINUATION OF DSPLP(). - GO TO 20317 -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (DECOMPOSE BASIS MATRIX) -C++ CODE FOR OUTPUT=YES IS ACTIVE -30004 IF (.NOT.(KPRINT.GE.2)) GO TO 20165 - CALL IVOUT(MRELAS,IBASIS, - *'('' SUBSCRIPTS OF BASIC VARIABLES DURING REDECOMPOSITION'')', - *IDG) -C++ CODE FOR OUTPUT=NO IS INACTIVE -C++ END -C -C SET RELATIVE PIVOTING FACTOR FOR USE IN LA05 () PACKAGE. -20165 UU=0.1 - CALL DPLPDM( - *MRELAS,NVARS,LMX,LBM,NREDC,INFO,IOPT, - *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB, - *ANORM,EPS,UU,GG, - *AMAT,BASMAT,CSC,WR, - *SINGLR,REDBAS) - IF (.NOT.(INFO.LT.0)) GO TO 20168 - GO TO 30001 -20168 CONTINUE - GO TO NPR004, (20013,20204,20242) -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (CLASSIFY VARIABLES) -C -C DEFINE THE CLASSIFICATION OF THE BASIC VARIABLES -C -1 VIOLATES LOWER BOUND, 0 FEASIBLE, +1 VIOLATES UPPER BOUND. -C (THIS INFO IS STORED IN PRIMAL(NVARS+1)-PRIMAL(NVARS+MRELAS)) -C TRANSLATE VARIABLE TO ITS UPPER BOUND, IF .GT. UPPER BOUND -30007 PRIMAL(NVARS+1)=ZERO - CALL DCOPY(MRELAS,PRIMAL(NVARS+1),0,PRIMAL(NVARS+1),1) - I=1 - N20172=MRELAS - GO TO 20173 -20172 I=I+1 -20173 IF ((N20172-I).LT.0) GO TO 20174 - J=IBASIS(I) - IF (.NOT.(IND(J).NE.4)) GO TO 20176 - IF (.NOT.(RPRIM(I).LT.ZERO)) GO TO 20179 - PRIMAL(I+NVARS)=-ONE - GO TO 20180 -20179 IF (.NOT.(IND(J).EQ.3)) GO TO 10009 - UPBND=BU(J)-BL(J) - IF (J.LE.NVARS) UPBND=UPBND/CSC(J) - IF (.NOT.(RPRIM(I).GT.UPBND)) GO TO 20182 - RPRIM(I)=RPRIM(I)-UPBND - IF (.NOT.(J.LE.NVARS)) GO TO 20185 - K=0 -20188 CALL DPNNZR(K,AIJ,IPLACE,AMAT,IMAT,J) - IF (.NOT.(K.LE.0)) GO TO 20190 - GO TO 20189 -20190 RHS(K)=RHS(K)-UPBND*AIJ*CSC(J) - GO TO 20188 -20189 GO TO 20186 -20185 RHS(J-NVARS)=RHS(J-NVARS)+UPBND -20186 PRIMAL(I+NVARS)=ONE -20182 CONTINUE - CONTINUE -10009 CONTINUE -20180 CONTINUE -20176 GO TO 20172 -20174 CONTINUE - GO TO NPR007, (20020,20036) -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (COMPUTE ERROR IN DUAL AND PRIMAL SYSTEMS) -30005 NTRIES=1 - GO TO 20195 -20194 NTRIES=NTRIES+1 -20195 IF ((2-NTRIES).LT.0) GO TO 20196 - CALL DPLPCE( - *MRELAS,NVARS,LMX,LBM,ITLP,ITBRC, - *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB, - *ERDNRM,EPS,TUNE,GG, - *AMAT,BASMAT,CSC,WR,WW,PRIMAL,ERD,ERP, - *SINGLR,REDBAS) - IF (.NOT.(.NOT. SINGLR)) GO TO 20198 -C++ CODE FOR OUTPUT=YES IS ACTIVE - IF (.NOT.(KPRINT.GE.3)) GO TO 20201 - CALL DVOUT(MRELAS,ERP,'('' EST. ERROR IN PRIMAL COMPS.'')',IDG) - CALL DVOUT(MRELAS,ERD,'('' EST. ERROR IN DUAL COMPS.'')',IDG) -20201 CONTINUE -C++ CODE FOR OUTPUT=NO IS INACTIVE -C++ END - GO TO 20193 -20198 IF (NTRIES.EQ.2) GO TO 20197 - ASSIGN 20204 TO NPR004 - GO TO 30004 -20204 CONTINUE - GO TO 20194 -20196 CONTINUE -20197 NERR=26 - CALL XERMSG ('SLATEC', 'DPLPMN', - + 'IN DSPLP, MOVED TO A SINGULAR POINT. THIS SHOULD NOT HAPPEN.', - + NERR, IOPT) - INFO=-NERR - GO TO 30001 -20193 CONTINUE - GO TO NPR005, (20018,20154,20243) -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (CHECK FEASIBILITY) -C -C SEE IF NEARBY FEASIBLE POINT SATISFIES THE CONSTRAINT -C EQUATIONS. -C -C COPY RHS INTO WW(*), THEN UPDATE WW(*). -30008 CALL DCOPY(MRELAS,RHS,1,WW,1) - J=1 - N20206=MRELAS - GO TO 20207 -20206 J=J+1 -20207 IF ((N20206-J).LT.0) GO TO 20208 - IBAS=IBASIS(J) - XVAL=RPRIM(J) -C -C ALL VARIABLES BOUNDED BELOW HAVE ZERO AS THAT BOUND. - IF (IND(IBAS).LE.3) XVAL=MAX(ZERO,XVAL) -C -C IF THE VARIABLE HAS AN UPPER BOUND, COMPUTE THAT BOUND. - IF (.NOT.(IND(IBAS).EQ.3)) GO TO 20210 - UPBND=BU(IBAS)-BL(IBAS) - IF (IBAS.LE.NVARS) UPBND=UPBND/CSC(IBAS) - XVAL=MIN(UPBND,XVAL) -20210 CONTINUE -C -C SUBTRACT XVAL TIMES COLUMN VECTOR FROM RIGHT-HAND SIDE IN WW(*) - IF (.NOT.(XVAL.NE.ZERO)) GO TO 20213 - IF (.NOT.(IBAS.LE.NVARS)) GO TO 20216 - I=0 -20219 CALL DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,IBAS) - IF (.NOT.(I.LE.0)) GO TO 20221 - GO TO 20220 -20221 WW(I)=WW(I)-XVAL*AIJ*CSC(IBAS) - GO TO 20219 -20220 GO TO 20217 -20216 IF (.NOT.(IND(IBAS).EQ.2)) GO TO 20224 - WW(IBAS-NVARS)=WW(IBAS-NVARS)-XVAL - GO TO 20225 -20224 WW(IBAS-NVARS)=WW(IBAS-NVARS)+XVAL -20225 CONTINUE - CONTINUE -20217 CONTINUE -20213 CONTINUE - GO TO 20206 -C -C COMPUTE NORM OF DIFFERENCE AND CHECK FOR FEASIBILITY. -20208 RESNRM=DASUM(MRELAS,WW,1) - FEAS=RESNRM.LE.TOLLS*(RPRNRM*ANORM+RHSNRM) -C -C TRY AN ABSOLUTE ERROR TEST IF THE RELATIVE TEST FAILS. - IF(.NOT. FEAS)FEAS=RESNRM.LE.TOLABS - IF (.NOT.(FEAS)) GO TO 20227 - PRIMAL(NVARS+1)=ZERO - CALL DCOPY(MRELAS,PRIMAL(NVARS+1),0,PRIMAL(NVARS+1),1) -20227 CONTINUE - GO TO NPR008, (20024,20032,20040) -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (INITIALIZE REDUCED COSTS AND STEEPEST EDGE WEIGHTS) -30014 CALL DPINCW( - *MRELAS,NVARS,LMX,LBM,NPP,JSTRT, - *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB, - *COSTSC,GG,ERDNRM,DULNRM, - *AMAT,BASMAT,CSC,WR,WW,RZ,RG,COSTS,COLNRM,DUALS, - *STPEDG) -C - GO TO NPR014, (20135,20246) -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (CHECK AND RETURN WITH EXCESS ITERATIONS) -30019 IF (.NOT.(ITLP.GT.MXITLP)) GO TO 20230 - NERR=25 - ASSIGN 20233 TO NPR011 - GO TO 30011 -C++ CODE FOR OUTPUT=YES IS ACTIVE -20233 IF (.NOT.(KPRINT.GE.1)) GO TO 20234 - ASSIGN 20237 TO NPR012 - GO TO 30012 -20237 CONTINUE -20234 CONTINUE -C++ CODE FOR OUTPUT=NO IS INACTIVE -C++ END - IDUM(1)=0 - IF(SAVEDT) IDUM(1)=ISAVE - WRITE (XERN1, '(I8)') MXITLP - WRITE (XERN2, '(I8)') IDUM(1) - CALL XERMSG ('SLATEC', 'DPLPMN', - * 'IN DSPLP, MAX ITERATIONS = ' // XERN1 // - * ' TAKEN. UP-TO-DATE RESULTS SAVED ON FILE NO. ' // XERN2 // - * '. IF FILE NO. = 0, NO SAVE.', NERR, IOPT) - INFO=-NERR - GO TO 30001 -20230 CONTINUE - GO TO 20155 -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (REDECOMPOSE BASIS MATRIX AND TRY AGAIN) -30016 IF (.NOT.(.NOT.REDBAS)) GO TO 20239 - ASSIGN 20242 TO NPR004 - GO TO 30004 -20242 ASSIGN 20243 TO NPR005 - GO TO 30005 -20243 ASSIGN 20244 TO NPR006 - GO TO 30006 -20244 ASSIGN 20245 TO NPR013 - GO TO 30013 -20245 ASSIGN 20246 TO NPR014 - GO TO 30014 -20246 CONTINUE -C -C ERASE NON-CYCLING MARKERS NEAR COMPLETION. -20239 I=MRELAS+1 - N20247=MRELAS+NVARS - GO TO 20248 -20247 I=I+1 -20248 IF ((N20247-I).LT.0) GO TO 20249 - IBASIS(I)=ABS(IBASIS(I)) - GO TO 20247 -20249 ASSIGN 20251 TO NPR015 - GO TO 30015 -20251 CONTINUE - GO TO 20145 -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (COMPUTE NEW PRIMAL) -C -C COPY RHS INTO WW(*), SOLVE SYSTEM. -30006 CALL DCOPY(MRELAS,RHS,1,WW,1) - TRANS = .FALSE. - CALL LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) - CALL DCOPY(MRELAS,WW,1,RPRIM,1) - RPRNRM=DASUM(MRELAS,RPRIM,1) - GO TO NPR006, (20019,20031,20039,20244,20275) -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (COMPUTE NEW DUALS) -C -C SOLVE FOR DUAL VARIABLES. FIRST COPY COSTS INTO DUALS(*). -30013 I=1 - N20252=MRELAS - GO TO 20253 -20252 I=I+1 -20253 IF ((N20252-I).LT.0) GO TO 20254 - J=IBASIS(I) - IF (.NOT.(J.LE.NVARS)) GO TO 20256 - DUALS(I)=COSTSC*COSTS(J)*CSC(J) + XLAMDA*PRIMAL(I+NVARS) - GO TO 20257 -20256 DUALS(I)=XLAMDA*PRIMAL(I+NVARS) -20257 CONTINUE - GO TO 20252 -C -20254 TRANS=.TRUE. - CALL LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,DUALS,TRANS) - DULNRM=DASUM(MRELAS,DUALS,1) - GO TO NPR013, (20134,20245,20267) -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (FIND VARIABLE TO ENTER BASIS AND GET SEARCH DIRECTION) -30015 CALL DPLPFE( - *MRELAS,NVARS,LMX,LBM,IENTER, - *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB, - *ERDNRM,EPS,GG,DULNRM,DIRNRM, - *AMAT,BASMAT,CSC,WR,WW,BL,BU,RZ,RG,COLNRM,DUALS, - *FOUND) - GO TO NPR015, (20141,20251) -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (CHOOSE VARIABLE TO LEAVE BASIS) -30017 CALL DPLPFL( - *MRELAS,NVARS,IENTER,ILEAVE, - *IBASIS,IND,IBB, - *THETA,DIRNRM,RPRNRM, - *CSC,WW,BL,BU,ERP,RPRIM,PRIMAL, - *FINITE,ZEROLV) - GO TO 20149 -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (MAKE MOVE AND UPDATE) -30018 CALL DPLPMU( - *MRELAS,NVARS,LMX,LBM,NREDC,INFO,IENTER,ILEAVE,IOPT,NPP,JSTRT, - *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB, - *ANORM,EPS,UU,GG,RPRNRM,ERDNRM,DULNRM,THETA,COSTSC,XLAMDA,RHSNRM, - *AMAT,BASMAT,CSC,WR,RPRIM,WW,BU,BL,RHS,ERD,ERP,RZ,RG,COLNRM,COSTS, - *PRIMAL,DUALS,SINGLR,REDBAS,ZEROLV,STPEDG) - IF (.NOT.(INFO.EQ.(-26))) GO TO 20259 - GO TO 30001 -C++ CODE FOR OUTPUT=YES IS ACTIVE -20259 IF (.NOT.(KPRINT.GE.2)) GO TO 20263 - GO TO 30021 -20266 CONTINUE -C++ CODE FOR OUTPUT=NO IS INACTIVE -C++ END -20263 CONTINUE - GO TO 20153 -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE(RESCALE AND REARRANGE VARIABLES) -C -C RESCALE THE DUAL VARIABLES. -30011 ASSIGN 20267 TO NPR013 - GO TO 30013 -20267 IF (.NOT.(COSTSC.NE.ZERO)) GO TO 20268 - I=1 - N20271=MRELAS - GO TO 20272 -20271 I=I+1 -20272 IF ((N20271-I).LT.0) GO TO 20273 - DUALS(I)=DUALS(I)/COSTSC - GO TO 20271 -20273 CONTINUE -20268 ASSIGN 20275 TO NPR006 - GO TO 30006 -C -C REAPPLY COLUMN SCALING TO PRIMAL. -20275 I=1 - N20276=MRELAS - GO TO 20277 -20276 I=I+1 -20277 IF ((N20276-I).LT.0) GO TO 20278 - J=IBASIS(I) - IF (.NOT.(J.LE.NVARS)) GO TO 20280 - SCALR=CSC(J) - IF(IND(J).EQ.2)SCALR=-SCALR - RPRIM(I)=RPRIM(I)*SCALR -20280 GO TO 20276 -C -C REPLACE TRANSLATED BASIC VARIABLES INTO ARRAY PRIMAL(*) -20278 PRIMAL(1)=ZERO - CALL DCOPY(NVARS+MRELAS,PRIMAL,0,PRIMAL,1) - J=1 - N20283=NVARS+MRELAS - GO TO 20284 -20283 J=J+1 -20284 IF ((N20283-J).LT.0) GO TO 20285 - IBAS=ABS(IBASIS(J)) - XVAL=ZERO - IF (J.LE.MRELAS) XVAL=RPRIM(J) - IF (IND(IBAS).EQ.1) XVAL=XVAL+BL(IBAS) - IF (IND(IBAS).EQ.2) XVAL=BU(IBAS)-XVAL - IF (.NOT.(IND(IBAS).EQ.3)) GO TO 20287 - IF (MOD(IBB(IBAS),2).EQ.0) XVAL=BU(IBAS)-BL(IBAS)-XVAL - XVAL = XVAL+BL(IBAS) -20287 PRIMAL(IBAS)=XVAL - GO TO 20283 -C -C COMPUTE DUALS FOR INDEPENDENT VARIABLES WITH BOUNDS. -C OTHER ENTRIES ARE ZERO. -20285 J=1 - N20290=NVARS - GO TO 20291 -20290 J=J+1 -20291 IF ((N20290-J).LT.0) GO TO 20292 - RZJ=ZERO - IF (.NOT.(IBB(J).GT.ZERO .AND. IND(J).NE.4)) GO TO 20294 - RZJ=COSTS(J) - I=0 -20297 CALL DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,J) - IF (.NOT.(I.LE.0)) GO TO 20299 - GO TO 20298 -20299 CONTINUE - RZJ=RZJ-AIJ*DUALS(I) - GO TO 20297 -20298 CONTINUE -20294 DUALS(MRELAS+J)=RZJ - GO TO 20290 -20292 CONTINUE - GO TO NPR011, (20051,20233) -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C++ CODE FOR OUTPUT=YES IS ACTIVE -C PROCEDURE (PRINT PROLOGUE) -30003 IDUM(1)=MRELAS - CALL IVOUT(1,IDUM,'(''1NUM. OF DEPENDENT VARS., MRELAS'')',IDG) - IDUM(1)=NVARS - CALL IVOUT(1,IDUM,'('' NUM. OF INDEPENDENT VARS., NVARS'')',IDG) - CALL IVOUT(1,IDUM,'('' DIMENSION OF COSTS(*)='')',IDG) - IDUM(1)=NVARS+MRELAS - CALL IVOUT(1,IDUM, '('' DIMENSIONS OF BL(*),BU(*),IND(*)'' - */'' PRIMAL(*),DUALS(*) ='')',IDG) - CALL IVOUT(1,IDUM,'('' DIMENSION OF IBASIS(*)='')',IDG) - IDUM(1)=LPRG+1 - CALL IVOUT(1,IDUM,'('' DIMENSION OF PRGOPT(*)='')',IDG) - CALL IVOUT(0,IDUM, - * '('' 1-NVARS=INDEPENDENT VARIABLE INDICES.''/ - * '' (NVARS+1)-(NVARS+MRELAS)=DEPENDENT VARIABLE INDICES.''/ - * '' CONSTRAINT INDICATORS ARE 1-4 AND MEAN'')',IDG) - CALL IVOUT(0,IDUM, - * '('' 1=VARIABLE HAS ONLY LOWER BOUND.''/ - * '' 2=VARIABLE HAS ONLY UPPER BOUND.''/ - * '' 3=VARIABLE HAS BOTH BOUNDS.''/ - * '' 4=VARIABLE HAS NO BOUNDS, IT IS FREE.'')',IDG) - CALL DVOUT(NVARS,COSTS,'('' ARRAY OF COSTS'')',IDG) - CALL IVOUT(NVARS+MRELAS,IND, - * '('' CONSTRAINT INDICATORS'')',IDG) - CALL DVOUT(NVARS+MRELAS,BL, - *'('' LOWER BOUNDS FOR VARIABLES (IGNORE UNUSED ENTRIES.)'')',IDG) - CALL DVOUT(NVARS+MRELAS,BU, - *'('' UPPER BOUNDS FOR VARIABLES (IGNORE UNUSED ENTRIES.)'')',IDG) - IF (.NOT.(KPRINT.GE.2)) GO TO 20302 - CALL IVOUT(0,IDUM, - * '(''0NON-BASIC INDICES THAT ARE NEGATIVE SHOW VARIABLES'' - * '' EXCHANGED AT A ZERO''/'' STEP LENGTH'')',IDG) - CALL IVOUT(0,IDUM, - * '('' WHEN COL. NO. LEAVING=COL. NO. ENTERING, THE ENTERING '' - * ''VARIABLE MOVED''/'' TO ITS BOUND. IT REMAINS NON-BASIC.''/ - * '' WHEN COL. NO. OF BASIS EXCHANGED IS NEGATIVE, THE LEAVING''/ - * '' VARIABLE IS AT ITS UPPER BOUND.'')',IDG) -20302 CONTINUE - GO TO 20011 -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (PRINT SUMMARY) -30012 IDUM(1)=INFO - CALL IVOUT(1,IDUM,'('' THE OUTPUT VALUE OF INFO IS'')',IDG) - IF (.NOT.(MINPRB)) GO TO 20305 - CALL IVOUT(0,IDUM,'('' THIS IS A MINIMIZATION PROBLEM.'')',IDG) - GO TO 20306 -20305 CALL IVOUT(0,IDUM,'('' THIS IS A MAXIMIZATION PROBLEM.'')',IDG) -20306 IF (.NOT.(STPEDG)) GO TO 20308 - CALL IVOUT(0,IDUM,'('' STEEPEST EDGE PRICING WAS USED.'')',IDG) - GO TO 20309 -20308 CALL IVOUT(0,IDUM,'('' MINIMUM REDUCED COST PRICING WAS USED.'')', - * IDG) -20309 RDUM(1)=DDOT(NVARS,COSTS,1,PRIMAL,1) - CALL DVOUT(1,RDUM, - * '('' OUTPUT VALUE OF THE OBJECTIVE FUNCTION'')',IDG) - CALL DVOUT(NVARS+MRELAS,PRIMAL, - * '('' THE OUTPUT INDEPENDENT AND DEPENDENT VARIABLES'')',IDG) - CALL DVOUT(MRELAS+NVARS,DUALS, - * '('' THE OUTPUT DUAL VARIABLES'')',IDG) - CALL IVOUT(NVARS+MRELAS,IBASIS, - * '('' VARIABLE INDICES IN POSITIONS 1-MRELAS ARE BASIC.'')',IDG) - IDUM(1)=ITLP - CALL IVOUT(1,IDUM,'('' NO. OF ITERATIONS'')',IDG) - IDUM(1)=NREDC - CALL IVOUT(1,IDUM,'('' NO. OF FULL REDECOMPS'')',IDG) - GO TO NPR012, (20096,20237) -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (PRINT ITERATION SUMMARY) -30021 IDUM(1)=ITLP+1 - CALL IVOUT(1,IDUM,'(''0ITERATION NUMBER'')',IDG) - IDUM(1)=IBASIS(ABS(ILEAVE)) - CALL IVOUT(1,IDUM, - * '('' INDEX OF VARIABLE ENTERING THE BASIS'')',IDG) - IDUM(1)=ILEAVE - CALL IVOUT(1,IDUM,'('' COLUMN OF THE BASIS EXCHANGED'')',IDG) - IDUM(1)=IBASIS(IENTER) - CALL IVOUT(1,IDUM, - * '('' INDEX OF VARIABLE LEAVING THE BASIS'')',IDG) - RDUM(1)=THETA - CALL DVOUT(1,RDUM,'('' LENGTH OF THE EXCHANGE STEP'')',IDG) - IF (.NOT.(KPRINT.GE.3)) GO TO 20311 - CALL DVOUT(MRELAS,RPRIM,'('' BASIC (INTERNAL) PRIMAL SOLN.'')', - * IDG) - CALL IVOUT(NVARS+MRELAS,IBASIS, - * '('' VARIABLE INDICES IN POSITIONS 1-MRELAS ARE BASIC.'')',IDG) - CALL IVOUT(NVARS+MRELAS,IBB,'('' IBB ARRAY'')',IDG) - CALL DVOUT(MRELAS,RHS,'('' TRANSLATED RHS'')',IDG) - CALL DVOUT(MRELAS,DUALS,'('' BASIC (INTERNAL) DUAL SOLN.'')',IDG) -20311 CONTINUE - GO TO 20266 -C++ CODE FOR OUTPUT=NO IS INACTIVE -C++ END -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (RETURN TO USER) -30001 IF (.NOT.(SAVEDT)) GO TO 20314 - GO TO 30020 -20317 CONTINUE -20314 IF(IMAT(LMX-1).NE.(-1)) CALL SCLOSM(IPAGEF) -C -C THIS TEST IS THERE ONLY TO AVOID DIAGNOSTICS ON SOME FORTRAN -C COMPILERS. - RETURN - END diff --git a/slatec/dplpmu.f b/slatec/dplpmu.f deleted file mode 100644 index 9943232..0000000 --- a/slatec/dplpmu.f +++ /dev/null @@ -1,433 +0,0 @@ -*DECK DPLPMU - SUBROUTINE DPLPMU (MRELAS, NVARS, LMX, LBM, NREDC, INFO, IENTER, - + ILEAVE, IOPT, NPP, JSTRT, IBASIS, IMAT, IBRC, IPR, IWR, IND, - + IBB, ANORM, EPS, UU, GG, RPRNRM, ERDNRM, DULNRM, THETA, COSTSC, - + XLAMDA, RHSNRM, AMAT, BASMAT, CSC, WR, RPRIM, WW, BU, BL, RHS, - + ERD, ERP, RZ, RG, COLNRM, COSTS, PRIMAL, DUALS, SINGLR, REDBAS, - + ZEROLV, STPEDG) -C***BEGIN PROLOGUE DPLPMU -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSPLP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (SPLPMU-S, DPLPMU-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO -C DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. -C -C USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. -C /REAL (12 BLANKS)/DOUBLE PRECISION/, -C /SASUM/DASUM/,/SCOPY/DCOPY/,/SDOT/DDOT/, -C /.E0/.D0/ -C -C THIS SUBPROGRAM IS FROM THE DSPLP( ) PACKAGE. IT PERFORMS THE -C TASKS OF UPDATING THE PRIMAL SOLUTION, EDGE WEIGHTS, REDUCED -C COSTS, AND MATRIX DECOMPOSITION. -C IT IS THE MAIN PART OF THE PROCEDURE (MAKE MOVE AND UPDATE). -C -C REVISED 821122-1100 -C REVISED YYMMDD -C -C***SEE ALSO DSPLP -C***ROUTINES CALLED DASUM, DCOPY, DDOT, DPLPDM, DPNNZR, DPRWPG, IDLOC, -C LA05BD, LA05CD, XERMSG -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890605 Removed unreferenced labels. (WRB) -C 890606 Changed references from IPLOC to IDLOC. (WRB) -C 890606 Removed unused COMMON block LA05DD. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DPLPMU - INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*) - DOUBLE PRECISION AIJ,ALPHA,ANORM,COSTSC,ERDNRM,DULNRM,EPS,GAMMA, - * GG,GQ,ONE,RPRNRM,RZJ,SCALR,THETA,TWO,UU,WP,XLAMDA,RHSNRM, - * ZERO,AMAT(*),BASMAT(*),CSC(*),WR(*),RPRIM(*),WW(*),BU(*),BL(*), - * RHS(*),ERD(*),ERP(*),RZ(*),RG(*),COSTS(*),PRIMAL(*),DUALS(*), - * COLNRM(*),RCOST,DASUM,DDOT,CNORM - LOGICAL SINGLR,REDBAS,PAGEPL,TRANS,ZEROLV,STPEDG -C -C***FIRST EXECUTABLE STATEMENT DPLPMU - ZERO=0.D0 - ONE=1.D0 - TWO=2.D0 - LPG=LMX-(NVARS+4) -C -C UPDATE THE PRIMAL SOLUTION WITH A MULTIPLE OF THE SEARCH -C DIRECTION. - I=1 - N20002=MRELAS - GO TO 20003 -20002 I=I+1 -20003 IF ((N20002-I).LT.0) GO TO 20004 - RPRIM(I)=RPRIM(I)-THETA*WW(I) - GO TO 20002 -C -C IF EJECTED VARIABLE IS LEAVING AT AN UPPER BOUND, THEN -C TRANSLATE RIGHT HAND SIDE. -20004 IF (.NOT.(ILEAVE.LT.0)) GO TO 20006 - IBAS=IBASIS(ABS(ILEAVE)) - SCALR=RPRIM(ABS(ILEAVE)) - ASSIGN 20009 TO NPR001 - GO TO 30001 -20009 IBB(IBAS)=ABS(IBB(IBAS))+1 -C -C IF ENTERING VARIABLE IS RESTRICTED TO ITS UPPER BOUND, TRANSLATE -C RIGHT HAND SIDE. IF THE VARIABLE DECREASED FROM ITS UPPER -C BOUND, A SIGN CHANGE IS REQUIRED IN THE TRANSLATION. -20006 IF (.NOT.(IENTER.EQ.ILEAVE)) GO TO 20010 - IBAS=IBASIS(IENTER) - SCALR=THETA - IF (MOD(IBB(IBAS),2).EQ.0) SCALR=-SCALR - ASSIGN 20013 TO NPR001 - GO TO 30001 -20013 IBB(IBAS)=IBB(IBAS)+1 - GO TO 20011 -20010 IBAS=IBASIS(IENTER) -C -C IF ENTERING VARIABLE IS DECREASING FROM ITS UPPER BOUND, -C COMPLEMENT ITS PRIMAL VALUE. - IF (.NOT.(IND(IBAS).EQ.3.AND.MOD(IBB(IBAS),2).EQ.0)) GO TO 20014 - SCALR=-(BU(IBAS)-BL(IBAS)) - IF (IBAS.LE.NVARS) SCALR=SCALR/CSC(IBAS) - ASSIGN 20017 TO NPR001 - GO TO 30001 -20017 THETA=-SCALR-THETA - IBB(IBAS)=IBB(IBAS)+1 -20014 CONTINUE - RPRIM(ABS(ILEAVE))=THETA - IBB(IBAS)=-ABS(IBB(IBAS)) - I=IBASIS(ABS(ILEAVE)) - IBB(I)=ABS(IBB(I)) - IF(PRIMAL(ABS(ILEAVE)+NVARS).GT.ZERO) IBB(I)=IBB(I)+1 -C -C INTERCHANGE COLUMN POINTERS TO NOTE EXCHANGE OF COLUMNS. -20011 IBAS=IBASIS(IENTER) - IBASIS(IENTER)=IBASIS(ABS(ILEAVE)) - IBASIS(ABS(ILEAVE))=IBAS -C -C IF VARIABLE WAS EXCHANGED AT A ZERO LEVEL, MARK IT SO THAT -C IT CAN'T BE BROUGHT BACK IN. THIS IS TO HELP PREVENT CYCLING. - IF(ZEROLV) IBASIS(IENTER)=-ABS(IBASIS(IENTER)) - RPRNRM=MAX(RPRNRM,DASUM(MRELAS,RPRIM,1)) - K=1 - N20018=MRELAS - GO TO 20019 -20018 K=K+1 -20019 IF ((N20018-K).LT.0) GO TO 20020 -C -C SEE IF VARIABLES THAT WERE CLASSIFIED AS INFEASIBLE HAVE NOW -C BECOME FEASIBLE. THIS MAY REQUIRED TRANSLATING UPPER BOUNDED -C VARIABLES. - IF (.NOT.(PRIMAL(K+NVARS).NE.ZERO .AND. - * ABS(RPRIM(K)).LE.RPRNRM*ERP(K))) GO TO 20022 - IF (.NOT.(PRIMAL(K+NVARS).GT.ZERO)) GO TO 20025 - IBAS=IBASIS(K) - SCALR=-(BU(IBAS)-BL(IBAS)) - IF(IBAS.LE.NVARS)SCALR=SCALR/CSC(IBAS) - ASSIGN 20028 TO NPR001 - GO TO 30001 -20028 RPRIM(K)=-SCALR - RPRNRM=RPRNRM-SCALR -20025 PRIMAL(K+NVARS)=ZERO -20022 CONTINUE - GO TO 20018 -C -C UPDATE REDUCED COSTS, EDGE WEIGHTS, AND MATRIX DECOMPOSITION. -20020 IF (.NOT.(IENTER.NE.ILEAVE)) GO TO 20029 -C -C THE INCOMING VARIABLE IS ALWAYS CLASSIFIED AS FEASIBLE. - PRIMAL(ABS(ILEAVE)+NVARS)=ZERO -C - WP=WW(ABS(ILEAVE)) - GQ=DDOT(MRELAS,WW,1,WW,1)+ONE -C -C COMPUTE INVERSE (TRANSPOSE) TIMES SEARCH DIRECTION. - TRANS=.TRUE. - CALL LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) -C -C UPDATE THE MATRIX DECOMPOSITION. COL. ABS(ILEAVE) IS LEAVING. -C THE ARRAY DUALS(*) CONTAINS INTERMEDIATE RESULTS FOR THE -C INCOMING COLUMN. - CALL LA05CD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,DUALS,GG,UU, - * ABS(ILEAVE)) - REDBAS=.FALSE. - IF (.NOT.(GG.LT.ZERO)) GO TO 20032 -C -C REDECOMPOSE BASIS MATRIX WHEN AN ERROR RETURN FROM -C LA05CD( ) IS NOTED. THIS WILL PROBABLY BE DUE TO -C SPACE BEING EXHAUSTED, GG=-7. - CALL DPLPDM( - *MRELAS,NVARS,LMX,LBM,NREDC,INFO,IOPT, - *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB, - *ANORM,EPS,UU,GG, - *AMAT,BASMAT,CSC,WR, - *SINGLR,REDBAS) - IF (.NOT.(SINGLR)) GO TO 20035 - NERR=26 - CALL XERMSG ('SLATEC', 'DPLPMU', - + 'IN DSPLP, MOVED TO A SINGULAR POINT. THIS SHOULD NOT HAPPEN.', - + NERR, IOPT) - INFO=-NERR - RETURN -20035 CONTINUE - GO TO 30002 -20038 CONTINUE -20032 CONTINUE -C -C IF STEEPEST EDGE PRICING IS USED, UPDATE REDUCED COSTS -C AND EDGE WEIGHTS. - IF (.NOT.(STPEDG)) GO TO 20039 -C -C COMPUTE COL. ABS(ILEAVE) OF THE NEW INVERSE (TRANSPOSE) MATRIX -C HERE ABS(ILEAVE) POINTS TO THE EJECTED COLUMN. -C USE ERD(*) FOR TEMP. STORAGE. - CALL DCOPY(MRELAS,ZERO,0,ERD,1) - ERD(ABS(ILEAVE))=ONE - TRANS=.TRUE. - CALL LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,ERD,TRANS) -C -C COMPUTE UPDATED DUAL VARIABLES IN DUALS(*). - ASSIGN 20042 TO NPR003 - GO TO 30003 -C -C COMPUTE THE DOT PRODUCT OF COL. J OF THE NEW INVERSE (TRANSPOSE) -C WITH EACH NON-BASIC COLUMN. ALSO COMPUTE THE DOT PRODUCT OF THE -C INVERSE (TRANSPOSE) OF NON-UPDATED MATRIX (TIMES) THE -C SEARCH DIRECTION WITH EACH NON-BASIC COLUMN. -C RECOMPUTE REDUCED COSTS. -20042 PAGEPL=.TRUE. - CALL DCOPY(NVARS+MRELAS,ZERO,0,RZ,1) - NNEGRC=0 - J=JSTRT -20043 IF (.NOT.(IBB(J).LE.0)) GO TO 20045 - PAGEPL=.TRUE. - RG(J)=ONE - GO TO 20046 -C -C NONBASIC INDEPENDENT VARIABLES (COLUMN IN SPARSE MATRIX STORAGE) -20045 IF (.NOT.(J.LE.NVARS)) GO TO 20048 - RZJ=COSTS(J)*COSTSC - ALPHA=ZERO - GAMMA=ZERO -C -C COMPUTE THE DOT PRODUCT OF THE SPARSE MATRIX NONBASIC COLUMNS -C WITH THREE VECTORS INVOLVED IN THE UPDATING STEP. - IF (.NOT.(J.EQ.1)) GO TO 20051 - ILOW=NVARS+5 - GO TO 20052 -20051 ILOW=IMAT(J+3)+1 -20052 IF (.NOT.(PAGEPL)) GO TO 20054 - IL1=IDLOC(ILOW,AMAT,IMAT) - IF (.NOT.(IL1.GE.LMX-1)) GO TO 20057 - ILOW=ILOW+2 - IL1=IDLOC(ILOW,AMAT,IMAT) -20057 CONTINUE - IPAGE=ABS(IMAT(LMX-1)) - GO TO 20055 -20054 IL1=IHI+1 -20055 IHI=IMAT(J+4)-(ILOW-IL1) -20060 IU1=MIN(LMX-2,IHI) - IF (.NOT.(IL1.GT.IU1)) GO TO 20062 - GO TO 20061 -20062 CONTINUE - DO 10 I=IL1,IU1 - RZJ=RZJ-AMAT(I)*DUALS(IMAT(I)) - ALPHA=ALPHA+AMAT(I)*ERD(IMAT(I)) - GAMMA=GAMMA+AMAT(I)*WW(IMAT(I)) -10 CONTINUE - IF (.NOT.(IHI.LE.LMX-2)) GO TO 20065 - GO TO 20061 -20065 CONTINUE - IPAGE=IPAGE+1 - KEY=1 - CALL DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT) - IL1=NVARS+5 - IHI=IHI-LPG - GO TO 20060 -20061 PAGEPL=IHI.EQ.(LMX-2) - RZ(J)=RZJ*CSC(J) - ALPHA=ALPHA*CSC(J) - GAMMA=GAMMA*CSC(J) - RG(J)=MAX(RG(J)-TWO*ALPHA*GAMMA+ALPHA**2*GQ,ONE+ALPHA**2) -C -C NONBASIC DEPENDENT VARIABLES (COLUMNS DEFINED IMPLICITLY) - GO TO 20049 -20048 PAGEPL=.TRUE. - SCALR=-ONE - IF(IND(J).EQ.2) SCALR=ONE - I=J-NVARS - ALPHA=SCALR*ERD(I) - RZ(J)=-SCALR*DUALS(I) - GAMMA=SCALR*WW(I) - RG(J)=MAX(RG(J)-TWO*ALPHA*GAMMA+ALPHA**2*GQ,ONE+ALPHA**2) -20049 CONTINUE -20046 CONTINUE -C - RCOST=RZ(J) - IF (MOD(IBB(J),2).EQ.0) RCOST=-RCOST - IF (.NOT.(IND(J).EQ.3)) GO TO 20068 - IF(BU(J).EQ.BL(J)) RCOST=ZERO -20068 CONTINUE - IF (IND(J).EQ.4) RCOST=-ABS(RCOST) - CNORM=ONE - IF (J.LE.NVARS) CNORM=COLNRM(J) - IF (RCOST+ERDNRM*DULNRM*CNORM.LT.ZERO) NNEGRC=NNEGRC+1 - J=MOD(J,MRELAS+NVARS)+1 - IF (.NOT.(NNEGRC.GE.NPP .OR. J.EQ.JSTRT)) GO TO 20071 - GO TO 20044 -20071 CONTINUE - GO TO 20043 -20044 JSTRT=J -C -C UPDATE THE EDGE WEIGHT FOR THE EJECTED VARIABLE. - RG(ABS(IBASIS(IENTER)))= GQ/WP**2 -C -C IF MINIMUM REDUCED COST (DANTZIG) PRICING IS USED, -C CALCULATE THE NEW REDUCED COSTS. - GO TO 20040 -C -C COMPUTE THE UPDATED DUALS IN DUALS(*). -20039 ASSIGN 20074 TO NPR003 - GO TO 30003 -20074 CALL DCOPY(NVARS+MRELAS,ZERO,0,RZ,1) - NNEGRC=0 - J=JSTRT - PAGEPL=.TRUE. -C -20075 IF (.NOT.(IBB(J).LE.0)) GO TO 20077 - PAGEPL=.TRUE. - GO TO 20078 -C -C NONBASIC INDEPENDENT VARIABLE (COLUMN IN SPARSE MATRIX STORAGE) -20077 IF (.NOT.(J.LE.NVARS)) GO TO 20080 - RZ(J)=COSTS(J)*COSTSC - IF (.NOT.(J.EQ.1)) GO TO 20083 - ILOW=NVARS+5 - GO TO 20084 -20083 ILOW=IMAT(J+3)+1 -20084 CONTINUE - IF (.NOT.(PAGEPL)) GO TO 20086 - IL1=IDLOC(ILOW,AMAT,IMAT) - IF (.NOT.(IL1.GE.LMX-1)) GO TO 20089 - ILOW=ILOW+2 - IL1=IDLOC(ILOW,AMAT,IMAT) -20089 CONTINUE - IPAGE=ABS(IMAT(LMX-1)) - GO TO 20087 -20086 IL1=IHI+1 -20087 CONTINUE - IHI=IMAT(J+4)-(ILOW-IL1) -20092 IU1=MIN(LMX-2,IHI) - IF (.NOT.(IU1.GE.IL1 .AND.MOD(IU1-IL1,2).EQ.0)) GO TO 20094 - RZ(J)=RZ(J)-AMAT(IL1)*DUALS(IMAT(IL1)) - IL1=IL1+1 -20094 CONTINUE - IF (.NOT.(IL1.GT.IU1)) GO TO 20097 - GO TO 20093 -20097 CONTINUE -C -C UNROLL THE DOT PRODUCT LOOP TO A DEPTH OF TWO. (THIS IS DONE -C FOR INCREASED EFFICIENCY). - DO 40 I=IL1,IU1,2 - RZ(J)=RZ(J)-AMAT(I)*DUALS(IMAT(I))-AMAT(I+1)*DUALS(IMAT(I+1)) -40 CONTINUE - IF (.NOT.(IHI.LE.LMX-2)) GO TO 20100 - GO TO 20093 -20100 CONTINUE - IPAGE=IPAGE+1 - KEY=1 - CALL DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT) - IL1=NVARS+5 - IHI=IHI-LPG - GO TO 20092 -20093 PAGEPL=IHI.EQ.(LMX-2) - RZ(J)=RZ(J)*CSC(J) -C -C NONBASIC DEPENDENT VARIABLES (COLUMNS DEFINED IMPLICITLY) - GO TO 20081 -20080 PAGEPL=.TRUE. - SCALR=-ONE - IF(IND(J).EQ.2) SCALR=ONE - I=J-NVARS - RZ(J)=-SCALR*DUALS(I) -20081 CONTINUE -20078 CONTINUE -C - RCOST=RZ(J) - IF (MOD(IBB(J),2).EQ.0) RCOST=-RCOST - IF (.NOT.(IND(J).EQ.3)) GO TO 20103 - IF(BU(J).EQ.BL(J)) RCOST=ZERO -20103 CONTINUE - IF (IND(J).EQ.4) RCOST=-ABS(RCOST) - CNORM=ONE - IF (J.LE.NVARS) CNORM=COLNRM(J) - IF (RCOST+ERDNRM*DULNRM*CNORM.LT.ZERO) NNEGRC=NNEGRC+1 - J=MOD(J,MRELAS+NVARS)+1 - IF (.NOT.(NNEGRC.GE.NPP .OR. J.EQ.JSTRT)) GO TO 20106 - GO TO 20076 -20106 CONTINUE - GO TO 20075 -20076 JSTRT=J -20040 CONTINUE - GO TO 20030 -C -C THIS IS NECESSARY ONLY FOR PRINTING OF INTERMEDIATE RESULTS. -20029 ASSIGN 20109 TO NPR003 - GO TO 30003 -20109 CONTINUE -20030 RETURN -C PROCEDURE (TRANSLATE RIGHT HAND SIDE) -C -C PERFORM THE TRANSLATION ON THE RIGHT-HAND SIDE. -30001 IF (.NOT.(IBAS.LE.NVARS)) GO TO 20110 - I=0 -20113 CALL DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,IBAS) - IF (.NOT.(I.LE.0)) GO TO 20115 - GO TO 20114 -20115 CONTINUE - RHS(I)=RHS(I)-SCALR*AIJ*CSC(IBAS) - GO TO 20113 -20114 GO TO 20111 -20110 I=IBAS-NVARS - IF (.NOT.(IND(IBAS).EQ.2)) GO TO 20118 - RHS(I)=RHS(I)-SCALR - GO TO 20119 -20118 RHS(I)=RHS(I)+SCALR -20119 CONTINUE -20111 CONTINUE - RHSNRM=MAX(RHSNRM,DASUM(MRELAS,RHS,1)) - GO TO NPR001, (20009,20013,20017,20028) -C PROCEDURE (COMPUTE NEW PRIMAL) -C -C COPY RHS INTO WW(*), SOLVE SYSTEM. -30002 CALL DCOPY(MRELAS,RHS,1,WW,1) - TRANS = .FALSE. - CALL LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) - CALL DCOPY(MRELAS,WW,1,RPRIM,1) - RPRNRM=DASUM(MRELAS,RPRIM,1) - GO TO 20038 -C PROCEDURE (COMPUTE NEW DUALS) -C -C SOLVE FOR DUAL VARIABLES. FIRST COPY COSTS INTO DUALS(*). -30003 I=1 - N20121=MRELAS - GO TO 20122 -20121 I=I+1 -20122 IF ((N20121-I).LT.0) GO TO 20123 - J=IBASIS(I) - IF (.NOT.(J.LE.NVARS)) GO TO 20125 - DUALS(I)=COSTSC*COSTS(J)*CSC(J) + XLAMDA*PRIMAL(I+NVARS) - GO TO 20126 -20125 DUALS(I)=XLAMDA*PRIMAL(I+NVARS) -20126 CONTINUE - GO TO 20121 -C -20123 TRANS=.TRUE. - CALL LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,DUALS,TRANS) - DULNRM=DASUM(MRELAS,DUALS,1) - GO TO NPR003, (20042,20074,20109) - END diff --git a/slatec/dplpup.f b/slatec/dplpup.f deleted file mode 100644 index 2c77a98..0000000 --- a/slatec/dplpup.f +++ /dev/null @@ -1,214 +0,0 @@ -*DECK DPLPUP - SUBROUTINE DPLPUP (DUSRMT, MRELAS, NVARS, PRGOPT, DATTRV, BL, BU, - + IND, INFO, AMAT, IMAT, SIZEUP, ASMALL, ABIG) -C***BEGIN PROLOGUE DPLPUP -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSPLP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (SPLPUP-S, DPLPUP-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO -C DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. -C -C USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. -C /REAL (12 BLANKS)/DOUBLE PRECISION/. -C -C REVISED 810613-1130 -C REVISED YYMMDD-HHMM -C -C THIS SUBROUTINE COLLECTS INFORMATION ABOUT THE BOUNDS AND MATRIX -C FROM THE USER. IT IS PART OF THE DSPLP( ) PACKAGE. -C -C***SEE ALSO DSPLP -C***ROUTINES CALLED DPCHNG, DPNNZR, XERMSG -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890605 Corrected references to XERRWV. (WRB) -C 890605 Removed unreferenced labels. (WRB) -C 891009 Removed unreferenced variables. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls, changed do-it-yourself -C DO loops to DO loops. (RWC) -C 900602 Get rid of ASSIGNed GOTOs. (RWC) -C***END PROLOGUE DPLPUP - DOUBLE PRECISION ABIG,AIJ,AMAT(*),AMN,AMX,ASMALL,BL(*), - * BU(*),DATTRV(*),PRGOPT(*),XVAL,ZERO - INTEGER IFLAG(10),IMAT(*),IND(*) - LOGICAL SIZEUP,FIRST - CHARACTER*8 XERN1, XERN2 - CHARACTER*16 XERN3, XERN4 -C -C***FIRST EXECUTABLE STATEMENT DPLPUP - ZERO = 0.D0 -C -C CHECK USER-SUPPLIED BOUNDS -C -C CHECK THAT IND(*) VALUES ARE 1,2,3 OR 4. -C ALSO CHECK CONSISTENCY OF UPPER AND LOWER BOUNDS. -C - DO 10 J=1,NVARS - IF (IND(J).LT.1 .OR. IND(J).GT.4) THEN - WRITE (XERN1, '(I8)') J - CALL XERMSG ('SLATEC', 'DPLPUP', - * 'IN DSPLP, INDEPENDENT VARIABLE = ' // XERN1 // - * ' IS NOT DEFINED.', 10, 1) - INFO = -10 - RETURN - ENDIF -C - IF (IND(J).EQ.3) THEN - IF (BL(J).GT.BU(J)) THEN - WRITE (XERN1, '(I8)') J - WRITE (XERN3, '(1PE15.6)') BL(J) - WRITE (XERN4, '(1PE15.6)') BU(J) - CALL XERMSG ('SLATEC', 'DPLPUP', - * 'IN DSPLP, LOWER BOUND = ' // XERN3 // - * ' AND UPPER BOUND = ' // XERN4 // - * ' FOR INDEPENDENT VARIABLE = ' // XERN1 // - * ' ARE NOT CONSISTENT.', 11, 1) - RETURN - ENDIF - ENDIF - 10 CONTINUE -C - DO 20 I=NVARS+1,NVARS+MRELAS - IF (IND(I).LT.1 .OR. IND(I).GT.4) THEN - WRITE (XERN1, '(I8)') I-NVARS - CALL XERMSG ('SLATEC', 'DPLPUP', - * 'IN DSPLP, DEPENDENT VARIABLE = ' // XERN1 // - * ' IS NOT DEFINED.', 12, 1) - INFO = -12 - RETURN - ENDIF -C - IF (IND(I).EQ.3) THEN - IF (BL(I).GT.BU(I)) THEN - WRITE (XERN1, '(I8)') I - WRITE (XERN3, '(1PE15.6)') BL(I) - WRITE (XERN4, '(1PE15.6)') BU(I) - CALL XERMSG ('SLATEC', 'DPLPUP', - * 'IN DSPLP, LOWER BOUND = ' // XERN3 // - * ' AND UPPER BOUND = ' // XERN4 // - * ' FOR DEPENDANT VARIABLE = ' // XERN1 // - * ' ARE NOT CONSISTENT.',13,1) - INFO = -13 - RETURN - ENDIF - ENDIF - 20 CONTINUE -C -C GET UPDATES OR DATA FOR MATRIX FROM THE USER -C -C GET THE ELEMENTS OF THE MATRIX FROM THE USER. IT WILL BE STORED -C BY COLUMNS USING THE SPARSE STORAGE CODES OF RJ HANSON AND -C JA WISNIEWSKI. -C - IFLAG(1) = 1 -C -C KEEP ACCEPTING ELEMENTS UNTIL THE USER IS FINISHED GIVING THEM. -C LIMIT THIS LOOP TO 2*NVARS*MRELAS ITERATIONS. -C - ITMAX = 2*NVARS*MRELAS+1 - ITCNT = 0 - FIRST = .TRUE. -C -C CHECK ON THE ITERATION COUNT. -C - 30 ITCNT = ITCNT+1 - IF (ITCNT.GT.ITMAX) THEN - CALL XERMSG ('SLATEC', 'DPLPUP', - + 'IN DSPLP, MORE THAN 2*NVARS*MRELAS ITERATIONS DEFINING ' // - + 'OR UPDATING MATRIX DATA.', 7, 1) - INFO = -7 - RETURN - ENDIF -C - AIJ = ZERO - CALL DUSRMT(I,J,AIJ,INDCAT,PRGOPT,DATTRV,IFLAG) - IF (IFLAG(1).EQ.1) THEN - IFLAG(1) = 2 - GO TO 30 - ENDIF -C -C CHECK TO SEE THAT THE SUBSCRIPTS I AND J ARE VALID. -C - IF (I.LT.1 .OR. I.GT.MRELAS .OR. J.LT.1 .OR. J.GT.NVARS) THEN -C -C CHECK ON SIZE OF MATRIX DATA -C RECORD THE LARGEST AND SMALLEST(IN MAGNITUDE) NONZERO ELEMENTS. -C - IF (IFLAG(1).EQ.3) THEN - IF (SIZEUP .AND. ABS(AIJ).NE.ZERO) THEN - IF (FIRST) THEN - AMX = ABS(AIJ) - AMN = ABS(AIJ) - FIRST = .FALSE. - ELSEIF (ABS(AIJ).GT.AMX) THEN - AMX = ABS(AIJ) - ELSEIF (ABS(AIJ).LT.AMN) THEN - AMN = ABS(AIJ) - ENDIF - ENDIF - GO TO 40 - ENDIF -C - WRITE (XERN1, '(I8)') I - WRITE (XERN2, '(I8)') J - CALL XERMSG ('SLATEC', 'DPLPUP', - * 'IN DSPLP, ROW INDEX = ' // XERN1 // ' OR COLUMN INDEX = ' - * // XERN2 // ' IS OUT OF RANGE.', 8, 1) - INFO = -8 - RETURN - ENDIF -C -C IF INDCAT=0 THEN SET A(I,J)=AIJ. -C IF INDCAT=1 THEN ACCUMULATE ELEMENT, A(I,J)=A(I,J)+AIJ. -C - IF (INDCAT.EQ.0) THEN - CALL DPCHNG(I,AIJ,IPLACE,AMAT,IMAT,J) - ELSEIF (INDCAT.EQ.1) THEN - INDEX = -(I-1) - CALL DPNNZR(INDEX,XVAL,IPLACE,AMAT,IMAT,J) - IF (INDEX.EQ.I) AIJ=AIJ+XVAL - CALL DPCHNG(I,AIJ,IPLACE,AMAT,IMAT,J) - ELSE - WRITE (XERN1, '(I8)') INDCAT - CALL XERMSG ('SLATEC', 'DPLPUP', - * 'IN DSPLP, INDICATION FLAG = ' // XERN1 // - * ' FOR MATRIX DATA MUST BE EITHER 0 OR 1.', 9, 1) - INFO = -9 - RETURN - ENDIF -C -C CHECK ON SIZE OF MATRIX DATA -C RECORD THE LARGEST AND SMALLEST(IN MAGNITUDE) NONZERO ELEMENTS. -C - IF (SIZEUP .AND. ABS(AIJ).NE.ZERO) THEN - IF (FIRST) THEN - AMX = ABS(AIJ) - AMN = ABS(AIJ) - FIRST = .FALSE. - ELSEIF (ABS(AIJ).GT.AMX) THEN - AMX = ABS(AIJ) - ELSEIF (ABS(AIJ).LT.AMN) THEN - AMN = ABS(AIJ) - ENDIF - ENDIF - IF (IFLAG(1).NE.3) GO TO 30 -C - 40 IF (SIZEUP .AND. .NOT. FIRST) THEN - IF (AMN.LT.ASMALL .OR. AMX.GT.ABIG) THEN - CALL XERMSG ('SLATEC', 'DPLPUP', - + 'IN DSPLP, A MATRIX ELEMENT''S SIZE IS OUT OF THE ' // - + 'SPECIFIED RANGE.', 22, 1) - INFO = -22 - RETURN - ENDIF - ENDIF - RETURN - END diff --git a/slatec/dpnnzr.f b/slatec/dpnnzr.f deleted file mode 100644 index ccfaca1..0000000 --- a/slatec/dpnnzr.f +++ /dev/null @@ -1,260 +0,0 @@ -*DECK DPNNZR - SUBROUTINE DPNNZR (I, XVAL, IPLACE, SX, IX, IRCX) -C***BEGIN PROLOGUE DPNNZR -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSPLP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (PNNZRS-S, DPNNZR-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C -C DPNNZR LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SCHEME. -C SPARSE MATRIX NON ZERO RETRIEVAL SUBROUTINE. -C -C SUBROUTINE DPNNZR() GETS THE NEXT NONZERO VALUE IN ROW OR COLUMN -C +/- IRCX WITH AN INDEX GREATER THAN THE VALUE OF I. -C -C I ABSOLUTE VALUE OF THIS SUBSCRIPT IS TO BE EXCEEDED -C IN THE SEARCH FOR THE NEXT NONZERO VALUE. A NEGATIVE -C OR ZERO VALUE OF I CAUSES THE SEARCH TO START AT -C THE BEGINNING OF THE VECTOR. A POSITIVE VALUE -C OF I CAUSES THE SEARCH TO CONTINUE FROM THE LAST PLACE -C ACCESSED. ON OUTPUT, THE ARGUMENT I -C CONTAINS THE VALUE OF THE SUBSCRIPT FOUND. AN OUTPUT -C VALUE OF I EQUAL TO ZERO INDICATES THAT ALL COMPONENTS -C WITH AN INDEX GREATER THAN THE INPUT VALUE OF I ARE -C ZERO. -C XVAL VALUE OF THE NONZERO ELEMENT FOUND. ON OUTPUT, -C XVAL=0. WHENEVER I=0. -C IPLACE POINTER INFORMATION WHICH IS MAINTAINED BY THE PACKAGE. -C SX(*),IX(*) THE WORK ARRAYS WHICH ARE USED TO STORE THE SPARSE -C MATRIX. THESE ARRAY CONTENTS ARE AUTOMATICALLY -C MAINTAINED BY THE PACKAGE FOR THE USER. -C IRCX POINTS TO THE VECTOR OF THE MATRIX BEING SCANNED. A -C NEGATIVE VALUE OF IRCX INDICATES THAT ROW -IRCX IS TO BE -C SCANNED. A POSITIVE VALUE OF IRCX INDICATES THAT -C COLUMN IRCX IS TO BE SCANNED. A ZERO VALUE OF IRCX IS -C AN ERROR. -C -C THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LNNZRS, -C SANDIA LABS. REPT. SAND78-0785. -C MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON -C REVISED 811130-1000 -C REVISED YYMMDD-HHMM -C -C***SEE ALSO DSPLP -C***ROUTINES CALLED IDLOC, XERMSG -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890605 Removed unreferenced labels. (WRB) -C 890606 Changed references from IPLOC to IDLOC. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 910403 Updated AUTHOR and DESCRIPTION sections. (WRB) -C***END PROLOGUE DPNNZR - DIMENSION IX(*) - DOUBLE PRECISION XVAL,SX(*),ZERO - SAVE ZERO - DATA ZERO /0.D0/ -C***FIRST EXECUTABLE STATEMENT DPNNZR - IOPT=1 -C -C CHECK VALIDITY OF ROW/COL. INDEX. -C - IF (.NOT.(IRCX .EQ.0)) GO TO 20002 - NERR=55 - CALL XERMSG ('SLATEC', 'DPNNZR', 'IRCX=0', NERR, IOPT) -C -C LMX IS THE LENGTH OF THE IN-MEMORY STORAGE AREA. -C -20002 LMX = IX(1) - IF (.NOT.(IRCX.LT.0)) GO TO 20005 -C -C CHECK SUBSCRIPTS OF THE ROW. THE ROW NUMBER MUST BE .LE. M AND -C THE INDEX MUST BE .LE. N. -C - IF (.NOT.(IX(2).LT.-IRCX .OR. IX(3).LT.ABS(I))) GO TO 20008 - NERR=55 - CALL XERMSG ('SLATEC', 'DPNNZR', - + 'SUBSCRIPTS FOR ARRAY ELEMENT TO BE ACCESSED WERE OUT OF ' // - + 'BOUNDS.', NERR, IOPT) -20008 L=IX(3) - GO TO 20006 -C -C CHECK SUBSCRIPTS OF THE COLUMN. THE COL. NUMBER MUST BE .LE. N AND -C THE INDEX MUST BE .LE. M. -C -20005 IF (.NOT.(IRCX.GT.IX(3) .OR. ABS(I).GT.IX(2))) GO TO 20011 - NERR=55 - CALL XERMSG ('SLATEC', 'DPNNZR', - + 'SUBSCRIPTS FOR ARRAY ELEMENT TO BE ACCESSED WERE OUT OF ' // - + 'BOUNDS', NERR, IOPT) -20011 L=IX(2) -C -C HERE L IS THE LARGEST POSSIBLE SUBSCRIPT WITHIN THE VECTOR. -C -20006 J=ABS(IRCX) - LL=IX(3)+4 - LPG = LMX - LL - IF (.NOT.(IRCX.GT.0)) GO TO 20014 -C -C SEARCHING FOR THE NEXT NONZERO IN A COLUMN. -C -C INITIALIZE STARTING LOCATIONS.. - IF (.NOT.(I.LE.0)) GO TO 20017 - IF (.NOT.(J.EQ.1)) GO TO 20020 - IPLACE=LL+1 - GO TO 20021 -20020 IPLACE=IX(J+3)+1 -20021 CONTINUE -C -C THE CASE I.LE.0 SIGNALS THAT THE SCAN FOR THE ENTRY -C IS TO BEGIN AT THE START OF THE VECTOR. -C -20017 I = ABS(I) - IF (.NOT.(J.EQ.1)) GO TO 20023 - ISTART = LL+1 - GO TO 20024 -20023 ISTART=IX(J+3)+1 -20024 IEND = IX(J+4) -C -C VALIDATE IPLACE. SET TO START OF VECTOR IF OUT OF RANGE. -C - IF (.NOT.(ISTART.GT.IPLACE .OR. IPLACE.GT.IEND)) GO TO 20026 - IF (.NOT.(J.EQ.1)) GO TO 20029 - IPLACE=LL+1 - GO TO 20030 -20029 IPLACE=IX(J+3)+1 -20030 CONTINUE -C -C SCAN THROUGH SEVERAL PAGES, IF NECESSARY, TO FIND MATRIX ENTRY. -C -20026 IPL = IDLOC(IPLACE,SX,IX) -C -C FIX UP IPLACE AND IPL IF THEY POINT TO PAGING DATA. -C THIS IS NECESSARY BECAUSE THERE IS CONTROL INFORMATION AT THE -C END OF EACH PAGE. -C - IDIFF = LMX - IPL - IF (.NOT.(IDIFF.LE.1.AND.IX(LMX-1).GT.0)) GO TO 20032 -C -C UPDATE THE RELATIVE ADDRESS IN A NEW PAGE. -C - IPLACE = IPLACE + IDIFF + 1 - IPL = IDLOC(IPLACE,SX,IX) -20032 NP = ABS(IX(LMX-1)) - GO TO 20036 -20035 IF (ILAST.EQ.IEND) GO TO 20037 -20036 ILAST = MIN(IEND,NP*LPG+LL-2) -C -C THE VIRTUAL END OF THE DATA FOR THIS PAGE IS ILAST. -C - IL = IDLOC(ILAST,SX,IX) - IL = MIN(IL,LMX-2) -C -C THE RELATIVE END OF DATA FOR THIS PAGE IS IL. -C SEARCH FOR A NONZERO VALUE WITH AN INDEX .GT. I ON THE PRESENT -C PAGE. -C -20038 IF (.NOT.(.NOT.(IPL.GE.IL.OR.(IX(IPL).GT.I.AND.SX(IPL).NE.ZERO)))) - * GO TO 20039 - IPL=IPL+1 - GO TO 20038 -C -C TEST IF WE HAVE FOUND THE NEXT NONZERO. -C -20039 IF (.NOT.(IX(IPL).GT.I .AND. SX(IPL).NE.ZERO .AND. IPL.LE.IL)) GO - *TO 20040 - I = IX(IPL) - XVAL = SX(IPL) - IPLACE = (NP-1)*LPG + IPL - RETURN -C -C UPDATE TO SCAN THE NEXT PAGE. -20040 IPL = LL + 1 - NP = NP + 1 - GO TO 20035 -C -C NO DATA WAS FOUND. END OF VECTOR ENCOUNTERED. -C -20037 I = 0 - XVAL = ZERO - IL = IL + 1 - IF(IL.EQ.LMX-1) IL = IL + 2 -C -C IF A NEW ITEM WOULD BE INSERTED, IPLACE POINTS TO THE PLACE -C TO PUT IT. -C - IPLACE = (NP-1)*LPG + IL - RETURN -C -C SEARCH A ROW FOR THE NEXT NONZERO. -C FIND ELEMENT J=ABS(IRCX) IN ROWS ABS(I)+1,...,L. -C -20014 I=ABS(I) -C -C CHECK FOR END OF VECTOR. -C - IF (.NOT.(I.EQ.L)) GO TO 20043 - I=0 - XVAL=ZERO - RETURN -20043 I1 = I+1 - II=I1 - N20046=L - GO TO 20047 -20046 II=II+1 -20047 IF ((N20046-II).LT.0) GO TO 20048 -C -C INITIALIZE IPPLOC FOR ORTHOGONAL SCAN. -C LOOK FOR J AS A SUBSCRIPT IN ROWS II, II=I+1,...,L. -C - IF (.NOT.(II.EQ.1)) GO TO 20050 - IPPLOC = LL + 1 - GO TO 20051 -20050 IPPLOC = IX(II+3) + 1 -20051 IEND = IX(II+4) -C -C SCAN THROUGH SEVERAL PAGES, IF NECESSARY, TO FIND MATRIX ENTRY. -C - IPL = IDLOC(IPPLOC,SX,IX) -C -C FIX UP IPPLOC AND IPL TO POINT TO MATRIX DATA. -C - IDIFF = LMX - IPL - IF (.NOT.(IDIFF.LE.1.AND.IX(LMX-1).GT.0)) GO TO 20053 - IPPLOC = IPPLOC + IDIFF + 1 - IPL = IDLOC(IPPLOC,SX,IX) -20053 NP = ABS(IX(LMX-1)) - GO TO 20057 -20056 IF (ILAST.EQ.IEND) GO TO 20058 -20057 ILAST = MIN(IEND,NP*LPG+LL-2) - IL = IDLOC(ILAST,SX,IX) - IL = MIN(IL,LMX-2) -20059 IF (.NOT.(.NOT.(IPL.GE.IL .OR. IX(IPL).GE.J))) GO TO 20060 - IPL=IPL+1 - GO TO 20059 -C -C TEST IF WE HAVE FOUND THE NEXT NONZERO. -C -20060 IF (.NOT.(IX(IPL).EQ.J .AND. SX(IPL).NE.ZERO .AND. IPL.LE.IL)) GO - *TO 20061 - I = II - XVAL = SX(IPL) - RETURN -20061 IF(IX(IPL).GE.J) ILAST = IEND - IPL = LL + 1 - NP = NP + 1 - GO TO 20056 -20058 GO TO 20046 -C -C ORTHOGONAL SCAN FAILED. THE VALUE J WAS NOT A SUBSCRIPT -C IN ANY ROW. -C -20048 I=0 - XVAL=ZERO - RETURN - END diff --git a/slatec/dpoch.f b/slatec/dpoch.f deleted file mode 100644 index 2283e45..0000000 --- a/slatec/dpoch.f +++ /dev/null @@ -1,102 +0,0 @@ -*DECK DPOCH - DOUBLE PRECISION FUNCTION DPOCH (A, X) -C***BEGIN PROLOGUE DPOCH -C***PURPOSE Evaluate a generalization of Pochhammer's symbol. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C1, C7A -C***TYPE DOUBLE PRECISION (POCH-S, DPOCH-D) -C***KEYWORDS FNLIB, POCHHAMMER, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate a double precision generalization of Pochhammer's symbol -C (A)-sub-X = GAMMA(A+X)/GAMMA(A) for double precision A and X. -C For X a non-negative integer, POCH(A,X) is just Pochhammer's symbol. -C This is a preliminary version that does not handle wrong arguments -C properly and may not properly handle the case when the result is -C computed to less than half of double precision. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D9LGMC, DFAC, DGAMMA, DGAMR, DLGAMS, DLNREL, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 890911 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 900727 Added EXTERNAL statement. (WRB) -C***END PROLOGUE DPOCH - DOUBLE PRECISION A, X, ABSA, ABSAX, ALNGA, ALNGAX, AX, B, PI, - 1 SGNGA, SGNGAX, DFAC, DLNREL, D9LGMC, DGAMMA, DGAMR, DCOT - EXTERNAL DGAMMA - SAVE PI - DATA PI / 3.1415926535 8979323846 2643383279 503 D0 / -C***FIRST EXECUTABLE STATEMENT DPOCH - AX = A + X - IF (AX.GT.0.0D0) GO TO 30 - IF (AINT(AX).NE.AX) GO TO 30 -C - IF (A .GT. 0.0D0 .OR. AINT(A) .NE. A) CALL XERMSG ('SLATEC', - + 'DPOCH', 'A+X IS NON-POSITIVE INTEGER BUT A IS NOT', 2, 2) -C -C WE KNOW HERE THAT BOTH A+X AND A ARE NON-POSITIVE INTEGERS. -C - DPOCH = 1.0D0 - IF (X.EQ.0.D0) RETURN -C - N = X - IF (MIN(A+X,A).LT.(-20.0D0)) GO TO 20 -C - IA = A - DPOCH = (-1.0D0)**N * DFAC(-IA)/DFAC(-IA-N) - RETURN -C - 20 DPOCH = (-1.0D0)**N * EXP ((A-0.5D0)*DLNREL(X/(A-1.0D0)) - 1 + X*LOG(-A+1.0D0-X) - X + D9LGMC(-A+1.0D0) - D9LGMC(-A-X+1.D0)) - RETURN -C -C A+X IS NOT ZERO OR A NEGATIVE INTEGER. -C - 30 DPOCH = 0.0D0 - IF (A.LE.0.0D0 .AND. AINT(A).EQ.A) RETURN -C - N = ABS(X) - IF (DBLE(N).NE.X .OR. N.GT.20) GO TO 50 -C -C X IS A SMALL NON-POSITIVE INTEGER, PRESUMMABLY A COMMON CASE. -C - DPOCH = 1.0D0 - IF (N.EQ.0) RETURN - DO 40 I=1,N - DPOCH = DPOCH * (A+I-1) - 40 CONTINUE - RETURN -C - 50 ABSAX = ABS(A+X) - ABSA = ABS(A) - IF (MAX(ABSAX,ABSA).GT.20.0D0) GO TO 60 - DPOCH = DGAMMA(A+X) * DGAMR(A) - RETURN -C - 60 IF (ABS(X).GT.0.5D0*ABSA) GO TO 70 -C -C ABS(X) IS SMALL AND BOTH ABS(A+X) AND ABS(A) ARE LARGE. THUS, -C A+X AND A MUST HAVE THE SAME SIGN. FOR NEGATIVE A, WE USE -C GAMMA(A+X)/GAMMA(A) = GAMMA(-A+1)/GAMMA(-A-X+1) * -C SIN(PI*A)/SIN(PI*(A+X)) -C - B = A - IF (B.LT.0.0D0) B = -A - X + 1.0D0 - DPOCH = EXP ((B-0.5D0)*DLNREL(X/B) + X*LOG(B+X) - X - 1 + D9LGMC(B+X) - D9LGMC(B) ) - IF (A.LT.0.0D0 .AND. DPOCH.NE.0.0D0) DPOCH = - 1 DPOCH/(COS(PI*X) + DCOT(PI*A)*SIN(PI*X) ) - RETURN -C - 70 CALL DLGAMS (A+X, ALNGAX, SGNGAX) - CALL DLGAMS (A, ALNGA, SGNGA) - DPOCH = SGNGAX * SGNGA * EXP(ALNGAX-ALNGA) -C - RETURN - END diff --git a/slatec/dpoch1.f b/slatec/dpoch1.f deleted file mode 100644 index 5b8b65b..0000000 --- a/slatec/dpoch1.f +++ /dev/null @@ -1,160 +0,0 @@ -*DECK DPOCH1 - DOUBLE PRECISION FUNCTION DPOCH1 (A, X) -C***BEGIN PROLOGUE DPOCH1 -C***PURPOSE Calculate a generalization of Pochhammer's symbol starting -C from first order. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C1, C7A -C***TYPE DOUBLE PRECISION (POCH1-S, DPOCH1-D) -C***KEYWORDS FIRST ORDER, FNLIB, POCHHAMMER, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate a double precision generalization of Pochhammer's symbol -C for double precision A and X for special situations that require -C especially accurate values when X is small in -C POCH1(A,X) = (POCH(A,X)-1)/X -C = (GAMMA(A+X)/GAMMA(A) - 1.0)/X . -C This specification is particularly suited for stably computing -C expressions such as -C (GAMMA(A+X)/GAMMA(A) - GAMMA(B+X)/GAMMA(B))/X -C = POCH1(A,X) - POCH1(B,X) -C Note that POCH1(A,0.0) = PSI(A) -C -C When ABS(X) is so small that substantial cancellation will occur if -C the straightforward formula is used, we use an expansion due -C to Fields and discussed by Y. L. Luke, The Special Functions and Their -C Approximations, Vol. 1, Academic Press, 1969, page 34. -C -C The ratio POCH(A,X) = GAMMA(A+X)/GAMMA(A) is written by Luke as -C (A+(X-1)/2)**X * polynomial in (A+(X-1)/2)**(-2) . -C In order to maintain significance in POCH1, we write for positive a -C (A+(X-1)/2)**X = EXP(X*LOG(A+(X-1)/2)) = EXP(Q) -C = 1.0 + Q*EXPREL(Q) . -C Likewise the polynomial is written -C POLY = 1.0 + X*POLY1(A,X) . -C Thus, -C POCH1(A,X) = (POCH(A,X) - 1) / X -C = EXPREL(Q)*(Q/X + Q*POLY1(A,X)) + POLY1(A,X) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DCOT, DEXPRL, DPOCH, DPSI, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770801 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 890911 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 900727 Added EXTERNAL statement. (WRB) -C***END PROLOGUE DPOCH1 - DOUBLE PRECISION A, X, ABSA, ABSX, ALNEPS, ALNVAR, B, BERN(20), - 1 BINV, BP, GBERN(21), GBK, PI, POLY1, Q, RHO, SINPXX, SINPX2, - 2 SQTBIG, TERM, TRIG, VAR, VAR2, D1MACH, DPSI, DEXPRL, DCOT, DPOCH - LOGICAL FIRST - EXTERNAL DCOT - SAVE BERN, PI, SQTBIG, ALNEPS, FIRST - DATA BERN ( 1) / +.8333333333 3333333333 3333333333 333 D-1 / - DATA BERN ( 2) / -.1388888888 8888888888 8888888888 888 D-2 / - DATA BERN ( 3) / +.3306878306 8783068783 0687830687 830 D-4 / - DATA BERN ( 4) / -.8267195767 1957671957 6719576719 576 D-6 / - DATA BERN ( 5) / +.2087675698 7868098979 2100903212 014 D-7 / - DATA BERN ( 6) / -.5284190138 6874931848 4768220217 955 D-9 / - DATA BERN ( 7) / +.1338253653 0684678832 8269809751 291 D-10 / - DATA BERN ( 8) / -.3389680296 3225828668 3019539124 944 D-12 / - DATA BERN ( 9) / +.8586062056 2778445641 3590545042 562 D-14 / - DATA BERN ( 10) / -.2174868698 5580618730 4151642386 591 D-15 / - DATA BERN ( 11) / +.5509002828 3602295152 0265260890 225 D-17 / - DATA BERN ( 12) / -.1395446468 5812523340 7076862640 635 D-18 / - DATA BERN ( 13) / +.3534707039 6294674716 9322997780 379 D-20 / - DATA BERN ( 14) / -.8953517427 0375468504 0261131811 274 D-22 / - DATA BERN ( 15) / +.2267952452 3376830603 1095073886 816 D-23 / - DATA BERN ( 16) / -.5744724395 2026452383 4847971943 400 D-24 / - DATA BERN ( 17) / +.1455172475 6148649018 6626486727 132 D-26 / - DATA BERN ( 18) / -.3685994940 6653101781 8178247990 866 D-28 / - DATA BERN ( 19) / +.9336734257 0950446720 3255515278 562 D-30 / - DATA BERN ( 20) / -.2365022415 7006299345 5963519636 983 D-31 / - DATA PI / 3.1415926535 8979323846 2643383279 503 D0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DPOCH1 - IF (FIRST) THEN - SQTBIG = 1.0D0/SQRT(24.0D0*D1MACH(1)) - ALNEPS = LOG(D1MACH(3)) - ENDIF - FIRST = .FALSE. -C - IF (X.EQ.0.0D0) DPOCH1 = DPSI(A) - IF (X.EQ.0.0D0) RETURN -C - ABSX = ABS(X) - ABSA = ABS(A) - IF (ABSX.GT.0.1D0*ABSA) GO TO 70 - IF (ABSX*LOG(MAX(ABSA,2.0D0)).GT.0.1D0) GO TO 70 -C - BP = A - IF (A.LT.(-0.5D0)) BP = 1.0D0 - A - X - INCR = 0 - IF (BP.LT.10.0D0) INCR = 11.0D0 - BP - B = BP + INCR -C - VAR = B + 0.5D0*(X-1.0D0) - ALNVAR = LOG(VAR) - Q = X*ALNVAR -C - POLY1 = 0.0D0 - IF (VAR.GE.SQTBIG) GO TO 40 - VAR2 = (1.0D0/VAR)**2 -C - RHO = 0.5D0*(X+1.0D0) - GBERN(1) = 1.0D0 - GBERN(2) = -RHO/12.0D0 - TERM = VAR2 - POLY1 = GBERN(2)*TERM -C - NTERMS = -0.5D0*ALNEPS/ALNVAR + 1.0D0 - IF (NTERMS .GT. 20) CALL XERMSG ('SLATEC', 'DPOCH1', - + 'NTERMS IS TOO BIG, MAYBE D1MACH(3) IS BAD', 1, 2) - IF (NTERMS.LT.2) GO TO 40 -C - DO 30 K=2,NTERMS - GBK = 0.0D0 - DO 20 J=1,K - NDX = K - J + 1 - GBK = GBK + BERN(NDX)*GBERN(J) - 20 CONTINUE - GBERN(K+1) = -RHO*GBK/K -C - TERM = TERM * (2*K-2-X)*(2*K-1-X)*VAR2 - POLY1 = POLY1 + GBERN(K+1)*TERM - 30 CONTINUE -C - 40 POLY1 = (X-1.0D0)*POLY1 - DPOCH1 = DEXPRL(Q)*(ALNVAR+Q*POLY1) + POLY1 -C - IF (INCR.EQ.0) GO TO 60 -C -C WE HAVE DPOCH1(B,X), BUT BP IS SMALL, SO WE USE BACKWARDS RECURSION -C TO OBTAIN DPOCH1(BP,X). -C - DO 50 II=1,INCR - I = INCR - II - BINV = 1.0D0/(BP+I) - DPOCH1 = (DPOCH1 - BINV) / (1.0D0 + X*BINV) - 50 CONTINUE -C - 60 IF (BP.EQ.A) RETURN -C -C WE HAVE DPOCH1(BP,X), BUT A IS LT -0.5. WE THEREFORE USE A REFLECTION -C FORMULA TO OBTAIN DPOCH1(A,X). -C - SINPXX = SIN(PI*X)/X - SINPX2 = SIN(0.5D0*PI*X) - TRIG = SINPXX*DCOT(PI*B) - 2.0D0*SINPX2*(SINPX2/X) -C - DPOCH1 = TRIG + (1.0D0 + X*TRIG)*DPOCH1 - RETURN -C - 70 DPOCH1 = (DPOCH(A,X) - 1.0D0) / X - RETURN -C - END diff --git a/slatec/dpoco.f b/slatec/dpoco.f deleted file mode 100644 index ebde804..0000000 --- a/slatec/dpoco.f +++ /dev/null @@ -1,208 +0,0 @@ -*DECK DPOCO - SUBROUTINE DPOCO (A, LDA, N, RCOND, Z, INFO) -C***BEGIN PROLOGUE DPOCO -C***PURPOSE Factor a real symmetric positive definite matrix -C and estimate the condition of the matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1B -C***TYPE DOUBLE PRECISION (SPOCO-S, DPOCO-D, CPOCO-C) -C***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, -C MATRIX FACTORIZATION, POSITIVE DEFINITE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C DPOCO factors a double precision symmetric positive definite -C matrix and estimates the condition of the matrix. -C -C If RCOND is not needed, DPOFA is slightly faster. -C To solve A*X = B , follow DPOCO by DPOSL. -C To compute INVERSE(A)*C , follow DPOCO by DPOSL. -C To compute DETERMINANT(A) , follow DPOCO by DPODI. -C To compute INVERSE(A) , follow DPOCO by DPODI. -C -C On Entry -C -C A DOUBLE PRECISION(LDA, N) -C the symmetric matrix to be factored. Only the -C diagonal and upper triangle are used. -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 R so that A = TRANS(R)*R -C where TRANS(R) is the transpose. -C The strict lower triangle is unaltered. -C If INFO .NE. 0 , the factorization is not complete. -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. If INFO .NE. 0 , RCOND is unchanged. -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 If INFO .NE. 0 , Z is unchanged. -C -C INFO INTEGER -C = 0 for normal return. -C = K signals an error condition. The leading minor -C of order K is not positive definite. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DASUM, DAXPY, DDOT, DPOFA, DSCAL -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DPOCO - INTEGER LDA,N,INFO - DOUBLE PRECISION A(LDA,*),Z(*) - DOUBLE PRECISION RCOND -C - DOUBLE PRECISION DDOT,EK,T,WK,WKM - DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM - INTEGER I,J,JM1,K,KB,KP1 -C -C FIND NORM OF A USING ONLY UPPER HALF -C -C***FIRST EXECUTABLE STATEMENT DPOCO - DO 30 J = 1, N - Z(J) = DASUM(J,A(1,J),1) - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 20 - DO 10 I = 1, JM1 - Z(I) = Z(I) + ABS(A(I,J)) - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - ANORM = 0.0D0 - DO 40 J = 1, N - ANORM = MAX(ANORM,Z(J)) - 40 CONTINUE -C -C FACTOR -C - CALL DPOFA(A,LDA,N,INFO) - IF (INFO .NE. 0) GO TO 180 -C -C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . -C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . -C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL -C GROWTH IN THE ELEMENTS OF W WHERE TRANS(R)*W = E . -C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. -C -C SOLVE TRANS(R)*W = E -C - EK = 1.0D0 - DO 50 J = 1, N - Z(J) = 0.0D0 - 50 CONTINUE - DO 110 K = 1, N - IF (Z(K) .NE. 0.0D0) EK = SIGN(EK,-Z(K)) - IF (ABS(EK-Z(K)) .LE. A(K,K)) GO TO 60 - S = A(K,K)/ABS(EK-Z(K)) - CALL DSCAL(N,S,Z,1) - EK = S*EK - 60 CONTINUE - WK = EK - Z(K) - WKM = -EK - Z(K) - S = ABS(WK) - SM = ABS(WKM) - WK = WK/A(K,K) - WKM = WKM/A(K,K) - KP1 = K + 1 - IF (KP1 .GT. N) GO TO 100 - DO 70 J = KP1, N - SM = SM + ABS(Z(J)+WKM*A(K,J)) - Z(J) = Z(J) + WK*A(K,J) - S = S + ABS(Z(J)) - 70 CONTINUE - IF (S .GE. SM) GO TO 90 - T = WKM - WK - WK = WKM - DO 80 J = KP1, N - Z(J) = Z(J) + T*A(K,J) - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - Z(K) = WK - 110 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) -C -C SOLVE R*Y = W -C - DO 130 KB = 1, N - K = N + 1 - KB - IF (ABS(Z(K)) .LE. A(K,K)) GO TO 120 - S = A(K,K)/ABS(Z(K)) - CALL DSCAL(N,S,Z,1) - 120 CONTINUE - Z(K) = Z(K)/A(K,K) - T = -Z(K) - CALL DAXPY(K-1,T,A(1,K),1,Z(1),1) - 130 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) -C - YNORM = 1.0D0 -C -C SOLVE TRANS(R)*V = Y -C - DO 150 K = 1, N - Z(K) = Z(K) - DDOT(K-1,A(1,K),1,Z(1),1) - IF (ABS(Z(K)) .LE. A(K,K)) GO TO 140 - S = A(K,K)/ABS(Z(K)) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM - 140 CONTINUE - Z(K) = Z(K)/A(K,K) - 150 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE R*Z = V -C - DO 170 KB = 1, N - K = N + 1 - KB - IF (ABS(Z(K)) .LE. A(K,K)) GO TO 160 - S = A(K,K)/ABS(Z(K)) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM - 160 CONTINUE - Z(K) = Z(K)/A(K,K) - T = -Z(K) - CALL DAXPY(K-1,T,A(1,K),1,Z(1),1) - 170 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 - 180 CONTINUE - RETURN - END diff --git a/slatec/dpodi.f b/slatec/dpodi.f deleted file mode 100644 index ce2a745..0000000 --- a/slatec/dpodi.f +++ /dev/null @@ -1,136 +0,0 @@ -*DECK DPODI - SUBROUTINE DPODI (A, LDA, N, DET, JOB) -C***BEGIN PROLOGUE DPODI -C***PURPOSE Compute the determinant and inverse of a certain real -C symmetric positive definite matrix using the factors -C computed by DPOCO, DPOFA or DQRDC. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1B, D3B1B -C***TYPE DOUBLE PRECISION (SPODI-S, DPODI-D, CPODI-C) -C***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, -C POSITIVE DEFINITE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C DPODI computes the determinant and inverse of a certain -C double precision symmetric positive definite matrix (see below) -C using the factors computed by DPOCO, DPOFA or DQRDC. -C -C On Entry -C -C A DOUBLE PRECISION(LDA, N) -C the output A from DPOCO or DPOFA -C or the output X from DQRDC. -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 JOB INTEGER -C = 11 both determinant and inverse. -C = 01 inverse only. -C = 10 determinant only. -C -C On Return -C -C A If DPOCO or DPOFA was used to factor A , then -C DPODI produces the upper half of INVERSE(A) . -C If DQRDC was used to decompose X , then -C DPODI produces the upper half of inverse(TRANS(X)*X) -C where TRANS(X) is the transpose. -C Elements of A below the diagonal are unchanged. -C If the units digit of JOB is zero, A is unchanged. -C -C DET DOUBLE PRECISION(2) -C determinant of A or of TRANS(X)*X if requested. -C Otherwise not referenced. -C Determinant = DET(1) * 10.0**DET(2) -C with 1.0 .LE. 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 DPOCO or DPOFA has set INFO .EQ. 0 . -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DSCAL -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DPODI - INTEGER LDA,N,JOB - DOUBLE PRECISION A(LDA,*) - DOUBLE PRECISION DET(2) -C - DOUBLE PRECISION T - DOUBLE PRECISION S - INTEGER I,J,JM1,K,KP1 -C***FIRST EXECUTABLE STATEMENT DPODI -C -C COMPUTE DETERMINANT -C - IF (JOB/10 .EQ. 0) GO TO 70 - DET(1) = 1.0D0 - DET(2) = 0.0D0 - S = 10.0D0 - DO 50 I = 1, N - DET(1) = A(I,I)**2*DET(1) - IF (DET(1) .EQ. 0.0D0) GO TO 60 - 10 IF (DET(1) .GE. 1.0D0) GO TO 20 - DET(1) = S*DET(1) - DET(2) = DET(2) - 1.0D0 - GO TO 10 - 20 CONTINUE - 30 IF (DET(1) .LT. S) GO TO 40 - DET(1) = DET(1)/S - DET(2) = DET(2) + 1.0D0 - GO TO 30 - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE -C -C COMPUTE INVERSE(R) -C - IF (MOD(JOB,10) .EQ. 0) GO TO 140 - 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(R) * TRANS(INVERSE(R)) -C - DO 130 J = 1, N - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 120 - DO 110 K = 1, JM1 - T = A(K,J) - CALL DAXPY(K,T,A(1,J),1,A(1,K),1) - 110 CONTINUE - 120 CONTINUE - T = A(J,J) - CALL DSCAL(J,T,A(1,J),1) - 130 CONTINUE - 140 CONTINUE - RETURN - END diff --git a/slatec/dpofa.f b/slatec/dpofa.f deleted file mode 100644 index d8c9996..0000000 --- a/slatec/dpofa.f +++ /dev/null @@ -1,83 +0,0 @@ -*DECK DPOFA - SUBROUTINE DPOFA (A, LDA, N, INFO) -C***BEGIN PROLOGUE DPOFA -C***PURPOSE Factor a real symmetric positive definite matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1B -C***TYPE DOUBLE PRECISION (SPOFA-S, DPOFA-D, CPOFA-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, -C POSITIVE DEFINITE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C DPOFA factors a double precision symmetric positive definite -C matrix. -C -C DPOFA is usually called by DPOCO, but it can be called -C directly with a saving in time if RCOND is not needed. -C (time for DPOCO) = (1 + 18/N)*(time for DPOFA) . -C -C On Entry -C -C A DOUBLE PRECISION(LDA, N) -C the symmetric matrix to be factored. Only the -C diagonal and upper triangle are used. -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 R so that A = TRANS(R)*R -C where TRANS(R) is the transpose. -C The strict lower triangle is unaltered. -C If INFO .NE. 0 , the factorization is not complete. -C -C INFO INTEGER -C = 0 for normal return. -C = K signals an error condition. The leading minor -C of order K is not positive definite. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DDOT -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DPOFA - INTEGER LDA,N,INFO - DOUBLE PRECISION A(LDA,*) -C - DOUBLE PRECISION DDOT,T - DOUBLE PRECISION S - INTEGER J,JM1,K -C***FIRST EXECUTABLE STATEMENT DPOFA - DO 30 J = 1, N - INFO = J - S = 0.0D0 - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 20 - DO 10 K = 1, JM1 - T = A(K,J) - DDOT(K-1,A(1,K),1,A(1,J),1) - T = T/A(K,K) - A(K,J) = T - S = S + T*T - 10 CONTINUE - 20 CONTINUE - S = A(J,J) - S - IF (S .LE. 0.0D0) GO TO 40 - A(J,J) = SQRT(S) - 30 CONTINUE - INFO = 0 - 40 CONTINUE - RETURN - END diff --git a/slatec/dpofs.f b/slatec/dpofs.f deleted file mode 100644 index d5234c8..0000000 --- a/slatec/dpofs.f +++ /dev/null @@ -1,164 +0,0 @@ -*DECK DPOFS - SUBROUTINE DPOFS (A, LDA, N, V, ITASK, IND, WORK) -C***BEGIN PROLOGUE DPOFS -C***PURPOSE Solve a positive definite symmetric system of linear -C equations. -C***LIBRARY SLATEC -C***CATEGORY D2B1B -C***TYPE DOUBLE PRECISION (SPOFS-S, DPOFS-D, CPOFS-C) -C***KEYWORDS HERMITIAN, LINEAR EQUATIONS, POSITIVE DEFINITE, SYMMETRIC -C***AUTHOR Voorhees, E. A., (LANL) -C***DESCRIPTION -C -C Subroutine DPOFS solves a positive definite symmetric -C NxN system of double precision linear equations using -C LINPACK subroutines DPOCO and DPOSL. That is, if A is an -C NxN double precision positive definite symmetric matrix and if -C X and B are double precision N-vectors, then DPOFS solves -C the equation -C -C A*X=B. -C -C The matrix A is first factored into upper and lower tri- -C angular matrices R and R-TRANPOSE. These factors are used to -C find the solution vector X. An approximate condition number is -C calculated to provide a rough estimate of the number of -C digits of accuracy in the computed solution. -C -C If the equation A*X=B is to be solved for more than one vector -C B, the factoring of A does not need to be performed again and -C the option only to solve (ITASK .GT. 1) will be faster for -C the succeeding solutions. In this case, the contents of A, -C LDA, and N must not have been altered by the user following -C factorization (ITASK=1). IND will not be changed by DPOFS -C in this case. -C -C Argument Description *** -C -C A DOUBLE PRECISION(LDA,N) -C on entry, the doubly subscripted array with dimension -C (LDA,N) which contains the coefficient matrix. Only -C the upper triangle, including the diagonal, of the -C coefficient matrix need be entered and will subse- -C quently be referenced and changed by the routine. -C on return, A contains in its upper triangle an upper -C triangular matrix R such that A = (R-TRANPOSE) * R . -C LDA INTEGER -C the leading dimension of the array A. LDA must be great- -C er than or equal to N. (terminal error message IND=-1) -C N INTEGER -C the order of the matrix A. N must be greater -C than or equal to 1. (terminal error message IND=-2) -C V DOUBLE PRECISION(N) -C on entry, the singly subscripted array(vector) of di- -C mension N which contains the right hand side B of a -C system of simultaneous linear equations A*X=B. -C on return, V contains the solution vector, X . -C ITASK INTEGER -C If ITASK = 1, the matrix A is factored and then the -C linear equation is solved. -C If ITASK .GT. 1, the equation is solved using the existing -C factored matrix A. -C If ITASK .LT. 1, then terminal error message IND=-3 is -C printed. -C IND INTEGER -C GT. 0 IND is a rough estimate of the number of digits -C of accuracy in the solution, X. -C LT. 0 See error message corresponding to IND below. -C WORK DOUBLE PRECISION(N) -C a singly subscripted array of dimension at least N. -C -C Error Messages Printed *** -C -C IND=-1 Terminal N is greater than LDA. -C IND=-2 Terminal N is less than 1. -C IND=-3 Terminal ITASK is less than 1. -C IND=-4 Terminal The matrix A is computationally singular or -C is not positive definite. A solution -C has not been computed. -C IND=-10 Warning The solution has no apparent significance. -C The solution may be inaccurate or the -C matrix A may be poorly scaled. -C -C Note- The above Terminal(*fatal*) Error Messages are -C designed to be handled by XERMSG in which -C LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 -C for warning error messages from XERMSG. Unless -C the user provides otherwise, an error message -C will be printed followed by an abort. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED D1MACH, DPOCO, DPOSL, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800514 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 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 DPOFS -C - INTEGER LDA,N,ITASK,IND,INFO - DOUBLE PRECISION A(LDA,*),V(*),WORK(*),D1MACH - DOUBLE PRECISION RCOND - CHARACTER*8 XERN1, XERN2 -C***FIRST EXECUTABLE STATEMENT DPOFS - IF (LDA.LT.N) THEN - IND = -1 - WRITE (XERN1, '(I8)') LDA - WRITE (XERN2, '(I8)') N - CALL XERMSG ('SLATEC', 'DPOFS', 'LDA = ' // XERN1 // - * ' IS LESS THAN N = ' // XERN2, -1, 1) - RETURN - ENDIF -C - IF (N.LE.0) THEN - IND = -2 - WRITE (XERN1, '(I8)') N - CALL XERMSG ('SLATEC', 'DPOFS', 'N = ' // XERN1 // - * ' IS LESS THAN 1', -2, 1) - RETURN - ENDIF -C - IF (ITASK.LT.1) THEN - IND = -3 - WRITE (XERN1, '(I8)') ITASK - CALL XERMSG ('SLATEC', 'DPOFS', 'ITASK = ' // XERN1 // - * ' IS LESS THAN 1', -3, 1) - RETURN - ENDIF -C - IF (ITASK.EQ.1) THEN -C -C FACTOR MATRIX A INTO R -C - CALL DPOCO(A,LDA,N,RCOND,WORK,INFO) -C -C CHECK FOR POSITIVE DEFINITE MATRIX -C - IF (INFO.NE.0) THEN - IND = -4 - CALL XERMSG ('SLATEC', 'DPOFS', - * 'SINGULAR OR NOT POSITIVE DEFINITE - NO SOLUTION', -4, 1) - RETURN - ENDIF -C -C COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) -C AND CHECK FOR IND GREATER THAN ZERO -C - IND = -LOG10(D1MACH(4)/RCOND) - IF (IND.EQ.0) THEN - IND = -10 - CALL XERMSG ('SLATEC', 'DPOFS', - * 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) - ENDIF - ENDIF -C -C SOLVE AFTER FACTORING -C - CALL DPOSL(A,LDA,N,V) - RETURN - END diff --git a/slatec/dpolcf.f b/slatec/dpolcf.f deleted file mode 100644 index 72f23df..0000000 --- a/slatec/dpolcf.f +++ /dev/null @@ -1,96 +0,0 @@ -*DECK DPOLCF - SUBROUTINE DPOLCF (XX, N, X, C, D, WORK) -C***BEGIN PROLOGUE DPOLCF -C***PURPOSE Compute the coefficients of the polynomial fit (including -C Hermite polynomial fits) produced by a previous call to -C POLINT. -C***LIBRARY SLATEC -C***CATEGORY E1B -C***TYPE DOUBLE PRECISION (POLCOF-S, DPOLCF-D) -C***KEYWORDS COEFFICIENTS, POLYNOMIAL -C***AUTHOR Huddleston, R. E., (SNLL) -C***DESCRIPTION -C -C Abstract -C Subroutine DPOLCF computes the coefficients of the polynomial -C fit (including Hermite polynomial fits ) produced by a previous -C call to DPLINT. The coefficients of the polynomial, expanded -C about XX, are stored in the array D. The expansion is of the form -C P(Z) = D(1) + D(2)*(Z-XX) +D(3)*((Z-XX)**2) + ... + -C D(N)*((Z-XX)**(N-1)). -C Between the call to DPLINT and the call to DPOLCF the variable N -C and the arrays X and C must not be altered. -C -C ***** INPUT PARAMETERS -C *** All TYPE REAL variables are DOUBLE PRECISION *** -C -C XX - The point about which the Taylor expansion is to be made. -C -C N - **** -C * N, X, and C must remain unchanged between the -C X - * call to DPLINT and the call to DPOLCF. -C C - **** -C -C ***** OUTPUT PARAMETER -C *** All TYPE REAL variables are DOUBLE PRECISION *** -C -C D - The array of coefficients for the Taylor expansion as -C explained in the abstract -C -C ***** STORAGE PARAMETER -C -C WORK - This is an array to provide internal working storage. It -C must be dimensioned by at least 2*N in the calling program. -C -C -C **** Note - There are two methods for evaluating the fit produced -C by DPLINT. You may call DPOLVL to perform the task, or you may -C call DPOLCF to obtain the coefficients of the Taylor expansion and -C then write your own evaluation scheme. Due to the inherent errors -C in the computations of the Taylor expansion from the Newton -C coefficients produced by DPLINT, much more accuracy may be -C expected by calling DPOLVL as opposed to writing your own scheme. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 890213 DATE WRITTEN -C 891006 Cosmetic changes to prologue. (WRB) -C 891024 Corrected KEYWORD section. (WRB) -C 891024 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE DPOLCF -C - INTEGER I,IM1,K,KM1,KM1PI,KM2N,KM2NPI,N,NM1,NMKP1,NPKM1 - DOUBLE PRECISION C(*),D(*),PONE,PTWO,X(*),XX,WORK(*) -C***FIRST EXECUTABLE STATEMENT DPOLCF - DO 10010 K=1,N - D(K)=C(K) -10010 CONTINUE - IF (N.EQ.1) RETURN - WORK(1)=1.0D0 - PONE=C(1) - NM1=N-1 - DO 10020 K=2,N - KM1=K-1 - NPKM1=N+K-1 - WORK(NPKM1)=XX-X(KM1) - WORK(K)=WORK(NPKM1)*WORK(KM1) - PTWO=PONE+WORK(K)*C(K) - PONE=PTWO -10020 CONTINUE - D(1)=PTWO - IF (N.EQ.2) RETURN - DO 10030 K=2,NM1 - KM1=K-1 - KM2N=K-2+N - NMKP1=N-K+1 - DO 10030 I=2,NMKP1 - KM2NPI=KM2N+I - IM1=I-1 - KM1PI=KM1+I - WORK(I)=WORK(KM2NPI)*WORK(IM1)+WORK(I) - D(K)=D(K)+WORK(I)*D(KM1PI) -10030 CONTINUE - RETURN - END diff --git a/slatec/dpolft.f b/slatec/dpolft.f deleted file mode 100644 index f51b59c..0000000 --- a/slatec/dpolft.f +++ /dev/null @@ -1,357 +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) - 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/ -C***FIRST EXECUTABLE STATEMENT DPOLFT - 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/slatec/dpolvl.f b/slatec/dpolvl.f deleted file mode 100644 index bb41d94..0000000 --- a/slatec/dpolvl.f +++ /dev/null @@ -1,207 +0,0 @@ -*DECK DPOLVL - SUBROUTINE DPOLVL (NDER, XX, YFIT, YP, N, X, C, WORK, IERR) -C***BEGIN PROLOGUE DPOLVL -C***PURPOSE Calculate the value of a polynomial and its first NDER -C derivatives where the polynomial was produced by a previous -C call to DPLINT. -C***LIBRARY SLATEC -C***CATEGORY E3 -C***TYPE DOUBLE PRECISION (POLYVL-S, DPOLVL-D) -C***KEYWORDS POLYNOMIAL EVALUATION -C***AUTHOR Huddleston, R. E., (SNLL) -C***DESCRIPTION -C -C Abstract - -C Subroutine DPOLVL calculates the value of the polynomial and -C its first NDER derivatives where the polynomial was produced by -C a previous call to DPLINT. -C The variable N and the arrays X and C must not be altered -C between the call to DPLINT and the call to DPOLVL. -C -C ****** Dimensioning Information ******* -C -C YP must be dimensioned by at least NDER -C X must be dimensioned by at least N (see the abstract ) -C C must be dimensioned by at least N (see the abstract ) -C WORK must be dimensioned by at least 2*N if NDER is .GT. 0. -C -C *** Note *** -C If NDER=0, neither YP nor WORK need to be dimensioned variables. -C If NDER=1, YP does not need to be a dimensioned variable. -C -C -C ***** Input parameters -C *** All TYPE REAL variables are DOUBLE PRECISION *** -C -C NDER - the number of derivatives to be evaluated -C -C XX - the argument at which the polynomial and its derivatives -C are to be evaluated. -C -C N - ***** -C * N, X, and C must not be altered between the call -C X - * to DPLINT and the call to DPOLVL. -C C - ***** -C -C -C ***** Output Parameters -C *** All TYPE REAL variables are DOUBLE PRECISION *** -C -C YFIT - the value of the polynomial at XX -C -C YP - the derivatives of the polynomial at XX. The derivative of -C order J at XX is stored in YP(J) , J = 1,...,NDER. -C -C IERR - Output error flag with the following possible values. -C = 1 indicates normal execution -C -C ***** Storage Parameters -C -C WORK = this is an array to provide internal working storage for -C DPOLVL. It must be dimensioned by at least 2*N if NDER is -C .GT. 0. If NDER=0, WORK does not need to be a dimensioned -C variable. -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 (NONE) -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 DPOLVL - INTEGER I,IERR,IM1,IZERO,K,KM1,KM1PI,KM2PN,KM2PNI,M,MM,N,NDR,NDER, - * NMKP1,NPKM1 - DOUBLE PRECISION C(*),FAC,PIONE,PITWO,PONE,PTWO,X(*),XK,XX, - * YFIT,YP(*),WORK(*) -C***FIRST EXECUTABLE STATEMENT DPOLVL - IERR=1 - IF (NDER.GT.0) GO TO 10020 -C -C ***** CODING FOR THE CASE NDER = 0 -C - PIONE=1.0D0 - PONE=C(1) - YFIT=PONE - IF (N.EQ.1) RETURN - DO 10010 K=2,N - PITWO=(XX-X(K-1))*PIONE - PIONE=PITWO - PTWO=PONE+PITWO*C(K) - PONE=PTWO -10010 CONTINUE - YFIT=PTWO - RETURN -C -C ***** END OF NDER = 0 CASE -C -10020 CONTINUE - IF (N.GT.1) GO TO 10040 - YFIT=C(1) -C -C ***** CODING FOR THE CASE N=1 AND NDER .GT. 0 -C - DO 10030 K=1,NDER - YP(K)=0.0D0 -10030 CONTINUE - RETURN -C -C ***** END OF THE CASE N = 1 AND NDER .GT. 0 -C -10040 CONTINUE - IF (NDER.LT.N) GO TO 10050 -C -C ***** SET FLAGS FOR NUMBER OF DERIVATIVES AND FOR DERIVATIVES -C IN EXCESS OF THE DEGREE (N-1) OF THE POLYNOMIAL. -C - IZERO=1 - NDR=N-1 - GO TO 10060 -10050 CONTINUE - IZERO=0 - NDR=NDER -10060 CONTINUE - M=NDR+1 - MM=M -C -C ***** START OF THE CASE NDER .GT. 0 AND N .GT. 1 -C ***** THE POLYNOMIAL AND ITS DERIVATIVES WILL BE EVALUATED AT XX -C - DO 10070 K=1,NDR - YP(K)=C(K+1) -10070 CONTINUE -C -C ***** THE FOLLOWING SECTION OF CODE IS EASIER TO READ IF ONE -C BREAKS WORK INTO TWO ARRAYS W AND V. THE CODE WOULD THEN -C READ -C W(1) = 1. -C PONE = C(1) -C *DO K = 2,N -C * V(K-1) = XX - X(K-1) -C * W(K) = V(K-1)*W(K-1) -C * PTWO = PONE + W(K)*C(K) -C * PONE = PWO -C -C YFIT = PTWO -C - WORK(1)=1.0D0 - PONE=C(1) - DO 10080 K=2,N - KM1=K-1 - NPKM1=N+K-1 - WORK(NPKM1)=XX-X(KM1) - WORK(K)=WORK(NPKM1)*WORK(KM1) - PTWO=PONE+WORK(K)*C(K) - PONE=PTWO -10080 CONTINUE - YFIT=PTWO -C -C ** AT THIS POINT THE POLYNOMIAL HAS BEEN EVALUATED AND INFORMATION -C FOR THE DERIVATIVE EVALUATIONS HAVE BEEN STORED IN THE ARRAY -C WORK - IF (N.EQ.2) GO TO 10110 - IF (M.EQ.N) MM=NDR -C -C ***** EVALUATE THE DERIVATIVES AT XX -C -C ****** DO K=2,MM (FOR MOST CASES, MM = NDER + 1) -C * ****** DO I=2,N-K+1 -C * * W(I) = V(K-2+I)*W(I-1) + W(I) -C * * YP(K-1) = YP(K-1) + W(I)*C(K-1+I) -C ****** CONTINUE -C - DO 10090 K=2,MM - NMKP1=N-K+1 - KM1=K-1 - KM2PN=K-2+N - DO 10090 I=2,NMKP1 - KM2PNI=KM2PN+I - IM1=I-1 - KM1PI=KM1+I - WORK(I)=WORK(KM2PNI)*WORK(IM1)+WORK(I) - YP(KM1)=YP(KM1)+WORK(I)*C(KM1PI) -10090 CONTINUE - IF (NDR.EQ.1) GO TO 10110 - FAC=1.0D0 - DO 10100 K=2,NDR - XK=K - FAC=XK*FAC - YP(K)=FAC*YP(K) -10100 CONTINUE -C -C ***** END OF DERIVATIVE EVALUATIONS -C -10110 CONTINUE - IF (IZERO.EQ.0) RETURN -C -C ***** SET EXCESS DERIVATIVES TO ZERO. -C - DO 10120 K=N,NDER - YP(K)=0.0D0 -10120 CONTINUE - RETURN - END diff --git a/slatec/dpopt.f b/slatec/dpopt.f deleted file mode 100644 index 83d7746..0000000 --- a/slatec/dpopt.f +++ /dev/null @@ -1,379 +0,0 @@ -*DECK DPOPT - SUBROUTINE DPOPT (PRGOPT, MRELAS, NVARS, INFO, CSC, IBASIS, ROPT, - + INTOPT, LOPT) -C***BEGIN PROLOGUE DPOPT -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSPLP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (SPOPT-S, DPOPT-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO -C DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. -C -C USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. -C /REAL (12 BLANKS)/DOUBLE PRECISION/,/R1MACH/D1MACH/,/E0/D0/ -C -C REVISED 821122-1045 -C REVISED YYMMDD-HHMM -C -C THIS SUBROUTINE PROCESSES THE OPTION VECTOR, PRGOPT(*), -C AND VALIDATES ANY MODIFIED DATA. -C -C***SEE ALSO DSPLP -C***ROUTINES CALLED D1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890605 Removed unreferenced labels. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 900510 Fixed an error message. (RWC) -C***END PROLOGUE DPOPT - DOUBLE PRECISION ABIG,ASMALL,COSTSC,CSC(*),EPS,ONE,PRGOPT(*), - * ROPT(07),TOLLS,TUNE,ZERO,D1MACH,TOLABS - INTEGER IBASIS(*),INTOPT(08) - LOGICAL CONTIN,USRBAS,SIZEUP,SAVEDT,COLSCP,CSTSCP,MINPRB, - * STPEDG,LOPT(8) -C -C***FIRST EXECUTABLE STATEMENT DPOPT - IOPT=1 - ZERO=0.D0 - ONE=1.D0 - GO TO 30001 -20002 CONTINUE - GO TO 30002 -C -20003 LOPT(1)=CONTIN - LOPT(2)=USRBAS - LOPT(3)=SIZEUP - LOPT(4)=SAVEDT - LOPT(5)=COLSCP - LOPT(6)=CSTSCP - LOPT(7)=MINPRB - LOPT(8)=STPEDG -C - INTOPT(1)=IDG - INTOPT(2)=IPAGEF - INTOPT(3)=ISAVE - INTOPT(4)=MXITLP - INTOPT(5)=KPRINT - INTOPT(6)=ITBRC - INTOPT(7)=NPP - INTOPT(8)=LPRG -C - ROPT(1)=EPS - ROPT(2)=ASMALL - ROPT(3)=ABIG - ROPT(4)=COSTSC - ROPT(5)=TOLLS - ROPT(6)=TUNE - ROPT(7)=TOLABS - RETURN -C -C -C PROCEDURE (INITIALIZE PARAMETERS AND PROCESS USER OPTIONS) -30001 CONTIN = .FALSE. - USRBAS = .FALSE. - SIZEUP = .FALSE. - SAVEDT = .FALSE. - COLSCP = .FALSE. - CSTSCP = .FALSE. - MINPRB = .TRUE. - STPEDG = .TRUE. -C -C GET THE MACHINE REL. FLOATING POINT ACCURACY VALUE FROM THE -C LIBRARY SUBPROGRAM, D1MACH( ). - EPS=D1MACH(4) - TOLLS=D1MACH(4) - TUNE=ONE - TOLABS=ZERO -C -C DEFINE NOMINAL FILE NUMBERS FOR MATRIX PAGES AND DATA SAVING. - IPAGEF=1 - ISAVE=2 - ITBRC=10 - MXITLP=3*(NVARS+MRELAS) - KPRINT=0 - IDG=-4 - NPP=NVARS - LPRG=0 -C - LAST = 1 - IADBIG=10000 - ICTMAX=1000 - ICTOPT= 0 -20004 NEXT=PRGOPT(LAST) - IF (.NOT.(NEXT.LE.0 .OR. NEXT.GT.IADBIG)) GO TO 20006 -C -C THE CHECKS FOR SMALL OR LARGE VALUES OF NEXT ARE TO PREVENT -C WORKING WITH UNDEFINED DATA. - NERR=14 - CALL XERMSG ('SLATEC', 'DPOPT', - + 'IN DSPLP, THE USER OPTION ARRAY HAS UNDEFINED DATA.', NERR, - + IOPT) - INFO=-NERR - RETURN -20006 IF (.NOT.(NEXT.EQ.1)) GO TO 10001 - GO TO 20005 -10001 IF (.NOT.(ICTOPT.GT.ICTMAX)) GO TO 10002 - NERR=15 - CALL XERMSG ('SLATEC', 'DPOPT', - + 'IN DSPLP, OPTION ARRAY PROCESSING IS CYCLING.', NERR, IOPT) - INFO=-NERR - RETURN -10002 CONTINUE - KEY = PRGOPT(LAST+1) -C -C IF KEY = 50, THIS IS TO BE A MAXIMIZATION PROBLEM -C INSTEAD OF A MINIMIZATION PROBLEM. - IF (.NOT.(KEY.EQ.50)) GO TO 20010 - MINPRB = PRGOPT(LAST+2).EQ.ZERO - LDS=3 - GO TO 20009 -20010 CONTINUE -C -C IF KEY = 51, THE LEVEL OF OUTPUT IS BEING MODIFIED. -C KPRINT = 0, NO OUTPUT -C = 1, SUMMARY OUTPUT -C = 2, LOTS OF OUTPUT -C = 3, EVEN MORE OUTPUT - IF (.NOT.(KEY.EQ.51)) GO TO 20013 - KPRINT=PRGOPT(LAST+2) - LDS=3 - GO TO 20009 -20013 CONTINUE -C -C IF KEY = 52, REDEFINE THE FORMAT AND PRECISION USED -C IN THE OUTPUT. - IF (.NOT.(KEY.EQ.52)) GO TO 20016 - IF (PRGOPT(LAST+2).NE.ZERO) IDG=PRGOPT(LAST+3) - LDS=4 - GO TO 20009 -20016 CONTINUE -C -C IF KEY = 53, THE ALLOTTED SPACE FOR THE SPARSE MATRIX -C STORAGE AND/OR SPARSE EQUATION SOLVING HAS BEEN CHANGED. -C (PROCESSED IN DSPLP(). THIS IS TO COMPUTE THE LENGTH OF PRGOPT(*).) - IF (.NOT.(KEY.EQ.53)) GO TO 20019 - LDS=5 - GO TO 20009 -20019 CONTINUE -C -C IF KEY = 54, REDEFINE THE FILE NUMBER WHERE THE PAGES -C FOR THE SPARSE MATRIX ARE STORED. - IF (.NOT.(KEY.EQ.54)) GO TO 20022 - IF(PRGOPT(LAST+2).NE.ZERO) IPAGEF = PRGOPT(LAST+3) - LDS=4 - GO TO 20009 -20022 CONTINUE -C -C IF KEY = 55, A CONTINUATION FOR A PROBLEM MAY BE REQUESTED. - IF (.NOT.(KEY .EQ. 55)) GO TO 20025 - CONTIN = PRGOPT(LAST+2).NE.ZERO - LDS=3 - GO TO 20009 -20025 CONTINUE -C -C IF KEY = 56, REDEFINE THE FILE NUMBER WHERE THE SAVED DATA -C WILL BE STORED. - IF (.NOT.(KEY.EQ.56)) GO TO 20028 - IF(PRGOPT(LAST+2).NE.ZERO) ISAVE = PRGOPT(LAST+3) - LDS=4 - GO TO 20009 -20028 CONTINUE -C -C IF KEY = 57, SAVE DATA (ON EXTERNAL FILE) AT MXITLP ITERATIONS OR -C THE OPTIMUM, WHICHEVER COMES FIRST. - IF (.NOT.(KEY.EQ.57)) GO TO 20031 - SAVEDT=PRGOPT(LAST+2).NE.ZERO - LDS=3 - GO TO 20009 -20031 CONTINUE -C -C IF KEY = 58, SEE IF PROBLEM IS TO RUN ONLY A GIVEN -C NUMBER OF ITERATIONS. - IF (.NOT.(KEY.EQ.58)) GO TO 20034 - IF (PRGOPT(LAST+2).NE.ZERO) MXITLP = PRGOPT(LAST+3) - LDS=4 - GO TO 20009 -20034 CONTINUE -C -C IF KEY = 59, SEE IF USER PROVIDES THE BASIS INDICES. - IF (.NOT.(KEY .EQ. 59)) GO TO 20037 - USRBAS = PRGOPT(LAST+2) .NE. ZERO - IF (.NOT.(USRBAS)) GO TO 20040 - I=1 - N20043=MRELAS - GO TO 20044 -20043 I=I+1 -20044 IF ((N20043-I).LT.0) GO TO 20045 - IBASIS(I) = PRGOPT(LAST+2+I) - GO TO 20043 -20045 CONTINUE -20040 CONTINUE - LDS=MRELAS+3 - GO TO 20009 -20037 CONTINUE -C -C IF KEY = 60, SEE IF USER HAS PROVIDED SCALING OF COLUMNS. - IF (.NOT.(KEY .EQ. 60)) GO TO 20047 - COLSCP = PRGOPT(LAST+2).NE.ZERO - IF (.NOT.(COLSCP)) GO TO 20050 - J=1 - N20053=NVARS - GO TO 20054 -20053 J=J+1 -20054 IF ((N20053-J).LT.0) GO TO 20055 - CSC(J)=ABS(PRGOPT(LAST+2+J)) - GO TO 20053 -20055 CONTINUE -20050 CONTINUE - LDS=NVARS+3 - GO TO 20009 -20047 CONTINUE -C -C IF KEY = 61, SEE IF USER HAS PROVIDED SCALING OF COSTS. - IF (.NOT.(KEY .EQ. 61)) GO TO 20057 - CSTSCP = PRGOPT(LAST+2).NE.ZERO - IF (CSTSCP) COSTSC = PRGOPT(LAST+3) - LDS=4 - GO TO 20009 -20057 CONTINUE -C -C IF KEY = 62, SEE IF SIZE PARAMETERS ARE PROVIDED WITH THE DATA. -C THESE WILL BE CHECKED AGAINST THE MATRIX ELEMENT SIZES LATER. - IF (.NOT.(KEY .EQ. 62)) GO TO 20060 - SIZEUP = PRGOPT(LAST+2).NE.ZERO - IF (.NOT.(SIZEUP)) GO TO 20063 - ASMALL = PRGOPT(LAST+3) - ABIG = PRGOPT(LAST+4) -20063 CONTINUE - LDS=5 - GO TO 20009 -20060 CONTINUE -C -C IF KEY = 63, SEE IF TOLERANCE FOR LINEAR SYSTEM RESIDUAL ERROR IS -C PROVIDED. - IF (.NOT.(KEY .EQ. 63)) GO TO 20066 - IF (PRGOPT(LAST+2).NE.ZERO) TOLLS = MAX(EPS,PRGOPT(LAST+3)) - LDS=4 - GO TO 20009 -20066 CONTINUE -C -C IF KEY = 64, SEE IF MINIMUM REDUCED COST OR STEEPEST EDGE -C DESCENT IS TO BE USED FOR SELECTING VARIABLES TO ENTER BASIS. - IF (.NOT.(KEY.EQ.64)) GO TO 20069 - STPEDG = PRGOPT(LAST+2).EQ.ZERO - LDS=3 - GO TO 20009 -20069 CONTINUE -C -C IF KEY = 65, SET THE NUMBER OF ITERATIONS BETWEEN RECALCULATING -C THE ERROR IN THE PRIMAL SOLUTION. - IF (.NOT.(KEY.EQ.65)) GO TO 20072 - IF (PRGOPT(LAST+2).NE.ZERO) ITBRC=MAX(ONE,PRGOPT(LAST+3)) - LDS=4 - GO TO 20009 -20072 CONTINUE -C -C IF KEY = 66, SET THE NUMBER OF NEGATIVE REDUCED COSTS TO BE FOUND -C IN THE PARTIAL PRICING STRATEGY. - IF (.NOT.(KEY.EQ.66)) GO TO 20075 - IF (.NOT.(PRGOPT(LAST+2).NE.ZERO)) GO TO 20078 - NPP=MAX(PRGOPT(LAST+3),ONE) - NPP=MIN(NPP,NVARS) -20078 CONTINUE - LDS=4 - GO TO 20009 -20075 CONTINUE -C IF KEY = 67, CHANGE THE TUNING PARAMETER TO APPLY TO THE ERROR -C ESTIMATES FOR THE PRIMAL AND DUAL SYSTEMS. - IF (.NOT.(KEY.EQ.67)) GO TO 20081 - IF (.NOT.(PRGOPT(LAST+2).NE.ZERO)) GO TO 20084 - TUNE=ABS(PRGOPT(LAST+3)) -20084 CONTINUE - LDS=4 - GO TO 20009 -20081 CONTINUE - IF (.NOT.(KEY.EQ.68)) GO TO 20087 - LDS=6 - GO TO 20009 -20087 CONTINUE -C -C RESET THE ABSOLUTE TOLERANCE TO BE USED ON THE FEASIBILITY -C DECISION PROVIDED THE RELATIVE ERROR TEST FAILED. - IF (.NOT.(KEY.EQ.69)) GO TO 20090 - IF(PRGOPT(LAST+2).NE.ZERO)TOLABS=PRGOPT(LAST+3) - LDS=4 - GO TO 20009 -20090 CONTINUE - CONTINUE -C -20009 ICTOPT = ICTOPT+1 - LAST = NEXT - LPRG=LPRG+LDS - GO TO 20004 -20005 CONTINUE - GO TO 20002 -C -C PROCEDURE (VALIDATE OPTIONALLY MODIFIED DATA) -C -C IF USER HAS DEFINED THE BASIS, CHECK FOR VALIDITY OF INDICES. -30002 IF (.NOT.(USRBAS)) GO TO 20093 - I=1 - N20096=MRELAS - GO TO 20097 -20096 I=I+1 -20097 IF ((N20096-I).LT.0) GO TO 20098 - ITEST=IBASIS(I) - IF (.NOT.(ITEST.LE.0 .OR.ITEST.GT.(NVARS+MRELAS))) GO TO 20100 - NERR=16 - CALL XERMSG ('SLATEC', 'DPOPT', - + 'IN DSPLP, AN INDEX OF USER-SUPPLIED BASIS IS OUT OF RANGE.', - + NERR, IOPT) - INFO=-NERR - RETURN -20100 CONTINUE - GO TO 20096 -20098 CONTINUE -20093 CONTINUE -C -C IF USER HAS PROVIDED SIZE PARAMETERS, MAKE SURE THEY ARE ORDERED -C AND POSITIVE. - IF (.NOT.(SIZEUP)) GO TO 20103 - IF (.NOT.(ASMALL.LE.ZERO .OR. ABIG.LT.ASMALL)) GO TO 20106 - NERR=17 - CALL XERMSG ('SLATEC', 'DPOPT', - + 'IN DSPLP, SIZE PARAMETERS FOR MATRIX MUST BE SMALLEST AND ' // - + 'LARGEST MAGNITUDES OF NONZERO ENTRIES.', NERR, IOPT) - INFO=-NERR - RETURN -20106 CONTINUE -20103 CONTINUE -C -C THE NUMBER OF ITERATIONS OF REV. SIMPLEX STEPS MUST BE POSITIVE. - IF (.NOT.(MXITLP.LE.0)) GO TO 20109 - NERR=18 - CALL XERMSG ('SLATEC', 'DPOPT', - + 'IN DSPLP, THE NUMBER OF REVISED SIMPLEX STEPS BETWEEN ' // - + 'CHECK-POINTS MUST BE POSITIVE.', NERR, IOPT) - INFO=-NERR - RETURN -20109 CONTINUE -C -C CHECK THAT SAVE AND PAGE FILE NUMBERS ARE DEFINED AND NOT EQUAL. - IF (.NOT.(ISAVE.LE.0.OR.IPAGEF.LE.0.OR.(ISAVE.EQ.IPAGEF))) GO TO 2 - *0112 - NERR=19 - CALL XERMSG ('SLATEC', 'DPOPT', - + 'IN DSPLP, FILE NUMBERS FOR SAVED DATA AND MATRIX PAGES ' // - + 'MUST BE POSITIVE AND NOT EQUAL.', NERR, IOPT) - INFO=-NERR - RETURN -20112 CONTINUE - CONTINUE - GO TO 20003 - END diff --git a/slatec/dposl.f b/slatec/dposl.f deleted file mode 100644 index 88631c5..0000000 --- a/slatec/dposl.f +++ /dev/null @@ -1,86 +0,0 @@ -*DECK DPOSL - SUBROUTINE DPOSL (A, LDA, N, B) -C***BEGIN PROLOGUE DPOSL -C***PURPOSE Solve the real symmetric positive definite linear system -C using the factors computed by DPOCO or DPOFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1B -C***TYPE DOUBLE PRECISION (SPOSL-S, DPOSL-D, CPOSL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, POSITIVE DEFINITE, SOLVE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C DPOSL solves the double precision symmetric positive definite -C system A * X = B -C using the factors computed by DPOCO or DPOFA. -C -C On Entry -C -C A DOUBLE PRECISION(LDA, N) -C the output from DPOCO or DPOFA. -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 B DOUBLE PRECISION(N) -C the right hand side vector. -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 -C a zero on the diagonal. Technically this indicates -C singularity, but it is usually caused by improper subroutine -C arguments. It will not occur if the subroutines are called -C correctly and INFO .EQ. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL DPOCO(A,LDA,N,RCOND,Z,INFO) -C IF (RCOND is too small .OR. INFO .NE. 0) GO TO ... -C DO 10 J = 1, P -C CALL DPOSL(A,LDA,N,C(1,J)) -C 10 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DDOT -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DPOSL - INTEGER LDA,N - DOUBLE PRECISION A(LDA,*),B(*) -C - DOUBLE PRECISION DDOT,T - INTEGER K,KB -C -C SOLVE TRANS(R)*Y = B -C -C***FIRST EXECUTABLE STATEMENT DPOSL - DO 10 K = 1, N - T = DDOT(K-1,A(1,K),1,B(1),1) - B(K) = (B(K) - T)/A(K,K) - 10 CONTINUE -C -C SOLVE R*X = Y -C - DO 20 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) - 20 CONTINUE - RETURN - END diff --git a/slatec/dppco.f b/slatec/dppco.f deleted file mode 100644 index 9188eae..0000000 --- a/slatec/dppco.f +++ /dev/null @@ -1,234 +0,0 @@ -*DECK DPPCO - SUBROUTINE DPPCO (AP, N, RCOND, Z, INFO) -C***BEGIN PROLOGUE DPPCO -C***PURPOSE Factor a symmetric positive definite matrix stored in -C packed form and estimate the condition number of the -C matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1B -C***TYPE DOUBLE PRECISION (SPPCO-S, DPPCO-D, CPPCO-C) -C***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, -C MATRIX FACTORIZATION, PACKED, POSITIVE DEFINITE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C DPPCO factors a double precision symmetric positive definite -C matrix stored in packed form -C and estimates the condition of the matrix. -C -C If RCOND is not needed, DPPFA is slightly faster. -C To solve A*X = B , follow DPPCO by DPPSL. -C To compute INVERSE(A)*C , follow DPPCO by DPPSL. -C To compute DETERMINANT(A) , follow DPPCO by DPPDI. -C To compute INVERSE(A) , follow DPPCO by DPPDI. -C -C On Entry -C -C AP DOUBLE PRECISION (N*(N+1)/2) -C the packed form of a symmetric matrix A . The -C columns of the upper triangle are stored sequentially -C in a one-dimensional array of length N*(N+1)/2 . -C See comments below for details. -C -C N INTEGER -C the order of the matrix A . -C -C On Return -C -C AP an upper triangular matrix R , stored in packed -C form, so that A = TRANS(R)*R . -C If INFO .NE. 0 , the factorization is not complete. -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. If INFO .NE. 0 , RCOND is unchanged. -C -C Z DOUBLE PRECISION(N) -C a work vector whose contents are usually unimportant. -C If A is singular to working precision, then Z is -C an approximate null vector in the sense that -C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . -C If INFO .NE. 0 , Z is unchanged. -C -C INFO INTEGER -C = 0 for normal return. -C = K signals an error condition. The leading minor -C of order K is not positive definite. -C -C Packed Storage -C -C The following program segment will pack the upper -C triangle of a symmetric matrix. -C -C K = 0 -C DO 20 J = 1, N -C DO 10 I = 1, J -C K = K + 1 -C AP(K) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DASUM, DAXPY, DDOT, DPPFA, DSCAL -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DPPCO - INTEGER N,INFO - DOUBLE PRECISION AP(*),Z(*) - DOUBLE PRECISION RCOND -C - DOUBLE PRECISION DDOT,EK,T,WK,WKM - DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM - INTEGER I,IJ,J,JM1,J1,K,KB,KJ,KK,KP1 -C -C FIND NORM OF A -C -C***FIRST EXECUTABLE STATEMENT DPPCO - J1 = 1 - DO 30 J = 1, N - Z(J) = DASUM(J,AP(J1),1) - IJ = J1 - J1 = J1 + J - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 20 - DO 10 I = 1, JM1 - Z(I) = Z(I) + ABS(AP(IJ)) - IJ = IJ + 1 - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - ANORM = 0.0D0 - DO 40 J = 1, N - ANORM = MAX(ANORM,Z(J)) - 40 CONTINUE -C -C FACTOR -C - CALL DPPFA(AP,N,INFO) - IF (INFO .NE. 0) GO TO 180 -C -C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . -C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . -C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL -C GROWTH IN THE ELEMENTS OF W WHERE TRANS(R)*W = E . -C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. -C -C SOLVE TRANS(R)*W = E -C - EK = 1.0D0 - DO 50 J = 1, N - Z(J) = 0.0D0 - 50 CONTINUE - KK = 0 - DO 110 K = 1, N - KK = KK + K - IF (Z(K) .NE. 0.0D0) EK = SIGN(EK,-Z(K)) - IF (ABS(EK-Z(K)) .LE. AP(KK)) GO TO 60 - S = AP(KK)/ABS(EK-Z(K)) - CALL DSCAL(N,S,Z,1) - EK = S*EK - 60 CONTINUE - WK = EK - Z(K) - WKM = -EK - Z(K) - S = ABS(WK) - SM = ABS(WKM) - WK = WK/AP(KK) - WKM = WKM/AP(KK) - KP1 = K + 1 - KJ = KK + K - IF (KP1 .GT. N) GO TO 100 - DO 70 J = KP1, N - SM = SM + ABS(Z(J)+WKM*AP(KJ)) - Z(J) = Z(J) + WK*AP(KJ) - S = S + ABS(Z(J)) - KJ = KJ + J - 70 CONTINUE - IF (S .GE. SM) GO TO 90 - T = WKM - WK - WK = WKM - KJ = KK + K - DO 80 J = KP1, N - Z(J) = Z(J) + T*AP(KJ) - KJ = KJ + J - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - Z(K) = WK - 110 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) -C -C SOLVE R*Y = W -C - DO 130 KB = 1, N - K = N + 1 - KB - IF (ABS(Z(K)) .LE. AP(KK)) GO TO 120 - S = AP(KK)/ABS(Z(K)) - CALL DSCAL(N,S,Z,1) - 120 CONTINUE - Z(K) = Z(K)/AP(KK) - KK = KK - K - T = -Z(K) - CALL DAXPY(K-1,T,AP(KK+1),1,Z(1),1) - 130 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) -C - YNORM = 1.0D0 -C -C SOLVE TRANS(R)*V = Y -C - DO 150 K = 1, N - Z(K) = Z(K) - DDOT(K-1,AP(KK+1),1,Z(1),1) - KK = KK + K - IF (ABS(Z(K)) .LE. AP(KK)) GO TO 140 - S = AP(KK)/ABS(Z(K)) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM - 140 CONTINUE - Z(K) = Z(K)/AP(KK) - 150 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE R*Z = V -C - DO 170 KB = 1, N - K = N + 1 - KB - IF (ABS(Z(K)) .LE. AP(KK)) GO TO 160 - S = AP(KK)/ABS(Z(K)) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM - 160 CONTINUE - Z(K) = Z(K)/AP(KK) - KK = KK - K - T = -Z(K) - CALL DAXPY(K-1,T,AP(KK+1),1,Z(1),1) - 170 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 - 180 CONTINUE - RETURN - END diff --git a/slatec/dppdi.f b/slatec/dppdi.f deleted file mode 100644 index 9060c77..0000000 --- a/slatec/dppdi.f +++ /dev/null @@ -1,142 +0,0 @@ -*DECK DPPDI - SUBROUTINE DPPDI (AP, N, DET, JOB) -C***BEGIN PROLOGUE DPPDI -C***PURPOSE Compute the determinant and inverse of a real symmetric -C positive definite matrix using factors from DPPCO or DPPFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1B, D3B1B -C***TYPE DOUBLE PRECISION (SPPDI-S, DPPDI-D, CPPDI-C) -C***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, -C PACKED, POSITIVE DEFINITE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C DPPDI computes the determinant and inverse -C of a double precision symmetric positive definite matrix -C using the factors computed by DPPCO or DPPFA . -C -C On Entry -C -C AP DOUBLE PRECISION (N*(N+1)/2) -C the output from DPPCO or DPPFA. -C -C N INTEGER -C the order of the matrix A . -C -C JOB INTEGER -C = 11 both determinant and inverse. -C = 01 inverse only. -C = 10 determinant only. -C -C On Return -C -C AP the upper triangular half of the inverse . -C The strict lower triangle is unaltered. -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. 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 DPOCO or DPOFA has set INFO .EQ. 0 . -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DSCAL -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DPPDI - INTEGER N,JOB - DOUBLE PRECISION AP(*) - DOUBLE PRECISION DET(2) -C - DOUBLE PRECISION T - DOUBLE PRECISION S - INTEGER I,II,J,JJ,JM1,J1,K,KJ,KK,KP1,K1 -C***FIRST EXECUTABLE STATEMENT DPPDI -C -C COMPUTE DETERMINANT -C - IF (JOB/10 .EQ. 0) GO TO 70 - DET(1) = 1.0D0 - DET(2) = 0.0D0 - S = 10.0D0 - II = 0 - DO 50 I = 1, N - II = II + I - DET(1) = AP(II)**2*DET(1) - IF (DET(1) .EQ. 0.0D0) GO TO 60 - 10 IF (DET(1) .GE. 1.0D0) GO TO 20 - DET(1) = S*DET(1) - DET(2) = DET(2) - 1.0D0 - GO TO 10 - 20 CONTINUE - 30 IF (DET(1) .LT. S) GO TO 40 - DET(1) = DET(1)/S - DET(2) = DET(2) + 1.0D0 - GO TO 30 - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE -C -C COMPUTE INVERSE(R) -C - IF (MOD(JOB,10) .EQ. 0) GO TO 140 - KK = 0 - DO 100 K = 1, N - K1 = KK + 1 - KK = KK + K - AP(KK) = 1.0D0/AP(KK) - T = -AP(KK) - CALL DSCAL(K-1,T,AP(K1),1) - KP1 = K + 1 - J1 = KK + 1 - KJ = KK + K - IF (N .LT. KP1) GO TO 90 - DO 80 J = KP1, N - T = AP(KJ) - AP(KJ) = 0.0D0 - CALL DAXPY(K,T,AP(K1),1,AP(J1),1) - J1 = J1 + J - KJ = KJ + J - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE -C -C FORM INVERSE(R) * TRANS(INVERSE(R)) -C - JJ = 0 - DO 130 J = 1, N - J1 = JJ + 1 - JJ = JJ + J - JM1 = J - 1 - K1 = 1 - KJ = J1 - IF (JM1 .LT. 1) GO TO 120 - DO 110 K = 1, JM1 - T = AP(KJ) - CALL DAXPY(K,T,AP(J1),1,AP(K1),1) - K1 = K1 + K - KJ = KJ + 1 - 110 CONTINUE - 120 CONTINUE - T = AP(JJ) - CALL DSCAL(J,T,AP(J1),1) - 130 CONTINUE - 140 CONTINUE - RETURN - END diff --git a/slatec/dpperm.f b/slatec/dpperm.f deleted file mode 100644 index 867910b..0000000 --- a/slatec/dpperm.f +++ /dev/null @@ -1,85 +0,0 @@ -*DECK DPPERM - SUBROUTINE DPPERM (DX, N, IPERM, IER) -C***BEGIN PROLOGUE DPPERM -C***PURPOSE Rearrange a given array according to a prescribed -C permutation vector. -C***LIBRARY SLATEC -C***CATEGORY N8 -C***TYPE DOUBLE PRECISION (SPPERM-S, DPPERM-D, IPPERM-I, HPPERM-H) -C***KEYWORDS PERMUTATION, REARRANGEMENT -C***AUTHOR McClain, M. A., (NIST) -C Rhoads, G. S., (NBS) -C***DESCRIPTION -C -C DPPERM rearranges the data vector DX according to the -C permutation IPERM: DX(I) <--- DX(IPERM(I)). IPERM could come -C from one of the sorting routines IPSORT, SPSORT, DPSORT or -C HPSORT. -C -C Description of Parameters -C DX - input/output -- double precision array of values to be -C rearranged. -C N - input -- number of values in double precision array DX. -C IPERM - input -- permutation vector. -C IER - output -- error indicator: -C = 0 if no error, -C = 1 if N is zero or negative, -C = 2 if IPERM is not a valid permutation. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 901004 DATE WRITTEN -C 920507 Modified by M. McClain to revise prologue text. -C***END PROLOGUE DPPERM - INTEGER N, IPERM(*), I, IER, INDX, INDX0, ISTRT - DOUBLE PRECISION DX(*), DTEMP -C***FIRST EXECUTABLE STATEMENT DPPERM - IER=0 - IF(N.LT.1)THEN - IER=1 - CALL XERMSG ('SLATEC', 'DPPERM', - + 'The number of values to be rearranged, N, is not positive.', - + IER, 1) - RETURN - ENDIF -C -C CHECK WHETHER IPERM IS A VALID PERMUTATION -C - DO 100 I=1,N - INDX=ABS(IPERM(I)) - IF((INDX.GE.1).AND.(INDX.LE.N))THEN - IF(IPERM(INDX).GT.0)THEN - IPERM(INDX)=-IPERM(INDX) - GOTO 100 - ENDIF - ENDIF - IER=2 - CALL XERMSG ('SLATEC', 'DPPERM', - + 'The permutation vector, IPERM, is not valid.', IER, 1) - RETURN - 100 CONTINUE -C -C REARRANGE THE VALUES OF DX -C -C USE THE IPERM VECTOR AS A FLAG. -C IF IPERM(I) > 0, THEN THE I-TH VALUE IS IN CORRECT LOCATION -C - DO 330 ISTRT = 1 , N - IF (IPERM(ISTRT) .GT. 0) GOTO 330 - INDX = ISTRT - INDX0 = INDX - DTEMP = DX(ISTRT) - 320 CONTINUE - IF (IPERM(INDX) .GE. 0) GOTO 325 - DX(INDX) = DX(-IPERM(INDX)) - INDX0 = INDX - IPERM(INDX) = -IPERM(INDX) - INDX = IPERM(INDX) - GOTO 320 - 325 CONTINUE - DX(INDX0) = DTEMP - 330 CONTINUE -C - RETURN - END diff --git a/slatec/dppfa.f b/slatec/dppfa.f deleted file mode 100644 index 257dbc4..0000000 --- a/slatec/dppfa.f +++ /dev/null @@ -1,101 +0,0 @@ -*DECK DPPFA - SUBROUTINE DPPFA (AP, N, INFO) -C***BEGIN PROLOGUE DPPFA -C***PURPOSE Factor a real symmetric positive definite matrix stored in -C packed form. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1B -C***TYPE DOUBLE PRECISION (SPPFA-S, DPPFA-D, CPPFA-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, PACKED, -C POSITIVE DEFINITE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C DPPFA factors a double precision symmetric positive definite -C matrix stored in packed form. -C -C DPPFA is usually called by DPPCO, but it can be called -C directly with a saving in time if RCOND is not needed. -C (time for DPPCO) = (1 + 18/N)*(time for DPPFA) . -C -C On Entry -C -C AP DOUBLE PRECISION (N*(N+1)/2) -C the packed form of a symmetric matrix A . The -C columns of the upper triangle are stored sequentially -C in a one-dimensional array of length N*(N+1)/2 . -C See comments below for details. -C -C N INTEGER -C the order of the matrix A . -C -C On Return -C -C AP an upper triangular matrix R , stored in packed -C form, so that A = TRANS(R)*R . -C -C INFO INTEGER -C = 0 for normal return. -C = K if the leading minor of order K is not -C positive definite. -C -C -C Packed Storage -C -C The following program segment will pack the upper -C triangle of a symmetric matrix. -C -C K = 0 -C DO 20 J = 1, N -C DO 10 I = 1, J -C K = K + 1 -C AP(K) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DDOT -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DPPFA - INTEGER N,INFO - DOUBLE PRECISION AP(*) -C - DOUBLE PRECISION DDOT,T - DOUBLE PRECISION S - INTEGER J,JJ,JM1,K,KJ,KK -C***FIRST EXECUTABLE STATEMENT DPPFA - JJ = 0 - DO 30 J = 1, N - INFO = J - S = 0.0D0 - JM1 = J - 1 - KJ = JJ - KK = 0 - IF (JM1 .LT. 1) GO TO 20 - DO 10 K = 1, JM1 - KJ = KJ + 1 - T = AP(KJ) - DDOT(K-1,AP(KK+1),1,AP(JJ+1),1) - KK = KK + K - T = T/AP(KK) - AP(KJ) = T - S = S + T*T - 10 CONTINUE - 20 CONTINUE - JJ = JJ + J - S = AP(JJ) - S - IF (S .LE. 0.0D0) GO TO 40 - AP(JJ) = SQRT(S) - 30 CONTINUE - INFO = 0 - 40 CONTINUE - RETURN - END diff --git a/slatec/dppgq8.f b/slatec/dppgq8.f deleted file mode 100644 index df4b8e6..0000000 --- a/slatec/dppgq8.f +++ /dev/null @@ -1,197 +0,0 @@ -*DECK DPPGQ8 - SUBROUTINE DPPGQ8 (FUN, LDC, C, XI, LXI, KK, ID, A, B, INPPV, ERR, - + ANS, IERR) -C***BEGIN PROLOGUE DPPGQ8 -C***SUBSIDIARY -C***PURPOSE Subsidiary to DPFQAD -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (PPGQ8-S, DPPGQ8-D) -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract **** A DOUBLE PRECISION routine **** -C -C DPPGQ8, a modification of GAUS8, integrates the -C product of FUN(X) by the ID-th derivative of a spline -C DPPVAL(LDC,C,XI,LXI,KK,ID,X,INPPV) between limits A and B. -C -C Description of Arguments -C -C Input-- FUN,C,XI,A,B,ERR are DOUBLE PRECISION -C FUN - Name of external function of one argument which -C multiplies DPPVAL. -C LDC - Leading dimension of matrix C, LDC .GE. KK -C C - Matrix of Taylor derivatives of dimension at least -C (K,LXI) -C XI - Breakpoint vector of length LXI+1 -C LXI - Number of polynomial pieces -C KK - Order of the spline, KK .GE. 1 -C ID - Order of the spline derivative, 0 .LE. ID .LE. KK-1 -C A - Lower limit of integral -C B - Upper limit of integral (may be less than A) -C INPPV- Initialization parameter for DPPVAL -C ERR - Is a requested pseudorelative error tolerance. Normally -C pick a value of ABS(ERR) .LT. 1D-3. ANS will normally -C have no more error than ABS(ERR) times the integral of -C the absolute value of FUN(X)*DPPVAL(LDC,C,XI,LXI,KK,ID,X, -C INPPV). -C -C -C Output-- ERR,ANS are DOUBLE PRECISION -C ERR - Will be an estimate of the absolute error in ANS if the -C input value of ERR was negative. (ERR Is unchanged if -C the input value of ERR was nonnegative.) The estimated -C error is solely for information to the user and should -C not be used as a correction to the computed integral. -C ANS - Computed value of integral -C IERR- A status code -C --Normal Codes -C 1 ANS most likely meets requested error tolerance, -C or A=B. -C -1 A and B are too nearly equal to allow normal -C integration. ANS is set to zero. -C --Abnormal Code -C 2 ANS probably does not meet requested error tolerance. -C -C***SEE ALSO DPFQAD -C***ROUTINES CALLED D1MACH, DPPVAL, I1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800901 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900328 Added TYPE section. (WRB) -C 910408 Updated the AUTHOR section. (WRB) -C***END PROLOGUE DPPGQ8 -C - INTEGER ID,IERR,INPPV,K,KK,KML,KMX,L,LDC,LMN,LMX,LR,LXI,MXL, - 1 NBITS, NIB, NLMN, NLMX - INTEGER I1MACH - DOUBLE PRECISION A,AA,AE,ANIB,ANS,AREA,B,BE,C,CC,EE,EF,EPS,ERR, - 1 EST,GL,GLR,GR,HH,SQ2,TOL,VL,VR,W1, W2, W3, W4, XI, X1, - 2 X2, X3, X4, X, H - DOUBLE PRECISION D1MACH, DPPVAL, G8, FUN - DIMENSION XI(*), C(LDC,*) - DIMENSION AA(60), HH(60), LR(60), VL(60), GR(60) - SAVE X1, X2, X3, X4, W1, W2, W3, W4, SQ2, NLMN, KMX, KML - DATA X1, X2, X3, X4/ - 1 1.83434642495649805D-01, 5.25532409916328986D-01, - 2 7.96666477413626740D-01, 9.60289856497536232D-01/ - DATA W1, W2, W3, W4/ - 1 3.62683783378361983D-01, 3.13706645877887287D-01, - 2 2.22381034453374471D-01, 1.01228536290376259D-01/ - DATA SQ2/1.41421356D0/ - DATA NLMN/1/,KMX/5000/,KML/6/ - G8(X,H)= - 1 H*((W1*(FUN(X-X1*H)*DPPVAL(LDC,C,XI,LXI,KK,ID,X-X1*H,INPPV) - 2 +FUN(X+X1*H)*DPPVAL(LDC,C,XI,LXI,KK,ID,X+X1*H,INPPV)) - 3 +W2*(FUN(X-X2*H)*DPPVAL(LDC,C,XI,LXI,KK,ID,X-X2*H,INPPV) - 4 +FUN(X+X2*H)*DPPVAL(LDC,C,XI,LXI,KK,ID,X+X2*H,INPPV))) - 5 +(W3*(FUN(X-X3*H)*DPPVAL(LDC,C,XI,LXI,KK,ID,X-X3*H,INPPV) - 6 +FUN(X+X3*H)*DPPVAL(LDC,C,XI,LXI,KK,ID,X+X3*H,INPPV)) - 7 +W4*(FUN(X-X4*H)*DPPVAL(LDC,C,XI,LXI,KK,ID,X-X4*H,INPPV) - 8 +FUN(X+X4*H)*DPPVAL(LDC,C,XI,LXI,KK,ID,X+X4*H,INPPV)))) -C -C INITIALIZE -C -C***FIRST EXECUTABLE STATEMENT DPPGQ8 - K = I1MACH(14) - ANIB = D1MACH(5)*K/0.30102000D0 - NBITS = INT(ANIB) - NLMX = MIN((NBITS*5)/8,60) - ANS = 0.0D0 - IERR = 1 - BE = 0.0D0 - IF (A.EQ.B) GO TO 140 - LMX = NLMX - LMN = NLMN - IF (B.EQ.0.0D0) GO TO 10 - IF (SIGN(1.0D0,B)*A.LE.0.0D0) GO TO 10 - CC = ABS(1.0D0-A/B) - IF (CC.GT.0.1D0) GO TO 10 - IF (CC.LE.0.0D0) GO TO 140 - ANIB = 0.5D0 - LOG(CC)/0.69314718D0 - NIB = INT(ANIB) - LMX = MIN(NLMX,NBITS-NIB-7) - IF (LMX.LT.1) GO TO 130 - LMN = MIN(LMN,LMX) - 10 TOL = MAX(ABS(ERR),2.0D0**(5-NBITS))/2.0D0 - IF (ERR.EQ.0.0D0) TOL = SQRT(D1MACH(4)) - EPS = TOL - HH(1) = (B-A)/4.0D0 - AA(1) = A - LR(1) = 1 - L = 1 - EST = G8(AA(L)+2.0D0*HH(L),2.0D0*HH(L)) - K = 8 - AREA = ABS(EST) - EF = 0.5D0 - MXL = 0 -C -C COMPUTE REFINED ESTIMATES, ESTIMATE THE ERROR, ETC. -C - 20 GL = G8(AA(L)+HH(L),HH(L)) - GR(L) = G8(AA(L)+3.0D0*HH(L),HH(L)) - K = K + 16 - AREA = AREA + (ABS(GL)+ABS(GR(L))-ABS(EST)) - GLR = GL + GR(L) - EE = ABS(EST-GLR)*EF - AE = MAX(EPS*AREA,TOL*ABS(GLR)) - IF (EE-AE) 40, 40, 50 - 30 MXL = 1 - 40 BE = BE + (EST-GLR) - IF (LR(L)) 60, 60, 80 -C -C CONSIDER THE LEFT HALF OF THIS LEVEL -C - 50 IF (K.GT.KMX) LMX = KML - IF (L.GE.LMX) GO TO 30 - L = L + 1 - EPS = EPS*0.5D0 - EF = EF/SQ2 - HH(L) = HH(L-1)*0.5D0 - LR(L) = -1 - AA(L) = AA(L-1) - EST = GL - GO TO 20 -C -C PROCEED TO RIGHT HALF AT THIS LEVEL -C - 60 VL(L) = GLR - 70 EST = GR(L-1) - LR(L) = 1 - AA(L) = AA(L) + 4.0D0*HH(L) - GO TO 20 -C -C RETURN ONE LEVEL -C - 80 VR = GLR - 90 IF (L.LE.1) GO TO 120 - L = L - 1 - EPS = EPS*2.0D0 - EF = EF*SQ2 - IF (LR(L)) 100, 100, 110 - 100 VL(L) = VL(L+1) + VR - GO TO 70 - 110 VR = VL(L+1) + VR - GO TO 90 -C -C EXIT -C - 120 ANS = VR - IF ((MXL.EQ.0) .OR. (ABS(BE).LE.2.0D0*TOL*AREA)) GO TO 140 - IERR = 2 - CALL XERMSG ('SLATEC', 'DPPGQ8', - + 'ANS IS PROBABLY INSUFFICIENTLY ACCURATE.', 3, 1) - GO TO 140 - 130 IERR = -1 - CALL XERMSG ('SLATEC', 'DPPGQ8', - + 'A AND B ARE TOO NEARLY EQUAL TO ALLOW NORMAL ' // - + 'INTEGRATION. ANSWER IS SET TO ZERO, AND IERR=-1.', 1, -1) - 140 CONTINUE - IF (ERR.LT.0.0D0) ERR = BE - RETURN - END diff --git a/slatec/dppqad.f b/slatec/dppqad.f deleted file mode 100644 index 7d36a7a..0000000 --- a/slatec/dppqad.f +++ /dev/null @@ -1,111 +0,0 @@ -*DECK DPPQAD - SUBROUTINE DPPQAD (LDC, C, XI, LXI, K, X1, X2, PQUAD) -C***BEGIN PROLOGUE DPPQAD -C***PURPOSE Compute the integral on (X1,X2) of a K-th order B-spline -C using the piecewise polynomial (PP) representation. -C***LIBRARY SLATEC -C***CATEGORY H2A2A1, E3, K6 -C***TYPE DOUBLE PRECISION (PPQAD-S, DPPQAD-D) -C***KEYWORDS B-SPLINE, DATA FITTING, INTERPOLATION, QUADRATURE, SPLINES -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Abstract **** a double precision routine **** -C DPPQAD computes the integral on (X1,X2) of a K-th order -C B-spline using the piecewise polynomial representation -C (C,XI,LXI,K). Here the Taylor expansion about the left -C end point XI(J) of the J-th interval is integrated and -C evaluated on subintervals of (X1,X2) which are formed by -C included break points. Integration outside (XI(1),XI(LXI+1)) -C is permitted. -C -C Description of Arguments -C Input C,XI,X1,X2 are double precision -C LDC - leading dimension of matrix C, LDC .GE. K -C C(I,J) - right Taylor derivatives at XI(J), I=1,K , J=1,LXI -C XI(*) - break point array of length LXI+1 -C LXI - number of polynomial pieces -C K - order of B-spline, K .GE. 1 -C X1,X2 - end points of quadrature interval, normally in -C XI(1) .LE. X .LE. XI(LXI+1) -C -C Output PQUAD is double precision -C PQUAD - integral of the PP representation over (X1,X2) -C -C Error Conditions -C Improper input is a fatal error -C -C***REFERENCES D. E. Amos, Quadrature subroutines for splines and -C B-splines, Report SAND79-1825, Sandia Laboratories, -C December 1979. -C***ROUTINES CALLED DINTRV, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800901 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 890911 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***END PROLOGUE DPPQAD -C - INTEGER I, II, IL, ILO, IL1, IL2, IM, K, LDC, LEFT, LXI, MF1, MF2 - DOUBLE PRECISION A,AA,BB,C,DX,FLK,PQUAD,Q,S,SS,TA,TB,X,XI,X1,X2 - DIMENSION XI(*), C(LDC,*), SS(2) -C -C***FIRST EXECUTABLE STATEMENT DPPQAD - PQUAD = 0.0D0 - IF(K.LT.1) GO TO 100 - IF(LXI.LT.1) GO TO 105 - IF(LDC.LT.K) GO TO 110 - AA = MIN(X1,X2) - BB = MAX(X1,X2) - IF (AA.EQ.BB) RETURN - ILO = 1 - CALL DINTRV(XI, LXI, AA, ILO, IL1, MF1) - CALL DINTRV(XI, LXI, BB, ILO, IL2, MF2) - Q = 0.0D0 - DO 40 LEFT=IL1,IL2 - TA = XI(LEFT) - A = MAX(AA,TA) - IF (LEFT.EQ.1) A = AA - TB = BB - IF (LEFT.LT.LXI) TB = XI(LEFT+1) - X = MIN(BB,TB) - DO 30 II=1,2 - SS(II) = 0.0D0 - DX = X - XI(LEFT) - IF (DX.EQ.0.0D0) GO TO 20 - S = C(K,LEFT) - FLK = K - IM = K - 1 - IL = IM - DO 10 I=1,IL - S = S*DX/FLK + C(IM,LEFT) - IM = IM - 1 - FLK = FLK - 1.0D0 - 10 CONTINUE - SS(II) = S*DX - 20 CONTINUE - X = A - 30 CONTINUE - Q = Q + (SS(1)-SS(2)) - 40 CONTINUE - IF (X1.GT.X2) Q = -Q - PQUAD = Q - RETURN -C -C - 100 CONTINUE - CALL XERMSG ('SLATEC', 'DPPQAD', 'K DOES NOT SATISFY K.GE.1', 2, - + 1) - RETURN - 105 CONTINUE - CALL XERMSG ('SLATEC', 'DPPQAD', 'LXI DOES NOT SATISFY LXI.GE.1', - + 2, 1) - RETURN - 110 CONTINUE - CALL XERMSG ('SLATEC', 'DPPQAD', 'LDC DOES NOT SATISFY LDC.GE.K', - + 2, 1) - RETURN - END diff --git a/slatec/dppsl.f b/slatec/dppsl.f deleted file mode 100644 index 81574e9..0000000 --- a/slatec/dppsl.f +++ /dev/null @@ -1,81 +0,0 @@ -*DECK DPPSL - SUBROUTINE DPPSL (AP, N, B) -C***BEGIN PROLOGUE DPPSL -C***PURPOSE Solve the real symmetric positive definite system using -C the factors computed by DPPCO or DPPFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1B -C***TYPE DOUBLE PRECISION (SPPSL-S, DPPSL-D, CPPSL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, PACKED, -C POSITIVE DEFINITE, SOLVE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C DPPSL solves the double precision symmetric positive definite -C system A * X = B -C using the factors computed by DPPCO or DPPFA. -C -C On Entry -C -C AP DOUBLE PRECISION (N*(N+1)/2) -C the output from DPPCO or DPPFA. -C -C N INTEGER -C the order of the matrix A . -C -C B DOUBLE PRECISION(N) -C the right hand side vector. -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 -C a zero on the diagonal. Technically this indicates -C singularity, but it is usually caused by improper subroutine -C arguments. It will not occur if the subroutines are called -C correctly and INFO .EQ. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL DPPCO(AP,N,RCOND,Z,INFO) -C IF (RCOND is too small .OR. INFO .NE. 0) GO TO ... -C DO 10 J = 1, P -C CALL DPPSL(AP,N,C(1,J)) -C 10 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DDOT -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DPPSL - INTEGER N - DOUBLE PRECISION AP(*),B(*) -C - DOUBLE PRECISION DDOT,T - INTEGER K,KB,KK -C***FIRST EXECUTABLE STATEMENT DPPSL - KK = 0 - DO 10 K = 1, N - T = DDOT(K-1,AP(KK+1),1,B(1),1) - KK = KK + K - B(K) = (B(K) - T)/AP(KK) - 10 CONTINUE - DO 20 KB = 1, N - K = N + 1 - KB - B(K) = B(K)/AP(KK) - KK = KK - K - T = -B(K) - CALL DAXPY(K-1,T,AP(KK+1),1,B(1),1) - 20 CONTINUE - RETURN - END diff --git a/slatec/dppval.f b/slatec/dppval.f deleted file mode 100644 index 4356032..0000000 --- a/slatec/dppval.f +++ /dev/null @@ -1,104 +0,0 @@ -*DECK DPPVAL - DOUBLE PRECISION FUNCTION DPPVAL (LDC, C, XI, LXI, K, IDERIV, X, - + INPPV) -C***BEGIN PROLOGUE DPPVAL -C***PURPOSE Calculate the value of the IDERIV-th derivative of the -C B-spline from the PP-representation. -C***LIBRARY SLATEC -C***CATEGORY E3, K6 -C***TYPE DOUBLE PRECISION (PPVAL-S, DPPVAL-D) -C***KEYWORDS B-SPLINE, DATA FITTING, INTERPOLATION, SPLINES -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Written by Carl de Boor and modified by D. E. Amos -C -C Abstract **** a double precision routine **** -C DPPVAL is the PPVALU function of the reference. -C -C DPPVAL calculates (at X) the value of the IDERIV-th -C derivative of the B-spline from the PP-representation -C (C,XI,LXI,K). The Taylor expansion about XI(J) for X in -C the interval XI(J) .LE. X .LT. XI(J+1) is evaluated, J=1,LXI. -C Right limiting values at X=XI(J) are obtained. DPPVAL will -C extrapolate beyond XI(1) and XI(LXI+1). -C -C To obtain left limiting values (left derivatives) at XI(J) -C replace LXI by J-1 and set X=XI(J),J=2,LXI+1. -C -C Description of Arguments -C -C Input C,XI,X are double precision -C LDC - leading dimension of C matrix, LDC .GE. K -C C - matrix of dimension at least (K,LXI) containing -C right derivatives at break points XI(*). -C XI - break point vector of length LXI+1 -C LXI - number of polynomial pieces -C K - order of B-spline, K .GE. 1 -C IDERIV - order of the derivative, 0 .LE. IDERIV .LE. K-1 -C IDERIV=0 gives the B-spline value -C X - argument, XI(1) .LE. X .LE. XI(LXI+1) -C INPPV - an initialization parameter which must be set -C to 1 the first time DPPVAL is called. -C -C Output DPPVAL is double precision -C INPPV - INPPV contains information for efficient process- -C ing after the initial call and INPPV must not -C be changed by the user. Distinct splines require -C distinct INPPV parameters. -C DPPVAL - value of the IDERIV-th derivative at X -C -C Error Conditions -C Improper input is a fatal error -C -C***REFERENCES Carl de Boor, Package for calculating with B-splines, -C SIAM Journal on Numerical Analysis 14, 3 (June 1977), -C pp. 441-472. -C***ROUTINES CALLED DINTRV, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800901 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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DPPVAL -C - INTEGER I, IDERIV, INPPV, J, K, LDC, LXI, NDUMMY, KK - DOUBLE PRECISION C, DX, X, XI - DIMENSION XI(*), C(LDC,*) -C***FIRST EXECUTABLE STATEMENT DPPVAL - DPPVAL = 0.0D0 - IF(K.LT.1) GO TO 90 - IF(LDC.LT.K) GO TO 80 - IF(LXI.LT.1) GO TO 85 - IF(IDERIV.LT.0 .OR. IDERIV.GE.K) GO TO 95 - I = K - IDERIV - KK = I - CALL DINTRV(XI, LXI, X, INPPV, I, NDUMMY) - DX = X - XI(I) - J = K - 10 DPPVAL = (DPPVAL/KK)*DX + C(J,I) - J = J - 1 - KK = KK - 1 - IF (KK.GT.0) GO TO 10 - RETURN -C -C - 80 CONTINUE - CALL XERMSG ('SLATEC', 'DPPVAL', 'LDC DOES NOT SATISFY LDC.GE.K', - + 2, 1) - RETURN - 85 CONTINUE - CALL XERMSG ('SLATEC', 'DPPVAL', 'LXI DOES NOT SATISFY LXI.GE.1', - + 2, 1) - RETURN - 90 CONTINUE - CALL XERMSG ('SLATEC', 'DPPVAL', 'K DOES NOT SATISFY K.GE.1', 2, - + 1) - RETURN - 95 CONTINUE - CALL XERMSG ('SLATEC', 'DPPVAL', - + 'IDERIV DOES NOT SATISFY 0.LE.IDERIV.LT.K', 2, 1) - RETURN - END diff --git a/slatec/dprvec.f b/slatec/dprvec.f deleted file mode 100644 index 54a7fcb..0000000 --- a/slatec/dprvec.f +++ /dev/null @@ -1,34 +0,0 @@ -*DECK DPRVEC - DOUBLE PRECISION FUNCTION DPRVEC (M, U, V) -C***BEGIN PROLOGUE DPRVEC -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBVSUP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (PRVEC-S, DPRVEC-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C This subroutine computes the inner product of a vector U -C with the imaginary product or mate vector corresponding to V. -C -C***SEE ALSO DBVSUP -C***ROUTINES CALLED DDOT -C***REVISION HISTORY (YYMMDD) -C 750601 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 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DPRVEC -C - DOUBLE PRECISION DDOT - INTEGER M, N, NP - DOUBLE PRECISION U(*), V(*), VP -C***FIRST EXECUTABLE STATEMENT DPRVEC - N = M/2 - NP = N + 1 - VP = DDOT(N,U(1),1,V(NP),1) - DPRVEC = DDOT(N,U(NP),1,V(1),1) - VP - RETURN - END diff --git a/slatec/dprwpg.f b/slatec/dprwpg.f deleted file mode 100644 index e7a24dc..0000000 --- a/slatec/dprwpg.f +++ /dev/null @@ -1,79 +0,0 @@ -*DECK DPRWPG - SUBROUTINE DPRWPG (KEY, IPAGE, LPG, SX, IX) -C***BEGIN PROLOGUE DPRWPG -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSPLP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (PRWPGE-S, DPRWPG-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C -C DPRWPG LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SCHEME. -C VIRTUAL MEMORY PAGE READ/WRITE SUBROUTINE. -C -C DEPENDING ON THE VALUE OF KEY, SUBROUTINE DPRWPG() PERFORMS A PAGE -C READ OR WRITE OF PAGE IPAGE. THE PAGE HAS LENGTH LPG. -C -C KEY IS A FLAG INDICATING WHETHER A PAGE READ OR WRITE IS -C TO BE PERFORMED. -C IF KEY = 1 DATA IS READ. -C IF KEY = 2 DATA IS WRITTEN. -C IPAGE IS THE PAGE NUMBER OF THE MATRIX TO BE ACCESSED. -C LPG IS THE LENGTH OF THE PAGE OF THE MATRIX TO BE ACCESSED. -C SX(*),IX(*) IS THE MATRIX TO BE ACCESSED. -C -C THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LRWPGE, -C SANDIA LABS. REPT. SAND78-0785. -C MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON -C REVISED 811130-1000 -C REVISED YYMMDD-HHMM -C -C***SEE ALSO DSPLP -C***ROUTINES CALLED DPRWVR, XERMSG -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 900510 Fixed error messages and replaced GOTOs with -C IF-THEN-ELSE. (RWC) -C 910403 Updated AUTHOR and DESCRIPTION sections. (WRB) -C***END PROLOGUE DPRWPG - DOUBLE PRECISION SX(*) - DIMENSION IX(*) -C***FIRST EXECUTABLE STATEMENT DPRWPG -C -C CHECK IF IPAGE IS IN RANGE. -C - IF (IPAGE.LT.1) THEN - CALL XERMSG ('SLATEC', 'DPRWPG', - + 'THE VALUE OF IPAGE (PAGE NUMBER) WAS NOT IN THE RANGE' // - + '1.LE.IPAGE.LE.MAXPGE.', 55, 1) - ENDIF -C -C CHECK IF LPG IS POSITIVE. -C - IF (LPG.LE.0) THEN - CALL XERMSG ('SLATEC', 'DPRWPG', - + 'THE VALUE OF LPG (PAGE LENGTH) WAS NONPOSITIVE.', 55, 1) - ENDIF -C -C DECIDE IF WE ARE READING OR WRITING. -C - IF (KEY.EQ.1) THEN -C -C CODE TO DO A PAGE READ. -C - CALL DPRWVR(KEY,IPAGE,LPG,SX,IX) - ELSE IF (KEY.EQ.2) THEN -C -C CODE TO DO A PAGE WRITE. -C - CALL DPRWVR(KEY,IPAGE,LPG,SX,IX) - ELSE - CALL XERMSG ('SLATEC', 'DPRWPG', - + 'THE VALUE OF KEY (READ-WRITE FLAG) WAS NOT 1 OR 2.', 55, 1) - ENDIF - RETURN - END diff --git a/slatec/dprwvr.f b/slatec/dprwvr.f deleted file mode 100644 index 9f47040..0000000 --- a/slatec/dprwvr.f +++ /dev/null @@ -1,65 +0,0 @@ -*DECK DPRWVR - SUBROUTINE DPRWVR (KEY, IPAGE, LPG, SX, IX) -C***BEGIN PROLOGUE DPRWVR -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSPLP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (PRWVIR-S, DPRWVR-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C -C DPRWVR LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SPARSE MATRIX -C STORAGE SCHEME. THE PAGE STORAGE IS ON RANDOM ACCESS DISK. -C DPRWVR IS PART OF THE SPARSE LP PACKAGE, DSPLP. -C -C KEY IS A FLAG WHICH INDICATES WHETHER A READ OR WRITE -C OPERATION IS TO BE PERFORMED. A VALUE OF KEY=1 INDICATES -C A READ. A VALUE OF KEY=2 INDICATES A WRITE. -C IPAGE IS THE PAGE OF MATRIX MN WE ARE ACCESSING. -C LPG IS THE LENGTH OF THE PAGE. -C SX(*),IX(*) IS THE MATRIX DATA. -C -C THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LRWVIR, -C SANDIA LABS. REPT. SAND78-0785. -C MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON -C -C***SEE ALSO DSPLP -C***ROUTINES CALLED DREADP, DWRITP, SOPENM -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 891009 Removed unreferenced variables. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910403 Updated AUTHOR and DESCRIPTION sections. (WRB) -C***END PROLOGUE DPRWVR - DIMENSION IX(*) - DOUBLE PRECISION SX(*),ZERO,ONE - LOGICAL FIRST - SAVE ZERO, ONE - DATA ZERO,ONE/0.D0,1.D0/ -C***FIRST EXECUTABLE STATEMENT DPRWVR -C -C COMPUTE STARTING ADDRESS OF PAGE. -C - IPAGEF=SX(3) - ISTART = IX(3) + 5 -C -C OPEN RANDOM ACCESS FILE NUMBER IPAGEF, IF FIRST PAGE WRITE. -C - FIRST=SX(4).EQ.ZERO - IF (.NOT.(FIRST)) GO TO 20002 - CALL SOPENM(IPAGEF,LPG) - SX(4)=ONE -C -C PERFORM EITHER A READ OR A WRITE. -C -20002 IADDR = 2*IPAGE - 1 - IF (.NOT.(KEY.EQ.1)) GO TO 20005 - CALL DREADP(IPAGEF,IX(ISTART),SX(ISTART),LPG,IADDR) - GO TO 20006 -20005 IF (.NOT.(KEY.EQ.2)) GO TO 10001 - CALL DWRITP(IPAGEF,IX(ISTART),SX(ISTART),LPG,IADDR) -10001 CONTINUE -20006 RETURN - END diff --git a/slatec/dpsi.f b/slatec/dpsi.f deleted file mode 100644 index 33cebb4..0000000 --- a/slatec/dpsi.f +++ /dev/null @@ -1,163 +0,0 @@ -*DECK DPSI - DOUBLE PRECISION FUNCTION DPSI (X) -C***BEGIN PROLOGUE DPSI -C***PURPOSE Compute the Psi (or Digamma) function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7C -C***TYPE DOUBLE PRECISION (PSI-S, DPSI-D, CPSI-C) -C***KEYWORDS DIGAMMA FUNCTION, FNLIB, PSI FUNCTION, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DPSI calculates the double precision Psi (or Digamma) function for -C double precision argument X. PSI(X) is the logarithmic derivative -C of the Gamma function of X. -C -C Series for PSI on the interval 0. to 1.00000E+00 -C with weighted error 5.79E-32 -C log weighted error 31.24 -C significant figures required 30.93 -C decimal places required 32.05 -C -C -C Series for APSI on the interval 0. to 1.00000E-02 -C with weighted error 7.75E-33 -C log weighted error 32.11 -C significant figures required 28.88 -C decimal places required 32.71 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DCOT, DCSEVL, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 890911 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 900727 Added EXTERNAL statement. (WRB) -C 920618 Removed space from variable name. (RWC, WRB) -C***END PROLOGUE DPSI - DOUBLE PRECISION X, PSICS(42), APSICS(16), AUX, DXREL, PI, XBIG, - 1 Y, DCOT, DCSEVL, D1MACH - LOGICAL FIRST - EXTERNAL DCOT - SAVE PSICS, APSICS, PI, NTPSI, NTAPSI, XBIG, DXREL, FIRST - DATA PSICS( 1) / -.3805708083 5217921520 4376776670 39 D-1 / - DATA PSICS( 2) / +.4914153930 2938712748 2046996542 77 D+0 / - DATA PSICS( 3) / -.5681574782 1244730242 8920647340 81 D-1 / - DATA PSICS( 4) / +.8357821225 9143131362 7756507478 62 D-2 / - DATA PSICS( 5) / -.1333232857 9943425998 0792741723 93 D-2 / - DATA PSICS( 6) / +.2203132870 6930824892 8723979795 21 D-3 / - DATA PSICS( 7) / -.3704023817 8456883592 8890869492 29 D-4 / - DATA PSICS( 8) / +.6283793654 8549898933 6514187176 90 D-5 / - DATA PSICS( 9) / -.1071263908 5061849855 2835417470 74 D-5 / - DATA PSICS( 10) / +.1831283946 5484165805 7315898103 78 D-6 / - DATA PSICS( 11) / -.3135350936 1808509869 0057797968 85 D-7 / - DATA PSICS( 12) / +.5372808776 2007766260 4719191436 15 D-8 / - DATA PSICS( 13) / -.9211681415 9784275717 8806326247 30 D-9 / - DATA PSICS( 14) / +.1579812652 1481822782 2528840328 23 D-9 / - DATA PSICS( 15) / -.2709864613 2380443065 4405894097 07 D-10 / - DATA PSICS( 16) / +.4648722859 9096834872 9473195295 49 D-11 / - DATA PSICS( 17) / -.7975272563 8303689726 5047977727 37 D-12 / - DATA PSICS( 18) / +.1368272385 7476992249 2510538928 38 D-12 / - DATA PSICS( 19) / -.2347515606 0658972717 3206779807 19 D-13 / - DATA PSICS( 20) / +.4027630715 5603541107 9079250062 81 D-14 / - DATA PSICS( 21) / -.6910251853 1179037846 5474229747 71 D-15 / - DATA PSICS( 22) / +.1185604713 8863349552 9291395257 68 D-15 / - DATA PSICS( 23) / -.2034168961 6261559308 1542104842 23 D-16 / - DATA PSICS( 24) / +.3490074968 6463043850 3742329323 51 D-17 / - DATA PSICS( 25) / -.5988014693 4976711003 0110813934 93 D-18 / - DATA PSICS( 26) / +.1027380162 8080588258 3980057122 13 D-18 / - DATA PSICS( 27) / -.1762704942 4561071368 3592601053 86 D-19 / - DATA PSICS( 28) / +.3024322801 8156920457 4540354901 33 D-20 / - DATA PSICS( 29) / -.5188916830 2092313774 2860888746 66 D-21 / - DATA PSICS( 30) / +.8902773034 5845713905 0058874879 99 D-22 / - DATA PSICS( 31) / -.1527474289 9426728392 8949719040 00 D-22 / - DATA PSICS( 32) / +.2620731479 8962083136 3583180799 99 D-23 / - DATA PSICS( 33) / -.4496464273 8220696772 5983880533 33 D-24 / - DATA PSICS( 34) / +.7714712959 6345107028 9193642666 66 D-25 / - DATA PSICS( 35) / -.1323635476 1887702968 1026389333 33 D-25 / - DATA PSICS( 36) / +.2270999436 2408300091 2773119999 99 D-26 / - DATA PSICS( 37) / -.3896419021 5374115954 4913919999 99 D-27 / - DATA PSICS( 38) / +.6685198138 8855302310 6798933333 33 D-28 / - DATA PSICS( 39) / -.1146998665 4920864872 5299199999 99 D-28 / - DATA PSICS( 40) / +.1967938588 6541405920 5154133333 33 D-29 / - DATA PSICS( 41) / -.3376448818 9750979801 9072000000 00 D-30 / - DATA PSICS( 42) / +.5793070319 3214159246 6773333333 33 D-31 / - DATA APSICS( 1) / -.8327107910 6929076017 4456932269 D-3 / - DATA APSICS( 2) / -.4162518421 9273935282 1627121990 D-3 / - DATA APSICS( 3) / +.1034315609 7874129117 4463193961 D-6 / - DATA APSICS( 4) / -.1214681841 3590415298 7299556365 D-9 / - DATA APSICS( 5) / +.3113694319 9835615552 1240278178 D-12 / - DATA APSICS( 6) / -.1364613371 9317704177 6516100945 D-14 / - DATA APSICS( 7) / +.9020517513 1541656513 0837974000 D-17 / - DATA APSICS( 8) / -.8315429974 2159146482 9933635466 D-19 / - DATA APSICS( 9) / +.1012242570 7390725418 8479482666 D-20 / - DATA APSICS( 10) / -.1562702494 3562250762 0478933333 D-22 / - DATA APSICS( 11) / +.2965427168 0890389613 3226666666 D-24 / - DATA APSICS( 12) / -.6746868867 6570216374 1866666666 D-26 / - DATA APSICS( 13) / +.1803453116 9718990421 3333333333 D-27 / - DATA APSICS( 14) / -.5569016182 4598360746 6666666666 D-29 / - DATA APSICS( 15) / +.1958679226 0773625173 3333333333 D-30 / - DATA APSICS( 16) / -.7751958925 2333568000 0000000000 D-32 / - DATA PI / 3.1415926535 8979323846 2643383279 50 D0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DPSI - IF (FIRST) THEN - NTPSI = INITDS (PSICS, 42, 0.1*REAL(D1MACH(3)) ) - NTAPSI = INITDS (APSICS, 16, 0.1*REAL(D1MACH(3)) ) -C - XBIG = 1.0D0/SQRT(D1MACH(3)) - DXREL = SQRT(D1MACH(4)) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) -C - IF (Y.GT.10.0D0) GO TO 50 -C -C DPSI(X) FOR ABS(X) .LE. 2 -C - N = X - IF (X.LT.0.D0) N = N - 1 - Y = X - N - N = N - 1 - DPSI = DCSEVL (2.D0*Y-1.D0, PSICS, NTPSI) - IF (N.EQ.0) RETURN -C - IF (N.GT.0) GO TO 30 -C - N = -N - IF (X .EQ. 0.D0) CALL XERMSG ('SLATEC', 'DPSI', 'X IS 0', 2, 2) - IF (X .LT. 0.D0 .AND. X+N-2 .EQ. 0.D0) CALL XERMSG ('SLATEC', - + 'DPSI', 'X IS A NEGATIVE INTEGER', 3, 2) - IF (X .LT. (-0.5D0) .AND. ABS((X-AINT(X-0.5D0))/X) .LT. DXREL) - + CALL XERMSG ('SLATEC', 'DPSI', - + 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER', - + 1, 1) -C - DO 20 I=1,N - DPSI = DPSI - 1.D0/(X+I-1) - 20 CONTINUE - RETURN -C -C DPSI(X) FOR X .GE. 2.0 AND X .LE. 10.0 -C - 30 DO 40 I=1,N - DPSI = DPSI + 1.0D0/(Y+I) - 40 CONTINUE - RETURN -C -C DPSI(X) FOR ABS(X) .GT. 10.0 -C - 50 AUX = 0.D0 - IF (Y.LT.XBIG) AUX = DCSEVL (2.D0*(10.D0/Y)**2-1.D0, APSICS, - 1 NTAPSI) -C - IF (X.LT.0.D0) DPSI = LOG(ABS(X)) - 0.5D0/X + AUX - 1 - PI*DCOT(PI*X) - IF (X.GT.0.D0) DPSI = LOG(X) - 0.5D0/X + AUX - RETURN -C - END diff --git a/slatec/dpsifn.f b/slatec/dpsifn.f deleted file mode 100644 index 8165230..0000000 --- a/slatec/dpsifn.f +++ /dev/null @@ -1,368 +0,0 @@ -*DECK DPSIFN - SUBROUTINE DPSIFN (X, N, KODE, M, ANS, NZ, IERR) -C***BEGIN PROLOGUE DPSIFN -C***PURPOSE Compute derivatives of the Psi function. -C***LIBRARY SLATEC -C***CATEGORY C7C -C***TYPE DOUBLE PRECISION (PSIFN-S, DPSIFN-D) -C***KEYWORDS DERIVATIVES OF THE GAMMA FUNCTION, POLYGAMMA FUNCTION, -C PSI FUNCTION -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C The following definitions are used in DPSIFN: -C -C Definition 1 -C PSI(X) = d/dx (ln(GAMMA(X)), the first derivative of -C the log GAMMA function. -C Definition 2 -C K K -C PSI(K,X) = d /dx (PSI(X)), the K-th derivative of PSI(X). -C ___________________________________________________________________ -C DPSIFN computes a sequence of SCALED derivatives of -C the PSI function; i.e. for fixed X and M it computes -C the M-member sequence -C -C ((-1)**(K+1)/GAMMA(K+1))*PSI(K,X) -C for K = N,...,N+M-1 -C -C where PSI(K,X) is as defined above. For KODE=1, DPSIFN returns -C the scaled derivatives as described. KODE=2 is operative only -C when K=0 and in that case DPSIFN returns -PSI(X) + LN(X). That -C is, the logarithmic behavior for large X is removed when KODE=2 -C and K=0. When sums or differences of PSI functions are computed -C the logarithmic terms can be combined analytically and computed -C separately to help retain significant digits. -C -C Note that CALL DPSIFN(X,0,1,1,ANS) results in -C ANS = -PSI(X) -C -C Input X is DOUBLE PRECISION -C X - Argument, X .gt. 0.0D0 -C N - First member of the sequence, 0 .le. N .le. 100 -C N=0 gives ANS(1) = -PSI(X) for KODE=1 -C -PSI(X)+LN(X) for KODE=2 -C KODE - Selection parameter -C KODE=1 returns scaled derivatives of the PSI -C function. -C KODE=2 returns scaled derivatives of the PSI -C function EXCEPT when N=0. In this case, -C ANS(1) = -PSI(X) + LN(X) is returned. -C M - Number of members of the sequence, M.ge.1 -C -C Output ANS is DOUBLE PRECISION -C ANS - A vector of length at least M whose first M -C components contain the sequence of derivatives -C scaled according to KODE. -C NZ - Underflow flag -C NZ.eq.0, A normal return -C NZ.ne.0, Underflow, last NZ components of ANS are -C set to zero, ANS(M-K+1)=0.0, K=1,...,NZ -C IERR - Error flag -C IERR=0, A normal return, computation completed -C IERR=1, Input error, no computation -C IERR=2, Overflow, X too small or N+M-1 too -C large or both -C IERR=3, Error, N too large. Dimensioned -C array TRMR(NMAX) is not large enough for N -C -C The nominal computational accuracy is the maximum of unit -C roundoff (=D1MACH(4)) and 1.0D-18 since critical constants -C are given to only 18 digits. -C -C PSIFN is the single precision version of DPSIFN. -C -C *Long Description: -C -C The basic method of evaluation is the asymptotic expansion -C for large X.ge.XMIN followed by backward recursion on a two -C term recursion relation -C -C W(X+1) + X**(-N-1) = W(X). -C -C This is supplemented by a series -C -C SUM( (X+K)**(-N-1) , K=0,1,2,... ) -C -C which converges rapidly for large N. Both XMIN and the -C number of terms of the series are calculated from the unit -C roundoff of the machine environment. -C -C***REFERENCES Handbook of Mathematical Functions, National Bureau -C of Standards Applied Mathematics Series 55, edited -C by M. Abramowitz and I. A. Stegun, equations 6.3.5, -C 6.3.18, 6.4.6, 6.4.9 and 6.4.10, pp.258-260, 1964. -C D. E. Amos, A portable Fortran subroutine for -C derivatives of the Psi function, Algorithm 610, ACM -C Transactions on Mathematical Software 9, 4 (1983), -C pp. 494-502. -C***ROUTINES CALLED D1MACH, I1MACH -C***REVISION HISTORY (YYMMDD) -C 820601 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DPSIFN - INTEGER I, IERR, J, K, KODE, M, MM, MX, N, NMAX, NN, NP, NX, NZ, - * FN - INTEGER I1MACH - DOUBLE PRECISION ANS, ARG, B, DEN, ELIM, EPS, FLN, - * FX, RLN, RXSQ, R1M4, R1M5, S, SLOPE, T, TA, TK, TOL, TOLS, TRM, - * TRMR, TSS, TST, TT, T1, T2, WDTOL, X, XDMLN, XDMY, XINC, XLN, - * XM, XMIN, XQ, YINT - DOUBLE PRECISION D1MACH - DIMENSION B(22), TRM(22), TRMR(100), ANS(*) - SAVE NMAX, B - DATA NMAX /100/ -C----------------------------------------------------------------------- -C BERNOULLI NUMBERS -C----------------------------------------------------------------------- - DATA B(1), B(2), B(3), B(4), B(5), B(6), B(7), B(8), B(9), B(10), - * B(11), B(12), B(13), B(14), B(15), B(16), B(17), B(18), B(19), - * B(20), B(21), B(22) /1.00000000000000000D+00, - * -5.00000000000000000D-01,1.66666666666666667D-01, - * -3.33333333333333333D-02,2.38095238095238095D-02, - * -3.33333333333333333D-02,7.57575757575757576D-02, - * -2.53113553113553114D-01,1.16666666666666667D+00, - * -7.09215686274509804D+00,5.49711779448621554D+01, - * -5.29124242424242424D+02,6.19212318840579710D+03, - * -8.65802531135531136D+04,1.42551716666666667D+06, - * -2.72982310678160920D+07,6.01580873900642368D+08, - * -1.51163157670921569D+10,4.29614643061166667D+11, - * -1.37116552050883328D+13,4.88332318973593167D+14, - * -1.92965793419400681D+16/ -C -C***FIRST EXECUTABLE STATEMENT DPSIFN - IERR = 0 - NZ=0 - IF (X.LE.0.0D0) IERR=1 - IF (N.LT.0) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (M.LT.1) IERR=1 - IF (IERR.NE.0) RETURN - MM=M - NX = MIN(-I1MACH(15),I1MACH(16)) - R1M5 = D1MACH(5) - R1M4 = D1MACH(4)*0.5D0 - WDTOL = MAX(R1M4,0.5D-18) -C----------------------------------------------------------------------- -C ELIM = APPROXIMATE EXPONENTIAL OVER AND UNDERFLOW LIMIT -C----------------------------------------------------------------------- - ELIM = 2.302D0*(NX*R1M5-3.0D0) - XLN = LOG(X) - 41 CONTINUE - NN = N + MM - 1 - FN = NN - T = (FN+1)*XLN -C----------------------------------------------------------------------- -C OVERFLOW AND UNDERFLOW TEST FOR SMALL AND LARGE X -C----------------------------------------------------------------------- - IF (ABS(T).GT.ELIM) GO TO 290 - IF (X.LT.WDTOL) GO TO 260 -C----------------------------------------------------------------------- -C COMPUTE XMIN AND THE NUMBER OF TERMS OF THE SERIES, FLN+1 -C----------------------------------------------------------------------- - RLN = R1M5*I1MACH(14) - RLN = MIN(RLN,18.06D0) - FLN = MAX(RLN,3.0D0) - 3.0D0 - YINT = 3.50D0 + 0.40D0*FLN - SLOPE = 0.21D0 + FLN*(0.0006038D0*FLN+0.008677D0) - XM = YINT + SLOPE*FN - MX = INT(XM) + 1 - XMIN = MX - IF (N.EQ.0) GO TO 50 - XM = -2.302D0*RLN - MIN(0.0D0,XLN) - ARG = XM/N - ARG = MIN(0.0D0,ARG) - EPS = EXP(ARG) - XM = 1.0D0 - EPS - IF (ABS(ARG).LT.1.0D-3) XM = -ARG - FLN = X*XM/EPS - XM = XMIN - X - IF (XM.GT.7.0D0 .AND. FLN.LT.15.0D0) GO TO 200 - 50 CONTINUE - XDMY = X - XDMLN = XLN - XINC = 0.0D0 - IF (X.GE.XMIN) GO TO 60 - NX = INT(X) - XINC = XMIN - NX - XDMY = X + XINC - XDMLN = LOG(XDMY) - 60 CONTINUE -C----------------------------------------------------------------------- -C GENERATE W(N+MM-1,X) BY THE ASYMPTOTIC EXPANSION -C----------------------------------------------------------------------- - T = FN*XDMLN - T1 = XDMLN + XDMLN - T2 = T + XDMLN - TK = MAX(ABS(T),ABS(T1),ABS(T2)) - IF (TK.GT.ELIM) GO TO 380 - TSS = EXP(-T) - TT = 0.5D0/XDMY - T1 = TT - TST = WDTOL*TT - IF (NN.NE.0) T1 = TT + 1.0D0/FN - RXSQ = 1.0D0/(XDMY*XDMY) - TA = 0.5D0*RXSQ - T = (FN+1)*TA - S = T*B(3) - IF (ABS(S).LT.TST) GO TO 80 - TK = 2.0D0 - DO 70 K=4,22 - T = T*((TK+FN+1)/(TK+1.0D0))*((TK+FN)/(TK+2.0D0))*RXSQ - TRM(K) = T*B(K) - IF (ABS(TRM(K)).LT.TST) GO TO 80 - S = S + TRM(K) - TK = TK + 2.0D0 - 70 CONTINUE - 80 CONTINUE - S = (S+T1)*TSS - IF (XINC.EQ.0.0D0) GO TO 100 -C----------------------------------------------------------------------- -C BACKWARD RECUR FROM XDMY TO X -C----------------------------------------------------------------------- - NX = INT(XINC) - NP = NN + 1 - IF (NX.GT.NMAX) GO TO 390 - IF (NN.EQ.0) GO TO 160 - XM = XINC - 1.0D0 - FX = X + XM -C----------------------------------------------------------------------- -C THIS LOOP SHOULD NOT BE CHANGED. FX IS ACCURATE WHEN X IS SMALL -C----------------------------------------------------------------------- - DO 90 I=1,NX - TRMR(I) = FX**(-NP) - S = S + TRMR(I) - XM = XM - 1.0D0 - FX = X + XM - 90 CONTINUE - 100 CONTINUE - ANS(MM) = S - IF (FN.EQ.0) GO TO 180 -C----------------------------------------------------------------------- -C GENERATE LOWER DERIVATIVES, J.LT.N+MM-1 -C----------------------------------------------------------------------- - IF (MM.EQ.1) RETURN - DO 150 J=2,MM - FN = FN - 1 - TSS = TSS*XDMY - T1 = TT - IF (FN.NE.0) T1 = TT + 1.0D0/FN - T = (FN+1)*TA - S = T*B(3) - IF (ABS(S).LT.TST) GO TO 120 - TK = 4 + FN - DO 110 K=4,22 - TRM(K) = TRM(K)*(FN+1)/TK - IF (ABS(TRM(K)).LT.TST) GO TO 120 - S = S + TRM(K) - TK = TK + 2.0D0 - 110 CONTINUE - 120 CONTINUE - S = (S+T1)*TSS - IF (XINC.EQ.0.0D0) GO TO 140 - IF (FN.EQ.0) GO TO 160 - XM = XINC - 1.0D0 - FX = X + XM - DO 130 I=1,NX - TRMR(I) = TRMR(I)*FX - S = S + TRMR(I) - XM = XM - 1.0D0 - FX = X + XM - 130 CONTINUE - 140 CONTINUE - MX = MM - J + 1 - ANS(MX) = S - IF (FN.EQ.0) GO TO 180 - 150 CONTINUE - RETURN -C----------------------------------------------------------------------- -C RECURSION FOR N = 0 -C----------------------------------------------------------------------- - 160 CONTINUE - DO 170 I=1,NX - S = S + 1.0D0/(X+NX-I) - 170 CONTINUE - 180 CONTINUE - IF (KODE.EQ.2) GO TO 190 - ANS(1) = S - XDMLN - RETURN - 190 CONTINUE - IF (XDMY.EQ.X) RETURN - XQ = XDMY/X - ANS(1) = S - LOG(XQ) - RETURN -C----------------------------------------------------------------------- -C COMPUTE BY SERIES (X+K)**(-(N+1)) , K=0,1,2,... -C----------------------------------------------------------------------- - 200 CONTINUE - NN = INT(FLN) + 1 - NP = N + 1 - T1 = (N+1)*XLN - T = EXP(-T1) - S = T - DEN = X - DO 210 I=1,NN - DEN = DEN + 1.0D0 - TRM(I) = DEN**(-NP) - S = S + TRM(I) - 210 CONTINUE - ANS(1) = S - IF (N.NE.0) GO TO 220 - IF (KODE.EQ.2) ANS(1) = S + XLN - 220 CONTINUE - IF (MM.EQ.1) RETURN -C----------------------------------------------------------------------- -C GENERATE HIGHER DERIVATIVES, J.GT.N -C----------------------------------------------------------------------- - TOL = WDTOL/5.0D0 - DO 250 J=2,MM - T = T/X - S = T - TOLS = T*TOL - DEN = X - DO 230 I=1,NN - DEN = DEN + 1.0D0 - TRM(I) = TRM(I)/DEN - S = S + TRM(I) - IF (TRM(I).LT.TOLS) GO TO 240 - 230 CONTINUE - 240 CONTINUE - ANS(J) = S - 250 CONTINUE - RETURN -C----------------------------------------------------------------------- -C SMALL X.LT.UNIT ROUND OFF -C----------------------------------------------------------------------- - 260 CONTINUE - ANS(1) = X**(-N-1) - IF (MM.EQ.1) GO TO 280 - K = 1 - DO 270 I=2,MM - ANS(K+1) = ANS(K)/X - K = K + 1 - 270 CONTINUE - 280 CONTINUE - IF (N.NE.0) RETURN - IF (KODE.EQ.2) ANS(1) = ANS(1) + XLN - RETURN - 290 CONTINUE - IF (T.GT.0.0D0) GO TO 380 - NZ=0 - IERR=2 - RETURN - 380 CONTINUE - NZ=NZ+1 - ANS(MM)=0.0D0 - MM=MM-1 - IF (MM.EQ.0) RETURN - GO TO 41 - 390 CONTINUE - NZ=0 - IERR=3 - RETURN - END diff --git a/slatec/dpsixn.f b/slatec/dpsixn.f deleted file mode 100644 index 171204c..0000000 --- a/slatec/dpsixn.f +++ /dev/null @@ -1,122 +0,0 @@ -*DECK DPSIXN - DOUBLE PRECISION FUNCTION DPSIXN (N) -C***BEGIN PROLOGUE DPSIXN -C***SUBSIDIARY -C***PURPOSE Subsidiary to DEXINT -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (PSIXN-S, DPSIXN-D) -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C This subroutine returns values of PSI(X)=derivative of log -C GAMMA(X), X.GT.0.0 at integer arguments. A table look-up is -C performed for N .LE. 100, and the asymptotic expansion is -C evaluated for N.GT.100. -C -C***SEE ALSO DEXINT -C***ROUTINES CALLED D1MACH -C***REVISION HISTORY (YYMMDD) -C 800501 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DPSIXN -C - INTEGER N, K - DOUBLE PRECISION AX, B, C, FN, RFN2, TRM, S, WDTOL - DOUBLE PRECISION D1MACH - DIMENSION B(6), C(100) -C -C DPSIXN(N), N = 1,100 - DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), - 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), - 2 C(19), C(20), C(21), C(22), C(23), C(24)/ - 3 -5.77215664901532861D-01, 4.22784335098467139D-01, - 4 9.22784335098467139D-01, 1.25611766843180047D+00, - 5 1.50611766843180047D+00, 1.70611766843180047D+00, - 6 1.87278433509846714D+00, 2.01564147795561000D+00, - 7 2.14064147795561000D+00, 2.25175258906672111D+00, - 8 2.35175258906672111D+00, 2.44266167997581202D+00, - 9 2.52599501330914535D+00, 2.60291809023222227D+00, - 1 2.67434666166079370D+00, 2.74101332832746037D+00, - 2 2.80351332832746037D+00, 2.86233685773922507D+00, - 3 2.91789241329478063D+00, 2.97052399224214905D+00, - 4 3.02052399224214905D+00, 3.06814303986119667D+00, - 5 3.11359758531574212D+00, 3.15707584618530734D+00/ - DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), - 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), - 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ - 3 3.19874251285197401D+00, 3.23874251285197401D+00, - 4 3.27720405131351247D+00, 3.31424108835054951D+00, - 5 3.34995537406483522D+00, 3.38443813268552488D+00, - 6 3.41777146601885821D+00, 3.45002953053498724D+00, - 7 3.48127953053498724D+00, 3.51158256083801755D+00, - 8 3.54099432554389990D+00, 3.56956575411532847D+00, - 9 3.59734353189310625D+00, 3.62437055892013327D+00, - 1 3.65068634839381748D+00, 3.67632737403484313D+00, - 2 3.70132737403484313D+00, 3.72571761793728215D+00, - 3 3.74952714174680596D+00, 3.77278295570029433D+00, - 4 3.79551022842756706D+00, 3.81773245064978928D+00, - 5 3.83947158108457189D+00, 3.86074817682925274D+00/ - DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), - 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), - 2 C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ - 3 3.88158151016258607D+00, 3.90198967342789220D+00, - 4 3.92198967342789220D+00, 3.94159751656514710D+00, - 5 3.96082828579591633D+00, 3.97969621032421822D+00, - 6 3.99821472884273674D+00, 4.01639654702455492D+00, - 7 4.03425368988169777D+00, 4.05179754953082058D+00, - 8 4.06903892884116541D+00, 4.08598808138353829D+00, - 9 4.10265474805020496D+00, 4.11904819067315578D+00, - 1 4.13517722293122029D+00, 4.15105023880423617D+00, - 2 4.16667523880423617D+00, 4.18205985418885155D+00, - 3 4.19721136934036670D+00, 4.21213674247469506D+00, - 4 4.22684262482763624D+00, 4.24133537845082464D+00, - 5 4.25562109273653893D+00, 4.26970559977879245D+00/ - DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), - 1 C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), - 2 C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ - 3 4.28359448866768134D+00, 4.29729311880466764D+00, - 4 4.31080663231818115D+00, 4.32413996565151449D+00, - 5 4.33729786038835659D+00, 4.35028487337536958D+00, - 6 4.36310538619588240D+00, 4.37576361404398366D+00, - 7 4.38826361404398366D+00, 4.40060929305632934D+00, - 8 4.41280441500754886D+00, 4.42485260777863319D+00, - 9 4.43675736968339510D+00, 4.44852207556574804D+00, - 1 4.46014998254249223D+00, 4.47164423541605544D+00, - 2 4.48300787177969181D+00, 4.49424382683587158D+00, - 3 4.50535493794698269D+00, 4.51634394893599368D+00, - 4 4.52721351415338499D+00, 4.53796620232542800D+00, - 5 4.54860450019776842D+00, 4.55913081598724211D+00/ - DATA C(97), C(98), C(99), C(100)/ - 1 4.56954748265390877D+00, 4.57985676100442424D+00, - 2 4.59006084263707730D+00, 4.60016185273808740D+00/ -C COEFFICIENTS OF ASYMPTOTIC EXPANSION - DATA B(1), B(2), B(3), B(4), B(5), B(6)/ - 1 8.33333333333333333D-02, -8.33333333333333333D-03, - 2 3.96825396825396825D-03, -4.16666666666666666D-03, - 3 7.57575757575757576D-03, -2.10927960927960928D-02/ -C -C***FIRST EXECUTABLE STATEMENT DPSIXN - IF (N.GT.100) GO TO 10 - DPSIXN = C(N) - RETURN - 10 CONTINUE - WDTOL = MAX(D1MACH(4),1.0D-18) - FN = N - AX = 1.0D0 - S = -0.5D0/FN - IF (ABS(S).LE.WDTOL) GO TO 30 - RFN2 = 1.0D0/(FN*FN) - DO 20 K=1,6 - AX = AX*RFN2 - TRM = -B(K)*AX - IF (ABS(TRM).LT.WDTOL) GO TO 30 - S = S + TRM - 20 CONTINUE - 30 CONTINUE - DPSIXN = S + LOG(FN) - RETURN - END diff --git a/slatec/dpsort.f b/slatec/dpsort.f deleted file mode 100644 index 5a52d60..0000000 --- a/slatec/dpsort.f +++ /dev/null @@ -1,269 +0,0 @@ -*DECK DPSORT - SUBROUTINE DPSORT (DX, N, IPERM, KFLAG, IER) -C***BEGIN PROLOGUE DPSORT -C***PURPOSE Return the permutation vector generated by sorting a given -C array and, optionally, rearrange the elements of the array. -C The array may be sorted in increasing or decreasing order. -C A slightly modified quicksort algorithm is used. -C***LIBRARY SLATEC -C***CATEGORY N6A1B, N6A2B -C***TYPE DOUBLE PRECISION (SPSORT-S, DPSORT-D, IPSORT-I, HPSORT-H) -C***KEYWORDS NUMBER SORTING, PASSIVE SORTING, SINGLETON QUICKSORT, SORT -C***AUTHOR Jones, R. E., (SNLA) -C Rhoads, G. S., (NBS) -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C -C DPSORT returns the permutation vector IPERM generated by sorting -C the array DX and, optionally, rearranges the values in DX. DX may -C be sorted in increasing or decreasing order. A slightly modified -C quicksort algorithm is used. -C -C IPERM is such that DX(IPERM(I)) is the Ith value in the -C rearrangement of DX. IPERM may be applied to another array by -C calling IPPERM, SPPERM, DPPERM or HPPERM. -C -C The main difference between DPSORT and its active sorting equivalent -C DSORT is that the data are referenced indirectly rather than -C directly. Therefore, DPSORT should require approximately twice as -C long to execute as DSORT. However, DPSORT is more general. -C -C Description of Parameters -C DX - input/output -- double precision array of values to be -C sorted. If ABS(KFLAG) = 2, then the values in DX will be -C rearranged on output; otherwise, they are unchanged. -C N - input -- number of values in array DX to be sorted. -C IPERM - output -- permutation array such that IPERM(I) is the -C index of the value in the original order of the -C DX array that is in the Ith location in the sorted -C order. -C KFLAG - input -- control parameter: -C = 2 means return the permutation vector resulting from -C sorting DX in increasing order and sort DX also. -C = 1 means return the permutation vector resulting from -C sorting DX in increasing order and do not sort DX. -C = -1 means return the permutation vector resulting from -C sorting DX in decreasing order and do not sort DX. -C = -2 means return the permutation vector resulting from -C sorting DX in decreasing order and sort DX also. -C IER - output -- error indicator: -C = 0 if no error, -C = 1 if N is zero or negative, -C = 2 if KFLAG is not 2, 1, -1, or -2. -C***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm -C for sorting with minimal storage, Communications of -C the ACM, 12, 3 (1969), pp. 185-187. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 761101 DATE WRITTEN -C 761118 Modified by John A. Wisniewski to use the Singleton -C quicksort algorithm. -C 870423 Modified by Gregory S. Rhoads for passive sorting with the -C option for the rearrangement of the original data. -C 890619 Double precision version of SPSORT created by D. W. Lozier. -C 890620 Algorithm for rearranging the data vector corrected by R. -C Boisvert. -C 890622 Prologue upgraded to Version 4.0 style by D. Lozier. -C 891128 Error when KFLAG.LT.0 and N=1 corrected by R. Boisvert. -C 920507 Modified by M. McClain to revise prologue text. -C 920818 Declarations section rebuilt and code restructured to use -C IF-THEN-ELSE-ENDIF. (SMR, WRB) -C***END PROLOGUE DPSORT -C .. Scalar Arguments .. - INTEGER IER, KFLAG, N -C .. Array Arguments .. - DOUBLE PRECISION DX(*) - INTEGER IPERM(*) -C .. Local Scalars .. - DOUBLE PRECISION R, TEMP - INTEGER I, IJ, INDX, INDX0, ISTRT, J, K, KK, L, LM, LMT, M, NN -C .. Local Arrays .. - INTEGER IL(21), IU(21) -C .. External Subroutines .. - EXTERNAL XERMSG -C .. Intrinsic Functions .. - INTRINSIC ABS, INT -C***FIRST EXECUTABLE STATEMENT DPSORT - IER = 0 - NN = N - IF (NN .LT. 1) THEN - IER = 1 - CALL XERMSG ('SLATEC', 'DPSORT', - + 'The number of values to be sorted, N, is not positive.', - + IER, 1) - RETURN - ENDIF -C - KK = ABS(KFLAG) - IF (KK.NE.1 .AND. KK.NE.2) THEN - IER = 2 - CALL XERMSG ('SLATEC', 'DPSORT', - + 'The sort control parameter, KFLAG, is not 2, 1, -1, or -2.', - + IER, 1) - RETURN - ENDIF -C -C Initialize permutation vector -C - DO 10 I=1,NN - IPERM(I) = I - 10 CONTINUE -C -C Return if only one value is to be sorted -C - IF (NN .EQ. 1) RETURN -C -C Alter array DX to get decreasing order if needed -C - IF (KFLAG .LE. -1) THEN - DO 20 I=1,NN - DX(I) = -DX(I) - 20 CONTINUE - ENDIF -C -C Sort DX only -C - M = 1 - I = 1 - J = NN - R = .375D0 -C - 30 IF (I .EQ. J) GO TO 80 - IF (R .LE. 0.5898437D0) THEN - R = R+3.90625D-2 - ELSE - R = R-0.21875D0 - ENDIF -C - 40 K = I -C -C Select a central element of the array and save it in location L -C - IJ = I + INT((J-I)*R) - LM = IPERM(IJ) -C -C If first element of array is greater than LM, interchange with LM -C - IF (DX(IPERM(I)) .GT. DX(LM)) THEN - IPERM(IJ) = IPERM(I) - IPERM(I) = LM - LM = IPERM(IJ) - ENDIF - L = J -C -C If last element of array is less than LM, interchange with LM -C - IF (DX(IPERM(J)) .LT. DX(LM)) THEN - IPERM(IJ) = IPERM(J) - IPERM(J) = LM - LM = IPERM(IJ) -C -C If first element of array is greater than LM, interchange -C with LM -C - IF (DX(IPERM(I)) .GT. DX(LM)) THEN - IPERM(IJ) = IPERM(I) - IPERM(I) = LM - LM = IPERM(IJ) - ENDIF - ENDIF - GO TO 60 - 50 LMT = IPERM(L) - IPERM(L) = IPERM(K) - IPERM(K) = LMT -C -C Find an element in the second half of the array which is smaller -C than LM -C - 60 L = L-1 - IF (DX(IPERM(L)) .GT. DX(LM)) GO TO 60 -C -C Find an element in the first half of the array which is greater -C than LM -C - 70 K = K+1 - IF (DX(IPERM(K)) .LT. DX(LM)) GO TO 70 -C -C Interchange these elements -C - IF (K .LE. L) GO TO 50 -C -C Save upper and lower subscripts of the array yet to be sorted -C - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 90 -C -C Begin again on another portion of the unsorted array -C - 80 M = M-1 - IF (M .EQ. 0) GO TO 120 - I = IL(M) - J = IU(M) -C - 90 IF (J-I .GE. 1) GO TO 40 - IF (I .EQ. 1) GO TO 30 - I = I-1 -C - 100 I = I+1 - IF (I .EQ. J) GO TO 80 - LM = IPERM(I+1) - IF (DX(IPERM(I)) .LE. DX(LM)) GO TO 100 - K = I -C - 110 IPERM(K+1) = IPERM(K) - K = K-1 - IF (DX(LM) .LT. DX(IPERM(K))) GO TO 110 - IPERM(K+1) = LM - GO TO 100 -C -C Clean up -C - 120 IF (KFLAG .LE. -1) THEN - DO 130 I=1,NN - DX(I) = -DX(I) - 130 CONTINUE - ENDIF -C -C Rearrange the values of DX if desired -C - IF (KK .EQ. 2) THEN -C -C Use the IPERM vector as a flag. -C If IPERM(I) < 0, then the I-th value is in correct location -C - DO 150 ISTRT=1,NN - IF (IPERM(ISTRT) .GE. 0) THEN - INDX = ISTRT - INDX0 = INDX - TEMP = DX(ISTRT) - 140 IF (IPERM(INDX) .GT. 0) THEN - DX(INDX) = DX(IPERM(INDX)) - INDX0 = INDX - IPERM(INDX) = -IPERM(INDX) - INDX = ABS(IPERM(INDX)) - GO TO 140 - ENDIF - DX(INDX0) = TEMP - ENDIF - 150 CONTINUE -C -C Revert the signs of the IPERM values -C - DO 160 I=1,NN - IPERM(I) = -IPERM(I) - 160 CONTINUE -C - ENDIF -C - RETURN - END diff --git a/slatec/dptsl.f b/slatec/dptsl.f deleted file mode 100644 index 64798ea..0000000 --- a/slatec/dptsl.f +++ /dev/null @@ -1,106 +0,0 @@ -*DECK DPTSL - SUBROUTINE DPTSL (N, D, E, B) -C***BEGIN PROLOGUE DPTSL -C***PURPOSE Solve a positive definite tridiagonal linear system. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B2A -C***TYPE DOUBLE PRECISION (SPTSL-S, DPTSL-D, CPTSL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, POSITIVE DEFINITE, SOLVE, -C TRIDIAGONAL -C***AUTHOR Dongarra, J., (ANL) -C***DESCRIPTION -C -C DPTSL, given a positive definite symmetric tridiagonal matrix and -C a right hand side, will find the solution. -C -C On Entry -C -C N INTEGER -C is the order of the tridiagonal matrix. -C -C D DOUBLE PRECISION(N) -C is the diagonal of the tridiagonal matrix. -C On output D is destroyed. -C -C E DOUBLE PRECISION(N) -C is the offdiagonal of the tridiagonal matrix. -C E(1) through E(N-1) should contain the -C offdiagonal. -C -C B DOUBLE PRECISION(N) -C is the right hand side vector. -C -C On Return -C -C B contains the solution. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890505 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DPTSL - INTEGER N - DOUBLE PRECISION D(*),E(*),B(*) -C - INTEGER K,KBM1,KE,KF,KP1,NM1,NM1D2 - DOUBLE PRECISION T1,T2 -C -C CHECK FOR 1 X 1 CASE -C -C***FIRST EXECUTABLE STATEMENT DPTSL - IF (N .NE. 1) GO TO 10 - B(1) = B(1)/D(1) - GO TO 70 - 10 CONTINUE - NM1 = N - 1 - NM1D2 = NM1/2 - IF (N .EQ. 2) GO TO 30 - KBM1 = N - 1 -C -C ZERO TOP HALF OF SUBDIAGONAL AND BOTTOM HALF OF -C SUPERDIAGONAL -C - DO 20 K = 1, NM1D2 - T1 = E(K)/D(K) - D(K+1) = D(K+1) - T1*E(K) - B(K+1) = B(K+1) - T1*B(K) - T2 = E(KBM1)/D(KBM1+1) - D(KBM1) = D(KBM1) - T2*E(KBM1) - B(KBM1) = B(KBM1) - T2*B(KBM1+1) - KBM1 = KBM1 - 1 - 20 CONTINUE - 30 CONTINUE - KP1 = NM1D2 + 1 -C -C CLEAN UP FOR POSSIBLE 2 X 2 BLOCK AT CENTER -C - IF (MOD(N,2) .NE. 0) GO TO 40 - T1 = E(KP1)/D(KP1) - D(KP1+1) = D(KP1+1) - T1*E(KP1) - B(KP1+1) = B(KP1+1) - T1*B(KP1) - KP1 = KP1 + 1 - 40 CONTINUE -C -C BACK SOLVE STARTING AT THE CENTER, GOING TOWARDS THE TOP -C AND BOTTOM -C - B(KP1) = B(KP1)/D(KP1) - IF (N .EQ. 2) GO TO 60 - K = KP1 - 1 - KE = KP1 + NM1D2 - 1 - DO 50 KF = KP1, KE - B(K) = (B(K) - E(K)*B(K+1))/D(K) - B(KF+1) = (B(KF+1) - E(KF)*B(KF))/D(KF+1) - K = K - 1 - 50 CONTINUE - 60 CONTINUE - IF (MOD(N,2) .EQ. 0) B(1) = (B(1) - E(1)*B(2))/D(1) - 70 CONTINUE - RETURN - END diff --git a/slatec/dqag.f b/slatec/dqag.f deleted file mode 100644 index 07cd16e..0000000 --- a/slatec/dqag.f +++ /dev/null @@ -1,193 +0,0 @@ -*DECK DQAG - SUBROUTINE DQAG (F, A, B, EPSABS, EPSREL, KEY, RESULT, ABSERR, - + NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK) -C***BEGIN PROLOGUE DQAG -C***PURPOSE The routine calculates an approximation result to a given -C definite integral I = integral of F over (A,B), -C hopefully satisfying following claim for accuracy -C ABS(I-RESULT)LE.MAX(EPSABS,EPSREL*ABS(I)). -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A1A1 -C***TYPE DOUBLE PRECISION (QAG-S, DQAG-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, GAUSS-KRONROD RULES, -C GENERAL-PURPOSE, GLOBALLY ADAPTIVE, INTEGRAND EXAMINATOR, -C QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Computation of a definite integral -C Standard fortran subroutine -C Double precision version -C -C F - Double precision -C Function subprogram defining the integrand -C Function F(X). The actual name for F needs to be -C Declared E X T E R N A L in the driver program. -C -C A - Double precision -C Lower limit of integration -C -C B - Double precision -C Upper limit of integration -C -C EPSABS - Double precision -C Absolute accuracy requested -C EPSREL - Double precision -C Relative accuracy requested -C If EPSABS.LE.0 -C And EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C The routine will end with IER = 6. -C -C KEY - Integer -C Key for choice of local integration rule -C A GAUSS-KRONROD PAIR is used with -C 7 - 15 POINTS If KEY.LT.2, -C 10 - 21 POINTS If KEY = 2, -C 15 - 31 POINTS If KEY = 3, -C 20 - 41 POINTS If KEY = 4, -C 25 - 51 POINTS If KEY = 5, -C 30 - 61 POINTS If KEY.GT.5. -C -C ON RETURN -C RESULT - Double precision -C Approximation to the integral -C -C ABSERR - Double precision -C Estimate of the modulus of the absolute error, -C Which should EQUAL or EXCEED ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C IER.GT.0 Abnormal termination of the routine -C The estimates for RESULT and ERROR are -C Less reliable. It is assumed that the -C requested accuracy has not been achieved. -C ERROR MESSAGES -C IER = 1 Maximum number of subdivisions allowed -C has been achieved. One can allow more -C subdivisions by increasing the value of -C LIMIT (and taking the according dimension -C adjustments into account). HOWEVER, If -C this yield no improvement it is advised -C to analyze the integrand in order to -C determine the integration difficulties. -C If the position of a local difficulty can -C be determined (I.E. SINGULARITY, -C DISCONTINUITY WITHIN THE INTERVAL) One -C will probably gain from splitting up the -C interval at this point and calling the -C INTEGRATOR on the SUBRANGES. If possible, -C AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR -C should be used which is designed for -C handling the type of difficulty involved. -C = 2 The occurrence of roundoff error is -C detected, which prevents the requested -C tolerance from being achieved. -C = 3 Extremely bad integrand behaviour occurs -C at some points of the integration -C interval. -C = 6 The input is invalid, because -C (EPSABS.LE.0 AND -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)) -C OR LIMIT.LT.1 OR LENW.LT.LIMIT*4. -C RESULT, ABSERR, NEVAL, LAST are set -C to zero. -C EXCEPT when LENW is invalid, IWORK(1), -C WORK(LIMIT*2+1) and WORK(LIMIT*3+1) are -C set to zero, WORK(1) is set to A and -C WORK(LIMIT+1) to B. -C -C DIMENSIONING PARAMETERS -C LIMIT - Integer -C Dimensioning parameter for IWORK -C Limit determines the maximum number of subintervals -C in the partition of the given integration interval -C (A,B), LIMIT.GE.1. -C If LIMIT.LT.1, the routine will end with IER = 6. -C -C LENW - Integer -C Dimensioning parameter for work -C LENW must be at least LIMIT*4. -C IF LENW.LT.LIMIT*4, the routine will end with -C IER = 6. -C -C LAST - Integer -C On return, LAST equals the number of subintervals -C produced in the subdivision process, which -C determines the number of significant elements -C actually in the WORK ARRAYS. -C -C WORK ARRAYS -C IWORK - Integer -C Vector of dimension at least limit, the first K -C elements of which contain pointers to the error -C estimates over the subintervals, such that -C WORK(LIMIT*3+IWORK(1)),... , WORK(LIMIT*3+IWORK(K)) -C form a decreasing sequence with K = LAST If -C LAST.LE.(LIMIT/2+2), and K = LIMIT+1-LAST otherwise -C -C WORK - Double precision -C Vector of dimension at least LENW -C on return -C WORK(1), ..., WORK(LAST) contain the left end -C points of the subintervals in the partition of -C (A,B), -C WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain the -C right end points, -C WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) contain -C the integral approximations over the subintervals, -C WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) contain -C the error estimates. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED DQAGE, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800101 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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE DQAG - DOUBLE PRECISION A,ABSERR,B,EPSABS,EPSREL,F,RESULT,WORK - INTEGER IER,IWORK,KEY,LAST,LENW,LIMIT,LVL,L1,L2,L3,NEVAL -C - DIMENSION IWORK(*),WORK(*) -C - EXTERNAL F -C***FIRST EXECUTABLE STATEMENT DQAG - IER = 6 - NEVAL = 0 - LAST = 0 - RESULT = 0.0D+00 - ABSERR = 0.0D+00 - IF (LIMIT.GE.1 .AND. LENW.GE.LIMIT*4) THEN -C -C PREPARE CALL FOR DQAGE. -C - L1 = LIMIT+1 - L2 = LIMIT+L1 - L3 = LIMIT+L2 -C - CALL DQAGE(F,A,B,EPSABS,EPSREL,KEY,LIMIT,RESULT,ABSERR,NEVAL, - 1 IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) -C -C CALL ERROR HANDLER IF NECESSARY. -C - LVL = 0 - ENDIF -C - IF (IER.EQ.6) LVL = 1 - IF (IER .NE. 0) CALL XERMSG ('SLATEC', 'DQAG', - + 'ABNORMAL RETURN', IER, LVL) - RETURN - END diff --git a/slatec/dqage.f b/slatec/dqage.f deleted file mode 100644 index 79ec30c..0000000 --- a/slatec/dqage.f +++ /dev/null @@ -1,351 +0,0 @@ -*DECK DQAGE - SUBROUTINE DQAGE (F, A, B, EPSABS, EPSREL, KEY, LIMIT, RESULT, - + ABSERR, NEVAL, IER, ALIST, BLIST, RLIST, ELIST, IORD, LAST) -C***BEGIN PROLOGUE DQAGE -C***PURPOSE The routine calculates an approximation result to a given -C definite integral I = Integral of F over (A,B), -C hopefully satisfying following claim for accuracy -C ABS(I-RESLT).LE.MAX(EPSABS,EPSREL*ABS(I)). -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A1A1 -C***TYPE DOUBLE PRECISION (QAGE-S, DQAGE-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, GAUSS-KRONROD RULES, -C GENERAL-PURPOSE, GLOBALLY ADAPTIVE, INTEGRAND EXAMINATOR, -C QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Computation of a definite integral -C Standard fortran subroutine -C Double precision version -C -C PARAMETERS -C ON ENTRY -C F - Double precision -C Function subprogram defining the integrand -C function F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C A - Double precision -C Lower limit of integration -C -C B - Double precision -C Upper limit of integration -C -C EPSABS - Double precision -C Absolute accuracy requested -C EPSREL - Double precision -C Relative accuracy requested -C If EPSABS.LE.0 -C and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C the routine will end with IER = 6. -C -C KEY - Integer -C Key for choice of local integration rule -C A Gauss-Kronrod pair is used with -C 7 - 15 points if KEY.LT.2, -C 10 - 21 points if KEY = 2, -C 15 - 31 points if KEY = 3, -C 20 - 41 points if KEY = 4, -C 25 - 51 points if KEY = 5, -C 30 - 61 points if KEY.GT.5. -C -C LIMIT - Integer -C Gives an upper bound on the number of subintervals -C in the partition of (A,B), LIMIT.GE.1. -C -C ON RETURN -C RESULT - Double precision -C Approximation to the integral -C -C ABSERR - Double precision -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C IER.GT.0 Abnormal termination of the routine -C The estimates for result and error are -C less reliable. It is assumed that the -C requested accuracy has not been achieved. -C ERROR MESSAGES -C IER = 1 Maximum number of subdivisions allowed -C has been achieved. One can allow more -C subdivisions by increasing the value -C of LIMIT. -C However, if this yields no improvement it -C is rather advised to analyze the integrand -C in order to determine the integration -C difficulties. If the position of a local -C difficulty can be determined(e.g. -C SINGULARITY, DISCONTINUITY within the -C interval) one will probably gain from -C splitting up the interval at this point -C and calling the integrator on the -C subranges. If possible, an appropriate -C special-purpose integrator should be used -C which is designed for handling the type of -C difficulty involved. -C = 2 The occurrence of roundoff error is -C detected, which prevents the requested -C tolerance from being achieved. -C = 3 Extremely bad integrand behaviour occurs -C at some points of the integration -C interval. -C = 6 The input is invalid, because -C (EPSABS.LE.0 and -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C RESULT, ABSERR, NEVAL, LAST, RLIST(1) , -C ELIST(1) and IORD(1) are set to zero. -C ALIST(1) and BLIST(1) are set to A and B -C respectively. -C -C ALIST - Double precision -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the left -C end points of the subintervals in the partition -C of the given integration range (A,B) -C -C BLIST - Double precision -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the right -C end points of the subintervals in the partition -C of the given integration range (A,B) -C -C RLIST - Double precision -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the -C integral approximations on the subintervals -C -C ELIST - Double precision -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the moduli of the -C absolute error estimates on the subintervals -C -C IORD - Integer -C Vector of dimension at least LIMIT, the first K -C elements of which are pointers to the -C error estimates over the subintervals, -C such that ELIST(IORD(1)), ..., -C ELIST(IORD(K)) form a decreasing sequence, -C with K = LAST if LAST.LE.(LIMIT/2+2), and -C K = LIMIT+1-LAST otherwise -C -C LAST - Integer -C Number of subintervals actually produced in the -C subdivision process -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DQK15, DQK21, DQK31, DQK41, DQK51, DQK61, -C DQPSRT -C***REVISION HISTORY (YYMMDD) -C 800101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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***END PROLOGUE DQAGE -C - DOUBLE PRECISION A,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1,A2,B, - 1 BLIST,B1,B2,DEFABS,DEFAB1,DEFAB2,D1MACH,ELIST,EPMACH, - 2 EPSABS,EPSREL,ERRBND,ERRMAX,ERROR1,ERROR2,ERRO12,ERRSUM,F, - 3 RESABS,RESULT,RLIST,UFLOW - INTEGER IER,IORD,IROFF1,IROFF2,K,KEY,KEYF,LAST,LIMIT,MAXERR,NEVAL, - 1 NRMAX -C - DIMENSION ALIST(*),BLIST(*),ELIST(*),IORD(*), - 1 RLIST(*) -C - EXTERNAL F -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER -C (ALIST(I),BLIST(I)) -C ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) -C MAXERR - POINTER TO THE INTERVAL WITH LARGEST -C ERROR ESTIMATE -C ERRMAX - ELIST(MAXERR) -C AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS -C ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS -C ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* -C ABS(RESULT)) -C *****1 - VARIABLE FOR THE LEFT SUBINTERVAL -C *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL -C LAST - INDEX FOR SUBDIVISION -C -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT DQAGE - EPMACH = D1MACH(4) - UFLOW = D1MACH(1) -C -C TEST ON VALIDITY OF PARAMETERS -C ------------------------------ -C - IER = 0 - NEVAL = 0 - LAST = 0 - RESULT = 0.0D+00 - ABSERR = 0.0D+00 - ALIST(1) = A - BLIST(1) = B - RLIST(1) = 0.0D+00 - ELIST(1) = 0.0D+00 - IORD(1) = 0 - IF(EPSABS.LE.0.0D+00.AND. - 1 EPSREL.LT.MAX(0.5D+02*EPMACH,0.5D-28)) IER = 6 - IF(IER.EQ.6) GO TO 999 -C -C FIRST APPROXIMATION TO THE INTEGRAL -C ----------------------------------- -C - KEYF = KEY - IF(KEY.LE.0) KEYF = 1 - IF(KEY.GE.7) KEYF = 6 - NEVAL = 0 - IF(KEYF.EQ.1) CALL DQK15(F,A,B,RESULT,ABSERR,DEFABS,RESABS) - IF(KEYF.EQ.2) CALL DQK21(F,A,B,RESULT,ABSERR,DEFABS,RESABS) - IF(KEYF.EQ.3) CALL DQK31(F,A,B,RESULT,ABSERR,DEFABS,RESABS) - IF(KEYF.EQ.4) CALL DQK41(F,A,B,RESULT,ABSERR,DEFABS,RESABS) - IF(KEYF.EQ.5) CALL DQK51(F,A,B,RESULT,ABSERR,DEFABS,RESABS) - IF(KEYF.EQ.6) CALL DQK61(F,A,B,RESULT,ABSERR,DEFABS,RESABS) - LAST = 1 - RLIST(1) = RESULT - ELIST(1) = ABSERR - IORD(1) = 1 -C -C TEST ON ACCURACY. -C - ERRBND = MAX(EPSABS,EPSREL*ABS(RESULT)) - IF(ABSERR.LE.0.5D+02*EPMACH*DEFABS.AND.ABSERR.GT.ERRBND) IER = 2 - IF(LIMIT.EQ.1) IER = 1 - IF(IER.NE.0.OR.(ABSERR.LE.ERRBND.AND.ABSERR.NE.RESABS) - 1 .OR.ABSERR.EQ.0.0D+00) GO TO 60 -C -C INITIALIZATION -C -------------- -C -C - ERRMAX = ABSERR - MAXERR = 1 - AREA = RESULT - ERRSUM = ABSERR - NRMAX = 1 - IROFF1 = 0 - IROFF2 = 0 -C -C MAIN DO-LOOP -C ------------ -C - DO 30 LAST = 2,LIMIT -C -C BISECT THE SUBINTERVAL WITH THE LARGEST ERROR ESTIMATE. -C - A1 = ALIST(MAXERR) - B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR)) - A2 = B1 - B2 = BLIST(MAXERR) - IF(KEYF.EQ.1) CALL DQK15(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) - IF(KEYF.EQ.2) CALL DQK21(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) - IF(KEYF.EQ.3) CALL DQK31(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) - IF(KEYF.EQ.4) CALL DQK41(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) - IF(KEYF.EQ.5) CALL DQK51(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) - IF(KEYF.EQ.6) CALL DQK61(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) - IF(KEYF.EQ.1) CALL DQK15(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) - IF(KEYF.EQ.2) CALL DQK21(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) - IF(KEYF.EQ.3) CALL DQK31(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) - IF(KEYF.EQ.4) CALL DQK41(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) - IF(KEYF.EQ.5) CALL DQK51(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) - IF(KEYF.EQ.6) CALL DQK61(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) -C -C IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL -C AND ERROR AND TEST FOR ACCURACY. -C - NEVAL = NEVAL+1 - AREA12 = AREA1+AREA2 - ERRO12 = ERROR1+ERROR2 - ERRSUM = ERRSUM+ERRO12-ERRMAX - AREA = AREA+AREA12-RLIST(MAXERR) - IF(DEFAB1.EQ.ERROR1.OR.DEFAB2.EQ.ERROR2) GO TO 5 - IF(ABS(RLIST(MAXERR)-AREA12).LE.0.1D-04*ABS(AREA12) - 1 .AND.ERRO12.GE.0.99D+00*ERRMAX) IROFF1 = IROFF1+1 - IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF2 = IROFF2+1 - 5 RLIST(MAXERR) = AREA1 - RLIST(LAST) = AREA2 - ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) - IF(ERRSUM.LE.ERRBND) GO TO 8 -C -C TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG. -C - IF(IROFF1.GE.6.OR.IROFF2.GE.20) IER = 2 -C -C SET ERROR FLAG IN THE CASE THAT THE NUMBER OF SUBINTERVALS -C EQUALS LIMIT. -C - IF(LAST.EQ.LIMIT) IER = 1 -C -C SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR -C AT A POINT OF THE INTEGRATION RANGE. -C - IF(MAX(ABS(A1),ABS(B2)).LE.(0.1D+01+0.1D+03* - 1 EPMACH)*(ABS(A2)+0.1D+04*UFLOW)) IER = 3 -C -C APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. -C - 8 IF(ERROR2.GT.ERROR1) GO TO 10 - ALIST(LAST) = A2 - BLIST(MAXERR) = B1 - BLIST(LAST) = B2 - ELIST(MAXERR) = ERROR1 - ELIST(LAST) = ERROR2 - GO TO 20 - 10 ALIST(MAXERR) = A2 - ALIST(LAST) = A1 - BLIST(LAST) = B1 - RLIST(MAXERR) = AREA2 - RLIST(LAST) = AREA1 - ELIST(MAXERR) = ERROR2 - ELIST(LAST) = ERROR1 -C -C CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING -C IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL -C WITH THE LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT). -C - 20 CALL DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) -C ***JUMP OUT OF DO-LOOP - IF(IER.NE.0.OR.ERRSUM.LE.ERRBND) GO TO 40 - 30 CONTINUE -C -C COMPUTE FINAL RESULT. -C --------------------- -C - 40 RESULT = 0.0D+00 - DO 50 K=1,LAST - RESULT = RESULT+RLIST(K) - 50 CONTINUE - ABSERR = ERRSUM - 60 IF(KEYF.NE.1) NEVAL = (10*KEYF+1)*(2*NEVAL+1) - IF(KEYF.EQ.1) NEVAL = 30*NEVAL+15 - 999 RETURN - END diff --git a/slatec/dqagi.f b/slatec/dqagi.f deleted file mode 100644 index 0dec16b..0000000 --- a/slatec/dqagi.f +++ /dev/null @@ -1,204 +0,0 @@ -*DECK DQAGI - SUBROUTINE DQAGI (F, BOUND, INF, EPSABS, EPSREL, RESULT, ABSERR, - + NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK) -C***BEGIN PROLOGUE DQAGI -C***PURPOSE The routine calculates an approximation result to a given -C INTEGRAL I = Integral of F over (BOUND,+INFINITY) -C OR I = Integral of F over (-INFINITY,BOUND) -C OR I = Integral of F over (-INFINITY,+INFINITY) -C Hopefully satisfying following claim for accuracy -C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A3A1, H2A4A1 -C***TYPE DOUBLE PRECISION (QAGI-S, DQAGI-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, EXTRAPOLATION, GENERAL-PURPOSE, -C GLOBALLY ADAPTIVE, INFINITE INTERVALS, QUADPACK, -C QUADRATURE, TRANSFORMATION -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration over infinite intervals -C Standard fortran subroutine -C -C PARAMETERS -C ON ENTRY -C F - Double precision -C Function subprogram defining the integrand -C function F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C BOUND - Double precision -C Finite bound of integration range -C (has no meaning if interval is doubly-infinite) -C -C INF - Integer -C indicating the kind of integration range involved -C INF = 1 corresponds to (BOUND,+INFINITY), -C INF = -1 to (-INFINITY,BOUND), -C INF = 2 to (-INFINITY,+INFINITY). -C -C EPSABS - Double precision -C Absolute accuracy requested -C EPSREL - Double precision -C Relative accuracy requested -C If EPSABS.LE.0 -C and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C the routine will end with IER = 6. -C -C -C ON RETURN -C RESULT - Double precision -C Approximation to the integral -C -C ABSERR - Double precision -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C - IER.GT.0 abnormal termination of the routine. The -C estimates for result and error are less -C reliable. It is assumed that the requested -C accuracy has not been achieved. -C ERROR MESSAGES -C IER = 1 Maximum number of subdivisions allowed -C has been achieved. One can allow more -C subdivisions by increasing the value of -C LIMIT (and taking the according dimension -C adjustments into account). However, if -C this yields no improvement it is advised -C to analyze the integrand in order to -C determine the integration difficulties. If -C the position of a local difficulty can be -C determined (e.g. SINGULARITY, -C DISCONTINUITY within the interval) one -C will probably gain from splitting up the -C interval at this point and calling the -C integrator on the subranges. If possible, -C an appropriate special-purpose integrator -C should be used, which is designed for -C handling the type of difficulty involved. -C = 2 The occurrence of roundoff error is -C detected, which prevents the requested -C tolerance from being achieved. -C The error may be under-estimated. -C = 3 Extremely bad integrand behaviour occurs -C at some points of the integration -C interval. -C = 4 The algorithm does not converge. -C Roundoff error is detected in the -C extrapolation table. -C It is assumed that the requested tolerance -C cannot be achieved, and that the returned -C RESULT is the best which can be obtained. -C = 5 The integral is probably divergent, or -C slowly convergent. It must be noted that -C divergence can occur with any other value -C of IER. -C = 6 The input is invalid, because -C (EPSABS.LE.0 and -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)) -C or LIMIT.LT.1 or LENIW.LT.LIMIT*4. -C RESULT, ABSERR, NEVAL, LAST are set to -C zero. Except when LIMIT or LENIW is -C invalid, IWORK(1), WORK(LIMIT*2+1) and -C WORK(LIMIT*3+1) are set to ZERO, WORK(1) -C is set to A and WORK(LIMIT+1) to B. -C -C DIMENSIONING PARAMETERS -C LIMIT - Integer -C Dimensioning parameter for IWORK -C LIMIT determines the maximum number of subintervals -C in the partition of the given integration interval -C (A,B), LIMIT.GE.1. -C If LIMIT.LT.1, the routine will end with IER = 6. -C -C LENW - Integer -C Dimensioning parameter for WORK -C LENW must be at least LIMIT*4. -C If LENW.LT.LIMIT*4, the routine will end -C with IER = 6. -C -C LAST - Integer -C On return, LAST equals the number of subintervals -C produced in the subdivision process, which -C determines the number of significant elements -C actually in the WORK ARRAYS. -C -C WORK ARRAYS -C IWORK - Integer -C Vector of dimension at least LIMIT, the first -C K elements of which contain pointers -C to the error estimates over the subintervals, -C such that WORK(LIMIT*3+IWORK(1)),... , -C WORK(LIMIT*3+IWORK(K)) form a decreasing -C sequence, with K = LAST if LAST.LE.(LIMIT/2+2), and -C K = LIMIT+1-LAST otherwise -C -C WORK - Double precision -C Vector of dimension at least LENW -C on return -C WORK(1), ..., WORK(LAST) contain the left -C end points of the subintervals in the -C partition of (A,B), -C WORK(LIMIT+1), ..., WORK(LIMIT+LAST) Contain -C the right end points, -C WORK(LIMIT*2+1), ...,WORK(LIMIT*2+LAST) contain the -C integral approximations over the subintervals, -C WORK(LIMIT*3+1), ..., WORK(LIMIT*3) -C contain the error estimates. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED DQAGIE, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800101 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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE DQAGI -C - DOUBLE PRECISION ABSERR,BOUND,EPSABS,EPSREL,F,RESULT,WORK - INTEGER IER,INF,IWORK,LAST,LENW,LIMIT,LVL,L1,L2,L3,NEVAL -C - DIMENSION IWORK(*),WORK(*) -C - EXTERNAL F -C -C CHECK VALIDITY OF LIMIT AND LENW. -C -C***FIRST EXECUTABLE STATEMENT DQAGI - IER = 6 - NEVAL = 0 - LAST = 0 - RESULT = 0.0D+00 - ABSERR = 0.0D+00 - IF(LIMIT.LT.1.OR.LENW.LT.LIMIT*4) GO TO 10 -C -C PREPARE CALL FOR DQAGIE. -C - L1 = LIMIT+1 - L2 = LIMIT+L1 - L3 = LIMIT+L2 -C - CALL DQAGIE(F,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,ABSERR, - 1 NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) -C -C CALL ERROR HANDLER IF NECESSARY. -C - LVL = 0 -10 IF(IER.EQ.6) LVL = 1 - IF (IER .NE. 0) CALL XERMSG ('SLATEC', 'DQAGI', - + 'ABNORMAL RETURN', IER, LVL) - RETURN - END diff --git a/slatec/dqagie.f b/slatec/dqagie.f deleted file mode 100644 index 4c739a4..0000000 --- a/slatec/dqagie.f +++ /dev/null @@ -1,463 +0,0 @@ -*DECK DQAGIE - SUBROUTINE DQAGIE (F, BOUND, INF, EPSABS, EPSREL, LIMIT, RESULT, - + ABSERR, NEVAL, IER, ALIST, BLIST, RLIST, ELIST, IORD, LAST) -C***BEGIN PROLOGUE DQAGIE -C***PURPOSE The routine calculates an approximation result to a given -C integral I = Integral of F over (BOUND,+INFINITY) -C or I = Integral of F over (-INFINITY,BOUND) -C or I = Integral of F over (-INFINITY,+INFINITY), -C hopefully satisfying following claim for accuracy -C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)) -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A3A1, H2A4A1 -C***TYPE DOUBLE PRECISION (QAGIE-S, DQAGIE-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, EXTRAPOLATION, GENERAL-PURPOSE, -C GLOBALLY ADAPTIVE, INFINITE INTERVALS, QUADPACK, -C QUADRATURE, TRANSFORMATION -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration over infinite intervals -C Standard fortran subroutine -C -C F - Double precision -C Function subprogram defining the integrand -C function F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C BOUND - Double precision -C Finite bound of integration range -C (has no meaning if interval is doubly-infinite) -C -C INF - Double precision -C Indicating the kind of integration range involved -C INF = 1 corresponds to (BOUND,+INFINITY), -C INF = -1 to (-INFINITY,BOUND), -C INF = 2 to (-INFINITY,+INFINITY). -C -C EPSABS - Double precision -C Absolute accuracy requested -C EPSREL - Double precision -C Relative accuracy requested -C If EPSABS.LE.0 -C and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C the routine will end with IER = 6. -C -C LIMIT - Integer -C Gives an upper bound on the number of subintervals -C in the partition of (A,B), LIMIT.GE.1 -C -C ON RETURN -C RESULT - Double precision -C Approximation to the integral -C -C ABSERR - Double precision -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C - IER.GT.0 Abnormal termination of the routine. The -C estimates for result and error are less -C reliable. It is assumed that the requested -C accuracy has not been achieved. -C ERROR MESSAGES -C IER = 1 Maximum number of subdivisions allowed -C has been achieved. One can allow more -C subdivisions by increasing the value of -C LIMIT (and taking the according dimension -C adjustments into account). However, if -C this yields no improvement it is advised -C to analyze the integrand in order to -C determine the integration difficulties. -C If the position of a local difficulty can -C be determined (e.g. SINGULARITY, -C DISCONTINUITY within the interval) one -C will probably gain from splitting up the -C interval at this point and calling the -C integrator on the subranges. If possible, -C an appropriate special-purpose integrator -C should be used, which is designed for -C handling the type of difficulty involved. -C = 2 The occurrence of roundoff error is -C detected, which prevents the requested -C tolerance from being achieved. -C The error may be under-estimated. -C = 3 Extremely bad integrand behaviour occurs -C at some points of the integration -C interval. -C = 4 The algorithm does not converge. -C Roundoff error is detected in the -C extrapolation table. -C It is assumed that the requested tolerance -C cannot be achieved, and that the returned -C result is the best which can be obtained. -C = 5 The integral is probably divergent, or -C slowly convergent. It must be noted that -C divergence can occur with any other value -C of IER. -C = 6 The input is invalid, because -C (EPSABS.LE.0 and -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C RESULT, ABSERR, NEVAL, LAST, RLIST(1), -C ELIST(1) and IORD(1) are set to zero. -C ALIST(1) and BLIST(1) are set to 0 -C and 1 respectively. -C -C ALIST - Double precision -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the left -C end points of the subintervals in the partition -C of the transformed integration range (0,1). -C -C BLIST - Double precision -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the right -C end points of the subintervals in the partition -C of the transformed integration range (0,1). -C -C RLIST - Double precision -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the integral -C approximations on the subintervals -C -C ELIST - Double precision -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the moduli of the -C absolute error estimates on the subintervals -C -C IORD - Integer -C Vector of dimension LIMIT, the first K -C elements of which are pointers to the -C error estimates over the subintervals, -C such that ELIST(IORD(1)), ..., ELIST(IORD(K)) -C form a decreasing sequence, with K = LAST -C If LAST.LE.(LIMIT/2+2), and K = LIMIT+1-LAST -C otherwise -C -C LAST - Integer -C Number of subintervals actually produced -C in the subdivision process -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DQELG, DQK15I, DQPSRT -C***REVISION HISTORY (YYMMDD) -C 800101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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***END PROLOGUE DQAGIE - DOUBLE PRECISION ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1, - 1 A2,BLIST,BOUN,BOUND,B1,B2,CORREC,DEFABS,DEFAB1,DEFAB2, - 2 DRES,D1MACH,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST, - 3 ERRBND,ERRMAX,ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,F,OFLOW,RESABS, - 4 RESEPS,RESULT,RES3LA,RLIST,RLIST2,SMALL,UFLOW - INTEGER ID,IER,IERRO,INF,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K,KSGN, - 1 KTMIN,LAST,LIMIT,MAXERR,NEVAL,NRES,NRMAX,NUMRL2 - LOGICAL EXTRAP,NOEXT -C - DIMENSION ALIST(*),BLIST(*),ELIST(*),IORD(*), - 1 RES3LA(3),RLIST(*),RLIST2(52) -C - EXTERNAL F -C -C THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF -C LIMEXP IN SUBROUTINE DQELG. -C -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER -C (ALIST(I),BLIST(I)) -C RLIST2 - ARRAY OF DIMENSION AT LEAST (LIMEXP+2), -C CONTAINING THE PART OF THE EPSILON TABLE -C WHICH IS STILL NEEDED FOR FURTHER COMPUTATIONS -C ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) -C MAXERR - POINTER TO THE INTERVAL WITH LARGEST ERROR -C ESTIMATE -C ERRMAX - ELIST(MAXERR) -C ERLAST - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED -C (BEFORE THAT SUBDIVISION HAS TAKEN PLACE) -C AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS -C ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS -C ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* -C ABS(RESULT)) -C *****1 - VARIABLE FOR THE LEFT SUBINTERVAL -C *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL -C LAST - INDEX FOR SUBDIVISION -C NRES - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE -C NUMRL2 - NUMBER OF ELEMENTS CURRENTLY IN RLIST2. IF AN -C APPROPRIATE APPROXIMATION TO THE COMPOUNDED -C INTEGRAL HAS BEEN OBTAINED, IT IS PUT IN -C RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED -C BY ONE. -C SMALL - LENGTH OF THE SMALLEST INTERVAL CONSIDERED UP -C TO NOW, MULTIPLIED BY 1.5 -C ERLARG - SUM OF THE ERRORS OVER THE INTERVALS LARGER -C THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW -C EXTRAP - LOGICAL VARIABLE DENOTING THAT THE ROUTINE -C IS ATTEMPTING TO PERFORM EXTRAPOLATION. I.E. -C BEFORE SUBDIVIDING THE SMALLEST INTERVAL WE -C TRY TO DECREASE THE VALUE OF ERLARG. -C NOEXT - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION -C IS NO LONGER ALLOWED (TRUE-VALUE) -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C OFLOW IS THE LARGEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT DQAGIE - EPMACH = D1MACH(4) -C -C TEST ON VALIDITY OF PARAMETERS -C ----------------------------- -C - IER = 0 - NEVAL = 0 - LAST = 0 - RESULT = 0.0D+00 - ABSERR = 0.0D+00 - ALIST(1) = 0.0D+00 - BLIST(1) = 0.1D+01 - RLIST(1) = 0.0D+00 - ELIST(1) = 0.0D+00 - IORD(1) = 0 - IF(EPSABS.LE.0.0D+00.AND.EPSREL.LT.MAX(0.5D+02*EPMACH,0.5D-28)) - 1 IER = 6 - IF(IER.EQ.6) GO TO 999 -C -C -C FIRST APPROXIMATION TO THE INTEGRAL -C ----------------------------------- -C -C DETERMINE THE INTERVAL TO BE MAPPED ONTO (0,1). -C IF INF = 2 THE INTEGRAL IS COMPUTED AS I = I1+I2, WHERE -C I1 = INTEGRAL OF F OVER (-INFINITY,0), -C I2 = INTEGRAL OF F OVER (0,+INFINITY). -C - BOUN = BOUND - IF(INF.EQ.2) BOUN = 0.0D+00 - CALL DQK15I(F,BOUN,INF,0.0D+00,0.1D+01,RESULT,ABSERR, - 1 DEFABS,RESABS) -C -C TEST ON ACCURACY -C - LAST = 1 - RLIST(1) = RESULT - ELIST(1) = ABSERR - IORD(1) = 1 - DRES = ABS(RESULT) - ERRBND = MAX(EPSABS,EPSREL*DRES) - IF(ABSERR.LE.1.0D+02*EPMACH*DEFABS.AND.ABSERR.GT.ERRBND) IER = 2 - IF(LIMIT.EQ.1) IER = 1 - IF(IER.NE.0.OR.(ABSERR.LE.ERRBND.AND.ABSERR.NE.RESABS).OR. - 1 ABSERR.EQ.0.0D+00) GO TO 130 -C -C INITIALIZATION -C -------------- -C - UFLOW = D1MACH(1) - OFLOW = D1MACH(2) - RLIST2(1) = RESULT - ERRMAX = ABSERR - MAXERR = 1 - AREA = RESULT - ERRSUM = ABSERR - ABSERR = OFLOW - NRMAX = 1 - NRES = 0 - KTMIN = 0 - NUMRL2 = 2 - EXTRAP = .FALSE. - NOEXT = .FALSE. - IERRO = 0 - IROFF1 = 0 - IROFF2 = 0 - IROFF3 = 0 - KSGN = -1 - IF(DRES.GE.(0.1D+01-0.5D+02*EPMACH)*DEFABS) KSGN = 1 -C -C MAIN DO-LOOP -C ------------ -C - DO 90 LAST = 2,LIMIT -C -C BISECT THE SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE. -C - A1 = ALIST(MAXERR) - B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR)) - A2 = B1 - B2 = BLIST(MAXERR) - ERLAST = ERRMAX - CALL DQK15I(F,BOUN,INF,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) - CALL DQK15I(F,BOUN,INF,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) -C -C IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL -C AND ERROR AND TEST FOR ACCURACY. -C - AREA12 = AREA1+AREA2 - ERRO12 = ERROR1+ERROR2 - ERRSUM = ERRSUM+ERRO12-ERRMAX - AREA = AREA+AREA12-RLIST(MAXERR) - IF(DEFAB1.EQ.ERROR1.OR.DEFAB2.EQ.ERROR2)GO TO 15 - IF(ABS(RLIST(MAXERR)-AREA12).GT.0.1D-04*ABS(AREA12) - 1 .OR.ERRO12.LT.0.99D+00*ERRMAX) GO TO 10 - IF(EXTRAP) IROFF2 = IROFF2+1 - IF(.NOT.EXTRAP) IROFF1 = IROFF1+1 - 10 IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF3 = IROFF3+1 - 15 RLIST(MAXERR) = AREA1 - RLIST(LAST) = AREA2 - ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) -C -C TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG. -C - IF(IROFF1+IROFF2.GE.10.OR.IROFF3.GE.20) IER = 2 - IF(IROFF2.GE.5) IERRO = 3 -C -C SET ERROR FLAG IN THE CASE THAT THE NUMBER OF -C SUBINTERVALS EQUALS LIMIT. -C - IF(LAST.EQ.LIMIT) IER = 1 -C -C SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR -C AT SOME POINTS OF THE INTEGRATION RANGE. -C - IF(MAX(ABS(A1),ABS(B2)).LE.(0.1D+01+0.1D+03*EPMACH)* - 1 (ABS(A2)+0.1D+04*UFLOW)) IER = 4 -C -C APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. -C - IF(ERROR2.GT.ERROR1) GO TO 20 - ALIST(LAST) = A2 - BLIST(MAXERR) = B1 - BLIST(LAST) = B2 - ELIST(MAXERR) = ERROR1 - ELIST(LAST) = ERROR2 - GO TO 30 - 20 ALIST(MAXERR) = A2 - ALIST(LAST) = A1 - BLIST(LAST) = B1 - RLIST(MAXERR) = AREA2 - RLIST(LAST) = AREA1 - ELIST(MAXERR) = ERROR2 - ELIST(LAST) = ERROR1 -C -C CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING -C IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL -C WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT). -C - 30 CALL DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) - IF(ERRSUM.LE.ERRBND) GO TO 115 - IF(IER.NE.0) GO TO 100 - IF(LAST.EQ.2) GO TO 80 - IF(NOEXT) GO TO 90 - ERLARG = ERLARG-ERLAST - IF(ABS(B1-A1).GT.SMALL) ERLARG = ERLARG+ERRO12 - IF(EXTRAP) GO TO 40 -C -C TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE -C SMALLEST INTERVAL. -C - IF(ABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90 - EXTRAP = .TRUE. - NRMAX = 2 - 40 IF(IERRO.EQ.3.OR.ERLARG.LE.ERTEST) GO TO 60 -C -C THE SMALLEST INTERVAL HAS THE LARGEST ERROR. -C BEFORE BISECTING DECREASE THE SUM OF THE ERRORS OVER THE -C LARGER INTERVALS (ERLARG) AND PERFORM EXTRAPOLATION. -C - ID = NRMAX - JUPBND = LAST - IF(LAST.GT.(2+LIMIT/2)) JUPBND = LIMIT+3-LAST - DO 50 K = ID,JUPBND - MAXERR = IORD(NRMAX) - ERRMAX = ELIST(MAXERR) - IF(ABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90 - NRMAX = NRMAX+1 - 50 CONTINUE -C -C PERFORM EXTRAPOLATION. -C - 60 NUMRL2 = NUMRL2+1 - RLIST2(NUMRL2) = AREA - CALL DQELG(NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES) - KTMIN = KTMIN+1 - IF(KTMIN.GT.5.AND.ABSERR.LT.0.1D-02*ERRSUM) IER = 5 - IF(ABSEPS.GE.ABSERR) GO TO 70 - KTMIN = 0 - ABSERR = ABSEPS - RESULT = RESEPS - CORREC = ERLARG - ERTEST = MAX(EPSABS,EPSREL*ABS(RESEPS)) - IF(ABSERR.LE.ERTEST) GO TO 100 -C -C PREPARE BISECTION OF THE SMALLEST INTERVAL. -C - 70 IF(NUMRL2.EQ.1) NOEXT = .TRUE. - IF(IER.EQ.5) GO TO 100 - MAXERR = IORD(1) - ERRMAX = ELIST(MAXERR) - NRMAX = 1 - EXTRAP = .FALSE. - SMALL = SMALL*0.5D+00 - ERLARG = ERRSUM - GO TO 90 - 80 SMALL = 0.375D+00 - ERLARG = ERRSUM - ERTEST = ERRBND - RLIST2(2) = AREA - 90 CONTINUE -C -C SET FINAL RESULT AND ERROR ESTIMATE. -C ------------------------------------ -C - 100 IF(ABSERR.EQ.OFLOW) GO TO 115 - IF((IER+IERRO).EQ.0) GO TO 110 - IF(IERRO.EQ.3) ABSERR = ABSERR+CORREC - IF(IER.EQ.0) IER = 3 - IF(RESULT.NE.0.0D+00.AND.AREA.NE.0.0D+00)GO TO 105 - IF(ABSERR.GT.ERRSUM)GO TO 115 - IF(AREA.EQ.0.0D+00) GO TO 130 - GO TO 110 - 105 IF(ABSERR/ABS(RESULT).GT.ERRSUM/ABS(AREA))GO TO 115 -C -C TEST ON DIVERGENCE -C - 110 IF(KSGN.EQ.(-1).AND.MAX(ABS(RESULT),ABS(AREA)).LE. - 1 DEFABS*0.1D-01) GO TO 130 - IF (0.1D-01.GT.(RESULT/AREA).OR.(RESULT/AREA).GT.0.1D+03 - 1 .OR.ERRSUM.GT.ABS(AREA)) IER = 6 - GO TO 130 -C -C COMPUTE GLOBAL INTEGRAL SUM. -C - 115 RESULT = 0.0D+00 - DO 120 K = 1,LAST - RESULT = RESULT+RLIST(K) - 120 CONTINUE - ABSERR = ERRSUM - 130 NEVAL = 30*LAST-15 - IF(INF.EQ.2) NEVAL = 2*NEVAL - IF(IER.GT.2) IER=IER-1 - 999 RETURN - END diff --git a/slatec/dqagp.f b/slatec/dqagp.f deleted file mode 100644 index 87a31ac..0000000 --- a/slatec/dqagp.f +++ /dev/null @@ -1,237 +0,0 @@ -*DECK DQAGP - SUBROUTINE DQAGP (F, A, B, NPTS2, POINTS, EPSABS, EPSREL, RESULT, - + ABSERR, NEVAL, IER, LENIW, LENW, LAST, IWORK, WORK) -C***BEGIN PROLOGUE DQAGP -C***PURPOSE The routine calculates an approximation result to a given -C definite integral I = Integral of F over (A,B), -C hopefully satisfying following claim for accuracy -C break points of the integration interval, where local -C difficulties of the integrand may occur (e.g. -C SINGULARITIES, DISCONTINUITIES), are provided by the user. -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A2A1 -C***TYPE DOUBLE PRECISION (QAGP-S, DQAGP-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, EXTRAPOLATION, GENERAL-PURPOSE, -C GLOBALLY ADAPTIVE, QUADPACK, QUADRATURE, -C SINGULARITIES AT USER SPECIFIED POINTS -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Computation of a definite integral -C Standard fortran subroutine -C Double precision version -C -C PARAMETERS -C ON ENTRY -C F - Double precision -C Function subprogram defining the integrand -C Function F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C A - Double precision -C Lower limit of integration -C -C B - Double precision -C Upper limit of integration -C -C NPTS2 - Integer -C Number equal to two more than the number of -C user-supplied break points within the integration -C range, NPTS.GE.2. -C If NPTS2.LT.2, The routine will end with IER = 6. -C -C POINTS - Double precision -C Vector of dimension NPTS2, the first (NPTS2-2) -C elements of which are the user provided break -C points. If these points do not constitute an -C ascending sequence there will be an automatic -C sorting. -C -C EPSABS - Double precision -C Absolute accuracy requested -C EPSREL - Double precision -C Relative accuracy requested -C If EPSABS.LE.0 -C And EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C The routine will end with IER = 6. -C -C ON RETURN -C RESULT - Double precision -C Approximation to the integral -C -C ABSERR - Double precision -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C IER.GT.0 Abnormal termination of the routine. -C The estimates for integral and error are -C less reliable. it is assumed that the -C requested accuracy has not been achieved. -C ERROR MESSAGES -C IER = 1 Maximum number of subdivisions allowed -C has been achieved. one can allow more -C subdivisions by increasing the value of -C LIMIT (and taking the according dimension -C adjustments into account). However, if -C this yields no improvement it is advised -C to analyze the integrand in order to -C determine the integration difficulties. If -C the position of a local difficulty can be -C determined (i.e. SINGULARITY, -C DISCONTINUITY within the interval), it -C should be supplied to the routine as an -C element of the vector points. If necessary -C an appropriate special-purpose integrator -C must be used, which is designed for -C handling the type of difficulty involved. -C = 2 The occurrence of roundoff error is -C detected, which prevents the requested -C tolerance from being achieved. -C The error may be under-estimated. -C = 3 Extremely bad integrand behaviour occurs -C at some points of the integration -C interval. -C = 4 The algorithm does not converge. -C roundoff error is detected in the -C extrapolation table. -C It is presumed that the requested -C tolerance cannot be achieved, and that -C the returned RESULT is the best which -C can be obtained. -C = 5 The integral is probably divergent, or -C slowly convergent. it must be noted that -C divergence can occur with any other value -C of IER.GT.0. -C = 6 The input is invalid because -C NPTS2.LT.2 or -C break points are specified outside -C the integration range or -C (EPSABS.LE.0 and -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)) -C RESULT, ABSERR, NEVAL, LAST are set to -C zero. Except when LENIW or LENW or NPTS2 -C is invalid, IWORK(1), IWORK(LIMIT+1), -C WORK(LIMIT*2+1) and WORK(LIMIT*3+1) -C are set to zero. -C WORK(1) is set to A and WORK(LIMIT+1) -C to B (where LIMIT = (LENIW-NPTS2)/2). -C -C DIMENSIONING PARAMETERS -C LENIW - Integer -C Dimensioning parameter for IWORK -C LENIW determines LIMIT = (LENIW-NPTS2)/2, -C which is the maximum number of subintervals in the -C partition of the given integration interval (A,B), -C LENIW.GE.(3*NPTS2-2). -C If LENIW.LT.(3*NPTS2-2), the routine will end with -C IER = 6. -C -C LENW - Integer -C Dimensioning parameter for WORK -C LENW must be at least LENIW*2-NPTS2. -C If LENW.LT.LENIW*2-NPTS2, the routine will end -C with IER = 6. -C -C LAST - Integer -C On return, LAST equals the number of subintervals -C produced in the subdivision process, which -C determines the number of significant elements -C actually in the WORK ARRAYS. -C -C WORK ARRAYS -C IWORK - Integer -C Vector of dimension at least LENIW. on return, -C the first K elements of which contain -C pointers to the error estimates over the -C subintervals, such that WORK(LIMIT*3+IWORK(1)),..., -C WORK(LIMIT*3+IWORK(K)) form a decreasing -C sequence, with K = LAST if LAST.LE.(LIMIT/2+2), and -C K = LIMIT+1-LAST otherwise -C IWORK(LIMIT+1), ...,IWORK(LIMIT+LAST) Contain the -C subdivision levels of the subintervals, i.e. -C if (AA,BB) is a subinterval of (P1,P2) -C where P1 as well as P2 is a user-provided -C break point or integration LIMIT, then (AA,BB) has -C level L if ABS(BB-AA) = ABS(P2-P1)*2**(-L), -C IWORK(LIMIT*2+1), ..., IWORK(LIMIT*2+NPTS2) have -C no significance for the user, -C note that LIMIT = (LENIW-NPTS2)/2. -C -C WORK - Double precision -C Vector of dimension at least LENW -C on return -C WORK(1), ..., WORK(LAST) contain the left -C end points of the subintervals in the -C partition of (A,B), -C WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain -C the right end points, -C WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) contain -C the integral approximations over the subintervals, -C WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) -C contain the corresponding error estimates, -C WORK(LIMIT*4+1), ..., WORK(LIMIT*4+NPTS2) -C contain the integration limits and the -C break points sorted in an ascending sequence. -C note that LIMIT = (LENIW-NPTS2)/2. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED DQAGPE, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800101 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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE DQAGP -C - DOUBLE PRECISION A,ABSERR,B,EPSABS,EPSREL,F,POINTS,RESULT,WORK - INTEGER IER,IWORK,LAST,LENIW,LENW,LIMIT,LVL,L1,L2,L3,L4,NEVAL, - 1 NPTS2 -C - DIMENSION IWORK(*),POINTS(*),WORK(*) -C - EXTERNAL F -C -C CHECK VALIDITY OF LIMIT AND LENW. -C -C***FIRST EXECUTABLE STATEMENT DQAGP - IER = 6 - NEVAL = 0 - LAST = 0 - RESULT = 0.0D+00 - ABSERR = 0.0D+00 - IF(LENIW.LT.(3*NPTS2-2).OR.LENW.LT.(LENIW*2-NPTS2).OR.NPTS2.LT.2) - 1 GO TO 10 -C -C PREPARE CALL FOR DQAGPE. -C - LIMIT = (LENIW-NPTS2)/2 - L1 = LIMIT+1 - L2 = LIMIT+L1 - L3 = LIMIT+L2 - L4 = LIMIT+L3 -C - CALL DQAGPE(F,A,B,NPTS2,POINTS,EPSABS,EPSREL,LIMIT,RESULT,ABSERR, - 1 NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),WORK(L4), - 2 IWORK(1),IWORK(L1),IWORK(L2),LAST) -C -C CALL ERROR HANDLER IF NECESSARY. -C - LVL = 0 -10 IF(IER.EQ.6) LVL = 1 - IF (IER .NE. 0) CALL XERMSG ('SLATEC', 'DQAGP', - + 'ABNORMAL RETURN', IER, LVL) - RETURN - END diff --git a/slatec/dqagpe.f b/slatec/dqagpe.f deleted file mode 100644 index f108e9e..0000000 --- a/slatec/dqagpe.f +++ /dev/null @@ -1,561 +0,0 @@ -*DECK DQAGPE - SUBROUTINE DQAGPE (F, A, B, NPTS2, POINTS, EPSABS, EPSREL, LIMIT, - + RESULT, ABSERR, NEVAL, IER, ALIST, BLIST, RLIST, ELIST, PTS, - + IORD, LEVEL, NDIN, LAST) -C***BEGIN PROLOGUE DQAGPE -C***PURPOSE Approximate a given definite integral I = Integral of F -C over (A,B), hopefully satisfying the accuracy claim: -C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). -C Break points of the integration interval, where local -C difficulties of the integrand may occur (e.g. singularities -C or discontinuities) are provided by the user. -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A2A1 -C***TYPE DOUBLE PRECISION (QAGPE-S, DQAGPE-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, EXTRAPOLATION, GENERAL-PURPOSE, -C GLOBALLY ADAPTIVE, QUADPACK, QUADRATURE, -C SINGULARITIES AT USER SPECIFIED POINTS -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Computation of a definite integral -C Standard fortran subroutine -C Double precision version -C -C PARAMETERS -C ON ENTRY -C F - Double precision -C Function subprogram defining the integrand -C function F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C A - Double precision -C Lower limit of integration -C -C B - Double precision -C Upper limit of integration -C -C NPTS2 - Integer -C Number equal to two more than the number of -C user-supplied break points within the integration -C range, NPTS2.GE.2. -C If NPTS2.LT.2, the routine will end with IER = 6. -C -C POINTS - Double precision -C Vector of dimension NPTS2, the first (NPTS2-2) -C elements of which are the user provided break -C POINTS. If these POINTS do not constitute an -C ascending sequence there will be an automatic -C sorting. -C -C EPSABS - Double precision -C Absolute accuracy requested -C EPSREL - Double precision -C Relative accuracy requested -C If EPSABS.LE.0 -C and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C the routine will end with IER = 6. -C -C LIMIT - Integer -C Gives an upper bound on the number of subintervals -C in the partition of (A,B), LIMIT.GE.NPTS2 -C If LIMIT.LT.NPTS2, the routine will end with -C IER = 6. -C -C ON RETURN -C RESULT - Double precision -C Approximation to the integral -C -C ABSERR - Double precision -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C IER.GT.0 Abnormal termination of the routine. -C The estimates for integral and error are -C less reliable. It is assumed that the -C requested accuracy has not been achieved. -C ERROR MESSAGES -C IER = 1 Maximum number of subdivisions allowed -C has been achieved. One can allow more -C subdivisions by increasing the value of -C LIMIT (and taking the according dimension -C adjustments into account). However, if -C this yields no improvement it is advised -C to analyze the integrand in order to -C determine the integration difficulties. If -C the position of a local difficulty can be -C determined (i.e. SINGULARITY, -C DISCONTINUITY within the interval), it -C should be supplied to the routine as an -C element of the vector points. If necessary -C an appropriate special-purpose integrator -C must be used, which is designed for -C handling the type of difficulty involved. -C = 2 The occurrence of roundoff error is -C detected, which prevents the requested -C tolerance from being achieved. -C The error may be under-estimated. -C = 3 Extremely bad integrand behaviour occurs -C At some points of the integration -C interval. -C = 4 The algorithm does not converge. -C Roundoff error is detected in the -C extrapolation table. It is presumed that -C the requested tolerance cannot be -C achieved, and that the returned result is -C the best which can be obtained. -C = 5 The integral is probably divergent, or -C slowly convergent. It must be noted that -C divergence can occur with any other value -C of IER.GT.0. -C = 6 The input is invalid because -C NPTS2.LT.2 or -C Break points are specified outside -C the integration range or -C (EPSABS.LE.0 and -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)) -C or LIMIT.LT.NPTS2. -C RESULT, ABSERR, NEVAL, LAST, RLIST(1), -C and ELIST(1) are set to zero. ALIST(1) and -C BLIST(1) are set to A and B respectively. -C -C ALIST - Double precision -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the left end points -C of the subintervals in the partition of the given -C integration range (A,B) -C -C BLIST - Double precision -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the right end points -C of the subintervals in the partition of the given -C integration range (A,B) -C -C RLIST - Double precision -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the integral -C approximations on the subintervals -C -C ELIST - Double precision -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the moduli of the -C absolute error estimates on the subintervals -C -C PTS - Double precision -C Vector of dimension at least NPTS2, containing the -C integration limits and the break points of the -C interval in ascending sequence. -C -C LEVEL - Integer -C Vector of dimension at least LIMIT, containing the -C subdivision levels of the subinterval, i.e. if -C (AA,BB) is a subinterval of (P1,P2) where P1 as -C well as P2 is a user-provided break point or -C integration limit, then (AA,BB) has level L if -C ABS(BB-AA) = ABS(P2-P1)*2**(-L). -C -C NDIN - Integer -C Vector of dimension at least NPTS2, after first -C integration over the intervals (PTS(I)),PTS(I+1), -C I = 0,1, ..., NPTS2-2, the error estimates over -C some of the intervals may have been increased -C artificially, in order to put their subdivision -C forward. If this happens for the subinterval -C numbered K, NDIN(K) is put to 1, otherwise -C NDIN(K) = 0. -C -C IORD - Integer -C Vector of dimension at least LIMIT, the first K -C elements of which are pointers to the -C error estimates over the subintervals, -C such that ELIST(IORD(1)), ..., ELIST(IORD(K)) -C form a decreasing sequence, with K = LAST -C If LAST.LE.(LIMIT/2+2), and K = LIMIT+1-LAST -C otherwise -C -C LAST - Integer -C Number of subintervals actually produced in the -C subdivisions process -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DQELG, DQK21, DQPSRT -C***REVISION HISTORY (YYMMDD) -C 800101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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***END PROLOGUE DQAGPE - DOUBLE PRECISION A,ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1, - 1 A2,B,BLIST,B1,B2,CORREC,DEFABS,DEFAB1,DEFAB2, - 2 DRES,D1MACH,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND, - 3 ERRMAX,ERROR1,ERRO12,ERROR2,ERRSUM,ERTEST,F,OFLOW,POINTS,PTS, - 4 RESA,RESABS,RESEPS,RESULT,RES3LA,RLIST,RLIST2,SIGN,TEMP,UFLOW - INTEGER I,ID,IER,IERRO,IND1,IND2,IORD,IP1,IROFF1,IROFF2,IROFF3,J, - 1 JLOW,JUPBND,K,KSGN,KTMIN,LAST,LEVCUR,LEVEL,LEVMAX,LIMIT,MAXERR, - 2 NDIN,NEVAL,NINT,NINTP1,NPTS,NPTS2,NRES,NRMAX,NUMRL2 - LOGICAL EXTRAP,NOEXT -C -C - DIMENSION ALIST(*),BLIST(*),ELIST(*),IORD(*), - 1 LEVEL(*),NDIN(*),POINTS(*),PTS(*),RES3LA(3), - 2 RLIST(*),RLIST2(52) -C - EXTERNAL F -C -C THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF -C LIMEXP IN SUBROUTINE EPSALG (RLIST2 SHOULD BE OF DIMENSION -C (LIMEXP+2) AT LEAST). -C -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER -C (ALIST(I),BLIST(I)) -C RLIST2 - ARRAY OF DIMENSION AT LEAST LIMEXP+2 -C CONTAINING THE PART OF THE EPSILON TABLE WHICH -C IS STILL NEEDED FOR FURTHER COMPUTATIONS -C ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) -C MAXERR - POINTER TO THE INTERVAL WITH LARGEST ERROR -C ESTIMATE -C ERRMAX - ELIST(MAXERR) -C ERLAST - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED -C (BEFORE THAT SUBDIVISION HAS TAKEN PLACE) -C AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS -C ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS -C ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* -C ABS(RESULT)) -C *****1 - VARIABLE FOR THE LEFT SUBINTERVAL -C *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL -C LAST - INDEX FOR SUBDIVISION -C NRES - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE -C NUMRL2 - NUMBER OF ELEMENTS IN RLIST2. IF AN APPROPRIATE -C APPROXIMATION TO THE COMPOUNDED INTEGRAL HAS -C BEEN OBTAINED, IT IS PUT IN RLIST2(NUMRL2) AFTER -C NUMRL2 HAS BEEN INCREASED BY ONE. -C ERLARG - SUM OF THE ERRORS OVER THE INTERVALS LARGER -C THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW -C EXTRAP - LOGICAL VARIABLE DENOTING THAT THE ROUTINE -C IS ATTEMPTING TO PERFORM EXTRAPOLATION. I.E. -C BEFORE SUBDIVIDING THE SMALLEST INTERVAL WE -C TRY TO DECREASE THE VALUE OF ERLARG. -C NOEXT - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION IS -C NO LONGER ALLOWED (TRUE-VALUE) -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C OFLOW IS THE LARGEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT DQAGPE - EPMACH = D1MACH(4) -C -C TEST ON VALIDITY OF PARAMETERS -C ----------------------------- -C - IER = 0 - NEVAL = 0 - LAST = 0 - RESULT = 0.0D+00 - ABSERR = 0.0D+00 - ALIST(1) = A - BLIST(1) = B - RLIST(1) = 0.0D+00 - ELIST(1) = 0.0D+00 - IORD(1) = 0 - LEVEL(1) = 0 - NPTS = NPTS2-2 - IF(NPTS2.LT.2.OR.LIMIT.LE.NPTS.OR.(EPSABS.LE.0.0D+00.AND. - 1 EPSREL.LT.MAX(0.5D+02*EPMACH,0.5D-28))) IER = 6 - IF(IER.EQ.6) GO TO 999 -C -C IF ANY BREAK POINTS ARE PROVIDED, SORT THEM INTO AN -C ASCENDING SEQUENCE. -C - SIGN = 1.0D+00 - IF(A.GT.B) SIGN = -1.0D+00 - PTS(1) = MIN(A,B) - IF(NPTS.EQ.0) GO TO 15 - DO 10 I = 1,NPTS - PTS(I+1) = POINTS(I) - 10 CONTINUE - 15 PTS(NPTS+2) = MAX(A,B) - NINT = NPTS+1 - A1 = PTS(1) - IF(NPTS.EQ.0) GO TO 40 - NINTP1 = NINT+1 - DO 20 I = 1,NINT - IP1 = I+1 - DO 20 J = IP1,NINTP1 - IF(PTS(I).LE.PTS(J)) GO TO 20 - TEMP = PTS(I) - PTS(I) = PTS(J) - PTS(J) = TEMP - 20 CONTINUE - IF(PTS(1).NE.MIN(A,B).OR.PTS(NINTP1).NE.MAX(A,B)) IER = 6 - IF(IER.EQ.6) GO TO 999 -C -C COMPUTE FIRST INTEGRAL AND ERROR APPROXIMATIONS. -C ------------------------------------------------ -C - 40 RESABS = 0.0D+00 - DO 50 I = 1,NINT - B1 = PTS(I+1) - CALL DQK21(F,A1,B1,AREA1,ERROR1,DEFABS,RESA) - ABSERR = ABSERR+ERROR1 - RESULT = RESULT+AREA1 - NDIN(I) = 0 - IF(ERROR1.EQ.RESA.AND.ERROR1.NE.0.0D+00) NDIN(I) = 1 - RESABS = RESABS+DEFABS - LEVEL(I) = 0 - ELIST(I) = ERROR1 - ALIST(I) = A1 - BLIST(I) = B1 - RLIST(I) = AREA1 - IORD(I) = I - A1 = B1 - 50 CONTINUE - ERRSUM = 0.0D+00 - DO 55 I = 1,NINT - IF(NDIN(I).EQ.1) ELIST(I) = ABSERR - ERRSUM = ERRSUM+ELIST(I) - 55 CONTINUE -C -C TEST ON ACCURACY. -C - LAST = NINT - NEVAL = 21*NINT - DRES = ABS(RESULT) - ERRBND = MAX(EPSABS,EPSREL*DRES) - IF(ABSERR.LE.0.1D+03*EPMACH*RESABS.AND.ABSERR.GT.ERRBND) IER = 2 - IF(NINT.EQ.1) GO TO 80 - DO 70 I = 1,NPTS - JLOW = I+1 - IND1 = IORD(I) - DO 60 J = JLOW,NINT - IND2 = IORD(J) - IF(ELIST(IND1).GT.ELIST(IND2)) GO TO 60 - IND1 = IND2 - K = J - 60 CONTINUE - IF(IND1.EQ.IORD(I)) GO TO 70 - IORD(K) = IORD(I) - IORD(I) = IND1 - 70 CONTINUE - IF(LIMIT.LT.NPTS2) IER = 1 - 80 IF(IER.NE.0.OR.ABSERR.LE.ERRBND) GO TO 999 -C -C INITIALIZATION -C -------------- -C - RLIST2(1) = RESULT - MAXERR = IORD(1) - ERRMAX = ELIST(MAXERR) - AREA = RESULT - NRMAX = 1 - NRES = 0 - NUMRL2 = 1 - KTMIN = 0 - EXTRAP = .FALSE. - NOEXT = .FALSE. - ERLARG = ERRSUM - ERTEST = ERRBND - LEVMAX = 1 - IROFF1 = 0 - IROFF2 = 0 - IROFF3 = 0 - IERRO = 0 - UFLOW = D1MACH(1) - OFLOW = D1MACH(2) - ABSERR = OFLOW - KSGN = -1 - IF(DRES.GE.(0.1D+01-0.5D+02*EPMACH)*RESABS) KSGN = 1 -C -C MAIN DO-LOOP -C ------------ -C - DO 160 LAST = NPTS2,LIMIT -C -C BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST ERROR -C ESTIMATE. -C - LEVCUR = LEVEL(MAXERR)+1 - A1 = ALIST(MAXERR) - B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR)) - A2 = B1 - B2 = BLIST(MAXERR) - ERLAST = ERRMAX - CALL DQK21(F,A1,B1,AREA1,ERROR1,RESA,DEFAB1) - CALL DQK21(F,A2,B2,AREA2,ERROR2,RESA,DEFAB2) -C -C IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL -C AND ERROR AND TEST FOR ACCURACY. -C - NEVAL = NEVAL+42 - AREA12 = AREA1+AREA2 - ERRO12 = ERROR1+ERROR2 - ERRSUM = ERRSUM+ERRO12-ERRMAX - AREA = AREA+AREA12-RLIST(MAXERR) - IF(DEFAB1.EQ.ERROR1.OR.DEFAB2.EQ.ERROR2) GO TO 95 - IF(ABS(RLIST(MAXERR)-AREA12).GT.0.1D-04*ABS(AREA12) - 1 .OR.ERRO12.LT.0.99D+00*ERRMAX) GO TO 90 - IF(EXTRAP) IROFF2 = IROFF2+1 - IF(.NOT.EXTRAP) IROFF1 = IROFF1+1 - 90 IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF3 = IROFF3+1 - 95 LEVEL(MAXERR) = LEVCUR - LEVEL(LAST) = LEVCUR - RLIST(MAXERR) = AREA1 - RLIST(LAST) = AREA2 - ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) -C -C TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG. -C - IF(IROFF1+IROFF2.GE.10.OR.IROFF3.GE.20) IER = 2 - IF(IROFF2.GE.5) IERRO = 3 -C -C SET ERROR FLAG IN THE CASE THAT THE NUMBER OF -C SUBINTERVALS EQUALS LIMIT. -C - IF(LAST.EQ.LIMIT) IER = 1 -C -C SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR -C AT A POINT OF THE INTEGRATION RANGE -C - IF(MAX(ABS(A1),ABS(B2)).LE.(0.1D+01+0.1D+03*EPMACH)* - 1 (ABS(A2)+0.1D+04*UFLOW)) IER = 4 -C -C APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. -C - IF(ERROR2.GT.ERROR1) GO TO 100 - ALIST(LAST) = A2 - BLIST(MAXERR) = B1 - BLIST(LAST) = B2 - ELIST(MAXERR) = ERROR1 - ELIST(LAST) = ERROR2 - GO TO 110 - 100 ALIST(MAXERR) = A2 - ALIST(LAST) = A1 - BLIST(LAST) = B1 - RLIST(MAXERR) = AREA2 - RLIST(LAST) = AREA1 - ELIST(MAXERR) = ERROR2 - ELIST(LAST) = ERROR1 -C -C CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING -C IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL -C WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT). -C - 110 CALL DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) -C ***JUMP OUT OF DO-LOOP - IF(ERRSUM.LE.ERRBND) GO TO 190 -C ***JUMP OUT OF DO-LOOP - IF(IER.NE.0) GO TO 170 - IF(NOEXT) GO TO 160 - ERLARG = ERLARG-ERLAST - IF(LEVCUR+1.LE.LEVMAX) ERLARG = ERLARG+ERRO12 - IF(EXTRAP) GO TO 120 -C -C TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE -C SMALLEST INTERVAL. -C - IF(LEVEL(MAXERR)+1.LE.LEVMAX) GO TO 160 - EXTRAP = .TRUE. - NRMAX = 2 - 120 IF(IERRO.EQ.3.OR.ERLARG.LE.ERTEST) GO TO 140 -C -C THE SMALLEST INTERVAL HAS THE LARGEST ERROR. -C BEFORE BISECTING DECREASE THE SUM OF THE ERRORS OVER -C THE LARGER INTERVALS (ERLARG) AND PERFORM EXTRAPOLATION. -C - ID = NRMAX - JUPBND = LAST - IF(LAST.GT.(2+LIMIT/2)) JUPBND = LIMIT+3-LAST - DO 130 K = ID,JUPBND - MAXERR = IORD(NRMAX) - ERRMAX = ELIST(MAXERR) -C ***JUMP OUT OF DO-LOOP - IF(LEVEL(MAXERR)+1.LE.LEVMAX) GO TO 160 - NRMAX = NRMAX+1 - 130 CONTINUE -C -C PERFORM EXTRAPOLATION. -C - 140 NUMRL2 = NUMRL2+1 - RLIST2(NUMRL2) = AREA - IF(NUMRL2.LE.2) GO TO 155 - CALL DQELG(NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES) - KTMIN = KTMIN+1 - IF(KTMIN.GT.5.AND.ABSERR.LT.0.1D-02*ERRSUM) IER = 5 - IF(ABSEPS.GE.ABSERR) GO TO 150 - KTMIN = 0 - ABSERR = ABSEPS - RESULT = RESEPS - CORREC = ERLARG - ERTEST = MAX(EPSABS,EPSREL*ABS(RESEPS)) -C ***JUMP OUT OF DO-LOOP - IF(ABSERR.LT.ERTEST) GO TO 170 -C -C PREPARE BISECTION OF THE SMALLEST INTERVAL. -C - 150 IF(NUMRL2.EQ.1) NOEXT = .TRUE. - IF(IER.GE.5) GO TO 170 - 155 MAXERR = IORD(1) - ERRMAX = ELIST(MAXERR) - NRMAX = 1 - EXTRAP = .FALSE. - LEVMAX = LEVMAX+1 - ERLARG = ERRSUM - 160 CONTINUE -C -C SET THE FINAL RESULT. -C --------------------- -C -C - 170 IF(ABSERR.EQ.OFLOW) GO TO 190 - IF((IER+IERRO).EQ.0) GO TO 180 - IF(IERRO.EQ.3) ABSERR = ABSERR+CORREC - IF(IER.EQ.0) IER = 3 - IF(RESULT.NE.0.0D+00.AND.AREA.NE.0.0D+00)GO TO 175 - IF(ABSERR.GT.ERRSUM)GO TO 190 - IF(AREA.EQ.0.0D+00) GO TO 210 - GO TO 180 - 175 IF(ABSERR/ABS(RESULT).GT.ERRSUM/ABS(AREA))GO TO 190 -C -C TEST ON DIVERGENCE. -C - 180 IF(KSGN.EQ.(-1).AND.MAX(ABS(RESULT),ABS(AREA)).LE. - 1 DEFABS*0.1D-01) GO TO 210 - IF(0.1D-01.GT.(RESULT/AREA).OR.(RESULT/AREA).GT.0.1D+03.OR. - 1 ERRSUM.GT.ABS(AREA)) IER = 6 - GO TO 210 -C -C COMPUTE GLOBAL INTEGRAL SUM. -C - 190 RESULT = 0.0D+00 - DO 200 K = 1,LAST - RESULT = RESULT+RLIST(K) - 200 CONTINUE - ABSERR = ERRSUM - 210 IF(IER.GT.2) IER = IER-1 - RESULT = RESULT*SIGN - 999 RETURN - END diff --git a/slatec/dqags.f b/slatec/dqags.f deleted file mode 100644 index 082bb0a..0000000 --- a/slatec/dqags.f +++ /dev/null @@ -1,200 +0,0 @@ -*DECK DQAGS - SUBROUTINE DQAGS (F, A, B, EPSABS, EPSREL, RESULT, ABSERR, NEVAL, - + IER, LIMIT, LENW, LAST, IWORK, WORK) -C***BEGIN PROLOGUE DQAGS -C***PURPOSE The routine calculates an approximation result to a given -C Definite integral I = Integral of F over (A,B), -C Hopefully satisfying following claim for accuracy -C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A1A1 -C***TYPE DOUBLE PRECISION (QAGS-S, DQAGS-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, END POINT SINGULARITIES, -C EXTRAPOLATION, GENERAL-PURPOSE, GLOBALLY ADAPTIVE, -C QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Computation of a definite integral -C Standard fortran subroutine -C Double precision version -C -C -C PARAMETERS -C ON ENTRY -C F - Double precision -C Function subprogram defining the integrand -C Function F(X). The actual name for F needs to be -C Declared E X T E R N A L in the driver program. -C -C A - Double precision -C Lower limit of integration -C -C B - Double precision -C Upper limit of integration -C -C EPSABS - Double precision -C Absolute accuracy requested -C EPSREL - Double precision -C Relative accuracy requested -C If EPSABS.LE.0 -C And EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C The routine will end with IER = 6. -C -C ON RETURN -C RESULT - Double precision -C Approximation to the integral -C -C ABSERR - Double precision -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C IER.GT.0 Abnormal termination of the routine -C The estimates for integral and error are -C less reliable. It is assumed that the -C requested accuracy has not been achieved. -C ERROR MESSAGES -C IER = 1 Maximum number of subdivisions allowed -C has been achieved. One can allow more sub- -C divisions by increasing the value of LIMIT -C (and taking the according dimension -C adjustments into account. However, if -C this yields no improvement it is advised -C to analyze the integrand in order to -C determine the integration difficulties. If -C the position of a local difficulty can be -C determined (E.G. SINGULARITY, -C DISCONTINUITY WITHIN THE INTERVAL) one -C will probably gain from splitting up the -C interval at this point and calling the -C integrator on the subranges. If possible, -C an appropriate special-purpose integrator -C should be used, which is designed for -C handling the type of difficulty involved. -C = 2 The occurrence of roundoff error is detec- -C ted, which prevents the requested -C tolerance from being achieved. -C The error may be under-estimated. -C = 3 Extremely bad integrand behaviour -C occurs at some points of the integration -C interval. -C = 4 The algorithm does not converge. -C Roundoff error is detected in the -C Extrapolation table. It is presumed that -C the requested tolerance cannot be -C achieved, and that the returned result is -C the best which can be obtained. -C = 5 The integral is probably divergent, or -C slowly convergent. It must be noted that -C divergence can occur with any other value -C of IER. -C = 6 The input is invalid, because -C (EPSABS.LE.0 AND -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28) -C OR LIMIT.LT.1 OR LENW.LT.LIMIT*4. -C RESULT, ABSERR, NEVAL, LAST are set to -C zero. Except when LIMIT or LENW is -C invalid, IWORK(1), WORK(LIMIT*2+1) and -C WORK(LIMIT*3+1) are set to zero, WORK(1) -C is set to A and WORK(LIMIT+1) TO B. -C -C DIMENSIONING PARAMETERS -C LIMIT - Integer -C DIMENSIONING PARAMETER FOR IWORK -C LIMIT determines the maximum number of subintervals -C in the partition of the given integration interval -C (A,B), LIMIT.GE.1. -C IF LIMIT.LT.1, the routine will end with IER = 6. -C -C LENW - Integer -C DIMENSIONING PARAMETER FOR WORK -C LENW must be at least LIMIT*4. -C If LENW.LT.LIMIT*4, the routine will end -C with IER = 6. -C -C LAST - Integer -C On return, LAST equals the number of subintervals -C produced in the subdivision process, determines the -C number of significant elements actually in the WORK -C Arrays. -C -C WORK ARRAYS -C IWORK - Integer -C Vector of dimension at least LIMIT, the first K -C elements of which contain pointers -C to the error estimates over the subintervals -C such that WORK(LIMIT*3+IWORK(1)),... , -C WORK(LIMIT*3+IWORK(K)) form a decreasing -C sequence, with K = LAST IF LAST.LE.(LIMIT/2+2), -C and K = LIMIT+1-LAST otherwise -C -C WORK - Double precision -C Vector of dimension at least LENW -C on return -C WORK(1), ..., WORK(LAST) contain the left -C end-points of the subintervals in the -C partition of (A,B), -C WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain -C the right end-points, -C WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) contain -C the integral approximations over the subintervals, -C WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) -C contain the error estimates. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED DQAGSE, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800101 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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE DQAGS -C -C - DOUBLE PRECISION A,ABSERR,B,EPSABS,EPSREL,F,RESULT,WORK - INTEGER IER,IWORK,LAST,LENW,LIMIT,LVL,L1,L2,L3,NEVAL -C - DIMENSION IWORK(*),WORK(*) -C - EXTERNAL F -C -C CHECK VALIDITY OF LIMIT AND LENW. -C -C***FIRST EXECUTABLE STATEMENT DQAGS - IER = 6 - NEVAL = 0 - LAST = 0 - RESULT = 0.0D+00 - ABSERR = 0.0D+00 - IF(LIMIT.LT.1.OR.LENW.LT.LIMIT*4) GO TO 10 -C -C PREPARE CALL FOR DQAGSE. -C - L1 = LIMIT+1 - L2 = LIMIT+L1 - L3 = LIMIT+L2 -C - CALL DQAGSE(F,A,B,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,NEVAL, - 1 IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) -C -C CALL ERROR HANDLER IF NECESSARY. -C - LVL = 0 -10 IF(IER.EQ.6) LVL = 1 - IF (IER .NE. 0) CALL XERMSG ('SLATEC', 'DQAGS', - + 'ABNORMAL RETURN', IER, LVL) - RETURN - END diff --git a/slatec/dqagse.f b/slatec/dqagse.f deleted file mode 100644 index bd1244f..0000000 --- a/slatec/dqagse.f +++ /dev/null @@ -1,455 +0,0 @@ -*DECK DQAGSE - SUBROUTINE DQAGSE (F, A, B, EPSABS, EPSREL, LIMIT, RESULT, ABSERR, - + NEVAL, IER, ALIST, BLIST, RLIST, ELIST, IORD, LAST) -C***BEGIN PROLOGUE DQAGSE -C***PURPOSE The routine calculates an approximation result to a given -C definite integral I = Integral of F over (A,B), -C hopefully satisfying following claim for accuracy -C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A1A1 -C***TYPE DOUBLE PRECISION (QAGSE-S, DQAGSE-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, END POINT SINGULARITIES, -C EXTRAPOLATION, GENERAL-PURPOSE, GLOBALLY ADAPTIVE, -C QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Computation of a definite integral -C Standard fortran subroutine -C Double precision version -C -C PARAMETERS -C ON ENTRY -C F - Double precision -C Function subprogram defining the integrand -C function F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C A - Double precision -C Lower limit of integration -C -C B - Double precision -C Upper limit of integration -C -C EPSABS - Double precision -C Absolute accuracy requested -C EPSREL - Double precision -C Relative accuracy requested -C If EPSABS.LE.0 -C and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C the routine will end with IER = 6. -C -C LIMIT - Integer -C Gives an upper bound on the number of subintervals -C in the partition of (A,B) -C -C ON RETURN -C RESULT - Double precision -C Approximation to the integral -C -C ABSERR - Double precision -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C IER.GT.0 Abnormal termination of the routine -C the estimates for integral and error are -C less reliable. It is assumed that the -C requested accuracy has not been achieved. -C ERROR MESSAGES -C = 1 Maximum number of subdivisions allowed -C has been achieved. One can allow more sub- -C divisions by increasing the value of LIMIT -C (and taking the according dimension -C adjustments into account). However, if -C this yields no improvement it is advised -C to analyze the integrand in order to -C determine the integration difficulties. If -C the position of a local difficulty can be -C determined (e.g. singularity, -C discontinuity within the interval) one -C will probably gain from splitting up the -C interval at this point and calling the -C integrator on the subranges. If possible, -C an appropriate special-purpose integrator -C should be used, which is designed for -C handling the type of difficulty involved. -C = 2 The occurrence of roundoff error is detec- -C ted, which prevents the requested -C tolerance from being achieved. -C The error may be under-estimated. -C = 3 Extremely bad integrand behaviour -C occurs at some points of the integration -C interval. -C = 4 The algorithm does not converge. -C Roundoff error is detected in the -C extrapolation table. -C It is presumed that the requested -C tolerance cannot be achieved, and that the -C returned result is the best which can be -C obtained. -C = 5 The integral is probably divergent, or -C slowly convergent. It must be noted that -C divergence can occur with any other value -C of IER. -C = 6 The input is invalid, because -C EPSABS.LE.0 and -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28). -C RESULT, ABSERR, NEVAL, LAST, RLIST(1), -C IORD(1) and ELIST(1) are set to zero. -C ALIST(1) and BLIST(1) are set to A and B -C respectively. -C -C ALIST - Double precision -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the left end points -C of the subintervals in the partition of the -C given integration range (A,B) -C -C BLIST - Double precision -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the right end points -C of the subintervals in the partition of the given -C integration range (A,B) -C -C RLIST - Double precision -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the integral -C approximations on the subintervals -C -C ELIST - Double precision -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the moduli of the -C absolute error estimates on the subintervals -C -C IORD - Integer -C Vector of dimension at least LIMIT, the first K -C elements of which are pointers to the -C error estimates over the subintervals, -C such that ELIST(IORD(1)), ..., ELIST(IORD(K)) -C form a decreasing sequence, with K = LAST -C If LAST.LE.(LIMIT/2+2), and K = LIMIT+1-LAST -C otherwise -C -C LAST - Integer -C Number of subintervals actually produced in the -C subdivision process -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DQELG, DQK21, DQPSRT -C***REVISION HISTORY (YYMMDD) -C 800101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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***END PROLOGUE DQAGSE -C - DOUBLE PRECISION A,ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1, - 1 A2,B,BLIST,B1,B2,CORREC,DEFABS,DEFAB1,DEFAB2,D1MACH, - 2 DRES,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND,ERRMAX, - 3 ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,F,OFLOW,RESABS,RESEPS,RESULT, - 4 RES3LA,RLIST,RLIST2,SMALL,UFLOW - INTEGER ID,IER,IERRO,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K,KSGN, - 1 KTMIN,LAST,LIMIT,MAXERR,NEVAL,NRES,NRMAX,NUMRL2 - LOGICAL EXTRAP,NOEXT -C - DIMENSION ALIST(*),BLIST(*),ELIST(*),IORD(*), - 1 RES3LA(3),RLIST(*),RLIST2(52) -C - EXTERNAL F -C -C THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF -C LIMEXP IN SUBROUTINE DQELG (RLIST2 SHOULD BE OF DIMENSION -C (LIMEXP+2) AT LEAST). -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER -C (ALIST(I),BLIST(I)) -C RLIST2 - ARRAY OF DIMENSION AT LEAST LIMEXP+2 CONTAINING -C THE PART OF THE EPSILON TABLE WHICH IS STILL -C NEEDED FOR FURTHER COMPUTATIONS -C ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) -C MAXERR - POINTER TO THE INTERVAL WITH LARGEST ERROR -C ESTIMATE -C ERRMAX - ELIST(MAXERR) -C ERLAST - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED -C (BEFORE THAT SUBDIVISION HAS TAKEN PLACE) -C AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS -C ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS -C ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* -C ABS(RESULT)) -C *****1 - VARIABLE FOR THE LEFT INTERVAL -C *****2 - VARIABLE FOR THE RIGHT INTERVAL -C LAST - INDEX FOR SUBDIVISION -C NRES - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE -C NUMRL2 - NUMBER OF ELEMENTS CURRENTLY IN RLIST2. IF AN -C APPROPRIATE APPROXIMATION TO THE COMPOUNDED -C INTEGRAL HAS BEEN OBTAINED IT IS PUT IN -C RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED -C BY ONE. -C SMALL - LENGTH OF THE SMALLEST INTERVAL CONSIDERED UP -C TO NOW, MULTIPLIED BY 1.5 -C ERLARG - SUM OF THE ERRORS OVER THE INTERVALS LARGER -C THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW -C EXTRAP - LOGICAL VARIABLE DENOTING THAT THE ROUTINE IS -C ATTEMPTING TO PERFORM EXTRAPOLATION I.E. BEFORE -C SUBDIVIDING THE SMALLEST INTERVAL WE TRY TO -C DECREASE THE VALUE OF ERLARG. -C NOEXT - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION -C IS NO LONGER ALLOWED (TRUE VALUE) -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C OFLOW IS THE LARGEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT DQAGSE - EPMACH = D1MACH(4) -C -C TEST ON VALIDITY OF PARAMETERS -C ------------------------------ - IER = 0 - NEVAL = 0 - LAST = 0 - RESULT = 0.0D+00 - ABSERR = 0.0D+00 - ALIST(1) = A - BLIST(1) = B - RLIST(1) = 0.0D+00 - ELIST(1) = 0.0D+00 - IF(EPSABS.LE.0.0D+00.AND.EPSREL.LT.MAX(0.5D+02*EPMACH,0.5D-28)) - 1 IER = 6 - IF(IER.EQ.6) GO TO 999 -C -C FIRST APPROXIMATION TO THE INTEGRAL -C ----------------------------------- -C - UFLOW = D1MACH(1) - OFLOW = D1MACH(2) - IERRO = 0 - CALL DQK21(F,A,B,RESULT,ABSERR,DEFABS,RESABS) -C -C TEST ON ACCURACY. -C - DRES = ABS(RESULT) - ERRBND = MAX(EPSABS,EPSREL*DRES) - LAST = 1 - RLIST(1) = RESULT - ELIST(1) = ABSERR - IORD(1) = 1 - IF(ABSERR.LE.1.0D+02*EPMACH*DEFABS.AND.ABSERR.GT.ERRBND) IER = 2 - IF(LIMIT.EQ.1) IER = 1 - IF(IER.NE.0.OR.(ABSERR.LE.ERRBND.AND.ABSERR.NE.RESABS).OR. - 1 ABSERR.EQ.0.0D+00) GO TO 140 -C -C INITIALIZATION -C -------------- -C - RLIST2(1) = RESULT - ERRMAX = ABSERR - MAXERR = 1 - AREA = RESULT - ERRSUM = ABSERR - ABSERR = OFLOW - NRMAX = 1 - NRES = 0 - NUMRL2 = 2 - KTMIN = 0 - EXTRAP = .FALSE. - NOEXT = .FALSE. - IROFF1 = 0 - IROFF2 = 0 - IROFF3 = 0 - KSGN = -1 - IF(DRES.GE.(0.1D+01-0.5D+02*EPMACH)*DEFABS) KSGN = 1 -C -C MAIN DO-LOOP -C ------------ -C - DO 90 LAST = 2,LIMIT -C -C BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST ERROR -C ESTIMATE. -C - A1 = ALIST(MAXERR) - B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR)) - A2 = B1 - B2 = BLIST(MAXERR) - ERLAST = ERRMAX - CALL DQK21(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) - CALL DQK21(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) -C -C IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL -C AND ERROR AND TEST FOR ACCURACY. -C - AREA12 = AREA1+AREA2 - ERRO12 = ERROR1+ERROR2 - ERRSUM = ERRSUM+ERRO12-ERRMAX - AREA = AREA+AREA12-RLIST(MAXERR) - IF(DEFAB1.EQ.ERROR1.OR.DEFAB2.EQ.ERROR2) GO TO 15 - IF(ABS(RLIST(MAXERR)-AREA12).GT.0.1D-04*ABS(AREA12) - 1 .OR.ERRO12.LT.0.99D+00*ERRMAX) GO TO 10 - IF(EXTRAP) IROFF2 = IROFF2+1 - IF(.NOT.EXTRAP) IROFF1 = IROFF1+1 - 10 IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF3 = IROFF3+1 - 15 RLIST(MAXERR) = AREA1 - RLIST(LAST) = AREA2 - ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) -C -C TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG. -C - IF(IROFF1+IROFF2.GE.10.OR.IROFF3.GE.20) IER = 2 - IF(IROFF2.GE.5) IERRO = 3 -C -C SET ERROR FLAG IN THE CASE THAT THE NUMBER OF SUBINTERVALS -C EQUALS LIMIT. -C - IF(LAST.EQ.LIMIT) IER = 1 -C -C SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR -C AT A POINT OF THE INTEGRATION RANGE. -C - IF(MAX(ABS(A1),ABS(B2)).LE.(0.1D+01+0.1D+03*EPMACH)* - 1 (ABS(A2)+0.1D+04*UFLOW)) IER = 4 -C -C APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. -C - IF(ERROR2.GT.ERROR1) GO TO 20 - ALIST(LAST) = A2 - BLIST(MAXERR) = B1 - BLIST(LAST) = B2 - ELIST(MAXERR) = ERROR1 - ELIST(LAST) = ERROR2 - GO TO 30 - 20 ALIST(MAXERR) = A2 - ALIST(LAST) = A1 - BLIST(LAST) = B1 - RLIST(MAXERR) = AREA2 - RLIST(LAST) = AREA1 - ELIST(MAXERR) = ERROR2 - ELIST(LAST) = ERROR1 -C -C CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING -C IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL -C WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT). -C - 30 CALL DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) -C ***JUMP OUT OF DO-LOOP - IF(ERRSUM.LE.ERRBND) GO TO 115 -C ***JUMP OUT OF DO-LOOP - IF(IER.NE.0) GO TO 100 - IF(LAST.EQ.2) GO TO 80 - IF(NOEXT) GO TO 90 - ERLARG = ERLARG-ERLAST - IF(ABS(B1-A1).GT.SMALL) ERLARG = ERLARG+ERRO12 - IF(EXTRAP) GO TO 40 -C -C TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE -C SMALLEST INTERVAL. -C - IF(ABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90 - EXTRAP = .TRUE. - NRMAX = 2 - 40 IF(IERRO.EQ.3.OR.ERLARG.LE.ERTEST) GO TO 60 -C -C THE SMALLEST INTERVAL HAS THE LARGEST ERROR. -C BEFORE BISECTING DECREASE THE SUM OF THE ERRORS OVER THE -C LARGER INTERVALS (ERLARG) AND PERFORM EXTRAPOLATION. -C - ID = NRMAX - JUPBND = LAST - IF(LAST.GT.(2+LIMIT/2)) JUPBND = LIMIT+3-LAST - DO 50 K = ID,JUPBND - MAXERR = IORD(NRMAX) - ERRMAX = ELIST(MAXERR) -C ***JUMP OUT OF DO-LOOP - IF(ABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90 - NRMAX = NRMAX+1 - 50 CONTINUE -C -C PERFORM EXTRAPOLATION. -C - 60 NUMRL2 = NUMRL2+1 - RLIST2(NUMRL2) = AREA - CALL DQELG(NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES) - KTMIN = KTMIN+1 - IF(KTMIN.GT.5.AND.ABSERR.LT.0.1D-02*ERRSUM) IER = 5 - IF(ABSEPS.GE.ABSERR) GO TO 70 - KTMIN = 0 - ABSERR = ABSEPS - RESULT = RESEPS - CORREC = ERLARG - ERTEST = MAX(EPSABS,EPSREL*ABS(RESEPS)) -C ***JUMP OUT OF DO-LOOP - IF(ABSERR.LE.ERTEST) GO TO 100 -C -C PREPARE BISECTION OF THE SMALLEST INTERVAL. -C - 70 IF(NUMRL2.EQ.1) NOEXT = .TRUE. - IF(IER.EQ.5) GO TO 100 - MAXERR = IORD(1) - ERRMAX = ELIST(MAXERR) - NRMAX = 1 - EXTRAP = .FALSE. - SMALL = SMALL*0.5D+00 - ERLARG = ERRSUM - GO TO 90 - 80 SMALL = ABS(B-A)*0.375D+00 - ERLARG = ERRSUM - ERTEST = ERRBND - RLIST2(2) = AREA - 90 CONTINUE -C -C SET FINAL RESULT AND ERROR ESTIMATE. -C ------------------------------------ -C - 100 IF(ABSERR.EQ.OFLOW) GO TO 115 - IF(IER+IERRO.EQ.0) GO TO 110 - IF(IERRO.EQ.3) ABSERR = ABSERR+CORREC - IF(IER.EQ.0) IER = 3 - IF(RESULT.NE.0.0D+00.AND.AREA.NE.0.0D+00) GO TO 105 - IF(ABSERR.GT.ERRSUM) GO TO 115 - IF(AREA.EQ.0.0D+00) GO TO 130 - GO TO 110 - 105 IF(ABSERR/ABS(RESULT).GT.ERRSUM/ABS(AREA)) GO TO 115 -C -C TEST ON DIVERGENCE. -C - 110 IF(KSGN.EQ.(-1).AND.MAX(ABS(RESULT),ABS(AREA)).LE. - 1 DEFABS*0.1D-01) GO TO 130 - IF(0.1D-01.GT.(RESULT/AREA).OR.(RESULT/AREA).GT.0.1D+03 - 1 .OR.ERRSUM.GT.ABS(AREA)) IER = 6 - GO TO 130 -C -C COMPUTE GLOBAL INTEGRAL SUM. -C - 115 RESULT = 0.0D+00 - DO 120 K = 1,LAST - RESULT = RESULT+RLIST(K) - 120 CONTINUE - ABSERR = ERRSUM - 130 IF(IER.GT.2) IER = IER-1 - 140 NEVAL = 42*LAST-21 - 999 RETURN - END diff --git a/slatec/dqawc.f b/slatec/dqawc.f deleted file mode 100644 index 3b970fb..0000000 --- a/slatec/dqawc.f +++ /dev/null @@ -1,190 +0,0 @@ -*DECK DQAWC - SUBROUTINE DQAWC (F, A, B, C, EPSABS, EPSREL, RESULT, ABSERR, - + NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK) -C***BEGIN PROLOGUE DQAWC -C***PURPOSE The routine calculates an approximation result to a -C Cauchy principal value I = INTEGRAL of F*W over (A,B) -C (W(X) = 1/((X-C), C.NE.A, C.NE.B), hopefully satisfying -C following claim for accuracy -C ABS(I-RESULT).LE.MAX(EPSABE,EPSREL*ABS(I)). -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A2A1, J4 -C***TYPE DOUBLE PRECISION (QAWC-S, DQAWC-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, CAUCHY PRINCIPAL VALUE, -C CLENSHAW-CURTIS METHOD, GLOBALLY ADAPTIVE, QUADPACK, -C QUADRATURE, SPECIAL-PURPOSE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Computation of a Cauchy principal value -C Standard fortran subroutine -C Double precision version -C -C -C PARAMETERS -C ON ENTRY -C F - Double precision -C Function subprogram defining the integrand -C Function F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C A - Double precision -C Under limit of integration -C -C B - Double precision -C Upper limit of integration -C -C C - Parameter in the weight function, C.NE.A, C.NE.B. -C If C = A or C = B, the routine will end with -C IER = 6 . -C -C EPSABS - Double precision -C Absolute accuracy requested -C EPSREL - Double precision -C Relative accuracy requested -C If EPSABS.LE.0 -C and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C the routine will end with IER = 6. -C -C ON RETURN -C RESULT - Double precision -C Approximation to the integral -C -C ABSERR - Double precision -C Estimate or the modulus of the absolute error, -C Which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C IER.GT.0 Abnormal termination of the routine -C the estimates for integral and error are -C less reliable. It is assumed that the -C requested accuracy has not been achieved. -C ERROR MESSAGES -C IER = 1 Maximum number of subdivisions allowed -C has been achieved. One can allow more sub- -C divisions by increasing the value of LIMIT -C (and taking the according dimension -C adjustments into account). However, if -C this yields no improvement it is advised -C to analyze the integrand in order to -C determine the integration difficulties. -C If the position of a local difficulty -C can be determined (e.g. SINGULARITY, -C DISCONTINUITY within the interval) one -C will probably gain from splitting up the -C interval at this point and calling -C appropriate integrators on the subranges. -C = 2 The occurrence of roundoff error is detec- -C ted, which prevents the requested -C tolerance from being achieved. -C = 3 Extremely bad integrand behaviour occurs -C at some points of the integration -C interval. -C = 6 The input is invalid, because -C C = A or C = B or -C (EPSABS.LE.0 and -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)) -C or LIMIT.LT.1 or LENW.LT.LIMIT*4. -C RESULT, ABSERR, NEVAL, LAST are set to -C zero. Except when LENW or LIMIT is -C invalid, IWORK(1), WORK(LIMIT*2+1) and -C WORK(LIMIT*3+1) are set to zero, WORK(1) -C is set to A and WORK(LIMIT+1) to B. -C -C DIMENSIONING PARAMETERS -C LIMIT - Integer -C Dimensioning parameter for IWORK -C LIMIT determines the maximum number of subintervals -C in the partition of the given integration interval -C (A,B), LIMIT.GE.1. -C If LIMIT.LT.1, the routine will end with IER = 6. -C -C LENW - Integer -C Dimensioning parameter for WORK -C LENW must be at least LIMIT*4. -C If LENW.LT.LIMIT*4, the routine will end with -C IER = 6. -C -C LAST - Integer -C On return, LAST equals the number of subintervals -C produced in the subdivision process, which -C determines the number of significant elements -C actually in the WORK ARRAYS. -C -C WORK ARRAYS -C IWORK - Integer -C Vector of dimension at least LIMIT, the first K -C elements of which contain pointers -C to the error estimates over the subintervals, -C such that WORK(LIMIT*3+IWORK(1)), ... , -C WORK(LIMIT*3+IWORK(K)) form a decreasing -C sequence, with K = LAST if LAST.LE.(LIMIT/2+2), -C and K = LIMIT+1-LAST otherwise -C -C WORK - Double precision -C Vector of dimension at least LENW -C On return -C WORK(1), ..., WORK(LAST) contain the left -C end points of the subintervals in the -C partition of (A,B), -C WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain -C the right end points, -C WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) contain -C the integral approximations over the subintervals, -C WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) -C contain the error estimates. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED DQAWCE, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800101 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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE DQAWC -C - DOUBLE PRECISION A,ABSERR,B,C,EPSABS,EPSREL,F,RESULT,WORK - INTEGER IER,IWORK,LAST,LENW,LIMIT,LVL,L1,L2,L3,NEVAL -C - DIMENSION IWORK(*),WORK(*) -C - EXTERNAL F -C -C CHECK VALIDITY OF LIMIT AND LENW. -C -C***FIRST EXECUTABLE STATEMENT DQAWC - IER = 6 - NEVAL = 0 - LAST = 0 - RESULT = 0.0D+00 - ABSERR = 0.0D+00 - IF(LIMIT.LT.1.OR.LENW.LT.LIMIT*4) GO TO 10 -C -C PREPARE CALL FOR DQAWCE. -C - L1 = LIMIT+1 - L2 = LIMIT+L1 - L3 = LIMIT+L2 - CALL DQAWCE(F,A,B,C,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,NEVAL,IER, - 1 WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) -C -C CALL ERROR HANDLER IF NECESSARY. -C - LVL = 0 -10 IF(IER.EQ.6) LVL = 1 - IF (IER .NE. 0) CALL XERMSG ('SLATEC', 'DQAWC', - + 'ABNORMAL RETURN', IER, LVL) - RETURN - END diff --git a/slatec/dqawce.f b/slatec/dqawce.f deleted file mode 100644 index 20a8e13..0000000 --- a/slatec/dqawce.f +++ /dev/null @@ -1,338 +0,0 @@ -*DECK DQAWCE - SUBROUTINE DQAWCE (F, A, B, C, EPSABS, EPSREL, LIMIT, RESULT, - + ABSERR, NEVAL, IER, ALIST, BLIST, RLIST, ELIST, IORD, LAST) -C***BEGIN PROLOGUE DQAWCE -C***PURPOSE The routine calculates an approximation result to a -C CAUCHY PRINCIPAL VALUE I = Integral of F*W over (A,B) -C (W(X) = 1/(X-C), (C.NE.A, C.NE.B), hopefully satisfying -C following claim for accuracy -C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)) -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A2A1, J4 -C***TYPE DOUBLE PRECISION (QAWCE-S, DQAWCE-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, CAUCHY PRINCIPAL VALUE, -C CLENSHAW-CURTIS METHOD, QUADPACK, QUADRATURE, -C SPECIAL-PURPOSE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Computation of a CAUCHY PRINCIPAL VALUE -C Standard fortran subroutine -C Double precision version -C -C PARAMETERS -C ON ENTRY -C F - Double precision -C Function subprogram defining the integrand -C function F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C A - Double precision -C Lower limit of integration -C -C B - Double precision -C Upper limit of integration -C -C C - Double precision -C Parameter in the WEIGHT function, C.NE.A, C.NE.B -C If C = A OR C = B, the routine will end with -C IER = 6. -C -C EPSABS - Double precision -C Absolute accuracy requested -C EPSREL - Double precision -C Relative accuracy requested -C If EPSABS.LE.0 -C and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C the routine will end with IER = 6. -C -C LIMIT - Integer -C Gives an upper bound on the number of subintervals -C in the partition of (A,B), LIMIT.GE.1 -C -C ON RETURN -C RESULT - Double precision -C Approximation to the integral -C -C ABSERR - Double precision -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C IER.GT.0 Abnormal termination of the routine -C the estimates for integral and error are -C less reliable. It is assumed that the -C requested accuracy has not been achieved. -C ERROR MESSAGES -C IER = 1 Maximum number of subdivisions allowed -C has been achieved. One can allow more sub- -C divisions by increasing the value of -C LIMIT. However, if this yields no -C improvement it is advised to analyze the -C the integrand, in order to determine the -C the integration difficulties. If the -C position of a local difficulty can be -C determined (e.g. SINGULARITY, -C DISCONTINUITY within the interval) one -C will probably gain from splitting up the -C interval at this point and calling -C appropriate integrators on the subranges. -C = 2 The occurrence of roundoff error is detec- -C ted, which prevents the requested -C tolerance from being achieved. -C = 3 Extremely bad integrand behaviour -C occurs at some interior points of -C the integration interval. -C = 6 The input is invalid, because -C C = A or C = B or -C (EPSABS.LE.0 and -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)) -C or LIMIT.LT.1. -C RESULT, ABSERR, NEVAL, RLIST(1), ELIST(1), -C IORD(1) and LAST are set to zero. ALIST(1) -C and BLIST(1) are set to A and B -C respectively. -C -C ALIST - Double precision -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the left -C end points of the subintervals in the partition -C of the given integration range (A,B) -C -C BLIST - Double precision -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the right -C end points of the subintervals in the partition -C of the given integration range (A,B) -C -C RLIST - Double precision -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the integral -C approximations on the subintervals -C -C ELIST - Double precision -C Vector of dimension LIMIT, the first LAST -C elements of which are the moduli of the absolute -C error estimates on the subintervals -C -C IORD - Integer -C Vector of dimension at least LIMIT, the first K -C elements of which are pointers to the error -C estimates over the subintervals, so that -C ELIST(IORD(1)), ..., ELIST(IORD(K)) with K = LAST -C If LAST.LE.(LIMIT/2+2), and K = LIMIT+1-LAST -C otherwise, form a decreasing sequence -C -C LAST - Integer -C Number of subintervals actually produced in -C the subdivision process -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DQC25C, DQPSRT -C***REVISION HISTORY (YYMMDD) -C 800101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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***END PROLOGUE DQAWCE -C - DOUBLE PRECISION A,AA,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1,A2, - 1 B,BB,BLIST,B1,B2,C,D1MACH,ELIST,EPMACH,EPSABS,EPSREL, - 2 ERRBND,ERRMAX,ERROR1,ERRO12,ERROR2,ERRSUM,F,RESULT,RLIST,UFLOW - INTEGER IER,IORD,IROFF1,IROFF2,K,KRULE,LAST,LIMIT,MAXERR,NEV, - 1 NEVAL,NRMAX -C - DIMENSION ALIST(*),BLIST(*),RLIST(*),ELIST(*), - 1 IORD(*) -C - EXTERNAL F -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER -C (ALIST(I),BLIST(I)) -C ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) -C MAXERR - POINTER TO THE INTERVAL WITH LARGEST -C ERROR ESTIMATE -C ERRMAX - ELIST(MAXERR) -C AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS -C ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS -C ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* -C ABS(RESULT)) -C *****1 - VARIABLE FOR THE LEFT SUBINTERVAL -C *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL -C LAST - INDEX FOR SUBDIVISION -C -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT DQAWCE - EPMACH = D1MACH(4) - UFLOW = D1MACH(1) -C -C -C TEST ON VALIDITY OF PARAMETERS -C ------------------------------ -C - IER = 6 - NEVAL = 0 - LAST = 0 - ALIST(1) = A - BLIST(1) = B - RLIST(1) = 0.0D+00 - ELIST(1) = 0.0D+00 - IORD(1) = 0 - RESULT = 0.0D+00 - ABSERR = 0.0D+00 - IF (C.EQ.A.OR.C.EQ.B.OR.(EPSABS.LE.0.0D+00.AND. - 1 EPSREL.LT.MAX(0.5D+02*EPMACH,0.5D-28))) GO TO 999 -C -C FIRST APPROXIMATION TO THE INTEGRAL -C ----------------------------------- -C - AA=A - BB=B - IF (A.LE.B) GO TO 10 - AA=B - BB=A -10 IER=0 - KRULE = 1 - CALL DQC25C(F,AA,BB,C,RESULT,ABSERR,KRULE,NEVAL) - LAST = 1 - RLIST(1) = RESULT - ELIST(1) = ABSERR - IORD(1) = 1 - ALIST(1) = A - BLIST(1) = B -C -C TEST ON ACCURACY -C - ERRBND = MAX(EPSABS,EPSREL*ABS(RESULT)) - IF(LIMIT.EQ.1) IER = 1 - IF(ABSERR.LT.MIN(0.1D-01*ABS(RESULT),ERRBND) - 1 .OR.IER.EQ.1) GO TO 70 -C -C INITIALIZATION -C -------------- -C - ALIST(1) = AA - BLIST(1) = BB - RLIST(1) = RESULT - ERRMAX = ABSERR - MAXERR = 1 - AREA = RESULT - ERRSUM = ABSERR - NRMAX = 1 - IROFF1 = 0 - IROFF2 = 0 -C -C MAIN DO-LOOP -C ------------ -C - DO 40 LAST = 2,LIMIT -C -C BISECT THE SUBINTERVAL WITH NRMAX-TH LARGEST -C ERROR ESTIMATE. -C - A1 = ALIST(MAXERR) - B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR)) - B2 = BLIST(MAXERR) - IF(C.LE.B1.AND.C.GT.A1) B1 = 0.5D+00*(C+B2) - IF(C.GT.B1.AND.C.LT.B2) B1 = 0.5D+00*(A1+C) - A2 = B1 - KRULE = 2 - CALL DQC25C(F,A1,B1,C,AREA1,ERROR1,KRULE,NEV) - NEVAL = NEVAL+NEV - CALL DQC25C(F,A2,B2,C,AREA2,ERROR2,KRULE,NEV) - NEVAL = NEVAL+NEV -C -C IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL -C AND ERROR AND TEST FOR ACCURACY. -C - AREA12 = AREA1+AREA2 - ERRO12 = ERROR1+ERROR2 - ERRSUM = ERRSUM+ERRO12-ERRMAX - AREA = AREA+AREA12-RLIST(MAXERR) - IF(ABS(RLIST(MAXERR)-AREA12).LT.0.1D-04*ABS(AREA12) - 1 .AND.ERRO12.GE.0.99D+00*ERRMAX.AND.KRULE.EQ.0) - 2 IROFF1 = IROFF1+1 - IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX.AND.KRULE.EQ.0) - 1 IROFF2 = IROFF2+1 - RLIST(MAXERR) = AREA1 - RLIST(LAST) = AREA2 - ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) - IF(ERRSUM.LE.ERRBND) GO TO 15 -C -C TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG. -C - IF(IROFF1.GE.6.AND.IROFF2.GT.20) IER = 2 -C -C SET ERROR FLAG IN THE CASE THAT NUMBER OF INTERVAL -C BISECTIONS EXCEEDS LIMIT. -C - IF(LAST.EQ.LIMIT) IER = 1 -C -C SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR -C AT A POINT OF THE INTEGRATION RANGE. -C - IF(MAX(ABS(A1),ABS(B2)).LE.(0.1D+01+0.1D+03*EPMACH) - 1 *(ABS(A2)+0.1D+04*UFLOW)) IER = 3 -C -C APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. -C - 15 IF(ERROR2.GT.ERROR1) GO TO 20 - ALIST(LAST) = A2 - BLIST(MAXERR) = B1 - BLIST(LAST) = B2 - ELIST(MAXERR) = ERROR1 - ELIST(LAST) = ERROR2 - GO TO 30 - 20 ALIST(MAXERR) = A2 - ALIST(LAST) = A1 - BLIST(LAST) = B1 - RLIST(MAXERR) = AREA2 - RLIST(LAST) = AREA1 - ELIST(MAXERR) = ERROR2 - ELIST(LAST) = ERROR1 -C -C CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING -C IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL -C WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT). -C - 30 CALL DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) -C ***JUMP OUT OF DO-LOOP - IF(IER.NE.0.OR.ERRSUM.LE.ERRBND) GO TO 50 - 40 CONTINUE -C -C COMPUTE FINAL RESULT. -C --------------------- -C - 50 RESULT = 0.0D+00 - DO 60 K=1,LAST - RESULT = RESULT+RLIST(K) - 60 CONTINUE - ABSERR = ERRSUM - 70 IF (AA.EQ.B) RESULT=-RESULT - 999 RETURN - END diff --git a/slatec/dqawf.f b/slatec/dqawf.f deleted file mode 100644 index 631ba77..0000000 --- a/slatec/dqawf.f +++ /dev/null @@ -1,243 +0,0 @@ -*DECK DQAWF - SUBROUTINE DQAWF (F, A, OMEGA, INTEGR, EPSABS, RESULT, ABSERR, - + NEVAL, IER, LIMLST, LST, LENIW, MAXP1, LENW, IWORK, WORK) -C***BEGIN PROLOGUE DQAWF -C***PURPOSE The routine calculates an approximation result to a given -C Fourier integral I=Integral of F(X)*W(X) over (A,INFINITY) -C where W(X) = COS(OMEGA*X) or W(X) = SIN(OMEGA*X). -C Hopefully satisfying following claim for accuracy -C ABS(I-RESULT).LE.EPSABS. -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A3A1 -C***TYPE DOUBLE PRECISION (QAWF-S, DQAWF-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, CONVERGENCE ACCELERATION, -C FOURIER INTEGRALS, INTEGRATION BETWEEN ZEROS, QUADPACK, -C QUADRATURE, SPECIAL-PURPOSE INTEGRAL -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Computation of Fourier integrals -C Standard fortran subroutine -C Double precision version -C -C -C PARAMETERS -C ON ENTRY -C F - Double precision -C Function subprogram defining the integrand -C function F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C A - Double precision -C Lower limit of integration -C -C OMEGA - Double precision -C Parameter in the integrand WEIGHT function -C -C INTEGR - Integer -C Indicates which of the WEIGHT functions is used -C INTEGR = 1 W(X) = COS(OMEGA*X) -C INTEGR = 2 W(X) = SIN(OMEGA*X) -C IF INTEGR.NE.1.AND.INTEGR.NE.2, the routine -C will end with IER = 6. -C -C EPSABS - Double precision -C Absolute accuracy requested, EPSABS.GT.0. -C If EPSABS.LE.0, the routine will end with IER = 6. -C -C ON RETURN -C RESULT - Double precision -C Approximation to the integral -C -C ABSERR - Double precision -C Estimate of the modulus of the absolute error, -C Which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C IER.GT.0 Abnormal termination of the routine. -C The estimates for integral and error are -C less reliable. It is assumed that the -C requested accuracy has not been achieved. -C ERROR MESSAGES -C If OMEGA.NE.0 -C IER = 1 Maximum number of cycles allowed -C has been achieved, i.e. of subintervals -C (A+(K-1)C,A+KC) where -C C = (2*INT(ABS(OMEGA))+1)*PI/ABS(OMEGA), -C FOR K = 1, 2, ..., LST. -C One can allow more cycles by increasing -C the value of LIMLST (and taking the -C according dimension adjustments into -C account). Examine the array IWORK which -C contains the error flags on the cycles, in -C order to look for eventual local -C integration difficulties. -C If the position of a local difficulty -C can be determined (e.g. singularity, -C discontinuity within the interval) one -C will probably gain from splitting up the -C interval at this point and calling -C appropriate integrators on the subranges. -C = 4 The extrapolation table constructed for -C convergence acceleration of the series -C formed by the integral contributions over -C the cycles, does not converge to within -C the requested accuracy. -C As in the case of IER = 1, it is advised -C to examine the array IWORK which contains -C the error flags on the cycles. -C = 6 The input is invalid because -C (INTEGR.NE.1 AND INTEGR.NE.2) or -C EPSABS.LE.0 or LIMLST.LT.1 or -C LENIW.LT.(LIMLST+2) or MAXP1.LT.1 or -C LENW.LT.(LENIW*2+MAXP1*25). -C RESULT, ABSERR, NEVAL, LST are set to -C zero. -C = 7 Bad integrand behaviour occurs within -C one or more of the cycles. Location and -C type of the difficulty involved can be -C determined from the first LST elements of -C vector IWORK. Here LST is the number of -C cycles actually needed (see below). -C IWORK(K) = 1 The maximum number of -C subdivisions (=(LENIW-LIMLST) -C /2) has been achieved on the -C K th cycle. -C = 2 Occurrence of roundoff error -C is detected and prevents the -C tolerance imposed on the K th -C cycle, from being achieved -C on this cycle. -C = 3 Extremely bad integrand -C behaviour occurs at some -C points of the K th cycle. -C = 4 The integration procedure -C over the K th cycle does -C not converge (to within the -C required accuracy) due to -C roundoff in the extrapolation -C procedure invoked on this -C cycle. It is assumed that the -C result on this interval is -C the best which can be -C obtained. -C = 5 The integral over the K th -C cycle is probably divergent -C or slowly convergent. It must -C be noted that divergence can -C occur with any other value of -C IWORK(K). -C If OMEGA = 0 and INTEGR = 1, -C The integral is calculated by means of DQAGIE, -C and IER = IWORK(1) (with meaning as described -C for IWORK(K),K = 1). -C -C DIMENSIONING PARAMETERS -C LIMLST - Integer -C LIMLST gives an upper bound on the number of -C cycles, LIMLST.GE.3. -C If LIMLST.LT.3, the routine will end with IER = 6. -C -C LST - Integer -C On return, LST indicates the number of cycles -C actually needed for the integration. -C If OMEGA = 0, then LST is set to 1. -C -C LENIW - Integer -C Dimensioning parameter for IWORK. On entry, -C (LENIW-LIMLST)/2 equals the maximum number of -C subintervals allowed in the partition of each -C cycle, LENIW.GE.(LIMLST+2). -C If LENIW.LT.(LIMLST+2), the routine will end with -C IER = 6. -C -C MAXP1 - Integer -C MAXP1 gives an upper bound on the number of -C Chebyshev moments which can be stored, i.e. for -C the intervals of lengths ABS(B-A)*2**(-L), -C L = 0,1, ..., MAXP1-2, MAXP1.GE.1. -C If MAXP1.LT.1, the routine will end with IER = 6. -C LENW - Integer -C Dimensioning parameter for WORK -C LENW must be at least LENIW*2+MAXP1*25. -C If LENW.LT.(LENIW*2+MAXP1*25), the routine will -C end with IER = 6. -C -C WORK ARRAYS -C IWORK - Integer -C Vector of dimension at least LENIW -C On return, IWORK(K) FOR K = 1, 2, ..., LST -C contain the error flags on the cycles. -C -C WORK - Double precision -C Vector of dimension at least -C On return, -C WORK(1), ..., WORK(LST) contain the integral -C approximations over the cycles, -C WORK(LIMLST+1), ..., WORK(LIMLST+LST) contain -C the error estimates over the cycles. -C further elements of WORK have no specific -C meaning for the user. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED DQAWFE, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800101 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891009 Removed unreferenced variable. (WRB) -C 891009 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***END PROLOGUE DQAWF -C - DOUBLE PRECISION A,ABSERR,EPSABS,F,OMEGA,RESULT,WORK - INTEGER IER,INTEGR,IWORK,LENIW,LENW,LIMIT,LIMLST,LL2,LVL, - 1 LST,L1,L2,L3,L4,L5,L6,MAXP1,NEVAL -C - DIMENSION IWORK(*),WORK(*) -C - EXTERNAL F -C -C CHECK VALIDITY OF LIMLST, LENIW, MAXP1 AND LENW. -C -C***FIRST EXECUTABLE STATEMENT DQAWF - IER = 6 - NEVAL = 0 - RESULT = 0.0D+00 - ABSERR = 0.0D+00 - IF(LIMLST.LT.3.OR.LENIW.LT.(LIMLST+2).OR.MAXP1.LT.1.OR.LENW.LT. - 1 (LENIW*2+MAXP1*25)) GO TO 10 -C -C PREPARE CALL FOR DQAWFE -C - LIMIT = (LENIW-LIMLST)/2 - L1 = LIMLST+1 - L2 = LIMLST+L1 - L3 = LIMIT+L2 - L4 = LIMIT+L3 - L5 = LIMIT+L4 - L6 = LIMIT+L5 - LL2 = LIMIT+L1 - CALL DQAWFE(F,A,OMEGA,INTEGR,EPSABS,LIMLST,LIMIT,MAXP1,RESULT, - 1 ABSERR,NEVAL,IER,WORK(1),WORK(L1),IWORK(1),LST,WORK(L2), - 2 WORK(L3),WORK(L4),WORK(L5),IWORK(L1),IWORK(LL2),WORK(L6)) -C -C CALL ERROR HANDLER IF NECESSARY -C - LVL = 0 -10 IF(IER.EQ.6) LVL = 1 - IF (IER .NE. 0) CALL XERMSG ('SLATEC', 'DQAWF', - + 'ABNORMAL RETURN', IER, LVL) - RETURN - END diff --git a/slatec/dqawfe.f b/slatec/dqawfe.f deleted file mode 100644 index 110d6be..0000000 --- a/slatec/dqawfe.f +++ /dev/null @@ -1,374 +0,0 @@ -*DECK DQAWFE - SUBROUTINE DQAWFE (F, A, OMEGA, INTEGR, EPSABS, LIMLST, LIMIT, - + MAXP1, RESULT, ABSERR, NEVAL, IER, RSLST, ERLST, IERLST, LST, - + ALIST, BLIST, RLIST, ELIST, IORD, NNLOG, CHEBMO) -C***BEGIN PROLOGUE DQAWFE -C***PURPOSE The routine calculates an approximation result to a -C given Fourier integral -C I = Integral of F(X)*W(X) over (A,INFINITY) -C where W(X)=COS(OMEGA*X) or W(X)=SIN(OMEGA*X), -C hopefully satisfying following claim for accuracy -C ABS(I-RESULT).LE.EPSABS. -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A3A1 -C***TYPE DOUBLE PRECISION (QAWFE-S, DQAWFE-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, CONVERGENCE ACCELERATION, -C FOURIER INTEGRALS, INTEGRATION BETWEEN ZEROS, QUADPACK, -C QUADRATURE, SPECIAL-PURPOSE INTEGRAL -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Computation of Fourier integrals -C Standard fortran subroutine -C Double precision version -C -C PARAMETERS -C ON ENTRY -C F - Double precision -C Function subprogram defining the integrand -C Function F(X). The actual name for F needs to -C be declared E X T E R N A L in the driver program. -C -C A - Double precision -C Lower limit of integration -C -C OMEGA - Double precision -C Parameter in the WEIGHT function -C -C INTEGR - Integer -C Indicates which WEIGHT function is used -C INTEGR = 1 W(X) = COS(OMEGA*X) -C INTEGR = 2 W(X) = SIN(OMEGA*X) -C If INTEGR.NE.1.AND.INTEGR.NE.2, the routine will -C end with IER = 6. -C -C EPSABS - Double precision -C absolute accuracy requested, EPSABS.GT.0 -C If EPSABS.LE.0, the routine will end with IER = 6. -C -C LIMLST - Integer -C LIMLST gives an upper bound on the number of -C cycles, LIMLST.GE.1. -C If LIMLST.LT.3, the routine will end with IER = 6. -C -C LIMIT - Integer -C Gives an upper bound on the number of subintervals -C allowed in the partition of each cycle, LIMIT.GE.1 -C each cycle, LIMIT.GE.1. -C -C MAXP1 - Integer -C Gives an upper bound on the number of -C Chebyshev moments which can be stored, I.E. -C for the intervals of lengths ABS(B-A)*2**(-L), -C L=0,1, ..., MAXP1-2, MAXP1.GE.1 -C -C ON RETURN -C RESULT - Double precision -C Approximation to the integral X -C -C ABSERR - Double precision -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - IER = 0 Normal and reliable termination of -C the routine. It is assumed that the -C requested accuracy has been achieved. -C IER.GT.0 Abnormal termination of the routine. The -C estimates for integral and error are less -C reliable. It is assumed that the requested -C accuracy has not been achieved. -C ERROR MESSAGES -C If OMEGA.NE.0 -C IER = 1 Maximum number of cycles allowed -C Has been achieved., i.e. of subintervals -C (A+(K-1)C,A+KC) where -C C = (2*INT(ABS(OMEGA))+1)*PI/ABS(OMEGA), -C for K = 1, 2, ..., LST. -C One can allow more cycles by increasing -C the value of LIMLST (and taking the -C according dimension adjustments into -C account). -C Examine the array IWORK which contains -C the error flags on the cycles, in order to -C look for eventual local integration -C difficulties. If the position of a local -C difficulty can be determined (e.g. -C SINGULARITY, DISCONTINUITY within the -C interval) one will probably gain from -C splitting up the interval at this point -C and calling appropriate integrators on -C the subranges. -C = 4 The extrapolation table constructed for -C convergence acceleration of the series -C formed by the integral contributions over -C the cycles, does not converge to within -C the requested accuracy. As in the case of -C IER = 1, it is advised to examine the -C array IWORK which contains the error -C flags on the cycles. -C = 6 The input is invalid because -C (INTEGR.NE.1 AND INTEGR.NE.2) or -C EPSABS.LE.0 or LIMLST.LT.3. -C RESULT, ABSERR, NEVAL, LST are set -C to zero. -C = 7 Bad integrand behaviour occurs within one -C or more of the cycles. Location and type -C of the difficulty involved can be -C determined from the vector IERLST. Here -C LST is the number of cycles actually -C needed (see below). -C IERLST(K) = 1 The maximum number of -C subdivisions (= LIMIT) has -C been achieved on the K th -C cycle. -C = 2 Occurrence of roundoff error -C is detected and prevents the -C tolerance imposed on the -C K th cycle, from being -C achieved. -C = 3 Extremely bad integrand -C behaviour occurs at some -C points of the K th cycle. -C = 4 The integration procedure -C over the K th cycle does -C not converge (to within the -C required accuracy) due to -C roundoff in the -C extrapolation procedure -C invoked on this cycle. It -C is assumed that the result -C on this interval is the -C best which can be obtained. -C = 5 The integral over the K th -C cycle is probably divergent -C or slowly convergent. It -C must be noted that -C divergence can occur with -C any other value of -C IERLST(K). -C If OMEGA = 0 and INTEGR = 1, -C The integral is calculated by means of DQAGIE -C and IER = IERLST(1) (with meaning as described -C for IERLST(K), K = 1). -C -C RSLST - Double precision -C Vector of dimension at least LIMLST -C RSLST(K) contains the integral contribution -C over the interval (A+(K-1)C,A+KC) where -C C = (2*INT(ABS(OMEGA))+1)*PI/ABS(OMEGA), -C K = 1, 2, ..., LST. -C Note that, if OMEGA = 0, RSLST(1) contains -C the value of the integral over (A,INFINITY). -C -C ERLST - Double precision -C Vector of dimension at least LIMLST -C ERLST(K) contains the error estimate corresponding -C with RSLST(K). -C -C IERLST - Integer -C Vector of dimension at least LIMLST -C IERLST(K) contains the error flag corresponding -C with RSLST(K). For the meaning of the local error -C flags see description of output parameter IER. -C -C LST - Integer -C Number of subintervals needed for the integration -C If OMEGA = 0 then LST is set to 1. -C -C ALIST, BLIST, RLIST, ELIST - Double precision -C vector of dimension at least LIMIT, -C -C IORD, NNLOG - Integer -C Vector of dimension at least LIMIT, providing -C space for the quantities needed in the subdivision -C process of each cycle -C -C CHEBMO - Double precision -C Array of dimension at least (MAXP1,25), providing -C space for the Chebyshev moments needed within the -C cycles -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DQAGIE, DQAWOE, DQELG -C***REVISION HISTORY (YYMMDD) -C 800101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891009 Removed unreferenced variable. (WRB) -C 891009 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE DQAWFE -C - DOUBLE PRECISION A,ABSEPS,ABSERR,ALIST,BLIST,CHEBMO,CORREC,CYCLE, - 1 C1,C2,DL,DRL,D1MACH,ELIST,ERLST,EP,EPS,EPSA, - 2 EPSABS,ERRSUM,F,FACT,OMEGA,P,PI,P1,PSUM,RESEPS,RESULT,RES3LA, - 3 RLIST,RSLST,UFLOW - INTEGER IER,IERLST,INTEGR,IORD,KTMIN,L,LAST,LST,LIMIT,LIMLST,LL, - 1 MAXP1,MOMCOM,NEV,NEVAL,NNLOG,NRES,NUMRL2 -C - DIMENSION ALIST(*),BLIST(*),CHEBMO(MAXP1,25),ELIST(*), - 1 ERLST(*),IERLST(*),IORD(*),NNLOG(*),PSUM(52), - 2 RES3LA(3),RLIST(*),RSLST(*) -C - EXTERNAL F -C -C -C THE DIMENSION OF PSUM IS DETERMINED BY THE VALUE OF -C LIMEXP IN SUBROUTINE DQELG (PSUM MUST BE OF DIMENSION -C (LIMEXP+2) AT LEAST). -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C C1, C2 - END POINTS OF SUBINTERVAL (OF LENGTH CYCLE) -C CYCLE - (2*INT(ABS(OMEGA))+1)*PI/ABS(OMEGA) -C PSUM - VECTOR OF DIMENSION AT LEAST (LIMEXP+2) -C (SEE ROUTINE DQELG) -C PSUM CONTAINS THE PART OF THE EPSILON TABLE -C WHICH IS STILL NEEDED FOR FURTHER COMPUTATIONS. -C EACH ELEMENT OF PSUM IS A PARTIAL SUM OF THE -C SERIES WHICH SHOULD SUM TO THE VALUE OF THE -C INTEGRAL. -C ERRSUM - SUM OF ERROR ESTIMATES OVER THE SUBINTERVALS, -C CALCULATED CUMULATIVELY -C EPSA - ABSOLUTE TOLERANCE REQUESTED OVER CURRENT -C SUBINTERVAL -C CHEBMO - ARRAY CONTAINING THE MODIFIED CHEBYSHEV -C MOMENTS (SEE ALSO ROUTINE DQC25F) -C - SAVE P, PI - DATA P/0.9D+00/ - DATA PI / 3.1415926535 8979323846 2643383279 50 D0 / -C -C TEST ON VALIDITY OF PARAMETERS -C ------------------------------ -C -C***FIRST EXECUTABLE STATEMENT DQAWFE - RESULT = 0.0D+00 - ABSERR = 0.0D+00 - NEVAL = 0 - LST = 0 - IER = 0 - IF((INTEGR.NE.1.AND.INTEGR.NE.2).OR.EPSABS.LE.0.0D+00.OR. - 1 LIMLST.LT.3) IER = 6 - IF(IER.EQ.6) GO TO 999 - IF(OMEGA.NE.0.0D+00) GO TO 10 -C -C INTEGRATION BY DQAGIE IF OMEGA IS ZERO -C -------------------------------------- -C - IF(INTEGR.EQ.1) CALL DQAGIE(F,A,1,EPSABS,0.0D+00,LIMIT, - 1 RESULT,ABSERR,NEVAL,IER,ALIST,BLIST,RLIST,ELIST,IORD,LAST) - RSLST(1) = RESULT - ERLST(1) = ABSERR - IERLST(1) = IER - LST = 1 - GO TO 999 -C -C INITIALIZATIONS -C --------------- -C - 10 L = ABS(OMEGA) - DL = 2*L+1 - CYCLE = DL*PI/ABS(OMEGA) - IER = 0 - KTMIN = 0 - NEVAL = 0 - NUMRL2 = 0 - NRES = 0 - C1 = A - C2 = CYCLE+A - P1 = 0.1D+01-P - UFLOW = D1MACH(1) - EPS = EPSABS - IF(EPSABS.GT.UFLOW/P1) EPS = EPSABS*P1 - EP = EPS - FACT = 0.1D+01 - CORREC = 0.0D+00 - ABSERR = 0.0D+00 - ERRSUM = 0.0D+00 -C -C MAIN DO-LOOP -C ------------ -C - DO 50 LST = 1,LIMLST -C -C INTEGRATE OVER CURRENT SUBINTERVAL. -C - EPSA = EPS*FACT - CALL DQAWOE(F,C1,C2,OMEGA,INTEGR,EPSA,0.0D+00,LIMIT,LST,MAXP1, - 1 RSLST(LST),ERLST(LST),NEV,IERLST(LST),LAST,ALIST,BLIST,RLIST, - 2 ELIST,IORD,NNLOG,MOMCOM,CHEBMO) - NEVAL = NEVAL+NEV - FACT = FACT*P - ERRSUM = ERRSUM+ERLST(LST) - DRL = 0.5D+02*ABS(RSLST(LST)) -C -C TEST ON ACCURACY WITH PARTIAL SUM -C - IF((ERRSUM+DRL).LE.EPSABS.AND.LST.GE.6) GO TO 80 - CORREC = MAX(CORREC,ERLST(LST)) - IF(IERLST(LST).NE.0) EPS = MAX(EP,CORREC*P1) - IF(IERLST(LST).NE.0) IER = 7 - IF(IER.EQ.7.AND.(ERRSUM+DRL).LE.CORREC*0.1D+02.AND. - 1 LST.GT.5) GO TO 80 - NUMRL2 = NUMRL2+1 - IF(LST.GT.1) GO TO 20 - PSUM(1) = RSLST(1) - GO TO 40 - 20 PSUM(NUMRL2) = PSUM(LL)+RSLST(LST) - IF(LST.EQ.2) GO TO 40 -C -C TEST ON MAXIMUM NUMBER OF SUBINTERVALS -C - IF(LST.EQ.LIMLST) IER = 1 -C -C PERFORM NEW EXTRAPOLATION -C - CALL DQELG(NUMRL2,PSUM,RESEPS,ABSEPS,RES3LA,NRES) -C -C TEST WHETHER EXTRAPOLATED RESULT IS INFLUENCED BY ROUNDOFF -C - KTMIN = KTMIN+1 - IF(KTMIN.GE.15.AND.ABSERR.LE.0.1D-02*(ERRSUM+DRL)) IER = 4 - IF(ABSEPS.GT.ABSERR.AND.LST.NE.3) GO TO 30 - ABSERR = ABSEPS - RESULT = RESEPS - KTMIN = 0 -C -C IF IER IS NOT 0, CHECK WHETHER DIRECT RESULT (PARTIAL SUM) -C OR EXTRAPOLATED RESULT YIELDS THE BEST INTEGRAL -C APPROXIMATION -C - IF((ABSERR+0.1D+02*CORREC).LE.EPSABS.OR. - 1 (ABSERR.LE.EPSABS.AND.0.1D+02*CORREC.GE.EPSABS)) GO TO 60 - 30 IF(IER.NE.0.AND.IER.NE.7) GO TO 60 - 40 LL = NUMRL2 - C1 = C2 - C2 = C2+CYCLE - 50 CONTINUE -C -C SET FINAL RESULT AND ERROR ESTIMATE -C ----------------------------------- -C - 60 ABSERR = ABSERR+0.1D+02*CORREC - IF(IER.EQ.0) GO TO 999 - IF(RESULT.NE.0.0D+00.AND.PSUM(NUMRL2).NE.0.0D+00) GO TO 70 - IF(ABSERR.GT.ERRSUM) GO TO 80 - IF(PSUM(NUMRL2).EQ.0.0D+00) GO TO 999 - 70 IF(ABSERR/ABS(RESULT).GT.(ERRSUM+DRL)/ABS(PSUM(NUMRL2))) - 1 GO TO 80 - IF(IER.GE.1.AND.IER.NE.7) ABSERR = ABSERR+DRL - GO TO 999 - 80 RESULT = PSUM(NUMRL2) - ABSERR = ERRSUM+DRL - 999 RETURN - END diff --git a/slatec/dqawo.f b/slatec/dqawo.f deleted file mode 100644 index b74e0cf..0000000 --- a/slatec/dqawo.f +++ /dev/null @@ -1,237 +0,0 @@ -*DECK DQAWO - SUBROUTINE DQAWO (F, A, B, OMEGA, INTEGR, EPSABS, EPSREL, RESULT, - + ABSERR, NEVAL, IER, LENIW, MAXP1, LENW, LAST, IWORK, WORK) -C***BEGIN PROLOGUE DQAWO -C***PURPOSE Calculate an approximation to a given definite integral -C I= Integral of F(X)*W(X) over (A,B), where -C W(X) = COS(OMEGA*X) -C or W(X) = SIN(OMEGA*X), -C hopefully satisfying the following claim for accuracy -C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A2A1 -C***TYPE DOUBLE PRECISION (QAWO-S, DQAWO-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, CLENSHAW-CURTIS METHOD, -C EXTRAPOLATION, GLOBALLY ADAPTIVE, -C INTEGRAND WITH OSCILLATORY COS OR SIN FACTOR, QUADPACK, -C QUADRATURE, SPECIAL-PURPOSE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Computation of oscillatory integrals -C Standard fortran subroutine -C Double precision version -C -C PARAMETERS -C ON ENTRY -C F - Double precision -C Function subprogram defining the function -C F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C A - Double precision -C Lower limit of integration -C -C B - Double precision -C Upper limit of integration -C -C OMEGA - Double precision -C Parameter in the integrand weight function -C -C INTEGR - Integer -C Indicates which of the weight functions is used -C INTEGR = 1 W(X) = COS(OMEGA*X) -C INTEGR = 2 W(X) = SIN(OMEGA*X) -C If INTEGR.NE.1.AND.INTEGR.NE.2, the routine will -C end with IER = 6. -C -C EPSABS - Double precision -C Absolute accuracy requested -C EPSREL - Double precision -C Relative accuracy requested -C If EPSABS.LE.0 and -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C the routine will end with IER = 6. -C -C ON RETURN -C RESULT - Double precision -C Approximation to the integral -C -C ABSERR - Double precision -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C - IER.GT.0 Abnormal termination of the routine. -C The estimates for integral and error are -C less reliable. It is assumed that the -C requested accuracy has not been achieved. -C ERROR MESSAGES -C IER = 1 Maximum number of subdivisions allowed -C has been achieved (= LENIW/2). One can -C allow more subdivisions by increasing the -C value of LENIW (and taking the according -C dimension adjustments into account). -C However, if this yields no improvement it -C is advised to analyze the integrand in -C order to determine the integration -C difficulties. If the position of a local -C difficulty can be determined (e.g. -C SINGULARITY, DISCONTINUITY within the -C interval) one will probably gain from -C splitting up the interval at this point -C and calling the integrator on the -C subranges. If possible, an appropriate -C special-purpose integrator should be used -C which is designed for handling the type of -C difficulty involved. -C = 2 The occurrence of roundoff error is -C detected, which prevents the requested -C tolerance from being achieved. -C The error may be under-estimated. -C = 3 Extremely bad integrand behaviour occurs -C at some interior points of the -C integration interval. -C = 4 The algorithm does not converge. -C Roundoff error is detected in the -C extrapolation table. It is presumed that -C the requested tolerance cannot be achieved -C due to roundoff in the extrapolation -C table, and that the returned result is -C the best which can be obtained. -C = 5 The integral is probably divergent, or -C slowly convergent. It must be noted that -C divergence can occur with any other value -C of IER. -C = 6 The input is invalid, because -C (EPSABS.LE.0 and -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)) -C or (INTEGR.NE.1 AND INTEGR.NE.2), -C or LENIW.LT.2 OR MAXP1.LT.1 or -C LENW.LT.LENIW*2+MAXP1*25. -C RESULT, ABSERR, NEVAL, LAST are set to -C zero. Except when LENIW, MAXP1 or LENW are -C invalid, WORK(LIMIT*2+1), WORK(LIMIT*3+1), -C IWORK(1), IWORK(LIMIT+1) are set to zero, -C WORK(1) is set to A and WORK(LIMIT+1) to -C B. -C -C DIMENSIONING PARAMETERS -C LENIW - Integer -C Dimensioning parameter for IWORK. -C LENIW/2 equals the maximum number of subintervals -C allowed in the partition of the given integration -C interval (A,B), LENIW.GE.2. -C If LENIW.LT.2, the routine will end with IER = 6. -C -C MAXP1 - Integer -C Gives an upper bound on the number of Chebyshev -C moments which can be stored, i.e. for the -C intervals of lengths ABS(B-A)*2**(-L), -C L=0,1, ..., MAXP1-2, MAXP1.GE.1 -C If MAXP1.LT.1, the routine will end with IER = 6. -C -C LENW - Integer -C Dimensioning parameter for WORK -C LENW must be at least LENIW*2+MAXP1*25. -C If LENW.LT.(LENIW*2+MAXP1*25), the routine will -C end with IER = 6. -C -C LAST - Integer -C On return, LAST equals the number of subintervals -C produced in the subdivision process, which -C determines the number of significant elements -C actually in the WORK ARRAYS. -C -C WORK ARRAYS -C IWORK - Integer -C Vector of dimension at least LENIW -C on return, the first K elements of which contain -C pointers to the error estimates over the -C subintervals, such that WORK(LIMIT*3+IWORK(1)), .. -C WORK(LIMIT*3+IWORK(K)) form a decreasing -C sequence, with LIMIT = LENW/2 , and K = LAST -C if LAST.LE.(LIMIT/2+2), and K = LIMIT+1-LAST -C otherwise. -C Furthermore, IWORK(LIMIT+1), ..., IWORK(LIMIT+ -C LAST) indicate the subdivision levels of the -C subintervals, such that IWORK(LIMIT+I) = L means -C that the subinterval numbered I is of length -C ABS(B-A)*2**(1-L). -C -C WORK - Double precision -C Vector of dimension at least LENW -C On return -C WORK(1), ..., WORK(LAST) contain the left -C end points of the subintervals in the -C partition of (A,B), -C WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain -C the right end points, -C WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) contain -C the integral approximations over the -C subintervals, -C WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) -C contain the error estimates. -C WORK(LIMIT*4+1), ..., WORK(LIMIT*4+MAXP1*25) -C Provide space for storing the Chebyshev moments. -C Note that LIMIT = LENW/2. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED DQAWOE, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800101 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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE DQAWO -C - DOUBLE PRECISION A,ABSERR,B,EPSABS,EPSREL,F,OMEGA,RESULT,WORK - INTEGER IER,INTEGR,IWORK,LAST,LIMIT,LENW,LENIW,LVL,L1,L2,L3,L4, - 1 MAXP1,MOMCOM,NEVAL -C - DIMENSION IWORK(*),WORK(*) -C - EXTERNAL F -C -C CHECK VALIDITY OF LENIW, MAXP1 AND LENW. -C -C***FIRST EXECUTABLE STATEMENT DQAWO - IER = 6 - NEVAL = 0 - LAST = 0 - RESULT = 0.0D+00 - ABSERR = 0.0D+00 - IF(LENIW.LT.2.OR.MAXP1.LT.1.OR.LENW.LT.(LENIW*2+MAXP1*25)) - 1 GO TO 10 -C -C PREPARE CALL FOR DQAWOE -C - LIMIT = LENIW/2 - L1 = LIMIT+1 - L2 = LIMIT+L1 - L3 = LIMIT+L2 - L4 = LIMIT+L3 - CALL DQAWOE(F,A,B,OMEGA,INTEGR,EPSABS,EPSREL,LIMIT,1,MAXP1,RESULT, - 1 ABSERR,NEVAL,IER,LAST,WORK(1),WORK(L1),WORK(L2),WORK(L3), - 2 IWORK(1),IWORK(L1),MOMCOM,WORK(L4)) -C -C CALL ERROR HANDLER IF NECESSARY -C - LVL = 0 -10 IF(IER.EQ.6) LVL = 0 - IF (IER .NE. 0) CALL XERMSG ('SLATEC', 'DQAWO', - + 'ABNORMAL RETURN', IER, LVL) - RETURN - END diff --git a/slatec/dqawoe.f b/slatec/dqawoe.f deleted file mode 100644 index 6d55e00..0000000 --- a/slatec/dqawoe.f +++ /dev/null @@ -1,542 +0,0 @@ -*DECK DQAWOE - SUBROUTINE DQAWOE (F, A, B, OMEGA, INTEGR, EPSABS, EPSREL, LIMIT, - + ICALL, MAXP1, RESULT, ABSERR, NEVAL, IER, LAST, ALIST, BLIST, - + RLIST, ELIST, IORD, NNLOG, MOMCOM, CHEBMO) -C***BEGIN PROLOGUE DQAWOE -C***PURPOSE Calculate an approximation to a given definite integral -C I = Integral of F(X)*W(X) over (A,B), where -C W(X) = COS(OMEGA*X) -C or W(X)=SIN(OMEGA*X), -C hopefully satisfying the following claim for accuracy -C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A2A1 -C***TYPE DOUBLE PRECISION (QAWOE-S, DQAWOE-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, CLENSHAW-CURTIS METHOD, -C EXTRAPOLATION, GLOBALLY ADAPTIVE, -C INTEGRAND WITH OSCILLATORY COS OR SIN FACTOR, QUADPACK, -C QUADRATURE, SPECIAL-PURPOSE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Computation of Oscillatory integrals -C Standard fortran subroutine -C Double precision version -C -C PARAMETERS -C ON ENTRY -C F - Double precision -C Function subprogram defining the integrand -C function F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C A - Double precision -C Lower limit of integration -C -C B - Double precision -C Upper limit of integration -C -C OMEGA - Double precision -C Parameter in the integrand weight function -C -C INTEGR - Integer -C Indicates which of the WEIGHT functions is to be -C used -C INTEGR = 1 W(X) = COS(OMEGA*X) -C INTEGR = 2 W(X) = SIN(OMEGA*X) -C If INTEGR.NE.1 and INTEGR.NE.2, the routine -C will end with IER = 6. -C -C EPSABS - Double precision -C Absolute accuracy requested -C EPSREL - Double precision -C Relative accuracy requested -C If EPSABS.LE.0 -C and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C the routine will end with IER = 6. -C -C LIMIT - Integer -C Gives an upper bound on the number of subdivisions -C in the partition of (A,B), LIMIT.GE.1. -C -C ICALL - Integer -C If DQAWOE is to be used only once, ICALL must -C be set to 1. Assume that during this call, the -C Chebyshev moments (for CLENSHAW-CURTIS integration -C of degree 24) have been computed for intervals of -C lengths (ABS(B-A))*2**(-L), L=0,1,2,...MOMCOM-1. -C If ICALL.GT.1 this means that DQAWOE has been -C called twice or more on intervals of the same -C length ABS(B-A). The Chebyshev moments already -C computed are then re-used in subsequent calls. -C If ICALL.LT.1, the routine will end with IER = 6. -C -C MAXP1 - Integer -C Gives an upper bound on the number of Chebyshev -C moments which can be stored, i.e. for the -C intervals of lengths ABS(B-A)*2**(-L), -C L=0,1, ..., MAXP1-2, MAXP1.GE.1. -C If MAXP1.LT.1, the routine will end with IER = 6. -C -C ON RETURN -C RESULT - Double precision -C Approximation to the integral -C -C ABSERR - Double precision -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the -C requested accuracy has been achieved. -C - IER.GT.0 Abnormal termination of the routine. -C The estimates for integral and error are -C less reliable. It is assumed that the -C requested accuracy has not been achieved. -C ERROR MESSAGES -C IER = 1 Maximum number of subdivisions allowed -C has been achieved. One can allow more -C subdivisions by increasing the value of -C LIMIT (and taking according dimension -C adjustments into account). However, if -C this yields no improvement it is advised -C to analyze the integrand, in order to -C determine the integration difficulties. -C If the position of a local difficulty can -C be determined (e.g. SINGULARITY, -C DISCONTINUITY within the interval) one -C will probably gain from splitting up the -C interval at this point and calling the -C integrator on the subranges. If possible, -C an appropriate special-purpose integrator -C should be used which is designed for -C handling the type of difficulty involved. -C = 2 The occurrence of roundoff error is -C detected, which prevents the requested -C tolerance from being achieved. -C The error may be under-estimated. -C = 3 Extremely bad integrand behaviour occurs -C at some points of the integration -C interval. -C = 4 The algorithm does not converge. -C Roundoff error is detected in the -C extrapolation table. -C It is presumed that the requested -C tolerance cannot be achieved due to -C roundoff in the extrapolation table, -C and that the returned result is the -C best which can be obtained. -C = 5 The integral is probably divergent, or -C slowly convergent. It must be noted that -C divergence can occur with any other value -C of IER.GT.0. -C = 6 The input is invalid, because -C (EPSABS.LE.0 and -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)) -C or (INTEGR.NE.1 and INTEGR.NE.2) or -C ICALL.LT.1 or MAXP1.LT.1. -C RESULT, ABSERR, NEVAL, LAST, RLIST(1), -C ELIST(1), IORD(1) and NNLOG(1) are set -C to ZERO. ALIST(1) and BLIST(1) are set -C to A and B respectively. -C -C LAST - Integer -C On return, LAST equals the number of -C subintervals produces in the subdivision -C process, which determines the number of -C significant elements actually in the -C WORK ARRAYS. -C ALIST - Double precision -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the left -C end points of the subintervals in the partition -C of the given integration range (A,B) -C -C BLIST - Double precision -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the right -C end points of the subintervals in the partition -C of the given integration range (A,B) -C -C RLIST - Double precision -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the integral -C approximations on the subintervals -C -C ELIST - Double precision -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the moduli of the -C absolute error estimates on the subintervals -C -C IORD - Integer -C Vector of dimension at least LIMIT, the first K -C elements of which are pointers to the error -C estimates over the subintervals, -C such that ELIST(IORD(1)), ..., -C ELIST(IORD(K)) form a decreasing sequence, with -C K = LAST if LAST.LE.(LIMIT/2+2), and -C K = LIMIT+1-LAST otherwise. -C -C NNLOG - Integer -C Vector of dimension at least LIMIT, containing the -C subdivision levels of the subintervals, i.e. -C IWORK(I) = L means that the subinterval -C numbered I is of length ABS(B-A)*2**(1-L) -C -C ON ENTRY AND RETURN -C MOMCOM - Integer -C Indicating that the Chebyshev moments -C have been computed for intervals of lengths -C (ABS(B-A))*2**(-L), L=0,1,2, ..., MOMCOM-1, -C MOMCOM.LT.MAXP1 -C -C CHEBMO - Double precision -C Array of dimension (MAXP1,25) containing the -C Chebyshev moments -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DQC25F, DQELG, DQPSRT -C***REVISION HISTORY (YYMMDD) -C 800101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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***END PROLOGUE DQAWOE -C - DOUBLE PRECISION A,ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1, - 1 A2,B,BLIST,B1,B2,CHEBMO,CORREC,DEFAB1,DEFAB2,DEFABS, - 2 DOMEGA,D1MACH,DRES,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST, - 3 ERRBND,ERRMAX,ERROR1,ERRO12,ERROR2,ERRSUM,ERTEST,F,OFLOW, - 4 OMEGA,RESABS,RESEPS,RESULT,RES3LA,RLIST,RLIST2,SMALL,UFLOW,WIDTH - INTEGER ICALL,ID,IER,IERRO,INTEGR,IORD,IROFF1,IROFF2,IROFF3, - 1 JUPBND,K,KSGN,KTMIN,LAST,LIMIT,MAXERR,MAXP1,MOMCOM,NEV,NEVAL, - 2 NNLOG,NRES,NRMAX,NRMOM,NUMRL2 - LOGICAL EXTRAP,NOEXT,EXTALL -C - DIMENSION ALIST(*),BLIST(*),RLIST(*),ELIST(*), - 1 IORD(*),RLIST2(52),RES3LA(3),CHEBMO(MAXP1,25),NNLOG(*) -C - EXTERNAL F -C -C THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF -C LIMEXP IN SUBROUTINE DQELG (RLIST2 SHOULD BE OF -C DIMENSION (LIMEXP+2) AT LEAST). -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER -C (ALIST(I),BLIST(I)) -C RLIST2 - ARRAY OF DIMENSION AT LEAST LIMEXP+2 -C CONTAINING THE PART OF THE EPSILON TABLE -C WHICH IS STILL NEEDED FOR FURTHER COMPUTATIONS -C ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) -C MAXERR - POINTER TO THE INTERVAL WITH LARGEST -C ERROR ESTIMATE -C ERRMAX - ELIST(MAXERR) -C ERLAST - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED -C AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS -C ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS -C ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* -C ABS(RESULT)) -C *****1 - VARIABLE FOR THE LEFT SUBINTERVAL -C *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL -C LAST - INDEX FOR SUBDIVISION -C NRES - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE -C NUMRL2 - NUMBER OF ELEMENTS IN RLIST2. IF AN APPROPRIATE -C APPROXIMATION TO THE COMPOUNDED INTEGRAL HAS -C BEEN OBTAINED IT IS PUT IN RLIST2(NUMRL2) AFTER -C NUMRL2 HAS BEEN INCREASED BY ONE -C SMALL - LENGTH OF THE SMALLEST INTERVAL CONSIDERED -C UP TO NOW, MULTIPLIED BY 1.5 -C ERLARG - SUM OF THE ERRORS OVER THE INTERVALS LARGER -C THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW -C EXTRAP - LOGICAL VARIABLE DENOTING THAT THE ROUTINE IS -C ATTEMPTING TO PERFORM EXTRAPOLATION, I.E. BEFORE -C SUBDIVIDING THE SMALLEST INTERVAL WE TRY TO -C DECREASE THE VALUE OF ERLARG -C NOEXT - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION -C IS NO LONGER ALLOWED (TRUE VALUE) -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C OFLOW IS THE LARGEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT DQAWOE - EPMACH = D1MACH(4) -C -C TEST ON VALIDITY OF PARAMETERS -C ------------------------------ -C - IER = 0 - NEVAL = 0 - LAST = 0 - RESULT = 0.0D+00 - ABSERR = 0.0D+00 - ALIST(1) = A - BLIST(1) = B - RLIST(1) = 0.0D+00 - ELIST(1) = 0.0D+00 - IORD(1) = 0 - NNLOG(1) = 0 - IF((INTEGR.NE.1.AND.INTEGR.NE.2).OR.(EPSABS.LE.0.0D+00.AND. - 1 EPSREL.LT.MAX(0.5D+02*EPMACH,0.5D-28)).OR.ICALL.LT.1.OR. - 2 MAXP1.LT.1) IER = 6 - IF(IER.EQ.6) GO TO 999 -C -C FIRST APPROXIMATION TO THE INTEGRAL -C ----------------------------------- -C - DOMEGA = ABS(OMEGA) - NRMOM = 0 - IF (ICALL.GT.1) GO TO 5 - MOMCOM = 0 - 5 CALL DQC25F(F,A,B,DOMEGA,INTEGR,NRMOM,MAXP1,0,RESULT,ABSERR, - 1 NEVAL,DEFABS,RESABS,MOMCOM,CHEBMO) -C -C TEST ON ACCURACY. -C - DRES = ABS(RESULT) - ERRBND = MAX(EPSABS,EPSREL*DRES) - RLIST(1) = RESULT - ELIST(1) = ABSERR - IORD(1) = 1 - IF(ABSERR.LE.0.1D+03*EPMACH*DEFABS.AND.ABSERR.GT.ERRBND) IER = 2 - IF(LIMIT.EQ.1) IER = 1 - IF(IER.NE.0.OR.ABSERR.LE.ERRBND) GO TO 200 -C -C INITIALIZATIONS -C --------------- -C - UFLOW = D1MACH(1) - OFLOW = D1MACH(2) - ERRMAX = ABSERR - MAXERR = 1 - AREA = RESULT - ERRSUM = ABSERR - ABSERR = OFLOW - NRMAX = 1 - EXTRAP = .FALSE. - NOEXT = .FALSE. - IERRO = 0 - IROFF1 = 0 - IROFF2 = 0 - IROFF3 = 0 - KTMIN = 0 - SMALL = ABS(B-A)*0.75D+00 - NRES = 0 - NUMRL2 = 0 - EXTALL = .FALSE. - IF(0.5D+00*ABS(B-A)*DOMEGA.GT.0.2D+01) GO TO 10 - NUMRL2 = 1 - EXTALL = .TRUE. - RLIST2(1) = RESULT - 10 IF(0.25D+00*ABS(B-A)*DOMEGA.LE.0.2D+01) EXTALL = .TRUE. - KSGN = -1 - IF(DRES.GE.(0.1D+01-0.5D+02*EPMACH)*DEFABS) KSGN = 1 -C -C MAIN DO-LOOP -C ------------ -C - DO 140 LAST = 2,LIMIT -C -C BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST -C ERROR ESTIMATE. -C - NRMOM = NNLOG(MAXERR)+1 - A1 = ALIST(MAXERR) - B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR)) - A2 = B1 - B2 = BLIST(MAXERR) - ERLAST = ERRMAX - CALL DQC25F(F,A1,B1,DOMEGA,INTEGR,NRMOM,MAXP1,0, - 1 AREA1,ERROR1,NEV,RESABS,DEFAB1,MOMCOM,CHEBMO) - NEVAL = NEVAL+NEV - CALL DQC25F(F,A2,B2,DOMEGA,INTEGR,NRMOM,MAXP1,1, - 1 AREA2,ERROR2,NEV,RESABS,DEFAB2,MOMCOM,CHEBMO) - NEVAL = NEVAL+NEV -C -C IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL -C AND ERROR AND TEST FOR ACCURACY. -C - AREA12 = AREA1+AREA2 - ERRO12 = ERROR1+ERROR2 - ERRSUM = ERRSUM+ERRO12-ERRMAX - AREA = AREA+AREA12-RLIST(MAXERR) - IF(DEFAB1.EQ.ERROR1.OR.DEFAB2.EQ.ERROR2) GO TO 25 - IF(ABS(RLIST(MAXERR)-AREA12).GT.0.1D-04*ABS(AREA12) - 1 .OR.ERRO12.LT.0.99D+00*ERRMAX) GO TO 20 - IF(EXTRAP) IROFF2 = IROFF2+1 - IF(.NOT.EXTRAP) IROFF1 = IROFF1+1 - 20 IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF3 = IROFF3+1 - 25 RLIST(MAXERR) = AREA1 - RLIST(LAST) = AREA2 - NNLOG(MAXERR) = NRMOM - NNLOG(LAST) = NRMOM - ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) -C -C TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG. -C - IF(IROFF1+IROFF2.GE.10.OR.IROFF3.GE.20) IER = 2 - IF(IROFF2.GE.5) IERRO = 3 -C -C SET ERROR FLAG IN THE CASE THAT THE NUMBER OF -C SUBINTERVALS EQUALS LIMIT. -C - IF(LAST.EQ.LIMIT) IER = 1 -C -C SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR -C AT A POINT OF THE INTEGRATION RANGE. -C - IF(MAX(ABS(A1),ABS(B2)).LE.(0.1D+01+0.1D+03*EPMACH) - 1 *(ABS(A2)+0.1D+04*UFLOW)) IER = 4 -C -C APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. -C - IF(ERROR2.GT.ERROR1) GO TO 30 - ALIST(LAST) = A2 - BLIST(MAXERR) = B1 - BLIST(LAST) = B2 - ELIST(MAXERR) = ERROR1 - ELIST(LAST) = ERROR2 - GO TO 40 - 30 ALIST(MAXERR) = A2 - ALIST(LAST) = A1 - BLIST(LAST) = B1 - RLIST(MAXERR) = AREA2 - RLIST(LAST) = AREA1 - ELIST(MAXERR) = ERROR2 - ELIST(LAST) = ERROR1 -C -C CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING -C IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL -C WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BISECTED NEXT). -C - 40 CALL DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) -C ***JUMP OUT OF DO-LOOP - IF(ERRSUM.LE.ERRBND) GO TO 170 - IF(IER.NE.0) GO TO 150 - IF(LAST.EQ.2.AND.EXTALL) GO TO 120 - IF(NOEXT) GO TO 140 - IF(.NOT.EXTALL) GO TO 50 - ERLARG = ERLARG-ERLAST - IF(ABS(B1-A1).GT.SMALL) ERLARG = ERLARG+ERRO12 - IF(EXTRAP) GO TO 70 -C -C TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE -C SMALLEST INTERVAL. -C - 50 WIDTH = ABS(BLIST(MAXERR)-ALIST(MAXERR)) - IF(WIDTH.GT.SMALL) GO TO 140 - IF(EXTALL) GO TO 60 -C -C TEST WHETHER WE CAN START WITH THE EXTRAPOLATION PROCEDURE -C (WE DO THIS IF WE INTEGRATE OVER THE NEXT INTERVAL WITH -C USE OF A GAUSS-KRONROD RULE - SEE SUBROUTINE DQC25F). -C - SMALL = SMALL*0.5D+00 - IF(0.25D+00*WIDTH*DOMEGA.GT.0.2D+01) GO TO 140 - EXTALL = .TRUE. - GO TO 130 - 60 EXTRAP = .TRUE. - NRMAX = 2 - 70 IF(IERRO.EQ.3.OR.ERLARG.LE.ERTEST) GO TO 90 -C -C THE SMALLEST INTERVAL HAS THE LARGEST ERROR. -C BEFORE BISECTING DECREASE THE SUM OF THE ERRORS OVER -C THE LARGER INTERVALS (ERLARG) AND PERFORM EXTRAPOLATION. -C - JUPBND = LAST - IF (LAST.GT.(LIMIT/2+2)) JUPBND = LIMIT+3-LAST - ID = NRMAX - DO 80 K = ID,JUPBND - MAXERR = IORD(NRMAX) - ERRMAX = ELIST(MAXERR) - IF(ABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 140 - NRMAX = NRMAX+1 - 80 CONTINUE -C -C PERFORM EXTRAPOLATION. -C - 90 NUMRL2 = NUMRL2+1 - RLIST2(NUMRL2) = AREA - IF(NUMRL2.LT.3) GO TO 110 - CALL DQELG(NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES) - KTMIN = KTMIN+1 - IF(KTMIN.GT.5.AND.ABSERR.LT.0.1D-02*ERRSUM) IER = 5 - IF(ABSEPS.GE.ABSERR) GO TO 100 - KTMIN = 0 - ABSERR = ABSEPS - RESULT = RESEPS - CORREC = ERLARG - ERTEST = MAX(EPSABS,EPSREL*ABS(RESEPS)) -C ***JUMP OUT OF DO-LOOP - IF(ABSERR.LE.ERTEST) GO TO 150 -C -C PREPARE BISECTION OF THE SMALLEST INTERVAL. -C - 100 IF(NUMRL2.EQ.1) NOEXT = .TRUE. - IF(IER.EQ.5) GO TO 150 - 110 MAXERR = IORD(1) - ERRMAX = ELIST(MAXERR) - NRMAX = 1 - EXTRAP = .FALSE. - SMALL = SMALL*0.5D+00 - ERLARG = ERRSUM - GO TO 140 - 120 SMALL = SMALL*0.5D+00 - NUMRL2 = NUMRL2+1 - RLIST2(NUMRL2) = AREA - 130 ERTEST = ERRBND - ERLARG = ERRSUM - 140 CONTINUE -C -C SET THE FINAL RESULT. -C --------------------- -C - 150 IF(ABSERR.EQ.OFLOW.OR.NRES.EQ.0) GO TO 170 - IF(IER+IERRO.EQ.0) GO TO 165 - IF(IERRO.EQ.3) ABSERR = ABSERR+CORREC - IF(IER.EQ.0) IER = 3 - IF(RESULT.NE.0.0D+00.AND.AREA.NE.0.0D+00) GO TO 160 - IF(ABSERR.GT.ERRSUM) GO TO 170 - IF(AREA.EQ.0.0D+00) GO TO 190 - GO TO 165 - 160 IF(ABSERR/ABS(RESULT).GT.ERRSUM/ABS(AREA)) GO TO 170 -C -C TEST ON DIVERGENCE. -C - 165 IF(KSGN.EQ.(-1).AND.MAX(ABS(RESULT),ABS(AREA)).LE. - 1 DEFABS*0.1D-01) GO TO 190 - IF(0.1D-01.GT.(RESULT/AREA).OR.(RESULT/AREA).GT.0.1D+03 - 1 .OR.ERRSUM.GE.ABS(AREA)) IER = 6 - GO TO 190 -C -C COMPUTE GLOBAL INTEGRAL SUM. -C - 170 RESULT = 0.0D+00 - DO 180 K=1,LAST - RESULT = RESULT+RLIST(K) - 180 CONTINUE - ABSERR = ERRSUM - 190 IF (IER.GT.2) IER=IER-1 - 200 IF (INTEGR.EQ.2.AND.OMEGA.LT.0.0D+00) RESULT=-RESULT - 999 RETURN - END diff --git a/slatec/dqaws.f b/slatec/dqaws.f deleted file mode 100644 index 52e1792..0000000 --- a/slatec/dqaws.f +++ /dev/null @@ -1,212 +0,0 @@ -*DECK DQAWS - SUBROUTINE DQAWS (F, A, B, ALFA, BETA, INTEGR, EPSABS, EPSREL, - + RESULT, ABSERR, NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK) -C***BEGIN PROLOGUE DQAWS -C***PURPOSE The routine calculates an approximation result to a given -C definite integral I = Integral of F*W over (A,B), -C (where W shows a singular behaviour at the end points -C see parameter INTEGR). -C Hopefully satisfying following claim for accuracy -C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A2A1 -C***TYPE DOUBLE PRECISION (QAWS-S, DQAWS-D) -C***KEYWORDS ALGEBRAIC-LOGARITHMIC END POINT SINGULARITIES, -C AUTOMATIC INTEGRATOR, CLENSHAW-CURTIS METHOD, -C GLOBALLY ADAPTIVE, QUADPACK, QUADRATURE, SPECIAL-PURPOSE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration of functions having algebraico-logarithmic -C end point singularities -C Standard fortran subroutine -C Double precision version -C -C PARAMETERS -C ON ENTRY -C F - Double precision -C Function subprogram defining the integrand -C function F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C A - Double precision -C Lower limit of integration -C -C B - Double precision -C Upper limit of integration, B.GT.A -C If B.LE.A, the routine will end with IER = 6. -C -C ALFA - Double precision -C Parameter in the integrand function, ALFA.GT.(-1) -C If ALFA.LE.(-1), the routine will end with -C IER = 6. -C -C BETA - Double precision -C Parameter in the integrand function, BETA.GT.(-1) -C If BETA.LE.(-1), the routine will end with -C IER = 6. -C -C INTEGR - Integer -C Indicates which WEIGHT function is to be used -C = 1 (X-A)**ALFA*(B-X)**BETA -C = 2 (X-A)**ALFA*(B-X)**BETA*LOG(X-A) -C = 3 (X-A)**ALFA*(B-X)**BETA*LOG(B-X) -C = 4 (X-A)**ALFA*(B-X)**BETA*LOG(X-A)*LOG(B-X) -C If INTEGR.LT.1 or INTEGR.GT.4, the routine -C will end with IER = 6. -C -C EPSABS - Double precision -C Absolute accuracy requested -C EPSREL - Double precision -C Relative accuracy requested -C If EPSABS.LE.0 -C and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C the routine will end with IER = 6. -C -C ON RETURN -C RESULT - Double precision -C Approximation to the integral -C -C ABSERR - Double precision -C Estimate of the modulus of the absolute error, -C Which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C IER.GT.0 Abnormal termination of the routine -C The estimates for the integral and error -C are less reliable. It is assumed that the -C requested accuracy has not been achieved. -C ERROR MESSAGES -C IER = 1 Maximum number of subdivisions allowed -C has been achieved. One can allow more -C subdivisions by increasing the value of -C LIMIT (and taking the according dimension -C adjustments into account). However, if -C this yields no improvement it is advised -C to analyze the integrand, in order to -C determine the integration difficulties -C which prevent the requested tolerance from -C being achieved. In case of a jump -C discontinuity or a local singularity -C of algebraico-logarithmic type at one or -C more interior points of the integration -C range, one should proceed by splitting up -C the interval at these points and calling -C the integrator on the subranges. -C = 2 The occurrence of roundoff error is -C detected, which prevents the requested -C tolerance from being achieved. -C = 3 Extremely bad integrand behaviour occurs -C at some points of the integration -C interval. -C = 6 The input is invalid, because -C B.LE.A or ALFA.LE.(-1) or BETA.LE.(-1) or -C or INTEGR.LT.1 or INTEGR.GT.4 or -C (EPSABS.LE.0 and -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)) -C or LIMIT.LT.2 or LENW.LT.LIMIT*4. -C RESULT, ABSERR, NEVAL, LAST are set to -C zero. Except when LENW or LIMIT is invalid -C IWORK(1), WORK(LIMIT*2+1) and -C WORK(LIMIT*3+1) are set to zero, WORK(1) -C is set to A and WORK(LIMIT+1) to B. -C -C DIMENSIONING PARAMETERS -C LIMIT - Integer -C Dimensioning parameter for IWORK -C LIMIT determines the maximum number of -C subintervals in the partition of the given -C integration interval (A,B), LIMIT.GE.2. -C If LIMIT.LT.2, the routine will end with IER = 6. -C -C LENW - Integer -C Dimensioning parameter for WORK -C LENW must be at least LIMIT*4. -C If LENW.LT.LIMIT*4, the routine will end -C with IER = 6. -C -C LAST - Integer -C On return, LAST equals the number of -C subintervals produced in the subdivision process, -C which determines the significant number of -C elements actually in the WORK ARRAYS. -C -C WORK ARRAYS -C IWORK - Integer -C Vector of dimension LIMIT, the first K -C elements of which contain pointers -C to the error estimates over the subintervals, -C such that WORK(LIMIT*3+IWORK(1)), ..., -C WORK(LIMIT*3+IWORK(K)) form a decreasing -C sequence with K = LAST if LAST.LE.(LIMIT/2+2), -C and K = LIMIT+1-LAST otherwise -C -C WORK - Double precision -C Vector of dimension LENW -C On return -C WORK(1), ..., WORK(LAST) contain the left -C end points of the subintervals in the -C partition of (A,B), -C WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain -C the right end points, -C WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) -C contain the integral approximations over -C the subintervals, -C WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) -C contain the error estimates. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED DQAWSE, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800101 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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE DQAWS -C - DOUBLE PRECISION A,ABSERR,ALFA,B,BETA,EPSABS,EPSREL,F,RESULT,WORK - INTEGER IER,INTEGR,IWORK,LAST,LENW,LIMIT,LVL,L1,L2,L3,NEVAL -C - DIMENSION IWORK(*),WORK(*) -C - EXTERNAL F -C -C CHECK VALIDITY OF LIMIT AND LENW. -C -C***FIRST EXECUTABLE STATEMENT DQAWS - IER = 6 - NEVAL = 0 - LAST = 0 - RESULT = 0.0D+00 - ABSERR = 0.0D+00 - IF(LIMIT.LT.2.OR.LENW.LT.LIMIT*4) GO TO 10 -C -C PREPARE CALL FOR DQAWSE. -C - L1 = LIMIT+1 - L2 = LIMIT+L1 - L3 = LIMIT+L2 -C - CALL DQAWSE(F,A,B,ALFA,BETA,INTEGR,EPSABS,EPSREL,LIMIT,RESULT, - 1 ABSERR,NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) -C -C CALL ERROR HANDLER IF NECESSARY. -C - LVL = 0 -10 IF(IER.EQ.6) LVL = 1 - IF (IER .NE. 0) CALL XERMSG ('SLATEC', 'DQAWS', - + 'ABNORMAL RETURN', IER, LVL) - RETURN - END diff --git a/slatec/dqawse.f b/slatec/dqawse.f deleted file mode 100644 index 51d928b..0000000 --- a/slatec/dqawse.f +++ /dev/null @@ -1,381 +0,0 @@ -*DECK DQAWSE - SUBROUTINE DQAWSE (F, A, B, ALFA, BETA, INTEGR, EPSABS, EPSREL, - + LIMIT, RESULT, ABSERR, NEVAL, IER, ALIST, BLIST, RLIST, ELIST, - + IORD, LAST) -C***BEGIN PROLOGUE DQAWSE -C***PURPOSE The routine calculates an approximation result to a given -C definite integral I = Integral of F*W over (A,B), -C (where W shows a singular behaviour at the end points, -C see parameter INTEGR). -C Hopefully satisfying following claim for accuracy -C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A2A1 -C***TYPE DOUBLE PRECISION (QAWSE-S, DQAWSE-D) -C***KEYWORDS ALGEBRAIC-LOGARITHMIC END POINT SINGULARITIES, -C AUTOMATIC INTEGRATOR, CLENSHAW-CURTIS METHOD, QUADPACK, -C QUADRATURE, SPECIAL-PURPOSE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration of functions having algebraico-logarithmic -C end point singularities -C Standard fortran subroutine -C Double precision version -C -C PARAMETERS -C ON ENTRY -C F - Double precision -C Function subprogram defining the integrand -C function F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C A - Double precision -C Lower limit of integration -C -C B - Double precision -C Upper limit of integration, B.GT.A -C If B.LE.A, the routine will end with IER = 6. -C -C ALFA - Double precision -C Parameter in the WEIGHT function, ALFA.GT.(-1) -C If ALFA.LE.(-1), the routine will end with -C IER = 6. -C -C BETA - Double precision -C Parameter in the WEIGHT function, BETA.GT.(-1) -C If BETA.LE.(-1), the routine will end with -C IER = 6. -C -C INTEGR - Integer -C Indicates which WEIGHT function is to be used -C = 1 (X-A)**ALFA*(B-X)**BETA -C = 2 (X-A)**ALFA*(B-X)**BETA*LOG(X-A) -C = 3 (X-A)**ALFA*(B-X)**BETA*LOG(B-X) -C = 4 (X-A)**ALFA*(B-X)**BETA*LOG(X-A)*LOG(B-X) -C If INTEGR.LT.1 or INTEGR.GT.4, the routine -C will end with IER = 6. -C -C EPSABS - Double precision -C Absolute accuracy requested -C EPSREL - Double precision -C Relative accuracy requested -C If EPSABS.LE.0 -C and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C the routine will end with IER = 6. -C -C LIMIT - Integer -C Gives an upper bound on the number of subintervals -C in the partition of (A,B), LIMIT.GE.2 -C If LIMIT.LT.2, the routine will end with IER = 6. -C -C ON RETURN -C RESULT - Double precision -C Approximation to the integral -C -C ABSERR - Double precision -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C IER.GT.0 Abnormal termination of the routine -C the estimates for the integral and error -C are less reliable. It is assumed that the -C requested accuracy has not been achieved. -C ERROR MESSAGES -C = 1 Maximum number of subdivisions allowed -C has been achieved. One can allow more -C subdivisions by increasing the value of -C LIMIT. However, if this yields no -C improvement, it is advised to analyze the -C integrand in order to determine the -C integration difficulties which prevent the -C requested tolerance from being achieved. -C In case of a jump DISCONTINUITY or a local -C SINGULARITY of algebraico-logarithmic type -C at one or more interior points of the -C integration range, one should proceed by -C splitting up the interval at these -C points and calling the integrator on the -C subranges. -C = 2 The occurrence of roundoff error is -C detected, which prevents the requested -C tolerance from being achieved. -C = 3 Extremely bad integrand behaviour occurs -C at some points of the integration -C interval. -C = 6 The input is invalid, because -C B.LE.A or ALFA.LE.(-1) or BETA.LE.(-1), or -C INTEGR.LT.1 or INTEGR.GT.4, or -C (EPSABS.LE.0 and -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C or LIMIT.LT.2. -C RESULT, ABSERR, NEVAL, RLIST(1), ELIST(1), -C IORD(1) and LAST are set to zero. ALIST(1) -C and BLIST(1) are set to A and B -C respectively. -C -C ALIST - Double precision -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the left -C end points of the subintervals in the partition -C of the given integration range (A,B) -C -C BLIST - Double precision -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the right -C end points of the subintervals in the partition -C of the given integration range (A,B) -C -C RLIST - Double precision -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the integral -C approximations on the subintervals -C -C ELIST - Double precision -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the moduli of the -C absolute error estimates on the subintervals -C -C IORD - Integer -C Vector of dimension at least LIMIT, the first K -C of which are pointers to the error -C estimates over the subintervals, so that -C ELIST(IORD(1)), ..., ELIST(IORD(K)) with K = LAST -C If LAST.LE.(LIMIT/2+2), and K = LIMIT+1-LAST -C otherwise form a decreasing sequence -C -C LAST - Integer -C Number of subintervals actually produced in -C the subdivision process -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DQC25S, DQMOMO, DQPSRT -C***REVISION HISTORY (YYMMDD) -C 800101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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***END PROLOGUE DQAWSE -C - DOUBLE PRECISION A,ABSERR,ALFA,ALIST,AREA,AREA1,AREA12,AREA2,A1, - 1 A2,B,BETA,BLIST,B1,B2,CENTRE,D1MACH,ELIST,EPMACH, - 2 EPSABS,EPSREL,ERRBND,ERRMAX,ERROR1,ERRO12,ERROR2,ERRSUM,F, - 3 RESAS1,RESAS2,RESULT,RG,RH,RI,RJ,RLIST,UFLOW - INTEGER IER,INTEGR,IORD,IROFF1,IROFF2,K,LAST,LIMIT,MAXERR,NEV, - 1 NEVAL,NRMAX -C - EXTERNAL F -C - DIMENSION ALIST(*),BLIST(*),RLIST(*),ELIST(*), - 1 IORD(*),RI(25),RJ(25),RH(25),RG(25) -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER -C (ALIST(I),BLIST(I)) -C ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) -C MAXERR - POINTER TO THE INTERVAL WITH LARGEST -C ERROR ESTIMATE -C ERRMAX - ELIST(MAXERR) -C AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS -C ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS -C ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* -C ABS(RESULT)) -C *****1 - VARIABLE FOR THE LEFT SUBINTERVAL -C *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL -C LAST - INDEX FOR SUBDIVISION -C -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT DQAWSE - EPMACH = D1MACH(4) - UFLOW = D1MACH(1) -C -C TEST ON VALIDITY OF PARAMETERS -C ------------------------------ -C - IER = 6 - NEVAL = 0 - LAST = 0 - RLIST(1) = 0.0D+00 - ELIST(1) = 0.0D+00 - IORD(1) = 0 - RESULT = 0.0D+00 - ABSERR = 0.0D+00 - IF (B.LE.A.OR.(EPSABS.EQ.0.0D+00.AND. - 1 EPSREL.LT.MAX(0.5D+02*EPMACH,0.5D-28)).OR.ALFA.LE.(-0.1D+01) - 2 .OR.BETA.LE.(-0.1D+01).OR.INTEGR.LT.1.OR.INTEGR.GT.4.OR. - 3 LIMIT.LT.2) GO TO 999 - IER = 0 -C -C COMPUTE THE MODIFIED CHEBYSHEV MOMENTS. -C - CALL DQMOMO(ALFA,BETA,RI,RJ,RG,RH,INTEGR) -C -C INTEGRATE OVER THE INTERVALS (A,(A+B)/2) AND ((A+B)/2,B). -C - CENTRE = 0.5D+00*(B+A) - CALL DQC25S(F,A,B,A,CENTRE,ALFA,BETA,RI,RJ,RG,RH,AREA1, - 1 ERROR1,RESAS1,INTEGR,NEV) - NEVAL = NEV - CALL DQC25S(F,A,B,CENTRE,B,ALFA,BETA,RI,RJ,RG,RH,AREA2, - 1 ERROR2,RESAS2,INTEGR,NEV) - LAST = 2 - NEVAL = NEVAL+NEV - RESULT = AREA1+AREA2 - ABSERR = ERROR1+ERROR2 -C -C TEST ON ACCURACY. -C - ERRBND = MAX(EPSABS,EPSREL*ABS(RESULT)) -C -C INITIALIZATION -C -------------- -C - IF(ERROR2.GT.ERROR1) GO TO 10 - ALIST(1) = A - ALIST(2) = CENTRE - BLIST(1) = CENTRE - BLIST(2) = B - RLIST(1) = AREA1 - RLIST(2) = AREA2 - ELIST(1) = ERROR1 - ELIST(2) = ERROR2 - GO TO 20 - 10 ALIST(1) = CENTRE - ALIST(2) = A - BLIST(1) = B - BLIST(2) = CENTRE - RLIST(1) = AREA2 - RLIST(2) = AREA1 - ELIST(1) = ERROR2 - ELIST(2) = ERROR1 - 20 IORD(1) = 1 - IORD(2) = 2 - IF(LIMIT.EQ.2) IER = 1 - IF(ABSERR.LE.ERRBND.OR.IER.EQ.1) GO TO 999 - ERRMAX = ELIST(1) - MAXERR = 1 - NRMAX = 1 - AREA = RESULT - ERRSUM = ABSERR - IROFF1 = 0 - IROFF2 = 0 -C -C MAIN DO-LOOP -C ------------ -C - DO 60 LAST = 3,LIMIT -C -C BISECT THE SUBINTERVAL WITH LARGEST ERROR ESTIMATE. -C - A1 = ALIST(MAXERR) - B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR)) - A2 = B1 - B2 = BLIST(MAXERR) -C - CALL DQC25S(F,A,B,A1,B1,ALFA,BETA,RI,RJ,RG,RH,AREA1, - 1 ERROR1,RESAS1,INTEGR,NEV) - NEVAL = NEVAL+NEV - CALL DQC25S(F,A,B,A2,B2,ALFA,BETA,RI,RJ,RG,RH,AREA2, - 1 ERROR2,RESAS2,INTEGR,NEV) - NEVAL = NEVAL+NEV -C -C IMPROVE PREVIOUS APPROXIMATIONS INTEGRAL AND ERROR -C AND TEST FOR ACCURACY. -C - AREA12 = AREA1+AREA2 - ERRO12 = ERROR1+ERROR2 - ERRSUM = ERRSUM+ERRO12-ERRMAX - AREA = AREA+AREA12-RLIST(MAXERR) - IF(A.EQ.A1.OR.B.EQ.B2) GO TO 30 - IF(RESAS1.EQ.ERROR1.OR.RESAS2.EQ.ERROR2) GO TO 30 -C -C TEST FOR ROUNDOFF ERROR. -C - IF(ABS(RLIST(MAXERR)-AREA12).LT.0.1D-04*ABS(AREA12) - 1 .AND.ERRO12.GE.0.99D+00*ERRMAX) IROFF1 = IROFF1+1 - IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF2 = IROFF2+1 - 30 RLIST(MAXERR) = AREA1 - RLIST(LAST) = AREA2 -C -C TEST ON ACCURACY. -C - ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) - IF(ERRSUM.LE.ERRBND) GO TO 35 -C -C SET ERROR FLAG IN THE CASE THAT THE NUMBER OF INTERVAL -C BISECTIONS EXCEEDS LIMIT. -C - IF(LAST.EQ.LIMIT) IER = 1 -C -C -C SET ERROR FLAG IN THE CASE OF ROUNDOFF ERROR. -C - IF(IROFF1.GE.6.OR.IROFF2.GE.20) IER = 2 -C -C SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR -C AT INTERIOR POINTS OF INTEGRATION RANGE. -C - IF(MAX(ABS(A1),ABS(B2)).LE.(0.1D+01+0.1D+03*EPMACH)* - 1 (ABS(A2)+0.1D+04*UFLOW)) IER = 3 -C -C APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. -C - 35 IF(ERROR2.GT.ERROR1) GO TO 40 - ALIST(LAST) = A2 - BLIST(MAXERR) = B1 - BLIST(LAST) = B2 - ELIST(MAXERR) = ERROR1 - ELIST(LAST) = ERROR2 - GO TO 50 - 40 ALIST(MAXERR) = A2 - ALIST(LAST) = A1 - BLIST(LAST) = B1 - RLIST(MAXERR) = AREA2 - RLIST(LAST) = AREA1 - ELIST(MAXERR) = ERROR2 - ELIST(LAST) = ERROR1 -C -C CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING -C IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL -C WITH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT). -C - 50 CALL DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) -C ***JUMP OUT OF DO-LOOP - IF (IER.NE.0.OR.ERRSUM.LE.ERRBND) GO TO 70 - 60 CONTINUE -C -C COMPUTE FINAL RESULT. -C --------------------- -C - 70 RESULT = 0.0D+00 - DO 80 K=1,LAST - RESULT = RESULT+RLIST(K) - 80 CONTINUE - ABSERR = ERRSUM - 999 RETURN - END diff --git a/slatec/dqc25c.f b/slatec/dqc25c.f deleted file mode 100644 index aa6f2fd..0000000 --- a/slatec/dqc25c.f +++ /dev/null @@ -1,169 +0,0 @@ -*DECK DQC25C - SUBROUTINE DQC25C (F, A, B, C, RESULT, ABSERR, KRUL, NEVAL) -C***BEGIN PROLOGUE DQC25C -C***PURPOSE To compute I = Integral of F*W over (A,B) with -C error estimate, where W(X) = 1/(X-C) -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A2A2, J4 -C***TYPE DOUBLE PRECISION (QC25C-S, DQC25C-D) -C***KEYWORDS 25-POINT CLENSHAW-CURTIS INTEGRATION, QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration rules for the computation of CAUCHY -C PRINCIPAL VALUE integrals -C Standard fortran subroutine -C Double precision version -C -C PARAMETERS -C F - Double precision -C Function subprogram defining the integrand function -C F(X). The actual name for F needs to be declared -C E X T E R N A L in the driver program. -C -C A - Double precision -C Left end point of the integration interval -C -C B - Double precision -C Right end point of the integration interval, B.GT.A -C -C C - Double precision -C Parameter in the WEIGHT function -C -C RESULT - Double precision -C Approximation to the integral -C result is computed by using a generalized -C Clenshaw-Curtis method if C lies within ten percent -C of the integration interval. In the other case the -C 15-point Kronrod rule obtained by optimal addition -C of abscissae to the 7-point Gauss rule, is applied. -C -C ABSERR - Double precision -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C KRUL - Integer -C Key which is decreased by 1 if the 15-point -C Gauss-Kronrod scheme has been used -C -C NEVAL - Integer -C Number of integrand evaluations -C -C ...................................................................... -C -C***REFERENCES (NONE) -C***ROUTINES CALLED DQCHEB, DQK15W, DQWGTC -C***REVISION HISTORY (YYMMDD) -C 810101 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***END PROLOGUE DQC25C -C - DOUBLE PRECISION A,ABSERR,AK22,AMOM0,AMOM1,AMOM2,B,C,CC,CENTR, - 1 CHEB12,CHEB24,DQWGTC,F,FVAL,HLGTH,P2,P3,P4,RESABS, - 2 RESASC,RESULT,RES12,RES24,U,X - INTEGER I,ISYM,K,KP,KRUL,NEVAL -C - DIMENSION X(11),FVAL(25),CHEB12(13),CHEB24(25) -C - EXTERNAL F, DQWGTC -C -C THE VECTOR X CONTAINS THE VALUES COS(K*PI/24), -C K = 1, ..., 11, TO BE USED FOR THE CHEBYSHEV SERIES -C EXPANSION OF F -C - SAVE X - DATA X(1),X(2),X(3),X(4),X(5),X(6),X(7),X(8),X(9),X(10),X(11)/ - 1 0.9914448613738104D+00, 0.9659258262890683D+00, - 2 0.9238795325112868D+00, 0.8660254037844386D+00, - 3 0.7933533402912352D+00, 0.7071067811865475D+00, - 4 0.6087614290087206D+00, 0.5000000000000000D+00, - 5 0.3826834323650898D+00, 0.2588190451025208D+00, - 6 0.1305261922200516D+00/ -C -C LIST OF MAJOR VARIABLES -C ---------------------- -C FVAL - VALUE OF THE FUNCTION F AT THE POINTS -C COS(K*PI/24), K = 0, ..., 24 -C CHEB12 - CHEBYSHEV SERIES EXPANSION COEFFICIENTS, -C FOR THE FUNCTION F, OF DEGREE 12 -C CHEB24 - CHEBYSHEV SERIES EXPANSION COEFFICIENTS, -C FOR THE FUNCTION F, OF DEGREE 24 -C RES12 - APPROXIMATION TO THE INTEGRAL CORRESPONDING -C TO THE USE OF CHEB12 -C RES24 - APPROXIMATION TO THE INTEGRAL CORRESPONDING -C TO THE USE OF CHEB24 -C DQWGTC - EXTERNAL FUNCTION SUBPROGRAM DEFINING -C THE WEIGHT FUNCTION -C HLGTH - HALF-LENGTH OF THE INTERVAL -C CENTR - MID POINT OF THE INTERVAL -C -C -C CHECK THE POSITION OF C. -C -C***FIRST EXECUTABLE STATEMENT DQC25C - CC = (0.2D+01*C-B-A)/(B-A) - IF(ABS(CC).LT.0.11D+01) GO TO 10 -C -C APPLY THE 15-POINT GAUSS-KRONROD SCHEME. -C - KRUL = KRUL-1 - CALL DQK15W(F,DQWGTC,C,P2,P3,P4,KP,A,B,RESULT,ABSERR, - 1 RESABS,RESASC) - NEVAL = 15 - IF (RESASC.EQ.ABSERR) KRUL = KRUL+1 - GO TO 50 -C -C USE THE GENERALIZED CLENSHAW-CURTIS METHOD. -C - 10 HLGTH = 0.5D+00*(B-A) - CENTR = 0.5D+00*(B+A) - NEVAL = 25 - FVAL(1) = 0.5D+00*F(HLGTH+CENTR) - FVAL(13) = F(CENTR) - FVAL(25) = 0.5D+00*F(CENTR-HLGTH) - DO 20 I=2,12 - U = HLGTH*X(I-1) - ISYM = 26-I - FVAL(I) = F(U+CENTR) - FVAL(ISYM) = F(CENTR-U) - 20 CONTINUE -C -C COMPUTE THE CHEBYSHEV SERIES EXPANSION. -C - CALL DQCHEB(X,FVAL,CHEB12,CHEB24) -C -C THE MODIFIED CHEBYSHEV MOMENTS ARE COMPUTED BY FORWARD -C RECURSION, USING AMOM0 AND AMOM1 AS STARTING VALUES. -C - AMOM0 = LOG(ABS((0.1D+01-CC)/(0.1D+01+CC))) - AMOM1 = 0.2D+01+CC*AMOM0 - RES12 = CHEB12(1)*AMOM0+CHEB12(2)*AMOM1 - RES24 = CHEB24(1)*AMOM0+CHEB24(2)*AMOM1 - DO 30 K=3,13 - AMOM2 = 0.2D+01*CC*AMOM1-AMOM0 - AK22 = (K-2)*(K-2) - IF((K/2)*2.EQ.K) AMOM2 = AMOM2-0.4D+01/(AK22-0.1D+01) - RES12 = RES12+CHEB12(K)*AMOM2 - RES24 = RES24+CHEB24(K)*AMOM2 - AMOM0 = AMOM1 - AMOM1 = AMOM2 - 30 CONTINUE - DO 40 K=14,25 - AMOM2 = 0.2D+01*CC*AMOM1-AMOM0 - AK22 = (K-2)*(K-2) - IF((K/2)*2.EQ.K) AMOM2 = AMOM2-0.4D+01/(AK22-0.1D+01) - RES24 = RES24+CHEB24(K)*AMOM2 - AMOM0 = AMOM1 - AMOM1 = AMOM2 - 40 CONTINUE - RESULT = RES24 - ABSERR = ABS(RES24-RES12) - 50 RETURN - END diff --git a/slatec/dqc25f.f b/slatec/dqc25f.f deleted file mode 100644 index 20666a8..0000000 --- a/slatec/dqc25f.f +++ /dev/null @@ -1,362 +0,0 @@ -*DECK DQC25F - SUBROUTINE DQC25F (F, A, B, OMEGA, INTEGR, NRMOM, MAXP1, KSAVE, - + RESULT, ABSERR, NEVAL, RESABS, RESASC, MOMCOM, CHEBMO) -C***BEGIN PROLOGUE DQC25F -C***PURPOSE To compute the integral I=Integral of F(X) over (A,B) -C Where W(X) = COS(OMEGA*X) or W(X)=SIN(OMEGA*X) and to -C compute J = Integral of ABS(F) over (A,B). For small value -C of OMEGA or small intervals (A,B) the 15-point GAUSS-KRONRO -C Rule is used. Otherwise a generalized CLENSHAW-CURTIS -C method is used. -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A2A2 -C***TYPE DOUBLE PRECISION (QC25F-S, DQC25F-D) -C***KEYWORDS CLENSHAW-CURTIS METHOD, GAUSS-KRONROD RULES, -C INTEGRATION RULES FOR FUNCTIONS WITH COS OR SIN FACTOR, -C QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration rules for functions with COS or SIN factor -C Standard fortran subroutine -C Double precision version -C -C PARAMETERS -C ON ENTRY -C F - Double precision -C Function subprogram defining the integrand -C function F(X). The actual name for F needs to -C be declared E X T E R N A L in the calling program. -C -C A - Double precision -C Lower limit of integration -C -C B - Double precision -C Upper limit of integration -C -C OMEGA - Double precision -C Parameter in the WEIGHT function -C -C INTEGR - Integer -C Indicates which WEIGHT function is to be used -C INTEGR = 1 W(X) = COS(OMEGA*X) -C INTEGR = 2 W(X) = SIN(OMEGA*X) -C -C NRMOM - Integer -C The length of interval (A,B) is equal to the length -C of the original integration interval divided by -C 2**NRMOM (we suppose that the routine is used in an -C adaptive integration process, otherwise set -C NRMOM = 0). NRMOM must be zero at the first call. -C -C MAXP1 - Integer -C Gives an upper bound on the number of Chebyshev -C moments which can be stored, i.e. for the -C intervals of lengths ABS(BB-AA)*2**(-L), -C L = 0,1,2, ..., MAXP1-2. -C -C KSAVE - Integer -C Key which is one when the moments for the -C current interval have been computed -C -C ON RETURN -C RESULT - Double precision -C Approximation to the integral I -C -C ABSERR - Double precision -C Estimate of the modulus of the absolute -C error, which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C RESABS - Double precision -C Approximation to the integral J -C -C RESASC - Double precision -C Approximation to the integral of ABS(F-I/(B-A)) -C -C ON ENTRY AND RETURN -C MOMCOM - Integer -C For each interval length we need to compute the -C Chebyshev moments. MOMCOM counts the number of -C intervals for which these moments have already been -C computed. If NRMOM.LT.MOMCOM or KSAVE = 1, the -C Chebyshev moments for the interval (A,B) have -C already been computed and stored, otherwise we -C compute them and we increase MOMCOM. -C -C CHEBMO - Double precision -C Array of dimension at least (MAXP1,25) containing -C the modified Chebyshev moments for the first MOMCOM -C MOMCOM interval lengths -C -C ...................................................................... -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DGTSL, DQCHEB, DQK15W, DQWGTF -C***REVISION HISTORY (YYMMDD) -C 810101 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***END PROLOGUE DQC25F -C - DOUBLE PRECISION A,ABSERR,AC,AN,AN2,AS,ASAP,ASS,B,CENTR,CHEBMO, - 1 CHEB12,CHEB24,CONC,CONS,COSPAR,D,DQWGTF,D1, - 2 D1MACH,D2,ESTC,ESTS,F,FVAL,HLGTH,OFLOW,OMEGA,PARINT,PAR2,PAR22, - 3 P2,P3,P4,RESABS,RESASC,RESC12,RESC24,RESS12,RESS24,RESULT, - 4 SINPAR,V,X - INTEGER I,IERS,INTEGR,ISYM,J,K,KSAVE,M,MOMCOM,NEVAL,MAXP1, - 1 NOEQU,NOEQ1,NRMOM -C - DIMENSION CHEBMO(MAXP1,25),CHEB12(13),CHEB24(25),D(25),D1(25), - 1 D2(25),FVAL(25),V(28),X(11) -C - EXTERNAL F, DQWGTF -C -C THE VECTOR X CONTAINS THE VALUES COS(K*PI/24) -C K = 1, ...,11, TO BE USED FOR THE CHEBYSHEV EXPANSION OF F -C - SAVE X - DATA X(1),X(2),X(3),X(4),X(5),X(6),X(7),X(8),X(9),X(10),X(11)/ - 1 0.9914448613738104D+00, 0.9659258262890683D+00, - 2 0.9238795325112868D+00, 0.8660254037844386D+00, - 3 0.7933533402912352D+00, 0.7071067811865475D+00, - 4 0.6087614290087206D+00, 0.5000000000000000D+00, - 5 0.3826834323650898D+00, 0.2588190451025208D+00, - 6 0.1305261922200516D+00/ -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C CENTR - MID POINT OF THE INTEGRATION INTERVAL -C HLGTH - HALF-LENGTH OF THE INTEGRATION INTERVAL -C FVAL - VALUE OF THE FUNCTION F AT THE POINTS -C (B-A)*0.5*COS(K*PI/12) + (B+A)*0.5, K = 0, ..., 24 -C CHEB12 - COEFFICIENTS OF THE CHEBYSHEV SERIES EXPANSION -C OF DEGREE 12, FOR THE FUNCTION F, IN THE -C INTERVAL (A,B) -C CHEB24 - COEFFICIENTS OF THE CHEBYSHEV SERIES EXPANSION -C OF DEGREE 24, FOR THE FUNCTION F, IN THE -C INTERVAL (A,B) -C RESC12 - APPROXIMATION TO THE INTEGRAL OF -C COS(0.5*(B-A)*OMEGA*X)*F(0.5*(B-A)*X+0.5*(B+A)) -C OVER (-1,+1), USING THE CHEBYSHEV SERIES -C EXPANSION OF DEGREE 12 -C RESC24 - APPROXIMATION TO THE SAME INTEGRAL, USING THE -C CHEBYSHEV SERIES EXPANSION OF DEGREE 24 -C RESS12 - THE ANALOGUE OF RESC12 FOR THE SINE -C RESS24 - THE ANALOGUE OF RESC24 FOR THE SINE -C -C -C MACHINE DEPENDENT CONSTANT -C -------------------------- -C -C OFLOW IS THE LARGEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT DQC25F - OFLOW = D1MACH(2) -C - CENTR = 0.5D+00*(B+A) - HLGTH = 0.5D+00*(B-A) - PARINT = OMEGA*HLGTH -C -C COMPUTE THE INTEGRAL USING THE 15-POINT GAUSS-KRONROD -C FORMULA IF THE VALUE OF THE PARAMETER IN THE INTEGRAND -C IS SMALL. -C - IF(ABS(PARINT).GT.0.2D+01) GO TO 10 - CALL DQK15W(F,DQWGTF,OMEGA,P2,P3,P4,INTEGR,A,B,RESULT, - 1 ABSERR,RESABS,RESASC) - NEVAL = 15 - GO TO 170 -C -C COMPUTE THE INTEGRAL USING THE GENERALIZED CLENSHAW- -C CURTIS METHOD. -C - 10 CONC = HLGTH*COS(CENTR*OMEGA) - CONS = HLGTH*SIN(CENTR*OMEGA) - RESASC = OFLOW - NEVAL = 25 -C -C CHECK WHETHER THE CHEBYSHEV MOMENTS FOR THIS INTERVAL -C HAVE ALREADY BEEN COMPUTED. -C - IF(NRMOM.LT.MOMCOM.OR.KSAVE.EQ.1) GO TO 120 -C -C COMPUTE A NEW SET OF CHEBYSHEV MOMENTS. -C - M = MOMCOM+1 - PAR2 = PARINT*PARINT - PAR22 = PAR2+0.2D+01 - SINPAR = SIN(PARINT) - COSPAR = COS(PARINT) -C -C COMPUTE THE CHEBYSHEV MOMENTS WITH RESPECT TO COSINE. -C - V(1) = 0.2D+01*SINPAR/PARINT - V(2) = (0.8D+01*COSPAR+(PAR2+PAR2-0.8D+01)*SINPAR/PARINT)/PAR2 - V(3) = (0.32D+02*(PAR2-0.12D+02)*COSPAR+(0.2D+01* - 1 ((PAR2-0.80D+02)*PAR2+0.192D+03)*SINPAR)/PARINT)/(PAR2*PAR2) - AC = 0.8D+01*COSPAR - AS = 0.24D+02*PARINT*SINPAR - IF(ABS(PARINT).GT.0.24D+02) GO TO 30 -C -C COMPUTE THE CHEBYSHEV MOMENTS AS THE SOLUTIONS OF A -C BOUNDARY VALUE PROBLEM WITH 1 INITIAL VALUE (V(3)) AND 1 -C END VALUE (COMPUTED USING AN ASYMPTOTIC FORMULA). -C - NOEQU = 25 - NOEQ1 = NOEQU-1 - AN = 0.6D+01 - DO 20 K = 1,NOEQ1 - AN2 = AN*AN - D(K) = -0.2D+01*(AN2-0.4D+01)*(PAR22-AN2-AN2) - D2(K) = (AN-0.1D+01)*(AN-0.2D+01)*PAR2 - D1(K+1) = (AN+0.3D+01)*(AN+0.4D+01)*PAR2 - V(K+3) = AS-(AN2-0.4D+01)*AC - AN = AN+0.2D+01 - 20 CONTINUE - AN2 = AN*AN - D(NOEQU) = -0.2D+01*(AN2-0.4D+01)*(PAR22-AN2-AN2) - V(NOEQU+3) = AS-(AN2-0.4D+01)*AC - V(4) = V(4)-0.56D+02*PAR2*V(3) - ASS = PARINT*SINPAR - ASAP = (((((0.210D+03*PAR2-0.1D+01)*COSPAR-(0.105D+03*PAR2 - 1 -0.63D+02)*ASS)/AN2-(0.1D+01-0.15D+02*PAR2)*COSPAR - 2 +0.15D+02*ASS)/AN2-COSPAR+0.3D+01*ASS)/AN2-COSPAR)/AN2 - V(NOEQU+3) = V(NOEQU+3)-0.2D+01*ASAP*PAR2*(AN-0.1D+01)* - 1 (AN-0.2D+01) -C -C SOLVE THE TRIDIAGONAL SYSTEM BY MEANS OF GAUSSIAN -C ELIMINATION WITH PARTIAL PIVOTING. -C -C *** CALL TO DGTSL MUST BE REPLACED BY CALL TO -C *** DOUBLE PRECISION VERSION OF LINPACK ROUTINE SGTSL -C - CALL DGTSL(NOEQU,D1,D,D2,V(4),IERS) - GO TO 50 -C -C COMPUTE THE CHEBYSHEV MOMENTS BY MEANS OF FORWARD -C RECURSION. -C - 30 AN = 0.4D+01 - DO 40 I = 4,13 - AN2 = AN*AN - V(I) = ((AN2-0.4D+01)*(0.2D+01*(PAR22-AN2-AN2)*V(I-1)-AC) - 1 +AS-PAR2*(AN+0.1D+01)*(AN+0.2D+01)*V(I-2))/ - 2 (PAR2*(AN-0.1D+01)*(AN-0.2D+01)) - AN = AN+0.2D+01 - 40 CONTINUE - 50 DO 60 J = 1,13 - CHEBMO(M,2*J-1) = V(J) - 60 CONTINUE -C -C COMPUTE THE CHEBYSHEV MOMENTS WITH RESPECT TO SINE. -C - V(1) = 0.2D+01*(SINPAR-PARINT*COSPAR)/PAR2 - V(2) = (0.18D+02-0.48D+02/PAR2)*SINPAR/PAR2 - 1 +(-0.2D+01+0.48D+02/PAR2)*COSPAR/PARINT - AC = -0.24D+02*PARINT*COSPAR - AS = -0.8D+01*SINPAR - IF(ABS(PARINT).GT.0.24D+02) GO TO 80 -C -C COMPUTE THE CHEBYSHEV MOMENTS AS THE SOLUTIONS OF A BOUNDARY -C VALUE PROBLEM WITH 1 INITIAL VALUE (V(2)) AND 1 END VALUE -C (COMPUTED USING AN ASYMPTOTIC FORMULA). -C - AN = 0.5D+01 - DO 70 K = 1,NOEQ1 - AN2 = AN*AN - D(K) = -0.2D+01*(AN2-0.4D+01)*(PAR22-AN2-AN2) - D2(K) = (AN-0.1D+01)*(AN-0.2D+01)*PAR2 - D1(K+1) = (AN+0.3D+01)*(AN+0.4D+01)*PAR2 - V(K+2) = AC+(AN2-0.4D+01)*AS - AN = AN+0.2D+01 - 70 CONTINUE - AN2 = AN*AN - D(NOEQU) = -0.2D+01*(AN2-0.4D+01)*(PAR22-AN2-AN2) - V(NOEQU+2) = AC+(AN2-0.4D+01)*AS - V(3) = V(3)-0.42D+02*PAR2*V(2) - ASS = PARINT*COSPAR - ASAP = (((((0.105D+03*PAR2-0.63D+02)*ASS+(0.210D+03*PAR2 - 1 -0.1D+01)*SINPAR)/AN2+(0.15D+02*PAR2-0.1D+01)*SINPAR- - 2 0.15D+02*ASS)/AN2-0.3D+01*ASS-SINPAR)/AN2-SINPAR)/AN2 - V(NOEQU+2) = V(NOEQU+2)-0.2D+01*ASAP*PAR2*(AN-0.1D+01) - 1 *(AN-0.2D+01) -C -C SOLVE THE TRIDIAGONAL SYSTEM BY MEANS OF GAUSSIAN -C ELIMINATION WITH PARTIAL PIVOTING. -C -C *** CALL TO DGTSL MUST BE REPLACED BY CALL TO -C *** DOUBLE PRECISION VERSION OF LINPACK ROUTINE SGTSL -C - CALL DGTSL(NOEQU,D1,D,D2,V(3),IERS) - GO TO 100 -C -C COMPUTE THE CHEBYSHEV MOMENTS BY MEANS OF FORWARD RECURSION. -C - 80 AN = 0.3D+01 - DO 90 I = 3,12 - AN2 = AN*AN - V(I) = ((AN2-0.4D+01)*(0.2D+01*(PAR22-AN2-AN2)*V(I-1)+AS) - 1 +AC-PAR2*(AN+0.1D+01)*(AN+0.2D+01)*V(I-2)) - 2 /(PAR2*(AN-0.1D+01)*(AN-0.2D+01)) - AN = AN+0.2D+01 - 90 CONTINUE - 100 DO 110 J = 1,12 - CHEBMO(M,2*J) = V(J) - 110 CONTINUE - 120 IF (NRMOM.LT.MOMCOM) M = NRMOM+1 - IF (MOMCOM.LT.(MAXP1-1).AND.NRMOM.GE.MOMCOM) MOMCOM = MOMCOM+1 -C -C COMPUTE THE COEFFICIENTS OF THE CHEBYSHEV EXPANSIONS -C OF DEGREES 12 AND 24 OF THE FUNCTION F. -C - FVAL(1) = 0.5D+00*F(CENTR+HLGTH) - FVAL(13) = F(CENTR) - FVAL(25) = 0.5D+00*F(CENTR-HLGTH) - DO 130 I = 2,12 - ISYM = 26-I - FVAL(I) = F(HLGTH*X(I-1)+CENTR) - FVAL(ISYM) = F(CENTR-HLGTH*X(I-1)) - 130 CONTINUE - CALL DQCHEB(X,FVAL,CHEB12,CHEB24) -C -C COMPUTE THE INTEGRAL AND ERROR ESTIMATES. -C - RESC12 = CHEB12(13)*CHEBMO(M,13) - RESS12 = 0.0D+00 - K = 11 - DO 140 J = 1,6 - RESC12 = RESC12+CHEB12(K)*CHEBMO(M,K) - RESS12 = RESS12+CHEB12(K+1)*CHEBMO(M,K+1) - K = K-2 - 140 CONTINUE - RESC24 = CHEB24(25)*CHEBMO(M,25) - RESS24 = 0.0D+00 - RESABS = ABS(CHEB24(25)) - K = 23 - DO 150 J = 1,12 - RESC24 = RESC24+CHEB24(K)*CHEBMO(M,K) - RESS24 = RESS24+CHEB24(K+1)*CHEBMO(M,K+1) - RESABS = ABS(CHEB24(K))+ABS(CHEB24(K+1)) - K = K-2 - 150 CONTINUE - ESTC = ABS(RESC24-RESC12) - ESTS = ABS(RESS24-RESS12) - RESABS = RESABS*ABS(HLGTH) - IF(INTEGR.EQ.2) GO TO 160 - RESULT = CONC*RESC24-CONS*RESS24 - ABSERR = ABS(CONC*ESTC)+ABS(CONS*ESTS) - GO TO 170 - 160 RESULT = CONC*RESS24+CONS*RESC24 - ABSERR = ABS(CONC*ESTS)+ABS(CONS*ESTC) - 170 RETURN - END diff --git a/slatec/dqc25s.f b/slatec/dqc25s.f deleted file mode 100644 index 1ddf1a7..0000000 --- a/slatec/dqc25s.f +++ /dev/null @@ -1,345 +0,0 @@ -*DECK DQC25S - SUBROUTINE DQC25S (F, A, B, BL, BR, ALFA, BETA, RI, RJ, RG, RH, - + RESULT, ABSERR, RESASC, INTEGR, NEV) -C***BEGIN PROLOGUE DQC25S -C***PURPOSE To compute I = Integral of F*W over (BL,BR), with error -C estimate, where the weight function W has a singular -C behaviour of ALGEBRAICO-LOGARITHMIC type at the points -C A and/or B. (BL,BR) is a part of (A,B). -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A2A2 -C***TYPE DOUBLE PRECISION (QC25S-S, DQC25S-D) -C***KEYWORDS 25-POINT CLENSHAW-CURTIS INTEGRATION, QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration rules for integrands having ALGEBRAICO-LOGARITHMIC -C end point singularities -C Standard fortran subroutine -C Double precision version -C -C PARAMETERS -C F - Double precision -C Function subprogram defining the integrand -C F(X). The actual name for F needs to be declared -C E X T E R N A L in the driver program. -C -C A - Double precision -C Left end point of the original interval -C -C B - Double precision -C Right end point of the original interval, B.GT.A -C -C BL - Double precision -C Lower limit of integration, BL.GE.A -C -C BR - Double precision -C Upper limit of integration, BR.LE.B -C -C ALFA - Double precision -C PARAMETER IN THE WEIGHT FUNCTION -C -C BETA - Double precision -C Parameter in the weight function -C -C RI,RJ,RG,RH - Double precision -C Modified CHEBYSHEV moments for the application -C of the generalized CLENSHAW-CURTIS -C method (computed in subroutine DQMOMO) -C -C RESULT - Double precision -C Approximation to the integral -C RESULT is computed by using a generalized -C CLENSHAW-CURTIS method if B1 = A or BR = B. -C in all other cases the 15-POINT KRONROD -C RULE is applied, obtained by optimal addition of -C Abscissae to the 7-POINT GAUSS RULE. -C -C ABSERR - Double precision -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C RESASC - Double precision -C Approximation to the integral of ABS(F*W-I/(B-A)) -C -C INTEGR - Integer -C Which determines the weight function -C = 1 W(X) = (X-A)**ALFA*(B-X)**BETA -C = 2 W(X) = (X-A)**ALFA*(B-X)**BETA*LOG(X-A) -C = 3 W(X) = (X-A)**ALFA*(B-X)**BETA*LOG(B-X) -C = 4 W(X) = (X-A)**ALFA*(B-X)**BETA*LOG(X-A)* -C LOG(B-X) -C -C NEV - Integer -C Number of integrand evaluations -C -C***REFERENCES (NONE) -C***ROUTINES CALLED DQCHEB, DQK15W, DQWGTS -C***REVISION HISTORY (YYMMDD) -C 810101 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***END PROLOGUE DQC25S -C - DOUBLE PRECISION A,ABSERR,ALFA,B,BETA,BL,BR,CENTR,CHEB12,CHEB24, - 1 DC,F,FACTOR,FIX,FVAL,HLGTH,RESABS,RESASC,RESULT,RES12, - 2 RES24,RG,RH,RI,RJ,U,DQWGTS,X - INTEGER I,INTEGR,ISYM,NEV -C - DIMENSION CHEB12(13),CHEB24(25),FVAL(25),RG(25),RH(25),RI(25), - 1 RJ(25),X(11) -C - EXTERNAL F, DQWGTS -C -C THE VECTOR X CONTAINS THE VALUES COS(K*PI/24) -C K = 1, ..., 11, TO BE USED FOR THE COMPUTATION OF THE -C CHEBYSHEV SERIES EXPANSION OF F. -C - SAVE X - DATA X(1),X(2),X(3),X(4),X(5),X(6),X(7),X(8),X(9),X(10),X(11)/ - 1 0.9914448613738104D+00, 0.9659258262890683D+00, - 2 0.9238795325112868D+00, 0.8660254037844386D+00, - 3 0.7933533402912352D+00, 0.7071067811865475D+00, - 4 0.6087614290087206D+00, 0.5000000000000000D+00, - 5 0.3826834323650898D+00, 0.2588190451025208D+00, - 6 0.1305261922200516D+00/ -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C FVAL - VALUE OF THE FUNCTION F AT THE POINTS -C (BR-BL)*0.5*COS(K*PI/24)+(BR+BL)*0.5 -C K = 0, ..., 24 -C CHEB12 - COEFFICIENTS OF THE CHEBYSHEV SERIES EXPANSION -C OF DEGREE 12, FOR THE FUNCTION F, IN THE -C INTERVAL (BL,BR) -C CHEB24 - COEFFICIENTS OF THE CHEBYSHEV SERIES EXPANSION -C OF DEGREE 24, FOR THE FUNCTION F, IN THE -C INTERVAL (BL,BR) -C RES12 - APPROXIMATION TO THE INTEGRAL OBTAINED FROM CHEB12 -C RES24 - APPROXIMATION TO THE INTEGRAL OBTAINED FROM CHEB24 -C DQWGTS - EXTERNAL FUNCTION SUBPROGRAM DEFINING -C THE FOUR POSSIBLE WEIGHT FUNCTIONS -C HLGTH - HALF-LENGTH OF THE INTERVAL (BL,BR) -C CENTR - MID POINT OF THE INTERVAL (BL,BR) -C -C***FIRST EXECUTABLE STATEMENT DQC25S - NEV = 25 - IF(BL.EQ.A.AND.(ALFA.NE.0.0D+00.OR.INTEGR.EQ.2.OR.INTEGR.EQ.4)) - 1 GO TO 10 - IF(BR.EQ.B.AND.(BETA.NE.0.0D+00.OR.INTEGR.EQ.3.OR.INTEGR.EQ.4)) - 1 GO TO 140 -C -C IF A.GT.BL AND B.LT.BR, APPLY THE 15-POINT GAUSS-KRONROD -C SCHEME. -C -C - CALL DQK15W(F,DQWGTS,A,B,ALFA,BETA,INTEGR,BL,BR, - 1 RESULT,ABSERR,RESABS,RESASC) - NEV = 15 - GO TO 270 -C -C THIS PART OF THE PROGRAM IS EXECUTED ONLY IF A = BL. -C ---------------------------------------------------- -C -C COMPUTE THE CHEBYSHEV SERIES EXPANSION OF THE -C FOLLOWING FUNCTION -C F1 = (0.5*(B+B-BR-A)-0.5*(BR-A)*X)**BETA -C *F(0.5*(BR-A)*X+0.5*(BR+A)) -C - 10 HLGTH = 0.5D+00*(BR-BL) - CENTR = 0.5D+00*(BR+BL) - FIX = B-CENTR - FVAL(1) = 0.5D+00*F(HLGTH+CENTR)*(FIX-HLGTH)**BETA - FVAL(13) = F(CENTR)*(FIX**BETA) - FVAL(25) = 0.5D+00*F(CENTR-HLGTH)*(FIX+HLGTH)**BETA - DO 20 I=2,12 - U = HLGTH*X(I-1) - ISYM = 26-I - FVAL(I) = F(U+CENTR)*(FIX-U)**BETA - FVAL(ISYM) = F(CENTR-U)*(FIX+U)**BETA - 20 CONTINUE - FACTOR = HLGTH**(ALFA+0.1D+01) - RESULT = 0.0D+00 - ABSERR = 0.0D+00 - RES12 = 0.0D+00 - RES24 = 0.0D+00 - IF(INTEGR.GT.2) GO TO 70 - CALL DQCHEB(X,FVAL,CHEB12,CHEB24) -C -C INTEGR = 1 (OR 2) -C - DO 30 I=1,13 - RES12 = RES12+CHEB12(I)*RI(I) - RES24 = RES24+CHEB24(I)*RI(I) - 30 CONTINUE - DO 40 I=14,25 - RES24 = RES24+CHEB24(I)*RI(I) - 40 CONTINUE - IF(INTEGR.EQ.1) GO TO 130 -C -C INTEGR = 2 -C - DC = LOG(BR-BL) - RESULT = RES24*DC - ABSERR = ABS((RES24-RES12)*DC) - RES12 = 0.0D+00 - RES24 = 0.0D+00 - DO 50 I=1,13 - RES12 = RES12+CHEB12(I)*RG(I) - RES24 = RES12+CHEB24(I)*RG(I) - 50 CONTINUE - DO 60 I=14,25 - RES24 = RES24+CHEB24(I)*RG(I) - 60 CONTINUE - GO TO 130 -C -C COMPUTE THE CHEBYSHEV SERIES EXPANSION OF THE -C FOLLOWING FUNCTION -C F4 = F1*LOG(0.5*(B+B-BR-A)-0.5*(BR-A)*X) -C - 70 FVAL(1) = FVAL(1)*LOG(FIX-HLGTH) - FVAL(13) = FVAL(13)*LOG(FIX) - FVAL(25) = FVAL(25)*LOG(FIX+HLGTH) - DO 80 I=2,12 - U = HLGTH*X(I-1) - ISYM = 26-I - FVAL(I) = FVAL(I)*LOG(FIX-U) - FVAL(ISYM) = FVAL(ISYM)*LOG(FIX+U) - 80 CONTINUE - CALL DQCHEB(X,FVAL,CHEB12,CHEB24) -C -C INTEGR = 3 (OR 4) -C - DO 90 I=1,13 - RES12 = RES12+CHEB12(I)*RI(I) - RES24 = RES24+CHEB24(I)*RI(I) - 90 CONTINUE - DO 100 I=14,25 - RES24 = RES24+CHEB24(I)*RI(I) - 100 CONTINUE - IF(INTEGR.EQ.3) GO TO 130 -C -C INTEGR = 4 -C - DC = LOG(BR-BL) - RESULT = RES24*DC - ABSERR = ABS((RES24-RES12)*DC) - RES12 = 0.0D+00 - RES24 = 0.0D+00 - DO 110 I=1,13 - RES12 = RES12+CHEB12(I)*RG(I) - RES24 = RES24+CHEB24(I)*RG(I) - 110 CONTINUE - DO 120 I=14,25 - RES24 = RES24+CHEB24(I)*RG(I) - 120 CONTINUE - 130 RESULT = (RESULT+RES24)*FACTOR - ABSERR = (ABSERR+ABS(RES24-RES12))*FACTOR - GO TO 270 -C -C THIS PART OF THE PROGRAM IS EXECUTED ONLY IF B = BR. -C ---------------------------------------------------- -C -C COMPUTE THE CHEBYSHEV SERIES EXPANSION OF THE -C FOLLOWING FUNCTION -C F2 = (0.5*(B+BL-A-A)+0.5*(B-BL)*X)**ALFA -C *F(0.5*(B-BL)*X+0.5*(B+BL)) -C - 140 HLGTH = 0.5D+00*(BR-BL) - CENTR = 0.5D+00*(BR+BL) - FIX = CENTR-A - FVAL(1) = 0.5D+00*F(HLGTH+CENTR)*(FIX+HLGTH)**ALFA - FVAL(13) = F(CENTR)*(FIX**ALFA) - FVAL(25) = 0.5D+00*F(CENTR-HLGTH)*(FIX-HLGTH)**ALFA - DO 150 I=2,12 - U = HLGTH*X(I-1) - ISYM = 26-I - FVAL(I) = F(U+CENTR)*(FIX+U)**ALFA - FVAL(ISYM) = F(CENTR-U)*(FIX-U)**ALFA - 150 CONTINUE - FACTOR = HLGTH**(BETA+0.1D+01) - RESULT = 0.0D+00 - ABSERR = 0.0D+00 - RES12 = 0.0D+00 - RES24 = 0.0D+00 - IF(INTEGR.EQ.2.OR.INTEGR.EQ.4) GO TO 200 -C -C INTEGR = 1 (OR 3) -C - CALL DQCHEB(X,FVAL,CHEB12,CHEB24) - DO 160 I=1,13 - RES12 = RES12+CHEB12(I)*RJ(I) - RES24 = RES24+CHEB24(I)*RJ(I) - 160 CONTINUE - DO 170 I=14,25 - RES24 = RES24+CHEB24(I)*RJ(I) - 170 CONTINUE - IF(INTEGR.EQ.1) GO TO 260 -C -C INTEGR = 3 -C - DC = LOG(BR-BL) - RESULT = RES24*DC - ABSERR = ABS((RES24-RES12)*DC) - RES12 = 0.0D+00 - RES24 = 0.0D+00 - DO 180 I=1,13 - RES12 = RES12+CHEB12(I)*RH(I) - RES24 = RES24+CHEB24(I)*RH(I) - 180 CONTINUE - DO 190 I=14,25 - RES24 = RES24+CHEB24(I)*RH(I) - 190 CONTINUE - GO TO 260 -C -C COMPUTE THE CHEBYSHEV SERIES EXPANSION OF THE -C FOLLOWING FUNCTION -C F3 = F2*LOG(0.5*(B-BL)*X+0.5*(B+BL-A-A)) -C - 200 FVAL(1) = FVAL(1)*LOG(FIX+HLGTH) - FVAL(13) = FVAL(13)*LOG(FIX) - FVAL(25) = FVAL(25)*LOG(FIX-HLGTH) - DO 210 I=2,12 - U = HLGTH*X(I-1) - ISYM = 26-I - FVAL(I) = FVAL(I)*LOG(U+FIX) - FVAL(ISYM) = FVAL(ISYM)*LOG(FIX-U) - 210 CONTINUE - CALL DQCHEB(X,FVAL,CHEB12,CHEB24) -C -C INTEGR = 2 (OR 4) -C - DO 220 I=1,13 - RES12 = RES12+CHEB12(I)*RJ(I) - RES24 = RES24+CHEB24(I)*RJ(I) - 220 CONTINUE - DO 230 I=14,25 - RES24 = RES24+CHEB24(I)*RJ(I) - 230 CONTINUE - IF(INTEGR.EQ.2) GO TO 260 - DC = LOG(BR-BL) - RESULT = RES24*DC - ABSERR = ABS((RES24-RES12)*DC) - RES12 = 0.0D+00 - RES24 = 0.0D+00 -C -C INTEGR = 4 -C - DO 240 I=1,13 - RES12 = RES12+CHEB12(I)*RH(I) - RES24 = RES24+CHEB24(I)*RH(I) - 240 CONTINUE - DO 250 I=14,25 - RES24 = RES24+CHEB24(I)*RH(I) - 250 CONTINUE - 260 RESULT = (RESULT+RES24)*FACTOR - ABSERR = (ABSERR+ABS(RES24-RES12))*FACTOR - 270 RETURN - END diff --git a/slatec/dqcheb.f b/slatec/dqcheb.f deleted file mode 100644 index bb0ff8e..0000000 --- a/slatec/dqcheb.f +++ /dev/null @@ -1,160 +0,0 @@ -*DECK DQCHEB - SUBROUTINE DQCHEB (X, FVAL, CHEB12, CHEB24) -C***BEGIN PROLOGUE DQCHEB -C***SUBSIDIARY -C***PURPOSE This routine computes the CHEBYSHEV series expansion -C of degrees 12 and 24 of a function using A -C FAST FOURIER TRANSFORM METHOD -C F(X) = SUM(K=1,..,13) (CHEB12(K)*T(K-1,X)), -C F(X) = SUM(K=1,..,25) (CHEB24(K)*T(K-1,X)), -C Where T(K,X) is the CHEBYSHEV POLYNOMIAL OF DEGREE K. -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (QCHEB-S, DQCHEB-D) -C***KEYWORDS CHEBYSHEV SERIES EXPANSION, FAST FOURIER TRANSFORM -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Chebyshev Series Expansion -C Standard Fortran Subroutine -C Double precision version -C -C PARAMETERS -C ON ENTRY -C X - Double precision -C Vector of dimension 11 containing the -C Values COS(K*PI/24), K = 1, ..., 11 -C -C FVAL - Double precision -C Vector of dimension 25 containing the -C function values at the points -C (B+A+(B-A)*COS(K*PI/24))/2, K = 0, ...,24, -C where (A,B) is the approximation interval. -C FVAL(1) and FVAL(25) are divided by two -C (these values are destroyed at output). -C -C ON RETURN -C CHEB12 - Double precision -C Vector of dimension 13 containing the -C CHEBYSHEV coefficients for degree 12 -C -C CHEB24 - Double precision -C Vector of dimension 25 containing the -C CHEBYSHEV Coefficients for degree 24 -C -C***SEE ALSO DQC25C, DQC25F, DQC25S -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 810101 DATE WRITTEN -C 830518 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DQCHEB -C - DOUBLE PRECISION ALAM,ALAM1,ALAM2,CHEB12,CHEB24,FVAL,PART1,PART2, - 1 PART3,V,X - INTEGER I,J -C - DIMENSION CHEB12(13),CHEB24(25),FVAL(25),V(12),X(11) -C -C***FIRST EXECUTABLE STATEMENT DQCHEB - DO 10 I=1,12 - J = 26-I - V(I) = FVAL(I)-FVAL(J) - FVAL(I) = FVAL(I)+FVAL(J) - 10 CONTINUE - ALAM1 = V(1)-V(9) - ALAM2 = X(6)*(V(3)-V(7)-V(11)) - CHEB12(4) = ALAM1+ALAM2 - CHEB12(10) = ALAM1-ALAM2 - ALAM1 = V(2)-V(8)-V(10) - ALAM2 = V(4)-V(6)-V(12) - ALAM = X(3)*ALAM1+X(9)*ALAM2 - CHEB24(4) = CHEB12(4)+ALAM - CHEB24(22) = CHEB12(4)-ALAM - ALAM = X(9)*ALAM1-X(3)*ALAM2 - CHEB24(10) = CHEB12(10)+ALAM - CHEB24(16) = CHEB12(10)-ALAM - PART1 = X(4)*V(5) - PART2 = X(8)*V(9) - PART3 = X(6)*V(7) - ALAM1 = V(1)+PART1+PART2 - ALAM2 = X(2)*V(3)+PART3+X(10)*V(11) - CHEB12(2) = ALAM1+ALAM2 - CHEB12(12) = ALAM1-ALAM2 - ALAM = X(1)*V(2)+X(3)*V(4)+X(5)*V(6)+X(7)*V(8) - 1 +X(9)*V(10)+X(11)*V(12) - CHEB24(2) = CHEB12(2)+ALAM - CHEB24(24) = CHEB12(2)-ALAM - ALAM = X(11)*V(2)-X(9)*V(4)+X(7)*V(6)-X(5)*V(8) - 1 +X(3)*V(10)-X(1)*V(12) - CHEB24(12) = CHEB12(12)+ALAM - CHEB24(14) = CHEB12(12)-ALAM - ALAM1 = V(1)-PART1+PART2 - ALAM2 = X(10)*V(3)-PART3+X(2)*V(11) - CHEB12(6) = ALAM1+ALAM2 - CHEB12(8) = ALAM1-ALAM2 - ALAM = X(5)*V(2)-X(9)*V(4)-X(1)*V(6) - 1 -X(11)*V(8)+X(3)*V(10)+X(7)*V(12) - CHEB24(6) = CHEB12(6)+ALAM - CHEB24(20) = CHEB12(6)-ALAM - ALAM = X(7)*V(2)-X(3)*V(4)-X(11)*V(6)+X(1)*V(8) - 1 -X(9)*V(10)-X(5)*V(12) - CHEB24(8) = CHEB12(8)+ALAM - CHEB24(18) = CHEB12(8)-ALAM - DO 20 I=1,6 - J = 14-I - V(I) = FVAL(I)-FVAL(J) - FVAL(I) = FVAL(I)+FVAL(J) - 20 CONTINUE - ALAM1 = V(1)+X(8)*V(5) - ALAM2 = X(4)*V(3) - CHEB12(3) = ALAM1+ALAM2 - CHEB12(11) = ALAM1-ALAM2 - CHEB12(7) = V(1)-V(5) - ALAM = X(2)*V(2)+X(6)*V(4)+X(10)*V(6) - CHEB24(3) = CHEB12(3)+ALAM - CHEB24(23) = CHEB12(3)-ALAM - ALAM = X(6)*(V(2)-V(4)-V(6)) - CHEB24(7) = CHEB12(7)+ALAM - CHEB24(19) = CHEB12(7)-ALAM - ALAM = X(10)*V(2)-X(6)*V(4)+X(2)*V(6) - CHEB24(11) = CHEB12(11)+ALAM - CHEB24(15) = CHEB12(11)-ALAM - DO 30 I=1,3 - J = 8-I - V(I) = FVAL(I)-FVAL(J) - FVAL(I) = FVAL(I)+FVAL(J) - 30 CONTINUE - CHEB12(5) = V(1)+X(8)*V(3) - CHEB12(9) = FVAL(1)-X(8)*FVAL(3) - ALAM = X(4)*V(2) - CHEB24(5) = CHEB12(5)+ALAM - CHEB24(21) = CHEB12(5)-ALAM - ALAM = X(8)*FVAL(2)-FVAL(4) - CHEB24(9) = CHEB12(9)+ALAM - CHEB24(17) = CHEB12(9)-ALAM - CHEB12(1) = FVAL(1)+FVAL(3) - ALAM = FVAL(2)+FVAL(4) - CHEB24(1) = CHEB12(1)+ALAM - CHEB24(25) = CHEB12(1)-ALAM - CHEB12(13) = V(1)-V(3) - CHEB24(13) = CHEB12(13) - ALAM = 0.1D+01/0.6D+01 - DO 40 I=2,12 - CHEB12(I) = CHEB12(I)*ALAM - 40 CONTINUE - ALAM = 0.5D+00*ALAM - CHEB12(1) = CHEB12(1)*ALAM - CHEB12(13) = CHEB12(13)*ALAM - DO 50 I=2,24 - CHEB24(I) = CHEB24(I)*ALAM - 50 CONTINUE - CHEB24(1) = 0.5D+00*ALAM*CHEB24(1) - CHEB24(25) = 0.5D+00*ALAM*CHEB24(25) - RETURN - END diff --git a/slatec/dqdota.f b/slatec/dqdota.f deleted file mode 100644 index b8b854d..0000000 --- a/slatec/dqdota.f +++ /dev/null @@ -1,89 +0,0 @@ -*DECK DQDOTA - DOUBLE PRECISION FUNCTION DQDOTA (N, DB, QC, DX, INCX, DY, INCY) -C***BEGIN PROLOGUE DQDOTA -C***PURPOSE Compute the inner product of two vectors with extended -C precision accumulation and result. -C***LIBRARY SLATEC -C***CATEGORY D1A4 -C***TYPE DOUBLE PRECISION (DQDOTA-D) -C***KEYWORDS DOT PRODUCT, INNER PRODUCT -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 DB double precision scalar to be added to inner product -C QC extended precision scalar to be added to inner product -C DX double precision vector with N elements -C INCX storage spacing between elements of DX -C DY double precision vector with N elements -C INCY storage spacing between elements of DY -C -C --Output-- -C DQDOTA double precision result -C QC extended precision result -C -C D.P. dot product with extended precision accumulation (and result) -C QC and DQDOTA are set = DB + QC + sum for I = 0 to N-1 of -C DX(LX+I*INCX) * DY(LY+I*INCY), where QC is an extended -C precision result previously computed by DQDOTI or DQDOTA -C and LX = 1 if INCX .GE. 0, else LX = (-INCX)*N, and LY is -C defined in a similar way using INCY. The MP package by -C Richard P. Brent is used for the extended precision arithmetic. -C -C Fred T. Krogh, JPL, 1977, June 1 -C -C The common block for the MP package is name MPCOM. If local -C variable I1 is zero, DQDOTA calls MPBLAS to initialize -C the MP package and reset I1 to 1. -C -C The argument QC(*) and the local variables QX and QY are INTEGER -C arrays of size 30. See the comments in the routine MPBLAS for the -C reason for this choice. -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 MPADD, MPBLAS, MPCDM, MPCMD, MPMUL -C***COMMON BLOCKS MPCOM -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 920501 Reformatted the REFERENCES section. (WRB) -C 930124 Increased Array sizes for SUN -r8. (RWC) -C***END PROLOGUE DQDOTA - DOUBLE PRECISION DX(*), DY(*), DB - INTEGER QC(30), QX(30), QY(30) - COMMON /MPCOM/ MPB, MPT, MPM, MPLUN, MPMXR, MPR(30) - SAVE I1 - DATA I1 / 0 / -C***FIRST EXECUTABLE STATEMENT DQDOTA - IF (I1 .EQ. 0) CALL MPBLAS(I1) - IF (DB .EQ. 0.D0) GO TO 20 - CALL MPCDM(DB, QX) - CALL MPADD(QC, QX, QC) - 20 IF (N .EQ. 0) GO TO 40 - IX = 1 - IY = 1 - IF (INCX .LT. 0) IX = (-N + 1) * INCX + 1 - IF (INCY .LT. 0) IY = (-N + 1) * INCY + 1 - DO 30 I = 1,N - CALL MPCDM(DX(IX), QX) - CALL MPCDM(DY(IY), QY) - CALL MPMUL(QX, QY, QX) - CALL MPADD(QC, QX, QC) - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - 40 CALL MPCMD(QC, DQDOTA) - RETURN - END diff --git a/slatec/dqdoti.f b/slatec/dqdoti.f deleted file mode 100644 index 7c214b5..0000000 --- a/slatec/dqdoti.f +++ /dev/null @@ -1,90 +0,0 @@ -*DECK DQDOTI - DOUBLE PRECISION FUNCTION DQDOTI (N, DB, QC, DX, INCX, DY, INCY) -C***BEGIN PROLOGUE DQDOTI -C***PURPOSE Compute the inner product of two vectors with extended -C precision accumulation and result. -C***LIBRARY SLATEC -C***CATEGORY D1A4 -C***TYPE DOUBLE PRECISION (DQDOTI-D) -C***KEYWORDS DOT PRODUCT, INNER PRODUCT -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 DB double precision scalar to be added to inner product -C QC extended precision scalar to be added -C DX double precision vector with N elements -C INCX storage spacing between elements of DX -C DY double precision vector with N elements -C INCY storage spacing between elements of DY -C -C --Output-- -C DQDOTI double precision result -C QC extended precision result -C -C D.P. dot product with extended precision accumulation (and result) -C QC and DQDOTI are set = DB + sum for I = 0 to N-1 of -C DX(LX+I*INCX) * DY(LY+I*INCY), where QC is an extended -C precision result which can be used as input to DQDOTA, -C and LX = 1 if INCX .GE. 0, else LX = (-INCX)*N, and LY is -C defined in a similar way using INCY. The MP package by -C Richard P. Brent is used for the extended precision arithmetic. -C -C Fred T. Krogh, JPL, 1977, June 1 -C -C The common block for the MP package is named MPCOM. If local -C variable I1 is zero, DQDOTI calls MPBLAS to initialize the MP -C package and reset I1 to 1. -C -C The argument QC(*), and the local variables QX and QY are INTEGER -C arrays of size 30. See the comments in the routine MPBLAS for the -C reason for this choice. -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 MPADD, MPBLAS, MPCDM, MPCMD, MPMUL -C***COMMON BLOCKS MPCOM -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 920501 Reformatted the REFERENCES section. (WRB) -C 930124 Increased Array sizes for SUN -r8. (RWC) -C***END PROLOGUE DQDOTI - DOUBLE PRECISION DX(*), DY(*), DB - INTEGER QC(30), QX(30), QY(30) - COMMON /MPCOM/ MPB, MPT, MPM, MPLUN, MPMXR, MPR(30) - SAVE I1 - DATA I1 / 0 / -C***FIRST EXECUTABLE STATEMENT DQDOTI - IF (I1 .EQ. 0) CALL MPBLAS(I1) - QC(1) = 0 - IF (DB .EQ. 0.D0) GO TO 60 - CALL MPCDM(DB, QX) - CALL MPADD(QC, QX, QC) - 60 IF (N .EQ. 0) GO TO 80 - IX = 1 - IY = 1 - IF (INCX .LT. 0) IX = (-N + 1) * INCX + 1 - IF (INCY .LT. 0) IY = (-N + 1) * INCY + 1 - DO 70 I = 1,N - CALL MPCDM(DX(IX), QX) - CALL MPCDM(DY(IY), QY) - CALL MPMUL(QX, QY, QX) - CALL MPADD(QC, QX, QC) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - 80 CALL MPCMD(QC, DQDOTI) - RETURN - END diff --git a/slatec/dqelg.f b/slatec/dqelg.f deleted file mode 100644 index c3b13a1..0000000 --- a/slatec/dqelg.f +++ /dev/null @@ -1,196 +0,0 @@ -*DECK DQELG - SUBROUTINE DQELG (N, EPSTAB, RESULT, ABSERR, RES3LA, NRES) -C***BEGIN PROLOGUE DQELG -C***SUBSIDIARY -C***PURPOSE The routine determines the limit of a given sequence of -C approximations, by means of the Epsilon algorithm of -C P.Wynn. An estimate of the absolute error is also given. -C The condensed Epsilon table is computed. Only those -C elements needed for the computation of the next diagonal -C are preserved. -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (QELG-S, DQELG-D) -C***KEYWORDS CONVERGENCE ACCELERATION, EPSILON ALGORITHM, EXTRAPOLATION -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Epsilon algorithm -C Standard fortran subroutine -C Double precision version -C -C PARAMETERS -C N - Integer -C EPSTAB(N) contains the new element in the -C first column of the epsilon table. -C -C EPSTAB - Double precision -C Vector of dimension 52 containing the elements -C of the two lower diagonals of the triangular -C epsilon table. The elements are numbered -C starting at the right-hand corner of the -C triangle. -C -C RESULT - Double precision -C Resulting approximation to the integral -C -C ABSERR - Double precision -C Estimate of the absolute error computed from -C RESULT and the 3 previous results -C -C RES3LA - Double precision -C Vector of dimension 3 containing the last 3 -C results -C -C NRES - Integer -C Number of calls to the routine -C (should be zero at first call) -C -C***SEE ALSO DQAGIE, DQAGOE, DQAGPE, DQAGSE -C***ROUTINES CALLED D1MACH -C***REVISION HISTORY (YYMMDD) -C 800101 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 900328 Added TYPE section. (WRB) -C***END PROLOGUE DQELG -C - DOUBLE PRECISION ABSERR,DELTA1,DELTA2,DELTA3,D1MACH, - 1 EPMACH,EPSINF,EPSTAB,ERROR,ERR1,ERR2,ERR3,E0,E1,E1ABS,E2,E3, - 2 OFLOW,RES,RESULT,RES3LA,SS,TOL1,TOL2,TOL3 - INTEGER I,IB,IB2,IE,INDX,K1,K2,K3,LIMEXP,N,NEWELM,NRES,NUM - DIMENSION EPSTAB(52),RES3LA(3) -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C E0 - THE 4 ELEMENTS ON WHICH THE COMPUTATION OF A NEW -C E1 ELEMENT IN THE EPSILON TABLE IS BASED -C E2 -C E3 E0 -C E3 E1 NEW -C E2 -C NEWELM - NUMBER OF ELEMENTS TO BE COMPUTED IN THE NEW -C DIAGONAL -C ERROR - ERROR = ABS(E1-E0)+ABS(E2-E1)+ABS(NEW-E2) -C RESULT - THE ELEMENT IN THE NEW DIAGONAL WITH LEAST VALUE -C OF ERROR -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C OFLOW IS THE LARGEST POSITIVE MAGNITUDE. -C LIMEXP IS THE MAXIMUM NUMBER OF ELEMENTS THE EPSILON -C TABLE CAN CONTAIN. IF THIS NUMBER IS REACHED, THE UPPER -C DIAGONAL OF THE EPSILON TABLE IS DELETED. -C -C***FIRST EXECUTABLE STATEMENT DQELG - EPMACH = D1MACH(4) - OFLOW = D1MACH(2) - NRES = NRES+1 - ABSERR = OFLOW - RESULT = EPSTAB(N) - IF(N.LT.3) GO TO 100 - LIMEXP = 50 - EPSTAB(N+2) = EPSTAB(N) - NEWELM = (N-1)/2 - EPSTAB(N) = OFLOW - NUM = N - K1 = N - DO 40 I = 1,NEWELM - K2 = K1-1 - K3 = K1-2 - RES = EPSTAB(K1+2) - E0 = EPSTAB(K3) - E1 = EPSTAB(K2) - E2 = RES - E1ABS = ABS(E1) - DELTA2 = E2-E1 - ERR2 = ABS(DELTA2) - TOL2 = MAX(ABS(E2),E1ABS)*EPMACH - DELTA3 = E1-E0 - ERR3 = ABS(DELTA3) - TOL3 = MAX(E1ABS,ABS(E0))*EPMACH - IF(ERR2.GT.TOL2.OR.ERR3.GT.TOL3) GO TO 10 -C -C IF E0, E1 AND E2 ARE EQUAL TO WITHIN MACHINE -C ACCURACY, CONVERGENCE IS ASSUMED. -C RESULT = E2 -C ABSERR = ABS(E1-E0)+ABS(E2-E1) -C - RESULT = RES - ABSERR = ERR2+ERR3 -C ***JUMP OUT OF DO-LOOP - GO TO 100 - 10 E3 = EPSTAB(K1) - EPSTAB(K1) = E1 - DELTA1 = E1-E3 - ERR1 = ABS(DELTA1) - TOL1 = MAX(E1ABS,ABS(E3))*EPMACH -C -C IF TWO ELEMENTS ARE VERY CLOSE TO EACH OTHER, OMIT -C A PART OF THE TABLE BY ADJUSTING THE VALUE OF N -C - IF(ERR1.LE.TOL1.OR.ERR2.LE.TOL2.OR.ERR3.LE.TOL3) GO TO 20 - SS = 0.1D+01/DELTA1+0.1D+01/DELTA2-0.1D+01/DELTA3 - EPSINF = ABS(SS*E1) -C -C TEST TO DETECT IRREGULAR BEHAVIOUR IN THE TABLE, AND -C EVENTUALLY OMIT A PART OF THE TABLE ADJUSTING THE VALUE -C OF N. -C - IF(EPSINF.GT.0.1D-03) GO TO 30 - 20 N = I+I-1 -C ***JUMP OUT OF DO-LOOP - GO TO 50 -C -C COMPUTE A NEW ELEMENT AND EVENTUALLY ADJUST -C THE VALUE OF RESULT. -C - 30 RES = E1+0.1D+01/SS - EPSTAB(K1) = RES - K1 = K1-2 - ERROR = ERR2+ABS(RES-E2)+ERR3 - IF(ERROR.GT.ABSERR) GO TO 40 - ABSERR = ERROR - RESULT = RES - 40 CONTINUE -C -C SHIFT THE TABLE. -C - 50 IF(N.EQ.LIMEXP) N = 2*(LIMEXP/2)-1 - IB = 1 - IF((NUM/2)*2.EQ.NUM) IB = 2 - IE = NEWELM+1 - DO 60 I=1,IE - IB2 = IB+2 - EPSTAB(IB) = EPSTAB(IB2) - IB = IB2 - 60 CONTINUE - IF(NUM.EQ.N) GO TO 80 - INDX = NUM-N+1 - DO 70 I = 1,N - EPSTAB(I)= EPSTAB(INDX) - INDX = INDX+1 - 70 CONTINUE - 80 IF(NRES.GE.4) GO TO 90 - RES3LA(NRES) = RESULT - ABSERR = OFLOW - GO TO 100 -C -C COMPUTE ERROR ESTIMATE -C - 90 ABSERR = ABS(RESULT-RES3LA(3))+ABS(RESULT-RES3LA(2)) - 1 +ABS(RESULT-RES3LA(1)) - RES3LA(1) = RES3LA(2) - RES3LA(2) = RES3LA(3) - RES3LA(3) = RESULT - 100 ABSERR = MAX(ABSERR,0.5D+01*EPMACH*ABS(RESULT)) - RETURN - END diff --git a/slatec/dqform.f b/slatec/dqform.f deleted file mode 100644 index 7971586..0000000 --- a/slatec/dqform.f +++ /dev/null @@ -1,103 +0,0 @@ -*DECK DQFORM - SUBROUTINE DQFORM (M, N, Q, LDQ, WA) -C***BEGIN PROLOGUE DQFORM -C***SUBSIDIARY -C***PURPOSE Subsidiary to DNSQ and DNSQE -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (QFORM-S, DQFORM-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This subroutine proceeds from the computed QR factorization of -C an M by N matrix A to accumulate the M by M orthogonal matrix -C Q from its factored form. -C -C The subroutine statement is -C -C SUBROUTINE DQFORM(M,N,Q,LDQ,WA) -C -C where -C -C M is a positive integer input variable set to the number -C of rows of A and the order of Q. -C -C N is a positive integer input variable set to the number -C of columns of A. -C -C Q is an M by M array. On input the full lower trapezoid in -C the first MIN(M,N) columns of Q contains the factored form. -C On output Q has been accumulated into a square matrix. -C -C LDQ is a positive integer input variable not less than M -C which specifies the leading dimension of the array Q. -C -C WA is a work array of length M. -C -C***SEE ALSO DNSQ, DNSQE -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DQFORM - INTEGER I, J, JM1, K, L, LDQ, M, MINMN, N, NP1 - DOUBLE PRECISION ONE, Q(LDQ,*), SUM, TEMP, WA(*), ZERO - SAVE ONE, ZERO - DATA ONE,ZERO /1.0D0,0.0D0/ -C -C ZERO OUT UPPER TRIANGLE OF Q IN THE FIRST MIN(M,N) COLUMNS. -C -C***FIRST EXECUTABLE STATEMENT DQFORM - MINMN = MIN(M,N) - IF (MINMN .LT. 2) GO TO 30 - DO 20 J = 2, MINMN - JM1 = J - 1 - DO 10 I = 1, JM1 - Q(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE -C -C INITIALIZE REMAINING COLUMNS TO THOSE OF THE IDENTITY MATRIX. -C - NP1 = N + 1 - IF (M .LT. NP1) GO TO 60 - DO 50 J = NP1, M - DO 40 I = 1, M - Q(I,J) = ZERO - 40 CONTINUE - Q(J,J) = ONE - 50 CONTINUE - 60 CONTINUE -C -C ACCUMULATE Q FROM ITS FACTORED FORM. -C - DO 120 L = 1, MINMN - K = MINMN - L + 1 - DO 70 I = K, M - WA(I) = Q(I,K) - Q(I,K) = ZERO - 70 CONTINUE - Q(K,K) = ONE - IF (WA(K) .EQ. ZERO) GO TO 110 - DO 100 J = K, M - SUM = ZERO - DO 80 I = K, M - SUM = SUM + Q(I,J)*WA(I) - 80 CONTINUE - TEMP = SUM/WA(K) - DO 90 I = K, M - Q(I,J) = Q(I,J) - TEMP*WA(I) - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE DQFORM. -C - END diff --git a/slatec/dqk15.f b/slatec/dqk15.f deleted file mode 100644 index a764ccd..0000000 --- a/slatec/dqk15.f +++ /dev/null @@ -1,185 +0,0 @@ -*DECK DQK15 - SUBROUTINE DQK15 (F, A, B, RESULT, ABSERR, RESABS, RESASC) -C***BEGIN PROLOGUE DQK15 -C***PURPOSE To compute I = Integral of F over (A,B), with error -C estimate -C J = integral of ABS(F) over (A,B) -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A1A2 -C***TYPE DOUBLE PRECISION (QK15-S, DQK15-D) -C***KEYWORDS 15-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration rules -C Standard fortran subroutine -C Double precision version -C -C PARAMETERS -C ON ENTRY -C F - Double precision -C Function subprogram defining the integrand -C FUNCTION F(X). The actual name for F needs to be -C Declared E X T E R N A L in the calling program. -C -C A - Double precision -C Lower limit of integration -C -C B - Double precision -C Upper limit of integration -C -C ON RETURN -C RESULT - Double precision -C Approximation to the integral I -C Result is computed by applying the 15-POINT -C KRONROD RULE (RESK) obtained by optimal addition -C of abscissae to the 7-POINT GAUSS RULE(RESG). -C -C ABSERR - Double precision -C Estimate of the modulus of the absolute error, -C which should not exceed ABS(I-RESULT) -C -C RESABS - Double precision -C Approximation to the integral J -C -C RESASC - Double precision -C Approximation to the integral of ABS(F-I/(B-A)) -C over (A,B) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH -C***REVISION HISTORY (YYMMDD) -C 800101 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***END PROLOGUE DQK15 -C - DOUBLE PRECISION A,ABSC,ABSERR,B,CENTR,DHLGTH, - 1 D1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH,RESABS,RESASC, - 2 RESG,RESK,RESKH,RESULT,UFLOW,WG,WGK,XGK - INTEGER J,JTW,JTWM1 - EXTERNAL F -C - DIMENSION FV1(7),FV2(7),WG(4),WGK(8),XGK(8) -C -C THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). -C BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR -C CORRESPONDING WEIGHTS ARE GIVEN. -C -C XGK - ABSCISSAE OF THE 15-POINT KRONROD RULE -C XGK(2), XGK(4), ... ABSCISSAE OF THE 7-POINT -C GAUSS RULE -C XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY -C ADDED TO THE 7-POINT GAUSS RULE -C -C WGK - WEIGHTS OF THE 15-POINT KRONROD RULE -C -C WG - WEIGHTS OF THE 7-POINT GAUSS RULE -C -C -C GAUSS QUADRATURE WEIGHTS AND KRONROD QUADRATURE ABSCISSAE AND WEIGHTS -C AS EVALUATED WITH 80 DECIMAL DIGIT ARITHMETIC BY L. W. FULLERTON, -C BELL LABS, NOV. 1981. -C - SAVE WG, XGK, WGK - DATA WG ( 1) / 0.1294849661 6886969327 0611432679 082 D0 / - DATA WG ( 2) / 0.2797053914 8927666790 1467771423 780 D0 / - DATA WG ( 3) / 0.3818300505 0511894495 0369775488 975 D0 / - DATA WG ( 4) / 0.4179591836 7346938775 5102040816 327 D0 / -C - DATA XGK ( 1) / 0.9914553711 2081263920 6854697526 329 D0 / - DATA XGK ( 2) / 0.9491079123 4275852452 6189684047 851 D0 / - DATA XGK ( 3) / 0.8648644233 5976907278 9712788640 926 D0 / - DATA XGK ( 4) / 0.7415311855 9939443986 3864773280 788 D0 / - DATA XGK ( 5) / 0.5860872354 6769113029 4144838258 730 D0 / - DATA XGK ( 6) / 0.4058451513 7739716690 6606412076 961 D0 / - DATA XGK ( 7) / 0.2077849550 0789846760 0689403773 245 D0 / - DATA XGK ( 8) / 0.0000000000 0000000000 0000000000 000 D0 / -C - DATA WGK ( 1) / 0.0229353220 1052922496 3732008058 970 D0 / - DATA WGK ( 2) / 0.0630920926 2997855329 0700663189 204 D0 / - DATA WGK ( 3) / 0.1047900103 2225018383 9876322541 518 D0 / - DATA WGK ( 4) / 0.1406532597 1552591874 5189590510 238 D0 / - DATA WGK ( 5) / 0.1690047266 3926790282 6583426598 550 D0 / - DATA WGK ( 6) / 0.1903505780 6478540991 3256402421 014 D0 / - DATA WGK ( 7) / 0.2044329400 7529889241 4161999234 649 D0 / - DATA WGK ( 8) / 0.2094821410 8472782801 2999174891 714 D0 / -C -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C CENTR - MID POINT OF THE INTERVAL -C HLGTH - HALF-LENGTH OF THE INTERVAL -C ABSC - ABSCISSA -C FVAL* - FUNCTION VALUE -C RESG - RESULT OF THE 7-POINT GAUSS FORMULA -C RESK - RESULT OF THE 15-POINT KRONROD FORMULA -C RESKH - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B), -C I.E. TO I/(B-A) -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT DQK15 - EPMACH = D1MACH(4) - UFLOW = D1MACH(1) -C - CENTR = 0.5D+00*(A+B) - HLGTH = 0.5D+00*(B-A) - DHLGTH = ABS(HLGTH) -C -C COMPUTE THE 15-POINT KRONROD APPROXIMATION TO -C THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. -C - FC = F(CENTR) - RESG = FC*WG(4) - RESK = FC*WGK(8) - RESABS = ABS(RESK) - DO 10 J=1,3 - JTW = J*2 - ABSC = HLGTH*XGK(JTW) - FVAL1 = F(CENTR-ABSC) - FVAL2 = F(CENTR+ABSC) - FV1(JTW) = FVAL1 - FV2(JTW) = FVAL2 - FSUM = FVAL1+FVAL2 - RESG = RESG+WG(J)*FSUM - RESK = RESK+WGK(JTW)*FSUM - RESABS = RESABS+WGK(JTW)*(ABS(FVAL1)+ABS(FVAL2)) - 10 CONTINUE - DO 15 J = 1,4 - JTWM1 = J*2-1 - ABSC = HLGTH*XGK(JTWM1) - FVAL1 = F(CENTR-ABSC) - FVAL2 = F(CENTR+ABSC) - FV1(JTWM1) = FVAL1 - FV2(JTWM1) = FVAL2 - FSUM = FVAL1+FVAL2 - RESK = RESK+WGK(JTWM1)*FSUM - RESABS = RESABS+WGK(JTWM1)*(ABS(FVAL1)+ABS(FVAL2)) - 15 CONTINUE - RESKH = RESK*0.5D+00 - RESASC = WGK(8)*ABS(FC-RESKH) - DO 20 J=1,7 - RESASC = RESASC+WGK(J)*(ABS(FV1(J)-RESKH)+ABS(FV2(J)-RESKH)) - 20 CONTINUE - RESULT = RESK*HLGTH - RESABS = RESABS*DHLGTH - RESASC = RESASC*DHLGTH - ABSERR = ABS((RESK-RESG)*HLGTH) - IF(RESASC.NE.0.0D+00.AND.ABSERR.NE.0.0D+00) - 1 ABSERR = RESASC*MIN(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00) - IF(RESABS.GT.UFLOW/(0.5D+02*EPMACH)) ABSERR = MAX - 1 ((EPMACH*0.5D+02)*RESABS,ABSERR) - RETURN - END diff --git a/slatec/dqk15i.f b/slatec/dqk15i.f deleted file mode 100644 index 7ffeefe..0000000 --- a/slatec/dqk15i.f +++ /dev/null @@ -1,198 +0,0 @@ -*DECK DQK15I - SUBROUTINE DQK15I (F, BOUN, INF, A, B, RESULT, ABSERR, RESABS, - + RESASC) -C***BEGIN PROLOGUE DQK15I -C***PURPOSE The original (infinite integration range is mapped -C onto the interval (0,1) and (A,B) is a part of (0,1). -C it is the purpose to compute -C I = Integral of transformed integrand over (A,B), -C J = Integral of ABS(Transformed Integrand) over (A,B). -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A3A2, H2A4A2 -C***TYPE DOUBLE PRECISION (QK15I-S, DQK15I-D) -C***KEYWORDS 15-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration Rule -C Standard Fortran subroutine -C Double precision version -C -C PARAMETERS -C ON ENTRY -C F - Double precision -C Function subprogram defining the integrand -C FUNCTION F(X). The actual name for F needs to be -C Declared E X T E R N A L in the calling program. -C -C BOUN - Double precision -C Finite bound of original integration -C Range (SET TO ZERO IF INF = +2) -C -C INF - Integer -C If INF = -1, the original interval is -C (-INFINITY,BOUND), -C If INF = +1, the original interval is -C (BOUND,+INFINITY), -C If INF = +2, the original interval is -C (-INFINITY,+INFINITY) AND -C The integral is computed as the sum of two -C integrals, one over (-INFINITY,0) and one over -C (0,+INFINITY). -C -C A - Double precision -C Lower limit for integration over subrange -C of (0,1) -C -C B - Double precision -C Upper limit for integration over subrange -C of (0,1) -C -C ON RETURN -C RESULT - Double precision -C Approximation to the integral I -C Result is computed by applying the 15-POINT -C KRONROD RULE(RESK) obtained by optimal addition -C of abscissae to the 7-POINT GAUSS RULE(RESG). -C -C ABSERR - Double precision -C Estimate of the modulus of the absolute error, -C WHICH SHOULD EQUAL or EXCEED ABS(I-RESULT) -C -C RESABS - Double precision -C Approximation to the integral J -C -C RESASC - Double precision -C Approximation to the integral of -C ABS((TRANSFORMED INTEGRAND)-I/(B-A)) over (A,B) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH -C***REVISION HISTORY (YYMMDD) -C 800101 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***END PROLOGUE DQK15I -C - DOUBLE PRECISION A,ABSC,ABSC1,ABSC2,ABSERR,B,BOUN,CENTR,DINF, - 1 D1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH, - 2 RESABS,RESASC,RESG,RESK,RESKH,RESULT,TABSC1,TABSC2,UFLOW,WG,WGK, - 3 XGK - INTEGER INF,J - EXTERNAL F -C - DIMENSION FV1(7),FV2(7),XGK(8),WGK(8),WG(8) -C -C THE ABSCISSAE AND WEIGHTS ARE SUPPLIED FOR THE INTERVAL -C (-1,1). BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND -C THEIR CORRESPONDING WEIGHTS ARE GIVEN. -C -C XGK - ABSCISSAE OF THE 15-POINT KRONROD RULE -C XGK(2), XGK(4), ... ABSCISSAE OF THE 7-POINT -C GAUSS RULE -C XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY -C ADDED TO THE 7-POINT GAUSS RULE -C -C WGK - WEIGHTS OF THE 15-POINT KRONROD RULE -C -C WG - WEIGHTS OF THE 7-POINT GAUSS RULE, CORRESPONDING -C TO THE ABSCISSAE XGK(2), XGK(4), ... -C WG(1), WG(3), ... ARE SET TO ZERO. -C - SAVE XGK, WGK, WG - DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7),XGK(8)/ - 1 0.9914553711208126D+00, 0.9491079123427585D+00, - 2 0.8648644233597691D+00, 0.7415311855993944D+00, - 3 0.5860872354676911D+00, 0.4058451513773972D+00, - 4 0.2077849550078985D+00, 0.0000000000000000D+00/ -C - DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7),WGK(8)/ - 1 0.2293532201052922D-01, 0.6309209262997855D-01, - 2 0.1047900103222502D+00, 0.1406532597155259D+00, - 3 0.1690047266392679D+00, 0.1903505780647854D+00, - 4 0.2044329400752989D+00, 0.2094821410847278D+00/ -C - DATA WG(1),WG(2),WG(3),WG(4),WG(5),WG(6),WG(7),WG(8)/ - 1 0.0000000000000000D+00, 0.1294849661688697D+00, - 2 0.0000000000000000D+00, 0.2797053914892767D+00, - 3 0.0000000000000000D+00, 0.3818300505051189D+00, - 4 0.0000000000000000D+00, 0.4179591836734694D+00/ -C -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C CENTR - MID POINT OF THE INTERVAL -C HLGTH - HALF-LENGTH OF THE INTERVAL -C ABSC* - ABSCISSA -C TABSC* - TRANSFORMED ABSCISSA -C FVAL* - FUNCTION VALUE -C RESG - RESULT OF THE 7-POINT GAUSS FORMULA -C RESK - RESULT OF THE 15-POINT KRONROD FORMULA -C RESKH - APPROXIMATION TO THE MEAN VALUE OF THE TRANSFORMED -C INTEGRAND OVER (A,B), I.E. TO I/(B-A) -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT DQK15I - EPMACH = D1MACH(4) - UFLOW = D1MACH(1) - DINF = MIN(1,INF) -C - CENTR = 0.5D+00*(A+B) - HLGTH = 0.5D+00*(B-A) - TABSC1 = BOUN+DINF*(0.1D+01-CENTR)/CENTR - FVAL1 = F(TABSC1) - IF(INF.EQ.2) FVAL1 = FVAL1+F(-TABSC1) - FC = (FVAL1/CENTR)/CENTR -C -C COMPUTE THE 15-POINT KRONROD APPROXIMATION TO -C THE INTEGRAL, AND ESTIMATE THE ERROR. -C - RESG = WG(8)*FC - RESK = WGK(8)*FC - RESABS = ABS(RESK) - DO 10 J=1,7 - ABSC = HLGTH*XGK(J) - ABSC1 = CENTR-ABSC - ABSC2 = CENTR+ABSC - TABSC1 = BOUN+DINF*(0.1D+01-ABSC1)/ABSC1 - TABSC2 = BOUN+DINF*(0.1D+01-ABSC2)/ABSC2 - FVAL1 = F(TABSC1) - FVAL2 = F(TABSC2) - IF(INF.EQ.2) FVAL1 = FVAL1+F(-TABSC1) - IF(INF.EQ.2) FVAL2 = FVAL2+F(-TABSC2) - FVAL1 = (FVAL1/ABSC1)/ABSC1 - FVAL2 = (FVAL2/ABSC2)/ABSC2 - FV1(J) = FVAL1 - FV2(J) = FVAL2 - FSUM = FVAL1+FVAL2 - RESG = RESG+WG(J)*FSUM - RESK = RESK+WGK(J)*FSUM - RESABS = RESABS+WGK(J)*(ABS(FVAL1)+ABS(FVAL2)) - 10 CONTINUE - RESKH = RESK*0.5D+00 - RESASC = WGK(8)*ABS(FC-RESKH) - DO 20 J=1,7 - RESASC = RESASC+WGK(J)*(ABS(FV1(J)-RESKH)+ABS(FV2(J)-RESKH)) - 20 CONTINUE - RESULT = RESK*HLGTH - RESASC = RESASC*HLGTH - RESABS = RESABS*HLGTH - ABSERR = ABS((RESK-RESG)*HLGTH) - IF(RESASC.NE.0.0D+00.AND.ABSERR.NE.0.D0) ABSERR = RESASC* - 1 MIN(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00) - IF(RESABS.GT.UFLOW/(0.5D+02*EPMACH)) ABSERR = MAX - 1 ((EPMACH*0.5D+02)*RESABS,ABSERR) - RETURN - END diff --git a/slatec/dqk15w.f b/slatec/dqk15w.f deleted file mode 100644 index 922e4bf..0000000 --- a/slatec/dqk15w.f +++ /dev/null @@ -1,190 +0,0 @@ -*DECK DQK15W - SUBROUTINE DQK15W (F, W, P1, P2, P3, P4, KP, A, B, RESULT, ABSERR, - + RESABS, RESASC) -C***BEGIN PROLOGUE DQK15W -C***PURPOSE To compute I = Integral of F*W over (A,B), with error -C estimate -C J = Integral of ABS(F*W) over (A,B) -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A2A2 -C***TYPE DOUBLE PRECISION (QK15W-S, DQK15W-D) -C***KEYWORDS 15-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration rules -C Standard fortran subroutine -C Double precision version -C -C PARAMETERS -C ON ENTRY -C F - Double precision -C Function subprogram defining the integrand -C function F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C W - Double precision -C Function subprogram defining the integrand -C WEIGHT function W(X). The actual name for W -C needs to be declared E X T E R N A L in the -C calling program. -C -C P1, P2, P3, P4 - Double precision -C Parameters in the WEIGHT function -C -C KP - Integer -C Key for indicating the type of WEIGHT function -C -C A - Double precision -C Lower limit of integration -C -C B - Double precision -C Upper limit of integration -C -C ON RETURN -C RESULT - Double precision -C Approximation to the integral I -C RESULT is computed by applying the 15-point -C Kronrod rule (RESK) obtained by optimal addition -C of abscissae to the 7-point Gauss rule (RESG). -C -C ABSERR - Double precision -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C RESABS - Double precision -C Approximation to the integral of ABS(F) -C -C RESASC - Double precision -C Approximation to the integral of ABS(F-I/(B-A)) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH -C***REVISION HISTORY (YYMMDD) -C 810101 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***END PROLOGUE DQK15W -C - DOUBLE PRECISION A,ABSC,ABSC1,ABSC2,ABSERR,B,CENTR,DHLGTH, - 1 D1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH, - 2 P1,P2,P3,P4,RESABS,RESASC,RESG,RESK,RESKH,RESULT,UFLOW,W,WG,WGK, - 3 XGK - INTEGER J,JTW,JTWM1,KP - EXTERNAL F, W -C - DIMENSION FV1(7),FV2(7),XGK(8),WGK(8),WG(4) -C -C THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). -C BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR -C CORRESPONDING WEIGHTS ARE GIVEN. -C -C XGK - ABSCISSAE OF THE 15-POINT GAUSS-KRONROD RULE -C XGK(2), XGK(4), ... ABSCISSAE OF THE 7-POINT -C GAUSS RULE -C XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY -C ADDED TO THE 7-POINT GAUSS RULE -C -C WGK - WEIGHTS OF THE 15-POINT GAUSS-KRONROD RULE -C -C WG - WEIGHTS OF THE 7-POINT GAUSS RULE -C - SAVE XGK, WGK, WG - DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7),XGK(8)/ - 1 0.9914553711208126D+00, 0.9491079123427585D+00, - 2 0.8648644233597691D+00, 0.7415311855993944D+00, - 3 0.5860872354676911D+00, 0.4058451513773972D+00, - 4 0.2077849550078985D+00, 0.0000000000000000D+00/ -C - DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7),WGK(8)/ - 1 0.2293532201052922D-01, 0.6309209262997855D-01, - 2 0.1047900103222502D+00, 0.1406532597155259D+00, - 3 0.1690047266392679D+00, 0.1903505780647854D+00, - 4 0.2044329400752989D+00, 0.2094821410847278D+00/ -C - DATA WG(1),WG(2),WG(3),WG(4)/ - 1 0.1294849661688697D+00, 0.2797053914892767D+00, - 2 0.3818300505051889D+00, 0.4179591836734694D+00/ -C -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C CENTR - MID POINT OF THE INTERVAL -C HLGTH - HALF-LENGTH OF THE INTERVAL -C ABSC* - ABSCISSA -C FVAL* - FUNCTION VALUE -C RESG - RESULT OF THE 7-POINT GAUSS FORMULA -C RESK - RESULT OF THE 15-POINT KRONROD FORMULA -C RESKH - APPROXIMATION TO THE MEAN VALUE OF F*W OVER (A,B), -C I.E. TO I/(B-A) -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT DQK15W - EPMACH = D1MACH(4) - UFLOW = D1MACH(1) -C - CENTR = 0.5D+00*(A+B) - HLGTH = 0.5D+00*(B-A) - DHLGTH = ABS(HLGTH) -C -C COMPUTE THE 15-POINT KRONROD APPROXIMATION TO THE -C INTEGRAL, AND ESTIMATE THE ERROR. -C - FC = F(CENTR)*W(CENTR,P1,P2,P3,P4,KP) - RESG = WG(4)*FC - RESK = WGK(8)*FC - RESABS = ABS(RESK) - DO 10 J=1,3 - JTW = J*2 - ABSC = HLGTH*XGK(JTW) - ABSC1 = CENTR-ABSC - ABSC2 = CENTR+ABSC - FVAL1 = F(ABSC1)*W(ABSC1,P1,P2,P3,P4,KP) - FVAL2 = F(ABSC2)*W(ABSC2,P1,P2,P3,P4,KP) - FV1(JTW) = FVAL1 - FV2(JTW) = FVAL2 - FSUM = FVAL1+FVAL2 - RESG = RESG+WG(J)*FSUM - RESK = RESK+WGK(JTW)*FSUM - RESABS = RESABS+WGK(JTW)*(ABS(FVAL1)+ABS(FVAL2)) - 10 CONTINUE - DO 15 J=1,4 - JTWM1 = J*2-1 - ABSC = HLGTH*XGK(JTWM1) - ABSC1 = CENTR-ABSC - ABSC2 = CENTR+ABSC - FVAL1 = F(ABSC1)*W(ABSC1,P1,P2,P3,P4,KP) - FVAL2 = F(ABSC2)*W(ABSC2,P1,P2,P3,P4,KP) - FV1(JTWM1) = FVAL1 - FV2(JTWM1) = FVAL2 - FSUM = FVAL1+FVAL2 - RESK = RESK+WGK(JTWM1)*FSUM - RESABS = RESABS+WGK(JTWM1)*(ABS(FVAL1)+ABS(FVAL2)) - 15 CONTINUE - RESKH = RESK*0.5D+00 - RESASC = WGK(8)*ABS(FC-RESKH) - DO 20 J=1,7 - RESASC = RESASC+WGK(J)*(ABS(FV1(J)-RESKH)+ABS(FV2(J)-RESKH)) - 20 CONTINUE - RESULT = RESK*HLGTH - RESABS = RESABS*DHLGTH - RESASC = RESASC*DHLGTH - ABSERR = ABS((RESK-RESG)*HLGTH) - IF(RESASC.NE.0.0D+00.AND.ABSERR.NE.0.0D+00) - 1 ABSERR = RESASC*MIN(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00) - IF(RESABS.GT.UFLOW/(0.5D+02*EPMACH)) ABSERR = MAX((EPMACH* - 1 0.5D+02)*RESABS,ABSERR) - RETURN - END diff --git a/slatec/dqk21.f b/slatec/dqk21.f deleted file mode 100644 index 5ec1077..0000000 --- a/slatec/dqk21.f +++ /dev/null @@ -1,193 +0,0 @@ -*DECK DQK21 - SUBROUTINE DQK21 (F, A, B, RESULT, ABSERR, RESABS, RESASC) -C***BEGIN PROLOGUE DQK21 -C***PURPOSE To compute I = Integral of F over (A,B), with error -C estimate -C J = Integral of ABS(F) over (A,B) -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A1A2 -C***TYPE DOUBLE PRECISION (QK21-S, DQK21-D) -C***KEYWORDS 21-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration rules -C Standard fortran subroutine -C Double precision version -C -C PARAMETERS -C ON ENTRY -C F - Double precision -C Function subprogram defining the integrand -C FUNCTION F(X). The actual name for F needs to be -C Declared E X T E R N A L in the driver program. -C -C A - Double precision -C Lower limit of integration -C -C B - Double precision -C Upper limit of integration -C -C ON RETURN -C RESULT - Double precision -C Approximation to the integral I -C RESULT is computed by applying the 21-POINT -C KRONROD RULE (RESK) obtained by optimal addition -C of abscissae to the 10-POINT GAUSS RULE (RESG). -C -C ABSERR - Double precision -C Estimate of the modulus of the absolute error, -C which should not exceed ABS(I-RESULT) -C -C RESABS - Double precision -C Approximation to the integral J -C -C RESASC - Double precision -C Approximation to the integral of ABS(F-I/(B-A)) -C over (A,B) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH -C***REVISION HISTORY (YYMMDD) -C 800101 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***END PROLOGUE DQK21 -C - DOUBLE PRECISION A,ABSC,ABSERR,B,CENTR,DHLGTH, - 1 D1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH,RESABS,RESASC, - 2 RESG,RESK,RESKH,RESULT,UFLOW,WG,WGK,XGK - INTEGER J,JTW,JTWM1 - EXTERNAL F -C - DIMENSION FV1(10),FV2(10),WG(5),WGK(11),XGK(11) -C -C THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). -C BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR -C CORRESPONDING WEIGHTS ARE GIVEN. -C -C XGK - ABSCISSAE OF THE 21-POINT KRONROD RULE -C XGK(2), XGK(4), ... ABSCISSAE OF THE 10-POINT -C GAUSS RULE -C XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY -C ADDED TO THE 10-POINT GAUSS RULE -C -C WGK - WEIGHTS OF THE 21-POINT KRONROD RULE -C -C WG - WEIGHTS OF THE 10-POINT GAUSS RULE -C -C -C GAUSS QUADRATURE WEIGHTS AND KRONROD QUADRATURE ABSCISSAE AND WEIGHTS -C AS EVALUATED WITH 80 DECIMAL DIGIT ARITHMETIC BY L. W. FULLERTON, -C BELL LABS, NOV. 1981. -C - SAVE WG, XGK, WGK - DATA WG ( 1) / 0.0666713443 0868813759 3568809893 332 D0 / - DATA WG ( 2) / 0.1494513491 5058059314 5776339657 697 D0 / - DATA WG ( 3) / 0.2190863625 1598204399 5534934228 163 D0 / - DATA WG ( 4) / 0.2692667193 0999635509 1226921569 469 D0 / - DATA WG ( 5) / 0.2955242247 1475287017 3892994651 338 D0 / -C - DATA XGK ( 1) / 0.9956571630 2580808073 5527280689 003 D0 / - DATA XGK ( 2) / 0.9739065285 1717172007 7964012084 452 D0 / - DATA XGK ( 3) / 0.9301574913 5570822600 1207180059 508 D0 / - DATA XGK ( 4) / 0.8650633666 8898451073 2096688423 493 D0 / - DATA XGK ( 5) / 0.7808177265 8641689706 3717578345 042 D0 / - DATA XGK ( 6) / 0.6794095682 9902440623 4327365114 874 D0 / - DATA XGK ( 7) / 0.5627571346 6860468333 9000099272 694 D0 / - DATA XGK ( 8) / 0.4333953941 2924719079 9265943165 784 D0 / - DATA XGK ( 9) / 0.2943928627 0146019813 1126603103 866 D0 / - DATA XGK ( 10) / 0.1488743389 8163121088 4826001129 720 D0 / - DATA XGK ( 11) / 0.0000000000 0000000000 0000000000 000 D0 / -C - DATA WGK ( 1) / 0.0116946388 6737187427 8064396062 192 D0 / - DATA WGK ( 2) / 0.0325581623 0796472747 8818972459 390 D0 / - DATA WGK ( 3) / 0.0547558965 7435199603 1381300244 580 D0 / - DATA WGK ( 4) / 0.0750396748 1091995276 7043140916 190 D0 / - DATA WGK ( 5) / 0.0931254545 8369760553 5065465083 366 D0 / - DATA WGK ( 6) / 0.1093871588 0229764189 9210590325 805 D0 / - DATA WGK ( 7) / 0.1234919762 6206585107 7958109831 074 D0 / - DATA WGK ( 8) / 0.1347092173 1147332592 8054001771 707 D0 / - DATA WGK ( 9) / 0.1427759385 7706008079 7094273138 717 D0 / - DATA WGK ( 10) / 0.1477391049 0133849137 4841515972 068 D0 / - DATA WGK ( 11) / 0.1494455540 0291690566 4936468389 821 D0 / -C -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C CENTR - MID POINT OF THE INTERVAL -C HLGTH - HALF-LENGTH OF THE INTERVAL -C ABSC - ABSCISSA -C FVAL* - FUNCTION VALUE -C RESG - RESULT OF THE 10-POINT GAUSS FORMULA -C RESK - RESULT OF THE 21-POINT KRONROD FORMULA -C RESKH - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B), -C I.E. TO I/(B-A) -C -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT DQK21 - EPMACH = D1MACH(4) - UFLOW = D1MACH(1) -C - CENTR = 0.5D+00*(A+B) - HLGTH = 0.5D+00*(B-A) - DHLGTH = ABS(HLGTH) -C -C COMPUTE THE 21-POINT KRONROD APPROXIMATION TO -C THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. -C - RESG = 0.0D+00 - FC = F(CENTR) - RESK = WGK(11)*FC - RESABS = ABS(RESK) - DO 10 J=1,5 - JTW = 2*J - ABSC = HLGTH*XGK(JTW) - FVAL1 = F(CENTR-ABSC) - FVAL2 = F(CENTR+ABSC) - FV1(JTW) = FVAL1 - FV2(JTW) = FVAL2 - FSUM = FVAL1+FVAL2 - RESG = RESG+WG(J)*FSUM - RESK = RESK+WGK(JTW)*FSUM - RESABS = RESABS+WGK(JTW)*(ABS(FVAL1)+ABS(FVAL2)) - 10 CONTINUE - DO 15 J = 1,5 - JTWM1 = 2*J-1 - ABSC = HLGTH*XGK(JTWM1) - FVAL1 = F(CENTR-ABSC) - FVAL2 = F(CENTR+ABSC) - FV1(JTWM1) = FVAL1 - FV2(JTWM1) = FVAL2 - FSUM = FVAL1+FVAL2 - RESK = RESK+WGK(JTWM1)*FSUM - RESABS = RESABS+WGK(JTWM1)*(ABS(FVAL1)+ABS(FVAL2)) - 15 CONTINUE - RESKH = RESK*0.5D+00 - RESASC = WGK(11)*ABS(FC-RESKH) - DO 20 J=1,10 - RESASC = RESASC+WGK(J)*(ABS(FV1(J)-RESKH)+ABS(FV2(J)-RESKH)) - 20 CONTINUE - RESULT = RESK*HLGTH - RESABS = RESABS*DHLGTH - RESASC = RESASC*DHLGTH - ABSERR = ABS((RESK-RESG)*HLGTH) - IF(RESASC.NE.0.0D+00.AND.ABSERR.NE.0.0D+00) - 1 ABSERR = RESASC*MIN(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00) - IF(RESABS.GT.UFLOW/(0.5D+02*EPMACH)) ABSERR = MAX - 1 ((EPMACH*0.5D+02)*RESABS,ABSERR) - RETURN - END diff --git a/slatec/dqk31.f b/slatec/dqk31.f deleted file mode 100644 index fae4b36..0000000 --- a/slatec/dqk31.f +++ /dev/null @@ -1,202 +0,0 @@ -*DECK DQK31 - SUBROUTINE DQK31 (F, A, B, RESULT, ABSERR, RESABS, RESASC) -C***BEGIN PROLOGUE DQK31 -C***PURPOSE To compute I = Integral of F over (A,B) with error -C estimate -C J = Integral of ABS(F) over (A,B) -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A1A2 -C***TYPE DOUBLE PRECISION (QK31-S, DQK31-D) -C***KEYWORDS 31-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration rules -C Standard fortran subroutine -C Double precision version -C -C PARAMETERS -C ON ENTRY -C F - Double precision -C Function subprogram defining the integrand -C FUNCTION F(X). The actual name for F needs to be -C Declared E X T E R N A L in the calling program. -C -C A - Double precision -C Lower limit of integration -C -C B - Double precision -C Upper limit of integration -C -C ON RETURN -C RESULT - Double precision -C Approximation to the integral I -C RESULT is computed by applying the 31-POINT -C GAUSS-KRONROD RULE (RESK), obtained by optimal -C addition of abscissae to the 15-POINT GAUSS -C RULE (RESG). -C -C ABSERR - Double precision -C Estimate of the modulus of the modulus, -C which should not exceed ABS(I-RESULT) -C -C RESABS - Double precision -C Approximation to the integral J -C -C RESASC - Double precision -C Approximation to the integral of ABS(F-I/(B-A)) -C over (A,B) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH -C***REVISION HISTORY (YYMMDD) -C 800101 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***END PROLOGUE DQK31 - DOUBLE PRECISION A,ABSC,ABSERR,B,CENTR,DHLGTH, - 1 D1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH,RESABS,RESASC, - 2 RESG,RESK,RESKH,RESULT,UFLOW,WG,WGK,XGK - INTEGER J,JTW,JTWM1 - EXTERNAL F -C - DIMENSION FV1(15),FV2(15),XGK(16),WGK(16),WG(8) -C -C THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). -C BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR -C CORRESPONDING WEIGHTS ARE GIVEN. -C -C XGK - ABSCISSAE OF THE 31-POINT KRONROD RULE -C XGK(2), XGK(4), ... ABSCISSAE OF THE 15-POINT -C GAUSS RULE -C XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY -C ADDED TO THE 15-POINT GAUSS RULE -C -C WGK - WEIGHTS OF THE 31-POINT KRONROD RULE -C -C WG - WEIGHTS OF THE 15-POINT GAUSS RULE -C -C -C GAUSS QUADRATURE WEIGHTS AND KRONROD QUADRATURE ABSCISSAE AND WEIGHTS -C AS EVALUATED WITH 80 DECIMAL DIGIT ARITHMETIC BY L. W. FULLERTON, -C BELL LABS, NOV. 1981. -C - SAVE WG, XGK, WGK - DATA WG ( 1) / 0.0307532419 9611726835 4628393577 204 D0 / - DATA WG ( 2) / 0.0703660474 8810812470 9267416450 667 D0 / - DATA WG ( 3) / 0.1071592204 6717193501 1869546685 869 D0 / - DATA WG ( 4) / 0.1395706779 2615431444 7804794511 028 D0 / - DATA WG ( 5) / 0.1662692058 1699393355 3200860481 209 D0 / - DATA WG ( 6) / 0.1861610000 1556221102 6800561866 423 D0 / - DATA WG ( 7) / 0.1984314853 2711157645 6118326443 839 D0 / - DATA WG ( 8) / 0.2025782419 2556127288 0620199967 519 D0 / -C - DATA XGK ( 1) / 0.9980022986 9339706028 5172840152 271 D0 / - DATA XGK ( 2) / 0.9879925180 2048542848 9565718586 613 D0 / - DATA XGK ( 3) / 0.9677390756 7913913425 7347978784 337 D0 / - DATA XGK ( 4) / 0.9372733924 0070590430 7758947710 209 D0 / - DATA XGK ( 5) / 0.8972645323 4408190088 2509656454 496 D0 / - DATA XGK ( 6) / 0.8482065834 1042721620 0648320774 217 D0 / - DATA XGK ( 7) / 0.7904185014 4246593296 7649294817 947 D0 / - DATA XGK ( 8) / 0.7244177313 6017004741 6186054613 938 D0 / - DATA XGK ( 9) / 0.6509967412 9741697053 3735895313 275 D0 / - DATA XGK ( 10) / 0.5709721726 0853884753 7226737253 911 D0 / - DATA XGK ( 11) / 0.4850818636 4023968069 3655740232 351 D0 / - DATA XGK ( 12) / 0.3941513470 7756336989 7207370981 045 D0 / - DATA XGK ( 13) / 0.2991800071 5316881216 6780024266 389 D0 / - DATA XGK ( 14) / 0.2011940939 9743452230 0628303394 596 D0 / - DATA XGK ( 15) / 0.1011420669 1871749902 7074231447 392 D0 / - DATA XGK ( 16) / 0.0000000000 0000000000 0000000000 000 D0 / -C - DATA WGK ( 1) / 0.0053774798 7292334898 7792051430 128 D0 / - DATA WGK ( 2) / 0.0150079473 2931612253 8374763075 807 D0 / - DATA WGK ( 3) / 0.0254608473 2671532018 6874001019 653 D0 / - DATA WGK ( 4) / 0.0353463607 9137584622 2037948478 360 D0 / - DATA WGK ( 5) / 0.0445897513 2476487660 8227299373 280 D0 / - DATA WGK ( 6) / 0.0534815246 9092808726 5343147239 430 D0 / - DATA WGK ( 7) / 0.0620095678 0067064028 5139230960 803 D0 / - DATA WGK ( 8) / 0.0698541213 1872825870 9520077099 147 D0 / - DATA WGK ( 9) / 0.0768496807 5772037889 4432777482 659 D0 / - DATA WGK ( 10) / 0.0830805028 2313302103 8289247286 104 D0 / - DATA WGK ( 11) / 0.0885644430 5621177064 7275443693 774 D0 / - DATA WGK ( 12) / 0.0931265981 7082532122 5486872747 346 D0 / - DATA WGK ( 13) / 0.0966427269 8362367850 5179907627 589 D0 / - DATA WGK ( 14) / 0.0991735987 2179195933 2393173484 603 D0 / - DATA WGK ( 15) / 0.1007698455 2387559504 4946662617 570 D0 / - DATA WGK ( 16) / 0.1013300070 1479154901 7374792767 493 D0 / -C -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C CENTR - MID POINT OF THE INTERVAL -C HLGTH - HALF-LENGTH OF THE INTERVAL -C ABSC - ABSCISSA -C FVAL* - FUNCTION VALUE -C RESG - RESULT OF THE 15-POINT GAUSS FORMULA -C RESK - RESULT OF THE 31-POINT KRONROD FORMULA -C RESKH - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B), -C I.E. TO I/(B-A) -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C***FIRST EXECUTABLE STATEMENT DQK31 - EPMACH = D1MACH(4) - UFLOW = D1MACH(1) -C - CENTR = 0.5D+00*(A+B) - HLGTH = 0.5D+00*(B-A) - DHLGTH = ABS(HLGTH) -C -C COMPUTE THE 31-POINT KRONROD APPROXIMATION TO -C THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. -C - FC = F(CENTR) - RESG = WG(8)*FC - RESK = WGK(16)*FC - RESABS = ABS(RESK) - DO 10 J=1,7 - JTW = J*2 - ABSC = HLGTH*XGK(JTW) - FVAL1 = F(CENTR-ABSC) - FVAL2 = F(CENTR+ABSC) - FV1(JTW) = FVAL1 - FV2(JTW) = FVAL2 - FSUM = FVAL1+FVAL2 - RESG = RESG+WG(J)*FSUM - RESK = RESK+WGK(JTW)*FSUM - RESABS = RESABS+WGK(JTW)*(ABS(FVAL1)+ABS(FVAL2)) - 10 CONTINUE - DO 15 J = 1,8 - JTWM1 = J*2-1 - ABSC = HLGTH*XGK(JTWM1) - FVAL1 = F(CENTR-ABSC) - FVAL2 = F(CENTR+ABSC) - FV1(JTWM1) = FVAL1 - FV2(JTWM1) = FVAL2 - FSUM = FVAL1+FVAL2 - RESK = RESK+WGK(JTWM1)*FSUM - RESABS = RESABS+WGK(JTWM1)*(ABS(FVAL1)+ABS(FVAL2)) - 15 CONTINUE - RESKH = RESK*0.5D+00 - RESASC = WGK(16)*ABS(FC-RESKH) - DO 20 J=1,15 - RESASC = RESASC+WGK(J)*(ABS(FV1(J)-RESKH)+ABS(FV2(J)-RESKH)) - 20 CONTINUE - RESULT = RESK*HLGTH - RESABS = RESABS*DHLGTH - RESASC = RESASC*DHLGTH - ABSERR = ABS((RESK-RESG)*HLGTH) - IF(RESASC.NE.0.0D+00.AND.ABSERR.NE.0.0D+00) - 1 ABSERR = RESASC*MIN(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00) - IF(RESABS.GT.UFLOW/(0.5D+02*EPMACH)) ABSERR = MAX - 1 ((EPMACH*0.5D+02)*RESABS,ABSERR) - RETURN - END diff --git a/slatec/dqk41.f b/slatec/dqk41.f deleted file mode 100644 index d070e6d..0000000 --- a/slatec/dqk41.f +++ /dev/null @@ -1,218 +0,0 @@ -*DECK DQK41 - SUBROUTINE DQK41 (F, A, B, RESULT, ABSERR, RESABS, RESASC) -C***BEGIN PROLOGUE DQK41 -C***PURPOSE To compute I = Integral of F over (A,B), with error -C estimate -C J = Integral of ABS(F) over (A,B) -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A1A2 -C***TYPE DOUBLE PRECISION (QK41-S, DQK41-D) -C***KEYWORDS 41-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration rules -C Standard fortran subroutine -C Double precision version -C -C PARAMETERS -C ON ENTRY -C F - Double precision -C Function subprogram defining the integrand -C FUNCTION F(X). The actual name for F needs to be -C declared E X T E R N A L in the calling program. -C -C A - Double precision -C Lower limit of integration -C -C B - Double precision -C Upper limit of integration -C -C ON RETURN -C RESULT - Double precision -C Approximation to the integral I -C RESULT is computed by applying the 41-POINT -C GAUSS-KRONROD RULE (RESK) obtained by optimal -C addition of abscissae to the 20-POINT GAUSS -C RULE (RESG). -C -C ABSERR - Double precision -C Estimate of the modulus of the absolute error, -C which should not exceed ABS(I-RESULT) -C -C RESABS - Double precision -C Approximation to the integral J -C -C RESASC - Double precision -C Approximation to the integral of ABS(F-I/(B-A)) -C over (A,B) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH -C***REVISION HISTORY (YYMMDD) -C 800101 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***END PROLOGUE DQK41 -C - DOUBLE PRECISION A,ABSC,ABSERR,B,CENTR,DHLGTH, - 1 D1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH,RESABS,RESASC, - 2 RESG,RESK,RESKH,RESULT,UFLOW,WG,WGK,XGK - INTEGER J,JTW,JTWM1 - EXTERNAL F -C - DIMENSION FV1(20),FV2(20),XGK(21),WGK(21),WG(10) -C -C THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). -C BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR -C CORRESPONDING WEIGHTS ARE GIVEN. -C -C XGK - ABSCISSAE OF THE 41-POINT GAUSS-KRONROD RULE -C XGK(2), XGK(4), ... ABSCISSAE OF THE 20-POINT -C GAUSS RULE -C XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY -C ADDED TO THE 20-POINT GAUSS RULE -C -C WGK - WEIGHTS OF THE 41-POINT GAUSS-KRONROD RULE -C -C WG - WEIGHTS OF THE 20-POINT GAUSS RULE -C -C -C GAUSS QUADRATURE WEIGHTS AND KRONROD QUADRATURE ABSCISSAE AND WEIGHTS -C AS EVALUATED WITH 80 DECIMAL DIGIT ARITHMETIC BY L. W. FULLERTON, -C BELL LABS, NOV. 1981. -C - SAVE WG, XGK, WGK - DATA WG ( 1) / 0.0176140071 3915211831 1861962351 853 D0 / - DATA WG ( 2) / 0.0406014298 0038694133 1039952274 932 D0 / - DATA WG ( 3) / 0.0626720483 3410906356 9506535187 042 D0 / - DATA WG ( 4) / 0.0832767415 7670474872 4758143222 046 D0 / - DATA WG ( 5) / 0.1019301198 1724043503 6750135480 350 D0 / - DATA WG ( 6) / 0.1181945319 6151841731 2377377711 382 D0 / - DATA WG ( 7) / 0.1316886384 4917662689 8494499748 163 D0 / - DATA WG ( 8) / 0.1420961093 1838205132 9298325067 165 D0 / - DATA WG ( 9) / 0.1491729864 7260374678 7828737001 969 D0 / - DATA WG ( 10) / 0.1527533871 3072585069 8084331955 098 D0 / -C - DATA XGK ( 1) / 0.9988590315 8827766383 8315576545 863 D0 / - DATA XGK ( 2) / 0.9931285991 8509492478 6122388471 320 D0 / - DATA XGK ( 3) / 0.9815078774 5025025919 3342994720 217 D0 / - DATA XGK ( 4) / 0.9639719272 7791379126 7666131197 277 D0 / - DATA XGK ( 5) / 0.9408226338 3175475351 9982722212 443 D0 / - DATA XGK ( 6) / 0.9122344282 5132590586 7752441203 298 D0 / - DATA XGK ( 7) / 0.8782768112 5228197607 7442995113 078 D0 / - DATA XGK ( 8) / 0.8391169718 2221882339 4529061701 521 D0 / - DATA XGK ( 9) / 0.7950414288 3755119835 0638833272 788 D0 / - DATA XGK ( 10) / 0.7463319064 6015079261 4305070355 642 D0 / - DATA XGK ( 11) / 0.6932376563 3475138480 5490711845 932 D0 / - DATA XGK ( 12) / 0.6360536807 2651502545 2836696226 286 D0 / - DATA XGK ( 13) / 0.5751404468 1971031534 2946036586 425 D0 / - DATA XGK ( 14) / 0.5108670019 5082709800 4364050955 251 D0 / - DATA XGK ( 15) / 0.4435931752 3872510319 9992213492 640 D0 / - DATA XGK ( 16) / 0.3737060887 1541956067 2548177024 927 D0 / - DATA XGK ( 17) / 0.3016278681 1491300432 0555356858 592 D0 / - DATA XGK ( 18) / 0.2277858511 4164507808 0496195368 575 D0 / - DATA XGK ( 19) / 0.1526054652 4092267550 5220241022 678 D0 / - DATA XGK ( 20) / 0.0765265211 3349733375 4640409398 838 D0 / - DATA XGK ( 21) / 0.0000000000 0000000000 0000000000 000 D0 / -C - DATA WGK ( 1) / 0.0030735837 1852053150 1218293246 031 D0 / - DATA WGK ( 2) / 0.0086002698 5564294219 8661787950 102 D0 / - DATA WGK ( 3) / 0.0146261692 5697125298 3787960308 868 D0 / - DATA WGK ( 4) / 0.0203883734 6126652359 8010231432 755 D0 / - DATA WGK ( 5) / 0.0258821336 0495115883 4505067096 153 D0 / - DATA WGK ( 6) / 0.0312873067 7703279895 8543119323 801 D0 / - DATA WGK ( 7) / 0.0366001697 5820079803 0557240707 211 D0 / - DATA WGK ( 8) / 0.0416688733 2797368626 3788305936 895 D0 / - DATA WGK ( 9) / 0.0464348218 6749767472 0231880926 108 D0 / - DATA WGK ( 10) / 0.0509445739 2372869193 2707670050 345 D0 / - DATA WGK ( 11) / 0.0551951053 4828599474 4832372419 777 D0 / - DATA WGK ( 12) / 0.0591114008 8063957237 4967220648 594 D0 / - DATA WGK ( 13) / 0.0626532375 5478116802 5870122174 255 D0 / - DATA WGK ( 14) / 0.0658345971 3361842211 1563556969 398 D0 / - DATA WGK ( 15) / 0.0686486729 2852161934 5623411885 368 D0 / - DATA WGK ( 16) / 0.0710544235 5344406830 5790361723 210 D0 / - DATA WGK ( 17) / 0.0730306903 3278666749 5189417658 913 D0 / - DATA WGK ( 18) / 0.0745828754 0049918898 6581418362 488 D0 / - DATA WGK ( 19) / 0.0757044976 8455667465 9542775376 617 D0 / - DATA WGK ( 20) / 0.0763778676 7208073670 5502835038 061 D0 / - DATA WGK ( 21) / 0.0766007119 1799965644 5049901530 102 D0 / -C -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C CENTR - MID POINT OF THE INTERVAL -C HLGTH - HALF-LENGTH OF THE INTERVAL -C ABSC - ABSCISSA -C FVAL* - FUNCTION VALUE -C RESG - RESULT OF THE 20-POINT GAUSS FORMULA -C RESK - RESULT OF THE 41-POINT KRONROD FORMULA -C RESKH - APPROXIMATION TO MEAN VALUE OF F OVER (A,B), I.E. -C TO I/(B-A) -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT DQK41 - EPMACH = D1MACH(4) - UFLOW = D1MACH(1) -C - CENTR = 0.5D+00*(A+B) - HLGTH = 0.5D+00*(B-A) - DHLGTH = ABS(HLGTH) -C -C COMPUTE THE 41-POINT GAUSS-KRONROD APPROXIMATION TO -C THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. -C - RESG = 0.0D+00 - FC = F(CENTR) - RESK = WGK(21)*FC - RESABS = ABS(RESK) - DO 10 J=1,10 - JTW = J*2 - ABSC = HLGTH*XGK(JTW) - FVAL1 = F(CENTR-ABSC) - FVAL2 = F(CENTR+ABSC) - FV1(JTW) = FVAL1 - FV2(JTW) = FVAL2 - FSUM = FVAL1+FVAL2 - RESG = RESG+WG(J)*FSUM - RESK = RESK+WGK(JTW)*FSUM - RESABS = RESABS+WGK(JTW)*(ABS(FVAL1)+ABS(FVAL2)) - 10 CONTINUE - DO 15 J = 1,10 - JTWM1 = J*2-1 - ABSC = HLGTH*XGK(JTWM1) - FVAL1 = F(CENTR-ABSC) - FVAL2 = F(CENTR+ABSC) - FV1(JTWM1) = FVAL1 - FV2(JTWM1) = FVAL2 - FSUM = FVAL1+FVAL2 - RESK = RESK+WGK(JTWM1)*FSUM - RESABS = RESABS+WGK(JTWM1)*(ABS(FVAL1)+ABS(FVAL2)) - 15 CONTINUE - RESKH = RESK*0.5D+00 - RESASC = WGK(21)*ABS(FC-RESKH) - DO 20 J=1,20 - RESASC = RESASC+WGK(J)*(ABS(FV1(J)-RESKH)+ABS(FV2(J)-RESKH)) - 20 CONTINUE - RESULT = RESK*HLGTH - RESABS = RESABS*DHLGTH - RESASC = RESASC*DHLGTH - ABSERR = ABS((RESK-RESG)*HLGTH) - IF(RESASC.NE.0.0D+00.AND.ABSERR.NE.0.D+00) - 1 ABSERR = RESASC*MIN(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00) - IF(RESABS.GT.UFLOW/(0.5D+02*EPMACH)) ABSERR = MAX - 1 ((EPMACH*0.5D+02)*RESABS,ABSERR) - RETURN - END diff --git a/slatec/dqk51.f b/slatec/dqk51.f deleted file mode 100644 index 23df789..0000000 --- a/slatec/dqk51.f +++ /dev/null @@ -1,231 +0,0 @@ -*DECK DQK51 - SUBROUTINE DQK51 (F, A, B, RESULT, ABSERR, RESABS, RESASC) -C***BEGIN PROLOGUE DQK51 -C***PURPOSE To compute I = Integral of F over (A,B) with error -C estimate -C J = Integral of ABS(F) over (A,B) -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A1A2 -C***TYPE DOUBLE PRECISION (QK51-S, DQK51-D) -C***KEYWORDS 51-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration rules -C Standard fortran subroutine -C Double precision version -C -C PARAMETERS -C ON ENTRY -C F - Double precision -C Function subroutine defining the integrand -C function F(X). The actual name for F needs to be -C declared E X T E R N A L in the calling program. -C -C A - Double precision -C Lower limit of integration -C -C B - Double precision -C Upper limit of integration -C -C ON RETURN -C RESULT - Double precision -C Approximation to the integral I -C RESULT is computed by applying the 51-point -C Kronrod rule (RESK) obtained by optimal addition -C of abscissae to the 25-point Gauss rule (RESG). -C -C ABSERR - Double precision -C Estimate of the modulus of the absolute error, -C which should not exceed ABS(I-RESULT) -C -C RESABS - Double precision -C Approximation to the integral J -C -C RESASC - Double precision -C Approximation to the integral of ABS(F-I/(B-A)) -C over (A,B) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH -C***REVISION HISTORY (YYMMDD) -C 800101 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 910819 Added WGK(26) to code. (WRB) -C***END PROLOGUE DQK51 -C - DOUBLE PRECISION A,ABSC,ABSERR,B,CENTR,DHLGTH, - 1 D1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH,RESABS,RESASC, - 2 RESG,RESK,RESKH,RESULT,UFLOW,WG,WGK,XGK - INTEGER J,JTW,JTWM1 - EXTERNAL F -C - DIMENSION FV1(25),FV2(25),XGK(26),WGK(26),WG(13) -C -C THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). -C BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR -C CORRESPONDING WEIGHTS ARE GIVEN. -C -C XGK - ABSCISSAE OF THE 51-POINT KRONROD RULE -C XGK(2), XGK(4), ... ABSCISSAE OF THE 25-POINT -C GAUSS RULE -C XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY -C ADDED TO THE 25-POINT GAUSS RULE -C -C WGK - WEIGHTS OF THE 51-POINT KRONROD RULE -C -C WG - WEIGHTS OF THE 25-POINT GAUSS RULE -C -C -C GAUSS QUADRATURE WEIGHTS AND KRONROD QUADRATURE ABSCISSAE AND WEIGHTS -C AS EVALUATED WITH 80 DECIMAL DIGIT ARITHMETIC BY L. W. FULLERTON, -C BELL LABS, NOV. 1981. -C - SAVE WG, XGK, WGK - DATA WG ( 1) / 0.0113937985 0102628794 7902964113 235 D0 / - DATA WG ( 2) / 0.0263549866 1503213726 1901815295 299 D0 / - DATA WG ( 3) / 0.0409391567 0130631265 5623487711 646 D0 / - DATA WG ( 4) / 0.0549046959 7583519192 5936891540 473 D0 / - DATA WG ( 5) / 0.0680383338 1235691720 7187185656 708 D0 / - DATA WG ( 6) / 0.0801407003 3500101801 3234959669 111 D0 / - DATA WG ( 7) / 0.0910282619 8296364981 1497220702 892 D0 / - DATA WG ( 8) / 0.1005359490 6705064420 2206890392 686 D0 / - DATA WG ( 9) / 0.1085196244 7426365311 6093957050 117 D0 / - DATA WG ( 10) / 0.1148582591 4571164833 9325545869 556 D0 / - DATA WG ( 11) / 0.1194557635 3578477222 8178126512 901 D0 / - DATA WG ( 12) / 0.1222424429 9031004168 8959518945 852 D0 / - DATA WG ( 13) / 0.1231760537 2671545120 3902873079 050 D0 / -C - DATA XGK ( 1) / 0.9992621049 9260983419 3457486540 341 D0 / - DATA XGK ( 2) / 0.9955569697 9049809790 8784946893 902 D0 / - DATA XGK ( 3) / 0.9880357945 3407724763 7331014577 406 D0 / - DATA XGK ( 4) / 0.9766639214 5951751149 8315386479 594 D0 / - DATA XGK ( 5) / 0.9616149864 2584251241 8130033660 167 D0 / - DATA XGK ( 6) / 0.9429745712 2897433941 4011169658 471 D0 / - DATA XGK ( 7) / 0.9207471152 8170156174 6346084546 331 D0 / - DATA XGK ( 8) / 0.8949919978 7827536885 1042006782 805 D0 / - DATA XGK ( 9) / 0.8658470652 9327559544 8996969588 340 D0 / - DATA XGK ( 10) / 0.8334426287 6083400142 1021108693 570 D0 / - DATA XGK ( 11) / 0.7978737979 9850005941 0410904994 307 D0 / - DATA XGK ( 12) / 0.7592592630 3735763057 7282865204 361 D0 / - DATA XGK ( 13) / 0.7177664068 1308438818 6654079773 298 D0 / - DATA XGK ( 14) / 0.6735663684 7346836448 5120633247 622 D0 / - DATA XGK ( 15) / 0.6268100990 1031741278 8122681624 518 D0 / - DATA XGK ( 16) / 0.5776629302 4122296772 3689841612 654 D0 / - DATA XGK ( 17) / 0.5263252843 3471918259 9623778158 010 D0 / - DATA XGK ( 18) / 0.4730027314 4571496052 2182115009 192 D0 / - DATA XGK ( 19) / 0.4178853821 9303774885 1814394594 572 D0 / - DATA XGK ( 20) / 0.3611723058 0938783773 5821730127 641 D0 / - DATA XGK ( 21) / 0.3030895389 3110783016 7478909980 339 D0 / - DATA XGK ( 22) / 0.2438668837 2098843204 5190362797 452 D0 / - DATA XGK ( 23) / 0.1837189394 2104889201 5969888759 528 D0 / - DATA XGK ( 24) / 0.1228646926 1071039638 7359818808 037 D0 / - DATA XGK ( 25) / 0.0615444830 0568507888 6546392366 797 D0 / - DATA XGK ( 26) / 0.0000000000 0000000000 0000000000 000 D0 / -C - DATA WGK ( 1) / 0.0019873838 9233031592 6507851882 843 D0 / - DATA WGK ( 2) / 0.0055619321 3535671375 8040236901 066 D0 / - DATA WGK ( 3) / 0.0094739733 8617415160 7207710523 655 D0 / - DATA WGK ( 4) / 0.0132362291 9557167481 3656405846 976 D0 / - DATA WGK ( 5) / 0.0168478177 0912829823 1516667536 336 D0 / - DATA WGK ( 6) / 0.0204353711 4588283545 6568292235 939 D0 / - DATA WGK ( 7) / 0.0240099456 0695321622 0092489164 881 D0 / - DATA WGK ( 8) / 0.0274753175 8785173780 2948455517 811 D0 / - DATA WGK ( 9) / 0.0307923001 6738748889 1109020215 229 D0 / - DATA WGK ( 10) / 0.0340021302 7432933783 6748795229 551 D0 / - DATA WGK ( 11) / 0.0371162714 8341554356 0330625367 620 D0 / - DATA WGK ( 12) / 0.0400838255 0403238207 4839284467 076 D0 / - DATA WGK ( 13) / 0.0428728450 2017004947 6895792439 495 D0 / - DATA WGK ( 14) / 0.0455029130 4992178890 9870584752 660 D0 / - DATA WGK ( 15) / 0.0479825371 3883671390 6392255756 915 D0 / - DATA WGK ( 16) / 0.0502776790 8071567196 3325259433 440 D0 / - DATA WGK ( 17) / 0.0523628858 0640747586 4366712137 873 D0 / - DATA WGK ( 18) / 0.0542511298 8854549014 4543370459 876 D0 / - DATA WGK ( 19) / 0.0559508112 2041231730 8240686382 747 D0 / - DATA WGK ( 20) / 0.0574371163 6156783285 3582693939 506 D0 / - DATA WGK ( 21) / 0.0586896800 2239420796 1974175856 788 D0 / - DATA WGK ( 22) / 0.0597203403 2417405997 9099291932 562 D0 / - DATA WGK ( 23) / 0.0605394553 7604586294 5360267517 565 D0 / - DATA WGK ( 24) / 0.0611285097 1705304830 5859030416 293 D0 / - DATA WGK ( 25) / 0.0614711898 7142531666 1544131965 264 D0 / - DATA WGK ( 26) / 0.0615808180 6783293507 8759824240 055 D0 / -C -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C CENTR - MID POINT OF THE INTERVAL -C HLGTH - HALF-LENGTH OF THE INTERVAL -C ABSC - ABSCISSA -C FVAL* - FUNCTION VALUE -C RESG - RESULT OF THE 25-POINT GAUSS FORMULA -C RESK - RESULT OF THE 51-POINT KRONROD FORMULA -C RESKH - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B), -C I.E. TO I/(B-A) -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT DQK51 - EPMACH = D1MACH(4) - UFLOW = D1MACH(1) -C - CENTR = 0.5D+00*(A+B) - HLGTH = 0.5D+00*(B-A) - DHLGTH = ABS(HLGTH) -C -C COMPUTE THE 51-POINT KRONROD APPROXIMATION TO -C THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. -C - FC = F(CENTR) - RESG = WG(13)*FC - RESK = WGK(26)*FC - RESABS = ABS(RESK) - DO 10 J=1,12 - JTW = J*2 - ABSC = HLGTH*XGK(JTW) - FVAL1 = F(CENTR-ABSC) - FVAL2 = F(CENTR+ABSC) - FV1(JTW) = FVAL1 - FV2(JTW) = FVAL2 - FSUM = FVAL1+FVAL2 - RESG = RESG+WG(J)*FSUM - RESK = RESK+WGK(JTW)*FSUM - RESABS = RESABS+WGK(JTW)*(ABS(FVAL1)+ABS(FVAL2)) - 10 CONTINUE - DO 15 J = 1,13 - JTWM1 = J*2-1 - ABSC = HLGTH*XGK(JTWM1) - FVAL1 = F(CENTR-ABSC) - FVAL2 = F(CENTR+ABSC) - FV1(JTWM1) = FVAL1 - FV2(JTWM1) = FVAL2 - FSUM = FVAL1+FVAL2 - RESK = RESK+WGK(JTWM1)*FSUM - RESABS = RESABS+WGK(JTWM1)*(ABS(FVAL1)+ABS(FVAL2)) - 15 CONTINUE - RESKH = RESK*0.5D+00 - RESASC = WGK(26)*ABS(FC-RESKH) - DO 20 J=1,25 - RESASC = RESASC+WGK(J)*(ABS(FV1(J)-RESKH)+ABS(FV2(J)-RESKH)) - 20 CONTINUE - RESULT = RESK*HLGTH - RESABS = RESABS*DHLGTH - RESASC = RESASC*DHLGTH - ABSERR = ABS((RESK-RESG)*HLGTH) - IF(RESASC.NE.0.0D+00.AND.ABSERR.NE.0.0D+00) - 1 ABSERR = RESASC*MIN(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00) - IF(RESABS.GT.UFLOW/(0.5D+02*EPMACH)) ABSERR = MAX - 1 ((EPMACH*0.5D+02)*RESABS,ABSERR) - RETURN - END diff --git a/slatec/dqk61.f b/slatec/dqk61.f deleted file mode 100644 index 16d852c..0000000 --- a/slatec/dqk61.f +++ /dev/null @@ -1,241 +0,0 @@ -*DECK DQK61 - SUBROUTINE DQK61 (F, A, B, RESULT, ABSERR, RESABS, RESASC) -C***BEGIN PROLOGUE DQK61 -C***PURPOSE To compute I = Integral of F over (A,B) with error -C estimate -C J = Integral of ABS(F) over (A,B) -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A1A2 -C***TYPE DOUBLE PRECISION (QK61-S, DQK61-D) -C***KEYWORDS 61-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration rule -C Standard fortran subroutine -C Double precision version -C -C -C PARAMETERS -C ON ENTRY -C F - Double precision -C Function subprogram defining the integrand -C function F(X). The actual name for F needs to be -C declared E X T E R N A L in the calling program. -C -C A - Double precision -C Lower limit of integration -C -C B - Double precision -C Upper limit of integration -C -C ON RETURN -C RESULT - Double precision -C Approximation to the integral I -C RESULT is computed by applying the 61-point -C Kronrod rule (RESK) obtained by optimal addition of -C abscissae to the 30-point Gauss rule (RESG). -C -C ABSERR - Double precision -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C RESABS - Double precision -C Approximation to the integral J -C -C RESASC - Double precision -C Approximation to the integral of ABS(F-I/(B-A)) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH -C***REVISION HISTORY (YYMMDD) -C 800101 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***END PROLOGUE DQK61 -C - DOUBLE PRECISION A,DABSC,ABSERR,B,CENTR,DHLGTH, - 1 D1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH,RESABS,RESASC, - 2 RESG,RESK,RESKH,RESULT,UFLOW,WG,WGK,XGK - INTEGER J,JTW,JTWM1 - EXTERNAL F -C - DIMENSION FV1(30),FV2(30),XGK(31),WGK(31),WG(15) -C -C THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE -C INTERVAL (-1,1). BECAUSE OF SYMMETRY ONLY THE POSITIVE -C ABSCISSAE AND THEIR CORRESPONDING WEIGHTS ARE GIVEN. -C -C XGK - ABSCISSAE OF THE 61-POINT KRONROD RULE -C XGK(2), XGK(4) ... ABSCISSAE OF THE 30-POINT -C GAUSS RULE -C XGK(1), XGK(3) ... OPTIMALLY ADDED ABSCISSAE -C TO THE 30-POINT GAUSS RULE -C -C WGK - WEIGHTS OF THE 61-POINT KRONROD RULE -C -C WG - WEIGHTS OF THE 30-POINT GAUSS RULE -C -C -C GAUSS QUADRATURE WEIGHTS AND KRONROD QUADRATURE ABSCISSAE AND WEIGHTS -C AS EVALUATED WITH 80 DECIMAL DIGIT ARITHMETIC BY L. W. FULLERTON, -C BELL LABS, NOV. 1981. -C - SAVE WG, XGK, WGK - DATA WG ( 1) / 0.0079681924 9616660561 5465883474 674 D0 / - DATA WG ( 2) / 0.0184664683 1109095914 2302131912 047 D0 / - DATA WG ( 3) / 0.0287847078 8332336934 9719179611 292 D0 / - DATA WG ( 4) / 0.0387991925 6962704959 6801936446 348 D0 / - DATA WG ( 5) / 0.0484026728 3059405290 2938140422 808 D0 / - DATA WG ( 6) / 0.0574931562 1761906648 1721689402 056 D0 / - DATA WG ( 7) / 0.0659742298 8218049512 8128515115 962 D0 / - DATA WG ( 8) / 0.0737559747 3770520626 8243850022 191 D0 / - DATA WG ( 9) / 0.0807558952 2942021535 4694938460 530 D0 / - DATA WG ( 10) / 0.0868997872 0108297980 2387530715 126 D0 / - DATA WG ( 11) / 0.0921225222 3778612871 7632707087 619 D0 / - DATA WG ( 12) / 0.0963687371 7464425963 9468626351 810 D0 / - DATA WG ( 13) / 0.0995934205 8679526706 2780282103 569 D0 / - DATA WG ( 14) / 0.1017623897 4840550459 6428952168 554 D0 / - DATA WG ( 15) / 0.1028526528 9355884034 1285636705 415 D0 / -C - DATA XGK ( 1) / 0.9994844100 5049063757 1325895705 811 D0 / - DATA XGK ( 2) / 0.9968934840 7464954027 1630050918 695 D0 / - DATA XGK ( 3) / 0.9916309968 7040459485 8628366109 486 D0 / - DATA XGK ( 4) / 0.9836681232 7974720997 0032581605 663 D0 / - DATA XGK ( 5) / 0.9731163225 0112626837 4693868423 707 D0 / - DATA XGK ( 6) / 0.9600218649 6830751221 6871025581 798 D0 / - DATA XGK ( 7) / 0.9443744447 4855997941 5831324037 439 D0 / - DATA XGK ( 8) / 0.9262000474 2927432587 9324277080 474 D0 / - DATA XGK ( 9) / 0.9055733076 9990779854 6522558925 958 D0 / - DATA XGK ( 10) / 0.8825605357 9205268154 3116462530 226 D0 / - DATA XGK ( 11) / 0.8572052335 4606109895 8658510658 944 D0 / - DATA XGK ( 12) / 0.8295657623 8276839744 2898119732 502 D0 / - DATA XGK ( 13) / 0.7997278358 2183908301 3668942322 683 D0 / - DATA XGK ( 14) / 0.7677774321 0482619491 7977340974 503 D0 / - DATA XGK ( 15) / 0.7337900624 5322680472 6171131369 528 D0 / - DATA XGK ( 16) / 0.6978504947 9331579693 2292388026 640 D0 / - DATA XGK ( 17) / 0.6600610641 2662696137 0053668149 271 D0 / - DATA XGK ( 18) / 0.6205261829 8924286114 0477556431 189 D0 / - DATA XGK ( 19) / 0.5793452358 2636169175 6024932172 540 D0 / - DATA XGK ( 20) / 0.5366241481 4201989926 4169793311 073 D0 / - DATA XGK ( 21) / 0.4924804678 6177857499 3693061207 709 D0 / - DATA XGK ( 22) / 0.4470337695 3808917678 0609900322 854 D0 / - DATA XGK ( 23) / 0.4004012548 3039439253 5476211542 661 D0 / - DATA XGK ( 24) / 0.3527047255 3087811347 1037207089 374 D0 / - DATA XGK ( 25) / 0.3040732022 7362507737 2677107199 257 D0 / - DATA XGK ( 26) / 0.2546369261 6788984643 9805129817 805 D0 / - DATA XGK ( 27) / 0.2045251166 8230989143 8957671002 025 D0 / - DATA XGK ( 28) / 0.1538699136 0858354696 3794672743 256 D0 / - DATA XGK ( 29) / 0.1028069379 6673703014 7096751318 001 D0 / - DATA XGK ( 30) / 0.0514718425 5531769583 3025213166 723 D0 / - DATA XGK ( 31) / 0.0000000000 0000000000 0000000000 000 D0 / -C - DATA WGK ( 1) / 0.0013890136 9867700762 4551591226 760 D0 / - DATA WGK ( 2) / 0.0038904611 2709988405 1267201844 516 D0 / - DATA WGK ( 3) / 0.0066307039 1593129217 3319826369 750 D0 / - DATA WGK ( 4) / 0.0092732796 5951776342 8441146892 024 D0 / - DATA WGK ( 5) / 0.0118230152 5349634174 2232898853 251 D0 / - DATA WGK ( 6) / 0.0143697295 0704580481 2451432443 580 D0 / - DATA WGK ( 7) / 0.0169208891 8905327262 7572289420 322 D0 / - DATA WGK ( 8) / 0.0194141411 9394238117 3408951050 128 D0 / - DATA WGK ( 9) / 0.0218280358 2160919229 7167485738 339 D0 / - DATA WGK ( 10) / 0.0241911620 7808060136 5686370725 232 D0 / - DATA WGK ( 11) / 0.0265099548 8233310161 0601709335 075 D0 / - DATA WGK ( 12) / 0.0287540487 6504129284 3978785354 334 D0 / - DATA WGK ( 13) / 0.0309072575 6238776247 2884252943 092 D0 / - DATA WGK ( 14) / 0.0329814470 5748372603 1814191016 854 D0 / - DATA WGK ( 15) / 0.0349793380 2806002413 7499670731 468 D0 / - DATA WGK ( 16) / 0.0368823646 5182122922 3911065617 136 D0 / - DATA WGK ( 17) / 0.0386789456 2472759295 0348651532 281 D0 / - DATA WGK ( 18) / 0.0403745389 5153595911 1995279752 468 D0 / - DATA WGK ( 19) / 0.0419698102 1516424614 7147541285 970 D0 / - DATA WGK ( 20) / 0.0434525397 0135606931 6831728117 073 D0 / - DATA WGK ( 21) / 0.0448148001 3316266319 2355551616 723 D0 / - DATA WGK ( 22) / 0.0460592382 7100698811 6271735559 374 D0 / - DATA WGK ( 23) / 0.0471855465 6929915394 5261478181 099 D0 / - DATA WGK ( 24) / 0.0481858617 5708712914 0779492298 305 D0 / - DATA WGK ( 25) / 0.0490554345 5502977888 7528165367 238 D0 / - DATA WGK ( 26) / 0.0497956834 2707420635 7811569379 942 D0 / - DATA WGK ( 27) / 0.0504059214 0278234684 0893085653 585 D0 / - DATA WGK ( 28) / 0.0508817958 9874960649 2297473049 805 D0 / - DATA WGK ( 29) / 0.0512215478 4925877217 0656282604 944 D0 / - DATA WGK ( 30) / 0.0514261285 3745902593 3862879215 781 D0 / - DATA WGK ( 31) / 0.0514947294 2945156755 8340433647 099 D0 / -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C CENTR - MID POINT OF THE INTERVAL -C HLGTH - HALF-LENGTH OF THE INTERVAL -C DABSC - ABSCISSA -C FVAL* - FUNCTION VALUE -C RESG - RESULT OF THE 30-POINT GAUSS RULE -C RESK - RESULT OF THE 61-POINT KRONROD RULE -C RESKH - APPROXIMATION TO THE MEAN VALUE OF F -C OVER (A,B), I.E. TO I/(B-A) -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT DQK61 - EPMACH = D1MACH(4) - UFLOW = D1MACH(1) -C - CENTR = 0.5D+00*(B+A) - HLGTH = 0.5D+00*(B-A) - DHLGTH = ABS(HLGTH) -C -C COMPUTE THE 61-POINT KRONROD APPROXIMATION TO THE -C INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. -C - RESG = 0.0D+00 - FC = F(CENTR) - RESK = WGK(31)*FC - RESABS = ABS(RESK) - DO 10 J=1,15 - JTW = J*2 - DABSC = HLGTH*XGK(JTW) - FVAL1 = F(CENTR-DABSC) - FVAL2 = F(CENTR+DABSC) - FV1(JTW) = FVAL1 - FV2(JTW) = FVAL2 - FSUM = FVAL1+FVAL2 - RESG = RESG+WG(J)*FSUM - RESK = RESK+WGK(JTW)*FSUM - RESABS = RESABS+WGK(JTW)*(ABS(FVAL1)+ABS(FVAL2)) - 10 CONTINUE - DO 15 J=1,15 - JTWM1 = J*2-1 - DABSC = HLGTH*XGK(JTWM1) - FVAL1 = F(CENTR-DABSC) - FVAL2 = F(CENTR+DABSC) - FV1(JTWM1) = FVAL1 - FV2(JTWM1) = FVAL2 - FSUM = FVAL1+FVAL2 - RESK = RESK+WGK(JTWM1)*FSUM - RESABS = RESABS+WGK(JTWM1)*(ABS(FVAL1)+ABS(FVAL2)) - 15 CONTINUE - RESKH = RESK*0.5D+00 - RESASC = WGK(31)*ABS(FC-RESKH) - DO 20 J=1,30 - RESASC = RESASC+WGK(J)*(ABS(FV1(J)-RESKH)+ABS(FV2(J)-RESKH)) - 20 CONTINUE - RESULT = RESK*HLGTH - RESABS = RESABS*DHLGTH - RESASC = RESASC*DHLGTH - ABSERR = ABS((RESK-RESG)*HLGTH) - IF(RESASC.NE.0.0D+00.AND.ABSERR.NE.0.0D+00) - 1 ABSERR = RESASC*MIN(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00) - IF(RESABS.GT.UFLOW/(0.5D+02*EPMACH)) ABSERR = MAX - 1 ((EPMACH*0.5D+02)*RESABS,ABSERR) - RETURN - END diff --git a/slatec/dqmomo.f b/slatec/dqmomo.f deleted file mode 100644 index cdc08a7..0000000 --- a/slatec/dqmomo.f +++ /dev/null @@ -1,137 +0,0 @@ -*DECK DQMOMO - SUBROUTINE DQMOMO (ALFA, BETA, RI, RJ, RG, RH, INTEGR) -C***BEGIN PROLOGUE DQMOMO -C***PURPOSE This routine computes modified Chebyshev moments. The K-th -C modified Chebyshev moment is defined as the integral over -C (-1,1) of W(X)*T(K,X), where T(K,X) is the Chebyshev -C polynomial of degree K. -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A2A1, C3A2 -C***TYPE DOUBLE PRECISION (QMOMO-S, DQMOMO-D) -C***KEYWORDS MODIFIED CHEBYSHEV MOMENTS, QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C MODIFIED CHEBYSHEV MOMENTS -C STANDARD FORTRAN SUBROUTINE -C DOUBLE PRECISION VERSION -C -C PARAMETERS -C ALFA - Double precision -C Parameter in the weight function W(X), ALFA.GT.(-1) -C -C BETA - Double precision -C Parameter in the weight function W(X), BETA.GT.(-1) -C -C RI - Double precision -C Vector of dimension 25 -C RI(K) is the integral over (-1,1) of -C (1+X)**ALFA*T(K-1,X), K = 1, ..., 25. -C -C RJ - Double precision -C Vector of dimension 25 -C RJ(K) is the integral over (-1,1) of -C (1-X)**BETA*T(K-1,X), K = 1, ..., 25. -C -C RG - Double precision -C Vector of dimension 25 -C RG(K) is the integral over (-1,1) of -C (1+X)**ALFA*LOG((1+X)/2)*T(K-1,X), K = 1, ..., 25. -C -C RH - Double precision -C Vector of dimension 25 -C RH(K) is the integral over (-1,1) of -C (1-X)**BETA*LOG((1-X)/2)*T(K-1,X), K = 1, ..., 25. -C -C INTEGR - Integer -C Input parameter indicating the modified -C Moments to be computed -C INTEGR = 1 compute RI, RJ -C = 2 compute RI, RJ, RG -C = 3 compute RI, RJ, RH -C = 4 compute RI, RJ, RG, RH -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 820101 DATE WRITTEN -C 891009 Removed unreferenced statement label. (WRB) -C 891009 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE DQMOMO -C - DOUBLE PRECISION ALFA,ALFP1,ALFP2,AN,ANM1,BETA,BETP1,BETP2,RALF, - 1 RBET,RG,RH,RI,RJ - INTEGER I,IM1,INTEGR -C - DIMENSION RG(25),RH(25),RI(25),RJ(25) -C -C -C***FIRST EXECUTABLE STATEMENT DQMOMO - ALFP1 = ALFA+0.1D+01 - BETP1 = BETA+0.1D+01 - ALFP2 = ALFA+0.2D+01 - BETP2 = BETA+0.2D+01 - RALF = 0.2D+01**ALFP1 - RBET = 0.2D+01**BETP1 -C -C COMPUTE RI, RJ USING A FORWARD RECURRENCE RELATION. -C - RI(1) = RALF/ALFP1 - RJ(1) = RBET/BETP1 - RI(2) = RI(1)*ALFA/ALFP2 - RJ(2) = RJ(1)*BETA/BETP2 - AN = 0.2D+01 - ANM1 = 0.1D+01 - DO 20 I=3,25 - RI(I) = -(RALF+AN*(AN-ALFP2)*RI(I-1))/(ANM1*(AN+ALFP1)) - RJ(I) = -(RBET+AN*(AN-BETP2)*RJ(I-1))/(ANM1*(AN+BETP1)) - ANM1 = AN - AN = AN+0.1D+01 - 20 CONTINUE - IF(INTEGR.EQ.1) GO TO 70 - IF(INTEGR.EQ.3) GO TO 40 -C -C COMPUTE RG USING A FORWARD RECURRENCE RELATION. -C - RG(1) = -RI(1)/ALFP1 - RG(2) = -(RALF+RALF)/(ALFP2*ALFP2)-RG(1) - AN = 0.2D+01 - ANM1 = 0.1D+01 - IM1 = 2 - DO 30 I=3,25 - RG(I) = -(AN*(AN-ALFP2)*RG(IM1)-AN*RI(IM1)+ANM1*RI(I))/ - 1 (ANM1*(AN+ALFP1)) - ANM1 = AN - AN = AN+0.1D+01 - IM1 = I - 30 CONTINUE - IF(INTEGR.EQ.2) GO TO 70 -C -C COMPUTE RH USING A FORWARD RECURRENCE RELATION. -C - 40 RH(1) = -RJ(1)/BETP1 - RH(2) = -(RBET+RBET)/(BETP2*BETP2)-RH(1) - AN = 0.2D+01 - ANM1 = 0.1D+01 - IM1 = 2 - DO 50 I=3,25 - RH(I) = -(AN*(AN-BETP2)*RH(IM1)-AN*RJ(IM1)+ - 1 ANM1*RJ(I))/(ANM1*(AN+BETP1)) - ANM1 = AN - AN = AN+0.1D+01 - IM1 = I - 50 CONTINUE - DO 60 I=2,25,2 - RH(I) = -RH(I) - 60 CONTINUE - 70 DO 80 I=2,25,2 - RJ(I) = -RJ(I) - 80 CONTINUE - RETURN - END diff --git a/slatec/dqnc79.f b/slatec/dqnc79.f deleted file mode 100644 index 8736a4f..0000000 --- a/slatec/dqnc79.f +++ /dev/null @@ -1,275 +0,0 @@ -*DECK DQNC79 - SUBROUTINE DQNC79 (FUN, A, B, ERR, ANS, IERR, K) -C***BEGIN PROLOGUE DQNC79 -C***PURPOSE Integrate a function using a 7-point adaptive Newton-Cotes -C quadrature rule. -C***LIBRARY SLATEC -C***CATEGORY H2A1A1 -C***TYPE DOUBLE PRECISION (QNC79-S, DQNC79-D) -C***KEYWORDS ADAPTIVE QUADRATURE, INTEGRATION, NEWTON-COTES -C***AUTHOR Kahaner, D. K., (NBS) -C Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract *** a DOUBLE PRECISION routine *** -C DQNC79 is a general purpose program for evaluation of -C one dimensional integrals of user defined functions. -C DQNC79 will pick its own points for evaluation of the -C integrand and these will vary from problem to problem. -C Thus, DQNC79 is not designed to integrate over data sets. -C Moderately smooth integrands will be integrated efficiently -C and reliably. For problems with strong singularities, -C oscillations etc., the user may wish to use more sophis- -C ticated routines such as those in QUADPACK. One measure -C of the reliability of DQNC79 is the output parameter K, -C giving the number of integrand evaluations that were needed. -C -C Description of Arguments -C -C --Input--* FUN, A, B, ERR are DOUBLE PRECISION * -C FUN - name of external function to be integrated. This name -C must be in an EXTERNAL statement in your calling -C program. You must write a Fortran function to evaluate -C FUN. This should be of the form -C DOUBLE PRECISION FUNCTION FUN (X) -C C -C C X can vary from A to B -C C FUN(X) should be finite for all X on interval. -C C -C FUN = ... -C RETURN -C END -C A - lower limit of integration -C B - upper limit of integration (may be less than A) -C ERR - is a requested error tolerance. Normally, pick a value -C 0 .LT. ERR .LT. 1.0D-8. -C -C --Output-- -C ANS - computed value of the integral. Hopefully, ANS is -C accurate to within ERR * integral of ABS(FUN(X)). -C IERR - a status code -C - Normal codes -C 1 ANS most likely meets requested error tolerance. -C -1 A equals B, or A and B are too nearly equal to -C allow normal integration. ANS is set to zero. -C - Abnormal code -C 2 ANS probably does not meet requested error tolerance. -C K - the number of function evaluations actually used to do -C the integration. A value of K .GT. 1000 indicates a -C difficult problem; other programs may be more efficient. -C DQNC79 will gracefully give up if K exceeds 2000. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, I1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 890911 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 920218 Code redone to parallel QNC79. (WRB) -C 930120 Increase array size 80->99, and KMX 2000->5000 for SUN -r8 -C wordlength. (RWC) -C***END PROLOGUE DQNC79 -C .. Scalar Arguments .. - DOUBLE PRECISION A, ANS, B, ERR - INTEGER IERR, K -C .. Function Arguments .. - DOUBLE PRECISION FUN - EXTERNAL FUN -C .. Local Scalars .. - DOUBLE PRECISION AE, AREA, BANK, BLOCAL, C, CE, EE, EF, EPS, Q13, - + Q7, Q7L, SQ2, TEST, TOL, VR, W1, W2, W3, W4 - INTEGER I, KML, KMX, L, LMN, LMX, NBITS, NIB, NLMN, NLMX - LOGICAL FIRST -C .. Local Arrays .. - DOUBLE PRECISION AA(99), F(13), F1(99), F2(99), F3(99), F4(99), - + F5(99), F6(99), F7(99), HH(99), Q7R(99), VL(99) - INTEGER LR(99) -C .. External Functions .. - DOUBLE PRECISION D1MACH - INTEGER I1MACH - EXTERNAL D1MACH, I1MACH -C .. External Subroutines .. - EXTERNAL XERMSG -C .. Intrinsic Functions .. - INTRINSIC ABS, LOG, MAX, MIN, SIGN, SQRT -C .. Save statement .. - SAVE NBITS, NLMX, FIRST, SQ2, W1, W2, W3, W4 -C .. Data statements .. - DATA KML /7/, KMX /5000/, NLMN /2/ - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DQNC79 - IF (FIRST) THEN - W1 = 41.0D0/140.0D0 - W2 = 216.0D0/140.0D0 - W3 = 27.0D0/140.0D0 - W4 = 272.0D0/140.0D0 - NBITS = D1MACH(5)*I1MACH(14)/0.30102000D0 - NLMX = MIN(99,(NBITS*4)/5) - SQ2 = SQRT(2.0D0) - ENDIF - FIRST = .FALSE. - ANS = 0.0D0 - IERR = 1 - CE = 0.0D0 - IF (A .EQ. B) GO TO 260 - LMX = NLMX - LMN = NLMN - IF (B .EQ. 0.0D0) GO TO 100 - IF (SIGN(1.0D0,B)*A .LE. 0.0D0) GO TO 100 - C = ABS(1.0D0-A/B) - IF (C .GT. 0.1D0) GO TO 100 - IF (C .LE. 0.0D0) GO TO 260 - NIB = 0.5D0 - LOG(C)/LOG(2.0D0) - LMX = MIN(NLMX,NBITS-NIB-4) - IF (LMX .LT. 2) GO TO 260 - LMN = MIN(LMN,LMX) - 100 TOL = MAX(ABS(ERR),2.0D0**(5-NBITS)) - IF (ERR .EQ. 0.0D0) TOL = SQRT(D1MACH(4)) - EPS = TOL - HH(1) = (B-A)/12.0D0 - AA(1) = A - LR(1) = 1 - DO 110 I = 1,11,2 - F(I) = FUN(A+(I-1)*HH(1)) - 110 CONTINUE - BLOCAL = B - F(13) = FUN(BLOCAL) - K = 7 - L = 1 - AREA = 0.0D0 - Q7 = 0.0D0 - EF = 256.0D0/255.0D0 - BANK = 0.0D0 -C -C Compute refined estimates, estimate the error, etc. -C - 120 DO 130 I = 2,12,2 - F(I) = FUN(AA(L)+(I-1)*HH(L)) - 130 CONTINUE - K = K + 6 -C -C Compute left and right half estimates -C - Q7L = HH(L)*((W1*(F(1)+F(7))+W2*(F(2)+F(6)))+ - + (W3*(F(3)+F(5))+W4*F(4))) - Q7R(L) = HH(L)*((W1*(F(7)+F(13))+W2*(F(8)+F(12)))+ - + (W3*(F(9)+F(11))+W4*F(10))) -C -C Update estimate of integral of absolute value -C - AREA = AREA + (ABS(Q7L)+ABS(Q7R(L))-ABS(Q7)) -C -C Do not bother to test convergence before minimum refinement level -C - IF (L .LT. LMN) GO TO 180 -C -C Estimate the error in new value for whole interval, Q13 -C - Q13 = Q7L + Q7R(L) - EE = ABS(Q7-Q13)*EF -C -C Compute nominal allowed error -C - AE = EPS*AREA -C -C Borrow from bank account, but not too much -C - TEST = MIN(AE+0.8D0*BANK,10.0D0*AE) -C -C Don't ask for excessive accuracy -C - TEST = MAX(TEST,TOL*ABS(Q13),0.00003D0*TOL*AREA) -C -C Now, did this interval pass or not? -C - IF (EE-TEST) 150,150,170 -C -C Have hit maximum refinement level -- penalize the cumulative error -C - 140 CE = CE + (Q7-Q13) - GO TO 160 -C -C On good intervals accumulate the theoretical estimate -C - 150 CE = CE + (Q7-Q13)/255.0D0 -C -C Update the bank account. Don't go into debt. -C - 160 BANK = BANK + (AE-EE) - IF (BANK .LT. 0.0D0) BANK = 0.0D0 -C -C Did we just finish a left half or a right half? -C - IF (LR(L)) 190,190,210 -C -C Consider the left half of next deeper level -C - 170 IF (K .GT. KMX) LMX = MIN(KML,LMX) - IF (L .GE. LMX) GO TO 140 - 180 L = L + 1 - EPS = EPS*0.5D0 - IF (L .LE. 17) EF = EF/SQ2 - HH(L) = HH(L-1)*0.5D0 - LR(L) = -1 - AA(L) = AA(L-1) - Q7 = Q7L - F1(L) = F(7) - F2(L) = F(8) - F3(L) = F(9) - F4(L) = F(10) - F5(L) = F(11) - F6(L) = F(12) - F7(L) = F(13) - F(13) = F(7) - F(11) = F(6) - F(9) = F(5) - F(7) = F(4) - F(5) = F(3) - F(3) = F(2) - GO TO 120 -C -C Proceed to right half at this level -C - 190 VL(L) = Q13 - 200 Q7 = Q7R(L-1) - LR(L) = 1 - AA(L) = AA(L) + 12.0D0*HH(L) - F(1) = F1(L) - F(3) = F2(L) - F(5) = F3(L) - F(7) = F4(L) - F(9) = F5(L) - F(11) = F6(L) - F(13) = F7(L) - GO TO 120 -C -C Left and right halves are done, so go back up a level -C - 210 VR = Q13 - 220 IF (L .LE. 1) GO TO 250 - IF (L .LE. 17) EF = EF*SQ2 - EPS = EPS*2.0D0 - L = L - 1 - IF (LR(L)) 230,230,240 - 230 VL(L) = VL(L+1) + VR - GO TO 200 - 240 VR = VL(L+1) + VR - GO TO 220 -C -C Exit -C - 250 ANS = VR - IF (ABS(CE) .LE. 2.0D0*TOL*AREA) GO TO 270 - IERR = 2 - CALL XERMSG ('SLATEC', 'DQNC79', - + 'ANS is probably insufficiently accurate.', 2, 1) - GO TO 270 - 260 IERR = -1 - CALL XERMSG ('SLATEC', 'DQNC79', - + 'A and B are too nearly equal to allow normal integration. $$' - + // 'ANS is set to zero and IERR to -1.', -1, -1) - 270 RETURN - END diff --git a/slatec/dqng.f b/slatec/dqng.f deleted file mode 100644 index b17633c..0000000 --- a/slatec/dqng.f +++ /dev/null @@ -1,386 +0,0 @@ -*DECK DQNG - SUBROUTINE DQNG (F, A, B, EPSABS, EPSREL, RESULT, ABSERR, NEVAL, - + IER) -C***BEGIN PROLOGUE DQNG -C***PURPOSE The routine calculates an approximation result to a -C given definite integral I = integral of F over (A,B), -C hopefully satisfying following claim for accuracy -C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A1A1 -C***TYPE DOUBLE PRECISION (QNG-S, DQNG-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, GAUSS-KRONROD(PATTERSON) RULES, -C NONADAPTIVE, QUADPACK, QUADRATURE, SMOOTH INTEGRAND -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C NON-ADAPTIVE INTEGRATION -C STANDARD FORTRAN SUBROUTINE -C DOUBLE PRECISION VERSION -C -C F - Double precision -C Function subprogram defining the integrand function -C F(X). The actual name for F needs to be declared -C E X T E R N A L in the driver program. -C -C A - Double precision -C Lower limit of integration -C -C B - Double precision -C Upper limit of integration -C -C EPSABS - Double precision -C Absolute accuracy requested -C EPSREL - Double precision -C Relative accuracy requested -C If EPSABS.LE.0 -C And EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C The routine will end with IER = 6. -C -C ON RETURN -C RESULT - Double precision -C Approximation to the integral I -C Result is obtained by applying the 21-POINT -C GAUSS-KRONROD RULE (RES21) obtained by optimal -C addition of abscissae to the 10-POINT GAUSS RULE -C (RES10), or by applying the 43-POINT RULE (RES43) -C obtained by optimal addition of abscissae to the -C 21-POINT GAUSS-KRONROD RULE, or by applying the -C 87-POINT RULE (RES87) obtained by optimal addition -C of abscissae to the 43-POINT RULE. -C -C ABSERR - Double precision -C Estimate of the modulus of the absolute error, -C which should EQUAL or EXCEED ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - IER = 0 normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C IER.GT.0 Abnormal termination of the routine. It is -C assumed that the requested accuracy has -C not been achieved. -C ERROR MESSAGES -C IER = 1 The maximum number of steps has been -C executed. The integral is probably too -C difficult to be calculated by DQNG. -C = 6 The input is invalid, because -C EPSABS.LE.0 AND -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28). -C RESULT, ABSERR and NEVAL are set to zero. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800101 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***END PROLOGUE DQNG -C - DOUBLE PRECISION A,ABSC,ABSERR,B,CENTR,DHLGTH, - 1 D1MACH,EPMACH,EPSABS,EPSREL,F,FCENTR,FVAL,FVAL1,FVAL2,FV1,FV2, - 2 FV3,FV4,HLGTH,RESULT,RES10,RES21,RES43,RES87,RESABS,RESASC, - 3 RESKH,SAVFUN,UFLOW,W10,W21A,W21B,W43A,W43B,W87A,W87B,X1,X2,X3,X4 - INTEGER IER,IPX,K,L,NEVAL - EXTERNAL F -C - DIMENSION FV1(5),FV2(5),FV3(5),FV4(5),X1(5),X2(5),X3(11),X4(22), - 1 W10(5),W21A(5),W21B(6),W43A(10),W43B(12),W87A(21),W87B(23), - 2 SAVFUN(21) -C -C THE FOLLOWING DATA STATEMENTS CONTAIN THE -C ABSCISSAE AND WEIGHTS OF THE INTEGRATION RULES USED. -C -C X1 ABSCISSAE COMMON TO THE 10-, 21-, 43- AND 87- -C POINT RULE -C X2 ABSCISSAE COMMON TO THE 21-, 43- AND 87-POINT RULE -C X3 ABSCISSAE COMMON TO THE 43- AND 87-POINT RULE -C X4 ABSCISSAE OF THE 87-POINT RULE -C W10 WEIGHTS OF THE 10-POINT FORMULA -C W21A WEIGHTS OF THE 21-POINT FORMULA FOR ABSCISSAE X1 -C W21B WEIGHTS OF THE 21-POINT FORMULA FOR ABSCISSAE X2 -C W43A WEIGHTS OF THE 43-POINT FORMULA FOR ABSCISSAE X1, X3 -C W43B WEIGHTS OF THE 43-POINT FORMULA FOR ABSCISSAE X3 -C W87A WEIGHTS OF THE 87-POINT FORMULA FOR ABSCISSAE X1, -C X2, X3 -C W87B WEIGHTS OF THE 87-POINT FORMULA FOR ABSCISSAE X4 -C -C -C GAUSS-KRONROD-PATTERSON QUADRATURE COEFFICIENTS FOR USE IN -C QUADPACK ROUTINE QNG. THESE COEFFICIENTS WERE CALCULATED WITH -C 101 DECIMAL DIGIT ARITHMETIC BY L. W. FULLERTON, BELL LABS, NOV 1981. -C - SAVE X1, W10, X2, W21A, W21B, X3, W43A, W43B, X4, W87A, W87B - DATA X1 ( 1) / 0.9739065285 1717172007 7964012084 452 D0 / - DATA X1 ( 2) / 0.8650633666 8898451073 2096688423 493 D0 / - DATA X1 ( 3) / 0.6794095682 9902440623 4327365114 874 D0 / - DATA X1 ( 4) / 0.4333953941 2924719079 9265943165 784 D0 / - DATA X1 ( 5) / 0.1488743389 8163121088 4826001129 720 D0 / - DATA W10 ( 1) / 0.0666713443 0868813759 3568809893 332 D0 / - DATA W10 ( 2) / 0.1494513491 5058059314 5776339657 697 D0 / - DATA W10 ( 3) / 0.2190863625 1598204399 5534934228 163 D0 / - DATA W10 ( 4) / 0.2692667193 0999635509 1226921569 469 D0 / - DATA W10 ( 5) / 0.2955242247 1475287017 3892994651 338 D0 / -C - DATA X2 ( 1) / 0.9956571630 2580808073 5527280689 003 D0 / - DATA X2 ( 2) / 0.9301574913 5570822600 1207180059 508 D0 / - DATA X2 ( 3) / 0.7808177265 8641689706 3717578345 042 D0 / - DATA X2 ( 4) / 0.5627571346 6860468333 9000099272 694 D0 / - DATA X2 ( 5) / 0.2943928627 0146019813 1126603103 866 D0 / - DATA W21A ( 1) / 0.0325581623 0796472747 8818972459 390 D0 / - DATA W21A ( 2) / 0.0750396748 1091995276 7043140916 190 D0 / - DATA W21A ( 3) / 0.1093871588 0229764189 9210590325 805 D0 / - DATA W21A ( 4) / 0.1347092173 1147332592 8054001771 707 D0 / - DATA W21A ( 5) / 0.1477391049 0133849137 4841515972 068 D0 / - DATA W21B ( 1) / 0.0116946388 6737187427 8064396062 192 D0 / - DATA W21B ( 2) / 0.0547558965 7435199603 1381300244 580 D0 / - DATA W21B ( 3) / 0.0931254545 8369760553 5065465083 366 D0 / - DATA W21B ( 4) / 0.1234919762 6206585107 7958109831 074 D0 / - DATA W21B ( 5) / 0.1427759385 7706008079 7094273138 717 D0 / - DATA W21B ( 6) / 0.1494455540 0291690566 4936468389 821 D0 / -C - DATA X3 ( 1) / 0.9993333609 0193208139 4099323919 911 D0 / - DATA X3 ( 2) / 0.9874334029 0808886979 5961478381 209 D0 / - DATA X3 ( 3) / 0.9548079348 1426629925 7919200290 473 D0 / - DATA X3 ( 4) / 0.9001486957 4832829362 5099494069 092 D0 / - DATA X3 ( 5) / 0.8251983149 8311415084 7066732588 520 D0 / - DATA X3 ( 6) / 0.7321483889 8930498261 2354848755 461 D0 / - DATA X3 ( 7) / 0.6228479705 3772523864 1159120344 323 D0 / - DATA X3 ( 8) / 0.4994795740 7105649995 2214885499 755 D0 / - DATA X3 ( 9) / 0.3649016613 4658076804 3989548502 644 D0 / - DATA X3 ( 10) / 0.2222549197 7660129649 8260928066 212 D0 / - DATA X3 ( 11) / 0.0746506174 6138332204 3914435796 506 D0 / - DATA W43A ( 1) / 0.0162967342 8966656492 4281974617 663 D0 / - DATA W43A ( 2) / 0.0375228761 2086950146 1613795898 115 D0 / - DATA W43A ( 3) / 0.0546949020 5825544214 7212685465 005 D0 / - DATA W43A ( 4) / 0.0673554146 0947808607 5553166302 174 D0 / - DATA W43A ( 5) / 0.0738701996 3239395343 2140695251 367 D0 / - DATA W43A ( 6) / 0.0057685560 5976979618 4184327908 655 D0 / - DATA W43A ( 7) / 0.0273718905 9324884208 1276069289 151 D0 / - DATA W43A ( 8) / 0.0465608269 1042883074 3339154433 824 D0 / - DATA W43A ( 9) / 0.0617449952 0144256449 6240336030 883 D0 / - DATA W43A ( 10) / 0.0713872672 6869339776 8559114425 516 D0 / - DATA W43B ( 1) / 0.0018444776 4021241410 0389106552 965 D0 / - DATA W43B ( 2) / 0.0107986895 8589165174 0465406741 293 D0 / - DATA W43B ( 3) / 0.0218953638 6779542810 2523123075 149 D0 / - DATA W43B ( 4) / 0.0325974639 7534568944 3882222526 137 D0 / - DATA W43B ( 5) / 0.0421631379 3519181184 7627924327 955 D0 / - DATA W43B ( 6) / 0.0507419396 0018457778 0189020092 084 D0 / - DATA W43B ( 7) / 0.0583793955 4261924837 5475369330 206 D0 / - DATA W43B ( 8) / 0.0647464049 5144588554 4689259517 511 D0 / - DATA W43B ( 9) / 0.0695661979 1235648452 8633315038 405 D0 / - DATA W43B ( 10) / 0.0728244414 7183320815 0939535192 842 D0 / - DATA W43B ( 11) / 0.0745077510 1417511827 3571813842 889 D0 / - DATA W43B ( 12) / 0.0747221475 1740300559 4425168280 423 D0 / -C - DATA X4 ( 1) / 0.9999029772 6272923449 0529830591 582 D0 / - DATA X4 ( 2) / 0.9979898959 8667874542 7496322365 960 D0 / - DATA X4 ( 3) / 0.9921754978 6068722280 8523352251 425 D0 / - DATA X4 ( 4) / 0.9813581635 7271277357 1916941623 894 D0 / - DATA X4 ( 5) / 0.9650576238 5838461912 8284110607 926 D0 / - DATA X4 ( 6) / 0.9431676131 3367059681 6416634507 426 D0 / - DATA X4 ( 7) / 0.9158064146 8550720959 1826430720 050 D0 / - DATA X4 ( 8) / 0.8832216577 7131650137 2117548744 163 D0 / - DATA X4 ( 9) / 0.8457107484 6241566660 5902011504 855 D0 / - DATA X4 ( 10) / 0.8035576580 3523098278 8739474980 964 D0 / - DATA X4 ( 11) / 0.7570057306 8549555832 8942793432 020 D0 / - DATA X4 ( 12) / 0.7062732097 8732181982 4094274740 840 D0 / - DATA X4 ( 13) / 0.6515894665 0117792253 4422205016 736 D0 / - DATA X4 ( 14) / 0.5932233740 5796108887 5273770349 144 D0 / - DATA X4 ( 15) / 0.5314936059 7083193228 5268948562 671 D0 / - DATA X4 ( 16) / 0.4667636230 4202284487 1966781659 270 D0 / - DATA X4 ( 17) / 0.3994248478 5921880473 2101665817 923 D0 / - DATA X4 ( 18) / 0.3298748771 0618828826 5053371824 597 D0 / - DATA X4 ( 19) / 0.2585035592 0216155180 2280975429 025 D0 / - DATA X4 ( 20) / 0.1856953965 6834665201 5917141167 606 D0 / - DATA X4 ( 21) / 0.1118422131 7990746817 2398359241 362 D0 / - DATA X4 ( 22) / 0.0373521233 9461987081 4998165437 704 D0 / - DATA W87A ( 1) / 0.0081483773 8414917290 0002878448 190 D0 / - DATA W87A ( 2) / 0.0187614382 0156282224 3935059003 794 D0 / - DATA W87A ( 3) / 0.0273474510 5005228616 1582829741 283 D0 / - DATA W87A ( 4) / 0.0336777073 1163793004 6581056957 588 D0 / - DATA W87A ( 5) / 0.0369350998 2042790761 4589586742 499 D0 / - DATA W87A ( 6) / 0.0028848724 3021153050 1334156248 695 D0 / - DATA W87A ( 7) / 0.0136859460 2271270188 8950035273 128 D0 / - DATA W87A ( 8) / 0.0232804135 0288831112 3409291030 404 D0 / - DATA W87A ( 9) / 0.0308724976 1171335867 5466394126 442 D0 / - DATA W87A ( 10) / 0.0356936336 3941877071 9351355457 044 D0 / - DATA W87A ( 11) / 0.0009152833 4520224136 0843392549 948 D0 / - DATA W87A ( 12) / 0.0053992802 1930047136 7738743391 053 D0 / - DATA W87A ( 13) / 0.0109476796 0111893113 4327826856 808 D0 / - DATA W87A ( 14) / 0.0162987316 9678733526 2665703223 280 D0 / - DATA W87A ( 15) / 0.0210815688 8920383511 2433060188 190 D0 / - DATA W87A ( 16) / 0.0253709697 6925382724 3467999831 710 D0 / - DATA W87A ( 17) / 0.0291896977 5647575250 1446154084 920 D0 / - DATA W87A ( 18) / 0.0323732024 6720278968 5788194889 595 D0 / - DATA W87A ( 19) / 0.0347830989 5036514275 0781997949 596 D0 / - DATA W87A ( 20) / 0.0364122207 3135178756 2801163687 577 D0 / - DATA W87A ( 21) / 0.0372538755 0304770853 9592001191 226 D0 / - DATA W87B ( 1) / 0.0002741455 6376207235 0016527092 881 D0 / - DATA W87B ( 2) / 0.0018071241 5505794294 8341311753 254 D0 / - DATA W87B ( 3) / 0.0040968692 8275916486 4458070683 480 D0 / - DATA W87B ( 4) / 0.0067582900 5184737869 9816577897 424 D0 / - DATA W87B ( 5) / 0.0095499576 7220164653 6053581325 377 D0 / - DATA W87B ( 6) / 0.0123294476 5224485369 4626639963 780 D0 / - DATA W87B ( 7) / 0.0150104473 4638895237 6697286041 943 D0 / - DATA W87B ( 8) / 0.0175489679 8624319109 9665352925 900 D0 / - DATA W87B ( 9) / 0.0199380377 8644088820 2278192730 714 D0 / - DATA W87B ( 10) / 0.0221949359 6101228679 6332102959 499 D0 / - DATA W87B ( 11) / 0.0243391471 2600080547 0360647041 454 D0 / - DATA W87B ( 12) / 0.0263745054 1483920724 1503786552 615 D0 / - DATA W87B ( 13) / 0.0282869107 8877120065 9968002987 960 D0 / - DATA W87B ( 14) / 0.0300525811 2809269532 2521110347 341 D0 / - DATA W87B ( 15) / 0.0316467513 7143992940 4586051078 883 D0 / - DATA W87B ( 16) / 0.0330504134 1997850329 0785944862 689 D0 / - DATA W87B ( 17) / 0.0342550997 0422606178 7082821046 821 D0 / - DATA W87B ( 18) / 0.0352624126 6015668103 3782717998 428 D0 / - DATA W87B ( 19) / 0.0360769896 2288870118 5500318003 895 D0 / - DATA W87B ( 20) / 0.0366986044 9845609449 8018047441 094 D0 / - DATA W87B ( 21) / 0.0371205492 6983257611 4119958413 599 D0 / - DATA W87B ( 22) / 0.0373342287 5193504032 1235449094 698 D0 / - DATA W87B ( 23) / 0.0373610737 6267902341 0321241766 599 D0 / -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C CENTR - MID POINT OF THE INTEGRATION INTERVAL -C HLGTH - HALF-LENGTH OF THE INTEGRATION INTERVAL -C FCENTR - FUNCTION VALUE AT MID POINT -C ABSC - ABSCISSA -C FVAL - FUNCTION VALUE -C SAVFUN - ARRAY OF FUNCTION VALUES WHICH HAVE ALREADY BEEN -C COMPUTED -C RES10 - 10-POINT GAUSS RESULT -C RES21 - 21-POINT KRONROD RESULT -C RES43 - 43-POINT RESULT -C RES87 - 87-POINT RESULT -C RESABS - APPROXIMATION TO THE INTEGRAL OF ABS(F) -C RESASC - APPROXIMATION TO THE INTEGRAL OF ABS(F-I/(B-A)) -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT DQNG - EPMACH = D1MACH(4) - UFLOW = D1MACH(1) -C -C TEST ON VALIDITY OF PARAMETERS -C ------------------------------ -C - RESULT = 0.0D+00 - ABSERR = 0.0D+00 - NEVAL = 0 - IER = 6 - IF(EPSABS.LE.0.0D+00.AND.EPSREL.LT.MAX(0.5D+02*EPMACH,0.5D-28)) - 1 GO TO 80 - HLGTH = 0.5D+00*(B-A) - DHLGTH = ABS(HLGTH) - CENTR = 0.5D+00*(B+A) - FCENTR = F(CENTR) - NEVAL = 21 - IER = 1 -C -C COMPUTE THE INTEGRAL USING THE 10- AND 21-POINT FORMULA. -C - DO 70 L = 1,3 - GO TO (5,25,45),L - 5 RES10 = 0.0D+00 - RES21 = W21B(6)*FCENTR - RESABS = W21B(6)*ABS(FCENTR) - DO 10 K=1,5 - ABSC = HLGTH*X1(K) - FVAL1 = F(CENTR+ABSC) - FVAL2 = F(CENTR-ABSC) - FVAL = FVAL1+FVAL2 - RES10 = RES10+W10(K)*FVAL - RES21 = RES21+W21A(K)*FVAL - RESABS = RESABS+W21A(K)*(ABS(FVAL1)+ABS(FVAL2)) - SAVFUN(K) = FVAL - FV1(K) = FVAL1 - FV2(K) = FVAL2 - 10 CONTINUE - IPX = 5 - DO 15 K=1,5 - IPX = IPX+1 - ABSC = HLGTH*X2(K) - FVAL1 = F(CENTR+ABSC) - FVAL2 = F(CENTR-ABSC) - FVAL = FVAL1+FVAL2 - RES21 = RES21+W21B(K)*FVAL - RESABS = RESABS+W21B(K)*(ABS(FVAL1)+ABS(FVAL2)) - SAVFUN(IPX) = FVAL - FV3(K) = FVAL1 - FV4(K) = FVAL2 - 15 CONTINUE -C -C TEST FOR CONVERGENCE. -C - RESULT = RES21*HLGTH - RESABS = RESABS*DHLGTH - RESKH = 0.5D+00*RES21 - RESASC = W21B(6)*ABS(FCENTR-RESKH) - DO 20 K = 1,5 - RESASC = RESASC+W21A(K)*(ABS(FV1(K)-RESKH)+ABS(FV2(K)-RESKH)) - 1 +W21B(K)*(ABS(FV3(K)-RESKH)+ABS(FV4(K)-RESKH)) - 20 CONTINUE - ABSERR = ABS((RES21-RES10)*HLGTH) - RESASC = RESASC*DHLGTH - GO TO 65 -C -C COMPUTE THE INTEGRAL USING THE 43-POINT FORMULA. -C - 25 RES43 = W43B(12)*FCENTR - NEVAL = 43 - DO 30 K=1,10 - RES43 = RES43+SAVFUN(K)*W43A(K) - 30 CONTINUE - DO 40 K=1,11 - IPX = IPX+1 - ABSC = HLGTH*X3(K) - FVAL = F(ABSC+CENTR)+F(CENTR-ABSC) - RES43 = RES43+FVAL*W43B(K) - SAVFUN(IPX) = FVAL - 40 CONTINUE -C -C TEST FOR CONVERGENCE. -C - RESULT = RES43*HLGTH - ABSERR = ABS((RES43-RES21)*HLGTH) - GO TO 65 -C -C COMPUTE THE INTEGRAL USING THE 87-POINT FORMULA. -C - 45 RES87 = W87B(23)*FCENTR - NEVAL = 87 - DO 50 K=1,21 - RES87 = RES87+SAVFUN(K)*W87A(K) - 50 CONTINUE - DO 60 K=1,22 - ABSC = HLGTH*X4(K) - RES87 = RES87+W87B(K)*(F(ABSC+CENTR)+F(CENTR-ABSC)) - 60 CONTINUE - RESULT = RES87*HLGTH - ABSERR = ABS((RES87-RES43)*HLGTH) - 65 IF(RESASC.NE.0.0D+00.AND.ABSERR.NE.0.0D+00) - 1 ABSERR = RESASC*MIN(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00) - IF (RESABS.GT.UFLOW/(0.5D+02*EPMACH)) ABSERR = MAX - 1 ((EPMACH*0.5D+02)*RESABS,ABSERR) - IF (ABSERR.LE.MAX(EPSABS,EPSREL*ABS(RESULT))) IER = 0 -C ***JUMP OUT OF DO-LOOP - IF (IER.EQ.0) GO TO 999 - 70 CONTINUE - 80 CALL XERMSG ('SLATEC', 'DQNG', 'ABNORMAL RETURN', IER, 0) - 999 RETURN - END diff --git a/slatec/dqpsrt.f b/slatec/dqpsrt.f deleted file mode 100644 index 8202430..0000000 --- a/slatec/dqpsrt.f +++ /dev/null @@ -1,142 +0,0 @@ -*DECK DQPSRT - SUBROUTINE DQPSRT (LIMIT, LAST, MAXERR, ERMAX, ELIST, IORD, NRMAX) -C***BEGIN PROLOGUE DQPSRT -C***SUBSIDIARY -C***PURPOSE This routine maintains the descending ordering in the -C list of the local error estimated resulting from the -C interval subdivision process. At each call two error -C estimates are inserted using the sequential search -C method, top-down for the largest error estimate and -C bottom-up for the smallest error estimate. -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (QPSRT-S, DQPSRT-D) -C***KEYWORDS SEQUENTIAL SORTING -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Ordering routine -C Standard fortran subroutine -C Double precision version -C -C PARAMETERS (MEANING AT OUTPUT) -C LIMIT - Integer -C Maximum number of error estimates the list -C can contain -C -C LAST - Integer -C Number of error estimates currently in the list -C -C MAXERR - Integer -C MAXERR points to the NRMAX-th largest error -C estimate currently in the list -C -C ERMAX - Double precision -C NRMAX-th largest error estimate -C ERMAX = ELIST(MAXERR) -C -C ELIST - Double precision -C Vector of dimension LAST containing -C the error estimates -C -C IORD - Integer -C Vector of dimension LAST, the first K elements -C of which contain pointers to the error -C estimates, such that -C ELIST(IORD(1)),..., ELIST(IORD(K)) -C form a decreasing sequence, with -C K = LAST if LAST.LE.(LIMIT/2+2), and -C K = LIMIT+1-LAST otherwise -C -C NRMAX - Integer -C MAXERR = IORD(NRMAX) -C -C***SEE ALSO DQAGE, DQAGIE, DQAGPE, DQAWSE -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 800101 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 900328 Added TYPE section. (WRB) -C***END PROLOGUE DQPSRT -C - DOUBLE PRECISION ELIST,ERMAX,ERRMAX,ERRMIN - INTEGER I,IBEG,IDO,IORD,ISUCC,J,JBND,JUPBN,K,LAST,LIMIT,MAXERR, - 1 NRMAX - DIMENSION ELIST(*),IORD(*) -C -C CHECK WHETHER THE LIST CONTAINS MORE THAN -C TWO ERROR ESTIMATES. -C -C***FIRST EXECUTABLE STATEMENT DQPSRT - IF(LAST.GT.2) GO TO 10 - IORD(1) = 1 - IORD(2) = 2 - GO TO 90 -C -C THIS PART OF THE ROUTINE IS ONLY EXECUTED IF, DUE TO A -C DIFFICULT INTEGRAND, SUBDIVISION INCREASED THE ERROR -C ESTIMATE. IN THE NORMAL CASE THE INSERT PROCEDURE SHOULD -C START AFTER THE NRMAX-TH LARGEST ERROR ESTIMATE. -C - 10 ERRMAX = ELIST(MAXERR) - IF(NRMAX.EQ.1) GO TO 30 - IDO = NRMAX-1 - DO 20 I = 1,IDO - ISUCC = IORD(NRMAX-1) -C ***JUMP OUT OF DO-LOOP - IF(ERRMAX.LE.ELIST(ISUCC)) GO TO 30 - IORD(NRMAX) = ISUCC - NRMAX = NRMAX-1 - 20 CONTINUE -C -C COMPUTE THE NUMBER OF ELEMENTS IN THE LIST TO BE MAINTAINED -C IN DESCENDING ORDER. THIS NUMBER DEPENDS ON THE NUMBER OF -C SUBDIVISIONS STILL ALLOWED. -C - 30 JUPBN = LAST - IF(LAST.GT.(LIMIT/2+2)) JUPBN = LIMIT+3-LAST - ERRMIN = ELIST(LAST) -C -C INSERT ERRMAX BY TRAVERSING THE LIST TOP-DOWN, -C STARTING COMPARISON FROM THE ELEMENT ELIST(IORD(NRMAX+1)). -C - JBND = JUPBN-1 - IBEG = NRMAX+1 - IF(IBEG.GT.JBND) GO TO 50 - DO 40 I=IBEG,JBND - ISUCC = IORD(I) -C ***JUMP OUT OF DO-LOOP - IF(ERRMAX.GE.ELIST(ISUCC)) GO TO 60 - IORD(I-1) = ISUCC - 40 CONTINUE - 50 IORD(JBND) = MAXERR - IORD(JUPBN) = LAST - GO TO 90 -C -C INSERT ERRMIN BY TRAVERSING THE LIST BOTTOM-UP. -C - 60 IORD(I-1) = MAXERR - K = JBND - DO 70 J=I,JBND - ISUCC = IORD(K) -C ***JUMP OUT OF DO-LOOP - IF(ERRMIN.LT.ELIST(ISUCC)) GO TO 80 - IORD(K+1) = ISUCC - K = K-1 - 70 CONTINUE - IORD(I) = LAST - GO TO 90 - 80 IORD(K+1) = LAST -C -C SET MAXERR AND ERMAX. -C - 90 MAXERR = IORD(NRMAX) - ERMAX = ELIST(MAXERR) - RETURN - END diff --git a/slatec/dqrdc.f b/slatec/dqrdc.f deleted file mode 100644 index 15042cd..0000000 --- a/slatec/dqrdc.f +++ /dev/null @@ -1,223 +0,0 @@ -*DECK DQRDC - SUBROUTINE DQRDC (X, LDX, N, P, QRAUX, JPVT, WORK, JOB) -C***BEGIN PROLOGUE DQRDC -C***PURPOSE Use Householder transformations to compute the QR -C factorization of an N by P matrix. Column pivoting is a -C users option. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D5 -C***TYPE DOUBLE PRECISION (SQRDC-S, DQRDC-D, CQRDC-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, ORTHOGONAL TRIANGULAR, -C QR DECOMPOSITION -C***AUTHOR Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C DQRDC uses Householder transformations to compute the QR -C factorization of an N by P matrix X. Column pivoting -C based on the 2-norms of the reduced columns may be -C performed at the user's option. -C -C On Entry -C -C X DOUBLE PRECISION(LDX,P), where LDX .GE. N. -C X contains the matrix whose decomposition is to be -C computed. -C -C LDX INTEGER. -C LDX is the leading dimension of the array X. -C -C N INTEGER. -C N is the number of rows of the matrix X. -C -C P INTEGER. -C P is the number of columns of the matrix X. -C -C JPVT INTEGER(P). -C JPVT contains integers that control the selection -C of the pivot columns. The K-th column X(K) of X -C is placed in one of three classes according to the -C value of JPVT(K). -C -C If JPVT(K) .GT. 0, then X(K) is an initial -C column. -C -C If JPVT(K) .EQ. 0, then X(K) is a free column. -C -C If JPVT(K) .LT. 0, then X(K) is a final column. -C -C Before the decomposition is computed, initial columns -C are moved to the beginning of the array X and final -C columns to the end. Both initial and final columns -C are frozen in place during the computation and only -C free columns are moved. At the K-th stage of the -C reduction, if X(K) is occupied by a free column -C it is interchanged with the free column of largest -C reduced norm. JPVT is not referenced if -C JOB .EQ. 0. -C -C WORK DOUBLE PRECISION(P). -C WORK is a work array. WORK is not referenced if -C JOB .EQ. 0. -C -C JOB INTEGER. -C JOB is an integer that initiates column pivoting. -C If JOB .EQ. 0, no pivoting is done. -C If JOB .NE. 0, pivoting is done. -C -C On Return -C -C X X contains in its upper triangle the upper -C triangular matrix R of the QR factorization. -C Below its diagonal X contains information from -C which the orthogonal part of the decomposition -C can be recovered. Note that if pivoting has -C been requested, the decomposition is not that -C of the original matrix X but that of X -C with its columns permuted as described by JPVT. -C -C QRAUX DOUBLE PRECISION(P). -C QRAUX contains further information required to recover -C the orthogonal part of the decomposition. -C -C JPVT JPVT(K) contains the index of the column of the -C original matrix that has been interchanged into -C the K-th column, if pivoting was requested. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DDOT, DNRM2, DSCAL, DSWAP -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DQRDC - INTEGER LDX,N,P,JOB - INTEGER JPVT(*) - DOUBLE PRECISION X(LDX,*),QRAUX(*),WORK(*) -C - INTEGER J,JP,L,LP1,LUP,MAXJ,PL,PU - DOUBLE PRECISION MAXNRM,DNRM2,TT - DOUBLE PRECISION DDOT,NRMXL,T - LOGICAL NEGJ,SWAPJ -C -C***FIRST EXECUTABLE STATEMENT DQRDC - PL = 1 - PU = 0 - IF (JOB .EQ. 0) GO TO 60 -C -C PIVOTING HAS BEEN REQUESTED. REARRANGE THE COLUMNS -C ACCORDING TO JPVT. -C - DO 20 J = 1, P - SWAPJ = JPVT(J) .GT. 0 - NEGJ = JPVT(J) .LT. 0 - JPVT(J) = J - IF (NEGJ) JPVT(J) = -J - IF (.NOT.SWAPJ) GO TO 10 - IF (J .NE. PL) CALL DSWAP(N,X(1,PL),1,X(1,J),1) - JPVT(J) = JPVT(PL) - JPVT(PL) = J - PL = PL + 1 - 10 CONTINUE - 20 CONTINUE - PU = P - DO 50 JJ = 1, P - J = P - JJ + 1 - IF (JPVT(J) .GE. 0) GO TO 40 - JPVT(J) = -JPVT(J) - IF (J .EQ. PU) GO TO 30 - CALL DSWAP(N,X(1,PU),1,X(1,J),1) - JP = JPVT(PU) - JPVT(PU) = JPVT(J) - JPVT(J) = JP - 30 CONTINUE - PU = PU - 1 - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE -C -C COMPUTE THE NORMS OF THE FREE COLUMNS. -C - IF (PU .LT. PL) GO TO 80 - DO 70 J = PL, PU - QRAUX(J) = DNRM2(N,X(1,J),1) - WORK(J) = QRAUX(J) - 70 CONTINUE - 80 CONTINUE -C -C PERFORM THE HOUSEHOLDER REDUCTION OF X. -C - LUP = MIN(N,P) - DO 200 L = 1, LUP - IF (L .LT. PL .OR. L .GE. PU) GO TO 120 -C -C LOCATE THE COLUMN OF LARGEST NORM AND BRING IT -C INTO THE PIVOT POSITION. -C - MAXNRM = 0.0D0 - MAXJ = L - DO 100 J = L, PU - IF (QRAUX(J) .LE. MAXNRM) GO TO 90 - MAXNRM = QRAUX(J) - MAXJ = J - 90 CONTINUE - 100 CONTINUE - IF (MAXJ .EQ. L) GO TO 110 - CALL DSWAP(N,X(1,L),1,X(1,MAXJ),1) - QRAUX(MAXJ) = QRAUX(L) - WORK(MAXJ) = WORK(L) - JP = JPVT(MAXJ) - JPVT(MAXJ) = JPVT(L) - JPVT(L) = JP - 110 CONTINUE - 120 CONTINUE - QRAUX(L) = 0.0D0 - IF (L .EQ. N) GO TO 190 -C -C COMPUTE THE HOUSEHOLDER TRANSFORMATION FOR COLUMN L. -C - NRMXL = DNRM2(N-L+1,X(L,L),1) - IF (NRMXL .EQ. 0.0D0) GO TO 180 - IF (X(L,L) .NE. 0.0D0) NRMXL = SIGN(NRMXL,X(L,L)) - CALL DSCAL(N-L+1,1.0D0/NRMXL,X(L,L),1) - X(L,L) = 1.0D0 + X(L,L) -C -C APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS, -C UPDATING THE NORMS. -C - LP1 = L + 1 - IF (P .LT. LP1) GO TO 170 - DO 160 J = LP1, P - T = -DDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L) - CALL DAXPY(N-L+1,T,X(L,L),1,X(L,J),1) - IF (J .LT. PL .OR. J .GT. PU) GO TO 150 - IF (QRAUX(J) .EQ. 0.0D0) GO TO 150 - TT = 1.0D0 - (ABS(X(L,J))/QRAUX(J))**2 - TT = MAX(TT,0.0D0) - T = TT - TT = 1.0D0 + 0.05D0*TT*(QRAUX(J)/WORK(J))**2 - IF (TT .EQ. 1.0D0) GO TO 130 - QRAUX(J) = QRAUX(J)*SQRT(T) - GO TO 140 - 130 CONTINUE - QRAUX(J) = DNRM2(N-L,X(L+1,J),1) - WORK(J) = QRAUX(J) - 140 CONTINUE - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE -C -C SAVE THE TRANSFORMATION. -C - QRAUX(L) = X(L,L) - X(L,L) = -NRMXL - 180 CONTINUE - 190 CONTINUE - 200 CONTINUE - RETURN - END diff --git a/slatec/dqrfac.f b/slatec/dqrfac.f deleted file mode 100644 index 491363e..0000000 --- a/slatec/dqrfac.f +++ /dev/null @@ -1,172 +0,0 @@ -*DECK DQRFAC - SUBROUTINE DQRFAC (M, N, A, LDA, PIVOT, IPVT, LIPVT, SIGMA, - + ACNORM, WA) -C***BEGIN PROLOGUE DQRFAC -C***SUBSIDIARY -C***PURPOSE Subsidiary to DNLS1, DNLS1E, DNSQ and DNSQE -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (QRFAC-S, DQRFAC-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C **** Double Precision version of QRFAC **** -C -C This subroutine uses Householder transformations with column -C pivoting (optional) to compute a QR factorization of the -C M by N matrix A. That is, DQRFAC determines an orthogonal -C matrix Q, a permutation matrix P, and an upper trapezoidal -C matrix R with diagonal elements of nonincreasing magnitude, -C such that A*P = Q*R. The Householder transformation for -C column K, K = 1,2,...,MIN(M,N), is of the form -C -C T -C I - (1/U(K))*U*U -C -C where U has zeros in the first K-1 positions. The form of -C this transformation and the method of pivoting first -C appeared in the corresponding LINPACK subroutine. -C -C The subroutine statement is -C -C SUBROUTINE DQRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,SIGMA,ACNORM,WA) -C -C where -C -C M is a positive integer input variable set to the number -C of rows of A. -C -C N is a positive integer input variable set to the number -C of columns of A. -C -C A is an M by N array. On input A contains the matrix for -C which the QR factorization is to be computed. On output -C the strict upper trapezoidal part of A contains the strict -C upper trapezoidal part of R, and the lower trapezoidal -C part of A contains a factored form of Q (the non-trivial -C elements of the U vectors described above). -C -C LDA is a positive integer input variable not less than M -C which specifies the leading dimension of the array A. -C -C PIVOT is a logical input variable. If pivot is set .TRUE., -C then column pivoting is enforced. If pivot is set .FALSE., -C then no column pivoting is done. -C -C IPVT is an integer output array of length LIPVT. IPVT -C defines the permutation matrix P such that A*P = Q*R. -C Column J of P is column IPVT(J) of the identity matrix. -C If pivot is .FALSE., IPVT is not referenced. -C -C LIPVT is a positive integer input variable. If PIVOT is -C .FALSE., then LIPVT may be as small as 1. If PIVOT is -C .TRUE., then LIPVT must be at least N. -C -C SIGMA is an output array of length N which contains the -C diagonal elements of R. -C -C ACNORM is an output array of length N which contains the -C norms of the corresponding columns of the input matrix A. -C If this information is not needed, then ACNORM can coincide -C with SIGMA. -C -C WA is a work array of length N. If pivot is .FALSE., then WA -C can coincide with SIGMA. -C -C***SEE ALSO DNLS1, DNLS1E, DNSQ, DNSQE -C***ROUTINES CALLED D1MACH, DENORM -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DQRFAC - INTEGER M,N,LDA,LIPVT - INTEGER IPVT(*) - LOGICAL PIVOT - SAVE ONE, P05, ZERO - DOUBLE PRECISION A(LDA,*),SIGMA(*),ACNORM(*),WA(*) - INTEGER I,J,JP1,K,KMAX,MINMN - DOUBLE PRECISION AJNORM,EPSMCH,ONE,P05,SUM,TEMP,ZERO - DOUBLE PRECISION D1MACH,DENORM - DATA ONE,P05,ZERO /1.0D0,5.0D-2,0.0D0/ -C***FIRST EXECUTABLE STATEMENT DQRFAC - EPSMCH = D1MACH(4) -C -C COMPUTE THE INITIAL COLUMN NORMS AND INITIALIZE SEVERAL ARRAYS. -C - DO 10 J = 1, N - ACNORM(J) = DENORM(M,A(1,J)) - SIGMA(J) = ACNORM(J) - WA(J) = SIGMA(J) - IF (PIVOT) IPVT(J) = J - 10 CONTINUE -C -C REDUCE A TO R WITH HOUSEHOLDER TRANSFORMATIONS. -C - MINMN = MIN(M,N) - DO 110 J = 1, MINMN - IF (.NOT.PIVOT) GO TO 40 -C -C BRING THE COLUMN OF LARGEST NORM INTO THE PIVOT POSITION. -C - KMAX = J - DO 20 K = J, N - IF (SIGMA(K) .GT. SIGMA(KMAX)) KMAX = K - 20 CONTINUE - IF (KMAX .EQ. J) GO TO 40 - DO 30 I = 1, M - TEMP = A(I,J) - A(I,J) = A(I,KMAX) - A(I,KMAX) = TEMP - 30 CONTINUE - SIGMA(KMAX) = SIGMA(J) - WA(KMAX) = WA(J) - K = IPVT(J) - IPVT(J) = IPVT(KMAX) - IPVT(KMAX) = K - 40 CONTINUE -C -C COMPUTE THE HOUSEHOLDER TRANSFORMATION TO REDUCE THE -C J-TH COLUMN OF A TO A MULTIPLE OF THE J-TH UNIT VECTOR. -C - AJNORM = DENORM(M-J+1,A(J,J)) - IF (AJNORM .EQ. ZERO) GO TO 100 - IF (A(J,J) .LT. ZERO) AJNORM = -AJNORM - DO 50 I = J, M - A(I,J) = A(I,J)/AJNORM - 50 CONTINUE - A(J,J) = A(J,J) + ONE -C -C APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS -C AND UPDATE THE NORMS. -C - JP1 = J + 1 - IF (N .LT. JP1) GO TO 100 - DO 90 K = JP1, N - SUM = ZERO - DO 60 I = J, M - SUM = SUM + A(I,J)*A(I,K) - 60 CONTINUE - TEMP = SUM/A(J,J) - DO 70 I = J, M - A(I,K) = A(I,K) - TEMP*A(I,J) - 70 CONTINUE - IF (.NOT.PIVOT .OR. SIGMA(K) .EQ. ZERO) GO TO 80 - TEMP = A(J,K)/SIGMA(K) - SIGMA(K) = SIGMA(K)*SQRT(MAX(ZERO,ONE-TEMP**2)) - IF (P05*(SIGMA(K)/WA(K))**2 .GT. EPSMCH) GO TO 80 - SIGMA(K) = DENORM(M-J,A(JP1,K)) - WA(K) = SIGMA(K) - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - SIGMA(J) = -AJNORM - 110 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE DQRFAC. -C - END diff --git a/slatec/dqrsl.f b/slatec/dqrsl.f deleted file mode 100644 index 273b190..0000000 --- a/slatec/dqrsl.f +++ /dev/null @@ -1,289 +0,0 @@ -*DECK DQRSL - SUBROUTINE DQRSL (X, LDX, N, K, QRAUX, Y, QY, QTY, B, RSD, XB, - + JOB, INFO) -C***BEGIN PROLOGUE DQRSL -C***PURPOSE Apply the output of DQRDC to compute coordinate transfor- -C mations, projections, and least squares solutions. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D9, D2A1 -C***TYPE DOUBLE PRECISION (SQRSL-S, DQRSL-D, CQRSL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, ORTHOGONAL TRIANGULAR, -C SOLVE -C***AUTHOR Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C DQRSL applies the output of DQRDC to compute coordinate -C transformations, projections, and least squares solutions. -C For K .LE. MIN(N,P), let XK be the matrix -C -C XK = (X(JPVT(1)),X(JPVT(2)), ... ,X(JPVT(K))) -C -C formed from columns JPVT(1), ... ,JPVT(K) of the original -C N X P matrix X that was input to DQRDC (if no pivoting was -C done, XK consists of the first K columns of X in their -C original order). DQRDC produces a factored orthogonal matrix Q -C and an upper triangular matrix R such that -C -C XK = Q * (R) -C (0) -C -C This information is contained in coded form in the arrays -C X and QRAUX. -C -C On Entry -C -C X DOUBLE PRECISION(LDX,P). -C X contains the output of DQRDC. -C -C LDX INTEGER. -C LDX is the leading dimension of the array X. -C -C N INTEGER. -C N is the number of rows of the matrix XK. It must -C have the same value as N in DQRDC. -C -C K INTEGER. -C K is the number of columns of the matrix XK. K -C must not be greater than MIN(N,P), where P is the -C same as in the calling sequence to DQRDC. -C -C QRAUX DOUBLE PRECISION(P). -C QRAUX contains the auxiliary output from DQRDC. -C -C Y DOUBLE PRECISION(N) -C Y contains an N-vector that is to be manipulated -C by DQRSL. -C -C JOB INTEGER. -C JOB specifies what is to be computed. JOB has -C the decimal expansion ABCDE, with the following -C meaning. -C -C If A .NE. 0, compute QY. -C If B,C,D, or E .NE. 0, compute QTY. -C If C .NE. 0, compute B. -C If D .NE. 0, compute RSD. -C If E .NE. 0, compute XB. -C -C Note that a request to compute B, RSD, or XB -C automatically triggers the computation of QTY, for -C which an array must be provided in the calling -C sequence. -C -C On Return -C -C QY DOUBLE PRECISION(N). -C QY contains Q*Y, if its computation has been -C requested. -C -C QTY DOUBLE PRECISION(N). -C QTY contains TRANS(Q)*Y, if its computation has -C been requested. Here TRANS(Q) is the -C transpose of the matrix Q. -C -C B DOUBLE PRECISION(K) -C B contains the solution of the least squares problem -C -C minimize norm2(Y - XK*B), -C -C if its computation has been requested. (Note that -C if pivoting was requested in DQRDC, the J-th -C component of B will be associated with column JPVT(J) -C of the original matrix X that was input into DQRDC.) -C -C RSD DOUBLE PRECISION(N). -C RSD contains the least squares residual Y - XK*B, -C if its computation has been requested. RSD is -C also the orthogonal projection of Y onto the -C orthogonal complement of the column space of XK. -C -C XB DOUBLE PRECISION(N). -C XB contains the least squares approximation XK*B, -C if its computation has been requested. XB is also -C the orthogonal projection of Y onto the column space -C of X. -C -C INFO INTEGER. -C INFO is zero unless the computation of B has -C been requested and R is exactly singular. In -C this case, INFO is the index of the first zero -C diagonal element of R and B is left unaltered. -C -C The parameters QY, QTY, B, RSD, and XB are not referenced -C if their computation is not requested and in this case -C can be replaced by dummy variables in the calling program. -C To save storage, the user may in some cases use the same -C array for different parameters in the calling sequence. A -C frequently occurring example is when one wishes to compute -C any of B, RSD, or XB and does not need Y or QTY. In this -C case one may identify Y, QTY, and one of B, RSD, or XB, while -C providing separate arrays for anything else that is to be -C computed. Thus the calling sequence -C -C CALL DQRSL(X,LDX,N,K,QRAUX,Y,DUM,Y,B,Y,DUM,110,INFO) -C -C will result in the computation of B and RSD, with RSD -C overwriting Y. More generally, each item in the following -C list contains groups of permissible identifications for -C a single calling sequence. -C -C 1. (Y,QTY,B) (RSD) (XB) (QY) -C -C 2. (Y,QTY,RSD) (B) (XB) (QY) -C -C 3. (Y,QTY,XB) (B) (RSD) (QY) -C -C 4. (Y,QY) (QTY,B) (RSD) (XB) -C -C 5. (Y,QY) (QTY,RSD) (B) (XB) -C -C 6. (Y,QY) (QTY,XB) (B) (RSD) -C -C In any group the value returned in the array allocated to -C the group corresponds to the last member of the group. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DCOPY, DDOT -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DQRSL - INTEGER LDX,N,K,JOB,INFO - DOUBLE PRECISION X(LDX,*),QRAUX(*),Y(*),QY(*),QTY(*),B(*),RSD(*), - 1 XB(*) -C - INTEGER I,J,JJ,JU,KP1 - DOUBLE PRECISION DDOT,T,TEMP - LOGICAL CB,CQY,CQTY,CR,CXB -C***FIRST EXECUTABLE STATEMENT DQRSL -C -C SET INFO FLAG. -C - INFO = 0 -C -C DETERMINE WHAT IS TO BE COMPUTED. -C - CQY = JOB/10000 .NE. 0 - CQTY = MOD(JOB,10000) .NE. 0 - CB = MOD(JOB,1000)/100 .NE. 0 - CR = MOD(JOB,100)/10 .NE. 0 - CXB = MOD(JOB,10) .NE. 0 - JU = MIN(K,N-1) -C -C SPECIAL ACTION WHEN N=1. -C - IF (JU .NE. 0) GO TO 40 - IF (CQY) QY(1) = Y(1) - IF (CQTY) QTY(1) = Y(1) - IF (CXB) XB(1) = Y(1) - IF (.NOT.CB) GO TO 30 - IF (X(1,1) .NE. 0.0D0) GO TO 10 - INFO = 1 - GO TO 20 - 10 CONTINUE - B(1) = Y(1)/X(1,1) - 20 CONTINUE - 30 CONTINUE - IF (CR) RSD(1) = 0.0D0 - GO TO 250 - 40 CONTINUE -C -C SET UP TO COMPUTE QY OR QTY. -C - IF (CQY) CALL DCOPY(N,Y,1,QY,1) - IF (CQTY) CALL DCOPY(N,Y,1,QTY,1) - IF (.NOT.CQY) GO TO 70 -C -C COMPUTE QY. -C - DO 60 JJ = 1, JU - J = JU - JJ + 1 - IF (QRAUX(J) .EQ. 0.0D0) GO TO 50 - TEMP = X(J,J) - X(J,J) = QRAUX(J) - T = -DDOT(N-J+1,X(J,J),1,QY(J),1)/X(J,J) - CALL DAXPY(N-J+1,T,X(J,J),1,QY(J),1) - X(J,J) = TEMP - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE - IF (.NOT.CQTY) GO TO 100 -C -C COMPUTE TRANS(Q)*Y. -C - DO 90 J = 1, JU - IF (QRAUX(J) .EQ. 0.0D0) GO TO 80 - TEMP = X(J,J) - X(J,J) = QRAUX(J) - T = -DDOT(N-J+1,X(J,J),1,QTY(J),1)/X(J,J) - CALL DAXPY(N-J+1,T,X(J,J),1,QTY(J),1) - X(J,J) = TEMP - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE -C -C SET UP TO COMPUTE B, RSD, OR XB. -C - IF (CB) CALL DCOPY(K,QTY,1,B,1) - KP1 = K + 1 - IF (CXB) CALL DCOPY(K,QTY,1,XB,1) - IF (CR .AND. K .LT. N) CALL DCOPY(N-K,QTY(KP1),1,RSD(KP1),1) - IF (.NOT.CXB .OR. KP1 .GT. N) GO TO 120 - DO 110 I = KP1, N - XB(I) = 0.0D0 - 110 CONTINUE - 120 CONTINUE - IF (.NOT.CR) GO TO 140 - DO 130 I = 1, K - RSD(I) = 0.0D0 - 130 CONTINUE - 140 CONTINUE - IF (.NOT.CB) GO TO 190 -C -C COMPUTE B. -C - DO 170 JJ = 1, K - J = K - JJ + 1 - IF (X(J,J) .NE. 0.0D0) GO TO 150 - INFO = J - GO TO 180 - 150 CONTINUE - B(J) = B(J)/X(J,J) - IF (J .EQ. 1) GO TO 160 - T = -B(J) - CALL DAXPY(J-1,T,X(1,J),1,B,1) - 160 CONTINUE - 170 CONTINUE - 180 CONTINUE - 190 CONTINUE - IF (.NOT.CR .AND. .NOT.CXB) GO TO 240 -C -C COMPUTE RSD OR XB AS REQUIRED. -C - DO 230 JJ = 1, JU - J = JU - JJ + 1 - IF (QRAUX(J) .EQ. 0.0D0) GO TO 220 - TEMP = X(J,J) - X(J,J) = QRAUX(J) - IF (.NOT.CR) GO TO 200 - T = -DDOT(N-J+1,X(J,J),1,RSD(J),1)/X(J,J) - CALL DAXPY(N-J+1,T,X(J,J),1,RSD(J),1) - 200 CONTINUE - IF (.NOT.CXB) GO TO 210 - T = -DDOT(N-J+1,X(J,J),1,XB(J),1)/X(J,J) - CALL DAXPY(N-J+1,T,X(J,J),1,XB(J),1) - 210 CONTINUE - X(J,J) = TEMP - 220 CONTINUE - 230 CONTINUE - 240 CONTINUE - 250 CONTINUE - RETURN - END diff --git a/slatec/dqrslv.f b/slatec/dqrslv.f deleted file mode 100644 index aee11aa..0000000 --- a/slatec/dqrslv.f +++ /dev/null @@ -1,201 +0,0 @@ -*DECK DQRSLV - SUBROUTINE DQRSLV (N, R, LDR, IPVT, DIAG, QTB, X, SIGMA, WA) -C***BEGIN PROLOGUE DQRSLV -C***SUBSIDIARY -C***PURPOSE Subsidiary to DNLS1 and DNLS1E -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (QRSOLV-S, DQRSLV-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C **** Double Precision version of QRSOLV **** -C -C Given an M by N matrix A, an N by N diagonal matrix D, -C and an M-vector B, the problem is to determine an X which -C solves the system -C -C A*X = B , D*X = 0 , -C -C in the least squares sense. -C -C This subroutine completes the solution of the problem -C if it is provided with the necessary information from the -C QR factorization, with column pivoting, of A. That is, if -C A*P = Q*R, where P is a permutation matrix, Q has orthogonal -C columns, and R is an upper triangular matrix with diagonal -C elements of nonincreasing magnitude, then DQRSLV expects -C the full upper triangle of R, the permutation matrix P, -C and the first N components of (Q TRANSPOSE)*B. The system -C A*X = B, D*X = 0, is then equivalent to -C -C T T -C R*Z = Q *B , P *D*P*Z = 0 , -C -C where X = P*Z. If this system does not have full rank, -C then a least squares solution is obtained. On output DQRSLV -C also provides an upper triangular matrix S such that -C -C T T T -C P *(A *A + D*D)*P = S *S . -C -C S is computed within DQRSLV and may be of separate interest. -C -C The subroutine statement is -C -C SUBROUTINE DQRSLV(N,R,LDR,IPVT,DIAG,QTB,X,SIGMA,WA) -C -C where -C -C N is a positive integer input variable set to the order of R. -C -C R is an N by N array. On input the full upper triangle -C must contain the full upper triangle of the matrix R. -C On output the full upper triangle is unaltered, and the -C strict lower triangle contains the strict upper triangle -C (transposed) of the upper triangular matrix S. -C -C LDR is a positive integer input variable not less than N -C which specifies the leading dimension of the array R. -C -C IPVT is an integer input array of length N which defines the -C permutation matrix P such that A*P = Q*R. Column J of P -C is column IPVT(J) of the identity matrix. -C -C DIAG is an input array of length N which must contain the -C diagonal elements of the matrix D. -C -C QTB is an input array of length N which must contain the first -C N elements of the vector (Q TRANSPOSE)*B. -C -C X is an output array of length N which contains the least -C squares solution of the system A*X = B, D*X = 0. -C -C SIGMA is an output array of length N which contains the -C diagonal elements of the upper triangular matrix S. -C -C WA is a work array of length N. -C -C***SEE ALSO DNLS1, DNLS1E -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DQRSLV - INTEGER N,LDR - INTEGER IPVT(*) - DOUBLE PRECISION R(LDR,*),DIAG(*),QTB(*),X(*),SIGMA(*),WA(*) - INTEGER I,J,JP1,K,KP1,L,NSING - DOUBLE PRECISION COS,COTAN,P5,P25,QTBPJ,SIN,SUM,TAN,TEMP,ZERO - SAVE P5, P25, ZERO - DATA P5,P25,ZERO /5.0D-1,2.5D-1,0.0D0/ -C***FIRST EXECUTABLE STATEMENT DQRSLV - DO 20 J = 1, N - DO 10 I = J, N - R(I,J) = R(J,I) - 10 CONTINUE - X(J) = R(J,J) - WA(J) = QTB(J) - 20 CONTINUE -C -C ELIMINATE THE DIAGONAL MATRIX D USING A GIVENS ROTATION. -C - DO 100 J = 1, N -C -C PREPARE THE ROW OF D TO BE ELIMINATED, LOCATING THE -C DIAGONAL ELEMENT USING P FROM THE QR FACTORIZATION. -C - L = IPVT(J) - IF (DIAG(L) .EQ. ZERO) GO TO 90 - DO 30 K = J, N - SIGMA(K) = ZERO - 30 CONTINUE - SIGMA(J) = DIAG(L) -C -C THE TRANSFORMATIONS TO ELIMINATE THE ROW OF D -C MODIFY ONLY A SINGLE ELEMENT OF (Q TRANSPOSE)*B -C BEYOND THE FIRST N, WHICH IS INITIALLY ZERO. -C - QTBPJ = ZERO - DO 80 K = J, N -C -C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE -C APPROPRIATE ELEMENT IN THE CURRENT ROW OF D. -C - IF (SIGMA(K) .EQ. ZERO) GO TO 70 - IF (ABS(R(K,K)) .GE. ABS(SIGMA(K))) GO TO 40 - COTAN = R(K,K)/SIGMA(K) - SIN = P5/SQRT(P25+P25*COTAN**2) - COS = SIN*COTAN - GO TO 50 - 40 CONTINUE - TAN = SIGMA(K)/R(K,K) - COS = P5/SQRT(P25+P25*TAN**2) - SIN = COS*TAN - 50 CONTINUE -C -C COMPUTE THE MODIFIED DIAGONAL ELEMENT OF R AND -C THE MODIFIED ELEMENT OF ((Q TRANSPOSE)*B,0). -C - R(K,K) = COS*R(K,K) + SIN*SIGMA(K) - TEMP = COS*WA(K) + SIN*QTBPJ - QTBPJ = -SIN*WA(K) + COS*QTBPJ - WA(K) = TEMP -C -C ACCUMULATE THE TRANSFORMATION IN THE ROW OF S. -C - KP1 = K + 1 - IF (N .LT. KP1) GO TO 70 - DO 60 I = KP1, N - TEMP = COS*R(I,K) + SIN*SIGMA(I) - SIGMA(I) = -SIN*R(I,K) + COS*SIGMA(I) - R(I,K) = TEMP - 60 CONTINUE - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE -C -C STORE THE DIAGONAL ELEMENT OF S AND RESTORE -C THE CORRESPONDING DIAGONAL ELEMENT OF R. -C - SIGMA(J) = R(J,J) - R(J,J) = X(J) - 100 CONTINUE -C -C SOLVE THE TRIANGULAR SYSTEM FOR Z. IF THE SYSTEM IS -C SINGULAR, THEN OBTAIN A LEAST SQUARES SOLUTION. -C - NSING = N - DO 110 J = 1, N - IF (SIGMA(J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1 - IF (NSING .LT. N) WA(J) = ZERO - 110 CONTINUE - IF (NSING .LT. 1) GO TO 150 - DO 140 K = 1, NSING - J = NSING - K + 1 - SUM = ZERO - JP1 = J + 1 - IF (NSING .LT. JP1) GO TO 130 - DO 120 I = JP1, NSING - SUM = SUM + R(I,J)*WA(I) - 120 CONTINUE - 130 CONTINUE - WA(J) = (WA(J) - SUM)/SIGMA(J) - 140 CONTINUE - 150 CONTINUE -C -C PERMUTE THE COMPONENTS OF Z BACK TO COMPONENTS OF X. -C - DO 160 J = 1, N - L = IPVT(J) - X(L) = WA(J) - 160 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE DQRSLV. -C - END diff --git a/slatec/dqwgtc.f b/slatec/dqwgtc.f deleted file mode 100644 index 7f85a1a..0000000 --- a/slatec/dqwgtc.f +++ /dev/null @@ -1,30 +0,0 @@ -*DECK DQWGTC - DOUBLE PRECISION FUNCTION DQWGTC (X, C, P2, P3, P4, KP) -C***BEGIN PROLOGUE DQWGTC -C***SUBSIDIARY -C***PURPOSE This function subprogram is used together with the -C routine DQAWC and defines the WEIGHT function. -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (QWGTC-S, DQWGTC-D) -C***KEYWORDS CAUCHY PRINCIPAL VALUE, WEIGHT FUNCTION -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***SEE ALSO DQK15W -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 810101 DATE WRITTEN -C 830518 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DQWGTC -C - DOUBLE PRECISION C,P2,P3,P4,X - INTEGER KP -C***FIRST EXECUTABLE STATEMENT DQWGTC - DQWGTC = 0.1D+01/(X-C) - RETURN - END diff --git a/slatec/dqwgtf.f b/slatec/dqwgtf.f deleted file mode 100644 index 4e069b1..0000000 --- a/slatec/dqwgtf.f +++ /dev/null @@ -1,35 +0,0 @@ -*DECK DQWGTF - DOUBLE PRECISION FUNCTION DQWGTF (X, OMEGA, P2, P3, P4, INTEGR) -C***BEGIN PROLOGUE DQWGTF -C***SUBSIDIARY -C***PURPOSE This function subprogram is used together with the -C routine DQAWF and defines the WEIGHT function. -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (QWGTF-S, DQWGTF-D) -C***KEYWORDS COS OR SIN IN WEIGHT FUNCTION -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***SEE ALSO DQK15W -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 810101 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 900328 Added TYPE section. (WRB) -C***END PROLOGUE DQWGTF -C - DOUBLE PRECISION OMEGA,OMX,P2,P3,P4,X - INTEGER INTEGR -C***FIRST EXECUTABLE STATEMENT DQWGTF - OMX = OMEGA*X - GO TO(10,20),INTEGR - 10 DQWGTF = COS(OMX) - GO TO 30 - 20 DQWGTF = SIN(OMX) - 30 RETURN - END diff --git a/slatec/dqwgts.f b/slatec/dqwgts.f deleted file mode 100644 index 8dc0c76..0000000 --- a/slatec/dqwgts.f +++ /dev/null @@ -1,40 +0,0 @@ -*DECK DQWGTS - DOUBLE PRECISION FUNCTION DQWGTS (X, A, B, ALFA, BETA, INTEGR) -C***BEGIN PROLOGUE DQWGTS -C***SUBSIDIARY -C***PURPOSE This function subprogram is used together with the -C routine DQAWS and defines the WEIGHT function. -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (QWGTS-S, DQWGTS-D) -C***KEYWORDS ALGEBRAICO-LOGARITHMIC, END POINT SINGULARITIES, -C WEIGHT FUNCTION -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***SEE ALSO DQK15W -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 810101 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 900328 Added TYPE section. (WRB) -C***END PROLOGUE DQWGTS -C - DOUBLE PRECISION A,ALFA,B,BETA,BMX,X,XMA - INTEGER INTEGR -C***FIRST EXECUTABLE STATEMENT DQWGTS - XMA = X-A - BMX = B-X - DQWGTS = XMA**ALFA*BMX**BETA - GO TO (40,10,20,30),INTEGR - 10 DQWGTS = DQWGTS*LOG(XMA) - GO TO 40 - 20 DQWGTS = DQWGTS*LOG(BMX) - GO TO 40 - 30 DQWGTS = DQWGTS*LOG(XMA)*LOG(BMX) - 40 RETURN - END diff --git a/slatec/drc.f b/slatec/drc.f deleted file mode 100644 index e5b8edc..0000000 --- a/slatec/drc.f +++ /dev/null @@ -1,333 +0,0 @@ -*DECK DRC - DOUBLE PRECISION FUNCTION DRC (X, Y, IER) -C***BEGIN PROLOGUE DRC -C***PURPOSE Calculate a double precision approximation to -C DRC(X,Y) = Integral from zero to infinity of -C -1/2 -1 -C (1/2)(t+X) (t+Y) dt, -C where X is nonnegative and Y is positive. -C***LIBRARY SLATEC -C***CATEGORY C14 -C***TYPE DOUBLE PRECISION (RC-S, DRC-D) -C***KEYWORDS DUPLICATION THEOREM, ELEMENTARY FUNCTIONS, -C ELLIPTIC INTEGRAL, TAYLOR SERIES -C***AUTHOR Carlson, B. C. -C Ames Laboratory-DOE -C Iowa State University -C Ames, IA 50011 -C Notis, E. M. -C Ames Laboratory-DOE -C Iowa State University -C Ames, IA 50011 -C Pexton, R. L. -C Lawrence Livermore National Laboratory -C Livermore, CA 94550 -C***DESCRIPTION -C -C 1. DRC -C Standard FORTRAN function routine -C Double precision version -C The routine calculates an approximation result to -C DRC(X,Y) = integral from zero to infinity of -C -C -1/2 -1 -C (1/2)(t+X) (t+Y) dt, -C -C where X is nonnegative and Y is positive. The duplication -C theorem is iterated until the variables are nearly equal, -C and the function is then expanded in Taylor series to fifth -C order. Logarithmic, inverse circular, and inverse hyper- -C bolic functions can be expressed in terms of DRC. -C -C 2. Calling Sequence -C DRC( X, Y, IER ) -C -C Parameters On Entry -C Values assigned by the calling routine -C -C X - Double precision, nonnegative variable -C -C Y - Double precision, positive variable -C -C -C -C On Return (values assigned by the DRC routine) -C -C DRC - Double precision approximation to the integral -C -C IER - Integer to indicate normal or abnormal termination. -C -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C -C IER > 0 Abnormal termination of the routine -C -C X and Y are unaltered. -C -C 3. Error messages -C -C Value of IER assigned by the DRC routine -C -C Value assigned Error message printed -C IER = 1 X.LT.0.0D0.OR.Y.LE.0.0D0 -C = 2 X+Y.LT.LOLIM -C = 3 MAX(X,Y) .GT. UPLIM -C -C 4. Control parameters -C -C Values of LOLIM, UPLIM, and ERRTOL are set by the -C routine. -C -C LOLIM and UPLIM determine the valid range of X and Y -C -C LOLIM - Lower limit of valid arguments -C -C Not less than 5 * (machine minimum) . -C -C UPLIM - Upper limit of valid arguments -C -C Not greater than (machine maximum) / 5 . -C -C -C Acceptable values for: LOLIM UPLIM -C IBM 360/370 SERIES : 3.0D-78 1.0D+75 -C CDC 6000/7000 SERIES : 1.0D-292 1.0D+321 -C UNIVAC 1100 SERIES : 1.0D-307 1.0D+307 -C CRAY : 2.3D-2466 1.0D+2465 -C VAX 11 SERIES : 1.5D-38 3.0D+37 -C -C ERRTOL determines the accuracy of the answer -C -C The value assigned by the routine will result -C in solution precision within 1-2 decimals of -C "machine precision". -C -C -C ERRTOL - relative error due to truncation is less than -C 16 * ERRTOL ** 6 / (1 - 2 * ERRTOL). -C -C -C The accuracy of the computed approximation to the inte- -C gral can be controlled by choosing the value of ERRTOL. -C Truncation of a Taylor series after terms of fifth order -C introduces an error less than the amount shown in the -C second column of the following table for each value of -C ERRTOL in the first column. In addition to the trunca- -C tion error there will be round-off error, but in prac- -C tice the total error from both sources is usually less -C than the amount given in the table. -C -C -C -C Sample choices: ERRTOL Relative truncation -C error less than -C 1.0D-3 2.0D-17 -C 3.0D-3 2.0D-14 -C 1.0D-2 2.0D-11 -C 3.0D-2 2.0D-8 -C 1.0D-1 2.0D-5 -C -C -C Decreasing ERRTOL by a factor of 10 yields six more -C decimal digits of accuracy at the expense of one or -C two more iterations of the duplication theorem. -C -C *Long Description: -C -C DRC special comments -C -C -C -C -C Check: DRC(X,X+Z) + DRC(Y,Y+Z) = DRC(0,Z) -C -C where X, Y, and Z are positive and X * Y = Z * Z -C -C -C On Input: -C -C X, and Y are the variables in the integral DRC(X,Y). -C -C On Output: -C -C X and Y are unaltered. -C -C -C -C DRC(0,1/4)=DRC(1/16,1/8)=PI=3.14159... -C -C DRC(9/4,2)=LN(2) -C -C -C -C ******************************************************** -C -C WARNING: Changes in the program may improve speed at the -C expense of robustness. -C -C -C -------------------------------------------------------------------- -C -C Special functions via DRC -C -C -C -C LN X X .GT. 0 -C -C 2 -C LN(X) = (X-1) DRC(((1+X)/2) , X ) -C -C -C -------------------------------------------------------------------- -C -C ARCSIN X -1 .LE. X .LE. 1 -C -C 2 -C ARCSIN X = X DRC (1-X ,1 ) -C -C -------------------------------------------------------------------- -C -C ARCCOS X 0 .LE. X .LE. 1 -C -C -C 2 2 -C ARCCOS X = SQRT(1-X ) DRC(X ,1 ) -C -C -------------------------------------------------------------------- -C -C ARCTAN X -INF .LT. X .LT. +INF -C -C 2 -C ARCTAN X = X DRC(1,1+X ) -C -C -------------------------------------------------------------------- -C -C ARCCOT X 0 .LE. X .LT. INF -C -C 2 2 -C ARCCOT X = DRC(X ,X +1 ) -C -C -------------------------------------------------------------------- -C -C ARCSINH X -INF .LT. X .LT. +INF -C -C 2 -C ARCSINH X = X DRC(1+X ,1 ) -C -C -------------------------------------------------------------------- -C -C ARCCOSH X X .GE. 1 -C -C 2 2 -C ARCCOSH X = SQRT(X -1) DRC(X ,1 ) -C -C -------------------------------------------------------------------- -C -C ARCTANH X -1 .LT. X .LT. 1 -C -C 2 -C ARCTANH X = X DRC(1,1-X ) -C -C -------------------------------------------------------------------- -C -C ARCCOTH X X .GT. 1 -C -C 2 2 -C ARCCOTH X = DRC(X ,X -1 ) -C -C -------------------------------------------------------------------- -C -C***REFERENCES B. C. Carlson and E. M. Notis, Algorithms for incomplete -C elliptic integrals, ACM Transactions on Mathematical -C Software 7, 3 (September 1981), pp. 398-403. -C B. C. Carlson, Computing elliptic integrals by -C duplication, Numerische Mathematik 33, (1979), -C pp. 1-16. -C B. C. Carlson, Elliptic integrals of the first kind, -C SIAM Journal of Mathematical Analysis 8, (1977), -C pp. 231-242. -C***ROUTINES CALLED D1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891009 Removed unreferenced statement labels. (WRB) -C 891009 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900510 Changed calls to XERMSG to standard form, and some -C editorial changes. (RWC)) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DRC - CHARACTER*16 XERN3, XERN4, XERN5 - INTEGER IER - DOUBLE PRECISION C1, C2, ERRTOL, LAMDA, LOLIM, D1MACH - DOUBLE PRECISION MU, S, SN, UPLIM, X, XN, Y, YN - LOGICAL FIRST - SAVE ERRTOL,LOLIM,UPLIM,C1,C2,FIRST - DATA FIRST /.TRUE./ -C -C***FIRST EXECUTABLE STATEMENT DRC - IF (FIRST) THEN - ERRTOL = (D1MACH(3)/16.0D0)**(1.0D0/6.0D0) - LOLIM = 5.0D0 * D1MACH(1) - UPLIM = D1MACH(2) / 5.0D0 -C - C1 = 1.0D0/7.0D0 - C2 = 9.0D0/22.0D0 - ENDIF - FIRST = .FALSE. -C -C CALL ERROR HANDLER IF NECESSARY. -C - DRC = 0.0D0 - IF (X.LT.0.0D0.OR.Y.LE.0.0D0) THEN - IER = 1 - WRITE (XERN3, '(1PE15.6)') X - WRITE (XERN4, '(1PE15.6)') Y - CALL XERMSG ('SLATEC', 'DRC', - * 'X.LT.0 .OR. Y.LE.0 WHERE X = ' // XERN3 // ' AND Y = ' // - * XERN4, 1, 1) - RETURN - ENDIF -C - IF (MAX(X,Y).GT.UPLIM) THEN - IER = 3 - WRITE (XERN3, '(1PE15.6)') X - WRITE (XERN4, '(1PE15.6)') Y - WRITE (XERN5, '(1PE15.6)') UPLIM - CALL XERMSG ('SLATEC', 'DRC', - * 'MAX(X,Y).GT.UPLIM WHERE X = ' // XERN3 // ' Y = ' // - * XERN4 // ' AND UPLIM = ' // XERN5, 3, 1) - RETURN - ENDIF -C - IF (X+Y.LT.LOLIM) THEN - IER = 2 - WRITE (XERN3, '(1PE15.6)') X - WRITE (XERN4, '(1PE15.6)') Y - WRITE (XERN5, '(1PE15.6)') LOLIM - CALL XERMSG ('SLATEC', 'DRC', - * 'X+Y.LT.LOLIM WHERE X = ' // XERN3 // ' Y = ' // XERN4 // - * ' AND LOLIM = ' // XERN5, 2, 1) - RETURN - ENDIF -C - IER = 0 - XN = X - YN = Y -C - 30 MU = (XN+YN+YN)/3.0D0 - SN = (YN+MU)/MU - 2.0D0 - IF (ABS(SN).LT.ERRTOL) GO TO 40 - LAMDA = 2.0D0*SQRT(XN)*SQRT(YN) + YN - XN = (XN+LAMDA)*0.250D0 - YN = (YN+LAMDA)*0.250D0 - GO TO 30 -C - 40 S = SN*SN*(0.30D0+SN*(C1+SN*(0.3750D0+SN*C2))) - DRC = (1.0D0+S)/SQRT(MU) - RETURN - END diff --git a/slatec/drc3jj.f b/slatec/drc3jj.f deleted file mode 100644 index 62240d9..0000000 --- a/slatec/drc3jj.f +++ /dev/null @@ -1,428 +0,0 @@ -*DECK DRC3JJ - SUBROUTINE DRC3JJ (L2, L3, M2, M3, L1MIN, L1MAX, THRCOF, NDIM, - + IER) -C***BEGIN PROLOGUE DRC3JJ -C***PURPOSE Evaluate the 3j symbol f(L1) = ( L1 L2 L3) -C (-M2-M3 M2 M3) -C for all allowed values of L1, the other parameters -C being held fixed. -C***LIBRARY SLATEC -C***CATEGORY C19 -C***TYPE DOUBLE PRECISION (RC3JJ-S, DRC3JJ-D) -C***KEYWORDS 3J COEFFICIENTS, 3J SYMBOLS, CLEBSCH-GORDAN COEFFICIENTS, -C RACAH COEFFICIENTS, VECTOR ADDITION COEFFICIENTS, -C WIGNER COEFFICIENTS -C***AUTHOR Gordon, R. G., Harvard University -C Schulten, K., Max Planck Institute -C***DESCRIPTION -C -C *Usage: -C -C DOUBLE PRECISION L2, L3, M2, M3, L1MIN, L1MAX, THRCOF(NDIM) -C INTEGER NDIM, IER -C -C CALL DRC3JJ (L2, L3, M2, M3, L1MIN, L1MAX, THRCOF, NDIM, IER) -C -C *Arguments: -C -C L2 :IN Parameter in 3j symbol. -C -C L3 :IN Parameter in 3j symbol. -C -C M2 :IN Parameter in 3j symbol. -C -C M3 :IN Parameter in 3j symbol. -C -C L1MIN :OUT Smallest allowable L1 in 3j symbol. -C -C L1MAX :OUT Largest allowable L1 in 3j symbol. -C -C THRCOF :OUT Set of 3j coefficients generated by evaluating the -C 3j symbol for all allowed values of L1. THRCOF(I) -C will contain f(L1MIN+I-1), I=1,2,...,L1MAX+L1MIN+1. -C -C NDIM :IN Declared length of THRCOF in calling program. -C -C IER :OUT Error flag. -C IER=0 No errors. -C IER=1 Either L2.LT.ABS(M2) or L3.LT.ABS(M3). -C IER=2 Either L2+ABS(M2) or L3+ABS(M3) non-integer. -C IER=3 L1MAX-L1MIN not an integer. -C IER=4 L1MAX less than L1MIN. -C IER=5 NDIM less than L1MAX-L1MIN+1. -C -C *Description: -C -C Although conventionally the parameters of the vector addition -C coefficients satisfy certain restrictions, such as being integers -C or integers plus 1/2, the restrictions imposed on input to this -C subroutine are somewhat weaker. See, for example, Section 27.9 of -C Abramowitz and Stegun or Appendix C of Volume II of A. Messiah. -C The restrictions imposed by this subroutine are -C 1. L2 .GE. ABS(M2) and L3 .GE. ABS(M3); -C 2. L2+ABS(M2) and L3+ABS(M3) must be integers; -C 3. L1MAX-L1MIN must be a non-negative integer, where -C L1MAX=L2+L3 and L1MIN=MAX(ABS(L2-L3),ABS(M2+M3)). -C If the conventional restrictions are satisfied, then these -C restrictions are met. -C -C The user should be cautious in using input parameters that do -C not satisfy the conventional restrictions. For example, the -C the subroutine produces values of -C f(L1) = ( L1 2.5 5.8) -C (-0.3 1.5 -1.2) -C for L1=3.3,4.3,...,8.3 but none of the symmetry properties of the 3j -C symbol, set forth on page 1056 of Messiah, is satisfied. -C -C The subroutine generates f(L1MIN), f(L1MIN+1), ..., f(L1MAX) -C where L1MIN and L1MAX are defined above. The sequence f(L1) is -C generated by a three-term recurrence algorithm with scaling to -C control overflow. Both backward and forward recurrence are used to -C maintain numerical stability. The two recurrence sequences are -C matched at an interior point and are normalized from the unitary -C property of 3j coefficients and Wigner's phase convention. -C -C The algorithm is suited to applications in which large quantum -C numbers arise, such as in molecular dynamics. -C -C***REFERENCES 1. Abramowitz, M., and Stegun, I. A., Eds., Handbook -C of Mathematical Functions with Formulas, Graphs -C and Mathematical Tables, NBS Applied Mathematics -C Series 55, June 1964 and subsequent printings. -C 2. Messiah, Albert., Quantum Mechanics, Volume II, -C North-Holland Publishing Company, 1963. -C 3. Schulten, Klaus and Gordon, Roy G., Exact recursive -C evaluation of 3j and 6j coefficients for quantum- -C mechanical coupling of angular momenta, J Math -C Phys, v 16, no. 10, October 1975, pp. 1961-1970. -C 4. Schulten, Klaus and Gordon, Roy G., Semiclassical -C approximations to 3j and 6j coefficients for -C quantum-mechanical coupling of angular momenta, -C J Math Phys, v 16, no. 10, October 1975, -C pp. 1971-1988. -C 5. Schulten, Klaus and Gordon, Roy G., Recursive -C evaluation of 3j and 6j coefficients, Computer -C Phys Comm, v 11, 1976, pp. 269-278. -C***ROUTINES CALLED D1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 880515 SLATEC prologue added by G. C. Nielson, NBS; parameters -C HUGE and TINY revised to depend on D1MACH. -C 891229 Prologue description rewritten; other prologue sections -C revised; LMATCH (location of match point for recurrences) -C removed from argument list; argument IER changed to serve -C only as an error flag (previously, in cases without error, -C it returned the number of scalings); number of error codes -C increased to provide more precise error information; -C program comments revised; SLATEC error handler calls -C introduced to enable printing of error messages to meet -C SLATEC standards. These changes were done by D. W. Lozier, -C M. A. McClain and J. M. Smith of the National Institute -C of Standards and Technology, formerly NBS. -C 910415 Mixed type expressions eliminated; variable C1 initialized; -C description of THRCOF expanded. These changes were done by -C D. W. Lozier. -C***END PROLOGUE DRC3JJ -C - INTEGER NDIM, IER - DOUBLE PRECISION L2, L3, M2, M3, L1MIN, L1MAX, THRCOF(NDIM) -C - INTEGER I, INDEX, LSTEP, N, NFIN, NFINP1, NFINP2, NFINP3, NLIM, - + NSTEP2 - DOUBLE PRECISION A1, A1S, A2, A2S, C1, C1OLD, C2, CNORM, D1MACH, - + DENOM, DV, EPS, HUGE, L1, M1, NEWFAC, OLDFAC, - + ONE, RATIO, SIGN1, SIGN2, SRHUGE, SRTINY, SUM1, - + SUM2, SUMBAC, SUMFOR, SUMUNI, THREE, THRESH, - + TINY, TWO, X, X1, X2, X3, Y, Y1, Y2, Y3, ZERO -C - DATA ZERO,EPS,ONE,TWO,THREE /0.0D0,0.01D0,1.0D0,2.0D0,3.0D0/ -C -C***FIRST EXECUTABLE STATEMENT DRC3JJ - IER=0 -C HUGE is the square root of one twentieth of the largest floating -C point number, approximately. - HUGE = SQRT(D1MACH(2)/20.0D0) - SRHUGE = SQRT(HUGE) - TINY = 1.0D0/HUGE - SRTINY = 1.0D0/SRHUGE -C -C LMATCH = ZERO - M1 = - M2 - M3 -C -C Check error conditions 1 and 2. - IF((L2-ABS(M2)+EPS.LT.ZERO).OR. - + (L3-ABS(M3)+EPS.LT.ZERO))THEN - IER=1 - CALL XERMSG('SLATEC','DRC3JJ','L2-ABS(M2) or L3-ABS(M3) '// - + 'less than zero.',IER,1) - RETURN - ELSEIF((MOD(L2+ABS(M2)+EPS,ONE).GE.EPS+EPS).OR. - + (MOD(L3+ABS(M3)+EPS,ONE).GE.EPS+EPS))THEN - IER=2 - CALL XERMSG('SLATEC','DRC3JJ','L2+ABS(M2) or L3+ABS(M3) '// - + 'not integer.',IER,1) - RETURN - ENDIF -C -C -C -C Limits for L1 -C - L1MIN = MAX(ABS(L2-L3),ABS(M1)) - L1MAX = L2 + L3 -C -C Check error condition 3. - IF(MOD(L1MAX-L1MIN+EPS,ONE).GE.EPS+EPS)THEN - IER=3 - CALL XERMSG('SLATEC','DRC3JJ','L1MAX-L1MIN not integer.',IER,1) - RETURN - ENDIF - IF(L1MIN.LT.L1MAX-EPS) GO TO 20 - IF(L1MIN.LT.L1MAX+EPS) GO TO 10 -C -C Check error condition 4. - IER=4 - CALL XERMSG('SLATEC','DRC3JJ','L1MIN greater than L1MAX.',IER,1) - RETURN -C -C This is reached in case that L1 can take only one value, -C i.e. L1MIN = L1MAX -C - 10 CONTINUE -C LSCALE = 0 - THRCOF(1) = (-ONE) ** INT(ABS(L2+M2-L3+M3)+EPS) / - 1 SQRT(L1MIN + L2 + L3 + ONE) - RETURN -C -C This is reached in case that L1 takes more than one value, -C i.e. L1MIN < L1MAX. -C - 20 CONTINUE -C LSCALE = 0 - NFIN = INT(L1MAX-L1MIN+ONE+EPS) - IF(NDIM-NFIN) 21, 23, 23 -C -C Check error condition 5. - 21 IER = 5 - CALL XERMSG('SLATEC','DRC3JJ','Dimension of result array for '// - + '3j coefficients too small.',IER,1) - RETURN -C -C -C Starting forward recursion from L1MIN taking NSTEP1 steps -C - 23 L1 = L1MIN - NEWFAC = 0.0D0 - C1 = 0.0D0 - THRCOF(1) = SRTINY - SUM1 = (L1+L1+ONE) * TINY -C -C - LSTEP = 1 - 30 LSTEP = LSTEP + 1 - L1 = L1 + ONE -C -C - OLDFAC = NEWFAC - A1 = (L1+L2+L3+ONE) * (L1-L2+L3) * (L1+L2-L3) * (-L1+L2+L3+ONE) - A2 = (L1+M1) * (L1-M1) - NEWFAC = SQRT(A1*A2) - IF(L1.LT.ONE+EPS) GO TO 40 -C -C - DV = - L2*(L2+ONE) * M1 + L3*(L3+ONE) * M1 + L1*(L1-ONE) * (M3-M2) - DENOM = (L1-ONE) * NEWFAC -C - IF(LSTEP-2) 32, 32, 31 -C - 31 C1OLD = ABS(C1) - 32 C1 = - (L1+L1-ONE) * DV / DENOM - GO TO 50 -C -C If L1 = 1, (L1-1) has to be factored out of DV, hence -C - 40 C1 = - (L1+L1-ONE) * L1 * (M3-M2) / NEWFAC -C - 50 IF(LSTEP.GT.2) GO TO 60 -C -C -C If L1 = L1MIN + 1, the third term in the recursion equation vanishes, -C hence - X = SRTINY * C1 - THRCOF(2) = X - SUM1 = SUM1 + TINY * (L1+L1+ONE) * C1*C1 - IF(LSTEP.EQ.NFIN) GO TO 220 - GO TO 30 -C -C - 60 C2 = - L1 * OLDFAC / DENOM -C -C Recursion to the next 3j coefficient X -C - X = C1 * THRCOF(LSTEP-1) + C2 * THRCOF(LSTEP-2) - THRCOF(LSTEP) = X - SUMFOR = SUM1 - SUM1 = SUM1 + (L1+L1+ONE) * X*X - IF(LSTEP.EQ.NFIN) GO TO 100 -C -C See if last unnormalized 3j coefficient exceeds SRHUGE -C - IF(ABS(X).LT.SRHUGE) GO TO 80 -C -C This is reached if last 3j coefficient larger than SRHUGE, -C so that the recursion series THRCOF(1), ... , THRCOF(LSTEP) -C has to be rescaled to prevent overflow -C -C LSCALE = LSCALE + 1 - DO 70 I=1,LSTEP - IF(ABS(THRCOF(I)).LT.SRTINY) THRCOF(I) = ZERO - 70 THRCOF(I) = THRCOF(I) / SRHUGE - SUM1 = SUM1 / HUGE - SUMFOR = SUMFOR / HUGE - X = X / SRHUGE -C -C As long as ABS(C1) is decreasing, the recursion proceeds towards -C increasing 3j values and, hence, is numerically stable. Once -C an increase of ABS(C1) is detected, the recursion direction is -C reversed. -C - 80 IF(C1OLD-ABS(C1)) 100, 100, 30 -C -C -C Keep three 3j coefficients around LMATCH for comparison with -C backward recursion. -C - 100 CONTINUE -C LMATCH = L1 - 1 - X1 = X - X2 = THRCOF(LSTEP-1) - X3 = THRCOF(LSTEP-2) - NSTEP2 = NFIN - LSTEP + 3 -C -C -C -C -C Starting backward recursion from L1MAX taking NSTEP2 steps, so -C that forward and backward recursion overlap at three points -C L1 = LMATCH+1, LMATCH, LMATCH-1. -C - NFINP1 = NFIN + 1 - NFINP2 = NFIN + 2 - NFINP3 = NFIN + 3 - L1 = L1MAX - THRCOF(NFIN) = SRTINY - SUM2 = TINY * (L1+L1+ONE) -C - L1 = L1 + TWO - LSTEP = 1 - 110 LSTEP = LSTEP + 1 - L1 = L1 - ONE -C - OLDFAC = NEWFAC - A1S = (L1+L2+L3)*(L1-L2+L3-ONE)*(L1+L2-L3-ONE)*(-L1+L2+L3+TWO) - A2S = (L1+M1-ONE) * (L1-M1-ONE) - NEWFAC = SQRT(A1S*A2S) -C - DV = - L2*(L2+ONE) * M1 + L3*(L3+ONE) * M1 + L1*(L1-ONE) * (M3-M2) -C - DENOM = L1 * NEWFAC - C1 = - (L1+L1-ONE) * DV / DENOM - IF(LSTEP.GT.2) GO TO 120 -C -C If L1 = L1MAX + 1, the third term in the recursion formula vanishes -C - Y = SRTINY * C1 - THRCOF(NFIN-1) = Y - SUMBAC = SUM2 - SUM2 = SUM2 + TINY * (L1+L1-THREE) * C1*C1 -C - GO TO 110 -C -C - 120 C2 = - (L1 - ONE) * OLDFAC / DENOM -C -C Recursion to the next 3j coefficient Y -C - Y = C1 * THRCOF(NFINP2-LSTEP) + C2 * THRCOF(NFINP3-LSTEP) -C - IF(LSTEP.EQ.NSTEP2) GO TO 200 -C - THRCOF(NFINP1-LSTEP) = Y - SUMBAC = SUM2 - SUM2 = SUM2 + (L1+L1-THREE) * Y*Y -C -C See if last unnormalized 3j coefficient exceeds SRHUGE -C - IF(ABS(Y).LT.SRHUGE) GO TO 110 -C -C This is reached if last 3j coefficient larger than SRHUGE, -C so that the recursion series THRCOF(NFIN), ... ,THRCOF(NFIN-LSTEP+1) -C has to be rescaled to prevent overflow -C -C LSCALE = LSCALE + 1 - DO 130 I=1,LSTEP - INDEX = NFIN - I + 1 - IF(ABS(THRCOF(INDEX)).LT.SRTINY) THRCOF(INDEX) = ZERO - 130 THRCOF(INDEX) = THRCOF(INDEX) / SRHUGE - SUM2 = SUM2 / HUGE - SUMBAC = SUMBAC / HUGE -C -C - GO TO 110 -C -C -C The forward recursion 3j coefficients X1, X2, X3 are to be matched -C with the corresponding backward recursion values Y1, Y2, Y3. -C - 200 Y3 = Y - Y2 = THRCOF(NFINP2-LSTEP) - Y1 = THRCOF(NFINP3-LSTEP) -C -C -C Determine now RATIO such that YI = RATIO * XI (I=1,2,3) holds -C with minimal error. -C - RATIO = ( X1*Y1 + X2*Y2 + X3*Y3 ) / ( X1*X1 + X2*X2 + X3*X3 ) - NLIM = NFIN - NSTEP2 + 1 -C - IF(ABS(RATIO).LT.ONE) GO TO 211 -C - DO 210 N=1,NLIM - 210 THRCOF(N) = RATIO * THRCOF(N) - SUMUNI = RATIO * RATIO * SUMFOR + SUMBAC - GO TO 230 -C - 211 NLIM = NLIM + 1 - RATIO = ONE / RATIO - DO 212 N=NLIM,NFIN - 212 THRCOF(N) = RATIO * THRCOF(N) - SUMUNI = SUMFOR + RATIO*RATIO*SUMBAC - GO TO 230 -C - 220 SUMUNI = SUM1 -C -C -C Normalize 3j coefficients -C - 230 CNORM = ONE / SQRT(SUMUNI) -C -C Sign convention for last 3j coefficient determines overall phase -C - SIGN1 = SIGN(ONE,THRCOF(NFIN)) - SIGN2 = (-ONE) ** INT(ABS(L2+M2-L3+M3)+EPS) - IF(SIGN1*SIGN2) 235,235,236 - 235 CNORM = - CNORM -C - 236 IF(ABS(CNORM).LT.ONE) GO TO 250 -C - DO 240 N=1,NFIN - 240 THRCOF(N) = CNORM * THRCOF(N) - RETURN -C - 250 THRESH = TINY / ABS(CNORM) - DO 251 N=1,NFIN - IF(ABS(THRCOF(N)).LT.THRESH) THRCOF(N) = ZERO - 251 THRCOF(N) = CNORM * THRCOF(N) -C - RETURN - END diff --git a/slatec/drc3jm.f b/slatec/drc3jm.f deleted file mode 100644 index 44853d4..0000000 --- a/slatec/drc3jm.f +++ /dev/null @@ -1,423 +0,0 @@ -*DECK DRC3JM - SUBROUTINE DRC3JM (L1, L2, L3, M1, M2MIN, M2MAX, THRCOF, NDIM, - + IER) -C***BEGIN PROLOGUE DRC3JM -C***PURPOSE Evaluate the 3j symbol g(M2) = (L1 L2 L3 ) -C (M1 M2 -M1-M2) -C for all allowed values of M2, the other parameters -C being held fixed. -C***LIBRARY SLATEC -C***CATEGORY C19 -C***TYPE DOUBLE PRECISION (RC3JM-S, DRC3JM-D) -C***KEYWORDS 3J COEFFICIENTS, 3J SYMBOLS, CLEBSCH-GORDAN COEFFICIENTS, -C RACAH COEFFICIENTS, VECTOR ADDITION COEFFICIENTS, -C WIGNER COEFFICIENTS -C***AUTHOR Gordon, R. G., Harvard University -C Schulten, K., Max Planck Institute -C***DESCRIPTION -C -C *Usage: -C -C DOUBLE PRECISION L1, L2, L3, M1, M2MIN, M2MAX, THRCOF(NDIM) -C INTEGER NDIM, IER -C -C CALL DRC3JM (L1, L2, L3, M1, M2MIN, M2MAX, THRCOF, NDIM, IER) -C -C *Arguments: -C -C L1 :IN Parameter in 3j symbol. -C -C L2 :IN Parameter in 3j symbol. -C -C L3 :IN Parameter in 3j symbol. -C -C M1 :IN Parameter in 3j symbol. -C -C M2MIN :OUT Smallest allowable M2 in 3j symbol. -C -C M2MAX :OUT Largest allowable M2 in 3j symbol. -C -C THRCOF :OUT Set of 3j coefficients generated by evaluating the -C 3j symbol for all allowed values of M2. THRCOF(I) -C will contain g(M2MIN+I-1), I=1,2,...,M2MAX-M2MIN+1. -C -C NDIM :IN Declared length of THRCOF in calling program. -C -C IER :OUT Error flag. -C IER=0 No errors. -C IER=1 Either L1.LT.ABS(M1) or L1+ABS(M1) non-integer. -C IER=2 ABS(L1-L2).LE.L3.LE.L1+L2 not satisfied. -C IER=3 L1+L2+L3 not an integer. -C IER=4 M2MAX-M2MIN not an integer. -C IER=5 M2MAX less than M2MIN. -C IER=6 NDIM less than M2MAX-M2MIN+1. -C -C *Description: -C -C Although conventionally the parameters of the vector addition -C coefficients satisfy certain restrictions, such as being integers -C or integers plus 1/2, the restrictions imposed on input to this -C subroutine are somewhat weaker. See, for example, Section 27.9 of -C Abramowitz and Stegun or Appendix C of Volume II of A. Messiah. -C The restrictions imposed by this subroutine are -C 1. L1.GE.ABS(M1) and L1+ABS(M1) must be an integer; -C 2. ABS(L1-L2).LE.L3.LE.L1+L2; -C 3. L1+L2+L3 must be an integer; -C 4. M2MAX-M2MIN must be an integer, where -C M2MAX=MIN(L2,L3-M1) and M2MIN=MAX(-L2,-L3-M1). -C If the conventional restrictions are satisfied, then these -C restrictions are met. -C -C The user should be cautious in using input parameters that do -C not satisfy the conventional restrictions. For example, the -C the subroutine produces values of -C g(M2) = (0.75 1.50 1.75 ) -C (0.25 M2 -0.25-M2) -C for M2=-1.5,-0.5,0.5,1.5 but none of the symmetry properties of the -C 3j symbol, set forth on page 1056 of Messiah, is satisfied. -C -C The subroutine generates g(M2MIN), g(M2MIN+1), ..., g(M2MAX) -C where M2MIN and M2MAX are defined above. The sequence g(M2) is -C generated by a three-term recurrence algorithm with scaling to -C control overflow. Both backward and forward recurrence are used to -C maintain numerical stability. The two recurrence sequences are -C matched at an interior point and are normalized from the unitary -C property of 3j coefficients and Wigner's phase convention. -C -C The algorithm is suited to applications in which large quantum -C numbers arise, such as in molecular dynamics. -C -C***REFERENCES 1. Abramowitz, M., and Stegun, I. A., Eds., Handbook -C of Mathematical Functions with Formulas, Graphs -C and Mathematical Tables, NBS Applied Mathematics -C Series 55, June 1964 and subsequent printings. -C 2. Messiah, Albert., Quantum Mechanics, Volume II, -C North-Holland Publishing Company, 1963. -C 3. Schulten, Klaus and Gordon, Roy G., Exact recursive -C evaluation of 3j and 6j coefficients for quantum- -C mechanical coupling of angular momenta, J Math -C Phys, v 16, no. 10, October 1975, pp. 1961-1970. -C 4. Schulten, Klaus and Gordon, Roy G., Semiclassical -C approximations to 3j and 6j coefficients for -C quantum-mechanical coupling of angular momenta, -C J Math Phys, v 16, no. 10, October 1975, -C pp. 1971-1988. -C 5. Schulten, Klaus and Gordon, Roy G., Recursive -C evaluation of 3j and 6j coefficients, Computer -C Phys Comm, v 11, 1976, pp. 269-278. -C***ROUTINES CALLED D1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 880515 SLATEC prologue added by G. C. Nielson, NBS; parameters -C HUGE and TINY revised to depend on D1MACH. -C 891229 Prologue description rewritten; other prologue sections -C revised; MMATCH (location of match point for recurrences) -C removed from argument list; argument IER changed to serve -C only as an error flag (previously, in cases without error, -C it returned the number of scalings); number of error codes -C increased to provide more precise error information; -C program comments revised; SLATEC error handler calls -C introduced to enable printing of error messages to meet -C SLATEC standards. These changes were done by D. W. Lozier, -C M. A. McClain and J. M. Smith of the National Institute -C of Standards and Technology, formerly NBS. -C 910415 Mixed type expressions eliminated; variable C1 initialized; -C description of THRCOF expanded. These changes were done by -C D. W. Lozier. -C***END PROLOGUE DRC3JM -C - INTEGER NDIM, IER - DOUBLE PRECISION L1, L2, L3, M1, M2MIN, M2MAX, THRCOF(NDIM) -C - INTEGER I, INDEX, LSTEP, N, NFIN, NFINP1, NFINP2, NFINP3, NLIM, - + NSTEP2 - DOUBLE PRECISION A1, A1S, C1, C1OLD, C2, CNORM, D1MACH, DV, EPS, - + HUGE, M2, M3, NEWFAC, OLDFAC, ONE, RATIO, SIGN1, - + SIGN2, SRHUGE, SRTINY, SUM1, SUM2, SUMBAC, - + SUMFOR, SUMUNI, THRESH, TINY, TWO, X, X1, X2, X3, - + Y, Y1, Y2, Y3, ZERO -C - DATA ZERO,EPS,ONE,TWO /0.0D0,0.01D0,1.0D0,2.0D0/ -C -C***FIRST EXECUTABLE STATEMENT DRC3JM - IER=0 -C HUGE is the square root of one twentieth of the largest floating -C point number, approximately. - HUGE = SQRT(D1MACH(2)/20.0D0) - SRHUGE = SQRT(HUGE) - TINY = 1.0D0/HUGE - SRTINY = 1.0D0/SRHUGE -C -C MMATCH = ZERO -C -C -C Check error conditions 1, 2, and 3. - IF((L1-ABS(M1)+EPS.LT.ZERO).OR. - + (MOD(L1+ABS(M1)+EPS,ONE).GE.EPS+EPS))THEN - IER=1 - CALL XERMSG('SLATEC','DRC3JM','L1-ABS(M1) less than zero or '// - + 'L1+ABS(M1) not integer.',IER,1) - RETURN - ELSEIF((L1+L2-L3.LT.-EPS).OR.(L1-L2+L3.LT.-EPS).OR. - + (-L1+L2+L3.LT.-EPS))THEN - IER=2 - CALL XERMSG('SLATEC','DRC3JM','L1, L2, L3 do not satisfy '// - + 'triangular condition.',IER,1) - RETURN - ELSEIF(MOD(L1+L2+L3+EPS,ONE).GE.EPS+EPS)THEN - IER=3 - CALL XERMSG('SLATEC','DRC3JM','L1+L2+L3 not integer.',IER,1) - RETURN - ENDIF -C -C -C Limits for M2 - M2MIN = MAX(-L2,-L3-M1) - M2MAX = MIN(L2,L3-M1) -C -C Check error condition 4. - IF(MOD(M2MAX-M2MIN+EPS,ONE).GE.EPS+EPS)THEN - IER=4 - CALL XERMSG('SLATEC','DRC3JM','M2MAX-M2MIN not integer.',IER,1) - RETURN - ENDIF - IF(M2MIN.LT.M2MAX-EPS) GO TO 20 - IF(M2MIN.LT.M2MAX+EPS) GO TO 10 -C -C Check error condition 5. - IER=5 - CALL XERMSG('SLATEC','DRC3JM','M2MIN greater than M2MAX.',IER,1) - RETURN -C -C -C This is reached in case that M2 and M3 can take only one value. - 10 CONTINUE -C MSCALE = 0 - THRCOF(1) = (-ONE) ** INT(ABS(L2-L3-M1)+EPS) / - 1 SQRT(L1+L2+L3+ONE) - RETURN -C -C This is reached in case that M1 and M2 take more than one value. - 20 CONTINUE -C MSCALE = 0 - NFIN = INT(M2MAX-M2MIN+ONE+EPS) - IF(NDIM-NFIN) 21, 23, 23 -C -C Check error condition 6. - 21 IER = 6 - CALL XERMSG('SLATEC','DRC3JM','Dimension of result array for '// - + '3j coefficients too small.',IER,1) - RETURN -C -C -C -C Start of forward recursion from M2 = M2MIN -C - 23 M2 = M2MIN - THRCOF(1) = SRTINY - NEWFAC = 0.0D0 - C1 = 0.0D0 - SUM1 = TINY -C -C - LSTEP = 1 - 30 LSTEP = LSTEP + 1 - M2 = M2 + ONE - M3 = - M1 - M2 -C -C - OLDFAC = NEWFAC - A1 = (L2-M2+ONE) * (L2+M2) * (L3+M3+ONE) * (L3-M3) - NEWFAC = SQRT(A1) -C -C - DV = (L1+L2+L3+ONE)*(L2+L3-L1) - (L2-M2+ONE)*(L3+M3+ONE) - 1 - (L2+M2-ONE)*(L3-M3-ONE) -C - IF(LSTEP-2) 32, 32, 31 -C - 31 C1OLD = ABS(C1) - 32 C1 = - DV / NEWFAC -C - IF(LSTEP.GT.2) GO TO 60 -C -C -C If M2 = M2MIN + 1, the third term in the recursion equation vanishes, -C hence -C - X = SRTINY * C1 - THRCOF(2) = X - SUM1 = SUM1 + TINY * C1*C1 - IF(LSTEP.EQ.NFIN) GO TO 220 - GO TO 30 -C -C - 60 C2 = - OLDFAC / NEWFAC -C -C Recursion to the next 3j coefficient - X = C1 * THRCOF(LSTEP-1) + C2 * THRCOF(LSTEP-2) - THRCOF(LSTEP) = X - SUMFOR = SUM1 - SUM1 = SUM1 + X*X - IF(LSTEP.EQ.NFIN) GO TO 100 -C -C See if last unnormalized 3j coefficient exceeds SRHUGE -C - IF(ABS(X).LT.SRHUGE) GO TO 80 -C -C This is reached if last 3j coefficient larger than SRHUGE, -C so that the recursion series THRCOF(1), ... , THRCOF(LSTEP) -C has to be rescaled to prevent overflow -C -C MSCALE = MSCALE + 1 - DO 70 I=1,LSTEP - IF(ABS(THRCOF(I)).LT.SRTINY) THRCOF(I) = ZERO - 70 THRCOF(I) = THRCOF(I) / SRHUGE - SUM1 = SUM1 / HUGE - SUMFOR = SUMFOR / HUGE - X = X / SRHUGE -C -C -C As long as ABS(C1) is decreasing, the recursion proceeds towards -C increasing 3j values and, hence, is numerically stable. Once -C an increase of ABS(C1) is detected, the recursion direction is -C reversed. -C - 80 IF(C1OLD-ABS(C1)) 100, 100, 30 -C -C -C Keep three 3j coefficients around MMATCH for comparison later -C with backward recursion values. -C - 100 CONTINUE -C MMATCH = M2 - 1 - NSTEP2 = NFIN - LSTEP + 3 - X1 = X - X2 = THRCOF(LSTEP-1) - X3 = THRCOF(LSTEP-2) -C -C Starting backward recursion from M2MAX taking NSTEP2 steps, so -C that forwards and backwards recursion overlap at the three points -C M2 = MMATCH+1, MMATCH, MMATCH-1. -C - NFINP1 = NFIN + 1 - NFINP2 = NFIN + 2 - NFINP3 = NFIN + 3 - THRCOF(NFIN) = SRTINY - SUM2 = TINY -C -C -C - M2 = M2MAX + TWO - LSTEP = 1 - 110 LSTEP = LSTEP + 1 - M2 = M2 - ONE - M3 = - M1 - M2 - OLDFAC = NEWFAC - A1S = (L2-M2+TWO) * (L2+M2-ONE) * (L3+M3+TWO) * (L3-M3-ONE) - NEWFAC = SQRT(A1S) - DV = (L1+L2+L3+ONE)*(L2+L3-L1) - (L2-M2+ONE)*(L3+M3+ONE) - 1 - (L2+M2-ONE)*(L3-M3-ONE) - C1 = - DV / NEWFAC - IF(LSTEP.GT.2) GO TO 120 -C -C If M2 = M2MAX + 1 the third term in the recursion equation vanishes -C - Y = SRTINY * C1 - THRCOF(NFIN-1) = Y - IF(LSTEP.EQ.NSTEP2) GO TO 200 - SUMBAC = SUM2 - SUM2 = SUM2 + Y*Y - GO TO 110 -C - 120 C2 = - OLDFAC / NEWFAC -C -C Recursion to the next 3j coefficient -C - Y = C1 * THRCOF(NFINP2-LSTEP) + C2 * THRCOF(NFINP3-LSTEP) -C - IF(LSTEP.EQ.NSTEP2) GO TO 200 -C - THRCOF(NFINP1-LSTEP) = Y - SUMBAC = SUM2 - SUM2 = SUM2 + Y*Y -C -C -C See if last 3j coefficient exceeds SRHUGE -C - IF(ABS(Y).LT.SRHUGE) GO TO 110 -C -C This is reached if last 3j coefficient larger than SRHUGE, -C so that the recursion series THRCOF(NFIN), ... , THRCOF(NFIN-LSTEP+1) -C has to be rescaled to prevent overflow. -C -C MSCALE = MSCALE + 1 - DO 111 I=1,LSTEP - INDEX = NFIN - I + 1 - IF(ABS(THRCOF(INDEX)).LT.SRTINY) - 1 THRCOF(INDEX) = ZERO - 111 THRCOF(INDEX) = THRCOF(INDEX) / SRHUGE - SUM2 = SUM2 / HUGE - SUMBAC = SUMBAC / HUGE -C - GO TO 110 -C -C -C -C The forward recursion 3j coefficients X1, X2, X3 are to be matched -C with the corresponding backward recursion values Y1, Y2, Y3. -C - 200 Y3 = Y - Y2 = THRCOF(NFINP2-LSTEP) - Y1 = THRCOF(NFINP3-LSTEP) -C -C -C Determine now RATIO such that YI = RATIO * XI (I=1,2,3) holds -C with minimal error. -C - RATIO = ( X1*Y1 + X2*Y2 + X3*Y3 ) / ( X1*X1 + X2*X2 + X3*X3 ) - NLIM = NFIN - NSTEP2 + 1 -C - IF(ABS(RATIO).LT.ONE) GO TO 211 -C - DO 210 N=1,NLIM - 210 THRCOF(N) = RATIO * THRCOF(N) - SUMUNI = RATIO * RATIO * SUMFOR + SUMBAC - GO TO 230 -C - 211 NLIM = NLIM + 1 - RATIO = ONE / RATIO - DO 212 N=NLIM,NFIN - 212 THRCOF(N) = RATIO * THRCOF(N) - SUMUNI = SUMFOR + RATIO*RATIO*SUMBAC - GO TO 230 -C - 220 SUMUNI = SUM1 -C -C -C Normalize 3j coefficients -C - 230 CNORM = ONE / SQRT((L1+L1+ONE) * SUMUNI) -C -C Sign convention for last 3j coefficient determines overall phase -C - SIGN1 = SIGN(ONE,THRCOF(NFIN)) - SIGN2 = (-ONE) ** INT(ABS(L2-L3-M1)+EPS) - IF(SIGN1*SIGN2) 235,235,236 - 235 CNORM = - CNORM -C - 236 IF(ABS(CNORM).LT.ONE) GO TO 250 -C - DO 240 N=1,NFIN - 240 THRCOF(N) = CNORM * THRCOF(N) - RETURN -C - 250 THRESH = TINY / ABS(CNORM) - DO 251 N=1,NFIN - IF(ABS(THRCOF(N)).LT.THRESH) THRCOF(N) = ZERO - 251 THRCOF(N) = CNORM * THRCOF(N) -C -C -C - RETURN - END diff --git a/slatec/drc6j.f b/slatec/drc6j.f deleted file mode 100644 index 4add016..0000000 --- a/slatec/drc6j.f +++ /dev/null @@ -1,439 +0,0 @@ -*DECK DRC6J - SUBROUTINE DRC6J (L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF, NDIM, - + IER) -C***BEGIN PROLOGUE DRC6J -C***PURPOSE Evaluate the 6j symbol h(L1) = {L1 L2 L3} -C {L4 L5 L6} -C for all allowed values of L1, the other parameters -C being held fixed. -C***LIBRARY SLATEC -C***CATEGORY C19 -C***TYPE DOUBLE PRECISION (RC6J-S, DRC6J-D) -C***KEYWORDS 6J COEFFICIENTS, 6J SYMBOLS, CLEBSCH-GORDAN COEFFICIENTS, -C RACAH COEFFICIENTS, VECTOR ADDITION COEFFICIENTS, -C WIGNER COEFFICIENTS -C***AUTHOR Gordon, R. G., Harvard University -C Schulten, K., Max Planck Institute -C***DESCRIPTION -C -C *Usage: -C -C DOUBLE PRECISION L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF(NDIM) -C INTEGER NDIM, IER -C -C CALL DRC6J(L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF, NDIM, IER) -C -C *Arguments: -C -C L2 :IN Parameter in 6j symbol. -C -C L3 :IN Parameter in 6j symbol. -C -C L4 :IN Parameter in 6j symbol. -C -C L5 :IN Parameter in 6j symbol. -C -C L6 :IN Parameter in 6j symbol. -C -C L1MIN :OUT Smallest allowable L1 in 6j symbol. -C -C L1MAX :OUT Largest allowable L1 in 6j symbol. -C -C SIXCOF :OUT Set of 6j coefficients generated by evaluating the -C 6j symbol for all allowed values of L1. SIXCOF(I) -C will contain h(L1MIN+I-1), I=1,2,...,L1MAX-L1MIN+1. -C -C NDIM :IN Declared length of SIXCOF in calling program. -C -C IER :OUT Error flag. -C IER=0 No errors. -C IER=1 L2+L3+L5+L6 or L4+L2+L6 not an integer. -C IER=2 L4, L2, L6 triangular condition not satisfied. -C IER=3 L4, L5, L3 triangular condition not satisfied. -C IER=4 L1MAX-L1MIN not an integer. -C IER=5 L1MAX less than L1MIN. -C IER=6 NDIM less than L1MAX-L1MIN+1. -C -C *Description: -C -C The definition and properties of 6j symbols can be found, for -C example, in Appendix C of Volume II of A. Messiah. Although the -C parameters of the vector addition coefficients satisfy certain -C conventional restrictions, the restriction that they be non-negative -C integers or non-negative integers plus 1/2 is not imposed on input -C to this subroutine. The restrictions imposed are -C 1. L2+L3+L5+L6 and L2+L4+L6 must be integers; -C 2. ABS(L2-L4).LE.L6.LE.L2+L4 must be satisfied; -C 3. ABS(L4-L5).LE.L3.LE.L4+L5 must be satisfied; -C 4. L1MAX-L1MIN must be a non-negative integer, where -C L1MAX=MIN(L2+L3,L5+L6) and L1MIN=MAX(ABS(L2-L3),ABS(L5-L6)). -C If all the conventional restrictions are satisfied, then these -C restrictions are met. Conversely, if input to this subroutine meets -C all of these restrictions and the conventional restriction stated -C above, then all the conventional restrictions are satisfied. -C -C The user should be cautious in using input parameters that do -C not satisfy the conventional restrictions. For example, the -C the subroutine produces values of -C h(L1) = { L1 2/3 1 } -C {2/3 2/3 2/3} -C for L1=1/3 and 4/3 but none of the symmetry properties of the 6j -C symbol, set forth on pages 1063 and 1064 of Messiah, is satisfied. -C -C The subroutine generates h(L1MIN), h(L1MIN+1), ..., h(L1MAX) -C where L1MIN and L1MAX are defined above. The sequence h(L1) is -C generated by a three-term recurrence algorithm with scaling to -C control overflow. Both backward and forward recurrence are used to -C maintain numerical stability. The two recurrence sequences are -C matched at an interior point and are normalized from the unitary -C property of 6j coefficients and Wigner's phase convention. -C -C The algorithm is suited to applications in which large quantum -C numbers arise, such as in molecular dynamics. -C -C***REFERENCES 1. Messiah, Albert., Quantum Mechanics, Volume II, -C North-Holland Publishing Company, 1963. -C 2. Schulten, Klaus and Gordon, Roy G., Exact recursive -C evaluation of 3j and 6j coefficients for quantum- -C mechanical coupling of angular momenta, J Math -C Phys, v 16, no. 10, October 1975, pp. 1961-1970. -C 3. Schulten, Klaus and Gordon, Roy G., Semiclassical -C approximations to 3j and 6j coefficients for -C quantum-mechanical coupling of angular momenta, -C J Math Phys, v 16, no. 10, October 1975, -C pp. 1971-1988. -C 4. Schulten, Klaus and Gordon, Roy G., Recursive -C evaluation of 3j and 6j coefficients, Computer -C Phys Comm, v 11, 1976, pp. 269-278. -C***ROUTINES CALLED D1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 880515 SLATEC prologue added by G. C. Nielson, NBS; parameters -C HUGE and TINY revised to depend on D1MACH. -C 891229 Prologue description rewritten; other prologue sections -C revised; LMATCH (location of match point for recurrences) -C removed from argument list; argument IER changed to serve -C only as an error flag (previously, in cases without error, -C it returned the number of scalings); number of error codes -C increased to provide more precise error information; -C program comments revised; SLATEC error handler calls -C introduced to enable printing of error messages to meet -C SLATEC standards. These changes were done by D. W. Lozier, -C M. A. McClain and J. M. Smith of the National Institute -C of Standards and Technology, formerly NBS. -C 910415 Mixed type expressions eliminated; variable C1 initialized; -C description of SIXCOF expanded. These changes were done by -C D. W. Lozier. -C***END PROLOGUE DRC6J -C - INTEGER NDIM, IER - DOUBLE PRECISION L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF(NDIM) -C - INTEGER I, INDEX, LSTEP, N, NFIN, NFINP1, NFINP2, NFINP3, NLIM, - + NSTEP2 - DOUBLE PRECISION A1, A1S, A2, A2S, C1, C1OLD, C2, CNORM, D1MACH, - + DENOM, DV, EPS, HUGE, L1, NEWFAC, OLDFAC, ONE, - + RATIO, SIGN1, SIGN2, SRHUGE, SRTINY, SUM1, SUM2, - + SUMBAC, SUMFOR, SUMUNI, THREE, THRESH, TINY, TWO, - + X, X1, X2, X3, Y, Y1, Y2, Y3, ZERO -C - DATA ZERO,EPS,ONE,TWO,THREE /0.0D0,0.01D0,1.0D0,2.0D0,3.0D0/ -C -C***FIRST EXECUTABLE STATEMENT DRC6J - IER=0 -C HUGE is the square root of one twentieth of the largest floating -C point number, approximately. - HUGE = SQRT(D1MACH(2)/20.0D0) - SRHUGE = SQRT(HUGE) - TINY = 1.0D0/HUGE - SRTINY = 1.0D0/SRHUGE -C -C LMATCH = ZERO -C -C Check error conditions 1, 2, and 3. - IF((MOD(L2+L3+L5+L6+EPS,ONE).GE.EPS+EPS).OR. - + (MOD(L4+L2+L6+EPS,ONE).GE.EPS+EPS))THEN - IER=1 - CALL XERMSG('SLATEC','DRC6J','L2+L3+L5+L6 or L4+L2+L6 not '// - + 'integer.',IER,1) - RETURN - ELSEIF((L4+L2-L6.LT.ZERO).OR.(L4-L2+L6.LT.ZERO).OR. - + (-L4+L2+L6.LT.ZERO))THEN - IER=2 - CALL XERMSG('SLATEC','DRC6J','L4, L2, L6 triangular '// - + 'condition not satisfied.',IER,1) - RETURN - ELSEIF((L4-L5+L3.LT.ZERO).OR.(L4+L5-L3.LT.ZERO).OR. - + (-L4+L5+L3.LT.ZERO))THEN - IER=3 - CALL XERMSG('SLATEC','DRC6J','L4, L5, L3 triangular '// - + 'condition not satisfied.',IER,1) - RETURN - ENDIF -C -C Limits for L1 -C - L1MIN = MAX(ABS(L2-L3),ABS(L5-L6)) - L1MAX = MIN(L2+L3,L5+L6) -C -C Check error condition 4. - IF(MOD(L1MAX-L1MIN+EPS,ONE).GE.EPS+EPS)THEN - IER=4 - CALL XERMSG('SLATEC','DRC6J','L1MAX-L1MIN not integer.',IER,1) - RETURN - ENDIF - IF(L1MIN.LT.L1MAX-EPS) GO TO 20 - IF(L1MIN.LT.L1MAX+EPS) GO TO 10 -C -C Check error condition 5. - IER=5 - CALL XERMSG('SLATEC','DRC6J','L1MIN greater than L1MAX.',IER,1) - RETURN -C -C -C This is reached in case that L1 can take only one value -C - 10 CONTINUE -C LSCALE = 0 - SIXCOF(1) = (-ONE) ** INT(L2+L3+L5+L6+EPS) / - 1 SQRT((L1MIN+L1MIN+ONE)*(L4+L4+ONE)) - RETURN -C -C -C This is reached in case that L1 can take more than one value. -C - 20 CONTINUE -C LSCALE = 0 - NFIN = INT(L1MAX-L1MIN+ONE+EPS) - IF(NDIM-NFIN) 21, 23, 23 -C -C Check error condition 6. - 21 IER = 6 - CALL XERMSG('SLATEC','DRC6J','Dimension of result array for 6j '// - + 'coefficients too small.',IER,1) - RETURN -C -C -C Start of forward recursion -C - 23 L1 = L1MIN - NEWFAC = 0.0D0 - C1 = 0.0D0 - SIXCOF(1) = SRTINY - SUM1 = (L1+L1+ONE) * TINY -C - LSTEP = 1 - 30 LSTEP = LSTEP + 1 - L1 = L1 + ONE -C - OLDFAC = NEWFAC - A1 = (L1+L2+L3+ONE) * (L1-L2+L3) * (L1+L2-L3) * (-L1+L2+L3+ONE) - A2 = (L1+L5+L6+ONE) * (L1-L5+L6) * (L1+L5-L6) * (-L1+L5+L6+ONE) - NEWFAC = SQRT(A1*A2) -C - IF(L1.LT.ONE+EPS) GO TO 40 -C - DV = TWO * ( L2*(L2+ONE)*L5*(L5+ONE) + L3*(L3+ONE)*L6*(L6+ONE) - 1 - L1*(L1-ONE)*L4*(L4+ONE) ) - 2 - (L2*(L2+ONE) + L3*(L3+ONE) - L1*(L1-ONE)) - 3 * (L5*(L5+ONE) + L6*(L6+ONE) - L1*(L1-ONE)) -C - DENOM = (L1-ONE) * NEWFAC -C - IF(LSTEP-2) 32, 32, 31 -C - 31 C1OLD = ABS(C1) - 32 C1 = - (L1+L1-ONE) * DV / DENOM - GO TO 50 -C -C If L1 = 1, (L1 - 1) has to be factored out of DV, hence -C - 40 C1 = - TWO * ( L2*(L2+ONE) + L5*(L5+ONE) - L4*(L4+ONE) ) - 1 / NEWFAC -C - 50 IF(LSTEP.GT.2) GO TO 60 -C -C If L1 = L1MIN + 1, the third term in recursion equation vanishes -C - X = SRTINY * C1 - SIXCOF(2) = X - SUM1 = SUM1 + TINY * (L1+L1+ONE) * C1 * C1 -C - IF(LSTEP.EQ.NFIN) GO TO 220 - GO TO 30 -C -C - 60 C2 = - L1 * OLDFAC / DENOM -C -C Recursion to the next 6j coefficient X -C - X = C1 * SIXCOF(LSTEP-1) + C2 * SIXCOF(LSTEP-2) - SIXCOF(LSTEP) = X -C - SUMFOR = SUM1 - SUM1 = SUM1 + (L1+L1+ONE) * X * X - IF(LSTEP.EQ.NFIN) GO TO 100 -C -C See if last unnormalized 6j coefficient exceeds SRHUGE -C - IF(ABS(X).LT.SRHUGE) GO TO 80 -C -C This is reached if last 6j coefficient larger than SRHUGE, -C so that the recursion series SIXCOF(1), ... ,SIXCOF(LSTEP) -C has to be rescaled to prevent overflow -C -C LSCALE = LSCALE + 1 - DO 70 I=1,LSTEP - IF(ABS(SIXCOF(I)).LT.SRTINY) SIXCOF(I) = ZERO - 70 SIXCOF(I) = SIXCOF(I) / SRHUGE - SUM1 = SUM1 / HUGE - SUMFOR = SUMFOR / HUGE - X = X / SRHUGE -C -C -C As long as the coefficient ABS(C1) is decreasing, the recursion -C proceeds towards increasing 6j values and, hence, is numerically -C stable. Once an increase of ABS(C1) is detected, the recursion -C direction is reversed. -C - 80 IF(C1OLD-ABS(C1)) 100, 100, 30 -C -C -C Keep three 6j coefficients around LMATCH for comparison later -C with backward recursion. -C - 100 CONTINUE -C LMATCH = L1 - 1 - X1 = X - X2 = SIXCOF(LSTEP-1) - X3 = SIXCOF(LSTEP-2) -C -C -C -C Starting backward recursion from L1MAX taking NSTEP2 steps, so -C that forward and backward recursion overlap at the three points -C L1 = LMATCH+1, LMATCH, LMATCH-1. -C - NFINP1 = NFIN + 1 - NFINP2 = NFIN + 2 - NFINP3 = NFIN + 3 - NSTEP2 = NFIN - LSTEP + 3 - L1 = L1MAX -C - SIXCOF(NFIN) = SRTINY - SUM2 = (L1+L1+ONE) * TINY -C -C - L1 = L1 + TWO - LSTEP = 1 - 110 LSTEP = LSTEP + 1 - L1 = L1 - ONE -C - OLDFAC = NEWFAC - A1S = (L1+L2+L3)*(L1-L2+L3-ONE)*(L1+L2-L3-ONE)*(-L1+L2+L3+TWO) - A2S = (L1+L5+L6)*(L1-L5+L6-ONE)*(L1+L5-L6-ONE)*(-L1+L5+L6+TWO) - NEWFAC = SQRT(A1S*A2S) -C - DV = TWO * ( L2*(L2+ONE)*L5*(L5+ONE) + L3*(L3+ONE)*L6*(L6+ONE) - 1 - L1*(L1-ONE)*L4*(L4+ONE) ) - 2 - (L2*(L2+ONE) + L3*(L3+ONE) - L1*(L1-ONE)) - 3 * (L5*(L5+ONE) + L6*(L6+ONE) - L1*(L1-ONE)) -C - DENOM = L1 * NEWFAC - C1 = - (L1+L1-ONE) * DV / DENOM - IF(LSTEP.GT.2) GO TO 120 -C -C If L1 = L1MAX + 1 the third term in the recursion equation vanishes -C - Y = SRTINY * C1 - SIXCOF(NFIN-1) = Y - IF(LSTEP.EQ.NSTEP2) GO TO 200 - SUMBAC = SUM2 - SUM2 = SUM2 + (L1+L1-THREE) * C1 * C1 * TINY - GO TO 110 -C -C - 120 C2 = - (L1-ONE) * OLDFAC / DENOM -C -C Recursion to the next 6j coefficient Y -C - Y = C1 * SIXCOF(NFINP2-LSTEP) + C2 * SIXCOF(NFINP3-LSTEP) - IF(LSTEP.EQ.NSTEP2) GO TO 200 - SIXCOF(NFINP1-LSTEP) = Y - SUMBAC = SUM2 - SUM2 = SUM2 + (L1+L1-THREE) * Y * Y -C -C See if last unnormalized 6j coefficient exceeds SRHUGE -C - IF(ABS(Y).LT.SRHUGE) GO TO 110 -C -C This is reached if last 6j coefficient larger than SRHUGE, -C so that the recursion series SIXCOF(NFIN), ... ,SIXCOF(NFIN-LSTEP+1) -C has to be rescaled to prevent overflow -C -C LSCALE = LSCALE + 1 - DO 130 I=1,LSTEP - INDEX = NFIN-I+1 - IF(ABS(SIXCOF(INDEX)).LT.SRTINY) SIXCOF(INDEX) = ZERO - 130 SIXCOF(INDEX) = SIXCOF(INDEX) / SRHUGE - SUMBAC = SUMBAC / HUGE - SUM2 = SUM2 / HUGE -C - GO TO 110 -C -C -C The forward recursion 6j coefficients X1, X2, X3 are to be matched -C with the corresponding backward recursion values Y1, Y2, Y3. -C - 200 Y3 = Y - Y2 = SIXCOF(NFINP2-LSTEP) - Y1 = SIXCOF(NFINP3-LSTEP) -C -C -C Determine now RATIO such that YI = RATIO * XI (I=1,2,3) holds -C with minimal error. -C - RATIO = ( X1*Y1 + X2*Y2 + X3*Y3 ) / ( X1*X1 + X2*X2 + X3*X3 ) - NLIM = NFIN - NSTEP2 + 1 -C - IF(ABS(RATIO).LT.ONE) GO TO 211 -C - DO 210 N=1,NLIM - 210 SIXCOF(N) = RATIO * SIXCOF(N) - SUMUNI = RATIO * RATIO * SUMFOR + SUMBAC - GO TO 230 -C - 211 NLIM = NLIM + 1 - RATIO = ONE / RATIO - DO 212 N=NLIM,NFIN - 212 SIXCOF(N) = RATIO * SIXCOF(N) - SUMUNI = SUMFOR + RATIO*RATIO*SUMBAC - GO TO 230 -C - 220 SUMUNI = SUM1 -C -C -C Normalize 6j coefficients -C - 230 CNORM = ONE / SQRT((L4+L4+ONE)*SUMUNI) -C -C Sign convention for last 6j coefficient determines overall phase -C - SIGN1 = SIGN(ONE,SIXCOF(NFIN)) - SIGN2 = (-ONE) ** INT(L2+L3+L5+L6+EPS) - IF(SIGN1*SIGN2) 235,235,236 - 235 CNORM = - CNORM -C - 236 IF(ABS(CNORM).LT.ONE) GO TO 250 -C - DO 240 N=1,NFIN - 240 SIXCOF(N) = CNORM * SIXCOF(N) - RETURN -C - 250 THRESH = TINY / ABS(CNORM) - DO 251 N=1,NFIN - IF(ABS(SIXCOF(N)).LT.THRESH) SIXCOF(N) = ZERO - 251 SIXCOF(N) = CNORM * SIXCOF(N) -C - RETURN - END diff --git a/slatec/drd.f b/slatec/drd.f deleted file mode 100644 index 7302e15..0000000 --- a/slatec/drd.f +++ /dev/null @@ -1,411 +0,0 @@ -*DECK DRD - DOUBLE PRECISION FUNCTION DRD (X, Y, Z, IER) -C***BEGIN PROLOGUE DRD -C***PURPOSE Compute the incomplete or complete elliptic integral of -C the 2nd kind. For X and Y nonnegative, X+Y and Z positive, -C DRD(X,Y,Z) = Integral from zero to infinity of -C -1/2 -1/2 -3/2 -C (3/2)(t+X) (t+Y) (t+Z) dt. -C If X or Y is zero, the integral is complete. -C***LIBRARY SLATEC -C***CATEGORY C14 -C***TYPE DOUBLE PRECISION (RD-S, DRD-D) -C***KEYWORDS COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM, -C INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE SECOND KIND, -C TAYLOR SERIES -C***AUTHOR Carlson, B. C. -C Ames Laboratory-DOE -C Iowa State University -C Ames, IA 50011 -C Notis, E. M. -C Ames Laboratory-DOE -C Iowa State University -C Ames, IA 50011 -C Pexton, R. L. -C Lawrence Livermore National Laboratory -C Livermore, CA 94550 -C***DESCRIPTION -C -C 1. DRD -C Evaluate an INCOMPLETE (or COMPLETE) ELLIPTIC INTEGRAL -C of the second kind -C Standard FORTRAN function routine -C Double precision version -C The routine calculates an approximation result to -C DRD(X,Y,Z) = Integral from zero to infinity of -C -1/2 -1/2 -3/2 -C (3/2)(t+X) (t+Y) (t+Z) dt, -C where X and Y are nonnegative, X + Y is positive, and Z is -C positive. If X or Y is zero, the integral is COMPLETE. -C The duplication theorem is iterated until the variables are -C nearly equal, and the function is then expanded in Taylor -C series to fifth order. -C -C 2. Calling Sequence -C -C DRD( X, Y, Z, IER ) -C -C Parameters On Entry -C Values assigned by the calling routine -C -C X - Double precision, nonnegative variable -C -C Y - Double precision, nonnegative variable -C -C X + Y is positive -C -C Z - Double precision, positive variable -C -C -C -C On Return (values assigned by the DRD routine) -C -C DRD - Double precision approximation to the integral -C -C -C IER - Integer -C -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C -C IER > 0 Abnormal termination of the routine -C -C -C X, Y, Z are unaltered. -C -C 3. Error Messages -C -C Value of IER assigned by the DRD routine -C -C Value assigned Error message printed -C IER = 1 MIN(X,Y) .LT. 0.0D0 -C = 2 MIN(X + Y, Z ) .LT. LOLIM -C = 3 MAX(X,Y,Z) .GT. UPLIM -C -C -C 4. Control Parameters -C -C Values of LOLIM, UPLIM, and ERRTOL are set by the -C routine. -C -C LOLIM and UPLIM determine the valid range of X, Y, and Z -C -C LOLIM - Lower limit of valid arguments -C -C Not less than 2 / (machine maximum) ** (2/3). -C -C UPLIM - Upper limit of valid arguments -C -C Not greater than (0.1D0 * ERRTOL / machine -C minimum) ** (2/3), where ERRTOL is described below. -C In the following table it is assumed that ERRTOL will -C never be chosen smaller than 1.0D-5. -C -C -C Acceptable values for: LOLIM UPLIM -C IBM 360/370 SERIES : 6.0D-51 1.0D+48 -C CDC 6000/7000 SERIES : 5.0D-215 2.0D+191 -C UNIVAC 1100 SERIES : 1.0D-205 2.0D+201 -C CRAY : 3.0D-1644 1.69D+1640 -C VAX 11 SERIES : 1.0D-25 4.5D+21 -C -C -C ERRTOL determines the accuracy of the answer -C -C The value assigned by the routine will result -C in solution precision within 1-2 decimals of -C "machine precision". -C -C ERRTOL Relative error due to truncation is less than -C 3 * ERRTOL ** 6 / (1-ERRTOL) ** 3/2. -C -C -C -C The accuracy of the computed approximation to the integral -C can be controlled by choosing the value of ERRTOL. -C Truncation of a Taylor series after terms of fifth order -C introduces an error less than the amount shown in the -C second column of the following table for each value of -C ERRTOL in the first column. In addition to the truncation -C error there will be round-off error, but in practice the -C total error from both sources is usually less than the -C amount given in the table. -C -C -C -C -C Sample choices: ERRTOL Relative truncation -C error less than -C 1.0D-3 4.0D-18 -C 3.0D-3 3.0D-15 -C 1.0D-2 4.0D-12 -C 3.0D-2 3.0D-9 -C 1.0D-1 4.0D-6 -C -C -C Decreasing ERRTOL by a factor of 10 yields six more -C decimal digits of accuracy at the expense of one or -C two more iterations of the duplication theorem. -C -C *Long Description: -C -C DRD Special Comments -C -C -C -C Check: DRD(X,Y,Z) + DRD(Y,Z,X) + DRD(Z,X,Y) -C = 3 / SQRT(X * Y * Z), where X, Y, and Z are positive. -C -C -C On Input: -C -C X, Y, and Z are the variables in the integral DRD(X,Y,Z). -C -C -C On Output: -C -C -C X, Y, Z are unaltered. -C -C -C -C ******************************************************** -C -C WARNING: Changes in the program may improve speed at the -C expense of robustness. -C -C -C -C ------------------------------------------------------------------- -C -C -C Special double precision functions via DRD and DRF -C -C -C Legendre form of ELLIPTIC INTEGRAL of 2nd kind -C -C ----------------------------------------- -C -C -C 2 2 2 -C E(PHI,K) = SIN(PHI) DRF(COS (PHI),1-K SIN (PHI),1) - -C -C 2 3 2 2 2 -C -(K/3) SIN (PHI) DRD(COS (PHI),1-K SIN (PHI),1) -C -C -C 2 2 2 -C E(K) = DRF(0,1-K ,1) - (K/3) DRD(0,1-K ,1) -C -C PI/2 2 2 1/2 -C = INT (1-K SIN (PHI) ) D PHI -C 0 -C -C Bulirsch form of ELLIPTIC INTEGRAL of 2nd kind -C -C ----------------------------------------- -C -C 2 2 2 -C EL2(X,KC,A,B) = AX DRF(1,1+KC X ,1+X ) + -C -C 3 2 2 2 -C +(1/3)(B-A) X DRD(1,1+KC X ,1+X ) -C -C -C -C -C Legendre form of alternative ELLIPTIC INTEGRAL -C of 2nd kind -C -C ----------------------------------------- -C -C -C -C Q 2 2 2 -1/2 -C D(Q,K) = INT SIN P (1-K SIN P) DP -C 0 -C -C -C -C 3 2 2 2 -C D(Q,K) = (1/3) (SIN Q) DRD(COS Q,1-K SIN Q,1) -C -C -C -C -C Lemniscate constant B -C -C ----------------------------------------- -C -C -C -C -C 1 2 4 -1/2 -C B = INT S (1-S ) DS -C 0 -C -C -C B = (1/3) DRD (0,2,1) -C -C -C Heuman's LAMBDA function -C -C ----------------------------------------- -C -C -C -C (PI/2) LAMBDA0(A,B) = -C -C 2 2 -C = SIN(B) (DRF(0,COS (A),1)-(1/3) SIN (A) * -C -C 2 2 2 2 -C *DRD(0,COS (A),1)) DRF(COS (B),1-COS (A) SIN (B),1) -C -C 2 3 2 -C -(1/3) COS (A) SIN (B) DRF(0,COS (A),1) * -C -C 2 2 2 -C *DRD(COS (B),1-COS (A) SIN (B),1) -C -C -C -C Jacobi ZETA function -C -C ----------------------------------------- -C -C 2 2 2 2 -C Z(B,K) = (K/3) SIN(B) DRF(COS (B),1-K SIN (B),1) -C -C -C 2 2 -C *DRD(0,1-K ,1)/DRF(0,1-K ,1) -C -C 2 3 2 2 2 -C -(K /3) SIN (B) DRD(COS (B),1-K SIN (B),1) -C -C -C --------------------------------------------------------------------- -C -C***REFERENCES B. C. Carlson and E. M. Notis, Algorithms for incomplete -C elliptic integrals, ACM Transactions on Mathematical -C Software 7, 3 (September 1981), pp. 398-403. -C B. C. Carlson, Computing elliptic integrals by -C duplication, Numerische Mathematik 33, (1979), -C pp. 1-16. -C B. C. Carlson, Elliptic integrals of the first kind, -C SIAM Journal of Mathematical Analysis 8, (1977), -C pp. 231-242. -C***ROUTINES CALLED D1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790801 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900510 Modify calls to XERMSG to put in standard form. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DRD - CHARACTER*16 XERN3, XERN4, XERN5, XERN6 - INTEGER IER - DOUBLE PRECISION LOLIM, TUPLIM, UPLIM, EPSLON, ERRTOL, D1MACH - DOUBLE PRECISION C1, C2, C3, C4, EA, EB, EC, ED, EF, LAMDA - DOUBLE PRECISION MU, POWER4, SIGMA, S1, S2, X, XN, XNDEV - DOUBLE PRECISION XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV, - * ZNROOT - LOGICAL FIRST - SAVE ERRTOL, LOLIM, UPLIM, C1, C2, C3, C4, FIRST - DATA FIRST /.TRUE./ -C -C***FIRST EXECUTABLE STATEMENT DRD - IF (FIRST) THEN - ERRTOL = (D1MACH(3)/3.0D0)**(1.0D0/6.0D0) - LOLIM = 2.0D0/(D1MACH(2))**(2.0D0/3.0D0) - TUPLIM = D1MACH(1)**(1.0E0/3.0E0) - TUPLIM = (0.10D0*ERRTOL)**(1.0E0/3.0E0)/TUPLIM - UPLIM = TUPLIM**2.0D0 -C - C1 = 3.0D0/14.0D0 - C2 = 1.0D0/6.0D0 - C3 = 9.0D0/22.0D0 - C4 = 3.0D0/26.0D0 - ENDIF - FIRST = .FALSE. -C -C CALL ERROR HANDLER IF NECESSARY. -C - DRD = 0.0D0 - IF( MIN(X,Y).LT.0.0D0) THEN - IER = 1 - WRITE (XERN3, '(1PE15.6)') X - WRITE (XERN4, '(1PE15.6)') Y - CALL XERMSG ('SLATEC', 'DRD', - * 'MIN(X,Y).LT.0 WHERE X = ' // XERN3 // ' AND Y = ' // - * XERN4, 1, 1) - RETURN - ENDIF -C - IF (MAX(X,Y,Z).GT.UPLIM) THEN - IER = 3 - WRITE (XERN3, '(1PE15.6)') X - WRITE (XERN4, '(1PE15.6)') Y - WRITE (XERN5, '(1PE15.6)') Z - WRITE (XERN6, '(1PE15.6)') UPLIM - CALL XERMSG ('SLATEC', 'DRD', - * 'MAX(X,Y,Z).GT.UPLIM WHERE X = ' // XERN3 // ' Y = ' // - * XERN4 // ' Z = ' // XERN5 // ' AND UPLIM = ' // XERN6, - * 3, 1) - RETURN - ENDIF -C - IF (MIN(X+Y,Z).LT.LOLIM) THEN - IER = 2 - WRITE (XERN3, '(1PE15.6)') X - WRITE (XERN4, '(1PE15.6)') Y - WRITE (XERN5, '(1PE15.6)') Z - WRITE (XERN6, '(1PE15.6)') LOLIM - CALL XERMSG ('SLATEC', 'DRD', - * 'MIN(X+Y,Z).LT.LOLIM WHERE X = ' // XERN3 // ' Y = ' // - * XERN4 // ' Z = ' // XERN5 // ' AND LOLIM = ' // XERN6, - * 2, 1) - RETURN - ENDIF -C - IER = 0 - XN = X - YN = Y - ZN = Z - SIGMA = 0.0D0 - POWER4 = 1.0D0 -C - 30 MU = (XN+YN+3.0D0*ZN)*0.20D0 - XNDEV = (MU-XN)/MU - YNDEV = (MU-YN)/MU - ZNDEV = (MU-ZN)/MU - EPSLON = MAX(ABS(XNDEV), ABS(YNDEV), ABS(ZNDEV)) - IF (EPSLON.LT.ERRTOL) GO TO 40 - XNROOT = SQRT(XN) - YNROOT = SQRT(YN) - ZNROOT = SQRT(ZN) - LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT - SIGMA = SIGMA + POWER4/(ZNROOT*(ZN+LAMDA)) - POWER4 = POWER4*0.250D0 - XN = (XN+LAMDA)*0.250D0 - YN = (YN+LAMDA)*0.250D0 - ZN = (ZN+LAMDA)*0.250D0 - GO TO 30 -C - 40 EA = XNDEV*YNDEV - EB = ZNDEV*ZNDEV - EC = EA - EB - ED = EA - 6.0D0*EB - EF = ED + EC + EC - S1 = ED*(-C1+0.250D0*C3*ED-1.50D0*C4*ZNDEV*EF) - S2 = ZNDEV*(C2*EF+ZNDEV*(-C3*EC+ZNDEV*C4*EA)) - DRD = 3.0D0*SIGMA + POWER4*(1.0D0+S1+S2)/(MU*SQRT(MU)) -C - RETURN - END diff --git a/slatec/dreadp.f b/slatec/dreadp.f deleted file mode 100644 index 1069346..0000000 --- a/slatec/dreadp.f +++ /dev/null @@ -1,44 +0,0 @@ -*DECK DREADP - SUBROUTINE DREADP (IPAGE, LIST, RLIST, LPAGE, IREC) -C***BEGIN PROLOGUE DREADP -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSPLP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (SREADP-S, DREADP-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C READ RECORD NUMBER IRECN, OF LENGTH LPG, FROM UNIT -C NUMBER IPAGEF INTO THE STORAGE ARRAY, LIST(*). -C READ RECORD IRECN+1, OF LENGTH LPG, FROM UNIT NUMBER -C IPAGEF INTO THE STORAGE ARRAY RLIST(*). -C -C TO CONVERT THIS PROGRAM UNIT TO DOUBLE PRECISION CHANGE -C /REAL (12 BLANKS)/ TO /DOUBLE PRECISION/. -C -C***SEE ALSO DSPLP -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890605 Corrected references to XERRWV. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C***END PROLOGUE DREADP - INTEGER LIST(*) - DOUBLE PRECISION RLIST(*) - CHARACTER*8 XERN1, XERN2 -C***FIRST EXECUTABLE STATEMENT DREADP - IPAGEF=IPAGE - LPG =LPAGE - IRECN=IREC - READ(IPAGEF,REC=IRECN,ERR=100)(LIST(I),I=1,LPG) - READ(IPAGEF,REC=IRECN+1,ERR=100)(RLIST(I),I=1,LPG) - RETURN -C - 100 WRITE (XERN1, '(I8)') LPG - WRITE (XERN2, '(I8)') IRECN - CALL XERMSG ('SLATEC', 'DREADP', 'IN DSPLP, LPG = ' // XERN1 // - * ' IRECN = ' // XERN2, 100, 1) - RETURN - END diff --git a/slatec/dreort.f b/slatec/dreort.f deleted file mode 100644 index 0fd28f7..0000000 --- a/slatec/dreort.f +++ /dev/null @@ -1,230 +0,0 @@ -*DECK DREORT - SUBROUTINE DREORT (NCOMP, Y, YP, YHP, NIV, W, S, P, IP, STOWA, - + IFLAG) -C***BEGIN PROLOGUE DREORT -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBVSUP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (REORT-S, DREORT-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C ********************************************************************** -C INPUT -C ********* -C Y, YP and YHP = homogeneous solution matrix and particular -C solution vector to be orthonormalized. -C IFLAG = 1 -- store YHP into Y and YP, test for -C reorthonormalization, orthonormalize if needed, -C save restart data. -C 2 -- store YHP into Y and YP, reorthonormalization, -C no restarts. -C (preset orthonormalization mode) -C 3 -- store YHP into Y and YP, reorthonormalization -C (when INHOMO=3 and X=XEND). -C ********************************************************************** -C OUTPUT -C ********* -C Y, YP = orthonormalized solutions. -C NIV = number of independent vectors returned from DMGSBV. -C IFLAG = 0 -- reorthonormalization was performed. -C 10 -- solution process must be restarted at the last -C orthonormalization point. -C 30 -- solutions are linearly dependent, problem must -C be restarted from the beginning. -C W, P, IP = orthonormalization information. -C ********************************************************************** -C -C***SEE ALSO DBVSUP -C***ROUTINES CALLED DDOT, DMGSBV, DSTOR1, DSTWAY -C***COMMON BLOCKS DML15T, DML18J, DML8SZ -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 890921 Realigned order of variables in certain COMMON blocks. -C (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DREORT -C - DOUBLE PRECISION DDOT - INTEGER ICOCO, IFLAG, IGOFX, IJK, INDPVT, INFO, INHOMO, INTEG, - 1 IP(*), ISTKOP, IVP, J, K, KK, KNSWOT, KOP, L, LOTJP, MFLAG, - 2 MNSWOT, MXNON, NCOMP, NCOMPD, NDISK, NEQ, NEQIVP, NFC, - 3 NFCC, NFCP, NIC, NIV, NOPG, NPS, NSWOT, NTAPE, NTP, NUMORT, - 4 NXPTS - DOUBLE PRECISION AE, C, DND, DNDT, DX, P(*), PWCND, PX, RE, S(*), - 1 SRP, STOWA(*), TND, TOL, VNORM, W(*), WCND, X, XBEG, XEND, - 2 XOP, XOT, XSAV, Y(NCOMP,*), YHP(NCOMP,*), YP(*), YPNM -C -C ****************************************************************** -C - COMMON /DML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMPD,NFC - COMMON /DML15T/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP, - 1 KNSWOT,KOP,LOTJP,MNSWOT,NSWOT - COMMON /DML18J/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ, - 1 INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,NFCC, - 2 ICOCO -C -C ********************************************************************** -C BEGIN BLOCK PERMITTING ...EXITS TO 210 -C BEGIN BLOCK PERMITTING ...EXITS TO 10 -C***FIRST EXECUTABLE STATEMENT DREORT - NFCP = NFC + 1 -C -C CHECK TO SEE IF ORTHONORMALIZATION TEST IS TO BE PERFORMED -C -C ...EXIT - IF (IFLAG .NE. 1) GO TO 10 - KNSWOT = KNSWOT + 1 -C ...EXIT - IF (KNSWOT .GE. NSWOT) GO TO 10 -C ......EXIT - IF ((XEND - X)*(X - XOT) .LT. 0.0D0) GO TO 210 - 10 CONTINUE - CALL DSTOR1(Y,YHP,YP,YHP(1,NFCP),1,0,0) -C -C *************************************************************** -C -C ORTHOGONALIZE THE HOMOGENEOUS SOLUTIONS Y -C AND PARTICULAR SOLUTION YP. -C - NIV = NFC - CALL DMGSBV(NCOMP,NFC,Y,NCOMP,NIV,MFLAG,S,P,IP,INHOMO,YP,W, - 1 WCND) -C -C ************************************************************ -C -C CHECK FOR LINEAR DEPENDENCE OF THE SOLUTIONS. -C - IF (MFLAG .EQ. 0) GO TO 50 -C BEGIN BLOCK PERMITTING ...EXITS TO 40 - IF (IFLAG .EQ. 2) GO TO 30 - IF (NSWOT .LE. 1 .AND. LOTJP .NE. 0) GO TO 20 -C -C RETRIEVE DATA FOR A RESTART AT LAST -C ORTHONORMALIZATION POINT -C - CALL DSTWAY(Y,YP,YHP,1,STOWA) - LOTJP = 1 - NSWOT = 1 - KNSWOT = 0 - MNSWOT = MNSWOT/2 - TND = TND + 1.0D0 - IFLAG = 10 -C .........EXIT - GO TO 40 - 20 CONTINUE - 30 CONTINUE - IFLAG = 30 - 40 CONTINUE - GO TO 200 - 50 CONTINUE -C BEGIN BLOCK PERMITTING ...EXITS TO 190 -C BEGIN BLOCK PERMITTING ...EXITS TO 110 -C -C ****************************************************** -C -C ...EXIT - IF (IFLAG .NE. 1) GO TO 110 -C -C TEST FOR ORTHONORMALIZATION -C -C ...EXIT - IF (WCND .LT. 50.0D0*TOL) GO TO 110 - DO 60 IJK = 1, NFCP -C ......EXIT - IF (S(IJK) .GT. 1.0D20) GO TO 110 - 60 CONTINUE -C -C USE LINEAR EXTRAPOLATION ON LOGARITHMIC VALUES OF THE -C NORM DECREMENTS TO DETERMINE NEXT ORTHONORMALIZATION -C CHECKPOINT. OTHER CONTROLS ON THE NUMBER OF STEPS TO -C THE NEXT CHECKPOINT ARE ADDED FOR SAFETY PURPOSES. -C - NSWOT = KNSWOT - KNSWOT = 0 - LOTJP = 0 - WCND = LOG10(WCND) - IF (WCND .GT. TND + 3.0D0) NSWOT = 2*NSWOT - IF (WCND .LT. PWCND) GO TO 70 - XOT = XEND - NSWOT = MIN(MNSWOT,NSWOT) - PWCND = WCND - PX = X - GO TO 100 - 70 CONTINUE - DX = X - PX - DND = PWCND - WCND - IF (DND .GE. 4) NSWOT = NSWOT/2 - DNDT = WCND - TND - IF (ABS(DX*DNDT) .LE. DND*ABS(XEND-X)) GO TO 80 - XOT = XEND - NSWOT = MIN(MNSWOT,NSWOT) - PWCND = WCND - PX = X - GO TO 90 - 80 CONTINUE - XOT = X + DX*DNDT/DND - NSWOT = MIN(MNSWOT,NSWOT) - PWCND = WCND - PX = X - 90 CONTINUE - 100 CONTINUE -C ......EXIT - GO TO 190 - 110 CONTINUE -C -C ********************************************************* -C -C ORTHONORMALIZATION NECESSARY SO WE NORMALIZE THE -C HOMOGENEOUS SOLUTION VECTORS AND CHANGE W ACCORDINGLY. -C - NSWOT = 1 - KNSWOT = 0 - LOTJP = 1 - KK = 1 - L = 1 - DO 150 K = 1, NFCC -C BEGIN BLOCK PERMITTING ...EXITS TO 140 - SRP = SQRT(P(KK)) - IF (INHOMO .EQ. 1) W(K) = SRP*W(K) - VNORM = 1.0D0/SRP - P(KK) = VNORM - KK = KK + NFCC + 1 - K - IF (NFC .EQ. NFCC) GO TO 120 -C ......EXIT - IF (L .NE. K/2) GO TO 140 - 120 CONTINUE - DO 130 J = 1, NCOMP - Y(J,L) = Y(J,L)*VNORM - 130 CONTINUE - L = L + 1 - 140 CONTINUE - 150 CONTINUE -C - IF (INHOMO .NE. 1 .OR. NPS .EQ. 1) GO TO 180 -C -C NORMALIZE THE PARTICULAR SOLUTION -C - YPNM = DDOT(NCOMP,YP,1,YP,1) - IF (YPNM .EQ. 0.0D0) YPNM = 1.0D0 - YPNM = SQRT(YPNM) - S(NFCP) = YPNM - DO 160 J = 1, NCOMP - YP(J) = YP(J)/YPNM - 160 CONTINUE - DO 170 J = 1, NFCC - W(J) = C*W(J) - 170 CONTINUE - 180 CONTINUE -C - IF (IFLAG .EQ. 1) CALL DSTWAY(Y,YP,YHP,0,STOWA) - IFLAG = 0 - 190 CONTINUE - 200 CONTINUE - 210 CONTINUE - RETURN - END diff --git a/slatec/drf.f b/slatec/drf.f deleted file mode 100644 index e513620..0000000 --- a/slatec/drf.f +++ /dev/null @@ -1,340 +0,0 @@ -*DECK DRF - DOUBLE PRECISION FUNCTION DRF (X, Y, Z, IER) -C***BEGIN PROLOGUE DRF -C***PURPOSE Compute the incomplete or complete elliptic integral of the -C 1st kind. For X, Y, and Z non-negative and at most one of -C them zero, RF(X,Y,Z) = Integral from zero to infinity of -C -1/2 -1/2 -1/2 -C (1/2)(t+X) (t+Y) (t+Z) dt. -C If X, Y or Z is zero, the integral is complete. -C***LIBRARY SLATEC -C***CATEGORY C14 -C***TYPE DOUBLE PRECISION (RF-S, DRF-D) -C***KEYWORDS COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM, -C INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE FIRST KIND, -C TAYLOR SERIES -C***AUTHOR Carlson, B. C. -C Ames Laboratory-DOE -C Iowa State University -C Ames, IA 50011 -C Notis, E. M. -C Ames Laboratory-DOE -C Iowa State University -C Ames, IA 50011 -C Pexton, R. L. -C Lawrence Livermore National Laboratory -C Livermore, CA 94550 -C***DESCRIPTION -C -C 1. DRF -C Evaluate an INCOMPLETE (or COMPLETE) ELLIPTIC INTEGRAL -C of the first kind -C Standard FORTRAN function routine -C Double precision version -C The routine calculates an approximation result to -C DRF(X,Y,Z) = Integral from zero to infinity of -C -C -1/2 -1/2 -1/2 -C (1/2)(t+X) (t+Y) (t+Z) dt, -C -C where X, Y, and Z are nonnegative and at most one of them -C is zero. If one of them is zero, the integral is COMPLETE. -C The duplication theorem is iterated until the variables are -C nearly equal, and the function is then expanded in Taylor -C series to fifth order. -C -C 2. Calling sequence -C DRF( X, Y, Z, IER ) -C -C Parameters On entry -C Values assigned by the calling routine -C -C X - Double precision, nonnegative variable -C -C Y - Double precision, nonnegative variable -C -C Z - Double precision, nonnegative variable -C -C -C -C On Return (values assigned by the DRF routine) -C -C DRF - Double precision approximation to the integral -C -C IER - Integer -C -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C -C IER > 0 Abnormal termination of the routine -C -C X, Y, Z are unaltered. -C -C -C 3. Error Messages -C -C -C Value of IER assigned by the DRF routine -C -C Value assigned Error Message Printed -C IER = 1 MIN(X,Y,Z) .LT. 0.0D0 -C = 2 MIN(X+Y,X+Z,Y+Z) .LT. LOLIM -C = 3 MAX(X,Y,Z) .GT. UPLIM -C -C -C -C 4. Control Parameters -C -C Values of LOLIM, UPLIM, and ERRTOL are set by the -C routine. -C -C LOLIM and UPLIM determine the valid range of X, Y and Z -C -C LOLIM - Lower limit of valid arguments -C -C Not less than 5 * (machine minimum). -C -C UPLIM - Upper limit of valid arguments -C -C Not greater than (machine maximum) / 5. -C -C -C Acceptable values for: LOLIM UPLIM -C IBM 360/370 SERIES : 3.0D-78 1.0D+75 -C CDC 6000/7000 SERIES : 1.0D-292 1.0D+321 -C UNIVAC 1100 SERIES : 1.0D-307 1.0D+307 -C CRAY : 2.3D-2466 1.09D+2465 -C VAX 11 SERIES : 1.5D-38 3.0D+37 -C -C -C -C ERRTOL determines the accuracy of the answer -C -C The value assigned by the routine will result -C in solution precision within 1-2 decimals of -C "machine precision". -C -C -C -C ERRTOL - Relative error due to truncation is less than -C ERRTOL ** 6 / (4 * (1-ERRTOL) . -C -C -C -C The accuracy of the computed approximation to the integral -C can be controlled by choosing the value of ERRTOL. -C Truncation of a Taylor series after terms of fifth order -C introduces an error less than the amount shown in the -C second column of the following table for each value of -C ERRTOL in the first column. In addition to the truncation -C error there will be round-off error, but in practice the -C total error from both sources is usually less than the -C amount given in the table. -C -C -C -C -C -C Sample choices: ERRTOL Relative Truncation -C error less than -C 1.0D-3 3.0D-19 -C 3.0D-3 2.0D-16 -C 1.0D-2 3.0D-13 -C 3.0D-2 2.0D-10 -C 1.0D-1 3.0D-7 -C -C -C Decreasing ERRTOL by a factor of 10 yields six more -C decimal digits of accuracy at the expense of one or -C two more iterations of the duplication theorem. -C -C *Long Description: -C -C DRF Special Comments -C -C -C -C Check by addition theorem: DRF(X,X+Z,X+W) + DRF(Y,Y+Z,Y+W) -C = DRF(0,Z,W), where X,Y,Z,W are positive and X * Y = Z * W. -C -C -C On Input: -C -C X, Y, and Z are the variables in the integral DRF(X,Y,Z). -C -C -C On Output: -C -C -C X, Y, Z are unaltered. -C -C -C -C ******************************************************** -C -C WARNING: Changes in the program may improve speed at the -C expense of robustness. -C -C -C -C Special double precision functions via DRF -C -C -C -C -C Legendre form of ELLIPTIC INTEGRAL of 1st kind -C -C ----------------------------------------- -C -C -C -C 2 2 2 -C F(PHI,K) = SIN(PHI) DRF(COS (PHI),1-K SIN (PHI),1) -C -C -C 2 -C K(K) = DRF(0,1-K ,1) -C -C -C PI/2 2 2 -1/2 -C = INT (1-K SIN (PHI) ) D PHI -C 0 -C -C -C -C Bulirsch form of ELLIPTIC INTEGRAL of 1st kind -C -C ----------------------------------------- -C -C -C 2 2 2 -C EL1(X,KC) = X DRF(1,1+KC X ,1+X ) -C -C -C Lemniscate constant A -C -C ----------------------------------------- -C -C -C 1 4 -1/2 -C A = INT (1-S ) DS = DRF(0,1,2) = DRF(0,2,1) -C 0 -C -C -C -C ------------------------------------------------------------------- -C -C***REFERENCES B. C. Carlson and E. M. Notis, Algorithms for incomplete -C elliptic integrals, ACM Transactions on Mathematical -C Software 7, 3 (September 1981), pp. 398-403. -C B. C. Carlson, Computing elliptic integrals by -C duplication, Numerische Mathematik 33, (1979), -C pp. 1-16. -C B. C. Carlson, Elliptic integrals of the first kind, -C SIAM Journal of Mathematical Analysis 8, (1977), -C pp. 231-242. -C***ROUTINES CALLED D1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891009 Removed unreferenced statement labels. (WRB) -C 891009 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900510 Changed calls to XERMSG to standard form, and some -C editorial changes. (RWC)) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DRF - CHARACTER*16 XERN3, XERN4, XERN5, XERN6 - INTEGER IER - DOUBLE PRECISION LOLIM, UPLIM, EPSLON, ERRTOL, D1MACH - DOUBLE PRECISION C1, C2, C3, E2, E3, LAMDA - DOUBLE PRECISION MU, S, X, XN, XNDEV - DOUBLE PRECISION XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV, - * ZNROOT - LOGICAL FIRST - SAVE ERRTOL,LOLIM,UPLIM,C1,C2,C3,FIRST - DATA FIRST /.TRUE./ -C -C***FIRST EXECUTABLE STATEMENT DRF -C - IF (FIRST) THEN - ERRTOL = (4.0D0*D1MACH(3))**(1.0D0/6.0D0) - LOLIM = 5.0D0 * D1MACH(1) - UPLIM = D1MACH(2)/5.0D0 -C - C1 = 1.0D0/24.0D0 - C2 = 3.0D0/44.0D0 - C3 = 1.0D0/14.0D0 - ENDIF - FIRST = .FALSE. -C -C CALL ERROR HANDLER IF NECESSARY. -C - DRF = 0.0D0 - IF (MIN(X,Y,Z).LT.0.0D0) THEN - IER = 1 - WRITE (XERN3, '(1PE15.6)') X - WRITE (XERN4, '(1PE15.6)') Y - WRITE (XERN5, '(1PE15.6)') Z - CALL XERMSG ('SLATEC', 'DRF', - * 'MIN(X,Y,Z).LT.0 WHERE X = ' // XERN3 // ' Y = ' // XERN4 // - * ' AND Z = ' // XERN5, 1, 1) - RETURN - ENDIF -C - IF (MAX(X,Y,Z).GT.UPLIM) THEN - IER = 3 - WRITE (XERN3, '(1PE15.6)') X - WRITE (XERN4, '(1PE15.6)') Y - WRITE (XERN5, '(1PE15.6)') Z - WRITE (XERN6, '(1PE15.6)') UPLIM - CALL XERMSG ('SLATEC', 'DRF', - * 'MAX(X,Y,Z).GT.UPLIM WHERE X = ' // XERN3 // ' Y = ' // - * XERN4 // ' Z = ' // XERN5 // ' AND UPLIM = ' // XERN6, 3, 1) - RETURN - ENDIF -C - IF (MIN(X+Y,X+Z,Y+Z).LT.LOLIM) THEN - IER = 2 - WRITE (XERN3, '(1PE15.6)') X - WRITE (XERN4, '(1PE15.6)') Y - WRITE (XERN5, '(1PE15.6)') Z - WRITE (XERN6, '(1PE15.6)') LOLIM - CALL XERMSG ('SLATEC', 'DRF', - * 'MIN(X+Y,X+Z,Y+Z).LT.LOLIM WHERE X = ' // XERN3 // - * ' Y = ' // XERN4 // ' Z = ' // XERN5 // ' AND LOLIM = ' // - * XERN6, 2, 1) - RETURN - ENDIF -C - IER = 0 - XN = X - YN = Y - ZN = Z -C - 30 MU = (XN+YN+ZN)/3.0D0 - XNDEV = 2.0D0 - (MU+XN)/MU - YNDEV = 2.0D0 - (MU+YN)/MU - ZNDEV = 2.0D0 - (MU+ZN)/MU - EPSLON = MAX(ABS(XNDEV),ABS(YNDEV),ABS(ZNDEV)) - IF (EPSLON.LT.ERRTOL) GO TO 40 - XNROOT = SQRT(XN) - YNROOT = SQRT(YN) - ZNROOT = SQRT(ZN) - LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT - XN = (XN+LAMDA)*0.250D0 - YN = (YN+LAMDA)*0.250D0 - ZN = (ZN+LAMDA)*0.250D0 - GO TO 30 -C - 40 E2 = XNDEV*YNDEV - ZNDEV*ZNDEV - E3 = XNDEV*YNDEV*ZNDEV - S = 1.0D0 + (C1*E2-0.10D0-C2*E3)*E2 + C3*E3 - DRF = S/SQRT(MU) -C - RETURN - END diff --git a/slatec/drj.f b/slatec/drj.f deleted file mode 100644 index 944f5b7..0000000 --- a/slatec/drj.f +++ /dev/null @@ -1,405 +0,0 @@ -*DECK DRJ - DOUBLE PRECISION FUNCTION DRJ (X, Y, Z, P, IER) -C***BEGIN PROLOGUE DRJ -C***PURPOSE Compute the incomplete or complete (X or Y or Z is zero) -C elliptic integral of the 3rd kind. For X, Y, and Z non- -C negative, at most one of them zero, and P positive, -C RJ(X,Y,Z,P) = Integral from zero to infinity of -C -1/2 -1/2 -1/2 -1 -C (3/2)(t+X) (t+Y) (t+Z) (t+P) dt. -C***LIBRARY SLATEC -C***CATEGORY C14 -C***TYPE DOUBLE PRECISION (RJ-S, DRJ-D) -C***KEYWORDS COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM, -C INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE THIRD KIND, -C TAYLOR SERIES -C***AUTHOR Carlson, B. C. -C Ames Laboratory-DOE -C Iowa State University -C Ames, IA 50011 -C Notis, E. M. -C Ames Laboratory-DOE -C Iowa State University -C Ames, IA 50011 -C Pexton, R. L. -C Lawrence Livermore National Laboratory -C Livermore, CA 94550 -C***DESCRIPTION -C -C 1. DRJ -C Standard FORTRAN function routine -C Double precision version -C The routine calculates an approximation result to -C DRJ(X,Y,Z,P) = Integral from zero to infinity of -C -C -1/2 -1/2 -1/2 -1 -C (3/2)(t+X) (t+Y) (t+Z) (t+P) dt, -C -C where X, Y, and Z are nonnegative, at most one of them is -C zero, and P is positive. If X or Y or Z is zero, the -C integral is COMPLETE. The duplication theorem is iterated -C until the variables are nearly equal, and the function is -C then expanded in Taylor series to fifth order. -C -C -C 2. Calling Sequence -C DRJ( X, Y, Z, P, IER ) -C -C Parameters on Entry -C Values assigned by the calling routine -C -C X - Double precision, nonnegative variable -C -C Y - Double precision, nonnegative variable -C -C Z - Double precision, nonnegative variable -C -C P - Double precision, positive variable -C -C -C On Return (values assigned by the DRJ routine) -C -C DRJ - Double precision approximation to the integral -C -C IER - Integer -C -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C -C IER > 0 Abnormal termination of the routine -C -C -C X, Y, Z, P are unaltered. -C -C -C 3. Error Messages -C -C Value of IER assigned by the DRJ routine -C -C Value assigned Error Message printed -C IER = 1 MIN(X,Y,Z) .LT. 0.0D0 -C = 2 MIN(X+Y,X+Z,Y+Z,P) .LT. LOLIM -C = 3 MAX(X,Y,Z,P) .GT. UPLIM -C -C -C -C 4. Control Parameters -C -C Values of LOLIM, UPLIM, and ERRTOL are set by the -C routine. -C -C -C LOLIM and UPLIM determine the valid range of X, Y, Z, and P -C -C LOLIM is not less than the cube root of the value -C of LOLIM used in the routine for DRC. -C -C UPLIM is not greater than 0.3 times the cube root of -C the value of UPLIM used in the routine for DRC. -C -C -C Acceptable values for: LOLIM UPLIM -C IBM 360/370 SERIES : 2.0D-26 3.0D+24 -C CDC 6000/7000 SERIES : 5.0D-98 3.0D+106 -C UNIVAC 1100 SERIES : 5.0D-103 6.0D+101 -C CRAY : 1.32D-822 1.4D+821 -C VAX 11 SERIES : 2.5D-13 9.0D+11 -C -C -C -C ERRTOL determines the accuracy of the answer -C -C the value assigned by the routine will result -C in solution precision within 1-2 decimals of -C "machine precision". -C -C -C -C -C Relative error due to truncation of the series for DRJ -C is less than 3 * ERRTOL ** 6 / (1 - ERRTOL) ** 3/2. -C -C -C -C The accuracy of the computed approximation to the integral -C can be controlled by choosing the value of ERRTOL. -C Truncation of a Taylor series after terms of fifth order -C introduces an error less than the amount shown in the -C second column of the following table for each value of -C ERRTOL in the first column. In addition to the truncation -C error there will be round-off error, but in practice the -C total error from both sources is usually less than the -C amount given in the table. -C -C -C -C Sample choices: ERRTOL Relative truncation -C error less than -C 1.0D-3 4.0D-18 -C 3.0D-3 3.0D-15 -C 1.0D-2 4.0D-12 -C 3.0D-2 3.0D-9 -C 1.0D-1 4.0D-6 -C -C Decreasing ERRTOL by a factor of 10 yields six more -C decimal digits of accuracy at the expense of one or -C two more iterations of the duplication theorem. -C -C *Long Description: -C -C DRJ Special Comments -C -C -C Check by addition theorem: DRJ(X,X+Z,X+W,X+P) -C + DRJ(Y,Y+Z,Y+W,Y+P) + (A-B) * DRJ(A,B,B,A) + 3.0D0 / SQRT(A) -C = DRJ(0,Z,W,P), where X,Y,Z,W,P are positive and X * Y -C = Z * W, A = P * P * (X+Y+Z+W), B = P * (P+X) * (P+Y), -C and B - A = P * (P-Z) * (P-W). The sum of the third and -C fourth terms on the left side is 3.0D0 * DRC(A,B). -C -C -C On Input: -C -C X, Y, Z, and P are the variables in the integral DRJ(X,Y,Z,P). -C -C -C On Output: -C -C -C X, Y, Z, P are unaltered. -C -C ******************************************************** -C -C WARNING: Changes in the program may improve speed at the -C expense of robustness. -C -C ------------------------------------------------------------------- -C -C -C Special double precision functions via DRJ and DRF -C -C -C Legendre form of ELLIPTIC INTEGRAL of 3rd kind -C ----------------------------------------- -C -C -C PHI 2 -1 -C P(PHI,K,N) = INT (1+N SIN (THETA) ) * -C 0 -C -C -C 2 2 -1/2 -C *(1-K SIN (THETA) ) D THETA -C -C -C 2 2 2 -C = SIN (PHI) DRF(COS (PHI), 1-K SIN (PHI),1) -C -C 3 2 2 2 -C -(N/3) SIN (PHI) DRJ(COS (PHI),1-K SIN (PHI), -C -C 2 -C 1,1+N SIN (PHI)) -C -C -C -C Bulirsch form of ELLIPTIC INTEGRAL of 3rd kind -C ----------------------------------------- -C -C -C 2 2 2 -C EL3(X,KC,P) = X DRF(1,1+KC X ,1+X ) + -C -C 3 2 2 2 2 -C +(1/3)(1-P) X DRJ(1,1+KC X ,1+X ,1+PX ) -C -C -C 2 -C CEL(KC,P,A,B) = A RF(0,KC ,1) + -C -C -C 2 -C +(1/3)(B-PA) DRJ(0,KC ,1,P) -C -C -C Heuman's LAMBDA function -C ----------------------------------------- -C -C -C 2 2 2 1/2 -C L(A,B,P) =(COS (A)SIN(B)COS(B)/(1-COS (A)SIN (B)) ) -C -C 2 2 2 -C *(SIN(P) DRF(COS (P),1-SIN (A) SIN (P),1) -C -C 2 3 2 2 -C +(SIN (A) SIN (P)/(3(1-COS (A) SIN (B)))) -C -C 2 2 2 -C *DRJ(COS (P),1-SIN (A) SIN (P),1,1- -C -C 2 2 2 2 -C -SIN (A) SIN (P)/(1-COS (A) SIN (B)))) -C -C -C -C (PI/2) LAMBDA0(A,B) =L(A,B,PI/2) = -C -C 2 2 2 -1/2 -C = COS (A) SIN(B) COS(B) (1-COS (A) SIN (B)) -C -C 2 2 2 -C *DRF(0,COS (A),1) + (1/3) SIN (A) COS (A) -C -C 2 2 -3/2 -C *SIN(B) COS(B) (1-COS (A) SIN (B)) -C -C 2 2 2 2 2 -C *DRJ(0,COS (A),1,COS (A) COS (B)/(1-COS (A) SIN (B))) -C -C -C Jacobi ZETA function -C ----------------------------------------- -C -C 2 2 2 1/2 -C Z(B,K) = (K/3) SIN(B) COS(B) (1-K SIN (B)) -C -C -C 2 2 2 2 -C *DRJ(0,1-K ,1,1-K SIN (B)) / DRF (0,1-K ,1) -C -C -C --------------------------------------------------------------------- -C -C***REFERENCES B. C. Carlson and E. M. Notis, Algorithms for incomplete -C elliptic integrals, ACM Transactions on Mathematical -C Software 7, 3 (September 1981), pp. 398-403. -C B. C. Carlson, Computing elliptic integrals by -C duplication, Numerische Mathematik 33, (1979), -C pp. 1-16. -C B. C. Carlson, Elliptic integrals of the first kind, -C SIAM Journal of Mathematical Analysis 8, (1977), -C pp. 231-242. -C***ROUTINES CALLED D1MACH, DRC, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891009 Removed unreferenced statement labels. (WRB) -C 891009 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900510 Changed calls to XERMSG to standard form, and some -C editorial changes. (RWC)). -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DRJ - INTEGER IER - CHARACTER*16 XERN3, XERN4, XERN5, XERN6, XERN7 - DOUBLE PRECISION ALFA, BETA, C1, C2, C3, C4, EA, EB, EC, E2, E3 - DOUBLE PRECISION LOLIM, UPLIM, EPSLON, ERRTOL, D1MACH - DOUBLE PRECISION LAMDA, MU, P, PN, PNDEV - DOUBLE PRECISION POWER4, DRC, SIGMA, S1, S2, S3, X, XN, XNDEV - DOUBLE PRECISION XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV, - * ZNROOT - LOGICAL FIRST - SAVE ERRTOL,LOLIM,UPLIM,C1,C2,C3,C4,FIRST - DATA FIRST /.TRUE./ -C -C***FIRST EXECUTABLE STATEMENT DRJ - IF (FIRST) THEN - ERRTOL = (D1MACH(3)/3.0D0)**(1.0D0/6.0D0) - LOLIM = (5.0D0 * D1MACH(1))**(1.0D0/3.0D0) - UPLIM = 0.30D0*( D1MACH(2) / 5.0D0)**(1.0D0/3.0D0) -C - C1 = 3.0D0/14.0D0 - C2 = 1.0D0/3.0D0 - C3 = 3.0D0/22.0D0 - C4 = 3.0D0/26.0D0 - ENDIF - FIRST = .FALSE. -C -C CALL ERROR HANDLER IF NECESSARY. -C - DRJ = 0.0D0 - IF (MIN(X,Y,Z).LT.0.0D0) THEN - IER = 1 - WRITE (XERN3, '(1PE15.6)') X - WRITE (XERN4, '(1PE15.6)') Y - WRITE (XERN5, '(1PE15.6)') Z - CALL XERMSG ('SLATEC', 'DRJ', - * 'MIN(X,Y,Z).LT.0 WHERE X = ' // XERN3 // ' Y = ' // XERN4 // - * ' AND Z = ' // XERN5, 1, 1) - RETURN - ENDIF -C - IF (MAX(X,Y,Z,P).GT.UPLIM) THEN - IER = 3 - WRITE (XERN3, '(1PE15.6)') X - WRITE (XERN4, '(1PE15.6)') Y - WRITE (XERN5, '(1PE15.6)') Z - WRITE (XERN6, '(1PE15.6)') P - WRITE (XERN7, '(1PE15.6)') UPLIM - CALL XERMSG ('SLATEC', 'DRJ', - * 'MAX(X,Y,Z,P).GT.UPLIM WHERE X = ' // XERN3 // ' Y = ' // - * XERN4 // ' Z = ' // XERN5 // ' P = ' // XERN6 // - * ' AND UPLIM = ' // XERN7, 3, 1) - RETURN - ENDIF -C - IF (MIN(X+Y,X+Z,Y+Z,P).LT.LOLIM) THEN - IER = 2 - WRITE (XERN3, '(1PE15.6)') X - WRITE (XERN4, '(1PE15.6)') Y - WRITE (XERN5, '(1PE15.6)') Z - WRITE (XERN6, '(1PE15.6)') P - WRITE (XERN7, '(1PE15.6)') LOLIM - CALL XERMSG ('SLATEC', 'RJ', - * 'MIN(X+Y,X+Z,Y+Z,P).LT.LOLIM WHERE X = ' // XERN3 // - * ' Y = ' // XERN4 // ' Z = ' // XERN5 // ' P = ' // XERN6 // - * ' AND LOLIM = ', 2, 1) - RETURN - ENDIF -C - IER = 0 - XN = X - YN = Y - ZN = Z - PN = P - SIGMA = 0.0D0 - POWER4 = 1.0D0 -C - 30 MU = (XN+YN+ZN+PN+PN)*0.20D0 - XNDEV = (MU-XN)/MU - YNDEV = (MU-YN)/MU - ZNDEV = (MU-ZN)/MU - PNDEV = (MU-PN)/MU - EPSLON = MAX(ABS(XNDEV), ABS(YNDEV), ABS(ZNDEV), ABS(PNDEV)) - IF (EPSLON.LT.ERRTOL) GO TO 40 - XNROOT = SQRT(XN) - YNROOT = SQRT(YN) - ZNROOT = SQRT(ZN) - LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT - ALFA = PN*(XNROOT+YNROOT+ZNROOT) + XNROOT*YNROOT*ZNROOT - ALFA = ALFA*ALFA - BETA = PN*(PN+LAMDA)*(PN+LAMDA) - SIGMA = SIGMA + POWER4*DRC(ALFA,BETA,IER) - POWER4 = POWER4*0.250D0 - XN = (XN+LAMDA)*0.250D0 - YN = (YN+LAMDA)*0.250D0 - ZN = (ZN+LAMDA)*0.250D0 - PN = (PN+LAMDA)*0.250D0 - GO TO 30 -C - 40 EA = XNDEV*(YNDEV+ZNDEV) + YNDEV*ZNDEV - EB = XNDEV*YNDEV*ZNDEV - EC = PNDEV*PNDEV - E2 = EA - 3.0D0*EC - E3 = EB + 2.0D0*PNDEV*(EA-EC) - S1 = 1.0D0 + E2*(-C1+0.750D0*C3*E2-1.50D0*C4*E3) - S2 = EB*(0.50D0*C2+PNDEV*(-C3-C3+PNDEV*C4)) - S3 = PNDEV*EA*(C2-PNDEV*C3) - C2*PNDEV*EC - DRJ = 3.0D0*SIGMA + POWER4*(S1+S2+S3)/(MU* SQRT(MU)) - RETURN - END diff --git a/slatec/drkfab.f b/slatec/drkfab.f deleted file mode 100644 index 09fec77..0000000 --- a/slatec/drkfab.f +++ /dev/null @@ -1,249 +0,0 @@ -*DECK DRKFAB - SUBROUTINE DRKFAB (NCOMP, XPTS, NXPTS, NFC, IFLAG, Z, MXNON, P, - + NTP, IP, YHP, NIV, U, V, W, S, STOWA, G, WORK, IWORK, NFCC) -C***BEGIN PROLOGUE DRKFAB -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBVSUP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (RKFAB-S, DRKFAB-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C ********************************************************************** -C -C Subroutine DRKFAB integrates the initial value equations using -C the variable-step Runge-Kutta-Fehlberg integration scheme or -C the variable-order Adams method and orthonormalization -C determined by a linear dependence test. -C -C ********************************************************************** -C -C***SEE ALSO DBVSUP -C***ROUTINES CALLED DBVDER, DDEABM, DDERKF, DREORT, DSTOR1 -C***COMMON BLOCKS DML15T, DML17B, DML18J, DML8SZ -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890921 Realigned order of variables in certain COMMON blocks. -C (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DRKFAB -C - INTEGER ICOCO, IDID, IFLAG, IGOFX, INDPVT, INFO, INHOMO, INTEG, - 1 IPAR, ISTKOP, IVP, J, JFLAG, JON, - 2 K1, K10, K11, K2, K3, K4, K5, K6, K7, K8, K9, KKKINT, - 3 KKKZPW, KNSWOT, KOD, KOP, KOPP, L1, L2, LLLINT, LOTJP, - 4 MNSWOT, MXNON, MXNOND, NCOMP, NCOMPD, NDISK, NEEDIW, NEEDW, - 5 NEQ, NEQIVP, NFC, NFCC, NFCCD, NFCD, NFCP1, NIC, NIV, NON, - 6 NOPG, NPS, NSWOT, NTAPE, NTP, NTPD, NUMORT, NXPTS, NXPTSD, - 7 IP(NFCC,*), IWORK(*) - DOUBLE PRECISION AE, C, G(*), P(NTP,*), PWCND, PX, RE, - 1 S(*), STOWA(*), TND, TOL, U(NCOMP,NFC,*), - 2 V(NCOMP,*), W(NFCC,*), WORK(*), X, XBEG, XEND, XOP, - 3 XOT, XPTS(*), XSAV, XXOP, YHP(NCOMP,*), Z(*) -C -C ****************************************************************** -C - COMMON /DML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMPD,NFCD - COMMON /DML15T/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP, - 1 KNSWOT,KOP,LOTJP,MNSWOT,NSWOT - COMMON /DML18J/ AE,RE,TOL,NXPTSD,NIC,NOPG,MXNOND,NDISK,NTAPE,NEQ, - 1 INDPVT,INTEG,NPS,NTPD,NEQIVP,NUMORT,NFCCD, - 2 ICOCO - COMMON /DML17B/ KKKZPW,NEEDW,NEEDIW,K1,K2,K3,K4,K5,K6,K7,K8,K9, - 1 K10,K11,L1,L2,KKKINT,LLLINT -C - EXTERNAL DBVDER -C -C ***************************************************************** -C INITIALIZATION OF COUNTERS AND VARIABLES. -C -C BEGIN BLOCK PERMITTING ...EXITS TO 220 -C BEGIN BLOCK PERMITTING ...EXITS TO 10 -C***FIRST EXECUTABLE STATEMENT DRKFAB - KOD = 1 - NON = 1 - X = XBEG - JON = 1 - INFO(1) = 0 - INFO(2) = 0 - INFO(3) = 1 - INFO(4) = 1 - WORK(1) = XEND -C ...EXIT - IF (NOPG .EQ. 0) GO TO 10 - INFO(3) = 0 - IF (X .EQ. Z(1)) JON = 2 - 10 CONTINUE - NFCP1 = NFC + 1 -C -C *************************************************************** -C *****BEGINNING OF INTEGRATION LOOP AT OUTPUT -C POINTS.****************** -C *************************************************************** -C - DO 210 KOPP = 2, NXPTS - KOP = KOPP - XOP = XPTS(KOP) - IF (NDISK .EQ. 0) KOD = KOP -C - 20 CONTINUE -C -C STEP BY STEP INTEGRATION LOOP BETWEEN OUTPUT POINTS. -C -C BEGIN BLOCK PERMITTING ...EXITS TO 190 -C BEGIN BLOCK PERMITTING ...EXITS TO 30 - XXOP = XOP -C ...EXIT - IF (NOPG .EQ. 0) GO TO 30 - IF (XEND .GT. XBEG .AND. XOP .GT. Z(JON)) - 1 XXOP = Z(JON) - IF (XEND .LT. XBEG .AND. XOP .LT. Z(JON)) - 1 XXOP = Z(JON) - 30 CONTINUE -C -C ****************************************************** - 40 CONTINUE -C BEGIN BLOCK PERMITTING ...EXITS TO 170 - GO TO (50,60), INTEG -C DDERKF INTEGRATOR -C - 50 CONTINUE - CALL DDERKF(DBVDER,NEQ,X,YHP,XXOP,INFO,RE,AE, - 1 IDID,WORK,KKKINT,IWORK,LLLINT,G, - 2 IPAR) - GO TO 70 -C DDEABM INTEGRATOR -C - 60 CONTINUE - CALL DDEABM(DBVDER,NEQ,X,YHP,XXOP,INFO,RE,AE, - 1 IDID,WORK,KKKINT,IWORK,LLLINT,G, - 2 IPAR) - 70 CONTINUE - IF (IDID .GE. 1) GO TO 80 - INFO(1) = 1 -C ......EXIT - IF (IDID .EQ. -1) GO TO 170 - IFLAG = 20 - IDID -C .....................EXIT - GO TO 220 - 80 CONTINUE -C -C ************************************************ -C GRAM-SCHMIDT ORTHOGONALIZATION TEST FOR -C ORTHONORMALIZATION (TEMPORARILY USING U AND -C V IN THE TEST) -C - IF (NOPG .EQ. 0) GO TO 100 - IF (XXOP .EQ. Z(JON)) GO TO 90 -C -C ****************************************** -C CONTINUE INTEGRATION IF WE ARE NOT AT -C AN OUTPUT POINT. -C -C ..................EXIT - IF (IDID .NE. 1) GO TO 200 -C .........EXIT - GO TO 170 - 90 CONTINUE - JFLAG = 2 - GO TO 110 - 100 CONTINUE - JFLAG = 1 - IF (INHOMO .EQ. 3 .AND. X .EQ. XEND) - 1 JFLAG = 3 - 110 CONTINUE -C - IF (NDISK .EQ. 0) NON = NUMORT + 1 - CALL DREORT(NCOMP,U(1,1,KOD),V(1,KOD),YHP,NIV, - 1 W(1,NON),S,P(1,NON),IP(1,NON),STOWA, - 2 JFLAG) -C - IF (JFLAG .NE. 30) GO TO 120 - IFLAG = 30 -C .....................EXIT - GO TO 220 - 120 CONTINUE -C - IF (JFLAG .NE. 10) GO TO 130 - XOP = XPTS(KOP) - IF (NDISK .EQ. 0) KOD = KOP -C ............EXIT - GO TO 190 - 130 CONTINUE -C - IF (JFLAG .EQ. 0) GO TO 140 -C -C ********************************************* -C CONTINUE INTEGRATION IF WE ARE NOT AT AN -C OUTPUT POINT. -C -C ...............EXIT - IF (IDID .NE. 1) GO TO 200 -C ......EXIT - GO TO 170 - 140 CONTINUE -C -C ************************************************ -C STORE ORTHONORMALIZED VECTORS INTO SOLUTION -C VECTORS. -C - IF (NUMORT .LT. MXNON) GO TO 150 - IF (X .EQ. XEND) GO TO 150 - IFLAG = 13 -C .....................EXIT - GO TO 220 - 150 CONTINUE -C - NUMORT = NUMORT + 1 - CALL DSTOR1(YHP,U(1,1,KOD),YHP(1,NFCP1), - 1 V(1,KOD),1,NDISK,NTAPE) -C -C ************************************************ -C STORE ORTHONORMALIZATION INFORMATION, -C INITIALIZE INTEGRATION FLAG, AND CONTINUE -C INTEGRATION TO THE NEXT ORTHONORMALIZATION -C POINT OR OUTPUT POINT. -C - Z(NUMORT) = X - IF (INHOMO .EQ. 1 .AND. NPS .EQ. 0) - 1 C = S(NFCP1)*C - IF (NDISK .EQ. 0) GO TO 160 - IF (INHOMO .EQ. 1) - 1 WRITE (NTAPE) (W(J,1), J = 1, NFCC) - WRITE (NTAPE) - 1 (IP(J,1), J = 1, NFCC), - 2 (P(J,1), J = 1, NTP) - 160 CONTINUE - INFO(1) = 0 - JON = JON + 1 -C ......EXIT - IF (NOPG .EQ. 1 .AND. X .NE. XOP) GO TO 180 -C -C ************************************************ -C CONTINUE INTEGRATION IF WE ARE NOT AT AN -C OUTPUT POINT. -C -C ............EXIT - IF (IDID .NE. 1) GO TO 200 - 170 CONTINUE - GO TO 40 - 180 CONTINUE - 190 CONTINUE - GO TO 20 - 200 CONTINUE -C -C STORAGE OF HOMOGENEOUS SOLUTIONS IN U AND THE PARTICULAR -C SOLUTION IN V AT THE OUTPUT POINTS. -C - CALL DSTOR1(U(1,1,KOD),YHP,V(1,KOD),YHP(1,NFCP1),0,NDISK, - 1 NTAPE) - 210 CONTINUE -C *************************************************************** -C *************************************************************** -C - IFLAG = 0 - 220 CONTINUE - RETURN - END diff --git a/slatec/drkfs.f b/slatec/drkfs.f deleted file mode 100644 index c3288c6..0000000 --- a/slatec/drkfs.f +++ /dev/null @@ -1,726 +0,0 @@ -*DECK DRKFS - SUBROUTINE DRKFS (DF, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, H, - + TOLFAC, YP, F1, F2, F3, F4, F5, YS, TOLD, DTSIGN, U26, RER, - + INIT, KSTEPS, KOP, IQUIT, STIFF, NONSTF, NTSTEP, NSTIFS, RPAR, - + IPAR) -C***BEGIN PROLOGUE DRKFS -C***SUBSIDIARY -C***PURPOSE Subsidiary to DDERKF -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (DERKFS-S, DRKFS-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C Fehlberg Fourth-Fifth Order Runge-Kutta Method -C ********************************************************************** -C -C DRKFS integrates a system of first order ordinary differential -C equations as described in the comments for DDERKF . -C -C The arrays YP,F1,F2,F3,F4,F5,and YS (of length at least NEQ) -C appear in the call list for variable dimensioning purposes. -C -C The variables H,TOLFAC,TOLD,DTSIGN,U26,RER,INIT,KSTEPS,KOP,IQUIT, -C STIFF,NONSTF,NTSTEP, and NSTIFS are used internally by the code -C and appear in the call list to eliminate local retention of -C variables between calls. Accordingly, these variables and the -C array YP should not be altered. -C Items of possible interest are -C H - An appropriate step size to be used for the next step -C TOLFAC - Factor of change in the tolerances -C YP - Derivative of solution vector at T -C KSTEPS - Counter on the number of steps attempted -C -C ********************************************************************** -C -C***SEE ALSO DDERKF -C***ROUTINES CALLED D1MACH, DFEHL, DHSTRT, DHVNRM, XERMSG -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891024 Changed references from DVNORM to DHVNRM. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls, change GOTOs to -C IF-THEN-ELSEs. (RWC) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DRKFS -C - INTEGER IDID, INFO, INIT, IPAR, IQUIT, K, KOP, KSTEPS, KTOL, - 1 MXKOP, MXSTEP, NATOLP, NEQ, NRTOLP, NSTIFS, NTSTEP - DOUBLE PRECISION A, ATOL, BIG, D1MACH, - 1 DT, DTSIGN, DHVNRM, DY, EE, EEOET, ES, ESTIFF, - 2 ESTTOL, ET, F1, F2, F3, F4, F5, H, HMIN, REMIN, RER, RPAR, - 3 RTOL, S, T, TOL, TOLD, TOLFAC, TOUT, U, U26, UTE, Y, YAVG, - 4 YP, YS - LOGICAL HFAILD,OUTPUT,STIFF,NONSTF - CHARACTER*8 XERN1 - CHARACTER*16 XERN3, XERN4 -C - DIMENSION Y(*),YP(*),F1(*),F2(*),F3(*),F4(*),F5(*), - 1 YS(*),INFO(15),RTOL(*),ATOL(*),RPAR(*),IPAR(*) -C - EXTERNAL DF -C -C .................................................................. -C -C A FIFTH ORDER METHOD WILL GENERALLY NOT BE CAPABLE OF DELIVERING -C ACCURACIES NEAR LIMITING PRECISION ON COMPUTERS WITH LONG -C WORDLENGTHS. TO PROTECT AGAINST LIMITING PRECISION DIFFICULTIES -C ARISING FROM UNREASONABLE ACCURACY REQUESTS, AN APPROPRIATE -C TOLERANCE THRESHOLD REMIN IS ASSIGNED FOR THIS METHOD. THIS -C VALUE SHOULD NOT BE CHANGED ACROSS DIFFERENT MACHINES. -C - SAVE REMIN, MXSTEP, MXKOP - DATA REMIN /1.0D-12/ -C -C .................................................................. -C -C THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE -C NUMBER OF STEPS ATTEMPTED. WHEN THIS EXCEEDS MXSTEP, THE -C COUNTER IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE -C EXCESSIVE WORK. -C - DATA MXSTEP /500/ -C -C .................................................................. -C -C INEFFICIENCY CAUSED BY TOO FREQUENT OUTPUT IS MONITORED BY -C COUNTING THE NUMBER OF STEP SIZES WHICH ARE SEVERELY SHORTENED -C DUE SOLELY TO THE CHOICE OF OUTPUT POINTS. WHEN THE NUMBER OF -C ABUSES EXCEED MXKOP, THE COUNTER IS RESET TO ZERO AND THE USER -C IS INFORMED ABOUT POSSIBLE MISUSE OF THE CODE. -C - DATA MXKOP /100/ -C -C .................................................................. -C -C***FIRST EXECUTABLE STATEMENT DRKFS - IF (INFO(1) .EQ. 0) THEN -C -C ON THE FIRST CALL , PERFORM INITIALIZATION -- -C DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY U BY CALLING THE -C FUNCTION ROUTINE D1MACH. THE USER MUST MAKE SURE THAT THE -C VALUES SET IN D1MACH ARE RELEVANT TO THE COMPUTER BEING USED. -C - U = D1MACH(4) -C -- SET ASSOCIATED MACHINE DEPENDENT PARAMETERS - U26 = 26.0D0*U - RER = 2.0D0*U + REMIN -C -- SET TERMINATION FLAG - IQUIT = 0 -C -- SET INITIALIZATION INDICATOR - INIT = 0 -C -- SET COUNTER FOR IMPACT OF OUTPUT POINTS - KOP = 0 -C -- SET COUNTER FOR ATTEMPTED STEPS - KSTEPS = 0 -C -- SET INDICATORS FOR STIFFNESS DETECTION - STIFF = .FALSE. - NONSTF = .FALSE. -C -- SET STEP COUNTERS FOR STIFFNESS DETECTION - NTSTEP = 0 - NSTIFS = 0 -C -- RESET INFO(1) FOR SUBSEQUENT CALLS - INFO(1) = 1 - ENDIF -C -C....................................................................... -C -C CHECK VALIDITY OF INPUT PARAMETERS ON EACH ENTRY -C - IF (INFO(1) .NE. 0 .AND. INFO(1) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(1) - CALL XERMSG ('SLATEC', 'DRKFS', - * 'IN DDERKF, INFO(1) MUST BE SET TO 0 ' // - * 'FOR THE START OF A NEW PROBLEM, AND MUST BE SET TO 1 ' // - * 'FOLLOWING AN INTERRUPTED TASK. YOU ARE ATTEMPTING TO ' // - * 'CONTINUE THE INTEGRATION ILLEGALLY BY CALLING THE CODE ' // - * 'WITH INFO(1) = ' // XERN1, 3, 1) - IDID = -33 - ENDIF -C - IF (INFO(2) .NE. 0 .AND. INFO(2) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(2) - CALL XERMSG ('SLATEC', 'DRKFS', - * 'IN DDERKF, INFO(2) MUST BE 0 OR 1 ' // - * 'INDICATING SCALAR AND VECTOR ERROR TOLERANCES, ' // - * 'RESPECTIVELY. YOU HAVE CALLED THE CODE WITH INFO(2) = ' // - * XERN1, 4, 1) - IDID = -33 - ENDIF -C - IF (INFO(3) .NE. 0 .AND. INFO(3) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(3) - CALL XERMSG ('SLATEC', 'DRKFS', - * 'IN DDERKF, INFO(3) MUST BE 0 OR 1 ' // - * 'INDICATING THE INTERVAL OR INTERMEDIATE-OUTPUT MODE OF ' // - * 'INTEGRATION, RESPECTIVELY. YOU HAVE CALLED THE CODE ' // - * 'WITH INFO(3) = ' // XERN1, 5, 1) - IDID = -33 - ENDIF -C - IF (NEQ .LT. 1) THEN - WRITE (XERN1, '(I8)') NEQ - CALL XERMSG ('SLATEC', 'DRKFS', - * 'IN DDERKF, THE NUMBER OF EQUATIONS ' // - * 'NEQ MUST BE A POSITIVE INTEGER. YOU HAVE CALLED THE ' // - * 'CODE WITH NEQ = ' // XERN1, 6, 1) - IDID = -33 - ENDIF -C - NRTOLP = 0 - NATOLP = 0 - DO 10 K=1,NEQ - IF (NRTOLP .EQ. 0 .AND. RTOL(K) .LT. 0.D0) THEN - WRITE (XERN1, '(I8)') K - WRITE (XERN3, '(1PE15.6)') RTOL(K) - CALL XERMSG ('SLATEC', 'DRKFS', - * 'IN DDERKF, THE RELATIVE ERROR ' // - * 'TOLERANCES RTOL MUST BE NON-NEGATIVE. YOU HAVE ' // - * 'CALLED THE CODE WITH RTOL(' // XERN1 // ') = ' // - * XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // - * 'NO FURTHER CHECKING OF RTOL COMPONENTS IS DONE.', 7, 1) - IDID = -33 - NRTOLP = 1 - ENDIF -C - IF (NATOLP .EQ. 0 .AND. ATOL(K) .LT. 0.D0) THEN - WRITE (XERN1, '(I8)') K - WRITE (XERN3, '(1PE15.6)') ATOL(K) - CALL XERMSG ('SLATEC', 'DRKFS', - * 'IN DDERKF, THE ABSOLUTE ERROR ' // - * 'TOLERANCES ATOL MUST BE NON-NEGATIVE. YOU HAVE ' // - * 'CALLED THE CODE WITH ATOL(' // XERN1 // ') = ' // - * XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // - * 'NO FURTHER CHECKING OF ATOL COMPONENTS IS DONE.', 8, 1) - IDID = -33 - NATOLP = 1 - ENDIF -C - IF (INFO(2) .EQ. 0) GO TO 20 - IF (NATOLP.GT.0 .AND. NRTOLP.GT.0) GO TO 20 - 10 CONTINUE -C -C -C CHECK SOME CONTINUATION POSSIBILITIES -C - 20 IF (INIT .NE. 0) THEN - IF (T .EQ. TOUT) THEN - WRITE (XERN3, '(1PE15.6)') T - CALL XERMSG ('SLATEC', 'DRKFS', - * 'IN DDERKF, YOU HAVE CALLED THE ' // - * 'CODE WITH T = TOUT = ' // XERN3 // '$$THIS IS NOT ' // - * 'ALLOWED ON CONTINUATION CALLS.', 9, 1) - IDID=-33 - ENDIF -C - IF (T .NE. TOLD) THEN - WRITE (XERN3, '(1PE15.6)') TOLD - WRITE (XERN4, '(1PE15.6)') T - CALL XERMSG ('SLATEC', 'DRKFS', - * 'IN DDERKF, YOU HAVE CHANGED THE ' // - * 'VALUE OF T FROM ' // XERN3 // ' TO ' // XERN4 // - * '$$THIS IS NOT ALLOWED ON CONTINUATION CALLS.', 10, 1) - IDID=-33 - ENDIF -C - IF (INIT .NE. 1) THEN - IF (DTSIGN*(TOUT-T) .LT. 0.D0) THEN - WRITE (XERN3, '(1PE15.6)') TOUT - CALL XERMSG ('SLATEC', 'DRKFS', - * 'IN DDERKF, BY CALLING THE CODE WITH TOUT = ' // - * XERN3 // ' YOU ARE ATTEMPTING TO CHANGE THE ' // - * 'DIRECTION OF INTEGRATION.$$THIS IS NOT ALLOWED ' // - * 'WITHOUT RESTARTING.', 11, 1) - IDID=-33 - ENDIF - ENDIF - ENDIF -C -C INVALID INPUT DETECTED -C - IF (IDID .EQ. (-33)) THEN - IF (IQUIT .NE. (-33)) THEN - IQUIT = -33 - GOTO 540 - ELSE - CALL XERMSG ('SLATEC', 'DRKFS', - * 'IN DDERKF, INVALID INPUT WAS ' // - * 'DETECTED ON SUCCESSIVE ENTRIES. IT IS IMPOSSIBLE ' // - * 'TO PROCEED BECAUSE YOU HAVE NOT CORRECTED THE ' // - * 'PROBLEM, SO EXECUTION IS BEING TERMINATED.', 12, 2) - RETURN - ENDIF - ENDIF -C -C ............................................................ -C -C RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND -C INTERPRETED AS ASKING FOR THE MOST ACCURATE SOLUTION -C POSSIBLE. IN THIS CASE, THE RELATIVE ERROR TOLERANCE -C RTOL IS RESET TO THE SMALLEST VALUE RER WHICH IS LIKELY -C TO BE REASONABLE FOR THIS METHOD AND MACHINE. -C - DO 190 K = 1, NEQ - IF (RTOL(K) + ATOL(K) .GT. 0.0D0) GO TO 180 - RTOL(K) = RER - IDID = -2 - 180 CONTINUE -C ...EXIT - IF (INFO(2) .EQ. 0) GO TO 200 - 190 CONTINUE - 200 CONTINUE -C - IF (IDID .NE. (-2)) GO TO 210 -C -C RTOL=ATOL=0 ON INPUT, SO RTOL WAS CHANGED TO A -C SMALL POSITIVE VALUE - TOLFAC = 1.0D0 - GO TO 530 - 210 CONTINUE -C -C BRANCH ON STATUS OF INITIALIZATION INDICATOR -C INIT=0 MEANS INITIAL DERIVATIVES AND -C STARTING STEP SIZE -C NOT YET COMPUTED -C INIT=1 MEANS STARTING STEP SIZE NOT YET -C COMPUTED INIT=2 MEANS NO FURTHER -C INITIALIZATION REQUIRED -C - IF (INIT .EQ. 0) GO TO 220 -C ......EXIT - IF (INIT .EQ. 1) GO TO 240 -C .........EXIT - GO TO 260 - 220 CONTINUE -C -C ................................................ -C -C MORE INITIALIZATION -- -C -- EVALUATE INITIAL -C DERIVATIVES -C - INIT = 1 - A = T - CALL DF(A,Y,YP,RPAR,IPAR) - IF (T .NE. TOUT) GO TO 230 -C -C INTERVAL MODE - IDID = 2 - T = TOUT - TOLD = T -C .....................EXIT - GO TO 560 - 230 CONTINUE - 240 CONTINUE -C -C -- SET SIGN OF INTEGRATION DIRECTION AND -C -- ESTIMATE STARTING STEP SIZE -C - INIT = 2 - DTSIGN = SIGN(1.0D0,TOUT-T) - U = D1MACH(4) - BIG = SQRT(D1MACH(2)) - UTE = U**0.375D0 - DY = UTE*DHVNRM(Y,NEQ) - IF (DY .EQ. 0.0D0) DY = UTE - KTOL = 1 - DO 250 K = 1, NEQ - IF (INFO(2) .EQ. 1) KTOL = K - TOL = RTOL(KTOL)*ABS(Y(K)) + ATOL(KTOL) - IF (TOL .EQ. 0.0D0) TOL = DY*RTOL(KTOL) - F1(K) = TOL - 250 CONTINUE -C - CALL DHSTRT(DF,NEQ,T,TOUT,Y,YP,F1,4,U,BIG,F2,F3,F4, - 1 F5,RPAR,IPAR,H) - 260 CONTINUE -C -C ...................................................... -C -C SET STEP SIZE FOR INTEGRATION IN THE DIRECTION -C FROM T TO TOUT AND SET OUTPUT POINT INDICATOR -C - DT = TOUT - T - H = SIGN(H,DT) - OUTPUT = .FALSE. -C -C TEST TO SEE IF DDERKF IS BEING SEVERELY IMPACTED BY -C TOO MANY OUTPUT POINTS -C - IF (ABS(H) .GE. 2.0D0*ABS(DT)) KOP = KOP + 1 - IF (KOP .LE. MXKOP) GO TO 270 -C -C UNNECESSARY FREQUENCY OF OUTPUT IS RESTRICTING -C THE STEP SIZE CHOICE - IDID = -5 - KOP = 0 - GO TO 510 - 270 CONTINUE -C - IF (ABS(DT) .GT. U26*ABS(T)) GO TO 290 -C -C IF TOO CLOSE TO OUTPUT POINT,EXTRAPOLATE AND -C RETURN -C - DO 280 K = 1, NEQ - Y(K) = Y(K) + DT*YP(K) - 280 CONTINUE - A = TOUT - CALL DF(A,Y,YP,RPAR,IPAR) - KSTEPS = KSTEPS + 1 - GO TO 500 - 290 CONTINUE -C BEGIN BLOCK PERMITTING ...EXITS TO 490 -C -C ********************************************* -C ********************************************* -C STEP BY STEP INTEGRATION -C - 300 CONTINUE -C BEGIN BLOCK PERMITTING ...EXITS TO 480 - HFAILD = .FALSE. -C -C TO PROTECT AGAINST IMPOSSIBLE ACCURACY -C REQUESTS, COMPUTE A TOLERANCE FACTOR -C BASED ON THE REQUESTED ERROR TOLERANCE -C AND A LEVEL OF ACCURACY ACHIEVABLE AT -C LIMITING PRECISION -C - TOLFAC = 0.0D0 - KTOL = 1 - DO 330 K = 1, NEQ - IF (INFO(2) .EQ. 1) KTOL = K - ET = RTOL(KTOL)*ABS(Y(K)) - 1 + ATOL(KTOL) - IF (ET .GT. 0.0D0) GO TO 310 - TOLFAC = MAX(TOLFAC, - 1 RER/RTOL(KTOL)) - GO TO 320 - 310 CONTINUE - TOLFAC = MAX(TOLFAC, - 1 ABS(Y(K)) - 2 *(RER/ET)) - 320 CONTINUE - 330 CONTINUE - IF (TOLFAC .LE. 1.0D0) GO TO 340 -C -C REQUESTED ERROR UNATTAINABLE DUE TO LIMITED -C PRECISION AVAILABLE - TOLFAC = 2.0D0*TOLFAC - IDID = -2 -C .....................EXIT - GO TO 520 - 340 CONTINUE -C -C SET SMALLEST ALLOWABLE STEP SIZE -C - HMIN = U26*ABS(T) -C -C ADJUST STEP SIZE IF NECESSARY TO HIT -C THE OUTPUT POINT -- LOOK AHEAD TWO -C STEPS TO AVOID DRASTIC CHANGES IN THE -C STEP SIZE AND THUS LESSEN THE IMPACT OF -C OUTPUT POINTS ON THE CODE. STRETCH THE -C STEP SIZE BY, AT MOST, AN AMOUNT EQUAL -C TO THE SAFETY FACTOR OF 9/10. -C - DT = TOUT - T - IF (ABS(DT) .GE. 2.0D0*ABS(H)) - 1 GO TO 370 - IF (ABS(DT) .GT. ABS(H)/0.9D0) - 1 GO TO 350 -C -C THE NEXT STEP, IF SUCCESSFUL, -C WILL COMPLETE THE INTEGRATION TO -C THE OUTPUT POINT -C - OUTPUT = .TRUE. - H = DT - GO TO 360 - 350 CONTINUE -C - H = 0.5D0*DT - 360 CONTINUE - 370 CONTINUE -C -C -C *************************************** -C CORE INTEGRATOR FOR TAKING A -C SINGLE STEP -C *************************************** -C TO AVOID PROBLEMS WITH ZERO -C CROSSINGS, RELATIVE ERROR IS -C MEASURED USING THE AVERAGE OF THE -C MAGNITUDES OF THE SOLUTION AT THE -C BEGINNING AND END OF A STEP. -C THE ERROR ESTIMATE FORMULA HAS -C BEEN GROUPED TO CONTROL LOSS OF -C SIGNIFICANCE. -C LOCAL ERROR ESTIMATES FOR A FIRST -C ORDER METHOD USING THE SAME -C STEP SIZE AS THE FEHLBERG METHOD -C ARE CALCULATED AS PART OF THE -C TEST FOR STIFFNESS. -C TO DISTINGUISH THE VARIOUS -C ARGUMENTS, H IS NOT PERMITTED -C TO BECOME SMALLER THAN 26 UNITS OF -C ROUNDOFF IN T. PRACTICAL LIMITS -C ON THE CHANGE IN THE STEP SIZE ARE -C ENFORCED TO SMOOTH THE STEP SIZE -C SELECTION PROCESS AND TO AVOID -C EXCESSIVE CHATTERING ON PROBLEMS -C HAVING DISCONTINUITIES. TO -C PREVENT UNNECESSARY FAILURES, THE -C CODE USES 9/10 THE STEP SIZE -C IT ESTIMATES WILL SUCCEED. -C AFTER A STEP FAILURE, THE STEP -C SIZE IS NOT ALLOWED TO INCREASE -C FOR THE NEXT ATTEMPTED STEP. THIS -C MAKES THE CODE MORE EFFICIENT ON -C PROBLEMS HAVING DISCONTINUITIES -C AND MORE EFFECTIVE IN GENERAL -C SINCE LOCAL EXTRAPOLATION IS BEING -C USED AND EXTRA CAUTION SEEMS -C WARRANTED. -C ....................................... -C -C MONITOR NUMBER OF STEPS ATTEMPTED -C - 380 CONTINUE - IF (KSTEPS .LE. MXSTEP) GO TO 390 -C -C A SIGNIFICANT AMOUNT OF WORK HAS -C BEEN EXPENDED - IDID = -1 - KSTEPS = 0 -C ........................EXIT - IF (.NOT.STIFF) GO TO 520 -C -C PROBLEM APPEARS TO BE STIFF - IDID = -4 - STIFF = .FALSE. - NONSTF = .FALSE. - NTSTEP = 0 - NSTIFS = 0 -C ........................EXIT - GO TO 520 - 390 CONTINUE -C -C ADVANCE AN APPROXIMATE SOLUTION OVER -C ONE STEP OF LENGTH H -C - CALL DFEHL(DF,NEQ,T,Y,H,YP,F1,F2,F3, - 1 F4,F5,YS,RPAR,IPAR) - KSTEPS = KSTEPS + 1 -C -C .................................... -C -C COMPUTE AND TEST ALLOWABLE -C TOLERANCES VERSUS LOCAL ERROR -C ESTIMATES. NOTE THAT RELATIVE -C ERROR IS MEASURED WITH RESPECT -C TO THE AVERAGE OF THE -C MAGNITUDES OF THE SOLUTION AT -C THE BEGINNING AND END OF THE -C STEP. LOCAL ERROR ESTIMATES -C FOR A SPECIAL FIRST ORDER -C METHOD ARE CALCULATED ONLY WHEN -C THE STIFFNESS DETECTION IS -C TURNED ON. -C - EEOET = 0.0D0 - ESTIFF = 0.0D0 - KTOL = 1 - DO 420 K = 1, NEQ - YAVG = 0.5D0 - 1 *(ABS(Y(K)) - 2 + ABS(YS(K))) - IF (INFO(2) .EQ. 1) KTOL = K - ET = RTOL(KTOL)*YAVG + ATOL(KTOL) - IF (ET .GT. 0.0D0) GO TO 400 -C -C PURE RELATIVE ERROR INAPPROPRIATE WHEN SOLUTION -C VANISHES - IDID = -3 -C ...........................EXIT - GO TO 520 - 400 CONTINUE -C - EE = ABS((-2090.0D0*YP(K) - 1 +(21970.0D0*F3(K) - 2 -15048.0D0*F4(K))) - 3 +(22528.0D0*F2(K) - 4 -27360.0D0*F5(K))) - IF (STIFF .OR. NONSTF) GO TO 410 - ES = ABS(H - 1 *(0.055455D0*YP(K) - 2 -0.035493D0*F1(K) - 3 -0.036571D0*F2(K) - 4 +0.023107D0*F3(K) - 5 -0.009515D0*F4(K) - 6 +0.003017D0*F5(K)) - 7 ) - ESTIFF = MAX(ESTIFF,ES/ET) - 410 CONTINUE - EEOET = MAX(EEOET,EE/ET) - 420 CONTINUE -C - ESTTOL = ABS(H)*EEOET/752400.0D0 -C -C ...EXIT - IF (ESTTOL .LE. 1.0D0) GO TO 440 -C -C .................................... -C -C UNSUCCESSFUL STEP -C - IF (ABS(H) .GT. HMIN) GO TO 430 -C -C REQUESTED ERROR UNATTAINABLE AT SMALLEST -C ALLOWABLE STEP SIZE - TOLFAC = 1.69D0*ESTTOL - IDID = -2 -C ........................EXIT - GO TO 520 - 430 CONTINUE -C -C REDUCE THE STEP SIZE , TRY AGAIN -C THE DECREASE IS LIMITED TO A FACTOR -C OF 1/10 -C - HFAILD = .TRUE. - OUTPUT = .FALSE. - S = 0.1D0 - IF (ESTTOL .LT. 59049.0D0) - 1 S = 0.9D0/ESTTOL**0.2D0 - H = SIGN(MAX(S*ABS(H),HMIN),H) - GO TO 380 - 440 CONTINUE -C -C ....................................... -C -C SUCCESSFUL STEP -C STORE SOLUTION AT T+H -C AND EVALUATE -C DERIVATIVES THERE -C - T = T + H - DO 450 K = 1, NEQ - Y(K) = YS(K) - 450 CONTINUE - A = T - CALL DF(A,Y,YP,RPAR,IPAR) -C -C CHOOSE NEXT STEP SIZE -C THE INCREASE IS LIMITED TO A FACTOR OF -C 5 IF STEP FAILURE HAS JUST OCCURRED, -C NEXT -C STEP SIZE IS NOT ALLOWED TO INCREASE -C - S = 5.0D0 - IF (ESTTOL .GT. 1.889568D-4) - 1 S = 0.9D0/ESTTOL**0.2D0 - IF (HFAILD) S = MIN(S,1.0D0) - H = SIGN(MAX(S*ABS(H),HMIN),H) -C -C ....................................... -C -C CHECK FOR STIFFNESS (IF NOT -C ALREADY DETECTED) -C -C IN A SEQUENCE OF 50 SUCCESSFUL -C STEPS BY THE FEHLBERG METHOD, 25 -C SUCCESSFUL STEPS BY THE FIRST -C ORDER METHOD INDICATES STIFFNESS -C AND TURNS THE TEST OFF. IF 26 -C FAILURES BY THE FIRST ORDER METHOD -C OCCUR, THE TEST IS TURNED OFF -C UNTIL THIS SEQUENCE OF 50 STEPS BY -C THE FEHLBERG METHOD IS COMPLETED. -C -C ...EXIT - IF (STIFF) GO TO 480 - NTSTEP = MOD(NTSTEP+1,50) - IF (NTSTEP .EQ. 1) NONSTF = .FALSE. -C ...EXIT - IF (NONSTF) GO TO 480 - IF (ESTIFF .GT. 1.0D0) GO TO 460 -C -C SUCCESSFUL STEP WITH FIRST ORDER -C METHOD - NSTIFS = NSTIFS + 1 -C TURN TEST OFF AFTER 25 INDICATIONS -C OF STIFFNESS - IF (NSTIFS .EQ. 25) STIFF = .TRUE. - GO TO 470 - 460 CONTINUE -C -C UNSUCCESSFUL STEP WITH FIRST ORDER -C METHOD - IF (NTSTEP - NSTIFS .LE. 25) GO TO 470 -C TURN STIFFNESS DETECTION OFF FOR THIS BLOCK OF -C FIFTY STEPS - NONSTF = .TRUE. -C RESET STIFF STEP COUNTER - NSTIFS = 0 - 470 CONTINUE - 480 CONTINUE -C -C ****************************************** -C END OF CORE INTEGRATOR -C ****************************************** -C -C -C SHOULD WE TAKE ANOTHER STEP -C -C ......EXIT - IF (OUTPUT) GO TO 490 - IF (INFO(3) .EQ. 0) GO TO 300 -C -C ********************************************* -C ********************************************* -C -C INTEGRATION SUCCESSFULLY COMPLETED -C -C ONE-STEP MODE - IDID = 1 - TOLD = T -C .....................EXIT - GO TO 560 - 490 CONTINUE - 500 CONTINUE -C -C INTERVAL MODE - IDID = 2 - T = TOUT - TOLD = T -C ...............EXIT - GO TO 560 - 510 CONTINUE - 520 CONTINUE - 530 CONTINUE - 540 CONTINUE -C -C INTEGRATION TASK INTERRUPTED -C - INFO(1) = -1 - TOLD = T -C ...EXIT - IF (IDID .NE. (-2)) GO TO 560 -C -C THE ERROR TOLERANCES ARE INCREASED TO VALUES -C WHICH ARE APPROPRIATE FOR CONTINUING - RTOL(1) = TOLFAC*RTOL(1) - ATOL(1) = TOLFAC*ATOL(1) -C ...EXIT - IF (INFO(2) .EQ. 0) GO TO 560 - DO 550 K = 2, NEQ - RTOL(K) = TOLFAC*RTOL(K) - ATOL(K) = TOLFAC*ATOL(K) - 550 CONTINUE - 560 CONTINUE - RETURN - END diff --git a/slatec/drlcal.f b/slatec/drlcal.f deleted file mode 100644 index 1430a24..0000000 --- a/slatec/drlcal.f +++ /dev/null @@ -1,116 +0,0 @@ -*DECK DRLCAL - SUBROUTINE DRLCAL (N, KMP, LL, MAXL, V, Q, RL, SNORMW, PROD, - + R0NRM) -C***BEGIN PROLOGUE DRLCAL -C***SUBSIDIARY -C***PURPOSE Internal routine for DGMRES. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (SRLCAL-S, DRLCAL-D) -C***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov -C Hindmarsh, Alan, (LLNL), alanh@llnl.gov -C Seager, Mark K., (LLNL), seager@llnl.gov -C Lawrence Livermore National Laboratory -C PO Box 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C***DESCRIPTION -C This routine calculates the scaled residual RL from the -C V(I)'s. -C *Usage: -C INTEGER N, KMP, LL, MAXL -C DOUBLE PRECISION V(N,LL), Q(2*MAXL), RL(N), SNORMW, PROD, R0NORM -C -C CALL DRLCAL(N, KMP, LL, MAXL, V, Q, RL, SNORMW, PROD, R0NRM) -C -C *Arguments: -C N :IN Integer -C The order of the matrix A, and the lengths -C of the vectors SR, SZ, R0 and Z. -C KMP :IN Integer -C The number of previous V vectors the new vector VNEW -C must be made orthogonal to. (KMP .le. MAXL) -C LL :IN Integer -C The current dimension of the Krylov subspace. -C MAXL :IN Integer -C The maximum dimension of the Krylov subspace. -C V :IN Double Precision V(N,LL) -C The N x LL array containing the orthogonal vectors -C V(*,1) to V(*,LL). -C Q :IN Double Precision Q(2*MAXL) -C A double precision array of length 2*MAXL containing the -C components of the Givens rotations used in the QR -C decomposition of HES. It is loaded in DHEQR and used in -C DHELS. -C RL :OUT Double Precision RL(N) -C The residual vector RL. This is either SB*(B-A*XL) if -C not preconditioning or preconditioning on the right, -C or SB*(M-inverse)*(B-A*XL) if preconditioning on the -C left. -C SNORMW :IN Double Precision -C Scale factor. -C PROD :IN Double Precision -C The product s1*s2*...*sl = the product of the sines of the -C Givens rotations used in the QR factorization of -C the Hessenberg matrix HES. -C R0NRM :IN Double Precision -C The scaled norm of initial residual R0. -C -C***SEE ALSO DGMRES -C***ROUTINES CALLED DCOPY, DSCAL -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910506 Made subsidiary to DGMRES. (FNF) -C 920511 Added complete declaration section. (WRB) -C***END PROLOGUE DRLCAL -C The following is for optimized compilation on LLNL/LTSS Crays. -CLLL. OPTIMIZE -C .. Scalar Arguments .. - DOUBLE PRECISION PROD, R0NRM, SNORMW - INTEGER KMP, LL, MAXL, N -C .. Array Arguments .. - DOUBLE PRECISION Q(*), RL(N), V(N,*) -C .. Local Scalars .. - DOUBLE PRECISION C, S, TEM - INTEGER I, I2, IP1, K, LLM1, LLP1 -C .. External Subroutines .. - EXTERNAL DCOPY, DSCAL -C***FIRST EXECUTABLE STATEMENT DRLCAL - IF (KMP .EQ. MAXL) THEN -C -C calculate RL. Start by copying V(*,1) into RL. -C - CALL DCOPY(N, V(1,1), 1, RL, 1) - LLM1 = LL - 1 - DO 20 I = 1,LLM1 - IP1 = I + 1 - I2 = I*2 - S = Q(I2) - C = Q(I2-1) - DO 10 K = 1,N - RL(K) = S*RL(K) + C*V(K,IP1) - 10 CONTINUE - 20 CONTINUE - S = Q(2*LL) - C = Q(2*LL-1)/SNORMW - LLP1 = LL + 1 - DO 30 K = 1,N - RL(K) = S*RL(K) + C*V(K,LLP1) - 30 CONTINUE - ENDIF -C -C When KMP < MAXL, RL vector already partially calculated. -C Scale RL by R0NRM*PROD to obtain the residual RL. -C - TEM = R0NRM*PROD - CALL DSCAL(N, TEM, RL, 1) - RETURN -C------------- LAST LINE OF DRLCAL FOLLOWS ---------------------------- - END diff --git a/slatec/drot.f b/slatec/drot.f deleted file mode 100644 index 8651e82..0000000 --- a/slatec/drot.f +++ /dev/null @@ -1,89 +0,0 @@ -*DECK DROT - SUBROUTINE DROT (N, DX, INCX, DY, INCY, DC, DS) -C***BEGIN PROLOGUE DROT -C***PURPOSE Apply a plane Givens rotation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A8 -C***TYPE DOUBLE PRECISION (SROT-S, DROT-D, CSROT-C) -C***KEYWORDS BLAS, GIVENS ROTATION, GIVENS TRANSFORMATION, -C LINEAR ALGEBRA, PLANE ROTATION, 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 DX double precision vector with N elements -C INCX storage spacing between elements of DX -C DY double precision vector with N elements -C INCY storage spacing between elements of DY -C DC D.P. element of rotation matrix -C DS D.P. element of rotation matrix -C -C --Output-- -C DX rotated vector DX (unchanged if N .LE. 0) -C DY rotated vector DY (unchanged if N .LE. 0) -C -C Multiply the 2 x 2 matrix ( DC DS) times the 2 x N matrix (DX**T) -C (-DS DC) (DY**T) -C where **T indicates transpose. The elements of DX are in -C DX(LX+I*INCX), I = 0 to N-1, where LX = 1 if INCX .GE. 0, else -C LX = 1+(1-N)*INCX, and similarly for DY using LY and 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 861211 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 DROT - DOUBLE PRECISION DX, DY, DC, DS, ZERO, ONE, W, Z - DIMENSION DX(*), DY(*) - SAVE ZERO, ONE - DATA ZERO, ONE /0.0D0, 1.0D0/ -C***FIRST EXECUTABLE STATEMENT DROT - IF (N .LE. 0 .OR. (DS .EQ. ZERO .AND. DC .EQ. ONE)) GO TO 40 - IF (.NOT. (INCX .EQ. INCY .AND. INCX .GT. 0)) GO TO 20 -C -C Code for equal and positive increments. -C - NSTEPS=INCX*N - DO 10 I = 1,NSTEPS,INCX - W=DX(I) - Z=DY(I) - DX(I)=DC*W+DS*Z - DY(I)=-DS*W+DC*Z - 10 CONTINUE - GO TO 40 -C -C Code for unequal or nonpositive increments. -C - 20 CONTINUE - KX=1 - KY=1 -C - IF (INCX .LT. 0) KX = 1-(N-1)*INCX - IF (INCY .LT. 0) KY = 1-(N-1)*INCY -C - DO 30 I = 1,N - W=DX(KX) - Z=DY(KY) - DX(KX)=DC*W+DS*Z - DY(KY)=-DS*W+DC*Z - KX=KX+INCX - KY=KY+INCY - 30 CONTINUE - 40 CONTINUE -C - RETURN - END diff --git a/slatec/drotg.f b/slatec/drotg.f deleted file mode 100644 index dd39690..0000000 --- a/slatec/drotg.f +++ /dev/null @@ -1,108 +0,0 @@ -*DECK DROTG - SUBROUTINE DROTG (DA, DB, DC, DS) -C***BEGIN PROLOGUE DROTG -C***PURPOSE Construct a plane Givens rotation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B10 -C***TYPE DOUBLE PRECISION (SROTG-S, DROTG-D, CROTG-C) -C***KEYWORDS BLAS, GIVENS ROTATION, GIVENS TRANSFORMATION, -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 DA double precision scalar -C DB double precision scalar -C -C --Output-- -C DA double precision result R -C DB double precision result Z -C DC double precision result -C DS double precision result -C -C Construct the Givens transformation -C -C ( DC DS ) -C G = ( ) , DC**2 + DS**2 = 1 , -C (-DS DC ) -C -C which zeros the second entry of the 2-vector (DA,DB)**T . -C -C The quantity R = (+/-)SQRT(DA**2 + DB**2) overwrites DA in -C storage. The value of DB is overwritten by a value Z which -C allows DC and DS to be recovered by the following algorithm. -C -C If Z=1 set DC=0.0 and DS=1.0 -C If ABS(Z) .LT. 1 set DC=SQRT(1-Z**2) and DS=Z -C If ABS(Z) .GT. 1 set DC=1/Z and DS=SQRT(1-DC**2) -C -C Normally, the subprogram DROT(N,DX,INCX,DY,INCY,DC,DS) will -C next be called to apply the transformation to a 2 by N matrix. -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 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 DROTG - DOUBLE PRECISION DA, DB, DC, DS, U, V, R -C***FIRST EXECUTABLE STATEMENT DROTG - IF (ABS(DA) .LE. ABS(DB)) GO TO 10 -C -C *** HERE ABS(DA) .GT. ABS(DB) *** -C - U = DA + DA - V = DB / U -C -C NOTE THAT U AND R HAVE THE SIGN OF DA -C - R = SQRT(0.25D0 + V**2) * U -C -C NOTE THAT DC IS POSITIVE -C - DC = DA / R - DS = V * (DC + DC) - DB = DS - DA = R - RETURN -C -C *** HERE ABS(DA) .LE. ABS(DB) *** -C - 10 IF (DB .EQ. 0.0D0) GO TO 20 - U = DB + DB - V = DA / U -C -C NOTE THAT U AND R HAVE THE SIGN OF DB -C (R IS IMMEDIATELY STORED IN DA) -C - DA = SQRT(0.25D0 + V**2) * U -C -C NOTE THAT DS IS POSITIVE -C - DS = DB / DA - DC = V * (DS + DS) - IF (DC .EQ. 0.0D0) GO TO 15 - DB = 1.0D0 / DC - RETURN - 15 DB = 1.0D0 - RETURN -C -C *** HERE DA = DB = 0.0 *** -C - 20 DC = 1.0D0 - DS = 0.0D0 - RETURN -C - END diff --git a/slatec/drotm.f b/slatec/drotm.f deleted file mode 100644 index 225198f..0000000 --- a/slatec/drotm.f +++ /dev/null @@ -1,150 +0,0 @@ -*DECK DROTM - SUBROUTINE DROTM (N, DX, INCX, DY, INCY, DPARAM) -C***BEGIN PROLOGUE DROTM -C***PURPOSE Apply a modified Givens transformation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A8 -C***TYPE DOUBLE PRECISION (SROTM-S, DROTM-D) -C***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, 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 DX double precision vector with N elements -C INCX storage spacing between elements of DX -C DY double precision vector with N elements -C INCY storage spacing between elements of DY -C DPARAM 5-element D.P. vector. DPARAM(1) is DFLAG described below. -C Locations 2-5 of SPARAM contain elements of the -C transformation matrix H described below. -C -C --Output-- -C DX rotated vector (unchanged if N .LE. 0) -C DY rotated vector (unchanged if N .LE. 0) -C -C Apply the modified Givens transformation, H, to the 2 by N matrix -C (DX**T) -C (DY**T) , where **T indicates transpose. The elements of DX are -C in DX(LX+I*INCX), I = 0 to N-1, where LX = 1 if INCX .GE. 0, else -C LX = 1+(1-N)*INCX, and similarly for DY using LY and INCY. -C -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 -C See DROTMG for a description of data storage in DPARAM. -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 861211 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 DROTM - DOUBLE PRECISION DFLAG, DH12, DH22, DX, TWO, Z, DH11, DH21, - 1 DPARAM, DY, W, ZERO - DIMENSION DX(*), DY(*), DPARAM(5) - SAVE ZERO, TWO - DATA ZERO, TWO /0.0D0, 2.0D0/ -C***FIRST EXECUTABLE STATEMENT DROTM - 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/slatec/drotmg.f b/slatec/drotmg.f deleted file mode 100644 index 540ee84..0000000 --- a/slatec/drotmg.f +++ /dev/null @@ -1,209 +0,0 @@ -*DECK DROTMG - SUBROUTINE DROTMG (DD1, DD2, DX1, DY1, DPARAM) -C***BEGIN PROLOGUE DROTMG -C***PURPOSE Construct a modified Givens transformation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B10 -C***TYPE DOUBLE PRECISION (SROTMG-S, DROTMG-D) -C***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, 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 DD1 double precision scalar -C DD2 double precision scalar -C DX1 double precision scalar -C DX2 double precision scalar -C DPARAM D.P. 5-vector. DPARAM(1)=DFLAG defined below. -C Locations 2-5 contain the rotation matrix. -C -C --Output-- -C DD1 changed to represent the effect of the transformation -C DD2 changed to represent the effect of the transformation -C DX1 changed to represent the effect of the transformation -C DX2 unchanged -C -C Construct the modified Givens transformation matrix H which zeros -C the second component of the 2-vector (SQRT(DD1)*DX1,SQRT(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 -C Locations 2-5 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***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 780301 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 920316 Prologue corrected. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DROTMG - DOUBLE PRECISION GAM, ONE, RGAMSQ, DD1, DD2, DH11, DH12, DH21, - 1 DH22, DPARAM, DP1, DP2, DQ1, DQ2, DU, DY1, ZERO, - 2 GAMSQ, DFLAG, DTEMP, DX1, TWO - DIMENSION DPARAM(5) - SAVE ZERO, ONE, TWO, GAM, GAMSQ, RGAMSQ - DATA ZERO, ONE, TWO /0.0D0, 1.0D0, 2.0D0/ - DATA GAM, GAMSQ, RGAMSQ /4096.0D0, 16777216.D0, 5.9604645D-8/ -C***FIRST EXECUTABLE STATEMENT DROTMG - 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. ABS(DQ1) .GT. ABS(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. ABS(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. ABS(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/slatec/drsco.f b/slatec/drsco.f deleted file mode 100644 index 220a84a..0000000 --- a/slatec/drsco.f +++ /dev/null @@ -1,47 +0,0 @@ -*DECK DRSCO - SUBROUTINE DRSCO (RSAV, ISAV) -C***BEGIN PROLOGUE DRSCO -C***SUBSIDIARY -C***PURPOSE Subsidiary to DDEBDF -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (RSCO-S, DRSCO-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C DRSCO transfers data from arrays to a common block within the -C integrator package DDEBDF. -C -C***SEE ALSO DDEBDF -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS DDEBD1 -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DRSCO -C----------------------------------------------------------------------- -C THIS ROUTINE RESTORES FROM RSAV AND ISAV THE CONTENTS OF COMMON -C BLOCK DDEBD1 , WHICH IS USED INTERNALLY IN THE DDEBDF -C PACKAGE. THIS PRESUMES THAT RSAV AND ISAV WERE LOADED BY MEANS -C OF SUBROUTINE DSVCO OR THE EQUIVALENT. -C----------------------------------------------------------------------- -C - INTEGER I, ILS, ISAV, LENILS, LENRLS - DOUBLE PRECISION RLS, RSAV - DIMENSION RSAV(*),ISAV(*) - SAVE LENRLS, LENILS - COMMON /DDEBD1/ RLS(218),ILS(33) - DATA LENRLS /218/, LENILS /33/ -C -C***FIRST EXECUTABLE STATEMENT DRSCO - DO 10 I = 1, LENRLS - RLS(I) = RSAV(I) - 10 CONTINUE - DO 20 I = 1, LENILS - ILS(I) = ISAV(I) - 20 CONTINUE - RETURN -C ----------------------- END OF SUBROUTINE DRSCO -C ----------------------- - END diff --git a/slatec/ds2lt.f b/slatec/ds2lt.f deleted file mode 100644 index 043d74a..0000000 --- a/slatec/ds2lt.f +++ /dev/null @@ -1,139 +0,0 @@ -*DECK DS2LT - SUBROUTINE DS2LT (N, NELT, IA, JA, A, ISYM, NEL, IEL, JEL, EL) -C***BEGIN PROLOGUE DS2LT -C***PURPOSE Lower Triangle Preconditioner SLAP Set Up. -C Routine to store the lower triangle of a matrix stored -C in the SLAP Column format. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE DOUBLE PRECISION (SS2LT-S, DS2LT-D) -C***KEYWORDS LINEAR SYSTEM, LOWER TRIANGLE, SLAP SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM -C INTEGER NEL, IEL(NEL), JEL(NEL) -C DOUBLE PRECISION A(NELT), EL(NEL) -C -C CALL DS2LT( N, NELT, IA, JA, A, ISYM, NEL, IEL, JEL, EL ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C NELT :IN Integer. -C Number of non-zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Double Precision A(NELT). -C These arrays should hold the matrix A in the SLAP Column -C format. See "Description", below. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the lower -C triangle of the matrix is stored. -C NEL :OUT Integer. -C Number of non-zeros in the lower triangle of A. Also -C corresponds to the length of the IEL, JEL, EL arrays. -C IEL :OUT Integer IEL(NEL). -C JEL :OUT Integer JEL(NEL). -C EL :OUT Double Precision EL(NEL). -C IEL, JEL, EL contain the lower triangle of the A matrix -C stored in SLAP Column format. See "Description", below, -C for more details bout the SLAP Column format. -C -C *Description -C =================== S L A P Column format ================== -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE DS2LT -C .. Scalar Arguments .. - INTEGER ISYM, N, NEL, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), EL(NELT) - INTEGER IA(NELT), IEL(NEL), JA(NELT), JEL(NEL) -C .. Local Scalars .. - INTEGER I, ICOL, J, JBGN, JEND -C***FIRST EXECUTABLE STATEMENT DS2LT - IF( ISYM.EQ.0 ) THEN -C -C The matrix is stored non-symmetricly. Pick out the lower -C triangle. -C - NEL = 0 - DO 20 ICOL = 1, N - JEL(ICOL) = NEL+1 - JBGN = JA(ICOL) - JEND = JA(ICOL+1)-1 -CVD$ NOVECTOR - DO 10 J = JBGN, JEND - IF( IA(J).GE.ICOL ) THEN - NEL = NEL + 1 - IEL(NEL) = IA(J) - EL(NEL) = A(J) - ENDIF - 10 CONTINUE - 20 CONTINUE - JEL(N+1) = NEL+1 - ELSE -C -C The matrix is symmetric and only the lower triangle is -C stored. Copy it to IEL, JEL, EL. -C - NEL = NELT - DO 30 I = 1, NELT - IEL(I) = IA(I) - EL(I) = A(I) - 30 CONTINUE - DO 40 I = 1, N+1 - JEL(I) = JA(I) - 40 CONTINUE - ENDIF - RETURN -C------------- LAST LINE OF DS2LT FOLLOWS ---------------------------- - END diff --git a/slatec/ds2y.f b/slatec/ds2y.f deleted file mode 100644 index 0c832f7..0000000 --- a/slatec/ds2y.f +++ /dev/null @@ -1,209 +0,0 @@ -*DECK DS2Y - SUBROUTINE DS2Y (N, NELT, IA, JA, A, ISYM) -C***BEGIN PROLOGUE DS2Y -C***PURPOSE SLAP Triad to SLAP Column Format Converter. -C Routine to convert from the SLAP Triad to SLAP Column -C format. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D1B9 -C***TYPE DOUBLE PRECISION (SS2Y-S, DS2Y-D) -C***KEYWORDS LINEAR SYSTEM, SLAP SPARSE -C***AUTHOR Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM -C DOUBLE PRECISION A(NELT) -C -C CALL DS2Y( N, NELT, IA, JA, A, ISYM ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C NELT :IN Integer. -C Number of non-zeros stored in A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Double Precision A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is used, this format is -C translated to the SLAP Column format by this routine. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the lower -C triangle of the matrix is stored. -C -C *Description: -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures. If the SLAP Triad format is give -C as input then this routine transforms it into SLAP Column -C format. The way this routine tells which format is given as -C input is to look at JA(N+1). If JA(N+1) = NELT+1 then we -C have the SLAP Column format. If that equality does not hold -C then it is assumed that the IA, JA, A arrays contain the -C SLAP Triad format. -C -C =================== S L A P Triad format =================== -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C***REFERENCES (NONE) -C***ROUTINES CALLED QS2I1D -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Corrected C***FIRST EXECUTABLE STATEMENT line. (FNF) -C 920511 Added complete declaration section. (WRB) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE DS2Y -C .. Scalar Arguments .. - INTEGER ISYM, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT) - INTEGER IA(NELT), JA(NELT) -C .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, IBGN, ICOL, IEND, ITEMP, J -C .. External Subroutines .. - EXTERNAL QS2I1D -C***FIRST EXECUTABLE STATEMENT DS2Y -C -C Check to see if the (IA,JA,A) arrays are in SLAP Column -C format. If it's not then transform from SLAP Triad. -C - IF( JA(N+1).EQ.NELT+1 ) RETURN -C -C Sort into ascending order by COLUMN (on the ja array). -C This will line up the columns. -C - CALL QS2I1D( JA, IA, A, NELT, 1 ) -C -C Loop over each column to see where the column indices change -C in the column index array ja. This marks the beginning of the -C next column. -C -CVD$R NOVECTOR - JA(1) = 1 - DO 20 ICOL = 1, N-1 - DO 10 J = JA(ICOL)+1, NELT - IF( JA(J).NE.ICOL ) THEN - JA(ICOL+1) = J - GOTO 20 - ENDIF - 10 CONTINUE - 20 CONTINUE - JA(N+1) = NELT+1 -C -C Mark the n+2 element so that future calls to a SLAP routine -C utilizing the YSMP-Column storage format will be able to tell. -C - JA(N+2) = 0 -C -C Now loop through the IA array making sure that the diagonal -C matrix element appears first in the column. Then sort the -C rest of the column in ascending order. -C - DO 70 ICOL = 1, N - IBGN = JA(ICOL) - IEND = JA(ICOL+1)-1 - DO 30 I = IBGN, IEND - IF( IA(I).EQ.ICOL ) THEN -C -C Swap the diagonal element with the first element in the -C column. -C - ITEMP = IA(I) - IA(I) = IA(IBGN) - IA(IBGN) = ITEMP - TEMP = A(I) - A(I) = A(IBGN) - A(IBGN) = TEMP - GOTO 40 - ENDIF - 30 CONTINUE - 40 IBGN = IBGN + 1 - IF( IBGN.LT.IEND ) THEN - DO 60 I = IBGN, IEND - DO 50 J = I+1, IEND - IF( IA(I).GT.IA(J) ) THEN - ITEMP = IA(I) - IA(I) = IA(J) - IA(J) = ITEMP - TEMP = A(I) - A(I) = A(J) - A(J) = TEMP - ENDIF - 50 CONTINUE - 60 CONTINUE - ENDIF - 70 CONTINUE - RETURN -C------------- LAST LINE OF DS2Y FOLLOWS ---------------------------- - END diff --git a/slatec/dsbmv.f b/slatec/dsbmv.f deleted file mode 100644 index c3a4b3d..0000000 --- a/slatec/dsbmv.f +++ /dev/null @@ -1,310 +0,0 @@ -*DECK DSBMV - SUBROUTINE DSBMV (UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, - $ INCY) -C***BEGIN PROLOGUE DSBMV -C***PURPOSE Perform the matrix-vector operation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE DOUBLE PRECISION (SSBMV-S, DSBMV-D, CSBMV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C DSBMV performs the matrix-vector operation -C -C y := alpha*A*x + beta*y, -C -C where alpha and beta are scalars, x and y are n element vectors and -C A is an n by n symmetric band matrix, with k super-diagonals. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the band matrix A is being supplied as -C follows: -C -C UPLO = 'U' or 'u' The upper triangular part of A is -C being supplied. -C -C UPLO = 'L' or 'l' The lower triangular part of A is -C being supplied. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C K - INTEGER. -C On entry, K specifies the number of super-diagonals of the -C matrix A. K must satisfy 0 .le. K. -C Unchanged on exit. -C -C ALPHA - DOUBLE PRECISION. -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -C Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -C by n part of the array A must contain the upper triangular -C band part of the symmetric matrix, supplied column by -C column, with the leading diagonal of the matrix in row -C ( k + 1 ) of the array, the first super-diagonal starting at -C position 2 in row k, and so on. The top left k by k triangle -C of the array A is not referenced. -C The following program segment will transfer the upper -C triangular part of a symmetric band matrix from conventional -C full matrix storage to band storage: -C -C DO 20, J = 1, N -C M = K + 1 - J -C DO 10, I = MAX( 1, J - K ), J -C A( M + I, J ) = matrix( I, J ) -C 10 CONTINUE -C 20 CONTINUE -C -C Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -C by n part of the array A must contain the lower triangular -C band part of the symmetric matrix, supplied column by -C column, with the leading diagonal of the matrix in row 1 of -C the array, the first sub-diagonal starting at position 1 in -C row 2, and so on. The bottom right k by k triangle of the -C array A is not referenced. -C The following program segment will transfer the lower -C triangular part of a symmetric band matrix from conventional -C full matrix storage to band storage: -C -C DO 20, J = 1, N -C M = 1 - J -C DO 10, I = J, MIN( N, J + K ) -C A( M + I, J ) = matrix( I, J ) -C 10 CONTINUE -C 20 CONTINUE -C -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C ( k + 1 ). -C Unchanged on exit. -C -C X - DOUBLE PRECISION array of DIMENSION at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the -C vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C BETA - DOUBLE PRECISION. -C On entry, BETA specifies the scalar beta. -C Unchanged on exit. -C -C Y - DOUBLE PRECISION array of DIMENSION at least -C ( 1 + ( n - 1 )*abs( INCY ) ). -C Before entry, the incremented array Y must contain the -C vector y. On exit, Y is overwritten by the updated vector y. -C -C INCY - INTEGER. -C On entry, INCY specifies the increment for the elements of -C Y. INCY must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE DSBMV -C .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA - INTEGER INCX, INCY, K, LDA, N - CHARACTER*1 UPLO -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -C .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -C .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C***FIRST EXECUTABLE STATEMENT DSBMV -C -C Test the input parameters. -C - 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 -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C Set up the start points in X and Y. -C - 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 -C -C Start the operations. In this version the elements of the array A -C are accessed sequentially with one pass through A. -C -C First form y := beta*y. -C - 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 -C -C Form y when upper triangle of A is stored. -C - 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 -C -C Form y when lower triangle of A is stored. -C - 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 -C - RETURN -C -C End of DSBMV . -C - END diff --git a/slatec/dscal.f b/slatec/dscal.f deleted file mode 100644 index 0c204c9..0000000 --- a/slatec/dscal.f +++ /dev/null @@ -1,80 +0,0 @@ -*DECK DSCAL - SUBROUTINE DSCAL (N, DA, DX, INCX) -C***BEGIN PROLOGUE DSCAL -C***PURPOSE Multiply a vector by a constant. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A6 -C***TYPE DOUBLE PRECISION (SSCAL-S, DSCAL-D, CSCAL-C) -C***KEYWORDS BLAS, LINEAR ALGEBRA, SCALE, 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 DA double precision scale factor -C DX double precision vector with N elements -C INCX storage spacing between elements of DX -C -C --Output-- -C DX double precision result (unchanged if N.LE.0) -C -C Replace double precision DX by double precision DA*DX. -C For I = 0 to N-1, replace DX(IX+I*INCX) with DA * DX(IX+I*INCX), -C where IX = 1 if INCX .GE. 0, else IX = 1+(1-N)*INCX. -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 900821 Modified to correct problem with a negative increment. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DSCAL - DOUBLE PRECISION DA, DX(*) - INTEGER I, INCX, IX, M, MP1, N -C***FIRST EXECUTABLE STATEMENT DSCAL - IF (N .LE. 0) RETURN - IF (INCX .EQ. 1) GOTO 20 -C -C Code for increment not equal to 1. -C - IX = 1 - IF (INCX .LT. 0) IX = (-N+1)*INCX + 1 - DO 10 I = 1,N - DX(IX) = DA*DX(IX) - IX = IX + INCX - 10 CONTINUE - RETURN -C -C Code for increment equal to 1. -C -C Clean-up loop so remaining vector length is a multiple of 5. -C - 20 M = MOD(N,5) - IF (M .EQ. 0) GOTO 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/slatec/dsd2s.f b/slatec/dsd2s.f deleted file mode 100644 index 78a417e..0000000 --- a/slatec/dsd2s.f +++ /dev/null @@ -1,151 +0,0 @@ -*DECK DSD2S - SUBROUTINE DSD2S (N, NELT, IA, JA, A, ISYM, DINV) -C***BEGIN PROLOGUE DSD2S -C***PURPOSE Diagonal Scaling Preconditioner SLAP Normal Eqns Set Up. -C Routine to compute the inverse of the diagonal of the -C matrix A*A', where A is stored in SLAP-Column format. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE DOUBLE PRECISION (SSD2S-S, DSD2S-D) -C***KEYWORDS DIAGONAL, SLAP SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM -C DOUBLE PRECISION A(NELT), DINV(N) -C -C CALL DSD2S( N, NELT, IA, JA, A, ISYM, DINV ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C NELT :IN Integer. -C Number of elements in arrays IA, JA, and A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Double Precision A(NELT). -C These arrays should hold the matrix A in the SLAP Column -C format. See "Description", below. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C DINV :OUT Double Precision DINV(N). -C Upon return this array holds 1./DIAG(A*A'). -C -C *Description -C =================== S L A P Column format ================== -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C With the SLAP format all of the "inner loops" of this -C routine should vectorize on machines with hardware support -C for vector gather/scatter operations. Your compiler may -C require a compiler directive to convince it that there are -C no implicit vector dependencies. Compiler directives for -C the Alliant FX/Fortran and CRI CFT/CFT77 compilers are -C supplied with the standard SLAP distribution. -C -C -C *Cautions: -C This routine assumes that the diagonal of A is all non-zero -C and that the operation DINV = 1.0/DIAG(A*A') will not under- -C flow or overflow. This is done so that the loop vectorizes. -C Matrices with zero or near zero or very large entries will -C have numerical difficulties and must be fixed before this -C routine is called. -C -C***SEE ALSO DSDCGN -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE DSD2S -C .. Scalar Arguments .. - INTEGER ISYM, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), DINV(N) - INTEGER IA(NELT), JA(NELT) -C .. Local Scalars .. - INTEGER I, K, KBGN, KEND -C***FIRST EXECUTABLE STATEMENT DSD2S - DO 10 I = 1, N - DINV(I) = 0 - 10 CONTINUE -C -C Loop over each column. -CVD$R NOCONCUR - DO 40 I = 1, N - KBGN = JA(I) - KEND = JA(I+1) - 1 -C -C Add in the contributions for each row that has a non-zero -C in this column. -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ NODEPCHK - DO 20 K = KBGN, KEND - DINV(IA(K)) = DINV(IA(K)) + A(K)**2 - 20 CONTINUE - IF( ISYM.EQ.1 ) THEN -C -C Lower triangle stored by columns => upper triangle stored by -C rows with Diagonal being the first entry. Loop across the -C rest of the row. - KBGN = KBGN + 1 - IF( KBGN.LE.KEND ) THEN - DO 30 K = KBGN, KEND - DINV(I) = DINV(I) + A(K)**2 - 30 CONTINUE - ENDIF - ENDIF - 40 CONTINUE - DO 50 I=1,N - DINV(I) = 1.0D0/DINV(I) - 50 CONTINUE -C - RETURN -C------------- LAST LINE OF DSD2S FOLLOWS ---------------------------- - END diff --git a/slatec/dsdbcg.f b/slatec/dsdbcg.f deleted file mode 100644 index 4d24195..0000000 --- a/slatec/dsdbcg.f +++ /dev/null @@ -1,272 +0,0 @@ -*DECK DSDBCG - SUBROUTINE DSDBCG (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, - + ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE DSDBCG -C***PURPOSE Diagonally Scaled BiConjugate Gradient Sparse Ax=b Solver. -C Routine to solve a linear system Ax = b using the -C BiConjugate Gradient method with diagonal scaling. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (SSDBCG-S, DSDBCG-D) -C***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, SLAP, -C SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LENW, IWORK(10), LENIW -C DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(8*N) -C -C CALL DSDBCG(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right-hand side vector. -C X :INOUT Double Precision X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Double Precision A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /DSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Double Precision. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Double Precision. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*D1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Double Precision RWORK(LENW). -C Double Precision array used for workspace. -C LENW :IN Integer. -C Length of the double precision workspace, RWORK. -C LENW >= 8*N. -C IWORK :WORK Integer IWORK(LENIW). -C Used to hold pointers into the RWORK array. -C LENIW :IN Integer. -C Length of the integer workspace, IWORK. LENIW >= 10. -C Upon return the following locations of IWORK hold information -C which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Double Precision workspace actually used. -C -C *Description: -C This routine performs preconditioned BiConjugate gradient -C method on the Non-Symmetric positive definite linear system -C Ax=b. The preconditioner is M = DIAG(A), the diagonal of the -C matrix A. This is the simplest of preconditioners and -C vectorizes very well. -C -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to -C be the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO DBCG, DLUBCG -C***REFERENCES (NONE) -C***ROUTINES CALLED DBCG, DCHKW, DS2Y, DSDI, DSDS, DSMTV, DSMV -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE DSDBCG -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - DOUBLE PRECISION ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(N), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER LOCDIN, LOCDZ, LOCIW, LOCP, LOCPP, LOCR, LOCRR, LOCW, - + LOCZ, LOCZZ -C .. External Subroutines .. - EXTERNAL DBCG, DCHKW, DS2Y, DSDI, DSDS, DSMTV, DSMV -C***FIRST EXECUTABLE STATEMENT DSDBCG -C - IERR = 0 - IF( N.LT.1 .OR. NELT.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Change the SLAP input matrix IA, JA, A to SLAP-Column format. - CALL DS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Set up the workspace. - LOCIW = LOCIB -C - LOCDIN = LOCRB - LOCR = LOCDIN + N - LOCZ = LOCR + N - LOCP = LOCZ + N - LOCRR = LOCP + N - LOCZZ = LOCRR + N - LOCPP = LOCZZ + N - LOCDZ = LOCPP + N - LOCW = LOCDZ + N -C -C Check the workspace allocations. - CALL DCHKW( 'DSDBCG', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(4) = LOCDIN - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Compute the inverse of the diagonal of the matrix. - CALL DSDS(N, NELT, IA, JA, A, ISYM, RWORK(LOCDIN)) -C -C Perform the Diagonally Scaled BiConjugate gradient algorithm. - CALL DBCG(N, B, X, NELT, IA, JA, A, ISYM, DSMV, DSMTV, - $ DSDI, DSDI, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, - $ RWORK(LOCR), RWORK(LOCZ), RWORK(LOCP), - $ RWORK(LOCRR), RWORK(LOCZZ), RWORK(LOCPP), - $ RWORK(LOCDZ), RWORK(1), IWORK(1)) - RETURN -C------------- LAST LINE OF DSDBCG FOLLOWS ---------------------------- - END diff --git a/slatec/dsdcg.f b/slatec/dsdcg.f deleted file mode 100644 index f221e14..0000000 --- a/slatec/dsdcg.f +++ /dev/null @@ -1,276 +0,0 @@ -*DECK DSDCG - SUBROUTINE DSDCG (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, - + ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE DSDCG -C***PURPOSE Diagonally Scaled Conjugate Gradient Sparse Ax=b Solver. -C Routine to solve a symmetric positive definite linear -C system Ax = b using the Preconditioned Conjugate -C Gradient method. The preconditioner is diagonal scaling. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2B4 -C***TYPE DOUBLE PRECISION (SSDCG-S, DSDCG-D) -C***KEYWORDS ITERATIVE PRECONDITION, SLAP, SPARSE, -C SYMMETRIC LINEAR SYSTEM -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LENW, IWORK(10), LENIW -C DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(5*N) -C -C CALL DSDCG(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right-hand side vector. -C X :INOUT Double Precision X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Double Precision A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /DSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Double Precision. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Double Precision. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*D1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Double Precision RWORK(LENW). -C Double Precision array used for workspace. -C LENW :IN Integer. -C Length of the double precision workspace, RWORK. LENW >= 5*N. -C IWORK :WORK Integer IWORK(LENIW). -C Used to hold pointers into the double precision workspace, -C RWORK. Upon return the following locations of IWORK hold -C information which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Double Precision workspace actually used. -C LENIW :IN Integer. -C Length of the integer workspace, IWORK. LENIW >= 10. -C -C *Description: -C This routine performs preconditioned conjugate gradient -C method on the symmetric positive definite linear system -C Ax=b. The preconditioner is M = DIAG(A), the diagonal of -C the matrix A. This is the simplest of preconditioners and -C vectorizes very well. This routine is simply a driver for -C the DCG routine. It calls the DSDS routine to set up the -C preconditioning and then calls DCG with the appropriate -C MATVEC and MSOLVE routines. -C -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to -C be the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO DCG, DSICCG -C***REFERENCES 1. Louis Hageman and David Young, Applied Iterative -C Methods, Academic Press, New York, 1981. -C 2. Concus, Golub and O'Leary, A Generalized Conjugate -C Gradient Method for the Numerical Solution of -C Elliptic Partial Differential Equations, in Sparse -C Matrix Computations, Bunch and Rose, Eds., Academic -C Press, New York, 1979. -C***ROUTINES CALLED DCG, DCHKW, DS2Y, DSDI, DSDS, DSMV -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of references. (FNF) -C***END PROLOGUE DSDCG -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - DOUBLE PRECISION ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER LOCD, LOCDZ, LOCIW, LOCP, LOCR, LOCW, LOCZ -C .. External Subroutines .. - EXTERNAL DCG, DCHKW, DS2Y, DSDI, DSDS, DSMV -C***FIRST EXECUTABLE STATEMENT DSDCG -C - IERR = 0 - IF( N.LT.1 .OR. NELT.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Modify the SLAP matrix data structure to YSMP-Column. - CALL DS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Set up the work arrays. - LOCIW = LOCIB -C - LOCD = LOCRB - LOCR = LOCD + N - LOCZ = LOCR + N - LOCP = LOCZ + N - LOCDZ = LOCP + N - LOCW = LOCDZ + N -C -C Check the workspace allocations. - CALL DCHKW( 'DSDCG', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(4) = LOCD - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Compute the inverse of the diagonal of the matrix. This -C will be used as the preconditioner. - CALL DSDS(N, NELT, IA, JA, A, ISYM, RWORK(LOCD)) -C -C Do the Preconditioned Conjugate Gradient. - CALL DCG(N, B, X, NELT, IA, JA, A, ISYM, DSMV, DSDI, - $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), - $ RWORK(LOCZ), RWORK(LOCP), RWORK(LOCDZ), RWORK, IWORK) - RETURN -C------------- LAST LINE OF DSDCG FOLLOWS ----------------------------- - END diff --git a/slatec/dsdcgn.f b/slatec/dsdcgn.f deleted file mode 100644 index 1bc4717..0000000 --- a/slatec/dsdcgn.f +++ /dev/null @@ -1,275 +0,0 @@ -*DECK DSDCGN - SUBROUTINE DSDCGN (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, - + ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE DSDCGN -C***PURPOSE Diagonally Scaled CG Sparse Ax=b Solver for Normal Eqn's. -C Routine to solve a general linear system Ax = b using -C diagonal scaling with the Conjugate Gradient method -C applied to the the normal equations, viz., AA'y = b, -C where x = A'y. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (SSDCGN-S, DSDCGN-D) -C***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM SOLVE, -C SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LENW, IWORK(10), LENIW -C DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(8*N) -C -C CALL DSDCGN(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right-hand side vector. -C X :INOUT Double Precision X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Double Precision A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /DSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Double Precision. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Double Precision. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*D1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Double Precision RWORK(LENW). -C Double Precision array used for workspace. -C LENW :IN Integer. -C Length of the double precision workspace, RWORK. -C LENW >= 8*N. -C IWORK :WORK Integer IWORK(LENIW). -C Used to hold pointers into the RWORK array. -C Upon return the following locations of IWORK hold information -C which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Double Precision workspace actually used. -C LENIW :IN Integer. -C Length of the integer workspace, IWORK. LENIW >= 10. -C -C *Description: -C This routine is simply a driver for the DCGN routine. It -C calls the DSD2S routine to set up the preconditioning and -C then calls DCGN with the appropriate MATVEC and MSOLVE -C routines. -C -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to be -C the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO DCGN, DSD2S, DSMV, DSMTV, DSDI -C***REFERENCES (NONE) -C***ROUTINES CALLED DCGN, DCHKW, DS2Y, DSD2S, DSDI, DSMTV, DSMV -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE DSDCGN -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - DOUBLE PRECISION ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER LOCATD, LOCATP, LOCATZ, LOCD, LOCDZ, LOCIW, LOCP, LOCR, - + LOCW, LOCZ -C .. External Subroutines .. - EXTERNAL DCGN, DCHKW, DS2Y, DSD2S, DSDI, DSMTV, DSMV -C***FIRST EXECUTABLE STATEMENT DSDCGN -C - IERR = 0 - IF( N.LT.1 .OR. NELT.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Modify the SLAP matrix data structure to YSMP-Column. - CALL DS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Set up the work arrays. - LOCIW = LOCIB -C - LOCD = LOCRB - LOCR = LOCD + N - LOCZ = LOCR + N - LOCP = LOCZ + N - LOCATP = LOCP + N - LOCATZ = LOCATP + N - LOCDZ = LOCATZ + N - LOCATD = LOCDZ + N - LOCW = LOCATD + N -C -C Check the workspace allocations. - CALL DCHKW( 'DSDCGN', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(4) = LOCD - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Compute the inverse of the diagonal of AA'. This will be -C used as the preconditioner. - CALL DSD2S(N, NELT, IA, JA, A, ISYM, RWORK(1)) -C -C Perform Conjugate Gradient algorithm on the normal equations. - CALL DCGN( N, B, X, NELT, IA, JA, A, ISYM, DSMV, DSMTV, DSDI, - $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), - $ RWORK(LOCZ), RWORK(LOCP), RWORK(LOCATP), RWORK(LOCATZ), - $ RWORK(LOCDZ), RWORK(LOCATD), RWORK, IWORK ) -C - IF( ITER.GT.ITMAX ) IERR = 2 - RETURN -C------------- LAST LINE OF DSDCGN FOLLOWS ---------------------------- - END diff --git a/slatec/dsdcgs.f b/slatec/dsdcgs.f deleted file mode 100644 index e97c531..0000000 --- a/slatec/dsdcgs.f +++ /dev/null @@ -1,286 +0,0 @@ -*DECK DSDCGS - SUBROUTINE DSDCGS (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, - + ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE DSDCGS -C***PURPOSE Diagonally Scaled CGS Sparse Ax=b Solver. -C Routine to solve a linear system Ax = b using the -C BiConjugate Gradient Squared method with diagonal scaling. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (SSDCGS-S, DSDCGS-D) -C***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, SLAP, -C SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LENW, IWORK(10), LENIW -C DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(8*N) -C -C CALL DSDCGS(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right-hand side vector. -C X :INOUT Double Precision X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Double Precision A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C This routine must calculate the residual from R = A*X - B. -C This is unnatural and hence expensive for this type of iter- -C ative method. ITOL=2 is *STRONGLY* recommended. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv time a vector is the pre- -C conditioning step. This is the *NATURAL* stopping for this -C iterative method and is *STRONGLY* recommended. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /DSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Double Precision. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Double Precision. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*D1MACH(3). Iteration proceeded. -C IERR = 5 => Breakdown of the method detected. -C (r0,r) approximately 0. -C IERR = 6 => Stagnation of the method detected. -C (r0,v) approximately 0. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Double Precision RWORK(LENW). -C Double Precision array used for workspace. -C LENW :IN Integer. -C Length of the double precision workspace, RWORK. LENW >= 8*N. -C IWORK :WORK Integer IWORK(LENIW). -C Used to hold pointers into the RWORK array. -C Upon return the following locations of IWORK hold information -C which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Double Precision workspace actually used. -C LENIW :IN Integer. -C Length of the integer workspace, IWORK. LENIW >= 10. -C -C *Description: -C This routine performs preconditioned BiConjugate gradient -C method on the Non-Symmetric positive definite linear system -C Ax=b. The preconditioner is M = DIAG(A), the diagonal of the -C matrix A. This is the simplest of preconditioners and -C vectorizes very well. -C -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to -C be the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO DCGS, DLUBCG -C***REFERENCES 1. P. Sonneveld, CGS, a fast Lanczos-type solver -C for nonsymmetric linear systems, Delft University -C of Technology Report 84-16, Department of Mathe- -C matics and Informatics, Delft, The Netherlands. -C 2. E. F. Kaasschieter, The solution of non-symmetric -C linear systems by biconjugate gradients or conjugate -C gradients squared, Delft University of Technology -C Report 86-21, Department of Mathematics and Informa- -C tics, Delft, The Netherlands. -C***ROUTINES CALLED DCGS, DCHKW, DS2Y, DSDI, DSDS, DSMV -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of references. (FNF) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE DSDCGS -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - DOUBLE PRECISION ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(N), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER LOCDIN, LOCIW, LOCP, LOCQ, LOCR, LOCR0, LOCU, LOCV1, - + LOCV2, LOCW -C .. External Subroutines .. - EXTERNAL DCGS, DCHKW, DS2Y, DSDI, DSDS, DSMV -C***FIRST EXECUTABLE STATEMENT DSDCGS -C - IERR = 0 - IF( N.LT.1 .OR. NELT.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Change the SLAP input matrix IA, JA, A to SLAP-Column format. - CALL DS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Set up the workspace. - LOCIW = LOCIB -C - LOCDIN = LOCRB - LOCR = LOCDIN + N - LOCR0 = LOCR + N - LOCP = LOCR0 + N - LOCQ = LOCP + N - LOCU = LOCQ + N - LOCV1 = LOCU + N - LOCV2 = LOCV1 + N - LOCW = LOCV2 + N -C -C Check the workspace allocations. - CALL DCHKW( 'DSDCGS', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(4) = LOCDIN - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Compute the inverse of the diagonal of the matrix. - CALL DSDS(N, NELT, IA, JA, A, ISYM, RWORK(LOCDIN)) -C -C Perform the Diagonally Scaled -C BiConjugate Gradient Squared algorithm. - CALL DCGS(N, B, X, NELT, IA, JA, A, ISYM, DSMV, - $ DSDI, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, - $ RWORK(LOCR), RWORK(LOCR0), RWORK(LOCP), - $ RWORK(LOCQ), RWORK(LOCU), RWORK(LOCV1), - $ RWORK(LOCV2), RWORK(1), IWORK(1)) - RETURN -C------------- LAST LINE OF DSDCGS FOLLOWS ---------------------------- - END diff --git a/slatec/dsdgmr.f b/slatec/dsdgmr.f deleted file mode 100644 index f30f1ba..0000000 --- a/slatec/dsdgmr.f +++ /dev/null @@ -1,386 +0,0 @@ -*DECK DSDGMR - SUBROUTINE DSDGMR (N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ITOL, - + TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE DSDGMR -C***PURPOSE Diagonally scaled GMRES iterative sparse Ax=b solver. -C This routine uses the generalized minimum residual -C (GMRES) method with diagonal scaling to solve possibly -C non-symmetric linear systems of the form: Ax = b. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (SSDGMR-S, DSDGMR-D) -C***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov -C Hindmarsh, Alan, (LLNL), alanh@llnl.gov -C Seager, Mark K., (LLNL), seager@llnl.gov -C Lawrence Livermore National Laboratory -C PO Box 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NSAVE, ITOL -C INTEGER ITMAX, ITER, IERR, IUNIT, LENW, IWORK(LENIW), LENIW -C DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(LENW) -C -C CALL DSDGMR(N, B, X, NELT, IA, JA, A, ISYM, NSAVE, -C $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, -C $ RWORK, LENW, IWORK, LENIW) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right-hand side vector. -C X :INOUT Double Precision X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Double Precision A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C NSAVE :IN Integer. -C Number of direction vectors to save and orthogonalize against. -C Must be greater than 1. -C ITOL :IN Integer. -C Flag to indicate the type of convergence criterion used. -C ITOL=0 Means the iteration stops when the test described -C below on the residual RL is satisfied. This is -C the "Natural Stopping Criteria" for this routine. -C Other values of ITOL cause extra, otherwise -C unnecessary, computation per iteration and are -C therefore much less efficient. See ISDGMR (the -C stop test routine) for more information. -C ITOL=1 Means the iteration stops when the first test -C described below on the residual RL is satisfied, -C and there is either right or no preconditioning -C being used. -C ITOL=2 Implies that the user is using left -C preconditioning, and the second stopping criterion -C below is used. -C ITOL=3 Means the iteration stops when the third test -C described below on Minv*Residual is satisfied, and -C there is either left or no preconditioning begin -C used. -C ITOL=11 is often useful for checking and comparing -C different routines. For this case, the user must -C supply the "exact" solution or a very accurate -C approximation (one with an error much less than -C TOL) through a common block, -C COMMON /DSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the -C difference between the iterative approximation and -C the user-supplied solution divided by the 2-norm -C of the user-supplied solution is less than TOL. -C Note that this requires the user to set up the -C "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling -C routine. The routine with this declaration should -C be loaded before the stop test so that the correct -C length is used by the loader. This procedure is -C not standard Fortran and may not work correctly on -C your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 -C then this common block is indeed standard Fortran. -C TOL :INOUT Double Precision. -C Convergence criterion, as described below. If TOL is set -C to zero on input, then a default value of 500*(the smallest -C positive magnitude, machine epsilon) is used. -C ITMAX :IN Integer. -C Maximum number of iterations. This routine uses the default -C of NRMAX = ITMAX/NSAVE to determine when each restart -C should occur. See the description of NRMAX and MAXL in -C DGMRES for a full and frightfully interesting discussion of -C this topic. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Double Precision. -C Error estimate of error in final approximate solution, as -C defined by ITOL. Letting norm() denote the Euclidean -C norm, ERR is defined as follows... -C If ITOL=0, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), -C for right or no preconditioning, and -C ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ -C norm(SB*(M-inverse)*B), -C for left preconditioning. -C If ITOL=1, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), -C since right or no preconditioning -C being used. -C If ITOL=2, then ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ -C norm(SB*(M-inverse)*B), -C since left preconditioning is being -C used. -C If ITOL=3, then ERR = Max |(Minv*(B-A*X(L)))(i)/x(i)| -C i=1,n -C If ITOL=11, then ERR = norm(SB*(X(L)-SOLN))/norm(SB*SOLN). -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient storage allocated for -C RGWK or IGWK. -C IERR = 2 => Routine DPIGMR failed to reduce the norm -C of the current residual on its last call, -C and so the iteration has stalled. In -C this case, X equals the last computed -C approximation. The user must either -C increase MAXL, or choose a different -C initial guess. -C IERR =-1 => Insufficient length for RGWK array. -C IGWK(6) contains the required minimum -C length of the RGWK array. -C IERR =-2 => Inconsistent ITOL and JPRE values. -C For IERR <= 2, RGWK(1) = RHOL, which is the norm on the -C left-hand-side of the relevant stopping test defined -C below associated with the residual for the current -C approximation X(L). -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Double Precision RWORK(LENW). -C Double Precision array of size LENW. -C LENW :IN Integer. -C Length of the double precision workspace, RWORK. -C LENW >= 1 + N*(NSAVE+7) + NSAVE*(NSAVE+3). -C For the recommended values of NSAVE (10), RWORK has size at -C least 131 + 17*N. -C IWORK :INOUT Integer IWORK(USER DEFINED >= 30). -C Used to hold pointers into the RWORK array. -C Upon return the following locations of IWORK hold information -C which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Double Precision workspace actually used. -C LENIW :IN Integer. -C Length of the integer workspace IWORK. LENIW >= 30. -C -C *Description: -C DSDGMR solves a linear system A*X = B rewritten in the form: -C -C (SB*A*(M-inverse)*(SX-inverse))*(SX*M*X) = SB*B, -C -C with right preconditioning, or -C -C (SB*(M-inverse)*A*(SX-inverse))*(SX*X) = SB*(M-inverse)*B, -C -C with left preconditioning, where A is an n-by-n double precision -C matrix, X and B are N-vectors, SB and SX are diagonal scaling -C matrices, and M is the diagonal of A. It uses -C preconditioned Krylov subpace methods based on the -C generalized minimum residual method (GMRES). This routine -C is a driver routine which assumes a SLAP matrix data -C structure and sets up the necessary information to do -C diagonal preconditioning and calls the main GMRES routine -C DGMRES for the solution of the linear system. DGMRES -C optionally performs either the full orthogonalization -C version of the GMRES algorithm or an incomplete variant of -C it. Both versions use restarting of the linear iteration by -C default, although the user can disable this feature. -C -C The GMRES algorithm generates a sequence of approximations -C X(L) to the true solution of the above linear system. The -C convergence criteria for stopping the iteration is based on -C the size of the scaled norm of the residual R(L) = B - -C A*X(L). The actual stopping test is either: -C -C norm(SB*(B-A*X(L))) .le. TOL*norm(SB*B), -C -C for right preconditioning, or -C -C norm(SB*(M-inverse)*(B-A*X(L))) .le. -C TOL*norm(SB*(M-inverse)*B), -C -C for left preconditioning, where norm() denotes the Euclidean -C norm, and TOL is a positive scalar less than one input by -C the user. If TOL equals zero when DSDGMR is called, then a -C default value of 500*(the smallest positive magnitude, -C machine epsilon) is used. If the scaling arrays SB and SX -C are used, then ideally they should be chosen so that the -C vectors SX*X(or SX*M*X) and SB*B have all their components -C approximately equal to one in magnitude. If one wants to -C use the same scaling in X and B, then SB and SX can be the -C same array in the calling program. -C -C The following is a list of the other routines and their -C functions used by GMRES: -C DGMRES Contains the matrix structure independent driver -C routine for GMRES. -C DPIGMR Contains the main iteration loop for GMRES. -C DORTH Orthogonalizes a new vector against older basis vectors. -C DHEQR Computes a QR decomposition of a Hessenberg matrix. -C DHELS Solves a Hessenberg least-squares system, using QR -C factors. -C RLCALC Computes the scaled residual RL. -C XLCALC Computes the solution XL. -C ISDGMR User-replaceable stopping routine. -C -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to be -C the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***REFERENCES 1. Peter N. Brown and A. C. Hindmarsh, Reduced Storage -C Matrix Methods in Stiff ODE Systems, Lawrence Liver- -C more National Laboratory Report UCRL-95088, Rev. 1, -C Livermore, California, June 1987. -C***ROUTINES CALLED DCHKW, DGMRES, DS2Y, DSDI, DSDS, DSMV -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of references. (FNF) -C***END PROLOGUE DSDGMR -C The following is for optimized compilation on LLNL/LTSS Crays. -CLLL. OPTIMIZE -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - DOUBLE PRECISION ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, - + NELT, NSAVE -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER LOCDIN, LOCIGW, LOCIW, LOCRGW, LOCW, MYITOL -C .. External Subroutines .. - EXTERNAL DCHKW, DGMRES, DS2Y, DSDI, DSDS, DSMV -C***FIRST EXECUTABLE STATEMENT DSDGMR -C - IERR = 0 - ERR = 0 - IF( NSAVE.LE.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Change the SLAP input matrix IA, JA, A to SLAP-Column format. - CALL DS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Set up the workspace. We assume MAXL=KMP=NSAVE. - LOCIGW = LOCIB - LOCIW = LOCIGW + 20 -C - LOCDIN = LOCRB - LOCRGW = LOCDIN + N - LOCW = LOCRGW + 1+N*(NSAVE+6)+NSAVE*(NSAVE+3) -C - IWORK(4) = LOCDIN - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Check the workspace allocations. - CALL DCHKW( 'DSDGMR', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C -C Compute the inverse of the diagonal of the matrix. - CALL DSDS(N, NELT, IA, JA, A, ISYM, RWORK(LOCDIN)) -C -C Perform the Diagonally Scaled Generalized Minimum -C Residual iteration algorithm. The following DGMRES -C defaults are used MAXL = KMP = NSAVE, JSCAL = 0, -C JPRE = -1, NRMAX = ITMAX/NSAVE - IWORK(LOCIGW ) = NSAVE - IWORK(LOCIGW+1) = NSAVE - IWORK(LOCIGW+2) = 0 - IWORK(LOCIGW+3) = -1 - IWORK(LOCIGW+4) = ITMAX/NSAVE - MYITOL = 0 -C - CALL DGMRES( N, B, X, NELT, IA, JA, A, ISYM, DSMV, DSDI, - $ MYITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, RWORK, - $ RWORK(LOCRGW), LENW-LOCRGW, IWORK(LOCIGW), 20, - $ RWORK, IWORK ) -C - IF( ITER.GT.ITMAX ) IERR = 2 - RETURN -C------------- LAST LINE OF DSDGMR FOLLOWS ---------------------------- - END diff --git a/slatec/dsdi.f b/slatec/dsdi.f deleted file mode 100644 index 1e14538..0000000 --- a/slatec/dsdi.f +++ /dev/null @@ -1,88 +0,0 @@ -*DECK DSDI - SUBROUTINE DSDI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C***BEGIN PROLOGUE DSDI -C***PURPOSE Diagonal Matrix Vector Multiply. -C Routine to calculate the product X = DIAG*B, where DIAG -C is a diagonal matrix. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D1B4 -C***TYPE DOUBLE PRECISION (SSDI-S, DSDI-D) -C***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM SOLVE, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, IWORK(10) -C DOUBLE PRECISION B(N), X(N), A(NELT), RWORK(USER DEFINED) -C -C CALL DSDI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Double Precision B(N). -C Vector to multiply the diagonal by. -C X :OUT Double Precision X(N). -C Result of DIAG*B. -C NELT :DUMMY Integer. -C IA :DUMMY Integer IA(NELT). -C JA :DUMMY Integer JA(NELT). -C A :DUMMY Double Precision A(NELT). -C ISYM :DUMMY Integer. -C These are for compatibility with SLAP MSOLVE calling sequence. -C RWORK :IN Double Precision RWORK(USER DEFINED). -C Work array holding the diagonal of some matrix to scale -C B by. This array must be set by the user or by a call -C to the SLAP routine DSDS or DSD2S. The length of RWORK -C must be >= IWORK(4)+N. -C IWORK :IN Integer IWORK(10). -C IWORK(4) holds the offset into RWORK for the diagonal matrix -C to scale B by. This is usually set up by the SLAP pre- -C conditioner setup routines DSDS or DSD2S. -C -C *Description: -C This routine is supplied with the SLAP package to perform -C the MSOLVE operation for iterative drivers that require -C diagonal Scaling (e.g., DSDCG, DSDBCG). It conforms -C to the SLAP MSOLVE CALLING CONVENTION and hence does not -C require an interface routine as do some of the other pre- -C conditioners supplied with SLAP. -C -C***SEE ALSO DSDS, DSD2S -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE DSDI -C .. Scalar Arguments .. - INTEGER ISYM, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), B(N), RWORK(*), X(N) - INTEGER IA(NELT), IWORK(10), JA(NELT) -C .. Local Scalars .. - INTEGER I, LOCD -C***FIRST EXECUTABLE STATEMENT DSDI -C -C Determine where the inverse of the diagonal -C is in the work array and then scale by it. -C - LOCD = IWORK(4) - 1 - DO 10 I = 1, N - X(I) = RWORK(LOCD+I)*B(I) - 10 CONTINUE - RETURN -C------------- LAST LINE OF DSDI FOLLOWS ---------------------------- - END diff --git a/slatec/dsdomn.f b/slatec/dsdomn.f deleted file mode 100644 index 6a56950..0000000 --- a/slatec/dsdomn.f +++ /dev/null @@ -1,263 +0,0 @@ -*DECK DSDOMN - SUBROUTINE DSDOMN (N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ITOL, - + TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE DSDOMN -C***PURPOSE Diagonally Scaled Orthomin Sparse Iterative Ax=b Solver. -C Routine to solve a general linear system Ax = b using -C the Orthomin method with diagonal scaling. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (SSDOMN-S, DSDOMN-D) -C***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM SOLVE, -C SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NSAVE, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LENW, IWORK(10), LENIW -C DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR -C DOUBLE PRECISION RWORK(7*N+3*N*NSAVE+NSAVE) -C -C CALL DSDOMN(N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right-hand side vector. -C X :INOUT Double Precision X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Double Precision A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen, it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C NSAVE :IN Integer. -C Number of direction vectors to save and orthogonalize against. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /DSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. -C TOL :INOUT Double Precision. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Double Precision. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*D1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Breakdown of method detected. -C (p,Ap) < epsilon**2. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Double Precision RWORK(LENW). -C Double Precision array used for workspace. -C LENW :IN Integer. -C Length of the double precision workspace, RWORK. -C LENW >= 7*N+NSAVE*(3*N+1). -C IWORK :WORK Integer IWORK(LENIW). -C Used to hold pointers into the RWORK array. -C LENIW :IN Integer. -C Length of the integer workspace, IWORK. LENIW >= 10. -C -C *Description: -C This routine is simply a driver for the DOMN routine. It -C calls the DSDS routine to set up the preconditioning and -C then calls DOMN with the appropriate MATVEC and MSOLVE -C routines. -C -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C -C In this format only the non-zeros are stored. They may -C appear in *ANY* order. The user supplies three arrays of -C length NELT, where NELT is the number of non-zeros in the -C matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero -C the user puts the row and column index of that matrix -C element in the IA and JA arrays. The value of the non-zero -C matrix element is placed in the corresponding location of -C the A array. This is an extremely easy data structure to -C generate. On the other hand it is not too efficient on -C vector computers for the iterative solution of linear -C systems. Hence, SLAP changes this input data structure to -C the SLAP Column format for the iteration (but does not -C change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C In this format the non-zeros are stored counting down -C columns (except for the diagonal entry, which must appear -C first in each "column") and are stored in the double pre- -C cision array A. In other words, for each column in the -C matrix first put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)),A(JA(ICOL)) are the first elements of the ICOL- -C th column in IA and A, and IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) -C are the last elements of the ICOL-th column. Note that we -C always have JA(N+1)=NELT+1, where N is the number of columns -C in the matrix and NELT is the number of non-zeros in the -C matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to -C be the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO DOMN, DSLUOM -C***REFERENCES (NONE) -C***ROUTINES CALLED DCHKW, DOMN, DS2Y, DSDI, DSDS, DSMV -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE DSDOMN -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - DOUBLE PRECISION ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, - + NELT, NSAVE -C .. Array Arguments .. - DOUBLE PRECISION A(N), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER LOCAP, LOCCSA, LOCDIN, LOCDZ, LOCEMA, LOCIW, LOCP, LOCR, - + LOCW, LOCZ -C .. External Subroutines .. - EXTERNAL DCHKW, DOMN, DS2Y, DSDI, DSDS, DSMV -C***FIRST EXECUTABLE STATEMENT DSDOMN -C - IERR = 0 - IF( N.LT.1 .OR. NELT.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Change the SLAP input matrix IA, JA, A to SLAP-Column format. - CALL DS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Set up the workspace. - LOCIW = LOCIB -C - LOCDIN = LOCRB - LOCR = LOCDIN + N - LOCZ = LOCR + N - LOCP = LOCZ + N - LOCAP = LOCP + N*(NSAVE+1) - LOCEMA = LOCAP + N*(NSAVE+1) - LOCDZ = LOCEMA + N*(NSAVE+1) - LOCCSA = LOCDZ + N - LOCW = LOCCSA + NSAVE -C -C Check the workspace allocations. - CALL DCHKW( 'DSDOMN', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(4) = LOCDIN - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Compute the inverse of the diagonal of the matrix. - CALL DSDS(N, NELT, IA, JA, A, ISYM, RWORK(LOCDIN)) -C -C Perform the Diagonally Scaled Orthomin iteration algorithm. - CALL DOMN(N, B, X, NELT, IA, JA, A, ISYM, DSMV, - $ DSDI, NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, - $ RWORK(LOCR), RWORK(LOCZ), RWORK(LOCP), RWORK(LOCAP), - $ RWORK(LOCEMA), RWORK(LOCDZ), RWORK(LOCCSA), - $ RWORK, IWORK ) - RETURN -C------------- LAST LINE OF DSDOMN FOLLOWS ---------------------------- - END diff --git a/slatec/dsdot.f b/slatec/dsdot.f deleted file mode 100644 index 85adb68..0000000 --- a/slatec/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/slatec/dsds.f b/slatec/dsds.f deleted file mode 100644 index e757820..0000000 --- a/slatec/dsds.f +++ /dev/null @@ -1,125 +0,0 @@ -*DECK DSDS - SUBROUTINE DSDS (N, NELT, IA, JA, A, ISYM, DINV) -C***BEGIN PROLOGUE DSDS -C***PURPOSE Diagonal Scaling Preconditioner SLAP Set Up. -C Routine to compute the inverse of the diagonal of a matrix -C stored in the SLAP Column format. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE DOUBLE PRECISION (SSDS-S, DSDS-D) -C***KEYWORDS DIAGONAL, SLAP SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM -C DOUBLE PRECISION A(NELT), DINV(N) -C -C CALL DSDS( N, NELT, IA, JA, A, ISYM, DINV ) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C NELT :IN Integer. -C Number of elements in arrays IA, JA, and A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Double Precision A(NELT). -C These arrays should hold the matrix A in the SLAP Column -C format. See "Description", below. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C DINV :OUT Double Precision DINV(N). -C Upon return this array holds 1./DIAG(A). -C -C *Description -C =================== S L A P Column format ================== -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C With the SLAP format all of the "inner loops" of this -C routine should vectorize on machines with hardware support -C for vector gather/scatter operations. Your compiler may -C require a compiler directive to convince it that there are -C no implicit vector dependencies. Compiler directives for -C the Alliant FX/Fortran and CRI CFT/CFT77 compilers are -C supplied with the standard SLAP distribution. -C -C -C *Cautions: -C This routine assumes that the diagonal of A is all non-zero -C and that the operation DINV = 1.0/DIAG(A) will not underflow -C or overflow. This is done so that the loop vectorizes. -C Matrices with zero or near zero or very large entries will -C have numerical difficulties and must be fixed before this -C routine is called. -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE DSDS -C .. Scalar Arguments .. - INTEGER ISYM, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), DINV(N) - INTEGER IA(NELT), JA(NELT) -C .. Local Scalars .. - INTEGER ICOL -C***FIRST EXECUTABLE STATEMENT DSDS -C -C Assume the Diagonal elements are the first in each column. -C This loop should *VECTORIZE*. If it does not you may have -C to add a compiler directive. We do not check for a zero -C (or near zero) diagonal element since this would interfere -C with vectorization. If this makes you nervous put a check -C in! It will run much slower. -C - DO 10 ICOL = 1, N - DINV(ICOL) = 1.0D0/A(JA(ICOL)) - 10 CONTINUE -C - RETURN -C------------- LAST LINE OF DSDS FOLLOWS ---------------------------- - END diff --git a/slatec/dsdscl.f b/slatec/dsdscl.f deleted file mode 100644 index 50c38c8..0000000 --- a/slatec/dsdscl.f +++ /dev/null @@ -1,195 +0,0 @@ -*DECK DSDSCL - SUBROUTINE DSDSCL (N, NELT, IA, JA, A, ISYM, X, B, DINV, JOB, - + ITOL) -C***BEGIN PROLOGUE DSDSCL -C***PURPOSE Diagonal Scaling of system Ax = b. -C This routine scales (and unscales) the system Ax = b -C by symmetric diagonal scaling. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE DOUBLE PRECISION (SSDSCL-S, DSDSCL-D) -C***KEYWORDS DIAGONAL, SLAP SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C This routine scales (and unscales) the system Ax = b by symmetric -C diagonal scaling. The new system is: -C -1/2 -1/2 1/2 -1/2 -C D AD (D x) = D b -C when scaling is selected with the JOB parameter. When unscaling -C is selected this process is reversed. The true solution is also -C scaled or unscaled if ITOL is set appropriately, see below. -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, JOB, ITOL -C DOUBLE PRECISION A(NELT), X(N), B(N), DINV(N) -C -C CALL DSDSCL( N, NELT, IA, JA, A, ISYM, X, B, DINV, JOB, ITOL ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C NELT :IN Integer. -C Number of elements in arrays IA, JA, and A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Double Precision A(NELT). -C These arrays should hold the matrix A in the SLAP Column -C format. See "Description", below. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C X :INOUT Double Precision X(N). -C Initial guess that will be later used in the iterative -C solution. -C of the scaled system. -C B :INOUT Double Precision B(N). -C Right hand side vector. -C DINV :INOUT Double Precision DINV(N). -C Upon return this array holds 1./DIAG(A). -C This is an input if JOB = 0. -C JOB :IN Integer. -C Flag indicating whether to scale or not. -C JOB non-zero means do scaling. -C JOB = 0 means do unscaling. -C ITOL :IN Integer. -C Flag indicating what type of error estimation to do in the -C iterative method. When ITOL = 11 the exact solution from -C common block DSLBLK will be used. When the system is scaled -C then the true solution must also be scaled. If ITOL is not -C 11 then this vector is not referenced. -C -C *Common Blocks: -C SOLN :INOUT Double Precision SOLN(N). COMMON BLOCK /DSLBLK/ -C The true solution, SOLN, is scaled (or unscaled) if ITOL is -C set to 11, see above. -C -C *Description -C =================== S L A P Column format ================== -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C With the SLAP format all of the "inner loops" of this -C routine should vectorize on machines with hardware support -C for vector gather/scatter operations. Your compiler may -C require a compiler directive to convince it that there are -C no implicit vector dependencies. Compiler directives for -C the Alliant FX/Fortran and CRI CFT/CFT77 compilers are -C supplied with the standard SLAP distribution. -C -C -C *Cautions: -C This routine assumes that the diagonal of A is all non-zero -C and that the operation DINV = 1.0/DIAG(A) will not under- -C flow or overflow. This is done so that the loop vectorizes. -C Matrices with zero or near zero or very large entries will -C have numerical difficulties and must be fixed before this -C routine is called. -C -C***SEE ALSO DSDCG -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS DSLBLK -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Added C***FIRST EXECUTABLE STATEMENT line. (FNF) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE DSDSCL -C .. Scalar Arguments .. - INTEGER ISYM, ITOL, JOB, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), B(N), DINV(N), X(N) - INTEGER IA(NELT), JA(NELT) -C .. Arrays in Common .. - DOUBLE PRECISION SOLN(1) -C .. Local Scalars .. - DOUBLE PRECISION DI - INTEGER ICOL, J, JBGN, JEND -C .. Intrinsic Functions .. - INTRINSIC SQRT -C .. Common blocks .. - COMMON /DSLBLK/ SOLN -C***FIRST EXECUTABLE STATEMENT DSDSCL -C -C SCALING... -C - IF( JOB.NE.0 ) THEN - DO 10 ICOL = 1, N - DINV(ICOL) = 1.0D0/SQRT( A(JA(ICOL)) ) - 10 CONTINUE - ELSE -C -C UNSCALING... -C - DO 15 ICOL = 1, N - DINV(ICOL) = 1.0D0/DINV(ICOL) - 15 CONTINUE - ENDIF -C - DO 30 ICOL = 1, N - JBGN = JA(ICOL) - JEND = JA(ICOL+1)-1 - DI = DINV(ICOL) - DO 20 J = JBGN, JEND - A(J) = DINV(IA(J))*A(J)*DI - 20 CONTINUE - 30 CONTINUE -C - DO 40 ICOL = 1, N - B(ICOL) = B(ICOL)*DINV(ICOL) - X(ICOL) = X(ICOL)/DINV(ICOL) - 40 CONTINUE -C -C Check to see if we need to scale the "true solution" as well. -C - IF( ITOL.EQ.11 ) THEN - DO 50 ICOL = 1, N - SOLN(ICOL) = SOLN(ICOL)/DINV(ICOL) - 50 CONTINUE - ENDIF -C - RETURN -C------------- LAST LINE OF DSDSCL FOLLOWS ---------------------------- - END diff --git a/slatec/dsgs.f b/slatec/dsgs.f deleted file mode 100644 index f958110..0000000 --- a/slatec/dsgs.f +++ /dev/null @@ -1,287 +0,0 @@ -*DECK DSGS - SUBROUTINE DSGS (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, ITMAX, - + ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE DSGS -C***PURPOSE Gauss-Seidel Method Iterative Sparse Ax = b Solver. -C Routine to solve a general linear system Ax = b using -C Gauss-Seidel iteration. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (SSGS-S, DSGS-D) -C***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+2*N+1), LENIW -C DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(NL+3*N) -C -C CALL DSGS(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right-hand side vector. -C X :INOUT Double Precision X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Double Precision A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the lower -C lower triangle of the matrix is stored. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /DSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Double Precision. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Double Precision. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*D1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Double Precision RWORK(LENW). -C Double Precision array used for workspace. -C LENW :IN Integer. -C Length of the double precision workspace, RWORK. -C LENW >= NL+3*N. -C NL is the number of non-zeros in the lower triangle of the -C matrix (including the diagonal). -C IWORK :WORK Integer IWORK(LENIW). -C Integer array used for workspace. -C Upon return the following locations of IWORK hold information -C which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Double Precision workspace actually used. -C LENIW :IN Integer. -C Length of the integer workspace, IWORK. LENIW >= NL+N+11. -C NL is the number of non-zeros in the lower triangle of the -C matrix (including the diagonal). -C -C *Description -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to be -C the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO DSJAC, DIR -C***REFERENCES (NONE) -C***ROUTINES CALLED DCHKW, DIR, DS2LT, DS2Y, DSLI, DSMV -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 921019 Corrected NEL to NL. (FNF) -C***END PROLOGUE DSGS -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - DOUBLE PRECISION ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(N), B(N), RWORK(*), X(N) - INTEGER IA(NELT), IWORK(10), JA(NELT) -C .. Local Scalars .. - INTEGER ICOL, J, JBGN, JEND, LOCDZ, LOCEL, LOCIEL, LOCIW, LOCJEL, - + LOCR, LOCW, LOCZ, NL -C .. External Subroutines .. - EXTERNAL DCHKW, DIR, DS2LT, DS2Y, DSLI, DSMV -C***FIRST EXECUTABLE STATEMENT DSGS -C - IF( N.LT.1 .OR. NELT.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Modify the SLAP matrix data structure to YSMP-Column. - CALL DS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Count number of elements in lower triangle of the matrix. - IF( ISYM.EQ.0 ) THEN - NL = 0 - DO 20 ICOL = 1, N - JBGN = JA(ICOL) - JEND = JA(ICOL+1)-1 - DO 10 J = JBGN, JEND - IF( IA(J).GE.ICOL ) NL = NL + 1 - 10 CONTINUE - 20 CONTINUE - ELSE - NL = JA(N+1)-1 - ENDIF -C -C Set up the work arrays. Then store the lower triangle of -C the matrix. -C - LOCJEL = LOCIB - LOCIEL = LOCJEL + N+1 - LOCIW = LOCIEL + NL -C - LOCEL = LOCRB - LOCR = LOCEL + NL - LOCZ = LOCR + N - LOCDZ = LOCZ + N - LOCW = LOCDZ + N -C -C Check the workspace allocations. - CALL DCHKW( 'DSGS', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(1) = NL - IWORK(2) = LOCIEL - IWORK(3) = LOCJEL - IWORK(4) = LOCEL - IWORK(9) = LOCIW - IWORK(10) = LOCW -C - CALL DS2LT( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIEL), - $ IWORK(LOCJEL), RWORK(LOCEL) ) -C -C Call iterative refinement routine. - CALL DIR(N, B, X, NELT, IA, JA, A, ISYM, DSMV, DSLI, - $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), - $ RWORK(LOCZ), RWORK(LOCDZ), RWORK, IWORK ) -C -C Set the amount of Integer and Double Precision Workspace used. - IWORK(9) = LOCIW+N+NELT - IWORK(10) = LOCW+NELT - RETURN -C------------- LAST LINE OF DSGS FOLLOWS ------------------------------ - END diff --git a/slatec/dsiccg.f b/slatec/dsiccg.f deleted file mode 100644 index 0a1819a..0000000 --- a/slatec/dsiccg.f +++ /dev/null @@ -1,315 +0,0 @@ -*DECK DSICCG - SUBROUTINE DSICCG (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, - + ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE DSICCG -C***PURPOSE Incomplete Cholesky Conjugate Gradient Sparse Ax=b Solver. -C Routine to solve a symmetric positive definite linear -C system Ax = b using the incomplete Cholesky -C Preconditioned Conjugate Gradient method. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2B4 -C***TYPE DOUBLE PRECISION (SSICCG-S, DSICCG-D) -C***KEYWORDS INCOMPLETE CHOLESKY, ITERATIVE PRECONDITION, SLAP, SPARSE, -C SYMMETRIC LINEAR SYSTEM -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+2*N+1), LENIW -C DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(NL+5*N) -C -C CALL DSICCG(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right-hand side vector. -C X :INOUT Double Precision X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Double Precision A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /DSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Double Precision. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Double Precision. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*D1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. -C IERR = 7 => Incomplete factorization broke down and was -C fudged. Resulting preconditioning may be less -C than the best. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Double Precision RWORK(LENW). -C Double Precision array used for workspace. -C LENW :IN Integer. -C Length of the double precision workspace, RWORK. -C LENW >= NL+5*N. -C NL is the number of non-zeros in the lower triangle of the -C matrix (including the diagonal). -C IWORK :WORK Integer IWORK(LENIW). -C Integer array used for workspace. -C Upon return the following locations of IWORK hold information -C which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Double Precision workspace actually used. -C LENIW :IN Integer. -C Length of the integer workspace, IWORK. LENIW >= NL+N+11. -C NL is the number of non-zeros in the lower triangle of the -C matrix (including the diagonal). -C -C *Description: -C This routine performs preconditioned conjugate gradient -C method on the symmetric positive definite linear system -C Ax=b. The preconditioner is the incomplete Cholesky (IC) -C factorization of the matrix A. See DSICS for details about -C the incomplete factorization algorithm. One should note -C here however, that the IC factorization is a slow process -C and that one should save factorizations for reuse, if -C possible. The MSOLVE operation (handled in DSLLTI) does -C vectorize on machines with hardware gather/scatter and is -C quite fast. -C -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to be -C the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO DCG, DSLLTI -C***REFERENCES 1. Louis Hageman and David Young, Applied Iterative -C Methods, Academic Press, New York, 1981. -C 2. Concus, Golub and O'Leary, A Generalized Conjugate -C Gradient Method for the Numerical Solution of -C Elliptic Partial Differential Equations, in Sparse -C Matrix Computations, Bunch and Rose, Eds., Academic -C Press, New York, 1979. -C***ROUTINES CALLED DCG, DCHKW, DS2Y, DSICS, DSLLTI, DSMV, XERMSG -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 900805 Changed XERRWV calls to calls to XERMSG. (RWC) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of references. (FNF) -C 921019 Corrected NEL to NL. (FNF) -C***END PROLOGUE DSICCG -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - DOUBLE PRECISION ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER LOCDIN, LOCDZ, LOCEL, LOCIEL, LOCIW, LOCJEL, LOCP, LOCR, - + LOCW, LOCZ, NL - CHARACTER XERN1*8 -C .. External Subroutines .. - EXTERNAL DCG, DCHKW, DS2Y, DSICS, DSLLTI, DSMV, XERMSG -C***FIRST EXECUTABLE STATEMENT DSICCG -C - IERR = 0 - IF( N.LT.1 .OR. NELT.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Change the SLAP input matrix IA, JA, A to SLAP-Column format. - CALL DS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Count number of elements in lower triangle of the matrix. -C Then set up the work arrays. - IF( ISYM.EQ.0 ) THEN - NL = (NELT + N)/2 - ELSE - NL = NELT - ENDIF -C - LOCJEL = LOCIB - LOCIEL = LOCJEL + NL - LOCIW = LOCIEL + N + 1 -C - LOCEL = LOCRB - LOCDIN = LOCEL + NL - LOCR = LOCDIN + N - LOCZ = LOCR + N - LOCP = LOCZ + N - LOCDZ = LOCP + N - LOCW = LOCDZ + N -C -C Check the workspace allocations. - CALL DCHKW( 'DSICCG', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(1) = NL - IWORK(2) = LOCJEL - IWORK(3) = LOCIEL - IWORK(4) = LOCEL - IWORK(5) = LOCDIN - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Compute the Incomplete Cholesky decomposition. -C - CALL DSICS(N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIEL), - $ IWORK(LOCJEL), RWORK(LOCEL), RWORK(LOCDIN), - $ RWORK(LOCR), IERR ) - IF( IERR.NE.0 ) THEN - WRITE (XERN1, '(I8)') IERR - CALL XERMSG ('SLATEC', 'DSICCG', - $ 'IC factorization broke down on step ' // XERN1 // - $ '. Diagonal was set to unity and factorization proceeded.', - $ 1, 1) - IERR = 7 - ENDIF -C -C Do the Preconditioned Conjugate Gradient. - CALL DCG(N, B, X, NELT, IA, JA, A, ISYM, DSMV, DSLLTI, - $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), - $ RWORK(LOCZ), RWORK(LOCP), RWORK(LOCDZ), RWORK(1), - $ IWORK(1)) - RETURN -C------------- LAST LINE OF DSICCG FOLLOWS ---------------------------- - END diff --git a/slatec/dsico.f b/slatec/dsico.f deleted file mode 100644 index 52bf06f..0000000 --- a/slatec/dsico.f +++ /dev/null @@ -1,261 +0,0 @@ -*DECK DSICO - SUBROUTINE DSICO (A, LDA, N, KPVT, RCOND, Z) -C***BEGIN PROLOGUE DSICO -C***PURPOSE Factor a symmetric matrix by elimination with symmetric -C pivoting and estimate the condition number of the matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1A -C***TYPE DOUBLE PRECISION (SSICO-S, DSICO-D, CHICO-C, CSICO-C) -C***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, -C MATRIX FACTORIZATION, SYMMETRIC -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C DSICO factors a double precision symmetric matrix by elimination -C with symmetric pivoting and estimates the condition of the -C matrix. -C -C If RCOND is not needed, DSIFA is slightly faster. -C To solve A*X = B , follow DSICO by DSISL. -C To compute INVERSE(A)*C , follow DSICO by DSISL. -C To compute INVERSE(A) , follow DSICO by DSIDI. -C To compute DETERMINANT(A) , follow DSICO by DSIDI. -C To compute INERTIA(A), follow DSICO by DSIDI. -C -C On Entry -C -C A DOUBLE PRECISION(LDA, N) -C the symmetric matrix to be factored. -C Only the diagonal and upper triangle are used. -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 Output -C -C A a block diagonal matrix and the multipliers which -C were used to obtain it. -C The factorization can be written A = U*D*TRANS(U) -C where U is a product of permutation and unit -C upper triangular matrices, TRANS(U) is the -C transpose of U , and D is block diagonal -C with 1 by 1 and 2 by 2 blocks. -C -C KPVT 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***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DASUM, DAXPY, DDOT, DSCAL, DSIFA -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Modified routine equivalence list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DSICO - INTEGER LDA,N,KPVT(*) - DOUBLE PRECISION A(LDA,*),Z(*) - DOUBLE PRECISION RCOND -C - DOUBLE PRECISION AK,AKM1,BK,BKM1,DDOT,DENOM,EK,T - DOUBLE PRECISION ANORM,S,DASUM,YNORM - INTEGER I,INFO,J,JM1,K,KP,KPS,KS -C -C FIND NORM OF A USING ONLY UPPER HALF -C -C***FIRST EXECUTABLE STATEMENT DSICO - DO 30 J = 1, N - Z(J) = DASUM(J,A(1,J),1) - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 20 - DO 10 I = 1, JM1 - Z(I) = Z(I) + ABS(A(I,J)) - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - ANORM = 0.0D0 - DO 40 J = 1, N - ANORM = MAX(ANORM,Z(J)) - 40 CONTINUE -C -C FACTOR -C - CALL DSIFA(A,LDA,N,KPVT,INFO) -C -C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . -C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . -C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL -C GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . -C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. -C -C SOLVE U*D*W = E -C - EK = 1.0D0 - DO 50 J = 1, N - Z(J) = 0.0D0 - 50 CONTINUE - K = N - 60 IF (K .EQ. 0) GO TO 120 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - KP = ABS(KPVT(K)) - KPS = K + 1 - KS - IF (KP .EQ. KPS) GO TO 70 - T = Z(KPS) - Z(KPS) = Z(KP) - Z(KP) = T - 70 CONTINUE - IF (Z(K) .NE. 0.0D0) EK = SIGN(EK,Z(K)) - Z(K) = Z(K) + EK - CALL DAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) - IF (KS .EQ. 1) GO TO 80 - IF (Z(K-1) .NE. 0.0D0) EK = SIGN(EK,Z(K-1)) - Z(K-1) = Z(K-1) + EK - CALL DAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) - 80 CONTINUE - IF (KS .EQ. 2) GO TO 100 - IF (ABS(Z(K)) .LE. ABS(A(K,K))) GO TO 90 - S = ABS(A(K,K))/ABS(Z(K)) - CALL DSCAL(N,S,Z,1) - EK = S*EK - 90 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 - GO TO 110 - 100 CONTINUE - AK = A(K,K)/A(K-1,K) - AKM1 = A(K-1,K-1)/A(K-1,K) - BK = Z(K)/A(K-1,K) - BKM1 = Z(K-1)/A(K-1,K) - DENOM = AK*AKM1 - 1.0D0 - Z(K) = (AKM1*BK - BKM1)/DENOM - Z(K-1) = (AK*BKM1 - BK)/DENOM - 110 CONTINUE - K = K - KS - GO TO 60 - 120 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) -C -C SOLVE TRANS(U)*Y = W -C - K = 1 - 130 IF (K .GT. N) GO TO 160 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. 1) GO TO 150 - Z(K) = Z(K) + DDOT(K-1,A(1,K),1,Z(1),1) - IF (KS .EQ. 2) - 1 Z(K+1) = Z(K+1) + DDOT(K-1,A(1,K+1),1,Z(1),1) - KP = ABS(KPVT(K)) - IF (KP .EQ. K) GO TO 140 - T = Z(K) - Z(K) = Z(KP) - Z(KP) = T - 140 CONTINUE - 150 CONTINUE - K = K + KS - GO TO 130 - 160 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) -C - YNORM = 1.0D0 -C -C SOLVE U*D*V = Y -C - K = N - 170 IF (K .EQ. 0) GO TO 230 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. KS) GO TO 190 - KP = ABS(KPVT(K)) - KPS = K + 1 - KS - IF (KP .EQ. KPS) GO TO 180 - T = Z(KPS) - Z(KPS) = Z(KP) - Z(KP) = T - 180 CONTINUE - CALL DAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) - IF (KS .EQ. 2) CALL DAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) - 190 CONTINUE - IF (KS .EQ. 2) GO TO 210 - IF (ABS(Z(K)) .LE. ABS(A(K,K))) GO TO 200 - S = ABS(A(K,K))/ABS(Z(K)) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM - 200 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 - GO TO 220 - 210 CONTINUE - AK = A(K,K)/A(K-1,K) - AKM1 = A(K-1,K-1)/A(K-1,K) - BK = Z(K)/A(K-1,K) - BKM1 = Z(K-1)/A(K-1,K) - DENOM = AK*AKM1 - 1.0D0 - Z(K) = (AKM1*BK - BKM1)/DENOM - Z(K-1) = (AK*BKM1 - BK)/DENOM - 220 CONTINUE - K = K - KS - GO TO 170 - 230 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE TRANS(U)*Z = V -C - K = 1 - 240 IF (K .GT. N) GO TO 270 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. 1) GO TO 260 - Z(K) = Z(K) + DDOT(K-1,A(1,K),1,Z(1),1) - IF (KS .EQ. 2) - 1 Z(K+1) = Z(K+1) + DDOT(K-1,A(1,K+1),1,Z(1),1) - KP = ABS(KPVT(K)) - IF (KP .EQ. K) GO TO 250 - T = Z(K) - Z(K) = Z(KP) - Z(KP) = T - 250 CONTINUE - 260 CONTINUE - K = K + KS - GO TO 240 - 270 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 diff --git a/slatec/dsics.f b/slatec/dsics.f deleted file mode 100644 index 2e3b45b..0000000 --- a/slatec/dsics.f +++ /dev/null @@ -1,342 +0,0 @@ -*DECK DSICS - SUBROUTINE DSICS (N, NELT, IA, JA, A, ISYM, NEL, IEL, JEL, EL, D, - + R, IWARN) -C***BEGIN PROLOGUE DSICS -C***PURPOSE Incompl. Cholesky Decomposition Preconditioner SLAP Set Up. -C Routine to generate the Incomplete Cholesky decomposition, -C L*D*L-trans, of a symmetric positive definite matrix, A, -C which is stored in SLAP Column format. The unit lower -C triangular matrix L is stored by rows, and the inverse of -C the diagonal matrix D is stored. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE DOUBLE PRECISION (SSICS-S, DSICS-D) -C***KEYWORDS INCOMPLETE CHOLESKY FACTORIZATION, -C ITERATIVE PRECONDITION, LINEAR SYSTEM, SLAP SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM -C INTEGER NEL, IEL(NEL), JEL(NEL), IWARN -C DOUBLE PRECISION A(NELT), EL(NEL), D(N), R(N) -C -C CALL DSICS( N, NELT, IA, JA, A, ISYM, NEL, IEL, JEL, EL, D, R, -C $ IWARN ) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C NELT :IN Integer. -C Number of elements in arrays IA, JA, and A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Double Precision A(NELT). -C These arrays should hold the matrix A in the SLAP Column -C format. See "Description", below. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the lower -C triangle of the matrix is stored. -C NEL :OUT Integer. -C Number of non-zeros in the lower triangle of A. Also -C corresponds to the length of the IEL, JEL, EL arrays. -C IEL :OUT Integer IEL(NEL). -C JEL :OUT Integer JEL(NEL). -C EL :OUT Double Precision EL(NEL). -C IEL, JEL, EL contain the unit lower triangular factor of the -C incomplete decomposition of the A matrix stored in SLAP -C Row format. The Diagonal of ones *IS* stored. See -C "Description", below for more details about the SLAP Row fmt. -C D :OUT Double Precision D(N) -C Upon return this array holds D(I) = 1./DIAG(A). -C R :WORK Double Precision R(N). -C Temporary double precision workspace needed for the -C factorization. -C IWARN :OUT Integer. -C This is a warning variable and is zero if the IC factoriza- -C tion goes well. It is set to the row index corresponding to -C the last zero pivot found. See "Description", below. -C -C *Description -C =================== S L A P Column format ================== -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C ==================== S L A P Row format ==================== -C -C This routine requires that the matrix A be stored in the -C SLAP Row format. In this format the non-zeros are stored -C counting across rows (except for the diagonal entry, which -C must appear first in each "row") and are stored in the -C double precision array A. In other words, for each row in -C the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going across the row (except the -C diagonal) in order. The JA array holds the column index for -C each non-zero. The IA array holds the offsets into the JA, -C A arrays for the beginning of each row. That is, -C JA(IA(IROW)),A(IA(IROW)) are the first elements of the IROW- -C th row in JA and A, and JA(IA(IROW+1)-1), A(IA(IROW+1)-1) -C are the last elements of the IROW-th row. Note that we -C always have IA(N+1) = NELT+1, where N is the number of rows -C in the matrix and NELT is the number of non-zeros in the -C matrix. -C -C Here is an example of the SLAP Row storage format for a 5x5 -C Matrix (in the A and JA arrays '|' denotes the end of a row): -C -C 5x5 Matrix SLAP Row format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 12 15 | 22 21 | 33 35 | 44 | 55 51 53 -C |21 22 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| IA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C With the SLAP format some of the "inner loops" of this -C routine should vectorize on machines with hardware support -C for vector gather/scatter operations. Your compiler may -C require a compiler directive to convince it that there are -C no implicit vector dependencies. Compiler directives for -C the Alliant FX/Fortran and CRI CFT/CFT77 compilers are -C supplied with the standard SLAP distribution. -C -C The IC factorization does not always exist for SPD matrices. -C In the event that a zero pivot is found it is set to be 1.0 -C and the factorization proceeds. The integer variable IWARN -C is set to the last row where the Diagonal was fudged. This -C eventuality hardly ever occurs in practice. -C -C***SEE ALSO DCG, DSICCG -C***REFERENCES 1. Gene Golub and Charles Van Loan, Matrix Computations, -C Johns Hopkins University Press, Baltimore, Maryland, -C 1983. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 900805 Changed XERRWV calls to calls to XERMSG. (RWC) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of reference. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE DSICS -C .. Scalar Arguments .. - INTEGER ISYM, IWARN, N, NEL, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), D(N), EL(NEL), R(N) - INTEGER IA(NELT), IEL(NEL), JA(NELT), JEL(NEL) -C .. Local Scalars .. - DOUBLE PRECISION ELTMP - INTEGER I, IBGN, IC, ICBGN, ICEND, ICOL, IEND, IR, IRBGN, IREND, - + IROW, IRR, J, JBGN, JELTMP, JEND - CHARACTER XERN1*8 -C .. External Subroutines .. - EXTERNAL XERMSG -C***FIRST EXECUTABLE STATEMENT DSICS -C -C Set the lower triangle in IEL, JEL, EL -C - IWARN = 0 -C -C All matrix elements stored in IA, JA, A. Pick out the lower -C triangle (making sure that the Diagonal of EL is one) and -C store by rows. -C - NEL = 1 - IEL(1) = 1 - JEL(1) = 1 - EL(1) = 1 - D(1) = A(1) -CVD$R NOCONCUR - DO 30 IROW = 2, N -C Put in the Diagonal. - NEL = NEL + 1 - IEL(IROW) = NEL - JEL(NEL) = IROW - EL(NEL) = 1 - D(IROW) = A(JA(IROW)) -C -C Look in all the lower triangle columns for a matching row. -C Since the matrix is symmetric, we can look across the -C IROW-th row by looking down the IROW-th column (if it is -C stored ISYM=0)... - IF( ISYM.EQ.0 ) THEN - ICBGN = JA(IROW) - ICEND = JA(IROW+1)-1 - ELSE - ICBGN = 1 - ICEND = IROW-1 - ENDIF - DO 20 IC = ICBGN, ICEND - IF( ISYM.EQ.0 ) THEN - ICOL = IA(IC) - IF( ICOL.GE.IROW ) GOTO 20 - ELSE - ICOL = IC - ENDIF - JBGN = JA(ICOL)+1 - JEND = JA(ICOL+1)-1 - IF( JBGN.LE.JEND .AND. IA(JEND).GE.IROW ) THEN -CVD$ NOVECTOR - DO 10 J = JBGN, JEND - IF( IA(J).EQ.IROW ) THEN - NEL = NEL + 1 - JEL(NEL) = ICOL - EL(NEL) = A(J) - GOTO 20 - ENDIF - 10 CONTINUE - ENDIF - 20 CONTINUE - 30 CONTINUE - IEL(N+1) = NEL+1 -C -C Sort ROWS of lower triangle into descending order (count out -C along rows out from Diagonal). -C - DO 60 IROW = 2, N - IBGN = IEL(IROW)+1 - IEND = IEL(IROW+1)-1 - IF( IBGN.LT.IEND ) THEN - DO 50 I = IBGN, IEND-1 -CVD$ NOVECTOR - DO 40 J = I+1, IEND - IF( JEL(I).GT.JEL(J) ) THEN - JELTMP = JEL(J) - JEL(J) = JEL(I) - JEL(I) = JELTMP - ELTMP = EL(J) - EL(J) = EL(I) - EL(I) = ELTMP - ENDIF - 40 CONTINUE - 50 CONTINUE - ENDIF - 60 CONTINUE -C -C Perform the Incomplete Cholesky decomposition by looping -C over the rows. -C Scale the first column. Use the structure of A to pick out -C the rows with something in column 1. -C - IRBGN = JA(1)+1 - IREND = JA(2)-1 - DO 65 IRR = IRBGN, IREND - IR = IA(IRR) -C Find the index into EL for EL(1,IR). -C Hint: it's the second entry. - I = IEL(IR)+1 - EL(I) = EL(I)/D(1) - 65 CONTINUE -C - DO 110 IROW = 2, N -C -C Update the IROW-th diagonal. -C - DO 66 I = 1, IROW-1 - R(I) = 0 - 66 CONTINUE - IBGN = IEL(IROW)+1 - IEND = IEL(IROW+1)-1 - IF( IBGN.LE.IEND ) THEN -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ NODEPCHK - DO 70 I = IBGN, IEND - R(JEL(I)) = EL(I)*D(JEL(I)) - D(IROW) = D(IROW) - EL(I)*R(JEL(I)) - 70 CONTINUE -C -C Check to see if we have a problem with the diagonal. -C - IF( D(IROW).LE.0.0D0 ) THEN - IF( IWARN.EQ.0 ) IWARN = IROW - D(IROW) = 1 - ENDIF - ENDIF -C -C Update each EL(IROW+1:N,IROW), if there are any. -C Use the structure of A to determine the Non-zero elements -C of the IROW-th column of EL. -C - IRBGN = JA(IROW) - IREND = JA(IROW+1)-1 - DO 100 IRR = IRBGN, IREND - IR = IA(IRR) - IF( IR.LE.IROW ) GOTO 100 -C Find the index into EL for EL(IR,IROW) - IBGN = IEL(IR)+1 - IEND = IEL(IR+1)-1 - IF( JEL(IBGN).GT.IROW ) GOTO 100 - DO 90 I = IBGN, IEND - IF( JEL(I).EQ.IROW ) THEN - ICEND = IEND - 91 IF( JEL(ICEND).GE.IROW ) THEN - ICEND = ICEND - 1 - GOTO 91 - ENDIF -C Sum up the EL(IR,1:IROW-1)*R(1:IROW-1) contributions. -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ NODEPCHK - DO 80 IC = IBGN, ICEND - EL(I) = EL(I) - EL(IC)*R(JEL(IC)) - 80 CONTINUE - EL(I) = EL(I)/D(IROW) - GOTO 100 - ENDIF - 90 CONTINUE -C -C If we get here, we have real problems... - WRITE (XERN1, '(I8)') IROW - CALL XERMSG ('SLATEC', 'DSICS', - $ 'A and EL data structure mismatch in row '// XERN1, 1, 2) - 100 CONTINUE - 110 CONTINUE -C -C Replace diagonals by their inverses. -C -CVD$ CONCUR - DO 120 I =1, N - D(I) = 1.0D0/D(I) - 120 CONTINUE - RETURN -C------------- LAST LINE OF DSICS FOLLOWS ---------------------------- - END diff --git a/slatec/dsidi.f b/slatec/dsidi.f deleted file mode 100644 index 12a1f26..0000000 --- a/slatec/dsidi.f +++ /dev/null @@ -1,229 +0,0 @@ -*DECK DSIDI - SUBROUTINE DSIDI (A, LDA, N, KPVT, DET, INERT, WORK, JOB) -C***BEGIN PROLOGUE DSIDI -C***PURPOSE Compute the determinant, inertia and inverse of a real -C symmetric matrix using the factors from DSIFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1A, D3B1A -C***TYPE DOUBLE PRECISION (SSIDI-S, DSIDI-D, CHIDI-C, CSIDI-C) -C***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, -C SYMMETRIC -C***AUTHOR Bunch, J., (UCSD) -C***DESCRIPTION -C -C DSIDI computes the determinant, inertia and inverse -C of a double precision symmetric matrix using the factors from -C DSIFA. -C -C On Entry -C -C A DOUBLE PRECISION(LDA,N) -C the output from DSIFA. -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 KPVT INTEGER(N) -C the pivot vector from DSIFA. -C -C WORK DOUBLE PRECISION(N) -C work vector. Contents destroyed. -C -C JOB INTEGER -C JOB has the decimal expansion ABC where -C if C .NE. 0, the inverse is computed, -C if B .NE. 0, the determinant is computed, -C if A .NE. 0, the inertia is computed. -C -C For example, JOB = 111 gives all three. -C -C On Return -C -C Variables not requested by JOB are not used. -C -C A contains the upper triangle of the inverse of -C the original matrix. The strict lower triangle -C is never referenced. -C -C DET DOUBLE PRECISION(2) -C determinant of original matrix. -C DETERMINANT = DET(1) * 10.0**DET(2) -C with 1.0 .LE. ABS(DET(1)) .LT. 10.0 -C or DET(1) = 0.0. -C -C INERT INTEGER(3) -C the inertia of the original matrix. -C INERT(1) = number of positive eigenvalues. -C INERT(2) = number of negative eigenvalues. -C INERT(3) = number of zero eigenvalues. -C -C Error Condition -C -C A division by zero may occur if the inverse is requested -C and DSICO has set RCOND .EQ. 0.0 -C or DSIFA has set INFO .NE. 0 . -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DCOPY, DDOT, DSWAP -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Modified routine equivalence list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DSIDI - INTEGER LDA,N,JOB - DOUBLE PRECISION A(LDA,*),WORK(*) - DOUBLE PRECISION DET(2) - INTEGER KPVT(*),INERT(3) -C - DOUBLE PRECISION AKKP1,DDOT,TEMP - DOUBLE PRECISION TEN,D,T,AK,AKP1 - INTEGER J,JB,K,KM1,KS,KSTEP - LOGICAL NOINV,NODET,NOERT -C***FIRST EXECUTABLE STATEMENT DSIDI - NOINV = MOD(JOB,10) .EQ. 0 - NODET = MOD(JOB,100)/10 .EQ. 0 - NOERT = MOD(JOB,1000)/100 .EQ. 0 -C - IF (NODET .AND. NOERT) GO TO 140 - IF (NOERT) GO TO 10 - INERT(1) = 0 - INERT(2) = 0 - INERT(3) = 0 - 10 CONTINUE - IF (NODET) GO TO 20 - DET(1) = 1.0D0 - DET(2) = 0.0D0 - TEN = 10.0D0 - 20 CONTINUE - T = 0.0D0 - DO 130 K = 1, N - D = A(K,K) -C -C CHECK IF 1 BY 1 -C - IF (KPVT(K) .GT. 0) GO TO 50 -C -C 2 BY 2 BLOCK -C USE DET (D S) = (D/T * C - T) * T , T = ABS(S) -C (S C) -C TO AVOID UNDERFLOW/OVERFLOW TROUBLES. -C TAKE TWO PASSES THROUGH SCALING. USE T FOR FLAG. -C - IF (T .NE. 0.0D0) GO TO 30 - T = ABS(A(K,K+1)) - D = (D/T)*A(K+1,K+1) - T - GO TO 40 - 30 CONTINUE - D = T - T = 0.0D0 - 40 CONTINUE - 50 CONTINUE -C - IF (NOERT) GO TO 60 - IF (D .GT. 0.0D0) INERT(1) = INERT(1) + 1 - IF (D .LT. 0.0D0) INERT(2) = INERT(2) + 1 - IF (D .EQ. 0.0D0) INERT(3) = INERT(3) + 1 - 60 CONTINUE -C - IF (NODET) GO TO 120 - DET(1) = D*DET(1) - IF (DET(1) .EQ. 0.0D0) GO TO 110 - 70 IF (ABS(DET(1)) .GE. 1.0D0) GO TO 80 - DET(1) = TEN*DET(1) - DET(2) = DET(2) - 1.0D0 - GO TO 70 - 80 CONTINUE - 90 IF (ABS(DET(1)) .LT. TEN) GO TO 100 - DET(1) = DET(1)/TEN - DET(2) = DET(2) + 1.0D0 - GO TO 90 - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE - 130 CONTINUE - 140 CONTINUE -C -C COMPUTE INVERSE(A) -C - IF (NOINV) GO TO 270 - K = 1 - 150 IF (K .GT. N) GO TO 260 - KM1 = K - 1 - IF (KPVT(K) .LT. 0) GO TO 180 -C -C 1 BY 1 -C - A(K,K) = 1.0D0/A(K,K) - IF (KM1 .LT. 1) GO TO 170 - CALL DCOPY(KM1,A(1,K),1,WORK,1) - DO 160 J = 1, KM1 - A(J,K) = DDOT(J,A(1,J),1,WORK,1) - CALL DAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1) - 160 CONTINUE - A(K,K) = A(K,K) + DDOT(KM1,WORK,1,A(1,K),1) - 170 CONTINUE - KSTEP = 1 - GO TO 220 - 180 CONTINUE -C -C 2 BY 2 -C - T = ABS(A(K,K+1)) - AK = A(K,K)/T - AKP1 = A(K+1,K+1)/T - AKKP1 = A(K,K+1)/T - D = T*(AK*AKP1 - 1.0D0) - A(K,K) = AKP1/D - A(K+1,K+1) = AK/D - A(K,K+1) = -AKKP1/D - IF (KM1 .LT. 1) GO TO 210 - CALL DCOPY(KM1,A(1,K+1),1,WORK,1) - DO 190 J = 1, KM1 - A(J,K+1) = DDOT(J,A(1,J),1,WORK,1) - CALL DAXPY(J-1,WORK(J),A(1,J),1,A(1,K+1),1) - 190 CONTINUE - A(K+1,K+1) = A(K+1,K+1) + DDOT(KM1,WORK,1,A(1,K+1),1) - A(K,K+1) = A(K,K+1) + DDOT(KM1,A(1,K),1,A(1,K+1),1) - CALL DCOPY(KM1,A(1,K),1,WORK,1) - DO 200 J = 1, KM1 - A(J,K) = DDOT(J,A(1,J),1,WORK,1) - CALL DAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1) - 200 CONTINUE - A(K,K) = A(K,K) + DDOT(KM1,WORK,1,A(1,K),1) - 210 CONTINUE - KSTEP = 2 - 220 CONTINUE -C -C SWAP -C - KS = ABS(KPVT(K)) - IF (KS .EQ. K) GO TO 250 - CALL DSWAP(KS,A(1,KS),1,A(1,K),1) - DO 230 JB = KS, K - J = K + KS - JB - TEMP = A(J,K) - A(J,K) = A(KS,J) - A(KS,J) = TEMP - 230 CONTINUE - IF (KSTEP .EQ. 1) GO TO 240 - TEMP = A(KS,K+1) - A(KS,K+1) = A(K,K+1) - A(K,K+1) = TEMP - 240 CONTINUE - 250 CONTINUE - K = K + KSTEP - GO TO 150 - 260 CONTINUE - 270 CONTINUE - RETURN - END diff --git a/slatec/dsifa.f b/slatec/dsifa.f deleted file mode 100644 index b03f250..0000000 --- a/slatec/dsifa.f +++ /dev/null @@ -1,237 +0,0 @@ -*DECK DSIFA - SUBROUTINE DSIFA (A, LDA, N, KPVT, INFO) -C***BEGIN PROLOGUE DSIFA -C***PURPOSE Factor a real symmetric matrix by elimination with -C symmetric pivoting. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1A -C***TYPE DOUBLE PRECISION (SSIFA-S, DSIFA-D, CHIFA-C, CSIFA-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, SYMMETRIC -C***AUTHOR Bunch, J., (UCSD) -C***DESCRIPTION -C -C DSIFA factors a double precision symmetric matrix by elimination -C with symmetric pivoting. -C -C To solve A*X = B , follow DSIFA by DSISL. -C To compute INVERSE(A)*C , follow DSIFA by DSISL. -C To compute DETERMINANT(A) , follow DSIFA by DSIDI. -C To compute INERTIA(A) , follow DSIFA by DSIDI. -C To compute INVERSE(A) , follow DSIFA by DSIDI. -C -C On Entry -C -C A DOUBLE PRECISION(LDA,N) -C the symmetric matrix to be factored. -C Only the diagonal and upper triangle are used. -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 a block diagonal matrix and the multipliers which -C were used to obtain it. -C The factorization can be written A = U*D*TRANS(U) -C where U is a product of permutation and unit -C upper triangular matrices, TRANS(U) is the -C transpose of U , and D is block diagonal -C with 1 by 1 and 2 by 2 blocks. -C -C KPVT INTEGER(N) -C an integer vector of pivot indices. -C -C INFO INTEGER -C = 0 normal value. -C = K if the K-th pivot block is singular. This is -C not an error condition for this subroutine, -C but it does indicate that DSISL or DSIDI may -C divide by zero if called. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DSWAP, IDAMAX -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Modified routine equivalence list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DSIFA - INTEGER LDA,N,KPVT(*),INFO - DOUBLE PRECISION A(LDA,*) -C - DOUBLE PRECISION AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T - DOUBLE PRECISION ABSAKK,ALPHA,COLMAX,ROWMAX - INTEGER IMAX,IMAXP1,J,JJ,JMAX,K,KM1,KM2,KSTEP,IDAMAX - LOGICAL SWAP -C***FIRST EXECUTABLE STATEMENT DSIFA -C -C INITIALIZE -C -C ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE. -C - ALPHA = (1.0D0 + SQRT(17.0D0))/8.0D0 -C - INFO = 0 -C -C MAIN LOOP ON K, WHICH GOES FROM N TO 1. -C - K = N - 10 CONTINUE -C -C LEAVE THE LOOP IF K=0 OR K=1. -C - IF (K .EQ. 0) GO TO 200 - IF (K .GT. 1) GO TO 20 - KPVT(1) = 1 - IF (A(1,1) .EQ. 0.0D0) INFO = 1 - GO TO 200 - 20 CONTINUE -C -C THIS SECTION OF CODE DETERMINES THE KIND OF -C ELIMINATION TO BE PERFORMED. WHEN IT IS COMPLETED, -C KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND -C SWAP WILL BE SET TO .TRUE. IF AN INTERCHANGE IS -C REQUIRED. -C - KM1 = K - 1 - ABSAKK = ABS(A(K,K)) -C -C DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN -C COLUMN K. -C - IMAX = IDAMAX(K-1,A(1,K),1) - COLMAX = ABS(A(IMAX,K)) - IF (ABSAKK .LT. ALPHA*COLMAX) GO TO 30 - KSTEP = 1 - SWAP = .FALSE. - GO TO 90 - 30 CONTINUE -C -C DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN -C ROW IMAX. -C - ROWMAX = 0.0D0 - IMAXP1 = IMAX + 1 - DO 40 J = IMAXP1, K - ROWMAX = MAX(ROWMAX,ABS(A(IMAX,J))) - 40 CONTINUE - IF (IMAX .EQ. 1) GO TO 50 - JMAX = IDAMAX(IMAX-1,A(1,IMAX),1) - ROWMAX = MAX(ROWMAX,ABS(A(JMAX,IMAX))) - 50 CONTINUE - IF (ABS(A(IMAX,IMAX)) .LT. ALPHA*ROWMAX) GO TO 60 - KSTEP = 1 - SWAP = .TRUE. - GO TO 80 - 60 CONTINUE - IF (ABSAKK .LT. ALPHA*COLMAX*(COLMAX/ROWMAX)) GO TO 70 - KSTEP = 1 - SWAP = .FALSE. - GO TO 80 - 70 CONTINUE - KSTEP = 2 - SWAP = IMAX .NE. KM1 - 80 CONTINUE - 90 CONTINUE - IF (MAX(ABSAKK,COLMAX) .NE. 0.0D0) GO TO 100 -C -C COLUMN K IS ZERO. SET INFO AND ITERATE THE LOOP. -C - KPVT(K) = K - INFO = K - GO TO 190 - 100 CONTINUE - IF (KSTEP .EQ. 2) GO TO 140 -C -C 1 X 1 PIVOT BLOCK. -C - IF (.NOT.SWAP) GO TO 120 -C -C PERFORM AN INTERCHANGE. -C - CALL DSWAP(IMAX,A(1,IMAX),1,A(1,K),1) - DO 110 JJ = IMAX, K - J = K + IMAX - JJ - T = A(J,K) - A(J,K) = A(IMAX,J) - A(IMAX,J) = T - 110 CONTINUE - 120 CONTINUE -C -C PERFORM THE ELIMINATION. -C - DO 130 JJ = 1, KM1 - J = K - JJ - MULK = -A(J,K)/A(K,K) - T = MULK - CALL DAXPY(J,T,A(1,K),1,A(1,J),1) - A(J,K) = MULK - 130 CONTINUE -C -C SET THE PIVOT ARRAY. -C - KPVT(K) = K - IF (SWAP) KPVT(K) = IMAX - GO TO 190 - 140 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - IF (.NOT.SWAP) GO TO 160 -C -C PERFORM AN INTERCHANGE. -C - CALL DSWAP(IMAX,A(1,IMAX),1,A(1,K-1),1) - DO 150 JJ = IMAX, KM1 - J = KM1 + IMAX - JJ - T = A(J,K-1) - A(J,K-1) = A(IMAX,J) - A(IMAX,J) = T - 150 CONTINUE - T = A(K-1,K) - A(K-1,K) = A(IMAX,K) - A(IMAX,K) = T - 160 CONTINUE -C -C PERFORM THE ELIMINATION. -C - KM2 = K - 2 - IF (KM2 .EQ. 0) GO TO 180 - AK = A(K,K)/A(K-1,K) - AKM1 = A(K-1,K-1)/A(K-1,K) - DENOM = 1.0D0 - AK*AKM1 - DO 170 JJ = 1, KM2 - J = KM1 - JJ - BK = A(J,K)/A(K-1,K) - BKM1 = A(J,K-1)/A(K-1,K) - MULK = (AKM1*BK - BKM1)/DENOM - MULKM1 = (AK*BKM1 - BK)/DENOM - T = MULK - CALL DAXPY(J,T,A(1,K),1,A(1,J),1) - T = MULKM1 - CALL DAXPY(J,T,A(1,K-1),1,A(1,J),1) - A(J,K) = MULK - A(J,K-1) = MULKM1 - 170 CONTINUE - 180 CONTINUE -C -C SET THE PIVOT ARRAY. -C - KPVT(K) = 1 - K - IF (SWAP) KPVT(K) = -IMAX - KPVT(K-1) = KPVT(K) - 190 CONTINUE - K = K - KSTEP - GO TO 10 - 200 CONTINUE - RETURN - END diff --git a/slatec/dsilur.f b/slatec/dsilur.f deleted file mode 100644 index d2aed71..0000000 --- a/slatec/dsilur.f +++ /dev/null @@ -1,307 +0,0 @@ -*DECK DSILUR - SUBROUTINE DSILUR (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, - + ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE DSILUR -C***PURPOSE Incomplete LU Iterative Refinement Sparse Ax = b Solver. -C Routine to solve a general linear system Ax = b using -C the incomplete LU decomposition with iterative refinement. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (SSILUR-S, DSILUR-D) -C***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+NU+4*N+2), LENIW -C DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(NL+NU+4*N) -C -C CALL DSILUR(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right-hand side vector. -C X :INOUT Double Precision X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Double Precision A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /DSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Double Precision. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Double Precision. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*D1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. -C IERR = 7 => Incomplete factorization broke down and was -C fudged. Resulting preconditioning may be less -C than the best. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Double Precision RWORK(LENW). -C Double Precision array used for workspace. -C LENW :IN Integer. -C Length of the double precision workspace, RWORK. -C LENW >= NL+NU+4*N. -C NL is the number of non-zeros in the lower triangle of the -C matrix (including the diagonal). -C NU is the number of non-zeros in the upper triangle of the -C matrix (including the diagonal). -C IWORK :WORK Integer IWORK(LENIW). -C Integer array used for workspace. -C Upon return the following locations of IWORK hold information -C which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Double Precision workspace actually used. -C LENIW :IN Integer. -C Length of integer workspace, IWORK. LENIW >= NL+NU+4*N+10. -C NL is the number of non-zeros in the lower triangle of the -C matrix (including the diagonal). -C NU is the number of non-zeros in the upper triangle of the -C matrix (including the diagonal). -C -C *Description -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to be -C the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO DSJAC, DSGS, DIR -C***REFERENCES (NONE) -C***ROUTINES CALLED DCHKW, DIR, DS2Y, DSILUS, DSLUI, DSMV -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 921019 Corrected NEL to NL. (FNF) -C***END PROLOGUE DSILUR -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - DOUBLE PRECISION ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER ICOL, J, JBGN, JEND, LOCDIN, LOCDZ, LOCIL, LOCIU, LOCIW, - + LOCJL, LOCJU, LOCL, LOCNC, LOCNR, LOCR, LOCU, LOCW, LOCZ, - + NL, NU -C .. External Subroutines .. - EXTERNAL DCHKW, DIR, DS2Y, DSILUS, DSLUI, DSMV -C***FIRST EXECUTABLE STATEMENT DSILUR -C - IERR = 0 - IF( N.LT.1 .OR. NELT.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Change the SLAP input matrix IA, JA, A to SLAP-Column format. - CALL DS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Count number of Non-Zero elements in preconditioner ILU -C matrix. Then set up the work arrays. - NL = 0 - NU = 0 - DO 20 ICOL = 1, N -C Don't count diagonal. - JBGN = JA(ICOL)+1 - JEND = JA(ICOL+1)-1 - IF( JBGN.LE.JEND ) THEN -CVD$ NOVECTOR - DO 10 J = JBGN, JEND - IF( IA(J).GT.ICOL ) THEN - NL = NL + 1 - IF( ISYM.NE.0 ) NU = NU + 1 - ELSE - NU = NU + 1 - ENDIF - 10 CONTINUE - ENDIF - 20 CONTINUE -C - LOCIL = LOCIB - LOCJL = LOCIL + N+1 - LOCIU = LOCJL + NL - LOCJU = LOCIU + NU - LOCNR = LOCJU + N+1 - LOCNC = LOCNR + N - LOCIW = LOCNC + N -C - LOCL = LOCRB - LOCDIN = LOCL + NL - LOCU = LOCDIN + N - LOCR = LOCU + NU - LOCZ = LOCR + N - LOCDZ = LOCZ + N - LOCW = LOCDZ + N -C -C Check the workspace allocations. - CALL DCHKW( 'DSILUR', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(1) = LOCIL - IWORK(2) = LOCJL - IWORK(3) = LOCIU - IWORK(4) = LOCJU - IWORK(5) = LOCL - IWORK(6) = LOCDIN - IWORK(7) = LOCU - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Compute the Incomplete LU decomposition. - CALL DSILUS( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIL), - $ IWORK(LOCJL), RWORK(LOCL), RWORK(LOCDIN), NU, IWORK(LOCIU), - $ IWORK(LOCJU), RWORK(LOCU), IWORK(LOCNR), IWORK(LOCNC) ) -C -C Do the Preconditioned Iterative Refinement iteration. - CALL DIR(N, B, X, NELT, IA, JA, A, ISYM, DSMV, DSLUI, - $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), - $ RWORK(LOCZ), RWORK(LOCDZ), RWORK, IWORK) - RETURN -C------------- LAST LINE OF DSILUR FOLLOWS ---------------------------- - END diff --git a/slatec/dsilus.f b/slatec/dsilus.f deleted file mode 100644 index 60848c4..0000000 --- a/slatec/dsilus.f +++ /dev/null @@ -1,361 +0,0 @@ -*DECK DSILUS - SUBROUTINE DSILUS (N, NELT, IA, JA, A, ISYM, NL, IL, JL, L, DINV, - + NU, IU, JU, U, NROW, NCOL) -C***BEGIN PROLOGUE DSILUS -C***PURPOSE Incomplete LU Decomposition Preconditioner SLAP Set Up. -C Routine to generate the incomplete LDU decomposition of a -C matrix. The unit lower triangular factor L is stored by -C rows and the unit upper triangular factor U is stored by -C columns. The inverse of the diagonal matrix D is stored. -C No fill in is allowed. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE DOUBLE PRECISION (SSILUS-S, DSILUS-D) -C***KEYWORDS INCOMPLETE LU FACTORIZATION, ITERATIVE PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM -C INTEGER NL, IL(NL), JL(NL), NU, IU(NU), JU(NU) -C INTEGER NROW(N), NCOL(N) -C DOUBLE PRECISION A(NELT), L(NL), DINV(N), U(NU) -C -C CALL DSILUS( N, NELT, IA, JA, A, ISYM, NL, IL, JL, L, -C $ DINV, NU, IU, JU, U, NROW, NCOL ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C NELT :IN Integer. -C Number of elements in arrays IA, JA, and A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Double Precision A(NELT). -C These arrays should hold the matrix A in the SLAP Column -C format. See "Description", below. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the lower -C triangle of the matrix is stored. -C NL :OUT Integer. -C Number of non-zeros in the L array. -C IL :OUT Integer IL(NL). -C JL :OUT Integer JL(NL). -C L :OUT Double Precision L(NL). -C IL, JL, L contain the unit lower triangular factor of the -C incomplete decomposition of some matrix stored in SLAP -C Row format. The Diagonal of ones *IS* stored. See -C "DESCRIPTION", below for more details about the SLAP format. -C NU :OUT Integer. -C Number of non-zeros in the U array. -C IU :OUT Integer IU(NU). -C JU :OUT Integer JU(NU). -C U :OUT Double Precision U(NU). -C IU, JU, U contain the unit upper triangular factor of the -C incomplete decomposition of some matrix stored in SLAP -C Column format. The Diagonal of ones *IS* stored. See -C "Description", below for more details about the SLAP -C format. -C NROW :WORK Integer NROW(N). -C NROW(I) is the number of non-zero elements in the I-th row -C of L. -C NCOL :WORK Integer NCOL(N). -C NCOL(I) is the number of non-zero elements in the I-th -C column of U. -C -C *Description -C IL, JL, L should contain the unit lower triangular factor of -C the incomplete decomposition of the A matrix stored in SLAP -C Row format. IU, JU, U should contain the unit upper factor -C of the incomplete decomposition of the A matrix stored in -C SLAP Column format This ILU factorization can be computed by -C the DSILUS routine. The diagonals (which are all one's) are -C stored. -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C ==================== S L A P Row format ==================== -C -C This routine requires that the matrix A be stored in the -C SLAP Row format. In this format the non-zeros are stored -C counting across rows (except for the diagonal entry, which -C must appear first in each "row") and are stored in the -C double precision array A. In other words, for each row in -C the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going across the row (except the -C diagonal) in order. The JA array holds the column index for -C each non-zero. The IA array holds the offsets into the JA, -C A arrays for the beginning of each row. That is, -C JA(IA(IROW)),A(IA(IROW)) are the first elements of the IROW- -C th row in JA and A, and JA(IA(IROW+1)-1), A(IA(IROW+1)-1) -C are the last elements of the IROW-th row. Note that we -C always have IA(N+1) = NELT+1, where N is the number of rows -C in the matrix and NELT is the number of non-zeros in the -C matrix. -C -C Here is an example of the SLAP Row storage format for a 5x5 -C Matrix (in the A and JA arrays '|' denotes the end of a row): -C -C 5x5 Matrix SLAP Row format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 12 15 | 22 21 | 33 35 | 44 | 55 51 53 -C |21 22 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| IA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C***SEE ALSO SILUR -C***REFERENCES 1. Gene Golub and Charles Van Loan, Matrix Computations, -C Johns Hopkins University Press, Baltimore, Maryland, -C 1983. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of reference. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE DSILUS -C .. Scalar Arguments .. - INTEGER ISYM, N, NELT, NL, NU -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), DINV(N), L(NL), U(NU) - INTEGER IA(NELT), IL(NL), IU(NU), JA(NELT), JL(NL), JU(NU), - + NCOL(N), NROW(N) -C .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, IBGN, ICOL, IEND, INDX, INDX1, INDX2, INDXC1, INDXC2, - + INDXR1, INDXR2, IROW, ITEMP, J, JBGN, JEND, JTEMP, K, KC, - + KR -C***FIRST EXECUTABLE STATEMENT DSILUS -C -C Count number of elements in each row of the lower triangle. -C - DO 10 I=1,N - NROW(I) = 0 - NCOL(I) = 0 - 10 CONTINUE -CVD$R NOCONCUR -CVD$R NOVECTOR - DO 30 ICOL = 1, N - JBGN = JA(ICOL)+1 - JEND = JA(ICOL+1)-1 - IF( JBGN.LE.JEND ) THEN - DO 20 J = JBGN, JEND - IF( IA(J).LT.ICOL ) THEN - NCOL(ICOL) = NCOL(ICOL) + 1 - ELSE - NROW(IA(J)) = NROW(IA(J)) + 1 - IF( ISYM.NE.0 ) NCOL(IA(J)) = NCOL(IA(J)) + 1 - ENDIF - 20 CONTINUE - ENDIF - 30 CONTINUE - JU(1) = 1 - IL(1) = 1 - DO 40 ICOL = 1, N - IL(ICOL+1) = IL(ICOL) + NROW(ICOL) - JU(ICOL+1) = JU(ICOL) + NCOL(ICOL) - NROW(ICOL) = IL(ICOL) - NCOL(ICOL) = JU(ICOL) - 40 CONTINUE -C -C Copy the matrix A into the L and U structures. - DO 60 ICOL = 1, N - DINV(ICOL) = A(JA(ICOL)) - JBGN = JA(ICOL)+1 - JEND = JA(ICOL+1)-1 - IF( JBGN.LE.JEND ) THEN - DO 50 J = JBGN, JEND - IROW = IA(J) - IF( IROW.LT.ICOL ) THEN -C Part of the upper triangle. - IU(NCOL(ICOL)) = IROW - U(NCOL(ICOL)) = A(J) - NCOL(ICOL) = NCOL(ICOL) + 1 - ELSE -C Part of the lower triangle (stored by row). - JL(NROW(IROW)) = ICOL - L(NROW(IROW)) = A(J) - NROW(IROW) = NROW(IROW) + 1 - IF( ISYM.NE.0 ) THEN -C Symmetric...Copy lower triangle into upper triangle as well. - IU(NCOL(IROW)) = ICOL - U(NCOL(IROW)) = A(J) - NCOL(IROW) = NCOL(IROW) + 1 - ENDIF - ENDIF - 50 CONTINUE - ENDIF - 60 CONTINUE -C -C Sort the rows of L and the columns of U. - DO 110 K = 2, N - JBGN = JU(K) - JEND = JU(K+1)-1 - IF( JBGN.LT.JEND ) THEN - DO 80 J = JBGN, JEND-1 - DO 70 I = J+1, JEND - IF( IU(J).GT.IU(I) ) THEN - ITEMP = IU(J) - IU(J) = IU(I) - IU(I) = ITEMP - TEMP = U(J) - U(J) = U(I) - U(I) = TEMP - ENDIF - 70 CONTINUE - 80 CONTINUE - ENDIF - IBGN = IL(K) - IEND = IL(K+1)-1 - IF( IBGN.LT.IEND ) THEN - DO 100 I = IBGN, IEND-1 - DO 90 J = I+1, IEND - IF( JL(I).GT.JL(J) ) THEN - JTEMP = JU(I) - JU(I) = JU(J) - JU(J) = JTEMP - TEMP = L(I) - L(I) = L(J) - L(J) = TEMP - ENDIF - 90 CONTINUE - 100 CONTINUE - ENDIF - 110 CONTINUE -C -C Perform the incomplete LDU decomposition. - DO 300 I=2,N -C -C I-th row of L - INDX1 = IL(I) - INDX2 = IL(I+1) - 1 - IF(INDX1 .GT. INDX2) GO TO 200 - DO 190 INDX=INDX1,INDX2 - IF(INDX .EQ. INDX1) GO TO 180 - INDXR1 = INDX1 - INDXR2 = INDX - 1 - INDXC1 = JU(JL(INDX)) - INDXC2 = JU(JL(INDX)+1) - 1 - IF(INDXC1 .GT. INDXC2) GO TO 180 - 160 KR = JL(INDXR1) - 170 KC = IU(INDXC1) - IF(KR .GT. KC) THEN - INDXC1 = INDXC1 + 1 - IF(INDXC1 .LE. INDXC2) GO TO 170 - ELSEIF(KR .LT. KC) THEN - INDXR1 = INDXR1 + 1 - IF(INDXR1 .LE. INDXR2) GO TO 160 - ELSEIF(KR .EQ. KC) THEN - L(INDX) = L(INDX) - L(INDXR1)*DINV(KC)*U(INDXC1) - INDXR1 = INDXR1 + 1 - INDXC1 = INDXC1 + 1 - IF(INDXR1 .LE. INDXR2 .AND. INDXC1 .LE. INDXC2) GO TO 160 - ENDIF - 180 L(INDX) = L(INDX)/DINV(JL(INDX)) - 190 CONTINUE -C -C I-th column of U - 200 INDX1 = JU(I) - INDX2 = JU(I+1) - 1 - IF(INDX1 .GT. INDX2) GO TO 260 - DO 250 INDX=INDX1,INDX2 - IF(INDX .EQ. INDX1) GO TO 240 - INDXC1 = INDX1 - INDXC2 = INDX - 1 - INDXR1 = IL(IU(INDX)) - INDXR2 = IL(IU(INDX)+1) - 1 - IF(INDXR1 .GT. INDXR2) GO TO 240 - 210 KR = JL(INDXR1) - 220 KC = IU(INDXC1) - IF(KR .GT. KC) THEN - INDXC1 = INDXC1 + 1 - IF(INDXC1 .LE. INDXC2) GO TO 220 - ELSEIF(KR .LT. KC) THEN - INDXR1 = INDXR1 + 1 - IF(INDXR1 .LE. INDXR2) GO TO 210 - ELSEIF(KR .EQ. KC) THEN - U(INDX) = U(INDX) - L(INDXR1)*DINV(KC)*U(INDXC1) - INDXR1 = INDXR1 + 1 - INDXC1 = INDXC1 + 1 - IF(INDXR1 .LE. INDXR2 .AND. INDXC1 .LE. INDXC2) GO TO 210 - ENDIF - 240 U(INDX) = U(INDX)/DINV(IU(INDX)) - 250 CONTINUE -C -C I-th diagonal element - 260 INDXR1 = IL(I) - INDXR2 = IL(I+1) - 1 - IF(INDXR1 .GT. INDXR2) GO TO 300 - INDXC1 = JU(I) - INDXC2 = JU(I+1) - 1 - IF(INDXC1 .GT. INDXC2) GO TO 300 - 270 KR = JL(INDXR1) - 280 KC = IU(INDXC1) - IF(KR .GT. KC) THEN - INDXC1 = INDXC1 + 1 - IF(INDXC1 .LE. INDXC2) GO TO 280 - ELSEIF(KR .LT. KC) THEN - INDXR1 = INDXR1 + 1 - IF(INDXR1 .LE. INDXR2) GO TO 270 - ELSEIF(KR .EQ. KC) THEN - DINV(I) = DINV(I) - L(INDXR1)*DINV(KC)*U(INDXC1) - INDXR1 = INDXR1 + 1 - INDXC1 = INDXC1 + 1 - IF(INDXR1 .LE. INDXR2 .AND. INDXC1 .LE. INDXC2) GO TO 270 - ENDIF -C - 300 CONTINUE -C -C Replace diagonal elements by their inverses. -CVD$ VECTOR - DO 430 I=1,N - DINV(I) = 1.0D0/DINV(I) - 430 CONTINUE -C - RETURN -C------------- LAST LINE OF DSILUS FOLLOWS ---------------------------- - END diff --git a/slatec/dsindg.f b/slatec/dsindg.f deleted file mode 100644 index ba5e21e..0000000 --- a/slatec/dsindg.f +++ /dev/null @@ -1,36 +0,0 @@ -*DECK DSINDG - DOUBLE PRECISION FUNCTION DSINDG (X) -C***BEGIN PROLOGUE DSINDG -C***PURPOSE Compute the sine of an argument in degrees. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4A -C***TYPE DOUBLE PRECISION (SINDG-S, DSINDG-D) -C***KEYWORDS DEGREES, ELEMENTARY FUNCTIONS, FNLIB, SINE, TRIGONOMETRIC -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DSINDG(X) calculates the double precision sine for double -C precision argument X where X is in degrees. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 770601 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***END PROLOGUE DSINDG - DOUBLE PRECISION X, RADDEG - SAVE RADDEG - DATA RADDEG / 0.0174532925 1994329576 9236907684 886 D0 / -C***FIRST EXECUTABLE STATEMENT DSINDG - DSINDG = SIN (RADDEG*X) -C - IF (MOD(X,90.D0).NE.0.D0) RETURN - N = ABS(X)/90.D0 + 0.5D0 - N = MOD (N, 2) - IF (N.EQ.0) DSINDG = 0.D0 - IF (N.EQ.1) DSINDG = SIGN (1.0D0, DSINDG) -C - RETURN - END diff --git a/slatec/dsisl.f b/slatec/dsisl.f deleted file mode 100644 index b32121e..0000000 --- a/slatec/dsisl.f +++ /dev/null @@ -1,187 +0,0 @@ -*DECK DSISL - SUBROUTINE DSISL (A, LDA, N, KPVT, B) -C***BEGIN PROLOGUE DSISL -C***PURPOSE Solve a real symmetric system using the factors obtained -C from SSIFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1A -C***TYPE DOUBLE PRECISION (SSISL-S, DSISL-D, CHISL-C, CSISL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE, SYMMETRIC -C***AUTHOR Bunch, J., (UCSD) -C***DESCRIPTION -C -C DSISL solves the double precision symmetric system -C A * X = B -C using the factors computed by DSIFA. -C -C On Entry -C -C A DOUBLE PRECISION(LDA,N) -C the output from DSIFA. -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 KPVT INTEGER(N) -C the pivot vector from DSIFA. -C -C B DOUBLE PRECISION(N) -C the right hand side vector. -C -C On Return -C -C B the solution vector X . -C -C Error Condition -C -C A division by zero may occur if DSICO has set RCOND .EQ. 0.0 -C or DSIFA has set INFO .NE. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL DSIFA(A,LDA,N,KPVT,INFO) -C IF (INFO .NE. 0) GO TO ... -C DO 10 J = 1, P -C CALL DSISL(A,LDA,N,KPVT,C(1,J)) -C 10 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DDOT -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Modified routine equivalence list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DSISL - INTEGER LDA,N,KPVT(*) - DOUBLE PRECISION A(LDA,*),B(*) -C - DOUBLE PRECISION AK,AKM1,BK,BKM1,DDOT,DENOM,TEMP - INTEGER K,KP -C -C LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND -C D INVERSE TO B. -C -C***FIRST EXECUTABLE STATEMENT DSISL - K = N - 10 IF (K .EQ. 0) GO TO 80 - IF (KPVT(K) .LT. 0) GO TO 40 -C -C 1 X 1 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 30 - KP = KPVT(K) - IF (KP .EQ. K) GO TO 20 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 20 CONTINUE -C -C APPLY THE TRANSFORMATION. -C - CALL DAXPY(K-1,B(K),A(1,K),1,B(1),1) - 30 CONTINUE -C -C APPLY D INVERSE. -C - B(K) = B(K)/A(K,K) - K = K - 1 - GO TO 70 - 40 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - IF (K .EQ. 2) GO TO 60 - KP = ABS(KPVT(K)) - IF (KP .EQ. K - 1) GO TO 50 -C -C INTERCHANGE. -C - TEMP = B(K-1) - B(K-1) = B(KP) - B(KP) = TEMP - 50 CONTINUE -C -C APPLY THE TRANSFORMATION. -C - CALL DAXPY(K-2,B(K),A(1,K),1,B(1),1) - CALL DAXPY(K-2,B(K-1),A(1,K-1),1,B(1),1) - 60 CONTINUE -C -C APPLY D INVERSE. -C - AK = A(K,K)/A(K-1,K) - AKM1 = A(K-1,K-1)/A(K-1,K) - BK = B(K)/A(K-1,K) - BKM1 = B(K-1)/A(K-1,K) - DENOM = AK*AKM1 - 1.0D0 - B(K) = (AKM1*BK - BKM1)/DENOM - B(K-1) = (AK*BKM1 - BK)/DENOM - K = K - 2 - 70 CONTINUE - GO TO 10 - 80 CONTINUE -C -C LOOP FORWARD APPLYING THE TRANSFORMATIONS. -C - K = 1 - 90 IF (K .GT. N) GO TO 160 - IF (KPVT(K) .LT. 0) GO TO 120 -C -C 1 X 1 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 110 -C -C APPLY THE TRANSFORMATION. -C - B(K) = B(K) + DDOT(K-1,A(1,K),1,B(1),1) - KP = KPVT(K) - IF (KP .EQ. K) GO TO 100 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 100 CONTINUE - 110 CONTINUE - K = K + 1 - GO TO 150 - 120 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 140 -C -C APPLY THE TRANSFORMATION. -C - B(K) = B(K) + DDOT(K-1,A(1,K),1,B(1),1) - B(K+1) = B(K+1) + DDOT(K-1,A(1,K+1),1,B(1),1) - KP = ABS(KPVT(K)) - IF (KP .EQ. K) GO TO 130 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 130 CONTINUE - 140 CONTINUE - K = K + 2 - 150 CONTINUE - GO TO 90 - 160 CONTINUE - RETURN - END diff --git a/slatec/dsjac.f b/slatec/dsjac.f deleted file mode 100644 index 05bb7e4..0000000 --- a/slatec/dsjac.f +++ /dev/null @@ -1,263 +0,0 @@ -*DECK DSJAC - SUBROUTINE DSJAC (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, - + ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE DSJAC -C***PURPOSE Jacobi's Method Iterative Sparse Ax = b Solver. -C Routine to solve a general linear system Ax = b using -C Jacobi iteration. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (SSJAC-S, DSJAC-D) -C***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LENW, IWORK(LENIW), LENIW -C DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(LENW) -C -C CALL DSJAC(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right-hand side vector. -C X :INOUT Double Precision X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Double Precision A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /DSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Double Precision. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Double Precision. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*D1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Double Precision RWORK(LENW). -C Double Precision array used for workspace. -C LENW :IN Integer. -C Length of the double precision workspace, RWORK. LENW >= 4*N. -C IWORK :WORK Integer IWORK(LENIW). -C Used to hold pointers into the double precision workspace, -C RWORK. Upon return the following locations of IWORK hold -C information which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Double Precision workspace actually used. -C LENIW :IN Integer. -C Length of the integer workspace, IWORK. LENIW >= 10. -C -C *Description: -C Jacobi's method solves the linear system Ax=b with the -C basic iterative method (where A = L + D + U): -C -C n+1 -1 n n -C X = D (B - LX - UX ) -C -C n -1 n -C = X + D (B - AX ) -C -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which one -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to be -C the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO DSGS, DIR -C***REFERENCES (NONE) -C***ROUTINES CALLED DCHKW, DIR, DS2Y, DSDI, DSDS, DSMV -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910506 Corrected error in C***ROUTINES CALLED list. (FNF) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C***END PROLOGUE DSJAC -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - DOUBLE PRECISION ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER LOCD, LOCDZ, LOCIW, LOCR, LOCW, LOCZ -C .. External Subroutines .. - EXTERNAL DCHKW, DIR, DS2Y, DSDI, DSDS, DSMV -C***FIRST EXECUTABLE STATEMENT DSJAC -C - IERR = 0 - IF( N.LT.1 .OR. NELT.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF - LOCIW = LOCIB - LOCD = LOCRB - LOCR = LOCD + N - LOCZ = LOCR + N - LOCDZ = LOCZ + N - LOCW = LOCDZ + N -C -C Check the workspace allocations. - CALL DCHKW( 'DSJAC', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(4) = LOCD - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Convert to SLAP column format. - CALL DS2Y(N, NELT, IA, JA, A, ISYM ) -C -C Compute the inverse of the diagonal of the matrix. This -C will be used as the preconditioner. - CALL DSDS(N, NELT, IA, JA, A, ISYM, RWORK(LOCD)) -C -C Set up the work array and perform the iterative refinement. - CALL DIR(N, B, X, NELT, IA, JA, A, ISYM, DSMV, DSDI, ITOL, TOL, - $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), RWORK(LOCZ), - $ RWORK(LOCDZ), RWORK, IWORK ) - RETURN -C------------- LAST LINE OF DSJAC FOLLOWS ----------------------------- - END diff --git a/slatec/dsli.f b/slatec/dsli.f deleted file mode 100644 index 321be6b..0000000 --- a/slatec/dsli.f +++ /dev/null @@ -1,61 +0,0 @@ -*DECK DSLI - SUBROUTINE DSLI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C***BEGIN PROLOGUE DSLI -C***PURPOSE SLAP MSOLVE for Lower Triangle Matrix. -C This routine acts as an interface between the SLAP generic -C MSOLVE calling convention and the routine that actually -C -1 -C computes L B = X. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A3 -C***TYPE DOUBLE PRECISION (SSLI-S, DSLI-D) -C***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM SOLVE, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C It is assumed that RWORK and IWORK have initialized with -C the information required for DSLI2: -C IWORK(1) = NEL -C IWORK(2) = Starting location of IEL in IWORK. -C IWORK(3) = Starting location of JEL in IWORK. -C IWORK(4) = Starting location of EL in RWORK. -C See the DESCRIPTION of DSLI2 for details. -C***REFERENCES (NONE) -C***ROUTINES CALLED DSLI2 -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE DSLI -C .. Scalar Arguments .. - INTEGER ISYM, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), B(N), RWORK(*), X(N) - INTEGER IA(NELT), IWORK(10), JA(NELT) -C .. Local Scalars .. - INTEGER LOCEL, LOCIEL, LOCJEL, NEL -C .. External Subroutines .. - EXTERNAL DSLI2 -C***FIRST EXECUTABLE STATEMENT DSLI -C - NEL = IWORK(1) - LOCIEL = IWORK(2) - LOCJEL = IWORK(3) - LOCEL = IWORK(4) - CALL DSLI2(N, B, X, NEL, IWORK(LOCIEL), IWORK(LOCJEL), - $ RWORK(LOCEL)) -C - RETURN -C------------- LAST LINE OF DSLI FOLLOWS ---------------------------- - END diff --git a/slatec/dsli2.f b/slatec/dsli2.f deleted file mode 100644 index 155a41b..0000000 --- a/slatec/dsli2.f +++ /dev/null @@ -1,139 +0,0 @@ -*DECK DSLI2 - SUBROUTINE DSLI2 (N, B, X, NEL, IEL, JEL, EL) -C***BEGIN PROLOGUE DSLI2 -C***PURPOSE SLAP Lower Triangle Matrix Backsolve. -C Routine to solve a system of the form Lx = b , where L -C is a lower triangular matrix. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A3 -C***TYPE DOUBLE PRECISION (SSLI2-S, DSLI2-D) -C***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM SOLVE, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NEL, IEL(NEL), JEL(NEL) -C DOUBLE PRECISION B(N), X(N), EL(NEL) -C -C CALL DSLI2( N, B, X, NEL, IEL, JEL, EL ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right hand side vector. -C X :OUT Double Precision X(N). -C Solution to Lx = b. -C NEL :IN Integer. -C Number of non-zeros in the EL array. -C IEL :IN Integer IEL(NEL). -C JEL :IN Integer JEL(NEL). -C EL :IN Double Precision EL(NEL). -C IEL, JEL, EL contain the unit lower triangular factor of -C the incomplete decomposition of the A matrix stored in -C SLAP Row format. The diagonal of ones *IS* stored. This -C structure can be set up by the DS2LT routine. See the -C "Description", below, for more details about the SLAP Row -C format. -C -C *Description: -C This routine is supplied with the SLAP package as a routine -C to perform the MSOLVE operation in the DIR iteration routine -C for the driver routine DSGS. It must be called via the SLAP -C MSOLVE calling sequence convention interface routine DSLI. -C **** THIS ROUTINE ITSELF DOES NOT CONFORM TO THE **** -C **** SLAP MSOLVE CALLING CONVENTION **** -C -C ==================== S L A P Row format ==================== -C -C This routine requires that the matrix A be stored in the -C SLAP Row format. In this format the non-zeros are stored -C counting across rows (except for the diagonal entry, which -C must appear first in each "row") and are stored in the -C double precision array A. In other words, for each row in -C the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going across the row (except the -C diagonal) in order. The JA array holds the column index for -C each non-zero. The IA array holds the offsets into the JA, -C A arrays for the beginning of each row. That is, -C JA(IA(IROW)),A(IA(IROW)) are the first elements of the IROW- -C th row in JA and A, and JA(IA(IROW+1)-1), A(IA(IROW+1)-1) -C are the last elements of the IROW-th row. Note that we -C always have IA(N+1) = NELT+1, where N is the number of rows -C in the matrix and NELT is the number of non-zeros in the -C matrix. -C -C Here is an example of the SLAP Row storage format for a 5x5 -C Matrix (in the A and JA arrays '|' denotes the end of a row): -C -C 5x5 Matrix SLAP Row format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 12 15 | 22 21 | 33 35 | 44 | 55 51 53 -C |21 22 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| IA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C With the SLAP Row format the "inner loop" of this routine -C should vectorize on machines with hardware support for -C vector gather/scatter operations. Your compiler may require -C a compiler directive to convince it that there are no -C implicit vector dependencies. Compiler directives for the -C Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied -C with the standard SLAP distribution. -C -C***SEE ALSO DSLI -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE DSLI2 -C .. Scalar Arguments .. - INTEGER N, NEL -C .. Array Arguments .. - DOUBLE PRECISION B(N), EL(NEL), X(N) - INTEGER IEL(NEL), JEL(NEL) -C .. Local Scalars .. - INTEGER I, ICOL, J, JBGN, JEND -C***FIRST EXECUTABLE STATEMENT DSLI2 -C -C Initialize the solution by copying the right hands side -C into it. -C - DO 10 I=1,N - X(I) = B(I) - 10 CONTINUE -C -CVD$ NOCONCUR - DO 30 ICOL = 1, N - X(ICOL) = X(ICOL)/EL(JEL(ICOL)) - JBGN = JEL(ICOL) + 1 - JEND = JEL(ICOL+1) - 1 - IF( JBGN.LE.JEND ) THEN -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ NOCONCUR -CVD$ NODEPCHK - DO 20 J = JBGN, JEND - X(IEL(J)) = X(IEL(J)) - EL(J)*X(ICOL) - 20 CONTINUE - ENDIF - 30 CONTINUE -C - RETURN -C------------- LAST LINE OF DSLI2 FOLLOWS ---------------------------- - END diff --git a/slatec/dsllti.f b/slatec/dsllti.f deleted file mode 100644 index 4766390..0000000 --- a/slatec/dsllti.f +++ /dev/null @@ -1,63 +0,0 @@ -*DECK DSLLTI - SUBROUTINE DSLLTI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C***BEGIN PROLOGUE DSLLTI -C***PURPOSE SLAP MSOLVE for LDL' (IC) Factorization. -C This routine acts as an interface between the SLAP generic -C MSOLVE calling convention and the routine that actually -C -1 -C computes (LDL') B = X. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE DOUBLE PRECISION (SSLLTI-S, DSLLTI-D) -C***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM SOLVE, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C It is assumed that RWORK and IWORK have initialized with -C the information required for DLLTI2: -C IWORK(1) = NEL -C IWORK(2) = Starting location of IEL in IWORK. -C IWORK(3) = Starting location of JEL in IWORK. -C IWORK(4) = Starting location of EL in RWORK. -C IWORK(5) = Starting location of DINV in RWORK. -C See the DESCRIPTION of DLLTI2 for details. -C***REFERENCES (NONE) -C***ROUTINES CALLED DLLTI2 -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Corrected conversion error. (FNF) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE DSLLTI -C .. Scalar Arguments .. - INTEGER ISYM, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), B(*), RWORK(*), X(*) - INTEGER IA(NELT), IWORK(*), JA(NELT) -C .. Local Scalars .. - INTEGER LOCDIN, LOCEL, LOCIEL, LOCJEL, NEL -C .. External Subroutines .. - EXTERNAL DLLTI2 -C***FIRST EXECUTABLE STATEMENT DSLLTI - NEL = IWORK(1) - LOCIEL = IWORK(3) - LOCJEL = IWORK(2) - LOCEL = IWORK(4) - LOCDIN = IWORK(5) - CALL DLLTI2(N, B, X, NEL, IWORK(LOCIEL), IWORK(LOCJEL), - $ RWORK(LOCEL), RWORK(LOCDIN)) -C - RETURN -C------------- LAST LINE OF DSLLTI FOLLOWS ---------------------------- - END diff --git a/slatec/dslubc.f b/slatec/dslubc.f deleted file mode 100644 index 7b40f61..0000000 --- a/slatec/dslubc.f +++ /dev/null @@ -1,323 +0,0 @@ -*DECK DSLUBC - SUBROUTINE DSLUBC (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, - + ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE DSLUBC -C***PURPOSE Incomplete LU BiConjugate Gradient Sparse Ax=b Solver. -C Routine to solve a linear system Ax = b using the -C BiConjugate Gradient method with Incomplete LU -C decomposition preconditioning. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (SSLUBC-S, DSLUBC-D) -C***KEYWORDS ITERATIVE INCOMPLETE LU PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+NU+4*N+2), LENIW -C DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(NL+NU+8*N) -C -C CALL DSLUBC(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right-hand side vector. -C X :INOUT Double Precision X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Double Precision A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /DSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Double Precision. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Double Precision. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*D1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. -C IERR = 7 => Incomplete factorization broke down and was -C fudged. Resulting preconditioning may be less -C than the best. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Double Precision RWORK(LENW). -C Double Precision array used for workspace. -C LENW :IN Integer. -C Length of the double precision workspace, RWORK. -C LENW >= NL+NU+8*N. -C NL is the number of non-zeros in the lower triangle of the -C matrix (including the diagonal). -C NU is the number of non-zeros in the upper triangle of the -C matrix (including the diagonal). -C IWORK :WORK Integer IWORK(LENIW). -C Integer array used for workspace. -C Upon return the following locations of IWORK hold information -C which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Double Precision workspace actually used. -C LENIW :IN Integer. -C Length of the integer workspace, IWORK. -C LENIW >= NL+NU+4*N+12. -C NL is the number of non-zeros in the lower triangle of the -C matrix (including the diagonal). -C NU is the number of non-zeros in the upper triangle of the -C matrix (including the diagonal). -C -C *Description: -C This routine is simply a driver for the DBCGN routine. It -C calls the DSILUS routine to set up the preconditioning and -C then calls DBCGN with the appropriate MATVEC, MTTVEC and -C MSOLVE, MTSOLV routines. -C -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to -C be the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO DBCG, DSDBCG -C***REFERENCES (NONE) -C***ROUTINES CALLED DBCG, DCHKW, DS2Y, DSILUS, DSLUI, DSLUTI, DSMTV, -C DSMV -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE DSLUBC -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - DOUBLE PRECISION ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER ICOL, J, JBGN, JEND, LOCDIN, LOCDZ, LOCIL, LOCIU, LOCIW, - + LOCJL, LOCJU, LOCL, LOCNC, LOCNR, LOCP, LOCPP, LOCR, - + LOCRR, LOCU, LOCW, LOCZ, LOCZZ, NL, NU -C .. External Subroutines .. - EXTERNAL DBCG, DCHKW, DS2Y, DSILUS, DSLUI, DSLUTI, DSMTV, DSMV -C***FIRST EXECUTABLE STATEMENT DSLUBC -C - IERR = 0 - IF( N.LT.1 .OR. NELT.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Change the SLAP input matrix IA, JA, A to SLAP-Column format. - CALL DS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Count number of Non-Zero elements preconditioner ILU matrix. -C Then set up the work arrays. - NL = 0 - NU = 0 - DO 20 ICOL = 1, N -C Don't count diagonal. - JBGN = JA(ICOL)+1 - JEND = JA(ICOL+1)-1 - IF( JBGN.LE.JEND ) THEN -CVD$ NOVECTOR - DO 10 J = JBGN, JEND - IF( IA(J).GT.ICOL ) THEN - NL = NL + 1 - IF( ISYM.NE.0 ) NU = NU + 1 - ELSE - NU = NU + 1 - ENDIF - 10 CONTINUE - ENDIF - 20 CONTINUE -C - LOCIL = LOCIB - LOCJL = LOCIL + N+1 - LOCIU = LOCJL + NL - LOCJU = LOCIU + NU - LOCNR = LOCJU + N+1 - LOCNC = LOCNR + N - LOCIW = LOCNC + N -C - LOCL = LOCRB - LOCDIN = LOCL + NL - LOCU = LOCDIN + N - LOCR = LOCU + NU - LOCZ = LOCR + N - LOCP = LOCZ + N - LOCRR = LOCP + N - LOCZZ = LOCRR + N - LOCPP = LOCZZ + N - LOCDZ = LOCPP + N - LOCW = LOCDZ + N -C -C Check the workspace allocations. - CALL DCHKW( 'DSLUBC', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(1) = LOCIL - IWORK(2) = LOCJL - IWORK(3) = LOCIU - IWORK(4) = LOCJU - IWORK(5) = LOCL - IWORK(6) = LOCDIN - IWORK(7) = LOCU - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Compute the Incomplete LU decomposition. - CALL DSILUS( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIL), - $ IWORK(LOCJL), RWORK(LOCL), RWORK(LOCDIN), NU, IWORK(LOCIU), - $ IWORK(LOCJU), RWORK(LOCU), IWORK(LOCNR), IWORK(LOCNC) ) -C -C Perform the incomplete LU preconditioned -C BiConjugate Gradient algorithm. - CALL DBCG(N, B, X, NELT, IA, JA, A, ISYM, DSMV, DSMTV, - $ DSLUI, DSLUTI, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, - $ RWORK(LOCR), RWORK(LOCZ), RWORK(LOCP), - $ RWORK(LOCRR), RWORK(LOCZZ), RWORK(LOCPP), - $ RWORK(LOCDZ), RWORK, IWORK ) - RETURN -C------------- LAST LINE OF DSLUBC FOLLOWS ---------------------------- - END diff --git a/slatec/dslucn.f b/slatec/dslucn.f deleted file mode 100644 index 55cba0e..0000000 --- a/slatec/dslucn.f +++ /dev/null @@ -1,322 +0,0 @@ -*DECK DSLUCN - SUBROUTINE DSLUCN (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, - + ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE DSLUCN -C***PURPOSE Incomplete LU CG Sparse Ax=b Solver for Normal Equations. -C Routine to solve a general linear system Ax = b using the -C incomplete LU decomposition with the Conjugate Gradient -C method applied to the normal equations, viz., AA'y = b, -C x = A'y. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (SSLUCN-S, DSLUCN-D) -C***KEYWORDS ITERATIVE INCOMPLETE LU PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+NU+4*N+2), LENIW -C DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(NL+NU+8*N) -C -C CALL DSLUCN(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right-hand side vector. -C X :INOUT Double Precision X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Double Precision A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /DSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Double Precision. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Double Precision. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*D1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. -C IERR = 7 => Incomplete factorization broke down and was -C fudged. Resulting preconditioning may be less -C than the best. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Double Precision RWORK(LENW). -C Double Precision array used for workspace. -C LENW :IN Integer. -C Length of the double precision workspace, RWORK. -C LENW >= NL+NU+8*N. -C NL is the number of non-zeros in the lower triangle of the -C matrix (including the diagonal). -C NU is the number of non-zeros in the upper triangle of the -C matrix (including the diagonal). -C IWORK :WORK Integer IWORK(LENIW). -C Integer array used for workspace. -C Upon return the following locations of IWORK hold information -C which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Double Precision workspace actually used. -C LENIW :IN Integer. -C Length of the integer workspace, IWORK. -C LENIW >= NL+NU+4*N+12. -C NL is the number of non-zeros in the lower triangle of the -C matrix (including the diagonal). -C NU is the number of non-zeros in the upper triangle of the -C matrix (including the diagonal). -C -C *Description: -C This routine is simply a driver for the DCGN routine. It -C calls the DSILUS routine to set up the preconditioning and then -C calls DCGN with the appropriate MATVEC and MSOLVE routines. -C -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to be -C the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO DCGN, SDCGN, DSILUS -C***REFERENCES (NONE) -C***ROUTINES CALLED DCGN, DCHKW, DS2Y, DSILUS, DSMMTI, DSMTV, DSMV -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE DSLUCN -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - DOUBLE PRECISION ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER ICOL, J, JBGN, JEND, LOCATD, LOCATP, LOCATZ, LOCDIN, - + LOCDZ, LOCIL, LOCIU, LOCIW, LOCJL, LOCJU, LOCL, LOCNC, - + LOCNR, LOCP, LOCR, LOCU, LOCW, LOCZ, NL, NU -C .. External Subroutines .. - EXTERNAL DCGN, DCHKW, DS2Y, DSILUS, DSMMTI, DSMTV, DSMV -C***FIRST EXECUTABLE STATEMENT DSLUCN -C - IERR = 0 - IF( N.LT.1 .OR. NELT.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Change the SLAP input matrix IA, JA, A to SLAP-Column format. - CALL DS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Count number of Non-Zero elements preconditioner ILU matrix. -C Then set up the work arrays. - NL = 0 - NU = 0 - DO 20 ICOL = 1, N -C Don't count diagonal. - JBGN = JA(ICOL)+1 - JEND = JA(ICOL+1)-1 - IF( JBGN.LE.JEND ) THEN -CVD$ NOVECTOR - DO 10 J = JBGN, JEND - IF( IA(J).GT.ICOL ) THEN - NL = NL + 1 - IF( ISYM.NE.0 ) NU = NU + 1 - ELSE - NU = NU + 1 - ENDIF - 10 CONTINUE - ENDIF - 20 CONTINUE -C - LOCIL = LOCIB - LOCJL = LOCIL + N+1 - LOCIU = LOCJL + NL - LOCJU = LOCIU + NU - LOCNR = LOCJU + N+1 - LOCNC = LOCNR + N - LOCIW = LOCNC + N -C - LOCL = LOCRB - LOCDIN = LOCL + NL - LOCU = LOCDIN + N - LOCR = LOCU + NU - LOCZ = LOCR + N - LOCP = LOCZ + N - LOCATP = LOCP + N - LOCATZ = LOCATP + N - LOCDZ = LOCATZ + N - LOCATD = LOCDZ + N - LOCW = LOCATD + N -C -C Check the workspace allocations. - CALL DCHKW( 'DSLUCN', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(1) = LOCIL - IWORK(2) = LOCJL - IWORK(3) = LOCIU - IWORK(4) = LOCJU - IWORK(5) = LOCL - IWORK(6) = LOCDIN - IWORK(7) = LOCU - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Compute the Incomplete LU decomposition. - CALL DSILUS( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIL), - $ IWORK(LOCJL), RWORK(LOCL), RWORK(LOCDIN), NU, IWORK(LOCIU), - $ IWORK(LOCJU), RWORK(LOCU), IWORK(LOCNR), IWORK(LOCNC) ) -C -C Perform Conjugate Gradient algorithm on the normal equations. - CALL DCGN(N, B, X, NELT, IA, JA, A, ISYM, DSMV, DSMTV, DSMMTI, - $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), - $ RWORK(LOCZ), RWORK(LOCP), RWORK(LOCATP), RWORK(LOCATZ), - $ RWORK(LOCDZ), RWORK(LOCATD), RWORK, IWORK ) -C - IF( ITER.GT.ITMAX ) IERR = 2 - RETURN -C------------- LAST LINE OF DSLUCN FOLLOWS ---------------------------- - END diff --git a/slatec/dslucs.f b/slatec/dslucs.f deleted file mode 100644 index 12cfece..0000000 --- a/slatec/dslucs.f +++ /dev/null @@ -1,317 +0,0 @@ -*DECK DSLUCS - SUBROUTINE DSLUCS (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, - + ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE DSLUCS -C***PURPOSE Incomplete LU BiConjugate Gradient Squared Ax=b Solver. -C Routine to solve a linear system Ax = b using the -C BiConjugate Gradient Squared method with Incomplete LU -C decomposition preconditioning. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (SSLUCS-S, DSLUCS-D) -C***KEYWORDS ITERATIVE INCOMPLETE LU PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+NU+4*N+2), LENIW -C DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(NL+NU+8*N) -C -C CALL DSLUCS(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right-hand side vector. -C X :INOUT Double Precision X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Double Precision A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C This routine must calculate the residual from R = A*X - B. -C This is unnatural and hence expensive for this type of iter- -C ative method. ITOL=2 is *STRONGLY* recommended. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv time a vector is the pre- -C conditioning step. This is the *NATURAL* stopping for this -C iterative method and is *STRONGLY* recommended. -C TOL :INOUT Double Precision. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Double Precision. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*D1MACH(3). Iteration proceeded. -C IERR = 5 => Breakdown of the method detected. -C (r0,r) approximately 0. -C IERR = 6 => Stagnation of the method detected. -C (r0,v) approximately 0. -C IERR = 7 => Incomplete factorization broke down and was -C fudged. Resulting preconditioning may be less -C than the best. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Double Precision RWORK(LENW). -C Double Precision array used for workspace. NL is the number -C of non-zeros in the lower triangle of the matrix (including -C the diagonal). NU is the number of non-zeros in the upper -C triangle of the matrix (including the diagonal). -C LENW :IN Integer. -C Length of the double precision workspace, RWORK. -C LENW >= NL+NU+8*N. -C IWORK :WORK Integer IWORK(LENIW). -C Integer array used for workspace. NL is the number of non- -C zeros in the lower triangle of the matrix (including the -C diagonal). NU is the number of non-zeros in the upper -C triangle of the matrix (including the diagonal). -C Upon return the following locations of IWORK hold information -C which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Double Precision workspace actually used. -C LENIW :IN Integer. -C Length of the integer workspace, IWORK. -C LENIW >= NL+NU+4*N+12. -C -C *Description: -C This routine is simply a driver for the DCGSN routine. It -C calls the DSILUS routine to set up the preconditioning and -C then calls DCGSN with the appropriate MATVEC, MTTVEC and -C MSOLVE, MTSOLV routines. -C -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to -C be the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO DCGS, DSDCGS -C***REFERENCES 1. P. Sonneveld, CGS, a fast Lanczos-type solver -C for nonsymmetric linear systems, Delft University -C of Technology Report 84-16, Department of Mathe- -C matics and Informatics, Delft, The Netherlands. -C 2. E. F. Kaasschieter, The solution of non-symmetric -C linear systems by biconjugate gradients or conjugate -C gradients squared, Delft University of Technology -C Report 86-21, Department of Mathematics and Informa- -C tics, Delft, The Netherlands. -C***ROUTINES CALLED DCGS, DCHKW, DS2Y, DSILUS, DSLUI, DSMV -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of references. (FNF) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE DSLUCS -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - DOUBLE PRECISION ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER ICOL, J, JBGN, JEND, LOCDIN, LOCIL, LOCIU, LOCIW, LOCJL, - + LOCJU, LOCL, LOCNC, LOCNR, LOCP, LOCQ, LOCR, LOCR0, LOCU, - + LOCUU, LOCV1, LOCV2, LOCW, NL, NU -C .. External Subroutines .. - EXTERNAL DCGS, DCHKW, DS2Y, DSILUS, DSLUI, DSMV -C***FIRST EXECUTABLE STATEMENT DSLUCS -C - IERR = 0 - IF( N.LT.1 .OR. NELT.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Change the SLAP input matrix IA, JA, A to SLAP-Column format. - CALL DS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Count number of Non-Zero elements preconditioner ILU matrix. -C Then set up the work arrays. - NL = 0 - NU = 0 - DO 20 ICOL = 1, N -C Don't count diagonal. - JBGN = JA(ICOL)+1 - JEND = JA(ICOL+1)-1 - IF( JBGN.LE.JEND ) THEN -CVD$ NOVECTOR - DO 10 J = JBGN, JEND - IF( IA(J).GT.ICOL ) THEN - NL = NL + 1 - IF( ISYM.NE.0 ) NU = NU + 1 - ELSE - NU = NU + 1 - ENDIF - 10 CONTINUE - ENDIF - 20 CONTINUE -C - LOCIL = LOCIB - LOCJL = LOCIL + N+1 - LOCIU = LOCJL + NL - LOCJU = LOCIU + NU - LOCNR = LOCJU + N+1 - LOCNC = LOCNR + N - LOCIW = LOCNC + N -C - LOCL = LOCRB - LOCDIN = LOCL + NL - LOCUU = LOCDIN + N - LOCR = LOCUU + NU - LOCR0 = LOCR + N - LOCP = LOCR0 + N - LOCQ = LOCP + N - LOCU = LOCQ + N - LOCV1 = LOCU + N - LOCV2 = LOCV1 + N - LOCW = LOCV2 + N -C -C Check the workspace allocations. - CALL DCHKW( 'DSLUCS', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(1) = LOCIL - IWORK(2) = LOCJL - IWORK(3) = LOCIU - IWORK(4) = LOCJU - IWORK(5) = LOCL - IWORK(6) = LOCDIN - IWORK(7) = LOCUU - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Compute the Incomplete LU decomposition. - CALL DSILUS( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIL), - $ IWORK(LOCJL), RWORK(LOCL), RWORK(LOCDIN), NU, IWORK(LOCIU), - $ IWORK(LOCJU), RWORK(LOCUU), IWORK(LOCNR), IWORK(LOCNC) ) -C -C Perform the incomplete LU preconditioned -C BiConjugate Gradient Squared algorithm. - CALL DCGS(N, B, X, NELT, IA, JA, A, ISYM, DSMV, - $ DSLUI, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, - $ RWORK(LOCR), RWORK(LOCR0), RWORK(LOCP), - $ RWORK(LOCQ), RWORK(LOCU), RWORK(LOCV1), - $ RWORK(LOCV2), RWORK, IWORK ) - RETURN -C------------- LAST LINE OF DSLUCS FOLLOWS ---------------------------- - END diff --git a/slatec/dslugm.f b/slatec/dslugm.f deleted file mode 100644 index e971227..0000000 --- a/slatec/dslugm.f +++ /dev/null @@ -1,431 +0,0 @@ -*DECK DSLUGM - SUBROUTINE DSLUGM (N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ITOL, - + TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE DSLUGM -C***PURPOSE Incomplete LU GMRES iterative sparse Ax=b solver. -C This routine uses the generalized minimum residual -C (GMRES) method with incomplete LU factorization for -C preconditioning to solve possibly non-symmetric linear -C systems of the form: Ax = b. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (SSLUGM-S, DSLUGM-D) -C***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov -C Hindmarsh, Alan, (LLNL), alanh@llnl.gov -C Seager, Mark K., (LLNL), seager@llnl.gov -C Lawrence Livermore National Laboratory -C PO Box 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NSAVE, ITOL -C INTEGER ITMAX, ITER, IERR, IUNIT, LENW, IWORK(LENIW), LENIW -C DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(LENW) -C -C CALL DSLUGM(N, B, X, NELT, IA, JA, A, ISYM, NSAVE, -C $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, -C $ RWORK, LENW, IWORK, LENIW) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right-hand side vector. -C X :INOUT Double Precision X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Double Precision A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C NSAVE :IN Integer. -C Number of direction vectors to save and orthogonalize against. -C Must be greater than 1. -C ITOL :IN Integer. -C Flag to indicate the type of convergence criterion used. -C ITOL=0 Means the iteration stops when the test described -C below on the residual RL is satisfied. This is -C the "Natural Stopping Criteria" for this routine. -C Other values of ITOL cause extra, otherwise -C unnecessary, computation per iteration and are -C therefore much less efficient. See ISDGMR (the -C stop test routine) for more information. -C ITOL=1 Means the iteration stops when the first test -C described below on the residual RL is satisfied, -C and there is either right or no preconditioning -C being used. -C ITOL=2 Implies that the user is using left -C preconditioning, and the second stopping criterion -C below is used. -C ITOL=3 Means the iteration stops when the third test -C described below on Minv*Residual is satisfied, and -C there is either left or no preconditioning begin -C used. -C ITOL=11 is often useful for checking and comparing -C different routines. For this case, the user must -C supply the "exact" solution or a very accurate -C approximation (one with an error much less than -C TOL) through a common block, -C COMMON /DSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the -C difference between the iterative approximation and -C the user-supplied solution divided by the 2-norm -C of the user-supplied solution is less than TOL. -C Note that this requires the user to set up the -C "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling -C routine. The routine with this declaration should -C be loaded before the stop test so that the correct -C length is used by the loader. This procedure is -C not standard Fortran and may not work correctly on -C your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 -C then this common block is indeed standard Fortran. -C TOL :INOUT Double Precision. -C Convergence criterion, as described below. If TOL is set -C to zero on input, then a default value of 500*(the smallest -C positive magnitude, machine epsilon) is used. -C ITMAX :IN Integer. -C Maximum number of iterations. This routine uses the default -C of NRMAX = ITMAX/NSAVE to determine the when each restart -C should occur. See the description of NRMAX and MAXL in -C DGMRES for a full and frightfully interesting discussion of -C this topic. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Double Precision. -C Error estimate of error in final approximate solution, as -C defined by ITOL. Letting norm() denote the Euclidean -C norm, ERR is defined as follows... -C If ITOL=0, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), -C for right or no preconditioning, and -C ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ -C norm(SB*(M-inverse)*B), -C for left preconditioning. -C If ITOL=1, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), -C since right or no preconditioning -C being used. -C If ITOL=2, then ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ -C norm(SB*(M-inverse)*B), -C since left preconditioning is being -C used. -C If ITOL=3, then ERR = Max |(Minv*(B-A*X(L)))(i)/x(i)| -C i=1,n -C If ITOL=11, then ERR = norm(SB*(X(L)-SOLN))/norm(SB*SOLN). -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient storage allocated for -C RGWK or IGWK. -C IERR = 2 => Routine DPIGMR failed to reduce the norm -C of the current residual on its last call, -C and so the iteration has stalled. In -C this case, X equals the last computed -C approximation. The user must either -C increase MAXL, or choose a different -C initial guess. -C IERR =-1 => Insufficient length for RGWK array. -C IGWK(6) contains the required minimum -C length of the RGWK array. -C IERR =-2 => Inconsistent ITOL and JPRE values. -C For IERR <= 2, RGWK(1) = RHOL, which is the norm on the -C left-hand-side of the relevant stopping test defined -C below associated with the residual for the current -C approximation X(L). -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Double Precision RWORK(LENW). -C Double Precision array of size LENW. -C LENW :IN Integer. -C Length of the double precision workspace, RWORK. -C LENW >= 1 + N*(NSAVE+7) + NSAVE*(NSAVE+3)+NL+NU. -C Here NL is the number of non-zeros in the lower triangle of -C the matrix (including the diagonal) and NU is the number of -C non-zeros in the upper triangle of the matrix (including the -C diagonal). -C For the recommended values, RWORK has size at least -C 131 + 17*N + NL + NU. -C IWORK :INOUT Integer IWORK(LENIW). -C Used to hold pointers into the RWORK array. -C Upon return the following locations of IWORK hold information -C which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Double Precision workspace actually used. -C LENIW :IN Integer. -C Length of the integer workspace, IWORK. -C LENIW >= NL+NU+4*N+32. -C -C *Description: -C DSLUGM solves a linear system A*X = B rewritten in the form: -C -C (SB*A*(M-inverse)*(SX-inverse))*(SX*M*X) = SB*B, -C -C with right preconditioning, or -C -C (SB*(M-inverse)*A*(SX-inverse))*(SX*X) = SB*(M-inverse)*B, -C -C with left preconditioning, where A is an n-by-n double precision -C matrix, X and B are N-vectors, SB and SX are diagonal scaling -C matrices, and M is the Incomplete LU factorization of A. It -C uses preconditioned Krylov subpace methods based on the -C generalized minimum residual method (GMRES). This routine -C is a driver routine which assumes a SLAP matrix data -C structure and sets up the necessary information to do -C diagonal preconditioning and calls the main GMRES routine -C DGMRES for the solution of the linear system. DGMRES -C optionally performs either the full orthogonalization -C version of the GMRES algorithm or an incomplete variant of -C it. Both versions use restarting of the linear iteration by -C default, although the user can disable this feature. -C -C The GMRES algorithm generates a sequence of approximations -C X(L) to the true solution of the above linear system. The -C convergence criteria for stopping the iteration is based on -C the size of the scaled norm of the residual R(L) = B - -C A*X(L). The actual stopping test is either: -C -C norm(SB*(B-A*X(L))) .le. TOL*norm(SB*B), -C -C for right preconditioning, or -C -C norm(SB*(M-inverse)*(B-A*X(L))) .le. -C TOL*norm(SB*(M-inverse)*B), -C -C for left preconditioning, where norm() denotes the Euclidean -C norm, and TOL is a positive scalar less than one input by -C the user. If TOL equals zero when DSLUGM is called, then a -C default value of 500*(the smallest positive magnitude, -C machine epsilon) is used. If the scaling arrays SB and SX -C are used, then ideally they should be chosen so that the -C vectors SX*X(or SX*M*X) and SB*B have all their components -C approximately equal to one in magnitude. If one wants to -C use the same scaling in X and B, then SB and SX can be the -C same array in the calling program. -C -C The following is a list of the other routines and their -C functions used by GMRES: -C DGMRES Contains the matrix structure independent driver -C routine for GMRES. -C DPIGMR Contains the main iteration loop for GMRES. -C DORTH Orthogonalizes a new vector against older basis vectors. -C DHEQR Computes a QR decomposition of a Hessenberg matrix. -C DHELS Solves a Hessenberg least-squares system, using QR -C factors. -C RLCALC Computes the scaled residual RL. -C XLCALC Computes the solution XL. -C ISDGMR User-replaceable stopping routine. -C -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to be -C the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***REFERENCES 1. Peter N. Brown and A. C. Hindmarsh, Reduced Storage -C Matrix Methods in Stiff ODE Systems, Lawrence Liver- -C more National Laboratory Report UCRL-95088, Rev. 1, -C Livermore, California, June 1987. -C***ROUTINES CALLED DCHKW, DGMRES, DS2Y, DSILUS, DSLUI, DSMV -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of references. (FNF) -C 921019 Corrected NEL to NL. (FNF) -C***END PROLOGUE DSLUGM -C The following is for optimized compilation on LLNL/LTSS Crays. -CLLL. OPTIMIZE -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - DOUBLE PRECISION ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, - + NELT, NSAVE -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER ICOL, J, JBGN, JEND, LOCDIN, LOCIGW, LOCIL, LOCIU, LOCIW, - + LOCJL, LOCJU, LOCL, LOCNC, LOCNR, LOCRGW, LOCU, LOCW, - + MYITOL, NL, NU -C .. External Subroutines .. - EXTERNAL DCHKW, DGMRES, DS2Y, DSILUS, DSLUI, DSMV -C***FIRST EXECUTABLE STATEMENT DSLUGM -C - IERR = 0 - ERR = 0 - IF( NSAVE.LE.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Change the SLAP input matrix IA, JA, A to SLAP-Column format. - CALL DS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Count number of Non-Zero elements preconditioner ILU matrix. -C Then set up the work arrays. We assume MAXL=KMP=NSAVE. - NL = 0 - NU = 0 - DO 20 ICOL = 1, N -C Don't count diagonal. - JBGN = JA(ICOL)+1 - JEND = JA(ICOL+1)-1 - IF( JBGN.LE.JEND ) THEN -CVD$ NOVECTOR - DO 10 J = JBGN, JEND - IF( IA(J).GT.ICOL ) THEN - NL = NL + 1 - IF( ISYM.NE.0 ) NU = NU + 1 - ELSE - NU = NU + 1 - ENDIF - 10 CONTINUE - ENDIF - 20 CONTINUE -C - LOCIGW = LOCIB - LOCIL = LOCIGW + 20 - LOCJL = LOCIL + N+1 - LOCIU = LOCJL + NL - LOCJU = LOCIU + NU - LOCNR = LOCJU + N+1 - LOCNC = LOCNR + N - LOCIW = LOCNC + N -C - LOCL = LOCRB - LOCDIN = LOCL + NL - LOCU = LOCDIN + N - LOCRGW = LOCU + NU - LOCW = LOCRGW + 1+N*(NSAVE+6)+NSAVE*(NSAVE+3) -C -C Check the workspace allocations. - CALL DCHKW( 'DSLUGM', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(1) = LOCIL - IWORK(2) = LOCJL - IWORK(3) = LOCIU - IWORK(4) = LOCJU - IWORK(5) = LOCL - IWORK(6) = LOCDIN - IWORK(7) = LOCU - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Compute the Incomplete LU decomposition. - CALL DSILUS( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIL), - $ IWORK(LOCJL), RWORK(LOCL), RWORK(LOCDIN), NU, IWORK(LOCIU), - $ IWORK(LOCJU), RWORK(LOCU), IWORK(LOCNR), IWORK(LOCNC) ) -C -C Perform the Incomplete LU Preconditioned Generalized Minimum -C Residual iteration algorithm. The following DGMRES -C defaults are used MAXL = KMP = NSAVE, JSCAL = 0, -C JPRE = -1, NRMAX = ITMAX/NSAVE - IWORK(LOCIGW ) = NSAVE - IWORK(LOCIGW+1) = NSAVE - IWORK(LOCIGW+2) = 0 - IWORK(LOCIGW+3) = -1 - IWORK(LOCIGW+4) = ITMAX/NSAVE - MYITOL = 0 -C - CALL DGMRES( N, B, X, NELT, IA, JA, A, ISYM, DSMV, DSLUI, - $ MYITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, RWORK, - $ RWORK(LOCRGW), LENW-LOCRGW, IWORK(LOCIGW), 20, - $ RWORK, IWORK ) -C - IF( ITER.GT.ITMAX ) IERR = 2 - RETURN -C------------- LAST LINE OF DSLUGM FOLLOWS ---------------------------- - END diff --git a/slatec/dslui.f b/slatec/dslui.f deleted file mode 100644 index eb4c477..0000000 --- a/slatec/dslui.f +++ /dev/null @@ -1,73 +0,0 @@ -*DECK DSLUI - SUBROUTINE DSLUI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C***BEGIN PROLOGUE DSLUI -C***PURPOSE SLAP MSOLVE for LDU Factorization. -C This routine acts as an interface between the SLAP generic -C MSOLVE calling convention and the routine that actually -C -1 -C computes (LDU) B = X. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE DOUBLE PRECISION (SSLUI-S, DSLUI-D) -C***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM SOLVE, -C SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C It is assumed that RWORK and IWORK have initialized with -C the information required for DSLUI2: -C IWORK(1) = Starting location of IL in IWORK. -C IWORK(2) = Starting location of JL in IWORK. -C IWORK(3) = Starting location of IU in IWORK. -C IWORK(4) = Starting location of JU in IWORK. -C IWORK(5) = Starting location of L in RWORK. -C IWORK(6) = Starting location of DINV in RWORK. -C IWORK(7) = Starting location of U in RWORK. -C See the DESCRIPTION of DSLUI2 for details. -C***REFERENCES (NONE) -C***ROUTINES CALLED DSLUI2 -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE DSLUI -C .. Scalar Arguments .. - INTEGER ISYM, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), B(N), RWORK(*), X(N) - INTEGER IA(NELT), IWORK(10), JA(NELT) -C .. Local Scalars .. - INTEGER LOCDIN, LOCIL, LOCIU, LOCJL, LOCJU, LOCL, LOCU -C .. External Subroutines .. - EXTERNAL DSLUI2 -C***FIRST EXECUTABLE STATEMENT DSLUI -C -C Pull out the locations of the arrays holding the ILU -C factorization. -C - LOCIL = IWORK(1) - LOCJL = IWORK(2) - LOCIU = IWORK(3) - LOCJU = IWORK(4) - LOCL = IWORK(5) - LOCDIN = IWORK(6) - LOCU = IWORK(7) -C -C Solve the system LUx = b - CALL DSLUI2(N, B, X, IWORK(LOCIL), IWORK(LOCJL), RWORK(LOCL), - $ RWORK(LOCDIN), IWORK(LOCIU), IWORK(LOCJU), RWORK(LOCU) ) -C - RETURN -C------------- LAST LINE OF DSLUI FOLLOWS ---------------------------- - END diff --git a/slatec/dslui2.f b/slatec/dslui2.f deleted file mode 100644 index 773f626..0000000 --- a/slatec/dslui2.f +++ /dev/null @@ -1,205 +0,0 @@ -*DECK DSLUI2 - SUBROUTINE DSLUI2 (N, B, X, IL, JL, L, DINV, IU, JU, U) -C***BEGIN PROLOGUE DSLUI2 -C***PURPOSE SLAP Backsolve for LDU Factorization. -C Routine to solve a system of the form L*D*U X = B, -C where L is a unit lower triangular matrix, D is a diagonal -C matrix, and U is a unit upper triangular matrix. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE DOUBLE PRECISION (SSLUI2-S, DSLUI2-D) -C***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM SOLVE, -C SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, IL(NL), JL(NL), IU(NU), JU(NU) -C DOUBLE PRECISION B(N), X(N), L(NL), DINV(N), U(NU) -C -C CALL DSLUI2( N, B, X, IL, JL, L, DINV, IU, JU, U ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right hand side. -C X :OUT Double Precision X(N). -C Solution of L*D*U x = b. -C IL :IN Integer IL(NL). -C JL :IN Integer JL(NL). -C L :IN Double Precision L(NL). -C IL, JL, L contain the unit lower triangular factor of the -C incomplete decomposition of some matrix stored in SLAP Row -C format. The diagonal of ones *IS* stored. This structure -C can be set up by the DSILUS routine. See the -C "Description", below for more details about the SLAP -C format. (NL is the number of non-zeros in the L array.) -C DINV :IN Double Precision DINV(N). -C Inverse of the diagonal matrix D. -C IU :IN Integer IU(NU). -C JU :IN Integer JU(NU). -C U :IN Double Precision U(NU). -C IU, JU, U contain the unit upper triangular factor of the -C incomplete decomposition of some matrix stored in SLAP -C Column format. The diagonal of ones *IS* stored. This -C structure can be set up by the DSILUS routine. See the -C "Description", below for more details about the SLAP -C format. (NU is the number of non-zeros in the U array.) -C -C *Description: -C This routine is supplied with the SLAP package as a routine -C to perform the MSOLVE operation in the SIR and SBCG -C iteration routines for the drivers DSILUR and DSLUBC. It -C must be called via the SLAP MSOLVE calling sequence -C convention interface routine DSLUI. -C **** THIS ROUTINE ITSELF DOES NOT CONFORM TO THE **** -C **** SLAP MSOLVE CALLING CONVENTION **** -C -C IL, JL, L should contain the unit lower triangular factor of -C the incomplete decomposition of the A matrix stored in SLAP -C Row format. IU, JU, U should contain the unit upper factor -C of the incomplete decomposition of the A matrix stored in -C SLAP Column format This ILU factorization can be computed by -C the DSILUS routine. The diagonals (which are all one's) are -C stored. -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C ==================== S L A P Row format ==================== -C -C This routine requires that the matrix A be stored in the -C SLAP Row format. In this format the non-zeros are stored -C counting across rows (except for the diagonal entry, which -C must appear first in each "row") and are stored in the -C double precision array A. In other words, for each row in -C the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going across the row (except the -C diagonal) in order. The JA array holds the column index for -C each non-zero. The IA array holds the offsets into the JA, -C A arrays for the beginning of each row. That is, -C JA(IA(IROW)),A(IA(IROW)) are the first elements of the IROW- -C th row in JA and A, and JA(IA(IROW+1)-1), A(IA(IROW+1)-1) -C are the last elements of the IROW-th row. Note that we -C always have IA(N+1) = NELT+1, where N is the number of rows -C in the matrix and NELT is the number of non-zeros in the -C matrix. -C -C Here is an example of the SLAP Row storage format for a 5x5 -C Matrix (in the A and JA arrays '|' denotes the end of a row): -C -C 5x5 Matrix SLAP Row format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 12 15 | 22 21 | 33 35 | 44 | 55 51 53 -C |21 22 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| IA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C With the SLAP format the "inner loops" of this routine -C should vectorize on machines with hardware support for -C vector gather/scatter operations. Your compiler may require -C a compiler directive to convince it that there are no -C implicit vector dependencies. Compiler directives for the -C Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied -C with the standard SLAP distribution. -C -C***SEE ALSO DSILUS -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE DSLUI2 -C .. Scalar Arguments .. - INTEGER N -C .. Array Arguments .. - DOUBLE PRECISION B(N), DINV(N), L(*), U(*), X(N) - INTEGER IL(*), IU(*), JL(*), JU(*) -C .. Local Scalars .. - INTEGER I, ICOL, IROW, J, JBGN, JEND -C***FIRST EXECUTABLE STATEMENT DSLUI2 -C -C Solve L*Y = B, storing result in X, L stored by rows. -C - DO 10 I = 1, N - X(I) = B(I) - 10 CONTINUE - DO 30 IROW = 2, N - JBGN = IL(IROW) - JEND = IL(IROW+1)-1 - IF( JBGN.LE.JEND ) THEN -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ ASSOC -CVD$ NODEPCHK - DO 20 J = JBGN, JEND - X(IROW) = X(IROW) - L(J)*X(JL(J)) - 20 CONTINUE - ENDIF - 30 CONTINUE -C -C Solve D*Z = Y, storing result in X. - DO 40 I=1,N - X(I) = X(I)*DINV(I) - 40 CONTINUE -C -C Solve U*X = Z, U stored by columns. - DO 60 ICOL = N, 2, -1 - JBGN = JU(ICOL) - JEND = JU(ICOL+1)-1 - IF( JBGN.LE.JEND ) THEN -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ NODEPCHK - DO 50 J = JBGN, JEND - X(IU(J)) = X(IU(J)) - U(J)*X(ICOL) - 50 CONTINUE - ENDIF - 60 CONTINUE -C - RETURN -C------------- LAST LINE OF DSLUI2 FOLLOWS ---------------------------- - END diff --git a/slatec/dslui4.f b/slatec/dslui4.f deleted file mode 100644 index e03538a..0000000 --- a/slatec/dslui4.f +++ /dev/null @@ -1,204 +0,0 @@ -*DECK DSLUI4 - SUBROUTINE DSLUI4 (N, B, X, IL, JL, L, DINV, IU, JU, U) -C***BEGIN PROLOGUE DSLUI4 -C***PURPOSE SLAP Backsolve for LDU Factorization. -C Routine to solve a system of the form (L*D*U)' X = B, -C where L is a unit lower triangular matrix, D is a diagonal -C matrix, and U is a unit upper triangular matrix and ' -C denotes transpose. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE DOUBLE PRECISION (SSLUI4-S, DSLUI4-D) -C***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM SOLVE, -C SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, IL(NL), JL(NL), IU(NU), JU(NU) -C DOUBLE PRECISION B(N), X(N), L(NL), DINV(N), U(NU) -C -C CALL DSLUI4( N, B, X, IL, JL, L, DINV, IU, JU, U ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right hand side. -C X :OUT Double Precision X(N). -C Solution of (L*D*U)trans x = b. -C IL :IN Integer IL(NL). -C JL :IN Integer JL(NL). -C L :IN Double Precision L(NL). -C IL, JL, L contain the unit lower triangular factor of the -C incomplete decomposition of some matrix stored in SLAP Row -C format. The diagonal of ones *IS* stored. This structure -C can be set up by the DSILUS routine. See the -C "Description", below for more details about the SLAP -C format. (NL is the number of non-zeros in the L array.) -C DINV :IN Double Precision DINV(N). -C Inverse of the diagonal matrix D. -C IU :IN Integer IU(NU). -C JU :IN Integer JU(NU). -C U :IN Double Precision U(NU). -C IU, JU, U contain the unit upper triangular factor of the -C incomplete decomposition of some matrix stored in SLAP -C Column format. The diagonal of ones *IS* stored. This -C structure can be set up by the DSILUS routine. See the -C "Description", below for more details about the SLAP -C format. (NU is the number of non-zeros in the U array.) -C -C *Description: -C This routine is supplied with the SLAP package as a routine -C to perform the MTSOLV operation in the SBCG iteration -C routine for the driver DSLUBC. It must be called via the -C SLAP MTSOLV calling sequence convention interface routine -C DSLUTI. -C **** THIS ROUTINE ITSELF DOES NOT CONFORM TO THE **** -C **** SLAP MSOLVE CALLING CONVENTION **** -C -C IL, JL, L should contain the unit lower triangular factor of -C the incomplete decomposition of the A matrix stored in SLAP -C Row format. IU, JU, U should contain the unit upper factor -C of the incomplete decomposition of the A matrix stored in -C SLAP Column format This ILU factorization can be computed by -C the DSILUS routine. The diagonals (which are all one's) are -C stored. -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C ==================== S L A P Row format ==================== -C -C This routine requires that the matrix A be stored in the -C SLAP Row format. In this format the non-zeros are stored -C counting across rows (except for the diagonal entry, which -C must appear first in each "row") and are stored in the -C double precision array A. In other words, for each row in -C the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going across the row (except the -C diagonal) in order. The JA array holds the column index for -C each non-zero. The IA array holds the offsets into the JA, -C A arrays for the beginning of each row. That is, -C JA(IA(IROW)),A(IA(IROW)) are the first elements of the IROW- -C th row in JA and A, and JA(IA(IROW+1)-1), A(IA(IROW+1)-1) -C are the last elements of the IROW-th row. Note that we -C always have IA(N+1) = NELT+1, where N is the number of rows -C in the matrix and NELT is the number of non-zeros in the -C matrix. -C -C Here is an example of the SLAP Row storage format for a 5x5 -C Matrix (in the A and JA arrays '|' denotes the end of a row): -C -C 5x5 Matrix SLAP Row format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 12 15 | 22 21 | 33 35 | 44 | 55 51 53 -C |21 22 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| IA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C With the SLAP format the "inner loops" of this routine -C should vectorize on machines with hardware support for -C vector gather/scatter operations. Your compiler may require -C a compiler directive to convince it that there are no -C implicit vector dependencies. Compiler directives for the -C Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied -C with the standard SLAP distribution. -C -C***SEE ALSO DSILUS -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE DSLUI4 -C .. Scalar Arguments .. - INTEGER N -C .. Array Arguments .. - DOUBLE PRECISION B(N), DINV(N), L(*), U(*), X(N) - INTEGER IL(*), IU(*), JL(*), JU(*) -C .. Local Scalars .. - INTEGER I, ICOL, IROW, J, JBGN, JEND -C***FIRST EXECUTABLE STATEMENT DSLUI4 - DO 10 I=1,N - X(I) = B(I) - 10 CONTINUE -C -C Solve U'*Y = X, storing result in X, U stored by columns. - DO 80 IROW = 2, N - JBGN = JU(IROW) - JEND = JU(IROW+1) - 1 - IF( JBGN.LE.JEND ) THEN -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ ASSOC -CVD$ NODEPCHK - DO 70 J = JBGN, JEND - X(IROW) = X(IROW) - U(J)*X(IU(J)) - 70 CONTINUE - ENDIF - 80 CONTINUE -C -C Solve D*Z = Y, storing result in X. - DO 90 I = 1, N - X(I) = X(I)*DINV(I) - 90 CONTINUE -C -C Solve L'*X = Z, L stored by rows. - DO 110 ICOL = N, 2, -1 - JBGN = IL(ICOL) - JEND = IL(ICOL+1) - 1 - IF( JBGN.LE.JEND ) THEN -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ NODEPCHK - DO 100 J = JBGN, JEND - X(JL(J)) = X(JL(J)) - L(J)*X(ICOL) - 100 CONTINUE - ENDIF - 110 CONTINUE - RETURN -C------------- LAST LINE OF DSLUI4 FOLLOWS ---------------------------- - END diff --git a/slatec/dsluom.f b/slatec/dsluom.f deleted file mode 100644 index 1f259eb..0000000 --- a/slatec/dsluom.f +++ /dev/null @@ -1,323 +0,0 @@ -*DECK DSLUOM - SUBROUTINE DSLUOM (N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ITOL, - + TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE DSLUOM -C***PURPOSE Incomplete LU Orthomin Sparse Iterative Ax=b Solver. -C Routine to solve a general linear system Ax = b using -C the Orthomin method with Incomplete LU decomposition. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (SSLUOM-S, DSLUOM-D) -C***KEYWORDS ITERATIVE INCOMPLETE LU PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NSAVE, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+NU+4*N+2), LENIW -C DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR -C DOUBLE PRECISION RWORK(NL+NU+7*N+3*N*NSAVE+NSAVE) -C -C CALL DSLUOM(N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) -C -C *Arguments: -C N :IN Integer. -C Order of the matrix. -C B :IN Double Precision B(N). -C Right-hand side vector. -C X :INOUT Double Precision X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Double Precision A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen, it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C NSAVE :IN Integer. -C Number of direction vectors to save and orthogonalize against. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /DSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Double Precision. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Double Precision. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*D1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Breakdown of the method detected. -C (p,Ap) < epsilon**2. -C IERR = 7 => Incomplete factorization broke down and was -C fudged. Resulting preconditioning may be less -C than the best. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Double Precision RWORK(LENW). -C Double Precision array used for workspace. NL is the number -C of non-zeros in the lower triangle of the matrix (including -C the diagonal). NU is the number of non-zeros in the upper -C triangle of the matrix (including the diagonal). -C LENW :IN Integer. -C Length of the double precision workspace, RWORK. -C LENW >= NL+NU+4*N+NSAVE*(3*N+1) -C IWORK :WORK Integer IWORK(LENIW) -C Integer array used for workspace. NL is the number of non- -C zeros in the lower triangle of the matrix (including the -C diagonal). NU is the number of non-zeros in the upper -C triangle of the matrix (including the diagonal). -C Upon return the following locations of IWORK hold information -C which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Double Precision workspace actually used. -C LENIW :IN Integer. -C Length of the integer workspace, IWORK. -C LENIW >= NL+NU+4*N+12. -C -C *Description: -C This routine is simply a driver for the DOMN routine. It -C calls the DSILUS routine to set up the preconditioning and -C then calls DOMN with the appropriate MATVEC and MSOLVE -C routines. -C -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to -C be the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO DOMN, DSDOMN -C***REFERENCES (NONE) -C***ROUTINES CALLED DCHKW, DOMN, DS2Y, DSILUS, DSLUI, DSMV -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 921019 Corrected NEL to NL. (FNF) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE DSLUOM -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - DOUBLE PRECISION ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, - + NELT, NSAVE -C .. Array Arguments .. - DOUBLE PRECISION A(N), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER ICOL, J, JBGN, JEND, LOCAP, LOCCSA, LOCDIN, LOCDZ, LOCEMA, - + LOCIL, LOCIU, LOCIW, LOCJL, LOCJU, LOCL, LOCNC, LOCNR, - + LOCP, LOCR, LOCU, LOCW, LOCZ, NL, NU -C .. External Subroutines .. - EXTERNAL DCHKW, DOMN, DS2Y, DSILUS, DSLUI, DSMV -C***FIRST EXECUTABLE STATEMENT DSLUOM -C - IERR = 0 - IF( N.LT.1 .OR. NELT.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Change the SLAP input matrix IA, JA, A to SLAP-Column format. - CALL DS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Count number of Non-Zero elements preconditioner ILU matrix. -C Then set up the work arrays. - NL = 0 - NU = 0 - DO 20 ICOL = 1, N -C Don't count diagonal. - JBGN = JA(ICOL)+1 - JEND = JA(ICOL+1)-1 - IF( JBGN.LE.JEND ) THEN -CVD$ NOVECTOR - DO 10 J = JBGN, JEND - IF( IA(J).GT.ICOL ) THEN - NL = NL + 1 - IF( ISYM.NE.0 ) NU = NU + 1 - ELSE - NU = NU + 1 - ENDIF - 10 CONTINUE - ENDIF - 20 CONTINUE -C - LOCIL = LOCIB - LOCJL = LOCIL + N+1 - LOCIU = LOCJL + NL - LOCJU = LOCIU + NU - LOCNR = LOCJU + N+1 - LOCNC = LOCNR + N - LOCIW = LOCNC + N -C - LOCL = LOCRB - LOCDIN = LOCL + NL - LOCU = LOCDIN + N - LOCR = LOCU + NU - LOCZ = LOCR + N - LOCP = LOCZ + N - LOCAP = LOCP + N*(NSAVE+1) - LOCEMA = LOCAP + N*(NSAVE+1) - LOCDZ = LOCEMA + N*(NSAVE+1) - LOCCSA = LOCDZ + N - LOCW = LOCCSA + NSAVE -C -C Check the workspace allocations. - CALL DCHKW( 'DSLUOM', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(1) = LOCIL - IWORK(2) = LOCJL - IWORK(3) = LOCIU - IWORK(4) = LOCJU - IWORK(5) = LOCL - IWORK(6) = LOCDIN - IWORK(7) = LOCU - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Compute the Incomplete LU decomposition. - CALL DSILUS( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIL), - $ IWORK(LOCJL), RWORK(LOCL), RWORK(LOCDIN), NU, IWORK(LOCIU), - $ IWORK(LOCJU), RWORK(LOCU), IWORK(LOCNR), IWORK(LOCNC) ) -C -C Perform the incomplete LU preconditioned OrthoMin algorithm. - CALL DOMN(N, B, X, NELT, IA, JA, A, ISYM, DSMV, - $ DSLUI, NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, - $ RWORK(LOCR), RWORK(LOCZ), RWORK(LOCP), RWORK(LOCAP), - $ RWORK(LOCEMA), RWORK(LOCDZ), RWORK(LOCCSA), - $ RWORK, IWORK ) - RETURN - END diff --git a/slatec/dsluti.f b/slatec/dsluti.f deleted file mode 100644 index a1e0fbe..0000000 --- a/slatec/dsluti.f +++ /dev/null @@ -1,71 +0,0 @@ -*DECK DSLUTI - SUBROUTINE DSLUTI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C***BEGIN PROLOGUE DSLUTI -C***PURPOSE SLAP MTSOLV for LDU Factorization. -C This routine acts as an interface between the SLAP generic -C MTSOLV calling convention and the routine that actually -C -T -C computes (LDU) B = X. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE DOUBLE PRECISION (SSLUTI-S, DSLUTI-D) -C***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM SOLVE, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C It is assumed that RWORK and IWORK have initialized with -C the information required for DSLUI4: -C IWORK(1) = Starting location of IL in IWORK. -C IWORK(2) = Starting location of JL in IWORK. -C IWORK(3) = Starting location of IU in IWORK. -C IWORK(4) = Starting location of JU in IWORK. -C IWORK(5) = Starting location of L in RWORK. -C IWORK(6) = Starting location of DINV in RWORK. -C IWORK(7) = Starting location of U in RWORK. -C See the DESCRIPTION of DSLUI4 for details. -C***REFERENCES (NONE) -C***ROUTINES CALLED DSLUI4 -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE DSLUTI -C .. Scalar Arguments .. - INTEGER ISYM, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(N), B(N), RWORK(*), X(N) - INTEGER IA(NELT), IWORK(10), JA(NELT) -C .. Local Scalars .. - INTEGER LOCDIN, LOCIL, LOCIU, LOCJL, LOCJU, LOCL, LOCU -C .. External Subroutines .. - EXTERNAL DSLUI4 -C***FIRST EXECUTABLE STATEMENT DSLUTI -C -C Pull out the pointers to the L, D and U matrices and call -C the workhorse routine. -C - LOCIL = IWORK(1) - LOCJL = IWORK(2) - LOCIU = IWORK(3) - LOCJU = IWORK(4) - LOCL = IWORK(5) - LOCDIN = IWORK(6) - LOCU = IWORK(7) -C - CALL DSLUI4(N, B, X, IWORK(LOCIL), IWORK(LOCJL), RWORK(LOCL), - $ RWORK(LOCDIN), IWORK(LOCIU), IWORK(LOCJU), RWORK(LOCU)) -C - RETURN -C------------- LAST LINE OF DSLUTI FOLLOWS ---------------------------- - END diff --git a/slatec/dslvs.f b/slatec/dslvs.f deleted file mode 100644 index e0bfcd3..0000000 --- a/slatec/dslvs.f +++ /dev/null @@ -1,103 +0,0 @@ -*DECK DSLVS - SUBROUTINE DSLVS (WM, IWM, X, TEM) -C***BEGIN PROLOGUE DSLVS -C***SUBSIDIARY -C***PURPOSE Subsidiary to DDEBDF -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (SLVS-S, DSLVS-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C DSLVS solves the linear system in the iteration scheme for the -C integrator package DDEBDF. -C -C***SEE ALSO DDEBDF -C***ROUTINES CALLED DGBSL, DGESL -C***COMMON BLOCKS DDEBD1 -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C 920422 Changed DIMENSION statement. (WRB) -C***END PROLOGUE DSLVS -C - INTEGER I, IER, IOWND, IOWNS, IWM, JSTART, KFLAG, L, MAXORD, - 1 MEBAND, METH, MITER, ML, MU, N, NFE, NJE, NQ, NQU, NST - DOUBLE PRECISION DI, EL0, H, HL0, HMIN, HMXI, HU, PHL0, - 1 R, ROWND, ROWNS, TEM, TN, UROUND, WM, X - DIMENSION WM(*), IWM(*), X(*), TEM(*) - COMMON /DDEBD1/ ROWND,ROWNS(210),EL0,H,HMIN,HMXI,HU,TN,UROUND, - 1 IOWND(14),IOWNS(6),IER,JSTART,KFLAG,L,METH,MITER, - 2 MAXORD,N,NQ,NST,NFE,NJE,NQU -C ------------------------------------------------------------------ -C THIS ROUTINE MANAGES THE SOLUTION OF THE LINEAR SYSTEM ARISING -C FROM A CHORD ITERATION. IT IS CALLED BY DSTOD IF MITER .NE. 0. -C IF MITER IS 1 OR 2, IT CALLS DGESL TO ACCOMPLISH THIS. -C IF MITER = 3 IT UPDATES THE COEFFICIENT H*EL0 IN THE DIAGONAL -C MATRIX, AND THEN COMPUTES THE SOLUTION. -C IF MITER IS 4 OR 5, IT CALLS DGBSL. -C COMMUNICATION WITH DSLVS USES THE FOLLOWING VARIABLES.. -C WM = DOUBLE PRECISION WORK SPACE CONTAINING THE INVERSE DIAGONAL -C MATRIX IF MITER -C IS 3 AND THE LU DECOMPOSITION OF THE MATRIX OTHERWISE. -C STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). -C WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA.. -C WM(1) = SQRT(UROUND) (NOT USED HERE), -C WM(2) = HL0, THE PREVIOUS VALUE OF H*EL0, USED IF MITER = -C 3. -C IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING -C AT IWM(21), IF MITER IS 1, 2, 4, OR 5. IWM ALSO CONTAINS -C THE BAND PARAMETERS ML = IWM(1) AND MU = IWM(2) IF MITER IS -C 4 OR 5. -C X = THE RIGHT-HAND SIDE VECTOR ON INPUT, AND THE SOLUTION -C VECTOR ON OUTPUT, OF LENGTH N. -C TEM = VECTOR OF WORK SPACE OF LENGTH N, NOT USED IN THIS VERSION. -C IER = OUTPUT FLAG (IN COMMON). IER = 0 IF NO TROUBLE OCCURRED. -C IER = -1 IF A SINGULAR MATRIX AROSE WITH MITER = 3. -C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, MITER, AND N. -C----------------------------------------------------------------------- -C BEGIN BLOCK PERMITTING ...EXITS TO 80 -C BEGIN BLOCK PERMITTING ...EXITS TO 60 -C***FIRST EXECUTABLE STATEMENT DSLVS - IER = 0 - GO TO (10,10,20,70,70), MITER - 10 CONTINUE - CALL DGESL(WM(3),N,N,IWM(21),X,0) -C ......EXIT - GO TO 80 -C - 20 CONTINUE - PHL0 = WM(2) - HL0 = H*EL0 - WM(2) = HL0 - IF (HL0 .EQ. PHL0) GO TO 40 - R = HL0/PHL0 - DO 30 I = 1, N - DI = 1.0D0 - R*(1.0D0 - 1.0D0/WM(I+2)) -C .........EXIT - IF (ABS(DI) .EQ. 0.0D0) GO TO 60 - WM(I+2) = 1.0D0/DI - 30 CONTINUE - 40 CONTINUE - DO 50 I = 1, N - X(I) = WM(I+2)*X(I) - 50 CONTINUE -C ......EXIT - GO TO 80 - 60 CONTINUE - IER = -1 -C ...EXIT - GO TO 80 -C - 70 CONTINUE - ML = IWM(1) - MU = IWM(2) - MEBAND = 2*ML + MU + 1 - CALL DGBSL(WM(3),MEBAND,N,ML,MU,IWM(21),X,0) - 80 CONTINUE - RETURN -C ----------------------- END OF SUBROUTINE DSLVS -C ----------------------- - END diff --git a/slatec/dsmmi2.f b/slatec/dsmmi2.f deleted file mode 100644 index 76c3949..0000000 --- a/slatec/dsmmi2.f +++ /dev/null @@ -1,239 +0,0 @@ -*DECK DSMMI2 - SUBROUTINE DSMMI2 (N, B, X, IL, JL, L, DINV, IU, JU, U) -C***BEGIN PROLOGUE DSMMI2 -C***PURPOSE SLAP Backsolve for LDU Factorization of Normal Equations. -C To solve a system of the form (L*D*U)*(L*D*U)' X = B, -C where L is a unit lower triangular matrix, D is a diagonal -C matrix, and U is a unit upper triangular matrix and ' -C denotes transpose. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE DOUBLE PRECISION (SSMMI2-S, DSMMI2-D) -C***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, IL(NL), JL(NL), IU(NU), JU(NU) -C DOUBLE PRECISION B(N), X(N), L(NL), DINV(N), U(NU) -C -C CALL DSMMI2( N, B, X, IL, JL, L, DINV, IU, JU, U ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right hand side. -C X :OUT Double Precision X(N). -C Solution of (L*D*U)(L*D*U)trans x = b. -C IL :IN Integer IL(NL). -C JL :IN Integer JL(NL). -C L :IN Double Precision L(NL). -C IL, JL, L contain the unit lower triangular factor of the -C incomplete decomposition of some matrix stored in SLAP Row -C format. The diagonal of ones *IS* stored. This structure -C can be set up by the DSILUS routine. See the -C "Description", below for more details about the SLAP -C format. (NL is the number of non-zeros in the L array.) -C DINV :IN Double Precision DINV(N). -C Inverse of the diagonal matrix D. -C IU :IN Integer IU(NU). -C JU :IN Integer JU(NU). -C U :IN Double Precision U(NU). -C IU, JU, U contain the unit upper triangular factor of the -C incomplete decomposition of some matrix stored in SLAP -C Column format. The diagonal of ones *IS* stored. This -C structure can be set up by the DSILUS routine. See the -C "Description", below for more details about the SLAP -C format. (NU is the number of non-zeros in the U array.) -C -C *Description: -C This routine is supplied with the SLAP package as a routine -C to perform the MSOLVE operation in the SBCGN iteration -C routine for the driver DSLUCN. It must be called via the -C SLAP MSOLVE calling sequence convention interface routine -C DSMMTI. -C **** THIS ROUTINE ITSELF DOES NOT CONFORM TO THE **** -C **** SLAP MSOLVE CALLING CONVENTION **** -C -C IL, JL, L should contain the unit lower triangular factor of -C the incomplete decomposition of the A matrix stored in SLAP -C Row format. IU, JU, U should contain the unit upper factor -C of the incomplete decomposition of the A matrix stored in -C SLAP Column format This ILU factorization can be computed by -C the DSILUS routine. The diagonals (which are all one's) are -C stored. -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C ==================== S L A P Row format ==================== -C -C This routine requires that the matrix A be stored in the -C SLAP Row format. In this format the non-zeros are stored -C counting across rows (except for the diagonal entry, which -C must appear first in each "row") and are stored in the -C double precision array A. In other words, for each row in -C the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going across the row (except the -C diagonal) in order. The JA array holds the column index for -C each non-zero. The IA array holds the offsets into the JA, -C A arrays for the beginning of each row. That is, -C JA(IA(IROW)),A(IA(IROW)) are the first elements of the IROW- -C th row in JA and A, and JA(IA(IROW+1)-1), A(IA(IROW+1)-1) -C are the last elements of the IROW-th row. Note that we -C always have IA(N+1) = NELT+1, where N is the number of rows -C in the matrix and NELT is the number of non-zeros in the -C matrix. -C -C Here is an example of the SLAP Row storage format for a 5x5 -C Matrix (in the A and JA arrays '|' denotes the end of a row): -C -C 5x5 Matrix SLAP Row format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 12 15 | 22 21 | 33 35 | 44 | 55 51 53 -C |21 22 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| IA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C With the SLAP format the "inner loops" of this routine -C should vectorize on machines with hardware support for -C vector gather/scatter operations. Your compiler may require -C a compiler directive to convince it that there are no -C implicit vector dependencies. Compiler directives for the -C Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied -C with the standard SLAP distribution. -C -C***SEE ALSO DSILUS -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE DSMMI2 -C .. Scalar Arguments .. - INTEGER N -C .. Array Arguments .. - DOUBLE PRECISION B(N), DINV(N), L(*), U(N), X(N) - INTEGER IL(*), IU(*), JL(*), JU(*) -C .. Local Scalars .. - INTEGER I, ICOL, IROW, J, JBGN, JEND -C***FIRST EXECUTABLE STATEMENT DSMMI2 -C -C Solve L*Y = B, storing result in X, L stored by rows. -C - DO 10 I = 1, N - X(I) = B(I) - 10 CONTINUE - DO 30 IROW = 2, N - JBGN = IL(IROW) - JEND = IL(IROW+1)-1 - IF( JBGN.LE.JEND ) THEN -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ ASSOC -CVD$ NODEPCHK - DO 20 J = JBGN, JEND - X(IROW) = X(IROW) - L(J)*X(JL(J)) - 20 CONTINUE - ENDIF - 30 CONTINUE -C -C Solve D*Z = Y, storing result in X. - DO 40 I=1,N - X(I) = X(I)*DINV(I) - 40 CONTINUE -C -C Solve U*X = Z, U stored by columns. - DO 60 ICOL = N, 2, -1 - JBGN = JU(ICOL) - JEND = JU(ICOL+1)-1 - IF( JBGN.LE.JEND ) THEN -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ NODEPCHK - DO 50 J = JBGN, JEND - X(IU(J)) = X(IU(J)) - U(J)*X(ICOL) - 50 CONTINUE - ENDIF - 60 CONTINUE -C -C Solve U'*Y = X, storing result in X, U stored by columns. - DO 80 IROW = 2, N - JBGN = JU(IROW) - JEND = JU(IROW+1) - 1 - IF( JBGN.LE.JEND ) THEN -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ ASSOC -CVD$ NODEPCHK - DO 70 J = JBGN, JEND - X(IROW) = X(IROW) - U(J)*X(IU(J)) - 70 CONTINUE - ENDIF - 80 CONTINUE -C -C Solve D*Z = Y, storing result in X. - DO 90 I = 1, N - X(I) = X(I)*DINV(I) - 90 CONTINUE -C -C Solve L'*X = Z, L stored by rows. - DO 110 ICOL = N, 2, -1 - JBGN = IL(ICOL) - JEND = IL(ICOL+1) - 1 - IF( JBGN.LE.JEND ) THEN -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ NODEPCHK - DO 100 J = JBGN, JEND - X(JL(J)) = X(JL(J)) - L(J)*X(ICOL) - 100 CONTINUE - ENDIF - 110 CONTINUE -C - RETURN -C------------- LAST LINE OF DSMMI2 FOLLOWS ---------------------------- - END diff --git a/slatec/dsmmti.f b/slatec/dsmmti.f deleted file mode 100644 index 6cf72f1..0000000 --- a/slatec/dsmmti.f +++ /dev/null @@ -1,72 +0,0 @@ -*DECK DSMMTI - SUBROUTINE DSMMTI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C***BEGIN PROLOGUE DSMMTI -C***PURPOSE SLAP MSOLVE for LDU Factorization of Normal Equations. -C This routine acts as an interface between the SLAP generic -C MMTSLV calling convention and the routine that actually -C -1 -C computes [(LDU)*(LDU)'] B = X. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE DOUBLE PRECISION (SSMMTI-S, DSMMTI-D) -C***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM SOLVE, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C It is assumed that RWORK and IWORK have initialized with -C the information required for DSMMI2: -C IWORK(1) = Starting location of IL in IWORK. -C IWORK(2) = Starting location of JL in IWORK. -C IWORK(3) = Starting location of IU in IWORK. -C IWORK(4) = Starting location of JU in IWORK. -C IWORK(5) = Starting location of L in RWORK. -C IWORK(6) = Starting location of DINV in RWORK. -C IWORK(7) = Starting location of U in RWORK. -C See the DESCRIPTION of DSMMI2 for details. -C***REFERENCES (NONE) -C***ROUTINES CALLED DSMMI2 -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE DSMMTI -C .. Scalar Arguments .. - INTEGER ISYM, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), B(N), RWORK(*), X(N) - INTEGER IA(NELT), IWORK(10), JA(NELT) -C .. Local Scalars .. - INTEGER LOCDIN, LOCIL, LOCIU, LOCJL, LOCJU, LOCL, LOCU -C .. External Subroutines .. - EXTERNAL DSMMI2 -C***FIRST EXECUTABLE STATEMENT DSMMTI -C -C Pull out the locations of the arrays holding the ILU -C factorization. -C - LOCIL = IWORK(1) - LOCJL = IWORK(2) - LOCIU = IWORK(3) - LOCJU = IWORK(4) - LOCL = IWORK(5) - LOCDIN = IWORK(6) - LOCU = IWORK(7) -C - CALL DSMMI2(N, B, X, IWORK(LOCIL), IWORK(LOCJL), - $ RWORK(LOCL), RWORK(LOCDIN), IWORK(LOCIU), - $ IWORK(LOCJU), RWORK(LOCU)) -C - RETURN -C------------- LAST LINE OF DSMMTI FOLLOWS ---------------------------- - END diff --git a/slatec/dsmtv.f b/slatec/dsmtv.f deleted file mode 100644 index 9352daf..0000000 --- a/slatec/dsmtv.f +++ /dev/null @@ -1,153 +0,0 @@ -*DECK DSMTV - SUBROUTINE DSMTV (N, X, Y, NELT, IA, JA, A, ISYM) -C***BEGIN PROLOGUE DSMTV -C***PURPOSE SLAP Column Format Sparse Matrix Transpose Vector Product. -C Routine to calculate the sparse matrix vector product: -C Y = A'*X, where ' denotes transpose. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D1B4 -C***TYPE DOUBLE PRECISION (SSMTV-S, DSMTV-D) -C***KEYWORDS MATRIX TRANSPOSE VECTOR MULTIPLY, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM -C DOUBLE PRECISION X(N), Y(N), A(NELT) -C -C CALL DSMTV(N, X, Y, NELT, IA, JA, A, ISYM ) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C X :IN Double Precision X(N). -C The vector that should be multiplied by the transpose of -C the matrix. -C Y :OUT Double Precision Y(N). -C The product of the transpose of the matrix and the vector. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Double Precision A(NELT). -C These arrays should hold the matrix A in the SLAP Column -C format. See "Description", below. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C -C *Description -C =================== S L A P Column format ================== -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C With the SLAP format the "inner loops" of this routine -C should vectorize on machines with hardware support for -C vector gather/scatter operations. Your compiler may require -C a compiler directive to convince it that there are no -C implicit vector dependencies. Compiler directives for the -C Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied -C with the standard SLAP distribution. -C -C *Cautions: -C This routine assumes that the matrix A is stored in SLAP -C Column format. It does not check for this (for speed) and -C evil, ugly, ornery and nasty things will happen if the matrix -C data structure is, in fact, not SLAP Column. Beware of the -C wrong data structure!!! -C -C***SEE ALSO DSMV -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE DSMTV -C .. Scalar Arguments .. - INTEGER ISYM, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), X(N), Y(N) - INTEGER IA(NELT), JA(NELT) -C .. Local Scalars .. - INTEGER I, IBGN, ICOL, IEND, IROW, J, JBGN, JEND -C***FIRST EXECUTABLE STATEMENT DSMTV -C -C Zero out the result vector. -C - DO 10 I = 1, N - Y(I) = 0 - 10 CONTINUE -C -C Multiply by A-Transpose. -C A-Transpose is stored by rows... -CVD$R NOCONCUR - DO 30 IROW = 1, N - IBGN = JA(IROW) - IEND = JA(IROW+1)-1 -CVD$ ASSOC - DO 20 I = IBGN, IEND - Y(IROW) = Y(IROW) + A(I)*X(IA(I)) - 20 CONTINUE - 30 CONTINUE -C - IF( ISYM.EQ.1 ) THEN -C -C The matrix is non-symmetric. Need to get the other half in... -C This loops assumes that the diagonal is the first entry in -C each column. -C - DO 50 ICOL = 1, N - JBGN = JA(ICOL)+1 - JEND = JA(ICOL+1)-1 - IF( JBGN.GT.JEND ) GOTO 50 -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ NODEPCHK - DO 40 J = JBGN, JEND - Y(IA(J)) = Y(IA(J)) + A(J)*X(ICOL) - 40 CONTINUE - 50 CONTINUE - ENDIF - RETURN -C------------- LAST LINE OF DSMTV FOLLOWS ---------------------------- - END diff --git a/slatec/dsmv.f b/slatec/dsmv.f deleted file mode 100644 index 758b08f..0000000 --- a/slatec/dsmv.f +++ /dev/null @@ -1,151 +0,0 @@ -*DECK DSMV - SUBROUTINE DSMV (N, X, Y, NELT, IA, JA, A, ISYM) -C***BEGIN PROLOGUE DSMV -C***PURPOSE SLAP Column Format Sparse Matrix Vector Product. -C Routine to calculate the sparse matrix vector product: -C Y = A*X. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D1B4 -C***TYPE DOUBLE PRECISION (SSMV-S, DSMV-D) -C***KEYWORDS MATRIX VECTOR MULTIPLY, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM -C DOUBLE PRECISION X(N), Y(N), A(NELT) -C -C CALL DSMV(N, X, Y, NELT, IA, JA, A, ISYM ) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C X :IN Double Precision X(N). -C The vector that should be multiplied by the matrix. -C Y :OUT Double Precision Y(N). -C The product of the matrix and the vector. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Double Precision A(NELT). -C These arrays should hold the matrix A in the SLAP Column -C format. See "Description", below. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C -C *Description -C =================== S L A P Column format ================== -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C double precision array A. In other words, for each column -C in the matrix put the diagonal entry in A. Then put in the -C other non-zero elements going down the column (except the -C diagonal) in order. The IA array holds the row index for -C each non-zero. The JA array holds the offsets into the IA, -C A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the -C ICOL-th column in IA and A. IA(JA(ICOL+1)-1), -C A(JA(ICOL+1)-1) points to the end of the ICOL-th column. -C Note that we always have JA(N+1) = NELT+1, where N is the -C number of columns in the matrix and NELT is the number of -C non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C With the SLAP format the "inner loops" of this routine -C should vectorize on machines with hardware support for -C vector gather/scatter operations. Your compiler may require -C a compiler directive to convince it that there are no -C implicit vector dependencies. Compiler directives for the -C Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied -C with the standard SLAP distribution. -C -C *Cautions: -C This routine assumes that the matrix A is stored in SLAP -C Column format. It does not check for this (for speed) and -C evil, ugly, ornery and nasty things will happen if the matrix -C data structure is, in fact, not SLAP Column. Beware of the -C wrong data structure!!! -C -C***SEE ALSO DSMTV -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE DSMV -C .. Scalar Arguments .. - INTEGER ISYM, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), X(N), Y(N) - INTEGER IA(NELT), JA(NELT) -C .. Local Scalars .. - INTEGER I, IBGN, ICOL, IEND, IROW, J, JBGN, JEND -C***FIRST EXECUTABLE STATEMENT DSMV -C -C Zero out the result vector. -C - DO 10 I = 1, N - Y(I) = 0 - 10 CONTINUE -C -C Multiply by A. -C -CVD$R NOCONCUR - DO 30 ICOL = 1, N - IBGN = JA(ICOL) - IEND = JA(ICOL+1)-1 -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ NODEPCHK - DO 20 I = IBGN, IEND - Y(IA(I)) = Y(IA(I)) + A(I)*X(ICOL) - 20 CONTINUE - 30 CONTINUE -C - IF( ISYM.EQ.1 ) THEN -C -C The matrix is non-symmetric. Need to get the other half in... -C This loops assumes that the diagonal is the first entry in -C each column. -C - DO 50 IROW = 1, N - JBGN = JA(IROW)+1 - JEND = JA(IROW+1)-1 - IF( JBGN.GT.JEND ) GOTO 50 - DO 40 J = JBGN, JEND - Y(IROW) = Y(IROW) + A(J)*X(IA(J)) - 40 CONTINUE - 50 CONTINUE - ENDIF - RETURN -C------------- LAST LINE OF DSMV FOLLOWS ---------------------------- - END diff --git a/slatec/dsort.f b/slatec/dsort.f deleted file mode 100644 index 2fe023a..0000000 --- a/slatec/dsort.f +++ /dev/null @@ -1,324 +0,0 @@ -*DECK DSORT - SUBROUTINE DSORT (DX, DY, N, KFLAG) -C***BEGIN PROLOGUE DSORT -C***PURPOSE Sort an array and optionally make the same interchanges in -C an auxiliary array. The array may be sorted in increasing -C or decreasing order. A slightly modified QUICKSORT -C algorithm is used. -C***LIBRARY SLATEC -C***CATEGORY N6A2B -C***TYPE DOUBLE PRECISION (SSORT-S, DSORT-D, ISORT-I) -C***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING -C***AUTHOR Jones, R. E., (SNLA) -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C -C DSORT sorts array DX and optionally makes the same interchanges in -C array DY. The array DX may be sorted in increasing order or -C decreasing order. A slightly modified quicksort algorithm is used. -C -C Description of Parameters -C DX - array of values to be sorted (usually abscissas) -C DY - array to be (optionally) carried along -C N - number of values in array DX to be sorted -C KFLAG - control parameter -C = 2 means sort DX in increasing order and carry DY along. -C = 1 means sort DX in increasing order (ignoring DY) -C = -1 means sort DX in decreasing order (ignoring DY) -C = -2 means sort DX in decreasing order and carry DY along. -C -C***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm -C for sorting with minimal storage, Communications of -C the ACM, 12, 3 (1969), pp. 185-187. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 761101 DATE WRITTEN -C 761118 Modified to use the Singleton quicksort algorithm. (JAW) -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891009 Removed unreferenced statement labels. (WRB) -C 891024 Changed category. (WRB) -C 891024 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 901012 Declared all variables; changed X,Y to DX,DY; changed -C code to parallel SSORT. (M. McClain) -C 920501 Reformatted the REFERENCES section. (DWL, WRB) -C 920519 Clarified error messages. (DWL) -C 920801 Declarations section rebuilt and code restructured to use -C IF-THEN-ELSE-ENDIF. (RWC, WRB) -C***END PROLOGUE DSORT -C .. Scalar Arguments .. - INTEGER KFLAG, N -C .. Array Arguments .. - DOUBLE PRECISION DX(*), DY(*) -C .. Local Scalars .. - DOUBLE PRECISION R, T, TT, TTY, TY - INTEGER I, IJ, J, K, KK, L, M, NN -C .. Local Arrays .. - INTEGER IL(21), IU(21) -C .. External Subroutines .. - EXTERNAL XERMSG -C .. Intrinsic Functions .. - INTRINSIC ABS, INT -C***FIRST EXECUTABLE STATEMENT DSORT - NN = N - IF (NN .LT. 1) THEN - CALL XERMSG ('SLATEC', 'DSORT', - + 'The number of values to be sorted is not positive.', 1, 1) - RETURN - ENDIF -C - KK = ABS(KFLAG) - IF (KK.NE.1 .AND. KK.NE.2) THEN - CALL XERMSG ('SLATEC', 'DSORT', - + 'The sort control parameter, K, is not 2, 1, -1, or -2.', 2, - + 1) - RETURN - ENDIF -C -C Alter array DX to get decreasing order if needed -C - IF (KFLAG .LE. -1) THEN - DO 10 I=1,NN - DX(I) = -DX(I) - 10 CONTINUE - ENDIF -C - IF (KK .EQ. 2) GO TO 100 -C -C Sort DX only -C - M = 1 - I = 1 - J = NN - R = 0.375D0 -C - 20 IF (I .EQ. J) GO TO 60 - IF (R .LE. 0.5898437D0) THEN - R = R+3.90625D-2 - ELSE - R = R-0.21875D0 - ENDIF -C - 30 K = I -C -C Select a central element of the array and save it in location T -C - IJ = I + INT((J-I)*R) - T = DX(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (DX(I) .GT. T) THEN - DX(IJ) = DX(I) - DX(I) = T - T = DX(IJ) - ENDIF - L = J -C -C If last element of array is less than than T, interchange with T -C - IF (DX(J) .LT. T) THEN - DX(IJ) = DX(J) - DX(J) = T - T = DX(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (DX(I) .GT. T) THEN - DX(IJ) = DX(I) - DX(I) = T - T = DX(IJ) - ENDIF - ENDIF -C -C Find an element in the second half of the array which is smaller -C than T -C - 40 L = L-1 - IF (DX(L) .GT. T) GO TO 40 -C -C Find an element in the first half of the array which is greater -C than T -C - 50 K = K+1 - IF (DX(K) .LT. T) GO TO 50 -C -C Interchange these elements -C - IF (K .LE. L) THEN - TT = DX(L) - DX(L) = DX(K) - DX(K) = TT - GO TO 40 - ENDIF -C -C Save upper and lower subscripts of the array yet to be sorted -C - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 70 -C -C Begin again on another portion of the unsorted array -C - 60 M = M-1 - IF (M .EQ. 0) GO TO 190 - I = IL(M) - J = IU(M) -C - 70 IF (J-I .GE. 1) GO TO 30 - IF (I .EQ. 1) GO TO 20 - I = I-1 -C - 80 I = I+1 - IF (I .EQ. J) GO TO 60 - T = DX(I+1) - IF (DX(I) .LE. T) GO TO 80 - K = I -C - 90 DX(K+1) = DX(K) - K = K-1 - IF (T .LT. DX(K)) GO TO 90 - DX(K+1) = T - GO TO 80 -C -C Sort DX and carry DY along -C - 100 M = 1 - I = 1 - J = NN - R = 0.375D0 -C - 110 IF (I .EQ. J) GO TO 150 - IF (R .LE. 0.5898437D0) THEN - R = R+3.90625D-2 - ELSE - R = R-0.21875D0 - ENDIF -C - 120 K = I -C -C Select a central element of the array and save it in location T -C - IJ = I + INT((J-I)*R) - T = DX(IJ) - TY = DY(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (DX(I) .GT. T) THEN - DX(IJ) = DX(I) - DX(I) = T - T = DX(IJ) - DY(IJ) = DY(I) - DY(I) = TY - TY = DY(IJ) - ENDIF - L = J -C -C If last element of array is less than T, interchange with T -C - IF (DX(J) .LT. T) THEN - DX(IJ) = DX(J) - DX(J) = T - T = DX(IJ) - DY(IJ) = DY(J) - DY(J) = TY - TY = DY(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (DX(I) .GT. T) THEN - DX(IJ) = DX(I) - DX(I) = T - T = DX(IJ) - DY(IJ) = DY(I) - DY(I) = TY - TY = DY(IJ) - ENDIF - ENDIF -C -C Find an element in the second half of the array which is smaller -C than T -C - 130 L = L-1 - IF (DX(L) .GT. T) GO TO 130 -C -C Find an element in the first half of the array which is greater -C than T -C - 140 K = K+1 - IF (DX(K) .LT. T) GO TO 140 -C -C Interchange these elements -C - IF (K .LE. L) THEN - TT = DX(L) - DX(L) = DX(K) - DX(K) = TT - TTY = DY(L) - DY(L) = DY(K) - DY(K) = TTY - GO TO 130 - ENDIF -C -C Save upper and lower subscripts of the array yet to be sorted -C - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 160 -C -C Begin again on another portion of the unsorted array -C - 150 M = M-1 - IF (M .EQ. 0) GO TO 190 - I = IL(M) - J = IU(M) -C - 160 IF (J-I .GE. 1) GO TO 120 - IF (I .EQ. 1) GO TO 110 - I = I-1 -C - 170 I = I+1 - IF (I .EQ. J) GO TO 150 - T = DX(I+1) - TY = DY(I+1) - IF (DX(I) .LE. T) GO TO 170 - K = I -C - 180 DX(K+1) = DX(K) - DY(K+1) = DY(K) - K = K-1 - IF (T .LT. DX(K)) GO TO 180 - DX(K+1) = T - DY(K+1) = TY - GO TO 170 -C -C Clean up -C - 190 IF (KFLAG .LE. -1) THEN - DO 200 I=1,NN - DX(I) = -DX(I) - 200 CONTINUE - ENDIF - RETURN - END diff --git a/slatec/dsos.f b/slatec/dsos.f deleted file mode 100644 index e4a2c06..0000000 --- a/slatec/dsos.f +++ /dev/null @@ -1,273 +0,0 @@ -*DECK DSOS - SUBROUTINE DSOS (FNC, NEQ, X, RTOLX, ATOLX, TOLF, IFLAG, RW, LRW, - + IW, LIW) -C***BEGIN PROLOGUE DSOS -C***PURPOSE Solve a square system of nonlinear equations. -C***LIBRARY SLATEC -C***CATEGORY F2A -C***TYPE DOUBLE PRECISION (SOS-S, DSOS-D) -C***KEYWORDS BROWN'S METHOD, NEWTON'S METHOD, NONLINEAR EQUATIONS, -C ROOTS, SOLUTIONS -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C DSOS solves a system of NEQ simultaneous nonlinear equations in -C NEQ unknowns. That is, it solves the problem F(X)=0 -C where X is a vector with components X(1),...,X(NEQ) and F -C is a vector of nonlinear functions. Each equation is of the form -C -C F (X(1),...,X(NEQ))=0 for K=1,...,NEQ. -C K -C -C The algorithm is based on an iterative method which is a -C variation of Newton's method using Gaussian elimination -C in a manner similar to the Gauss-Seidel process. Convergence -C is roughly quadratic. All partial derivatives required by -C the algorithm are approximated by first difference quotients. -C The convergence behavior of this code is affected by the -C ordering of the equations, and it is advantageous to place linear -C and mildly nonlinear equations first in the ordering. -C -C Actually, DSOS is merely an interfacing routine for -C calling subroutine DSOSEQ which embodies the solution -C algorithm. The purpose of this is to add greater -C flexibility and ease of use for the prospective user. -C -C DSOSEQ calls the accompanying routine DSOSSL which solves special -C triangular linear systems by back-substitution. -C -C The user must supply a function subprogram which evaluates the -C K-th equation only (K specified by DSOSEQ) for each call -C to the subprogram. -C -C DSOS represents an implementation of the mathematical algorithm -C described in the references below. It is a modification of the -C code SOSNLE written by H. A. Watts in 1973. -C -C ********************************************************************** -C -Input- -C -C FNC -Name of the function program which evaluates the equations. -C This name must be in an EXTERNAL statement in the calling -C program. The user must supply FNC in the form FNC(X,K), -C where X is the solution vector (which must be dimensioned -C in FNC) and FNC returns the value of the K-th function. -C -C NEQ -Number of equations to be solved. -C -C X -Solution vector. Initial guesses must be supplied. -C -C RTOLX -Relative error tolerance used in the convergence criteria. -C Each solution component X(I) is checked by an accuracy test -C of the form ABS(X(I)-XOLD(I)) .LE. RTOLX*ABS(X(I))+ATOLX, -C where XOLD(I) represents the previous iteration value. -C RTOLX must be non-negative. -C -C ATOLX -Absolute error tolerance used in the convergence criteria. -C ATOLX must be non-negative. If the user suspects some -C solution component may be zero, he should set ATOLX to an -C appropriate (depends on the scale of the remaining variables) -C positive value for better efficiency. -C -C TOLF -Residual error tolerance used in the convergence criteria. -C Convergence will be indicated if all residuals (values of the -C functions or equations) are not bigger than TOLF in -C magnitude. Note that extreme care must be given in assigning -C an appropriate value for TOLF because this convergence test -C is dependent on the scaling of the equations. An -C inappropriate value can cause premature termination of the -C iteration process. -C -C IFLAG -Optional input indicator. You must set IFLAG=-1 if you -C want to use any of the optional input items listed below. -C Otherwise set it to zero. -C -C RW -A DOUBLE PRECISION work array which is split apart by DSOS -C and used internally by DSOSEQ. -C -C LRW -Dimension of the RW array. LRW must be at least -C 1 + 6*NEQ + NEQ*(NEQ+1)/2 -C -C IW -An INTEGER work array which is split apart by DSOS and used -C internally by DSOSEQ. -C -C LIW -Dimension of the IW array. LIW must be at least 3 + NEQ. -C -C -Optional Input- -C -C IW(1) -Internal printing parameter. You must set IW(1)=-1 if -C you want the intermediate solution iterates to be printed. -C -C IW(2) -Iteration limit. The maximum number of allowable -C iterations can be specified, if desired. To override the -C default value of 50, set IW(2) to the number wanted. -C -C Remember, if you tell the code that you are using one of the -C options (by setting IFLAG=-1), you must supply values -C for both IW(1) and IW(2). -C -C ********************************************************************** -C -Output- -C -C X -Solution vector. -C -C IFLAG -Status indicator -C -C *** Convergence to a Solution *** -C -C 1 Means satisfactory convergence to a solution was achieved. -C Each solution component X(I) satisfies the error tolerance -C test ABS(X(I)-XOLD(I)) .LE. RTOLX*ABS(X(I))+ATOLX. -C -C 2 Means procedure converged to a solution such that all -C residuals are at most TOLF in magnitude, -C ABS(FNC(X,I)) .LE. TOLF. -C -C 3 Means that conditions for both IFLAG=1 and IFLAG=2 hold. -C -C 4 Means possible numerical convergence. Behavior indicates -C limiting precision calculations as a result of user asking -C for too much accuracy or else convergence is very slow. -C Residual norms and solution increment norms have -C remained roughly constant over several consecutive -C iterations. -C -C *** Task Interrupted *** -C -C 5 Means the allowable number of iterations has been met -C without obtaining a solution to the specified accuracy. -C Very slow convergence may be indicated. Examine the -C approximate solution returned and see if the error -C tolerances seem appropriate. -C -C 6 Means the allowable number of iterations has been met and -C the iterative process does not appear to be converging. -C A local minimum may have been encountered or there may be -C limiting precision difficulties. -C -C 7 Means that the iterative scheme appears to be diverging. -C Residual norms and solution increment norms have -C increased over several consecutive iterations. -C -C *** Task Cannot Be Continued *** -C -C 8 Means that a Jacobian-related matrix was singular. -C -C 9 Means improper input parameters. -C -C *** IFLAG should be examined after each call to *** -C *** DSOS with the appropriate action being taken. *** -C -C -C RW(1) -Contains a norm of the residual. -C -C IW(3) -Contains the number of iterations used by the process. -C -C ********************************************************************** -C -C***REFERENCES K. M. Brown, Solution of simultaneous nonlinear -C equations, Algorithm 316, Communications of the -C A.C.M. 10, (1967), pp. 728-729. -C K. M. Brown, A quadratically convergent Newton-like -C method based upon Gaussian elimination, SIAM Journal -C on Numerical Analysis 6, (1969), pp. 560-569. -C***ROUTINES CALLED DSOSEQ, XERMSG -C***REVISION HISTORY (YYMMDD) -C 801001 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 900510 Convert XERRWV calls to XERMSG calls, change Prologue -C comments to agree with SOS. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DSOS - INTEGER IFLAG, INPFLG, IPRINT, IW(*), K1, K2, K3, K4, K5, K6, - 1 LIW, LRW, MXIT, NC, NCJS, NEQ, NSRI, NSRRC - DOUBLE PRECISION ATOLX, FNC, RTOLX, RW(*), TOLF, X(*) - CHARACTER*8 XERN1 - CHARACTER*16 XERN3, XERN4 - EXTERNAL FNC -C***FIRST EXECUTABLE STATEMENT DSOS - INPFLG = IFLAG -C -C CHECK FOR VALID INPUT -C - IF (NEQ .LE. 0) THEN - WRITE (XERN1, '(I8)') NEQ - CALL XERMSG ('SLATEC', 'DSOS', 'THE NUMBER OF EQUATIONS ' // - * 'MUST BE A POSITIVE INTEGER. YOU HAVE CALLED THE ' // - * 'CODE WITH NEQ = ' // XERN1, 1, 1) - IFLAG = 9 - ENDIF -C - IF (RTOLX .LT. 0.0D0 .OR. ATOLX .LT. 0.0D0) THEN - WRITE (XERN3, '(1PE15.6)') ATOLX - WRITE (XERN4, '(1PE15.6)') RTOLX - CALL XERMSG ('SLATEC', 'DSOS', 'THE ERROR TOLERANCES FOR ' // - * 'THE SOLUTION ITERATES CANNOT BE NEGATIVE. YOU HAVE ' // - * 'CALLED THE CODE WITH RTOLX = ' // XERN3 // - * ' AND ATOLX = ' // XERN4,2, 1) - IFLAG = 9 - ENDIF -C - IF (TOLF .LT. 0.0D0) THEN - WRITE (XERN3, '(1PE15.6)') TOLF - CALL XERMSG ('SLATEC', 'DSOS', 'THE RESIDUAL ERROR ' // - * 'TOLERANCE MUST BE NON-NEGATIVE. YOU HAVE CALLED THE ' // - * 'CODE WITH TOLF = ' // XERN3, 3, 1) - IFLAG = 9 - ENDIF -C - IPRINT = 0 - MXIT = 50 - IF (INPFLG .EQ. (-1)) THEN - IF (IW(1) .EQ. (-1)) IPRINT = -1 - MXIT = IW(2) - IF (MXIT .LE. 0) THEN - WRITE (XERN1, '(I8)') MXIT - CALL XERMSG ('SLATEC', 'DSOS', 'YOU HAVE TOLD THE CODE ' // - * 'TO USE OPTIONAL INPUT ITEMS BY SETTING IFLAG=-1. ' // - * 'HOWEVER YOU HAVE CALLED THE CODE WITH THE MAXIMUM ' // - * 'ALLOWABLE NUMBER OF ITERATIONS SET TO IW(2) = ' // - * XERN1, 4, 1) - IFLAG = 9 - ENDIF - ENDIF -C - NC = (NEQ*(NEQ+1))/2 - IF (LRW .LT. 1 + 6*NEQ + NC) THEN - WRITE (XERN1, '(I8)') LRW - CALL XERMSG ('SLATEC', 'DSOS', 'DIMENSION OF THE RW ARRAY ' // - * 'MUST BE AT LEAST 1 + 6*NEQ + NEQ*(NEQ+1)/2 . YOU HAVE ' // - * 'CALLED THE CODE WITH LRW = ' // XERN1, 5, 1) - IFLAG = 9 - ENDIF -C - IF (LIW .LT. 3 + NEQ) THEN - WRITE (XERN1, '(I8)') LIW - CALL XERMSG ('SLATEC', 'DSOS', 'DIMENSION OF THE IW ARRAY ' // - * 'MUST BE AT LEAST 3 + NEQ. YOU HAVE CALLED THE CODE ' // - * 'WITH LIW = ' // XERN1, 6, 1) - IFLAG = 9 - ENDIF -C - IF (IFLAG .NE. 9) THEN - NCJS = 6 - NSRRC = 4 - NSRI = 5 -C - K1 = NC + 2 - K2 = K1 + NEQ - K3 = K2 + NEQ - K4 = K3 + NEQ - K5 = K4 + NEQ - K6 = K5 + NEQ -C - CALL DSOSEQ(FNC, NEQ, X, RTOLX, ATOLX, TOLF, IFLAG, MXIT, NCJS, - 1 NSRRC, NSRI, IPRINT, RW(1), RW(2), NC, RW(K1), - 2 RW(K2), RW(K3), RW(K4), RW(K5), RW(K6), IW(4)) -C - IW(3) = MXIT - ENDIF - RETURN - END diff --git a/slatec/dsoseq.f b/slatec/dsoseq.f deleted file mode 100644 index a9dc7c2..0000000 --- a/slatec/dsoseq.f +++ /dev/null @@ -1,501 +0,0 @@ -*DECK DSOSEQ - SUBROUTINE DSOSEQ (FNC, N, S, RTOLX, ATOLX, TOLF, IFLAG, MXIT, - + NCJS, NSRRC, NSRI, IPRINT, FMAX, C, NC, B, P, TEMP, X, Y, FAC, - + IS) -C***BEGIN PROLOGUE DSOSEQ -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSOS -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (SOSEQS-S, DSOSEQ-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C DSOSEQ solves a system of N simultaneous nonlinear equations. -C See the comments in the interfacing routine DSOS for a more -C detailed description of some of the items in the calling list. -C -C ********************************************************************** -C -Input- -C -C FNC- Function subprogram which evaluates the equations -C N -number of equations -C S -Solution vector of initial guesses -C RTOLX-Relative error tolerance on solution components -C ATOLX-Absolute error tolerance on solution components -C TOLF-Residual error tolerance -C MXIT-Maximum number of allowable iterations. -C NCJS-Maximum number of consecutive iterative steps to perform -C using the same triangular Jacobian matrix approximation. -C NSRRC-Number of consecutive iterative steps for which the -C limiting precision accuracy test must be satisfied -C before the routine exits with IFLAG=4. -C NSRI-Number of consecutive iterative steps for which the -C diverging condition test must be satisfied before -C the routine exits with IFLAG=7. -C IPRINT-Internal printing parameter. You must set IPRINT=-1 if you -C want the intermediate solution iterates and a residual norm -C to be printed. -C C -Internal work array, dimensioned at least N*(N+1)/2. -C NC -Dimension of C array. NC .GE. N*(N+1)/2. -C B -Internal work array, dimensioned N. -C P -Internal work array, dimensioned N. -C TEMP-Internal work array, dimensioned N. -C X -Internal work array, dimensioned N. -C Y -Internal work array, dimensioned N. -C FAC -Internal work array, dimensioned N. -C IS -Internal work array, dimensioned N. -C -C -Output- -C S -Solution vector -C IFLAG-Status indicator flag -C MXIT-The actual number of iterations performed -C FMAX-Residual norm -C C -Upper unit triangular matrix which approximates the -C forward triangularization of the full Jacobian matrix. -C Stored in a vector with dimension at least N*(N+1)/2. -C B -Contains the residuals (function values) divided -C by the corresponding components of the P vector -C P -Array used to store the partial derivatives. After -C each iteration P(K) contains the maximal derivative -C occurring in the K-th reduced equation. -C TEMP-Array used to store the previous solution iterate. -C X -Solution vector. Contains the values achieved on the -C last iteration loop upon exit from DSOS. -C Y -Array containing the solution increments. -C FAC -Array containing factors used in computing numerical -C derivatives. -C IS -Records the pivotal information (column interchanges) -C -C ********************************************************************** -C *** Three machine dependent parameters appear in this subroutine. -C -C *** The smallest positive magnitude, zero, is defined by the function -C *** routine D1MACH(1). -C -C *** URO, the computer unit roundoff value, is defined by D1MACH(3) for -C *** machines that round or D1MACH(4) for machines that truncate. -C *** URO is the smallest positive number such that 1.+URO .GT. 1. -C -C *** The output tape unit number, LOUN, is defined by the function -C *** I1MACH(2). -C ********************************************************************** -C -C***SEE ALSO DSOS -C***ROUTINES CALLED D1MACH, DSOSSL, I1MACH -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DSOSEQ -C -C - INTEGER I1MACH - DOUBLE PRECISION D1MACH - INTEGER IC, ICR, IFLAG, IPRINT, IS(*), ISJ, ISV, IT, ITEM, ITRY, - 1 J, JK, JS, K, KD, KJ, KK, KM1, KN, KSV, L, LOUN, LS, M, MIT, - 2 MM, MXIT, N, NC, NCJS, NP1, NSRI, NSRRC - DOUBLE PRECISION ATOLX, B(*), C(*), CSV, F, FAC(*), FACT, FDIF, - 1 FMAX, FMIN, FMXS, FN1, FN2, FNC, FP, H, HX, P(*), PMAX, RE, - 2 RTOLX, S(*), SRURO, TEMP(*), TEST, TOLF, URO, X(*), XNORM, - 3 Y(*), YJ, YN1, YN2, YN3, YNORM, YNS, ZERO -C -C BEGIN BLOCK PERMITTING ...EXITS TO 430 -C BEGIN BLOCK PERMITTING ...EXITS TO 410 -C BEGIN BLOCK PERMITTING ...EXITS TO 390 -C***FIRST EXECUTABLE STATEMENT DSOSEQ - URO = D1MACH(4) - LOUN = I1MACH(2) - ZERO = D1MACH(1) - RE = MAX(RTOLX,URO) - SRURO = SQRT(URO) -C - IFLAG = 0 - NP1 = N + 1 - ICR = 0 - IC = 0 - ITRY = NCJS - YN1 = 0.0D0 - YN2 = 0.0D0 - YN3 = 0.0D0 - YNS = 0.0D0 - MIT = 0 - FN1 = 0.0D0 - FN2 = 0.0D0 - FMXS = 0.0D0 -C -C INITIALIZE THE INTERCHANGE (PIVOTING) VECTOR AND -C SAVE THE CURRENT SOLUTION APPROXIMATION FOR FUTURE USE. -C - DO 10 K = 1, N - IS(K) = K - X(K) = S(K) - TEMP(K) = X(K) - 10 CONTINUE -C -C -C ********************************************************* -C **** BEGIN PRINCIPAL ITERATION LOOP **** -C ********************************************************* -C - DO 380 M = 1, MXIT -C BEGIN BLOCK PERMITTING ...EXITS TO 350 -C BEGIN BLOCK PERMITTING ...EXITS TO 240 -C - DO 20 K = 1, N - FAC(K) = SRURO - 20 CONTINUE -C - 30 CONTINUE -C BEGIN BLOCK PERMITTING ...EXITS TO 180 - KN = 1 - FMAX = 0.0D0 -C -C -C ******** BEGIN SUBITERATION LOOP DEFINING -C THE LINEARIZATION OF EACH ******** -C EQUATION WHICH RESULTS IN THE CONSTRUCTION -C OF AN UPPER ******** TRIANGULAR MATRIX -C APPROXIMATING THE FORWARD ******** -C TRIANGULARIZATION OF THE FULL JACOBIAN -C MATRIX -C - DO 170 K = 1, N -C BEGIN BLOCK PERMITTING ...EXITS TO 160 - KM1 = K - 1 -C -C BACK-SOLVE A TRIANGULAR LINEAR -C SYSTEM OBTAINING IMPROVED SOLUTION -C VALUES FOR K-1 OF THE VARIABLES FROM -C THE FIRST K-1 EQUATIONS. THESE -C VARIABLES ARE THEN ELIMINATED FROM -C THE K-TH EQUATION. -C - IF (KM1 .EQ. 0) GO TO 50 - CALL DSOSSL(K,N,KM1,Y,C,B,KN) - DO 40 J = 1, KM1 - JS = IS(J) - X(JS) = TEMP(JS) + Y(J) - 40 CONTINUE - 50 CONTINUE -C -C -C EVALUATE THE K-TH EQUATION AND THE -C INTERMEDIATE COMPUTATION FOR THE MAX -C NORM OF THE RESIDUAL VECTOR. -C - F = FNC(X,K) - FMAX = MAX(FMAX,ABS(F)) -C -C IF WE WISH TO PERFORM SEVERAL -C ITERATIONS USING A FIXED -C FACTORIZATION OF AN APPROXIMATE -C JACOBIAN,WE NEED ONLY UPDATE THE -C CONSTANT VECTOR. -C -C ...EXIT - IF (ITRY .LT. NCJS) GO TO 160 -C -C - IT = 0 -C -C COMPUTE PARTIAL DERIVATIVES THAT ARE -C REQUIRED IN THE LINEARIZATION OF THE -C K-TH REDUCED EQUATION -C - DO 90 J = K, N - ITEM = IS(J) - HX = X(ITEM) - H = FAC(ITEM)*HX - IF (ABS(H) .LE. ZERO) - 1 H = FAC(ITEM) - X(ITEM) = HX + H - IF (KM1 .EQ. 0) GO TO 70 - Y(J) = H - CALL DSOSSL(K,N,J,Y,C,B,KN) - DO 60 L = 1, KM1 - LS = IS(L) - X(LS) = TEMP(LS) + Y(L) - 60 CONTINUE - 70 CONTINUE - FP = FNC(X,K) - X(ITEM) = HX - FDIF = FP - F - IF (ABS(FDIF) .GT. URO*ABS(F)) - 1 GO TO 80 - FDIF = 0.0D0 - IT = IT + 1 - 80 CONTINUE - P(J) = FDIF/H - 90 CONTINUE -C - IF (IT .LE. (N - K)) GO TO 110 -C -C ALL COMPUTED PARTIAL DERIVATIVES -C OF THE K-TH EQUATION ARE -C EFFECTIVELY ZERO.TRY LARGER -C PERTURBATIONS OF THE INDEPENDENT -C VARIABLES. -C - DO 100 J = K, N - ISJ = IS(J) - FACT = 100.0D0*FAC(ISJ) -C ..............................EXIT - IF (FACT .GT. 1.0D10) - 1 GO TO 390 - FAC(ISJ) = FACT - 100 CONTINUE -C ............EXIT - GO TO 180 - 110 CONTINUE -C -C ...EXIT - IF (K .EQ. N) GO TO 160 -C -C ACHIEVE A PIVOTING EFFECT BY -C CHOOSING THE MAXIMAL DERIVATIVE -C ELEMENT -C - PMAX = 0.0D0 - DO 130 J = K, N - TEST = ABS(P(J)) - IF (TEST .LE. PMAX) GO TO 120 - PMAX = TEST - ISV = J - 120 CONTINUE - 130 CONTINUE -C ........................EXIT - IF (PMAX .EQ. 0.0D0) GO TO 390 -C -C SET UP THE COEFFICIENTS FOR THE K-TH -C ROW OF THE TRIANGULAR LINEAR SYSTEM -C AND SAVE THE PARTIAL DERIVATIVE OF -C LARGEST MAGNITUDE -C - PMAX = P(ISV) - KK = KN - DO 140 J = K, N - IF (J .NE. ISV) - 1 C(KK) = -P(J)/PMAX - KK = KK + 1 - 140 CONTINUE - P(K) = PMAX -C -C -C ...EXIT - IF (ISV .EQ. K) GO TO 160 -C -C INTERCHANGE THE TWO COLUMNS OF C -C DETERMINED BY THE PIVOTAL STRATEGY -C - KSV = IS(K) - IS(K) = IS(ISV) - IS(ISV) = KSV -C - KD = ISV - K - KJ = K - DO 150 J = 1, K - CSV = C(KJ) - JK = KJ + KD - C(KJ) = C(JK) - C(JK) = CSV - KJ = KJ + N - J - 150 CONTINUE - 160 CONTINUE -C - KN = KN + NP1 - K -C -C STORE THE COMPONENTS FOR THE CONSTANT -C VECTOR -C - B(K) = -F/P(K) -C - 170 CONTINUE -C ......EXIT - GO TO 190 - 180 CONTINUE - GO TO 30 - 190 CONTINUE -C -C ******** -C ******** END OF LOOP CREATING THE TRIANGULAR -C LINEARIZATION MATRIX -C ******** -C -C -C SOLVE THE RESULTING TRIANGULAR SYSTEM FOR A NEW -C SOLUTION APPROXIMATION AND OBTAIN THE SOLUTION -C INCREMENT NORM. -C - KN = KN - 1 - Y(N) = B(N) - IF (N .GT. 1) CALL DSOSSL(N,N,N,Y,C,B,KN) - XNORM = 0.0D0 - YNORM = 0.0D0 - DO 200 J = 1, N - YJ = Y(J) - YNORM = MAX(YNORM,ABS(YJ)) - JS = IS(J) - X(JS) = TEMP(JS) + YJ - XNORM = MAX(XNORM,ABS(X(JS))) - 200 CONTINUE -C -C -C PRINT INTERMEDIATE SOLUTION ITERATES AND -C RESIDUAL NORM IF DESIRED -C - IF (IPRINT .NE. (-1)) GO TO 220 - MM = M - 1 - WRITE (LOUN,210) FMAX,MM,(X(J), J = 1, N) - 210 FORMAT ('0RESIDUAL NORM =', D9.2, / 1X, - 1 'SOLUTION ITERATE (', I3, ')', / - 2 (1X, 5D26.14)) - 220 CONTINUE -C -C TEST FOR CONVERGENCE TO A SOLUTION (RELATIVE -C AND/OR ABSOLUTE ERROR COMPARISON ON SUCCESSIVE -C APPROXIMATIONS OF EACH SOLUTION VARIABLE) -C - DO 230 J = 1, N - JS = IS(J) -C ......EXIT - IF (ABS(Y(J)) .GT. RE*ABS(X(JS)) + ATOLX) - 1 GO TO 240 - 230 CONTINUE - IF (FMAX .LE. FMXS) IFLAG = 1 - 240 CONTINUE -C -C TEST FOR CONVERGENCE TO A SOLUTION BASED ON -C RESIDUALS -C - IF (FMAX .LE. TOLF) IFLAG = IFLAG + 2 -C ............EXIT - IF (IFLAG .GT. 0) GO TO 410 -C -C - IF (M .GT. 1) GO TO 250 - FMIN = FMAX - GO TO 330 - 250 CONTINUE -C BEGIN BLOCK PERMITTING ...EXITS TO 320 -C -C SAVE SOLUTION HAVING MINIMUM RESIDUAL NORM. -C - IF (FMAX .GE. FMIN) GO TO 270 - MIT = M + 1 - YN1 = YNORM - YN2 = YNS - FN1 = FMXS - FMIN = FMAX - DO 260 J = 1, N - S(J) = X(J) - 260 CONTINUE - IC = 0 - 270 CONTINUE -C -C TEST FOR LIMITING PRECISION CONVERGENCE. VERY -C SLOWLY CONVERGENT PROBLEMS MAY ALSO BE -C DETECTED. -C - IF (YNORM .GT. SRURO*XNORM) GO TO 290 - IF (FMAX .LT. 0.2D0*FMXS - 1 .OR. FMAX .GT. 5.0D0*FMXS) GO TO 290 - IF (YNORM .LT. 0.2D0*YNS - 1 .OR. YNORM .GT. 5.0D0*YNS) GO TO 290 - ICR = ICR + 1 - IF (ICR .GE. NSRRC) GO TO 280 - IC = 0 -C .........EXIT - GO TO 320 - 280 CONTINUE - IFLAG = 4 - FMAX = FMIN -C ........................EXIT - GO TO 430 - 290 CONTINUE - ICR = 0 -C -C TEST FOR DIVERGENCE OF THE ITERATIVE SCHEME. -C - IF (YNORM .GT. 2.0D0*YNS - 1 .OR. FMAX .GT. 2.0D0*FMXS) GO TO 300 - IC = 0 - GO TO 310 - 300 CONTINUE - IC = IC + 1 -C ......EXIT - IF (IC .LT. NSRI) GO TO 320 - IFLAG = 7 -C .....................EXIT - GO TO 410 - 310 CONTINUE - 320 CONTINUE - 330 CONTINUE -C -C CHECK TO SEE IF NEXT ITERATION CAN USE THE OLD -C JACOBIAN FACTORIZATION -C - ITRY = ITRY - 1 - IF (ITRY .EQ. 0) GO TO 340 - IF (20.0D0*YNORM .GT. XNORM) GO TO 340 - IF (YNORM .GT. 2.0D0*YNS) GO TO 340 -C ......EXIT - IF (FMAX .LT. 2.0D0*FMXS) GO TO 350 - 340 CONTINUE - ITRY = NCJS - 350 CONTINUE -C -C SAVE THE CURRENT SOLUTION APPROXIMATION AND THE -C RESIDUAL AND SOLUTION INCREMENT NORMS FOR USE IN THE -C NEXT ITERATION. -C - DO 360 J = 1, N - TEMP(J) = X(J) - 360 CONTINUE - IF (M .NE. MIT) GO TO 370 - FN2 = FMAX - YN3 = YNORM - 370 CONTINUE - FMXS = FMAX - YNS = YNORM -C -C - 380 CONTINUE -C -C ********************************************************* -C **** END OF PRINCIPAL ITERATION LOOP **** -C ********************************************************* -C -C -C TOO MANY ITERATIONS, CONVERGENCE WAS NOT ACHIEVED. - M = MXIT - IFLAG = 5 - IF (YN1 .GT. 10.0D0*YN2 .OR. YN3 .GT. 10.0D0*YN1) - 1 IFLAG = 6 - IF (FN1 .GT. 5.0D0*FMIN .OR. FN2 .GT. 5.0D0*FMIN) - 1 IFLAG = 6 - IF (FMAX .GT. 5.0D0*FMIN) IFLAG = 6 -C ......EXIT - GO TO 410 - 390 CONTINUE -C -C -C A JACOBIAN-RELATED MATRIX IS EFFECTIVELY SINGULAR. - IFLAG = 8 - DO 400 J = 1, N - S(J) = TEMP(J) - 400 CONTINUE -C ......EXIT - GO TO 430 - 410 CONTINUE -C -C - DO 420 J = 1, N - S(J) = X(J) - 420 CONTINUE - 430 CONTINUE -C -C - MXIT = M - RETURN - END diff --git a/slatec/dsossl.f b/slatec/dsossl.f deleted file mode 100644 index 96cbb4f..0000000 --- a/slatec/dsossl.f +++ /dev/null @@ -1,67 +0,0 @@ -*DECK DSOSSL - SUBROUTINE DSOSSL (K, N, L, X, C, B, M) -C***BEGIN PROLOGUE DSOSSL -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSOS -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (SOSSOL-S, DSOSSL-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C DSOSSL solves an upper triangular type of linear system by back -C substitution. -C -C The matrix C is upper trapezoidal and stored as a linear array by -C rows. The equations have been normalized so that the diagonal -C entries of C are understood to be unity. The off diagonal entries -C and the elements of the constant right hand side vector B have -C already been stored as the negatives of the corresponding equation -C values. -C With each call to DSOSSL a (K-1) by (K-1) triangular system is -C resolved. For L greater than K, column L of C is included in the -C right hand side vector. -C -C***SEE ALSO DSOS -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DSOSSL -C -C - INTEGER J, JKM, K, KJ, KM, KM1, KMM1, KN, L, LK, M, N, NP1 - DOUBLE PRECISION B(*), C(*), X(*), XMAX -C -C***FIRST EXECUTABLE STATEMENT DSOSSL - NP1 = N + 1 - KM1 = K - 1 - LK = KM1 - IF (L .EQ. K) LK = K - KN = M -C -C - DO 40 KJ = 1, KM1 - KMM1 = K - KJ - KM = KMM1 + 1 - XMAX = 0.0D0 - KN = KN - NP1 + KMM1 - IF (KM .GT. LK) GO TO 20 - JKM = KN -C - DO 10 J = KM, LK - JKM = JKM + 1 - XMAX = XMAX + C(JKM)*X(J) - 10 CONTINUE - 20 CONTINUE -C - IF (L .LE. K) GO TO 30 - JKM = KN + L - KMM1 - XMAX = XMAX + C(JKM)*X(L) - 30 CONTINUE - X(KMM1) = XMAX + B(KMM1) - 40 CONTINUE -C - RETURN - END diff --git a/slatec/dspco.f b/slatec/dspco.f deleted file mode 100644 index e879b56..0000000 --- a/slatec/dspco.f +++ /dev/null @@ -1,301 +0,0 @@ -*DECK DSPCO - SUBROUTINE DSPCO (AP, N, KPVT, RCOND, Z) -C***BEGIN PROLOGUE DSPCO -C***PURPOSE Factor a real symmetric matrix stored in packed form -C by elimination with symmetric pivoting and estimate the -C condition number of the matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1A -C***TYPE DOUBLE PRECISION (SSPCO-S, DSPCO-D, CHPCO-C, CSPCO-C) -C***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, -C MATRIX FACTORIZATION, PACKED, SYMMETRIC -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C DSPCO factors a double precision symmetric matrix stored in -C packed form by elimination with symmetric pivoting and estimates -C the condition of the matrix. -C -C IF RCOND is not needed, DSPFA is slightly faster. -C To solve A*X = B , follow DSPCO by DSPSL. -C To compute INVERSE(A)*C , follow DSPCO by DSPSL. -C To compute INVERSE(A) , follow DSPCO by DSPDI. -C To compute DETERMINANT(A) , follow DSPCO by DSPDI. -C To compute INERTIA(A), follow DSPCO by DSPDI. -C -C On Entry -C -C AP DOUBLE PRECISION (N*(N+1)/2) -C the packed form of a symmetric matrix A . The -C columns of the upper triangle are stored sequentially -C in a one-dimensional array of length N*(N+1)/2 . -C See comments below for details. -C -C N INTEGER -C the order of the matrix A . -C -C Output -C -C AP a block diagonal matrix and the multipliers which -C were used to obtain it stored in packed form. -C The factorization can be written A = U*D*TRANS(U) -C where U is a product of permutation and unit -C upper triangular matrices , TRANS(U) is the -C transpose of U , and D is block diagonal -C with 1 by 1 and 2 by 2 blocks. -C -C KPVT 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 Packed Storage -C -C The following program segment will pack the upper -C triangle of a symmetric matrix. -C -C K = 0 -C DO 20 J = 1, N -C DO 10 I = 1, J -C K = K + 1 -C AP(K) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DASUM, DAXPY, DDOT, DSCAL, DSPFA -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Modified routine equivalence list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DSPCO - INTEGER N,KPVT(*) - DOUBLE PRECISION AP(*),Z(*) - DOUBLE PRECISION RCOND -C - DOUBLE PRECISION AK,AKM1,BK,BKM1,DDOT,DENOM,EK,T - DOUBLE PRECISION ANORM,S,DASUM,YNORM - INTEGER I,IJ,IK,IKM1,IKP1,INFO,J,JM1,J1 - INTEGER K,KK,KM1K,KM1KM1,KP,KPS,KS -C -C FIND NORM OF A USING ONLY UPPER HALF -C -C***FIRST EXECUTABLE STATEMENT DSPCO - J1 = 1 - DO 30 J = 1, N - Z(J) = DASUM(J,AP(J1),1) - IJ = J1 - J1 = J1 + J - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 20 - DO 10 I = 1, JM1 - Z(I) = Z(I) + ABS(AP(IJ)) - IJ = IJ + 1 - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - ANORM = 0.0D0 - DO 40 J = 1, N - ANORM = MAX(ANORM,Z(J)) - 40 CONTINUE -C -C FACTOR -C - CALL DSPFA(AP,N,KPVT,INFO) -C -C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . -C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . -C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL -C GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . -C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. -C -C SOLVE U*D*W = E -C - EK = 1.0D0 - DO 50 J = 1, N - Z(J) = 0.0D0 - 50 CONTINUE - K = N - IK = (N*(N - 1))/2 - 60 IF (K .EQ. 0) GO TO 120 - KK = IK + K - IKM1 = IK - (K - 1) - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - KP = ABS(KPVT(K)) - KPS = K + 1 - KS - IF (KP .EQ. KPS) GO TO 70 - T = Z(KPS) - Z(KPS) = Z(KP) - Z(KP) = T - 70 CONTINUE - IF (Z(K) .NE. 0.0D0) EK = SIGN(EK,Z(K)) - Z(K) = Z(K) + EK - CALL DAXPY(K-KS,Z(K),AP(IK+1),1,Z(1),1) - IF (KS .EQ. 1) GO TO 80 - IF (Z(K-1) .NE. 0.0D0) EK = SIGN(EK,Z(K-1)) - Z(K-1) = Z(K-1) + EK - CALL DAXPY(K-KS,Z(K-1),AP(IKM1+1),1,Z(1),1) - 80 CONTINUE - IF (KS .EQ. 2) GO TO 100 - IF (ABS(Z(K)) .LE. ABS(AP(KK))) GO TO 90 - S = ABS(AP(KK))/ABS(Z(K)) - CALL DSCAL(N,S,Z,1) - EK = S*EK - 90 CONTINUE - IF (AP(KK) .NE. 0.0D0) Z(K) = Z(K)/AP(KK) - IF (AP(KK) .EQ. 0.0D0) Z(K) = 1.0D0 - GO TO 110 - 100 CONTINUE - KM1K = IK + K - 1 - KM1KM1 = IKM1 + K - 1 - AK = AP(KK)/AP(KM1K) - AKM1 = AP(KM1KM1)/AP(KM1K) - BK = Z(K)/AP(KM1K) - BKM1 = Z(K-1)/AP(KM1K) - DENOM = AK*AKM1 - 1.0D0 - Z(K) = (AKM1*BK - BKM1)/DENOM - Z(K-1) = (AK*BKM1 - BK)/DENOM - 110 CONTINUE - K = K - KS - IK = IK - K - IF (KS .EQ. 2) IK = IK - (K + 1) - GO TO 60 - 120 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) -C -C SOLVE TRANS(U)*Y = W -C - K = 1 - IK = 0 - 130 IF (K .GT. N) GO TO 160 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. 1) GO TO 150 - Z(K) = Z(K) + DDOT(K-1,AP(IK+1),1,Z(1),1) - IKP1 = IK + K - IF (KS .EQ. 2) - 1 Z(K+1) = Z(K+1) + DDOT(K-1,AP(IKP1+1),1,Z(1),1) - KP = ABS(KPVT(K)) - IF (KP .EQ. K) GO TO 140 - T = Z(K) - Z(K) = Z(KP) - Z(KP) = T - 140 CONTINUE - 150 CONTINUE - IK = IK + K - IF (KS .EQ. 2) IK = IK + (K + 1) - K = K + KS - GO TO 130 - 160 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) -C - YNORM = 1.0D0 -C -C SOLVE U*D*V = Y -C - K = N - IK = N*(N - 1)/2 - 170 IF (K .EQ. 0) GO TO 230 - KK = IK + K - IKM1 = IK - (K - 1) - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. KS) GO TO 190 - KP = ABS(KPVT(K)) - KPS = K + 1 - KS - IF (KP .EQ. KPS) GO TO 180 - T = Z(KPS) - Z(KPS) = Z(KP) - Z(KP) = T - 180 CONTINUE - CALL DAXPY(K-KS,Z(K),AP(IK+1),1,Z(1),1) - IF (KS .EQ. 2) CALL DAXPY(K-KS,Z(K-1),AP(IKM1+1),1,Z(1),1) - 190 CONTINUE - IF (KS .EQ. 2) GO TO 210 - IF (ABS(Z(K)) .LE. ABS(AP(KK))) GO TO 200 - S = ABS(AP(KK))/ABS(Z(K)) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM - 200 CONTINUE - IF (AP(KK) .NE. 0.0D0) Z(K) = Z(K)/AP(KK) - IF (AP(KK) .EQ. 0.0D0) Z(K) = 1.0D0 - GO TO 220 - 210 CONTINUE - KM1K = IK + K - 1 - KM1KM1 = IKM1 + K - 1 - AK = AP(KK)/AP(KM1K) - AKM1 = AP(KM1KM1)/AP(KM1K) - BK = Z(K)/AP(KM1K) - BKM1 = Z(K-1)/AP(KM1K) - DENOM = AK*AKM1 - 1.0D0 - Z(K) = (AKM1*BK - BKM1)/DENOM - Z(K-1) = (AK*BKM1 - BK)/DENOM - 220 CONTINUE - K = K - KS - IK = IK - K - IF (KS .EQ. 2) IK = IK - (K + 1) - GO TO 170 - 230 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE TRANS(U)*Z = V -C - K = 1 - IK = 0 - 240 IF (K .GT. N) GO TO 270 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. 1) GO TO 260 - Z(K) = Z(K) + DDOT(K-1,AP(IK+1),1,Z(1),1) - IKP1 = IK + K - IF (KS .EQ. 2) - 1 Z(K+1) = Z(K+1) + DDOT(K-1,AP(IKP1+1),1,Z(1),1) - KP = ABS(KPVT(K)) - IF (KP .EQ. K) GO TO 250 - T = Z(K) - Z(K) = Z(KP) - Z(KP) = T - 250 CONTINUE - 260 CONTINUE - IK = IK + K - IF (KS .EQ. 2) IK = IK + (K + 1) - K = K + KS - GO TO 240 - 270 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 diff --git a/slatec/dspdi.f b/slatec/dspdi.f deleted file mode 100644 index 5585491..0000000 --- a/slatec/dspdi.f +++ /dev/null @@ -1,256 +0,0 @@ -*DECK DSPDI - SUBROUTINE DSPDI (AP, N, KPVT, DET, INERT, WORK, JOB) -C***BEGIN PROLOGUE DSPDI -C***PURPOSE Compute the determinant, inertia, inverse of a real -C symmetric matrix stored in packed form using the factors -C from DSPFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1A, D3B1A -C***TYPE DOUBLE PRECISION (SSPDI-S, DSPDI-D, CHPDI-C, CSPDI-C) -C***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, -C PACKED, SYMMETRIC -C***AUTHOR Bunch, J., (UCSD) -C***DESCRIPTION -C -C DSPDI computes the determinant, inertia and inverse -C of a double precision symmetric matrix using the factors from -C DSPFA, where the matrix is stored in packed form. -C -C On Entry -C -C AP DOUBLE PRECISION (N*(N+1)/2) -C the output from DSPFA. -C -C N INTEGER -C the order of the matrix A. -C -C KPVT INTEGER(N) -C the pivot vector from DSPFA. -C -C WORK DOUBLE PRECISION(N) -C work vector. Contents ignored. -C -C JOB INTEGER -C JOB has the decimal expansion ABC where -C if C .NE. 0, the inverse is computed, -C if B .NE. 0, the determinant is computed, -C if A .NE. 0, the inertia is computed. -C -C For example, JOB = 111 gives all three. -C -C On Return -C -C Variables not requested by JOB are not used. -C -C AP contains the upper triangle of the inverse of -C the original matrix, stored in packed form. -C The columns of the upper triangle are stored -C sequentially in a one-dimensional array. -C -C DET DOUBLE PRECISION(2) -C determinant of original matrix. -C DETERMINANT = DET(1) * 10.0**DET(2) -C with 1.0 .LE. ABS(DET(1)) .LT. 10.0 -C or DET(1) = 0.0. -C -C INERT INTEGER(3) -C the inertia of the original matrix. -C INERT(1) = number of positive eigenvalues. -C INERT(2) = number of negative eigenvalues. -C INERT(3) = number of zero eigenvalues. -C -C Error Condition -C -C A division by zero will occur if the inverse is requested -C and DSPCO has set RCOND .EQ. 0.0 -C or DSPFA has set INFO .NE. 0 . -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DCOPY, DDOT, DSWAP -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Modified routine equivalence list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DSPDI - INTEGER N,JOB - DOUBLE PRECISION AP(*),WORK(*) - DOUBLE PRECISION DET(2) - INTEGER KPVT(*),INERT(3) -C - DOUBLE PRECISION AKKP1,DDOT,TEMP - DOUBLE PRECISION TEN,D,T,AK,AKP1 - INTEGER IJ,IK,IKP1,IKS,J,JB,JK,JKP1 - INTEGER K,KK,KKP1,KM1,KS,KSJ,KSKP1,KSTEP - LOGICAL NOINV,NODET,NOERT -C***FIRST EXECUTABLE STATEMENT DSPDI - NOINV = MOD(JOB,10) .EQ. 0 - NODET = MOD(JOB,100)/10 .EQ. 0 - NOERT = MOD(JOB,1000)/100 .EQ. 0 -C - IF (NODET .AND. NOERT) GO TO 140 - IF (NOERT) GO TO 10 - INERT(1) = 0 - INERT(2) = 0 - INERT(3) = 0 - 10 CONTINUE - IF (NODET) GO TO 20 - DET(1) = 1.0D0 - DET(2) = 0.0D0 - TEN = 10.0D0 - 20 CONTINUE - T = 0.0D0 - IK = 0 - DO 130 K = 1, N - KK = IK + K - D = AP(KK) -C -C CHECK IF 1 BY 1 -C - IF (KPVT(K) .GT. 0) GO TO 50 -C -C 2 BY 2 BLOCK -C USE DET (D S) = (D/T * C - T) * T , T = ABS(S) -C (S C) -C TO AVOID UNDERFLOW/OVERFLOW TROUBLES. -C TAKE TWO PASSES THROUGH SCALING. USE T FOR FLAG. -C - IF (T .NE. 0.0D0) GO TO 30 - IKP1 = IK + K - KKP1 = IKP1 + K - T = ABS(AP(KKP1)) - D = (D/T)*AP(KKP1+1) - T - GO TO 40 - 30 CONTINUE - D = T - T = 0.0D0 - 40 CONTINUE - 50 CONTINUE -C - IF (NOERT) GO TO 60 - IF (D .GT. 0.0D0) INERT(1) = INERT(1) + 1 - IF (D .LT. 0.0D0) INERT(2) = INERT(2) + 1 - IF (D .EQ. 0.0D0) INERT(3) = INERT(3) + 1 - 60 CONTINUE -C - IF (NODET) GO TO 120 - DET(1) = D*DET(1) - IF (DET(1) .EQ. 0.0D0) GO TO 110 - 70 IF (ABS(DET(1)) .GE. 1.0D0) GO TO 80 - DET(1) = TEN*DET(1) - DET(2) = DET(2) - 1.0D0 - GO TO 70 - 80 CONTINUE - 90 IF (ABS(DET(1)) .LT. TEN) GO TO 100 - DET(1) = DET(1)/TEN - DET(2) = DET(2) + 1.0D0 - GO TO 90 - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE - IK = IK + K - 130 CONTINUE - 140 CONTINUE -C -C COMPUTE INVERSE(A) -C - IF (NOINV) GO TO 270 - K = 1 - IK = 0 - 150 IF (K .GT. N) GO TO 260 - KM1 = K - 1 - KK = IK + K - IKP1 = IK + K - KKP1 = IKP1 + K - IF (KPVT(K) .LT. 0) GO TO 180 -C -C 1 BY 1 -C - AP(KK) = 1.0D0/AP(KK) - IF (KM1 .LT. 1) GO TO 170 - CALL DCOPY(KM1,AP(IK+1),1,WORK,1) - IJ = 0 - DO 160 J = 1, KM1 - JK = IK + J - AP(JK) = DDOT(J,AP(IJ+1),1,WORK,1) - CALL DAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IK+1),1) - IJ = IJ + J - 160 CONTINUE - AP(KK) = AP(KK) + DDOT(KM1,WORK,1,AP(IK+1),1) - 170 CONTINUE - KSTEP = 1 - GO TO 220 - 180 CONTINUE -C -C 2 BY 2 -C - T = ABS(AP(KKP1)) - AK = AP(KK)/T - AKP1 = AP(KKP1+1)/T - AKKP1 = AP(KKP1)/T - D = T*(AK*AKP1 - 1.0D0) - AP(KK) = AKP1/D - AP(KKP1+1) = AK/D - AP(KKP1) = -AKKP1/D - IF (KM1 .LT. 1) GO TO 210 - CALL DCOPY(KM1,AP(IKP1+1),1,WORK,1) - IJ = 0 - DO 190 J = 1, KM1 - JKP1 = IKP1 + J - AP(JKP1) = DDOT(J,AP(IJ+1),1,WORK,1) - CALL DAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IKP1+1),1) - IJ = IJ + J - 190 CONTINUE - AP(KKP1+1) = AP(KKP1+1) - 1 + DDOT(KM1,WORK,1,AP(IKP1+1),1) - AP(KKP1) = AP(KKP1) - 1 + DDOT(KM1,AP(IK+1),1,AP(IKP1+1),1) - CALL DCOPY(KM1,AP(IK+1),1,WORK,1) - IJ = 0 - DO 200 J = 1, KM1 - JK = IK + J - AP(JK) = DDOT(J,AP(IJ+1),1,WORK,1) - CALL DAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IK+1),1) - IJ = IJ + J - 200 CONTINUE - AP(KK) = AP(KK) + DDOT(KM1,WORK,1,AP(IK+1),1) - 210 CONTINUE - KSTEP = 2 - 220 CONTINUE -C -C SWAP -C - KS = ABS(KPVT(K)) - IF (KS .EQ. K) GO TO 250 - IKS = (KS*(KS - 1))/2 - CALL DSWAP(KS,AP(IKS+1),1,AP(IK+1),1) - KSJ = IK + KS - DO 230 JB = KS, K - J = K + KS - JB - JK = IK + J - TEMP = AP(JK) - AP(JK) = AP(KSJ) - AP(KSJ) = TEMP - KSJ = KSJ - (J - 1) - 230 CONTINUE - IF (KSTEP .EQ. 1) GO TO 240 - KSKP1 = IKP1 + KS - TEMP = AP(KSKP1) - AP(KSKP1) = AP(KKP1) - AP(KKP1) = TEMP - 240 CONTINUE - 250 CONTINUE - IK = IK + K - IF (KSTEP .EQ. 2) IK = IK + K + 1 - K = K + KSTEP - GO TO 150 - 260 CONTINUE - 270 CONTINUE - RETURN - END diff --git a/slatec/dspenc.f b/slatec/dspenc.f deleted file mode 100644 index d326b06..0000000 --- a/slatec/dspenc.f +++ /dev/null @@ -1,140 +0,0 @@ -*DECK DSPENC - DOUBLE PRECISION FUNCTION DSPENC (X) -C***BEGIN PROLOGUE DSPENC -C***PURPOSE Compute a form of Spence's integral due to K. Mitchell. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C5 -C***TYPE DOUBLE PRECISION (SPENC-S, DSPENC-D) -C***KEYWORDS FNLIB, SPECIAL FUNCTIONS, SPENCE'S INTEGRAL -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DSPENC(X) calculates the double precision Spence's integral -C for double precision argument X. Spence's function defined by -C integral from 0 to X of -LOG(1-Y)/Y DY. -C For ABS(X) .LE. 1, the uniformly convergent expansion -C DSPENC = sum K=1,infinity X**K / K**2 is valid. -C This is a form of Spence's integral due to K. Mitchell which differs -C from the definition in the NBS Handbook of Mathematical Functions. -C -C Spence's function can be used to evaluate much more general integral -C forms. For example, -C integral from 0 to Z of LOG(A*X+B)/(C*X+D) DX = -C LOG(ABS(B-A*D/C))*LOG(ABS(A*(C*X+D)/(A*D-B*C)))/C -C - DSPENC (A*(C*Z+D)/(A*D-B*C)) / C. -C -C Ref -- K. Mitchell, Philosophical Magazine, 40, p.351 (1949). -C Stegun and Abromowitz, AMS 55, p.1004. -C -C -C Series for SPEN on the interval 0. to 5.00000E-01 -C with weighted error 4.74E-32 -C log weighted error 31.32 -C significant figures required 30.37 -C decimal places required 32.11 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DCSEVL, INITDS -C***REVISION HISTORY (YYMMDD) -C 780201 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891115 Corrected third argument in reference to INITDS. (WRB) -C 891115 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE DSPENC - DOUBLE PRECISION X, SPENCS(38), ALN, PI26, XBIG, D1MACH, DCSEVL - LOGICAL FIRST - SAVE SPENCS, PI26, NSPENC, XBIG, FIRST - DATA SPENCS( 1) / +.1527365598 8924058729 4668491002 8 D+0 / - DATA SPENCS( 2) / +.8169658058 0510144035 0183818527 1 D-1 / - DATA SPENCS( 3) / +.5814157140 7787308729 7735064118 2 D-2 / - DATA SPENCS( 4) / +.5371619814 5415275422 4788900531 9 D-3 / - DATA SPENCS( 5) / +.5724704675 1858262332 1060305478 2 D-4 / - DATA SPENCS( 6) / +.6674546121 6493363436 0783543858 9 D-5 / - DATA SPENCS( 7) / +.8276467339 7156769815 8439168901 1 D-6 / - DATA SPENCS( 8) / +.1073315673 0306789512 7000587335 4 D-6 / - DATA SPENCS( 9) / +.1440077294 3032394023 3459033151 3 D-7 / - DATA SPENCS( 10) / +.1984442029 9659063678 9887713960 8 D-8 / - DATA SPENCS( 11) / +.2794005822 1636387202 0199482161 5 D-9 / - DATA SPENCS( 12) / +.4003991310 8833118230 7258044590 8 D-10 / - DATA SPENCS( 13) / +.5823462892 0446384713 6813583575 7 D-11 / - DATA SPENCS( 14) / +.8576708692 6386892780 9791477122 4 D-12 / - DATA SPENCS( 15) / +.1276862586 2801930459 8948303343 3 D-12 / - DATA SPENCS( 16) / +.1918826209 0425170811 6238041606 2 D-13 / - DATA SPENCS( 17) / +.2907319206 9771381777 9579971967 3 D-14 / - DATA SPENCS( 18) / +.4437112685 2767804625 5747364174 5 D-15 / - DATA SPENCS( 19) / +.6815727787 4145995278 6735913560 7 D-16 / - DATA SPENCS( 20) / +.1053017386 0155744295 4701941664 4 D-16 / - DATA SPENCS( 21) / +.1635389806 7523771000 5182173457 0 D-17 / - DATA SPENCS( 22) / +.2551852874 9404639323 1090164258 1 D-18 / - DATA SPENCS( 23) / +.3999020621 9993601127 7047037951 9 D-19 / - DATA SPENCS( 24) / +.6291501645 2168118765 1414917119 9 D-20 / - DATA SPENCS( 25) / +.9933827435 6756776438 0388775253 3 D-21 / - DATA SPENCS( 26) / +.1573679570 7499648167 2176380586 6 D-21 / - DATA SPENCS( 27) / +.2500595316 8494761293 6927095466 6 D-22 / - DATA SPENCS( 28) / +.3984740918 3838111392 1066325333 3 D-23 / - DATA SPENCS( 29) / +.6366473210 0828438926 9132629333 3 D-24 / - DATA SPENCS( 30) / +.1019674287 2396783670 7706197333 3 D-24 / - DATA SPENCS( 31) / +.1636881058 9135188411 1107413333 3 D-25 / - DATA SPENCS( 32) / +.2633310439 4176501173 4527999999 9 D-26 / - DATA SPENCS( 33) / +.4244811560 1239768172 2436266666 6 D-27 / - DATA SPENCS( 34) / +.6855411983 6800529168 2474666666 6 D-28 / - DATA SPENCS( 35) / +.1109122433 4380564340 1898666666 6 D-28 / - DATA SPENCS( 36) / +.1797431304 9998914573 6533333333 3 D-29 / - DATA SPENCS( 37) / +.2917505845 9760951732 9066666666 6 D-30 / - DATA SPENCS( 38) / +.4742646808 9286710613 3333333333 3 D-31 / - DATA PI26 / +1.644934066 8482264364 7241516664 6025189219 D0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DSPENC - IF (FIRST) THEN - NSPENC = INITDS (SPENCS, 38, 0.1*REAL(D1MACH(3))) - XBIG = 1.0D0/D1MACH(3) - ENDIF - FIRST = .FALSE. -C - IF (X.GT.2.0D0) GO TO 60 - IF (X.GT.1.0D0) GO TO 50 - IF (X.GT.0.5D0) GO TO 40 - IF (X.GE.0.0D0) GO TO 30 - IF (X.GT.(-1.D0)) GO TO 20 -C -C HERE IF X .LE. -1.0 -C - ALN = LOG(1.0D0-X) - DSPENC = -PI26 - 0.5D0*ALN*(2.0D0*LOG(-X)-ALN) - IF (X.GT.(-XBIG)) DSPENC = DSPENC - 1 + (1.D0 + DCSEVL (4.D0/(1.D0-X)-1.D0, SPENCS, NSPENC))/(1.D0-X) - RETURN -C -C -1.0 .LT. X .LT. 0.0 -C - 20 DSPENC = -0.5D0*LOG(1.0D0-X)**2 - 1 - X*(1.D0+DCSEVL(4.D0*X/(X-1.D0)-1.D0, SPENCS, NSPENC))/(X-1.D0) - RETURN -C -C 0.0 .LE. X .LE. 0.5 -C - 30 DSPENC = X*(1.D0 + DCSEVL (4.D0*X-1.D0, SPENCS, NSPENC)) - RETURN -C -C 0.5 .LT. X .LE. 1.0 -C - 40 DSPENC = PI26 - IF (X.NE.1.D0) DSPENC = PI26 - LOG(X)*LOG(1.0D0-X) - 1 - (1.D0-X)*(1.D0+DCSEVL(4.D0*(1.D0-X)-1.D0, SPENCS, NSPENC)) - RETURN -C -C 1.0 .LT. X .LE. 2.0 -C - 50 DSPENC = PI26 - 0.5D0*LOG(X)*LOG((X-1.D0)**2/X) - 1 + (X-1.D0)*(1.D0+DCSEVL(4.D0*(X-1.D0)/X-1.D0, SPENCS, NSPENC))/X - RETURN -C -C X .GT. 2.0 -C - 60 DSPENC = 2.0D0*PI26 - 0.5D0*LOG(X)**2 - IF (X.LT.XBIG) DSPENC = DSPENC - 1 - (1.D0 + DCSEVL (4.D0/X-1.D0, SPENCS, NSPENC))/X - RETURN -C - END diff --git a/slatec/dspfa.f b/slatec/dspfa.f deleted file mode 100644 index 25cb117..0000000 --- a/slatec/dspfa.f +++ /dev/null @@ -1,277 +0,0 @@ -*DECK DSPFA - SUBROUTINE DSPFA (AP, N, KPVT, INFO) -C***BEGIN PROLOGUE DSPFA -C***PURPOSE Factor a real symmetric matrix stored in packed form by -C elimination with symmetric pivoting. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1A -C***TYPE DOUBLE PRECISION (SSPFA-S, DSPFA-D, CHPFA-C, CSPFA-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, PACKED, -C SYMMETRIC -C***AUTHOR Bunch, J., (UCSD) -C***DESCRIPTION -C -C DSPFA factors a double precision symmetric matrix stored in -C packed form by elimination with symmetric pivoting. -C -C To solve A*X = B , follow DSPFA by DSPSL. -C To compute INVERSE(A)*C , follow DSPFA by DSPSL. -C To compute DETERMINANT(A) , follow DSPFA by DSPDI. -C To compute INERTIA(A) , follow DSPFA by DSPDI. -C To compute INVERSE(A) , follow DSPFA by DSPDI. -C -C On Entry -C -C AP DOUBLE PRECISION (N*(N+1)/2) -C the packed form of a symmetric matrix A . The -C columns of the upper triangle are stored sequentially -C in a one-dimensional array of length N*(N+1)/2 . -C See comments below for details. -C -C N INTEGER -C the order of the matrix A . -C -C Output -C -C AP a block diagonal matrix and the multipliers which -C were used to obtain it stored in packed form. -C The factorization can be written A = U*D*TRANS(U) -C where U is a product of permutation and unit -C upper triangular matrices, TRANS(U) is the -C transpose of U , and D is block diagonal -C with 1 by 1 and 2 by 2 blocks. -C -C KPVT INTEGER(N) -C an integer vector of pivot indices. -C -C INFO INTEGER -C = 0 normal value. -C = K if the K-th pivot block is singular. This is -C not an error condition for this subroutine, -C but it does indicate that DSPSL or DSPDI may -C divide by zero if called. -C -C Packed Storage -C -C The following program segment will pack the upper -C triangle of a symmetric matrix. -C -C K = 0 -C DO 20 J = 1, N -C DO 10 I = 1, J -C K = K + 1 -C AP(K) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DSWAP, IDAMAX -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Modified routine equivalence list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DSPFA - INTEGER N,KPVT(*),INFO - DOUBLE PRECISION AP(*) -C - DOUBLE PRECISION AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T - DOUBLE PRECISION ABSAKK,ALPHA,COLMAX,ROWMAX - INTEGER IDAMAX,IJ,IK,IKM1,IM,IMAX,IMAXP1,IMIM,IMJ,IMK - INTEGER J,JJ,JK,JKM1,JMAX,JMIM,K,KK,KM1,KM1K,KM1KM1,KM2,KSTEP - LOGICAL SWAP -C***FIRST EXECUTABLE STATEMENT DSPFA -C -C INITIALIZE -C -C ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE. -C - ALPHA = (1.0D0 + SQRT(17.0D0))/8.0D0 -C - INFO = 0 -C -C MAIN LOOP ON K, WHICH GOES FROM N TO 1. -C - K = N - IK = (N*(N - 1))/2 - 10 CONTINUE -C -C LEAVE THE LOOP IF K=0 OR K=1. -C - IF (K .EQ. 0) GO TO 200 - IF (K .GT. 1) GO TO 20 - KPVT(1) = 1 - IF (AP(1) .EQ. 0.0D0) INFO = 1 - GO TO 200 - 20 CONTINUE -C -C THIS SECTION OF CODE DETERMINES THE KIND OF -C ELIMINATION TO BE PERFORMED. WHEN IT IS COMPLETED, -C KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND -C SWAP WILL BE SET TO .TRUE. IF AN INTERCHANGE IS -C REQUIRED. -C - KM1 = K - 1 - KK = IK + K - ABSAKK = ABS(AP(KK)) -C -C DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN -C COLUMN K. -C - IMAX = IDAMAX(K-1,AP(IK+1),1) - IMK = IK + IMAX - COLMAX = ABS(AP(IMK)) - IF (ABSAKK .LT. ALPHA*COLMAX) GO TO 30 - KSTEP = 1 - SWAP = .FALSE. - GO TO 90 - 30 CONTINUE -C -C DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN -C ROW IMAX. -C - ROWMAX = 0.0D0 - IMAXP1 = IMAX + 1 - IM = IMAX*(IMAX - 1)/2 - IMJ = IM + 2*IMAX - DO 40 J = IMAXP1, K - ROWMAX = MAX(ROWMAX,ABS(AP(IMJ))) - IMJ = IMJ + J - 40 CONTINUE - IF (IMAX .EQ. 1) GO TO 50 - JMAX = IDAMAX(IMAX-1,AP(IM+1),1) - JMIM = JMAX + IM - ROWMAX = MAX(ROWMAX,ABS(AP(JMIM))) - 50 CONTINUE - IMIM = IMAX + IM - IF (ABS(AP(IMIM)) .LT. ALPHA*ROWMAX) GO TO 60 - KSTEP = 1 - SWAP = .TRUE. - GO TO 80 - 60 CONTINUE - IF (ABSAKK .LT. ALPHA*COLMAX*(COLMAX/ROWMAX)) GO TO 70 - KSTEP = 1 - SWAP = .FALSE. - GO TO 80 - 70 CONTINUE - KSTEP = 2 - SWAP = IMAX .NE. KM1 - 80 CONTINUE - 90 CONTINUE - IF (MAX(ABSAKK,COLMAX) .NE. 0.0D0) GO TO 100 -C -C COLUMN K IS ZERO. SET INFO AND ITERATE THE LOOP. -C - KPVT(K) = K - INFO = K - GO TO 190 - 100 CONTINUE - IF (KSTEP .EQ. 2) GO TO 140 -C -C 1 X 1 PIVOT BLOCK. -C - IF (.NOT.SWAP) GO TO 120 -C -C PERFORM AN INTERCHANGE. -C - CALL DSWAP(IMAX,AP(IM+1),1,AP(IK+1),1) - IMJ = IK + IMAX - DO 110 JJ = IMAX, K - J = K + IMAX - JJ - JK = IK + J - T = AP(JK) - AP(JK) = AP(IMJ) - AP(IMJ) = T - IMJ = IMJ - (J - 1) - 110 CONTINUE - 120 CONTINUE -C -C PERFORM THE ELIMINATION. -C - IJ = IK - (K - 1) - DO 130 JJ = 1, KM1 - J = K - JJ - JK = IK + J - MULK = -AP(JK)/AP(KK) - T = MULK - CALL DAXPY(J,T,AP(IK+1),1,AP(IJ+1),1) - AP(JK) = MULK - IJ = IJ - (J - 1) - 130 CONTINUE -C -C SET THE PIVOT ARRAY. -C - KPVT(K) = K - IF (SWAP) KPVT(K) = IMAX - GO TO 190 - 140 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - KM1K = IK + K - 1 - IKM1 = IK - (K - 1) - IF (.NOT.SWAP) GO TO 160 -C -C PERFORM AN INTERCHANGE. -C - CALL DSWAP(IMAX,AP(IM+1),1,AP(IKM1+1),1) - IMJ = IKM1 + IMAX - DO 150 JJ = IMAX, KM1 - J = KM1 + IMAX - JJ - JKM1 = IKM1 + J - T = AP(JKM1) - AP(JKM1) = AP(IMJ) - AP(IMJ) = T - IMJ = IMJ - (J - 1) - 150 CONTINUE - T = AP(KM1K) - AP(KM1K) = AP(IMK) - AP(IMK) = T - 160 CONTINUE -C -C PERFORM THE ELIMINATION. -C - KM2 = K - 2 - IF (KM2 .EQ. 0) GO TO 180 - AK = AP(KK)/AP(KM1K) - KM1KM1 = IKM1 + K - 1 - AKM1 = AP(KM1KM1)/AP(KM1K) - DENOM = 1.0D0 - AK*AKM1 - IJ = IK - (K - 1) - (K - 2) - DO 170 JJ = 1, KM2 - J = KM1 - JJ - JK = IK + J - BK = AP(JK)/AP(KM1K) - JKM1 = IKM1 + J - BKM1 = AP(JKM1)/AP(KM1K) - MULK = (AKM1*BK - BKM1)/DENOM - MULKM1 = (AK*BKM1 - BK)/DENOM - T = MULK - CALL DAXPY(J,T,AP(IK+1),1,AP(IJ+1),1) - T = MULKM1 - CALL DAXPY(J,T,AP(IKM1+1),1,AP(IJ+1),1) - AP(JK) = MULK - AP(JKM1) = MULKM1 - IJ = IJ - (J - 1) - 170 CONTINUE - 180 CONTINUE -C -C SET THE PIVOT ARRAY. -C - KPVT(K) = 1 - K - IF (SWAP) KPVT(K) = -IMAX - KPVT(K-1) = KPVT(K) - 190 CONTINUE - IK = IK - (K - 1) - IF (KSTEP .EQ. 2) IK = IK - (K - 2) - K = K - KSTEP - GO TO 10 - 200 CONTINUE - RETURN - END diff --git a/slatec/dsplp.f b/slatec/dsplp.f deleted file mode 100644 index e039594..0000000 --- a/slatec/dsplp.f +++ /dev/null @@ -1,1683 +0,0 @@ -*DECK DSPLP - SUBROUTINE DSPLP (DUSRMT, MRELAS, NVARS, COSTS, PRGOPT, DATTRV, - + BL, BU, IND, INFO, PRIMAL, DUALS, IBASIS, WORK, LW, IWORK, LIW) -C***BEGIN PROLOGUE DSPLP -C***PURPOSE Solve linear programming problems involving at -C most a few thousand constraints and variables. -C Takes advantage of sparsity in the constraint matrix. -C***LIBRARY SLATEC -C***CATEGORY G2A2 -C***TYPE DOUBLE PRECISION (SPLP-S, DSPLP-D) -C***KEYWORDS LINEAR CONSTRAINTS, LINEAR OPTIMIZATION, -C LINEAR PROGRAMMING, LP, SPARSE CONSTRAINTS -C***AUTHOR Hanson, R. J., (SNLA) -C Hiebert, K. L., (SNLA) -C***DESCRIPTION -C -C These are the short usage instructions; for details about -C other features, options and methods for defining the matrix -C A, see the extended usage instructions which are contained in -C the Long Description section below. -C -C |------------| -C |Introduction| -C |------------| -C The subprogram DSPLP( ) solves a linear optimization problem. -C The problem statement is as follows -C -C minimize (transpose of costs)*x -C subject to A*x=w. -C -C The entries of the unknowns x and w may have simple lower or -C upper bounds (or both), or be free to take on any value. By -C setting the bounds for x and w, the user is imposing the con- -C straints of the problem. The matrix A has MRELAS rows and -C NVARS columns. The vectors costs, x, and w respectively -C have NVARS, NVARS, and MRELAS number of entries. -C -C The input for the problem includes the problem dimensions, -C MRELAS and NVARS, the array COSTS(*), data for the matrix -C A, and the bound information for the unknowns x and w, BL(*), -C BU(*), and IND(*). Only the nonzero entries of the matrix A -C are passed to DSPLP( ). -C -C The output from the problem (when output flag INFO=1) includes -C optimal values for x and w in PRIMAL(*), optimal values for -C dual variables of the equations A*x=w and the simple bounds -C on x in DUALS(*), and the indices of the basic columns, -C IBASIS(*). -C -C |------------------------------| -C |Fortran Declarations Required:| -C |------------------------------| -C -C DIMENSION COSTS(NVARS),PRGOPT(*),DATTRV(*), -C *BL(NVARS+MRELAS),BU(NVARS+MRELAS),IND(NVARS+MRELAS), -C *PRIMAL(NVARS+MRELAS),DUALS(MRELAS+NVARS),IBASIS(NVARS+MRELAS), -C *WORK(LW),IWORK(LIW) -C -C EXTERNAL DUSRMT -C -C The dimensions of PRGOPT(*) and DATTRV(*) must be at least 1. -C The exact lengths will be determined by user-required options and -C data transferred to the subprogram DUSRMT( ). -C -C The values of LW and LIW, the lengths of the arrays WORK(*) -C and IWORK(*), must satisfy the inequalities -C -C LW .GE. 4*NVARS+ 8*MRELAS+LAMAT+ LBM -C LIW.GE. NVARS+11*MRELAS+LAMAT+2*LBM -C -C It is an error if they do not both satisfy these inequalities. -C (The subprogram will inform the user of the required lengths -C if either LW or LIW is wrong.) The values of LAMAT and LBM -C nominally are -C -C LAMAT=4*NVARS+7 -C and LBM =8*MRELAS -C -C LAMAT determines the length of the sparse matrix storage area. -C The value of LBM determines the amount of storage available -C to decompose and update the active basis matrix. -C -C |------| -C |Input:| -C |------| -C -C MRELAS,NVARS -C ------------ -C These parameters are respectively the number of constraints (the -C linear relations A*x=w that the unknowns x and w are to satisfy) -C and the number of entries in the vector x. Both must be .GE. 1. -C Other values are errors. -C -C COSTS(*) -C -------- -C The NVARS entries of this array are the coefficients of the -C linear objective function. The value COSTS(J) is the -C multiplier for variable J of the unknown vector x. Each -C entry of this array must be defined. -C -C DUSRMT -C ------ -C This is the name of a specific subprogram in the DSPLP( ) package -C used to define the matrix A. In this usage mode of DSPLP( ) -C the user places the nonzero entries of A in the -C array DATTRV(*) as given in the description of that parameter. -C The name DUSRMT must appear in a Fortran EXTERNAL statement. -C -C DATTRV(*) -C --------- -C The array DATTRV(*) contains data for the matrix A as follows: -C Each column (numbered J) requires (floating point) data con- -C sisting of the value (-J) followed by pairs of values. Each pair -C consists of the row index immediately followed by the value -C of the matrix at that entry. A value of J=0 signals that there -C are no more columns. The required length of -C DATTRV(*) is 2*no. of nonzeros + NVARS + 1. -C -C BL(*),BU(*),IND(*) -C ------------------ -C The values of IND(*) are input parameters that define -C the form of the bounds for the unknowns x and w. The values for -C the bounds are found in the arrays BL(*) and BU(*) as follows. -C -C For values of J between 1 and NVARS, -C if IND(J)=1, then X(J) .GE. BL(J); BU(J) is not used. -C if IND(J)=2, then X(J) .LE. BU(J); BL(J) is not used. -C if IND(J)=3, then BL(J) .LE. X(J) .LE. BU(J),(BL(J)=BU(J) ok) -C if IND(J)=4, then X(J) is free to have any value, -C and BL(J), BU(J) are not used. -C -C For values of I between NVARS+1 and NVARS+MRELAS, -C if IND(I)=1, then W(I-NVARS) .GE. BL(I); BU(I) is not used. -C if IND(I)=2, then W(I-NVARS) .LE. BU(I); BL(I) is not used. -C if IND(I)=3, then BL(I) .LE. W(I-NVARS) .LE. BU(I), -C (BL(I)=BU(I) is ok). -C if IND(I)=4, then W(I-NVARS) is free to have any value, -C and BL(I), BU(I) are not used. -C -C A value of IND(*) not equal to 1,2,3 or 4 is an error. When -C IND(I)=3, BL(I) must be .LE. BU(I). The condition BL(I).GT. -C BU(I) indicates infeasibility and is an error. -C -C PRGOPT(*) -C --------- -C This array is used to redefine various parameters within DSPLP( ). -C Frequently, perhaps most of the time, a user will be satisfied -C and obtain the solutions with no changes to any of these -C parameters. To try this, simply set PRGOPT(1)=1.D0. -C -C For users with more sophisticated needs, DSPLP( ) provides several -C options that may be used to take advantage of more detailed -C knowledge of the problem or satisfy other utilitarian needs. -C The complete description of how to use this option array to -C utilize additional subprogram features is found under the -C heading of DSPLP( ) Subprogram Options in the Extended -C Usage Instructions. -C -C Briefly, the user should note the following value of the parameter -C KEY and the corresponding task or feature desired before turning -C to that document. -C -C Value Brief Statement of Purpose for Option -C of KEY -C ------ ------------------------------------- -C 50 Change from a minimization problem to a -C maximization problem. -C 51 Change the amount of printed output. -C Normally, no printed output is obtained. -C 52 Redefine the line length and precision used -C for the printed output. -C 53 Redefine the values of LAMAT and LBM that -C were discussed above under the heading -C Fortran Declarations Required. -C 54 Redefine the unit number where pages of the sparse -C data matrix A are stored. Normally, the unit -C number is 1. -C 55 A computation, partially completed, is -C being continued. Read the up-to-date -C partial results from unit number 2. -C 56 Redefine the unit number where the partial results -C are stored. Normally, the unit number is 2. -C 57 Save partial results on unit 2 either after -C maximum iterations or at the optimum. -C 58 Redefine the value for the maximum number of -C iterations. Normally, the maximum number of -C iterations is 3*(NVARS+MRELAS). -C 59 Provide DSPLP( ) with a starting (feasible) -C nonsingular basis. Normally, DSPLP( ) starts -C with the identity matrix columns corresponding -C to the vector w. -C 60 The user has provided scale factors for the -C columns of A. Normally, DSPLP( ) computes scale -C factors that are the reciprocals of the max. norm -C of each column. -C 61 The user has provided a scale factor -C for the vector costs. Normally, DSPLP( ) computes -C a scale factor equal to the reciprocal of the -C max. norm of the vector costs after the column -C scaling for the data matrix has been applied. -C 62 Size parameters, namely the smallest and -C largest magnitudes of nonzero entries in -C the matrix A, are provided. Values noted -C outside this range are to be considered errors. -C 63 Redefine the tolerance required in -C evaluating residuals for feasibility. -C Normally, this value is set to RELPR, -C where RELPR = relative precision of the arithmetic. -C 64 Change the criterion for bringing new variables -C into the basis from the steepest edge (best -C local move) to the minimum reduced cost. -C 65 Redefine the value for the number of iterations -C between recalculating the error in the primal -C solution. Normally, this value is equal to ten. -C 66 Perform "partial pricing" on variable selection. -C Redefine the value for the number of negative -C reduced costs to compute (at most) when finding -C a variable to enter the basis. Normally this -C value is set to NVARS. This implies that no -C "partial pricing" is used. -C 67 Adjust the tuning factor (normally one) to apply -C to the primal and dual error estimates. -C 68 Pass information to the subprogram DFULMT(), -C provided with the DSPLP() package, so that a Fortran -C two-dimensional array can be used as the argument -C DATTRV(*). -C 69 Pass an absolute tolerance to use for the feasibility -C test when the usual relative error test indicates -C infeasibility. The nominal value of this tolerance, -C TOLABS, is zero. -C -C -C |---------------| -C |Working Arrays:| -C |---------------| -C -C WORK(*),LW, -C IWORK(*),LIW -C ------------ -C The arrays WORK(*) and IWORK(*) are respectively floating point -C and type INTEGER working arrays for DSPLP( ) and its -C subprograms. The lengths of these arrays are respectively -C LW and LIW. These parameters must satisfy the inequalities -C noted above under the heading "Fortran Declarations Required:" -C It is an error if either value is too small. -C -C |----------------------------| -C |Input/Output files required:| -C |----------------------------| -C -C Fortran unit 1 is used by DSPLP( ) to store the sparse matrix A -C out of high-speed memory. A crude -C upper bound for the amount of information written on unit 1 -C is 6*nz, where nz is the number of nonzero entries in A. -C -C |-------| -C |Output:| -C |-------| -C -C INFO,PRIMAL(*),DUALS(*) -C ----------------------- -C The integer flag INFO indicates why DSPLP( ) has returned to the -C user. If INFO=1 the solution has been computed. In this case -C X(J)=PRIMAL(J) and W(I)=PRIMAL(I+NVARS). The dual variables -C for the equations A*x=w are in the array DUALS(I)=dual for -C equation number I. The dual value for the component X(J) that -C has an upper or lower bound (or both) is returned in -C DUALS(J+MRELAS). The only other values for INFO are .LT. 0. -C The meaning of these values can be found by reading -C the diagnostic message in the output file, or by looking for -C error number = (-INFO) in the Extended Usage Instructions -C under the heading: -C -C List of DSPLP( ) Error and Diagnostic Messages. -C -C BL(*),BU(*),IND(*) -C ------------------ -C These arrays are output parameters only under the (unusual) -C circumstances where the stated problem is infeasible, has an -C unbounded optimum value, or both. These respective conditions -C correspond to INFO=-1,-2 or -3. See the Extended -C Usage Instructions for further details. -C -C IBASIS(I),I=1,...,MRELAS -C ------------------------ -C This array contains the indices of the variables that are -C in the active basis set at the solution (INFO=1). A value -C of IBASIS(I) between 1 and NVARS corresponds to the variable -C X(IBASIS(I)). A value of IBASIS(I) between NVARS+1 and NVARS+ -C MRELAS corresponds to the variable W(IBASIS(I)-NVARS). -C -C *Long Description: -C -C SUBROUTINE DSPLP(DUSRMT,MRELAS,NVARS,COSTS,PRGOPT,DATTRV, -C * BL,BU,IND,INFO,PRIMAL,DUALS,IBASIS,WORK,LW,IWORK,LIW) -C -C |------------| -C |Introduction| -C |------------| -C The subprogram DSPLP( ) solves a linear optimization problem. -C The problem statement is as follows -C -C minimize (transpose of costs)*x -C subject to A*x=w. -C -C The entries of the unknowns x and w may have simple lower or -C upper bounds (or both), or be free to take on any value. By -C setting the bounds for x and w, the user is imposing the con- -C straints of the problem. -C -C (The problem may also be stated as a maximization -C problem. This is done by means of input in the option array -C PRGOPT(*).) The matrix A has MRELAS rows and NVARS columns. The -C vectors costs, x, and w respectively have NVARS, NVARS, and -C MRELAS number of entries. -C -C The input for the problem includes the problem dimensions, -C MRELAS and NVARS, the array COSTS(*), data for the matrix -C A, and the bound information for the unknowns x and w, BL(*), -C BU(*), and IND(*). -C -C The output from the problem (when output flag INFO=1) includes -C optimal values for x and w in PRIMAL(*), optimal values for -C dual variables of the equations A*x=w and the simple bounds -C on x in DUALS(*), and the indices of the basic columns in -C IBASIS(*). -C -C |------------------------------| -C |Fortran Declarations Required:| -C |------------------------------| -C -C DIMENSION COSTS(NVARS),PRGOPT(*),DATTRV(*), -C *BL(NVARS+MRELAS),BU(NVARS+MRELAS),IND(NVARS+MRELAS), -C *PRIMAL(NVARS+MRELAS),DUALS(MRELAS+NVARS),IBASIS(NVARS+MRELAS), -C *WORK(LW),IWORK(LIW) -C -C EXTERNAL DUSRMT (or 'NAME', if user provides the subprogram) -C -C The dimensions of PRGOPT(*) and DATTRV(*) must be at least 1. -C The exact lengths will be determined by user-required options and -C data transferred to the subprogram DUSRMT( ) ( or 'NAME'). -C -C The values of LW and LIW, the lengths of the arrays WORK(*) -C and IWORK(*), must satisfy the inequalities -C -C LW .GE. 4*NVARS+ 8*MRELAS+LAMAT+ LBM -C LIW.GE. NVARS+11*MRELAS+LAMAT+2*LBM -C -C It is an error if they do not both satisfy these inequalities. -C (The subprogram will inform the user of the required lengths -C if either LW or LIW is wrong.) The values of LAMAT and LBM -C nominally are -C -C LAMAT=4*NVARS+7 -C and LBM =8*MRELAS -C -C These values will be as shown unless the user changes them by -C means of input in the option array PRGOPT(*). The value of LAMAT -C determines the length of the sparse matrix "staging" area. -C For reasons of efficiency the user may want to increase the value -C of LAMAT. The value of LBM determines the amount of storage -C available to decompose and update the active basis matrix. -C Due to exhausting the working space because of fill-in, -C it may be necessary for the user to increase the value of LBM. -C (If this situation occurs an informative diagnostic is printed -C and a value of INFO=-28 is obtained as an output parameter.) -C -C |------| -C |Input:| -C |------| -C -C MRELAS,NVARS -C ------------ -C These parameters are respectively the number of constraints (the -C linear relations A*x=w that the unknowns x and w are to satisfy) -C and the number of entries in the vector x. Both must be .GE. 1. -C Other values are errors. -C -C COSTS(*) -C -------- -C The NVARS entries of this array are the coefficients of the -C linear objective function. The value COSTS(J) is the -C multiplier for variable J of the unknown vector x. Each -C entry of this array must be defined. This array can be changed -C by the user between restarts. See options with KEY=55,57 for -C details of checkpointing and restarting. -C -C DUSRMT -C ------ -C This is the name of a specific subprogram in the DSPLP( ) package -C that is used to define the matrix entries when this data is passed -C to DSPLP( ) as a linear array. In this usage mode of DSPLP( ) -C the user gives information about the nonzero entries of A -C in DATTRV(*) as given under the description of that parameter. -C The name DUSRMT must appear in a Fortran EXTERNAL statement. -C Users who are passing the matrix data with DUSRMT( ) can skip -C directly to the description of the input parameter DATTRV(*). -C Also see option 68 for passing the constraint matrix data using -C a standard Fortran two-dimensional array. -C -C If the user chooses to provide a subprogram 'NAME'( ) to -C define the matrix A, then DATTRV(*) may be used to pass floating -C point data from the user's program unit to the subprogram -C 'NAME'( ). The content of DATTRV(*) is not changed in any way. -C -C The subprogram 'NAME'( ) can be of the user's choice -C but it must meet Fortran standards and it must appear in a -C Fortran EXTERNAL statement. The first statement of the subprogram -C has the form -C -C SUBROUTINE 'NAME'(I,J,AIJ, INDCAT, PRGOPT, DATTRV, IFLAG) -C -C The variables I,J, INDCAT, IFLAG(10) are type INTEGER, -C while AIJ, PRGOPT(*),DATTRV(*) are type REAL. -C -C The user interacts with the contents of IFLAG(*) to -C direct the appropriate action. The algorithmic steps are -C as follows. -C -C Test IFLAG(1). -C -C IF(IFLAG(1).EQ.1) THEN -C -C Initialize the necessary pointers and data -C for defining the matrix A. The contents -C of IFLAG(K), K=2,...,10, may be used for -C storage of the pointers. This array remains intact -C between calls to 'NAME'( ) by DSPLP( ). -C RETURN -C -C END IF -C -C IF(IFLAG(1).EQ.2) THEN -C -C Define one set of values for I,J,AIJ, and INDCAT. -C Each nonzero entry of A must be defined this way. -C These values can be defined in any convenient order. -C (It is most efficient to define the data by -C columns in the order 1,...,NVARS; within each -C column define the entries in the order 1,...,MRELAS.) -C If this is the last matrix value to be -C defined or updated, then set IFLAG(1)=3. -C (When I and J are positive and respectively no larger -C than MRELAS and NVARS, the value of AIJ is used to -C define (or update) row I and column J of A.) -C RETURN -C -C END IF -C -C END -C -C Remarks: The values of I and J are the row and column -C indices for the nonzero entries of the matrix A. -C The value of this entry is AIJ. -C Set INDCAT=0 if this value defines that entry. -C Set INDCAT=1 if this entry is to be updated, -C new entry=old entry+AIJ. -C A value of I not between 1 and MRELAS, a value of J -C not between 1 and NVARS, or a value of INDCAT -C not equal to 0 or 1 are each errors. -C -C The contents of IFLAG(K), K=2,...,10, can be used to -C remember the status (of the process of defining the -C matrix entries) between calls to 'NAME'( ) by DSPLP( ). -C On entry to 'NAME'( ), only the values 1 or 2 will be -C in IFLAG(1). More than 2*NVARS*MRELAS definitions of -C the matrix elements is considered an error because -C it suggests an infinite loop in the user-written -C subprogram 'NAME'( ). Any matrix element not -C provided by 'NAME'( ) is defined to be zero. -C -C The REAL arrays PRGOPT(*) and DATTRV(*) are passed as -C arguments directly from DSPLP( ) to 'NAME'( ). -C The array PRGOPT(*) contains any user-defined program -C options. In this usage mode the array DATTRV(*) may -C now contain any (type REAL) data that the user needs -C to define the matrix A. Both arrays PRGOPT(*) and -C DATTRV(*) remain intact between calls to 'NAME'( ) -C by DSPLP( ). -C Here is a subprogram that communicates the matrix values for A, -C as represented in DATTRV(*), to DSPLP( ). This subprogram, -C called DUSRMT( ), is included as part of the DSPLP( ) package. -C This subprogram 'decodes' the array DATTRV(*) and defines the -C nonzero entries of the matrix A for DSPLP( ) to store. This -C listing is presented here as a guide and example -C for the users who find it necessary to write their own subroutine -C for this purpose. The contents of DATTRV(*) are given below in -C the description of that parameter. -C -C SUBROUTINE DUSRMT(I,J,AIJ, INDCAT,PRGOPT,DATTRV,IFLAG) -C DIMENSION PRGOPT(*),DATTRV(*),IFLAG(10) -C -C IF(IFLAG(1).EQ.1) THEN -C -C THIS IS THE INITIALIZATION STEP. THE VALUES OF IFLAG(K),K=2,3,4, -C ARE RESPECTIVELY THE COLUMN INDEX, THE ROW INDEX (OR THE NEXT COL. -C INDEX), AND THE POINTER TO THE MATRIX ENTRY'S VALUE WITHIN -C DATTRV(*). ALSO CHECK (DATTRV(1)=0.) SIGNIFYING NO DATA. -C IF(DATTRV(1).EQ.0.) THEN -C I = 0 -C J = 0 -C IFLAG(1) = 3 -C ELSE -C IFLAG(2)=-DATTRV(1) -C IFLAG(3)= DATTRV(2) -C IFLAG(4)= 3 -C END IF -C -C RETURN -C ELSE -C J=IFLAG(2) -C I=IFLAG(3) -C L=IFLAG(4) -C IF(I.EQ.0) THEN -C -C SIGNAL THAT ALL OF THE NONZERO ENTRIES HAVE BEEN DEFINED. -C IFLAG(1)=3 -C RETURN -C ELSE IF(I.LT.0) THEN -C -C SIGNAL THAT A SWITCH IS MADE TO A NEW COLUMN. -C J=-I -C I=DATTRV(L) -C L=L+1 -C END IF -C -C AIJ=DATTRV(L) -C -C UPDATE THE INDICES AND POINTERS FOR THE NEXT ENTRY. -C IFLAG(2)=J -C IFLAG(3)=DATTRV(L+1) -C IFLAG(4)=L+2 -C -C INDCAT=0 DENOTES THAT ENTRIES OF THE MATRIX ARE ASSIGNED THE -C VALUES FROM DATTRV(*). NO ACCUMULATION IS PERFORMED. -C INDCAT=0 -C RETURN -C END IF -C END -C -C DATTRV(*) -C --------- -C If the user chooses to use the provided subprogram DUSRMT( ) then -C the array DATTRV(*) contains data for the matrix A as follows: -C Each column (numbered J) requires (floating point) data con- -C sisting of the value (-J) followed by pairs of values. Each pair -C consists of the row index immediately followed by the value -C of the matrix at that entry. A value of J=0 signals that there -C are no more columns. (See "Example of DSPLP( ) Usage," below.) -C The dimension of DATTRV(*) must be 2*no. of nonzeros -C + NVARS + 1 in this usage. No checking of the array -C length is done by the subprogram package. -C -C If the Save/Restore feature is in use (see options with -C KEY=55,57 for details of checkpointing and restarting) -C DUSRMT( ) can be used to redefine entries of the matrix. -C The matrix entries are redefined or overwritten. No accum- -C ulation is performed. -C Any other nonzero entry of A, defined in a previous call to -C DSPLP( ), remain intact. -C -C BL(*),BU(*),IND(*) -C ------------------ -C The values of IND(*) are input parameters that define -C the form of the bounds for the unknowns x and w. The values for -C the bounds are found in the arrays BL(*) and BU(*) as follows. -C -C For values of J between 1 and NVARS, -C if IND(J)=1, then X(J) .GE. BL(J); BU(J) is not used. -C if IND(J)=2, then X(J) .LE. BU(J); BL(J) is not used. -C if IND(J)=3, then BL(J) .LE. X(J) .LE. BU(J),(BL(J)=BU(J) ok) -C if IND(J)=4, then X(J) is free to have any value, -C and BL(J), BU(J) are not used. -C -C For values of I between NVARS+1 and NVARS+MRELAS, -C if IND(I)=1, then W(I-NVARS) .GE. BL(I); BU(I) is not used. -C if IND(I)=2, then W(I-NVARS) .LE. BU(I); BL(I) is not used. -C if IND(I)=3, then BL(I) .LE. W(I-NVARS) .LE. BU(I), -C (BL(I)=BU(I) is ok). -C if IND(I)=4, then W(I-NVARS) is free to have any value, -C and BL(I), BU(I) are not used. -C -C A value of IND(*) not equal to 1,2,3 or 4 is an error. When -C IND(I)=3, BL(I) must be .LE. BU(I). The condition BL(I).GT. -C BU(I) indicates infeasibility and is an error. These -C arrays can be changed by the user between restarts. See -C options with KEY=55,57 for details of checkpointing and -C restarting. -C -C PRGOPT(*) -C --------- -C This array is used to redefine various parameters within DSPLP( ). -C Frequently, perhaps most of the time, a user will be satisfied -C and obtain the solutions with no changes to any of these -C parameters. To try this, simply set PRGOPT(1)=1.D0. -C -C For users with more sophisticated needs, DSPLP( ) provides several -C options that may be used to take advantage of more detailed -C knowledge of the problem or satisfy other utilitarian needs. -C The complete description of how to use this option array to -C utilize additional subprogram features is found under the -C heading "Usage of DSPLP( ) Subprogram Options." -C -C Briefly, the user should note the following value of the parameter -C KEY and the corresponding task or feature desired before turning -C to that section. -C -C Value Brief Statement of Purpose for Option -C of KEY -C ------ ------------------------------------- -C 50 Change from a minimization problem to a -C maximization problem. -C 51 Change the amount of printed output. -C Normally, no printed output is obtained. -C 52 Redefine the line length and precision used -C for the printed output. -C 53 Redefine the values of LAMAT and LBM that -C were discussed above under the heading -C Fortran Declarations Required. -C 54 Redefine the unit number where pages of the sparse -C data matrix A are stored. Normally, the unit -C number is 1. -C 55 A computation, partially completed, is -C being continued. Read the up-to-date -C partial results from unit number 2. -C 56 Redefine the unit number where the partial results -C are stored. Normally, the unit number is 2. -C 57 Save partial results on unit 2 either after -C maximum iterations or at the optimum. -C 58 Redefine the value for the maximum number of -C iterations. Normally, the maximum number of -C iterations is 3*(NVARS+MRELAS). -C 59 Provide DSPLP( ) with a starting (feasible) -C nonsingular basis. Normally, DSPLP( ) starts -C with the identity matrix columns corresponding -C to the vector w. -C 60 The user has provided scale factors for the -C columns of A. Normally, DSPLP( ) computes scale -C factors that are the reciprocals of the max. norm -C of each column. -C 61 The user has provided a scale factor -C for the vector costs. Normally, DSPLP( ) computes -C a scale factor equal to the reciprocal of the -C max. norm of the vector costs after the column -C scaling for the data matrix has been applied. -C 62 Size parameters, namely the smallest and -C largest magnitudes of nonzero entries in -C the matrix A, are provided. Values noted -C outside this range are to be considered errors. -C 63 Redefine the tolerance required in -C evaluating residuals for feasibility. -C Normally, this value is set to the value RELPR, -C where RELPR = relative precision of the arithmetic. -C 64 Change the criterion for bringing new variables -C into the basis from the steepest edge (best -C local move) to the minimum reduced cost. -C 65 Redefine the value for the number of iterations -C between recalculating the error in the primal -C solution. Normally, this value is equal to ten. -C 66 Perform "partial pricing" on variable selection. -C Redefine the value for the number of negative -C reduced costs to compute (at most) when finding -C a variable to enter the basis. Normally this -C value is set to NVARS. This implies that no -C "partial pricing" is used. -C 67 Adjust the tuning factor (normally one) to apply -C to the primal and dual error estimates. -C 68 Pass information to the subprogram DFULMT(), -C provided with the DSPLP() package, so that a Fortran -C two-dimensional array can be used as the argument -C DATTRV(*). -C 69 Pass an absolute tolerance to use for the feasibility -C test when the usual relative error test indicates -C infeasibility. The nominal value of this tolerance, -C TOLABS, is zero. -C -C -C |---------------| -C |Working Arrays:| -C |---------------| -C -C WORK(*),LW, -C IWORK(*),LIW -C ------------ -C The arrays WORK(*) and IWORK(*) are respectively floating point -C and type INTEGER working arrays for DSPLP( ) and its -C subprograms. The lengths of these arrays are respectively -C LW and LIW. These parameters must satisfy the inequalities -C noted above under the heading "Fortran Declarations Required." -C It is an error if either value is too small. -C -C |----------------------------| -C |Input/Output files required:| -C |----------------------------| -C -C Fortran unit 1 is used by DSPLP( ) to store the sparse matrix A -C out of high-speed memory. This direct access file is opened -C within the package under the following two conditions. -C 1. When the Save/Restore feature is used. 2. When the -C constraint matrix is so large that storage out of high-speed -C memory is required. The user may need to close unit 1 -C (with deletion from the job step) in the main program unit -C when several calls are made to DSPLP( ). A crude -C upper bound for the amount of information written on unit 1 -C is 6*nz, where nz is the number of nonzero entries in A. -C The unit number may be redefined to any other positive value -C by means of input in the option array PRGOPT(*). -C -C Fortran unit 2 is used by DSPLP( ) only when the Save/Restore -C feature is desired. Normally this feature is not used. It is -C activated by means of input in the option array PRGOPT(*). -C On some computer systems the user may need to open unit -C 2 before executing a call to DSPLP( ). This file is type -C sequential and is unformatted. -C -C Fortran unit=I1MACH(2) (check local setting) is used by DSPLP( ) -C when the printed output feature (KEY=51) is used. Normally -C this feature is not used. It is activated by input in the -C options array PRGOPT(*). For many computer systems I1MACH(2)=6. -C -C |-------| -C |Output:| -C |-------| -C -C INFO,PRIMAL(*),DUALS(*) -C ----------------------- -C The integer flag INFO indicates why DSPLP( ) has returned to the -C user. If INFO=1 the solution has been computed. In this case -C X(J)=PRIMAL(J) and W(I)=PRIMAL(I+NVARS). The dual variables -C for the equations A*x=w are in the array DUALS(I)=dual for -C equation number I. The dual value for the component X(J) that -C has an upper or lower bound (or both) is returned in -C DUALS(J+MRELAS). The only other values for INFO are .LT. 0. -C The meaning of these values can be found by reading -C the diagnostic message in the output file, or by looking for -C error number = (-INFO) under the heading "List of DSPLP( ) Error -C and Diagnostic Messages." -C The diagnostic messages are printed using the error processing -C subprogram XERMSG( ) with error category LEVEL=1. -C See the document "Brief Instr. for Using the Sandia Math. -C Subroutine Library," SAND79-2382, Nov., 1980, for further inform- -C ation about resetting the usual response to a diagnostic message. -C -C BL(*),BU(*),IND(*) -C ------------------ -C These arrays are output parameters only under the (unusual) -C circumstances where the stated problem is infeasible, has an -C unbounded optimum value, or both. These respective conditions -C correspond to INFO=-1,-2 or -3. For INFO=-1 or -3 certain comp- -C onents of the vectors x or w will not satisfy the input bounds. -C If component J of X or component I of W does not satisfy its input -C bound because of infeasibility, then IND(J)=-4 or IND(I+NVARS)=-4, -C respectively. For INFO=-2 or -3 certain -C components of the vector x could not be used as basic variables -C because the objective function would have become unbounded. -C In particular if component J of x corresponds to such a variable, -C then IND(J)=-3. Further, if the input value of IND(J) -C =1, then BU(J)=BL(J); -C =2, then BL(J)=BU(J); -C =4, then BL(J)=0.,BU(J)=0. -C -C (The J-th variable in x has been restricted to an appropriate -C feasible value.) -C The negative output value for IND(*) allows the user to identify -C those constraints that are not satisfied or those variables that -C would cause unbounded values of the objective function. Note -C that the absolute value of IND(*), together with BL(*) and BU(*), -C are valid input to DSPLP( ). In the case of infeasibility the -C sum of magnitudes of the infeasible values is minimized. Thus -C one could reenter DSPLP( ) with these components of x or w now -C fixed at their present values. This involves setting -C the appropriate components of IND(*) = 3, and BL(*) = BU(*). -C -C IBASIS(I),I=1,...,MRELAS -C ------------------------ -C This array contains the indices of the variables that are -C in the active basis set at the solution (INFO=1). A value -C of IBASIS(I) between 1 and NVARS corresponds to the variable -C X(IBASIS(I)). A value of IBASIS(I) between NVARS+1 and NVARS+ -C MRELAS corresponds to the variable W(IBASIS(I)-NVARS). -C -C Computing with the Matrix A after Calling DSPLP( ) -C -------------------------------------------------- -C Following the return from DSPLP( ), nonzero entries of the MRELAS -C by NVARS matrix A are available for usage by the user. The method -C for obtaining the next nonzero in column J with a row index -C strictly greater than I in value, is completed by executing -C -C CALL DPNNZR(I,AIJ,IPLACE,WORK,IWORK,J) -C -C The value of I is also an output parameter. If I.LE.0 on output, -C then there are no more nonzeroes in column J. If I.GT.0, the -C output value for component number I of column J is in AIJ. The -C parameters WORK(*) and IWORK(*) are the same arguments as in the -C call to DSPLP( ). The parameter IPLACE is a single INTEGER -C working variable. -C -C The data structure used for storage of the matrix A within DSPLP() -C corresponds to sequential storage by columns as defined in -C SAND78-0785. Note that the names of the subprograms LNNZRS(), -C LCHNGS(),LINITM(),LLOC(),LRWPGE(), and LRWVIR() have been -C changed to DPNNZR(),DPCHNG(),PINITM(),IPLOC(),DPRWPG(), and -C DPRWVR() respectively. The error processing subprogram LERROR() -C is no longer used; XERMSG() is used instead. -C -C |--------------------------------| -C |Subprograms Required by DSPLP( )| -C |--------------------------------| -C Called by DSPLP() are DPLPMN(),DPLPUP(),DPINIT(),DPOPT(), -C DPLPDM(),DPLPCE(),DPINCW(),DPLPFL(), -C DPLPFE(),DPLPMU(). -C -C Error Processing Subprograms XERMSG(),I1MACH(),D1MACH() -C -C Sparse Matrix Subprograms DPNNZR(),DPCHNG(),DPRWPG(),DPRWVR(), -C PINITM(),IPLOC() -C -C Mass Storage File Subprograms SOPENM(),SCLOSM(),DREADP(),DWRITP() -C -C Basic Linear Algebra Subprograms DCOPY(),DASUM(),DDOT() -C -C Sparse Matrix Basis Handling Subprograms LA05AD(),LA05BD(), -C LA05CD(),LA05ED(),MC20AD() -C -C Vector Output Subprograms DVOUT(),IVOUT() -C -C Machine-sensitive Subprograms I1MACH( ),D1MACH( ), -C SOPENM(),SCLOSM(),DREADP(),DWRITP(). -C COMMON Block Used -C ----------------- -C /LA05DD/ SMALL,LP,LENL,LENU,NCP,LROW,LCOL -C See the document AERE-R8269 for further details. -C |-------------------------| -C |Example of DSPLP( ) Usage| -C |-------------------------| -C PROGRAM LPEX -C THE OPTIMIZATION PROBLEM IS TO FIND X1, X2, X3 THAT -C MINIMIZE X1 + X2 + X3, X1.GE.0, X2.GE.0, X3 UNCONSTRAINED. -C -C THE UNKNOWNS X1,X2,X3 ARE TO SATISFY CONSTRAINTS -C -C X1 -3*X2 +4*X3 = 5 -C X1 -2*X2 .LE.3 -C 2*X2 - X3.GE.4 -C -C WE FIRST DEFINE THE DEPENDENT VARIABLES -C W1=X1 -3*X2 +4*X3 -C W2=X1- 2*X2 -C W3= 2*X2 -X3 -C -C WE NOW SHOW HOW TO USE DSPLP( ) TO SOLVE THIS LINEAR OPTIMIZATION -C PROBLEM. EACH REQUIRED STEP WILL BE SHOWN IN THIS EXAMPLE. -C DIMENSION COSTS(03),PRGOPT(01),DATTRV(18),BL(06),BU(06),IND(06), -C *PRIMAL(06),DUALS(06),IBASIS(06),WORK(079),IWORK(103) -C -C EXTERNAL DUSRMT -C MRELAS=3 -C NVARS=3 -C -C DEFINE THE ARRAY COSTS(*) FOR THE OBJECTIVE FUNCTION. -C COSTS(01)=1. -C COSTS(02)=1. -C COSTS(03)=1. -C -C PLACE THE NONZERO INFORMATION ABOUT THE MATRIX IN DATTRV(*). -C DEFINE COL. 1: -C DATTRV(01)=-1 -C DATTRV(02)=1 -C DATTRV(03)=1. -C DATTRV(04)=2 -C DATTRV(05)=1. -C -C DEFINE COL. 2: -C DATTRV(06)=-2 -C DATTRV(07)=1 -C DATTRV(08)=-3. -C DATTRV(09)=2 -C DATTRV(10)=-2. -C DATTRV(11)=3 -C DATTRV(12)=2. -C -C DEFINE COL. 3: -C DATTRV(13)=-3 -C DATTRV(14)=1 -C DATTRV(15)=4. -C DATTRV(16)=3 -C DATTRV(17)=-1. -C -C DATTRV(18)=0 -C -C CONSTRAIN X1,X2 TO BE NONNEGATIVE. LET X3 HAVE NO BOUNDS. -C BL(1)=0. -C IND(1)=1 -C BL(2)=0. -C IND(2)=1 -C IND(3)=4 -C -C CONSTRAIN W1=5,W2.LE.3, AND W3.GE.4. -C BL(4)=5. -C BU(4)=5. -C IND(4)=3 -C BU(5)=3. -C IND(5)=2 -C BL(6)=4. -C IND(6)=1 -C -C INDICATE THAT NO MODIFICATIONS TO OPTIONS ARE IN USE. -C PRGOPT(01)=1 -C -C DEFINE THE WORKING ARRAY LENGTHS. -C LW=079 -C LIW=103 -C CALL DSPLP(DUSRMT,MRELAS,NVARS,COSTS,PRGOPT,DATTRV, -C *BL,BU,IND,INFO,PRIMAL,DUALS,IBASIS,WORK,LW,IWORK,LIW) -C -C CALCULATE VAL, THE MINIMAL VALUE OF THE OBJECTIVE FUNCTION. -C VAL=DDOT(NVARS,COSTS,1,PRIMAL,1) -C -C STOP -C END -C |------------------------| -C |End of Example of Usage | -C |------------------------| -C -C |-------------------------------------| -C |Usage of DSPLP( ) Subprogram Options.| -C |-------------------------------------| -C -C Users frequently have a large variety of requirements for linear -C optimization software. Allowing for these varied requirements -C is at cross purposes with the desire to keep the usage of DSPLP( ) -C as simple as possible. One solution to this dilemma is as follows. -C (1) Provide a version of DSPLP( ) that solves a wide class of -C problems and is easy to use. (2) Identify parameters within -C DSPLP() that certain users may want to change. (3) Provide a -C means of changing any selected number of these parameters that -C does not require changing all of them. -C -C Changing selected parameters is done by requiring -C that the user provide an option array, PRGOPT(*), to DSPLP( ). -C The contents of PRGOPT(*) inform DSPLP( ) of just those options -C that are going to be modified within the total set of possible -C parameters that can be modified. The array PRGOPT(*) is a linked -C list consisting of groups of data of the following form -C -C LINK -C KEY -C SWITCH -C data set -C -C that describe the desired options. The parameters LINK, KEY and -C switch are each one word and are always required. The data set -C can be comprised of several words or can be empty. The number of -C words in the data set for each option depends on the value of -C the parameter KEY. -C -C The value of LINK points to the first entry of the next group -C of data within PRGOPT(*). The exception is when there are no more -C options to change. In that case, LINK=1 and the values for KEY, -C SWITCH and data set are not referenced. The general layout of -C PRGOPT(*) is as follows: -C ...PRGOPT(1)=LINK1 (link to first entry of next group) -C . PRGOPT(2)=KEY1 (KEY to the option change) -C . PRGOPT(3)=SWITCH1 (on/off switch for the option) -C . PRGOPT(4)=data value -C . . -C . . -C . . -C ...PRGOPT(LINK1)=LINK2 (link to first entry of next group) -C . PRGOPT(LINK1+1)=KEY2 (KEY to option change) -C . PRGOPT(LINK1+2)=SWITCH2 (on/off switch for the option) -C . PRGOPT(LINK1+3)=data value -C ... . -C . . -C . . -C ...PRGOPT(LINK)=1 (no more options to change) -C -C A value of LINK that is .LE.0 or .GT. 10000 is an error. -C In this case DSPLP( ) returns with an error message, INFO=-14. -C This helps prevent using invalid but positive values of LINK that -C will probably extend beyond the program limits of PRGOPT(*). -C Unrecognized values of KEY are ignored. If the value of SWITCH is -C zero then the option is turned off. For any other value of SWITCH -C the option is turned on. This is used to allow easy changing of -C options without rewriting PRGOPT(*). The order of the options is -C arbitrary and any number of options can be changed with the -C following restriction. To prevent cycling in processing of the -C option array PRGOPT(*), a count of the number of options changed -C is maintained. Whenever this count exceeds 1000 an error message -C (INFO=-15) is printed and the subprogram returns. -C -C In the following description of the options, the value of -C LATP indicates the amount of additional storage that a particular -C option requires. The sum of all of these values (plus one) is -C the minimum dimension for the array PRGOPT(*). -C -C If a user is satisfied with the nominal form of DSPLP( ), -C set PRGOPT(1)=1 (or PRGOPT(1)=1.D0). -C -C Options: -C -C -----KEY = 50. Change from a minimization problem to a maximization -C problem. -C If SWITCH=0 option is off; solve minimization problem. -C =1 option is on; solve maximization problem. -C data set =empty -C LATP=3 -C -C -----KEY = 51. Change the amount of printed output. The nominal form -C of DSPLP( ) has no printed output. -C The first level of output (SWITCH=1) includes -C -C (1) Minimum dimensions for the arrays COSTS(*),BL(*),BU(*),IND(*), -C PRIMAL(*),DUALS(*),IBASIS(*), and PRGOPT(*). -C (2) Problem dimensions MRELAS,NVARS. -C (3) The types of and values for the bounds on x and w, -C and the values of the components of the vector costs. -C (4) Whether optimization problem is minimization or -C maximization. -C (5) Whether steepest edge or smallest reduced cost criteria used -C for exchanging variables in the revised simplex method. -C -C Whenever a solution has been found, (INFO=1), -C -C (6) the value of the objective function, -C (7) the values of the vectors x and w, -C (8) the dual variables for the constraints A*x=w and the -C bounded components of x, -C (9) the indices of the basic variables, -C (10) the number of revised simplex method iterations, -C (11) the number of full decompositions of the basis matrix. -C -C The second level of output (SWITCH=2) includes all for SWITCH=1 -C plus -C -C (12) the iteration number, -C (13) the column number to enter the basis, -C (14) the column number to leave the basis, -C (15) the length of the step taken. -C -C The third level of output (SWITCH=3) includes all for SWITCH=2 -C plus -C (16) critical quantities required in the revised simplex method. -C This output is rather voluminous. It is intended to be used -C as a diagnostic tool in case of a failure in DSPLP( ). -C -C If SWITCH=0 option is off; no printed output. -C =1 summary output. -C =2 lots of output. -C =3 even more output. -C data set =empty -C LATP=3 -C -C -----KEY = 52. Redefine the parameter, IDIGIT, which determines the -C format and precision used for the printed output. In the printed -C output, at least ABS(IDIGIT) decimal digits per number is -C printed. If IDIGIT.LT.0, 72 printing columns are used. If -C IDIGIT.GT.0, 133 printing columns are used. -C If SWITCH=0 option is off; IDIGIT=-4. -C =1 option is on. -C data set =IDIGIT -C LATP=4 -C -C -----KEY = 53. Redefine LAMAT and LBM, the lengths of the portions of -C WORK(*) and IWORK(*) that are allocated to the sparse matrix -C storage and the sparse linear equation solver, respectively. -C LAMAT must be .GE. NVARS+7 and LBM must be positive. -C If SWITCH=0 option is off; LAMAT=4*NVARS+7 -C LBM =8*MRELAS. -C =1 option is on. -C data set =LAMAT -C LBM -C LATP=5 -C -C -----KEY = 54. Redefine IPAGEF, the file number where the pages of the -C sparse data matrix are stored. IPAGEF must be positive and -C different from ISAVE (see option 56). -C If SWITCH=0 option is off; IPAGEF=1. -C =1 option is on. -C data set =IPAGEF -C LATP=4 -C -C -----KEY = 55. Partial results have been computed and stored on unit -C number ISAVE (see option 56), during a previous run of -C DSPLP( ). This is a continuation from these partial results. -C The arrays COSTS(*),BL(*),BU(*),IND(*) do not have to have -C the same values as they did when the checkpointing occurred. -C This feature makes it possible for the user to do certain -C types of parameter studies such as changing costs and varying -C the constraints of the problem. This file is rewound both be- -C fore and after reading the partial results. -C If SWITCH=0 option is off; start a new problem. -C =1 option is on; continue from partial results -C that are stored in file ISAVE. -C data set = empty -C LATP=3 -C -C -----KEY = 56. Redefine ISAVE, the file number where the partial -C results are stored (see option 57). ISAVE must be positive and -C different from IPAGEF (see option 54). -C If SWITCH=0 option is off; ISAVE=2. -C =1 option is on. -C data set =ISAVE -C LATP=4 -C -C -----KEY = 57. Save the partial results after maximum number of -C iterations, MAXITR, or at the optimum. When this option is on, -C data essential to continuing the calculation is saved on a file -C using a Fortran binary write operation. The data saved includes -C all the information about the sparse data matrix A. Also saved -C is information about the current basis. Nominally the partial -C results are saved on Fortran unit 2. This unit number can be -C redefined (see option 56). If the save option is on, -C this file must be opened (or declared) by the user prior to the -C call to DSPLP( ). A crude upper bound for the number of words -C written to this file is 6*nz. Here nz= number of nonzeros in A. -C If SWITCH=0 option is off; do not save partial results. -C =1 option is on; save partial results. -C data set = empty -C LATP=3 -C -C -----KEY = 58. Redefine the maximum number of iterations, MAXITR, to -C be taken before returning to the user. -C If SWITCH=0 option is off; MAXITR=3*(NVARS+MRELAS). -C =1 option is on. -C data set =MAXITR -C LATP=4 -C -C -----KEY = 59. Provide DSPLP( ) with exactly MRELAS indices which -C comprise a feasible, nonsingular basis. The basis must define a -C feasible point: values for x and w such that A*x=w and all the -C stated bounds on x and w are satisfied. The basis must also be -C nonsingular. The failure of either condition will cause an error -C message (INFO=-23 or =-24, respectively). Normally, DSPLP( ) uses -C identity matrix columns which correspond to the components of w. -C This option would normally not be used when restarting from -C a previously saved run (KEY=57). -C In numbering the unknowns, -C the components of x are numbered (1-NVARS) and the components -C of w are numbered (NVARS+1)-(NVARS+MRELAS). A value for an -C index .LE. 0 or .GT. (NVARS+MRELAS) is an error (INFO=-16). -C If SWITCH=0 option is off; DSPLP( ) chooses the initial basis. -C =1 option is on; user provides the initial basis. -C data set =MRELAS indices of basis; order is arbitrary. -C LATP=MRELAS+3 -C -C -----KEY = 60. Provide the scale factors for the columns of the data -C matrix A. Normally, DSPLP( ) computes the scale factors as the -C reciprocals of the max. norm of each column. -C If SWITCH=0 option is off; DSPLP( ) computes the scale factors. -C =1 option is on; user provides the scale factors. -C data set =scaling for column J, J=1,NVARS; order is sequential. -C LATP=NVARS+3 -C -C -----KEY = 61. Provide a scale factor, COSTSC, for the vector of -C costs. Normally, DSPLP( ) computes this scale factor to be the -C reciprocal of the max. norm of the vector costs after the column -C scaling has been applied. -C If SWITCH=0 option is off; DSPLP( ) computes COSTSC. -C =1 option is on; user provides COSTSC. -C data set =COSTSC -C LATP=4 -C -C -----KEY = 62. Provide size parameters, ASMALL and ABIG, the smallest -C and largest magnitudes of nonzero entries in the data matrix A, -C respectively. When this option is on, DSPLP( ) will check the -C nonzero entries of A to see if they are in the range of ASMALL and -C ABIG. If an entry of A is not within this range, DSPLP( ) returns -C an error message, INFO=-22. Both ASMALL and ABIG must be positive -C with ASMALL .LE. ABIG. Otherwise, an error message is returned, -C INFO=-17. -C If SWITCH=0 option is off; no checking of the data matrix is done -C =1 option is on; checking is done. -C data set =ASMALL -C ABIG -C LATP=5 -C -C -----KEY = 63. Redefine the relative tolerance, TOLLS, used in -C checking if the residuals are feasible. Normally, -C TOLLS=RELPR, where RELPR is the machine precision. -C If SWITCH=0 option is off; TOLLS=RELPR. -C =1 option is on. -C data set =TOLLS -C LATP=4 -C -C -----KEY = 64. Use the minimum reduced cost pricing strategy to choose -C columns to enter the basis. Normally, DSPLP( ) uses the steepest -C edge pricing strategy which is the best local move. The steepest -C edge pricing strategy generally uses fewer iterations than the -C minimum reduced cost pricing, but each iteration costs more in the -C number of calculations done. The steepest edge pricing is -C considered to be more efficient. However, this is very problem -C dependent. That is why DSPLP( ) provides the option of either -C pricing strategy. -C If SWITCH=0 option is off; steepest option edge pricing is used. -C =1 option is on; minimum reduced cost pricing is used. -C data set =empty -C LATP=3 -C -C -----KEY = 65. Redefine MXITBR, the number of iterations between -C recalculating the error in the primal solution. Normally, MXITBR -C is set to 10. The error in the primal solution is used to monitor -C the error in solving the linear system. This is an expensive -C calculation and every tenth iteration is generally often enough. -C If SWITCH=0 option is off; MXITBR=10. -C =1 option is on. -C data set =MXITBR -C LATP=4 -C -C -----KEY = 66. Redefine NPP, the number of negative reduced costs -C (at most) to be found at each iteration of choosing -C a variable to enter the basis. Normally NPP is set -C to NVARS which implies that all of the reduced costs -C are computed at each such step. This "partial -C pricing" may very well increase the total number -C of iterations required. However it decreases the -C number of calculations at each iteration. -C therefore the effect on overall efficiency is quite -C problem-dependent. -C -C if SWITCH=0 option is off; NPP=NVARS -C =1 option is on. -C data set =NPP -C LATP=4 -C -C -----KEY = 67. Redefine the tuning factor (PHI) used to scale the -C error estimates for the primal and dual linear algebraic systems -C of equations. Normally, PHI = 1.D0, but in some environments it -C may be necessary to reset PHI to the range 0.001-0.01. This is -C particularly important for machines with short word lengths. -C -C if SWITCH = 0 option is off; PHI=1.D0. -C = 1 option is on. -C Data Set = PHI -C LATP=4 -C -C -----KEY = 68. Used together with the subprogram DFULMT(), provided -C with the DSPLP() package, for passing a standard Fortran two- -C dimensional array containing the constraint matrix. Thus the sub- -C program DFULMT must be declared in a Fortran EXTERNAL statement. -C The two-dimensional array is passed as the argument DATTRV. -C The information about the array and problem dimensions are passed -C in the option array PRGOPT(*). It is an error if DFULMT() is -C used and this information is not passed in PRGOPT(*). -C -C if SWITCH = 0 option is off; this is an error is DFULMT() is -C used. -C = 1 option is on. -C Data Set = IA = row dimension of two-dimensional array. -C MRELAS = number of constraint equations. -C NVARS = number of dependent variables. -C LATP = 6 -C -----KEY = 69. Normally a relative tolerance (TOLLS, see option 63) -C is used to decide if the problem is feasible. If this test fails -C an absolute test will be applied using the value TOLABS. -C Nominally TOLABS = zero. -C If SWITCH = 0 option is off; TOLABS = zero. -C = 1 option is on. -C Data set = TOLABS -C LATP = 4 -C -C |-----------------------------| -C |Example of Option array Usage| -C |-----------------------------| -C To illustrate the usage of the option array, let us suppose that -C the user has the following nonstandard requirements: -C -C a) Wants to change from minimization to maximization problem. -C b) Wants to limit the number of simplex steps to 100. -C c) Wants to save the partial results after 100 steps on -C Fortran unit 2. -C -C After these 100 steps are completed the user wants to continue the -C problem (until completed) using the partial results saved on -C Fortran unit 2. Here are the entries of the array PRGOPT(*) -C that accomplish these tasks. (The definitions of the other -C required input parameters are not shown.) -C -C CHANGE TO A MAXIMIZATION PROBLEM; KEY=50. -C PRGOPT(01)=4 -C PRGOPT(02)=50 -C PRGOPT(03)=1 -C -C LIMIT THE NUMBER OF SIMPLEX STEPS TO 100; KEY=58. -C PRGOPT(04)=8 -C PRGOPT(05)=58 -C PRGOPT(06)=1 -C PRGOPT(07)=100 -C -C SAVE THE PARTIAL RESULTS, AFTER 100 STEPS, ON FORTRAN -C UNIT 2; KEY=57. -C PRGOPT(08)=11 -C PRGOPT(09)=57 -C PRGOPT(10)=1 -C -C NO MORE OPTIONS TO CHANGE. -C PRGOPT(11)=1 -C The user makes the CALL statement for DSPLP( ) at this point. -C Now to restart, using the partial results after 100 steps, define -C new values for the array PRGOPT(*): -C -C AGAIN INFORM DSPLP( ) THAT THIS IS A MAXIMIZATION PROBLEM. -C PRGOPT(01)=4 -C PRGOPT(02)=50 -C PRGOPT(03)=1 -C -C RESTART, USING SAVED PARTIAL RESULTS; KEY=55. -C PRGOPT(04)=7 -C PRGOPT(05)=55 -C PRGOPT(06)=1 -C -C NO MORE OPTIONS TO CHANGE. THE SUBPROGRAM DSPLP( ) IS NO LONGER -C LIMITED TO 100 SIMPLEX STEPS BUT WILL RUN UNTIL COMPLETION OR -C MAX.=3*(MRELAS+NVARS) ITERATIONS. -C PRGOPT(07)=1 -C The user now makes a CALL to subprogram DSPLP( ) to compute the -C solution. -C |--------------------------------------------| -C |End of Usage of DSPLP( ) Subprogram Options.| -C |--------------------------------------------| -C -C |-----------------------------------------------| -C |List of DSPLP( ) Error and Diagnostic Messages.| -C |-----------------------------------------------| -C This section may be required to understand the meanings of the -C error flag =-INFO that may be returned from DSPLP( ). -C -C -----1. There is no set of values for x and w that satisfy A*x=w and -C the stated bounds. The problem can be made feasible by ident- -C ifying components of w that are now infeasible and then rede- -C signating them as free variables. Subprogram DSPLP( ) only -C identifies an infeasible problem; it takes no other action to -C change this condition. Message: -C DSPLP( ). THE PROBLEM APPEARS TO BE INFEASIBLE. -C ERROR NUMBER = 1 -C -C 2. One of the variables in either the vector x or w was con- -C strained at a bound. Otherwise the objective function value, -C (transpose of costs)*x, would not have a finite optimum. -C Message: -C DSPLP( ). THE PROBLEM APPEARS TO HAVE NO FINITE SOLN. -C ERROR NUMBER = 2 -C -C 3. Both of the conditions of 1. and 2. above have occurred. -C Message: -C DSPLP( ). THE PROBLEM APPEARS TO BE INFEASIBLE AND TO -C HAVE NO FINITE SOLN. -C ERROR NUMBER = 3 -C -C -----4. The REAL and INTEGER working arrays, WORK(*) and IWORK(*), -C are not long enough. The values (I1) and (I2) in the message -C below will give you the minimum length required. Also redefine -C LW and LIW, the lengths of these arrays. Message: -C DSPLP( ). WORK OR IWORK IS NOT LONG ENOUGH. LW MUST BE (I1) -C AND LIW MUST BE (I2). -C IN ABOVE MESSAGE, I1= 0 -C IN ABOVE MESSAGE, I2= 0 -C ERROR NUMBER = 4 -C -C -----5. and 6. These error messages often mean that one or more -C arguments were left out of the call statement to DSPLP( ) or -C that the values of MRELAS and NVARS have been over-written -C by garbage. Messages: -C DSPLP( ). VALUE OF MRELAS MUST BE .GT.0. NOW=(I1). -C IN ABOVE MESSAGE, I1= 0 -C ERROR NUMBER = 5 -C -C DSPLP( ). VALUE OF NVARS MUST BE .GT.0. NOW=(I1). -C IN ABOVE MESSAGE, I1= 0 -C ERROR NUMBER = 6 -C -C -----7.,8., and 9. These error messages can occur as the data matrix -C is being defined by either DUSRMT( ) or the user-supplied sub- -C program, 'NAME'( ). They would indicate a mistake in the contents -C of DATTRV(*), the user-written subprogram or that data has been -C over-written. -C Messages: -C DSPLP( ). MORE THAN 2*NVARS*MRELAS ITERS. DEFINING OR UPDATING -C MATRIX DATA. -C ERROR NUMBER = 7 -C -C DSPLP( ). ROW INDEX (I1) OR COLUMN INDEX (I2) IS OUT OF RANGE. -C IN ABOVE MESSAGE, I1= 1 -C IN ABOVE MESSAGE, I2= 12 -C ERROR NUMBER = 8 -C -C DSPLP( ). INDICATION FLAG (I1) FOR MATRIX DATA MUST BE -C EITHER 0 OR 1. -C IN ABOVE MESSAGE, I1= 12 -C ERROR NUMBER = 9 -C -C -----10. and 11. The type of bound (even no bound) and the bounds -C must be specified for each independent variable. If an independent -C variable has both an upper and lower bound, the bounds must be -C consistent. The lower bound must be .LE. the upper bound. -C Messages: -C DSPLP( ). INDEPENDENT VARIABLE (I1) IS NOT DEFINED. -C IN ABOVE MESSAGE, I1= 1 -C ERROR NUMBER = 10 -C -C DSPLP( ). LOWER BOUND (R1) AND UPPER BOUND (R2) FOR INDEP. -C VARIABLE (I1) ARE NOT CONSISTENT. -C IN ABOVE MESSAGE, I1= 1 -C IN ABOVE MESSAGE, R1= 0. -C IN ABOVE MESSAGE, R2= -.1000000000E+01 -C ERROR NUMBER = 11 -C -C -----12. and 13. The type of bound (even no bound) and the bounds -C must be specified for each dependent variable. If a dependent -C variable has both an upper and lower bound, the bounds must be -C consistent. The lower bound must be .LE. the upper bound. -C Messages: -C DSPLP( ). DEPENDENT VARIABLE (I1) IS NOT DEFINED. -C IN ABOVE MESSAGE, I1= 1 -C ERROR NUMBER = 12 -C -C DSPLP( ). LOWER BOUND (R1) AND UPPER BOUND (R2) FOR DEP. -C VARIABLE (I1) ARE NOT CONSISTENT. -C IN ABOVE MESSAGE, I1= 1 -C IN ABOVE MESSAGE, R1= 0. -C IN ABOVE MESSAGE, R2= -.1000000000E+01 -C ERROR NUMBER = 13 -C -C -----14. - 21. These error messages can occur when processing the -C option array, PRGOPT(*), supplied by the user. They would -C indicate a mistake in defining PRGOPT(*) or that data has been -C over-written. See heading Usage of DSPLP( ) -C Subprogram Options, for details on how to define PRGOPT(*). -C Messages: -C DSPLP( ). THE USER OPTION ARRAY HAS UNDEFINED DATA. -C ERROR NUMBER = 14 -C -C DSPLP( ). OPTION ARRAY PROCESSING IS CYCLING. -C ERROR NUMBER = 15 -C -C DSPLP( ). AN INDEX OF USER-SUPPLIED BASIS IS OUT OF RANGE. -C ERROR NUMBER = 16 -C -C DSPLP( ). SIZE PARAMETERS FOR MATRIX MUST BE SMALLEST AND LARGEST -C MAGNITUDES OF NONZERO ENTRIES. -C ERROR NUMBER = 17 -C -C DSPLP( ). THE NUMBER OF REVISED SIMPLEX STEPS BETWEEN CHECK-POINTS -C MUST BE POSITIVE. -C ERROR NUMBER = 18 -C -C DSPLP( ). FILE NUMBERS FOR SAVED DATA AND MATRIX PAGES MUST BE -C POSITIVE AND NOT EQUAL. -C ERROR NUMBER = 19 -C -C DSPLP( ). USER-DEFINED VALUE OF LAMAT (I1) -C MUST BE .GE. NVARS+7. -C IN ABOVE MESSAGE, I1= 1 -C ERROR NUMBER = 20 -C -C DSPLP( ). USER-DEFINED VALUE OF LBM MUST BE .GE. 0. -C ERROR NUMBER = 21 -C -C -----22. The user-option, number 62, to check the size of the matrix -C data has been used. An element of the matrix does not lie within -C the range of ASMALL and ABIG, parameters provided by the user. -C (See the heading: Usage of DSPLP( ) Subprogram Options, -C for details about this feature.) Message: -C DSPLP( ). A MATRIX ELEMENT'S SIZE IS OUT OF THE SPECIFIED RANGE. -C ERROR NUMBER = 22 -C -C -----23. The user has provided an initial basis that is singular. -C In this case, the user can remedy this problem by letting -C subprogram DSPLP( ) choose its own initial basis. Message: -C DSPLP( ). A SINGULAR INITIAL BASIS WAS ENCOUNTERED. -C ERROR NUMBER = 23 -C -C -----24. The user has provided an initial basis which is infeasible. -C The x and w values it defines do not satisfy A*x=w and the stated -C bounds. In this case, the user can let subprogram DSPLP( ) -C choose its own initial basis. Message: -C DSPLP( ). AN INFEASIBLE INITIAL BASIS WAS ENCOUNTERED. -C ERROR NUMBER = 24 -C -C -----25.Subprogram DSPLP( ) has completed the maximum specified number -C of iterations. (The nominal maximum number is 3*(MRELAS+NVARS).) -C The results, necessary to continue on from -C this point, can be saved on Fortran unit 2 by activating option -C KEY=57. If the user anticipates continuing the calculation, then -C the contents of Fortran unit 2 must be retained intact. This -C is not done by subprogram DSPLP( ), so the user needs to save unit -C 2 by using the appropriate system commands. Message: -C DSPLP( ). MAX. ITERS. (I1) TAKEN. UP-TO-DATE RESULTS -C SAVED ON FILE (I2). IF(I2)=0, NO SAVE. -C IN ABOVE MESSAGE, I1= 500 -C IN ABOVE MESSAGE, I2= 2 -C ERROR NUMBER = 25 -C -C -----26. This error should never happen. Message: -C DSPLP( ). MOVED TO A SINGULAR POINT. THIS SHOULD NOT HAPPEN. -C ERROR NUMBER = 26 -C -C -----27. The subprogram LA05A( ), which decomposes the basis matrix, -C has returned with an error flag (R1). (See the document, -C "Fortran subprograms for handling sparse linear programming -C bases", AERE-R8269, J.K. Reid, Jan., 1976, H.M. Stationery Office, -C for an explanation of this error.) Message: -C DSPLP( ). LA05A( ) RETURNED ERROR FLAG (R1) BELOW. -C IN ABOVE MESSAGE, R1= -.5000000000E+01 -C ERROR NUMBER = 27 -C -C -----28. The sparse linear solver package, LA05*( ), requires more -C space. The value of LBM must be increased. See the companion -C document, Usage of DSPLP( ) Subprogram Options, for details on how -C to increase the value of LBM. Message: -C DSPLP( ). SHORT ON STORAGE FOR LA05*( ) PACKAGE. USE PRGOPT(*) -C TO GIVE MORE. -C ERROR NUMBER = 28 -C -C -----29. The row dimension of the two-dimensional Fortran array, -C the number of constraint equations (MRELAS), and the number -C of variables (NVARS), were not passed to the subprogram -C DFULMT(). See KEY = 68 for details. Message: -C DFULMT() OF DSPLP() PACKAGE. ROW DIM., MRELAS, NVARS ARE -C MISSING FROM PRGOPT(*). -C ERROR NUMBER = 29 -C -C |-------------------------------------------------------| -C |End of List of DSPLP( ) Error and Diagnostic Messages. | -C |-------------------------------------------------------| -C***REFERENCES R. J. Hanson and K. L. Hiebert, A sparse linear -C programming subprogram, Report SAND81-0297, Sandia -C National Laboratories, 1981. -C***ROUTINES CALLED DPLPMN, XERMSG -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890605 Corrected references to XERRWV. (WRB) -C 890605 Removed unreferenced labels. (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 DSPLP - DOUBLE PRECISION BL(*),BU(*),COSTS(*),DATTRV(*),DUALS(*), - * PRGOPT(*),PRIMAL(*),WORK(*),ZERO -C - INTEGER IBASIS(*),IND(*),IWORK(*) - CHARACTER*8 XERN1, XERN2 -C - EXTERNAL DUSRMT -C -C***FIRST EXECUTABLE STATEMENT DSPLP - ZERO=0.D0 - IOPT=1 -C -C VERIFY THAT MRELAS, NVARS .GT. 0. -C - IF (MRELAS.LE.0) THEN - WRITE (XERN1, '(I8)') MRELAS - CALL XERMSG ('SLATEC', 'DSPLP', 'VALUE OF MRELAS MUST BE ' // - * '.GT. 0. NOW = ' // XERN1, 5, 1) - INFO = -5 - RETURN - ENDIF -C - IF (NVARS.LE.0) THEN - WRITE (XERN1, '(I8)') NVARS - CALL XERMSG ('SLATEC', 'DSPLP', 'VALUE OF NVARS MUST BE ' // - * '.GT. 0. NOW = ' // XERN1, 6, 1) - INFO = -6 - RETURN - ENDIF -C - LMX=4*NVARS+7 - LBM=8*MRELAS - LAST = 1 - IADBIG=10000 - ICTMAX=1000 - ICTOPT= 0 -C -C LOOK IN OPTION ARRAY FOR CHANGES TO WORK ARRAY LENGTHS. -20008 NEXT=PRGOPT(LAST) - IF (.NOT.(NEXT.LE.0 .OR. NEXT.GT.IADBIG)) GO TO 20010 -C -C THE CHECKS FOR SMALL OR LARGE VALUES OF NEXT ARE TO PREVENT -C WORKING WITH UNDEFINED DATA. - NERR=14 - CALL XERMSG ('SLATEC', 'DSPLP', - + 'THE USER OPTION ARRAY HAS UNDEFINED DATA.', NERR, IOPT) - INFO=-NERR - RETURN -20010 IF (.NOT.(NEXT.EQ.1)) GO TO 10001 - GO TO 20009 -10001 IF (.NOT.(ICTOPT.GT.ICTMAX)) GO TO 10002 - NERR=15 - CALL XERMSG ('SLATEC', 'DSPLP', - + 'OPTION ARRAY PROCESSING IS CYCLING.', NERR, IOPT) - INFO=-NERR - RETURN -10002 CONTINUE - KEY = PRGOPT(LAST+1) -C -C IF KEY = 53, USER MAY SPECIFY LENGTHS OF PORTIONS -C OF WORK(*) AND IWORK(*) THAT ARE ALLOCATED TO THE -C SPARSE MATRIX STORAGE AND SPARSE LINEAR EQUATION -C SOLVING. - IF (.NOT.(KEY.EQ.53)) GO TO 20013 - IF (.NOT.(PRGOPT(LAST+2).NE.ZERO)) GO TO 20016 - LMX=PRGOPT(LAST+3) - LBM=PRGOPT(LAST+4) -20016 CONTINUE -20013 ICTOPT = ICTOPT+1 - LAST = NEXT - GO TO 20008 -C -C CHECK LENGTH VALIDITY OF SPARSE MATRIX STAGING AREA. -C -20009 IF (LMX.LT.NVARS+7) THEN - WRITE (XERN1, '(I8)') LMX - CALL XERMSG ('SLATEC', 'DSPLP', 'USER-DEFINED VALUE OF ' // - * 'LAMAT = ' // XERN1 // ' MUST BE .GE. NVARS+7.', 20, 1) - INFO = -20 - RETURN - ENDIF -C -C TRIVIAL CHECK ON LENGTH OF LA05*() MATRIX AREA. -C - IF (.NOT.(LBM.LT.0)) GO TO 20022 - NERR=21 - CALL XERMSG ('SLATEC', 'DSPLP', - + 'USER-DEFINED VALUE OF LBM MUST BE .GE. 0.', NERR, IOPT) - INFO=-NERR - RETURN -20022 CONTINUE -C -C DEFINE POINTERS FOR STARTS OF SUBARRAYS USED IN WORK(*) -C AND IWORK(*) IN OTHER SUBPROGRAMS OF THE PACKAGE. - LAMAT=1 - LCSC=LAMAT+LMX - LCOLNR=LCSC+NVARS - LERD=LCOLNR+NVARS - LERP=LERD+MRELAS - LBASMA=LERP+MRELAS - LWR=LBASMA+LBM - LRZ=LWR+MRELAS - LRG=LRZ+NVARS+MRELAS - LRPRIM=LRG+NVARS+MRELAS - LRHS=LRPRIM+MRELAS - LWW=LRHS+MRELAS - LWORK=LWW+MRELAS-1 - LIMAT=1 - LIBB=LIMAT+LMX - LIBRC=LIBB+NVARS+MRELAS - LIPR=LIBRC+2*LBM - LIWR=LIPR+2*MRELAS - LIWORK=LIWR+8*MRELAS-1 -C -C CHECK ARRAY LENGTH VALIDITY OF WORK(*), IWORK(*). -C - IF (LW.LT.LWORK .OR. LIW.LT.LIWORK) THEN - WRITE (XERN1, '(I8)') LWORK - WRITE (XERN2, '(I8)') LIWORK - CALL XERMSG ('SLATEC', 'DSPLP', 'WORK OR IWORK IS NOT LONG ' // - * 'ENOUGH. LW MUST BE = ' // XERN1 // ' AND LIW MUST BE = ' // - * XERN2, 4, 1) - INFO = -4 - RETURN - ENDIF -C - CALL DPLPMN(DUSRMT,MRELAS,NVARS,COSTS,PRGOPT,DATTRV, - * BL,BU,IND,INFO,PRIMAL,DUALS,WORK(LAMAT), - * WORK(LCSC),WORK(LCOLNR),WORK(LERD),WORK(LERP),WORK(LBASMA), - * WORK(LWR),WORK(LRZ),WORK(LRG),WORK(LRPRIM),WORK(LRHS), - * WORK(LWW),LMX,LBM,IBASIS,IWORK(LIBB),IWORK(LIMAT), - * IWORK(LIBRC),IWORK(LIPR),IWORK(LIWR)) -C -C CALL DPLPMN(DUSRMT,MRELAS,NVARS,COSTS,PRGOPT,DATTRV, -C 1 BL,BU,IND,INFO,PRIMAL,DUALS,AMAT, -C 2 CSC,COLNRM,ERD,ERP,BASMAT, -C 3 WR,RZ,RG,RPRIM,RHS, -C 4 WW,LMX,LBM,IBASIS,IBB,IMAT, -C 5 IBRC,IPR,IWR) -C - RETURN - END diff --git a/slatec/dspmv.f b/slatec/dspmv.f deleted file mode 100644 index 34917de..0000000 --- a/slatec/dspmv.f +++ /dev/null @@ -1,269 +0,0 @@ -*DECK DSPMV - SUBROUTINE DSPMV (UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY) -C***BEGIN PROLOGUE DSPMV -C***PURPOSE Perform the matrix-vector operation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE DOUBLE PRECISION (SSPMV-S, DSPMV-D, CSPMV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C DSPMV performs the matrix-vector operation -C -C y := alpha*A*x + beta*y, -C -C where alpha and beta are scalars, x and y are n element vectors and -C A is an n by n symmetric matrix, supplied in packed form. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the matrix A is supplied in the packed -C array AP as follows: -C -C UPLO = 'U' or 'u' The upper triangular part of A is -C supplied in AP. -C -C UPLO = 'L' or 'l' The lower triangular part of A is -C supplied in AP. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - DOUBLE PRECISION. -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C AP - DOUBLE PRECISION array of DIMENSION at least -C ( ( n*( n + 1))/2). -C Before entry with UPLO = 'U' or 'u', the array AP must -C contain the upper triangular part of the symmetric matrix -C packed sequentially, column by column, so that AP( 1 ) -C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -C and a( 2, 2 ) respectively, and so on. -C Before entry with UPLO = 'L' or 'l', the array AP must -C contain the lower triangular part of the symmetric matrix -C packed sequentially, column by column, so that AP( 1 ) -C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -C and a( 3, 1 ) respectively, and so on. -C Unchanged on exit. -C -C X - DOUBLE PRECISION array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C BETA - DOUBLE PRECISION. -C On entry, BETA specifies the scalar beta. When BETA is -C supplied as zero then Y need not be set on input. -C Unchanged on exit. -C -C Y - DOUBLE PRECISION array of dimension at least -C ( 1 + ( n - 1 )*abs( INCY ) ). -C Before entry, the incremented array Y must contain the n -C element vector y. On exit, Y is overwritten by the updated -C vector y. -C -C INCY - INTEGER. -C On entry, INCY specifies the increment for the elements of -C Y. INCY must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE DSPMV -C .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA - INTEGER INCX, INCY, N - CHARACTER*1 UPLO -C .. Array Arguments .. - DOUBLE PRECISION AP( * ), X( * ), Y( * ) -C .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -C .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C***FIRST EXECUTABLE STATEMENT DSPMV -C -C Test the input parameters. -C - 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 -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C Set up the start points in X and Y. -C - 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 -C -C Start the operations. In this version the elements of the array AP -C are accessed sequentially with one pass through AP. -C -C First form y := beta*y. -C - 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 -C -C Form y when AP contains the upper triangle. -C - 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 -C -C Form y when AP contains the lower triangle. -C - 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 -C - RETURN -C -C End of DSPMV . -C - END diff --git a/slatec/dspr.f b/slatec/dspr.f deleted file mode 100644 index 79501c3..0000000 --- a/slatec/dspr.f +++ /dev/null @@ -1,205 +0,0 @@ -*DECK DSPR - SUBROUTINE DSPR (UPLO, N, ALPHA, X, INCX, AP) -C***BEGIN PROLOGUE DSPR -C***PURPOSE Perform the symmetric rank 1 operation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE DOUBLE PRECISION (DSPR-D) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C DSPR performs the symmetric rank 1 operation -C -C A := alpha*x*x' + A, -C -C where alpha is a real scalar, x is an n element vector and A is an -C n by n symmetric matrix, supplied in packed form. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the matrix A is supplied in the packed -C array AP as follows: -C -C UPLO = 'U' or 'u' The upper triangular part of A is -C supplied in AP. -C -C UPLO = 'L' or 'l' The lower triangular part of A is -C supplied in AP. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - DOUBLE PRECISION. -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C X - DOUBLE PRECISION array of dimension at least -C ( 1 + ( n - 1)*abs( INCX)). -C Before entry, the incremented array X must contain the n -C element vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C AP - DOUBLE PRECISION array of DIMENSION at least -C ( ( n*( n + 1 ) )/2 ). -C Before entry with UPLO = 'U' or 'u', the array AP must -C contain the upper triangular part of the symmetric matrix -C packed sequentially, column by column, so that AP( 1 ) -C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -C and a( 2, 2 ) respectively, and so on. On exit, the array -C AP is overwritten by the upper triangular part of the -C updated matrix. -C Before entry with UPLO = 'L' or 'l', the array AP must -C contain the lower triangular part of the symmetric matrix -C packed sequentially, column by column, so that AP( 1 ) -C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -C and a( 3, 1 ) respectively, and so on. On exit, the array -C AP is overwritten by the lower triangular part of the -C updated matrix. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE DSPR -C .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, N - CHARACTER*1 UPLO -C .. Array Arguments .. - DOUBLE PRECISION AP( * ), X( * ) -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -C .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C***FIRST EXECUTABLE STATEMENT DSPR -C -C Test the input parameters. -C - 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 -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -C -C Set the start point in X if the increment is not unity. -C - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -C -C Start the operations. In this version the elements of the array AP -C are accessed sequentially with one pass through AP. -C - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -C -C Form A when upper triangle is stored in AP. -C - 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 -C -C Form A when lower triangle is stored in AP. -C - 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 -C - RETURN -C -C End of DSPR . -C - END diff --git a/slatec/dspr2.f b/slatec/dspr2.f deleted file mode 100644 index b83fbcd..0000000 --- a/slatec/dspr2.f +++ /dev/null @@ -1,236 +0,0 @@ -*DECK DSPR2 - SUBROUTINE DSPR2 (UPLO, N, ALPHA, X, INCX, Y, INCY, AP) -C***BEGIN PROLOGUE DSPR2 -C***PURPOSE Perform the symmetric rank 2 operation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE DOUBLE PRECISION (SSPR2-S, DSPR2-D, CSPR2-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C DSPR2 performs the symmetric rank 2 operation -C -C A := alpha*x*y' + alpha*y*x' + A, -C -C where alpha is a scalar, x and y are n element vectors and A is an -C n by n symmetric matrix, supplied in packed form. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the matrix A is supplied in the packed -C array AP as follows: -C -C UPLO = 'U' or 'u' The upper triangular part of A is -C supplied in AP. -C -C UPLO = 'L' or 'l' The lower triangular part of A is -C supplied in AP. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - DOUBLE PRECISION. -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C X - DOUBLE PRECISION array of dimension at least -C ( 1 + ( n - 1)*abs( INCX)). -C Before entry, the incremented array X must contain the n -C element vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C Y - DOUBLE PRECISION array of dimension at least -C ( 1 + ( n - 1 )*abs( INCY ) ). -C Before entry, the incremented array Y must contain the n -C element vector y. -C Unchanged on exit. -C -C INCY - INTEGER. -C On entry, INCY specifies the increment for the elements of -C Y. INCY must not be zero. -C Unchanged on exit. -C -C AP - DOUBLE PRECISION array of DIMENSION at least -C ( ( n*( n + 1 ) )/2 ). -C Before entry with UPLO = 'U' or 'u', the array AP must -C contain the upper triangular part of the symmetric matrix -C packed sequentially, column by column, so that AP( 1 ) -C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -C and a( 2, 2 ) respectively, and so on. On exit, the array -C AP is overwritten by the upper triangular part of the -C updated matrix. -C Before entry with UPLO = 'L' or 'l', the array AP must -C contain the lower triangular part of the symmetric matrix -C packed sequentially, column by column, so that AP( 1 ) -C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -C and a( 3, 1 ) respectively, and so on. On exit, the array -C AP is overwritten by the lower triangular part of the -C updated matrix. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE DSPR2 -C .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, INCY, N - CHARACTER*1 UPLO -C .. Array Arguments .. - DOUBLE PRECISION AP( * ), X( * ), Y( * ) -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -C .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C***FIRST EXECUTABLE STATEMENT DSPR2 -C -C Test the input parameters. -C - 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 -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -C -C Set up the start points in X and Y if the increments are not both -C unity. -C - 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 -C -C Start the operations. In this version the elements of the array AP -C are accessed sequentially with one pass through AP. -C - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -C -C Form A when upper triangle is stored in AP. -C - 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 -C -C Form A when lower triangle is stored in AP. -C - 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 -C - RETURN -C -C End of DSPR2 . -C - END diff --git a/slatec/dspsl.f b/slatec/dspsl.f deleted file mode 100644 index 8c84fa5..0000000 --- a/slatec/dspsl.f +++ /dev/null @@ -1,196 +0,0 @@ -*DECK DSPSL - SUBROUTINE DSPSL (AP, N, KPVT, B) -C***BEGIN PROLOGUE DSPSL -C***PURPOSE Solve a real symmetric system using the factors obtained -C from DSPFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1A -C***TYPE DOUBLE PRECISION (SSPSL-S, DSPSL-D, CHPSL-C, CSPSL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, PACKED, SOLVE, SYMMETRIC -C***AUTHOR Bunch, J., (UCSD) -C***DESCRIPTION -C -C DSISL solves the double precision symmetric system -C A * X = B -C using the factors computed by DSPFA. -C -C On Entry -C -C AP DOUBLE PRECISION(N*(N+1)/2) -C the output from DSPFA. -C -C N INTEGER -C the order of the matrix A . -C -C KPVT INTEGER(N) -C the pivot vector from DSPFA. -C -C B DOUBLE PRECISION(N) -C the right hand side vector. -C -C On Return -C -C B the solution vector X . -C -C Error Condition -C -C A division by zero may occur if DSPCO has set RCOND .EQ. 0.0 -C or DSPFA has set INFO .NE. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL DSPFA(AP,N,KPVT,INFO) -C IF (INFO .NE. 0) GO TO ... -C DO 10 J = 1, P -C CALL DSPSL(AP,N,KPVT,C(1,J)) -C 10 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DDOT -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Modified routine equivalence list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DSPSL - INTEGER N,KPVT(*) - DOUBLE PRECISION AP(*),B(*) -C - DOUBLE PRECISION AK,AKM1,BK,BKM1,DDOT,DENOM,TEMP - INTEGER IK,IKM1,IKP1,K,KK,KM1K,KM1KM1,KP -C -C LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND -C D INVERSE TO B. -C -C***FIRST EXECUTABLE STATEMENT DSPSL - K = N - IK = (N*(N - 1))/2 - 10 IF (K .EQ. 0) GO TO 80 - KK = IK + K - IF (KPVT(K) .LT. 0) GO TO 40 -C -C 1 X 1 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 30 - KP = KPVT(K) - IF (KP .EQ. K) GO TO 20 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 20 CONTINUE -C -C APPLY THE TRANSFORMATION. -C - CALL DAXPY(K-1,B(K),AP(IK+1),1,B(1),1) - 30 CONTINUE -C -C APPLY D INVERSE. -C - B(K) = B(K)/AP(KK) - K = K - 1 - IK = IK - K - GO TO 70 - 40 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - IKM1 = IK - (K - 1) - IF (K .EQ. 2) GO TO 60 - KP = ABS(KPVT(K)) - IF (KP .EQ. K - 1) GO TO 50 -C -C INTERCHANGE. -C - TEMP = B(K-1) - B(K-1) = B(KP) - B(KP) = TEMP - 50 CONTINUE -C -C APPLY THE TRANSFORMATION. -C - CALL DAXPY(K-2,B(K),AP(IK+1),1,B(1),1) - CALL DAXPY(K-2,B(K-1),AP(IKM1+1),1,B(1),1) - 60 CONTINUE -C -C APPLY D INVERSE. -C - KM1K = IK + K - 1 - KK = IK + K - AK = AP(KK)/AP(KM1K) - KM1KM1 = IKM1 + K - 1 - AKM1 = AP(KM1KM1)/AP(KM1K) - BK = B(K)/AP(KM1K) - BKM1 = B(K-1)/AP(KM1K) - DENOM = AK*AKM1 - 1.0D0 - B(K) = (AKM1*BK - BKM1)/DENOM - B(K-1) = (AK*BKM1 - BK)/DENOM - K = K - 2 - IK = IK - (K + 1) - K - 70 CONTINUE - GO TO 10 - 80 CONTINUE -C -C LOOP FORWARD APPLYING THE TRANSFORMATIONS. -C - K = 1 - IK = 0 - 90 IF (K .GT. N) GO TO 160 - IF (KPVT(K) .LT. 0) GO TO 120 -C -C 1 X 1 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 110 -C -C APPLY THE TRANSFORMATION. -C - B(K) = B(K) + DDOT(K-1,AP(IK+1),1,B(1),1) - KP = KPVT(K) - IF (KP .EQ. K) GO TO 100 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 100 CONTINUE - 110 CONTINUE - IK = IK + K - K = K + 1 - GO TO 150 - 120 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 140 -C -C APPLY THE TRANSFORMATION. -C - B(K) = B(K) + DDOT(K-1,AP(IK+1),1,B(1),1) - IKP1 = IK + K - B(K+1) = B(K+1) + DDOT(K-1,AP(IKP1+1),1,B(1),1) - KP = ABS(KPVT(K)) - IF (KP .EQ. K) GO TO 130 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 130 CONTINUE - 140 CONTINUE - IK = IK + K + K + 1 - K = K + 2 - 150 CONTINUE - GO TO 90 - 160 CONTINUE - RETURN - END diff --git a/slatec/dsteps.f b/slatec/dsteps.f deleted file mode 100644 index fb61a13..0000000 --- a/slatec/dsteps.f +++ /dev/null @@ -1,577 +0,0 @@ -*DECK DSTEPS - SUBROUTINE DSTEPS (DF, NEQN, Y, X, H, EPS, WT, START, HOLD, K, - + KOLD, CRASH, PHI, P, YP, PSI, ALPHA, BETA, SIG, V, W, G, - + PHASE1, NS, NORND, KSTEPS, TWOU, FOURU, XOLD, KPREV, IVC, IV, - + KGI, GI, RPAR, IPAR) -C***BEGIN PROLOGUE DSTEPS -C***PURPOSE Integrate a system of first order ordinary differential -C equations one step. -C***LIBRARY SLATEC (DEPAC) -C***CATEGORY I1A1B -C***TYPE DOUBLE PRECISION (STEPS-S, DSTEPS-D) -C***KEYWORDS ADAMS METHOD, DEPAC, INITIAL VALUE PROBLEMS, ODE, -C ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR -C***AUTHOR Shampine, L. F., (SNLA) -C Gordon, M. K., (SNLA) -C MODIFIED BY H.A. WATTS -C***DESCRIPTION -C -C Written by L. F. Shampine and M. K. Gordon -C -C Abstract -C -C Subroutine DSTEPS is normally used indirectly through subroutine -C DDEABM . Because DDEABM suffices for most problems and is much -C easier to use, using it should be considered before using DSTEPS -C alone. -C -C Subroutine DSTEPS integrates a system of NEQN first order ordinary -C differential equations one step, normally from X to X+H, using a -C modified divided difference form of the Adams Pece formulas. Local -C extrapolation is used to improve absolute stability and accuracy. -C The code adjusts its order and step size to control the local error -C per unit step in a generalized sense. Special devices are included -C to control roundoff error and to detect when the user is requesting -C too much accuracy. -C -C This code is completely explained and documented in the text, -C Computer Solution of Ordinary Differential Equations, The Initial -C Value Problem by L. F. Shampine and M. K. Gordon. -C Further details on use of this code are available in "Solving -C Ordinary Differential Equations with ODE, STEP, and INTRP", -C by L. F. Shampine and M. K. Gordon, SLA-73-1060. -C -C -C The parameters represent -- -C DF -- subroutine to evaluate derivatives -C NEQN -- number of equations to be integrated -C Y(*) -- solution vector at X -C X -- independent variable -C H -- appropriate step size for next step. Normally determined by -C code -C EPS -- local error tolerance -C WT(*) -- vector of weights for error criterion -C START -- logical variable set .TRUE. for first step, .FALSE. -C otherwise -C HOLD -- step size used for last successful step -C K -- appropriate order for next step (determined by code) -C KOLD -- order used for last successful step -C CRASH -- logical variable set .TRUE. when no step can be taken, -C .FALSE. otherwise. -C YP(*) -- derivative of solution vector at X after successful -C step -C KSTEPS -- counter on attempted steps -C TWOU -- 2.*U where U is machine unit roundoff quantity -C FOURU -- 4.*U where U is machine unit roundoff quantity -C RPAR,IPAR -- parameter arrays which you may choose to use -C for communication between your program and subroutine F. -C They are not altered or used by DSTEPS. -C The variables X,XOLD,KOLD,KGI and IVC and the arrays Y,PHI,ALPHA,G, -C W,P,IV and GI are required for the interpolation subroutine SINTRP. -C The remaining variables and arrays are included in the call list -C only to eliminate local retention of variables between calls. -C -C Input to DSTEPS -C -C First call -- -C -C The user must provide storage in his calling program for all arrays -C in the call list, namely -C -C DIMENSION Y(NEQN),WT(NEQN),PHI(NEQN,16),P(NEQN),YP(NEQN),PSI(12), -C 1 ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13),GI(11),IV(10), -C 2 RPAR(*),IPAR(*) -C -C **Note** -C -C The user must also declare START , CRASH , PHASE1 and NORND -C logical variables and DF an EXTERNAL subroutine, supply the -C subroutine DF(X,Y,YP) to evaluate -C DY(I)/DX = YP(I) = DF(X,Y(1),Y(2),...,Y(NEQN)) -C and initialize only the following parameters. -C NEQN -- number of equations to be integrated -C Y(*) -- vector of initial values of dependent variables -C X -- initial value of the independent variable -C H -- nominal step size indicating direction of integration -C and maximum size of step. Must be variable -C EPS -- local error tolerance per step. Must be variable -C WT(*) -- vector of non-zero weights for error criterion -C START -- .TRUE. -C YP(*) -- vector of initial derivative values -C KSTEPS -- set KSTEPS to zero -C TWOU -- 2.*U where U is machine unit roundoff quantity -C FOURU -- 4.*U where U is machine unit roundoff quantity -C Define U to be the machine unit roundoff quantity by calling -C the function routine D1MACH, U = D1MACH(4), or by -C computing U so that U is the smallest positive number such -C that 1.0+U .GT. 1.0. -C -C DSTEPS requires that the L2 norm of the vector with components -C LOCAL ERROR(L)/WT(L) be less than EPS for a successful step. The -C array WT allows the user to specify an error test appropriate -C for his problem. For example, -C WT(L) = 1.0 specifies absolute error, -C = ABS(Y(L)) error relative to the most recent value of the -C L-th component of the solution, -C = ABS(YP(L)) error relative to the most recent value of -C the L-th component of the derivative, -C = MAX(WT(L),ABS(Y(L))) error relative to the largest -C magnitude of L-th component obtained so far, -C = ABS(Y(L))*RELERR/EPS + ABSERR/EPS specifies a mixed -C relative-absolute test where RELERR is relative -C error, ABSERR is absolute error and EPS = -C MAX(RELERR,ABSERR) . -C -C Subsequent calls -- -C -C Subroutine DSTEPS is designed so that all information needed to -C continue the integration, including the step size H and the order -C K , is returned with each step. With the exception of the step -C size, the error tolerance, and the weights, none of the parameters -C should be altered. The array WT must be updated after each step -C to maintain relative error tests like those above. Normally the -C integration is continued just beyond the desired endpoint and the -C solution interpolated there with subroutine SINTRP . If it is -C impossible to integrate beyond the endpoint, the step size may be -C reduced to hit the endpoint since the code will not take a step -C larger than the H input. Changing the direction of integration, -C i.e., the sign of H , requires the user set START = .TRUE. before -C calling DSTEPS again. This is the only situation in which START -C should be altered. -C -C Output from DSTEPS -C -C Successful Step -- -C -C The subroutine returns after each successful step with START and -C CRASH set .FALSE. . X represents the independent variable -C advanced one step of length HOLD from its value on input and Y -C the solution vector at the new value of X . All other parameters -C represent information corresponding to the new X needed to -C continue the integration. -C -C Unsuccessful Step -- -C -C When the error tolerance is too small for the machine precision, -C the subroutine returns without taking a step and CRASH = .TRUE. . -C An appropriate step size and error tolerance for continuing are -C estimated and all other information is restored as upon input -C before returning. To continue with the larger tolerance, the user -C just calls the code again. A restart is neither required nor -C desirable. -C -C***REFERENCES L. F. Shampine and M. K. Gordon, Solving ordinary -C differential equations with ODE, STEP, and INTRP, -C Report SLA-73-1060, Sandia Laboratories, 1973. -C***ROUTINES CALLED D1MACH, DHSTRT -C***REVISION HISTORY (YYMMDD) -C 740101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DSTEPS -C - INTEGER I, IFAIL, IM1, IP1, IPAR, IQ, J, K, KM1, KM2, KNEW, - 1 KOLD, KP1, KP2, KSTEPS, L, LIMIT1, LIMIT2, NEQN, NS, NSM2, - 2 NSP1, NSP2 - DOUBLE PRECISION ABSH, ALPHA, BETA, BIG, D1MACH, - 1 EPS, ERK, ERKM1, ERKM2, ERKP1, ERR, - 2 FOURU, G, GI, GSTR, H, HNEW, HOLD, P, P5EPS, PHI, PSI, R, - 3 REALI, REALNS, RHO, ROUND, RPAR, SIG, TAU, TEMP1, - 4 TEMP2, TEMP3, TEMP4, TEMP5, TEMP6, TWO, TWOU, U, V, W, WT, - 5 X, XOLD, Y, YP - LOGICAL START,CRASH,PHASE1,NORND - DIMENSION Y(*),WT(*),PHI(NEQN,16),P(*),YP(*),PSI(12), - 1 ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13),GI(11),IV(10), - 2 RPAR(*),IPAR(*) - DIMENSION TWO(13),GSTR(13) - EXTERNAL DF - SAVE TWO, GSTR -C - DATA TWO(1),TWO(2),TWO(3),TWO(4),TWO(5),TWO(6),TWO(7),TWO(8), - 1 TWO(9),TWO(10),TWO(11),TWO(12),TWO(13) - 2 /2.0D0,4.0D0,8.0D0,16.0D0,32.0D0,64.0D0,128.0D0,256.0D0, - 3 512.0D0,1024.0D0,2048.0D0,4096.0D0,8192.0D0/ - DATA GSTR(1),GSTR(2),GSTR(3),GSTR(4),GSTR(5),GSTR(6),GSTR(7), - 1 GSTR(8),GSTR(9),GSTR(10),GSTR(11),GSTR(12),GSTR(13) - 2 /0.5D0,0.0833D0,0.0417D0,0.0264D0,0.0188D0,0.0143D0,0.0114D0, - 3 0.00936D0,0.00789D0,0.00679D0,0.00592D0,0.00524D0,0.00468D0/ -C -C *** BEGIN BLOCK 0 *** -C CHECK IF STEP SIZE OR ERROR TOLERANCE IS TOO SMALL FOR MACHINE -C PRECISION. IF FIRST STEP, INITIALIZE PHI ARRAY AND ESTIMATE A -C STARTING STEP SIZE. -C *** -C -C IF STEP SIZE IS TOO SMALL, DETERMINE AN ACCEPTABLE ONE -C -C***FIRST EXECUTABLE STATEMENT DSTEPS - CRASH = .TRUE. - IF(ABS(H) .GE. FOURU*ABS(X)) GO TO 5 - H = SIGN(FOURU*ABS(X),H) - RETURN - 5 P5EPS = 0.5D0*EPS -C -C IF ERROR TOLERANCE IS TOO SMALL, INCREASE IT TO AN ACCEPTABLE VALUE -C - ROUND = 0.0D0 - DO 10 L = 1,NEQN - 10 ROUND = ROUND + (Y(L)/WT(L))**2 - ROUND = TWOU*SQRT(ROUND) - IF(P5EPS .GE. ROUND) GO TO 15 - EPS = 2.0D0*ROUND*(1.0D0 + FOURU) - RETURN - 15 CRASH = .FALSE. - G(1) = 1.0D0 - G(2) = 0.5D0 - SIG(1) = 1.0D0 - IF(.NOT.START) GO TO 99 -C -C INITIALIZE. COMPUTE APPROPRIATE STEP SIZE FOR FIRST STEP -C -C CALL DF(X,Y,YP,RPAR,IPAR) -C SUM = 0.0 - DO 20 L = 1,NEQN - PHI(L,1) = YP(L) - 20 PHI(L,2) = 0.0D0 -C20 SUM = SUM + (YP(L)/WT(L))**2 -C SUM = SQRT(SUM) -C ABSH = ABS(H) -C IF(EPS .LT. 16.0*SUM*H*H) ABSH = 0.25*SQRT(EPS/SUM) -C H = SIGN(MAX(ABSH,FOURU*ABS(X)),H) -C - U = D1MACH(4) - BIG = SQRT(D1MACH(2)) - CALL DHSTRT(DF,NEQN,X,X+H,Y,YP,WT,1,U,BIG, - 1 PHI(1,3),PHI(1,4),PHI(1,5),PHI(1,6),RPAR,IPAR,H) -C - HOLD = 0.0D0 - K = 1 - KOLD = 0 - KPREV = 0 - START = .FALSE. - PHASE1 = .TRUE. - NORND = .TRUE. - IF(P5EPS .GT. 100.0D0*ROUND) GO TO 99 - NORND = .FALSE. - DO 25 L = 1,NEQN - 25 PHI(L,15) = 0.0D0 - 99 IFAIL = 0 -C *** END BLOCK 0 *** -C -C *** BEGIN BLOCK 1 *** -C COMPUTE COEFFICIENTS OF FORMULAS FOR THIS STEP. AVOID COMPUTING -C THOSE QUANTITIES NOT CHANGED WHEN STEP SIZE IS NOT CHANGED. -C *** -C - 100 KP1 = K+1 - KP2 = K+2 - KM1 = K-1 - KM2 = K-2 -C -C NS IS THE NUMBER OF DSTEPS TAKEN WITH SIZE H, INCLUDING THE CURRENT -C ONE. WHEN K.LT.NS, NO COEFFICIENTS CHANGE -C - IF(H .NE. HOLD) NS = 0 - IF (NS.LE.KOLD) NS = NS+1 - NSP1 = NS+1 - IF (K .LT. NS) GO TO 199 -C -C COMPUTE THOSE COMPONENTS OF ALPHA(*),BETA(*),PSI(*),SIG(*) WHICH -C ARE CHANGED -C - BETA(NS) = 1.0D0 - REALNS = NS - ALPHA(NS) = 1.0D0/REALNS - TEMP1 = H*REALNS - SIG(NSP1) = 1.0D0 - IF(K .LT. NSP1) GO TO 110 - DO 105 I = NSP1,K - IM1 = I-1 - TEMP2 = PSI(IM1) - PSI(IM1) = TEMP1 - BETA(I) = BETA(IM1)*PSI(IM1)/TEMP2 - TEMP1 = TEMP2 + H - ALPHA(I) = H/TEMP1 - REALI = I - 105 SIG(I+1) = REALI*ALPHA(I)*SIG(I) - 110 PSI(K) = TEMP1 -C -C COMPUTE COEFFICIENTS G(*) -C -C INITIALIZE V(*) AND SET W(*). -C - IF(NS .GT. 1) GO TO 120 - DO 115 IQ = 1,K - TEMP3 = IQ*(IQ+1) - V(IQ) = 1.0D0/TEMP3 - 115 W(IQ) = V(IQ) - IVC = 0 - KGI = 0 - IF (K .EQ. 1) GO TO 140 - KGI = 1 - GI(1) = W(2) - GO TO 140 -C -C IF ORDER WAS RAISED, UPDATE DIAGONAL PART OF V(*) -C - 120 IF(K .LE. KPREV) GO TO 130 - IF (IVC .EQ. 0) GO TO 122 - JV = KP1 - IV(IVC) - IVC = IVC - 1 - GO TO 123 - 122 JV = 1 - TEMP4 = K*KP1 - V(K) = 1.0D0/TEMP4 - W(K) = V(K) - IF (K .NE. 2) GO TO 123 - KGI = 1 - GI(1) = W(2) - 123 NSM2 = NS-2 - IF(NSM2 .LT. JV) GO TO 130 - DO 125 J = JV,NSM2 - I = K-J - V(I) = V(I) - ALPHA(J+1)*V(I+1) - 125 W(I) = V(I) - IF (I .NE. 2) GO TO 130 - KGI = NS - 1 - GI(KGI) = W(2) -C -C UPDATE V(*) AND SET W(*) -C - 130 LIMIT1 = KP1 - NS - TEMP5 = ALPHA(NS) - DO 135 IQ = 1,LIMIT1 - V(IQ) = V(IQ) - TEMP5*V(IQ+1) - 135 W(IQ) = V(IQ) - G(NSP1) = W(1) - IF (LIMIT1 .EQ. 1) GO TO 137 - KGI = NS - GI(KGI) = W(2) - 137 W(LIMIT1+1) = V(LIMIT1+1) - IF (K .GE. KOLD) GO TO 140 - IVC = IVC + 1 - IV(IVC) = LIMIT1 + 2 -C -C COMPUTE THE G(*) IN THE WORK VECTOR W(*) -C - 140 NSP2 = NS + 2 - KPREV = K - IF(KP1 .LT. NSP2) GO TO 199 - DO 150 I = NSP2,KP1 - LIMIT2 = KP2 - I - TEMP6 = ALPHA(I-1) - DO 145 IQ = 1,LIMIT2 - 145 W(IQ) = W(IQ) - TEMP6*W(IQ+1) - 150 G(I) = W(1) - 199 CONTINUE -C *** END BLOCK 1 *** -C -C *** BEGIN BLOCK 2 *** -C PREDICT A SOLUTION P(*), EVALUATE DERIVATIVES USING PREDICTED -C SOLUTION, ESTIMATE LOCAL ERROR AT ORDER K AND ERRORS AT ORDERS K, -C K-1, K-2 AS IF CONSTANT STEP SIZE WERE USED. -C *** -C -C INCREMENT COUNTER ON ATTEMPTED DSTEPS -C - KSTEPS = KSTEPS + 1 -C -C CHANGE PHI TO PHI STAR -C - IF(K .LT. NSP1) GO TO 215 - DO 210 I = NSP1,K - TEMP1 = BETA(I) - DO 205 L = 1,NEQN - 205 PHI(L,I) = TEMP1*PHI(L,I) - 210 CONTINUE -C -C PREDICT SOLUTION AND DIFFERENCES -C - 215 DO 220 L = 1,NEQN - PHI(L,KP2) = PHI(L,KP1) - PHI(L,KP1) = 0.0D0 - 220 P(L) = 0.0D0 - DO 230 J = 1,K - I = KP1 - J - IP1 = I+1 - TEMP2 = G(I) - DO 225 L = 1,NEQN - P(L) = P(L) + TEMP2*PHI(L,I) - 225 PHI(L,I) = PHI(L,I) + PHI(L,IP1) - 230 CONTINUE - IF(NORND) GO TO 240 - DO 235 L = 1,NEQN - TAU = H*P(L) - PHI(L,15) - P(L) = Y(L) + TAU - 235 PHI(L,16) = (P(L) - Y(L)) - TAU - GO TO 250 - 240 DO 245 L = 1,NEQN - 245 P(L) = Y(L) + H*P(L) - 250 XOLD = X - X = X + H - ABSH = ABS(H) - CALL DF(X,P,YP,RPAR,IPAR) -C -C ESTIMATE ERRORS AT ORDERS K,K-1,K-2 -C - ERKM2 = 0.0D0 - ERKM1 = 0.0D0 - ERK = 0.0D0 - DO 265 L = 1,NEQN - TEMP3 = 1.0D0/WT(L) - TEMP4 = YP(L) - PHI(L,1) - IF(KM2)265,260,255 - 255 ERKM2 = ERKM2 + ((PHI(L,KM1)+TEMP4)*TEMP3)**2 - 260 ERKM1 = ERKM1 + ((PHI(L,K)+TEMP4)*TEMP3)**2 - 265 ERK = ERK + (TEMP4*TEMP3)**2 - IF(KM2)280,275,270 - 270 ERKM2 = ABSH*SIG(KM1)*GSTR(KM2)*SQRT(ERKM2) - 275 ERKM1 = ABSH*SIG(K)*GSTR(KM1)*SQRT(ERKM1) - 280 TEMP5 = ABSH*SQRT(ERK) - ERR = TEMP5*(G(K)-G(KP1)) - ERK = TEMP5*SIG(KP1)*GSTR(K) - KNEW = K -C -C TEST IF ORDER SHOULD BE LOWERED -C - IF(KM2)299,290,285 - 285 IF(MAX(ERKM1,ERKM2) .LE. ERK) KNEW = KM1 - GO TO 299 - 290 IF(ERKM1 .LE. 0.5D0*ERK) KNEW = KM1 -C -C TEST IF STEP SUCCESSFUL -C - 299 IF(ERR .LE. EPS) GO TO 400 -C *** END BLOCK 2 *** -C -C *** BEGIN BLOCK 3 *** -C THE STEP IS UNSUCCESSFUL. RESTORE X, PHI(*,*), PSI(*) . -C IF THIRD CONSECUTIVE FAILURE, SET ORDER TO ONE. IF STEP FAILS MORE -C THAN THREE TIMES, CONSIDER AN OPTIMAL STEP SIZE. DOUBLE ERROR -C TOLERANCE AND RETURN IF ESTIMATED STEP SIZE IS TOO SMALL FOR MACHINE -C PRECISION. -C *** -C -C RESTORE X, PHI(*,*) AND PSI(*) -C - PHASE1 = .FALSE. - X = XOLD - DO 310 I = 1,K - TEMP1 = 1.0D0/BETA(I) - IP1 = I+1 - DO 305 L = 1,NEQN - 305 PHI(L,I) = TEMP1*(PHI(L,I) - PHI(L,IP1)) - 310 CONTINUE - IF(K .LT. 2) GO TO 320 - DO 315 I = 2,K - 315 PSI(I-1) = PSI(I) - H -C -C ON THIRD FAILURE, SET ORDER TO ONE. THEREAFTER, USE OPTIMAL STEP -C SIZE -C - 320 IFAIL = IFAIL + 1 - TEMP2 = 0.5D0 - IF(IFAIL - 3) 335,330,325 - 325 IF(P5EPS .LT. 0.25D0*ERK) TEMP2 = SQRT(P5EPS/ERK) - 330 KNEW = 1 - 335 H = TEMP2*H - K = KNEW - NS = 0 - IF(ABS(H) .GE. FOURU*ABS(X)) GO TO 340 - CRASH = .TRUE. - H = SIGN(FOURU*ABS(X),H) - EPS = EPS + EPS - RETURN - 340 GO TO 100 -C *** END BLOCK 3 *** -C -C *** BEGIN BLOCK 4 *** -C THE STEP IS SUCCESSFUL. CORRECT THE PREDICTED SOLUTION, EVALUATE -C THE DERIVATIVES USING THE CORRECTED SOLUTION AND UPDATE THE -C DIFFERENCES. DETERMINE BEST ORDER AND STEP SIZE FOR NEXT STEP. -C *** - 400 KOLD = K - HOLD = H -C -C CORRECT AND EVALUATE -C - TEMP1 = H*G(KP1) - IF(NORND) GO TO 410 - DO 405 L = 1,NEQN - TEMP3 = Y(L) - RHO = TEMP1*(YP(L) - PHI(L,1)) - PHI(L,16) - Y(L) = P(L) + RHO - PHI(L,15) = (Y(L) - P(L)) - RHO - 405 P(L) = TEMP3 - GO TO 420 - 410 DO 415 L = 1,NEQN - TEMP3 = Y(L) - Y(L) = P(L) + TEMP1*(YP(L) - PHI(L,1)) - 415 P(L) = TEMP3 - 420 CALL DF(X,Y,YP,RPAR,IPAR) -C -C UPDATE DIFFERENCES FOR NEXT STEP -C - DO 425 L = 1,NEQN - PHI(L,KP1) = YP(L) - PHI(L,1) - 425 PHI(L,KP2) = PHI(L,KP1) - PHI(L,KP2) - DO 435 I = 1,K - DO 430 L = 1,NEQN - 430 PHI(L,I) = PHI(L,I) + PHI(L,KP1) - 435 CONTINUE -C -C ESTIMATE ERROR AT ORDER K+1 UNLESS: -C IN FIRST PHASE WHEN ALWAYS RAISE ORDER, -C ALREADY DECIDED TO LOWER ORDER, -C STEP SIZE NOT CONSTANT SO ESTIMATE UNRELIABLE -C - ERKP1 = 0.0D0 - IF(KNEW .EQ. KM1 .OR. K .EQ. 12) PHASE1 = .FALSE. - IF(PHASE1) GO TO 450 - IF(KNEW .EQ. KM1) GO TO 455 - IF(KP1 .GT. NS) GO TO 460 - DO 440 L = 1,NEQN - 440 ERKP1 = ERKP1 + (PHI(L,KP2)/WT(L))**2 - ERKP1 = ABSH*GSTR(KP1)*SQRT(ERKP1) -C -C USING ESTIMATED ERROR AT ORDER K+1, DETERMINE APPROPRIATE ORDER -C FOR NEXT STEP -C - IF(K .GT. 1) GO TO 445 - IF(ERKP1 .GE. 0.5D0*ERK) GO TO 460 - GO TO 450 - 445 IF(ERKM1 .LE. MIN(ERK,ERKP1)) GO TO 455 - IF(ERKP1 .GE. ERK .OR. K .EQ. 12) GO TO 460 -C -C HERE ERKP1 .LT. ERK .LT. MAX(ERKM1,ERKM2) ELSE ORDER WOULD HAVE -C BEEN LOWERED IN BLOCK 2. THUS ORDER IS TO BE RAISED -C -C RAISE ORDER -C - 450 K = KP1 - ERK = ERKP1 - GO TO 460 -C -C LOWER ORDER -C - 455 K = KM1 - ERK = ERKM1 -C -C WITH NEW ORDER DETERMINE APPROPRIATE STEP SIZE FOR NEXT STEP -C - 460 HNEW = H + H - IF(PHASE1) GO TO 465 - IF(P5EPS .GE. ERK*TWO(K+1)) GO TO 465 - HNEW = H - IF(P5EPS .GE. ERK) GO TO 465 - TEMP2 = K+1 - R = (P5EPS/ERK)**(1.0D0/TEMP2) - HNEW = ABSH*MAX(0.5D0,MIN(0.9D0,R)) - HNEW = SIGN(MAX(HNEW,FOURU*ABS(X)),H) - 465 H = HNEW - RETURN -C *** END BLOCK 4 *** - END diff --git a/slatec/dstod.f b/slatec/dstod.f deleted file mode 100644 index 4f87d8e..0000000 --- a/slatec/dstod.f +++ /dev/null @@ -1,695 +0,0 @@ -*DECK DSTOD - SUBROUTINE DSTOD (NEQ, Y, YH, NYH, YH1, EWT, SAVF, ACOR, WM, IWM, - + DF, DJAC, RPAR, IPAR) -C***BEGIN PROLOGUE DSTOD -C***SUBSIDIARY -C***PURPOSE Subsidiary to DDEBDF -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (STOD-S, DSTOD-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C DSTOD integrates a system of first order odes over one step in the -C integrator package DDEBDF. -C ---------------------------------------------------------------------- -C DSTOD performs one step of the integration of an initial value -C problem for a system of ordinary differential equations. -C Note.. DSTOD is independent of the value of the iteration method -C indicator MITER, when this is .NE. 0, and hence is independent -C of the type of chord method used, or the Jacobian structure. -C Communication with DSTOD is done with the following variables.. -C -C Y = An array of length .GE. N used as the Y argument in -C all calls to DF and DJAC. -C NEQ = Integer array containing problem size in NEQ(1), and -C passed as the NEQ argument in all calls to DF and DJAC. -C YH = An NYH by LMAX array containing the dependent variables -C and their approximate scaled derivatives, where -C LMAX = MAXORD + 1. YH(I,J+1) contains the approximate -C J-th derivative of Y(I), scaled by H**J/FACTORIAL(J) -C (J = 0,1,...,NQ). On entry for the first step, the first -C two columns of YH must be set from the initial values. -C NYH = A constant integer .GE. N, the first dimension of YH. -C YH1 = A one-dimensional array occupying the same space as YH. -C EWT = An array of N elements with which the estimated local -C errors in YH are compared. -C SAVF = An array of working storage, of length N. -C ACOR = A work array of length N, used for the accumulated -C corrections. On a successful return, ACOR(I) contains -C the estimated one-step local error in Y(I). -C WM,IWM = DOUBLE PRECISION and INTEGER work arrays associated with -C matrix operations in chord iteration (MITER .NE. 0). -C DPJAC = Name of routine to evaluate and preprocess Jacobian matrix -C if a chord method is being used. -C DSLVS = Name of routine to solve linear system in chord iteration. -C H = The step size to be attempted on the next step. -C H is altered by the error control algorithm during the -C problem. H can be either positive or negative, but its -C sign must remain constant throughout the problem. -C HMIN = The minimum absolute value of the step size H to be used. -C HMXI = Inverse of the maximum absolute value of H to be used. -C HMXI = 0.0 is allowed and corresponds to an infinite HMAX. -C HMIN and HMXI may be changed at any time, but will not -C take effect until the next change of H is considered. -C TN = The independent variable. TN is updated on each step taken. -C JSTART = An integer used for input only, with the following -C values and meanings.. -C 0 Perform the first step. -C .GT.0 Take a new step continuing from the last. -C -1 Take the next step with a new value of H, MAXORD, -C N, METH, MITER, and/or matrix parameters. -C -2 Take the next step with a new value of H, -C but with other inputs unchanged. -C On return, JSTART is set to 1 to facilitate continuation. -C KFLAG = a completion code with the following meanings.. -C 0 The step was successful. -C -1 The requested error could not be achieved. -C -2 Corrector convergence could not be achieved. -C A return with KFLAG = -1 or -2 means either -C ABS(H) = HMIN or 10 consecutive failures occurred. -C On a return with KFLAG negative, the values of TN and -C the YH array are as of the beginning of the last -C step, and H is the last step size attempted. -C MAXORD = The maximum order of integration method to be allowed. -C METH/MITER = The method flags. See description in driver. -C N = The number of first-order differential equations. -C ---------------------------------------------------------------------- -C -C***SEE ALSO DDEBDF -C***ROUTINES CALLED DCFOD, DPJAC, DSLVS, DVNRMS -C***COMMON BLOCKS DDEBD1 -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C 920422 Changed DIMENSION statement. (WRB) -C***END PROLOGUE DSTOD -C - INTEGER I, I1, IALTH, IER, IOD, IOWND, IPAR, IPUP, IREDO, IRET, - 1 IWM, J, JB, JSTART, KFLAG, KSTEPS, L, LMAX, M, MAXORD, - 2 MEO, METH, MITER, N, NCF, NEQ, NEWQ, NFE, NJE, NQ, NQNYH, - 3 NQU, NST, NSTEPJ, NYH - DOUBLE PRECISION ACOR, CONIT, CRATE, DCON, DDN, - 1 DEL, DELP, DSM, DUP, DVNRMS, EL, EL0, ELCO, - 2 EWT, EXDN, EXSM, EXUP, H, HMIN, HMXI, HOLD, HU, R, RC, - 3 RH, RHDN, RHSM, RHUP, RMAX, ROWND, RPAR, SAVF, TESCO, - 4 TN, TOLD, UROUND, WM, Y, YH, YH1 - EXTERNAL DF, DJAC -C - DIMENSION Y(*),YH(NYH,*),YH1(*),EWT(*),SAVF(*),ACOR(*),WM(*), - 1 IWM(*),RPAR(*),IPAR(*) - COMMON /DDEBD1/ ROWND,CONIT,CRATE,EL(13),ELCO(13,12),HOLD,RC,RMAX, - 1 TESCO(3,12),EL0,H,HMIN,HMXI,HU,TN,UROUND,IOWND(7), - 2 KSTEPS,IOD(6),IALTH,IPUP,LMAX,MEO,NQNYH,NSTEPJ, - 3 IER,JSTART,KFLAG,L,METH,MITER,MAXORD,N,NQ,NST,NFE, - 4 NJE,NQU -C -C -C BEGIN BLOCK PERMITTING ...EXITS TO 690 -C BEGIN BLOCK PERMITTING ...EXITS TO 60 -C***FIRST EXECUTABLE STATEMENT DSTOD - KFLAG = 0 - TOLD = TN - NCF = 0 - IF (JSTART .GT. 0) GO TO 160 - IF (JSTART .EQ. -1) GO TO 10 - IF (JSTART .EQ. -2) GO TO 90 -C --------------------------------------------------------- -C ON THE FIRST CALL, THE ORDER IS SET TO 1, AND OTHER -C VARIABLES ARE INITIALIZED. RMAX IS THE MAXIMUM RATIO BY -C WHICH H CAN BE INCREASED IN A SINGLE STEP. IT IS -C INITIALLY 1.E4 TO COMPENSATE FOR THE SMALL INITIAL H, -C BUT THEN IS NORMALLY EQUAL TO 10. IF A FAILURE OCCURS -C (IN CORRECTOR CONVERGENCE OR ERROR TEST), RMAX IS SET AT -C 2 FOR THE NEXT INCREASE. -C --------------------------------------------------------- - LMAX = MAXORD + 1 - NQ = 1 - L = 2 - IALTH = 2 - RMAX = 10000.0D0 - RC = 0.0D0 - EL0 = 1.0D0 - CRATE = 0.7D0 - DELP = 0.0D0 - HOLD = H - MEO = METH - NSTEPJ = 0 - IRET = 3 - GO TO 50 - 10 CONTINUE -C BEGIN BLOCK PERMITTING ...EXITS TO 30 -C ------------------------------------------------------ -C THE FOLLOWING BLOCK HANDLES PRELIMINARIES NEEDED WHEN -C JSTART = -1. IPUP IS SET TO MITER TO FORCE A MATRIX -C UPDATE. IF AN ORDER INCREASE IS ABOUT TO BE -C CONSIDERED (IALTH = 1), IALTH IS RESET TO 2 TO -C POSTPONE CONSIDERATION ONE MORE STEP. IF THE CALLER -C HAS CHANGED METH, DCFOD IS CALLED TO RESET THE -C COEFFICIENTS OF THE METHOD. IF THE CALLER HAS -C CHANGED MAXORD TO A VALUE LESS THAN THE CURRENT -C ORDER NQ, NQ IS REDUCED TO MAXORD, AND A NEW H CHOSEN -C ACCORDINGLY. IF H IS TO BE CHANGED, YH MUST BE -C RESCALED. IF H OR METH IS BEING CHANGED, IALTH IS -C RESET TO L = NQ + 1 TO PREVENT FURTHER CHANGES IN H -C FOR THAT MANY STEPS. -C ------------------------------------------------------ - IPUP = MITER - LMAX = MAXORD + 1 - IF (IALTH .EQ. 1) IALTH = 2 - IF (METH .EQ. MEO) GO TO 20 - CALL DCFOD(METH,ELCO,TESCO) - MEO = METH -C ......EXIT - IF (NQ .GT. MAXORD) GO TO 30 - IALTH = L - IRET = 1 -C ............EXIT - GO TO 60 - 20 CONTINUE - IF (NQ .LE. MAXORD) GO TO 90 - 30 CONTINUE - NQ = MAXORD - L = LMAX - DO 40 I = 1, L - EL(I) = ELCO(I,NQ) - 40 CONTINUE - NQNYH = NQ*NYH - RC = RC*EL(1)/EL0 - EL0 = EL(1) - CONIT = 0.5D0/(NQ+2) - DDN = DVNRMS(N,SAVF,EWT)/TESCO(1,L) - EXDN = 1.0D0/L - RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) - RH = MIN(RHDN,1.0D0) - IREDO = 3 - IF (H .EQ. HOLD) GO TO 660 - RH = MIN(RH,ABS(H/HOLD)) - H = HOLD - GO TO 100 - 50 CONTINUE -C ------------------------------------------------------------ -C DCFOD IS CALLED TO GET ALL THE INTEGRATION COEFFICIENTS -C FOR THE CURRENT METH. THEN THE EL VECTOR AND RELATED -C CONSTANTS ARE RESET WHENEVER THE ORDER NQ IS CHANGED, OR AT -C THE START OF THE PROBLEM. -C ------------------------------------------------------------ - CALL DCFOD(METH,ELCO,TESCO) - 60 CONTINUE - 70 CONTINUE -C BEGIN BLOCK PERMITTING ...EXITS TO 680 - DO 80 I = 1, L - EL(I) = ELCO(I,NQ) - 80 CONTINUE - NQNYH = NQ*NYH - RC = RC*EL(1)/EL0 - EL0 = EL(1) - CONIT = 0.5D0/(NQ+2) - GO TO (90,660,160), IRET -C --------------------------------------------------------- -C IF H IS BEING CHANGED, THE H RATIO RH IS CHECKED AGAINST -C RMAX, HMIN, AND HMXI, AND THE YH ARRAY RESCALED. IALTH -C IS SET TO L = NQ + 1 TO PREVENT A CHANGE OF H FOR THAT -C MANY STEPS, UNLESS FORCED BY A CONVERGENCE OR ERROR TEST -C FAILURE. -C --------------------------------------------------------- - 90 CONTINUE - IF (H .EQ. HOLD) GO TO 160 - RH = H/HOLD - H = HOLD - IREDO = 3 - 100 CONTINUE - 110 CONTINUE - RH = MIN(RH,RMAX) - RH = RH/MAX(1.0D0,ABS(H)*HMXI*RH) - R = 1.0D0 - DO 130 J = 2, L - R = R*RH - DO 120 I = 1, N - YH(I,J) = YH(I,J)*R - 120 CONTINUE - 130 CONTINUE - H = H*RH - RC = RC*RH - IALTH = L - IF (IREDO .NE. 0) GO TO 150 - RMAX = 10.0D0 - R = 1.0D0/TESCO(2,NQU) - DO 140 I = 1, N - ACOR(I) = ACOR(I)*R - 140 CONTINUE -C ...............EXIT - GO TO 690 - 150 CONTINUE -C ------------------------------------------------------ -C THIS SECTION COMPUTES THE PREDICTED VALUES BY -C EFFECTIVELY MULTIPLYING THE YH ARRAY BY THE PASCAL -C TRIANGLE MATRIX. RC IS THE RATIO OF NEW TO OLD -C VALUES OF THE COEFFICIENT H*EL(1). WHEN RC DIFFERS -C FROM 1 BY MORE THAN 30 PERCENT, IPUP IS SET TO MITER -C TO FORCE DPJAC TO BE CALLED, IF A JACOBIAN IS -C INVOLVED. IN ANY CASE, DPJAC IS CALLED AT LEAST -C EVERY 20-TH STEP. -C ------------------------------------------------------ - 160 CONTINUE - 170 CONTINUE -C BEGIN BLOCK PERMITTING ...EXITS TO 610 -C BEGIN BLOCK PERMITTING ...EXITS TO 490 - IF (ABS(RC-1.0D0) .GT. 0.3D0) IPUP = MITER - IF (NST .GE. NSTEPJ + 20) IPUP = MITER - TN = TN + H - I1 = NQNYH + 1 - DO 190 JB = 1, NQ - I1 = I1 - NYH - DO 180 I = I1, NQNYH - YH1(I) = YH1(I) + YH1(I+NYH) - 180 CONTINUE - 190 CONTINUE - KSTEPS = KSTEPS + 1 -C --------------------------------------------- -C UP TO 3 CORRECTOR ITERATIONS ARE TAKEN. A -C CONVERGENCE TEST IS MADE ON THE R.M.S. NORM -C OF EACH CORRECTION, WEIGHTED BY THE ERROR -C WEIGHT VECTOR EWT. THE SUM OF THE -C CORRECTIONS IS ACCUMULATED IN THE VECTOR -C ACOR(I). THE YH ARRAY IS NOT ALTERED IN THE -C CORRECTOR LOOP. -C --------------------------------------------- - 200 CONTINUE - M = 0 - DO 210 I = 1, N - Y(I) = YH(I,1) - 210 CONTINUE - CALL DF(TN,Y,SAVF,RPAR,IPAR) - NFE = NFE + 1 - IF (IPUP .LE. 0) GO TO 220 -C --------------------------------------- -C IF INDICATED, THE MATRIX P = I - -C H*EL(1)*J IS REEVALUATED AND -C PREPROCESSED BEFORE STARTING THE -C CORRECTOR ITERATION. IPUP IS SET TO 0 -C AS AN INDICATOR THAT THIS HAS BEEN -C DONE. -C --------------------------------------- - IPUP = 0 - RC = 1.0D0 - NSTEPJ = NST - CRATE = 0.7D0 - CALL DPJAC(NEQ,Y,YH,NYH,EWT,ACOR,SAVF, - 1 WM,IWM,DF,DJAC,RPAR,IPAR) -C ......EXIT - IF (IER .NE. 0) GO TO 440 - 220 CONTINUE - DO 230 I = 1, N - ACOR(I) = 0.0D0 - 230 CONTINUE - 240 CONTINUE - IF (MITER .NE. 0) GO TO 270 -C ------------------------------------ -C IN THE CASE OF FUNCTIONAL -C ITERATION, UPDATE Y DIRECTLY FROM -C THE RESULT OF THE LAST FUNCTION -C EVALUATION. -C ------------------------------------ - DO 250 I = 1, N - SAVF(I) = H*SAVF(I) - YH(I,2) - Y(I) = SAVF(I) - ACOR(I) - 250 CONTINUE - DEL = DVNRMS(N,Y,EWT) - DO 260 I = 1, N - Y(I) = YH(I,1) + EL(1)*SAVF(I) - ACOR(I) = SAVF(I) - 260 CONTINUE - GO TO 300 - 270 CONTINUE -C ------------------------------------ -C IN THE CASE OF THE CHORD METHOD, -C COMPUTE THE CORRECTOR ERROR, AND -C SOLVE THE LINEAR SYSTEM WITH THAT -C AS RIGHT-HAND SIDE AND P AS -C COEFFICIENT MATRIX. -C ------------------------------------ - DO 280 I = 1, N - Y(I) = H*SAVF(I) - 1 - (YH(I,2) + ACOR(I)) - 280 CONTINUE - CALL DSLVS(WM,IWM,Y,SAVF) -C ......EXIT - IF (IER .NE. 0) GO TO 430 - DEL = DVNRMS(N,Y,EWT) - DO 290 I = 1, N - ACOR(I) = ACOR(I) + Y(I) - Y(I) = YH(I,1) + EL(1)*ACOR(I) - 290 CONTINUE - 300 CONTINUE -C --------------------------------------- -C TEST FOR CONVERGENCE. IF M.GT.0, AN -C ESTIMATE OF THE CONVERGENCE RATE -C CONSTANT IS STORED IN CRATE, AND THIS -C IS USED IN THE TEST. -C --------------------------------------- - IF (M .NE. 0) - 1 CRATE = MAX(0.2D0*CRATE,DEL/DELP) - DCON = DEL*MIN(1.0D0,1.5D0*CRATE) - 1 /(TESCO(2,NQ)*CONIT) - IF (DCON .GT. 1.0D0) GO TO 420 -C ------------------------------------ -C THE CORRECTOR HAS CONVERGED. IPUP -C IS SET TO -1 IF MITER .NE. 0, TO -C SIGNAL THAT THE JACOBIAN INVOLVED -C MAY NEED UPDATING LATER. THE LOCAL -C ERROR TEST IS MADE AND CONTROL -C PASSES TO STATEMENT 500 IF IT -C FAILS. -C ------------------------------------ - IF (MITER .NE. 0) IPUP = -1 - IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ) - IF (M .GT. 0) - 1 DSM = DVNRMS(N,ACOR,EWT) - 2 /TESCO(2,NQ) - IF (DSM .GT. 1.0D0) GO TO 380 -C BEGIN BLOCK -C PERMITTING ...EXITS TO 360 -C ------------------------------ -C AFTER A SUCCESSFUL STEP, -C UPDATE THE YH ARRAY. -C CONSIDER CHANGING H IF IALTH -C = 1. OTHERWISE DECREASE -C IALTH BY 1. IF IALTH IS THEN -C 1 AND NQ .LT. MAXORD, THEN -C ACOR IS SAVED FOR USE IN A -C POSSIBLE ORDER INCREASE ON -C THE NEXT STEP. IF A CHANGE -C IN H IS CONSIDERED, AN -C INCREASE OR DECREASE IN ORDER -C BY ONE IS CONSIDERED ALSO. A -C CHANGE IN H IS MADE ONLY IF -C IT IS BY A FACTOR OF AT LEAST -C 1.1. IF NOT, IALTH IS SET TO -C 3 TO PREVENT TESTING FOR THAT -C MANY STEPS. -C ------------------------------ - KFLAG = 0 - IREDO = 0 - NST = NST + 1 - HU = H - NQU = NQ - DO 320 J = 1, L - DO 310 I = 1, N - YH(I,J) = YH(I,J) - 1 + EL(J) - 2 *ACOR(I) - 310 CONTINUE - 320 CONTINUE - IALTH = IALTH - 1 - IF (IALTH .NE. 0) GO TO 340 -C --------------------------- -C REGARDLESS OF THE SUCCESS -C OR FAILURE OF THE STEP, -C FACTORS RHDN, RHSM, AND -C RHUP ARE COMPUTED, BY -C WHICH H COULD BE -C MULTIPLIED AT ORDER NQ - -C 1, ORDER NQ, OR ORDER NQ + -C 1, RESPECTIVELY. IN THE -C CASE OF FAILURE, RHUP = -C 0.0 TO AVOID AN ORDER -C INCREASE. THE LARGEST OF -C THESE IS DETERMINED AND -C THE NEW ORDER CHOSEN -C ACCORDINGLY. IF THE ORDER -C IS TO BE INCREASED, WE -C COMPUTE ONE ADDITIONAL -C SCALED DERIVATIVE. -C --------------------------- - RHUP = 0.0D0 -C .....................EXIT - IF (L .EQ. LMAX) GO TO 490 - DO 330 I = 1, N - SAVF(I) = ACOR(I) - 1 - YH(I,LMAX) - 330 CONTINUE - DUP = DVNRMS(N,SAVF,EWT) - 1 /TESCO(3,NQ) - EXUP = 1.0D0/(L+1) - RHUP = 1.0D0 - 1 /(1.4D0*DUP**EXUP - 2 + 0.0000014D0) -C .....................EXIT - GO TO 490 - 340 CONTINUE -C ...EXIT - IF (IALTH .GT. 1) GO TO 360 -C ...EXIT - IF (L .EQ. LMAX) GO TO 360 - DO 350 I = 1, N - YH(I,LMAX) = ACOR(I) - 350 CONTINUE - 360 CONTINUE - R = 1.0D0/TESCO(2,NQU) - DO 370 I = 1, N - ACOR(I) = ACOR(I)*R - 370 CONTINUE -C .................................EXIT - GO TO 690 - 380 CONTINUE -C ------------------------------------ -C THE ERROR TEST FAILED. KFLAG KEEPS -C TRACK OF MULTIPLE FAILURES. -C RESTORE TN AND THE YH ARRAY TO -C THEIR PREVIOUS VALUES, AND PREPARE -C TO TRY THE STEP AGAIN. COMPUTE THE -C OPTIMUM STEP SIZE FOR THIS OR ONE -C LOWER ORDER. AFTER 2 OR MORE -C FAILURES, H IS FORCED TO DECREASE -C BY A FACTOR OF 0.2 OR LESS. -C ------------------------------------ - KFLAG = KFLAG - 1 - TN = TOLD - I1 = NQNYH + 1 - DO 400 JB = 1, NQ - I1 = I1 - NYH - DO 390 I = I1, NQNYH - YH1(I) = YH1(I) - YH1(I+NYH) - 390 CONTINUE - 400 CONTINUE - RMAX = 2.0D0 - IF (ABS(H) .GT. HMIN*1.00001D0) - 1 GO TO 410 -C --------------------------------- -C ALL RETURNS ARE MADE THROUGH -C THIS SECTION. H IS SAVED IN -C HOLD TO ALLOW THE CALLER TO -C CHANGE H ON THE NEXT STEP. -C --------------------------------- - KFLAG = -1 -C .................................EXIT - GO TO 690 - 410 CONTINUE -C ...............EXIT - IF (KFLAG .LE. -3) GO TO 610 - IREDO = 2 - RHUP = 0.0D0 -C ............EXIT - GO TO 490 - 420 CONTINUE - M = M + 1 -C ...EXIT - IF (M .EQ. 3) GO TO 430 -C ...EXIT - IF (M .GE. 2 .AND. DEL .GT. 2.0D0*DELP) - 1 GO TO 430 - DELP = DEL - CALL DF(TN,Y,SAVF,RPAR,IPAR) - NFE = NFE + 1 - GO TO 240 - 430 CONTINUE -C ------------------------------------------ -C THE CORRECTOR ITERATION FAILED TO -C CONVERGE IN 3 TRIES. IF MITER .NE. 0 AND -C THE JACOBIAN IS OUT OF DATE, DPJAC IS -C CALLED FOR THE NEXT TRY. OTHERWISE THE -C YH ARRAY IS RETRACTED TO ITS VALUES -C BEFORE PREDICTION, AND H IS REDUCED, IF -C POSSIBLE. IF H CANNOT BE REDUCED OR 10 -C FAILURES HAVE OCCURRED, EXIT WITH KFLAG = -C -2. -C ------------------------------------------ -C ...EXIT - IF (IPUP .EQ. 0) GO TO 440 - IPUP = MITER - GO TO 200 - 440 CONTINUE - TN = TOLD - NCF = NCF + 1 - RMAX = 2.0D0 - I1 = NQNYH + 1 - DO 460 JB = 1, NQ - I1 = I1 - NYH - DO 450 I = I1, NQNYH - YH1(I) = YH1(I) - YH1(I+NYH) - 450 CONTINUE - 460 CONTINUE - IF (ABS(H) .GT. HMIN*1.00001D0) GO TO 470 - KFLAG = -2 -C ........................EXIT - GO TO 690 - 470 CONTINUE - IF (NCF .NE. 10) GO TO 480 - KFLAG = -2 -C ........................EXIT - GO TO 690 - 480 CONTINUE - RH = 0.25D0 - IPUP = MITER - IREDO = 1 -C .........EXIT - GO TO 650 - 490 CONTINUE - EXSM = 1.0D0/L - RHSM = 1.0D0/(1.2D0*DSM**EXSM + 0.0000012D0) - RHDN = 0.0D0 - IF (NQ .EQ. 1) GO TO 500 - DDN = DVNRMS(N,YH(1,L),EWT)/TESCO(1,NQ) - EXDN = 1.0D0/NQ - RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) - 500 CONTINUE - IF (RHSM .GE. RHUP) GO TO 550 - IF (RHUP .LE. RHDN) GO TO 540 - NEWQ = L - RH = RHUP - IF (RH .GE. 1.1D0) GO TO 520 - IALTH = 3 - R = 1.0D0/TESCO(2,NQU) - DO 510 I = 1, N - ACOR(I) = ACOR(I)*R - 510 CONTINUE -C ...........................EXIT - GO TO 690 - 520 CONTINUE - R = EL(L)/L - DO 530 I = 1, N - YH(I,NEWQ+1) = ACOR(I)*R - 530 CONTINUE - NQ = NEWQ - L = NQ + 1 - IRET = 2 -C ..................EXIT - GO TO 680 - 540 CONTINUE - GO TO 580 - 550 CONTINUE - IF (RHSM .LT. RHDN) GO TO 580 - NEWQ = NQ - RH = RHSM - IF (KFLAG .EQ. 0 .AND. RH .LT. 1.1D0) - 1 GO TO 560 - IF (KFLAG .LE. -2) RH = MIN(RH,0.2D0) -C ------------------------------------------ -C IF THERE IS A CHANGE OF ORDER, RESET NQ, -C L, AND THE COEFFICIENTS. IN ANY CASE H -C IS RESET ACCORDING TO RH AND THE YH ARRAY -C IS RESCALED. THEN EXIT FROM 680 IF THE -C STEP WAS OK, OR REDO THE STEP OTHERWISE. -C ------------------------------------------ -C ............EXIT - IF (NEWQ .EQ. NQ) GO TO 650 - NQ = NEWQ - L = NQ + 1 - IRET = 2 -C ..................EXIT - GO TO 680 - 560 CONTINUE - IALTH = 3 - R = 1.0D0/TESCO(2,NQU) - DO 570 I = 1, N - ACOR(I) = ACOR(I)*R - 570 CONTINUE -C .....................EXIT - GO TO 690 - 580 CONTINUE - NEWQ = NQ - 1 - RH = RHDN - IF (KFLAG .LT. 0 .AND. RH .GT. 1.0D0) RH = 1.0D0 - IF (KFLAG .EQ. 0 .AND. RH .LT. 1.1D0) GO TO 590 - IF (KFLAG .LE. -2) RH = MIN(RH,0.2D0) -C --------------------------------------------- -C IF THERE IS A CHANGE OF ORDER, RESET NQ, L, -C AND THE COEFFICIENTS. IN ANY CASE H IS -C RESET ACCORDING TO RH AND THE YH ARRAY IS -C RESCALED. THEN EXIT FROM 680 IF THE STEP -C WAS OK, OR REDO THE STEP OTHERWISE. -C --------------------------------------------- -C .........EXIT - IF (NEWQ .EQ. NQ) GO TO 650 - NQ = NEWQ - L = NQ + 1 - IRET = 2 -C ...............EXIT - GO TO 680 - 590 CONTINUE - IALTH = 3 - R = 1.0D0/TESCO(2,NQU) - DO 600 I = 1, N - ACOR(I) = ACOR(I)*R - 600 CONTINUE -C ..................EXIT - GO TO 690 - 610 CONTINUE -C --------------------------------------------------- -C CONTROL REACHES THIS SECTION IF 3 OR MORE FAILURES -C HAVE OCCURRED. IF 10 FAILURES HAVE OCCURRED, EXIT -C WITH KFLAG = -1. IT IS ASSUMED THAT THE -C DERIVATIVES THAT HAVE ACCUMULATED IN THE YH ARRAY -C HAVE ERRORS OF THE WRONG ORDER. HENCE THE FIRST -C DERIVATIVE IS RECOMPUTED, AND THE ORDER IS SET TO -C 1. THEN H IS REDUCED BY A FACTOR OF 10, AND THE -C STEP IS RETRIED, UNTIL IT SUCCEEDS OR H REACHES -C HMIN. -C --------------------------------------------------- - IF (KFLAG .NE. -10) GO TO 620 -C ------------------------------------------------ -C ALL RETURNS ARE MADE THROUGH THIS SECTION. H -C IS SAVED IN HOLD TO ALLOW THE CALLER TO CHANGE -C H ON THE NEXT STEP. -C ------------------------------------------------ - KFLAG = -1 -C ..................EXIT - GO TO 690 - 620 CONTINUE - RH = 0.1D0 - RH = MAX(HMIN/ABS(H),RH) - H = H*RH - DO 630 I = 1, N - Y(I) = YH(I,1) - 630 CONTINUE - CALL DF(TN,Y,SAVF,RPAR,IPAR) - NFE = NFE + 1 - DO 640 I = 1, N - YH(I,2) = H*SAVF(I) - 640 CONTINUE - IPUP = MITER - IALTH = 5 -C ......EXIT - IF (NQ .NE. 1) GO TO 670 - GO TO 170 - 650 CONTINUE - 660 CONTINUE - RH = MAX(RH,HMIN/ABS(H)) - GO TO 110 - 670 CONTINUE - NQ = 1 - L = 2 - IRET = 3 - 680 CONTINUE - GO TO 70 - 690 CONTINUE - HOLD = H - JSTART = 1 - RETURN -C ----------------------- END OF SUBROUTINE DSTOD -C ----------------------- - END diff --git a/slatec/dstor1.f b/slatec/dstor1.f deleted file mode 100644 index 328c4e3..0000000 --- a/slatec/dstor1.f +++ /dev/null @@ -1,80 +0,0 @@ -*DECK DSTOR1 - SUBROUTINE DSTOR1 (U, YH, V, YP, NTEMP, NDISK, NTAPE) -C***BEGIN PROLOGUE DSTOR1 -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBVSUP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (STOR1-S, DSTOR1-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C ********************************************************************** -C 0 -- storage at output points. -C NTEMP = -C 1 -- temporary storage -C ********************************************************************** -C -C***SEE ALSO DBVSUP -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS DML8SZ -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 890921 Realigned order of variables in certain COMMON blocks. -C (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DSTOR1 - INTEGER IGOFX, INHOMO, IVP, J, NCOMP, NCTNF, NDISK, NFC, NTAPE, - 1 NTEMP - DOUBLE PRECISION C, U(*), V(*), XSAV, YH(*), YP(*) -C -C ****************************************************************** -C - COMMON /DML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMP,NFC -C -C ***************************************************************** -C -C BEGIN BLOCK PERMITTING ...EXITS TO 80 -C***FIRST EXECUTABLE STATEMENT DSTOR1 - NCTNF = NCOMP*NFC - DO 10 J = 1, NCTNF - U(J) = YH(J) - 10 CONTINUE - IF (INHOMO .EQ. 1) GO TO 30 -C -C ZERO PARTICULAR SOLUTION -C -C ......EXIT - IF (NTEMP .EQ. 1) GO TO 80 - DO 20 J = 1, NCOMP - V(J) = 0.0D0 - 20 CONTINUE - GO TO 70 - 30 CONTINUE -C -C NONZERO PARTICULAR SOLUTION -C - IF (NTEMP .EQ. 0) GO TO 50 -C - DO 40 J = 1, NCOMP - V(J) = YP(J) - 40 CONTINUE -C .........EXIT - GO TO 80 - 50 CONTINUE -C - DO 60 J = 1, NCOMP - V(J) = C*YP(J) - 60 CONTINUE - 70 CONTINUE -C -C IS OUTPUT INFORMATION TO BE WRITTEN TO DISK -C - IF (NDISK .EQ. 1) - 1 WRITE (NTAPE) (V(J), J = 1, NCOMP),(U(J), J = 1, NCTNF) - 80 CONTINUE -C - RETURN - END diff --git a/slatec/dstway.f b/slatec/dstway.f deleted file mode 100644 index 9a67f45..0000000 --- a/slatec/dstway.f +++ /dev/null @@ -1,86 +0,0 @@ -*DECK DSTWAY - SUBROUTINE DSTWAY (U, V, YHP, INOUT, STOWA) -C***BEGIN PROLOGUE DSTWAY -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBVSUP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (STWAY-S, DSTWAY-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C This subroutine stores (recalls) integration data in the event -C that a restart is needed (the homogeneous solution vectors become -C too dependent to continue). -C -C***SEE ALSO DBVSUP -C***ROUTINES CALLED DSTOR1 -C***COMMON BLOCKS DML15T, DML18J, DML8SZ -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 890921 Realigned order of variables in certain COMMON blocks. -C (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DSTWAY -C - INTEGER ICOCO, IGOFX, INDPVT, INFO, INHOMO, INOUT, INTEG, ISTKOP, - 1 IVP, J, K, KNSWOT, KO, KOP, KS, KSJ, LOTJP, MNSWOT, MXNON, - 2 NCOMP, NDISK, NEQ, NEQIVP, NFC, NFCC, NIC, NOPG, NPS, NSWOT, - 3 NTAPE, NTP, NUMORT, NXPTS - DOUBLE PRECISION AE, C, PWCND, PX, RE, STOWA(*), TND, TOL, U(*), - 1 V(*), X, XBEG, XEND, XOP, XOT, XSAV, YHP(*) -C - COMMON /DML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMP,NFC - COMMON /DML15T/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP, - 1 KNSWOT,KOP,LOTJP,MNSWOT,NSWOT - COMMON /DML18J/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ, - 1 INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,NFCC, - 2 ICOCO -C -C***FIRST EXECUTABLE STATEMENT DSTWAY - IF (INOUT .EQ. 1) GO TO 30 -C -C SAVE IN STOWA ARRAY AND ISTKOP -C - KS = NFC*NCOMP - CALL DSTOR1(STOWA,U,STOWA(KS+1),V,1,0,0) - KS = KS + NCOMP - IF (NEQIVP .LT. 1) GO TO 20 - DO 10 J = 1, NEQIVP - KSJ = KS + J - STOWA(KSJ) = YHP(KSJ) - 10 CONTINUE - 20 CONTINUE - KS = KS + NEQIVP - STOWA(KS+1) = X - ISTKOP = KOP - IF (XOP .EQ. X) ISTKOP = KOP + 1 - GO TO 80 - 30 CONTINUE -C -C RECALL FROM STOWA ARRAY AND ISTKOP -C - KS = NFC*NCOMP - CALL DSTOR1(YHP,STOWA,YHP(KS+1),STOWA(KS+1),1,0,0) - KS = KS + NCOMP - IF (NEQIVP .LT. 1) GO TO 50 - DO 40 J = 1, NEQIVP - KSJ = KS + J - YHP(KSJ) = STOWA(KSJ) - 40 CONTINUE - 50 CONTINUE - KS = KS + NEQIVP - X = STOWA(KS+1) - INFO(1) = 0 - KO = KOP - ISTKOP - KOP = ISTKOP - IF (NDISK .EQ. 0 .OR. KO .EQ. 0) GO TO 70 - DO 60 K = 1, KO - BACKSPACE NTAPE - 60 CONTINUE - 70 CONTINUE - 80 CONTINUE - RETURN - END diff --git a/slatec/dsuds.f b/slatec/dsuds.f deleted file mode 100644 index 74455bb..0000000 --- a/slatec/dsuds.f +++ /dev/null @@ -1,125 +0,0 @@ -*DECK DSUDS - SUBROUTINE DSUDS (A, X, B, NEQ, NUK, NRDA, IFLAG, MLSO, WORK, - + IWORK) -C***BEGIN PROLOGUE DSUDS -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBVSUP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (SUDS-S, DSUDS-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C DSUDS solves the underdetermined system of linear equations A Z = -C B where A is NEQ by NUK and NEQ .LE. NUK. in particular, if rank -C A equals IRA, a vector X and a matrix U are determined such that -C X is the UNIQUE solution of smallest length, satisfying A X = B, -C and the columns of U form an orthonormal basis for the null -C space of A, satisfying A U = 0 . Then all solutions Z are -C given by -C Z = X + C(1)*U(1) + ..... + C(NUK-IRA)*U(NUK-IRA) -C where U(J) represents the J-th column of U and the C(J) are -C arbitrary constants. -C If the system of equations are not compatible, only the least -C squares solution of minimal length is computed. -C DSUDS is an interfacing routine which calls subroutine DLSSUD -C for the solution. DLSSUD in turn calls subroutine DORTHR and -C possibly subroutine DOHTRL for the decomposition of A by -C orthogonal transformations. In the process, DORTHR calls upon -C subroutine DCSCAL for scaling. -C -C ******************************************************************** -C INPUT -C ******************************************************************** -C -C A -- Contains the matrix of NEQ equations in NUK unknowns and must -C be dimensioned NRDA by NUK. The original A is destroyed. -C X -- Solution array of length at least NUK. -C B -- Given constant vector of length NEQ, B is destroyed. -C NEQ -- Number of equations, NEQ greater or equal to 1. -C NUK -- Number of columns in the matrix (which is also the number -C of unknowns), NUK not smaller than NEQ. -C NRDA -- Row dimension of A, NRDA greater or equal to NEQ. -C IFLAG -- Status indicator -C =0 for the first call (and for each new problem defined by -C a new matrix A) when the matrix data is treated as exact -C =-K for the first call (and for each new problem defined by -C a new matrix A) when the matrix data is assumed to be -C accurate to about K digits. -C =1 for subsequent calls whenever the matrix A has already -C been decomposed (problems with new vectors B but -C same matrix A can be handled efficiently). -C MLSO -- =0 if only the minimal length solution is wanted. -C =1 if the complete solution is wanted, includes the -C linear space defined by the matrix U in the abstract. -C WORK(*),IWORK(*) -- Arrays for storage of internal information, -C WORK must be dimensioned at least -C NUK + 3*NEQ + MLSO*NUK*(NUK-RANK A) -C where it is possible for 0 .LE. RANK A .LE. NEQ -C IWORK must be dimensioned at least 3 + NEQ -C IWORK(2) -- Scaling indicator -C =-1 if the matrix is to be pre-scaled by -C columns when appropriate. -C If the scaling indicator is not equal to -1 -C no scaling will be attempted. -C For most problems scaling will probably not be necessary -C -C ********************************************************************* -C OUTPUT -C ********************************************************************* -C -C IFLAG -- Status indicator -C =1 if solution was obtained. -C =2 if improper input is detected. -C =3 if rank of matrix is less than NEQ. -C to continue simply reset IFLAG=1 and call DSUDS again. -C =4 if the system of equations appears to be inconsistent. -C However, the least squares solution of minimal length -C was obtained. -C X -- Minimal length least squares solution of A X = B. -C A -- Contains the strictly upper triangular part of the reduced -C matrix and transformation information. -C WORK(*),IWORK(*) -- Contains information needed on subsequent -C calls (IFLAG=1 case on input) which must not -C be altered. -C The matrix U described in the abstract is -C stored in the NUK*(NUK-rank A) elements of -C the WORK array beginning at WORK(1+NUK+3*NEQ). -C However U is not defined when MLSO=0 or -C IFLAG=4. -C IWORK(1) contains the numerically determined -C rank of the matrix A -C -C ********************************************************************* -C -C***SEE ALSO DBVSUP -C***REFERENCES H. A. Watts, Solving linear least squares problems -C using SODS/SUDS/CODS, Sandia Report SAND77-0683, -C Sandia Laboratories, 1977. -C***ROUTINES CALLED DLSSUD -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910408 Updated the AUTHOR and REFERENCES sections. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DSUDS - INTEGER IFLAG, IL, IP, IS, IWORK(*), KS, KT, KU, KV, MLSO, NEQ, - 1 NRDA, NUK - DOUBLE PRECISION A(NRDA,*), B(*), WORK(*), X(*) -C -C***FIRST EXECUTABLE STATEMENT DSUDS - IS = 2 - IP = 3 - IL = IP + NEQ - KV = 1 + NEQ - KT = KV + NEQ - KS = KT + NEQ - KU = KS + NUK -C - CALL DLSSUD(A,X,B,NEQ,NUK,NRDA,WORK(KU),NUK,IFLAG,MLSO,IWORK(1), - 1 IWORK(IS),A,WORK(1),IWORK(IP),B,WORK(KV),WORK(KT), - 2 IWORK(IL),WORK(KS)) -C - RETURN - END diff --git a/slatec/dsvco.f b/slatec/dsvco.f deleted file mode 100644 index 20b1516..0000000 --- a/slatec/dsvco.f +++ /dev/null @@ -1,46 +0,0 @@ -*DECK DSVCO - SUBROUTINE DSVCO (RSAV, ISAV) -C***BEGIN PROLOGUE DSVCO -C***SUBSIDIARY -C***PURPOSE Subsidiary to DDEBDF -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (SVCO-S, DSVCO-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C DSVCO transfers data from a common block to arrays within the -C integrator package DDEBDF. -C -C***SEE ALSO DDEBDF -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS DDEBD1 -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DSVCO -C----------------------------------------------------------------------- -C THIS ROUTINE STORES IN RSAV AND ISAV THE CONTENTS OF COMMON BLOCK -C DDEBD1 , WHICH IS USED INTERNALLY IN THE DDEBDF PACKAGE. -C -C RSAV = DOUBLE PRECISION ARRAY OF LENGTH 218 OR MORE. -C ISAV = INTEGER ARRAY OF LENGTH 33 OR MORE. -C----------------------------------------------------------------------- - INTEGER I, ILS, ISAV, LENILS, LENRLS - DOUBLE PRECISION RLS, RSAV - DIMENSION RSAV(*),ISAV(*) - SAVE LENRLS, LENILS - COMMON /DDEBD1/ RLS(218),ILS(33) - DATA LENRLS /218/, LENILS /33/ -C -C***FIRST EXECUTABLE STATEMENT DSVCO - DO 10 I = 1, LENRLS - RSAV(I) = RLS(I) - 10 CONTINUE - DO 20 I = 1, LENILS - ISAV(I) = ILS(I) - 20 CONTINUE - RETURN -C ----------------------- END OF SUBROUTINE DSVCO -C ----------------------- - END diff --git a/slatec/dsvdc.f b/slatec/dsvdc.f deleted file mode 100644 index 5015d51..0000000 --- a/slatec/dsvdc.f +++ /dev/null @@ -1,487 +0,0 @@ -*DECK DSVDC - SUBROUTINE DSVDC (X, LDX, N, P, S, E, U, LDU, V, LDV, WORK, JOB, - + INFO) -C***BEGIN PROLOGUE DSVDC -C***PURPOSE Perform the singular value decomposition of a rectangular -C matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D6 -C***TYPE DOUBLE PRECISION (SSVDC-S, DSVDC-D, CSVDC-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, -C SINGULAR VALUE DECOMPOSITION -C***AUTHOR Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C DSVDC is a subroutine to reduce a double precision NxP matrix X -C by orthogonal transformations U and V to diagonal form. The -C diagonal elements S(I) are the singular values of X. The -C columns of U are the corresponding left singular vectors, -C and the columns of V the right singular vectors. -C -C On Entry -C -C X DOUBLE PRECISION(LDX,P), where LDX .GE. N. -C X contains the matrix whose singular value -C decomposition is to be computed. X is -C destroyed by DSVDC. -C -C LDX INTEGER. -C LDX is the leading dimension of the array X. -C -C N INTEGER. -C N is the number of rows of the matrix X. -C -C P INTEGER. -C P is the number of columns of the matrix X. -C -C LDU INTEGER. -C LDU is the leading dimension of the array U. -C (See below). -C -C LDV INTEGER. -C LDV is the leading dimension of the array V. -C (See below). -C -C WORK DOUBLE PRECISION(N). -C WORK is a scratch array. -C -C JOB INTEGER. -C JOB controls the computation of the singular -C vectors. It has the decimal expansion AB -C with the following meaning -C -C A .EQ. 0 do not compute the left singular -C vectors. -C A .EQ. 1 return the N left singular vectors -C in U. -C A .GE. 2 return the first MIN(N,P) singular -C vectors in U. -C B .EQ. 0 do not compute the right singular -C vectors. -C B .EQ. 1 return the right singular vectors -C in V. -C -C On Return -C -C S DOUBLE PRECISION(MM), where MM=MIN(N+1,P). -C The first MIN(N,P) entries of S contain the -C singular values of X arranged in descending -C order of magnitude. -C -C E DOUBLE PRECISION(P). -C E ordinarily contains zeros. However see the -C discussion of INFO for exceptions. -C -C U DOUBLE PRECISION(LDU,K), where LDU .GE. N. -C If JOBA .EQ. 1, then K .EQ. N. -C If JOBA .GE. 2, then K .EQ. MIN(N,P). -C U contains the matrix of right singular vectors. -C U is not referenced if JOBA .EQ. 0. If N .LE. P -C or if JOBA .EQ. 2, then U may be identified with X -C in the subroutine call. -C -C V DOUBLE PRECISION(LDV,P), where LDV .GE. P. -C V contains the matrix of right singular vectors. -C V is not referenced if JOB .EQ. 0. If P .LE. N, -C then V may be identified with X in the -C subroutine call. -C -C INFO INTEGER. -C The singular values (and their corresponding -C singular vectors) S(INFO+1),S(INFO+2),...,S(M) -C are correct (here M=MIN(N,P)). Thus if -C INFO .EQ. 0, all the singular values and their -C vectors are correct. In any event, the matrix -C B = TRANS(U)*X*V is the bidiagonal matrix -C with the elements of S on its diagonal and the -C elements of E on its super-diagonal (TRANS(U) -C is the transpose of U). Thus the singular -C values of X and B are the same. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DDOT, DNRM2, DROT, DROTG, DSCAL, DSWAP -C***REVISION HISTORY (YYMMDD) -C 790319 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DSVDC - INTEGER LDX,N,P,LDU,LDV,JOB,INFO - DOUBLE PRECISION X(LDX,*),S(*),E(*),U(LDU,*),V(LDV,*),WORK(*) -C -C - INTEGER I,ITER,J,JOBU,K,KASE,KK,L,LL,LLS,LM1,LP1,LS,LU,M,MAXIT, - 1 MM,MM1,MP1,NCT,NCTP1,NCU,NRT,NRTP1 - DOUBLE PRECISION DDOT,T - DOUBLE PRECISION B,C,CS,EL,EMM1,F,G,DNRM2,SCALE,SHIFT,SL,SM,SN, - 1 SMM1,T1,TEST,ZTEST - LOGICAL WANTU,WANTV -C***FIRST EXECUTABLE STATEMENT DSVDC -C -C SET THE MAXIMUM NUMBER OF ITERATIONS. -C - MAXIT = 30 -C -C DETERMINE WHAT IS TO BE COMPUTED. -C - WANTU = .FALSE. - WANTV = .FALSE. - JOBU = MOD(JOB,100)/10 - NCU = N - IF (JOBU .GT. 1) NCU = MIN(N,P) - IF (JOBU .NE. 0) WANTU = .TRUE. - IF (MOD(JOB,10) .NE. 0) WANTV = .TRUE. -C -C REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS -C IN S AND THE SUPER-DIAGONAL ELEMENTS IN E. -C - INFO = 0 - NCT = MIN(N-1,P) - NRT = MAX(0,MIN(P-2,N)) - LU = MAX(NCT,NRT) - IF (LU .LT. 1) GO TO 170 - DO 160 L = 1, LU - LP1 = L + 1 - IF (L .GT. NCT) GO TO 20 -C -C COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND -C PLACE THE L-TH DIAGONAL IN S(L). -C - S(L) = DNRM2(N-L+1,X(L,L),1) - IF (S(L) .EQ. 0.0D0) GO TO 10 - IF (X(L,L) .NE. 0.0D0) S(L) = SIGN(S(L),X(L,L)) - CALL DSCAL(N-L+1,1.0D0/S(L),X(L,L),1) - X(L,L) = 1.0D0 + X(L,L) - 10 CONTINUE - S(L) = -S(L) - 20 CONTINUE - IF (P .LT. LP1) GO TO 50 - DO 40 J = LP1, P - IF (L .GT. NCT) GO TO 30 - IF (S(L) .EQ. 0.0D0) GO TO 30 -C -C APPLY THE TRANSFORMATION. -C - T = -DDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L) - CALL DAXPY(N-L+1,T,X(L,L),1,X(L,J),1) - 30 CONTINUE -C -C PLACE THE L-TH ROW OF X INTO E FOR THE -C SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION. -C - E(J) = X(L,J) - 40 CONTINUE - 50 CONTINUE - IF (.NOT.WANTU .OR. L .GT. NCT) GO TO 70 -C -C PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK -C MULTIPLICATION. -C - DO 60 I = L, N - U(I,L) = X(I,L) - 60 CONTINUE - 70 CONTINUE - IF (L .GT. NRT) GO TO 150 -C -C COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE -C L-TH SUPER-DIAGONAL IN E(L). -C - E(L) = DNRM2(P-L,E(LP1),1) - IF (E(L) .EQ. 0.0D0) GO TO 80 - IF (E(LP1) .NE. 0.0D0) E(L) = SIGN(E(L),E(LP1)) - CALL DSCAL(P-L,1.0D0/E(L),E(LP1),1) - E(LP1) = 1.0D0 + E(LP1) - 80 CONTINUE - E(L) = -E(L) - IF (LP1 .GT. N .OR. E(L) .EQ. 0.0D0) GO TO 120 -C -C APPLY THE TRANSFORMATION. -C - DO 90 I = LP1, N - WORK(I) = 0.0D0 - 90 CONTINUE - DO 100 J = LP1, P - CALL DAXPY(N-L,E(J),X(LP1,J),1,WORK(LP1),1) - 100 CONTINUE - DO 110 J = LP1, P - CALL DAXPY(N-L,-E(J)/E(LP1),WORK(LP1),1,X(LP1,J),1) - 110 CONTINUE - 120 CONTINUE - IF (.NOT.WANTV) GO TO 140 -C -C PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT -C BACK MULTIPLICATION. -C - DO 130 I = LP1, P - V(I,L) = E(I) - 130 CONTINUE - 140 CONTINUE - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE -C -C SET UP THE FINAL BIDIAGONAL MATRIX OR ORDER M. -C - M = MIN(P,N+1) - NCTP1 = NCT + 1 - NRTP1 = NRT + 1 - IF (NCT .LT. P) S(NCTP1) = X(NCTP1,NCTP1) - IF (N .LT. M) S(M) = 0.0D0 - IF (NRTP1 .LT. M) E(NRTP1) = X(NRTP1,M) - E(M) = 0.0D0 -C -C IF REQUIRED, GENERATE U. -C - IF (.NOT.WANTU) GO TO 300 - IF (NCU .LT. NCTP1) GO TO 200 - DO 190 J = NCTP1, NCU - DO 180 I = 1, N - U(I,J) = 0.0D0 - 180 CONTINUE - U(J,J) = 1.0D0 - 190 CONTINUE - 200 CONTINUE - IF (NCT .LT. 1) GO TO 290 - DO 280 LL = 1, NCT - L = NCT - LL + 1 - IF (S(L) .EQ. 0.0D0) GO TO 250 - LP1 = L + 1 - IF (NCU .LT. LP1) GO TO 220 - DO 210 J = LP1, NCU - T = -DDOT(N-L+1,U(L,L),1,U(L,J),1)/U(L,L) - CALL DAXPY(N-L+1,T,U(L,L),1,U(L,J),1) - 210 CONTINUE - 220 CONTINUE - CALL DSCAL(N-L+1,-1.0D0,U(L,L),1) - U(L,L) = 1.0D0 + U(L,L) - LM1 = L - 1 - IF (LM1 .LT. 1) GO TO 240 - DO 230 I = 1, LM1 - U(I,L) = 0.0D0 - 230 CONTINUE - 240 CONTINUE - GO TO 270 - 250 CONTINUE - DO 260 I = 1, N - U(I,L) = 0.0D0 - 260 CONTINUE - U(L,L) = 1.0D0 - 270 CONTINUE - 280 CONTINUE - 290 CONTINUE - 300 CONTINUE -C -C IF IT IS REQUIRED, GENERATE V. -C - IF (.NOT.WANTV) GO TO 350 - DO 340 LL = 1, P - L = P - LL + 1 - LP1 = L + 1 - IF (L .GT. NRT) GO TO 320 - IF (E(L) .EQ. 0.0D0) GO TO 320 - DO 310 J = LP1, P - T = -DDOT(P-L,V(LP1,L),1,V(LP1,J),1)/V(LP1,L) - CALL DAXPY(P-L,T,V(LP1,L),1,V(LP1,J),1) - 310 CONTINUE - 320 CONTINUE - DO 330 I = 1, P - V(I,L) = 0.0D0 - 330 CONTINUE - V(L,L) = 1.0D0 - 340 CONTINUE - 350 CONTINUE -C -C MAIN ITERATION LOOP FOR THE SINGULAR VALUES. -C - MM = M - ITER = 0 - 360 CONTINUE -C -C QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND. -C - IF (M .EQ. 0) GO TO 620 -C -C IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET -C FLAG AND RETURN. -C - IF (ITER .LT. MAXIT) GO TO 370 - INFO = M - GO TO 620 - 370 CONTINUE -C -C THIS SECTION OF THE PROGRAM INSPECTS FOR -C NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS. ON -C COMPLETION THE VARIABLES KASE AND L ARE SET AS FOLLOWS. -C -C KASE = 1 IF S(M) AND E(L-1) ARE NEGLIGIBLE AND L.LT.M -C KASE = 2 IF S(L) IS NEGLIGIBLE AND L.LT.M -C KASE = 3 IF E(L-1) IS NEGLIGIBLE, L.LT.M, AND -C S(L), ..., S(M) ARE NOT NEGLIGIBLE (QR STEP). -C KASE = 4 IF E(M-1) IS NEGLIGIBLE (CONVERGENCE). -C - DO 390 LL = 1, M - L = M - LL - IF (L .EQ. 0) GO TO 400 - TEST = ABS(S(L)) + ABS(S(L+1)) - ZTEST = TEST + ABS(E(L)) - IF (ZTEST .NE. TEST) GO TO 380 - E(L) = 0.0D0 - GO TO 400 - 380 CONTINUE - 390 CONTINUE - 400 CONTINUE - IF (L .NE. M - 1) GO TO 410 - KASE = 4 - GO TO 480 - 410 CONTINUE - LP1 = L + 1 - MP1 = M + 1 - DO 430 LLS = LP1, MP1 - LS = M - LLS + LP1 - IF (LS .EQ. L) GO TO 440 - TEST = 0.0D0 - IF (LS .NE. M) TEST = TEST + ABS(E(LS)) - IF (LS .NE. L + 1) TEST = TEST + ABS(E(LS-1)) - ZTEST = TEST + ABS(S(LS)) - IF (ZTEST .NE. TEST) GO TO 420 - S(LS) = 0.0D0 - GO TO 440 - 420 CONTINUE - 430 CONTINUE - 440 CONTINUE - IF (LS .NE. L) GO TO 450 - KASE = 3 - GO TO 470 - 450 CONTINUE - IF (LS .NE. M) GO TO 460 - KASE = 1 - GO TO 470 - 460 CONTINUE - KASE = 2 - L = LS - 470 CONTINUE - 480 CONTINUE - L = L + 1 -C -C PERFORM THE TASK INDICATED BY KASE. -C - GO TO (490,520,540,570), KASE -C -C DEFLATE NEGLIGIBLE S(M). -C - 490 CONTINUE - MM1 = M - 1 - F = E(M-1) - E(M-1) = 0.0D0 - DO 510 KK = L, MM1 - K = MM1 - KK + L - T1 = S(K) - CALL DROTG(T1,F,CS,SN) - S(K) = T1 - IF (K .EQ. L) GO TO 500 - F = -SN*E(K-1) - E(K-1) = CS*E(K-1) - 500 CONTINUE - IF (WANTV) CALL DROT(P,V(1,K),1,V(1,M),1,CS,SN) - 510 CONTINUE - GO TO 610 -C -C SPLIT AT NEGLIGIBLE S(L). -C - 520 CONTINUE - F = E(L-1) - E(L-1) = 0.0D0 - DO 530 K = L, M - T1 = S(K) - CALL DROTG(T1,F,CS,SN) - S(K) = T1 - F = -SN*E(K) - E(K) = CS*E(K) - IF (WANTU) CALL DROT(N,U(1,K),1,U(1,L-1),1,CS,SN) - 530 CONTINUE - GO TO 610 -C -C PERFORM ONE QR STEP. -C - 540 CONTINUE -C -C CALCULATE THE SHIFT. -C - SCALE = MAX(ABS(S(M)),ABS(S(M-1)),ABS(E(M-1)), - 1 ABS(S(L)),ABS(E(L))) - SM = S(M)/SCALE - SMM1 = S(M-1)/SCALE - EMM1 = E(M-1)/SCALE - SL = S(L)/SCALE - EL = E(L)/SCALE - B = ((SMM1 + SM)*(SMM1 - SM) + EMM1**2)/2.0D0 - C = (SM*EMM1)**2 - SHIFT = 0.0D0 - IF (B .EQ. 0.0D0 .AND. C .EQ. 0.0D0) GO TO 550 - SHIFT = SQRT(B**2+C) - IF (B .LT. 0.0D0) SHIFT = -SHIFT - SHIFT = C/(B + SHIFT) - 550 CONTINUE - F = (SL + SM)*(SL - SM) - SHIFT - G = SL*EL -C -C CHASE ZEROS. -C - MM1 = M - 1 - DO 560 K = L, MM1 - CALL DROTG(F,G,CS,SN) - IF (K .NE. L) E(K-1) = F - F = CS*S(K) + SN*E(K) - E(K) = CS*E(K) - SN*S(K) - G = SN*S(K+1) - S(K+1) = CS*S(K+1) - IF (WANTV) CALL DROT(P,V(1,K),1,V(1,K+1),1,CS,SN) - CALL DROTG(F,G,CS,SN) - S(K) = F - F = CS*E(K) + SN*S(K+1) - S(K+1) = -SN*E(K) + CS*S(K+1) - G = SN*E(K+1) - E(K+1) = CS*E(K+1) - IF (WANTU .AND. K .LT. N) - 1 CALL DROT(N,U(1,K),1,U(1,K+1),1,CS,SN) - 560 CONTINUE - E(M-1) = F - ITER = ITER + 1 - GO TO 610 -C -C CONVERGENCE. -C - 570 CONTINUE -C -C MAKE THE SINGULAR VALUE POSITIVE. -C - IF (S(L) .GE. 0.0D0) GO TO 580 - S(L) = -S(L) - IF (WANTV) CALL DSCAL(P,-1.0D0,V(1,L),1) - 580 CONTINUE -C -C ORDER THE SINGULAR VALUE. -C - 590 IF (L .EQ. MM) GO TO 600 - IF (S(L) .GE. S(L+1)) GO TO 600 - T = S(L) - S(L) = S(L+1) - S(L+1) = T - IF (WANTV .AND. L .LT. P) - 1 CALL DSWAP(P,V(1,L),1,V(1,L+1),1) - IF (WANTU .AND. L .LT. N) - 1 CALL DSWAP(N,U(1,L),1,U(1,L+1),1) - L = L + 1 - GO TO 590 - 600 CONTINUE - ITER = 0 - M = M - 1 - 610 CONTINUE - GO TO 360 - 620 CONTINUE - RETURN - END diff --git a/slatec/dswap.f b/slatec/dswap.f deleted file mode 100644 index 441e601..0000000 --- a/slatec/dswap.f +++ /dev/null @@ -1,102 +0,0 @@ -*DECK DSWAP - SUBROUTINE DSWAP (N, DX, INCX, DY, INCY) -C***BEGIN PROLOGUE DSWAP -C***PURPOSE Interchange two vectors. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A5 -C***TYPE DOUBLE PRECISION (SSWAP-S, DSWAP-D, CSWAP-C, ISWAP-I) -C***KEYWORDS BLAS, INTERCHANGE, 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 DX double precision vector with N elements -C INCX storage spacing between elements of DX -C DY double precision vector with N elements -C INCY storage spacing between elements of DY -C -C --Output-- -C DX input vector DY (unchanged if N .LE. 0) -C DY input vector DX (unchanged if N .LE. 0) -C -C Interchange double precision DX and double precision DY. -C For I = 0 to N-1, interchange DX(LX+I*INCX) and DY(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 DSWAP - DOUBLE PRECISION DX(*), DY(*), DTEMP1, DTEMP2, DTEMP3 -C***FIRST EXECUTABLE STATEMENT DSWAP - IF (N .LE. 0) RETURN - IF (INCX .EQ. INCY) IF (INCX-1) 5,20,60 -C -C Code for unequal or nonpositive increments. -C - 5 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 - DTEMP1 = DX(IX) - DX(IX) = DY(IY) - DY(IY) = DTEMP1 - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -C -C Code for both increments equal to 1. -C -C Clean-up loop so remaining vector length is a multiple of 3. -C - 20 M = MOD(N,3) - IF (M .EQ. 0) GO TO 40 - DO 30 I = 1,M - DTEMP1 = DX(I) - DX(I) = DY(I) - DY(I) = DTEMP1 - 30 CONTINUE - IF (N .LT. 3) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,3 - DTEMP1 = DX(I) - DTEMP2 = DX(I+1) - DTEMP3 = DX(I+2) - DX(I) = DY(I) - DX(I+1) = DY(I+1) - DX(I+2) = DY(I+2) - DY(I) = DTEMP1 - DY(I+1) = DTEMP2 - DY(I+2) = DTEMP3 - 50 CONTINUE - RETURN -C -C Code for equal, positive, non-unit increments. -C - 60 NS = N*INCX - DO 70 I = 1,NS,INCX - DTEMP1 = DX(I) - DX(I) = DY(I) - DY(I) = DTEMP1 - 70 CONTINUE - RETURN - END diff --git a/slatec/dsymm.f b/slatec/dsymm.f deleted file mode 100644 index 2fe3fa6..0000000 --- a/slatec/dsymm.f +++ /dev/null @@ -1,300 +0,0 @@ -*DECK DSYMM - SUBROUTINE DSYMM (SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, - $ C, LDC) -C***BEGIN PROLOGUE DSYMM -C***PURPOSE Perform one of the matrix-matrix operations. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B6 -C***TYPE DOUBLE PRECISION (SSYMM-S, DSYMM-D, CSYMM-C) -C***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J., (ANL) -C Duff, I., (AERE) -C Du Croz, J., (NAG) -C Hammarling, S. (NAG) -C***DESCRIPTION -C -C DSYMM performs one of the matrix-matrix operations -C -C C := alpha*A*B + beta*C, -C -C or -C -C C := alpha*B*A + beta*C, -C -C where alpha and beta are scalars, A is a symmetric matrix and B and -C C are m by n matrices. -C -C Parameters -C ========== -C -C SIDE - CHARACTER*1. -C On entry, SIDE specifies whether the symmetric matrix A -C appears on the left or right in the operation as follows: -C -C SIDE = 'L' or 'l' C := alpha*A*B + beta*C, -C -C SIDE = 'R' or 'r' C := alpha*B*A + beta*C, -C -C Unchanged on exit. -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the symmetric matrix A is to be -C referenced as follows: -C -C UPLO = 'U' or 'u' Only the upper triangular part of the -C symmetric matrix is to be referenced. -C -C UPLO = 'L' or 'l' Only the lower triangular part of the -C symmetric matrix is to be referenced. -C -C Unchanged on exit. -C -C M - INTEGER. -C On entry, M specifies the number of rows of the matrix C. -C M must be at least zero. -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the number of columns of the matrix C. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - DOUBLE PRECISION. -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is -C m when SIDE = 'L' or 'l' and is n otherwise. -C Before entry with SIDE = 'L' or 'l', the m by m part of -C the array A must contain the symmetric matrix, such that -C when UPLO = 'U' or 'u', the leading m by m upper triangular -C part of the array A must contain the upper triangular part -C of the symmetric matrix and the strictly lower triangular -C part of A is not referenced, and when UPLO = 'L' or 'l', -C the leading m by m lower triangular part of the array A -C must contain the lower triangular part of the symmetric -C matrix and the strictly upper triangular part of A is not -C referenced. -C Before entry with SIDE = 'R' or 'r', the n by n part of -C the array A must contain the symmetric matrix, such that -C when UPLO = 'U' or 'u', the leading n by n upper triangular -C part of the array A must contain the upper triangular part -C of the symmetric matrix and the strictly lower triangular -C part of A is not referenced, and when UPLO = 'L' or 'l', -C the leading n by n lower triangular part of the array A -C must contain the lower triangular part of the symmetric -C matrix and the strictly upper triangular part of A is not -C referenced. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. When SIDE = 'L' or 'l' then -C LDA must be at least max( 1, m ), otherwise LDA must be at -C least max( 1, n ). -C Unchanged on exit. -C -C B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). -C Before entry, the leading m by n part of the array B must -C contain the matrix B. -C Unchanged on exit. -C -C LDB - INTEGER. -C On entry, LDB specifies the first dimension of B as declared -C in the calling (sub) program. LDB must be at least -C max( 1, m ). -C Unchanged on exit. -C -C BETA - DOUBLE PRECISION. -C On entry, BETA specifies the scalar beta. When BETA is -C supplied as zero then C need not be set on input. -C Unchanged on exit. -C -C C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). -C Before entry, the leading m by n part of the array C must -C contain the matrix C, except when beta is zero, in which -C case C need not be set on entry. -C On exit, the array C is overwritten by the m by n updated -C matrix. -C -C LDC - INTEGER. -C On entry, LDC specifies the first dimension of C as declared -C in the calling (sub) program. LDC must be at least -C max( 1, m ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. -C A set of level 3 basic linear algebra subprograms. -C ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 890208 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE DSYMM -C .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO - INTEGER M, N, LDA, LDB, LDC - DOUBLE PRECISION ALPHA, BETA -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, K, NROWA - DOUBLE PRECISION TEMP1, TEMP2 -C .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -C***FIRST EXECUTABLE STATEMENT DSYMM -C -C Set NROWA as the number of rows of A. -C - IF( LSAME( SIDE, 'L' ) )THEN - NROWA = M - ELSE - NROWA = N - END IF - UPPER = LSAME( UPLO, 'U' ) -C -C Test the input parameters. -C - 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 -C -C Quick return if possible. -C - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C And when alpha.eq.zero. -C - 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 -C -C Start the operations. -C - IF( LSAME( SIDE, 'L' ) )THEN -C -C Form C := alpha*A*B + beta*C. -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 -C -C Form C := alpha*B*A + beta*C. -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 -C - RETURN -C -C End of DSYMM . -C - END diff --git a/slatec/dsymv.f b/slatec/dsymv.f deleted file mode 100644 index c039476..0000000 --- a/slatec/dsymv.f +++ /dev/null @@ -1,268 +0,0 @@ -*DECK DSYMV - SUBROUTINE DSYMV (UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) -C***BEGIN PROLOGUE DSYMV -C***PURPOSE Perform the matrix-vector operation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE DOUBLE PRECISION (SSYMV-S, DSYMV-D, CSYMV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C DSYMV performs the matrix-vector operation -C -C y := alpha*A*x + beta*y, -C -C where alpha and beta are scalars, x and y are n element vectors and -C A is an n by n symmetric matrix. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the array A is to be referenced as -C follows: -C -C UPLO = 'U' or 'u' Only the upper triangular part of A -C is to be referenced. -C -C UPLO = 'L' or 'l' Only the lower triangular part of A -C is to be referenced. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - DOUBLE PRECISION. -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -C Before entry with UPLO = 'U' or 'u', the leading n by n -C upper triangular part of the array A must contain the upper -C triangular part of the symmetric matrix and the strictly -C lower triangular part of A is not referenced. -C Before entry with UPLO = 'L' or 'l', the leading n by n -C lower triangular part of the array A must contain the lower -C triangular part of the symmetric matrix and the strictly -C upper triangular part of A is not referenced. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C max( 1, n ). -C Unchanged on exit. -C -C X - DOUBLE PRECISION array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C BETA - DOUBLE PRECISION. -C On entry, BETA specifies the scalar beta. When BETA is -C supplied as zero then Y need not be set on input. -C Unchanged on exit. -C -C Y - DOUBLE PRECISION array of dimension at least -C ( 1 + ( n - 1 )*abs( INCY ) ). -C Before entry, the incremented array Y must contain the n -C element vector y. On exit, Y is overwritten by the updated -C vector y. -C -C INCY - INTEGER. -C On entry, INCY specifies the increment for the elements of -C Y. INCY must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE DSYMV -C .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -C .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -C .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C***FIRST EXECUTABLE STATEMENT DSYMV -C -C Test the input parameters. -C - 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 -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C Set up the start points in X and Y. -C - 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 -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through the triangular part -C of A. -C -C First form y := beta*y. -C - 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 -C -C Form y when A is stored in upper triangle. -C - 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 -C -C Form y when A is stored in lower triangle. -C - 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 -C - RETURN -C -C End of DSYMV . -C - END diff --git a/slatec/dsyr.f b/slatec/dsyr.f deleted file mode 100644 index 541fa55..0000000 --- a/slatec/dsyr.f +++ /dev/null @@ -1,204 +0,0 @@ -*DECK DSYR - SUBROUTINE DSYR (UPLO, N, ALPHA, X, INCX, A, LDA) -C***BEGIN PROLOGUE DSYR -C***PURPOSE Perform the symmetric rank 1 operation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE DOUBLE PRECISION (DSYR-D) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C DSYR performs the symmetric rank 1 operation -C -C A := alpha*x*x' + A, -C -C where alpha is a real scalar, x is an n element vector and A is an -C n by n symmetric matrix. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the array A is to be referenced as -C follows: -C -C UPLO = 'U' or 'u' Only the upper triangular part of A -C is to be referenced. -C -C UPLO = 'L' or 'l' Only the lower triangular part of A -C is to be referenced. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - DOUBLE PRECISION. -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C X - DOUBLE PRECISION array of dimension at least -C ( 1 + ( n - 1)*abs( INCX)). -C Before entry, the incremented array X must contain the n -C element vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -C Before entry with UPLO = 'U' or 'u', the leading n by n -C upper triangular part of the array A must contain the upper -C triangular part of the symmetric matrix and the strictly -C lower triangular part of A is not referenced. On exit, the -C upper triangular part of the array A is overwritten by the -C upper triangular part of the updated matrix. -C Before entry with UPLO = 'L' or 'l', the leading n by n -C lower triangular part of the array A must contain the lower -C triangular part of the symmetric matrix and the strictly -C upper triangular part of A is not referenced. On exit, the -C lower triangular part of the array A is overwritten by the -C lower triangular part of the updated matrix. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C max( 1, n ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE DSYR -C .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, LDA, N - CHARACTER*1 UPLO -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ) -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -C .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, KX -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C***FIRST EXECUTABLE STATEMENT DSYR -C -C Test the input parameters. -C - 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 -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -C -C Set the start point in X if the increment is not unity. -C - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through the triangular part -C of A. -C - IF( LSAME( UPLO, 'U' ) )THEN -C -C Form A when A is stored in upper triangle. -C - 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 -C -C Form A when A is stored in lower triangle. -C - 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 -C - RETURN -C -C End of DSYR . -C - END diff --git a/slatec/dsyr2.f b/slatec/dsyr2.f deleted file mode 100644 index 0f0fc73..0000000 --- a/slatec/dsyr2.f +++ /dev/null @@ -1,237 +0,0 @@ -*DECK DSYR2 - SUBROUTINE DSYR2 (UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA) -C***BEGIN PROLOGUE DSYR2 -C***PURPOSE Perform the symmetric rank 2 operation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE DOUBLE PRECISION (SSYR2-S, DSYR2-D, CSYR2-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C DSYR2 performs the symmetric rank 2 operation -C -C A := alpha*x*y' + alpha*y*x' + A, -C -C where alpha is a scalar, x and y are n element vectors and A is an n -C by n symmetric matrix. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the array A is to be referenced as -C follows: -C -C UPLO = 'U' or 'u' Only the upper triangular part of A -C is to be referenced. -C -C UPLO = 'L' or 'l' Only the lower triangular part of A -C is to be referenced. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - DOUBLE PRECISION. -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C X - DOUBLE PRECISION array of dimension at least -C ( 1 + ( n - 1)*abs( INCX)). -C Before entry, the incremented array X must contain the n -C element vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C Y - DOUBLE PRECISION array of dimension at least -C ( 1 + ( n - 1 )*abs( INCY ) ). -C Before entry, the incremented array Y must contain the n -C element vector y. -C Unchanged on exit. -C -C INCY - INTEGER. -C On entry, INCY specifies the increment for the elements of -C Y. INCY must not be zero. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -C Before entry with UPLO = 'U' or 'u', the leading n by n -C upper triangular part of the array A must contain the upper -C triangular part of the symmetric matrix and the strictly -C lower triangular part of A is not referenced. On exit, the -C upper triangular part of the array A is overwritten by the -C upper triangular part of the updated matrix. -C Before entry with UPLO = 'L' or 'l', the leading n by n -C lower triangular part of the array A must contain the lower -C triangular part of the symmetric matrix and the strictly -C upper triangular part of A is not referenced. On exit, the -C lower triangular part of the array A is overwritten by the -C lower triangular part of the updated matrix. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C max( 1, n ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE DSYR2 -C .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -C .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C***FIRST EXECUTABLE STATEMENT DSYR2 -C -C Test the input parameters. -C - 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 -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -C -C Set up the start points in X and Y if the increments are not both -C unity. -C - 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 -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through the triangular part -C of A. -C - IF( LSAME( UPLO, 'U' ) )THEN -C -C Form A when A is stored in the upper triangle. -C - 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 -C -C Form A when A is stored in the lower triangle. -C - 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 -C - RETURN -C -C End of DSYR2 . -C - END diff --git a/slatec/dsyr2k.f b/slatec/dsyr2k.f deleted file mode 100644 index 5cca6b4..0000000 --- a/slatec/dsyr2k.f +++ /dev/null @@ -1,333 +0,0 @@ -*DECK DSYR2K - SUBROUTINE DSYR2K (UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, - $ C, LDC) -C***BEGIN PROLOGUE DSYR2K -C***PURPOSE Perform one of the symmetric rank 2k operations. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B6 -C***TYPE DOUBLE PRECISION (SSYR2-S, DSYR2-D, CSYR2-C, DSYR2K-D) -C***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J., (ANL) -C Duff, I., (AERE) -C Du Croz, J., (NAG) -C Hammarling, S. (NAG) -C***DESCRIPTION -C -C DSYR2K performs one of the symmetric rank 2k operations -C -C C := alpha*A*B' + alpha*B*A' + beta*C, -C -C or -C -C C := alpha*A'*B + alpha*B'*A + beta*C, -C -C where alpha and beta are scalars, C is an n by n symmetric matrix -C and A and B are n by k matrices in the first case and k by n -C matrices in the second case. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the array C is to be referenced as -C follows: -C -C UPLO = 'U' or 'u' Only the upper triangular part of C -C is to be referenced. -C -C UPLO = 'L' or 'l' Only the lower triangular part of C -C is to be referenced. -C -C Unchanged on exit. -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the operation to be performed as -C follows: -C -C TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + -C beta*C. -C -C TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + -C beta*C. -C -C TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A + -C beta*C. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix C. N must be -C at least zero. -C Unchanged on exit. -C -C K - INTEGER. -C On entry with TRANS = 'N' or 'n', K specifies the number -C of columns of the matrices A and B, and on entry with -C TRANS = 'T' or 't' or 'C' or 'c', K specifies the number -C of rows of the matrices A and B. K must be at least zero. -C Unchanged on exit. -C -C ALPHA - DOUBLE PRECISION. -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is -C k when TRANS = 'N' or 'n', and is n otherwise. -C Before entry with TRANS = 'N' or 'n', the leading n by k -C part of the array A must contain the matrix A, otherwise -C the leading k by n part of the array A must contain the -C matrix A. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. When TRANS = 'N' or 'n' -C then LDA must be at least max( 1, n ), otherwise LDA must -C be at least max( 1, k ). -C Unchanged on exit. -C -C B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is -C k when TRANS = 'N' or 'n', and is n otherwise. -C Before entry with TRANS = 'N' or 'n', the leading n by k -C part of the array B must contain the matrix B, otherwise -C the leading k by n part of the array B must contain the -C matrix B. -C Unchanged on exit. -C -C LDB - INTEGER. -C On entry, LDB specifies the first dimension of B as declared -C in the calling (sub) program. When TRANS = 'N' or 'n' -C then LDB must be at least max( 1, n ), otherwise LDB must -C be at least max( 1, k ). -C Unchanged on exit. -C -C BETA - DOUBLE PRECISION. -C On entry, BETA specifies the scalar beta. -C Unchanged on exit. -C -C C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). -C Before entry with UPLO = 'U' or 'u', the leading n by n -C upper triangular part of the array C must contain the upper -C triangular part of the symmetric matrix and the strictly -C lower triangular part of C is not referenced. On exit, the -C upper triangular part of the array C is overwritten by the -C upper triangular part of the updated matrix. -C Before entry with UPLO = 'L' or 'l', the leading n by n -C lower triangular part of the array C must contain the lower -C triangular part of the symmetric matrix and the strictly -C upper triangular part of C is not referenced. On exit, the -C lower triangular part of the array C is overwritten by the -C lower triangular part of the updated matrix. -C -C LDC - INTEGER. -C On entry, LDC specifies the first dimension of C as declared -C in the calling (sub) program. LDC must be at least -C max( 1, n ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. -C A set of level 3 basic linear algebra subprograms. -C ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 890208 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE DSYR2K -C .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDB, LDC - DOUBLE PRECISION ALPHA, BETA -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) -C -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - DOUBLE PRECISION TEMP1, TEMP2 -C .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -C***FIRST EXECUTABLE STATEMENT DSYR2K -C -C Test the input parameters. -C - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -C - 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 -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C And when alpha.eq.zero. -C - 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 -C -C Start the operations. -C - IF( LSAME( TRANS, 'N' ) )THEN -C -C Form C := alpha*A*B' + alpha*B*A' + C. -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 -C -C Form C := alpha*A'*B + alpha*B'*A + C. -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 -C - RETURN -C -C End of DSYR2K. -C - END diff --git a/slatec/dsyrk.f b/slatec/dsyrk.f deleted file mode 100644 index bd284ea..0000000 --- a/slatec/dsyrk.f +++ /dev/null @@ -1,299 +0,0 @@ -*DECK DSYRK - SUBROUTINE DSYRK (UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC) -C***BEGIN PROLOGUE DSYRK -C***PURPOSE Perform one of the symmetric rank k operations. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B6 -C***TYPE DOUBLE PRECISION (SSYRK-S, DSYRK-D, CSYRK-C) -C***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J., (ANL) -C Duff, I., (AERE) -C Du Croz, J., (NAG) -C Hammarling, S. (NAG) -C***DESCRIPTION -C -C DSYRK performs one of the symmetric rank k operations -C -C C := alpha*A*A' + beta*C, -C -C or -C -C C := alpha*A'*A + beta*C, -C -C where alpha and beta are scalars, C is an n by n symmetric matrix -C and A is an n by k matrix in the first case and a k by n matrix -C in the second case. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the array C is to be referenced as -C follows: -C -C UPLO = 'U' or 'u' Only the upper triangular part of C -C is to be referenced. -C -C UPLO = 'L' or 'l' Only the lower triangular part of C -C is to be referenced. -C -C Unchanged on exit. -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the operation to be performed as -C follows: -C -C TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. -C -C TRANS = 'T' or 't' C := alpha*A'*A + beta*C. -C -C TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix C. N must be -C at least zero. -C Unchanged on exit. -C -C K - INTEGER. -C On entry with TRANS = 'N' or 'n', K specifies the number -C of columns of the matrix A, and on entry with -C TRANS = 'T' or 't' or 'C' or 'c', K specifies the number -C of rows of the matrix A. K must be at least zero. -C Unchanged on exit. -C -C ALPHA - DOUBLE PRECISION. -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is -C k when TRANS = 'N' or 'n', and is n otherwise. -C Before entry with TRANS = 'N' or 'n', the leading n by k -C part of the array A must contain the matrix A, otherwise -C the leading k by n part of the array A must contain the -C matrix A. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. When TRANS = 'N' or 'n' -C then LDA must be at least max( 1, n ), otherwise LDA must -C be at least max( 1, k ). -C Unchanged on exit. -C -C BETA - DOUBLE PRECISION. -C On entry, BETA specifies the scalar beta. -C Unchanged on exit. -C -C C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). -C Before entry with UPLO = 'U' or 'u', the leading n by n -C upper triangular part of the array C must contain the upper -C triangular part of the symmetric matrix and the strictly -C lower triangular part of C is not referenced. On exit, the -C upper triangular part of the array C is overwritten by the -C upper triangular part of the updated matrix. -C Before entry with UPLO = 'L' or 'l', the leading n by n -C lower triangular part of the array C must contain the lower -C triangular part of the symmetric matrix and the strictly -C upper triangular part of C is not referenced. On exit, the -C lower triangular part of the array C is overwritten by the -C lower triangular part of the updated matrix. -C -C LDC - INTEGER. -C On entry, LDC specifies the first dimension of C as declared -C in the calling (sub) program. LDC must be at least -C max( 1, n ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. -C A set of level 3 basic linear algebra subprograms. -C ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 890208 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE DSYRK -C .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDC - DOUBLE PRECISION ALPHA, BETA -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - DOUBLE PRECISION TEMP -C .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -C***FIRST EXECUTABLE STATEMENT DSYRK -C -C Test the input parameters. -C - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -C - 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 -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C And when alpha.eq.zero. -C - 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 -C -C Start the operations. -C - IF( LSAME( TRANS, 'N' ) )THEN -C -C Form C := alpha*A*A' + beta*C. -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 -C -C Form C := alpha*A'*A + beta*C. -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 -C - RETURN -C -C End of DSYRK . -C - END diff --git a/slatec/dtbmv.f b/slatec/dtbmv.f deleted file mode 100644 index 7da1e4c..0000000 --- a/slatec/dtbmv.f +++ /dev/null @@ -1,349 +0,0 @@ -*DECK DTBMV - SUBROUTINE DTBMV (UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) -C***BEGIN PROLOGUE DTBMV -C***PURPOSE Perform one of the matrix-vector operations. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE DOUBLE PRECISION (STBMV-S, DTBMV-D, CTBMV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C DTBMV performs one of the matrix-vector operations -C -C x := A*x, or x := A'*x, -C -C where x is an n element vector and A is an n by n unit, or non-unit, -C upper or lower triangular band matrix, with ( k + 1) diagonals. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the matrix is an upper or -C lower triangular matrix as follows: -C -C UPLO = 'U' or 'u' A is an upper triangular matrix. -C -C UPLO = 'L' or 'l' A is a lower triangular matrix. -C -C Unchanged on exit. -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the operation to be performed as -C follows: -C -C TRANS = 'N' or 'n' x := A*x. -C -C TRANS = 'T' or 't' x := A'*x. -C -C TRANS = 'C' or 'c' x := A'*x. -C -C Unchanged on exit. -C -C DIAG - CHARACTER*1. -C On entry, DIAG specifies whether or not A is unit -C triangular as follows: -C -C DIAG = 'U' or 'u' A is assumed to be unit triangular. -C -C DIAG = 'N' or 'n' A is not assumed to be unit -C triangular. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C K - INTEGER. -C On entry with UPLO = 'U' or 'u', K specifies the number of -C super-diagonals of the matrix A. -C On entry with UPLO = 'L' or 'l', K specifies the number of -C sub-diagonals of the matrix A. -C K must satisfy 0 .le. K. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -C Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -C by n part of the array A must contain the upper triangular -C band part of the matrix of coefficients, supplied column by -C column, with the leading diagonal of the matrix in row -C ( k + 1 ) of the array, the first super-diagonal starting at -C position 2 in row k, and so on. The top left k by k triangle -C of the array A is not referenced. -C The following program segment will transfer an upper -C triangular band matrix from conventional full matrix storage -C to band storage: -C -C DO 20, J = 1, N -C M = K + 1 - J -C DO 10, I = MAX( 1, J - K ), J -C A( M + I, J ) = matrix( I, J ) -C 10 CONTINUE -C 20 CONTINUE -C -C Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -C by n part of the array A must contain the lower triangular -C band part of the matrix of coefficients, supplied column by -C column, with the leading diagonal of the matrix in row 1 of -C the array, the first sub-diagonal starting at position 1 in -C row 2, and so on. The bottom right k by k triangle of the -C array A is not referenced. -C The following program segment will transfer a lower -C triangular band matrix from conventional full matrix storage -C to band storage: -C -C DO 20, J = 1, N -C M = 1 - J -C DO 10, I = J, MIN( N, J + K ) -C A( M + I, J ) = matrix( I, J ) -C 10 CONTINUE -C 20 CONTINUE -C -C Note that when DIAG = 'U' or 'u' the elements of the array A -C corresponding to the diagonal elements of the matrix are not -C referenced, but are assumed to be unity. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C ( k + 1 ). -C Unchanged on exit. -C -C X - DOUBLE PRECISION array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element vector x. On exit, X is overwritten with the -C transformed vector x. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE DTBMV -C .. Scalar Arguments .. - INTEGER INCX, K, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ) -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -C .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L - LOGICAL NOUNIT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C***FIRST EXECUTABLE STATEMENT DTBMV -C -C Test the input parameters. -C - 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 -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - NOUNIT = LSAME( DIAG, 'N' ) -C -C Set up the start point in X if the increment is not unity. This -C will be ( N - 1 )*INCX too small for descending loops. -C - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through A. -C - IF( LSAME( TRANS, 'N' ) )THEN -C -C Form x := A*x. -C - 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 -C -C Form x := A'*x. -C - 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 -C - RETURN -C -C End of DTBMV . -C - END diff --git a/slatec/dtbsv.f b/slatec/dtbsv.f deleted file mode 100644 index 90b2e6e..0000000 --- a/slatec/dtbsv.f +++ /dev/null @@ -1,353 +0,0 @@ -*DECK DTBSV - SUBROUTINE DTBSV (UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) -C***BEGIN PROLOGUE DTBSV -C***PURPOSE Solve one of the systems of equations. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE DOUBLE PRECISION (STBSV-S, DTBSV-D, CTBSV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C DTBSV solves one of the systems of equations -C -C A*x = b, or A'*x = b, -C -C where b and x are n element vectors and A is an n by n unit, or -C non-unit, upper or lower triangular band matrix, with ( k + 1) -C diagonals. -C -C No test for singularity or near-singularity is included in this -C routine. Such tests must be performed before calling this routine. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the matrix is an upper or -C lower triangular matrix as follows: -C -C UPLO = 'U' or 'u' A is an upper triangular matrix. -C -C UPLO = 'L' or 'l' A is a lower triangular matrix. -C -C Unchanged on exit. -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the equations to be solved as -C follows: -C -C TRANS = 'N' or 'n' A*x = b. -C -C TRANS = 'T' or 't' A'*x = b. -C -C TRANS = 'C' or 'c' A'*x = b. -C -C Unchanged on exit. -C -C DIAG - CHARACTER*1. -C On entry, DIAG specifies whether or not A is unit -C triangular as follows: -C -C DIAG = 'U' or 'u' A is assumed to be unit triangular. -C -C DIAG = 'N' or 'n' A is not assumed to be unit -C triangular. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C K - INTEGER. -C On entry with UPLO = 'U' or 'u', K specifies the number of -C super-diagonals of the matrix A. -C On entry with UPLO = 'L' or 'l', K specifies the number of -C sub-diagonals of the matrix A. -C K must satisfy 0 .le. K. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -C Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -C by n part of the array A must contain the upper triangular -C band part of the matrix of coefficients, supplied column by -C column, with the leading diagonal of the matrix in row -C ( k + 1 ) of the array, the first super-diagonal starting at -C position 2 in row k, and so on. The top left k by k triangle -C of the array A is not referenced. -C The following program segment will transfer an upper -C triangular band matrix from conventional full matrix storage -C to band storage: -C -C DO 20, J = 1, N -C M = K + 1 - J -C DO 10, I = MAX( 1, J - K ), J -C A( M + I, J ) = matrix( I, J ) -C 10 CONTINUE -C 20 CONTINUE -C -C Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -C by n part of the array A must contain the lower triangular -C band part of the matrix of coefficients, supplied column by -C column, with the leading diagonal of the matrix in row 1 of -C the array, the first sub-diagonal starting at position 1 in -C row 2, and so on. The bottom right k by k triangle of the -C array A is not referenced. -C The following program segment will transfer a lower -C triangular band matrix from conventional full matrix storage -C to band storage: -C -C DO 20, J = 1, N -C M = 1 - J -C DO 10, I = J, MIN( N, J + K ) -C A( M + I, J ) = matrix( I, J ) -C 10 CONTINUE -C 20 CONTINUE -C -C Note that when DIAG = 'U' or 'u' the elements of the array A -C corresponding to the diagonal elements of the matrix are not -C referenced, but are assumed to be unity. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C ( k + 1 ). -C Unchanged on exit. -C -C X - DOUBLE PRECISION array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element right-hand side vector b. On exit, X is overwritten -C with the solution vector x. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE DTBSV -C .. Scalar Arguments .. - INTEGER INCX, K, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ) -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -C .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L - LOGICAL NOUNIT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C***FIRST EXECUTABLE STATEMENT DTBSV -C -C Test the input parameters. -C - 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 -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - NOUNIT = LSAME( DIAG, 'N' ) -C -C Set up the start point in X if the increment is not unity. This -C will be ( N - 1 )*INCX too small for descending loops. -C - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -C -C Start the operations. In this version the elements of A are -C accessed by sequentially with one pass through A. -C - IF( LSAME( TRANS, 'N' ) )THEN -C -C Form x := inv( A )*x. -C - 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 -C -C Form x := inv( A')*x. -C - 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 -C - RETURN -C -C End of DTBSV . -C - END diff --git a/slatec/dtin.f b/slatec/dtin.f deleted file mode 100644 index 17ceabc..0000000 --- a/slatec/dtin.f +++ /dev/null @@ -1,187 +0,0 @@ -*DECK DTIN - SUBROUTINE DTIN (N, NELT, IA, JA, A, ISYM, SOLN, RHS, IUNIT, JOB) -C***BEGIN PROLOGUE DTIN -C***PURPOSE Read in SLAP Triad Format Linear System. -C Routine to read in a SLAP Triad format matrix and right -C hand side and solution to the system, if known. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY N1 -C***TYPE DOUBLE PRECISION (STIN-S, DTIN-D) -C***KEYWORDS DIAGNOSTICS, LINEAR SYSTEM, SLAP SPARSE -C***AUTHOR Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, IUNIT, JOB -C DOUBLE PRECISION A(NELT), SOLN(N), RHS(N) -C -C CALL DTIN( N, NELT, IA, JA, A, ISYM, SOLN, RHS, IUNIT, JOB ) -C -C *Arguments: -C N :OUT Integer -C Order of the Matrix. -C NELT :INOUT Integer. -C On input NELT is the maximum number of non-zeros that -C can be stored in the IA, JA, A arrays. -C On output NELT is the number of non-zeros stored in A. -C IA :OUT Integer IA(NELT). -C JA :OUT Integer JA(NELT). -C A :OUT Double Precision A(NELT). -C On output these arrays hold the matrix A in the SLAP -C Triad format. See "Description", below. -C ISYM :OUT Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the lower -C triangle of the matrix is stored. -C SOLN :OUT Double Precision SOLN(N). -C The solution to the linear system, if present. This array -C is accessed if and only if JOB to read it in, see below. -C If the user requests that SOLN be read in, but it is not in -C the file, then it is simply zeroed out. -C RHS :OUT Double Precision RHS(N). -C The right hand side vector. This array is accessed if and -C only if JOB is set to read it in, see below. -C If the user requests that RHS be read in, but it is not in -C the file, then it is simply zeroed out. -C IUNIT :IN Integer. -C Fortran logical I/O device unit number to write the matrix -C to. This unit must be connected in a system dependent fashion -C to a file or the console or you will get a nasty message -C from the Fortran I/O libraries. -C JOB :INOUT Integer. -C Flag indicating what I/O operations to perform. -C On input JOB indicates what Input operations to try to -C perform. -C JOB = 0 => Read only the matrix. -C JOB = 1 => Read matrix and RHS (if present). -C JOB = 2 => Read matrix and SOLN (if present). -C JOB = 3 => Read matrix, RHS and SOLN (if present). -C On output JOB indicates what operations were actually -C performed. -C JOB = 0 => Read in only the matrix. -C JOB = 1 => Read in the matrix and RHS. -C JOB = 2 => Read in the matrix and SOLN. -C JOB = 3 => Read in the matrix, RHS and SOLN. -C -C *Description: -C The format for the input is as follows. On the first line -C are counters and flags: N, NELT, ISYM, IRHS, ISOLN. N, NELT -C and ISYM are described above. IRHS is a flag indicating if -C the RHS was written out (1 is yes, 0 is no). ISOLN is a -C flag indicating if the SOLN was written out (1 is yes, 0 is -C no). The format for the fist line is: 5i10. Then comes the -C NELT Triad's IA(I), JA(I) and A(I), I = 1, NELT. The format -C for these lines is : 1X,I5,1X,I5,1X,D16.7. Then comes -C RHS(I), I = 1, N, if IRHS = 1. Then comes SOLN(I), I = 1, -C N, if ISOLN = 1. The format for these lines is: 1X,D16.7. -C -C =================== S L A P Triad format =================== -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 921007 Changed E's to D's in formats. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE DTIN -C .. Scalar Arguments .. - INTEGER ISYM, IUNIT, JOB, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), RHS(N), SOLN(N) - INTEGER IA(NELT), JA(NELT) -C .. Local Scalars .. - INTEGER I, IRHS, ISOLN, JOBRET, NELTMX -C .. Intrinsic Functions .. - INTRINSIC MIN -C***FIRST EXECUTABLE STATEMENT DTIN -C -C Read in the information heading. -C - NELTMX = NELT - READ(IUNIT,1000) N, NELT, ISYM, IRHS, ISOLN - NELT = MIN( NELT, NELTMX ) -C -C Read in the matrix non-zeros in Triad format. - DO 10 I = 1, NELT - READ(IUNIT,1010) IA(I), JA(I), A(I) - 10 CONTINUE -C -C If requested, read in the rhs. - JOBRET = 0 - IF( JOB.EQ.1 .OR. JOB.EQ.3 ) THEN -C -C Check to see if rhs is in the file. - IF( IRHS.EQ.1 ) THEN - JOBRET = 1 - READ(IUNIT,1020) (RHS(I),I=1,N) - ELSE - DO 20 I = 1, N - RHS(I) = 0 - 20 CONTINUE - ENDIF - ENDIF -C -C If requested, read in the solution. - IF( JOB.GT.1 ) THEN -C -C Check to see if solution is in the file. - IF( ISOLN.EQ.1 ) THEN - JOBRET = JOBRET + 2 - READ(IUNIT,1020) (SOLN(I),I=1,N) - ELSE - DO 30 I = 1, N - SOLN(I) = 0 - 30 CONTINUE - ENDIF - ENDIF -C - JOB = JOBRET - RETURN - 1000 FORMAT(5I10) - 1010 FORMAT(1X,I5,1X,I5,1X,D16.7) - 1020 FORMAT(1X,D16.7) -C------------- LAST LINE OF DTIN FOLLOWS ---------------------------- - END diff --git a/slatec/dtout.f b/slatec/dtout.f deleted file mode 100644 index f680ebd..0000000 --- a/slatec/dtout.f +++ /dev/null @@ -1,154 +0,0 @@ -*DECK DTOUT - SUBROUTINE DTOUT (N, NELT, IA, JA, A, ISYM, SOLN, RHS, IUNIT, JOB) -C***BEGIN PROLOGUE DTOUT -C***PURPOSE Write out SLAP Triad Format Linear System. -C Routine to write out a SLAP Triad format matrix and right -C hand side and solution to the system, if known. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY N1 -C***TYPE DOUBLE PRECISION (STOUT-S, DTOUT-D) -C***KEYWORDS DIAGNOSTICS, LINEAR SYSTEM, SLAP SPARSE -C***AUTHOR Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, IUNIT, JOB -C DOUBLE PRECISION A(NELT), SOLN(N), RHS(N) -C -C CALL DTOUT( N, NELT, IA, JA, A, ISYM, SOLN, RHS, IUNIT, JOB ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C NELT :IN Integer. -C Number of non-zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Double Precision A(NELT). -C These arrays should hold the matrix A in the SLAP -C Triad format. See "Description", below. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the lower -C triangle of the matrix is stored. -C SOLN :IN Double Precision SOLN(N). -C The solution to the linear system, if known. This array -C is accessed if and only if JOB is set to print it out, -C see below. -C RHS :IN Double Precision RHS(N). -C The right hand side vector. This array is accessed if and -C only if JOB is set to print it out, see below. -C IUNIT :IN Integer. -C Fortran logical I/O device unit number to write the matrix -C to. This unit must be connected in a system dependent fashion -C to a file or the console or you will get a nasty message -C from the Fortran I/O libraries. -C JOB :IN Integer. -C Flag indicating what I/O operations to perform. -C JOB = 0 => Print only the matrix. -C = 1 => Print matrix and RHS. -C = 2 => Print matrix and SOLN. -C = 3 => Print matrix, RHS and SOLN. -C -C *Description: -C The format for the output is as follows. On the first line -C are counters and flags: N, NELT, ISYM, IRHS, ISOLN. N, NELT -C and ISYM are described above. IRHS is a flag indicating if -C the RHS was written out (1 is yes, 0 is no). ISOLN is a -C flag indicating if the SOLN was written out (1 is yes, 0 is -C no). The format for the fist line is: 5i10. Then comes the -C NELT Triad's IA(I), JA(I) and A(I), I = 1, NELT. The format -C for these lines is : 1X,I5,1X,I5,1X,D16.7. Then comes -C RHS(I), I = 1, N, if IRHS = 1. Then comes SOLN(I), I = 1, -C N, if ISOLN = 1. The format for these lines is: 1X,D16.7. -C -C =================== S L A P Triad format =================== -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 921007 Changed E's to D's in formats. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE DTOUT -C .. Scalar Arguments .. - INTEGER ISYM, IUNIT, JOB, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), RHS(N), SOLN(N) - INTEGER IA(NELT), JA(NELT) -C .. Local Scalars .. - INTEGER I, IRHS, ISOLN -C***FIRST EXECUTABLE STATEMENT DTOUT -C -C If RHS and SOLN are to be printed also. -C Write out the information heading. -C - IRHS = 0 - ISOLN = 0 - IF( JOB.EQ.1 .OR. JOB.EQ.3 ) IRHS = 1 - IF( JOB.GT.1 ) ISOLN = 1 - WRITE(IUNIT,1000) N, NELT, ISYM, IRHS, ISOLN -C -C Write out the matrix non-zeros in Triad format. - DO 10 I = 1, NELT - WRITE(IUNIT,1010) IA(I), JA(I), A(I) - 10 CONTINUE -C -C If requested, write out the rhs. - IF( IRHS.EQ.1 ) THEN - WRITE(IUNIT,1020) (RHS(I),I=1,N) - ENDIF -C -C If requested, write out the solution. - IF( ISOLN.EQ.1 ) THEN - WRITE(IUNIT,1020) (SOLN(I),I=1,N) - ENDIF - RETURN - 1000 FORMAT(5I10) - 1010 FORMAT(1X,I5,1X,I5,1X,D16.7) - 1020 FORMAT(1X,D16.7) -C------------- LAST LINE OF DTOUT FOLLOWS ---------------------------- - END diff --git a/slatec/dtpmv.f b/slatec/dtpmv.f deleted file mode 100644 index 6014027..0000000 --- a/slatec/dtpmv.f +++ /dev/null @@ -1,306 +0,0 @@ -*DECK DTPMV - SUBROUTINE DTPMV (UPLO, TRANS, DIAG, N, AP, X, INCX) -C***BEGIN PROLOGUE DTPMV -C***PURPOSE Perform one of the matrix-vector operations. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE DOUBLE PRECISION (STPMV-S, DTPMV-D, CTPMV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C DTPMV performs one of the matrix-vector operations -C -C x := A*x, or x := A'*x, -C -C where x is an n element vector and A is an n by n unit, or non-unit, -C upper or lower triangular matrix, supplied in packed form. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the matrix is an upper or -C lower triangular matrix as follows: -C -C UPLO = 'U' or 'u' A is an upper triangular matrix. -C -C UPLO = 'L' or 'l' A is a lower triangular matrix. -C -C Unchanged on exit. -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the operation to be performed as -C follows: -C -C TRANS = 'N' or 'n' x := A*x. -C -C TRANS = 'T' or 't' x := A'*x. -C -C TRANS = 'C' or 'c' x := A'*x. -C -C Unchanged on exit. -C -C DIAG - CHARACTER*1. -C On entry, DIAG specifies whether or not A is unit -C triangular as follows: -C -C DIAG = 'U' or 'u' A is assumed to be unit triangular. -C -C DIAG = 'N' or 'n' A is not assumed to be unit -C triangular. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C AP - DOUBLE PRECISION array of DIMENSION at least -C ( ( n*( n + 1))/2). -C Before entry with UPLO = 'U' or 'u', the array AP must -C contain the upper triangular matrix packed sequentially, -C column by column, so that AP( 1 ) contains a( 1, 1 ), -C AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) -C respectively, and so on. -C Before entry with UPLO = 'L' or 'l', the array AP must -C contain the lower triangular matrix packed sequentially, -C column by column, so that AP( 1 ) contains a( 1, 1 ), -C AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) -C respectively, and so on. -C Note that when DIAG = 'U' or 'u', the diagonal elements of -C A are not referenced, but are assumed to be unity. -C Unchanged on exit. -C -C X - DOUBLE PRECISION array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element vector x. On exit, X is overwritten with the -C transformed vector x. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE DTPMV -C .. Scalar Arguments .. - INTEGER INCX, N - CHARACTER*1 DIAG, TRANS, UPLO -C .. Array Arguments .. - DOUBLE PRECISION AP( * ), X( * ) -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -C .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX - LOGICAL NOUNIT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C***FIRST EXECUTABLE STATEMENT DTPMV -C -C Test the input parameters. -C - 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 -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - NOUNIT = LSAME( DIAG, 'N' ) -C -C Set up the start point in X if the increment is not unity. This -C will be ( N - 1 )*INCX too small for descending loops. -C - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -C -C Start the operations. In this version the elements of AP are -C accessed sequentially with one pass through AP. -C - IF( LSAME( TRANS, 'N' ) )THEN -C -C Form x:= A*x. -C - 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 -C -C Form x := A'*x. -C - 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 -C - RETURN -C -C End of DTPMV . -C - END diff --git a/slatec/dtpsv.f b/slatec/dtpsv.f deleted file mode 100644 index 281954f..0000000 --- a/slatec/dtpsv.f +++ /dev/null @@ -1,309 +0,0 @@ -*DECK DTPSV - SUBROUTINE DTPSV (UPLO, TRANS, DIAG, N, AP, X, INCX) -C***BEGIN PROLOGUE DTPSV -C***PURPOSE Solve one of the systems of equations. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE DOUBLE PRECISION (STPSV-S, DTPSV-D, CTPSV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C DTPSV solves one of the systems of equations -C -C A*x = b, or A'*x = b, -C -C where b and x are n element vectors and A is an n by n unit, or -C non-unit, upper or lower triangular matrix, supplied in packed form. -C -C No test for singularity or near-singularity is included in this -C routine. Such tests must be performed before calling this routine. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the matrix is an upper or -C lower triangular matrix as follows: -C -C UPLO = 'U' or 'u' A is an upper triangular matrix. -C -C UPLO = 'L' or 'l' A is a lower triangular matrix. -C -C Unchanged on exit. -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the equations to be solved as -C follows: -C -C TRANS = 'N' or 'n' A*x = b. -C -C TRANS = 'T' or 't' A'*x = b. -C -C TRANS = 'C' or 'c' A'*x = b. -C -C Unchanged on exit. -C -C DIAG - CHARACTER*1. -C On entry, DIAG specifies whether or not A is unit -C triangular as follows: -C -C DIAG = 'U' or 'u' A is assumed to be unit triangular. -C -C DIAG = 'N' or 'n' A is not assumed to be unit -C triangular. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C AP - DOUBLE PRECISION array of DIMENSION at least -C ( ( n*( n + 1))/2). -C Before entry with UPLO = 'U' or 'u', the array AP must -C contain the upper triangular matrix packed sequentially, -C column by column, so that AP( 1 ) contains a( 1, 1 ), -C AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) -C respectively, and so on. -C Before entry with UPLO = 'L' or 'l', the array AP must -C contain the lower triangular matrix packed sequentially, -C column by column, so that AP( 1 ) contains a( 1, 1 ), -C AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) -C respectively, and so on. -C Note that when DIAG = 'U' or 'u', the diagonal elements of -C A are not referenced, but are assumed to be unity. -C Unchanged on exit. -C -C X - DOUBLE PRECISION array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element right-hand side vector b. On exit, X is overwritten -C with the solution vector x. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE DTPSV -C .. Scalar Arguments .. - INTEGER INCX, N - CHARACTER*1 DIAG, TRANS, UPLO -C .. Array Arguments .. - DOUBLE PRECISION AP( * ), X( * ) -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -C .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX - LOGICAL NOUNIT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C***FIRST EXECUTABLE STATEMENT DTPSV -C -C Test the input parameters. -C - 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 -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - NOUNIT = LSAME( DIAG, 'N' ) -C -C Set up the start point in X if the increment is not unity. This -C will be ( N - 1 )*INCX too small for descending loops. -C - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -C -C Start the operations. In this version the elements of AP are -C accessed sequentially with one pass through AP. -C - IF( LSAME( TRANS, 'N' ) )THEN -C -C Form x := inv( A )*x. -C - 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 -C -C Form x := inv( A' )*x. -C - 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 -C - RETURN -C -C End of DTPSV . -C - END diff --git a/slatec/dtrco.f b/slatec/dtrco.f deleted file mode 100644 index 0950588..0000000 --- a/slatec/dtrco.f +++ /dev/null @@ -1,175 +0,0 @@ -*DECK DTRCO - SUBROUTINE DTRCO (T, LDT, N, RCOND, Z, JOB) -C***BEGIN PROLOGUE DTRCO -C***PURPOSE Estimate the condition number of a triangular matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2A3 -C***TYPE DOUBLE PRECISION (STRCO-S, DTRCO-D, CTRCO-C) -C***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, -C TRIANGULAR MATRIX -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C DTRCO estimates the condition of a double precision triangular -C matrix. -C -C On Entry -C -C T DOUBLE PRECISION(LDT,N) -C T contains the triangular matrix. The zero -C elements of the matrix are not referenced, and -C the corresponding elements of the array can be -C used to store other information. -C -C LDT INTEGER -C LDT is the leading dimension of the array T. -C -C N INTEGER -C N is the order of the system. -C -C JOB INTEGER -C = 0 T is lower triangular. -C = nonzero T is upper triangular. -C -C On Return -C -C RCOND DOUBLE PRECISION -C an estimate of the reciprocal condition of T . -C For the system T*X = B , relative perturbations -C in T 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 T 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 T 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***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DASUM, DAXPY, DSCAL -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DTRCO - INTEGER LDT,N,JOB - DOUBLE PRECISION T(LDT,*),Z(*) - DOUBLE PRECISION RCOND -C - DOUBLE PRECISION W,WK,WKM,EK - DOUBLE PRECISION TNORM,YNORM,S,SM,DASUM - INTEGER I1,J,J1,J2,K,KK,L - LOGICAL LOWER -C***FIRST EXECUTABLE STATEMENT DTRCO - LOWER = JOB .EQ. 0 -C -C COMPUTE 1-NORM OF T -C - TNORM = 0.0D0 - DO 10 J = 1, N - L = J - IF (LOWER) L = N + 1 - J - I1 = 1 - IF (LOWER) I1 = J - TNORM = MAX(TNORM,DASUM(L,T(I1,J),1)) - 10 CONTINUE -C -C RCOND = 1/(NORM(T)*(ESTIMATE OF NORM(INVERSE(T)))) . -C ESTIMATE = NORM(Z)/NORM(Y) WHERE T*Z = Y AND TRANS(T)*Y = E . -C TRANS(T) IS THE TRANSPOSE OF T . -C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL -C GROWTH IN THE ELEMENTS OF Y . -C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. -C -C SOLVE TRANS(T)*Y = E -C - EK = 1.0D0 - DO 20 J = 1, N - Z(J) = 0.0D0 - 20 CONTINUE - DO 100 KK = 1, N - K = KK - IF (LOWER) K = N + 1 - KK - IF (Z(K) .NE. 0.0D0) EK = SIGN(EK,-Z(K)) - IF (ABS(EK-Z(K)) .LE. ABS(T(K,K))) GO TO 30 - S = ABS(T(K,K))/ABS(EK-Z(K)) - CALL DSCAL(N,S,Z,1) - EK = S*EK - 30 CONTINUE - WK = EK - Z(K) - WKM = -EK - Z(K) - S = ABS(WK) - SM = ABS(WKM) - IF (T(K,K) .EQ. 0.0D0) GO TO 40 - WK = WK/T(K,K) - WKM = WKM/T(K,K) - GO TO 50 - 40 CONTINUE - WK = 1.0D0 - WKM = 1.0D0 - 50 CONTINUE - IF (KK .EQ. N) GO TO 90 - J1 = K + 1 - IF (LOWER) J1 = 1 - J2 = N - IF (LOWER) J2 = K - 1 - DO 60 J = J1, J2 - SM = SM + ABS(Z(J)+WKM*T(K,J)) - Z(J) = Z(J) + WK*T(K,J) - S = S + ABS(Z(J)) - 60 CONTINUE - IF (S .GE. SM) GO TO 80 - W = WKM - WK - WK = WKM - DO 70 J = J1, J2 - Z(J) = Z(J) + W*T(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 - YNORM = 1.0D0 -C -C SOLVE T*Z = Y -C - DO 130 KK = 1, N - K = N + 1 - KK - IF (LOWER) K = KK - IF (ABS(Z(K)) .LE. ABS(T(K,K))) GO TO 110 - S = ABS(T(K,K))/ABS(Z(K)) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM - 110 CONTINUE - IF (T(K,K) .NE. 0.0D0) Z(K) = Z(K)/T(K,K) - IF (T(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 - I1 = 1 - IF (LOWER) I1 = K + 1 - IF (KK .GE. N) GO TO 120 - W = -Z(K) - CALL DAXPY(N-KK,W,T(I1,K),1,Z(I1),1) - 120 CONTINUE - 130 CONTINUE -C MAKE ZNORM = 1.0 - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM -C - IF (TNORM .NE. 0.0D0) RCOND = YNORM/TNORM - IF (TNORM .EQ. 0.0D0) RCOND = 0.0D0 - RETURN - END diff --git a/slatec/dtrdi.f b/slatec/dtrdi.f deleted file mode 100644 index fe73d9b..0000000 --- a/slatec/dtrdi.f +++ /dev/null @@ -1,147 +0,0 @@ -*DECK DTRDI - SUBROUTINE DTRDI (T, LDT, N, DET, JOB, INFO) -C***BEGIN PROLOGUE DTRDI -C***PURPOSE Compute the determinant and inverse of a triangular matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2A3, D3A3 -C***TYPE DOUBLE PRECISION (STRDI-S, DTRDI-D, CTRDI-C) -C***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, -C TRIANGULAR MATRIX -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C DTRDI computes the determinant and inverse of a double precision -C triangular matrix. -C -C On Entry -C -C T DOUBLE PRECISION(LDT,N) -C T contains the triangular matrix. The zero -C elements of the matrix are not referenced, and -C the corresponding elements of the array can be -C used to store other information. -C -C LDT INTEGER -C LDT is the leading dimension of the array T. -C -C N INTEGER -C N is the order of the system. -C -C JOB INTEGER -C = 010 no det, inverse of lower triangular. -C = 011 no det, inverse of upper triangular. -C = 100 det, no inverse. -C = 110 det, inverse of lower triangular. -C = 111 det, inverse of upper triangular. -C -C On Return -C -C T 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. ABS(DET(1)) .LT. 10.0 -C or DET(1) .EQ. 0.0 . -C -C INFO INTEGER -C INFO contains zero if the system is nonsingular -C and the inverse is requested. -C Otherwise INFO contains the index of -C a zero diagonal element of T. -C -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DSCAL -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DTRDI - INTEGER LDT,N,JOB,INFO - DOUBLE PRECISION T(LDT,*),DET(2) -C - DOUBLE PRECISION TEMP - DOUBLE PRECISION TEN - INTEGER I,J,K,KB,KM1,KP1 -C***FIRST EXECUTABLE STATEMENT DTRDI -C -C COMPUTE DETERMINANT -C - IF (JOB/100 .EQ. 0) GO TO 70 - DET(1) = 1.0D0 - DET(2) = 0.0D0 - TEN = 10.0D0 - DO 50 I = 1, N - DET(1) = T(I,I)*DET(1) - IF (DET(1) .EQ. 0.0D0) GO TO 60 - 10 IF (ABS(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 (ABS(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 OF UPPER TRIANGULAR -C - IF (MOD(JOB/10,10) .EQ. 0) GO TO 170 - IF (MOD(JOB,10) .EQ. 0) GO TO 120 - DO 100 K = 1, N - INFO = K - IF (T(K,K) .EQ. 0.0D0) GO TO 110 - T(K,K) = 1.0D0/T(K,K) - TEMP = -T(K,K) - CALL DSCAL(K-1,TEMP,T(1,K),1) - KP1 = K + 1 - IF (N .LT. KP1) GO TO 90 - DO 80 J = KP1, N - TEMP = T(K,J) - T(K,J) = 0.0D0 - CALL DAXPY(K,TEMP,T(1,K),1,T(1,J),1) - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - INFO = 0 - 110 CONTINUE - GO TO 160 - 120 CONTINUE -C -C COMPUTE INVERSE OF LOWER TRIANGULAR -C - DO 150 KB = 1, N - K = N + 1 - KB - INFO = K - IF (T(K,K) .EQ. 0.0D0) GO TO 180 - T(K,K) = 1.0D0/T(K,K) - TEMP = -T(K,K) - IF (K .NE. N) CALL DSCAL(N-K,TEMP,T(K+1,K),1) - KM1 = K - 1 - IF (KM1 .LT. 1) GO TO 140 - DO 130 J = 1, KM1 - TEMP = T(K,J) - T(K,J) = 0.0D0 - CALL DAXPY(N-K+1,TEMP,T(K,K),1,T(K,J),1) - 130 CONTINUE - 140 CONTINUE - 150 CONTINUE - INFO = 0 - 160 CONTINUE - 170 CONTINUE - 180 CONTINUE - RETURN - END diff --git a/slatec/dtrmm.f b/slatec/dtrmm.f deleted file mode 100644 index 4190458..0000000 --- a/slatec/dtrmm.f +++ /dev/null @@ -1,361 +0,0 @@ -*DECK DTRMM - SUBROUTINE DTRMM (SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB) -C***BEGIN PROLOGUE DTRMM -C***PURPOSE Perform one of the matrix-matrix operations. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B6 -C***TYPE DOUBLE PRECISION (STRMM-S, DTRMM-D, CTRMM-C) -C***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J., (ANL) -C Duff, I., (AERE) -C Du Croz, J., (NAG) -C Hammarling, S. (NAG) -C***DESCRIPTION -C -C DTRMM performs one of the matrix-matrix operations -C -C B := alpha*op( A )*B, or B := alpha*B*op( A ), -C -C where alpha is a scalar, B is an m by n matrix, A is a unit, or -C non-unit, upper or lower triangular matrix and op( A ) is one of -C -C op( A ) = A or op( A ) = A'. -C -C Parameters -C ========== -C -C SIDE - CHARACTER*1. -C On entry, SIDE specifies whether op( A ) multiplies B from -C the left or right as follows: -C -C SIDE = 'L' or 'l' B := alpha*op( A )*B. -C -C SIDE = 'R' or 'r' B := alpha*B*op( A ). -C -C Unchanged on exit. -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the matrix A is an upper or -C lower triangular matrix as follows: -C -C UPLO = 'U' or 'u' A is an upper triangular matrix. -C -C UPLO = 'L' or 'l' A is a lower triangular matrix. -C -C Unchanged on exit. -C -C TRANSA - CHARACTER*1. -C On entry, TRANSA specifies the form of op( A ) to be used in -C the matrix multiplication as follows: -C -C TRANSA = 'N' or 'n' op( A ) = A. -C -C TRANSA = 'T' or 't' op( A ) = A'. -C -C TRANSA = 'C' or 'c' op( A ) = A'. -C -C Unchanged on exit. -C -C DIAG - CHARACTER*1. -C On entry, DIAG specifies whether or not A is unit triangular -C as follows: -C -C DIAG = 'U' or 'u' A is assumed to be unit triangular. -C -C DIAG = 'N' or 'n' A is not assumed to be unit -C triangular. -C -C Unchanged on exit. -C -C M - INTEGER. -C On entry, M specifies the number of rows of B. M must be at -C least zero. -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the number of columns of B. N must be -C at least zero. -C Unchanged on exit. -C -C ALPHA - DOUBLE PRECISION. -C On entry, ALPHA specifies the scalar alpha. When alpha is -C zero then A is not referenced and B need not be set before -C entry. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m -C when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -C Before entry with UPLO = 'U' or 'u', the leading k by k -C upper triangular part of the array A must contain the upper -C triangular matrix and the strictly lower triangular part of -C A is not referenced. -C Before entry with UPLO = 'L' or 'l', the leading k by k -C lower triangular part of the array A must contain the lower -C triangular matrix and the strictly upper triangular part of -C A is not referenced. -C Note that when DIAG = 'U' or 'u', the diagonal elements of -C A are not referenced either, but are assumed to be unity. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. When SIDE = 'L' or 'l' then -C LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -C then LDA must be at least max( 1, n ). -C Unchanged on exit. -C -C B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). -C Before entry, the leading m by n part of the array B must -C contain the matrix B, and on exit is overwritten by the -C transformed matrix. -C -C LDB - INTEGER. -C On entry, LDB specifies the first dimension of B as declared -C in the calling (sub) program. LDB must be at least -C max( 1, m ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. -C A set of level 3 basic linear algebra subprograms. -C ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 890208 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE DTRMM -C .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Local Scalars .. - LOGICAL LSIDE, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - DOUBLE PRECISION TEMP -C .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -C***FIRST EXECUTABLE STATEMENT DTRMM -C -C Test the input parameters. -C - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -C - 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 -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C -C And when alpha.eq.zero. -C - 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 -C -C Start the operations. -C - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) )THEN -C -C Form B := alpha*A*B. -C - 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 -C -C Form B := alpha*B*A'. -C - 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 -C -C Form B := alpha*B*A. -C - 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 -C -C Form B := alpha*B*A'. -C - 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 -C - RETURN -C -C End of DTRMM . -C - END diff --git a/slatec/dtrmv.f b/slatec/dtrmv.f deleted file mode 100644 index 7650e0b..0000000 --- a/slatec/dtrmv.f +++ /dev/null @@ -1,293 +0,0 @@ -*DECK DTRMV - SUBROUTINE DTRMV (UPLO, TRANS, DIAG, N, A, LDA, X, INCX) -C***BEGIN PROLOGUE DTRMV -C***PURPOSE Perform one of the matrix-vector operations. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE DOUBLE PRECISION (STRMV-S, DTRMV-D, CTRMV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C DTRMV performs one of the matrix-vector operations -C -C x := A*x, or x := A'*x, -C -C where x is an n element vector and A is an n by n unit, or non-unit, -C upper or lower triangular matrix. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the matrix is an upper or -C lower triangular matrix as follows: -C -C UPLO = 'U' or 'u' A is an upper triangular matrix. -C -C UPLO = 'L' or 'l' A is a lower triangular matrix. -C -C Unchanged on exit. -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the operation to be performed as -C follows: -C -C TRANS = 'N' or 'n' x := A*x. -C -C TRANS = 'T' or 't' x := A'*x. -C -C TRANS = 'C' or 'c' x := A'*x. -C -C Unchanged on exit. -C -C DIAG - CHARACTER*1. -C On entry, DIAG specifies whether or not A is unit -C triangular as follows: -C -C DIAG = 'U' or 'u' A is assumed to be unit triangular. -C -C DIAG = 'N' or 'n' A is not assumed to be unit -C triangular. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION ( LDA, n). -C Before entry with UPLO = 'U' or 'u', the leading n by n -C upper triangular part of the array A must contain the upper -C triangular matrix and the strictly lower triangular part of -C A is not referenced. -C Before entry with UPLO = 'L' or 'l', the leading n by n -C lower triangular part of the array A must contain the lower -C triangular matrix and the strictly upper triangular part of -C A is not referenced. -C Note that when DIAG = 'U' or 'u', the diagonal elements of -C A are not referenced either, but are assumed to be unity. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C max( 1, n ). -C Unchanged on exit. -C -C X - DOUBLE PRECISION array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element vector x. On exit, X is overwritten with the -C transformed vector x. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE DTRMV -C .. Scalar Arguments .. - INTEGER INCX, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ) -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -C .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, KX - LOGICAL NOUNIT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C***FIRST EXECUTABLE STATEMENT DTRMV -C -C Test the input parameters. -C - 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 -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - NOUNIT = LSAME( DIAG, 'N' ) -C -C Set up the start point in X if the increment is not unity. This -C will be ( N - 1 )*INCX too small for descending loops. -C - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through A. -C - IF( LSAME( TRANS, 'N' ) )THEN -C -C Form x := A*x. -C - 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 -C -C Form x := A'*x. -C - 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 -C - RETURN -C -C End of DTRMV . -C - END diff --git a/slatec/dtrsl.f b/slatec/dtrsl.f deleted file mode 100644 index 7f4e13d..0000000 --- a/slatec/dtrsl.f +++ /dev/null @@ -1,146 +0,0 @@ -*DECK DTRSL - SUBROUTINE DTRSL (T, LDT, N, B, JOB, INFO) -C***BEGIN PROLOGUE DTRSL -C***PURPOSE Solve a system of the form T*X=B or TRANS(T)*X=B, where -C T is a triangular matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2A3 -C***TYPE DOUBLE PRECISION (STRSL-S, DTRSL-D, CTRSL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, TRIANGULAR LINEAR SYSTEM, -C TRIANGULAR MATRIX -C***AUTHOR Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C DTRSL solves systems of the form -C -C T * X = B -C or -C TRANS(T) * X = B -C -C where T is a triangular matrix of order N. Here TRANS(T) -C denotes the transpose of the matrix T. -C -C On Entry -C -C T DOUBLE PRECISION(LDT,N) -C T contains the matrix of the system. The zero -C elements of the matrix are not referenced, and -C the corresponding elements of the array can be -C used to store other information. -C -C LDT INTEGER -C LDT is the leading dimension of the array T. -C -C N INTEGER -C N is the order of the system. -C -C B DOUBLE PRECISION(N). -C B contains the right hand side of the system. -C -C JOB INTEGER -C JOB specifies what kind of system is to be solved. -C If JOB is -C -C 00 solve T*X=B, T lower triangular, -C 01 solve T*X=B, T upper triangular, -C 10 solve TRANS(T)*X=B, T lower triangular, -C 11 solve TRANS(T)*X=B, T upper triangular. -C -C On Return -C -C B B contains the solution, if INFO .EQ. 0. -C Otherwise B is unaltered. -C -C INFO INTEGER -C INFO contains zero if the system is nonsingular. -C Otherwise INFO contains the index of -C the first zero diagonal element of T. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DDOT -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DTRSL - INTEGER LDT,N,JOB,INFO - DOUBLE PRECISION T(LDT,*),B(*) -C -C - DOUBLE PRECISION DDOT,TEMP - INTEGER CASE,J,JJ -C***FIRST EXECUTABLE STATEMENT DTRSL -C -C CHECK FOR ZERO DIAGONAL ELEMENTS. -C - DO 10 INFO = 1, N - IF (T(INFO,INFO) .EQ. 0.0D0) GO TO 150 - 10 CONTINUE - INFO = 0 -C -C DETERMINE THE TASK AND GO TO IT. -C - CASE = 1 - IF (MOD(JOB,10) .NE. 0) CASE = 2 - IF (MOD(JOB,100)/10 .NE. 0) CASE = CASE + 2 - GO TO (20,50,80,110), CASE -C -C SOLVE T*X=B FOR T LOWER TRIANGULAR -C - 20 CONTINUE - B(1) = B(1)/T(1,1) - IF (N .LT. 2) GO TO 40 - DO 30 J = 2, N - TEMP = -B(J-1) - CALL DAXPY(N-J+1,TEMP,T(J,J-1),1,B(J),1) - B(J) = B(J)/T(J,J) - 30 CONTINUE - 40 CONTINUE - GO TO 140 -C -C SOLVE T*X=B FOR T UPPER TRIANGULAR. -C - 50 CONTINUE - B(N) = B(N)/T(N,N) - IF (N .LT. 2) GO TO 70 - DO 60 JJ = 2, N - J = N - JJ + 1 - TEMP = -B(J+1) - CALL DAXPY(J,TEMP,T(1,J+1),1,B(1),1) - B(J) = B(J)/T(J,J) - 60 CONTINUE - 70 CONTINUE - GO TO 140 -C -C SOLVE TRANS(T)*X=B FOR T LOWER TRIANGULAR. -C - 80 CONTINUE - B(N) = B(N)/T(N,N) - IF (N .LT. 2) GO TO 100 - DO 90 JJ = 2, N - J = N - JJ + 1 - B(J) = B(J) - DDOT(JJ-1,T(J+1,J),1,B(J+1),1) - B(J) = B(J)/T(J,J) - 90 CONTINUE - 100 CONTINUE - GO TO 140 -C -C SOLVE TRANS(T)*X=B FOR T UPPER TRIANGULAR. -C - 110 CONTINUE - B(1) = B(1)/T(1,1) - IF (N .LT. 2) GO TO 130 - DO 120 J = 2, N - B(J) = B(J) - DDOT(J-1,T(1,J),1,B(1),1) - B(J) = B(J)/T(J,J) - 120 CONTINUE - 130 CONTINUE - 140 CONTINUE - 150 CONTINUE - RETURN - END diff --git a/slatec/dtrsm.f b/slatec/dtrsm.f deleted file mode 100644 index 2548239..0000000 --- a/slatec/dtrsm.f +++ /dev/null @@ -1,384 +0,0 @@ -*DECK DTRSM - SUBROUTINE DTRSM (SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB) -C***BEGIN PROLOGUE DTRSM -C***PURPOSE Solve one of the matrix equations. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B6 -C***TYPE DOUBLE PRECISION (STRSM-S, DTRSM-D, CTRSM-C) -C***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J., (ANL) -C Duff, I., (AERE) -C Du Croz, J., (NAG) -C Hammarling, S. (NAG) -C***DESCRIPTION -C -C DTRSM solves one of the matrix equations -C -C op( A )*X = alpha*B, or X*op( A ) = alpha*B, -C -C where alpha is a scalar, X and B are m by n matrices, A is a unit, or -C non-unit, upper or lower triangular matrix and op( A ) is one of -C -C op( A ) = A or op( A ) = A'. -C -C The matrix X is overwritten on B. -C -C Parameters -C ========== -C -C SIDE - CHARACTER*1. -C On entry, SIDE specifies whether op( A ) appears on the left -C or right of X as follows: -C -C SIDE = 'L' or 'l' op( A )*X = alpha*B. -C -C SIDE = 'R' or 'r' X*op( A ) = alpha*B. -C -C Unchanged on exit. -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the matrix A is an upper or -C lower triangular matrix as follows: -C -C UPLO = 'U' or 'u' A is an upper triangular matrix. -C -C UPLO = 'L' or 'l' A is a lower triangular matrix. -C -C Unchanged on exit. -C -C TRANSA - CHARACTER*1. -C On entry, TRANSA specifies the form of op( A ) to be used in -C the matrix multiplication as follows: -C -C TRANSA = 'N' or 'n' op( A ) = A. -C -C TRANSA = 'T' or 't' op( A ) = A'. -C -C TRANSA = 'C' or 'c' op( A ) = A'. -C -C Unchanged on exit. -C -C DIAG - CHARACTER*1. -C On entry, DIAG specifies whether or not A is unit triangular -C as follows: -C -C DIAG = 'U' or 'u' A is assumed to be unit triangular. -C -C DIAG = 'N' or 'n' A is not assumed to be unit -C triangular. -C -C Unchanged on exit. -C -C M - INTEGER. -C On entry, M specifies the number of rows of B. M must be at -C least zero. -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the number of columns of B. N must be -C at least zero. -C Unchanged on exit. -C -C ALPHA - DOUBLE PRECISION. -C On entry, ALPHA specifies the scalar alpha. When alpha is -C zero then A is not referenced and B need not be set before -C entry. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m -C when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -C Before entry with UPLO = 'U' or 'u', the leading k by k -C upper triangular part of the array A must contain the upper -C triangular matrix and the strictly lower triangular part of -C A is not referenced. -C Before entry with UPLO = 'L' or 'l', the leading k by k -C lower triangular part of the array A must contain the lower -C triangular matrix and the strictly upper triangular part of -C A is not referenced. -C Note that when DIAG = 'U' or 'u', the diagonal elements of -C A are not referenced either, but are assumed to be unity. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. When SIDE = 'L' or 'l' then -C LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -C then LDA must be at least max( 1, n ). -C Unchanged on exit. -C -C B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). -C Before entry, the leading m by n part of the array B must -C contain the right-hand side matrix B, and on exit is -C overwritten by the solution matrix X. -C -C LDB - INTEGER. -C On entry, LDB specifies the first dimension of B as declared -C in the calling (sub) program. LDB must be at least -C max( 1, m ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. -C A set of level 3 basic linear algebra subprograms. -C ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 890208 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE DTRSM -C .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -C -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Local Scalars .. - LOGICAL LSIDE, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - DOUBLE PRECISION TEMP -C .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -C***FIRST EXECUTABLE STATEMENT DTRSM -C -C Test the input parameters. -C - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -C - 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 -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C -C And when alpha.eq.zero. -C - 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 -C -C Start the operations. -C - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) )THEN -C -C Form B := alpha*inv( A )*B. -C - 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 -C -C Form B := alpha*inv( A' )*B. -C - 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 -C -C Form B := alpha*B*inv( A ). -C - 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 -C -C Form B := alpha*B*inv( A' ). -C - 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 -C - RETURN -C -C End of DTRSM . -C - END diff --git a/slatec/dtrsv.f b/slatec/dtrsv.f deleted file mode 100644 index 8c526a8..0000000 --- a/slatec/dtrsv.f +++ /dev/null @@ -1,296 +0,0 @@ -*DECK DTRSV - SUBROUTINE DTRSV (UPLO, TRANS, DIAG, N, A, LDA, X, INCX) -C***BEGIN PROLOGUE DTRSV -C***PURPOSE Solve one of the systems of equations. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE DOUBLE PRECISION (STRSV-S, DTRSV-D, CTRSV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C DTRSV solves one of the systems of equations -C -C A*x = b, or A'*x = b, -C -C where b and x are n element vectors and A is an n by n unit, or -C non-unit, upper or lower triangular matrix. -C -C No test for singularity or near-singularity is included in this -C routine. Such tests must be performed before calling this routine. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the matrix is an upper or -C lower triangular matrix as follows: -C -C UPLO = 'U' or 'u' A is an upper triangular matrix. -C -C UPLO = 'L' or 'l' A is a lower triangular matrix. -C -C Unchanged on exit. -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the equations to be solved as -C follows: -C -C TRANS = 'N' or 'n' A*x = b. -C -C TRANS = 'T' or 't' A'*x = b. -C -C TRANS = 'C' or 'c' A'*x = b. -C -C Unchanged on exit. -C -C DIAG - CHARACTER*1. -C On entry, DIAG specifies whether or not A is unit -C triangular as follows: -C -C DIAG = 'U' or 'u' A is assumed to be unit triangular. -C -C DIAG = 'N' or 'n' A is not assumed to be unit -C triangular. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION ( LDA, n). -C Before entry with UPLO = 'U' or 'u', the leading n by n -C upper triangular part of the array A must contain the upper -C triangular matrix and the strictly lower triangular part of -C A is not referenced. -C Before entry with UPLO = 'L' or 'l', the leading n by n -C lower triangular part of the array A must contain the lower -C triangular matrix and the strictly upper triangular part of -C A is not referenced. -C Note that when DIAG = 'U' or 'u', the diagonal elements of -C A are not referenced either, but are assumed to be unity. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C max( 1, n ). -C Unchanged on exit. -C -C X - DOUBLE PRECISION array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element right-hand side vector b. On exit, X is overwritten -C with the solution vector x. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE DTRSV -C .. Scalar Arguments .. - INTEGER INCX, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ) -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -C .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, KX - LOGICAL NOUNIT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C***FIRST EXECUTABLE STATEMENT DTRSV -C -C Test the input parameters. -C - 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 -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - NOUNIT = LSAME( DIAG, 'N' ) -C -C Set up the start point in X if the increment is not unity. This -C will be ( N - 1 )*INCX too small for descending loops. -C - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through A. -C - IF( LSAME( TRANS, 'N' ) )THEN -C -C Form x := inv( A )*x. -C - 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 -C -C Form x := inv( A' )*x. -C - 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 -C - RETURN -C -C End of DTRSV . -C - END diff --git a/slatec/du11ls.f b/slatec/du11ls.f deleted file mode 100644 index 3bc2146..0000000 --- a/slatec/du11ls.f +++ /dev/null @@ -1,296 +0,0 @@ -*DECK DU11LS - SUBROUTINE DU11LS (A, MDA, M, N, UB, DB, MODE, NP, KRANK, KSURE, - + H, W, EB, IC, IR) -C***BEGIN PROLOGUE DU11LS -C***SUBSIDIARY -C***PURPOSE Subsidiary to DLLSIA -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (U11LS-S, DU11LS-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C **** Double Precision version of U11LS **** -C -C This routine performs a QR factorization of A -C using Householder transformations. Row and -C column pivots are chosen to reduce the growth -C of round-off and to help detect possible rank -C deficiency. -C -C***SEE ALSO DLLSIA -C***ROUTINES CALLED DAXPY, DDOT, DNRM2, DSCAL, DSWAP, IDAMAX, ISWAP, -C XERMSG -C***REVISION HISTORY (YYMMDD) -C 810801 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891009 Removed unreferenced variable. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DU11LS - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DOUBLE PRECISION DDOT,DNRM2 - DIMENSION A(MDA,*),UB(*),DB(*),H(*),W(*),EB(*) - INTEGER IC(*),IR(*) -C -C INITIALIZATION -C -C***FIRST EXECUTABLE STATEMENT DU11LS - J=0 - KRANK=N - DO 10 I=1,N - IC(I)=I - 10 CONTINUE - DO 12 I=1,M - IR(I)=I - 12 CONTINUE -C -C DETERMINE REL AND ABS ERROR VECTORS -C -C -C -C CALCULATE COL LENGTH -C - DO 30 I=1,N - H(I)=DNRM2(M,A(1,I),1) - W(I)=H(I) - 30 CONTINUE -C -C INITIALIZE ERROR BOUNDS -C - DO 40 I=1,N - EB(I)=MAX(DB(I),UB(I)*H(I)) - UB(I)=EB(I) - DB(I)=0.0D0 - 40 CONTINUE -C -C DISCARD SELF DEPENDENT COLUMNS -C - I=1 - 50 IF(EB(I).GE.H(I)) GO TO 60 - IF(I.EQ.KRANK) GO TO 70 - I=I+1 - GO TO 50 -C -C MATRIX REDUCTION -C - 60 CONTINUE - KK=KRANK - KRANK=KRANK-1 - IF(MODE.EQ.0) RETURN - IF(I.GT.NP) GO TO 64 - CALL XERMSG ('SLATEC', 'DU11LS', - + 'FIRST NP COLUMNS ARE LINEARLY DEPENDENT', 8, 0) - KRANK=I-1 - RETURN - 64 CONTINUE - IF(I.GT.KRANK) GO TO 70 - CALL DSWAP(1,EB(I),1,EB(KK),1) - CALL DSWAP(1,UB(I),1,UB(KK),1) - CALL DSWAP(1,W(I),1,W(KK),1) - CALL DSWAP(1,H(I),1,H(KK),1) - CALL ISWAP(1,IC(I),1,IC(KK),1) - CALL DSWAP(M,A(1,I),1,A(1,KK),1) - GO TO 50 -C -C TEST FOR ZERO RANK -C - 70 IF(KRANK.GT.0) GO TO 80 - KRANK=0 - KSURE=0 - RETURN - 80 CONTINUE -C -C M A I N L O O P -C - 110 CONTINUE - J=J+1 - JP1=J+1 - JM1=J-1 - KZ=KRANK - IF(J.LE.NP) KZ=J -C -C EACH COL HAS MM=M-J+1 COMPONENTS -C - MM=M-J+1 -C -C UB DETERMINES COLUMN PIVOT -C - 115 IMIN=J - IF(H(J).EQ.0.D0) GO TO 170 - RMIN=UB(J)/H(J) - DO 120 I=J,KZ - IF(UB(I).GE.H(I)*RMIN) GO TO 120 - RMIN=UB(I)/H(I) - IMIN=I - 120 CONTINUE -C -C TEST FOR RANK DEFICIENCY -C - IF(RMIN.LT.1.0D0) GO TO 200 - TT=(EB(IMIN)+ABS(DB(IMIN)))/H(IMIN) - IF(TT.GE.1.0D0) GO TO 170 -C COMPUTE EXACT UB - DO 125 I=1,JM1 - W(I)=A(I,IMIN) - 125 CONTINUE - L=JM1 - 130 W(L)=W(L)/A(L,L) - IF(L.EQ.1) GO TO 150 - LM1=L-1 - DO 140 I=L,JM1 - W(LM1)=W(LM1)-A(LM1,I)*W(I) - 140 CONTINUE - L=LM1 - GO TO 130 - 150 TT=EB(IMIN) - DO 160 I=1,JM1 - TT=TT+ABS(W(I))*EB(I) - 160 CONTINUE - UB(IMIN)=TT - IF(UB(IMIN)/H(IMIN).GE.1.0D0) GO TO 170 - GO TO 200 -C -C MATRIX REDUCTION -C - 170 CONTINUE - KK=KRANK - KRANK=KRANK-1 - KZ=KRANK - IF(MODE.EQ.0) RETURN - IF(J.GT.NP) GO TO 172 - CALL XERMSG ('SLATEC', 'DU11LS', - + 'FIRST NP COLUMNS ARE LINEARLY DEPENDENT', 8, 0) - KRANK=J-1 - RETURN - 172 CONTINUE - IF(IMIN.GT.KRANK) GO TO 180 - CALL ISWAP(1,IC(IMIN),1,IC(KK),1) - CALL DSWAP(M,A(1,IMIN),1,A(1,KK),1) - CALL DSWAP(1,EB(IMIN),1,EB(KK),1) - CALL DSWAP(1,UB(IMIN),1,UB(KK),1) - CALL DSWAP(1,DB(IMIN),1,DB(KK),1) - CALL DSWAP(1,W(IMIN),1,W(KK),1) - CALL DSWAP(1,H(IMIN),1,H(KK),1) - 180 IF(J.GT.KRANK) GO TO 300 - GO TO 115 -C -C COLUMN PIVOT -C - 200 IF(IMIN.EQ.J) GO TO 230 - CALL DSWAP(1,H(J),1,H(IMIN),1) - CALL DSWAP(M,A(1,J),1,A(1,IMIN),1) - CALL DSWAP(1,EB(J),1,EB(IMIN),1) - CALL DSWAP(1,UB(J),1,UB(IMIN),1) - CALL DSWAP(1,DB(J),1,DB(IMIN),1) - CALL DSWAP(1,W(J),1,W(IMIN),1) - CALL ISWAP(1,IC(J),1,IC(IMIN),1) -C -C ROW PIVOT -C - 230 CONTINUE - JMAX=IDAMAX(MM,A(J,J),1) - JMAX=JMAX+J-1 - IF(JMAX.EQ.J) GO TO 240 - CALL DSWAP(N,A(J,1),MDA,A(JMAX,1),MDA) - CALL ISWAP(1,IR(J),1,IR(JMAX),1) - 240 CONTINUE -C -C APPLY HOUSEHOLDER TRANSFORMATION -C - TN=DNRM2(MM,A(J,J),1) - IF(TN.EQ.0.0D0) GO TO 170 - IF(A(J,J).NE.0.0D0) TN=SIGN(TN,A(J,J)) - CALL DSCAL(MM,1.0D0/TN,A(J,J),1) - A(J,J)=A(J,J)+1.0D0 - IF(J.EQ.N) GO TO 250 - DO 248 I=JP1,N - BB=-DDOT(MM,A(J,J),1,A(J,I),1)/A(J,J) - CALL DAXPY(MM,BB,A(J,J),1,A(J,I),1) - IF(I.LE.NP) GO TO 248 - IF(H(I).EQ.0.0D0) GO TO 248 - TT=1.0D0-(ABS(A(J,I))/H(I))**2 - TT=MAX(TT,0.0D0) - T=TT - TT=1.0D0+.05D0*TT*(H(I)/W(I))**2 - IF(TT.EQ.1.0D0) GO TO 244 - H(I)=H(I)*SQRT(T) - GO TO 246 - 244 CONTINUE - H(I)=DNRM2(M-J,A(J+1,I),1) - W(I)=H(I) - 246 CONTINUE - 248 CONTINUE - 250 CONTINUE - H(J)=A(J,J) - A(J,J)=-TN -C -C -C UPDATE UB, DB -C - UB(J)=UB(J)/ABS(A(J,J)) - DB(J)=(SIGN(EB(J),DB(J))+DB(J))/A(J,J) - IF(J.EQ.KRANK) GO TO 300 - DO 260 I=JP1,KRANK - UB(I)=UB(I)+ABS(A(J,I))*UB(J) - DB(I)=DB(I)-A(J,I)*DB(J) - 260 CONTINUE - GO TO 110 -C -C E N D M A I N L O O P -C - 300 CONTINUE -C -C COMPUTE KSURE -C - KM1=KRANK-1 - DO 318 I=1,KM1 - IS=0 - KMI=KRANK-I - DO 315 II=1,KMI - IF(UB(II).LE.UB(II+1)) GO TO 315 - IS=1 - TEMP=UB(II) - UB(II)=UB(II+1) - UB(II+1)=TEMP - 315 CONTINUE - IF(IS.EQ.0) GO TO 320 - 318 CONTINUE - 320 CONTINUE - KSURE=0 - SUM=0.0D0 - DO 328 I=1,KRANK - R2=UB(I)*UB(I) - IF(R2+SUM.GE.1.0D0) GO TO 330 - SUM=SUM+R2 - KSURE=KSURE+1 - 328 CONTINUE - 330 CONTINUE -C -C IF SYSTEM IS OF REDUCED RANK AND MODE = 2 -C COMPLETE THE DECOMPOSITION FOR SHORTEST LEAST SQUARES SOLUTION -C - IF(KRANK.EQ.N .OR. MODE.LT.2) GO TO 360 - NMK=N-KRANK - KP1=KRANK+1 - I=KRANK - 340 TN=DNRM2(NMK,A(I,KP1),MDA)/A(I,I) - TN=A(I,I)*SQRT(1.0D0+TN*TN) - CALL DSCAL(NMK,1.0D0/TN,A(I,KP1),MDA) - W(I)=A(I,I)/TN+1.0D0 - A(I,I)=-TN - IF(I.EQ.1) GO TO 350 - IM1=I-1 - DO 345 II=1,IM1 - TT=-DDOT(NMK,A(II,KP1),MDA,A(I,KP1),MDA)/W(I) - TT=TT-A(II,I) - CALL DAXPY(NMK,TT,A(I,KP1),MDA,A(II,KP1),MDA) - A(II,I)=A(II,I)+TT*W(I) - 345 CONTINUE - I=I-1 - GO TO 340 - 350 CONTINUE - 360 CONTINUE - RETURN - END diff --git a/slatec/du11us.f b/slatec/du11us.f deleted file mode 100644 index 1efadbd..0000000 --- a/slatec/du11us.f +++ /dev/null @@ -1,293 +0,0 @@ -*DECK DU11US - SUBROUTINE DU11US (A, MDA, M, N, UB, DB, MODE, NP, KRANK, KSURE, - + H, W, EB, IR, IC) -C***BEGIN PROLOGUE DU11US -C***SUBSIDIARY -C***PURPOSE Subsidiary to DULSIA -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (U11US-S, DU11US-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This routine performs an LQ factorization of the -C matrix A using Householder transformations. Row -C and column pivots are chosen to reduce the growth -C of round-off and to help detect possible rank -C deficiency. -C -C***SEE ALSO DULSIA -C***ROUTINES CALLED DAXPY, DDOT, DNRM2, DSCAL, DSWAP, IDAMAX, ISWAP, -C XERMSG -C***REVISION HISTORY (YYMMDD) -C 810801 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DU11US - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DOUBLE PRECISION DDOT,DNRM2 - DIMENSION A(MDA,*),UB(*),DB(*),H(*),W(*),EB(*) - INTEGER IC(*),IR(*) -C -C INITIALIZATION -C -C***FIRST EXECUTABLE STATEMENT DU11US - J=0 - KRANK=M - DO 10 I=1,N - IC(I)=I - 10 CONTINUE - DO 12 I=1,M - IR(I)=I - 12 CONTINUE -C -C DETERMINE REL AND ABS ERROR VECTORS -C -C -C -C CALCULATE ROW LENGTH -C - DO 30 I=1,M - H(I)=DNRM2(N,A(I,1),MDA) - W(I)=H(I) - 30 CONTINUE -C -C INITIALIZE ERROR BOUNDS -C - DO 40 I=1,M - EB(I)=MAX(DB(I),UB(I)*H(I)) - UB(I)=EB(I) - DB(I)=0.0D0 - 40 CONTINUE -C -C DISCARD SELF DEPENDENT ROWS -C - I=1 - 50 IF(EB(I).GE.H(I)) GO TO 60 - IF(I.EQ.KRANK) GO TO 70 - I=I+1 - GO TO 50 -C -C MATRIX REDUCTION -C - 60 CONTINUE - KK=KRANK - KRANK=KRANK-1 - IF(MODE.EQ.0) RETURN - IF(I.GT.NP) GO TO 64 - CALL XERMSG ('SLATEC', 'DU11US', - + 'FIRST NP ROWS ARE LINEARLY DEPENDENT', 8, 0) - KRANK=I-1 - RETURN - 64 CONTINUE - IF(I.GT.KRANK) GO TO 70 - CALL DSWAP(1,EB(I),1,EB(KK),1) - CALL DSWAP(1,UB(I),1,UB(KK),1) - CALL DSWAP(1,W(I),1,W(KK),1) - CALL DSWAP(1,H(I),1,H(KK),1) - CALL ISWAP(1,IR(I),1,IR(KK),1) - CALL DSWAP(N,A(I,1),MDA,A(KK,1),MDA) - GO TO 50 -C -C TEST FOR ZERO RANK -C - 70 IF(KRANK.GT.0) GO TO 80 - KRANK=0 - KSURE=0 - RETURN - 80 CONTINUE -C -C M A I N L O O P -C - 110 CONTINUE - J=J+1 - JP1=J+1 - JM1=J-1 - KZ=KRANK - IF(J.LE.NP) KZ=J -C -C EACH ROW HAS NN=N-J+1 COMPONENTS -C - NN=N-J+1 -C -C UB DETERMINES ROW PIVOT -C - 115 IMIN=J - IF(H(J).EQ.0.D0) GO TO 170 - RMIN=UB(J)/H(J) - DO 120 I=J,KZ - IF(UB(I).GE.H(I)*RMIN) GO TO 120 - RMIN=UB(I)/H(I) - IMIN=I - 120 CONTINUE -C -C TEST FOR RANK DEFICIENCY -C - IF(RMIN.LT.1.0D0) GO TO 200 - TT=(EB(IMIN)+ABS(DB(IMIN)))/H(IMIN) - IF(TT.GE.1.0D0) GO TO 170 -C COMPUTE EXACT UB - DO 125 I=1,JM1 - W(I)=A(IMIN,I) - 125 CONTINUE - L=JM1 - 130 W(L)=W(L)/A(L,L) - IF(L.EQ.1) GO TO 150 - LM1=L-1 - DO 140 I=L,JM1 - W(LM1)=W(LM1)-A(I,LM1)*W(I) - 140 CONTINUE - L=LM1 - GO TO 130 - 150 TT=EB(IMIN) - DO 160 I=1,JM1 - TT=TT+ABS(W(I))*EB(I) - 160 CONTINUE - UB(IMIN)=TT - IF(UB(IMIN)/H(IMIN).GE.1.0D0) GO TO 170 - GO TO 200 -C -C MATRIX REDUCTION -C - 170 CONTINUE - KK=KRANK - KRANK=KRANK-1 - KZ=KRANK - IF(MODE.EQ.0) RETURN - IF(J.GT.NP) GO TO 172 - CALL XERMSG ('SLATEC', 'DU11US', - + 'FIRST NP ROWS ARE LINEARLY DEPENDENT', 8, 0) - KRANK=J-1 - RETURN - 172 CONTINUE - IF(IMIN.GT.KRANK) GO TO 180 - CALL ISWAP(1,IR(IMIN),1,IR(KK),1) - CALL DSWAP(N,A(IMIN,1),MDA,A(KK,1),MDA) - CALL DSWAP(1,EB(IMIN),1,EB(KK),1) - CALL DSWAP(1,UB(IMIN),1,UB(KK),1) - CALL DSWAP(1,DB(IMIN),1,DB(KK),1) - CALL DSWAP(1,W(IMIN),1,W(KK),1) - CALL DSWAP(1,H(IMIN),1,H(KK),1) - 180 IF(J.GT.KRANK) GO TO 300 - GO TO 115 -C -C ROW PIVOT -C - 200 IF(IMIN.EQ.J) GO TO 230 - CALL DSWAP(1,H(J),1,H(IMIN),1) - CALL DSWAP(N,A(J,1),MDA,A(IMIN,1),MDA) - CALL DSWAP(1,EB(J),1,EB(IMIN),1) - CALL DSWAP(1,UB(J),1,UB(IMIN),1) - CALL DSWAP(1,DB(J),1,DB(IMIN),1) - CALL DSWAP(1,W(J),1,W(IMIN),1) - CALL ISWAP(1,IR(J),1,IR(IMIN),1) -C -C COLUMN PIVOT -C - 230 CONTINUE - JMAX=IDAMAX(NN,A(J,J),MDA) - JMAX=JMAX+J-1 - IF(JMAX.EQ.J) GO TO 240 - CALL DSWAP(M,A(1,J),1,A(1,JMAX),1) - CALL ISWAP(1,IC(J),1,IC(JMAX),1) - 240 CONTINUE -C -C APPLY HOUSEHOLDER TRANSFORMATION -C - TN=DNRM2(NN,A(J,J),MDA) - IF(TN.EQ.0.0D0) GO TO 170 - IF(A(J,J).NE.0.0D0) TN=SIGN(TN,A(J,J)) - CALL DSCAL(NN,1.0D0/TN,A(J,J),MDA) - A(J,J)=A(J,J)+1.0D0 - IF(J.EQ.M) GO TO 250 - DO 248 I=JP1,M - BB=-DDOT(NN,A(J,J),MDA,A(I,J),MDA)/A(J,J) - CALL DAXPY(NN,BB,A(J,J),MDA,A(I,J),MDA) - IF(I.LE.NP) GO TO 248 - IF(H(I).EQ.0.0D0) GO TO 248 - TT=1.0D0-(ABS(A(I,J))/H(I))**2 - TT=MAX(TT,0.0D0) - T=TT - TT=1.0D0+.05D0*TT*(H(I)/W(I))**2 - IF(TT.EQ.1.0D0) GO TO 244 - H(I)=H(I)*SQRT(T) - GO TO 246 - 244 CONTINUE - H(I)=DNRM2(N-J,A(I,J+1),MDA) - W(I)=H(I) - 246 CONTINUE - 248 CONTINUE - 250 CONTINUE - H(J)=A(J,J) - A(J,J)=-TN -C -C -C UPDATE UB, DB -C - UB(J)=UB(J)/ABS(A(J,J)) - DB(J)=(SIGN(EB(J),DB(J))+DB(J))/A(J,J) - IF(J.EQ.KRANK) GO TO 300 - DO 260 I=JP1,KRANK - UB(I)=UB(I)+ABS(A(I,J))*UB(J) - DB(I)=DB(I)-A(I,J)*DB(J) - 260 CONTINUE - GO TO 110 -C -C E N D M A I N L O O P -C - 300 CONTINUE -C -C COMPUTE KSURE -C - KM1=KRANK-1 - DO 318 I=1,KM1 - IS=0 - KMI=KRANK-I - DO 315 II=1,KMI - IF(UB(II).LE.UB(II+1)) GO TO 315 - IS=1 - TEMP=UB(II) - UB(II)=UB(II+1) - UB(II+1)=TEMP - 315 CONTINUE - IF(IS.EQ.0) GO TO 320 - 318 CONTINUE - 320 CONTINUE - KSURE=0 - SUM=0.0D0 - DO 328 I=1,KRANK - R2=UB(I)*UB(I) - IF(R2+SUM.GE.1.0D0) GO TO 330 - SUM=SUM+R2 - KSURE=KSURE+1 - 328 CONTINUE - 330 CONTINUE -C -C IF SYSTEM IS OF REDUCED RANK AND MODE = 2 -C COMPLETE THE DECOMPOSITION FOR SHORTEST LEAST SQUARES SOLUTION -C - IF(KRANK.EQ.M .OR. MODE.LT.2) GO TO 360 - MMK=M-KRANK - KP1=KRANK+1 - I=KRANK - 340 TN=DNRM2(MMK,A(KP1,I),1)/A(I,I) - TN=A(I,I)*SQRT(1.0D0+TN*TN) - CALL DSCAL(MMK,1.0D0/TN,A(KP1,I),1) - W(I)=A(I,I)/TN+1.0D0 - A(I,I)=-TN - IF(I.EQ.1) GO TO 350 - IM1=I-1 - DO 345 II=1,IM1 - TT=-DDOT(MMK,A(KP1,II),1,A(KP1,I),1)/W(I) - TT=TT-A(I,II) - CALL DAXPY(MMK,TT,A(KP1,I),1,A(KP1,II),1) - A(I,II)=A(I,II)+TT*W(I) - 345 CONTINUE - I=I-1 - GO TO 340 - 350 CONTINUE - 360 CONTINUE - RETURN - END diff --git a/slatec/du12ls.f b/slatec/du12ls.f deleted file mode 100644 index ee34d5d..0000000 --- a/slatec/du12ls.f +++ /dev/null @@ -1,159 +0,0 @@ -*DECK DU12LS - SUBROUTINE DU12LS (A, MDA, M, N, B, MDB, NB, MODE, KRANK, RNORM, - + H, W, IC, IR) -C***BEGIN PROLOGUE DU12LS -C***SUBSIDIARY -C***PURPOSE Subsidiary to DLLSIA -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (U12LS-S, DU12LS-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Given the Householder QR factorization of A, this -C subroutine solves the system AX=B. If the system -C is of reduced rank, this routine returns a solution -C according to the selected mode. -C -C Note - If MODE.NE.2, W is never accessed. -C -C***SEE ALSO DLLSIA -C***ROUTINES CALLED DAXPY, DDOT, DNRM2, DSWAP -C***REVISION HISTORY (YYMMDD) -C 810801 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DU12LS - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DOUBLE PRECISION DDOT,DNRM2 - DIMENSION A(MDA,*),B(MDB,*),RNORM(*),H(*),W(*) - INTEGER IC(*),IR(*) -C***FIRST EXECUTABLE STATEMENT DU12LS - K=KRANK - KP1=K+1 -C -C RANK=0 -C - IF(K.GT.0) GO TO 410 - DO 404 JB=1,NB - RNORM(JB)=DNRM2(M,B(1,JB),1) - 404 CONTINUE - DO 406 JB=1,NB - DO 406 I=1,N - B(I,JB)=0.0D0 - 406 CONTINUE - RETURN -C -C REORDER B TO REFLECT ROW INTERCHANGES -C - 410 CONTINUE - I=0 - 412 I=I+1 - IF(I.EQ.M) GO TO 418 - J=IR(I) - IF(J.EQ.I) GO TO 412 - IF(J.LT.0) GO TO 412 - IR(I)=-IR(I) - DO 413 JB=1,NB - RNORM(JB)=B(I,JB) - 413 CONTINUE - IJ=I - 414 DO 415 JB=1,NB - B(IJ,JB)=B(J,JB) - 415 CONTINUE - IJ=J - J=IR(IJ) - IR(IJ)=-IR(IJ) - IF(J.NE.I) GO TO 414 - DO 416 JB=1,NB - B(IJ,JB)=RNORM(JB) - 416 CONTINUE - GO TO 412 - 418 CONTINUE - DO 420 I=1,M - IR(I)=ABS(IR(I)) - 420 CONTINUE -C -C APPLY HOUSEHOLDER TRANSFORMATIONS TO B -C - DO 430 J=1,K - TT=A(J,J) - A(J,J)=H(J) - DO 425 I=1,NB - BB=-DDOT(M-J+1,A(J,J),1,B(J,I),1)/H(J) - CALL DAXPY(M-J+1,BB,A(J,J),1,B(J,I),1) - 425 CONTINUE - A(J,J)=TT - 430 CONTINUE -C -C FIND NORMS OF RESIDUAL VECTOR(S)..(BEFORE OVERWRITE B) -C - DO 440 JB=1,NB - RNORM(JB)=DNRM2((M-K),B(KP1,JB),1) - 440 CONTINUE -C -C BACK SOLVE UPPER TRIANGULAR R -C - I=K - 442 DO 444 JB=1,NB - B(I,JB)=B(I,JB)/A(I,I) - 444 CONTINUE - IF(I.EQ.1) GO TO 450 - IM1=I-1 - DO 448 JB=1,NB - CALL DAXPY(IM1,-B(I,JB),A(1,I),1,B(1,JB),1) - 448 CONTINUE - I=IM1 - GO TO 442 - 450 CONTINUE -C -C RANK LT N -C -C TRUNCATED SOLUTION -C - IF(K.EQ.N) GO TO 480 - DO 460 JB=1,NB - DO 460 I=KP1,N - B(I,JB)=0.0D0 - 460 CONTINUE - IF(MODE.EQ.1) GO TO 480 -C -C MINIMAL LENGTH SOLUTION -C - NMK=N-K - DO 470 JB=1,NB - DO 465 I=1,K - TT=-DDOT(NMK,A(I,KP1),MDA,B(KP1,JB),1)/W(I) - TT=TT-B(I,JB) - CALL DAXPY(NMK,TT,A(I,KP1),MDA,B(KP1,JB),1) - B(I,JB)=B(I,JB)+TT*W(I) - 465 CONTINUE - 470 CONTINUE -C -C -C REORDER B TO REFLECT COLUMN INTERCHANGES -C - 480 CONTINUE - I=0 - 482 I=I+1 - IF(I.EQ.N) GO TO 488 - J=IC(I) - IF(J.EQ.I) GO TO 482 - IF(J.LT.0) GO TO 482 - IC(I)=-IC(I) - 484 CALL DSWAP(NB,B(J,1),MDB,B(I,1),MDB) - IJ=IC(J) - IC(J)=-IC(J) - J=IJ - IF(J.EQ.I) GO TO 482 - GO TO 484 - 488 CONTINUE - DO 490 I=1,N - IC(I)=ABS(IC(I)) - 490 CONTINUE -C -C SOLUTION VECTORS ARE IN FIRST N ROWS OF B(,) -C - RETURN - END diff --git a/slatec/du12us.f b/slatec/du12us.f deleted file mode 100644 index def9693..0000000 --- a/slatec/du12us.f +++ /dev/null @@ -1,156 +0,0 @@ -*DECK DU12US - SUBROUTINE DU12US (A, MDA, M, N, B, MDB, NB, MODE, KRANK, RNORM, - + H, W, IR, IC) -C***BEGIN PROLOGUE DU12US -C***SUBSIDIARY -C***PURPOSE Subsidiary to DULSIA -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (U12US-S, DU12US-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Given the Householder LQ factorization of A, this -C subroutine solves the system AX=B. If the system -C is of reduced rank, this routine returns a solution -C according to the selected mode. -C -C Note - If MODE.NE.2, W is never accessed. -C -C***SEE ALSO DULSIA -C***ROUTINES CALLED DAXPY, DDOT, DNRM2, DSWAP -C***REVISION HISTORY (YYMMDD) -C 810801 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DU12US - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DOUBLE PRECISION DDOT,DNRM2 - DIMENSION A(MDA,*),B(MDB,*),RNORM(*),H(*),W(*) - INTEGER IC(*),IR(*) -C***FIRST EXECUTABLE STATEMENT DU12US - K=KRANK - KP1=K+1 -C -C RANK=0 -C - IF(K.GT.0) GO TO 410 - DO 404 JB=1,NB - RNORM(JB)=DNRM2(M,B(1,JB),1) - 404 CONTINUE - DO 406 JB=1,NB - DO 406 I=1,N - B(I,JB)=0.0D0 - 406 CONTINUE - RETURN -C -C REORDER B TO REFLECT ROW INTERCHANGES -C - 410 CONTINUE - I=0 - 412 I=I+1 - IF(I.EQ.M) GO TO 418 - J=IR(I) - IF(J.EQ.I) GO TO 412 - IF(J.LT.0) GO TO 412 - IR(I)=-IR(I) - DO 413 JB=1,NB - RNORM(JB)=B(I,JB) - 413 CONTINUE - IJ=I - 414 DO 415 JB=1,NB - B(IJ,JB)=B(J,JB) - 415 CONTINUE - IJ=J - J=IR(IJ) - IR(IJ)=-IR(IJ) - IF(J.NE.I) GO TO 414 - DO 416 JB=1,NB - B(IJ,JB)=RNORM(JB) - 416 CONTINUE - GO TO 412 - 418 CONTINUE - DO 420 I=1,M - IR(I)=ABS(IR(I)) - 420 CONTINUE -C -C IF A IS OF REDUCED RANK AND MODE=2, -C APPLY HOUSEHOLDER TRANSFORMATIONS TO B -C - IF(MODE.LT.2 .OR. K.EQ.M) GO TO 440 - MMK=M-K - DO 430 JB=1,NB - DO 425 J=1,K - I=KP1-J - TT=-DDOT(MMK,A(KP1,I),1,B(KP1,JB),1)/W(I) - TT=TT-B(I,JB) - CALL DAXPY(MMK,TT,A(KP1,I),1,B(KP1,JB),1) - B(I,JB)=B(I,JB)+TT*W(I) - 425 CONTINUE - 430 CONTINUE -C -C FIND NORMS OF RESIDUAL VECTOR(S)..(BEFORE OVERWRITE B) -C - 440 DO 442 JB=1,NB - RNORM(JB)=DNRM2((M-K),B(KP1,JB),1) - 442 CONTINUE -C -C BACK SOLVE LOWER TRIANGULAR L -C - DO 450 JB=1,NB - DO 448 I=1,K - B(I,JB)=B(I,JB)/A(I,I) - IF(I.EQ.K) GO TO 450 - IP1=I+1 - CALL DAXPY(K-I,-B(I,JB),A(IP1,I),1,B(IP1,JB),1) - 448 CONTINUE - 450 CONTINUE -C -C -C TRUNCATED SOLUTION -C - IF(K.EQ.N) GO TO 462 - DO 460 JB=1,NB - DO 460 I=KP1,N - B(I,JB)=0.0D0 - 460 CONTINUE -C -C APPLY HOUSEHOLDER TRANSFORMATIONS TO B -C - 462 DO 470 I=1,K - J=KP1-I - TT=A(J,J) - A(J,J)=H(J) - DO 465 JB=1,NB - BB=-DDOT(N-J+1,A(J,J),MDA,B(J,JB),1)/H(J) - CALL DAXPY(N-J+1,BB,A(J,J),MDA,B(J,JB),1) - 465 CONTINUE - A(J,J)=TT - 470 CONTINUE -C -C -C REORDER B TO REFLECT COLUMN INTERCHANGES -C - I=0 - 482 I=I+1 - IF(I.EQ.N) GO TO 488 - J=IC(I) - IF(J.EQ.I) GO TO 482 - IF(J.LT.0) GO TO 482 - IC(I)=-IC(I) - 484 CALL DSWAP(NB,B(J,1),MDB,B(I,1),MDB) - IJ=IC(J) - IC(J)=-IC(J) - J=IJ - IF(J.EQ.I) GO TO 482 - GO TO 484 - 488 CONTINUE - DO 490 I=1,N - IC(I)=ABS(IC(I)) - 490 CONTINUE -C -C SOLUTION VECTORS ARE IN FIRST N ROWS OF B(,) -C - RETURN - END diff --git a/slatec/dulsia.f b/slatec/dulsia.f deleted file mode 100644 index 561bbc8..0000000 --- a/slatec/dulsia.f +++ /dev/null @@ -1,323 +0,0 @@ -*DECK DULSIA - SUBROUTINE DULSIA (A, MDA, M, N, B, MDB, NB, RE, AE, KEY, MODE, - + NP, KRANK, KSURE, RNORM, W, LW, IWORK, LIW, INFO) -C***BEGIN PROLOGUE DULSIA -C***PURPOSE Solve an underdetermined linear system of equations by -C performing an LQ factorization of the matrix using -C Householder transformations. Emphasis is put on detecting -C possible rank deficiency. -C***LIBRARY SLATEC -C***CATEGORY D9 -C***TYPE DOUBLE PRECISION (ULSIA-S, DULSIA-D) -C***KEYWORDS LINEAR LEAST SQUARES, LQ FACTORIZATION, -C UNDERDETERMINED LINEAR SYSTEM -C***AUTHOR Manteuffel, T. A., (LANL) -C***DESCRIPTION -C -C DULSIA computes the minimal length solution(s) to the problem AX=B -C where A is an M by N matrix with M.LE.N and B is the M by NB -C matrix of right hand sides. User input bounds on the uncertainty -C in the elements of A are used to detect numerical rank deficiency. -C The algorithm employs a row and column pivot strategy to -C minimize the growth of uncertainty and round-off errors. -C -C DULSIA requires (MDA+1)*N + (MDB+1)*NB + 6*M dimensioned space -C -C ****************************************************************** -C * * -C * WARNING - All input arrays are changed on exit. * -C * * -C ****************************************************************** -C -C Input.. All TYPE REAL variables are DOUBLE PRECISION -C -C A(,) Linear coefficient matrix of AX=B, with MDA the -C MDA,M,N actual first dimension of A in the calling program. -C M is the row dimension (no. of EQUATIONS of the -C problem) and N the col dimension (no. of UNKNOWNS). -C Must have MDA.GE.M and M.LE.N. -C -C B(,) Right hand side(s), with MDB the actual first -C MDB,NB dimension of B in the calling program. NB is the -C number of M by 1 right hand sides. Since the -C solution is returned in B, must have MDB.GE.N. If -C NB = 0, B is never accessed. -C -C ****************************************************************** -C * * -C * Note - Use of RE and AE are what make this * -C * code significantly different from * -C * other linear least squares solvers. * -C * However, the inexperienced user is * -C * advised to set RE=0.,AE=0.,KEY=0. * -C * * -C ****************************************************************** -C -C RE(),AE(),KEY -C RE() RE() is a vector of length N such that RE(I) is -C the maximum relative uncertainty in row I of -C the matrix A. The values of RE() must be between -C 0 and 1. A minimum of 10*machine precision will -C be enforced. -C -C AE() AE() is a vector of length N such that AE(I) is -C the maximum absolute uncertainty in row I of -C the matrix A. The values of AE() must be greater -C than or equal to 0. -C -C KEY For ease of use, RE and AE may be input as either -C vectors or scalars. If a scalar is input, the algo- -C rithm will use that value for each column of A. -C The parameter KEY indicates whether scalars or -C vectors are being input. -C KEY=0 RE scalar AE scalar -C KEY=1 RE vector AE scalar -C KEY=2 RE scalar AE vector -C KEY=3 RE vector AE vector -C -C -C MODE The integer MODE indicates how the routine -C is to react if rank deficiency is detected. -C If MODE = 0 return immediately, no solution -C 1 compute truncated solution -C 2 compute minimal length least squares sol -C The inexperienced user is advised to set MODE=0 -C -C NP The first NP rows of A will not be interchanged -C with other rows even though the pivot strategy -C would suggest otherwise. -C The inexperienced user is advised to set NP=0. -C -C WORK() A real work array dimensioned 5*M. However, if -C RE or AE have been specified as vectors, dimension -C WORK 4*M. If both RE and AE have been specified -C as vectors, dimension WORK 3*M. -C -C LW Actual dimension of WORK -C -C IWORK() Integer work array dimensioned at least N+M. -C -C LIW Actual dimension of IWORK. -C -C -C INFO Is a flag which provides for the efficient -C solution of subsequent problems involving the -C same A but different B. -C If INFO = 0 original call -C INFO = 1 subsequent calls -C On subsequent calls, the user must supply A, KRANK, -C LW, IWORK, LIW, and the first 2*M locations of WORK -C as output by the original call to DULSIA. MODE must -C be equal to the value of MODE in the original call. -C If MODE.LT.2, only the first N locations of WORK -C are accessed. AE, RE, KEY, and NP are not accessed. -C -C -C -C -C Output..All TYPE REAL variables are DOUBLE PRECISION -C -C A(,) Contains the lower triangular part of the reduced -C matrix and the transformation information. It togeth -C with the first M elements of WORK (see below) -C completely specify the LQ factorization of A. -C -C B(,) Contains the N by NB solution matrix for X. -C -C KRANK,KSURE The numerical rank of A, based upon the relative -C and absolute bounds on uncertainty, is bounded -C above by KRANK and below by KSURE. The algorithm -C returns a solution based on KRANK. KSURE provides -C an indication of the precision of the rank. -C -C RNORM() Contains the Euclidean length of the NB residual -C vectors B(I)-AX(I), I=1,NB. If the matrix A is of -C full rank, then RNORM=0.0. -C -C WORK() The first M locations of WORK contain values -C necessary to reproduce the Householder -C transformation. -C -C IWORK() The first N locations contain the order in -C which the columns of A were used. The next -C M locations contain the order in which the -C rows of A were used. -C -C INFO Flag to indicate status of computation on completion -C -1 Parameter error(s) -C 0 - Rank deficient, no solution -C 1 - Rank deficient, truncated solution -C 2 - Rank deficient, minimal length least squares sol -C 3 - Numerical rank 0, zero solution -C 4 - Rank .LT. NP -C 5 - Full rank -C -C***REFERENCES T. Manteuffel, An interval analysis approach to rank -C determination in linear least squares problems, -C Report SAND80-0655, Sandia Laboratories, June 1980. -C***ROUTINES CALLED D1MACH, DU11US, DU12US, XERMSG -C***REVISION HISTORY (YYMMDD) -C 810801 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891006 Cosmetic changes to prologue. (WRB) -C 891009 Removed unreferenced variable. (WRB) -C 891009 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 Fixed an error message. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DULSIA - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DOUBLE PRECISION D1MACH - DIMENSION A(MDA,*),B(MDB,*),RE(*),AE(*),RNORM(*),W(*) - INTEGER IWORK(*) -C -C***FIRST EXECUTABLE STATEMENT DULSIA - IF(INFO.LT.0 .OR. INFO.GT.1) GO TO 514 - IT=INFO - INFO=-1 - IF(NB.EQ.0 .AND. IT.EQ.1) GO TO 501 - IF(M.LT.1) GO TO 502 - IF(N.LT.1) GO TO 503 - IF(N.LT.M) GO TO 504 - IF(MDA.LT.M) GO TO 505 - IF(LIW.LT.M+N) GO TO 506 - IF(MODE.LT.0 .OR. MODE.GT.3) GO TO 515 - IF(NB.EQ.0) GO TO 4 - IF(NB.LT.0) GO TO 507 - IF(MDB.LT.N) GO TO 508 - IF(IT.EQ.0) GO TO 4 - GO TO 400 - 4 IF(KEY.LT.0.OR.KEY.GT.3) GO TO 509 - IF(KEY.EQ.0 .AND. LW.LT.5*M) GO TO 510 - IF(KEY.EQ.1 .AND. LW.LT.4*M) GO TO 510 - IF(KEY.EQ.2 .AND. LW.LT.4*M) GO TO 510 - IF(KEY.EQ.3 .AND. LW.LT.3*M) GO TO 510 - IF(NP.LT.0 .OR. NP.GT.M) GO TO 516 -C - EPS=10.*D1MACH(3) - M1=1 - M2=M1+M - M3=M2+M - M4=M3+M - M5=M4+M -C - IF(KEY.EQ.1) GO TO 100 - IF(KEY.EQ.2) GO TO 200 - IF(KEY.EQ.3) GO TO 300 -C - IF(RE(1).LT.0.D00) GO TO 511 - IF(RE(1).GT.1.0D0) GO TO 512 - IF(RE(1).LT.EPS) RE(1)=EPS - IF(AE(1).LT.0.0D0) GO TO 513 - DO 20 I=1,M - W(M4-1+I)=RE(1) - W(M5-1+I)=AE(1) - 20 CONTINUE - CALL DU11US(A,MDA,M,N,W(M4),W(M5),MODE,NP,KRANK,KSURE, - 1 W(M1),W(M2),W(M3),IWORK(M1),IWORK(M2)) - GO TO 400 -C - 100 CONTINUE - IF(AE(1).LT.0.0D0) GO TO 513 - DO 120 I=1,M - IF(RE(I).LT.0.0D0) GO TO 511 - IF(RE(I).GT.1.0D0) GO TO 512 - IF(RE(I).LT.EPS) RE(I)=EPS - W(M4-1+I)=AE(1) - 120 CONTINUE - CALL DU11US(A,MDA,M,N,RE,W(M4),MODE,NP,KRANK,KSURE, - 1 W(M1),W(M2),W(M3),IWORK(M1),IWORK(M2)) - GO TO 400 -C - 200 CONTINUE - IF(RE(1).LT.0.0D0) GO TO 511 - IF(RE(1).GT.1.0D0) GO TO 512 - IF(RE(1).LT.EPS) RE(1)=EPS - DO 220 I=1,M - W(M4-1+I)=RE(1) - IF(AE(I).LT.0.0D0) GO TO 513 - 220 CONTINUE - CALL DU11US(A,MDA,M,N,W(M4),AE,MODE,NP,KRANK,KSURE, - 1 W(M1),W(M2),W(M3),IWORK(M1),IWORK(M2)) - GO TO 400 -C - 300 CONTINUE - DO 320 I=1,M - IF(RE(I).LT.0.0D0) GO TO 511 - IF(RE(I).GT.1.0D0) GO TO 512 - IF(RE(I).LT.EPS) RE(I)=EPS - IF(AE(I).LT.0.0D0) GO TO 513 - 320 CONTINUE - CALL DU11US(A,MDA,M,N,RE,AE,MODE,NP,KRANK,KSURE, - 1 W(M1),W(M2),W(M3),IWORK(M1),IWORK(M2)) -C -C DETERMINE INFO -C - 400 IF(KRANK.NE.M) GO TO 402 - INFO=5 - GO TO 410 - 402 IF(KRANK.NE.0) GO TO 404 - INFO=3 - GO TO 410 - 404 IF(KRANK.GE.NP) GO TO 406 - INFO=4 - RETURN - 406 INFO=MODE - IF(MODE.EQ.0) RETURN - 410 IF(NB.EQ.0) RETURN -C -C -C SOLUTION PHASE -C - M1=1 - M2=M1+M - M3=M2+M - IF(INFO.EQ.2) GO TO 420 - IF(LW.LT.M2-1) GO TO 510 - CALL DU12US(A,MDA,M,N,B,MDB,NB,MODE,KRANK, - 1 RNORM,W(M1),W(M1),IWORK(M1),IWORK(M2)) - RETURN -C - 420 IF(LW.LT.M3-1) GO TO 510 - CALL DU12US(A,MDA,M,N,B,MDB,NB,MODE,KRANK, - 1 RNORM,W(M1),W(M2),IWORK(M1),IWORK(M2)) - RETURN -C -C ERROR MESSAGES -C - 501 CALL XERMSG ('SLATEC', 'DULSIA', - + 'SOLUTION ONLY (INFO=1) BUT NO RIGHT HAND SIDE (NB=0)', 1, 0) - RETURN - 502 CALL XERMSG ('SLATEC', 'DULSIA', 'M.LT.1', 2, 1) - RETURN - 503 CALL XERMSG ('SLATEC', 'DULSIA', 'N.LT.1', 2, 1) - RETURN - 504 CALL XERMSG ('SLATEC', 'DULSIA', 'N.LT.M', 2, 1) - RETURN - 505 CALL XERMSG ('SLATEC', 'DULSIA', 'MDA.LT.M', 2, 1) - RETURN - 506 CALL XERMSG ('SLATEC', 'DULSIA', 'LIW.LT.M+N', 2, 1) - RETURN - 507 CALL XERMSG ('SLATEC', 'DULSIA', 'NB.LT.0', 2, 1) - RETURN - 508 CALL XERMSG ('SLATEC', 'DULSIA', 'MDB.LT.N', 2, 1) - RETURN - 509 CALL XERMSG ('SLATEC', 'DULSIA', 'KEY OUT OF RANGE', 2, 1) - RETURN - 510 CALL XERMSG ('SLATEC', 'DULSIA', 'INSUFFICIENT WORK SPACE', 8, 1) - INFO=-1 - RETURN - 511 CALL XERMSG ('SLATEC', 'DULSIA', 'RE(I) .LT. 0', 2, 1) - RETURN - 512 CALL XERMSG ('SLATEC', 'DULSIA', 'RE(I) .GT. 1', 2, 1) - RETURN - 513 CALL XERMSG ('SLATEC', 'DULSIA', 'AE(I) .LT. 0', 2, 1) - RETURN - 514 CALL XERMSG ('SLATEC', 'DULSIA', 'INFO OUT OF RANGE', 2, 1) - RETURN - 515 CALL XERMSG ('SLATEC', 'DULSIA', 'MODE OUT OF RANGE', 2, 1) - RETURN - 516 CALL XERMSG ('SLATEC', 'DULSIA', 'NP OUT OF RANGE', 2, 1) - RETURN - END diff --git a/slatec/dusrmt.f b/slatec/dusrmt.f deleted file mode 100644 index 087eef6..0000000 --- a/slatec/dusrmt.f +++ /dev/null @@ -1,70 +0,0 @@ -*DECK DUSRMT - SUBROUTINE DUSRMT (I, J, AIJ, INDCAT, PRGOPT, DATTRV, IFLAG) -C***BEGIN PROLOGUE DUSRMT -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSPLP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (USRMAT-S, DUSRMT-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C The user may supply this code -C -C***SEE ALSO DSPLP -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DUSRMT - DOUBLE PRECISION PRGOPT(*),DATTRV(*),AIJ - INTEGER IFLAG(*) -C -C***FIRST EXECUTABLE STATEMENT DUSRMT - IF(IFLAG(1).EQ.1) THEN -C -C THIS IS THE INITIALIZATION STEP. THE VALUES OF IFLAG(K),K=2,3,4, -C ARE RESPECTIVELY THE COLUMN INDEX, THE ROW INDEX (OR THE NEXT COL. -C INDEX), AND THE POINTER TO THE MATRIX ENTRY'S VALUE WITHIN -C DATTRV(*). ALSO CHECK (DATTRV(1)=0.) SIGNIFYING NO DATA. - IF(DATTRV(1).EQ.0.D0) THEN - I = 0 - J = 0 - IFLAG(1) = 3 - ELSE - IFLAG(2)=-DATTRV(1) - IFLAG(3)= DATTRV(2) - IFLAG(4)= 3 - ENDIF -C - RETURN - ELSE - J=IFLAG(2) - I=IFLAG(3) - L=IFLAG(4) - IF(I.EQ.0) THEN -C -C SIGNAL THAT ALL OF THE NONZERO ENTRIES HAVE BEEN DEFINED. - IFLAG(1)=3 - RETURN - ELSE IF(I.LT.0) THEN -C -C SIGNAL THAT A SWITCH IS MADE TO A NEW COLUMN. - J=-I - I=DATTRV(L) - L=L+1 - ENDIF -C - AIJ=DATTRV(L) -C -C UPDATE THE INDICES AND POINTERS FOR THE NEXT ENTRY. - IFLAG(2)=J - IFLAG(3)=DATTRV(L+1) - IFLAG(4)=L+2 -C -C INDCAT=0 DENOTES THAT ENTRIES OF THE MATRIX ARE ASSIGNED THE -C VALUES FROM DATTRV(*). NO ACCUMULATION IS PERFORMED. - INDCAT=0 - RETURN - ENDIF - END diff --git a/slatec/dvecs.f b/slatec/dvecs.f deleted file mode 100644 index 9771738..0000000 --- a/slatec/dvecs.f +++ /dev/null @@ -1,69 +0,0 @@ -*DECK DVECS - SUBROUTINE DVECS (NCOMP, LNFC, YHP, WORK, IWORK, INHOMO, IFLAG) -C***BEGIN PROLOGUE DVECS -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBVSUP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (SVECS-S, DVECS-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C This subroutine is used for the special structure of COMPLEX*16 -C valued problems. DMGSBV is called upon to obtain LNFC vectors from an -C original set of 2*LNFC independent vectors so that the resulting -C LNFC vectors together with their imaginary product or mate vectors -C form an independent set. -C -C***SEE ALSO DBVSUP -C***ROUTINES CALLED DMGSBV -C***COMMON BLOCKS DML18J -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 890921 Realigned order of variables in certain COMMON blocks. -C (WRB) -C 891009 Removed unreferenced statement label. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DVECS -C - INTEGER ICOCO, IDP, IFLAG, INDPVT, INHOMO, INTEG, IWORK(*), K, - 1 KP, LNFC, LNFCC, MXNON, NCOMP, NDISK, NEQ, NEQIVP, NIC, NIV, - 2 NOPG, NPS, NTAPE, NTP, NUMORT, NXPTS - DOUBLE PRECISION AE, DUM, RE, TOL, WORK(*), YHP(NCOMP,*) - COMMON /DML18J/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ, - 1 INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,LNFCC, - 2 ICOCO -C***FIRST EXECUTABLE STATEMENT DVECS - IF (LNFC .NE. 1) GO TO 20 - DO 10 K = 1, NCOMP - YHP(K,LNFC+1) = YHP(K,LNFCC+1) - 10 CONTINUE - IFLAG = 1 - GO TO 60 - 20 CONTINUE - NIV = LNFC - LNFC = 2*LNFC - LNFCC = 2*LNFCC - KP = LNFC + 2 + LNFCC - IDP = INDPVT - INDPVT = 0 - CALL DMGSBV(NCOMP,LNFC,YHP,NCOMP,NIV,IFLAG,WORK(1),WORK(KP), - 1 IWORK(1),INHOMO,YHP(1,LNFC+1),WORK(LNFC+2),DUM) - LNFC = LNFC/2 - LNFCC = LNFCC/2 - INDPVT = IDP - IF (IFLAG .NE. 0 .OR. NIV .NE. LNFC) GO TO 40 - DO 30 K = 1, NCOMP - YHP(K,LNFC+1) = YHP(K,LNFCC+1) - 30 CONTINUE - IFLAG = 1 - GO TO 50 - 40 CONTINUE - IFLAG = 99 - 50 CONTINUE - 60 CONTINUE - CONTINUE - RETURN - END diff --git a/slatec/dvnrms.f b/slatec/dvnrms.f deleted file mode 100644 index 57f3bc1..0000000 --- a/slatec/dvnrms.f +++ /dev/null @@ -1,36 +0,0 @@ -*DECK DVNRMS - DOUBLE PRECISION FUNCTION DVNRMS (N, V, W) -C***BEGIN PROLOGUE DVNRMS -C***SUBSIDIARY -C***PURPOSE Subsidiary to DDEBDF -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (VNWRMS-S, DVNRMS-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C DVNRMS computes a weighted root-mean-square vector norm for the -C integrator package DDEBDF. -C -C***SEE ALSO DDEBDF -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DVNRMS - INTEGER I, N - DOUBLE PRECISION SUM, V, W - DIMENSION V(*),W(*) -C***FIRST EXECUTABLE STATEMENT DVNRMS - SUM = 0.0D0 - DO 10 I = 1, N - SUM = SUM + (V(I)/W(I))**2 - 10 CONTINUE - DVNRMS = SQRT(SUM/N) - RETURN -C ----------------------- END OF FUNCTION DVNRMS -C ------------------------ - END diff --git a/slatec/dvout.f b/slatec/dvout.f deleted file mode 100644 index f1a1e0c..0000000 --- a/slatec/dvout.f +++ /dev/null @@ -1,137 +0,0 @@ -*DECK DVOUT - SUBROUTINE DVOUT (N, DX, IFMT, IDIGIT) -C***BEGIN PROLOGUE DVOUT -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSPLP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (SVOUT-S, DVOUT-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C -C DOUBLE PRECISION VECTOR OUTPUT ROUTINE. -C -C INPUT.. -C -C N,DX(*) PRINT THE DOUBLE PRECISION ARRAY DX(I),I=1,...,N, ON -C OUTPUT UNIT LOUT. THE HEADING IN THE FORTRAN FORMAT -C STATEMENT IFMT(*), DESCRIBED BELOW, IS PRINTED AS A FIRST -C STEP. THE COMPONENTS DX(I) ARE INDEXED, ON OUTPUT, -C IN A PLEASANT FORMAT. -C IFMT(*) A FORTRAN FORMAT STATEMENT. THIS IS PRINTED ON OUTPUT -C UNIT LOUT WITH THE VARIABLE FORMAT FORTRAN STATEMENT -C WRITE(LOUT,IFMT) -C IDIGIT PRINT AT LEAST ABS(IDIGIT) DECIMAL DIGITS PER NUMBER. -C THE SUBPROGRAM WILL CHOOSE THAT INTEGER 4,6,10 OR 14 -C WHICH WILL PRINT AT LEAST ABS(IDIGIT) NUMBER OF -C PLACES. IF IDIGIT.LT.0, 72 PRINTING COLUMNS ARE UTILIZED -C TO WRITE EACH LINE OF OUTPUT OF THE ARRAY DX(*). (THIS -C CAN BE USED ON MOST TIME-SHARING TERMINALS). IF -C IDIGIT.GE.0, 133 PRINTING COLUMNS ARE UTILIZED. (THIS CAN -C BE USED ON MOST LINE PRINTERS). -C -C EXAMPLE.. -C -C PRINT AN ARRAY CALLED (COSTS OF PURCHASES) OF LENGTH 100 SHOWING -C 6 DECIMAL DIGITS PER NUMBER. THE USER IS RUNNING ON A TIME-SHARING -C SYSTEM WITH A 72 COLUMN OUTPUT DEVICE. -C -C DOUBLE PRECISION COSTS(100) -C N = 100 -C IDIGIT = -6 -C CALL DVOUT(N,COSTS,'(''1COSTS OF PURCHASES'')',IDIGIT) -C -C***SEE ALSO DSPLP -C***ROUTINES CALLED I1MACH -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891107 Added comma after 1P edit descriptor in FORMAT -C statements. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910403 Updated AUTHOR section. (WRB) -C***END PROLOGUE DVOUT - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DOUBLE PRECISION DX(*) - CHARACTER IFMT*(*) -C***FIRST EXECUTABLE STATEMENT DVOUT - LOUT=I1MACH(2) - WRITE(LOUT,IFMT) - IF(N.LE.0) RETURN - NDIGIT = IDIGIT - IF(IDIGIT.EQ.0) NDIGIT = 6 - IF(IDIGIT.GE.0) GO TO 80 -C - NDIGIT = -IDIGIT - IF(NDIGIT.GT.6) GO TO 20 -C - DO 10 K1=1,N,4 - K2 = MIN(N,K1+3) - WRITE(LOUT,1000) K1,K2,(DX(I),I = K1, K2) - 10 CONTINUE - RETURN -C - 20 CONTINUE - IF(NDIGIT.GT.14) GO TO 40 -C - DO 30 K1=1,N,2 - K2 = MIN(N,K1+1) - WRITE(LOUT,1001) K1,K2,(DX(I),I = K1, K2) - 30 CONTINUE - RETURN -C - 40 CONTINUE - IF(NDIGIT.GT.20) GO TO 60 -C - DO 50 K1=1,N,2 - K2=MIN(N,K1+1) - WRITE(LOUT,1002) K1,K2,(DX(I),I = K1, K2) - 50 CONTINUE - RETURN -C - 60 CONTINUE - DO 70 K1=1,N - K2 = K1 - WRITE(LOUT,1003) K1,K2,(DX(I),I = K1, K2) - 70 CONTINUE - RETURN -C - 80 CONTINUE - IF(NDIGIT.GT.6) GO TO 100 -C - DO 90 K1=1,N,8 - K2 = MIN(N,K1+7) - WRITE(LOUT,1000) K1,K2,(DX(I),I = K1, K2) - 90 CONTINUE - RETURN -C - 100 CONTINUE - IF(NDIGIT.GT.14) GO TO 120 -C - DO 110 K1=1,N,5 - K2 = MIN(N,K1+4) - WRITE(LOUT,1001) K1,K2,(DX(I),I = K1, K2) - 110 CONTINUE - RETURN -C - 120 CONTINUE - IF(NDIGIT.GT.20) GO TO 140 -C - DO 130 K1=1,N,4 - K2 = MIN(N,K1+3) - WRITE(LOUT,1002) K1,K2,(DX(I),I = K1, K2) - 130 CONTINUE - RETURN -C - 140 CONTINUE - DO 150 K1=1,N,3 - K2 = MIN(N,K1+2) - WRITE(LOUT,1003) K1,K2,(DX(I),I = K1, K2) - 150 CONTINUE - RETURN - 1000 FORMAT(1X,I4,3H - ,I4,1X,1P,8D14.5) - 1001 FORMAT(1X,I4,3H - ,I4,1X,1P,5D22.13) - 1002 FORMAT(1X,I4,3H - ,I4,1X,1P,4D28.19) - 1003 FORMAT(1X,I4,3H - ,I4,1X,1P,3D36.27) - END diff --git a/slatec/dwnlit.f b/slatec/dwnlit.f deleted file mode 100644 index c68154b..0000000 --- a/slatec/dwnlit.f +++ /dev/null @@ -1,288 +0,0 @@ -*DECK DWNLIT - SUBROUTINE DWNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, - + RNORM, IDOPE, DOPE, DONE) -C***BEGIN PROLOGUE DWNLIT -C***SUBSIDIARY -C***PURPOSE Subsidiary to DWNNLS -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (WNLIT-S, DWNLIT-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C This is a companion subprogram to DWNNLS( ). -C The documentation for DWNNLS( ) has complete usage instructions. -C -C Note The M by (N+1) matrix W( , ) contains the rt. hand side -C B as the (N+1)st col. -C -C Triangularize L1 by L1 subsystem, where L1=MIN(M,L), with -C col interchanges. -C -C***SEE ALSO DWNNLS -C***ROUTINES CALLED DCOPY, DH12, DROTM, DROTMG, DSCAL, DSWAP, DWNLT1, -C DWNLT2, DWNLT3, IDAMAX -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and revised. (WRB & RWC) -C 890620 Revised to make WNLT1, WNLT2, and WNLT3 subroutines. (RWC) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900604 DP version created from SP version. . (RWC) -C***END PROLOGUE DWNLIT - INTEGER IDOPE(*), IPIVOT(*), ITYPE(*), L, M, MDW, N - DOUBLE PRECISION DOPE(*), H(*), RNORM, SCALE(*), W(MDW,*) - LOGICAL DONE -C - EXTERNAL DCOPY, DH12, DROTM, DROTMG, DSCAL, DSWAP, DWNLT1, - * DWNLT2, DWNLT3, IDAMAX - INTEGER IDAMAX - LOGICAL DWNLT2 -C - DOUBLE PRECISION ALSQ, AMAX, EANORM, FACTOR, HBAR, RN, SPARAM(5), - * T, TAU - INTEGER I, I1, IMAX, IR, J, J1, JJ, JP, KRANK, L1, LB, LEND, ME, - * MEND, NIV, NSOLN - LOGICAL INDEP, RECALC -C -C***FIRST EXECUTABLE STATEMENT DWNLIT - ME = IDOPE(1) - NSOLN = IDOPE(2) - L1 = IDOPE(3) -C - ALSQ = DOPE(1) - EANORM = DOPE(2) - TAU = DOPE(3) -C - LB = MIN(M-1,L) - RECALC = .TRUE. - RNORM = 0.D0 - KRANK = 0 -C -C We set FACTOR=1.0 so that the heavy weight ALAMDA will be -C included in the test for column independence. -C - FACTOR = 1.D0 - LEND = L - DO 180 I=1,LB -C -C Set IR to point to the I-th row. -C - IR = I - MEND = M - CALL DWNLT1 (I, LEND, M, IR, MDW, RECALC, IMAX, HBAR, H, SCALE, - + W) -C -C Update column SS and find pivot column. -C - CALL DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) -C -C Perform column interchange. -C Test independence of incoming column. -C - 130 IF (DWNLT2(ME, MEND, IR, FACTOR, TAU, SCALE, W(1,I))) THEN -C -C Eliminate I-th column below diagonal using modified Givens -C transformations applied to (A B). -C -C When operating near the ME line, use the largest element -C above it as the pivot. -C - DO 160 J=M,I+1,-1 - JP = J-1 - IF (J.EQ.ME+1) THEN - IMAX = ME - AMAX = SCALE(ME)*W(ME,I)**2 - DO 150 JP=J-1,I,-1 - T = SCALE(JP)*W(JP,I)**2 - IF (T.GT.AMAX) THEN - IMAX = JP - AMAX = T - ENDIF - 150 CONTINUE - JP = IMAX - ENDIF -C - IF (W(J,I).NE.0.D0) THEN - CALL DROTMG (SCALE(JP), SCALE(J), W(JP,I), W(J,I), - + SPARAM) - W(J,I) = 0.D0 - CALL DROTM (N+1-I, W(JP,I+1), MDW, W(J,I+1), MDW, - + SPARAM) - ENDIF - 160 CONTINUE - ELSE IF (LEND.GT.I) THEN -C -C Column I is dependent. Swap with column LEND. -C Perform column interchange, -C and find column in remaining set with largest SS. -C - CALL DWNLT3 (I, LEND, M, MDW, IPIVOT, H, W) - LEND = LEND - 1 - IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 - HBAR = H(IMAX) - GO TO 130 - ELSE - KRANK = I - 1 - GO TO 190 - ENDIF - 180 CONTINUE - KRANK = L1 -C - 190 IF (KRANK.LT.ME) THEN - FACTOR = ALSQ - DO 200 I=KRANK+1,ME - CALL DCOPY (L, 0.D0, 0, W(I,1), MDW) - 200 CONTINUE -C -C Determine the rank of the remaining equality constraint -C equations by eliminating within the block of constrained -C variables. Remove any redundant constraints. -C - RECALC = .TRUE. - LB = MIN(L+ME-KRANK, N) - DO 270 I=L+1,LB - IR = KRANK + I - L - LEND = N - MEND = ME - CALL DWNLT1 (I, LEND, ME, IR, MDW, RECALC, IMAX, HBAR, H, - + SCALE, W) -C -C Update col ss and find pivot col -C - CALL DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) -C -C Perform column interchange -C Eliminate elements in the I-th col. -C - DO 240 J=ME,IR+1,-1 - IF (W(J,I).NE.0.D0) THEN - CALL DROTMG (SCALE(J-1), SCALE(J), W(J-1,I), W(J,I), - + SPARAM) - W(J,I) = 0.D0 - CALL DROTM (N+1-I, W(J-1,I+1), MDW,W(J,I+1), MDW, - + SPARAM) - ENDIF - 240 CONTINUE -C -C I=column being eliminated. -C Test independence of incoming column. -C Remove any redundant or dependent equality constraints. -C - IF (.NOT.DWNLT2(ME, MEND, IR, FACTOR,TAU,SCALE,W(1,I))) THEN - JJ = IR - DO 260 IR=JJ,ME - CALL DCOPY (N, 0.D0, 0, W(IR,1), MDW) - RNORM = RNORM + (SCALE(IR)*W(IR,N+1)/ALSQ)*W(IR,N+1) - W(IR,N+1) = 0.D0 - SCALE(IR) = 1.D0 -C -C Reclassify the zeroed row as a least squares equation. -C - ITYPE(IR) = 1 - 260 CONTINUE -C -C Reduce ME to reflect any discovered dependent equality -C constraints. -C - ME = JJ - 1 - GO TO 280 - ENDIF - 270 CONTINUE - ENDIF -C -C Try to determine the variables KRANK+1 through L1 from the -C least squares equations. Continue the triangularization with -C pivot element W(ME+1,I). -C - 280 IF (KRANK.LT.L1) THEN - RECALC = .TRUE. -C -C Set FACTOR=ALSQ to remove effect of heavy weight from -C test for column independence. -C - FACTOR = ALSQ - DO 350 I=KRANK+1,L1 -C -C Set IR to point to the ME+1-st row. -C - IR = ME+1 - LEND = L - MEND = M - CALL DWNLT1 (I, L, M, IR, MDW, RECALC, IMAX, HBAR, H, SCALE, - + W) -C -C Update column SS and find pivot column. -C - CALL DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) -C -C Perform column interchange. -C Eliminate I-th column below the IR-th element. -C - DO 320 J=M,IR+1,-1 - IF (W(J,I).NE.0.D0) THEN - CALL DROTMG (SCALE(J-1), SCALE(J), W(J-1,I), W(J,I), - + SPARAM) - W(J,I) = 0.D0 - CALL DROTM (N+1-I, W(J-1,I+1), MDW, W(J,I+1), MDW, - + SPARAM) - ENDIF - 320 CONTINUE -C -C Test if new pivot element is near zero. -C If so, the column is dependent. -C Then check row norm test to be classified as independent. -C - T = SCALE(IR)*W(IR,I)**2 - INDEP = T .GT. (TAU*EANORM)**2 - IF (INDEP) THEN - RN = 0.D0 - DO 340 I1=IR,M - DO 330 J1=I+1,N - RN = MAX(RN, SCALE(I1)*W(I1,J1)**2) - 330 CONTINUE - 340 CONTINUE - INDEP = T .GT. RN*TAU**2 - ENDIF -C -C If independent, swap the IR-th and KRANK+1-th rows to -C maintain the triangular form. Update the rank indicator -C KRANK and the equality constraint pointer ME. -C - IF (.NOT.INDEP) GO TO 360 - CALL DSWAP(N+1, W(KRANK+1,1), MDW, W(IR,1), MDW) - CALL DSWAP(1, SCALE(KRANK+1), 1, SCALE(IR), 1) -C -C Reclassify the least square equation as an equality -C constraint and rescale it. -C - ITYPE(IR) = 0 - T = SQRT(SCALE(KRANK+1)) - CALL DSCAL(N+1, T, W(KRANK+1,1), MDW) - SCALE(KRANK+1) = ALSQ - ME = ME+1 - KRANK = KRANK+1 - 350 CONTINUE - ENDIF -C -C If pseudorank is less than L, apply Householder transformation. -C from right. -C - 360 IF (KRANK.LT.L) THEN - DO 370 J=KRANK,1,-1 - CALL DH12 (1, J, KRANK+1, L, W(J,1), MDW, H(J), W, MDW, 1, - + J-1) - 370 CONTINUE - ENDIF -C - NIV = KRANK + NSOLN - L - IF (L.EQ.N) DONE = .TRUE. -C -C End of initial triangularization. -C - IDOPE(1) = ME - IDOPE(2) = KRANK - IDOPE(3) = NIV - RETURN - END diff --git a/slatec/dwnlsm.f b/slatec/dwnlsm.f deleted file mode 100644 index ef6cc9f..0000000 --- a/slatec/dwnlsm.f +++ /dev/null @@ -1,650 +0,0 @@ -*DECK DWNLSM - SUBROUTINE DWNLSM (W, MDW, MME, MA, N, L, PRGOPT, X, RNORM, MODE, - + IPIVOT, ITYPE, WD, H, SCALE, Z, TEMP, D) -C***BEGIN PROLOGUE DWNLSM -C***SUBSIDIARY -C***PURPOSE Subsidiary to DWNNLS -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (WNLSM-S, DWNLSM-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C This is a companion subprogram to DWNNLS. -C The documentation for DWNNLS has complete usage instructions. -C -C In addition to the parameters discussed in the prologue to -C subroutine DWNNLS, the following work arrays are used in -C subroutine DWNLSM (they are passed through the calling -C sequence from DWNNLS for purposes of variable dimensioning). -C Their contents will in general be of no interest to the user. -C -C Variables of type REAL are DOUBLE PRECISION. -C -C IPIVOT(*) -C An array of length N. Upon completion it contains the -C pivoting information for the cols of W(*,*). -C -C ITYPE(*) -C An array of length M which is used to keep track -C of the classification of the equations. ITYPE(I)=0 -C denotes equation I as an equality constraint. -C ITYPE(I)=1 denotes equation I as a least squares -C equation. -C -C WD(*) -C An array of length N. Upon completion it contains the -C dual solution vector. -C -C H(*) -C An array of length N. Upon completion it contains the -C pivot scalars of the Householder transformations performed -C in the case KRANK.LT.L. -C -C SCALE(*) -C An array of length M which is used by the subroutine -C to store the diagonal matrix of weights. -C These are used to apply the modified Givens -C transformations. -C -C Z(*),TEMP(*) -C Working arrays of length N. -C -C D(*) -C An array of length N that contains the -C column scaling for the matrix (E). -C (A) -C -C***SEE ALSO DWNNLS -C***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DH12, DNRM2, DROTM, -C DROTMG, DSCAL, DSWAP, DWNLIT, IDAMAX, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and revised. (WRB & RWC) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 900510 Fixed an error message. (RWC) -C 900604 DP version created from SP version. (RWC) -C 900911 Restriction on value of ALAMDA included. (WRB) -C***END PROLOGUE DWNLSM - INTEGER IPIVOT(*), ITYPE(*), L, MA, MDW, MME, MODE, N - DOUBLE PRECISION D(*), H(*), PRGOPT(*), RNORM, SCALE(*), TEMP(*), - * W(MDW,*), WD(*), X(*), Z(*) -C - EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DH12, DNRM2, DROTM, DROTMG, - * DSCAL, DSWAP, DWNLIT, IDAMAX, XERMSG - DOUBLE PRECISION D1MACH, DASUM, DNRM2 - INTEGER IDAMAX -C - DOUBLE PRECISION ALAMDA, ALPHA, ALSQ, AMAX, BLOWUP, BNORM, - * DOPE(3), DRELPR, EANORM, FAC, SM, SPARAM(5), T, TAU, WMAX, Z2, - * ZZ - INTEGER I, IDOPE(3), IMAX, ISOL, ITEMP, ITER, ITMAX, IWMAX, J, - * JCON, JP, KEY, KRANK, L1, LAST, LINK, M, ME, NEXT, NIV, NLINK, - * NOPT, NSOLN, NTIMES - LOGICAL DONE, FEASBL, FIRST, HITCON, POS -C - SAVE DRELPR, FIRST - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DWNLSM -C -C Initialize variables. -C DRELPR is the precision for the particular machine -C being used. This logic avoids resetting it every entry. -C - IF (FIRST) DRELPR = D1MACH(4) - FIRST = .FALSE. -C -C Set the nominal tolerance used in the code. -C - TAU = SQRT(DRELPR) -C - M = MA + MME - ME = MME - MODE = 2 -C -C To process option vector -C - FAC = 1.D-4 -C -C Set the nominal blow up factor used in the code. -C - BLOWUP = TAU -C -C The nominal column scaling used in the code is -C the identity scaling. -C - CALL DCOPY (N, 1.D0, 0, D, 1) -C -C Define bound for number of options to change. -C - NOPT = 1000 -C -C Define bound for positive value of LINK. -C - NLINK = 100000 - NTIMES = 0 - LAST = 1 - LINK = PRGOPT(1) - IF (LINK.LE.0 .OR. LINK.GT.NLINK) THEN - CALL XERMSG ('SLATEC', 'DWNLSM', - + 'IN DWNNLS, THE OPTION VECTOR IS UNDEFINED', 3, 1) - RETURN - ENDIF -C - 100 IF (LINK.GT.1) THEN - NTIMES = NTIMES + 1 - IF (NTIMES.GT.NOPT) THEN - CALL XERMSG ('SLATEC', 'DWNLSM', - + 'IN DWNNLS, THE LINKS IN THE OPTION VECTOR ARE CYCLING.', - + 3, 1) - RETURN - ENDIF -C - KEY = PRGOPT(LAST+1) - IF (KEY.EQ.6 .AND. PRGOPT(LAST+2).NE.0.D0) THEN - DO 110 J = 1,N - T = DNRM2(M,W(1,J),1) - IF (T.NE.0.D0) T = 1.D0/T - D(J) = T - 110 CONTINUE - ENDIF -C - IF (KEY.EQ.7) CALL DCOPY (N, PRGOPT(LAST+2), 1, D, 1) - IF (KEY.EQ.8) TAU = MAX(DRELPR,PRGOPT(LAST+2)) - IF (KEY.EQ.9) BLOWUP = MAX(DRELPR,PRGOPT(LAST+2)) -C - NEXT = PRGOPT(LINK) - IF (NEXT.LE.0 .OR. NEXT.GT.NLINK) THEN - CALL XERMSG ('SLATEC', 'DWNLSM', - + 'IN DWNNLS, THE OPTION VECTOR IS UNDEFINED', 3, 1) - RETURN - ENDIF -C - LAST = LINK - LINK = NEXT - GO TO 100 - ENDIF -C - DO 120 J = 1,N - CALL DSCAL (M, D(J), W(1,J), 1) - 120 CONTINUE -C -C Process option vector -C - DONE = .FALSE. - ITER = 0 - ITMAX = 3*(N-L) - MODE = 0 - NSOLN = L - L1 = MIN(M,L) -C -C Compute scale factor to apply to equality constraint equations. -C - DO 130 J = 1,N - WD(J) = DASUM(M,W(1,J),1) - 130 CONTINUE -C - IMAX = IDAMAX(N,WD,1) - EANORM = WD(IMAX) - BNORM = DASUM(M,W(1,N+1),1) - ALAMDA = EANORM/(DRELPR*FAC) -C -C On machines, such as the VAXes using D floating, with a very -C limited exponent range for double precision values, the previously -C computed value of ALAMDA may cause an overflow condition. -C Therefore, this code further limits the value of ALAMDA. -C - ALAMDA = MIN(ALAMDA,SQRT(D1MACH(2))) -C -C Define scaling diagonal matrix for modified Givens usage and -C classify equation types. -C - ALSQ = ALAMDA**2 - DO 140 I = 1,M -C -C When equation I is heavily weighted ITYPE(I)=0, -C else ITYPE(I)=1. -C - IF (I.LE.ME) THEN - T = ALSQ - ITEMP = 0 - ELSE - T = 1.D0 - ITEMP = 1 - ENDIF - SCALE(I) = T - ITYPE(I) = ITEMP - 140 CONTINUE -C -C Set the solution vector X(*) to zero and the column interchange -C matrix to the identity. -C - CALL DCOPY (N, 0.D0, 0, X, 1) - DO 150 I = 1,N - IPIVOT(I) = I - 150 CONTINUE -C -C Perform initial triangularization in the submatrix -C corresponding to the unconstrained variables. -C Set first L components of dual vector to zero because -C these correspond to the unconstrained variables. -C - CALL DCOPY (L, 0.D0, 0, WD, 1) -C -C The arrays IDOPE(*) and DOPE(*) are used to pass -C information to DWNLIT(). This was done to avoid -C a long calling sequence or the use of COMMON. -C - IDOPE(1) = ME - IDOPE(2) = NSOLN - IDOPE(3) = L1 -C - DOPE(1) = ALSQ - DOPE(2) = EANORM - DOPE(3) = TAU - CALL DWNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, RNORM, - + IDOPE, DOPE, DONE) - ME = IDOPE(1) - KRANK = IDOPE(2) - NIV = IDOPE(3) -C -C Perform WNNLS algorithm using the following steps. -C -C Until(DONE) -C compute search direction and feasible point -C when (HITCON) add constraints -C else perform multiplier test and drop a constraint -C fin -C Compute-Final-Solution -C -C To compute search direction and feasible point, -C solve the triangular system of currently non-active -C variables and store the solution in Z(*). -C -C To solve system -C Copy right hand side into TEMP vector to use overwriting method. -C - 160 IF (DONE) GO TO 330 - ISOL = L + 1 - IF (NSOLN.GE.ISOL) THEN - CALL DCOPY (NIV, W(1,N+1), 1, TEMP, 1) - DO 170 J = NSOLN,ISOL,-1 - IF (J.GT.KRANK) THEN - I = NIV - NSOLN + J - ELSE - I = J - ENDIF -C - IF (J.GT.KRANK .AND. J.LE.L) THEN - Z(J) = 0.D0 - ELSE - Z(J) = TEMP(I)/W(I,J) - CALL DAXPY (I-1, -Z(J), W(1,J), 1, TEMP, 1) - ENDIF - 170 CONTINUE - ENDIF -C -C Increment iteration counter and check against maximum number -C of iterations. -C - ITER = ITER + 1 - IF (ITER.GT.ITMAX) THEN - MODE = 1 - DONE = .TRUE. - ENDIF -C -C Check to see if any constraints have become active. -C If so, calculate an interpolation factor so that all -C active constraints are removed from the basis. -C - ALPHA = 2.D0 - HITCON = .FALSE. - DO 180 J = L+1,NSOLN - ZZ = Z(J) - IF (ZZ.LE.0.D0) THEN - T = X(J)/(X(J)-ZZ) - IF (T.LT.ALPHA) THEN - ALPHA = T - JCON = J - ENDIF - HITCON = .TRUE. - ENDIF - 180 CONTINUE -C -C Compute search direction and feasible point -C - IF (HITCON) THEN -C -C To add constraints, use computed ALPHA to interpolate between -C last feasible solution X(*) and current unconstrained (and -C infeasible) solution Z(*). -C - DO 190 J = L+1,NSOLN - X(J) = X(J) + ALPHA*(Z(J)-X(J)) - 190 CONTINUE - FEASBL = .FALSE. -C -C Remove column JCON and shift columns JCON+1 through N to the -C left. Swap column JCON into the N th position. This achieves -C upper Hessenberg form for the nonactive constraints and -C leaves an upper Hessenberg matrix to retriangularize. -C - 200 DO 210 I = 1,M - T = W(I,JCON) - CALL DCOPY (N-JCON, W(I, JCON+1), MDW, W(I, JCON), MDW) - W(I,N) = T - 210 CONTINUE -C -C Update permuted index vector to reflect this shift and swap. -C - ITEMP = IPIVOT(JCON) - DO 220 I = JCON,N - 1 - IPIVOT(I) = IPIVOT(I+1) - 220 CONTINUE - IPIVOT(N) = ITEMP -C -C Similarly permute X(*) vector. -C - CALL DCOPY (N-JCON, X(JCON+1), 1, X(JCON), 1) - X(N) = 0.D0 - NSOLN = NSOLN - 1 - NIV = NIV - 1 -C -C Retriangularize upper Hessenberg matrix after adding -C constraints. -C - I = KRANK + JCON - L - DO 230 J = JCON,NSOLN - IF (ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.0) THEN -C -C Zero IP1 to I in column J -C - IF (W(I+1,J).NE.0.D0) THEN - CALL DROTMG (SCALE(I), SCALE(I+1), W(I,J), W(I+1,J), - + SPARAM) - W(I+1,J) = 0.D0 - CALL DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), MDW, - + SPARAM) - ENDIF - ELSEIF (ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.1) THEN -C -C Zero IP1 to I in column J -C - IF (W(I+1,J).NE.0.D0) THEN - CALL DROTMG (SCALE(I), SCALE(I+1), W(I,J), W(I+1,J), - + SPARAM) - W(I+1,J) = 0.D0 - CALL DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), MDW, - + SPARAM) - ENDIF - ELSEIF (ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.0) THEN - CALL DSWAP (N+1, W(I,1), MDW, W(I+1,1), MDW) - CALL DSWAP (1, SCALE(I), 1, SCALE(I+1), 1) - ITEMP = ITYPE(I+1) - ITYPE(I+1) = ITYPE(I) - ITYPE(I) = ITEMP -C -C Swapped row was formerly a pivot element, so it will -C be large enough to perform elimination. -C Zero IP1 to I in column J. -C - IF (W(I+1,J).NE.0.D0) THEN - CALL DROTMG (SCALE(I), SCALE(I+1), W(I,J), W(I+1,J), - + SPARAM) - W(I+1,J) = 0.D0 - CALL DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), MDW, - + SPARAM) - ENDIF - ELSEIF (ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.1) THEN - IF (SCALE(I)*W(I,J)**2/ALSQ.GT.(TAU*EANORM)**2) THEN -C -C Zero IP1 to I in column J -C - IF (W(I+1,J).NE.0.D0) THEN - CALL DROTMG (SCALE(I), SCALE(I+1), W(I,J), - + W(I+1,J), SPARAM) - W(I+1,J) = 0.D0 - CALL DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), MDW, - + SPARAM) - ENDIF - ELSE - CALL DSWAP (N+1, W(I,1), MDW, W(I+1,1), MDW) - CALL DSWAP (1, SCALE(I), 1, SCALE(I+1), 1) - ITEMP = ITYPE(I+1) - ITYPE(I+1) = ITYPE(I) - ITYPE(I) = ITEMP - W(I+1,J) = 0.D0 - ENDIF - ENDIF - I = I + 1 - 230 CONTINUE -C -C See if the remaining coefficients in the solution set are -C feasible. They should be because of the way ALPHA was -C determined. If any are infeasible, it is due to roundoff -C error. Any that are non-positive will be set to zero and -C removed from the solution set. -C - DO 240 JCON = L+1,NSOLN - IF (X(JCON).LE.0.D0) GO TO 250 - 240 CONTINUE - FEASBL = .TRUE. - 250 IF (.NOT.FEASBL) GO TO 200 - ELSE -C -C To perform multiplier test and drop a constraint. -C - CALL DCOPY (NSOLN, Z, 1, X, 1) - IF (NSOLN.LT.N) CALL DCOPY (N-NSOLN, 0.D0, 0, X(NSOLN+1), 1) -C -C Reclassify least squares equations as equalities as necessary. -C - I = NIV + 1 - 260 IF (I.LE.ME) THEN - IF (ITYPE(I).EQ.0) THEN - I = I + 1 - ELSE - CALL DSWAP (N+1, W(I,1), MDW, W(ME,1), MDW) - CALL DSWAP (1, SCALE(I), 1, SCALE(ME), 1) - ITEMP = ITYPE(I) - ITYPE(I) = ITYPE(ME) - ITYPE(ME) = ITEMP - ME = ME - 1 - ENDIF - GO TO 260 - ENDIF -C -C Form inner product vector WD(*) of dual coefficients. -C - DO 280 J = NSOLN+1,N - SM = 0.D0 - DO 270 I = NSOLN+1,M - SM = SM + SCALE(I)*W(I,J)*W(I,N+1) - 270 CONTINUE - WD(J) = SM - 280 CONTINUE -C -C Find J such that WD(J)=WMAX is maximum. This determines -C that the incoming column J will reduce the residual vector -C and be positive. -C - 290 WMAX = 0.D0 - IWMAX = NSOLN + 1 - DO 300 J = NSOLN+1,N - IF (WD(J).GT.WMAX) THEN - WMAX = WD(J) - IWMAX = J - ENDIF - 300 CONTINUE - IF (WMAX.LE.0.D0) GO TO 330 -C -C Set dual coefficients to zero for incoming column. -C - WD(IWMAX) = 0.D0 -C -C WMAX .GT. 0.D0, so okay to move column IWMAX to solution set. -C Perform transformation to retriangularize, and test for near -C linear dependence. -C -C Swap column IWMAX into NSOLN-th position to maintain upper -C Hessenberg form of adjacent columns, and add new column to -C triangular decomposition. -C - NSOLN = NSOLN + 1 - NIV = NIV + 1 - IF (NSOLN.NE.IWMAX) THEN - CALL DSWAP (M, W(1,NSOLN), 1, W(1,IWMAX), 1) - WD(IWMAX) = WD(NSOLN) - WD(NSOLN) = 0.D0 - ITEMP = IPIVOT(NSOLN) - IPIVOT(NSOLN) = IPIVOT(IWMAX) - IPIVOT(IWMAX) = ITEMP - ENDIF -C -C Reduce column NSOLN so that the matrix of nonactive constraints -C variables is triangular. -C - DO 320 J = M,NIV+1,-1 - JP = J - 1 -C -C When operating near the ME line, test to see if the pivot -C element is near zero. If so, use the largest element above -C it as the pivot. This is to maintain the sharp interface -C between weighted and non-weighted rows in all cases. -C - IF (J.EQ.ME+1) THEN - IMAX = ME - AMAX = SCALE(ME)*W(ME,NSOLN)**2 - DO 310 JP = J - 1,NIV,-1 - T = SCALE(JP)*W(JP,NSOLN)**2 - IF (T.GT.AMAX) THEN - IMAX = JP - AMAX = T - ENDIF - 310 CONTINUE - JP = IMAX - ENDIF -C - IF (W(J,NSOLN).NE.0.D0) THEN - CALL DROTMG (SCALE(JP), SCALE(J), W(JP,NSOLN), - + W(J,NSOLN), SPARAM) - W(J,NSOLN) = 0.D0 - CALL DROTM (N+1-NSOLN, W(JP,NSOLN+1), MDW, W(J,NSOLN+1), - + MDW, SPARAM) - ENDIF - 320 CONTINUE -C -C Solve for Z(NSOLN)=proposed new value for X(NSOLN). Test if -C this is nonpositive or too large. If this was true or if the -C pivot term was zero, reject the column as dependent. -C - IF (W(NIV,NSOLN).NE.0.D0) THEN - ISOL = NIV - Z2 = W(ISOL,N+1)/W(ISOL,NSOLN) - Z(NSOLN) = Z2 - POS = Z2 .GT. 0.D0 - IF (Z2*EANORM.GE.BNORM .AND. POS) THEN - POS = .NOT. (BLOWUP*Z2*EANORM.GE.BNORM) - ENDIF -C -C Try to add row ME+1 as an additional equality constraint. -C Check size of proposed new solution component. -C Reject it if it is too large. -C - ELSEIF (NIV.LE.ME .AND. W(ME+1,NSOLN).NE.0.D0) THEN - ISOL = ME + 1 - IF (POS) THEN -C -C Swap rows ME+1 and NIV, and scale factors for these rows. -C - CALL DSWAP (N+1, W(ME+1,1), MDW, W(NIV,1), MDW) - CALL DSWAP (1, SCALE(ME+1), 1, SCALE(NIV), 1) - ITEMP = ITYPE(ME+1) - ITYPE(ME+1) = ITYPE(NIV) - ITYPE(NIV) = ITEMP - ME = ME + 1 - ENDIF - ELSE - POS = .FALSE. - ENDIF -C - IF (.NOT.POS) THEN - NSOLN = NSOLN - 1 - NIV = NIV - 1 - ENDIF - IF (.NOT.(POS.OR.DONE)) GO TO 290 - ENDIF - GO TO 160 -C -C Else perform multiplier test and drop a constraint. To compute -C final solution. Solve system, store results in X(*). -C -C Copy right hand side into TEMP vector to use overwriting method. -C - 330 ISOL = 1 - IF (NSOLN.GE.ISOL) THEN - CALL DCOPY (NIV, W(1,N+1), 1, TEMP, 1) - DO 340 J = NSOLN,ISOL,-1 - IF (J.GT.KRANK) THEN - I = NIV - NSOLN + J - ELSE - I = J - ENDIF -C - IF (J.GT.KRANK .AND. J.LE.L) THEN - Z(J) = 0.D0 - ELSE - Z(J) = TEMP(I)/W(I,J) - CALL DAXPY (I-1, -Z(J), W(1,J), 1, TEMP, 1) - ENDIF - 340 CONTINUE - ENDIF -C -C Solve system. -C - CALL DCOPY (NSOLN, Z, 1, X, 1) -C -C Apply Householder transformations to X(*) if KRANK.LT.L -C - IF (KRANK.LT.L) THEN - DO 350 I = 1,KRANK - CALL DH12 (2, I, KRANK+1, L, W(I,1), MDW, H(I), X, 1, 1, 1) - 350 CONTINUE - ENDIF -C -C Fill in trailing zeroes for constrained variables not in solution. -C - IF (NSOLN.LT.N) CALL DCOPY (N-NSOLN, 0.D0, 0, X(NSOLN+1), 1) -C -C Permute solution vector to natural order. -C - DO 380 I = 1,N - J = I - 360 IF (IPIVOT(J).EQ.I) GO TO 370 - J = J + 1 - GO TO 360 -C - 370 IPIVOT(J) = IPIVOT(I) - IPIVOT(I) = J - CALL DSWAP (1, X(J), 1, X(I), 1) - 380 CONTINUE -C -C Rescale the solution using the column scaling. -C - DO 390 J = 1,N - X(J) = X(J)*D(J) - 390 CONTINUE -C - DO 400 I = NSOLN+1,M - T = W(I,N+1) - IF (I.LE.ME) T = T/ALAMDA - T = (SCALE(I)*T)*T - RNORM = RNORM + T - 400 CONTINUE -C - RNORM = SQRT(RNORM) - RETURN - END diff --git a/slatec/dwnlt1.f b/slatec/dwnlt1.f deleted file mode 100644 index 5ee6c8e..0000000 --- a/slatec/dwnlt1.f +++ /dev/null @@ -1,64 +0,0 @@ -*DECK DWNLT1 - SUBROUTINE DWNLT1 (I, LEND, MEND, IR, MDW, RECALC, IMAX, HBAR, H, - + SCALE, W) -C***BEGIN PROLOGUE DWNLT1 -C***SUBSIDIARY -C***PURPOSE Subsidiary to WNLIT -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (WNLT1-S, DWNLT1-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C To update the column Sum Of Squares and find the pivot column. -C The column Sum of Squares Vector will be updated at each step. -C When numerically necessary, these values will be recomputed. -C -C***SEE ALSO DWNLIT -C***ROUTINES CALLED IDAMAX -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) -C 900604 DP version created from SP version. (RWC) -C***END PROLOGUE DWNLT1 - INTEGER I, IMAX, IR, LEND, MDW, MEND - DOUBLE PRECISION H(*), HBAR, SCALE(*), W(MDW,*) - LOGICAL RECALC -C - EXTERNAL IDAMAX - INTEGER IDAMAX -C - INTEGER J, K -C -C***FIRST EXECUTABLE STATEMENT DWNLT1 - IF (IR.NE.1 .AND. (.NOT.RECALC)) THEN -C -C Update column SS=sum of squares. -C - DO 10 J=I,LEND - H(J) = H(J) - SCALE(IR-1)*W(IR-1,J)**2 - 10 CONTINUE -C -C Test for numerical accuracy. -C - IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 - RECALC = (HBAR+1.E-3*H(IMAX)) .EQ. HBAR - ENDIF -C -C If required, recalculate column SS, using rows IR through MEND. -C - IF (RECALC) THEN - DO 30 J=I,LEND - H(J) = 0.D0 - DO 20 K=IR,MEND - H(J) = H(J) + SCALE(K)*W(K,J)**2 - 20 CONTINUE - 30 CONTINUE -C -C Find column with largest SS. -C - IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 - HBAR = H(IMAX) - ENDIF - RETURN - END diff --git a/slatec/dwnlt2.f b/slatec/dwnlt2.f deleted file mode 100644 index 7f50dda..0000000 --- a/slatec/dwnlt2.f +++ /dev/null @@ -1,59 +0,0 @@ -*DECK DWNLT2 - LOGICAL FUNCTION DWNLT2 (ME, MEND, IR, FACTOR, TAU, SCALE, WIC) -C***BEGIN PROLOGUE DWNLT2 -C***SUBSIDIARY -C***PURPOSE Subsidiary to WNLIT -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (WNLT2-S, DWNLT2-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C To test independence of incoming column. -C -C Test the column IC to determine if it is linearly independent -C of the columns already in the basis. In the initial tri. step, -C we usually want the heavy weight ALAMDA to be included in the -C test for independence. In this case, the value of FACTOR will -C have been set to 1.E0 before this procedure is invoked. -C In the potentially rank deficient problem, the value of FACTOR -C will have been set to ALSQ=ALAMDA**2 to remove the effect of the -C heavy weight from the test for independence. -C -C Write new column as partitioned vector -C (A1) number of components in solution so far = NIV -C (A2) M-NIV components -C And compute SN = inverse weighted length of A1 -C RN = inverse weighted length of A2 -C Call the column independent when RN .GT. TAU*SN -C -C***SEE ALSO DWNLIT -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) -C 900604 DP version created from SP version. (RWC) -C***END PROLOGUE DWNLT2 - DOUBLE PRECISION FACTOR, SCALE(*), TAU, WIC(*) - INTEGER IR, ME, MEND -C - DOUBLE PRECISION RN, SN, T - INTEGER J -C -C***FIRST EXECUTABLE STATEMENT DWNLT2 - SN = 0.E0 - RN = 0.E0 - DO 10 J=1,MEND - T = SCALE(J) - IF (J.LE.ME) T = T/FACTOR - T = T*WIC(J)**2 -C - IF (J.LT.IR) THEN - SN = SN + T - ELSE - RN = RN + T - ENDIF - 10 CONTINUE - DWNLT2 = RN .GT. SN*TAU**2 - RETURN - END diff --git a/slatec/dwnlt3.f b/slatec/dwnlt3.f deleted file mode 100644 index 23f6359..0000000 --- a/slatec/dwnlt3.f +++ /dev/null @@ -1,44 +0,0 @@ -*DECK DWNLT3 - SUBROUTINE DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) -C***BEGIN PROLOGUE DWNLT3 -C***SUBSIDIARY -C***PURPOSE Subsidiary to WNLIT -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (WNLT3-S, DWNLT3-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C Perform column interchange. -C Exchange elements of permuted index vector and perform column -C interchanges. -C -C***SEE ALSO DWNLIT -C***ROUTINES CALLED DSWAP -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) -C 900604 DP version created from SP version. (RWC) -C***END PROLOGUE DWNLT3 - INTEGER I, IMAX, IPIVOT(*), M, MDW - DOUBLE PRECISION H(*), W(MDW,*) -C - EXTERNAL DSWAP -C - DOUBLE PRECISION T - INTEGER ITEMP -C -C***FIRST EXECUTABLE STATEMENT DWNLT3 - IF (IMAX.NE.I) THEN - ITEMP = IPIVOT(I) - IPIVOT(I) = IPIVOT(IMAX) - IPIVOT(IMAX) = ITEMP -C - CALL DSWAP(M, W(1,IMAX), 1, W(1,I), 1) -C - T = H(IMAX) - H(IMAX) = H(I) - H(I) = T - ENDIF - RETURN - END diff --git a/slatec/dwnnls.f b/slatec/dwnnls.f deleted file mode 100644 index c39b36f..0000000 --- a/slatec/dwnnls.f +++ /dev/null @@ -1,327 +0,0 @@ -*DECK DWNNLS - SUBROUTINE DWNNLS (W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, - + IWORK, WORK) -C***BEGIN PROLOGUE DWNNLS -C***PURPOSE Solve a linearly constrained least squares problem with -C equality constraints and nonnegativity constraints on -C selected variables. -C***LIBRARY SLATEC -C***CATEGORY K1A2A -C***TYPE DOUBLE PRECISION (WNNLS-S, DWNNLS-D) -C***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, -C EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, -C NONNEGATIVITY CONSTRAINTS, QUADRATIC PROGRAMMING -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C Abstract -C -C This subprogram solves a linearly constrained least squares -C problem. Suppose there are given matrices E and A of -C respective dimensions ME by N and MA by N, and vectors F -C and B of respective lengths ME and MA. This subroutine -C solves the problem -C -C EX = F, (equations to be exactly satisfied) -C -C AX = B, (equations to be approximately satisfied, -C in the least squares sense) -C -C subject to components L+1,...,N nonnegative -C -C Any values ME.GE.0, MA.GE.0 and 0.LE. L .LE.N are permitted. -C -C The problem is reposed as problem DWNNLS -C -C (WT*E)X = (WT*F) -C ( A) ( B), (least squares) -C subject to components L+1,...,N nonnegative. -C -C The subprogram chooses the heavy weight (or penalty parameter) WT. -C -C The parameters for DWNNLS are -C -C INPUT.. All TYPE REAL variables are DOUBLE PRECISION -C -C W(*,*),MDW, The array W(*,*) is double subscripted with first -C ME,MA,N,L dimensioning parameter equal to MDW. For this -C discussion let us call M = ME + MA. Then MDW -C must satisfy MDW.GE.M. The condition MDW.LT.M -C is an error. -C -C The array W(*,*) contains the matrices and vectors -C -C (E F) -C (A B) -C -C in rows and columns 1,...,M and 1,...,N+1 -C respectively. Columns 1,...,L correspond to -C unconstrained variables X(1),...,X(L). The -C remaining variables are constrained to be -C nonnegative. The condition L.LT.0 or L.GT.N is -C an error. -C -C PRGOPT(*) This double precision array is the option vector. -C If the user is satisfied with the nominal -C subprogram features set -C -C PRGOPT(1)=1 (or PRGOPT(1)=1.0) -C -C Otherwise PRGOPT(*) is a linked list consisting of -C groups of data of the following form -C -C LINK -C KEY -C DATA SET -C -C The parameters LINK and KEY are each one word. -C The DATA SET can be comprised of several words. -C The number of items depends on the value of KEY. -C The value of LINK points to the first -C entry of the next group of data within -C PRGOPT(*). The exception is when there are -C no more options to change. In that -C case LINK=1 and the values KEY and DATA SET -C are not referenced. The general layout of -C PRGOPT(*) is as follows. -C -C ...PRGOPT(1)=LINK1 (link to first entry of next group) -C . PRGOPT(2)=KEY1 (key to the option change) -C . PRGOPT(3)=DATA VALUE (data value for this change) -C . . -C . . -C . . -C ...PRGOPT(LINK1)=LINK2 (link to the first entry of -C . next group) -C . PRGOPT(LINK1+1)=KEY2 (key to the option change) -C . PRGOPT(LINK1+2)=DATA VALUE -C ... . -C . . -C . . -C ...PRGOPT(LINK)=1 (no more options to change) -C -C Values of LINK that are nonpositive are errors. -C A value of LINK.GT.NLINK=100000 is also an error. -C This helps prevent using invalid but positive -C values of LINK that will probably extend -C beyond the program limits of PRGOPT(*). -C Unrecognized values of KEY are ignored. The -C order of the options is arbitrary and any number -C of options can be changed with the following -C restriction. To prevent cycling in the -C processing of the option array a count of the -C number of options changed is maintained. -C Whenever this count exceeds NOPT=1000 an error -C message is printed and the subprogram returns. -C -C OPTIONS.. -C -C KEY=6 -C Scale the nonzero columns of the -C entire data matrix -C (E) -C (A) -C to have length one. The DATA SET for -C this option is a single value. It must -C be nonzero if unit length column scaling is -C desired. -C -C KEY=7 -C Scale columns of the entire data matrix -C (E) -C (A) -C with a user-provided diagonal matrix. -C The DATA SET for this option consists -C of the N diagonal scaling factors, one for -C each matrix column. -C -C KEY=8 -C Change the rank determination tolerance from -C the nominal value of SQRT(SRELPR). This quantity -C can be no smaller than SRELPR, The arithmetic- -C storage precision. The quantity used -C here is internally restricted to be at -C least SRELPR. The DATA SET for this option -C is the new tolerance. -C -C KEY=9 -C Change the blow-up parameter from the -C nominal value of SQRT(SRELPR). The reciprocal of -C this parameter is used in rejecting solution -C components as too large when a variable is -C first brought into the active set. Too large -C means that the proposed component times the -C reciprocal of the parameter is not less than -C the ratio of the norms of the right-side -C vector and the data matrix. -C This parameter can be no smaller than SRELPR, -C the arithmetic-storage precision. -C -C For example, suppose we want to provide -C a diagonal matrix to scale the problem -C matrix and change the tolerance used for -C determining linear dependence of dropped col -C vectors. For these options the dimensions of -C PRGOPT(*) must be at least N+6. The FORTRAN -C statements defining these options would -C be as follows. -C -C PRGOPT(1)=N+3 (link to entry N+3 in PRGOPT(*)) -C PRGOPT(2)=7 (user-provided scaling key) -C -C CALL DCOPY(N,D,1,PRGOPT(3),1) (copy the N -C scaling factors from a user array called D(*) -C into PRGOPT(3)-PRGOPT(N+2)) -C -C PRGOPT(N+3)=N+6 (link to entry N+6 of PRGOPT(*)) -C PRGOPT(N+4)=8 (linear dependence tolerance key) -C PRGOPT(N+5)=... (new value of the tolerance) -C -C PRGOPT(N+6)=1 (no more options to change) -C -C -C IWORK(1), The amounts of working storage actually allocated -C IWORK(2) for the working arrays WORK(*) and IWORK(*), -C respectively. These quantities are compared with -C the actual amounts of storage needed for DWNNLS( ). -C Insufficient storage allocated for either WORK(*) -C or IWORK(*) is considered an error. This feature -C was included in DWNNLS( ) because miscalculating -C the storage formulas for WORK(*) and IWORK(*) -C might very well lead to subtle and hard-to-find -C execution errors. -C -C The length of WORK(*) must be at least -C -C LW = ME+MA+5*N -C This test will not be made if IWORK(1).LE.0. -C -C The length of IWORK(*) must be at least -C -C LIW = ME+MA+N -C This test will not be made if IWORK(2).LE.0. -C -C OUTPUT.. All TYPE REAL variables are DOUBLE PRECISION -C -C X(*) An array dimensioned at least N, which will -C contain the N components of the solution vector -C on output. -C -C RNORM The residual norm of the solution. The value of -C RNORM contains the residual vector length of the -C equality constraints and least squares equations. -C -C MODE The value of MODE indicates the success or failure -C of the subprogram. -C -C MODE = 0 Subprogram completed successfully. -C -C = 1 Max. number of iterations (equal to -C 3*(N-L)) exceeded. Nearly all problems -C should complete in fewer than this -C number of iterations. An approximate -C solution and its corresponding residual -C vector length are in X(*) and RNORM. -C -C = 2 Usage error occurred. The offending -C condition is noted with the error -C processing subprogram, XERMSG( ). -C -C User-designated -C Working arrays.. -C -C WORK(*) A double precision working array of length at least -C M + 5*N. -C -C IWORK(*) An integer-valued working array of length at least -C M+N. -C -C***REFERENCES K. H. Haskell and R. J. Hanson, An algorithm for -C linear least squares problems with equality and -C nonnegativity constraints, Report SAND77-0552, Sandia -C Laboratories, June 1978. -C K. H. Haskell and R. J. Hanson, Selected algorithms for -C the linearly constrained least squares problem - a -C users guide, Report SAND78-1290, Sandia Laboratories, -C August 1979. -C K. H. Haskell and R. J. Hanson, An algorithm for -C linear least squares problems with equality and -C nonnegativity constraints, Mathematical Programming -C 21 (1981), pp. 98-118. -C R. J. Hanson and K. H. Haskell, Two algorithms for the -C linearly constrained least squares problem, ACM -C Transactions on Mathematical Software, September 1982. -C C. L. Lawson and R. J. Hanson, Solving Least Squares -C Problems, Prentice-Hall, Inc., 1974. -C***ROUTINES CALLED DWNLSM, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and revised. (WRB & RWC) -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, change Prologue -C comments to agree with WNNLS. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DWNNLS - INTEGER IWORK(*), L, L1, L2, L3, L4, L5, LIW, LW, MA, MDW, ME, - * MODE, N - DOUBLE PRECISION PRGOPT(*), RNORM, W(MDW,*), WORK(*), X(*) - CHARACTER*8 XERN1 -C***FIRST EXECUTABLE STATEMENT DWNNLS - MODE = 0 - IF (MA+ME.LE.0 .OR. N.LE.0) RETURN -C - IF (IWORK(1).GT.0) THEN - LW = ME + MA + 5*N - IF (IWORK(1).LT.LW) THEN - WRITE (XERN1, '(I8)') LW - CALL XERMSG ('SLATEC', 'DWNNLS', 'INSUFFICIENT STORAGE ' // - * 'ALLOCATED FOR WORK(*), NEED LW = ' // XERN1, 2, 1) - MODE = 2 - RETURN - ENDIF - ENDIF -C - IF (IWORK(2).GT.0) THEN - LIW = ME + MA + N - IF (IWORK(2).LT.LIW) THEN - WRITE (XERN1, '(I8)') LIW - CALL XERMSG ('SLATEC', 'DWNNLS', 'INSUFFICIENT STORAGE ' // - * 'ALLOCATED FOR IWORK(*), NEED LIW = ' // XERN1, 2, 1) - MODE = 2 - RETURN - ENDIF - ENDIF -C - IF (MDW.LT.ME+MA) THEN - CALL XERMSG ('SLATEC', 'DWNNLS', - * 'THE VALUE MDW.LT.ME+MA IS AN ERROR', 1, 1) - MODE = 2 - RETURN - ENDIF -C - IF (L.LT.0 .OR. L.GT.N) THEN - CALL XERMSG ('SLATEC', 'DWNNLS', - * 'L.GE.0 .AND. L.LE.N IS REQUIRED', 2, 1) - MODE = 2 - RETURN - ENDIF -C -C THE PURPOSE OF THIS SUBROUTINE IS TO BREAK UP THE ARRAYS -C WORK(*) AND IWORK(*) INTO SEPARATE WORK ARRAYS -C REQUIRED BY THE MAIN SUBROUTINE DWNLSM( ). -C - L1 = N + 1 - L2 = L1 + N - L3 = L2 + ME + MA - L4 = L3 + N - L5 = L4 + N -C - CALL DWNLSM(W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, IWORK, - * IWORK(L1), WORK(1), WORK(L1), WORK(L2), WORK(L3), - * WORK(L4), WORK(L5)) - RETURN - END diff --git a/slatec/dwritp.f b/slatec/dwritp.f deleted file mode 100644 index 6e86085..0000000 --- a/slatec/dwritp.f +++ /dev/null @@ -1,44 +0,0 @@ -*DECK DWRITP - SUBROUTINE DWRITP (IPAGE, LIST, RLIST, LPAGE, IREC) -C***BEGIN PROLOGUE DWRITP -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSPLP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (SWRITP-S, DWRITP-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C WRITE RECORD NUMBER IRECN, OF LENGTH LPG, FROM STORAGE -C ARRAY LIST(*) ONTO UNIT NUMBER IPAGEF. -C WRITE RECORD NUMBER IRECN+1, OF LENGTH LPG, ONTO UNIT -C NUMBER IPAGEF FROM THE STORAGE ARRAY RLIST(*). -C -C TO CHANGE THIS PROGRAM UNIT TO DOUBLE PRECISION CHANGE -C /REAL (12 BLANKS)/ TO /DOUBLE PRECISION/. -C -C***SEE ALSO DSPLP -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890605 Corrected references to XERRWV. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C***END PROLOGUE DWRITP - INTEGER LIST(*) - DOUBLE PRECISION RLIST(*) - CHARACTER*8 XERN1, XERN2 -C***FIRST EXECUTABLE STATEMENT DWRITP - IPAGEF=IPAGE - LPG =LPAGE - IRECN =IREC - WRITE(IPAGEF,REC=IRECN,ERR=100)(LIST(I),I=1,LPG) - WRITE(IPAGEF,REC=IRECN+1,ERR=100)(RLIST(I),I=1,LPG) - RETURN -C - 100 WRITE (XERN1, '(I8)') LPG - WRITE (XERN2, '(I8)') IRECN - CALL XERMSG ('SLATEC', 'DWRITP', 'IN DSPLP, LGP = ' // XERN1 // - * ' IRECN = ' // XERN2, 100, 1) - RETURN - END diff --git a/slatec/dwupdt.f b/slatec/dwupdt.f deleted file mode 100644 index 67e51b2..0000000 --- a/slatec/dwupdt.f +++ /dev/null @@ -1,123 +0,0 @@ -*DECK DWUPDT - SUBROUTINE DWUPDT (N, R, LDR, W, B, ALPHA, COS, SIN) -C***BEGIN PROLOGUE DWUPDT -C***SUBSIDIARY -C***PURPOSE Subsidiary to DNLS1 and DNLS1E -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (RWUPDT-S, DWUPDT-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Given an N by N upper triangular matrix R, this subroutine -C computes the QR decomposition of the matrix formed when a row -C is added to R. If the row is specified by the vector W, then -C DWUPDT determines an orthogonal matrix Q such that when the -C N+1 by N matrix composed of R augmented by W is premultiplied -C by (Q TRANSPOSE), the resulting matrix is upper trapezoidal. -C The orthogonal matrix Q is the product of N transformations -C -C G(1)*G(2)* ... *G(N) -C -C where G(I) is a Givens rotation in the (I,N+1) plane which -C eliminates elements in the I-th plane. DWUPDT also -C computes the product (Q TRANSPOSE)*C where C is the -C (N+1)-vector (b,alpha). Q itself is not accumulated, rather -C the information to recover the G rotations is supplied. -C -C The subroutine statement is -C -C SUBROUTINE DWUPDT(N,R,LDR,W,B,ALPHA,COS,SIN) -C -C where -C -C N is a positive integer input variable set to the order of R. -C -C R is an N by N array. On input the upper triangular part of -C R must contain the matrix to be updated. On output R -C contains the updated triangular matrix. -C -C LDR is a positive integer input variable not less than N -C which specifies the leading dimension of the array R. -C -C W is an input array of length N which must contain the row -C vector to be added to R. -C -C B is an array of length N. On input B must contain the -C first N elements of the vector C. On output B contains -C the first N elements of the vector (Q TRANSPOSE)*C. -C -C ALPHA is a variable. On input ALPHA must contain the -C (N+1)-st element of the vector C. On output ALPHA contains -C the (N+1)-st element of the vector (Q TRANSPOSE)*C. -C -C COS is an output array of length N which contains the -C cosines of the transforming Givens rotations. -C -C SIN is an output array of length N which contains the -C sines of the transforming Givens rotations. -C -C ********** -C -C***SEE ALSO DNLS1, DNLS1E -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DWUPDT - INTEGER N,LDR - DOUBLE PRECISION ALPHA - DOUBLE PRECISION R(LDR,*),W(*),B(*),COS(*),SIN(*) - INTEGER I,J,JM1 - DOUBLE PRECISION COTAN,ONE,P5,P25,ROWJ,TAN,TEMP,ZERO - SAVE ONE, P5, P25, ZERO - DATA ONE,P5,P25,ZERO /1.0D0,5.0D-1,2.5D-1,0.0D0/ -C***FIRST EXECUTABLE STATEMENT DWUPDT - DO 60 J = 1, N - ROWJ = W(J) - JM1 = J - 1 -C -C APPLY THE PREVIOUS TRANSFORMATIONS TO -C R(I,J), I=1,2,...,J-1, AND TO W(J). -C - IF (JM1 .LT. 1) GO TO 20 - DO 10 I = 1, JM1 - TEMP = COS(I)*R(I,J) + SIN(I)*ROWJ - ROWJ = -SIN(I)*R(I,J) + COS(I)*ROWJ - R(I,J) = TEMP - 10 CONTINUE - 20 CONTINUE -C -C DETERMINE A GIVENS ROTATION WHICH ELIMINATES W(J). -C - COS(J) = ONE - SIN(J) = ZERO - IF (ROWJ .EQ. ZERO) GO TO 50 - IF (ABS(R(J,J)) .GE. ABS(ROWJ)) GO TO 30 - COTAN = R(J,J)/ROWJ - SIN(J) = P5/SQRT(P25+P25*COTAN**2) - COS(J) = SIN(J)*COTAN - GO TO 40 - 30 CONTINUE - TAN = ROWJ/R(J,J) - COS(J) = P5/SQRT(P25+P25*TAN**2) - SIN(J) = COS(J)*TAN - 40 CONTINUE -C -C APPLY THE CURRENT TRANSFORMATION TO R(J,J), B(J), AND ALPHA. -C - R(J,J) = COS(J)*R(J,J) + SIN(J)*ROWJ - TEMP = COS(J)*B(J) + SIN(J)*ALPHA - ALPHA = -SIN(J)*B(J) + COS(J)*ALPHA - B(J) = TEMP - 50 CONTINUE - 60 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE DWUPDT. -C - END diff --git a/slatec/dx.f b/slatec/dx.f deleted file mode 100644 index da05d3d..0000000 --- a/slatec/dx.f +++ /dev/null @@ -1,98 +0,0 @@ -*DECK DX - SUBROUTINE DX (U, IDMN, I, J, UXXX, UXXXX) -C***BEGIN PROLOGUE DX -C***SUBSIDIARY -C***PURPOSE Subsidiary to SEPELI -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (DX-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This program computes second order finite difference -C approximations to the third and fourth X -C partial derivatives of U at the (I,J) mesh point. -C -C***SEE ALSO SEPELI -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS SPLPCM -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE DX -C - COMMON /SPLPCM/ KSWX ,KSWY ,K ,L , - 1 AIT ,BIT ,CIT ,DIT , - 2 MIT ,NIT ,IS ,MS , - 3 JS ,NS ,DLX ,DLY , - 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 - DIMENSION U(IDMN,*) -C***FIRST EXECUTABLE STATEMENT DX - IF (I.GT.2 .AND. I.LT.(K-1)) GO TO 50 - IF (I .EQ. 1) GO TO 10 - IF (I .EQ. 2) GO TO 30 - IF (I .EQ. K-1) GO TO 60 - IF (I .EQ. K) GO TO 80 -C -C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=A -C - 10 IF (KSWX .EQ. 1) GO TO 20 - UXXX = (-5.0*U(1,J)+18.0*U(2,J)-24.0*U(3,J)+14.0*U(4,J)- - 1 3.0*U(5,J))/(TDLX3) - UXXXX = (3.0*U(1,J)-14.0*U(2,J)+26.0*U(3,J)-24.0*U(4,J)+ - 1 11.0*U(5,J)-2.0*U(6,J))/DLX4 - RETURN -C -C PERIODIC AT X=A -C - 20 UXXX = (-U(K-2,J)+2.0*U(K-1,J)-2.0*U(2,J)+U(3,J))/(TDLX3) - UXXXX = (U(K-2,J)-4.0*U(K-1,J)+6.0*U(1,J)-4.0*U(2,J)+U(3,J))/DLX4 - RETURN -C -C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=A+DLX -C - 30 IF (KSWX .EQ. 1) GO TO 40 - UXXX = (-3.0*U(1,J)+10.0*U(2,J)-12.0*U(3,J)+6.0*U(4,J)-U(5,J))/ - 1 TDLX3 - UXXXX = (2.0*U(1,J)-9.0*U(2,J)+16.0*U(3,J)-14.0*U(4,J)+6.0*U(5,J)- - 1 U(6,J))/DLX4 - RETURN -C -C PERIODIC AT X=A+DLX -C - 40 UXXX = (-U(K-1,J)+2.0*U(1,J)-2.0*U(3,J)+U(4,J))/(TDLX3) - UXXXX = (U(K-1,J)-4.0*U(1,J)+6.0*U(2,J)-4.0*U(3,J)+U(4,J))/DLX4 - RETURN -C -C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS ON THE INTERIOR -C - 50 CONTINUE - UXXX = (-U(I-2,J)+2.0*U(I-1,J)-2.0*U(I+1,J)+U(I+2,J))/TDLX3 - UXXXX = (U(I-2,J)-4.0*U(I-1,J)+6.0*U(I,J)-4.0*U(I+1,J)+U(I+2,J))/ - 1 DLX4 - RETURN -C -C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=B-DLX -C - 60 IF (KSWX .EQ. 1) GO TO 70 - UXXX = (U(K-4,J)-6.0*U(K-3,J)+12.0*U(K-2,J)-10.0*U(K-1,J)+ - 1 3.0*U(K,J))/TDLX3 - UXXXX = (-U(K-5,J)+6.0*U(K-4,J)-14.0*U(K-3,J)+16.0*U(K-2,J)- - 1 9.0*U(K-1,J)+2.0*U(K,J))/DLX4 - RETURN -C -C PERIODIC AT X=B-DLX -C - 70 UXXX = (-U(K-3,J)+2.0*U(K-2,J)-2.0*U(1,J)+U(2,J))/TDLX3 - UXXXX = (U(K-3,J)-4.0*U(K-2,J)+6.0*U(K-1,J)-4.0*U(1,J)+U(2,J))/ - 1 DLX4 - RETURN -C -C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=B -C - 80 UXXX = -(3.0*U(K-4,J)-14.0*U(K-3,J)+24.0*U(K-2,J)-18.0*U(K-1,J)+ - 1 5.0*U(K,J))/TDLX3 - UXXXX = (-2.0*U(K-5,J)+11.0*U(K-4,J)-24.0*U(K-3,J)+26.0*U(K-2,J)- - 1 14.0*U(K-1,J)+3.0*U(K,J))/DLX4 - RETURN - END diff --git a/slatec/dx4.f b/slatec/dx4.f deleted file mode 100644 index b2eb228..0000000 --- a/slatec/dx4.f +++ /dev/null @@ -1,98 +0,0 @@ -*DECK DX4 - SUBROUTINE DX4 (U, IDMN, I, J, UXXX, UXXXX) -C***BEGIN PROLOGUE DX4 -C***SUBSIDIARY -C***PURPOSE Subsidiary to SEPX4 -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (DX4-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This program computes second order finite difference -C approximations to the third and fourth X -C partial derivatives of U at the (I,J) mesh point. -C -C***SEE ALSO SEPX4 -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS SPL4 -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE DX4 -C - COMMON /SPL4/ KSWX ,KSWY ,K ,L , - 1 AIT ,BIT ,CIT ,DIT , - 2 MIT ,NIT ,IS ,MS , - 3 JS ,NS ,DLX ,DLY , - 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 - DIMENSION U(IDMN,*) -C***FIRST EXECUTABLE STATEMENT DX4 - IF (I.GT.2 .AND. I.LT.(K-1)) GO TO 50 - IF (I .EQ. 1) GO TO 10 - IF (I .EQ. 2) GO TO 30 - IF (I .EQ. K-1) GO TO 60 - IF (I .EQ. K) GO TO 80 -C -C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=A -C - 10 IF (KSWX .EQ. 1) GO TO 20 - UXXX = (-5.0*U(1,J)+18.0*U(2,J)-24.0*U(3,J)+14.0*U(4,J)- - 1 3.0*U(5,J))/(TDLX3) - UXXXX = (3.0*U(1,J)-14.0*U(2,J)+26.0*U(3,J)-24.0*U(4,J)+ - 1 11.0*U(5,J)-2.0*U(6,J))/DLX4 - RETURN -C -C PERIODIC AT X=A -C - 20 UXXX = (-U(K-2,J)+2.0*U(K-1,J)-2.0*U(2,J)+U(3,J))/(TDLX3) - UXXXX = (U(K-2,J)-4.0*U(K-1,J)+6.0*U(1,J)-4.0*U(2,J)+U(3,J))/DLX4 - RETURN -C -C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=A+DLX -C - 30 IF (KSWX .EQ. 1) GO TO 40 - UXXX = (-3.0*U(1,J)+10.0*U(2,J)-12.0*U(3,J)+6.0*U(4,J)-U(5,J))/ - 1 TDLX3 - UXXXX = (2.0*U(1,J)-9.0*U(2,J)+16.0*U(3,J)-14.0*U(4,J)+6.0*U(5,J)- - 1 U(6,J))/DLX4 - RETURN -C -C PERIODIC AT X=A+DLX -C - 40 UXXX = (-U(K-1,J)+2.0*U(1,J)-2.0*U(3,J)+U(4,J))/(TDLX3) - UXXXX = (U(K-1,J)-4.0*U(1,J)+6.0*U(2,J)-4.0*U(3,J)+U(4,J))/DLX4 - RETURN -C -C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS ON THE INTERIOR -C - 50 CONTINUE - UXXX = (-U(I-2,J)+2.0*U(I-1,J)-2.0*U(I+1,J)+U(I+2,J))/TDLX3 - UXXXX = (U(I-2,J)-4.0*U(I-1,J)+6.0*U(I,J)-4.0*U(I+1,J)+U(I+2,J))/ - 1 DLX4 - RETURN -C -C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=B-DLX -C - 60 IF (KSWX .EQ. 1) GO TO 70 - UXXX = (U(K-4,J)-6.0*U(K-3,J)+12.0*U(K-2,J)-10.0*U(K-1,J)+ - 1 3.0*U(K,J))/TDLX3 - UXXXX = (-U(K-5,J)+6.0*U(K-4,J)-14.0*U(K-3,J)+16.0*U(K-2,J)- - 1 9.0*U(K-1,J)+2.0*U(K,J))/DLX4 - RETURN -C -C PERIODIC AT X=B-DLX -C - 70 UXXX = (-U(K-3,J)+2.0*U(K-2,J)-2.0*U(1,J)+U(2,J))/TDLX3 - UXXXX = (U(K-3,J)-4.0*U(K-2,J)+6.0*U(K-1,J)-4.0*U(1,J)+U(2,J))/ - 1 DLX4 - RETURN -C -C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=B -C - 80 UXXX = -(3.0*U(K-4,J)-14.0*U(K-3,J)+24.0*U(K-2,J)-18.0*U(K-1,J)+ - 1 5.0*U(K,J))/TDLX3 - UXXXX = (-2.0*U(K-5,J)+11.0*U(K-4,J)-24.0*U(K-3,J)+26.0*U(K-2,J)- - 1 14.0*U(K-1,J)+3.0*U(K,J))/DLX4 - RETURN - END diff --git a/slatec/dxadd.f b/slatec/dxadd.f deleted file mode 100644 index 21531d8..0000000 --- a/slatec/dxadd.f +++ /dev/null @@ -1,171 +0,0 @@ -*DECK DXADD - SUBROUTINE DXADD (X, IX, Y, IY, Z, IZ, IERROR) -C***BEGIN PROLOGUE DXADD -C***PURPOSE To provide double-precision floating-point arithmetic -C with an extended exponent range. -C***LIBRARY SLATEC -C***CATEGORY A3D -C***TYPE DOUBLE PRECISION (XADD-S, DXADD-D) -C***KEYWORDS EXTENDED-RANGE DOUBLE-PRECISION ARITHMETIC -C***AUTHOR Lozier, Daniel W., (National Bureau of Standards) -C Smith, John M., (NBS and George Mason University) -C***DESCRIPTION -C DOUBLE PRECISION X, Y, Z -C INTEGER IX, IY, IZ -C -C FORMS THE EXTENDED-RANGE SUM (Z,IZ) = -C (X,IX) + (Y,IY). (Z,IZ) IS ADJUSTED -C BEFORE RETURNING. THE INPUT OPERANDS -C NEED NOT BE IN ADJUSTED FORM, BUT THEIR -C PRINCIPAL PARTS MUST SATISFY -C RADIX**(-2L).LE.ABS(X).LE.RADIX**(2L), -C RADIX**(-2L).LE.ABS(Y).LE.RADIX**(2L). -C -C***SEE ALSO DXSET -C***REFERENCES (NONE) -C***ROUTINES CALLED DXADJ -C***COMMON BLOCKS DXBLK2 -C***REVISION HISTORY (YYMMDD) -C 820712 DATE WRITTEN -C 881020 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Changed all specific intrinsics to generic. (WRB) -C Corrected order of sections in prologue and added TYPE -C section. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE DXADD - DOUBLE PRECISION X, Y, Z - INTEGER IX, IY, IZ - DOUBLE PRECISION RADIX, RADIXL, RAD2L, DLG10R - INTEGER L, L2, KMAX - COMMON /DXBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX - SAVE /DXBLK2/ - DOUBLE PRECISION S, T -C -C THE CONDITIONS IMPOSED ON L AND KMAX BY THIS SUBROUTINE -C ARE -C (1) 1 .LT. L .LE. 0.5D0*LOGR(0.5D0*DZERO) -C -C (2) NRADPL .LT. L .LE. KMAX/6 -C -C (3) KMAX .LE. (2**NBITS - 4*L - 1)/2 -C -C THESE CONDITIONS MUST BE MET BY APPROPRIATE CODING -C IN SUBROUTINE DXSET. -C -C***FIRST EXECUTABLE STATEMENT DXADD - IERROR=0 - IF (X.NE.0.0D0) GO TO 10 - Z = Y - IZ = IY - GO TO 220 - 10 IF (Y.NE.0.0D0) GO TO 20 - Z = X - IZ = IX - GO TO 220 - 20 CONTINUE - IF (IX.GE.0 .AND. IY.GE.0) GO TO 40 - IF (IX.LT.0 .AND. IY.LT.0) GO TO 40 - IF (ABS(IX).LE.6*L .AND. ABS(IY).LE.6*L) GO TO 40 - IF (IX.GE.0) GO TO 30 - Z = Y - IZ = IY - GO TO 220 - 30 CONTINUE - Z = X - IZ = IX - GO TO 220 - 40 I = IX - IY - IF (I) 80, 50, 90 - 50 IF (ABS(X).GT.1.0D0 .AND. ABS(Y).GT.1.0D0) GO TO 60 - IF (ABS(X).LT.1.0D0 .AND. ABS(Y).LT.1.0D0) GO TO 70 - Z = X + Y - IZ = IX - GO TO 220 - 60 S = X/RADIXL - T = Y/RADIXL - Z = S + T - IZ = IX + L - GO TO 220 - 70 S = X*RADIXL - T = Y*RADIXL - Z = S + T - IZ = IX - L - GO TO 220 - 80 S = Y - IS = IY - T = X - GO TO 100 - 90 S = X - IS = IX - T = Y - 100 CONTINUE -C -C AT THIS POINT, THE ONE OF (X,IX) OR (Y,IY) THAT HAS THE -C LARGER AUXILIARY INDEX IS STORED IN (S,IS). THE PRINCIPAL -C PART OF THE OTHER INPUT IS STORED IN T. -C - I1 = ABS(I)/L - I2 = MOD(ABS(I),L) - IF (ABS(T).GE.RADIXL) GO TO 130 - IF (ABS(T).GE.1.0D0) GO TO 120 - IF (RADIXL*ABS(T).GE.1.0D0) GO TO 110 - J = I1 + 1 - T = T*RADIX**(L-I2) - GO TO 140 - 110 J = I1 - T = T*RADIX**(-I2) - GO TO 140 - 120 J = I1 - 1 - IF (J.LT.0) GO TO 110 - T = T*RADIX**(-I2)/RADIXL - GO TO 140 - 130 J = I1 - 2 - IF (J.LT.0) GO TO 120 - T = T*RADIX**(-I2)/RAD2L - 140 CONTINUE -C -C AT THIS POINT, SOME OR ALL OF THE DIFFERENCE IN THE -C AUXILIARY INDICES HAS BEEN USED TO EFFECT A LEFT SHIFT -C OF T. THE SHIFTED VALUE OF T SATISFIES -C -C RADIX**(-2*L) .LE. ABS(T) .LE. 1.0D0 -C -C AND, IF J=0, NO FURTHER SHIFTING REMAINS TO BE DONE. -C - IF (J.EQ.0) GO TO 190 - IF (ABS(S).GE.RADIXL .OR. J.GT.3) GO TO 150 - IF (ABS(S).GE.1.0D0) GO TO (180, 150, 150), J - IF (RADIXL*ABS(S).GE.1.0D0) GO TO (180, 170, 150), J - GO TO (180, 170, 160), J - 150 Z = S - IZ = IS - GO TO 220 - 160 S = S*RADIXL - 170 S = S*RADIXL - 180 S = S*RADIXL - 190 CONTINUE -C -C AT THIS POINT, THE REMAINING DIFFERENCE IN THE -C AUXILIARY INDICES HAS BEEN USED TO EFFECT A RIGHT SHIFT -C OF S. IF THE SHIFTED VALUE OF S WOULD HAVE EXCEEDED -C RADIX**L, THEN (S,IS) IS RETURNED AS THE VALUE OF THE -C SUM. -C - IF (ABS(S).GT.1.0D0 .AND. ABS(T).GT.1.0D0) GO TO 200 - IF (ABS(S).LT.1.0D0 .AND. ABS(T).LT.1.0D0) GO TO 210 - Z = S + T - IZ = IS - J*L - GO TO 220 - 200 S = S/RADIXL - T = T/RADIXL - Z = S + T - IZ = IS - J*L + L - GO TO 220 - 210 S = S*RADIXL - T = T*RADIXL - Z = S + T - IZ = IS - J*L - L - 220 CALL DXADJ(Z, IZ,IERROR) - RETURN - END diff --git a/slatec/dxadj.f b/slatec/dxadj.f deleted file mode 100644 index 518be8b..0000000 --- a/slatec/dxadj.f +++ /dev/null @@ -1,77 +0,0 @@ -*DECK DXADJ - SUBROUTINE DXADJ (X, IX, IERROR) -C***BEGIN PROLOGUE DXADJ -C***PURPOSE To provide double-precision floating-point arithmetic -C with an extended exponent range. -C***LIBRARY SLATEC -C***CATEGORY A3D -C***TYPE DOUBLE PRECISION (XADJ-S, DXADJ-D) -C***KEYWORDS EXTENDED-RANGE DOUBLE-PRECISION ARITHMETIC -C***AUTHOR Lozier, Daniel W., (National Bureau of Standards) -C Smith, John M., (NBS and George Mason University) -C***DESCRIPTION -C DOUBLE PRECISION X -C INTEGER IX -C -C TRANSFORMS (X,IX) SO THAT -C RADIX**(-L) .LE. ABS(X) .LT. RADIX**L. -C ON MOST COMPUTERS THIS TRANSFORMATION DOES -C NOT CHANGE THE MANTISSA OF X PROVIDED RADIX IS -C THE NUMBER BASE OF DOUBLE-PRECISION ARITHMETIC. -C -C***SEE ALSO DXSET -C***REFERENCES (NONE) -C***ROUTINES CALLED XERMSG -C***COMMON BLOCKS DXBLK2 -C***REVISION HISTORY (YYMMDD) -C 820712 DATE WRITTEN -C 881020 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Changed all specific intrinsics to generic. (WRB) -C Corrected order of sections in prologue and added TYPE -C section. (WRB) -C CALLs to XERROR changed to CALLs to XERMSG. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE DXADJ - DOUBLE PRECISION X - INTEGER IX - DOUBLE PRECISION RADIX, RADIXL, RAD2L, DLG10R - INTEGER L, L2, KMAX - COMMON /DXBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX - SAVE /DXBLK2/ -C -C THE CONDITION IMPOSED ON L AND KMAX BY THIS SUBROUTINE -C IS -C 2*L .LE. KMAX -C -C THIS CONDITION MUST BE MET BY APPROPRIATE CODING -C IN SUBROUTINE DXSET. -C -C***FIRST EXECUTABLE STATEMENT DXADJ - IERROR=0 - IF (X.EQ.0.0D0) GO TO 50 - IF (ABS(X).GE.1.0D0) GO TO 20 - IF (RADIXL*ABS(X).GE.1.0D0) GO TO 60 - X = X*RAD2L - IF (IX.LT.0) GO TO 10 - IX = IX - L2 - GO TO 70 - 10 IF (IX.LT.-KMAX+L2) GO TO 40 - IX = IX - L2 - GO TO 70 - 20 IF (ABS(X).LT.RADIXL) GO TO 60 - X = X/RAD2L - IF (IX.GT.0) GO TO 30 - IX = IX + L2 - GO TO 70 - 30 IF (IX.GT.KMAX-L2) GO TO 40 - IX = IX + L2 - GO TO 70 - 40 CALL XERMSG ('SLATEC', 'DXADJ', 'overflow in auxiliary index', - + 207, 1) - IERROR=207 - RETURN - 50 IX = 0 - 60 IF (ABS(IX).GT.KMAX) GO TO 40 - 70 RETURN - END diff --git a/slatec/dxc210.f b/slatec/dxc210.f deleted file mode 100644 index c79679f..0000000 --- a/slatec/dxc210.f +++ /dev/null @@ -1,113 +0,0 @@ -*DECK DXC210 - SUBROUTINE DXC210 (K, Z, J, IERROR) -C***BEGIN PROLOGUE DXC210 -C***PURPOSE To provide double-precision floating-point arithmetic -C with an extended exponent range. -C***LIBRARY SLATEC -C***CATEGORY A3D -C***TYPE DOUBLE PRECISION (XC210-S, DXC210-D) -C***KEYWORDS EXTENDED-RANGE DOUBLE-PRECISION ARITHMETIC -C***AUTHOR Lozier, Daniel W., (National Bureau of Standards) -C Smith, John M., (NBS and George Mason University) -C***DESCRIPTION -C INTEGER K, J -C DOUBLE PRECISION Z -C -C GIVEN K THIS SUBROUTINE COMPUTES J AND Z -C SUCH THAT RADIX**K = Z*10**J, WHERE Z IS IN -C THE RANGE 1/10 .LE. Z .LT. 1. -C THE VALUE OF Z WILL BE ACCURATE TO FULL -C DOUBLE-PRECISION PROVIDED THE NUMBER -C OF DECIMAL PLACES IN THE LARGEST -C INTEGER PLUS THE NUMBER OF DECIMAL -C PLACES CARRIED IN DOUBLE-PRECISION DOES NOT -C EXCEED 60. DXC210 IS CALLED BY SUBROUTINE -C DXCON WHEN NECESSARY. THE USER SHOULD -C NEVER NEED TO CALL DXC210 DIRECTLY. -C -C***SEE ALSO DXSET -C***REFERENCES (NONE) -C***ROUTINES CALLED XERMSG -C***COMMON BLOCKS DXBLK3 -C***REVISION HISTORY (YYMMDD) -C 820712 DATE WRITTEN -C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Changed all specific intrinsics to generic. (WRB) -C Corrected order of sections in prologue and added TYPE -C section. (WRB) -C CALLs to XERROR changed to CALLs to XERMSG. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE DXC210 - DOUBLE PRECISION Z - INTEGER K, J - INTEGER NLG102, MLG102, LG102 - COMMON /DXBLK3/ NLG102, MLG102, LG102(21) - SAVE /DXBLK3/ -C -C THE CONDITIONS IMPOSED ON NLG102, MLG102, AND LG102 BY -C THIS SUBROUTINE ARE -C -C (1) NLG102 .GE. 2 -C -C (2) MLG102 .GE. 1 -C -C (3) 2*MLG102*(MLG102 - 1) .LE. 2**NBITS - 1 -C -C THESE CONDITIONS MUST BE MET BY APPROPRIATE CODING -C IN SUBROUTINE DXSET. -C -C***FIRST EXECUTABLE STATEMENT DXC210 - IERROR=0 - IF (K.EQ.0) GO TO 70 - M = MLG102 - KA = ABS(K) - KA1 = KA/M - KA2 = MOD(KA,M) - IF (KA1.GE.M) GO TO 60 - NM1 = NLG102 - 1 - NP1 = NLG102 + 1 - IT = KA2*LG102(NP1) - IC = IT/M - ID = MOD(IT,M) - Z = ID - IF (KA1.GT.0) GO TO 20 - DO 10 II=1,NM1 - I = NP1 - II - IT = KA2*LG102(I) + IC - IC = IT/M - ID = MOD(IT,M) - Z = Z/M + ID - 10 CONTINUE - JA = KA*LG102(1) + IC - GO TO 40 - 20 CONTINUE - DO 30 II=1,NM1 - I = NP1 - II - IT = KA2*LG102(I) + KA1*LG102(I+1) + IC - IC = IT/M - ID = MOD(IT,M) - Z = Z/M + ID - 30 CONTINUE - JA = KA*LG102(1) + KA1*LG102(2) + IC - 40 CONTINUE - Z = Z/M - IF (K.GT.0) GO TO 50 - J = -JA - Z = 10.0D0**(-Z) - GO TO 80 - 50 CONTINUE - J = JA + 1 - Z = 10.0D0**(Z-1.0D0) - GO TO 80 - 60 CONTINUE -C THIS ERROR OCCURS IF K EXCEEDS MLG102**2 - 1 IN MAGNITUDE. -C - CALL XERMSG ('SLATEC', 'DXC210', 'K too large', 208, 1) - IERROR=208 - RETURN - 70 CONTINUE - J = 0 - Z = 1.0D0 - 80 RETURN - END diff --git a/slatec/dxcon.f b/slatec/dxcon.f deleted file mode 100644 index b4c03d3..0000000 --- a/slatec/dxcon.f +++ /dev/null @@ -1,167 +0,0 @@ -*DECK DXCON - SUBROUTINE DXCON (X, IX, IERROR) -C***BEGIN PROLOGUE DXCON -C***PURPOSE To provide double-precision floating-point arithmetic -C with an extended exponent range. -C***LIBRARY SLATEC -C***CATEGORY A3D -C***TYPE DOUBLE PRECISION (XCON-S, DXCON-D) -C***KEYWORDS EXTENDED-RANGE DOUBLE-PRECISION ARITHMETIC -C***AUTHOR Lozier, Daniel W., (National Bureau of Standards) -C Smith, John M., (NBS and George Mason University) -C***DESCRIPTION -C DOUBLE PRECISION X -C INTEGER IX -C -C CONVERTS (X,IX) = X*RADIX**IX -C TO DECIMAL FORM IN PREPARATION FOR -C PRINTING, SO THAT (X,IX) = X*10**IX -C WHERE 1/10 .LE. ABS(X) .LT. 1 -C IS RETURNED, EXCEPT THAT IF -C (ABS(X),IX) IS BETWEEN RADIX**(-2L) -C AND RADIX**(2L) THEN THE REDUCED -C FORM WITH IX = 0 IS RETURNED. -C -C***SEE ALSO DXSET -C***REFERENCES (NONE) -C***ROUTINES CALLED DXADJ, DXC210, DXRED -C***COMMON BLOCKS DXBLK2 -C***REVISION HISTORY (YYMMDD) -C 820712 DATE WRITTEN -C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Changed all specific intrinsics to generic. (WRB) -C Corrected order of sections in prologue and added TYPE -C section. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE DXCON - DOUBLE PRECISION X - INTEGER IX -C -C THE CONDITIONS IMPOSED ON L AND KMAX BY THIS SUBROUTINE -C ARE -C (1) 4 .LE. L .LE. 2**NBITS - 1 - KMAX -C -C (2) KMAX .LE. ((2**NBITS)-2)/LOG10R - L -C -C THESE CONDITIONS MUST BE MET BY APPROPRIATE CODING -C IN SUBROUTINE DXSET. -C - DOUBLE PRECISION RADIX, RADIXL, RAD2L, DLG10R - INTEGER L, L2, KMAX - COMMON /DXBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX - SAVE /DXBLK2/, ISPACE -C - DOUBLE PRECISION A, B, Z -C - DATA ISPACE /1/ -C THE PARAMETER ISPACE IS THE INCREMENT USED IN FORM- -C ING THE AUXILIARY INDEX OF THE DECIMAL EXTENDED-RANGE -C FORM. THE RETURNED VALUE OF IX WILL BE AN INTEGER MULT- -C IPLE OF ISPACE. ISPACE MUST SATISFY 1 .LE. ISPACE .LE. -C L/2. IF A VALUE GREATER THAN 1 IS TAKEN, THE RETURNED -C VALUE OF X WILL SATISFY 10**(-ISPACE) .LE. ABS(X) .LE. 1 -C WHEN (ABS(X),IX) .LT. RADIX**(-2L), AND 1/10 .LE. ABS(X) -C .LT. 10**(ISPACE-1) WHEN (ABS(X),IX) .GT. RADIX**(2L). -C -C***FIRST EXECUTABLE STATEMENT DXCON - IERROR=0 - CALL DXRED(X, IX,IERROR) - IF (IERROR.NE.0) RETURN - IF (IX.EQ.0) GO TO 150 - CALL DXADJ(X, IX,IERROR) - IF (IERROR.NE.0) RETURN -C -C CASE 1 IS WHEN (X,IX) IS LESS THAN RADIX**(-2L) IN MAGNITUDE, -C CASE 2 IS WHEN (X,IX) IS GREATER THAN RADIX**(2L) IN MAGNITUDE. - ITEMP = 1 - ICASE = (3+SIGN(ITEMP,IX))/2 - GO TO (10, 20), ICASE - 10 IF (ABS(X).LT.1.0D0) GO TO 30 - X = X/RADIXL - IX = IX + L - GO TO 30 - 20 IF (ABS(X).GE.1.0D0) GO TO 30 - X = X*RADIXL - IX = IX - L - 30 CONTINUE -C -C AT THIS POINT, RADIX**(-L) .LE. ABS(X) .LT. 1.0D0 IN CASE 1, -C 1.0D0 .LE. ABS(X) .LT. RADIX**L IN CASE 2. - I = LOG10(ABS(X))/DLG10R - A = RADIX**I - GO TO (40, 60), ICASE - 40 IF (A.LE.RADIX*ABS(X)) GO TO 50 - I = I - 1 - A = A/RADIX - GO TO 40 - 50 IF (ABS(X).LT.A) GO TO 80 - I = I + 1 - A = A*RADIX - GO TO 50 - 60 IF (A.LE.ABS(X)) GO TO 70 - I = I - 1 - A = A/RADIX - GO TO 60 - 70 IF (ABS(X).LT.RADIX*A) GO TO 80 - I = I + 1 - A = A*RADIX - GO TO 70 - 80 CONTINUE -C -C AT THIS POINT I IS SUCH THAT -C RADIX**(I-1) .LE. ABS(X) .LT. RADIX**I IN CASE 1, -C RADIX**I .LE. ABS(X) .LT. RADIX**(I+1) IN CASE 2. - ITEMP = ISPACE/DLG10R - A = RADIX**ITEMP - B = 10.0D0**ISPACE - 90 IF (A.LE.B) GO TO 100 - ITEMP = ITEMP - 1 - A = A/RADIX - GO TO 90 - 100 IF (B.LT.A*RADIX) GO TO 110 - ITEMP = ITEMP + 1 - A = A*RADIX - GO TO 100 - 110 CONTINUE -C -C AT THIS POINT ITEMP IS SUCH THAT -C RADIX**ITEMP .LE. 10**ISPACE .LT. RADIX**(ITEMP+1). - IF (ITEMP.GT.0) GO TO 120 -C ITEMP = 0 IF, AND ONLY IF, ISPACE = 1 AND RADIX = 16.0D0 - X = X*RADIX**(-I) - IX = IX + I - CALL DXC210(IX, Z, J,IERROR) - IF (IERROR.NE.0) RETURN - X = X*Z - IX = J - GO TO (130, 140), ICASE - 120 CONTINUE - I1 = I/ITEMP - X = X*RADIX**(-I1*ITEMP) - IX = IX + I1*ITEMP -C -C AT THIS POINT, -C RADIX**(-ITEMP) .LE. ABS(X) .LT. 1.0D0 IN CASE 1, -C 1.0D0 .LE. ABS(X) .LT. RADIX**ITEMP IN CASE 2. - CALL DXC210(IX, Z, J,IERROR) - IF (IERROR.NE.0) RETURN - J1 = J/ISPACE - J2 = J - J1*ISPACE - X = X*Z*10.0D0**J2 - IX = J1*ISPACE -C -C AT THIS POINT, -C 10.0D0**(-2*ISPACE) .LE. ABS(X) .LT. 1.0D0 IN CASE 1, -C 10.0D0**-1 .LE. ABS(X) .LT. 10.0D0**(2*ISPACE-1) IN CASE 2. - GO TO (130, 140), ICASE - 130 IF (B*ABS(X).GE.1.0D0) GO TO 150 - X = X*B - IX = IX - ISPACE - GO TO 130 - 140 IF (10.0D0*ABS(X).LT.B) GO TO 150 - X = X/B - IX = IX + ISPACE - GO TO 140 - 150 RETURN - END diff --git a/slatec/dxlcal.f b/slatec/dxlcal.f deleted file mode 100644 index cb18d52..0000000 --- a/slatec/dxlcal.f +++ /dev/null @@ -1,185 +0,0 @@ -*DECK DXLCAL - SUBROUTINE DXLCAL (N, LGMR, X, XL, ZL, HES, MAXLP1, Q, V, R0NRM, - + WK, SZ, JSCAL, JPRE, MSOLVE, NMSL, RPAR, IPAR, NELT, IA, JA, A, - + ISYM) -C***BEGIN PROLOGUE DXLCAL -C***SUBSIDIARY -C***PURPOSE Internal routine for DGMRES. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (SXLCAL-S, DXLCAL-D) -C***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov -C Hindmarsh, Alan, (LLNL), alanh@llnl.gov -C Seager, Mark K., (LLNL), seager@llnl.gov -C Lawrence Livermore National Laboratory -C PO Box 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C***DESCRIPTION -C This routine computes the solution XL, the current DGMRES -C iterate, given the V(I)'s and the QR factorization of the -C Hessenberg matrix HES. This routine is only called when -C ITOL=11. -C -C *Usage: -C INTEGER N, LGMR, MAXLP1, JSCAL, JPRE, NMSL, IPAR(USER DEFINED) -C INTEGER NELT, IA(NELT), JA(NELT), ISYM -C DOUBLE PRECISION X(N), XL(N), ZL(N), HES(MAXLP1,MAXL), Q(2*MAXL), -C $ V(N,MAXLP1), R0NRM, WK(N), SZ(N), -C $ RPAR(USER DEFINED), A(NELT) -C EXTERNAL MSOLVE -C -C CALL DXLCAL(N, LGMR, X, XL, ZL, HES, MAXLP1, Q, V, R0NRM, -C $ WK, SZ, JSCAL, JPRE, MSOLVE, NMSL, RPAR, IPAR, -C $ NELT, IA, JA, A, ISYM) -C -C *Arguments: -C N :IN Integer -C The order of the matrix A, and the lengths -C of the vectors SR, SZ, R0 and Z. -C LGMR :IN Integer -C The number of iterations performed and -C the current order of the upper Hessenberg -C matrix HES. -C X :IN Double Precision X(N) -C The current approximate solution as of the last restart. -C XL :OUT Double Precision XL(N) -C An array of length N used to hold the approximate -C solution X(L). -C Warning: XL and ZL are the same array in the calling routine. -C ZL :IN Double Precision ZL(N) -C An array of length N used to hold the approximate -C solution Z(L). -C HES :IN Double Precision HES(MAXLP1,MAXL) -C 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) and V(*,k). -C MAXLP1 :IN Integer -C MAXLP1 = MAXL + 1, used for dynamic dimensioning of HES. -C MAXL is the maximum allowable order of the matrix HES. -C Q :IN Double Precision Q(2*MAXL) -C A double precision array of length 2*MAXL containing the -C components of the Givens rotations used in the QR -C decomposition of HES. It is loaded in DHEQR. -C V :IN Double Precision V(N,MAXLP1) -C The N by(LGMR+1) array containing the LGMR -C orthogonal vectors V(*,1) to V(*,LGMR). -C R0NRM :IN Double Precision -C The scaled norm of the initial residual for the -C current call to DPIGMR. -C WK :IN Double Precision WK(N) -C A double precision work array of length N. -C SZ :IN Double Precision SZ(N) -C A vector of length N containing the non-zero -C elements of the diagonal scaling matrix for Z. -C JSCAL :IN Integer -C A flag indicating whether arrays SR and SZ are used. -C JSCAL=0 means SR and SZ are not used and the -C algorithm will perform as if all -C SR(i) = 1 and SZ(i) = 1. -C JSCAL=1 means only SZ is used, and the algorithm -C performs as if all SR(i) = 1. -C JSCAL=2 means only SR is used, and the algorithm -C performs as if all SZ(i) = 1. -C JSCAL=3 means both SR and SZ are used. -C JPRE :IN Integer -C The preconditioner type flag. -C MSOLVE :EXT External. -C Name of the routine which solves a linear system Mz = r for -C z given r with the preconditioning matrix M (M is supplied via -C RPAR and IPAR arrays. The name of the MSOLVE routine must -C be declared external in the calling program. The calling -C sequence to MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RPAR, IPAR) -C Where N is the number of unknowns, R is the right-hand side -C vector and Z is the solution upon return. NELT, IA, JA, A and -C ISYM are defined as below. RPAR is a double precision array -C that can be used to pass necessary preconditioning information -C and/or workspace to MSOLVE. IPAR is an integer work array -C for the same purpose as RPAR. -C NMSL :IN Integer -C The number of calls to MSOLVE. -C RPAR :IN Double Precision RPAR(USER DEFINED) -C Double Precision workspace passed directly to the MSOLVE -C routine. -C IPAR :IN Integer IPAR(USER DEFINED) -C Integer workspace passed directly to the MSOLVE routine. -C NELT :IN Integer -C The length of arrays IA, JA and A. -C IA :IN Integer IA(NELT) -C An integer array of length NELT containing matrix data. -C It is passed directly to the MATVEC and MSOLVE routines. -C JA :IN Integer JA(NELT) -C An integer array of length NELT containing matrix data. -C It is passed directly to the MATVEC and MSOLVE routines. -C A :IN Double Precision A(NELT) -C A double precision array of length NELT containing matrix -C data. -C It is passed directly to the MATVEC and MSOLVE routines. -C ISYM :IN Integer -C A flag to indicate symmetric matrix storage. -C If ISYM=0, all non-zero entries of the matrix are -C stored. If ISYM=1, the matrix is symmetric and -C only the upper or lower triangular part is stored. -C -C***SEE ALSO DGMRES -C***ROUTINES CALLED DAXPY, DCOPY, DHELS -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MSOLVE from ROUTINES CALLED list. (FNF) -C 910506 Made subsidiary to DGMRES. (FNF) -C 920511 Added complete declaration section. (WRB) -C***END PROLOGUE DXLCAL -C The following is for optimized compilation on LLNL/LTSS Crays. -CLLL. OPTIMIZE -C .. Scalar Arguments .. - DOUBLE PRECISION R0NRM - INTEGER ISYM, JPRE, JSCAL, LGMR, MAXLP1, N, NELT, NMSL -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), HES(MAXLP1,*), Q(*), RPAR(*), SZ(*), - + V(N,*), WK(N), X(N), XL(N), ZL(N) - INTEGER IA(NELT), IPAR(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MSOLVE -C .. Local Scalars .. - INTEGER I, K, LL, LLP1 -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DHELS -C***FIRST EXECUTABLE STATEMENT DXLCAL - LL = LGMR - LLP1 = LL + 1 - DO 10 K = 1,LLP1 - WK(K) = 0 - 10 CONTINUE - WK(1) = R0NRM - CALL DHELS(HES, MAXLP1, LL, Q, WK) - DO 20 K = 1,N - ZL(K) = 0 - 20 CONTINUE - DO 30 I = 1,LL - CALL DAXPY(N, WK(I), V(1,I), 1, ZL, 1) - 30 CONTINUE - IF ((JSCAL .EQ. 1) .OR.(JSCAL .EQ. 3)) THEN - DO 40 K = 1,N - ZL(K) = ZL(K)/SZ(K) - 40 CONTINUE - ENDIF - IF (JPRE .GT. 0) THEN - CALL DCOPY(N, ZL, 1, WK, 1) - CALL MSOLVE(N, WK, ZL, NELT, IA, JA, A, ISYM, RPAR, IPAR) - NMSL = NMSL + 1 - ENDIF -C calculate XL from X and ZL. - DO 50 K = 1,N - XL(K) = X(K) + ZL(K) - 50 CONTINUE - RETURN -C------------- LAST LINE OF DXLCAL FOLLOWS ---------------------------- - END diff --git a/slatec/dxlegf.f b/slatec/dxlegf.f deleted file mode 100644 index 206d066..0000000 --- a/slatec/dxlegf.f +++ /dev/null @@ -1,228 +0,0 @@ -*DECK DXLEGF - SUBROUTINE DXLEGF (DNU1, NUDIFF, MU1, MU2, THETA, ID, PQA, IPQA, - 1 IERROR) -C***BEGIN PROLOGUE DXLEGF -C***PURPOSE Compute normalized Legendre polynomials and associated -C Legendre functions. -C***LIBRARY SLATEC -C***CATEGORY C3A2, C9 -C***TYPE DOUBLE PRECISION (XLEGF-S, DXLEGF-D) -C***KEYWORDS LEGENDRE FUNCTIONS -C***AUTHOR Smith, John M., (NBS and George Mason University) -C***DESCRIPTION -C -C DXLEGF: Extended-range Double-precision Legendre Functions -C -C A feature of the DXLEGF subroutine for Legendre functions is -C the use of extended-range arithmetic, a software extension of -C ordinary floating-point arithmetic that greatly increases the -C exponent range of the representable numbers. This avoids the -C need for scaling the solutions to lie within the exponent range -C of the most restrictive manufacturer's hardware. The increased -C exponent range is achieved by allocating an integer storage -C location together with each floating-point storage location. -C -C The interpretation of the pair (X,I) where X is floating-point -C and I is integer is X*(IR**I) where IR is the internal radix of -C the computer arithmetic. -C -C This subroutine computes one of the following vectors: -C -C 1. Legendre function of the first kind of negative order, either -C a. P(-MU1,NU,X), P(-MU1-1,NU,X), ..., P(-MU2,NU,X) or -C b. P(-MU,NU1,X), P(-MU,NU1+1,X), ..., P(-MU,NU2,X) -C 2. Legendre function of the second kind, either -C a. Q(MU1,NU,X), Q(MU1+1,NU,X), ..., Q(MU2,NU,X) or -C b. Q(MU,NU1,X), Q(MU,NU1+1,X), ..., Q(MU,NU2,X) -C 3. Legendre function of the first kind of positive order, either -C a. P(MU1,NU,X), P(MU1+1,NU,X), ..., P(MU2,NU,X) or -C b. P(MU,NU1,X), P(MU,NU1+1,X), ..., P(MU,NU2,X) -C 4. Normalized Legendre polynomials, either -C a. PN(MU1,NU,X), PN(MU1+1,NU,X), ..., PN(MU2,NU,X) or -C b. PN(MU,NU1,X), PN(MU,NU1+1,X), ..., PN(MU,NU2,X) -C -C where X = COS(THETA). -C -C The input values to DXLEGF are DNU1, NUDIFF, MU1, MU2, THETA, -C and ID. These must satisfy -C -C DNU1 is DOUBLE PRECISION and greater than or equal to -0.5; -C NUDIFF is INTEGER and non-negative; -C MU1 is INTEGER and non-negative; -C MU2 is INTEGER and greater than or equal to MU1; -C THETA is DOUBLE PRECISION and in the half-open interval (0,PI/2]; -C ID is INTEGER and equal to 1, 2, 3 or 4; -C -C and additionally either NUDIFF = 0 or MU2 = MU1. -C -C If ID=1 and NUDIFF=0, a vector of type 1a above is computed -C with NU=DNU1. -C -C If ID=1 and MU1=MU2, a vector of type 1b above is computed -C with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. -C -C If ID=2 and NUDIFF=0, a vector of type 2a above is computed -C with NU=DNU1. -C -C If ID=2 and MU1=MU2, a vector of type 2b above is computed -C with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. -C -C If ID=3 and NUDIFF=0, a vector of type 3a above is computed -C with NU=DNU1. -C -C If ID=3 and MU1=MU2, a vector of type 3b above is computed -C with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. -C -C If ID=4 and NUDIFF=0, a vector of type 4a above is computed -C with NU=DNU1. -C -C If ID=4 and MU1=MU2, a vector of type 4b above is computed -C with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. -C -C In each case the vector of computed Legendre function values -C is returned in the extended-range vector (PQA(I),IPQA(I)). The -C length of this vector is either MU2-MU1+1 or NUDIFF+1. -C -C Where possible, DXLEGF returns IPQA(I) as zero. In this case the -C value of the Legendre function is contained entirely in PQA(I), -C so it can be used in subsequent computations without further -C consideration of extended-range arithmetic. If IPQA(I) is nonzero, -C then the value of the Legendre function is not representable in -C floating-point because of underflow or overflow. The program that -C calls DXLEGF must test IPQA(I) to ensure correct usage. -C -C IERROR is an error indicator. If no errors are detected, IERROR=0 -C when control returns to the calling routine. If an error is detected, -C IERROR is returned as nonzero. The calling routine must check the -C value of IERROR. -C -C If IERROR=210 or 211, invalid input was provided to DXLEGF. -C If IERROR=201,202,203, or 204, invalid input was provided to DXSET. -C If IERROR=205 or 206, an internal consistency error occurred in -C DXSET (probably due to a software malfunction in the library routine -C I1MACH). -C If IERROR=207, an overflow or underflow of an extended-range number -C was detected in DXADJ. -C If IERROR=208, an overflow or underflow of an extended-range number -C was detected in DXC210. -C -C***SEE ALSO DXSET -C***REFERENCES Olver and Smith, Associated Legendre Functions on the -C Cut, J Comp Phys, v 51, n 3, Sept 1983, pp 502--518. -C Smith, Olver and Lozier, Extended-Range Arithmetic and -C Normalized Legendre Polynomials, ACM Trans on Math -C Softw, v 7, n 1, March 1981, pp 93--105. -C***ROUTINES CALLED DXPMU, DXPMUP, DXPNRM, DXPQNU, DXQMU, DXQNU, DXRED, -C DXSET, XERMSG -C***REVISION HISTORY (YYMMDD) -C 820728 DATE WRITTEN -C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Changed all specific intrinsics to generic. (WRB) -C Corrected order of sections in prologue and added TYPE -C section. (WRB) -C CALLs to XERROR changed to CALLs to XERMSG. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE DXLEGF - DOUBLE PRECISION PQA,DNU1,DNU2,SX,THETA,X,PI2 - DIMENSION PQA(*),IPQA(*) -C -C***FIRST EXECUTABLE STATEMENT DXLEGF - IERROR=0 - CALL DXSET (0, 0, 0.0D0, 0,IERROR) - IF (IERROR.NE.0) RETURN - PI2=2.D0*ATAN(1.D0) -C -C ZERO OUTPUT ARRAYS -C - L=(MU2-MU1)+NUDIFF+1 - DO 290 I=1,L - PQA(I)=0.D0 - 290 IPQA(I)=0 -C -C CHECK FOR VALID INPUT VALUES -C - IF(NUDIFF.LT.0) GO TO 400 - IF(DNU1.LT.-.5D0) GO TO 400 - IF(MU2.LT.MU1) GO TO 400 - IF(MU1.LT.0) GO TO 400 - IF(THETA.LE.0.D0.OR.THETA.GT.PI2) GO TO 420 - IF(ID.LT.1.OR.ID.GT.4) GO TO 400 - IF((MU1.NE.MU2).AND.(NUDIFF.GT.0)) GO TO 400 -C -C IF DNU1 IS NOT AN INTEGER, NORMALIZED P(MU,DNU,X) -C CANNOT BE CALCULATED. IF DNU1 IS AN INTEGER AND -C MU1.GT.DNU2 THEN ALL VALUES OF P(+MU,DNU,X) AND -C NORMALIZED P(MU,NU,X) WILL BE ZERO. -C - DNU2=DNU1+NUDIFF - IF((ID.EQ.3).AND.(MOD(DNU1,1.D0).NE.0.D0)) GO TO 295 - IF((ID.EQ.4).AND.(MOD(DNU1,1.D0).NE.0.D0)) GO TO 400 - IF((ID.EQ.3.OR.ID.EQ.4).AND.MU1.GT.DNU2) RETURN - 295 CONTINUE -C - X=COS(THETA) - SX=1.D0/SIN(THETA) - IF(ID.EQ.2) GO TO 300 - IF(MU2-MU1.LE.0) GO TO 360 -C -C FIXED NU, VARIABLE MU -C CALL DXPMU TO CALCULATE P(-MU1,NU,X),....,P(-MU2,NU,X) -C - CALL DXPMU(DNU1,DNU2,MU1,MU2,THETA,X,SX,ID,PQA,IPQA,IERROR) - IF (IERROR.NE.0) RETURN - GO TO 380 -C - 300 IF(MU2.EQ.MU1) GO TO 320 -C -C FIXED NU, VARIABLE MU -C CALL DXQMU TO CALCULATE Q(MU1,NU,X),....,Q(MU2,NU,X) -C - CALL DXQMU(DNU1,DNU2,MU1,MU2,THETA,X,SX,ID,PQA,IPQA,IERROR) - IF (IERROR.NE.0) RETURN - GO TO 390 -C -C FIXED MU, VARIABLE NU -C CALL DXQNU TO CALCULATE Q(MU,DNU1,X),....,Q(MU,DNU2,X) -C - 320 CALL DXQNU(DNU1,DNU2,MU1,THETA,X,SX,ID,PQA,IPQA,IERROR) - IF (IERROR.NE.0) RETURN - GO TO 390 -C -C FIXED MU, VARIABLE NU -C CALL DXPQNU TO CALCULATE P(-MU,DNU1,X),....,P(-MU,DNU2,X) -C - 360 CALL DXPQNU(DNU1,DNU2,MU1,THETA,ID,PQA,IPQA,IERROR) - IF (IERROR.NE.0) RETURN -C -C IF ID = 3, TRANSFORM P(-MU,NU,X) VECTOR INTO -C P(MU,NU,X) VECTOR. -C - 380 IF(ID.EQ.3) CALL DXPMUP(DNU1,DNU2,MU1,MU2,PQA,IPQA,IERROR) - IF (IERROR.NE.0) RETURN -C -C IF ID = 4, TRANSFORM P(-MU,NU,X) VECTOR INTO -C NORMALIZED P(MU,NU,X) VECTOR. -C - IF(ID.EQ.4) CALL DXPNRM(DNU1,DNU2,MU1,MU2,PQA,IPQA,IERROR) - IF (IERROR.NE.0) RETURN -C -C PLACE RESULTS IN REDUCED FORM IF POSSIBLE -C AND RETURN TO MAIN PROGRAM. -C - 390 DO 395 I=1,L - CALL DXRED(PQA(I),IPQA(I),IERROR) - IF (IERROR.NE.0) RETURN - 395 CONTINUE - RETURN -C -C ***** ERROR TERMINATION ***** -C - 400 CALL XERMSG ('SLATEC', 'DXLEGF', - + 'DNU1, NUDIFF, MU1, MU2, or ID not valid', 210, 1) - IERROR=210 - RETURN - 420 CALL XERMSG ('SLATEC', 'DXLEGF', 'THETA out of range', 211, 1) - IERROR=211 - RETURN - END diff --git a/slatec/dxnrmp.f b/slatec/dxnrmp.f deleted file mode 100644 index a680b62..0000000 --- a/slatec/dxnrmp.f +++ /dev/null @@ -1,269 +0,0 @@ -*DECK DXNRMP - SUBROUTINE DXNRMP (NU, MU1, MU2, DARG, MODE, DPN, IPN, ISIG, - 1 IERROR) -C***BEGIN PROLOGUE DXNRMP -C***PURPOSE Compute normalized Legendre polynomials. -C***LIBRARY SLATEC -C***CATEGORY C3A2, C9 -C***TYPE DOUBLE PRECISION (XNRMP-S, DXNRMP-D) -C***KEYWORDS LEGENDRE FUNCTIONS -C***AUTHOR Lozier, Daniel W., (National Bureau of Standards) -C Smith, John M., (NBS and George Mason University) -C***DESCRIPTION -C -C SUBROUTINE TO CALCULATE NORMALIZED LEGENDRE POLYNOMIALS -C (XNRMP is single-precision version) -C DXNRMP calculates normalized Legendre polynomials of varying -C order and fixed argument and degree. The order MU and degree -C NU are non-negative integers and the argument is real. Because -C the algorithm requires the use of numbers outside the normal -C machine range, this subroutine employs a special arithmetic -C called extended-range arithmetic. See J.M. Smith, F.W.J. Olver, -C and D.W. Lozier, Extended-Range Arithmetic and Normalized -C Legendre Polynomials, ACM Transactions on Mathematical Soft- -C ware, 93-105, March 1981, for a complete description of the -C algorithm and special arithmetic. Also see program comments -C in DXSET. -C -C The normalized Legendre polynomials are multiples of the -C associated Legendre polynomials of the first kind where the -C normalizing coefficients are chosen so as to make the integral -C from -1 to 1 of the square of each function equal to 1. See -C E. Jahnke, F. Emde and F. Losch, Tables of Higher Functions, -C McGraw-Hill, New York, 1960, p. 121. -C -C The input values to DXNRMP are NU, MU1, MU2, DARG, and MODE. -C These must satisfy -C 1. NU .GE. 0 specifies the degree of the normalized Legendre -C polynomial that is wanted. -C 2. MU1 .GE. 0 specifies the lowest-order normalized Legendre -C polynomial that is wanted. -C 3. MU2 .GE. MU1 specifies the highest-order normalized Leg- -C endre polynomial that is wanted. -C 4a. MODE = 1 and -1.0D0 .LE. DARG .LE. 1.0D0 specifies that -C Normalized Legendre(NU, MU, DARG) is wanted for MU = MU1, -C MU1 + 1, ..., MU2. -C 4b. MODE = 2 and -3.14159... .LT. DARG .LT. 3.14159... spec- -C ifies that Normalized Legendre(NU, MU, COS(DARG)) is -C wanted for MU = MU1, MU1 + 1, ..., MU2. -C -C The output of DXNRMP consists of the two vectors DPN and IPN -C and the error estimate ISIG. The computed values are stored as -C extended-range numbers such that -C (DPN(1),IPN(1))=NORMALIZED LEGENDRE(NU,MU1,DX) -C (DPN(2),IPN(2))=NORMALIZED LEGENDRE(NU,MU1+1,DX) -C . -C . -C (DPN(K),IPN(K))=NORMALIZED LEGENDRE(NU,MU2,DX) -C where K = MU2 - MU1 + 1 and DX = DARG or COS(DARG) according -C to whether MODE = 1 or 2. Finally, ISIG is an estimate of the -C number of decimal digits lost through rounding errors in the -C computation. For example if DARG is accurate to 12 significant -C decimals, then the computed function values are accurate to -C 12 - ISIG significant decimals (except in neighborhoods of -C zeros). -C -C The interpretation of (DPN(I),IPN(I)) is DPN(I)*(IR**IPN(I)) -C where IR is the internal radix of the computer arithmetic. When -C IPN(I) = 0 the value of the normalized Legendre polynomial is -C contained entirely in DPN(I) and subsequent double-precision -C computations can be performed without further consideration of -C extended-range arithmetic. However, if IPN(I) .NE. 0 the corre- -C sponding value of the normalized Legendre polynomial cannot be -C represented in double-precision because of overflow or under- -C flow. THE USER MUST TEST IPN(I) IN HIS/HER PROGRAM. In the case -C that IPN(I) is nonzero, the user could rewrite his/her program -C to use extended range arithmetic. -C -C -C -C The interpretation of (DPN(I),IPN(I)) can be changed to -C DPN(I)*(10**IPN(I)) by calling the extended-range subroutine -C DXCON. This should be done before printing the computed values. -C As an example of usage, the Fortran coding -C J = K -C DO 20 I = 1, K -C CALL DXCON(DPN(I), IPN(I),IERROR) -C IF (IERROR.NE.0) RETURN -C PRINT 10, DPN(I), IPN(I) -C 10 FORMAT(1X, D30.18 , I15) -C IF ((IPN(I) .EQ. 0) .OR. (J .LT. K)) GO TO 20 -C J = I - 1 -C 20 CONTINUE -C will print all computed values and determine the largest J -C such that IPN(1) = IPN(2) = ... = IPN(J) = 0. Because of the -C change of representation caused by calling DXCON, (DPN(I), -C IPN(I)) for I = J+1, J+2, ... cannot be used in subsequent -C extended-range computations. -C -C IERROR is an error indicator. If no errors are detected, -C IERROR=0 when control returns to the calling routine. If -C an error is detected, IERROR is returned as nonzero. The -C calling routine must check the value of IERROR. -C -C If IERROR=212 or 213, invalid input was provided to DXNRMP. -C If IERROR=201,202,203, or 204, invalid input was provided -C to DXSET. -C If IERROR=205 or 206, an internal consistency error occurred -C in DXSET (probably due to a software malfunction in the -C library routine I1MACH). -C If IERROR=207, an overflow or underflow of an extended-range -C number was detected in DXADJ. -C If IERROR=208, an overflow or underflow of an extended-range -C number was detected in DXC210. -C -C***SEE ALSO DXSET -C***REFERENCES Smith, Olver and Lozier, Extended-Range Arithmetic and -C Normalized Legendre Polynomials, ACM Trans on Math -C Softw, v 7, n 1, March 1981, pp 93--105. -C***ROUTINES CALLED DXADD, DXADJ, DXRED, DXSET, XERMSG -C***REVISION HISTORY (YYMMDD) -C 820712 DATE WRITTEN -C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Changed all specific intrinsics to generic. (WRB) -C Corrected order of sections in prologue and added TYPE -C section. (WRB) -C CALLs to XERROR changed to CALLs to XERMSG. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE DXNRMP - INTEGER NU, MU1, MU2, MODE, IPN, ISIG - DOUBLE PRECISION DARG, DPN - DIMENSION DPN(*), IPN(*) - DOUBLE PRECISION C1,C2,P,P1,P2,P3,S,SX,T,TX,X,DK -C CALL DXSET TO INITIALIZE EXTENDED-RANGE ARITHMETIC (SEE DXSET -C LISTING FOR DETAILS) -C***FIRST EXECUTABLE STATEMENT DXNRMP - IERROR=0 - CALL DXSET (0, 0, 0.0D0, 0,IERROR) - IF (IERROR.NE.0) RETURN -C -C TEST FOR PROPER INPUT VALUES. -C - IF (NU.LT.0) GO TO 110 - IF (MU1.LT.0) GO TO 110 - IF (MU1.GT.MU2) GO TO 110 - IF (NU.EQ.0) GO TO 90 - IF (MODE.LT.1 .OR. MODE.GT.2) GO TO 110 - GO TO (10, 20), MODE - 10 IF (ABS(DARG).GT.1.0D0) GO TO 120 - IF (ABS(DARG).EQ.1.0D0) GO TO 90 - X = DARG - SX = SQRT((1.0D0+ABS(X))*((0.5D0-ABS(X))+0.5D0)) - TX = X/SX - ISIG = LOG10(2.0D0*NU*(5.0D0+TX**2)) - GO TO 30 - 20 IF (ABS(DARG).GT.4.0D0*ATAN(1.0D0)) GO TO 120 - IF (DARG.EQ.0.0D0) GO TO 90 - X = COS(DARG) - SX = ABS(SIN(DARG)) - TX = X/SX - ISIG = LOG10(2.0D0*NU*(5.0D0+ABS(DARG*TX))) -C -C BEGIN CALCULATION -C - 30 MU = MU2 - I = MU2 - MU1 + 1 -C -C IF MU.GT.NU, NORMALIZED LEGENDRE(NU,MU,X)=0. -C - 40 IF (MU.LE.NU) GO TO 50 - DPN(I) = 0.0D0 - IPN(I) = 0 - I = I - 1 - MU = MU - 1 - IF (I .GT. 0) GO TO 40 - ISIG = 0 - GO TO 160 - 50 MU = NU -C -C P1 = 0. = NORMALIZED LEGENDRE(NU,NU+1,X) -C - P1 = 0.0D0 - IP1 = 0 -C -C CALCULATE P2 = NORMALIZED LEGENDRE(NU,NU,X) -C - P2 = 1.0D0 - IP2 = 0 - P3 = 0.5D0 - DK = 2.0D0 - DO 60 J=1,NU - P3 = ((DK+1.0D0)/DK)*P3 - P2 = P2*SX - CALL DXADJ(P2, IP2,IERROR) - IF (IERROR.NE.0) RETURN - DK = DK + 2.0D0 - 60 CONTINUE - P2 = P2*SQRT(P3) - CALL DXADJ(P2, IP2,IERROR) - IF (IERROR.NE.0) RETURN - S = 2.0D0*TX - T = 1.0D0/NU - IF (MU2.LT.NU) GO TO 70 - DPN(I) = P2 - IPN(I) = IP2 - I = I - 1 - IF (I .EQ. 0) GO TO 140 -C -C RECURRENCE PROCESS -C - 70 P = MU*T - C1 = 1.0D0/SQRT((1.0D0-P+T)*(1.0D0+P)) - C2 = S*P*C1*P2 - C1 = -SQRT((1.0D0+P+T)*(1.0D0-P))*C1*P1 - CALL DXADD(C2, IP2, C1, IP1, P, IP,IERROR) - IF (IERROR.NE.0) RETURN - MU = MU - 1 - IF (MU.GT.MU2) GO TO 80 -C -C STORE IN ARRAY DPN FOR RETURN TO CALLING ROUTINE. -C - DPN(I) = P - IPN(I) = IP - I = I - 1 - IF (I .EQ. 0) GO TO 140 - 80 P1 = P2 - IP1 = IP2 - P2 = P - IP2 = IP - IF (MU.LE.MU1) GO TO 140 - GO TO 70 -C -C SPECIAL CASE WHEN X=-1 OR +1, OR NU=0. -C - 90 K = MU2 - MU1 + 1 - DO 100 I=1,K - DPN(I) = 0.0D0 - IPN(I) = 0 - 100 CONTINUE - ISIG = 0 - IF (MU1.GT.0) GO TO 160 - ISIG = 1 - DPN(1) = SQRT(NU+0.5D0) - IPN(1) = 0 - IF (MOD(NU,2).EQ.0) GO TO 160 - IF (MODE.EQ.1 .AND. DARG.EQ.1.0D0) GO TO 160 - IF (MODE.EQ.2) GO TO 160 - DPN(1) = -DPN(1) - GO TO 160 -C -C ERROR PRINTOUTS AND TERMINATION. -C - 110 CALL XERMSG ('SLATEC', 'DXNRMP', 'NU, MU1, MU2 or MODE not valid', - + 212, 1) - IERROR=212 - RETURN - 120 CALL XERMSG ('SLATEC', 'DXNRMP', 'DARG out of range', 213, 1) - IERROR=213 - RETURN -C -C RETURN TO CALLING PROGRAM -C - 140 K = MU2 - MU1 + 1 - DO 150 I=1,K - CALL DXRED(DPN(I),IPN(I),IERROR) - IF (IERROR.NE.0) RETURN - 150 CONTINUE - 160 RETURN - END diff --git a/slatec/dxpmu.f b/slatec/dxpmu.f deleted file mode 100644 index fa5967a..0000000 --- a/slatec/dxpmu.f +++ /dev/null @@ -1,69 +0,0 @@ -*DECK DXPMU - SUBROUTINE DXPMU (NU1, NU2, MU1, MU2, THETA, X, SX, ID, PQA, IPQA, - 1 IERROR) -C***BEGIN PROLOGUE DXPMU -C***SUBSIDIARY -C***PURPOSE To compute the values of Legendre functions for DXLEGF. -C Method: backward mu-wise recurrence for P(-MU,NU,X) for -C fixed nu to obtain P(-MU2,NU1,X), P(-(MU2-1),NU1,X), ..., -C P(-MU1,NU1,X) and store in ascending mu order. -C***LIBRARY SLATEC -C***CATEGORY C3A2, C9 -C***TYPE DOUBLE PRECISION (XPMU-S, DXPMU-D) -C***KEYWORDS LEGENDRE FUNCTIONS -C***AUTHOR Smith, John M., (NBS and George Mason University) -C***ROUTINES CALLED DXADD, DXADJ, DXPQNU -C***REVISION HISTORY (YYMMDD) -C 820728 DATE WRITTEN -C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Changed all specific intrinsics to generic. (WRB) -C Corrected order of sections in prologue and added TYPE -C section. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE DXPMU - DOUBLE PRECISION PQA,NU1,NU2,P0,X,SX,THETA,X1,X2 - DIMENSION PQA(*),IPQA(*) -C -C CALL DXPQNU TO OBTAIN P(-MU2,NU,X) -C -C***FIRST EXECUTABLE STATEMENT DXPMU - IERROR=0 - CALL DXPQNU(NU1,NU2,MU2,THETA,ID,PQA,IPQA,IERROR) - IF (IERROR.NE.0) RETURN - P0=PQA(1) - IP0=IPQA(1) - MU=MU2-1 -C -C CALL DXPQNU TO OBTAIN P(-MU2-1,NU,X) -C - CALL DXPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR) - IF (IERROR.NE.0) RETURN - N=MU2-MU1+1 - PQA(N)=P0 - IPQA(N)=IP0 - IF(N.EQ.1) GO TO 300 - PQA(N-1)=PQA(1) - IPQA(N-1)=IPQA(1) - IF(N.EQ.2) GO TO 300 - J=N-2 - 290 CONTINUE -C -C BACKWARD RECURRENCE IN MU TO OBTAIN -C P(-MU2,NU1,X),P(-(MU2-1),NU1,X),....P(-MU1,NU1,X) -C USING -C (NU-MU)*(NU+MU+1.)*P(-(MU+1),NU,X)= -C 2.*MU*X*SQRT((1./(1.-X**2))*P(-MU,NU,X)-P(-(MU-1),NU,X) -C - X1=2.D0*MU*X*SX*PQA(J+1) - X2=-(NU1-MU)*(NU1+MU+1.D0)*PQA(J+2) - CALL DXADD(X1,IPQA(J+1),X2,IPQA(J+2),PQA(J),IPQA(J),IERROR) - IF (IERROR.NE.0) RETURN - CALL DXADJ(PQA(J),IPQA(J),IERROR) - IF (IERROR.NE.0) RETURN - IF(J.EQ.1) GO TO 300 - J=J-1 - MU=MU-1 - GO TO 290 - 300 RETURN - END diff --git a/slatec/dxpmup.f b/slatec/dxpmup.f deleted file mode 100644 index 796f765..0000000 --- a/slatec/dxpmup.f +++ /dev/null @@ -1,76 +0,0 @@ -*DECK DXPMUP - SUBROUTINE DXPMUP (NU1, NU2, MU1, MU2, PQA, IPQA, IERROR) -C***BEGIN PROLOGUE DXPMUP -C***SUBSIDIARY -C***PURPOSE To compute the values of Legendre functions for DXLEGF. -C This subroutine transforms an array of Legendre functions -C of the first kind of negative order stored in array PQA -C into Legendre functions of the first kind of positive -C order stored in array PQA. The original array is destroyed. -C***LIBRARY SLATEC -C***CATEGORY C3A2, C9 -C***TYPE DOUBLE PRECISION (XPMUP-S, DXPMUP-D) -C***KEYWORDS LEGENDRE FUNCTIONS -C***AUTHOR Smith, John M., (NBS and George Mason University) -C***ROUTINES CALLED DXADJ -C***REVISION HISTORY (YYMMDD) -C 820728 DATE WRITTEN -C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Changed all specific intrinsics to generic. (WRB) -C Corrected order of sections in prologue and added TYPE -C section. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE DXPMUP - DOUBLE PRECISION DMU,NU,NU1,NU2,PQA,PROD - DIMENSION PQA(*),IPQA(*) -C***FIRST EXECUTABLE STATEMENT DXPMUP - IERROR=0 - NU=NU1 - MU=MU1 - DMU=MU - N=INT(NU2-NU1+.1D0)+(MU2-MU1)+1 - J=1 - IF(MOD(REAL(NU),1.).NE.0.) GO TO 210 - 200 IF(DMU.LT.NU+1.D0) GO TO 210 - PQA(J)=0.D0 - IPQA(J)=0 - J=J+1 - IF(J.GT.N) RETURN -C INCREMENT EITHER MU OR NU AS APPROPRIATE. - IF(NU2-NU1.GT..5D0) NU=NU+1.D0 - IF(MU2.GT.MU1) MU=MU+1 - GO TO 200 -C -C TRANSFORM P(-MU,NU,X) TO P(MU,NU,X) USING -C P(MU,NU,X)=(NU-MU+1)*(NU-MU+2)*...*(NU+MU)*P(-MU,NU,X)*(-1)**MU -C - 210 PROD=1.D0 - IPROD=0 - K=2*MU - IF(K.EQ.0) GO TO 222 - DO 220 L=1,K - PROD=PROD*(DMU-NU-L) - 220 CALL DXADJ(PROD,IPROD,IERROR) - IF (IERROR.NE.0) RETURN - 222 CONTINUE - DO 240 I=J,N - IF(MU.EQ.0) GO TO 225 - PQA(I)=PQA(I)*PROD*(-1)**MU - IPQA(I)=IPQA(I)+IPROD - CALL DXADJ(PQA(I),IPQA(I),IERROR) - IF (IERROR.NE.0) RETURN - 225 IF(NU2-NU1.GT..5D0) GO TO 230 - PROD=(DMU-NU)*PROD*(-DMU-NU-1.D0) - CALL DXADJ(PROD,IPROD,IERROR) - IF (IERROR.NE.0) RETURN - MU=MU+1 - DMU=DMU+1.D0 - GO TO 240 - 230 PROD=PROD*(-DMU-NU-1.D0)/(DMU-NU-1.D0) - CALL DXADJ(PROD,IPROD,IERROR) - IF (IERROR.NE.0) RETURN - NU=NU+1.D0 - 240 CONTINUE - RETURN - END diff --git a/slatec/dxpnrm.f b/slatec/dxpnrm.f deleted file mode 100644 index f83ce14..0000000 --- a/slatec/dxpnrm.f +++ /dev/null @@ -1,89 +0,0 @@ -*DECK DXPNRM - SUBROUTINE DXPNRM (NU1, NU2, MU1, MU2, PQA, IPQA, IERROR) -C***BEGIN PROLOGUE DXPNRM -C***SUBSIDIARY -C***PURPOSE To compute the values of Legendre functions for DXLEGF. -C This subroutine transforms an array of Legendre functions -C of the first kind of negative order stored in array PQA -C into normalized Legendre polynomials stored in array PQA. -C The original array is destroyed. -C***LIBRARY SLATEC -C***CATEGORY C3A2, C9 -C***TYPE DOUBLE PRECISION (XPNRM-S, DXPNRM-D) -C***KEYWORDS LEGENDRE FUNCTIONS -C***AUTHOR Smith, John M., (NBS and George Mason University) -C***ROUTINES CALLED DXADJ -C***REVISION HISTORY (YYMMDD) -C 820728 DATE WRITTEN -C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Changed all specific intrinsics to generic. (WRB) -C Corrected order of sections in prologue and added TYPE -C section. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE DXPNRM - DOUBLE PRECISION C1,DMU,NU,NU1,NU2,PQA,PROD - DIMENSION PQA(*),IPQA(*) -C***FIRST EXECUTABLE STATEMENT DXPNRM - IERROR=0 - L=(MU2-MU1)+(NU2-NU1+1.5D0) - MU=MU1 - DMU=MU1 - NU=NU1 -C -C IF MU .GT.NU, NORM P =0. -C - J=1 - 500 IF(DMU.LE.NU) GO TO 505 - PQA(J)=0.D0 - IPQA(J)=0 - J=J+1 - IF(J.GT.L) RETURN -C -C INCREMENT EITHER MU OR NU AS APPROPRIATE. -C - IF(MU2.GT.MU1) DMU=DMU+1.D0 - IF(NU2-NU1.GT..5D0) NU=NU+1.D0 - GO TO 500 -C -C TRANSFORM P(-MU,NU,X) INTO NORMALIZED P(MU,NU,X) USING -C NORM P(MU,NU,X)= -C SQRT((NU+.5)*FACTORIAL(NU+MU)/FACTORIAL(NU-MU)) -C *P(-MU,NU,X) -C - 505 PROD=1.D0 - IPROD=0 - K=2*MU - IF(K.LE.0) GO TO 520 - DO 510 I=1,K - PROD=PROD*SQRT(NU+DMU+1.D0-I) - 510 CALL DXADJ(PROD,IPROD,IERROR) - IF (IERROR.NE.0) RETURN - 520 DO 540 I=J,L - C1=PROD*SQRT(NU+.5D0) - PQA(I)=PQA(I)*C1 - IPQA(I)=IPQA(I)+IPROD - CALL DXADJ(PQA(I),IPQA(I),IERROR) - IF (IERROR.NE.0) RETURN - IF(NU2-NU1.GT..5D0) GO TO 530 - IF(DMU.GE.NU) GO TO 525 - PROD=SQRT(NU+DMU+1.D0)*PROD - IF(NU.GT.DMU) PROD=PROD*SQRT(NU-DMU) - CALL DXADJ(PROD,IPROD,IERROR) - IF (IERROR.NE.0) RETURN - MU=MU+1 - DMU=DMU+1.D0 - GO TO 540 - 525 PROD=0.D0 - IPROD=0 - MU=MU+1 - DMU=DMU+1.D0 - GO TO 540 - 530 PROD=SQRT(NU+DMU+1.D0)*PROD - IF(NU.NE.DMU-1.D0) PROD=PROD/SQRT(NU-DMU+1.D0) - CALL DXADJ(PROD,IPROD,IERROR) - IF (IERROR.NE.0) RETURN - NU=NU+1.D0 - 540 CONTINUE - RETURN - END diff --git a/slatec/dxpqnu.f b/slatec/dxpqnu.f deleted file mode 100644 index 25a2e13..0000000 --- a/slatec/dxpqnu.f +++ /dev/null @@ -1,193 +0,0 @@ -*DECK DXPQNU - SUBROUTINE DXPQNU (NU1, NU2, MU, THETA, ID, PQA, IPQA, IERROR) -C***BEGIN PROLOGUE DXPQNU -C***SUBSIDIARY -C***PURPOSE To compute the values of Legendre functions for DXLEGF. -C This subroutine calculates initial values of P or Q using -C power series, then performs forward nu-wise recurrence to -C obtain P(-MU,NU,X), Q(0,NU,X), or Q(1,NU,X). The nu-wise -C recurrence is stable for P for all mu and for Q for mu=0,1. -C***LIBRARY SLATEC -C***CATEGORY C3A2, C9 -C***TYPE DOUBLE PRECISION (XPQNU-S, DXPQNU-D) -C***KEYWORDS LEGENDRE FUNCTIONS -C***AUTHOR Smith, John M., (NBS and George Mason University) -C***ROUTINES CALLED DXADD, DXADJ, DXPSI -C***COMMON BLOCKS DXBLK1 -C***REVISION HISTORY (YYMMDD) -C 820728 DATE WRITTEN -C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Changed all specific intrinsics to generic. (WRB) -C Corrected order of sections in prologue and added TYPE -C section. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE DXPQNU - DOUBLE PRECISION A,NU,NU1,NU2,PQ,PQA,DXPSI,R,THETA,W,X,X1,X2,XS, - 1 Y,Z - DOUBLE PRECISION DI,DMU,PQ1,PQ2,FACTMU,FLOK - DIMENSION PQA(*),IPQA(*) - COMMON /DXBLK1/ NBITSF - SAVE /DXBLK1/ -C -C J0, IPSIK, AND IPSIX ARE INITIALIZED IN THIS SUBROUTINE. -C J0 IS THE NUMBER OF TERMS USED IN SERIES EXPANSION -C IN SUBROUTINE DXPQNU. -C IPSIK, IPSIX ARE VALUES OF K AND X RESPECTIVELY -C USED IN THE CALCULATION OF THE DXPSI FUNCTION. -C -C***FIRST EXECUTABLE STATEMENT DXPQNU - IERROR=0 - J0=NBITSF - IPSIK=1+(NBITSF/10) - IPSIX=5*IPSIK - IPQ=0 -C FIND NU IN INTERVAL [-.5,.5) IF ID=2 ( CALCULATION OF Q ) - NU=MOD(NU1,1.D0) - IF(NU.GE..5D0) NU=NU-1.D0 -C FIND NU IN INTERVAL (-1.5,-.5] IF ID=1,3, OR 4 ( CALC. OF P ) - IF(ID.NE.2.AND.NU.GT.-.5D0) NU=NU-1.D0 -C CALCULATE MU FACTORIAL - K=MU - DMU=MU - IF(MU.LE.0) GO TO 60 - FACTMU=1.D0 - IF=0 - DO 50 I=1,K - FACTMU=FACTMU*I - 50 CALL DXADJ(FACTMU,IF,IERROR) - IF (IERROR.NE.0) RETURN - 60 IF(K.EQ.0) FACTMU=1.D0 - IF(K.EQ.0) IF=0 -C -C X=COS(THETA) -C Y=SIN(THETA/2)**2=(1-X)/2=.5-.5*X -C R=TAN(THETA/2)=SQRT((1-X)/(1+X) -C - X=COS(THETA) - Y=SIN(THETA/2.D0)**2 - R=TAN(THETA/2.D0) -C -C USE ASCENDING SERIES TO CALCULATE TWO VALUES OF P OR Q -C FOR USE AS STARTING VALUES IN RECURRENCE RELATION. -C - PQ2=0.0D0 - DO 100 J=1,2 - IPQ1=0 - IF(ID.EQ.2) GO TO 80 -C -C SERIES FOR P ( ID = 1, 3, OR 4 ) -C P(-MU,NU,X)=1./FACTORIAL(MU)*SQRT(((1.-X)/(1.+X))**MU) -C *SUM(FROM 0 TO J0-1)A(J)*(.5-.5*X)**J -C - IPQ=0 - PQ=1.D0 - A=1.D0 - IA=0 - DO 65 I=2,J0 - DI=I - A=A*Y*(DI-2.D0-NU)*(DI-1.D0+NU)/((DI-1.D0+DMU)*(DI-1.D0)) - CALL DXADJ(A,IA,IERROR) - IF (IERROR.NE.0) RETURN - IF(A.EQ.0.D0) GO TO 66 - CALL DXADD(PQ,IPQ,A,IA,PQ,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - 65 CONTINUE - 66 CONTINUE - IF(MU.LE.0) GO TO 90 - X2=R - X1=PQ - K=MU - DO 77 I=1,K - X1=X1*X2 - 77 CALL DXADJ(X1,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - PQ=X1/FACTMU - IPQ=IPQ-IF - CALL DXADJ(PQ,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - GO TO 90 -C -C Z=-LN(R)=.5*LN((1+X)/(1-X)) -C - 80 Z=-LOG(R) - W=DXPSI(NU+1.D0,IPSIK,IPSIX) - XS=1.D0/SIN(THETA) -C -C SERIES SUMMATION FOR Q ( ID = 2 ) -C Q(0,NU,X)=SUM(FROM 0 TO J0-1)((.5*LN((1+X)/(1-X)) -C +DXPSI(J+1,IPSIK,IPSIX)-DXPSI(NU+1,IPSIK,IPSIX)))*A(J)*(.5-.5*X)**J -C -C Q(1,NU,X)=-SQRT(1./(1.-X**2))+SQRT((1-X)/(1+X)) -C *SUM(FROM 0 T0 J0-1)(-NU*(NU+1)/2*LN((1+X)/(1-X)) -C +(J-NU)*(J+NU+1)/(2*(J+1))+NU*(NU+1)* -C (DXPSI(NU+1,IPSIK,IPSIX)-DXPSI(J+1,IPSIK,IPSIX))*A(J)*(.5-.5*X)**J -C -C NOTE, IN THIS LOOP K=J+1 -C - PQ=0.D0 - IPQ=0 - IA=0 - A=1.D0 - DO 85 K=1,J0 - FLOK=K - IF(K.EQ.1) GO TO 81 - A=A*Y*(FLOK-2.D0-NU)*(FLOK-1.D0+NU)/((FLOK-1.D0+DMU)*(FLOK-1.D0)) - CALL DXADJ(A,IA,IERROR) - IF (IERROR.NE.0) RETURN - 81 CONTINUE - IF(MU.GE.1) GO TO 83 - X1=(DXPSI(FLOK,IPSIK,IPSIX)-W+Z)*A - IX1=IA - CALL DXADD(PQ,IPQ,X1,IX1,PQ,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - GO TO 85 - 83 X1=(NU*(NU+1.D0)*(Z-W+DXPSI(FLOK,IPSIK,IPSIX))+(NU-FLOK+1.D0) - 1 *(NU+FLOK)/(2.D0*FLOK))*A - IX1=IA - CALL DXADD(PQ,IPQ,X1,IX1,PQ,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - 85 CONTINUE - IF(MU.GE.1) PQ=-R*PQ - IXS=0 - IF(MU.GE.1) CALL DXADD(PQ,IPQ,-XS,IXS,PQ,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - IF(J.EQ.2) MU=-MU - IF(J.EQ.2) DMU=-DMU - 90 IF(J.EQ.1) PQ2=PQ - IF(J.EQ.1) IPQ2=IPQ - NU=NU+1.D0 - 100 CONTINUE - K=0 - IF(NU-1.5D0.LT.NU1) GO TO 120 - K=K+1 - PQA(K)=PQ2 - IPQA(K)=IPQ2 - IF(NU.GT.NU2+.5D0) RETURN - 120 PQ1=PQ - IPQ1=IPQ - IF(NU.LT.NU1+.5D0) GO TO 130 - K=K+1 - PQA(K)=PQ - IPQA(K)=IPQ - IF(NU.GT.NU2+.5D0) RETURN -C -C FORWARD NU-WISE RECURRENCE FOR F(MU,NU,X) FOR FIXED MU -C USING -C (NU+MU+1)*F(MU,NU,X)=(2.*NU+1)*F(MU,NU,X)-(NU-MU)*F(MU,NU-1,X) -C WHERE F(MU,NU,X) MAY BE P(-MU,NU,X) OR IF MU IS REPLACED -C BY -MU THEN F(MU,NU,X) MAY BE Q(MU,NU,X). -C NOTE, IN THIS LOOP, NU=NU+1 -C - 130 X1=(2.D0*NU-1.D0)/(NU+DMU)*X*PQ1 - X2=(NU-1.D0-DMU)/(NU+DMU)*PQ2 - CALL DXADD(X1,IPQ1,-X2,IPQ2,PQ,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - CALL DXADJ(PQ,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - NU=NU+1.D0 - PQ2=PQ1 - IPQ2=IPQ1 - GO TO 120 -C - END diff --git a/slatec/dxpsi.f b/slatec/dxpsi.f deleted file mode 100644 index cfd8a65..0000000 --- a/slatec/dxpsi.f +++ /dev/null @@ -1,59 +0,0 @@ -*DECK DXPSI - DOUBLE PRECISION FUNCTION DXPSI (A, IPSIK, IPSIX) -C***BEGIN PROLOGUE DXPSI -C***SUBSIDIARY -C***PURPOSE To compute values of the Psi function for DXLEGF. -C***LIBRARY SLATEC -C***CATEGORY C7C -C***TYPE DOUBLE PRECISION (XPSI-S, DXPSI-D) -C***KEYWORDS PSI FUNCTION -C***AUTHOR Smith, John M., (NBS and George Mason University) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 820728 DATE WRITTEN -C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Changed all specific intrinsics to generic. (WRB) -C Corrected order of sections in prologue and added TYPE -C section. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE DXPSI - DOUBLE PRECISION A,B,C,CNUM,CDENOM - DIMENSION CNUM(12),CDENOM(12) - SAVE CNUM, CDENOM -C -C CNUM(I) AND CDENOM(I) ARE THE ( REDUCED ) NUMERATOR -C AND 2*I*DENOMINATOR RESPECTIVELY OF THE 2*I TH BERNOULLI -C NUMBER. -C - DATA CNUM(1),CNUM(2),CNUM(3),CNUM(4),CNUM(5),CNUM(6),CNUM(7), - 1CNUM(8),CNUM(9),CNUM(10),CNUM(11),CNUM(12) - 2 / 1.D0, -1.D0, 1.D0, -1.D0, 1.D0, - 3 -691.D0, 1.D0, -3617.D0, 43867.D0, -174611.D0, 77683.D0, - 4 -236364091.D0/ - DATA CDENOM(1),CDENOM(2),CDENOM(3),CDENOM(4),CDENOM(5),CDENOM(6), - 1 CDENOM(7),CDENOM(8),CDENOM(9),CDENOM(10),CDENOM(11),CDENOM(12) - 2/12.D0,120.D0, 252.D0, 240.D0,132.D0, - 3 32760.D0, 12.D0, 8160.D0, 14364.D0, 6600.D0, 276.D0, 65520.D0/ -C***FIRST EXECUTABLE STATEMENT DXPSI - N=MAX(0,IPSIX-INT(A)) - B=N+A - K1=IPSIK-1 -C -C SERIES EXPANSION FOR A .GT. IPSIX USING IPSIK-1 TERMS. -C - C=0.D0 - DO 12 I=1,K1 - K=IPSIK-I - 12 C=(C+CNUM(K)/CDENOM(K))/B**2 - DXPSI=LOG(B)-(C+.5D0/B) - IF(N.EQ.0) GO TO 20 - B=0.D0 -C -C RECURRENCE FOR A .LE. IPSIX. -C - DO 15 M=1,N - 15 B=B+1.D0/(N-M+A) - DXPSI=DXPSI-B - 20 RETURN - END diff --git a/slatec/dxqmu.f b/slatec/dxqmu.f deleted file mode 100644 index 034ed2b..0000000 --- a/slatec/dxqmu.f +++ /dev/null @@ -1,83 +0,0 @@ -*DECK DXQMU - SUBROUTINE DXQMU (NU1, NU2, MU1, MU2, THETA, X, SX, ID, PQA, IPQA, - 1 IERROR) -C***BEGIN PROLOGUE DXQMU -C***SUBSIDIARY -C***PURPOSE To compute the values of Legendre functions for DXLEGF. -C Method: forward mu-wise recurrence for Q(MU,NU,X) for fixed -C nu to obtain Q(MU1,NU,X), Q(MU1+1,NU,X), ..., Q(MU2,NU,X). -C***LIBRARY SLATEC -C***CATEGORY C3A2, C9 -C***TYPE DOUBLE PRECISION (XQMU-S, DXQMU-D) -C***KEYWORDS LEGENDRE FUNCTIONS -C***AUTHOR Smith, John M., (NBS and George Mason University) -C***ROUTINES CALLED DXADD, DXADJ, DXPQNU -C***REVISION HISTORY (YYMMDD) -C 820728 DATE WRITTEN -C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Corrected order of sections in prologue and added TYPE -C section. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE DXQMU - DIMENSION PQA(*),IPQA(*) - DOUBLE PRECISION DMU,NU,NU1,NU2,PQ,PQA,PQ1,PQ2,SX,X,X1,X2 - DOUBLE PRECISION THETA -C***FIRST EXECUTABLE STATEMENT DXQMU - IERROR=0 - MU=0 -C -C CALL DXPQNU TO OBTAIN Q(0.,NU1,X) -C - CALL DXPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR) - IF (IERROR.NE.0) RETURN - PQ2=PQA(1) - IPQ2=IPQA(1) - MU=1 -C -C CALL DXPQNU TO OBTAIN Q(1.,NU1,X) -C - CALL DXPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR) - IF (IERROR.NE.0) RETURN - NU=NU1 - K=0 - MU=1 - DMU=1.D0 - PQ1=PQA(1) - IPQ1=IPQA(1) - IF(MU1.GT.0) GO TO 310 - K=K+1 - PQA(K)=PQ2 - IPQA(K)=IPQ2 - IF(MU2.LT.1) GO TO 330 - 310 IF(MU1.GT.1) GO TO 320 - K=K+1 - PQA(K)=PQ1 - IPQA(K)=IPQ1 - IF(MU2.LE.1) GO TO 330 - 320 CONTINUE -C -C FORWARD RECURRENCE IN MU TO OBTAIN -C Q(MU1,NU,X),Q(MU1+1,NU,X),....,Q(MU2,NU,X) USING -C Q(MU+1,NU,X)=-2.*MU*X*SQRT(1./(1.-X**2))*Q(MU,NU,X) -C -(NU+MU)*(NU-MU+1.)*Q(MU-1,NU,X) -C - X1=-2.D0*DMU*X*SX*PQ1 - X2=(NU+DMU)*(NU-DMU+1.D0)*PQ2 - CALL DXADD(X1,IPQ1,-X2,IPQ2,PQ,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - CALL DXADJ(PQ,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - PQ2=PQ1 - IPQ2=IPQ1 - PQ1=PQ - IPQ1=IPQ - MU=MU+1 - DMU=DMU+1.D0 - IF(MU.LT.MU1) GO TO 320 - K=K+1 - PQA(K)=PQ - IPQA(K)=IPQ - IF(MU2.GT.MU) GO TO 320 - 330 RETURN - END diff --git a/slatec/dxqnu.f b/slatec/dxqnu.f deleted file mode 100644 index bd4b7ee..0000000 --- a/slatec/dxqnu.f +++ /dev/null @@ -1,124 +0,0 @@ -*DECK DXQNU - SUBROUTINE DXQNU (NU1, NU2, MU1, THETA, X, SX, ID, PQA, IPQA, - 1 IERROR) -C***BEGIN PROLOGUE DXQNU -C***SUBSIDIARY -C***PURPOSE To compute the values of Legendre functions for DXLEGF. -C Method: backward nu-wise recurrence for Q(MU,NU,X) for -C fixed mu to obtain Q(MU1,NU1,X), Q(MU1,NU1+1,X), ..., -C Q(MU1,NU2,X). -C***LIBRARY SLATEC -C***CATEGORY C3A2, C9 -C***TYPE DOUBLE PRECISION (XQNU-S, DXQNU-D) -C***KEYWORDS LEGENDRE FUNCTIONS -C***AUTHOR Smith, John M., (NBS and George Mason University) -C***ROUTINES CALLED DXADD, DXADJ, DXPQNU -C***REVISION HISTORY (YYMMDD) -C 820728 DATE WRITTEN -C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Corrected order of sections in prologue and added TYPE -C section. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE DXQNU - DIMENSION PQA(*),IPQA(*) - DOUBLE PRECISION DMU,NU,NU1,NU2,PQ,PQA,PQ1,PQ2,SX,X,X1,X2 - DOUBLE PRECISION THETA,PQL1,PQL2 -C***FIRST EXECUTABLE STATEMENT DXQNU - IERROR=0 - K=0 - PQ2=0.0D0 - IPQ2=0 - PQL2=0.0D0 - IPQL2=0 - IF(MU1.EQ.1) GO TO 290 - MU=0 -C -C CALL DXPQNU TO OBTAIN Q(0.,NU2,X) AND Q(0.,NU2-1,X) -C - CALL DXPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR) - IF (IERROR.NE.0) RETURN - IF(MU1.EQ.0) RETURN - K=(NU2-NU1+1.5D0) - PQ2=PQA(K) - IPQ2=IPQA(K) - PQL2=PQA(K-1) - IPQL2=IPQA(K-1) - 290 MU=1 -C -C CALL DXPQNU TO OBTAIN Q(1.,NU2,X) AND Q(1.,NU2-1,X) -C - CALL DXPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR) - IF (IERROR.NE.0) RETURN - IF(MU1.EQ.1) RETURN - NU=NU2 - PQ1=PQA(K) - IPQ1=IPQA(K) - PQL1=PQA(K-1) - IPQL1=IPQA(K-1) - 300 MU=1 - DMU=1.D0 - 320 CONTINUE -C -C FORWARD RECURRENCE IN MU TO OBTAIN Q(MU1,NU2,X) AND -C Q(MU1,NU2-1,X) USING -C Q(MU+1,NU,X)=-2.*MU*X*SQRT(1./(1.-X**2))*Q(MU,NU,X) -C -(NU+MU)*(NU-MU+1.)*Q(MU-1,NU,X) -C -C FIRST FOR NU=NU2 -C - X1=-2.D0*DMU*X*SX*PQ1 - X2=(NU+DMU)*(NU-DMU+1.D0)*PQ2 - CALL DXADD(X1,IPQ1,-X2,IPQ2,PQ,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - CALL DXADJ(PQ,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - PQ2=PQ1 - IPQ2=IPQ1 - PQ1=PQ - IPQ1=IPQ - MU=MU+1 - DMU=DMU+1.D0 - IF(MU.LT.MU1) GO TO 320 - PQA(K)=PQ - IPQA(K)=IPQ - IF(K.EQ.1) RETURN - IF(NU.LT.NU2) GO TO 340 -C -C THEN FOR NU=NU2-1 -C - NU=NU-1.D0 - PQ2=PQL2 - IPQ2=IPQL2 - PQ1=PQL1 - IPQ1=IPQL1 - K=K-1 - GO TO 300 -C -C BACKWARD RECURRENCE IN NU TO OBTAIN -C Q(MU1,NU1,X),Q(MU1,NU1+1,X),....,Q(MU1,NU2,X) -C USING -C (NU-MU+1.)*Q(MU,NU+1,X)= -C (2.*NU+1.)*X*Q(MU,NU,X)-(NU+MU)*Q(MU,NU-1,X) -C - 340 PQ1=PQA(K) - IPQ1=IPQA(K) - PQ2=PQA(K+1) - IPQ2=IPQA(K+1) - 350 IF(NU.LE.NU1) RETURN - K=K-1 - X1=(2.D0*NU+1.D0)*X*PQ1/(NU+DMU) - X2=-(NU-DMU+1.D0)*PQ2/(NU+DMU) - CALL DXADD(X1,IPQ1,X2,IPQ2,PQ,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - CALL DXADJ(PQ,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - PQ2=PQ1 - IPQ2=IPQ1 - PQ1=PQ - IPQ1=IPQ - PQA(K)=PQ - IPQA(K)=IPQ - NU=NU-1.D0 - GO TO 350 - END diff --git a/slatec/dxred.f b/slatec/dxred.f deleted file mode 100644 index 929dfec..0000000 --- a/slatec/dxred.f +++ /dev/null @@ -1,85 +0,0 @@ -*DECK DXRED - SUBROUTINE DXRED (X, IX, IERROR) -C***BEGIN PROLOGUE DXRED -C***PURPOSE To provide double-precision floating-point arithmetic -C with an extended exponent range. -C***LIBRARY SLATEC -C***CATEGORY A3D -C***TYPE DOUBLE PRECISION (XRED-S, DXRED-D) -C***KEYWORDS EXTENDED-RANGE DOUBLE-PRECISION ARITHMETIC -C***AUTHOR Lozier, Daniel W., (National Bureau of Standards) -C Smith, John M., (NBS and George Mason University) -C***DESCRIPTION -C DOUBLE PRECISION X -C INTEGER IX -C -C IF -C RADIX**(-2L) .LE. (ABS(X),IX) .LE. RADIX**(2L) -C THEN DXRED TRANSFORMS (X,IX) SO THAT IX=0. -C IF (X,IX) IS OUTSIDE THE ABOVE RANGE, -C THEN DXRED TAKES NO ACTION. -C THIS SUBROUTINE IS USEFUL IF THE -C RESULTS OF EXTENDED-RANGE CALCULATIONS -C ARE TO BE USED IN SUBSEQUENT ORDINARY -C DOUBLE-PRECISION CALCULATIONS. -C -C***SEE ALSO DXSET -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS DXBLK2 -C***REVISION HISTORY (YYMMDD) -C 820712 DATE WRITTEN -C 881020 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Changed all specific intrinsics to generic. (WRB) -C Corrected order of sections in prologue and added TYPE -C section. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE DXRED - DOUBLE PRECISION X - INTEGER IX - DOUBLE PRECISION RADIX, RADIXL, RAD2L, DLG10R, XA - INTEGER L, L2, KMAX - COMMON /DXBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX - SAVE /DXBLK2/ -C -C***FIRST EXECUTABLE STATEMENT DXRED - IERROR=0 - IF (X.EQ.0.0D0) GO TO 90 - XA = ABS(X) - IF (IX.EQ.0) GO TO 70 - IXA = ABS(IX) - IXA1 = IXA/L2 - IXA2 = MOD(IXA,L2) - IF (IX.GT.0) GO TO 40 - 10 CONTINUE - IF (XA.GT.1.0D0) GO TO 20 - XA = XA*RAD2L - IXA1 = IXA1 + 1 - GO TO 10 - 20 XA = XA/RADIX**IXA2 - IF (IXA1.EQ.0) GO TO 70 - DO 30 I=1,IXA1 - IF (XA.LT.1.0D0) GO TO 100 - XA = XA/RAD2L - 30 CONTINUE - GO TO 70 -C - 40 CONTINUE - IF (XA.LT.1.0D0) GO TO 50 - XA = XA/RAD2L - IXA1 = IXA1 + 1 - GO TO 40 - 50 XA = XA*RADIX**IXA2 - IF (IXA1.EQ.0) GO TO 70 - DO 60 I=1,IXA1 - IF (XA.GT.1.0D0) GO TO 100 - XA = XA*RAD2L - 60 CONTINUE - 70 IF (XA.GT.RAD2L) GO TO 100 - IF (XA.GT.1.0D0) GO TO 80 - IF (RAD2L*XA.LT.1.0D0) GO TO 100 - 80 X = SIGN(XA,X) - 90 IX = 0 - 100 RETURN - END diff --git a/slatec/dxset.f b/slatec/dxset.f deleted file mode 100644 index 411971f..0000000 --- a/slatec/dxset.f +++ /dev/null @@ -1,331 +0,0 @@ -*DECK DXSET - SUBROUTINE DXSET (IRAD, NRADPL, DZERO, NBITS, IERROR) -C***BEGIN PROLOGUE DXSET -C***PURPOSE To provide double-precision floating-point arithmetic -C with an extended exponent range. -C***LIBRARY SLATEC -C***CATEGORY A3D -C***TYPE DOUBLE PRECISION (XSET-S, DXSET-D) -C***KEYWORDS EXTENDED-RANGE DOUBLE-PRECISION ARITHMETIC -C***AUTHOR Lozier, Daniel W., (National Bureau of Standards) -C Smith, John M., (NBS and George Mason University) -C***DESCRIPTION -C -C SUBROUTINE DXSET MUST BE CALLED PRIOR TO CALLING ANY OTHER -C EXTENDED-RANGE SUBROUTINE. IT CALCULATES AND STORES SEVERAL -C MACHINE-DEPENDENT CONSTANTS IN COMMON BLOCKS. THE USER MUST -C SUPPLY FOUR CONSTANTS THAT PERTAIN TO HIS PARTICULAR COMPUTER. -C THE CONSTANTS ARE -C -C IRAD = THE INTERNAL BASE OF DOUBLE-PRECISION -C ARITHMETIC IN THE COMPUTER. -C NRADPL = THE NUMBER OF RADIX PLACES CARRIED IN -C THE DOUBLE-PRECISION REPRESENTATION. -C DZERO = THE SMALLEST OF 1/DMIN, DMAX, DMAXLN WHERE -C DMIN = THE SMALLEST POSITIVE DOUBLE-PRECISION -C NUMBER OR AN UPPER BOUND TO THIS NUMBER, -C DMAX = THE LARGEST DOUBLE-PRECISION NUMBER -C OR A LOWER BOUND TO THIS NUMBER, -C DMAXLN = THE LARGEST DOUBLE-PRECISION NUMBER -C SUCH THAT LOG10(DMAXLN) CAN BE COMPUTED BY THE -C FORTRAN SYSTEM (ON MOST SYSTEMS DMAXLN = DMAX). -C NBITS = THE NUMBER OF BITS (EXCLUSIVE OF SIGN) IN -C AN INTEGER COMPUTER WORD. -C -C ALTERNATIVELY, ANY OR ALL OF THE CONSTANTS CAN BE GIVEN -C THE VALUE 0 (0.0D0 FOR DZERO). IF A CONSTANT IS ZERO, DXSET TRIES -C TO ASSIGN AN APPROPRIATE VALUE BY CALLING I1MACH -C (SEE P.A.FOX, A.D.HALL, N.L.SCHRYER, ALGORITHM 528 FRAMEWORK -C FOR A PORTABLE LIBRARY, ACM TRANSACTIONS ON MATH SOFTWARE, -C V.4, NO.2, JUNE 1978, 177-188). -C -C THIS IS THE SETTING-UP SUBROUTINE FOR A PACKAGE OF SUBROUTINES -C THAT FACILITATE THE USE OF EXTENDED-RANGE ARITHMETIC. EXTENDED-RANGE -C ARITHMETIC ON A PARTICULAR COMPUTER IS DEFINED ON THE SET OF NUMBERS -C OF THE FORM -C -C (X,IX) = X*RADIX**IX -C -C WHERE X IS A DOUBLE-PRECISION NUMBER CALLED THE PRINCIPAL PART, -C IX IS AN INTEGER CALLED THE AUXILIARY INDEX, AND RADIX IS THE -C INTERNAL BASE OF THE DOUBLE-PRECISION ARITHMETIC. OBVIOUSLY, -C EACH REAL NUMBER IS REPRESENTABLE WITHOUT ERROR BY MORE THAN ONE -C EXTENDED-RANGE FORM. CONVERSIONS BETWEEN DIFFERENT FORMS ARE -C ESSENTIAL IN CARRYING OUT ARITHMETIC OPERATIONS. WITH THE CHOICE -C OF RADIX WE HAVE MADE, AND THE SUBROUTINES WE HAVE WRITTEN, THESE -C CONVERSIONS ARE PERFORMED WITHOUT ERROR (AT LEAST ON MOST COMPUTERS). -C (SEE SMITH, J.M., OLVER, F.W.J., AND LOZIER, D.W., EXTENDED-RANGE -C ARITHMETIC AND NORMALIZED LEGENDRE POLYNOMIALS, ACM TRANSACTIONS ON -C MATHEMATICAL SOFTWARE, MARCH 1981). -C -C AN EXTENDED-RANGE NUMBER (X,IX) IS SAID TO BE IN ADJUSTED FORM IF -C X AND IX ARE ZERO OR -C -C RADIX**(-L) .LE. ABS(X) .LT. RADIX**L -C -C IS SATISFIED, WHERE L IS A COMPUTER-DEPENDENT INTEGER DEFINED IN THIS -C SUBROUTINE. TWO EXTENDED-RANGE NUMBERS IN ADJUSTED FORM CAN BE ADDED, -C SUBTRACTED, MULTIPLIED OR DIVIDED (IF THE DIVISOR IS NONZERO) WITHOUT -C CAUSING OVERFLOW OR UNDERFLOW IN THE PRINCIPAL PART OF THE RESULT. -C WITH PROPER USE OF THE EXTENDED-RANGE SUBROUTINES, THE ONLY OVERFLOW -C THAT CAN OCCUR IS INTEGER OVERFLOW IN THE AUXILIARY INDEX. IF THIS -C IS DETECTED, THE SOFTWARE CALLS XERROR (A GENERAL ERROR-HANDLING -C FORTRAN SUBROUTINE PACKAGE). -C -C MULTIPLICATION AND DIVISION IS PERFORMED BY SETTING -C -C (X,IX)*(Y,IY) = (X*Y,IX+IY) -C OR -C (X,IX)/(Y,IY) = (X/Y,IX-IY). -C -C PRE-ADJUSTMENT OF THE OPERANDS IS ESSENTIAL TO AVOID -C OVERFLOW OR UNDERFLOW OF THE PRINCIPAL PART. SUBROUTINE -C DXADJ (SEE BELOW) MAY BE CALLED TO TRANSFORM ANY EXTENDED- -C RANGE NUMBER INTO ADJUSTED FORM. -C -C ADDITION AND SUBTRACTION REQUIRE THE USE OF SUBROUTINE DXADD -C (SEE BELOW). THE INPUT OPERANDS NEED NOT BE IN ADJUSTED FORM. -C HOWEVER, THE RESULT OF ADDITION OR SUBTRACTION IS RETURNED -C IN ADJUSTED FORM. THUS, FOR EXAMPLE, IF (X,IX),(Y,IY), -C (U,IU), AND (V,IV) ARE IN ADJUSTED FORM, THEN -C -C (X,IX)*(Y,IY) + (U,IU)*(V,IV) -C -C CAN BE COMPUTED AND STORED IN ADJUSTED FORM WITH NO EXPLICIT -C CALLS TO DXADJ. -C -C WHEN AN EXTENDED-RANGE NUMBER IS TO BE PRINTED, IT MUST BE -C CONVERTED TO AN EXTENDED-RANGE FORM WITH DECIMAL RADIX. SUBROUTINE -C DXCON IS PROVIDED FOR THIS PURPOSE. -C -C THE SUBROUTINES CONTAINED IN THIS PACKAGE ARE -C -C SUBROUTINE DXADD -C USAGE -C CALL DXADD(X,IX,Y,IY,Z,IZ,IERROR) -C IF (IERROR.NE.0) RETURN -C DESCRIPTION -C FORMS THE EXTENDED-RANGE SUM (Z,IZ) = -C (X,IX) + (Y,IY). (Z,IZ) IS ADJUSTED -C BEFORE RETURNING. THE INPUT OPERANDS -C NEED NOT BE IN ADJUSTED FORM, BUT THEIR -C PRINCIPAL PARTS MUST SATISFY -C RADIX**(-2L).LE.ABS(X).LE.RADIX**(2L), -C RADIX**(-2L).LE.ABS(Y).LE.RADIX**(2L). -C -C SUBROUTINE DXADJ -C USAGE -C CALL DXADJ(X,IX,IERROR) -C IF (IERROR.NE.0) RETURN -C DESCRIPTION -C TRANSFORMS (X,IX) SO THAT -C RADIX**(-L) .LE. ABS(X) .LT. RADIX**L. -C ON MOST COMPUTERS THIS TRANSFORMATION DOES -C NOT CHANGE THE MANTISSA OF X PROVIDED RADIX IS -C THE NUMBER BASE OF DOUBLE-PRECISION ARITHMETIC. -C -C SUBROUTINE DXC210 -C USAGE -C CALL DXC210(K,Z,J,IERROR) -C IF (IERROR.NE.0) RETURN -C DESCRIPTION -C GIVEN K THIS SUBROUTINE COMPUTES J AND Z -C SUCH THAT RADIX**K = Z*10**J, WHERE Z IS IN -C THE RANGE 1/10 .LE. Z .LT. 1. -C THE VALUE OF Z WILL BE ACCURATE TO FULL -C DOUBLE-PRECISION PROVIDED THE NUMBER -C OF DECIMAL PLACES IN THE LARGEST -C INTEGER PLUS THE NUMBER OF DECIMAL -C PLACES CARRIED IN DOUBLE-PRECISION DOES NOT -C EXCEED 60. DXC210 IS CALLED BY SUBROUTINE -C DXCON WHEN NECESSARY. THE USER SHOULD -C NEVER NEED TO CALL DXC210 DIRECTLY. -C -C SUBROUTINE DXCON -C USAGE -C CALL DXCON(X,IX,IERROR) -C IF (IERROR.NE.0) RETURN -C DESCRIPTION -C CONVERTS (X,IX) = X*RADIX**IX -C TO DECIMAL FORM IN PREPARATION FOR -C PRINTING, SO THAT (X,IX) = X*10**IX -C WHERE 1/10 .LE. ABS(X) .LT. 1 -C IS RETURNED, EXCEPT THAT IF -C (ABS(X),IX) IS BETWEEN RADIX**(-2L) -C AND RADIX**(2L) THEN THE REDUCED -C FORM WITH IX = 0 IS RETURNED. -C -C SUBROUTINE DXRED -C USAGE -C CALL DXRED(X,IX,IERROR) -C IF (IERROR.NE.0) RETURN -C DESCRIPTION -C IF -C RADIX**(-2L) .LE. (ABS(X),IX) .LE. RADIX**(2L) -C THEN DXRED TRANSFORMS (X,IX) SO THAT IX=0. -C IF (X,IX) IS OUTSIDE THE ABOVE RANGE, -C THEN DXRED TAKES NO ACTION. -C THIS SUBROUTINE IS USEFUL IF THE -C RESULTS OF EXTENDED-RANGE CALCULATIONS -C ARE TO BE USED IN SUBSEQUENT ORDINARY -C DOUBLE-PRECISION CALCULATIONS. -C -C***REFERENCES Smith, Olver and Lozier, Extended-Range Arithmetic and -C Normalized Legendre Polynomials, ACM Trans on Math -C Softw, v 7, n 1, March 1981, pp 93--105. -C***ROUTINES CALLED I1MACH, XERMSG -C***COMMON BLOCKS DXBLK1, DXBLK2, DXBLK3 -C***REVISION HISTORY (YYMMDD) -C 820712 DATE WRITTEN -C 881020 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Changed all specific intrinsics to generic. (WRB) -C Corrected order of sections in prologue and added TYPE -C section. (WRB) -C CALLs to XERROR changed to CALLs to XERMSG. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE DXSET - INTEGER IRAD, NRADPL, NBITS - DOUBLE PRECISION DZERO, DZEROX - COMMON /DXBLK1/ NBITSF - SAVE /DXBLK1/ - DOUBLE PRECISION RADIX, RADIXL, RAD2L, DLG10R - INTEGER L, L2, KMAX - COMMON /DXBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX - SAVE /DXBLK2/ - INTEGER NLG102, MLG102, LG102 - COMMON /DXBLK3/ NLG102, MLG102, LG102(21) - SAVE /DXBLK3/ - INTEGER IFLAG - SAVE IFLAG -C - DIMENSION LOG102(20), LGTEMP(20) - SAVE LOG102 -C -C LOG102 CONTAINS THE FIRST 60 DIGITS OF LOG10(2) FOR USE IN -C CONVERSION OF EXTENDED-RANGE NUMBERS TO BASE 10 . - DATA LOG102 /301,029,995,663,981,195,213,738,894,724,493,026,768, - * 189,881,462,108,541,310,428/ -C -C FOLLOWING CODING PREVENTS DXSET FROM BEING EXECUTED MORE THAN ONCE. -C THIS IS IMPORTANT BECAUSE SOME SUBROUTINES (SUCH AS DXNRMP AND -C DXLEGF) CALL DXSET TO MAKE SURE EXTENDED-RANGE ARITHMETIC HAS -C BEEN INITIALIZED. THE USER MAY WANT TO PRE-EMPT THIS CALL, FOR -C EXAMPLE WHEN I1MACH IS NOT AVAILABLE. SEE CODING BELOW. - DATA IFLAG /0/ -C***FIRST EXECUTABLE STATEMENT DXSET - IERROR=0 - IF (IFLAG .NE. 0) RETURN - IRADX = IRAD - NRDPLC = NRADPL - DZEROX = DZERO - IMINEX = 0 - IMAXEX = 0 - NBITSX = NBITS -C FOLLOWING 5 STATEMENTS SHOULD BE DELETED IF I1MACH IS -C NOT AVAILABLE OR NOT CONFIGURED TO RETURN THE CORRECT -C MACHINE-DEPENDENT VALUES. - IF (IRADX .EQ. 0) IRADX = I1MACH (10) - IF (NRDPLC .EQ. 0) NRDPLC = I1MACH (14) - IF (DZEROX .EQ. 0.0D0) IMINEX = I1MACH (15) - IF (DZEROX .EQ. 0.0D0) IMAXEX = I1MACH (16) - IF (NBITSX .EQ. 0) NBITSX = I1MACH (8) - IF (IRADX.EQ.2) GO TO 10 - IF (IRADX.EQ.4) GO TO 10 - IF (IRADX.EQ.8) GO TO 10 - IF (IRADX.EQ.16) GO TO 10 - CALL XERMSG ('SLATEC', 'DXSET', 'IMPROPER VALUE OF IRAD', 201, 1) - IERROR=201 - RETURN - 10 CONTINUE - LOG2R=0 - IF (IRADX.EQ.2) LOG2R = 1 - IF (IRADX.EQ.4) LOG2R = 2 - IF (IRADX.EQ.8) LOG2R = 3 - IF (IRADX.EQ.16) LOG2R = 4 - NBITSF=LOG2R*NRDPLC - RADIX = IRADX - DLG10R = LOG10(RADIX) - IF (DZEROX .NE. 0.0D0) GO TO 14 - LX = MIN ((1-IMINEX)/2, (IMAXEX-1)/2) - GO TO 16 - 14 LX = 0.5D0*LOG10(DZEROX)/DLG10R -C RADIX**(2*L) SHOULD NOT OVERFLOW, BUT REDUCE L BY 1 FOR FURTHER -C PROTECTION. - LX=LX-1 - 16 L2 = 2*LX - IF (LX.GE.4) GO TO 20 - CALL XERMSG ('SLATEC', 'DXSET', 'IMPROPER VALUE OF DZERO', 202, 1) - IERROR=202 - RETURN - 20 L = LX - RADIXL = RADIX**L - RAD2L = RADIXL**2 -C IT IS NECESSARY TO RESTRICT NBITS (OR NBITSX) TO BE LESS THAN SOME -C UPPER LIMIT BECAUSE OF BINARY-TO-DECIMAL CONVERSION. SUCH CONVERSION -C IS DONE BY DXC210 AND REQUIRES A CONSTANT THAT IS STORED TO SOME FIXED -C PRECISION. THE STORED CONSTANT (LOG102 IN THIS ROUTINE) PROVIDES -C FOR CONVERSIONS ACCURATE TO THE LAST DECIMAL DIGIT WHEN THE INTEGER -C WORD LENGTH DOES NOT EXCEED 63. A LOWER LIMIT OF 15 BITS IS IMPOSED -C BECAUSE THE SOFTWARE IS DESIGNED TO RUN ON COMPUTERS WITH INTEGER WORD -C LENGTH OF AT LEAST 16 BITS. - IF (15.LE.NBITSX .AND. NBITSX.LE.63) GO TO 30 - CALL XERMSG ('SLATEC', 'DXSET', 'IMPROPER VALUE OF NBITS', 203, 1) - IERROR=203 - RETURN - 30 CONTINUE - KMAX = 2**(NBITSX-1) - L2 - NB = (NBITSX-1)/2 - MLG102 = 2**NB - IF (1.LE.NRDPLC*LOG2R .AND. NRDPLC*LOG2R.LE.120) GO TO 40 - CALL XERMSG ('SLATEC', 'DXSET', 'IMPROPER VALUE OF NRADPL', 204, - + 1) - IERROR=204 - RETURN - 40 CONTINUE - NLG102 = NRDPLC*LOG2R/NB + 3 - NP1 = NLG102 + 1 -C -C AFTER COMPLETION OF THE FOLLOWING LOOP, IC CONTAINS -C THE INTEGER PART AND LGTEMP CONTAINS THE FRACTIONAL PART -C OF LOG10(IRADX) IN RADIX 1000. - IC = 0 - DO 50 II=1,20 - I = 21 - II - IT = LOG2R*LOG102(I) + IC - IC = IT/1000 - LGTEMP(I) = MOD(IT,1000) - 50 CONTINUE -C -C AFTER COMPLETION OF THE FOLLOWING LOOP, LG102 CONTAINS -C LOG10(IRADX) IN RADIX MLG102. THE RADIX POINT IS -C BETWEEN LG102(1) AND LG102(2). - LG102(1) = IC - DO 80 I=2,NP1 - LG102X = 0 - DO 70 J=1,NB - IC = 0 - DO 60 KK=1,20 - K = 21 - KK - IT = 2*LGTEMP(K) + IC - IC = IT/1000 - LGTEMP(K) = MOD(IT,1000) - 60 CONTINUE - LG102X = 2*LG102X + IC - 70 CONTINUE - LG102(I) = LG102X - 80 CONTINUE -C -C CHECK SPECIAL CONDITIONS REQUIRED BY SUBROUTINES... - IF (NRDPLC.LT.L) GO TO 90 - CALL XERMSG ('SLATEC', 'DXSET', 'NRADPL .GE. L', 205, 1) - IERROR=205 - RETURN - 90 IF (6*L.LE.KMAX) GO TO 100 - CALL XERMSG ('SLATEC', 'DXSET', '6*L .GT. KMAX', 206, 1) - IERROR=206 - RETURN - 100 CONTINUE - IFLAG = 1 - RETURN - END diff --git a/slatec/dy.f b/slatec/dy.f deleted file mode 100644 index 166781d..0000000 --- a/slatec/dy.f +++ /dev/null @@ -1,99 +0,0 @@ -*DECK DY - SUBROUTINE DY (U, IDMN, I, J, UYYY, UYYYY) -C***BEGIN PROLOGUE DY -C***SUBSIDIARY -C***PURPOSE Subsidiary to SEPELI -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (DY-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This program computes second order finite difference -C approximations to the third and fourth Y -C partial derivatives of U at the (I,J) mesh point. -C -C***SEE ALSO SEPELI -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS SPLPCM -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE DY -C - COMMON /SPLPCM/ KSWX ,KSWY ,K ,L , - 1 AIT ,BIT ,CIT ,DIT , - 2 MIT ,NIT ,IS ,MS , - 3 JS ,NS ,DLX ,DLY , - 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 - DIMENSION U(IDMN,*) -C***FIRST EXECUTABLE STATEMENT DY - IF (J.GT.2 .AND. J.LT.(L-1)) GO TO 50 - IF (J .EQ. 1) GO TO 10 - IF (J .EQ. 2) GO TO 30 - IF (J .EQ. L-1) GO TO 60 - IF (J .EQ. L) GO TO 80 -C -C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=C -C - 10 IF (KSWY .EQ. 1) GO TO 20 - UYYY = (-5.0*U(I,1)+18.0*U(I,2)-24.0*U(I,3)+14.0*U(I,4)- - 1 3.0*U(I,5))/TDLY3 - UYYYY = (3.0*U(I,1)-14.0*U(I,2)+26.0*U(I,3)-24.0*U(I,4)+ - 1 11.0*U(I,5)-2.0*U(I,6))/DLY4 - RETURN -C -C PERIODIC AT X=A -C - 20 UYYY = (-U(I,L-2)+2.0*U(I,L-1)-2.0*U(I,2)+U(I,3))/TDLY3 - UYYYY = (U(I,L-2)-4.0*U(I,L-1)+6.0*U(I,1)-4.0*U(I,2)+U(I,3))/DLY4 - RETURN -C -C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=C+DLY -C - 30 IF (KSWY .EQ. 1) GO TO 40 - UYYY = (-3.0*U(I,1)+10.0*U(I,2)-12.0*U(I,3)+6.0*U(I,4)-U(I,5))/ - 1 TDLY3 - UYYYY = (2.0*U(I,1)-9.0*U(I,2)+16.0*U(I,3)-14.0*U(I,4)+6.0*U(I,5)- - 1 U(I,6))/DLY4 - RETURN -C -C PERIODIC AT Y=C+DLY -C - 40 UYYY = (-U(I,L-1)+2.0*U(I,1)-2.0*U(I,3)+U(I,4))/TDLY3 - UYYYY = (U(I,L-1)-4.0*U(I,1)+6.0*U(I,2)-4.0*U(I,3)+U(I,4))/DLY4 - RETURN -C -C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS ON THE INTERIOR -C - 50 CONTINUE - UYYY = (-U(I,J-2)+2.0*U(I,J-1)-2.0*U(I,J+1)+U(I,J+2))/TDLY3 - UYYYY = (U(I,J-2)-4.0*U(I,J-1)+6.0*U(I,J)-4.0*U(I,J+1)+U(I,J+2))/ - 1 DLY4 - RETURN -C -C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=D-DLY -C - 60 IF (KSWY .EQ. 1) GO TO 70 - UYYY = (U(I,L-4)-6.0*U(I,L-3)+12.0*U(I,L-2)-10.0*U(I,L-1)+ - 1 3.0*U(I,L))/TDLY3 - UYYYY = (-U(I,L-5)+6.0*U(I,L-4)-14.0*U(I,L-3)+16.0*U(I,L-2)- - 1 9.0*U(I,L-1)+2.0*U(I,L))/DLY4 - RETURN -C -C PERIODIC AT Y=D-DLY -C - 70 CONTINUE - UYYY = (-U(I,L-3)+2.0*U(I,L-2)-2.0*U(I,1)+U(I,2))/TDLY3 - UYYYY = (U(I,L-3)-4.0*U(I,L-2)+6.0*U(I,L-1)-4.0*U(I,1)+U(I,2))/ - 1 DLY4 - RETURN -C -C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=D -C - 80 UYYY = -(3.0*U(I,L-4)-14.0*U(I,L-3)+24.0*U(I,L-2)-18.0*U(I,L-1)+ - 1 5.0*U(I,L))/TDLY3 - UYYYY = (-2.0*U(I,L-5)+11.0*U(I,L-4)-24.0*U(I,L-3)+26.0*U(I,L-2)- - 1 14.0*U(I,L-1)+3.0*U(I,L))/DLY4 - RETURN - END diff --git a/slatec/dy4.f b/slatec/dy4.f deleted file mode 100644 index 92b9a5a..0000000 --- a/slatec/dy4.f +++ /dev/null @@ -1,99 +0,0 @@ -*DECK DY4 - SUBROUTINE DY4 (U, IDMN, I, J, UYYY, UYYYY) -C***BEGIN PROLOGUE DY4 -C***SUBSIDIARY -C***PURPOSE Subsidiary to SEPX4 -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (DY4-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This program computes second order finite difference -C approximations to the third and fourth Y -C partial derivatives of U at the (I,J) mesh point. -C -C***SEE ALSO SEPX4 -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS SPL4 -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE DY4 -C - COMMON /SPL4/ KSWX ,KSWY ,K ,L , - 1 AIT ,BIT ,CIT ,DIT , - 2 MIT ,NIT ,IS ,MS , - 3 JS ,NS ,DLX ,DLY , - 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 - DIMENSION U(IDMN,*) -C***FIRST EXECUTABLE STATEMENT DY4 - IF (J.GT.2 .AND. J.LT.(L-1)) GO TO 50 - IF (J .EQ. 1) GO TO 10 - IF (J .EQ. 2) GO TO 30 - IF (J .EQ. L-1) GO TO 60 - IF (J .EQ. L) GO TO 80 -C -C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=C -C - 10 IF (KSWY .EQ. 1) GO TO 20 - UYYY = (-5.0*U(I,1)+18.0*U(I,2)-24.0*U(I,3)+14.0*U(I,4)- - 1 3.0*U(I,5))/TDLY3 - UYYYY = (3.0*U(I,1)-14.0*U(I,2)+26.0*U(I,3)-24.0*U(I,4)+ - 1 11.0*U(I,5)-2.0*U(I,6))/DLY4 - RETURN -C -C PERIODIC AT X=A -C - 20 UYYY = (-U(I,L-2)+2.0*U(I,L-1)-2.0*U(I,2)+U(I,3))/TDLY3 - UYYYY = (U(I,L-2)-4.0*U(I,L-1)+6.0*U(I,1)-4.0*U(I,2)+U(I,3))/DLY4 - RETURN -C -C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=C+DLY -C - 30 IF (KSWY .EQ. 1) GO TO 40 - UYYY = (-3.0*U(I,1)+10.0*U(I,2)-12.0*U(I,3)+6.0*U(I,4)-U(I,5))/ - 1 TDLY3 - UYYYY = (2.0*U(I,1)-9.0*U(I,2)+16.0*U(I,3)-14.0*U(I,4)+6.0*U(I,5)- - 1 U(I,6))/DLY4 - RETURN -C -C PERIODIC AT Y=C+DLY -C - 40 UYYY = (-U(I,L-1)+2.0*U(I,1)-2.0*U(I,3)+U(I,4))/TDLY3 - UYYYY = (U(I,L-1)-4.0*U(I,1)+6.0*U(I,2)-4.0*U(I,3)+U(I,4))/DLY4 - RETURN -C -C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS ON THE INTERIOR -C - 50 CONTINUE - UYYY = (-U(I,J-2)+2.0*U(I,J-1)-2.0*U(I,J+1)+U(I,J+2))/TDLY3 - UYYYY = (U(I,J-2)-4.0*U(I,J-1)+6.0*U(I,J)-4.0*U(I,J+1)+U(I,J+2))/ - 1 DLY4 - RETURN -C -C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=D-DLY -C - 60 IF (KSWY .EQ. 1) GO TO 70 - UYYY = (U(I,L-4)-6.0*U(I,L-3)+12.0*U(I,L-2)-10.0*U(I,L-1)+ - 1 3.0*U(I,L))/TDLY3 - UYYYY = (-U(I,L-5)+6.0*U(I,L-4)-14.0*U(I,L-3)+16.0*U(I,L-2)- - 1 9.0*U(I,L-1)+2.0*U(I,L))/DLY4 - RETURN -C -C PERIODIC AT Y=D-DLY -C - 70 CONTINUE - UYYY = (-U(I,L-3)+2.0*U(I,L-2)-2.0*U(I,1)+U(I,2))/TDLY3 - UYYYY = (U(I,L-3)-4.0*U(I,L-2)+6.0*U(I,L-1)-4.0*U(I,1)+U(I,2))/ - 1 DLY4 - RETURN -C -C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=D -C - 80 UYYY = -(3.0*U(I,L-4)-14.0*U(I,L-3)+24.0*U(I,L-2)-18.0*U(I,L-1)+ - 1 5.0*U(I,L))/TDLY3 - UYYYY = (-2.0*U(I,L-5)+11.0*U(I,L-4)-24.0*U(I,L-3)+26.0*U(I,L-2)- - 1 14.0*U(I,L-1)+3.0*U(I,L))/DLY4 - RETURN - END diff --git a/slatec/dyairy.f b/slatec/dyairy.f deleted file mode 100644 index 0893920..0000000 --- a/slatec/dyairy.f +++ /dev/null @@ -1,394 +0,0 @@ -*DECK DYAIRY - SUBROUTINE DYAIRY (X, RX, C, BI, DBI) -C***BEGIN PROLOGUE DYAIRY -C***SUBSIDIARY -C***PURPOSE Subsidiary to DBESJ and DBESY -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (YAIRY-S, DYAIRY-D) -C***AUTHOR Amos, D. E., (SNLA) -C Daniel, S. L., (SNLA) -C***DESCRIPTION -C -C DYAIRY computes the Airy function BI(X) -C and its derivative DBI(X) for DASYJY -C -C INPUT -C -C X - Argument, computed by DASYJY, X unrestricted -C RX - RX=SQRT(ABS(X)), computed by DASYJY -C C - C=2.*(ABS(X)**1.5)/3., computed by DASYJY -C -C OUTPUT -C BI - Value of function BI(X) -C DBI - Value of the derivative DBI(X) -C -C***SEE ALSO DBESJ, DBESY -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910408 Updated the AUTHOR section. (WRB) -C***END PROLOGUE DYAIRY -C - INTEGER I, J, M1, M1D, M2, M2D, M3, M3D, M4D, N1, N1D, N2, N2D, - 1 N3, N3D, N4D - DOUBLE PRECISION AA,AX,BB,BI,BJN,BJP,BK1,BK2,BK3,BK4,C,CON1,CON2, - 1 CON3, CV, DAA, DBB, DBI, DBJN, DBJP, DBK1, DBK2, DBK3, DBK4, D1, - 2 D2, EX, E1, E2, FPI12, F1, F2, RTRX, RX, SPI12, S1, S2, T, TC, - 3 TEMP1, TEMP2, TT, X - DIMENSION BK1(20), BK2(20), BK3(20), BK4(14) - DIMENSION BJP(19), BJN(19), AA(14), BB(14) - DIMENSION DBK1(21), DBK2(20), DBK3(20), DBK4(14) - DIMENSION DBJP(19), DBJN(19), DAA(14), DBB(14) - SAVE N1, N2, N3, M1, M2, M3, N1D, N2D, N3D, N4D, - 1 M1D, M2D, M3D, M4D, FPI12, SPI12, CON1, CON2, CON3, - 2 BK1, BK2, BK3, BK4, BJN, BJP, AA, BB, DBK1, DBK2, DBK3, DBK4, - 3 DBJP, DBJN, DAA, DBB - DATA N1,N2,N3/20,19,14/ - DATA M1,M2,M3/18,17,12/ - DATA N1D,N2D,N3D,N4D/21,20,19,14/ - DATA M1D,M2D,M3D,M4D/19,18,17,12/ - DATA FPI12,SPI12,CON1,CON2,CON3/ - 1 1.30899693899575D+00, 1.83259571459405D+00, 6.66666666666667D-01, - 2 7.74148278841779D+00, 3.64766105490356D-01/ - DATA BK1(1), BK1(2), BK1(3), BK1(4), BK1(5), BK1(6), - 1 BK1(7), BK1(8), BK1(9), BK1(10), BK1(11), BK1(12), - 2 BK1(13), BK1(14), BK1(15), BK1(16), BK1(17), BK1(18), - 3 BK1(19), BK1(20)/ 2.43202846447449D+00, 2.57132009754685D+00, - 4 1.02802341258616D+00, 3.41958178205872D-01, 8.41978629889284D-02, - 5 1.93877282587962D-02, 3.92687837130335D-03, 6.83302689948043D-04, - 6 1.14611403991141D-04, 1.74195138337086D-05, 2.41223620956355D-06, - 7 3.24525591983273D-07, 4.03509798540183D-08, 4.70875059642296D-09, - 8 5.35367432585889D-10, 5.70606721846334D-11, 5.80526363709933D-12, - 9 5.76338988616388D-13, 5.42103834518071D-14, 4.91857330301677D-15/ - DATA BK2(1), BK2(2), BK2(3), BK2(4), BK2(5), BK2(6), - 1 BK2(7), BK2(8), BK2(9), BK2(10), BK2(11), BK2(12), - 2 BK2(13), BK2(14), BK2(15), BK2(16), BK2(17), BK2(18), - 3 BK2(19), BK2(20)/ 5.74830555784088D-01,-6.91648648376891D-03, - 4 1.97460263052093D-03,-5.24043043868823D-04, 1.22965147239661D-04, - 5-2.27059514462173D-05, 2.23575555008526D-06, 4.15174955023899D-07, - 6-2.84985752198231D-07, 8.50187174775435D-08,-1.70400826891326D-08, - 7 2.25479746746889D-09,-1.09524166577443D-10,-3.41063845099711D-11, - 8 1.11262893886662D-11,-1.75542944241734D-12, 1.36298600401767D-13, - 9 8.76342105755664D-15,-4.64063099157041D-15, 7.78772758732960D-16/ - DATA BK3(1), BK3(2), BK3(3), BK3(4), BK3(5), BK3(6), - 1 BK3(7), BK3(8), BK3(9), BK3(10), BK3(11), BK3(12), - 2 BK3(13), BK3(14), BK3(15), BK3(16), BK3(17), BK3(18), - 3 BK3(19), BK3(20)/ 5.66777053506912D-01, 2.63672828349579D-03, - 4 5.12303351473130D-05, 2.10229231564492D-06, 1.42217095113890D-07, - 5 1.28534295891264D-08, 7.28556219407507D-10,-3.45236157301011D-10, - 6-2.11919115912724D-10,-6.56803892922376D-11,-8.14873160315074D-12, - 7 3.03177845632183D-12, 1.73447220554115D-12, 1.67935548701554D-13, - 8-1.49622868806719D-13,-5.15470458953407D-14, 8.75741841857830D-15, - 9 7.96735553525720D-15,-1.29566137861742D-16,-1.11878794417520D-15/ - DATA BK4(1), BK4(2), BK4(3), BK4(4), BK4(5), BK4(6), - 1 BK4(7), BK4(8), BK4(9), BK4(10), BK4(11), BK4(12), - 2 BK4(13), BK4(14)/ 4.85444386705114D-01,-3.08525088408463D-03, - 3 6.98748404837928D-05,-2.82757234179768D-06, 1.59553313064138D-07, - 4-1.12980692144601D-08, 9.47671515498754D-10,-9.08301736026423D-11, - 5 9.70776206450724D-12,-1.13687527254574D-12, 1.43982917533415D-13, - 6-1.95211019558815D-14, 2.81056379909357D-15,-4.26916444775176D-16/ - DATA BJP(1), BJP(2), BJP(3), BJP(4), BJP(5), BJP(6), - 1 BJP(7), BJP(8), BJP(9), BJP(10), BJP(11), BJP(12), - 2 BJP(13), BJP(14), BJP(15), BJP(16), BJP(17), BJP(18), - 3 BJP(19) / 1.34918611457638D-01,-3.19314588205813D-01, - 4 5.22061946276114D-02, 5.28869112170312D-02,-8.58100756077350D-03, - 5-2.99211002025555D-03, 4.21126741969759D-04, 8.73931830369273D-05, - 6-1.06749163477533D-05,-1.56575097259349D-06, 1.68051151983999D-07, - 7 1.89901103638691D-08,-1.81374004961922D-09,-1.66339134593739D-10, - 8 1.42956335780810D-11, 1.10179811626595D-12,-8.60187724192263D-14, - 9-5.71248177285064D-15, 4.08414552853803D-16/ - DATA BJN(1), BJN(2), BJN(3), BJN(4), BJN(5), BJN(6), - 1 BJN(7), BJN(8), BJN(9), BJN(10), BJN(11), BJN(12), - 2 BJN(13), BJN(14), BJN(15), BJN(16), BJN(17), BJN(18), - 3 BJN(19) / 6.59041673525697D-02,-4.24905910566004D-01, - 4 2.87209745195830D-01, 1.29787771099606D-01,-4.56354317590358D-02, - 5-1.02630175982540D-02, 2.50704671521101D-03, 3.78127183743483D-04, - 6-7.11287583284084D-05,-8.08651210688923D-06, 1.23879531273285D-06, - 7 1.13096815867279D-07,-1.46234283176310D-08,-1.11576315688077D-09, - 8 1.24846618243897D-10, 8.18334132555274D-12,-8.07174877048484D-13, - 9-4.63778618766425D-14, 4.09043399081631D-15/ - DATA AA(1), AA(2), AA(3), AA(4), AA(5), AA(6), - 1 AA(7), AA(8), AA(9), AA(10), AA(11), AA(12), - 2 AA(13), AA(14) /-2.78593552803079D-01, 3.52915691882584D-03, - 3 2.31149677384994D-05,-4.71317842263560D-06, 1.12415907931333D-07, - 4 2.00100301184339D-08,-2.60948075302193D-09, 3.55098136101216D-11, - 5 3.50849978423875D-11,-5.83007187954202D-12, 2.04644828753326D-13, - 6 1.10529179476742D-13,-2.87724778038775D-14, 2.88205111009939D-15/ - DATA BB(1), BB(2), BB(3), BB(4), BB(5), BB(6), - 1 BB(7), BB(8), BB(9), BB(10), BB(11), BB(12), - 2 BB(13), BB(14) /-4.90275424742791D-01,-1.57647277946204D-03, - 3 9.66195963140306D-05,-1.35916080268815D-07,-2.98157342654859D-07, - 4 1.86824767559979D-08, 1.03685737667141D-09,-3.28660818434328D-10, - 5 2.57091410632780D-11, 2.32357655300677D-12,-9.57523279048255D-13, - 6 1.20340828049719D-13, 2.90907716770715D-15,-4.55656454580149D-15/ - DATA DBK1(1), DBK1(2), DBK1(3), DBK1(4), DBK1(5), DBK1(6), - 1 DBK1(7), DBK1(8), DBK1(9), DBK1(10),DBK1(11),DBK1(12), - 2 DBK1(13),DBK1(14),DBK1(15),DBK1(16),DBK1(17),DBK1(18), - 3 DBK1(19),DBK1(20), - 4 DBK1(21) / 2.95926143981893D+00, 3.86774568440103D+00, - 5 1.80441072356289D+00, 5.78070764125328D-01, 1.63011468174708D-01, - 6 3.92044409961855D-02, 7.90964210433812D-03, 1.50640863167338D-03, - 7 2.56651976920042D-04, 3.93826605867715D-05, 5.81097771463818D-06, - 8 7.86881233754659D-07, 9.93272957325739D-08, 1.21424205575107D-08, - 9 1.38528332697707D-09, 1.50190067586758D-10, 1.58271945457594D-11, - 1 1.57531847699042D-12, 1.50774055398181D-13, 1.40594335806564D-14, - 2 1.24942698777218D-15/ - DATA DBK2(1), DBK2(2), DBK2(3), DBK2(4), DBK2(5), DBK2(6), - 1 DBK2(7), DBK2(8), DBK2(9), DBK2(10),DBK2(11),DBK2(12), - 2 DBK2(13),DBK2(14),DBK2(15),DBK2(16),DBK2(17),DBK2(18), - 3 DBK2(19),DBK2(20)/ 5.49756809432471D-01, 9.13556983276901D-03, - 4-2.53635048605507D-03, 6.60423795342054D-04,-1.55217243135416D-04, - 5 3.00090325448633D-05,-3.76454339467348D-06,-1.33291331611616D-07, - 6 2.42587371049013D-07,-8.07861075240228D-08, 1.71092818861193D-08, - 7-2.41087357570599D-09, 1.53910848162371D-10, 2.56465373190630D-11, - 8-9.88581911653212D-12, 1.60877986412631D-12,-1.20952524741739D-13, - 9-1.06978278410820D-14, 5.02478557067561D-15,-8.68986130935886D-16/ - DATA DBK3(1), DBK3(2), DBK3(3), DBK3(4), DBK3(5), DBK3(6), - 1 DBK3(7), DBK3(8), DBK3(9), DBK3(10),DBK3(11),DBK3(12), - 2 DBK3(13),DBK3(14),DBK3(15),DBK3(16),DBK3(17),DBK3(18), - 3 DBK3(19),DBK3(20)/ 5.60598509354302D-01,-3.64870013248135D-03, - 4-5.98147152307417D-05,-2.33611595253625D-06,-1.64571516521436D-07, - 5-2.06333012920569D-08,-4.27745431573110D-09,-1.08494137799276D-09, - 6-2.37207188872763D-10,-2.22132920864966D-11, 1.07238008032138D-11, - 7 5.71954845245808D-12, 7.51102737777835D-13,-3.81912369483793D-13, - 8-1.75870057119257D-13, 6.69641694419084D-15, 2.26866724792055D-14, - 9 2.69898141356743D-15,-2.67133612397359D-15,-6.54121403165269D-16/ - DATA DBK4(1), DBK4(2), DBK4(3), DBK4(4), DBK4(5), DBK4(6), - 1 DBK4(7), DBK4(8), DBK4(9), DBK4(10),DBK4(11),DBK4(12), - 2 DBK4(13),DBK4(14)/ 4.93072999188036D-01, 4.38335419803815D-03, - 3-8.37413882246205D-05, 3.20268810484632D-06,-1.75661979548270D-07, - 4 1.22269906524508D-08,-1.01381314366052D-09, 9.63639784237475D-11, - 5-1.02344993379648D-11, 1.19264576554355D-12,-1.50443899103287D-13, - 6 2.03299052379349D-14,-2.91890652008292D-15, 4.42322081975475D-16/ - DATA DBJP(1), DBJP(2), DBJP(3), DBJP(4), DBJP(5), DBJP(6), - 1 DBJP(7), DBJP(8), DBJP(9), DBJP(10),DBJP(11),DBJP(12), - 2 DBJP(13),DBJP(14),DBJP(15),DBJP(16),DBJP(17),DBJP(18), - 3 DBJP(19) / 1.13140872390745D-01,-2.08301511416328D-01, - 4 1.69396341953138D-02, 2.90895212478621D-02,-3.41467131311549D-03, - 5-1.46455339197417D-03, 1.63313272898517D-04, 3.91145328922162D-05, - 6-3.96757190808119D-06,-6.51846913772395D-07, 5.98707495269280D-08, - 7 7.44108654536549D-09,-6.21241056522632D-10,-6.18768017313526D-11, - 8 4.72323484752324D-12, 3.91652459802532D-13,-2.74985937845226D-14, - 9-1.95036497762750D-15, 1.26669643809444D-16/ - DATA DBJN(1), DBJN(2), DBJN(3), DBJN(4), DBJN(5), DBJN(6), - 1 DBJN(7), DBJN(8), DBJN(9), DBJN(10),DBJN(11),DBJN(12), - 2 DBJN(13),DBJN(14),DBJN(15),DBJN(16),DBJN(17),DBJN(18), - 3 DBJN(19) /-1.88091260068850D-02,-1.47798180826140D-01, - 4 5.46075900433171D-01, 1.52146932663116D-01,-9.58260412266886D-02, - 5-1.63102731696130D-02, 5.75364806680105D-03, 7.12145408252655D-04, - 6-1.75452116846724D-04,-1.71063171685128D-05, 3.24435580631680D-06, - 7 2.61190663932884D-07,-4.03026865912779D-08,-2.76435165853895D-09, - 8 3.59687929062312D-10, 2.14953308456051D-11,-2.41849311903901D-12, - 9-1.28068004920751D-13, 1.26939834401773D-14/ - DATA DAA(1), DAA(2), DAA(3), DAA(4), DAA(5), DAA(6), - 1 DAA(7), DAA(8), DAA(9), DAA(10), DAA(11), DAA(12), - 2 DAA(13), DAA(14)/ 2.77571356944231D-01,-4.44212833419920D-03, - 3 8.42328522190089D-05, 2.58040318418710D-06,-3.42389720217621D-07, - 4 6.24286894709776D-09, 2.36377836844577D-09,-3.16991042656673D-10, - 5 4.40995691658191D-12, 5.18674221093575D-12,-9.64874015137022D-13, - 6 4.90190576608710D-14, 1.77253430678112D-14,-5.55950610442662D-15/ - DATA DBB(1), DBB(2), DBB(3), DBB(4), DBB(5), DBB(6), - 1 DBB(7), DBB(8), DBB(9), DBB(10), DBB(11), DBB(12), - 2 DBB(13), DBB(14)/ 4.91627321104601D-01, 3.11164930427489D-03, - 3 8.23140762854081D-05,-4.61769776172142D-06,-6.13158880534626D-08, - 4 2.87295804656520D-08,-1.81959715372117D-09,-1.44752826642035D-10, - 5 4.53724043420422D-11,-3.99655065847223D-12,-3.24089119830323D-13, - 6 1.62098952568741D-13,-2.40765247974057D-14, 1.69384811284491D-16/ -C***FIRST EXECUTABLE STATEMENT DYAIRY - AX = ABS(X) - RX = SQRT(AX) - C = CON1*AX*RX - IF (X.LT.0.0D0) GO TO 120 - IF (C.GT.8.0D0) GO TO 60 - IF (X.GT.2.5D0) GO TO 30 - T = (X+X-2.5D0)*0.4D0 - TT = T + T - J = N1 - F1 = BK1(J) - F2 = 0.0D0 - DO 10 I=1,M1 - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + BK1(J) - F2 = TEMP1 - 10 CONTINUE - BI = T*F1 - F2 + BK1(1) - J = N1D - F1 = DBK1(J) - F2 = 0.0D0 - DO 20 I=1,M1D - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + DBK1(J) - F2 = TEMP1 - 20 CONTINUE - DBI = T*F1 - F2 + DBK1(1) - RETURN - 30 CONTINUE - RTRX = SQRT(RX) - T = (X+X-CON2)*CON3 - TT = T + T - J = N1 - F1 = BK2(J) - F2 = 0.0D0 - DO 40 I=1,M1 - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + BK2(J) - F2 = TEMP1 - 40 CONTINUE - BI = (T*F1-F2+BK2(1))/RTRX - EX = EXP(C) - BI = BI*EX - J = N2D - F1 = DBK2(J) - F2 = 0.0D0 - DO 50 I=1,M2D - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + DBK2(J) - F2 = TEMP1 - 50 CONTINUE - DBI = (T*F1-F2+DBK2(1))*RTRX - DBI = DBI*EX - RETURN -C - 60 CONTINUE - RTRX = SQRT(RX) - T = 16.0D0/C - 1.0D0 - TT = T + T - J = N1 - F1 = BK3(J) - F2 = 0.0D0 - DO 70 I=1,M1 - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + BK3(J) - F2 = TEMP1 - 70 CONTINUE - S1 = T*F1 - F2 + BK3(1) - J = N2D - F1 = DBK3(J) - F2 = 0.0D0 - DO 80 I=1,M2D - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + DBK3(J) - F2 = TEMP1 - 80 CONTINUE - D1 = T*F1 - F2 + DBK3(1) - TC = C + C - EX = EXP(C) - IF (TC.GT.35.0D0) GO TO 110 - T = 10.0D0/C - 1.0D0 - TT = T + T - J = N3 - F1 = BK4(J) - F2 = 0.0D0 - DO 90 I=1,M3 - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + BK4(J) - F2 = TEMP1 - 90 CONTINUE - S2 = T*F1 - F2 + BK4(1) - BI = (S1+EXP(-TC)*S2)/RTRX - BI = BI*EX - J = N4D - F1 = DBK4(J) - F2 = 0.0D0 - DO 100 I=1,M4D - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + DBK4(J) - F2 = TEMP1 - 100 CONTINUE - D2 = T*F1 - F2 + DBK4(1) - DBI = RTRX*(D1+EXP(-TC)*D2) - DBI = DBI*EX - RETURN - 110 BI = EX*S1/RTRX - DBI = EX*RTRX*D1 - RETURN -C - 120 CONTINUE - IF (C.GT.5.0D0) GO TO 150 - T = 0.4D0*C - 1.0D0 - TT = T + T - J = N2 - F1 = BJP(J) - E1 = BJN(J) - F2 = 0.0D0 - E2 = 0.0D0 - DO 130 I=1,M2 - J = J - 1 - TEMP1 = F1 - TEMP2 = E1 - F1 = TT*F1 - F2 + BJP(J) - E1 = TT*E1 - E2 + BJN(J) - F2 = TEMP1 - E2 = TEMP2 - 130 CONTINUE - BI = (T*E1-E2+BJN(1)) - AX*(T*F1-F2+BJP(1)) - J = N3D - F1 = DBJP(J) - E1 = DBJN(J) - F2 = 0.0D0 - E2 = 0.0D0 - DO 140 I=1,M3D - J = J - 1 - TEMP1 = F1 - TEMP2 = E1 - F1 = TT*F1 - F2 + DBJP(J) - E1 = TT*E1 - E2 + DBJN(J) - F2 = TEMP1 - E2 = TEMP2 - 140 CONTINUE - DBI = X*X*(T*F1-F2+DBJP(1)) + (T*E1-E2+DBJN(1)) - RETURN -C - 150 CONTINUE - RTRX = SQRT(RX) - T = 10.0D0/C - 1.0D0 - TT = T + T - J = N3 - F1 = AA(J) - E1 = BB(J) - F2 = 0.0D0 - E2 = 0.0D0 - DO 160 I=1,M3 - J = J - 1 - TEMP1 = F1 - TEMP2 = E1 - F1 = TT*F1 - F2 + AA(J) - E1 = TT*E1 - E2 + BB(J) - F2 = TEMP1 - E2 = TEMP2 - 160 CONTINUE - TEMP1 = T*F1 - F2 + AA(1) - TEMP2 = T*E1 - E2 + BB(1) - CV = C - FPI12 - BI = (TEMP1*COS(CV)+TEMP2*SIN(CV))/RTRX - J = N4D - F1 = DAA(J) - E1 = DBB(J) - F2 = 0.0D0 - E2 = 0.0D0 - DO 170 I=1,M4D - J = J - 1 - TEMP1 = F1 - TEMP2 = E1 - F1 = TT*F1 - F2 + DAA(J) - E1 = TT*E1 - E2 + DBB(J) - F2 = TEMP1 - E2 = TEMP2 - 170 CONTINUE - TEMP1 = T*F1 - F2 + DAA(1) - TEMP2 = T*E1 - E2 + DBB(1) - CV = C - SPI12 - DBI = (TEMP1*COS(CV)-TEMP2*SIN(CV))*RTRX - RETURN - END diff --git a/slatec/e1.f b/slatec/e1.f deleted file mode 100644 index 43bd793..0000000 --- a/slatec/e1.f +++ /dev/null @@ -1,295 +0,0 @@ -*DECK E1 - FUNCTION E1 (X) -C***BEGIN PROLOGUE E1 -C***PURPOSE Compute the exponential integral E1(X). -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C5 -C***TYPE SINGLE PRECISION (E1-S, DE1-D) -C***KEYWORDS E1 FUNCTION, EXPONENTIAL INTEGRAL, FNLIB, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C E1 calculates the single precision exponential integral, E1(X), for -C positive single precision argument X and the Cauchy principal value -C for negative X. If principal values are used everywhere, then, for -C all X, -C -C E1(X) = -Ei(-X) -C or -C Ei(X) = -E1(-X). -C -C -C Series for AE11 on the interval -1.00000D-01 to 0. -C with weighted error 1.76E-17 -C log weighted error 16.75 -C significant figures required 15.70 -C decimal places required 17.55 -C -C -C Series for AE12 on the interval -2.50000D-01 to -1.00000D-01 -C with weighted error 5.83E-17 -C log weighted error 16.23 -C significant figures required 15.76 -C decimal places required 16.93 -C -C -C Series for E11 on the interval -4.00000D+00 to -1.00000D+00 -C with weighted error 1.08E-18 -C log weighted error 17.97 -C significant figures required 19.02 -C decimal places required 18.61 -C -C -C Series for E12 on the interval -1.00000D+00 to 1.00000D+00 -C with weighted error 3.15E-18 -C log weighted error 17.50 -C approx significant figures required 15.8 -C decimal places required 18.10 -C -C -C Series for AE13 on the interval 2.50000D-01 to 1.00000D+00 -C with weighted error 2.34E-17 -C log weighted error 16.63 -C significant figures required 16.14 -C decimal places required 17.33 -C -C -C Series for AE14 on the interval 0. to 2.50000D-01 -C with weighted error 5.41E-17 -C log weighted error 16.27 -C significant figures required 15.38 -C decimal places required 16.97 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891115 Modified prologue description. (WRB) -C 891115 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 920618 Removed space from variable names. (RWC, WRB) -C***END PROLOGUE E1 - DIMENSION AE11CS(39), AE12CS(25), E11CS(19), E12CS(16), - 1 AE13CS(25), AE14CS(26) - LOGICAL FIRST - SAVE AE11CS, AE12CS, E11CS, E12CS, AE13CS, AE14CS, - 1 NTAE11, NTAE12, NTE11, NTE12, NTAE13, NTAE14, XMAX, FIRST - DATA AE11CS( 1) / .1215032397 1606579E0 / - DATA AE11CS( 2) / -.0650887785 13550150E0 / - DATA AE11CS( 3) / .0048976513 57459670E0 / - DATA AE11CS( 4) / -.0006492378 43027216E0 / - DATA AE11CS( 5) / .0000938404 34587471E0 / - DATA AE11CS( 6) / .0000004202 36380882E0 / - DATA AE11CS( 7) / -.0000081133 74735904E0 / - DATA AE11CS( 8) / .0000028042 47688663E0 / - DATA AE11CS( 9) / .0000000564 87164441E0 / - DATA AE11CS(10) / -.0000003448 09174450E0 / - DATA AE11CS(11) / .0000000582 09273578E0 / - DATA AE11CS(12) / .0000000387 11426349E0 / - DATA AE11CS(13) / -.0000000124 53235014E0 / - DATA AE11CS(14) / -.0000000051 18504888E0 / - DATA AE11CS(15) / .0000000021 48771527E0 / - DATA AE11CS(16) / .0000000008 68459898E0 / - DATA AE11CS(17) / -.0000000003 43650105E0 / - DATA AE11CS(18) / -.0000000001 79796603E0 / - DATA AE11CS(19) / .0000000000 47442060E0 / - DATA AE11CS(20) / .0000000000 40423282E0 / - DATA AE11CS(21) / -.0000000000 03543928E0 / - DATA AE11CS(22) / -.0000000000 08853444E0 / - DATA AE11CS(23) / -.0000000000 00960151E0 / - DATA AE11CS(24) / .0000000000 01692921E0 / - DATA AE11CS(25) / .0000000000 00607990E0 / - DATA AE11CS(26) / -.0000000000 00224338E0 / - DATA AE11CS(27) / -.0000000000 00200327E0 / - DATA AE11CS(28) / -.0000000000 00006246E0 / - DATA AE11CS(29) / .0000000000 00045571E0 / - DATA AE11CS(30) / .0000000000 00016383E0 / - DATA AE11CS(31) / -.0000000000 00005561E0 / - DATA AE11CS(32) / -.0000000000 00006074E0 / - DATA AE11CS(33) / -.0000000000 00000862E0 / - DATA AE11CS(34) / .0000000000 00001223E0 / - DATA AE11CS(35) / .0000000000 00000716E0 / - DATA AE11CS(36) / -.0000000000 00000024E0 / - DATA AE11CS(37) / -.0000000000 00000201E0 / - DATA AE11CS(38) / -.0000000000 00000082E0 / - DATA AE11CS(39) / .0000000000 00000017E0 / - DATA AE12CS( 1) / .5824174951 3472674E0 / - DATA AE12CS( 2) / -.1583488509 0578275E0 / - DATA AE12CS( 3) / -.0067642755 90323141E0 / - DATA AE12CS( 4) / .0051258439 50185725E0 / - DATA AE12CS( 5) / .0004352324 92169391E0 / - DATA AE12CS( 6) / -.0001436133 66305483E0 / - DATA AE12CS( 7) / -.0000418013 20556301E0 / - DATA AE12CS( 8) / -.0000027133 95758640E0 / - DATA AE12CS( 9) / .0000011513 81913647E0 / - DATA AE12CS(10) / .0000004206 50022012E0 / - DATA AE12CS(11) / .0000000665 81901391E0 / - DATA AE12CS(12) / .0000000006 62143777E0 / - DATA AE12CS(13) / -.0000000028 44104870E0 / - DATA AE12CS(14) / -.0000000009 40724197E0 / - DATA AE12CS(15) / -.0000000001 77476602E0 / - DATA AE12CS(16) / -.0000000000 15830222E0 / - DATA AE12CS(17) / .0000000000 02905732E0 / - DATA AE12CS(18) / .0000000000 01769356E0 / - DATA AE12CS(19) / .0000000000 00492735E0 / - DATA AE12CS(20) / .0000000000 00093709E0 / - DATA AE12CS(21) / .0000000000 00010707E0 / - DATA AE12CS(22) / -.0000000000 00000537E0 / - DATA AE12CS(23) / -.0000000000 00000716E0 / - DATA AE12CS(24) / -.0000000000 00000244E0 / - DATA AE12CS(25) / -.0000000000 00000058E0 / - DATA E11CS( 1) / -16.1134616555 71494026E0 / - DATA E11CS( 2) / 7.7940727787 426802769E0 / - DATA E11CS( 3) / -1.9554058188 631419507E0 / - DATA E11CS( 4) / .3733729386 6277945612E0 / - DATA E11CS( 5) / -.0569250319 1092901938E0 / - DATA E11CS( 6) / .0072110777 6966009185E0 / - DATA E11CS( 7) / -.0007810490 1449841593E0 / - DATA E11CS( 8) / .0000738809 3356262168E0 / - DATA E11CS( 9) / -.0000062028 6187580820E0 / - DATA E11CS(10) / .0000004681 6002303176E0 / - DATA E11CS(11) / -.0000000320 9288853329E0 / - DATA E11CS(12) / .0000000020 1519974874E0 / - DATA E11CS(13) / -.0000000001 1673686816E0 / - DATA E11CS(14) / .0000000000 0627627066E0 / - DATA E11CS(15) / -.0000000000 0031481541E0 / - DATA E11CS(16) / .0000000000 0001479904E0 / - DATA E11CS(17) / -.0000000000 0000065457E0 / - DATA E11CS(18) / .0000000000 0000002733E0 / - DATA E11CS(19) / -.0000000000 0000000108E0 / - DATA E12CS( 1) / -0.0373902147 92202795E0 / - DATA E12CS( 2) / 0.0427239860 62209577E0 / - DATA E12CS( 3) / -.1303182079 849700544E0 / - DATA E12CS( 4) / .0144191240 2469889073E0 / - DATA E12CS( 5) / -.0013461707 8051068022E0 / - DATA E12CS( 6) / .0001073102 9253063780E0 / - DATA E12CS( 7) / -.0000074299 9951611943E0 / - DATA E12CS( 8) / .0000004537 7325690753E0 / - DATA E12CS( 9) / -.0000000247 6417211390E0 / - DATA E12CS(10) / .0000000012 2076581374E0 / - DATA E12CS(11) / -.0000000000 5485141480E0 / - DATA E12CS(12) / .0000000000 0226362142E0 / - DATA E12CS(13) / -.0000000000 0008635897E0 / - DATA E12CS(14) / .0000000000 0000306291E0 / - DATA E12CS(15) / -.0000000000 0000010148E0 / - DATA E12CS(16) / .0000000000 0000000315E0 / - DATA AE13CS( 1) / -.6057732466 4060346E0 / - DATA AE13CS( 2) / -.1125352434 8366090E0 / - DATA AE13CS( 3) / .0134322662 47902779E0 / - DATA AE13CS( 4) / -.0019268451 87381145E0 / - DATA AE13CS( 5) / .0003091183 37720603E0 / - DATA AE13CS( 6) / -.0000535641 32129618E0 / - DATA AE13CS( 7) / .0000098278 12880247E0 / - DATA AE13CS( 8) / -.0000018853 68984916E0 / - DATA AE13CS( 9) / .0000003749 43193568E0 / - DATA AE13CS(10) / -.0000000768 23455870E0 / - DATA AE13CS(11) / .0000000161 43270567E0 / - DATA AE13CS(12) / -.0000000034 66802211E0 / - DATA AE13CS(13) / .0000000007 58754209E0 / - DATA AE13CS(14) / -.0000000001 68864333E0 / - DATA AE13CS(15) / .0000000000 38145706E0 / - DATA AE13CS(16) / -.0000000000 08733026E0 / - DATA AE13CS(17) / .0000000000 02023672E0 / - DATA AE13CS(18) / -.0000000000 00474132E0 / - DATA AE13CS(19) / .0000000000 00112211E0 / - DATA AE13CS(20) / -.0000000000 00026804E0 / - DATA AE13CS(21) / .0000000000 00006457E0 / - DATA AE13CS(22) / -.0000000000 00001568E0 / - DATA AE13CS(23) / .0000000000 00000383E0 / - DATA AE13CS(24) / -.0000000000 00000094E0 / - DATA AE13CS(25) / .0000000000 00000023E0 / - DATA AE14CS( 1) / -.1892918000 753017E0 / - DATA AE14CS( 2) / -.0864811785 5259871E0 / - DATA AE14CS( 3) / .0072241015 4374659E0 / - DATA AE14CS( 4) / -.0008097559 4575573E0 / - DATA AE14CS( 5) / .0001099913 4432661E0 / - DATA AE14CS( 6) / -.0000171733 2998937E0 / - DATA AE14CS( 7) / .0000029856 2751447E0 / - DATA AE14CS( 8) / -.0000005659 6491457E0 / - DATA AE14CS( 9) / .0000001152 6808397E0 / - DATA AE14CS(10) / -.0000000249 5030440E0 / - DATA AE14CS(11) / .0000000056 9232420E0 / - DATA AE14CS(12) / -.0000000013 5995766E0 / - DATA AE14CS(13) / .0000000003 3846628E0 / - DATA AE14CS(14) / -.0000000000 8737853E0 / - DATA AE14CS(15) / .0000000000 2331588E0 / - DATA AE14CS(16) / -.0000000000 0641148E0 / - DATA AE14CS(17) / .0000000000 0181224E0 / - DATA AE14CS(18) / -.0000000000 0052538E0 / - DATA AE14CS(19) / .0000000000 0015592E0 / - DATA AE14CS(20) / -.0000000000 0004729E0 / - DATA AE14CS(21) / .0000000000 0001463E0 / - DATA AE14CS(22) / -.0000000000 0000461E0 / - DATA AE14CS(23) / .0000000000 0000148E0 / - DATA AE14CS(24) / -.0000000000 0000048E0 / - DATA AE14CS(25) / .0000000000 0000016E0 / - DATA AE14CS(26) / -.0000000000 0000005E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT E1 - IF (FIRST) THEN - ETA = 0.1*R1MACH(3) - NTAE11 = INITS (AE11CS, 39, ETA) - NTAE12 = INITS (AE12CS, 25, ETA) - NTE11 = INITS (E11CS, 19, ETA) - NTE12 = INITS (E12CS, 16, ETA) - NTAE13 = INITS (AE13CS, 25, ETA) - NTAE14 = INITS (AE14CS, 26, ETA) -C - XMAXT = -LOG (R1MACH(1)) - XMAX = XMAXT - LOG(XMAXT) - ENDIF - FIRST = .FALSE. -C - IF (X.GT.(-10.)) GO TO 20 -C -C E1(X) = -EI(-X) FOR X .LE. -10. -C - E1 = EXP(-X)/X * (1.+CSEVL (20./X+1., AE11CS, NTAE11)) - RETURN -C - 20 IF (X.GT.(-4.0)) GO TO 30 -C -C E1(X) = -EI(-X) FOR -10. .LT. X .LE. -4. -C - E1 = EXP(-X)/X * (1.+CSEVL ((40./X+7.)/3., AE12CS, NTAE12)) - RETURN -C - 30 IF (X.GT.(-1.0)) GO TO 40 -C -C E1(X) = -EI(-X) FOR -4. .LT. X .LE. -1. -C - E1 = -LOG(ABS(X)) + CSEVL ((2.*X+5.)/3., E11CS, NTE11) - RETURN -C - 40 IF (X.GT.1.) GO TO 50 - IF (X .EQ. 0.) CALL XERMSG ('SLATEC', 'E1', 'X IS 0', 2, 2) -C -C E1(X) = -EI(-X) FOR -1. .LT. X .LE. 1., X .NE. 0. -C - E1 = (-LOG(ABS(X)) - 0.6875 + X) + CSEVL (X, E12CS, NTE12) - RETURN -C - 50 IF (X.GT.4.) GO TO 60 -C -C E1(X) = -EI(-X) FOR 1. .LT. X .LE. 4. -C - E1 = EXP(-X)/X * (1.+CSEVL ((8./X-5.)/3., AE13CS, NTAE13)) - RETURN -C - 60 IF (X.GT.XMAX) GO TO 70 -C -C E1(X) = -EI(-X) FOR 4. .LT. X .LE. XMAX -C - E1 = EXP(-X)/X * (1. + CSEVL (8./X-1., AE14CS, NTAE14)) - RETURN -C -C E1(X) = -EI(-X) FOR X .GT. XMAX -C - 70 CALL XERMSG ('SLATEC', 'E1', 'X SO BIG E1 UNDERFLOWS', 1, 1) - E1 = 0. - RETURN -C - END diff --git a/slatec/efc.f b/slatec/efc.f deleted file mode 100644 index 806d38c..0000000 --- a/slatec/efc.f +++ /dev/null @@ -1,268 +0,0 @@ -*DECK EFC - SUBROUTINE EFC (NDATA, XDATA, YDATA, SDDATA, NORD, NBKPT, BKPT, - + MDEIN, MDEOUT, COEFF, LW, W) -C***BEGIN PROLOGUE EFC -C***PURPOSE Fit a piecewise polynomial curve to discrete data. -C The piecewise polynomials are represented as B-splines. -C The fitting is done in a weighted least squares sense. -C***LIBRARY SLATEC -C***CATEGORY K1A1A1, K1A2A, L8A3 -C***TYPE SINGLE PRECISION (EFC-S, DEFC-D) -C***KEYWORDS B-SPLINE, CURVE FITTING, WEIGHTED LEAST SQUARES -C***AUTHOR Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C This subprogram fits a piecewise polynomial curve -C to discrete data. The piecewise polynomials are -C represented as B-splines. -C The fitting is done in a weighted least squares sense. -C -C The data can be processed in groups of modest size. -C The size of the group is chosen by the user. This feature -C may be necessary for purposes of using constrained curve fitting -C with subprogram FC( ) on a very large data set. -C -C For a description of the B-splines and usage instructions to -C evaluate them, see -C -C C. W. de Boor, Package for Calculating with B-Splines. -C SIAM J. Numer. Anal., p. 441, (June, 1977). -C -C For further discussion of (constrained) curve fitting using -C B-splines, see -C -C R. J. Hanson, Constrained Least Squares Curve Fitting -C to Discrete Data Using B-Splines, a User's -C Guide. Sandia Labs. Tech. Rept. SAND-78-1291, -C December, (1978). -C -C Input.. -C NDATA,XDATA(*), -C YDATA(*), -C SDDATA(*) -C The NDATA discrete (X,Y) pairs and the Y value -C standard deviation or uncertainty, SD, are in -C the respective arrays XDATA(*), YDATA(*), and -C SDDATA(*). No sorting of XDATA(*) is -C required. Any non-negative value of NDATA is -C allowed. A negative value of NDATA is an -C error. A zero value for any entry of -C SDDATA(*) will weight that data point as 1. -C Otherwise the weight of that data point is -C the reciprocal of this entry. -C -C NORD,NBKPT, -C BKPT(*) -C The NBKPT knots of the B-spline of order NORD -C are in the array BKPT(*). Normally the -C problem data interval will be included between -C the limits BKPT(NORD) and BKPT(NBKPT-NORD+1). -C The additional end knots BKPT(I),I=1,..., -C NORD-1 and I=NBKPT-NORD+2,...,NBKPT, are -C required to compute the functions used to fit -C the data. No sorting of BKPT(*) is required. -C Internal to EFC( ) the extreme end knots may -C be reduced and increased respectively to -C accommodate any data values that are exterior -C to the given knot values. The contents of -C BKPT(*) is not changed. -C -C NORD must be in the range 1 .LE. NORD .LE. 20. -C The value of NBKPT must satisfy the condition -C NBKPT .GE. 2*NORD. -C Other values are considered errors. -C -C (The order of the spline is one more than the -C degree of the piecewise polynomial defined on -C each interval. This is consistent with the -C B-spline package convention. For example, -C NORD=4 when we are using piecewise cubics.) -C -C MDEIN -C An integer flag, with one of two possible -C values (1 or 2), that directs the subprogram -C action with regard to new data points provided -C by the user. -C -C =1 The first time that EFC( ) has been -C entered. There are NDATA points to process. -C -C =2 This is another entry to EFC( ). The sub- -C program EFC( ) has been entered with MDEIN=1 -C exactly once before for this problem. There -C are NDATA new additional points to merge and -C process with any previous points. -C (When using EFC( ) with MDEIN=2 it is import- -C ant that the set of knots remain fixed at the -C same values for all entries to EFC( ).) -C LW -C The amount of working storage actually -C allocated for the working array W(*). -C This quantity is compared with the -C actual amount of storage needed in EFC( ). -C Insufficient storage allocated for W(*) is -C an error. This feature was included in EFC( ) -C because misreading the storage formula -C for W(*) might very well lead to subtle -C and hard-to-find programming bugs. -C -C The length of the array W(*) must satisfy -C -C LW .GE. (NBKPT-NORD+3)*(NORD+1)+ -C (NBKPT+1)*(NORD+1)+ -C 2*MAX(NDATA,NBKPT)+NBKPT+NORD**2 -C -C Output.. -C MDEOUT -C An output flag that indicates the status -C of the curve fit. -C -C =-1 A usage error of EFC( ) occurred. The -C offending condition is noted with the SLATEC -C library error processor, XERMSG( ). In case -C the working array W(*) is not long enough, the -C minimal acceptable length is printed. -C -C =1 The B-spline coefficients for the fitted -C curve have been returned in array COEFF(*). -C -C =2 Not enough data has been processed to -C determine the B-spline coefficients. -C The user has one of two options. Continue -C to process more data until a unique set -C of coefficients is obtained, or use the -C subprogram FC( ) to obtain a specific -C set of coefficients. The user should read -C the usage instructions for FC( ) for further -C details if this second option is chosen. -C COEFF(*) -C If the output value of MDEOUT=1, this array -C contains the unknowns obtained from the least -C squares fitting process. These N=NBKPT-NORD -C parameters are the B-spline coefficients. -C For MDEOUT=2, not enough data was processed to -C uniquely determine the B-spline coefficients. -C In this case, and also when MDEOUT=-1, all -C values of COEFF(*) are set to zero. -C -C If the user is not satisfied with the fitted -C curve returned by EFC( ), the constrained -C least squares curve fitting subprogram FC( ) -C may be required. The work done within EFC( ) -C to accumulate the data can be utilized by -C the user, if so desired. This involves -C saving the first (NBKPT-NORD+3)*(NORD+1) -C entries of W(*) and providing this data -C to FC( ) with the "old problem" designation. -C The user should read the usage instructions -C for subprogram FC( ) for further details. -C -C Working Array.. -C W(*) -C This array is typed REAL. -C Its length is specified as an input parameter -C in LW as noted above. The contents of W(*) -C must not be modified by the user between calls -C to EFC( ) with values of MDEIN=1,2,2,... . -C The first (NBKPT-NORD+3)*(NORD+1) entries of -C W(*) are acceptable as direct input to FC( ) -C for an "old problem" only when MDEOUT=1 or 2. -C -C Evaluating the -C Fitted Curve.. -C To evaluate derivative number IDER at XVAL, -C use the function subprogram BVALU( ). -C -C F = BVALU(BKPT,COEFF,NBKPT-NORD,NORD,IDER, -C XVAL,INBV,WORKB) -C -C The output of this subprogram will not be -C defined unless an output value of MDEOUT=1 -C was obtained from EFC( ), XVAL is in the data -C interval, and IDER is nonnegative and .LT. -C NORD. -C -C The first time BVALU( ) is called, INBV=1 -C must be specified. This value of INBV is the -C overwritten by BVALU( ). The array WORKB(*) -C must be of length at least 3*NORD, and must -C not be the same as the W(*) array used in the -C call to EFC( ). -C -C BVALU( ) expects the breakpoint array BKPT(*) -C to be sorted. -C -C***REFERENCES R. J. Hanson, Constrained least squares curve fitting -C to discrete data using B-splines, a users guide, -C Report SAND78-1291, Sandia Laboratories, December -C 1978. -C***ROUTINES CALLED EFCMN -C***REVISION HISTORY (YYMMDD) -C 800801 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 900510 Change Prologue comments to refer to XERMSG. (RWC) -C 900607 Editorial changes to Prologue to make Prologues for EFC, -C DEFC, FC, and DFC look as much the same as possible. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE EFC -C -C SUBROUTINE FUNCTION/REMARKS -C -C BSPLVN( ) COMPUTE FUNCTION VALUES OF B-SPLINES. FROM -C THE B-SPLINE PACKAGE OF DE BOOR NOTED ABOVE. -C -C BNDACC( ), BANDED LEAST SQUARES MATRIX PROCESSORS. -C BNDSOL( ) FROM LAWSON-HANSON, SOLVING LEAST -C SQUARES PROBLEMS. -C -C SSORT( ) DATA SORTING SUBROUTINE, FROM THE -C SANDIA MATH. LIBRARY, SAND77-1441. -C -C XERMSG( ) ERROR HANDLING ROUTINE -C FOR THE SLATEC MATH. LIBRARY. -C SEE SAND78-1189, BY R. E. JONES. -C -C SCOPY( ),SSCAL( ) SUBROUTINES FROM THE BLAS PACKAGE. -C -C WRITTEN BY R. HANSON, SANDIA NATL. LABS., -C ALB., N. M., AUGUST-SEPTEMBER, 1980. -C - REAL BKPT(*),COEFF(*),SDDATA(*),W(*),XDATA(*),YDATA(*) - INTEGER LW, MDEIN, MDEOUT, NBKPT, NDATA, NORD -C - EXTERNAL EFCMN -C - INTEGER LBF, LBKPT, LG, LPTEMP, LWW, LXTEMP, MDG, MDW -C -C***FIRST EXECUTABLE STATEMENT EFC -C LWW=1 USAGE IN EFCMN( ) OF W(*).. -C LWW,...,LG-1 W(*,*) -C -C LG,...,LXTEMP-1 G(*,*) -C -C LXTEMP,...,LPTEMP-1 XTEMP(*) -C -C LPTEMP,...,LBKPT-1 PTEMP(*) -C -C LBKPT,...,LBF BKPT(*) (LOCAL TO EFCMN( )) -C -C LBF,...,LBF+NORD**2 BF(*,*) -C - MDG = NBKPT+1 - MDW = NBKPT-NORD+3 - LWW = 1 - LG = LWW + MDW*(NORD+1) - LXTEMP = LG + MDG*(NORD+1) - LPTEMP = LXTEMP + MAX(NDATA,NBKPT) - LBKPT = LPTEMP + MAX(NDATA,NBKPT) - LBF = LBKPT + NBKPT - CALL EFCMN(NDATA,XDATA,YDATA,SDDATA, - 1 NORD,NBKPT,BKPT, - 2 MDEIN,MDEOUT, - 3 COEFF, - 4 W(LBF),W(LXTEMP),W(LPTEMP),W(LBKPT), - 5 W(LG),MDG,W(LWW),MDW,LW) - RETURN - END diff --git a/slatec/efcmn.f b/slatec/efcmn.f deleted file mode 100644 index 463cc12..0000000 --- a/slatec/efcmn.f +++ /dev/null @@ -1,236 +0,0 @@ -*DECK EFCMN - SUBROUTINE EFCMN (NDATA, XDATA, YDATA, SDDATA, NORD, NBKPT, - + BKPTIN, MDEIN, MDEOUT, COEFF, BF, XTEMP, PTEMP, BKPT, G, MDG, - + W, MDW, LW) -C***BEGIN PROLOGUE EFCMN -C***SUBSIDIARY -C***PURPOSE Subsidiary to EFC -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (EFCMN-S, DEFCMN-D) -C***AUTHOR Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C This is a companion subprogram to EFC( ). -C This subprogram does weighted least squares fitting of data by -C B-spline curves. -C The documentation for EFC( ) has complete usage instructions. -C -C***SEE ALSO EFC -C***ROUTINES CALLED BNDACC, BNDSOL, BSPLVN, SCOPY, SSCAL, SSORT, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800801 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and extensively revised (WRB & RWC) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C***END PROLOGUE EFCMN - INTEGER LW, MDEIN, MDEOUT, MDG, MDW, NBKPT, NDATA, NORD - REAL BF(NORD,*), BKPT(*), BKPTIN(*), COEFF(*), - * G(MDG,*), PTEMP(*), SDDATA(*), W(MDW,*), XDATA(*), XTEMP(*), - * YDATA(*) -C - EXTERNAL BNDACC, BNDSOL, BSPLVN, SCOPY, SSCAL, SSORT, XERMSG -C - REAL DUMMY, RNORM, XMAX, XMIN, XVAL - INTEGER I, IDATA, ILEFT, INTSEQ, IP, IR, IROW, L, MT, N, NB, - * NORDM1, NORDP1, NP1 - CHARACTER*8 XERN1, XERN2 -C -C***FIRST EXECUTABLE STATEMENT EFCMN -C -C Initialize variables and analyze input. -C - N = NBKPT - NORD - NP1 = N + 1 -C -C Initially set all output coefficients to zero. -C - CALL SCOPY (N, 0.E0, 0, COEFF, 1) - MDEOUT = -1 - IF (NORD.LT.1 .OR. NORD.GT.20) THEN - CALL XERMSG ('SLATEC', 'EFCMN', - + 'IN EFC, THE ORDER OF THE B-SPLINE MUST BE 1 THRU 20.', - + 3, 1) - RETURN - ENDIF -C - IF (NBKPT.LT.2*NORD) THEN - CALL XERMSG ('SLATEC', 'EFCMN', - + 'IN EFC, THE NUMBER OF KNOTS MUST BE AT LEAST TWICE ' // - + 'THE B-SPLINE ORDER.', 4, 1) - RETURN - ENDIF -C - IF (NDATA.LT.0) THEN - CALL XERMSG ('SLATEC', 'EFCMN', - + 'IN EFC, THE NUMBER OF DATA POINTS MUST BE NONNEGATIVE.', - + 5, 1) - RETURN - ENDIF -C - NB = (NBKPT-NORD+3)*(NORD+1) + (NBKPT+1)*(NORD+1) + - + 2*MAX(NBKPT,NDATA) + NBKPT + NORD**2 - IF (LW .LT. NB) THEN - WRITE (XERN1, '(I8)') NB - WRITE (XERN2, '(I8)') LW - CALL XERMSG ('SLATEC', 'EFCMN', - * 'IN EFC, INSUFFICIENT STORAGE FOR W(*). CHECK FORMULA ' // - * 'THAT READS LW.GE. ... . NEED = ' // XERN1 // - * ' GIVEN = ' // XERN2, 6, 1) - MDEOUT = -1 - RETURN - ENDIF -C - IF (MDEIN.NE.1 .AND. MDEIN.NE.2) THEN - CALL XERMSG ('SLATEC', 'EFCMN', - + 'IN EFC, INPUT VALUE OF MDEIN MUST BE 1-2.', 7, 1) - RETURN - ENDIF -C -C Sort the breakpoints. -C - CALL SCOPY (NBKPT, BKPTIN, 1, BKPT, 1) - CALL SSORT (BKPT, DUMMY, NBKPT, 1) -C -C Save interval containing knots. -C - XMIN = BKPT(NORD) - XMAX = BKPT(NP1) - NORDM1 = NORD - 1 - NORDP1 = NORD + 1 -C -C Process least squares equations. -C -C Sort data and an array of pointers. -C - CALL SCOPY (NDATA, XDATA, 1, XTEMP, 1) - DO 100 I = 1,NDATA - PTEMP(I) = I - 100 CONTINUE -C - IF (NDATA.GT.0) THEN - CALL SSORT (XTEMP, PTEMP, NDATA, 2) - XMIN = MIN(XMIN,XTEMP(1)) - XMAX = MAX(XMAX,XTEMP(NDATA)) - ENDIF -C -C Fix breakpoint array if needed. This should only involve very -C minor differences with the input array of breakpoints. -C - DO 110 I = 1,NORD - BKPT(I) = MIN(BKPT(I),XMIN) - 110 CONTINUE -C - DO 120 I = NP1,NBKPT - BKPT(I) = MAX(BKPT(I),XMAX) - 120 CONTINUE -C -C Initialize parameters of banded matrix processor, BNDACC( ). -C - MT = 0 - IP = 1 - IR = 1 - ILEFT = NORD - INTSEQ = 1 - DO 150 IDATA = 1,NDATA -C -C Sorted indices are in PTEMP(*). -C - L = PTEMP(IDATA) - XVAL = XDATA(L) -C -C When interval changes, process equations in the last block. -C - IF (XVAL.GE.BKPT(ILEFT+1)) THEN - CALL BNDACC (G, MDG, NORD, IP, IR, MT, ILEFT-NORDM1) - MT = 0 -C -C Move pointer up to have BKPT(ILEFT).LE.XVAL, ILEFT.LE.N. -C - DO 130 ILEFT = ILEFT,N - IF (XVAL.LT.BKPT(ILEFT+1)) GO TO 140 - IF (MDEIN.EQ.2) THEN -C -C Data is being sequentially accumulated. -C Transfer previously accumulated rows from W(*,*) to -C G(*,*) and process them. -C - CALL SCOPY (NORDP1, W(INTSEQ,1), MDW, G(IR,1), MDG) - CALL BNDACC (G, MDG, NORD, IP, IR, 1, INTSEQ) - INTSEQ = INTSEQ + 1 - ENDIF - 130 CONTINUE - ENDIF -C -C Obtain B-spline function value. -C - 140 CALL BSPLVN (BKPT, NORD, 1, XVAL, ILEFT, BF) -C -C Move row into place. -C - IROW = IR + MT - MT = MT + 1 - CALL SCOPY (NORD, BF, 1, G(IROW,1), MDG) - G(IROW,NORDP1) = YDATA(L) -C -C Scale data if uncertainty is nonzero. -C - IF (SDDATA(L).NE.0.E0) CALL SSCAL (NORDP1, 1.E0/SDDATA(L), - + G(IROW,1), MDG) -C -C When staging work area is exhausted, process rows. -C - IF (IROW.EQ.MDG-1) THEN - CALL BNDACC (G, MDG, NORD, IP, IR, MT, ILEFT-NORDM1) - MT = 0 - ENDIF - 150 CONTINUE -C -C Process last block of equations. -C - CALL BNDACC (G, MDG, NORD, IP, IR, MT, ILEFT-NORDM1) -C -C Finish processing any previously accumulated rows from W(*,*) -C to G(*,*). -C - IF (MDEIN.EQ.2) THEN - DO 160 I = INTSEQ,NP1 - CALL SCOPY (NORDP1, W(I,1), MDW, G(IR,1), MDG) - CALL BNDACC (G, MDG, NORD, IP, IR, 1, MIN(N,I)) - 160 CONTINUE - ENDIF -C -C Last call to adjust block positioning. -C - CALL SCOPY (NORDP1, 0.E0, 0, G(IR,1), MDG) - CALL BNDACC (G, MDG, NORD, IP, IR, 1, NP1) -C -C Transfer accumulated rows from G(*,*) to W(*,*) for -C possible later sequential accumulation. -C - DO 170 I = 1,NP1 - CALL SCOPY (NORDP1, G(I,1), MDG, W(I,1), MDW) - 170 CONTINUE -C -C Solve for coefficients when possible. -C - DO 180 I = 1,N - IF (G(I,1).EQ.0.E0) THEN - MDEOUT = 2 - RETURN - ENDIF - 180 CONTINUE -C -C All the diagonal terms in the accumulated triangular -C matrix are nonzero. The solution can be computed but -C it may be unsuitable for further use due to poor -C conditioning or the lack of constraints. No checking -C for either of these is done here. -C - CALL BNDSOL (1, G, MDG, NORD, IP, IR, COEFF, N, RNORM) - MDEOUT = 1 - RETURN - END diff --git a/slatec/ei.f b/slatec/ei.f deleted file mode 100644 index de5d639..0000000 --- a/slatec/ei.f +++ /dev/null @@ -1,34 +0,0 @@ -*DECK EI - FUNCTION EI (X) -C***BEGIN PROLOGUE EI -C***PURPOSE Compute the exponential integral Ei(X). -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C5 -C***TYPE SINGLE PRECISION (EI-S, DEI-D) -C***KEYWORDS EI FUNCTION, EXPONENTIAL INTEGRAL, FNLIB, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C EI calculates the single precision exponential integral, Ei(X), for -C positive single precision argument X and the Cauchy principal value -C for negative X. If principal values are used everywhere, then, for -C all X, -C -C Ei(X) = -E1(-X) -C or -C E1(X) = -Ei(-X). -C -C***REFERENCES (NONE) -C***ROUTINES CALLED E1 -C***REVISION HISTORY (YYMMDD) -C 770401 DATE WRITTEN -C 891115 Modified prologue description. (WRB) -C 891115 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE EI -C***FIRST EXECUTABLE STATEMENT EI - EI = -E1(-X) -C - RETURN - END diff --git a/slatec/eisdoc.f b/slatec/eisdoc.f deleted file mode 100644 index ebe548a..0000000 --- a/slatec/eisdoc.f +++ /dev/null @@ -1,279 +0,0 @@ -*DECK EISDOC - SUBROUTINE EISDOC -C***BEGIN PROLOGUE EISDOC -C***PURPOSE Documentation for EISPACK, a collection of subprograms for -C solving matrix eigen-problems. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4, Z -C***TYPE ALL (EISDOC-A) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Vandevender, W. H., (SNLA) -C***DESCRIPTION -C -C **********EISPACK Routines********** -C -C single double complx -C ------ ------ ------ -C -C RS - CH Computes eigenvalues and, optionally, -C eigenvectors of real symmetric -C (complex Hermitian) matrix. -C -C RSP - - Compute eigenvalues and, optionally, -C eigenvectors of real symmetric matrix -C packed into a one dimensional array. -C -C RG - CG Computes eigenvalues and, optionally, -C eigenvectors of a real (complex) general -C matrix. -C -C BISECT - - Compute eigenvalues of symmetric tridiagonal -C matrix given interval using Sturm sequencing. -C -C IMTQL1 - - Computes eigenvalues of symmetric tridiagonal -C matrix implicit QL method. -C -C IMTQL2 - - Computes eigenvalues and eigenvectors of -C symmetric tridiagonal matrix using -C implicit QL method. -C -C IMTQLV - - Computes eigenvalues of symmetric tridiagonal -C matrix by the implicit QL method. -C Eigenvectors may be computed later. -C -C RATQR - - Computes largest or smallest eigenvalues -C of symmetric tridiagonal matrix using -C rational QR method with Newton correction. -C -C RST - - Compute eigenvalues and, optionally, -C eigenvectors of real symmetric tridiagonal -C matrix. -C -C RT - - Compute eigenvalues and eigenvectors of -C a special real tridiagonal matrix. -C -C TQL1 - - Compute eigenvalues of symmetric tridiagonal -C matrix by QL method. -C -C TQL2 - - Compute eigenvalues and eigenvectors -C of symmetric tridiagonal matrix. -C -C TQLRAT - - Computes eigenvalues of symmetric -C tridiagonal matrix a rational variant -C of the QL method. -C -C TRIDIB - - Computes eigenvalues of symmetric -C tridiagonal matrix given interval using -C Sturm sequencing. -C -C TSTURM - - Computes eigenvalues of symmetric tridiagonal -C matrix given interval and eigenvectors -C by Sturm sequencing. This subroutine -C is a translation of the ALGOL procedure -C TRISTURM by Peters and Wilkinson. HANDBOOK -C FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, -C 418-439(1971). -C -C BQR - - Computes some of the eigenvalues of a real -C symmetric matrix using the QR method with -C shifts of origin. -C -C RSB - - Computes eigenvalues and, optionally, -C eigenvectors of symmetric band matrix. -C -C RSG - - Computes eigenvalues and, optionally, -C eigenvectors of symmetric generalized -C eigenproblem: A*X=(LAMBDA)*B*X -C -C RSGAB - - Computes eigenvalues and, optionally, -C eigenvectors of symmetric generalized -C eigenproblem: A*B*X=(LAMBDA)*X -C -C RSGBA - - Computes eigenvalues and, optionally, -C eigenvectors of symmetric generalized -C eigenproblem: B*A*X=(LAMBDA)*X -C -C RGG - - Computes eigenvalues and eigenvectors -C for real generalized eigenproblem: -C A*X=(LAMBDA)*B*X. -C -C BALANC - CBAL Balances a general real (complex) -C matrix and isolates eigenvalues whenever -C possible. -C -C BANDR - - Reduces real symmetric band matrix -C to symmetric tridiagonal matrix and, -C optionally, accumulates orthogonal similarity -C transformations. -C -C HTRID3 - - Reduces complex Hermitian (packed) matrix -C to real symmetric tridiagonal matrix by unitary -C similarity transformations. -C -C HTRIDI - - Reduces complex Hermitian matrix to real -C symmetric tridiagonal matrix using unitary -C similarity transformations. -C -C TRED1 - - Reduce real symmetric matrix to symmetric -C tridiagonal matrix using orthogonal -C similarity transformations. -C -C TRED2 - - Reduce real symmetric matrix to symmetric -C tridiagonal matrix using and accumulating -C orthogonal transformations. -C -C TRED3 - - Reduce symmetric matrix stored in packed -C form to symmetric tridiagonal matrix using -C orthogonal transformations. -C -C ELMHES - COMHES Reduces real (complex) general matrix to -C upper Hessenberg form using stabilized -C elementary similarity transformations. -C -C ORTHES - CORTH Reduces real (complex) general matrix to upper -C Hessenberg form orthogonal (unitary) -C similarity transformations. -C -C QZHES - - The first step of the QZ algorithm for solving -C generalized matrix eigenproblems. Accepts -C a pair of real general matrices and reduces -C one of them to upper Hessenberg and the other -C to upper triangular form using orthogonal -C transformations. Usually followed by QZIT, -C QZVAL, QZ -C -C QZIT - - The second step of the QZ algorithm for -C generalized eigenproblems. Accepts an upper -C Hessenberg and an upper triangular matrix -C and reduces the former to quasi-triangular -C form while preserving the form of the latter. -C Usually preceded by QZHES and followed by QZVAL -C and QZVEC. -C -C FIGI - - Transforms certain real non-symmetric -C tridiagonal matrix to symmetric tridiagonal -C matrix. -C -C FIGI2 - - Transforms certain real non-symmetric -C tridiagonal matrix to symmetric tridiagonal -C matrix. -C -C REDUC - - Reduces generalized symmetric eigenproblem -C A*X=(LAMBDA)*B*X, to standard symmetric -C eigenproblem using Cholesky factorization. -C -C REDUC2 - - Reduces certain generalized symmetric -C eigenproblems standard symmetric eigenproblem, -C using Cholesky factorization. -C -C - - COMLR Computes eigenvalues of a complex upper -C Hessenberg matrix using the modified LR method. -C -C - - COMLR2 Computes eigenvalues and eigenvectors of -C complex upper Hessenberg matrix using -C modified LR method. -C -C HQR - COMQR Computes eigenvalues of a real (complex) -C upper Hessenberg matrix using the QR method. -C -C HQR2 - COMQR2 Computes eigenvalues and eigenvectors of -C real (complex) upper Hessenberg matrix -C using QR method. -C -C INVIT - CINVIT Computes eigenvectors of real (complex) -C Hessenberg matrix associated with specified -C eigenvalues by inverse iteration. -C -C QZVAL - - The third step of the QZ algorithm for -C generalized eigenproblems. Accepts a pair -C of real matrices, one quasi-triangular form -C and the other in upper triangular form and -C computes the eigenvalues of the associated -C eigenproblem. Usually preceded by QZHES, -C QZIT, and followed by QZVEC. -C -C BANDV - - Forms eigenvectors of real symmetric band -C matrix associated with a set of ordered -C approximate eigenvalue by inverse iteration. -C -C QZVEC - - The optional fourth step of the QZ algorithm -C for generalized eigenproblems. Accepts -C a matrix in quasi-triangular form and another -C in upper triangular and computes the -C eigenvectors of the triangular problem -C and transforms them back to the original -C coordinates Usually preceded by QZHES, QZIT, -C QZVAL. -C -C TINVIT - - Eigenvectors of symmetric tridiagonal -C matrix corresponding to some specified -C eigenvalues, using inverse iteration. -C -C BAKVEC - - Forms eigenvectors of certain real -C non-symmetric tridiagonal matrix from -C symmetric tridiagonal matrix output from FIGI. -C -C BALBAK - CBABK2 Forms eigenvectors of real (complex) general -C matrix from eigenvectors of matrix output -C from BALANC (CBAL). -C -C ELMBAK - COMBAK Forms eigenvectors of real (complex) general -C matrix from eigenvectors of upper Hessenberg -C matrix output from ELMHES (COMHES). -C -C ELTRAN - - Accumulates the stabilized elementary -C similarity transformations used in the -C reduction of a real general matrix to upper -C Hessenberg form by ELMHES. -C -C HTRIB3 - - Computes eigenvectors of complex Hermitian -C matrix from eigenvectors of real symmetric -C tridiagonal matrix output from HTRID3. -C -C HTRIBK - - Forms eigenvectors of complex Hermitian -C matrix from eigenvectors of real symmetric -C tridiagonal matrix output from HTRIDI. -C -C ORTBAK - CORTB Forms eigenvectors of general real (complex) -C matrix from eigenvectors of upper Hessenberg -C matrix output from ORTHES (CORTH). -C -C ORTRAN - - Accumulates orthogonal similarity -C transformations in reduction of real general -C matrix by ORTHES. -C -C REBAK - - Forms eigenvectors of generalized symmetric -C eigensystem from eigenvectors of derived -C matrix output from REDUC or REDUC2. -C -C REBAKB - - Forms eigenvectors of generalized symmetric -C eigensystem from eigenvectors of derived -C matrix output from REDUC2 -C -C TRBAK1 - - Forms the eigenvectors of real symmetric -C matrix from eigenvectors of symmetric -C tridiagonal matrix formed by TRED1. -C -C TRBAK3 - - Forms eigenvectors of real symmetric matrix -C from the eigenvectors of symmetric tridiagonal -C matrix formed by TRED3. -C -C MINFIT - - Compute Singular Value Decomposition -C of rectangular matrix and solve related -C Linear Least Squares problem. -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 811101 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900723 PURPOSE section revised. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE EISDOC -C***FIRST EXECUTABLE STATEMENT EISDOC - RETURN - END diff --git a/slatec/elmbak.f b/slatec/elmbak.f deleted file mode 100644 index 4c7c7c3..0000000 --- a/slatec/elmbak.f +++ /dev/null @@ -1,106 +0,0 @@ -*DECK ELMBAK - SUBROUTINE ELMBAK (NM, LOW, IGH, A, INT, M, Z) -C***BEGIN PROLOGUE ELMBAK -C***PURPOSE Form the eigenvectors of a real general matrix from the -C eigenvectors of the upper Hessenberg matrix output from -C ELMHES. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C4 -C***TYPE SINGLE PRECISION (ELMBAK-S, COMBAK-C) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure ELMBAK, -C NUM. MATH. 12, 349-368(1968) by Martin and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). -C -C This subroutine forms the eigenvectors of a REAL GENERAL -C matrix by back transforming those of the corresponding -C upper Hessenberg matrix determined by ELMHES. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, A and Z, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C LOW and IGH are two INTEGER variables determined by the -C balancing subroutine BALANC. If BALANC has not been -C used, set LOW=1 and IGH equal to the order of the matrix. -C -C A contains the multipliers which were used in the reduction -C by ELMHES in its lower triangle below the subdiagonal. -C A is a two-dimensional REAL array, dimensioned A(NM,IGH). -C -C INT contains information on the rows and columns interchanged -C in the reduction by ELMHES. Only elements LOW through IGH -C are used. INT is a one-dimensional INTEGER array, -C dimensioned INT(IGH). -C -C M is the number of columns of Z to be back transformed. -C M is an INTEGER variable. -C -C Z contains the real and imaginary parts of the eigenvectors -C to be back transformed in its first M columns. Z is a -C two-dimensional REAL array, dimensioned Z(NM,M). -C -C On OUTPUT -C -C Z contains the real and imaginary parts of the transformed -C eigenvectors in its first M columns. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE ELMBAK -C - INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1 - REAL A(NM,*),Z(NM,*) - REAL X - INTEGER INT(*) -C -C***FIRST EXECUTABLE STATEMENT ELMBAK - IF (M .EQ. 0) GO TO 200 - LA = IGH - 1 - KP1 = LOW + 1 - IF (LA .LT. KP1) GO TO 200 -C .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... - DO 140 MM = KP1, LA - MP = LOW + IGH - MM - MP1 = MP + 1 -C - DO 110 I = MP1, IGH - X = A(I,MP-1) - IF (X .EQ. 0.0E0) GO TO 110 -C - DO 100 J = 1, M - 100 Z(I,J) = Z(I,J) + X * Z(MP,J) -C - 110 CONTINUE -C - I = INT(MP) - IF (I .EQ. MP) GO TO 140 -C - DO 130 J = 1, M - X = Z(I,J) - Z(I,J) = Z(MP,J) - Z(MP,J) = X - 130 CONTINUE -C - 140 CONTINUE -C - 200 RETURN - END diff --git a/slatec/elmhes.f b/slatec/elmhes.f deleted file mode 100644 index 858ee62..0000000 --- a/slatec/elmhes.f +++ /dev/null @@ -1,121 +0,0 @@ -*DECK ELMHES - SUBROUTINE ELMHES (NM, N, LOW, IGH, A, INT) -C***BEGIN PROLOGUE ELMHES -C***PURPOSE Reduce a real general matrix to upper Hessenberg form -C using stabilized elementary similarity transformations. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C1B2 -C***TYPE SINGLE PRECISION (ELMHES-S, COMHES-C) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure ELMHES, -C NUM. MATH. 12, 349-368(1968) by Martin and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). -C -C Given a REAL GENERAL matrix, this subroutine -C reduces a submatrix situated in rows and columns -C LOW through IGH to upper Hessenberg form by -C stabilized elementary similarity transformations. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameter, A, as declared in the calling program -C dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix, A. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C LOW and IGH are two INTEGER variables determined by the -C balancing subroutine BALANC. If BALANC has not been -C used, set LOW=1 and IGH equal to the order of the matrix, N. -C -C A contains the input matrix. A is a two-dimensional REAL -C array, dimensioned A(NM,N). -C -C On OUTPUT -C -C A contains the upper Hessenberg matrix. The multipliers which -C were used in the reduction are stored in the remaining -C triangle under the Hessenberg matrix. -C -C INT contains information on the rows and columns interchanged -C in the reduction. Only elements LOW through IGH are used. -C INT is a one-dimensional INTEGER array, dimensioned INT(IGH). -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE ELMHES -C - INTEGER I,J,M,N,LA,NM,IGH,KP1,LOW,MM1,MP1 - REAL A(NM,*) - REAL X,Y - INTEGER INT(*) -C -C***FIRST EXECUTABLE STATEMENT ELMHES - LA = IGH - 1 - KP1 = LOW + 1 - IF (LA .LT. KP1) GO TO 200 -C - DO 180 M = KP1, LA - MM1 = M - 1 - X = 0.0E0 - I = M -C - DO 100 J = M, IGH - IF (ABS(A(J,MM1)) .LE. ABS(X)) GO TO 100 - X = A(J,MM1) - I = J - 100 CONTINUE -C - INT(M) = I - IF (I .EQ. M) GO TO 130 -C .......... INTERCHANGE ROWS AND COLUMNS OF A .......... - DO 110 J = MM1, N - Y = A(I,J) - A(I,J) = A(M,J) - A(M,J) = Y - 110 CONTINUE -C - DO 120 J = 1, IGH - Y = A(J,I) - A(J,I) = A(J,M) - A(J,M) = Y - 120 CONTINUE -C .......... END INTERCHANGE .......... - 130 IF (X .EQ. 0.0E0) GO TO 180 - MP1 = M + 1 -C - DO 160 I = MP1, IGH - Y = A(I,MM1) - IF (Y .EQ. 0.0E0) GO TO 160 - Y = Y / X - A(I,MM1) = Y -C - DO 140 J = M, N - 140 A(I,J) = A(I,J) - Y * A(M,J) -C - DO 150 J = 1, IGH - 150 A(J,M) = A(J,M) + Y * A(J,I) -C - 160 CONTINUE -C - 180 CONTINUE -C - 200 RETURN - END diff --git a/slatec/eltran.f b/slatec/eltran.f deleted file mode 100644 index d9e6960..0000000 --- a/slatec/eltran.f +++ /dev/null @@ -1,102 +0,0 @@ -*DECK ELTRAN - SUBROUTINE ELTRAN (NM, N, LOW, IGH, A, INT, Z) -C***BEGIN PROLOGUE ELTRAN -C***PURPOSE Accumulates the stabilized elementary similarity -C transformations used in the reduction of a real general -C matrix to upper Hessenberg form by ELMHES. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C4 -C***TYPE SINGLE PRECISION (ELTRAN-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure ELMTRANS, -C NUM. MATH. 16, 181-204(1970) by Peters and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). -C -C This subroutine accumulates the stabilized elementary -C similarity transformations used in the reduction of a -C REAL GENERAL matrix to upper Hessenberg form by ELMHES. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, A and Z, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix A. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C LOW and IGH are two INTEGER variables determined by the -C balancing subroutine BALANC. If BALANC has not been -C used, set LOW=1 and IGH equal to the order of the matrix, N. -C -C A contains the multipliers which were used in the reduction -C by ELMHES in its lower triangle below the subdiagonal. -C A is a two-dimensional REAL array, dimensioned A(NM,IGH). -C -C INT contains information on the rows and columns interchanged -C in the reduction by ELMHES. Only elements LOW through IGH -C are used. INT is a one-dimensional INTEGER array, -C dimensioned INT(IGH). -C -C On OUTPUT -C -C Z contains the transformation matrix produced in the reduction -C by ELMHES. Z is a two-dimensional REAL array, dimensioned -C Z(NM,N). -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE ELTRAN -C - INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1 - REAL A(NM,*),Z(NM,*) - INTEGER INT(*) -C -C***FIRST EXECUTABLE STATEMENT ELTRAN - DO 80 I = 1, N -C - DO 60 J = 1, N - 60 Z(I,J) = 0.0E0 -C - Z(I,I) = 1.0E0 - 80 CONTINUE -C - KL = IGH - LOW - 1 - IF (KL .LT. 1) GO TO 200 -C .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... - DO 140 MM = 1, KL - MP = IGH - MM - MP1 = MP + 1 -C - DO 100 I = MP1, IGH - 100 Z(I,MP) = A(I,MP-1) -C - I = INT(MP) - IF (I .EQ. MP) GO TO 140 -C - DO 130 J = MP, IGH - Z(MP,J) = Z(I,J) - Z(I,J) = 0.0E0 - 130 CONTINUE -C - Z(I,MP) = 1.0E0 - 140 CONTINUE -C - 200 RETURN - END diff --git a/slatec/enorm.f b/slatec/enorm.f deleted file mode 100644 index 7eeda1e..0000000 --- a/slatec/enorm.f +++ /dev/null @@ -1,117 +0,0 @@ -*DECK ENORM - REAL FUNCTION ENORM (N, X) -C***BEGIN PROLOGUE ENORM -C***SUBSIDIARY -C***PURPOSE Subsidiary to SNLS1, SNLS1E, SNSQ and SNSQE -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (ENORM-S, DENORM-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Given an N-vector X, this function calculates the -C Euclidean norm of X. -C -C The Euclidean norm is computed by accumulating the sum of -C squares in three different sums. The sums of squares for the -C small and large components are scaled so that no overflows -C occur. Non-destructive underflows are permitted. Underflows -C and overflows do not occur in the computation of the unscaled -C sum of squares for the intermediate components. -C The definitions of small, intermediate and large components -C depend on two constants, RDWARF and RGIANT. The main -C restrictions on these constants are that RDWARF**2 not -C underflow and RGIANT**2 not overflow. The constants -C given here are suitable for every known computer. -C -C The function statement is -C -C REAL FUNCTION ENORM(N,X) -C -C where -C -C N is a positive integer input variable. -C -C X is an input array of length N. -C -C***SEE ALSO SNLS1, SNLS1E, SNSQ, SNSQE -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE ENORM - INTEGER N - REAL X(*) - INTEGER I - REAL AGIANT,FLOATN,ONE,RDWARF,RGIANT,S1,S2,S3,XABS,X1MAX,X3MAX, - 1 ZERO - SAVE ONE, ZERO, RDWARF, RGIANT - DATA ONE,ZERO,RDWARF,RGIANT /1.0E0,0.0E0,3.834E-20,1.304E19/ -C***FIRST EXECUTABLE STATEMENT ENORM - S1 = ZERO - S2 = ZERO - S3 = ZERO - X1MAX = ZERO - X3MAX = ZERO - FLOATN = N - AGIANT = RGIANT/FLOATN - DO 90 I = 1, N - XABS = ABS(X(I)) - IF (XABS .GT. RDWARF .AND. XABS .LT. AGIANT) GO TO 70 - IF (XABS .LE. RDWARF) GO TO 30 -C -C SUM FOR LARGE COMPONENTS. -C - IF (XABS .LE. X1MAX) GO TO 10 - S1 = ONE + S1*(X1MAX/XABS)**2 - X1MAX = XABS - GO TO 20 - 10 CONTINUE - S1 = S1 + (XABS/X1MAX)**2 - 20 CONTINUE - GO TO 60 - 30 CONTINUE -C -C SUM FOR SMALL COMPONENTS. -C - IF (XABS .LE. X3MAX) GO TO 40 - S3 = ONE + S3*(X3MAX/XABS)**2 - X3MAX = XABS - GO TO 50 - 40 CONTINUE - IF (XABS .NE. ZERO) S3 = S3 + (XABS/X3MAX)**2 - 50 CONTINUE - 60 CONTINUE - GO TO 80 - 70 CONTINUE -C -C SUM FOR INTERMEDIATE COMPONENTS. -C - S2 = S2 + XABS**2 - 80 CONTINUE - 90 CONTINUE -C -C CALCULATION OF NORM. -C - IF (S1 .EQ. ZERO) GO TO 100 - ENORM = X1MAX*SQRT(S1+(S2/X1MAX)/X1MAX) - GO TO 130 - 100 CONTINUE - IF (S2 .EQ. ZERO) GO TO 110 - IF (S2 .GE. X3MAX) - 1 ENORM = SQRT(S2*(ONE+(X3MAX/S2)*(X3MAX*S3))) - IF (S2 .LT. X3MAX) - 1 ENORM = SQRT(X3MAX*((S2/X3MAX)+(X3MAX*S3))) - GO TO 120 - 110 CONTINUE - ENORM = X3MAX*SQRT(S3) - 120 CONTINUE - 130 CONTINUE - RETURN -C -C LAST CARD OF FUNCTION ENORM. -C - END diff --git a/slatec/erf.f b/slatec/erf.f deleted file mode 100644 index bfef0ef..0000000 --- a/slatec/erf.f +++ /dev/null @@ -1,73 +0,0 @@ -*DECK ERF - FUNCTION ERF (X) -C***BEGIN PROLOGUE ERF -C***PURPOSE Compute the error function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C8A, L5A1E -C***TYPE SINGLE PRECISION (ERF-S, DERF-D) -C***KEYWORDS ERF, ERROR FUNCTION, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C ERF(X) calculates the single precision error function for -C single precision argument X. -C -C Series for ERF on the interval 0. to 1.00000D+00 -C with weighted error 7.10E-18 -C log weighted error 17.15 -C significant figures required 16.31 -C decimal places required 17.71 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, ERFC, INITS, R1MACH -C***REVISION HISTORY (YYMMDD) -C 770401 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 900727 Added EXTERNAL statement. (WRB) -C 920618 Removed space from variable name. (RWC, WRB) -C***END PROLOGUE ERF - DIMENSION ERFCS(13) - LOGICAL FIRST - EXTERNAL ERFC - SAVE ERFCS, SQRTPI, NTERF, XBIG, SQEPS, FIRST - DATA ERFCS( 1) / -.0490461212 34691808E0 / - DATA ERFCS( 2) / -.1422612051 0371364E0 / - DATA ERFCS( 3) / .0100355821 87599796E0 / - DATA ERFCS( 4) / -.0005768764 69976748E0 / - DATA ERFCS( 5) / .0000274199 31252196E0 / - DATA ERFCS( 6) / -.0000011043 17550734E0 / - DATA ERFCS( 7) / .0000000384 88755420E0 / - DATA ERFCS( 8) / -.0000000011 80858253E0 / - DATA ERFCS( 9) / .0000000000 32334215E0 / - DATA ERFCS(10) / -.0000000000 00799101E0 / - DATA ERFCS(11) / .0000000000 00017990E0 / - DATA ERFCS(12) / -.0000000000 00000371E0 / - DATA ERFCS(13) / .0000000000 00000007E0 / - DATA SQRTPI /1.772453850 9055160E0/ - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT ERF - IF (FIRST) THEN - NTERF = INITS (ERFCS, 13, 0.1*R1MACH(3)) - XBIG = SQRT(-LOG(SQRTPI*R1MACH(3))) - SQEPS = SQRT(2.0*R1MACH(3)) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.1.) GO TO 20 -C -C ERF(X) = 1. - ERFC(X) FOR -1. .LE. X .LE. 1. -C - IF (Y.LE.SQEPS) ERF = 2.0*X/SQRTPI - IF (Y.GT.SQEPS) ERF = X*(1.0 + CSEVL(2.*X**2-1., ERFCS, NTERF)) - RETURN -C -C ERF(X) = 1. - ERFC(X) FOR ABS(X) .GT. 1. -C - 20 IF (Y.LE.XBIG) ERF = SIGN (1.0-ERFC(Y), X) - IF (Y.GT.XBIG) ERF = SIGN (1.0, X) -C - RETURN - END diff --git a/slatec/erfc.f b/slatec/erfc.f deleted file mode 100644 index baab90f..0000000 --- a/slatec/erfc.f +++ /dev/null @@ -1,156 +0,0 @@ -*DECK ERFC - FUNCTION ERFC (X) -C***BEGIN PROLOGUE ERFC -C***PURPOSE Compute the complementary error function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C8A, L5A1E -C***TYPE SINGLE PRECISION (ERFC-S, DERFC-D) -C***KEYWORDS COMPLEMENTARY ERROR FUNCTION, ERFC, FNLIB, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C ERFC(X) calculates the single precision complementary error -C function for single precision argument X. -C -C Series for ERF on the interval 0. to 1.00000D+00 -C with weighted error 7.10E-18 -C log weighted error 17.15 -C significant figures required 16.31 -C decimal places required 17.71 -C -C Series for ERFC on the interval 0. to 2.50000D-01 -C with weighted error 4.81E-17 -C log weighted error 16.32 -C approx significant figures required 15.0 -C -C -C Series for ERC2 on the interval 2.50000D-01 to 1.00000D+00 -C with weighted error 5.22E-17 -C log weighted error 16.28 -C approx significant figures required 15.0 -C decimal places required 16.96 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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 920618 Removed space from variable names. (RWC, WRB) -C***END PROLOGUE ERFC - DIMENSION ERFCS(13), ERFCCS(24), ERC2CS(23) - LOGICAL FIRST - SAVE ERFCS, ERC2CS, ERFCCS, SQRTPI, NTERF, NTERFC, - 1 NTERC2, XSML, XMAX, SQEPS, FIRST - DATA ERFCS( 1) / -.0490461212 34691808E0 / - DATA ERFCS( 2) / -.1422612051 0371364E0 / - DATA ERFCS( 3) / .0100355821 87599796E0 / - DATA ERFCS( 4) / -.0005768764 69976748E0 / - DATA ERFCS( 5) / .0000274199 31252196E0 / - DATA ERFCS( 6) / -.0000011043 17550734E0 / - DATA ERFCS( 7) / .0000000384 88755420E0 / - DATA ERFCS( 8) / -.0000000011 80858253E0 / - DATA ERFCS( 9) / .0000000000 32334215E0 / - DATA ERFCS(10) / -.0000000000 00799101E0 / - DATA ERFCS(11) / .0000000000 00017990E0 / - DATA ERFCS(12) / -.0000000000 00000371E0 / - DATA ERFCS(13) / .0000000000 00000007E0 / - DATA ERC2CS( 1) / -.0696013466 02309501E0 / - DATA ERC2CS( 2) / -.0411013393 62620893E0 / - DATA ERC2CS( 3) / .0039144958 66689626E0 / - DATA ERC2CS( 4) / -.0004906395 65054897E0 / - DATA ERC2CS( 5) / .0000715747 90013770E0 / - DATA ERC2CS( 6) / -.0000115307 16341312E0 / - DATA ERC2CS( 7) / .0000019946 70590201E0 / - DATA ERC2CS( 8) / -.0000003642 66647159E0 / - DATA ERC2CS( 9) / .0000000694 43726100E0 / - DATA ERC2CS(10) / -.0000000137 12209021E0 / - DATA ERC2CS(11) / .0000000027 88389661E0 / - DATA ERC2CS(12) / -.0000000005 81416472E0 / - DATA ERC2CS(13) / .0000000001 23892049E0 / - DATA ERC2CS(14) / -.0000000000 26906391E0 / - DATA ERC2CS(15) / .0000000000 05942614E0 / - DATA ERC2CS(16) / -.0000000000 01332386E0 / - DATA ERC2CS(17) / .0000000000 00302804E0 / - DATA ERC2CS(18) / -.0000000000 00069666E0 / - DATA ERC2CS(19) / .0000000000 00016208E0 / - DATA ERC2CS(20) / -.0000000000 00003809E0 / - DATA ERC2CS(21) / .0000000000 00000904E0 / - DATA ERC2CS(22) / -.0000000000 00000216E0 / - DATA ERC2CS(23) / .0000000000 00000052E0 / - DATA ERFCCS( 1) / 0.0715179310 202925E0 / - DATA ERFCCS( 2) / -.0265324343 37606719E0 / - DATA ERFCCS( 3) / .0017111539 77920853E0 / - DATA ERFCCS( 4) / -.0001637516 63458512E0 / - DATA ERFCCS( 5) / .0000198712 93500549E0 / - DATA ERFCCS( 6) / -.0000028437 12412769E0 / - DATA ERFCCS( 7) / .0000004606 16130901E0 / - DATA ERFCCS( 8) / -.0000000822 77530261E0 / - DATA ERFCCS( 9) / .0000000159 21418724E0 / - DATA ERFCCS(10) / -.0000000032 95071356E0 / - DATA ERFCCS(11) / .0000000007 22343973E0 / - DATA ERFCCS(12) / -.0000000001 66485584E0 / - DATA ERFCCS(13) / .0000000000 40103931E0 / - DATA ERFCCS(14) / -.0000000000 10048164E0 / - DATA ERFCCS(15) / .0000000000 02608272E0 / - DATA ERFCCS(16) / -.0000000000 00699105E0 / - DATA ERFCCS(17) / .0000000000 00192946E0 / - DATA ERFCCS(18) / -.0000000000 00054704E0 / - DATA ERFCCS(19) / .0000000000 00015901E0 / - DATA ERFCCS(20) / -.0000000000 00004729E0 / - DATA ERFCCS(21) / .0000000000 00001432E0 / - DATA ERFCCS(22) / -.0000000000 00000439E0 / - DATA ERFCCS(23) / .0000000000 00000138E0 / - DATA ERFCCS(24) / -.0000000000 00000048E0 / - DATA SQRTPI /1.772453850 9055160E0/ - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT ERFC - IF (FIRST) THEN - ETA = 0.1*R1MACH(3) - NTERF = INITS (ERFCS, 13, ETA) - NTERFC = INITS (ERFCCS, 24, ETA) - NTERC2 = INITS (ERC2CS, 23, ETA) -C - XSML = -SQRT (-LOG(SQRTPI*R1MACH(3))) - TXMAX = SQRT (-LOG(SQRTPI*R1MACH(1))) - XMAX = TXMAX - 0.5*LOG(TXMAX)/TXMAX - 0.01 - SQEPS = SQRT (2.0*R1MACH(3)) - ENDIF - FIRST = .FALSE. -C - IF (X.GT.XSML) GO TO 20 -C -C ERFC(X) = 1.0 - ERF(X) FOR X .LT. XSML -C - ERFC = 2. - RETURN -C - 20 IF (X.GT.XMAX) GO TO 40 - Y = ABS(X) - IF (Y.GT.1.0) GO TO 30 -C -C ERFC(X) = 1.0 - ERF(X) FOR -1. .LE. X .LE. 1. -C - IF (Y.LT.SQEPS) ERFC = 1.0 - 2.0*X/SQRTPI - IF (Y.GE.SQEPS) ERFC = 1.0 - - 1 X*(1.0 + CSEVL (2.*X*X-1., ERFCS, NTERF) ) - RETURN -C -C ERFC(X) = 1.0 - ERF(X) FOR 1. .LT. ABS(X) .LE. XMAX -C - 30 Y = Y*Y - IF (Y.LE.4.) ERFC = EXP(-Y)/ABS(X) * (0.5 + CSEVL ((8./Y-5.)/3., - 1 ERC2CS, NTERC2) ) - IF (Y.GT.4.) ERFC = EXP(-Y)/ABS(X) * (0.5 + CSEVL (8./Y-1., - 1 ERFCCS, NTERFC) ) - IF (X.LT.0.) ERFC = 2.0 - ERFC - RETURN -C - 40 CALL XERMSG ('SLATEC', 'ERFC', 'X SO BIG ERFC UNDERFLOWS', 1, 1) - ERFC = 0. - RETURN -C - END diff --git a/slatec/exbvp.f b/slatec/exbvp.f deleted file mode 100644 index ac8f2c1..0000000 --- a/slatec/exbvp.f +++ /dev/null @@ -1,104 +0,0 @@ -*DECK EXBVP - SUBROUTINE EXBVP (Y, NROWY, XPTS, A, NROWA, ALPHA, B, NROWB, BETA, - + IFLAG, WORK, IWORK) -C***BEGIN PROLOGUE EXBVP -C***SUBSIDIARY -C***PURPOSE Subsidiary to BVSUP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (EXBVP-S, DEXBVP-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C This subroutine is used to execute the basic technique for solving -C the two-point boundary value problem -C -C***SEE ALSO BVSUP -C***ROUTINES CALLED BVPOR, XERMSG -C***COMMON BLOCKS ML15TO, ML17BW, ML18JR, ML5MCO, ML8SZ -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890921 Realigned order of variables in certain COMMON blocks. -C (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE EXBVP -C - DIMENSION Y(NROWY,*),A(NROWA,*),ALPHA(*),B(NROWB,*),BETA(*), - 1 WORK(*),IWORK(*),XPTS(*) - CHARACTER*8 XERN1, XERN2 -C -C **************************************************************** -C - COMMON /ML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMP,NFC - COMMON /ML18JR/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ, - 1 INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,NFCC, - 2 ICOCO - COMMON /ML15TO/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP, - 1 KNSWOT,KOP,LOTJP,MNSWOT,NSWOT - COMMON /ML17BW/ KKKZPW,NEEDW,NEEDIW,K1,K2,K3,K4,K5,K6,K7,K8,K9, - 1 K10,K11,L1,L2,KKKINT,LLLINT -C - COMMON /ML5MCO/ URO,SRU,EPS,SQOVFL,TWOU,FOURU,LPAR -C -C***FIRST EXECUTABLE STATEMENT EXBVP - KOTC = 1 - IEXP = 0 - IF (IWORK(7) .EQ. -1) IEXP = IWORK(8) -C -C COMPUTE ORTHONORMALIZATION TOLERANCES. -C - 10 TOL = 10.0**((-LPAR-IEXP)*2) -C - IWORK(8) = IEXP - MXNON = IWORK(2) -C -C ********************************************************************** -C ********************************************************************** -C - CALL BVPOR(Y,NROWY,NCOMP,XPTS,NXPTS,A,NROWA,ALPHA,NIC,B, - 1 NROWB,BETA,NFC,IFLAG,WORK(1),MXNON,WORK(K1),NTP, - 2 IWORK(18),WORK(K2),IWORK(16),WORK(K3),WORK(K4), - 3 WORK(K5),WORK(K6),WORK(K7),WORK(K8),WORK(K9), - 4 WORK(K10),IWORK(L1),NFCC) -C -C ********************************************************************** -C ********************************************************************** -C IF MGSBV RETURNS WITH MESSAGE OF DEPENDENT VECTORS, WE REDUCE -C ORTHONORMALIZATION TOLERANCE AND TRY AGAIN. THIS IS DONE -C A MAXIMUM OF 2 TIMES. -C - IF (IFLAG .NE. 30) GO TO 20 - IF (KOTC .EQ. 3 .OR. NOPG .EQ. 1) GO TO 30 - KOTC = KOTC + 1 - IEXP = IEXP - 2 - GO TO 10 -C -C ********************************************************************** -C IF BVPOR RETURNS MESSAGE THAT THE MAXIMUM NUMBER OF -C ORTHONORMALIZATIONS HAS BEEN ATTAINED AND WE CANNOT CONTINUE, THEN -C WE ESTIMATE THE NEW STORAGE REQUIREMENTS IN ORDER TO SOLVE PROBLEM -C - 20 IF (IFLAG .NE. 13) GO TO 30 - XL = ABS(XEND-XBEG) - ZQUIT = ABS(X-XBEG) - INC = 1.5 * XL/ZQUIT * (MXNON+1) - IF (NDISK .NE. 1) THEN - NSAFW = INC*KKKZPW + NEEDW - NSAFIW = INC*NFCC + NEEDIW - ELSE - NSAFW = NEEDW + INC - NSAFIW = NEEDIW - ENDIF -C - WRITE (XERN1, '(I8)') NSAFW - WRITE (XERN2, '(I8)') NSAFIW - CALL XERMSG ('SLATEC', 'EXBVP', - * 'IN BVSUP, PREDICTED STORAGE ALLOCATION FOR WORK ARRAY IS ' // - * XERN1 // ', PREDICTED STORAGE ALLOCATION FOR IWORK ARRAY IS ' - * // XERN2, 1, 0) -C - 30 IWORK(1) = MXNON - RETURN - END diff --git a/slatec/exint.f b/slatec/exint.f deleted file mode 100644 index 9c8045b..0000000 --- a/slatec/exint.f +++ /dev/null @@ -1,330 +0,0 @@ -*DECK EXINT - SUBROUTINE EXINT (X, N, KODE, M, TOL, EN, NZ, IERR) -C***BEGIN PROLOGUE EXINT -C***PURPOSE Compute an M member sequence of exponential integrals -C E(N+K,X), K=0,1,...,M-1 for N .GE. 1 and X .GE. 0. -C***LIBRARY SLATEC -C***CATEGORY C5 -C***TYPE SINGLE PRECISION (EXINT-S, DEXINT-D) -C***KEYWORDS EXPONENTIAL INTEGRAL, SPECIAL FUNCTIONS -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C EXINT computes M member sequences of exponential integrals -C E(N+K,X), K=0,1,...,M-1 for N .GE. 1 and X .GE. 0. The -C exponential integral is defined by -C -C E(N,X)=integral on (1,infinity) of EXP(-XT)/T**N -C -C where X=0.0 and N=1 cannot occur simultaneously. Formulas -C and notation are found in the NBS Handbook of Mathematical -C Functions (ref. 1). -C -C The power series is implemented for X .LE. XCUT and the -C confluent hypergeometric representation -C -C E(A,X) = EXP(-X)*(X**(A-1))*U(A,A,X) -C -C is computed for X .GT. XCUT. Since sequences are computed in -C a stable fashion by recurring away from X, A is selected as -C the integer closest to X within the constraint N .LE. A .LE. -C N+M-1. For the U computation, A is further modified to be the -C nearest even integer. Indices are carried forward or -C backward by the two term recursion relation -C -C K*E(K+1,X) + X*E(K,X) = EXP(-X) -C -C once E(A,X) is computed. The U function is computed by means -C of the backward recursive Miller algorithm applied to the -C three term contiguous relation for U(A+K,A,X), K=0,1,... -C This produces accurate ratios and determines U(A+K,A,X), and -C hence E(A,X), to within a multiplicative constant C. -C Another contiguous relation applied to C*U(A,A,X) and -C C*U(A+1,A,X) gets C*U(A+1,A+1,X), a quantity proportional to -C E(A+1,X). The normalizing constant C is obtained from the -C two term recursion relation above with K=A. -C -C Description of Arguments -C -C Input -C X X .GT. 0.0 for N=1 and X .GE. 0.0 for N .GE. 2 -C N order of the first member of the sequence, N .GE. 1 -C (X=0.0 and N=1 is an error) -C KODE a selection parameter for scaled values -C KODE=1 returns E(N+K,X), K=0,1,...,M-1. -C =2 returns EXP(X)*E(N+K,X), K=0,1,...,M-1. -C M number of exponential integrals in the sequence, -C M .GE. 1 -C TOL relative accuracy wanted, ETOL .LE. TOL .LE. 0.1 -C ETOL = single precision unit roundoff = R1MACH(4) -C -C Output -C EN a vector of dimension at least M containing values -C EN(K) = E(N+K-1,X) or EXP(X)*E(N+K-1,X), K=1,M -C depending on KODE -C NZ underflow indicator -C NZ=0 a normal return -C NZ=M X exceeds XLIM and an underflow occurs. -C EN(K)=0.0E0 , K=1,M returned on KODE=1 -C IERR error flag -C IERR=0, normal return, computation completed -C IERR=1, input error, no computation -C IERR=2, error, no computation -C algorithm termination condition not met -C -C***REFERENCES M. Abramowitz and I. A. Stegun, Handbook of -C Mathematical Functions, NBS AMS Series 55, U.S. Dept. -C of Commerce, 1955. -C D. E. Amos, Computation of exponential integrals, ACM -C Transactions on Mathematical Software 6, (1980), -C pp. 365-377 and pp. 420-428. -C***ROUTINES CALLED I1MACH, PSIXN, R1MACH -C***REVISION HISTORY (YYMMDD) -C 800501 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 910408 Updated the REFERENCES section. (WRB) -C 920207 Updated with code with a revision date of 880811 from -C D. Amos. Included correction of argument list. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE EXINT - REAL A,AA,AAMS,AH,AK,AT,B,BK,BT,CC,CNORM,CT,EM,EMX,EN, - 1 ETOL,FNM,FX,PT,P1,P2,S,TOL,TX,X,XCUT,XLIM,XTOL,Y, - 2 YT,Y1,Y2 - REAL R1MACH,PSIXN - INTEGER I,IC,ICASE,ICT,IERR,IK,IND,IX,I1M,JSET,K,KK,KN,KODE,KS,M, - 1 ML,MU,N,ND,NM,NZ - INTEGER I1MACH - DIMENSION EN(*), A(99), B(99), Y(2) -C***FIRST EXECUTABLE STATEMENT EXINT - IERR = 0 - NZ = 0 - ETOL = MAX(R1MACH(4),0.5E-18) - IF (X.LT.0.0E0) IERR = 1 - IF (N.LT.1) IERR = 1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR = 1 - IF (M.LT.1) IERR = 1 - IF (TOL.LT.ETOL .OR. TOL.GT.0.1E0) IERR = 1 - IF (X.EQ.0.0E0 .AND. N.EQ.1) IERR = 1 - IF (IERR.NE.0) RETURN - I1M = -I1MACH(12) - PT = 2.3026E0*R1MACH(5)*I1M - XLIM = PT - 6.907755E0 - BT = PT + (N+M-1) - IF (BT.GT.1000.0E0) XLIM = PT - LOG(BT) -C - XCUT = 2.0E0 - IF (ETOL.GT.2.0E-7) XCUT = 1.0E0 - IF (X.GT.XCUT) GO TO 100 - IF (X.EQ.0.0E0 .AND. N.GT.1) GO TO 80 -C----------------------------------------------------------------------- -C SERIES FOR E(N,X) FOR X.LE.XCUT -C----------------------------------------------------------------------- - TX = X + 0.5E0 - IX = TX -C----------------------------------------------------------------------- -C ICASE=1 MEANS INTEGER CLOSEST TO X IS 2 AND N=1 -C ICASE=2 MEANS INTEGER CLOSEST TO X IS 0,1, OR 2 AND N.GE.2 -C----------------------------------------------------------------------- - ICASE = 2 - IF (IX.GT.N) ICASE = 1 - NM = N - ICASE + 1 - ND = NM + 1 - IND = 3 - ICASE - MU = M - IND - ML = 1 - KS = ND - FNM = NM - S = 0.0E0 - XTOL = 3.0E0*TOL - IF (ND.EQ.1) GO TO 10 - XTOL = 0.3333E0*TOL - S = 1.0E0/FNM - 10 CONTINUE - AA = 1.0E0 - AK = 1.0E0 - IC = 35 - IF (X.LT.ETOL) IC = 1 - DO 50 I=1,IC - AA = -AA*X/AK - IF (I.EQ.NM) GO TO 30 - S = S - AA/(AK-FNM) - IF (ABS(AA).LE.XTOL*ABS(S)) GO TO 20 - AK = AK + 1.0E0 - GO TO 50 - 20 CONTINUE - IF (I.LT.2) GO TO 40 - IF (ND-2.GT.I .OR. I.GT.ND-1) GO TO 60 - AK = AK + 1.0E0 - GO TO 50 - 30 S = S + AA*(-LOG(X)+PSIXN(ND)) - XTOL = 3.0E0*TOL - 40 AK = AK + 1.0E0 - 50 CONTINUE - IF (IC.NE.1) GO TO 340 - 60 IF (ND.EQ.1) S = S + (-LOG(X)+PSIXN(1)) - IF (KODE.EQ.2) S = S*EXP(X) - EN(1) = S - EMX = 1.0E0 - IF (M.EQ.1) GO TO 70 - EN(IND) = S - AA = KS - IF (KODE.EQ.1) EMX = EXP(-X) - GO TO (220, 240), ICASE - 70 IF (ICASE.EQ.2) RETURN - IF (KODE.EQ.1) EMX = EXP(-X) - EN(1) = (EMX-S)/X - RETURN - 80 CONTINUE - DO 90 I=1,M - EN(I) = 1.0E0/(N+I-2) - 90 CONTINUE - RETURN -C----------------------------------------------------------------------- -C BACKWARD RECURSIVE MILLER ALGORITHM FOR -C E(N,X)=EXP(-X)*(X**(N-1))*U(N,N,X) -C WITH RECURSION AWAY FROM N=INTEGER CLOSEST TO X. -C U(A,B,X) IS THE SECOND CONFLUENT HYPERGEOMETRIC FUNCTION -C----------------------------------------------------------------------- - 100 CONTINUE - EMX = 1.0E0 - IF (KODE.EQ.2) GO TO 130 - IF (X.LE.XLIM) GO TO 120 - NZ = M - DO 110 I=1,M - EN(I) = 0.0E0 - 110 CONTINUE - RETURN - 120 EMX = EXP(-X) - 130 CONTINUE - IX = X+0.5E0 - KN = N + M - 1 - IF (KN.LE.IX) GO TO 140 - IF (N.LT.IX .AND. IX.LT.KN) GO TO 170 - IF (N.GE.IX) GO TO 160 - GO TO 340 - 140 ICASE = 1 - KS = KN - ML = M - 1 - MU = -1 - IND = M - IF (KN.GT.1) GO TO 180 - 150 KS = 2 - ICASE = 3 - GO TO 180 - 160 ICASE = 2 - IND = 1 - KS = N - MU = M - 1 - IF (N.GT.1) GO TO 180 - IF (KN.EQ.1) GO TO 150 - IX = 2 - 170 ICASE = 1 - KS = IX - ML = IX - N - IND = ML + 1 - MU = KN - IX - 180 CONTINUE - IK = KS/2 - AH = IK - JSET = 1 + KS - (IK+IK) -C----------------------------------------------------------------------- -C START COMPUTATION FOR -C EN(IND) = C*U( A , A ,X) JSET=1 -C EN(IND) = C*U(A+1,A+1,X) JSET=2 -C FOR AN EVEN INTEGER A. -C----------------------------------------------------------------------- - IC = 0 - AA = AH + AH - AAMS = AA - 1.0E0 - AAMS = AAMS*AAMS - TX = X + X - FX = TX + TX - AK = AH - XTOL = TOL - IF (TOL.LE.1.0E-3) XTOL = 20.0E0*TOL - CT = AAMS + FX*AH - EM = (AH+1.0E0)/((X+AA)*XTOL*SQRT(CT)) - BK = AA - CC = AH*AH -C----------------------------------------------------------------------- -C FORWARD RECURSION FOR P(IC),P(IC+1) AND INDEX IC FOR BACKWARD -C RECURSION -C----------------------------------------------------------------------- - P1 = 0.0E0 - P2 = 1.0E0 - 190 CONTINUE - IF (IC.EQ.99) GO TO 340 - IC = IC + 1 - AK = AK + 1.0E0 - AT = BK/(BK+AK+CC+IC) - BK = BK + AK + AK - A(IC) = AT - BT = (AK+AK+X)/(AK+1.0E0) - B(IC) = BT - PT = P2 - P2 = BT*P2 - AT*P1 - P1 = PT - CT = CT + FX - EM = EM*AT*(1.0E0-TX/CT) - IF (EM*(AK+1.0E0).GT.P1*P1) GO TO 190 - ICT = IC - KK = IC + 1 - BT = TX/(CT+FX) - Y2 = (BK/(BK+CC+KK))*(P1/P2)*(1.0E0-BT+0.375E0*BT*BT) - Y1 = 1.0E0 -C----------------------------------------------------------------------- -C BACKWARD RECURRENCE FOR -C Y1= C*U( A ,A,X) -C Y2= C*(A/(1+A/2))*U(A+1,A,X) -C----------------------------------------------------------------------- - DO 200 K=1,ICT - KK = KK - 1 - YT = Y1 - Y1 = (B(KK)*Y1-Y2)/A(KK) - Y2 = YT - 200 CONTINUE -C----------------------------------------------------------------------- -C THE CONTIGUOUS RELATION -C X*U(B,C+1,X)=(C-B)*U(B,C,X)+U(B-1,C,X) -C WITH B=A+1 , C=A IS USED FOR -C Y(2) = C * U(A+1,A+1,X) -C X IS INCORPORATED INTO THE NORMALIZING RELATION -C----------------------------------------------------------------------- - PT = Y2/Y1 - CNORM = 1.0E0 - PT*(AH+1.0E0)/AA - Y(1) = 1.0E0/(CNORM*AA+X) - Y(2) = CNORM*Y(1) - IF (ICASE.EQ.3) GO TO 210 - EN(IND) = EMX*Y(JSET) - IF (M.EQ.1) RETURN - AA = KS - GO TO (220, 240), ICASE -C----------------------------------------------------------------------- -C RECURSION SECTION N*E(N+1,X) + X*E(N,X)=EMX -C----------------------------------------------------------------------- - 210 EN(1) = EMX*(1.0E0-Y(1))/X - RETURN - 220 K = IND - 1 - DO 230 I=1,ML - AA = AA - 1.0E0 - EN(K) = (EMX-AA*EN(K+1))/X - K = K - 1 - 230 CONTINUE - IF (MU.LE.0) RETURN - AA = KS - 240 K = IND - DO 250 I=1,MU - EN(K+1) = (EMX-X*EN(K))/AA - AA = AA + 1.0E0 - K = K + 1 - 250 CONTINUE - RETURN - 340 CONTINUE - IERR = 2 - RETURN - END diff --git a/slatec/exprel.f b/slatec/exprel.f deleted file mode 100644 index 6e3543c..0000000 --- a/slatec/exprel.f +++ /dev/null @@ -1,53 +0,0 @@ -*DECK EXPREL - FUNCTION EXPREL (X) -C***BEGIN PROLOGUE EXPREL -C***PURPOSE Calculate the relative error exponential (EXP(X)-1)/X. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4B -C***TYPE SINGLE PRECISION (EXPREL-S, DEXPRL-D, CEXPRL-C) -C***KEYWORDS ELEMENTARY FUNCTIONS, EXPONENTIAL, FIRST ORDER, FNLIB -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate EXPREL(X) = (EXP(X) - 1.0) / X. For small ABS(X) the -C Taylor series is used. If X is negative, the reflection formula -C EXPREL(X) = EXP(X) * EXPREL(ABS(X)) -C may be used. This reflection formula will be of use when the -C evaluation for small ABS(X) is done by Chebyshev series rather than -C Taylor series. EXPREL and X are single precision. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH -C***REVISION HISTORY (YYMMDD) -C 770801 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***END PROLOGUE EXPREL - LOGICAL FIRST - SAVE NTERMS, XBND, FIRST - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT EXPREL - IF (FIRST) THEN - ALNEPS = LOG(R1MACH(3)) - XN = 3.72 - 0.3*ALNEPS - XLN = LOG((XN+1.0)/1.36) - NTERMS = XN - (XN*XLN+ALNEPS)/(XLN+1.36) + 1.5 - XBND = R1MACH(3) - ENDIF - FIRST = .FALSE. -C - ABSX = ABS(X) - IF (ABSX.GT.0.5) EXPREL = (EXP(X) - 1.0) / X - IF (ABSX.GT.0.5) RETURN -C - EXPREL = 1.0 - IF (ABSX.LT.XBND) RETURN -C - EXPREL = 0.0 - DO 20 I=1,NTERMS - EXPREL = 1.0 + EXPREL*X/(NTERMS+2-I) - 20 CONTINUE -C - RETURN - END diff --git a/slatec/ezfft1.f b/slatec/ezfft1.f deleted file mode 100644 index 2d22dfa..0000000 --- a/slatec/ezfft1.f +++ /dev/null @@ -1,89 +0,0 @@ -*DECK EZFFT1 - SUBROUTINE EZFFT1 (N, WA, IFAC) -C***BEGIN PROLOGUE EZFFT1 -C***SUBSIDIARY -C***PURPOSE EZFFTI calls EZFFT1 with appropriate work array -C partitioning. -C***LIBRARY SLATEC (FFTPACK) -C***TYPE SINGLE PRECISION (EZFFT1-S) -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C (a) changing dummy array size declarations (1) to (*), -C (b) changing references to intrinsic function FLOAT -C to REAL, and -C (c) changing definition of variable TPI by using -C FORTRAN intrinsic function ATAN instead of a DATA -C statement. -C 881128 Modified by Dick Valent to meet prologue standards. -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 900402 Added TYPE section. (WRB) -C***END PROLOGUE EZFFT1 - DIMENSION WA(*), IFAC(*), NTRYH(4) - SAVE NTRYH - DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ -C***FIRST EXECUTABLE STATEMENT EZFFT1 - TPI = 8.*ATAN(1.) - NL = N - NF = 0 - J = 0 - 101 J = J+1 - IF (J-4) 102,102,103 - 102 NTRY = NTRYH(J) - GO TO 104 - 103 NTRY = NTRY+2 - 104 NQ = NL/NTRY - NR = NL-NTRY*NQ - IF (NR) 101,105,101 - 105 NF = NF+1 - IFAC(NF+2) = NTRY - NL = NQ - IF (NTRY .NE. 2) GO TO 107 - IF (NF .EQ. 1) GO TO 107 - DO 106 I=2,NF - IB = NF-I+2 - IFAC(IB+2) = IFAC(IB+1) - 106 CONTINUE - IFAC(3) = 2 - 107 IF (NL .NE. 1) GO TO 104 - IFAC(1) = N - IFAC(2) = NF - ARGH = TPI/N - IS = 0 - NFM1 = NF-1 - L1 = 1 - IF (NFM1 .EQ. 0) RETURN - DO 111 K1=1,NFM1 - IP = IFAC(K1+2) - L2 = L1*IP - IDO = N/L2 - IPM = IP-1 - ARG1 = L1*ARGH - CH1 = 1. - SH1 = 0. - DCH1 = COS(ARG1) - DSH1 = SIN(ARG1) - DO 110 J=1,IPM - CH1H = DCH1*CH1-DSH1*SH1 - SH1 = DCH1*SH1+DSH1*CH1 - CH1 = CH1H - I = IS+2 - WA(I-1) = CH1 - WA(I) = SH1 - IF (IDO .LT. 5) GO TO 109 - DO 108 II=5,IDO,2 - I = I+2 - WA(I-1) = CH1*WA(I-3)-SH1*WA(I-2) - WA(I) = CH1*WA(I-2)+SH1*WA(I-3) - 108 CONTINUE - 109 IS = IS+IDO - 110 CONTINUE - L1 = L2 - 111 CONTINUE - RETURN - END diff --git a/slatec/ezfftb.f b/slatec/ezfftb.f deleted file mode 100644 index a6a1a78..0000000 --- a/slatec/ezfftb.f +++ /dev/null @@ -1,119 +0,0 @@ -*DECK EZFFTB - SUBROUTINE EZFFTB (N, R, AZERO, A, B, WSAVE) -C***BEGIN PROLOGUE EZFFTB -C***PURPOSE A simplified real, periodic, backward fast Fourier -C transform. -C***LIBRARY SLATEC (FFTPACK) -C***CATEGORY J1A1 -C***TYPE SINGLE PRECISION (EZFFTB-S) -C***KEYWORDS FFTPACK, FOURIER TRANSFORM -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C Subroutine EZFFTB computes a real periodic sequence from its -C Fourier coefficients (Fourier synthesis). The transform is -C defined below at Output Parameter R. EZFFTB is a simplified -C but slower version of RFFTB. -C -C Input Parameters -C -C N the length of the output array R. The method is most -C efficient when N is the product of small primes. -C -C AZERO the constant Fourier coefficient -C -C A,B arrays which contain the remaining Fourier coefficients. -C These arrays are not destroyed. -C -C The length of these arrays depends on whether N is even or -C odd. -C -C If N is even, N/2 locations are required. -C If N is odd, (N-1)/2 locations are required -C -C WSAVE a work array which must be dimensioned at least 3*N+15 -C in the program that calls EZFFTB. The WSAVE array must be -C initialized by calling subroutine EZFFTI(N,WSAVE), and a -C different WSAVE array must be used for each different -C value of N. This initialization does not have to be -C repeated so long as N remains unchanged. Thus subsequent -C transforms can be obtained faster than the first. -C The same WSAVE array can be used by EZFFTF and EZFFTB. -C -C Output Parameters -C -C R if N is even, define KMAX=N/2 -C if N is odd, define KMAX=(N-1)/2 -C -C Then for I=1,...,N -C -C R(I)=AZERO plus the sum from K=1 to K=KMAX of -C -C A(K)*COS(K*(I-1)*2*PI/N)+B(K)*SIN(K*(I-1)*2*PI/N) -C -C ********************* Complex Notation ************************** -C -C For J=1,...,N -C -C R(J) equals the sum from K=-KMAX to K=KMAX of -C -C C(K)*EXP(I*K*(J-1)*2*PI/N) -C -C where -C -C C(K) = .5*CMPLX(A(K),-B(K)) for K=1,...,KMAX -C -C C(-K) = CONJG(C(K)) -C -C C(0) = AZERO -C -C and I=SQRT(-1) -C -C *************** Amplitude - Phase Notation *********************** -C -C For I=1,...,N -C -C R(I) equals AZERO plus the sum from K=1 to K=KMAX of -C -C ALPHA(K)*COS(K*(I-1)*2*PI/N+BETA(K)) -C -C where -C -C ALPHA(K) = SQRT(A(K)*A(K)+B(K)*B(K)) -C -C COS(BETA(K))=A(K)/ALPHA(K) -C -C SIN(BETA(K))=-B(K)/ALPHA(K) -C -C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel -C Computations (G. Rodrigue, ed.), Academic Press, -C 1982, pp. 51-83. -C***ROUTINES CALLED RFFTB -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C changing dummy array size declarations (1) to (*) -C 861211 REVISION DATE from Version 3.2 -C 881128 Modified by Dick Valent to meet prologue standards. -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE EZFFTB - DIMENSION R(*), A(*), B(*), WSAVE(*) -C***FIRST EXECUTABLE STATEMENT EZFFTB - IF (N-2) 101,102,103 - 101 R(1) = AZERO - RETURN - 102 R(1) = AZERO+A(1) - R(2) = AZERO-A(1) - RETURN - 103 NS2 = (N-1)/2 - DO 104 I=1,NS2 - R(2*I) = .5*A(I) - R(2*I+1) = -.5*B(I) - 104 CONTINUE - R(1) = AZERO - IF (MOD(N,2) .EQ. 0) R(N) = A(NS2+1) - CALL RFFTB (N,R,WSAVE(N+1)) - RETURN - END diff --git a/slatec/ezfftf.f b/slatec/ezfftf.f deleted file mode 100644 index 01f6b7c..0000000 --- a/slatec/ezfftf.f +++ /dev/null @@ -1,96 +0,0 @@ -*DECK EZFFTF - SUBROUTINE EZFFTF (N, R, AZERO, A, B, WSAVE) -C***BEGIN PROLOGUE EZFFTF -C***PURPOSE Compute a simplified real, periodic, fast Fourier forward -C transform. -C***LIBRARY SLATEC (FFTPACK) -C***CATEGORY J1A1 -C***TYPE SINGLE PRECISION (EZFFTF-S) -C***KEYWORDS FFTPACK, FOURIER TRANSFORM -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C Subroutine EZFFTF computes the Fourier coefficients of a real -C periodic sequence (Fourier analysis). The transform is defined -C below at Output Parameters AZERO, A and B. EZFFTF is a simplified -C but slower version of RFFTF. -C -C Input Parameters -C -C N the length of the array R to be transformed. The method -C is most efficient when N is the product of small primes. -C -C R a real array of length N which contains the sequence -C to be transformed. R is not destroyed. -C -C -C WSAVE a work array which must be dimensioned at least 3*N+15 -C in the program that calls EZFFTF. The WSAVE array must be -C initialized by calling subroutine EZFFTI(N,WSAVE), and a -C different WSAVE array must be used for each different -C value of N. This initialization does not have to be -C repeated so long as N remains unchanged. Thus subsequent -C transforms can be obtained faster than the first. -C The same WSAVE array can be used by EZFFTF and EZFFTB. -C -C Output Parameters -C -C AZERO the sum from I=1 to I=N of R(I)/N -C -C A,B for N even B(N/2)=0. and A(N/2) is the sum from I=1 to -C I=N of (-1)**(I-1)*R(I)/N -C -C for N even define KMAX=N/2-1 -C for N odd define KMAX=(N-1)/2 -C -C then for K=1,...,KMAX -C -C A(K) equals the sum from I=1 to I=N of -C -C 2./N*R(I)*COS(K*(I-1)*2*PI/N) -C -C B(K) equals the sum from I=1 to I=N of -C -C 2./N*R(I)*SIN(K*(I-1)*2*PI/N) -C -C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel -C Computations (G. Rodrigue, ed.), Academic Press, -C 1982, pp. 51-83. -C***ROUTINES CALLED RFFTF -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C (a) changing dummy array size declarations (1) to (*), -C (b) changing references to intrinsic function FLOAT -C to REAL. -C 881128 Modified by Dick Valent to meet prologue standards. -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 EZFFTF - DIMENSION R(*), A(*), B(*), WSAVE(*) -C***FIRST EXECUTABLE STATEMENT EZFFTF - IF (N-2) 101,102,103 - 101 AZERO = R(1) - RETURN - 102 AZERO = .5*(R(1)+R(2)) - A(1) = .5*(R(1)-R(2)) - RETURN - 103 DO 104 I=1,N - WSAVE(I) = R(I) - 104 CONTINUE - CALL RFFTF (N,WSAVE,WSAVE(N+1)) - CF = 2./N - CFM = -CF - AZERO = .5*CF*WSAVE(1) - NS2 = (N+1)/2 - NS2M = NS2-1 - DO 105 I=1,NS2M - A(I) = CF*WSAVE(2*I) - B(I) = CFM*WSAVE(2*I+1) - 105 CONTINUE - IF (MOD(N,2) .EQ. 0) A(NS2) = .5*CF*WSAVE(N) - RETURN - END diff --git a/slatec/ezffti.f b/slatec/ezffti.f deleted file mode 100644 index 099ba3e..0000000 --- a/slatec/ezffti.f +++ /dev/null @@ -1,47 +0,0 @@ -*DECK EZFFTI - SUBROUTINE EZFFTI (N, WSAVE) -C***BEGIN PROLOGUE EZFFTI -C***PURPOSE Initialize a work array for EZFFTF and EZFFTB. -C***LIBRARY SLATEC (FFTPACK) -C***CATEGORY J1A1 -C***TYPE SINGLE PRECISION (EZFFTI-S) -C***KEYWORDS FFTPACK, FOURIER TRANSFORM -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C Subroutine EZFFTI initializes the work array WSAVE which is used in -C both EZFFTF and EZFFTB. The prime factorization of N together with -C a tabulation of the trigonometric functions are computed and -C stored in WSAVE. -C -C Input Parameter -C -C N the length of the sequence to be transformed. -C -C Output Parameter -C -C WSAVE a work array which must be dimensioned at least 3*N+15. -C The same work array can be used for both EZFFTF and EZFFTB -C as long as N remains unchanged. Different WSAVE arrays -C are required for different values of N. -C -C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel -C Computations (G. Rodrigue, ed.), Academic Press, -C 1982, pp. 51-83. -C***ROUTINES CALLED EZFFT1 -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C changing dummy array size declarations (1) to (*). -C 861211 REVISION DATE from Version 3.2 -C 881128 Modified by Dick Valent to meet prologue standards. -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE EZFFTI - DIMENSION WSAVE(*) -C***FIRST EXECUTABLE STATEMENT EZFFTI - IF (N .EQ. 1) RETURN - CALL EZFFT1 (N,WSAVE(2*N+1),WSAVE(3*N+1)) - RETURN - END diff --git a/slatec/fac.f b/slatec/fac.f deleted file mode 100644 index ee36c95..0000000 --- a/slatec/fac.f +++ /dev/null @@ -1,72 +0,0 @@ -*DECK FAC - FUNCTION FAC (N) -C***BEGIN PROLOGUE FAC -C***PURPOSE Compute the factorial function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C1 -C***TYPE SINGLE PRECISION (FAC-S, DFAC-D) -C***KEYWORDS FACTORIAL, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C FAC(N) evaluates the factorial function of N. FAC is single -C precision. N must be an integer between 0 and 25 inclusive. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED GAMLIM, R9LGMC, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 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***END PROLOGUE FAC - DIMENSION FACN(26) - SAVE FACN, SQ2PIL, NMAX - DATA FACN( 1) / 1.0E0 / - DATA FACN( 2) / 1.0E0 / - DATA FACN( 3) / 2.0E0 / - DATA FACN( 4) / 6.0E0 / - DATA FACN( 5) / 24.0E0 / - DATA FACN( 6) / 120.0E0 / - DATA FACN( 7) / 720.0E0 / - DATA FACN( 8) / 5040.0E0 / - DATA FACN( 9) / 40320.0E0 / - DATA FACN(10) / 362880.0E0 / - DATA FACN(11) / 3628800.0E0 / - DATA FACN(12) / 39916800.0E0 / - DATA FACN(13) / 479001600.0E0 / - DATA FACN(14) / 6227020800.0E0 / - DATA FACN(15) / 87178291200.0E0 / - DATA FACN(16) / 1307674368000.0E0 / - DATA FACN(17) / 20922789888000.0E0 / - DATA FACN(18) / 355687428096000.0E0 / - DATA FACN(19) / 6402373705728000.0E0 / - DATA FACN(20) / .12164510040883200E18 / - DATA FACN(21) / .24329020081766400E19 / - DATA FACN(22) / .51090942171709440E20 / - DATA FACN(23) / .11240007277776077E22 / - DATA FACN(24) / .25852016738884977E23 / - DATA FACN(25) / .62044840173323944E24 / - DATA FACN(26) / .15511210043330986E26 / - DATA SQ2PIL / 0.9189385332 0467274E0/ - DATA NMAX / 0 / -C***FIRST EXECUTABLE STATEMENT FAC - IF (NMAX.NE.0) GO TO 10 - CALL GAMLIM (XMIN, XMAX) - NMAX = XMAX - 1. -C - 10 IF (N .LT. 0) CALL XERMSG ('SLATEC', 'FAC', - + 'FACTORIAL OF NEGATIVE INTEGER UNDEFINED', 1, 2) -C - IF (N.LE.25) FAC = FACN(N+1) - IF (N.LE.25) RETURN -C - IF (N .GT. NMAX) CALL XERMSG ('SLATEC', 'FAC', - + 'N SO BIG FACTORIAL(N) OVERFLOWS', 2, 2) -C - X = N + 1 - FAC = EXP ( (X-0.5)*LOG(X) - X + SQ2PIL + R9LGMC(X) ) -C - RETURN - END diff --git a/slatec/fc.f b/slatec/fc.f deleted file mode 100644 index 6094562..0000000 --- a/slatec/fc.f +++ /dev/null @@ -1,411 +0,0 @@ -*DECK FC - SUBROUTINE FC (NDATA, XDATA, YDATA, SDDATA, NORD, NBKPT, BKPT, - + NCONST, XCONST, YCONST, NDERIV, MODE, COEFF, W, IW) -C***BEGIN PROLOGUE FC -C***PURPOSE Fit a piecewise polynomial curve to discrete data. -C The piecewise polynomials are represented as B-splines. -C The fitting is done in a weighted least squares sense. -C Equality and inequality constraints can be imposed on the -C fitted curve. -C***LIBRARY SLATEC -C***CATEGORY K1A1A1, K1A2A, L8A3 -C***TYPE SINGLE PRECISION (FC-S, DFC-D) -C***KEYWORDS B-SPLINE, CONSTRAINED LEAST SQUARES, CURVE FITTING, -C WEIGHTED LEAST SQUARES -C***AUTHOR Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C This subprogram fits a piecewise polynomial curve -C to discrete data. The piecewise polynomials are -C represented as B-splines. -C The fitting is done in a weighted least squares sense. -C Equality and inequality constraints can be imposed on the -C fitted curve. -C -C For a description of the B-splines and usage instructions to -C evaluate them, see -C -C C. W. de Boor, Package for Calculating with B-Splines. -C SIAM J. Numer. Anal., p. 441, (June, 1977). -C -C For further documentation and discussion of constrained -C curve fitting using B-splines, see -C -C R. J. Hanson, Constrained Least Squares Curve Fitting -C to Discrete Data Using B-Splines, a User's -C Guide. Sandia Labs. Tech. Rept. SAND-78-1291, -C December, (1978). -C -C Input.. -C NDATA,XDATA(*), -C YDATA(*), -C SDDATA(*) -C The NDATA discrete (X,Y) pairs and the Y value -C standard deviation or uncertainty, SD, are in -C the respective arrays XDATA(*), YDATA(*), and -C SDDATA(*). No sorting of XDATA(*) is -C required. Any non-negative value of NDATA is -C allowed. A negative value of NDATA is an -C error. A zero value for any entry of -C SDDATA(*) will weight that data point as 1. -C Otherwise the weight of that data point is -C the reciprocal of this entry. -C -C NORD,NBKPT, -C BKPT(*) -C The NBKPT knots of the B-spline of order NORD -C are in the array BKPT(*). Normally the -C problem data interval will be included between -C the limits BKPT(NORD) and BKPT(NBKPT-NORD+1). -C The additional end knots BKPT(I),I=1,..., -C NORD-1 and I=NBKPT-NORD+2,...,NBKPT, are -C required to compute the functions used to fit -C the data. No sorting of BKPT(*) is required. -C Internal to FC( ) the extreme end knots may -C be reduced and increased respectively to -C accommodate any data values that are exterior -C to the given knot values. The contents of -C BKPT(*) is not changed. -C -C NORD must be in the range 1 .LE. NORD .LE. 20. -C The value of NBKPT must satisfy the condition -C NBKPT .GE. 2*NORD. -C Other values are considered errors. -C -C (The order of the spline is one more than the -C degree of the piecewise polynomial defined on -C each interval. This is consistent with the -C B-spline package convention. For example, -C NORD=4 when we are using piecewise cubics.) -C -C NCONST,XCONST(*), -C YCONST(*),NDERIV(*) -C The number of conditions that constrain the -C B-spline is NCONST. A constraint is specified -C by an (X,Y) pair in the arrays XCONST(*) and -C YCONST(*), and by the type of constraint and -C derivative value encoded in the array -C NDERIV(*). No sorting of XCONST(*) is -C required. The value of NDERIV(*) is -C determined as follows. Suppose the I-th -C constraint applies to the J-th derivative -C of the B-spline. (Any non-negative value of -C J < NORD is permitted. In particular the -C value J=0 refers to the B-spline itself.) -C For this I-th constraint, set -C XCONST(I)=X, -C YCONST(I)=Y, and -C NDERIV(I)=ITYPE+4*J, where -C -C ITYPE = 0, if (J-th deriv. at X) .LE. Y. -C = 1, if (J-th deriv. at X) .GE. Y. -C = 2, if (J-th deriv. at X) .EQ. Y. -C = 3, if (J-th deriv. at X) .EQ. -C (J-th deriv. at Y). -C (A value of NDERIV(I)=-1 will cause this -C constraint to be ignored. This subprogram -C feature is often useful when temporarily -C suppressing a constraint while still -C retaining the source code of the calling -C program.) -C -C MODE -C An input flag that directs the least squares -C solution method used by FC( ). -C -C The variance function, referred to below, -C defines the square of the probable error of -C the fitted curve at any point, XVAL. -C This feature of FC( ) allows one to use the -C square root of this variance function to -C determine a probable error band around the -C fitted curve. -C -C =1 a new problem. No variance function. -C -C =2 a new problem. Want variance function. -C -C =3 an old problem. No variance function. -C -C =4 an old problem. Want variance function. -C -C Any value of MODE other than 1-4 is an error. -C -C The user with a new problem can skip directly -C to the description of the input parameters -C IW(1), IW(2). -C -C If the user correctly specifies the new or old -C problem status, the subprogram FC( ) will -C perform more efficiently. -C By an old problem it is meant that subprogram -C FC( ) was last called with this same set of -C knots, data points and weights. -C -C Another often useful deployment of this old -C problem designation can occur when one has -C previously obtained a Q-R orthogonal -C decomposition of the matrix resulting from -C B-spline fitting of data (without constraints) -C at the breakpoints BKPT(I), I=1,...,NBKPT. -C For example, this matrix could be the result -C of sequential accumulation of the least -C squares equations for a very large data set. -C The user writes this code in a manner -C convenient for the application. For the -C discussion here let -C -C N=NBKPT-NORD, and K=N+3 -C -C Let us assume that an equivalent least squares -C system -C -C RC=D -C -C has been obtained. Here R is an N+1 by N -C matrix and D is a vector with N+1 components. -C The last row of R is zero. The matrix R is -C upper triangular and banded. At most NORD of -C the diagonals are nonzero. -C The contents of R and D can be copied to the -C working array W(*) as follows. -C -C The I-th diagonal of R, which has N-I+1 -C elements, is copied to W(*) starting at -C -C W((I-1)*K+1), -C -C for I=1,...,NORD. -C The vector D is copied to W(*) starting at -C -C W(NORD*K+1) -C -C The input value used for NDATA is arbitrary -C when an old problem is designated. Because -C of the feature of FC( ) that checks the -C working storage array lengths, a value not -C exceeding NBKPT should be used. For example, -C use NDATA=0. -C -C (The constraints or variance function request -C can change in each call to FC( ).) A new -C problem is anything other than an old problem. -C -C IW(1),IW(2) -C The amounts of working storage actually -C allocated for the working arrays W(*) and -C IW(*). These quantities are compared with the -C actual amounts of storage needed in FC( ). -C Insufficient storage allocated for either -C W(*) or IW(*) is an error. This feature was -C included in FC( ) because misreading the -C storage formulas for W(*) and IW(*) might very -C well lead to subtle and hard-to-find -C programming bugs. -C -C The length of W(*) must be at least -C -C NB=(NBKPT-NORD+3)*(NORD+1)+ -C 2*MAX(NDATA,NBKPT)+NBKPT+NORD**2 -C -C Whenever possible the code uses banded matrix -C processors BNDACC( ) and BNDSOL( ). These -C are utilized if there are no constraints, -C no variance function is required, and there -C is sufficient data to uniquely determine the -C B-spline coefficients. If the band processors -C cannot be used to determine the solution, -C then the constrained least squares code LSEI -C is used. In this case the subprogram requires -C an additional block of storage in W(*). For -C the discussion here define the integers NEQCON -C and NINCON respectively as the number of -C equality (ITYPE=2,3) and inequality -C (ITYPE=0,1) constraints imposed on the fitted -C curve. Define -C -C L=NBKPT-NORD+1 -C -C and note that -C -C NCONST=NEQCON+NINCON. -C -C When the subprogram FC( ) uses LSEI( ) the -C length of the working array W(*) must be at -C least -C -C LW=NB+(L+NCONST)*L+ -C 2*(NEQCON+L)+(NINCON+L)+(NINCON+2)*(L+6) -C -C The length of the array IW(*) must be at least -C -C IW1=NINCON+2*L -C -C in any case. -C -C Output.. -C MODE -C An output flag that indicates the status -C of the constrained curve fit. -C -C =-1 a usage error of FC( ) occurred. The -C offending condition is noted with the -C SLATEC library error processor, XERMSG. -C In case the working arrays W(*) or IW(*) -C are not long enough, the minimal -C acceptable length is printed. -C -C = 0 successful constrained curve fit. -C -C = 1 the requested equality constraints -C are contradictory. -C -C = 2 the requested inequality constraints -C are contradictory. -C -C = 3 both equality and inequality constraints -C are contradictory. -C -C COEFF(*) -C If the output value of MODE=0 or 1, this array -C contains the unknowns obtained from the least -C squares fitting process. These N=NBKPT-NORD -C parameters are the B-spline coefficients. -C For MODE=1, the equality constraints are -C contradictory. To make the fitting process -C more robust, the equality constraints are -C satisfied in a least squares sense. In this -C case the array COEFF(*) contains B-spline -C coefficients for this extended concept of a -C solution. If MODE=-1,2 or 3 on output, the -C array COEFF(*) is undefined. -C -C Working Arrays.. -C W(*),IW(*) -C These arrays are respectively typed REAL and -C INTEGER. -C Their required lengths are specified as input -C parameters in IW(1), IW(2) noted above. The -C contents of W(*) must not be modified by the -C user if the variance function is desired. -C -C Evaluating the -C Variance Function.. -C To evaluate the variance function (assuming -C that the uncertainties of the Y values were -C provided to FC( ) and an input value of -C MODE=2 or 4 was used), use the function -C subprogram CV( ) -C -C VAR=CV(XVAL,NDATA,NCONST,NORD,NBKPT, -C BKPT,W) -C -C Here XVAL is the point where the variance is -C desired. The other arguments have the same -C meaning as in the usage of FC( ). -C -C For those users employing the old problem -C designation, let MDATA be the number of data -C points in the problem. (This may be different -C from NDATA if the old problem designation -C feature was used.) The value, VAR, should be -C multiplied by the quantity -C -C REAL(MAX(NDATA-N,1))/MAX(MDATA-N,1) -C -C The output of this subprogram is not defined -C if an input value of MODE=1 or 3 was used in -C FC( ) or if an output value of MODE=-1, 2, or -C 3 was obtained. The variance function, except -C for the scaling factor noted above, is given -C by -C -C VAR=(transpose of B(XVAL))*C*B(XVAL) -C -C The vector B(XVAL) is the B-spline basis -C function values at X=XVAL. -C The covariance matrix, C, of the solution -C coefficients accounts only for the least -C squares equations and the explicitly stated -C equality constraints. This fact must be -C considered when interpreting the variance -C function from a data fitting problem that has -C inequality constraints on the fitted curve. -C -C Evaluating the -C Fitted Curve.. -C To evaluate derivative number IDER at XVAL, -C use the function subprogram BVALU( ). -C -C F = BVALU(BKPT,COEFF,NBKPT-NORD,NORD,IDER, -C XVAL,INBV,WORKB) -C -C The output of this subprogram will not be -C defined unless an output value of MODE=0 or 1 -C was obtained from FC( ), XVAL is in the data -C interval, and IDER is nonnegative and .LT. -C NORD. -C -C The first time BVALU( ) is called, INBV=1 -C must be specified. This value of INBV is the -C overwritten by BVALU( ). The array WORKB(*) -C must be of length at least 3*NORD, and must -C not be the same as the W(*) array used in -C the call to FC( ). -C -C BVALU( ) expects the breakpoint array BKPT(*) -C to be sorted. -C -C***REFERENCES R. J. Hanson, Constrained least squares curve fitting -C to discrete data using B-splines, a users guide, -C Report SAND78-1291, Sandia Laboratories, December -C 1978. -C***ROUTINES CALLED FCMN -C***REVISION HISTORY (YYMMDD) -C 780801 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 900510 Convert references to XERRWV to references to XERMSG. (RWC) -C 900607 Editorial changes to Prologue to make Prologues for EFC, -C DEFC, FC, and DFC look as much the same as possible. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE FC - REAL BKPT(*), COEFF(*), SDDATA(*), W(*), XCONST(*), - * XDATA(*), YCONST(*), YDATA(*) - INTEGER IW(*), MODE, NBKPT, NCONST, NDATA, NDERIV(*), NORD -C - EXTERNAL FCMN -C - INTEGER I1, I2, I3, I4, I5, I6, I7, MDG, MDW -C -C***FIRST EXECUTABLE STATEMENT FC - MDG = NBKPT - NORD + 3 - MDW = NBKPT - NORD + 1 + NCONST -C USAGE IN FCMN( ) OF W(*).. -C I1,...,I2-1 G(*,*) -C -C I2,...,I3-1 XTEMP(*) -C -C I3,...,I4-1 PTEMP(*) -C -C I4,...,I5-1 BKPT(*) (LOCAL TO FCMN( )) -C -C I5,...,I6-1 BF(*,*) -C -C I6,...,I7-1 W(*,*) -C -C I7,... WORK(*) FOR LSEI( ) -C - I1 = 1 - I2 = I1 + MDG*(NORD+1) - I3 = I2 + MAX(NDATA,NBKPT) - I4 = I3 + MAX(NDATA,NBKPT) - I5 = I4 + NBKPT - I6 = I5 + NORD*NORD - I7 = I6 + MDW*(NBKPT-NORD+1) - CALL FCMN(NDATA, XDATA, YDATA, SDDATA, NORD, NBKPT, BKPT, NCONST, - 1 XCONST, YCONST, NDERIV, MODE, COEFF, W(I5), W(I2), W(I3), - 2 W(I4), W(I1), MDG, W(I6), MDW, W(I7), IW) - RETURN - END diff --git a/slatec/fcmn.f b/slatec/fcmn.f deleted file mode 100644 index 9cd2826..0000000 --- a/slatec/fcmn.f +++ /dev/null @@ -1,394 +0,0 @@ -*DECK FCMN - SUBROUTINE FCMN (NDATA, XDATA, YDATA, SDDATA, NORD, NBKPT, BKPTIN, - + NCONST, XCONST, YCONST, NDERIV, MODE, COEFF, BF, XTEMP, PTEMP, - + BKPT, G, MDG, W, MDW, WORK, IWORK) -C***BEGIN PROLOGUE FCMN -C***SUBSIDIARY -C***PURPOSE Subsidiary to FC -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (FCMN-S, DFCMN-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This is a companion subprogram to FC( ). -C The documentation for FC( ) has complete usage instructions. -C -C***SEE ALSO FC -C***ROUTINES CALLED BNDACC, BNDSOL, BSPLVD, BSPLVN, LSEI, SAXPY, SCOPY, -C SSCAL, SSORT, XERMSG -C***REVISION HISTORY (YYMMDD) -C 780801 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and extensively revised (WRB & RWC) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C***END PROLOGUE FCMN - INTEGER IWORK(*), MDG, MDW, MODE, NBKPT, NCONST, NDATA, NDERIV(*), - * NORD - REAL BF(NORD,*), BKPT(*), BKPTIN(*), COEFF(*), - * G(MDG,*), PTEMP(*), SDDATA(*), W(MDW,*), WORK(*), - * XCONST(*), XDATA(*), XTEMP(*), YCONST(*), YDATA(*) -C - EXTERNAL BNDACC, BNDSOL, BSPLVD, BSPLVN, LSEI, SAXPY, SCOPY, - * SSCAL, SSORT, XERMSG -C - REAL DUMMY, PRGOPT(10), RNORM, RNORME, RNORML, XMAX, - * XMIN, XVAL, YVAL - INTEGER I, IDATA, IDERIV, ILEFT, INTRVL, INTW1, IP, IR, IROW, - * ITYPE, IW1, IW2, L, LW, MT, N, NB, NEQCON, NINCON, NORDM1, - * NORDP1, NP1 - LOGICAL BAND, NEW, VAR - CHARACTER*8 XERN1 -C -C***FIRST EXECUTABLE STATEMENT FCMN -C -C Analyze input. -C - IF (NORD.LT.1 .OR. NORD.GT.20) THEN - CALL XERMSG ('SLATEC', 'FCMN', - + 'IN FC, THE ORDER OF THE B-SPLINE MUST BE 1 THRU 20.', - + 2, 1) - MODE = -1 - RETURN -C - ELSEIF (NBKPT.LT.2*NORD) THEN - CALL XERMSG ('SLATEC', 'FCMN', - + 'IN FC, THE NUMBER OF KNOTS MUST BE AT LEAST TWICE ' // - + 'THE B-SPLINE ORDER.', 2, 1) - MODE = -1 - RETURN - ENDIF -C - IF (NDATA.LT.0) THEN - CALL XERMSG ('SLATEC', 'FCMN', - + 'IN FC, THE NUMBER OF DATA POINTS MUST BE NONNEGATIVE.', - + 2, 1) - MODE = -1 - RETURN - ENDIF -C -C Amount of storage allocated for W(*), IW(*). -C - IW1 = IWORK(1) - IW2 = IWORK(2) - NB = (NBKPT-NORD+3)*(NORD+1) + 2*MAX(NDATA,NBKPT) + NBKPT + - + NORD**2 -C -C See if sufficient storage has been allocated. -C - IF (IW1.LT.NB) THEN - WRITE (XERN1, '(I8)') NB - CALL XERMSG ('SLATEC', 'FCMN', - * 'IN FC, INSUFFICIENT STORAGE FOR W(*). CHECK NB = ' // - * XERN1, 2, 1) - MODE = -1 - RETURN - ENDIF -C - IF (MODE.EQ.1) THEN - BAND = .TRUE. - VAR = .FALSE. - NEW = .TRUE. - ELSEIF (MODE.EQ.2) THEN - BAND = .FALSE. - VAR = .TRUE. - NEW = .TRUE. - ELSEIF (MODE.EQ.3) THEN - BAND = .TRUE. - VAR = .FALSE. - NEW = .FALSE. - ELSEIF (MODE.EQ.4) THEN - BAND = .FALSE. - VAR = .TRUE. - NEW = .FALSE. - ELSE - CALL XERMSG ('SLATEC', 'FCMN', - + 'IN FC, INPUT VALUE OF MODE MUST BE 1-4.', 2, 1) - MODE = -1 - RETURN - ENDIF - MODE = 0 -C -C Sort the breakpoints. -C - CALL SCOPY (NBKPT, BKPTIN, 1, BKPT, 1) - CALL SSORT (BKPT, DUMMY, NBKPT, 1) -C -C Initialize variables. -C - NEQCON = 0 - NINCON = 0 - DO 100 I = 1,NCONST - L = NDERIV(I) - ITYPE = MOD(L,4) - IF (ITYPE.LT.2) THEN - NINCON = NINCON + 1 - ELSE - NEQCON = NEQCON + 1 - ENDIF - 100 CONTINUE -C -C Compute the number of variables. -C - N = NBKPT - NORD - NP1 = N + 1 - LW = NB + (NP1+NCONST)*NP1 + 2*(NEQCON+NP1) + (NINCON+NP1) + - + (NINCON+2)*(NP1+6) - INTW1 = NINCON + 2*NP1 -C -C Save interval containing knots. -C - XMIN = BKPT(NORD) - XMAX = BKPT(NP1) -C -C Find the smallest referenced independent variable value in any -C constraint. -C - DO 110 I = 1,NCONST - XMIN = MIN(XMIN,XCONST(I)) - XMAX = MAX(XMAX,XCONST(I)) - 110 CONTINUE - NORDM1 = NORD - 1 - NORDP1 = NORD + 1 -C -C Define the option vector PRGOPT(1-10) for use in LSEI( ). -C - PRGOPT(1) = 4 -C -C Set the covariance matrix computation flag. -C - PRGOPT(2) = 1 - IF (VAR) THEN - PRGOPT(3) = 1 - ELSE - PRGOPT(3) = 0 - ENDIF -C -C Increase the rank determination tolerances for both equality -C constraint equations and least squares equations. -C - PRGOPT(4) = 7 - PRGOPT(5) = 4 - PRGOPT(6) = 1.E-4 -C - PRGOPT(7) = 10 - PRGOPT(8) = 5 - PRGOPT(9) = 1.E-4 -C - PRGOPT(10) = 1 -C -C Turn off work array length checking in LSEI( ). -C - IWORK(1) = 0 - IWORK(2) = 0 -C -C Initialize variables and analyze input. -C - IF (NEW) THEN -C -C To process least squares equations sort data and an array of -C pointers. -C - CALL SCOPY (NDATA, XDATA, 1, XTEMP, 1) - DO 120 I = 1,NDATA - PTEMP(I) = I - 120 CONTINUE -C - IF (NDATA.GT.0) THEN - CALL SSORT (XTEMP, PTEMP, NDATA, 2) - XMIN = MIN(XMIN,XTEMP(1)) - XMAX = MAX(XMAX,XTEMP(NDATA)) - ENDIF -C -C Fix breakpoint array if needed. -C - DO 130 I = 1,NORD - BKPT(I) = MIN(BKPT(I),XMIN) - 130 CONTINUE -C - DO 140 I = NP1,NBKPT - BKPT(I) = MAX(BKPT(I),XMAX) - 140 CONTINUE -C -C Initialize parameters of banded matrix processor, BNDACC( ). -C - MT = 0 - IP = 1 - IR = 1 - ILEFT = NORD - DO 160 IDATA = 1,NDATA -C -C Sorted indices are in PTEMP(*). -C - L = PTEMP(IDATA) - XVAL = XDATA(L) -C -C When interval changes, process equations in the last block. -C - IF (XVAL.GE.BKPT(ILEFT+1)) THEN - CALL BNDACC (G, MDG, NORD, IP, IR, MT, ILEFT-NORDM1) - MT = 0 -C -C Move pointer up to have BKPT(ILEFT).LE.XVAL, -C ILEFT.LT.NP1. -C - 150 IF (XVAL.GE.BKPT(ILEFT+1) .AND. ILEFT.LT.N) THEN - ILEFT = ILEFT + 1 - GO TO 150 - ENDIF - ENDIF -C -C Obtain B-spline function value. -C - CALL BSPLVN (BKPT, NORD, 1, XVAL, ILEFT, BF) -C -C Move row into place. -C - IROW = IR + MT - MT = MT + 1 - CALL SCOPY (NORD, BF, 1, G(IROW,1), MDG) - G(IROW,NORDP1) = YDATA(L) -C -C Scale data if uncertainty is nonzero. -C - IF (SDDATA(L).NE.0.E0) CALL SSCAL (NORDP1, 1.E0/SDDATA(L), - + G(IROW,1), MDG) -C -C When staging work area is exhausted, process rows. -C - IF (IROW.EQ.MDG-1) THEN - CALL BNDACC (G, MDG, NORD, IP, IR, MT, ILEFT-NORDM1) - MT = 0 - ENDIF - 160 CONTINUE -C -C Process last block of equations. -C - CALL BNDACC (G, MDG, NORD, IP, IR, MT, ILEFT-NORDM1) -C -C Last call to adjust block positioning. -C - CALL SCOPY (NORDP1, 0.E0, 0, G(IR,1), MDG) - CALL BNDACC (G, MDG, NORD, IP, IR, 1, NP1) - ENDIF -C - BAND = BAND .AND. NCONST.EQ.0 - DO 170 I = 1,N - BAND = BAND .AND. G(I,1).NE.0.E0 - 170 CONTINUE -C -C Process banded least squares equations. -C - IF (BAND) THEN - CALL BNDSOL (1, G, MDG, NORD, IP, IR, COEFF, N, RNORM) - RETURN - ENDIF -C -C Check further for sufficient storage in working arrays. -C - IF (IW1.LT.LW) THEN - WRITE (XERN1, '(I8)') LW - CALL XERMSG ('SLATEC', 'FCMN', - * 'IN FC, INSUFFICIENT STORAGE FOR W(*). CHECK LW = ' // - * XERN1, 2, 1) - MODE = -1 - RETURN - ENDIF -C - IF (IW2.LT.INTW1) THEN - WRITE (XERN1, '(I8)') INTW1 - CALL XERMSG ('SLATEC', 'FCMN', - * 'IN FC, INSUFFICIENT STORAGE FOR IW(*). CHECK IW1 = ' // - * XERN1, 2, 1) - MODE = -1 - RETURN - ENDIF -C -C Write equality constraints. -C Analyze constraint indicators for an equality constraint. -C - NEQCON = 0 - DO 220 IDATA = 1,NCONST - L = NDERIV(IDATA) - ITYPE = MOD(L,4) - IF (ITYPE.GT.1) THEN - IDERIV = L/4 - NEQCON = NEQCON + 1 - ILEFT = NORD - XVAL = XCONST(IDATA) -C - 180 IF (XVAL.LT.BKPT(ILEFT+1) .OR. ILEFT.GE.N) GO TO 190 - ILEFT = ILEFT + 1 - GO TO 180 -C - 190 CALL BSPLVD (BKPT, NORD, XVAL, ILEFT, BF, IDERIV+1) - CALL SCOPY (NP1, 0.E0, 0, W(NEQCON,1), MDW) - CALL SCOPY (NORD, BF(1,IDERIV+1), 1, W(NEQCON,ILEFT-NORDM1), - + MDW) -C - IF (ITYPE.EQ.2) THEN - W(NEQCON,NP1) = YCONST(IDATA) - ELSE - ILEFT = NORD - YVAL = YCONST(IDATA) -C - 200 IF (YVAL.LT.BKPT(ILEFT+1) .OR. ILEFT.GE.N) GO TO 210 - ILEFT = ILEFT + 1 - GO TO 200 -C - 210 CALL BSPLVD (BKPT, NORD, YVAL, ILEFT, BF, IDERIV+1) - CALL SAXPY (NORD, -1.E0, BF(1, IDERIV+1), 1, - + W(NEQCON, ILEFT-NORDM1), MDW) - ENDIF - ENDIF - 220 CONTINUE -C -C Transfer least squares data. -C - DO 230 I = 1,NP1 - IROW = I + NEQCON - CALL SCOPY (N, 0.E0, 0, W(IROW,1), MDW) - CALL SCOPY (MIN(NP1-I, NORD), G(I,1), MDG, W(IROW,I), MDW) - W(IROW,NP1) = G(I,NORDP1) - 230 CONTINUE -C -C Write inequality constraints. -C Analyze constraint indicators for inequality constraints. -C - NINCON = 0 - DO 260 IDATA = 1,NCONST - L = NDERIV(IDATA) - ITYPE = MOD(L,4) - IF (ITYPE.LT.2) THEN - IDERIV = L/4 - NINCON = NINCON + 1 - ILEFT = NORD - XVAL = XCONST(IDATA) -C - 240 IF (XVAL.LT.BKPT(ILEFT+1) .OR. ILEFT.GE.N) GO TO 250 - ILEFT = ILEFT + 1 - GO TO 240 -C - 250 CALL BSPLVD (BKPT, NORD, XVAL, ILEFT, BF, IDERIV+1) - IROW = NEQCON + NP1 + NINCON - CALL SCOPY (N, 0.E0, 0, W(IROW,1), MDW) - INTRVL = ILEFT - NORDM1 - CALL SCOPY (NORD, BF(1, IDERIV+1), 1, W(IROW, INTRVL), MDW) -C - IF (ITYPE.EQ.1) THEN - W(IROW,NP1) = YCONST(IDATA) - ELSE - W(IROW,NP1) = -YCONST(IDATA) - CALL SSCAL (NORD, -1.E0, W(IROW, INTRVL), MDW) - ENDIF - ENDIF - 260 CONTINUE -C -C Solve constrained least squares equations. -C - CALL LSEI(W, MDW, NEQCON, NP1, NINCON, N, PRGOPT, COEFF, RNORME, - + RNORML, MODE, WORK, IWORK) - RETURN - END diff --git a/slatec/fdjac1.f b/slatec/fdjac1.f deleted file mode 100644 index a1f90e7..0000000 --- a/slatec/fdjac1.f +++ /dev/null @@ -1,155 +0,0 @@ -*DECK FDJAC1 - SUBROUTINE FDJAC1 (FCN, N, X, FVEC, FJAC, LDFJAC, IFLAG, ML, MU, - + EPSFCN, WA1, WA2) -C***BEGIN PROLOGUE FDJAC1 -C***SUBSIDIARY -C***PURPOSE Subsidiary to SNSQ and SNSQE -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (FDJAC1-S, DFDJC1-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This subroutine computes a forward-difference approximation -C to the N by N Jacobian matrix associated with a specified -C problem of N functions in N VARIABLES. If the Jacobian has -C a banded form, then function evaluations are saved by only -C approximating the nonzero terms. -C -C The subroutine statement is -C -C SUBROUTINE FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN, -C WA1,WA2) -C -C where -C -C FCN is the name of the user-supplied subroutine which -C calculates the functions. FCN must be declared -C in an external statement in the user calling -C program, and should be written as follows. -C -C SUBROUTINE FCN(N,X,FVEC,IFLAG) -C INTEGER N,IFLAG -C REAL X(N),FVEC(N) -C ---------- -C Calculate the functions at X and -C return this vector in FVEC. -C ---------- -C RETURN -C END -C -C The value of IFLAG should not be changed by FCN unless -C the user wants to terminate execution of FDJAC1. -C In this case set IFLAG to a negative integer. -C -C N Is a positive integer input variable set to the number -C of functions and variables. -C -C X is an input array of length N. -C -C FVEC is an input array of length N which must contain the -C functions evaluated at X. -C -C FJAC is an output N by N array which contains the -C approximation to the Jacobian matrix evaluated at X. -C -C LDFJAC is a positive integer input variable not less than N -C which specifies the leading dimension of the array FJAC. -C -C IFLAG is an integer variable which can be used to terminate -C the execution of FDJAC1. See description of FCN. -C -C ML is a nonnegative integer input variable which specifies -C the number of subdiagonals within the band of the -C Jacobian matrix. If the Jacobian is not banded, set -C ML to at least N - 1. -C -C EPSFCN is an input variable used in determining a suitable -C step length for the forward-difference approximation. This -C approximation assumes that the relative errors in the -C functions are of the order of EPSFCN. If EPSFCN is less -C than the machine precision, it is assumed that the relative -C errors in the functions are of the order of the machine -C precision. -C -C MU is a nonnegative integer input variable which specifies -C the number of superdiagonals within the band of the -C Jacobian matrix. If the Jacobian is not banded, set -C MU to at least N - 1. -C -C WA1 and WA2 are work arrays of length N. If ML + MU + 1 is at -C least N, then the Jacobian is considered dense, and WA2 is -C not referenced. -C -C***SEE ALSO SNSQ, SNSQE -C***ROUTINES CALLED R1MACH -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE FDJAC1 - INTEGER N,LDFJAC,IFLAG,ML,MU - REAL EPSFCN - REAL X(*),FVEC(*),FJAC(LDFJAC,*),WA1(*),WA2(*) - INTEGER I,J,K,MSUM - REAL EPS,EPSMCH,H,TEMP,ZERO - REAL R1MACH - SAVE ZERO - DATA ZERO /0.0E0/ -C***FIRST EXECUTABLE STATEMENT FDJAC1 - EPSMCH = R1MACH(4) -C - EPS = SQRT(MAX(EPSFCN,EPSMCH)) - MSUM = ML + MU + 1 - IF (MSUM .LT. N) GO TO 40 -C -C COMPUTATION OF DENSE APPROXIMATE JACOBIAN. -C - DO 20 J = 1, N - TEMP = X(J) - H = EPS*ABS(TEMP) - IF (H .EQ. ZERO) H = EPS - X(J) = TEMP + H - CALL FCN(N,X,WA1,IFLAG) - IF (IFLAG .LT. 0) GO TO 30 - X(J) = TEMP - DO 10 I = 1, N - FJAC(I,J) = (WA1(I) - FVEC(I))/H - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - GO TO 110 - 40 CONTINUE -C -C COMPUTATION OF BANDED APPROXIMATE JACOBIAN. -C - DO 90 K = 1, MSUM - DO 60 J = K, N, MSUM - WA2(J) = X(J) - H = EPS*ABS(WA2(J)) - IF (H .EQ. ZERO) H = EPS - X(J) = WA2(J) + H - 60 CONTINUE - CALL FCN(N,X,WA1,IFLAG) - IF (IFLAG .LT. 0) GO TO 100 - DO 80 J = K, N, MSUM - X(J) = WA2(J) - H = EPS*ABS(WA2(J)) - IF (H .EQ. ZERO) H = EPS - DO 70 I = 1, N - FJAC(I,J) = ZERO - IF (I .GE. J - MU .AND. I .LE. J + ML) - 1 FJAC(I,J) = (WA1(I) - FVEC(I))/H - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE FDJAC1. -C - END diff --git a/slatec/fdjac3.f b/slatec/fdjac3.f deleted file mode 100644 index 8ca42c4..0000000 --- a/slatec/fdjac3.f +++ /dev/null @@ -1,114 +0,0 @@ -*DECK FDJAC3 - SUBROUTINE FDJAC3 (FCN, M, N, X, FVEC, FJAC, LDFJAC, IFLAG, - + EPSFCN, WA) -C***BEGIN PROLOGUE FDJAC3 -C***SUBSIDIARY -C***PURPOSE Subsidiary to SNLS1 and SNLS1E -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (FDJAC3-S, DFDJC3-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This subroutine computes a forward-difference approximation -C to the M by N Jacobian matrix associated with a specified -C problem of M functions in N variables. -C -C The subroutine statement is -C -C SUBROUTINE FDJAC3(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA) -C -C where -C -C FCN is the name of the user-supplied subroutine which -C calculates the functions. FCN must be declared -C in an external statement in the user calling -C program, and should be written as follows. -C -C SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) -C INTEGER LDFJAC,M,N,IFLAG -C REAL X(N),FVEC(M),FJAC(LDFJAC,N) -C ---------- -C When IFLAG.EQ.1 calculate the functions at X and -C return this vector in FVEC. -C ---------- -C RETURN -C END -C -C The value of IFLAG should not be changed by FCN unless -C the user wants to terminate execution of FDJAC3. -C In this case set IFLAG to a negative integer. -C -C M is a positive integer input variable set to the number -C of functions. -C -C N is a positive integer input variable set to the number -C of variables. N must not exceed M. -C -C X is an input array of length N. -C -C FVEC is an input array of length M which must contain the -C functions evaluated at X. -C -C FJAC is an output M by N array which contains the -C approximation to the Jacobian matrix evaluated at X. -C -C LDFJAC is a positive integer input variable not less than M -C which specifies the leading dimension of the array FJAC. -C -C IFLAG is an integer variable which can be used to terminate -C THE EXECUTION OF FDJAC3. See description of FCN. -C -C EPSFCN is an input variable used in determining a suitable -C step length for the forward-difference approximation. This -C approximation assumes that the relative errors in the -C functions are of the order of EPSFCN. If EPSFCN is less -C than the machine precision, it is assumed that the relative -C errors in the functions are of the order of the machine -C precision. -C -C WA is a work array of length M. -C -C***SEE ALSO SNLS1, SNLS1E -C***ROUTINES CALLED R1MACH -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE FDJAC3 - INTEGER M,N,LDFJAC,IFLAG - REAL EPSFCN - REAL X(*),FVEC(*),FJAC(LDFJAC,*),WA(*) - INTEGER I,J - REAL EPS,EPSMCH,H,TEMP,ZERO - REAL R1MACH - SAVE ZERO - DATA ZERO /0.0E0/ -C***FIRST EXECUTABLE STATEMENT FDJAC3 - EPSMCH = R1MACH(4) -C - EPS = SQRT(MAX(EPSFCN,EPSMCH)) -C SET IFLAG=1 TO INDICATE THAT FUNCTION VALUES -C ARE TO BE RETURNED BY FCN. - IFLAG = 1 - DO 20 J = 1, N - TEMP = X(J) - H = EPS*ABS(TEMP) - IF (H .EQ. ZERO) H = EPS - X(J) = TEMP + H - CALL FCN(IFLAG,M,N,X,WA,FJAC,LDFJAC) - IF (IFLAG .LT. 0) GO TO 30 - X(J) = TEMP - DO 10 I = 1, M - FJAC(I,J) = (WA(I) - FVEC(I))/H - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE FDJAC3. -C - END diff --git a/slatec/fdump.f b/slatec/fdump.f deleted file mode 100644 index 1f44a57..0000000 --- a/slatec/fdump.f +++ /dev/null @@ -1,31 +0,0 @@ -*DECK FDUMP - SUBROUTINE FDUMP -C***BEGIN PROLOGUE FDUMP -C***PURPOSE Symbolic dump (should be locally written). -C***LIBRARY SLATEC (XERROR) -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 diff --git a/slatec/fftdoc.f b/slatec/fftdoc.f deleted file mode 100644 index 79e908b..0000000 --- a/slatec/fftdoc.f +++ /dev/null @@ -1,66 +0,0 @@ -*DECK FFTDOC - SUBROUTINE FFTDOC -C***BEGIN PROLOGUE FFTDOC -C***PURPOSE Documentation for FFTPACK, a collection of Fast Fourier -C Transform routines. -C***LIBRARY SLATEC -C***CATEGORY J1, Z -C***TYPE ALL (FFTDOC-A) -C***KEYWORDS DOCUMENTATION, FAST FOURIER TRANSFORM, FFT -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -C Version 3 June 1979 -C -C A Package of Fortran Subprograms for The Fast Fourier -C Transform of Periodic and Other Symmetric Sequences -C By -C Paul N Swarztrauber -C -C National Center For Atmospheric Research, Boulder, Colorado 80307 -C which is sponsored by the National Science Foundation -C -C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -C -C This package consists of programs which perform Fast Fourier -C Transforms for both complex and real periodic sequences and -C certain other symmetric sequences that are listed below. -C -C 1. RFFTI Initialize RFFTF and RFFTB -C 2. RFFTF Forward transform of a real periodic sequence -C 3. RFFTB Backward transform of a real coefficient array -C -C 4. EZFFTI Initialize EZFFTF and EZFFTB -C 5. EZFFTF A simplified real periodic forward transform -C 6. EZFFTB A simplified real periodic backward transform -C -C 7. SINTI Initialize SINT -C 8. SINT Sine transform of a real odd sequence -C -C 9. COSTI Initialize COST -C 10. COST Cosine transform of a real even sequence -C -C 11. SINQI Initialize SINQF and SINQB -C 12. SINQF Forward sine transform with odd wave numbers -C 13. SINQB Unnormalized inverse of SINQF -C -C 14. COSQI Initialize COSQF and COSQB -C 15. COSQF Forward cosine transform with odd wave numbers -C 16. COSQB Unnormalized inverse of COSQF -C -C 17. CFFTI Initialize CFFTF and CFFTB -C 18. CFFTF Forward transform of a complex periodic sequence -C 19. CFFTB Unnormalized inverse of CFFTF -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 780201 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900723 PURPOSE section revised. (WRB) -C***END PROLOGUE FFTDOC -C***FIRST EXECUTABLE STATEMENT FFTDOC - RETURN - END diff --git a/slatec/figi.f b/slatec/figi.f deleted file mode 100644 index d50bdb5..0000000 --- a/slatec/figi.f +++ /dev/null @@ -1,100 +0,0 @@ -*DECK FIGI - SUBROUTINE FIGI (NM, N, T, D, E, E2, IERR) -C***BEGIN PROLOGUE FIGI -C***PURPOSE Transforms certain real non-symmetric tridiagonal matrix -C to symmetric tridiagonal matrix. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C1C -C***TYPE SINGLE PRECISION (FIGI-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C Given a NONSYMMETRIC TRIDIAGONAL matrix such that the products -C of corresponding pairs of off-diagonal elements are all -C non-negative, this subroutine reduces it to a symmetric -C tridiagonal matrix with the same eigenvalues. If, further, -C a zero product only occurs when both factors are zero, -C the reduced matrix is similar to the original matrix. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameter, T, as declared in the calling program -C dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix T. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C T contains the nonsymmetric matrix. Its subdiagonal is -C stored in the last N-1 positions of the first column, -C its diagonal in the N positions of the second column, -C and its superdiagonal in the first N-1 positions of -C the third column. T(1,1) and T(N,3) are arbitrary. -C T is a two-dimensional REAL array, dimensioned T(NM,3). -C -C On OUTPUT -C -C T is unaltered. -C -C D contains the diagonal elements of the tridiagonal symmetric -C matrix. D is a one-dimensional REAL array, dimensioned D(N). -C -C E contains the subdiagonal elements of the tridiagonal -C symmetric matrix in its last N-1 positions. E(1) is not set. -C E is a one-dimensional REAL array, dimensioned E(N). -C -C E2 contains the squares of the corresponding elements of E. -C E2 may coincide with E if the squares are not needed. -C E2 is a one-dimensional REAL array, dimensioned E2(N). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C N+I if T(I,1)*T(I-1,3) is negative and a symmetric -C matrix cannot be produced with FIGI, -C -(3*N+I) if T(I,1)*T(I-1,3) is zero with one factor -C non-zero. In this case, the eigenvectors of -C the symmetric matrix are not simply related -C to those of T and should not be sought. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE FIGI -C - INTEGER I,N,NM,IERR - REAL T(NM,3),D(*),E(*),E2(*) -C -C***FIRST EXECUTABLE STATEMENT FIGI - IERR = 0 -C - DO 100 I = 1, N - IF (I .EQ. 1) GO TO 90 - E2(I) = T(I,1) * T(I-1,3) - IF (E2(I)) 1000, 60, 80 - 60 IF (T(I,1) .EQ. 0.0E0 .AND. T(I-1,3) .EQ. 0.0E0) GO TO 80 -C .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL -C ELEMENTS IS ZERO WITH ONE MEMBER NON-ZERO .......... - IERR = -(3 * N + I) - 80 E(I) = SQRT(E2(I)) - 90 D(I) = T(I,2) - 100 CONTINUE -C - GO TO 1001 -C .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL -C ELEMENTS IS NEGATIVE .......... - 1000 IERR = N + I - 1001 RETURN - END diff --git a/slatec/figi2.f b/slatec/figi2.f deleted file mode 100644 index 4e5a732..0000000 --- a/slatec/figi2.f +++ /dev/null @@ -1,109 +0,0 @@ -*DECK FIGI2 - SUBROUTINE FIGI2 (NM, N, T, D, E, Z, IERR) -C***BEGIN PROLOGUE FIGI2 -C***PURPOSE Transforms certain real non-symmetric tridiagonal matrix -C to symmetric tridiagonal matrix. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C1C -C***TYPE SINGLE PRECISION (FIGI2-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C Given a NONSYMMETRIC TRIDIAGONAL matrix such that the products -C of corresponding pairs of off-diagonal elements are all -C non-negative, and zero only when both factors are zero, this -C subroutine reduces it to a SYMMETRIC TRIDIAGONAL matrix -C using and accumulating diagonal similarity transformations. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, T and Z, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix T. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C T contains the nonsymmetric matrix. Its subdiagonal is -C stored in the last N-1 positions of the first column, -C its diagonal in the N positions of the second column, -C and its superdiagonal in the first N-1 positions of -C the third column. T(1,1) and T(N,3) are arbitrary. -C T is a two-dimensional REAL array, dimensioned T(NM,3). -C -C On OUTPUT -C -C T is unaltered. -C -C D contains the diagonal elements of the tridiagonal symmetric -C matrix. D is a one-dimensional REAL array, dimensioned D(N). -C -C E contains the subdiagonal elements of the tridiagonal -C symmetric matrix in its last N-1 positions. E(1) is not set. -C E is a one-dimensional REAL array, dimensioned E(N). -C -C Z contains the diagonal transformation matrix produced in the -C symmetrization. Z is a two-dimensional REAL array, -C dimensioned Z(NM,N). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C N+I if T(I,1)*T(I-1,3) is negative, -C 2*N+I if T(I,1)*T(I-1,3) is zero with one factor -C non-zero. In these cases, there does not exist -C a symmetrizing similarity transformation which -C is essential for the validity of the later -C eigenvector computation. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE FIGI2 -C - INTEGER I,J,N,NM,IERR - REAL T(NM,3),D(*),E(*),Z(NM,*) - REAL H -C -C***FIRST EXECUTABLE STATEMENT FIGI2 - IERR = 0 -C - DO 100 I = 1, N -C - DO 50 J = 1, N - 50 Z(I,J) = 0.0E0 -C - IF (I .EQ. 1) GO TO 70 - H = T(I,1) * T(I-1,3) - IF (H) 900, 60, 80 - 60 IF (T(I,1) .NE. 0.0E0 .OR. T(I-1,3) .NE. 0.0E0) GO TO 1000 - E(I) = 0.0E0 - 70 Z(I,I) = 1.0E0 - GO TO 90 - 80 E(I) = SQRT(H) - Z(I,I) = Z(I-1,I-1) * E(I) / T(I-1,3) - 90 D(I) = T(I,2) - 100 CONTINUE -C - GO TO 1001 -C .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL -C ELEMENTS IS NEGATIVE .......... - 900 IERR = N + I - GO TO 1001 -C .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL -C ELEMENTS IS ZERO WITH ONE MEMBER NON-ZERO .......... - 1000 IERR = 2 * N + I - 1001 RETURN - END diff --git a/slatec/fulmat.f b/slatec/fulmat.f deleted file mode 100644 index 467da64..0000000 --- a/slatec/fulmat.f +++ /dev/null @@ -1,85 +0,0 @@ -*DECK FULMAT - SUBROUTINE FULMAT (I, J, AIJ, INDCAT, PRGOPT, DATTRV, IFLAG) -C***BEGIN PROLOGUE FULMAT -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (FULMAT-S, DFULMT-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C DECODES A STANDARD TWO-DIMENSIONAL FORTRAN ARRAY PASSED -C IN THE ARRAY DATTRV(IA,*). THE ROW DIMENSION IA AND THE -C MATRIX DIMENSIONS MRELAS AND NVARS MUST SIMULTANEOUSLY BE -C PASSED USING THE OPTION ARRAY, PRGOPT(*). IT IS AN ERROR -C IF THIS DATA IS NOT PASSED TO FULMAT( ). -C EXAMPLE-- (FOR USE TOGETHER WITH SPLP().) -C EXTERNAL USRMAT -C DIMENSION DATTRV(IA,*) -C PRGOPT(01)=7 -C PRGOPT(02)=68 -C PRGOPT(03)=1 -C PRGOPT(04)=IA -C PRGOPT(05)=MRELAS -C PRGOPT(06)=NVARS -C PRGOPT(07)=1 -C CALL SPLP( ... FULMAT INSTEAD OF USRMAT...) -C -C***SEE ALSO SPLP -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE FULMAT - REAL AIJ,ZERO,DATTRV(*),PRGOPT(*) - INTEGER IFLAG(10) - SAVE ZERO -C***FIRST EXECUTABLE STATEMENT FULMAT - IF (.NOT.(IFLAG(1).EQ.1)) GO TO 50 -C INITIALIZE POINTERS TO PROCESS FULL TWO-DIMENSIONAL FORTRAN -C ARRAYS. - ZERO = 0. - LP = 1 - 10 NEXT = PRGOPT(LP) - IF (.NOT.(NEXT.LE.1)) GO TO 20 - NERR = 29 - LEVEL = 1 - CALL XERMSG ('SLATEC', 'FULMAT', - + 'IN SPLP PACKAGE, ROW DIM., MRELAS, NVARS ARE MISSING FROM ' // - + 'PRGOPT.', NERR, LEVEL) - IFLAG(1) = 3 - GO TO 110 - 20 KEY = PRGOPT(LP+1) - IF (.NOT.(KEY.NE.68)) GO TO 30 - LP = NEXT - GO TO 10 - 30 IF (.NOT.(PRGOPT(LP+2).EQ.ZERO)) GO TO 40 - LP = NEXT - GO TO 10 - 40 IFLAG(2) = 1 - IFLAG(3) = 1 - IFLAG(4) = PRGOPT(LP+3) - IFLAG(5) = PRGOPT(LP+4) - IFLAG(6) = PRGOPT(LP+5) - GO TO 110 - 50 IF (.NOT.(IFLAG(1).EQ.2)) GO TO 100 - 60 I = IFLAG(2) - J = IFLAG(3) - IF (.NOT.(J.GT.IFLAG(6))) GO TO 70 - IFLAG(1) = 3 - GO TO 110 - 70 IF (.NOT.(I.GT.IFLAG(5))) GO TO 80 - IFLAG(2) = 1 - IFLAG(3) = J + 1 - GO TO 60 - 80 AIJ = DATTRV(IFLAG(4)*(J-1)+I) - IFLAG(2) = I + 1 - IF (.NOT.(AIJ.EQ.ZERO)) GO TO 90 - GO TO 60 - 90 INDCAT = 0 - GO TO 110 - 100 CONTINUE - 110 RETURN - END diff --git a/slatec/fundoc.f b/slatec/fundoc.f deleted file mode 100644 index 3ee4b5a..0000000 --- a/slatec/fundoc.f +++ /dev/null @@ -1,218 +0,0 @@ -*DECK FUNDOC - SUBROUTINE FUNDOC -C***BEGIN PROLOGUE FUNDOC -C***PURPOSE Documentation for FNLIB, a collection of routines for -C evaluating elementary and special functions. -C***LIBRARY SLATEC -C***CATEGORY C, Z -C***TYPE ALL (FUNDOC-A) -C***KEYWORDS DOCUMENTATION, ELEMENTARY FUNCTIONS, SPECIAL FUNCTIONS -C***AUTHOR Kahaner, D. K., (NBS) -C***DESCRIPTION -C -C The SLATEC Library -- Elementary And Special Functions -C -C This describes the elementary and special function routines available -C in the SLATEC library. Most of the these routines were written by -C Wayne Fullerton while at LANL. Some were written by Don Amos of SNLA. -C There are approximately 63 single precision, 63 double precision and -C 25 complex user callable elementary and special function routines. -C -C The table below gives a breakdown of routines according to their -C function. Unless otherwise indicated all routines are function -C subprograms. -C Sngl. Dble. -C Description Notation Prec. Prec. Complex -C -C ***Intrinsic Functions and Fundamental Functions*** -C Unpack floating point Call R9UPAK(X,Y,N) D9UPAK -- -C number -C Pack floating point R9PAK(Y,N) D9PAK -- -C number -C Initialize orthogonal INITS(OS,NOS,ETA) INITDS -- -C polynomial series -C Evaluate Chebyshev summation for CSEVL(X,CS,N) DCSEVL -- -C series i = 1 to n of -C cs(i)*(2*x)**(i-1) -C -C ***Elementary Functions*** -C Argument = theta in z = \ z \ * -- -- CARG(Z) -C radians e**(i * theta) -C Cube root CBRT(X) DCBRT CCBRT -C Relative error exponen- ((e**x) -1) / x EXPREL(X) DEXPRL CEXPRL -C tial from first order -C Common logarithm log to the base 10 -- -- CLOG10(Z) -C of z -C Relative error logarithm ln(1 + x) ALNREL(X) DLNREL CLNREL -C Relative error logarithm (ln(1 + x) - x R9LN2R(X) D9LN2R C9LN2R -C from second order + x**2/2) / x**3 -C ***Trigonometric and Hyperbolic Functions*** -C Tangent tan z -- -- CTAN(Z) -C Cotangent cot x COT(X) DCOT CCOT -C Sine x in degrees sin((2*pi*x)/360) SINDG(X) DSINDG -- -C Cosine x in degrees cos((2*pi*x)/360) COSDG(X) DCOSDG -- -C Arc sine arcsin (z) -- -- CASIN(Z) -C Arc cosine arccos (z) -- -- CACOS(Z) -C Arc tangent arctan (z) -- -- CATAN(Z) -C Quadrant correct arctan (z1/z2) -- -- CATAN2(Z1, -C arc tangent Z2) -C Hyperbolic sine sinh z -- -- CSINH(Z) -C Hyperbolic cosine cosh z -- -- CCOSH(Z) -C Hyperbolic tangent tanh z -- -- CTANH(Z) -C Arc hyperbolic sine arcsinh (x) ASINH(X) DASINH CASINH -C Arc hyperbolic cosine arccosh (x) ACOSH(X) DACOSH CACOSH -C Arc hyperbolic tangent arctanh (x) ATANH(X) DATANH CATANH -C Relative error arc (arctan (x) - x) R9ATN1(X) D9ATN1 -- -C tangent from first order / x**3 -C ***Exponential Integrals and Related Functions*** -C Exponential integral Ei(x) = (minus) EI(X) DEI -- -C the integral from -C -x to infinity of -C (e**-t / t)dt -C Exponential integral E sub 1 (x) = E1(X) DE1 -- -C the integral from x -C to infinity of -C (e**-t / t) dt -C Logarithmic integral li(x) = the ALI(X) DLI -- -C integral from 0 to -C x of (1 / ln t) dt -C Sequences of exponential integrals. -C M values are computed where -C k=0,1,...M-1 and n>=1 -C Exponential integral E sub n+k (x) Call EXINT(X, DEXINT -- -C =the integral from N,KODE,M,TOL, -C 1 to infinity of EN,IERR) -C (e**(-x*t)/t**(n+k))dt -C ***Gamma Functions and Related Functions*** -C Factorial n! FAC(N) DFAC -- -C Binomial n!/(m!*(n-m)!) BINOM(N,M) DBINOM -- -C Gamma gamma(x) GAMMA(X) DGAMMA CGAMMA -C Gamma(x) under and Call GAMLIM( DGAMLM -- -C overflow limits XMIN,XMAX) -C Reciprocal gamma 1 / gamma(x) GAMR(X) DGAMR CGAMR -C Log abs gamma ln \gamma(x)\ ALNGAM(X) DLNGAM -- -C Log gamma ln gamma(z) -- -- CLNGAM -C Log abs gamma g = ln \gamma(x)\ Call ALGAMS(X, DLGAMS -- -C with sign s = sign gamma(x) G,S) -C Incomplete gamma gamma(a,x) = GAMI(A,X) DGAMI -- -C the integral from -C 0 to x of -C (t**(a-1) * e**-t)dt -C Complementary gamma(a,x) = GAMIC(A,X) DGAMIC -- -C incomplete gamma the integral from -C x to infinity of -C (t**(a-1) * e**-t)dt -C Tricomi's gamma super star(a,x) GAMIT(A,X) DGAMIT -- -C incomplete gamma = x**-a * -C incomplete gamma(a,x) -C / gamma(a) -C Psi (Digamma) psi(x) = gamma'(x) PSI(X) DPSI CPSI -C / gamma(x) -C Pochhammer's (a) sub x = gamma(a+x) POCH(A,X) DPOCH -- -C generalized symbol / gamma(a) -C Pochhammer's symbol ((a) sub x -1) / x POCH1(A,X) DPOCH1 -- -C from first order -C Beta b(a,b) = (gamma(a) BETA(A,B) DBETA CBETA -C * gamma(b)) -C / gamma(a+b) -C = the integral -C from 0 to 1 of -C (t**(a-1) * -C (1-t)**(b-1))dt -C Log beta ln b(a,b) ALBETA(A,B) DLBETA CLBETA -C Incomplete beta i sub x (a,b) = BETAI(X,A,B) DBETAI __ -C b sub x (a,b) / b(a,b) -C = 1 / b(a,b) * -C the integral -C from 0 to x of -C (t**(a-1) * -C (1-t)**(b-1))dt -C Log gamma correction ln gamma(x) - R9LGMC(X) D9LGMC C9LGMC -C term when Stirling's (ln(2 * pi))/2 - -C approximation is valid (x - 1/2) * ln(x) + x -C ***Error Functions and Fresnel Integrals*** -C Error function erf x = (2 / ERF(X) DERF -- -C square root of pi) * -C the integral from -C 0 to x of -C e**(-t**2)dt -C Complementary erfc x = (2 / ERFC(X) DERFC -- -C error function square root of pi) * -C the integral from -C x to infinity of -C e**(-t**2)dt -C Dawson's function F(x) = e**(-x**2) DAWS(X) DDAWS -- -C * the integral from -C from 0 to x of -C e**(t**2)dt -C ***Bessel Functions*** -C Bessel functions of special integer order -C First kind, order zero J sub 0 (x) BESJ0(X) DBESJ0 -- -C First kind, order one J sub 1 (x) BESJ1(X) DBESJ1 -- -C Second kind, order zero Y sub 0 (x) BESY0(X) DBESY0 -- -C Second kind, order one Y sub 1 (x) BESY1(X) DBESY1 -- -C Modified (hyperbolic) Bessel functions of special integer order -C First kind, order zero I sub 0 (x) BESI0(X) DBESI0 -- -C First kind, order one I sub 1 (x) BESI1(X) DBESI1 -- -C Third kind, order zero K sub 0 (x) BESK0(X) DBESK0 -- -C Third kind, order one K sub 1 (x) BESK1(X) DBESK1 -- -C Modified (hyperbolic) Bessel functions of special integer order -C scaled by an exponential -C First kind, order zero e**-\x\ * I sub 0(x) BESI0E(X) DBSI0E -- -C First kind, order one e**-\x\ * I sub 1(x) BESI1E(X) DBSI1E -- -C Third kind, order zero e**x * K sub 0 (x) BESK0E(X) DBSK0E -- -C Third kind, order one e**x * K sub 1 (x) BESK1E(X) DBSK1E -- -C Sequences of Bessel functions of general order. -C N values are computed where k = 1,2,...N and v .ge. 0. -C Modified first kind I sub v+k-1 (x) Call BESI(X, DBESI -- -C optional scaling ALPHA,KODE,N, -C by e**(-x) Y,NZ) -C First kind J sub v+k-1 (x) Call BESJ(X, DBESJ -- -C ALPHA,N,Y,NZ) -C Second kind Y sub v+k-1 (x) Call BESY(X, DBESY -- -C FNU,N,Y) -C Modified third kind K sub v+k-1 (x) Call BESK(X, DBESK -- -C optional scaling FNU,KODE,N,Y, -C by e**(x) NZ) -C Sequences of Bessel functions. \N\ values are computed where -C I = 0, 1, 2, ..., N-1 for N > 0 or I = 0, -1, -2, ..., N+1 -C for N < 0. -C Modified third kind K sub v+i (x) Call BESKS( DBESKS -- -C XNU,X,N,BK) -C Sequences of Bessel functions scaled by an exponential. -C \N\ values are computed where I = 0, 1, 2, ..., N-1 -C for N > 0 or I = 0, -1, -2, ..., N+1 for N < 0. -C Modified third kind e**x * Call BESKES( DBSKES -- -C K sub v+i (x) XNU,X,N,BK) -C ***Bessel Functions of Fractional Order*** -C Airy functions -C Airy Ai(x) AI(X) DAI -- -C Bairy Bi(x) BI(X) DBI -- -C Exponentially scaled Airy functions -C Airy Ai(x), x <= 0 AIE(X) DAIE -- -C exp(2/3 * x**(3/2)) -C * Ai(x), x >= 0 -C Bairy Bi(x), x <= 0 BIE(X) DBIE -- -C exp(-2/3 * x**(3/2)) -C * Bi(x), x >= 0 -C ***Confluent Hypergeometric Functions*** -C Confluent U(a,b,x) CHU(A,B,X) DCHU -- -C hypergeometric -C ***Miscellaneous Functions*** -C Spence s(x) = - the SPENC(X) DSPENC -- -C dilogarithm integral from -C 0 to x of -C ((ln \1-y\) / y)dy -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801015 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Routine name changed from FNLIBD to FUNDOC. (WRB) -C 900723 PURPOSE section revised. (WRB) -C***END PROLOGUE FUNDOC -C***FIRST EXECUTABLE STATEMENT FUNDOC - RETURN - END diff --git a/slatec/fzero.f b/slatec/fzero.f deleted file mode 100644 index 9e483a3..0000000 --- a/slatec/fzero.f +++ /dev/null @@ -1,223 +0,0 @@ -*DECK FZERO - SUBROUTINE FZERO (F, B, C, R, RE, AE, IFLAG) -C***BEGIN PROLOGUE FZERO -C***PURPOSE Search for a zero of a function F(X) in a given interval -C (B,C). It is designed primarily for problems where F(B) -C and F(C) have opposite signs. -C***LIBRARY SLATEC -C***CATEGORY F1B -C***TYPE SINGLE PRECISION (FZERO-S, DFZERO-D) -C***KEYWORDS BISECTION, NONLINEAR EQUATIONS, ROOTS, ZEROS -C***AUTHOR Shampine, L. F., (SNLA) -C Watts, H. A., (SNLA) -C***DESCRIPTION -C -C FZERO searches for a zero of a REAL function F(X) between the -C given REAL values B and C until the width of the interval (B,C) -C has collapsed to within a tolerance specified by the stopping -C criterion, -C ABS(B-C) .LE. 2.*(RW*ABS(B)+AE). -C The method used is an efficient combination of bisection and the -C secant rule and is due to T. J. Dekker. -C -C Description Of Arguments -C -C F :EXT - Name of the REAL external function. This name must -C be in an EXTERNAL statement in the calling program. -C F must be a function of one REAL argument. -C -C B :INOUT - One end of the REAL interval (B,C). The value -C returned for B usually is the better approximation -C to a zero of F. -C -C C :INOUT - The other end of the REAL interval (B,C) -C -C R :OUT - A (better) REAL guess of a zero of F which could help -C in speeding up convergence. If F(B) and F(R) have -C opposite signs, a root will be found in the interval -C (B,R); if not, but F(R) and F(C) have opposite signs, -C a root will be found in the interval (R,C); -C otherwise, the interval (B,C) will be searched for a -C possible root. When no better guess is known, it is -C recommended that r be set to B or C, since if R is -C not interior to the interval (B,C), it will be -C ignored. -C -C RE :IN - Relative error used for RW in the stopping criterion. -C If the requested RE is less than machine precision, -C then RW is set to approximately machine precision. -C -C AE :IN - Absolute error used in the stopping criterion. If -C the given interval (B,C) contains the origin, then a -C nonzero value should be chosen for AE. -C -C IFLAG :OUT - A status code. User must check IFLAG after each -C call. Control returns to the user from FZERO in all -C cases. -C -C 1 B is within the requested tolerance of a zero. -C The interval (B,C) collapsed to the requested -C tolerance, the function changes sign in (B,C), and -C F(X) decreased in magnitude as (B,C) collapsed. -C -C 2 F(B) = 0. However, the interval (B,C) may not have -C collapsed to the requested tolerance. -C -C 3 B may be near a singular point of F(X). -C The interval (B,C) collapsed to the requested tol- -C erance and the function changes sign in (B,C), but -C F(X) increased in magnitude as (B,C) collapsed, i.e. -C ABS(F(B out)) .GT. MAX(ABS(F(B in)),ABS(F(C in))) -C -C 4 No change in sign of F(X) was found although the -C interval (B,C) collapsed to the requested tolerance. -C The user must examine this case and decide whether -C B is near a local minimum of F(X), or B is near a -C zero of even multiplicity, or neither of these. -C -C 5 Too many (.GT. 500) function evaluations used. -C -C***REFERENCES L. F. Shampine and H. A. Watts, FZERO, a root-solving -C code, Report SC-TM-70-631, Sandia Laboratories, -C September 1970. -C T. J. Dekker, Finding a zero by means of successive -C linear interpolation, Constructive Aspects of the -C Fundamental Theorem of Algebra, edited by B. Dejon -C and P. Henrici, Wiley-Interscience, 1969. -C***ROUTINES CALLED R1MACH -C***REVISION HISTORY (YYMMDD) -C 700901 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 FZERO - REAL A,ACBS,ACMB,AE,AW,B,C,CMB,ER,FA,FB,FC,FX,FZ,P,Q,R, - + RE,RW,T,TOL,Z - INTEGER IC,IFLAG,KOUNT -C***FIRST EXECUTABLE STATEMENT FZERO -C -C ER is two times the computer unit roundoff value which is defined -C here by the function R1MACH. -C - ER = 2.0E0 * R1MACH(4) -C -C Initialize. -C - Z = R - IF (R .LE. MIN(B,C) .OR. R .GE. MAX(B,C)) Z = C - RW = MAX(RE,ER) - AW = MAX(AE,0.E0) - IC = 0 - T = Z - FZ = F(T) - FC = FZ - T = B - FB = F(T) - KOUNT = 2 - IF (SIGN(1.0E0,FZ) .EQ. SIGN(1.0E0,FB)) GO TO 1 - C = Z - GO TO 2 - 1 IF (Z .EQ. C) GO TO 2 - T = C - FC = F(T) - KOUNT = 3 - IF (SIGN(1.0E0,FZ) .EQ. SIGN(1.0E0,FC)) GO TO 2 - B = Z - FB = FZ - 2 A = C - FA = FC - ACBS = ABS(B-C) - FX = MAX(ABS(FB),ABS(FC)) -C - 3 IF (ABS(FC) .GE. ABS(FB)) GO TO 4 -C -C Perform interchange. -C - A = B - FA = FB - B = C - FB = FC - C = A - FC = FA -C - 4 CMB = 0.5E0*(C-B) - ACMB = ABS(CMB) - TOL = RW*ABS(B) + AW -C -C Test stopping criterion and function count. -C - IF (ACMB .LE. TOL) GO TO 10 - IF (FB .EQ. 0.E0) GO TO 11 - IF (KOUNT .GE. 500) GO TO 14 -C -C Calculate new iterate implicitly as B+P/Q, where we arrange -C P .GE. 0. The implicit form is used to prevent overflow. -C - P = (B-A)*FB - Q = FA - FB - IF (P .GE. 0.E0) GO TO 5 - P = -P - Q = -Q -C -C Update A and check for satisfactory reduction in the size of the -C bracketing interval. If not, perform bisection. -C - 5 A = B - FA = FB - IC = IC + 1 - IF (IC .LT. 4) GO TO 6 - IF (8.0E0*ACMB .GE. ACBS) GO TO 8 - IC = 0 - ACBS = ACMB -C -C Test for too small a change. -C - 6 IF (P .GT. ABS(Q)*TOL) GO TO 7 -C -C Increment by TOLerance. -C - B = B + SIGN(TOL,CMB) - GO TO 9 -C -C Root ought to be between B and (C+B)/2. -C - 7 IF (P .GE. CMB*Q) GO TO 8 -C -C Use secant rule. -C - B = B + P/Q - GO TO 9 -C -C Use bisection (C+B)/2. -C - 8 B = B + CMB -C -C Have completed computation for new iterate B. -C - 9 T = B - FB = F(T) - KOUNT = KOUNT + 1 -C -C Decide whether next step is interpolation or extrapolation. -C - IF (SIGN(1.0E0,FB) .NE. SIGN(1.0E0,FC)) GO TO 3 - C = A - FC = FA - GO TO 3 -C -C Finished. Process results for proper setting of IFLAG. -C - 10 IF (SIGN(1.0E0,FB) .EQ. SIGN(1.0E0,FC)) GO TO 13 - IF (ABS(FB) .GT. FX) GO TO 12 - IFLAG = 1 - RETURN - 11 IFLAG = 2 - RETURN - 12 IFLAG = 3 - RETURN - 13 IFLAG = 4 - RETURN - 14 IFLAG = 5 - RETURN - END diff --git a/slatec/gami.f b/slatec/gami.f deleted file mode 100644 index d507574..0000000 --- a/slatec/gami.f +++ /dev/null @@ -1,45 +0,0 @@ -*DECK GAMI - FUNCTION GAMI (A, X) -C***BEGIN PROLOGUE GAMI -C***PURPOSE Evaluate the incomplete Gamma function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE SINGLE PRECISION (GAMI-S, DGAMI-D) -C***KEYWORDS FNLIB, INCOMPLETE GAMMA FUNCTION, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate the incomplete gamma function defined by -C -C GAMI = integral from T = 0 to X of EXP(-T) * T**(A-1.0) . -C -C GAMI is evaluated for positive values of A and non-negative values -C of X. A slight deterioration of 2 or 3 digits accuracy will occur -C when GAMI is very large or very small, because logarithmic variables -C are used. GAMI, A, and X are single precision. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED ALNGAM, GAMIT, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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***END PROLOGUE GAMI -C***FIRST EXECUTABLE STATEMENT GAMI - IF (A .LE. 0.0) CALL XERMSG ('SLATEC', 'GAMI', - + 'A MUST BE GT ZERO', 1, 2) - IF (X .LT. 0.0) CALL XERMSG ('SLATEC', 'GAMI', - + 'X MUST BE GE ZERO', 2, 2) -C - GAMI = 0.0 - IF (X.EQ.0.0) RETURN -C -C THE ONLY ERROR POSSIBLE IN THE EXPRESSION BELOW IS A FATAL OVERFLOW. - FACTOR = EXP (ALNGAM(A) + A*LOG(X) ) -C - GAMI = FACTOR * GAMIT(A, X) -C - RETURN - END diff --git a/slatec/gamic.f b/slatec/gamic.f deleted file mode 100644 index c499fb1..0000000 --- a/slatec/gamic.f +++ /dev/null @@ -1,127 +0,0 @@ -*DECK GAMIC - REAL FUNCTION GAMIC (A, X) -C***BEGIN PROLOGUE GAMIC -C***PURPOSE Calculate the complementary incomplete Gamma function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE SINGLE PRECISION (GAMIC-S, DGAMIC-D) -C***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate the complementary incomplete gamma function -C -C GAMIC = integral from X to infinity of EXP(-T) * T**(A-1.) . -C -C GAMIC is evaluated for arbitrary real values of A and for non- -C negative values of X (even though GAMIC is defined for X .LT. -C 0.0), except that for X = 0 and A .LE. 0.0, GAMIC is undefined. -C -C GAMIC, A, and X are REAL. -C -C A slight deterioration of 2 or 3 digits accuracy will occur when -C GAMIC is very large or very small in absolute value, because log- -C arithmic variables are used. Also, if the parameter A is very close -C to a negative integer (but not a negative integer), there is a loss -C of accuracy, which is reported if the result is less than half -C machine precision. -C -C***REFERENCES W. Gautschi, A computational procedure for incomplete -C gamma functions, ACM Transactions on Mathematical -C Software 5, 4 (December 1979), pp. 466-481. -C W. Gautschi, Incomplete gamma functions, Algorithm 542, -C ACM Transactions on Mathematical Software 5, 4 -C (December 1979), pp. 482-489. -C***ROUTINES CALLED ALGAMS, ALNGAM, R1MACH, R9GMIC, R9GMIT, R9LGIC, -C R9LGIT, XERCLR, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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 920528 DESCRIPTION and REFERENCES sections revised. (WRB) -C***END PROLOGUE GAMIC - LOGICAL FIRST - SAVE EPS, SQEPS, ALNEPS, BOT, FIRST - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT GAMIC - IF (FIRST) THEN - EPS = 0.5*R1MACH(3) - SQEPS = SQRT(R1MACH(4)) - ALNEPS = -LOG(R1MACH(3)) - BOT = LOG(R1MACH(1)) - ENDIF - FIRST = .FALSE. -C - IF (X .LT. 0.0) CALL XERMSG ('SLATEC', 'GAMIC', 'X IS NEGATIVE', - + 2, 2) -C - IF (X.GT.0.0) GO TO 20 - IF (A .LE. 0.0) CALL XERMSG ('SLATEC', 'GAMIC', - + 'X = 0 AND A LE 0 SO GAMIC IS UNDEFINED', 3, 2) -C - GAMIC = EXP (ALNGAM(A+1.0) - LOG(A)) - RETURN -C - 20 ALX = LOG(X) - SGA = 1.0 - IF (A.NE.0.0) SGA = SIGN (1.0, A) - MA = A + 0.5*SGA - AEPS = A - MA -C - IZERO = 0 - IF (X.GE.1.0) GO TO 60 -C - IF (A.GT.0.5 .OR. ABS(AEPS).GT.0.001) GO TO 50 - FM = -MA - E = 2.0 - IF (FM.GT.1.0) E = 2.0*(FM+2.0)/(FM*FM-1.0) - E = E - ALX*X**(-0.001) - IF (E*ABS(AEPS).GT.EPS) GO TO 50 -C - GAMIC = R9GMIC (A, X, ALX) - RETURN -C - 50 CALL ALGAMS (A+1.0, ALGAP1, SGNGAM) - GSTAR = R9GMIT (A, X, ALGAP1, SGNGAM, ALX) - IF (GSTAR.EQ.0.0) IZERO = 1 - IF (GSTAR.NE.0.0) ALNGS = LOG (ABS(GSTAR)) - IF (GSTAR.NE.0.0) SGNGS = SIGN (1.0, GSTAR) - GO TO 70 -C - 60 IF (A.LT.X) GAMIC = EXP (R9LGIC(A, X, ALX)) - IF (A.LT.X) RETURN -C - SGNGAM = 1.0 - ALGAP1 = ALNGAM (A+1.0) - SGNGS = 1.0 - ALNGS = R9LGIT (A, X, ALGAP1) -C -C EVALUATION OF GAMIC(A,X) IN TERMS OF TRICOMI-S INCOMPLETE GAMMA FN. -C - 70 H = 1.0 - IF (IZERO.EQ.1) GO TO 80 -C - T = A*ALX + ALNGS - IF (T.GT.ALNEPS) GO TO 90 - IF (T.GT.(-ALNEPS)) H = 1.0 - SGNGS*EXP(T) -C - IF (ABS(H).LT.SQEPS) CALL XERCLR - IF (ABS(H) .LT. SQEPS) CALL XERMSG ('SLATEC', 'GAMIC', - + 'RESULT LT HALF PRECISION', 1, 1) -C - 80 SGNG = SIGN (1.0, H) * SGA * SGNGAM - T = LOG(ABS(H)) + ALGAP1 - LOG(ABS(A)) - IF (T.LT.BOT) CALL XERCLR - GAMIC = SGNG * EXP(T) - RETURN -C - 90 SGNG = -SGNGS * SGA * SGNGAM - T = T + ALGAP1 - LOG(ABS(A)) - IF (T.LT.BOT) CALL XERCLR - GAMIC = SGNG * EXP(T) - RETURN -C - END diff --git a/slatec/gamit.f b/slatec/gamit.f deleted file mode 100644 index 451cf0b..0000000 --- a/slatec/gamit.f +++ /dev/null @@ -1,112 +0,0 @@ -*DECK GAMIT - REAL FUNCTION GAMIT (A, X) -C***BEGIN PROLOGUE GAMIT -C***PURPOSE Calculate Tricomi's form of the incomplete Gamma function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE SINGLE PRECISION (GAMIT-S, DGAMIT-D) -C***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, -C SPECIAL FUNCTIONS, TRICOMI -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate Tricomi's incomplete gamma function defined by -C -C GAMIT = X**(-A)/GAMMA(A) * integral from 0 to X of EXP(-T) * -C T**(A-1.) -C -C for A .GT. 0.0 and by analytic continuation for A .LE. 0.0. -C GAMMA(X) is the complete gamma function of X. -C -C GAMIT is evaluated for arbitrary real values of A and for non- -C negative values of X (even though GAMIT is defined for X .LT. -C 0.0), except that for X = 0 and A .LE. 0.0, GAMIT is infinite, -C which is a fatal error. -C -C The function and both arguments are REAL. -C -C A slight deterioration of 2 or 3 digits accuracy will occur when -C GAMIT is very large or very small in absolute value, because log- -C arithmic variables are used. Also, if the parameter A is very -C close to a negative integer (but not a negative integer), there is -C a loss of accuracy, which is reported if the result is less than -C half machine precision. -C -C***REFERENCES W. Gautschi, A computational procedure for incomplete -C gamma functions, ACM Transactions on Mathematical -C Software 5, 4 (December 1979), pp. 466-481. -C W. Gautschi, Incomplete gamma functions, Algorithm 542, -C ACM Transactions on Mathematical Software 5, 4 -C (December 1979), pp. 482-489. -C***ROUTINES CALLED ALGAMS, ALNGAM, GAMR, R1MACH, R9GMIT, R9LGIC, -C R9LGIT, XERCLR, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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 920528 DESCRIPTION and REFERENCES sections revised. (WRB) -C***END PROLOGUE GAMIT - LOGICAL FIRST - SAVE ALNEPS, SQEPS, BOT, FIRST - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT GAMIT - IF (FIRST) THEN - ALNEPS = -LOG(R1MACH(3)) - SQEPS = SQRT(R1MACH(4)) - BOT = LOG(R1MACH(1)) - ENDIF - FIRST = .FALSE. -C - IF (X .LT. 0.0) CALL XERMSG ('SLATEC', 'GAMIT', 'X IS NEGATIVE', - + 2, 2) -C - IF (X.NE.0.0) ALX = LOG(X) - SGA = 1.0 - IF (A.NE.0.0) SGA = SIGN (1.0, A) - AINTA = AINT (A+0.5*SGA) - AEPS = A - AINTA -C - IF (X.GT.0.0) GO TO 20 - GAMIT = 0.0 - IF (AINTA.GT.0.0 .OR. AEPS.NE.0.0) GAMIT = GAMR(A+1.0) - RETURN -C - 20 IF (X.GT.1.0) GO TO 40 - IF (A.GE.(-0.5) .OR. AEPS.NE.0.0) CALL ALGAMS (A+1.0, ALGAP1, - 1 SGNGAM) - GAMIT = R9GMIT (A, X, ALGAP1, SGNGAM, ALX) - RETURN -C - 40 IF (A.LT.X) GO TO 50 - T = R9LGIT (A, X, ALNGAM(A+1.0)) - IF (T.LT.BOT) CALL XERCLR - GAMIT = EXP(T) - RETURN -C - 50 ALNG = R9LGIC (A, X, ALX) -C -C EVALUATE GAMIT IN TERMS OF LOG(GAMIC(A,X)) -C - H = 1.0 - IF (AEPS.EQ.0.0 .AND. AINTA.LE.0.0) GO TO 60 - CALL ALGAMS (A+1.0, ALGAP1, SGNGAM) - T = LOG(ABS(A)) + ALNG - ALGAP1 - IF (T.GT.ALNEPS) GO TO 70 - IF (T.GT.(-ALNEPS)) H = 1.0 - SGA*SGNGAM*EXP(T) - IF (ABS(H).GT.SQEPS) GO TO 60 - CALL XERCLR - CALL XERMSG ('SLATEC', 'GAMIT', 'RESULT LT HALF PRECISION', 1, 1) -C - 60 T = -A*ALX + LOG(ABS(H)) - IF (T.LT.BOT) CALL XERCLR - GAMIT = SIGN (EXP(T), H) - RETURN -C - 70 T = T - A*ALX - IF (T.LT.BOT) CALL XERCLR - GAMIT = -SGA*SGNGAM*EXP(T) - RETURN -C - END diff --git a/slatec/gamlim.f b/slatec/gamlim.f deleted file mode 100644 index 2b7ef10..0000000 --- a/slatec/gamlim.f +++ /dev/null @@ -1,61 +0,0 @@ -*DECK GAMLIM - SUBROUTINE GAMLIM (XMIN, XMAX) -C***BEGIN PROLOGUE GAMLIM -C***PURPOSE Compute the minimum and maximum bounds for the argument in -C the Gamma function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7A, R2 -C***TYPE SINGLE PRECISION (GAMLIM-S, DGAMLM-D) -C***KEYWORDS COMPLETE GAMMA FUNCTION, FNLIB, LIMITS, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Calculate the minimum and maximum legal bounds for X in GAMMA(X). -C XMIN and XMAX are not the only bounds, but they are the only non- -C trivial ones to calculate. -C -C Output Arguments -- -C XMIN minimum legal value of X in GAMMA(X). Any smaller value of -C X might result in underflow. -C XMAX maximum legal value of X in GAMMA(X). Any larger value will -C cause overflow. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 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***END PROLOGUE GAMLIM -C***FIRST EXECUTABLE STATEMENT GAMLIM - ALNSML = LOG(R1MACH(1)) - XMIN = -ALNSML - DO 10 I=1,10 - XOLD = XMIN - XLN = LOG(XMIN) - XMIN = XMIN - XMIN*((XMIN+0.5)*XLN - XMIN - 0.2258 + ALNSML) - 1 / (XMIN*XLN + 0.5) - IF (ABS(XMIN-XOLD).LT.0.005) GO TO 20 - 10 CONTINUE - CALL XERMSG ('SLATEC', 'GAMLIM', 'UNABLE TO FIND XMIN', 1, 2) -C - 20 XMIN = -XMIN + 0.01 -C - ALNBIG = LOG(R1MACH(2)) - XMAX = ALNBIG - DO 30 I=1,10 - XOLD = XMAX - XLN = LOG(XMAX) - XMAX = XMAX - XMAX*((XMAX-0.5)*XLN - XMAX + 0.9189 - ALNBIG) - 1 / (XMAX*XLN - 0.5) - IF (ABS(XMAX-XOLD).LT.0.005) GO TO 40 - 30 CONTINUE - CALL XERMSG ('SLATEC', 'GAMLIM', 'UNABLE TO FIND XMAX', 2, 2) -C - 40 XMAX = XMAX - 0.01 - XMIN = MAX (XMIN, -XMAX+1.) -C - RETURN - END diff --git a/slatec/gamln.f b/slatec/gamln.f deleted file mode 100644 index 5bedd42..0000000 --- a/slatec/gamln.f +++ /dev/null @@ -1,198 +0,0 @@ -*DECK GAMLN - REAL FUNCTION GAMLN (Z, IERR) -C***BEGIN PROLOGUE GAMLN -C***SUBSIDIARY -C***PURPOSE Compute the logarithm of the Gamma function -C***LIBRARY SLATEC -C***CATEGORY C7A -C***TYPE SINGLE PRECISION (GAMLN-S, DGAMLN-D) -C***KEYWORDS LOGARITHM OF GAMMA FUNCTION -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C GAMLN COMPUTES THE NATURAL LOG OF THE GAMMA FUNCTION FOR -C Z.GT.0. THE ASYMPTOTIC EXPANSION IS USED TO GENERATE VALUES -C GREATER THAN ZMIN WHICH ARE ADJUSTED BY THE RECURSION -C G(Z+1)=Z*G(Z) FOR Z.LE.ZMIN. THE FUNCTION WAS MADE AS -C PORTABLE AS POSSIBLE BY COMPUTING ZMIN FROM THE NUMBER OF BASE -C 10 DIGITS IN A WORD, RLN=MAX(-ALOG10(R1MACH(4)),0.5E-18) -C LIMITED TO 18 DIGITS OF (RELATIVE) ACCURACY. -C -C SINCE INTEGER ARGUMENTS ARE COMMON, A TABLE LOOK UP ON 100 -C VALUES IS USED FOR SPEED OF EXECUTION. -C -C DESCRIPTION OF ARGUMENTS -C -C INPUT -C Z - REAL ARGUMENT, Z.GT.0.0E0 -C -C OUTPUT -C GAMLN - NATURAL LOG OF THE GAMMA FUNCTION AT Z -C IERR - ERROR FLAG -C IERR=0, NORMAL RETURN, COMPUTATION COMPLETED -C IERR=1, Z.LE.0.0E0, NO COMPUTATION -C -C***REFERENCES COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT -C BY D. E. AMOS, SAND83-0083, MAY, 1983. -C***ROUTINES CALLED I1MACH, R1MACH -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 830501 REVISION DATE from Version 3.2 -C 910415 Prologue converted to Version 4.0 format. (BAB) -C 920128 Category corrected. (WRB) -C 921215 GAMLN defined for Z negative. (WRB) -C***END PROLOGUE GAMLN -C - INTEGER I, I1M, K, MZ, NZ, IERR, I1MACH - REAL CF, CON, FLN, FZ, GLN, RLN, S, TLG, TRM, TST, T1, WDTOL, Z, - * ZDMY, ZINC, ZM, ZMIN, ZP, ZSQ - REAL R1MACH - DIMENSION CF(22), GLN(100) -C LNGAMMA(N), N=1,100 - DATA GLN(1), GLN(2), GLN(3), GLN(4), GLN(5), GLN(6), GLN(7), - 1 GLN(8), GLN(9), GLN(10), GLN(11), GLN(12), GLN(13), GLN(14), - 2 GLN(15), GLN(16), GLN(17), GLN(18), GLN(19), GLN(20), - 3 GLN(21), GLN(22)/ - 4 0.00000000000000000E+00, 0.00000000000000000E+00, - 5 6.93147180559945309E-01, 1.79175946922805500E+00, - 6 3.17805383034794562E+00, 4.78749174278204599E+00, - 7 6.57925121201010100E+00, 8.52516136106541430E+00, - 8 1.06046029027452502E+01, 1.28018274800814696E+01, - 9 1.51044125730755153E+01, 1.75023078458738858E+01, - A 1.99872144956618861E+01, 2.25521638531234229E+01, - B 2.51912211827386815E+01, 2.78992713838408916E+01, - C 3.06718601060806728E+01, 3.35050734501368889E+01, - D 3.63954452080330536E+01, 3.93398841871994940E+01, - E 4.23356164607534850E+01, 4.53801388984769080E+01/ - DATA GLN(23), GLN(24), GLN(25), GLN(26), GLN(27), GLN(28), - 1 GLN(29), GLN(30), GLN(31), GLN(32), GLN(33), GLN(34), - 2 GLN(35), GLN(36), GLN(37), GLN(38), GLN(39), GLN(40), - 3 GLN(41), GLN(42), GLN(43), GLN(44)/ - 4 4.84711813518352239E+01, 5.16066755677643736E+01, - 5 5.47847293981123192E+01, 5.80036052229805199E+01, - 6 6.12617017610020020E+01, 6.45575386270063311E+01, - 7 6.78897431371815350E+01, 7.12570389671680090E+01, - 8 7.46582363488301644E+01, 7.80922235533153106E+01, - 9 8.15579594561150372E+01, 8.50544670175815174E+01, - A 8.85808275421976788E+01, 9.21361756036870925E+01, - B 9.57196945421432025E+01, 9.93306124547874269E+01, - C 1.02968198614513813E+02, 1.06631760260643459E+02, - D 1.10320639714757395E+02, 1.14034211781461703E+02, - E 1.17771881399745072E+02, 1.21533081515438634E+02/ - DATA GLN(45), GLN(46), GLN(47), GLN(48), GLN(49), GLN(50), - 1 GLN(51), GLN(52), GLN(53), GLN(54), GLN(55), GLN(56), - 2 GLN(57), GLN(58), GLN(59), GLN(60), GLN(61), GLN(62), - 3 GLN(63), GLN(64), GLN(65), GLN(66)/ - 4 1.25317271149356895E+02, 1.29123933639127215E+02, - 5 1.32952575035616310E+02, 1.36802722637326368E+02, - 6 1.40673923648234259E+02, 1.44565743946344886E+02, - 7 1.48477766951773032E+02, 1.52409592584497358E+02, - 8 1.56360836303078785E+02, 1.60331128216630907E+02, - 9 1.64320112263195181E+02, 1.68327445448427652E+02, - A 1.72352797139162802E+02, 1.76395848406997352E+02, - B 1.80456291417543771E+02, 1.84533828861449491E+02, - C 1.88628173423671591E+02, 1.92739047287844902E+02, - D 1.96866181672889994E+02, 2.01009316399281527E+02, - E 2.05168199482641199E+02, 2.09342586752536836E+02/ - DATA GLN(67), GLN(68), GLN(69), GLN(70), GLN(71), GLN(72), - 1 GLN(73), GLN(74), GLN(75), GLN(76), GLN(77), GLN(78), - 2 GLN(79), GLN(80), GLN(81), GLN(82), GLN(83), GLN(84), - 3 GLN(85), GLN(86), GLN(87), GLN(88)/ - 4 2.13532241494563261E+02, 2.17736934113954227E+02, - 5 2.21956441819130334E+02, 2.26190548323727593E+02, - 6 2.30439043565776952E+02, 2.34701723442818268E+02, - 7 2.38978389561834323E+02, 2.43268849002982714E+02, - 8 2.47572914096186884E+02, 2.51890402209723194E+02, - 9 2.56221135550009525E+02, 2.60564940971863209E+02, - A 2.64921649798552801E+02, 2.69291097651019823E+02, - B 2.73673124285693704E+02, 2.78067573440366143E+02, - C 2.82474292687630396E+02, 2.86893133295426994E+02, - D 2.91323950094270308E+02, 2.95766601350760624E+02, - E 3.00220948647014132E+02, 3.04686856765668715E+02/ - DATA GLN(89), GLN(90), GLN(91), GLN(92), GLN(93), GLN(94), - 1 GLN(95), GLN(96), GLN(97), GLN(98), GLN(99), GLN(100)/ - 2 3.09164193580146922E+02, 3.13652829949879062E+02, - 3 3.18152639620209327E+02, 3.22663499126726177E+02, - 4 3.27185287703775217E+02, 3.31717887196928473E+02, - 5 3.36261181979198477E+02, 3.40815058870799018E+02, - 6 3.45379407062266854E+02, 3.49954118040770237E+02, - 7 3.54539085519440809E+02, 3.59134205369575399E+02/ -C COEFFICIENTS OF ASYMPTOTIC EXPANSION - DATA CF(1), CF(2), CF(3), CF(4), CF(5), CF(6), CF(7), CF(8), - 1 CF(9), CF(10), CF(11), CF(12), CF(13), CF(14), CF(15), - 2 CF(16), CF(17), CF(18), CF(19), CF(20), CF(21), CF(22)/ - 3 8.33333333333333333E-02, -2.77777777777777778E-03, - 4 7.93650793650793651E-04, -5.95238095238095238E-04, - 5 8.41750841750841751E-04, -1.91752691752691753E-03, - 6 6.41025641025641026E-03, -2.95506535947712418E-02, - 7 1.79644372368830573E-01, -1.39243221690590112E+00, - 8 1.34028640441683920E+01, -1.56848284626002017E+02, - 9 2.19310333333333333E+03, -3.61087712537249894E+04, - A 6.91472268851313067E+05, -1.52382215394074162E+07, - B 3.82900751391414141E+08, -1.08822660357843911E+10, - C 3.47320283765002252E+11, -1.23696021422692745E+13, - D 4.88788064793079335E+14, -2.13203339609193739E+16/ -C -C LN(2*PI) - DATA CON / 1.83787706640934548E+00/ -C -C***FIRST EXECUTABLE STATEMENT GAMLN - IERR=0 - IF (Z.LE.0.0E0) GO TO 70 - IF (Z.GT.101.0E0) GO TO 10 - NZ = Z - FZ = Z - NZ - IF (FZ.GT.0.0E0) GO TO 10 - IF (NZ.GT.100) GO TO 10 - GAMLN = GLN(NZ) - RETURN - 10 CONTINUE - WDTOL = R1MACH(4) - WDTOL = MAX(WDTOL,0.5E-18) - I1M = I1MACH(11) - RLN = R1MACH(5)*I1M - FLN = MIN(RLN,20.0E0) - FLN = MAX(FLN,3.0E0) - FLN = FLN - 3.0E0 - ZM = 1.8000E0 + 0.3875E0*FLN - MZ = ZM + 1 - ZMIN = MZ - ZDMY = Z - ZINC = 0.0E0 - IF (Z.GE.ZMIN) GO TO 20 - ZINC = ZMIN - NZ - ZDMY = Z + ZINC - 20 CONTINUE - ZP = 1.0E0/ZDMY - T1 = CF(1)*ZP - S = T1 - IF (ZP.LT.WDTOL) GO TO 40 - ZSQ = ZP*ZP - TST = T1*WDTOL - DO 30 K=2,22 - ZP = ZP*ZSQ - TRM = CF(K)*ZP - IF (ABS(TRM).LT.TST) GO TO 40 - S = S + TRM - 30 CONTINUE - 40 CONTINUE - IF (ZINC.NE.0.0E0) GO TO 50 - TLG = ALOG(Z) - GAMLN = Z*(TLG-1.0E0) + 0.5E0*(CON-TLG) + S - RETURN - 50 CONTINUE - ZP = 1.0E0 - NZ = ZINC - DO 60 I=1,NZ - ZP = ZP*(Z+(I-1)) - 60 CONTINUE - TLG = ALOG(ZDMY) - GAMLN = ZDMY*(TLG-1.0E0) - ALOG(ZP) + 0.5E0*(CON-TLG) + S - RETURN -C -C - 70 CONTINUE - GAMLN = R1MACH(2) - IERR=1 - RETURN - END diff --git a/slatec/gamma.f b/slatec/gamma.f deleted file mode 100644 index afcec90..0000000 --- a/slatec/gamma.f +++ /dev/null @@ -1,138 +0,0 @@ -*DECK GAMMA - FUNCTION GAMMA (X) -C***BEGIN PROLOGUE GAMMA -C***PURPOSE Compute the complete Gamma function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7A -C***TYPE SINGLE PRECISION (GAMMA-S, DGAMMA-D, CGAMMA-C) -C***KEYWORDS COMPLETE GAMMA FUNCTION, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C GAMMA computes the gamma function at X, where X is not 0, -1, -2, .... -C GAMMA and X are single precision. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, GAMLIM, INITS, R1MACH, R9LGMC, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 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***END PROLOGUE GAMMA - DIMENSION GCS(23) - LOGICAL FIRST - SAVE GCS, PI, SQ2PIL, NGCS, XMIN, XMAX, DXREL, FIRST - DATA GCS ( 1) / .0085711955 90989331E0/ - DATA GCS ( 2) / .0044153813 24841007E0/ - DATA GCS ( 3) / .0568504368 1599363E0/ - DATA GCS ( 4) /-.0042198353 96418561E0/ - DATA GCS ( 5) / .0013268081 81212460E0/ - DATA GCS ( 6) /-.0001893024 529798880E0/ - DATA GCS ( 7) / .0000360692 532744124E0/ - DATA GCS ( 8) /-.0000060567 619044608E0/ - DATA GCS ( 9) / .0000010558 295463022E0/ - DATA GCS (10) /-.0000001811 967365542E0/ - DATA GCS (11) / .0000000311 772496471E0/ - DATA GCS (12) /-.0000000053 542196390E0/ - DATA GCS (13) / .0000000009 193275519E0/ - DATA GCS (14) /-.0000000001 577941280E0/ - DATA GCS (15) / .0000000000 270798062E0/ - DATA GCS (16) /-.0000000000 046468186E0/ - DATA GCS (17) / .0000000000 007973350E0/ - DATA GCS (18) /-.0000000000 001368078E0/ - DATA GCS (19) / .0000000000 000234731E0/ - DATA GCS (20) /-.0000000000 000040274E0/ - DATA GCS (21) / .0000000000 000006910E0/ - DATA GCS (22) /-.0000000000 000001185E0/ - DATA GCS (23) / .0000000000 000000203E0/ - DATA PI /3.14159 26535 89793 24E0/ -C SQ2PIL IS LOG (SQRT (2.*PI) ) - DATA SQ2PIL /0.91893 85332 04672 74E0/ - DATA FIRST /.TRUE./ -C -C LANL DEPENDENT CODE REMOVED 81.02.04 -C -C***FIRST EXECUTABLE STATEMENT GAMMA - IF (FIRST) THEN -C -C --------------------------------------------------------------------- -C INITIALIZE. FIND LEGAL BOUNDS FOR X, AND DETERMINE THE NUMBER OF -C TERMS IN THE SERIES REQUIRED TO ATTAIN AN ACCURACY TEN TIMES BETTER -C THAN MACHINE PRECISION. -C - NGCS = INITS (GCS, 23, 0.1*R1MACH(3)) -C - CALL GAMLIM (XMIN, XMAX) - DXREL = SQRT (R1MACH(4)) -C -C --------------------------------------------------------------------- -C FINISH INITIALIZATION. START EVALUATING GAMMA(X). -C - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.10.0) GO TO 50 -C -C COMPUTE GAMMA(X) FOR ABS(X) .LE. 10.0. REDUCE INTERVAL AND -C FIND GAMMA(1+Y) FOR 0. .LE. Y .LT. 1. FIRST OF ALL. -C - N = X - IF (X.LT.0.) N = N - 1 - Y = X - N - N = N - 1 - GAMMA = 0.9375 + CSEVL(2.*Y-1., GCS, NGCS) - IF (N.EQ.0) RETURN -C - IF (N.GT.0) GO TO 30 -C -C COMPUTE GAMMA(X) FOR X .LT. 1. -C - N = -N - IF (X .EQ. 0.) CALL XERMSG ('SLATEC', 'GAMMA', 'X IS 0', 4, 2) - IF (X .LT. 0. .AND. X+N-2 .EQ. 0.) CALL XERMSG ('SLATEC', 'GAMMA' - 1, 'X IS A NEGATIVE INTEGER', 4, 2) - IF (X .LT. (-0.5) .AND. ABS((X-AINT(X-0.5))/X) .LT. DXREL) CALL - 1XERMSG ( 'SLATEC', 'GAMMA', - 2'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER' - 3, 1, 1) -C - DO 20 I=1,N - GAMMA = GAMMA / (X+I-1) - 20 CONTINUE - RETURN -C -C GAMMA(X) FOR X .GE. 2. -C - 30 DO 40 I=1,N - GAMMA = (Y+I)*GAMMA - 40 CONTINUE - RETURN -C -C COMPUTE GAMMA(X) FOR ABS(X) .GT. 10.0. RECALL Y = ABS(X). -C - 50 IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'GAMMA', - + 'X SO BIG GAMMA OVERFLOWS', 3, 2) -C - GAMMA = 0. - IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'GAMMA', - + 'X SO SMALL GAMMA UNDERFLOWS', 2, 1) - IF (X.LT.XMIN) RETURN -C - GAMMA = EXP((Y-0.5)*LOG(Y) - Y + SQ2PIL + R9LGMC(Y) ) - IF (X.GT.0.) RETURN -C - IF (ABS((X-AINT(X-0.5))/X) .LT. DXREL) CALL XERMSG ('SLATEC', - + 'GAMMA', - + 'ANSWER LT HALF PRECISION, X TOO NEAR NEGATIVE INTEGER', 1, 1) -C - SINPIY = SIN (PI*Y) - IF (SINPIY .EQ. 0.) CALL XERMSG ('SLATEC', 'GAMMA', - + 'X IS A NEGATIVE INTEGER', 4, 2) -C - GAMMA = -PI / (Y*SINPIY*GAMMA) -C - RETURN - END diff --git a/slatec/gamr.f b/slatec/gamr.f deleted file mode 100644 index 8a7d50d..0000000 --- a/slatec/gamr.f +++ /dev/null @@ -1,42 +0,0 @@ -*DECK GAMR - FUNCTION GAMR (X) -C***BEGIN PROLOGUE GAMR -C***PURPOSE Compute the reciprocal of the Gamma function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7A -C***TYPE SINGLE PRECISION (GAMR-S, DGAMR-D, CGAMR-C) -C***KEYWORDS FNLIB, RECIPROCAL GAMMA FUNCTION, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C GAMR is a single precision function that evaluates the reciprocal -C of the gamma function for single precision argument X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED ALGAMS, GAMMA, XERCLR, XGETF, XSETF -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900727 Added EXTERNAL statement. (WRB) -C***END PROLOGUE GAMR - EXTERNAL GAMMA -C***FIRST EXECUTABLE STATEMENT GAMR - GAMR = 0.0 - IF (X.LE.0.0 .AND. AINT(X).EQ.X) RETURN -C - CALL XGETF (IROLD) - CALL XSETF (1) - IF (ABS(X).GT.10.0) GO TO 10 - GAMR = 1.0/GAMMA(X) - CALL XERCLR - CALL XSETF (IROLD) - RETURN -C - 10 CALL ALGAMS (X, ALNGX, SGNGX) - CALL XERCLR - CALL XSETF (IROLD) - GAMR = SGNGX * EXP(-ALNGX) - RETURN -C - END diff --git a/slatec/gamrn.f b/slatec/gamrn.f deleted file mode 100644 index fb00a8b..0000000 --- a/slatec/gamrn.f +++ /dev/null @@ -1,105 +0,0 @@ -*DECK GAMRN - REAL FUNCTION GAMRN (X) -C***BEGIN PROLOGUE GAMRN -C***SUBSIDIARY -C***PURPOSE Subsidiary to BSKIN -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (GAMRN-S, DGAMRN-D) -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C GAMRN computes the GAMMA function ratio GAMMA(X)/GAMMA(X+0.5) -C for real X.gt.0. If X.ge.XMIN, an asymptotic expansion is -C evaluated. If X.lt.XMIN, an integer is added to X to form a -C new value of X.ge.XMIN and the asymptotic expansion is eval- -C uated for this new value of X. Successive application of the -C recurrence relation -C -C W(X)=W(X+1)*(1+0.5/X) -C -C reduces the argument to its original value. XMIN and comp- -C utational tolerances are computed as a function of the number -C of digits carried in a word by calls to I1MACH and R1MACH. -C However, the computational accuracy is limited to the max- -C imum of unit roundoff (=R1MACH(4)) and 1.0E-18 since critical -C constants are given to only 18 digits. -C -C Input -C X - Argument, X.gt.0.0 -C -C OUTPUT -C GAMRN - Ratio GAMMA(X)/GAMMA(X+0.5) -C -C***SEE ALSO BSKIN -C***REFERENCES Y. L. Luke, The Special Functions and Their -C Approximations, Vol. 1, Math In Sci. And -C Eng. Series 53, Academic Press, New York, 1969, -C pp. 34-35. -C***ROUTINES CALLED I1MACH, R1MACH -C***REVISION HISTORY (YYMMDD) -C 820601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C 920520 Added REFERENCES section. (WRB) -C***END PROLOGUE GAMRN - INTEGER I, I1M11, K, MX, NX - INTEGER I1MACH - REAL FLN, GR, RLN, S, TOL, TRM, X, XDMY, XINC, XM, XMIN, XP, XSQ - REAL R1MACH - DIMENSION GR(12) - SAVE GR -C - DATA GR(1), GR(2), GR(3), GR(4), GR(5), GR(6), GR(7), GR(8), - * GR(9), GR(10), GR(11), GR(12) /1.00000000000000000E+00, - * -1.56250000000000000E-02,2.56347656250000000E-03, - * -1.27983093261718750E-03,1.34351104497909546E-03, - * -2.43289663922041655E-03,6.75423753364157164E-03, - * -2.66369606131178216E-02,1.41527455519564332E-01, - * -9.74384543032201613E-01,8.43686251229783675E+00, - * -8.97258321640552515E+01/ -C -C***FIRST EXECUTABLE STATEMENT GAMRN - NX = INT(X) - TOL = MAX(R1MACH(4),1.0E-18) - I1M11 = I1MACH(11) - RLN = R1MACH(5)*I1M11 - FLN = MIN(RLN,20.0E0) - FLN = MAX(FLN,3.0E0) - FLN = FLN - 3.0E0 - XM = 2.0E0 + FLN*(0.2366E0+0.01723E0*FLN) - MX = INT(XM) + 1 - XMIN = MX - XDMY = X - 0.25E0 - XINC = 0.0E0 - IF (X.GE.XMIN) GO TO 10 - XINC = XMIN - NX - XDMY = XDMY + XINC - 10 CONTINUE - S = 1.0E0 - IF (XDMY*TOL.GT.1.0E0) GO TO 30 - XSQ = 1.0E0/(XDMY*XDMY) - XP = XSQ - DO 20 K=2,12 - TRM = GR(K)*XP - IF (ABS(TRM).LT.TOL) GO TO 30 - S = S + TRM - XP = XP*XSQ - 20 CONTINUE - 30 CONTINUE - S = S/SQRT(XDMY) - IF (XINC.NE.0.0E0) GO TO 40 - GAMRN = S - RETURN - 40 CONTINUE - NX = INT(XINC) - XP = 0.0E0 - DO 50 I=1,NX - S = S*(1.0E0+0.5E0/(X+XP)) - XP = XP + 1.0E0 - 50 CONTINUE - GAMRN = S - RETURN - END diff --git a/slatec/gaus8.f b/slatec/gaus8.f deleted file mode 100644 index 3e338fd..0000000 --- a/slatec/gaus8.f +++ /dev/null @@ -1,195 +0,0 @@ -*DECK GAUS8 - SUBROUTINE GAUS8 (FUN, A, B, ERR, ANS, IERR) -C***BEGIN PROLOGUE GAUS8 -C***PURPOSE Integrate a real function of one variable over a finite -C interval using an adaptive 8-point Legendre-Gauss -C algorithm. Intended primarily for high accuracy -C integration or integration of smooth functions. -C***LIBRARY SLATEC -C***CATEGORY H2A1A1 -C***TYPE SINGLE PRECISION (GAUS8-S, DGAUS8-D) -C***KEYWORDS ADAPTIVE QUADRATURE, AUTOMATIC INTEGRATOR, -C GAUSS QUADRATURE, NUMERICAL INTEGRATION -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C GAUS8 integrates real functions of one variable over finite -C intervals using an adaptive 8-point Legendre-Gauss algorithm. -C GAUS8 is intended primarily for high accuracy integration -C or integration of smooth functions. -C -C Description of Arguments -C -C Input-- -C FUN - name of external function to be integrated. This name -C must be in an EXTERNAL statement in the calling program. -C FUN must be a REAL function of one REAL argument. The -C value of the argument to FUN is the variable of -C integration which ranges from A to B. -C A - lower limit of integration -C B - upper limit of integration (may be less than A) -C ERR - is a requested pseudorelative error tolerance. Normally -C pick a value of ABS(ERR) so that STOL .LT. ABS(ERR) .LE. -C 1.0E-3 where STOL is the single precision unit roundoff -C R1MACH(4). ANS will normally have no more error than -C ABS(ERR) times the integral of the absolute value of -C FUN(X). Usually, smaller values for ERR yield more -C accuracy and require more function evaluations. -C -C A negative value for ERR causes an estimate of the -C absolute error in ANS to be returned in ERR. Note that -C ERR must be a variable (not a constant) in this case. -C Note also that the user must reset the value of ERR -C before making any more calls that use the variable ERR. -C -C Output-- -C ERR - will be an estimate of the absolute error in ANS if the -C input value of ERR was negative. (ERR is unchanged if -C the input value of ERR was non-negative.) The estimated -C error is solely for information to the user and should -C not be used as a correction to the computed integral. -C ANS - computed value of integral -C IERR- a status code -C --Normal codes -C 1 ANS most likely meets requested error tolerance, -C or A=B. -C -1 A and B are too nearly equal to allow normal -C integration. ANS is set to zero. -C --Abnormal code -C 2 ANS probably does not meet requested error tolerance. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED I1MACH, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 810223 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE GAUS8 - INTEGER IERR, K, KML, KMX, L, LMN, LMX, LR, MXL, NBITS, - 1 NIB, NLMN, NLMX - INTEGER I1MACH - REAL A, AA, AE, ANIB, ANS, AREA, B, C, CE, EE, EF, EPS, ERR, EST, - 1 GL, GLR, GR, HH, SQ2, TOL, VL, VR, W1, W2, W3, W4, X1, X2, X3, - 2 X4, X, H - REAL R1MACH, G8, FUN - DIMENSION AA(30), HH(30), LR(30), VL(30), GR(30) - SAVE X1, X2, X3, X4, W1, W2, W3, W4, SQ2, - 1 NLMN, KMX, KML - DATA X1, X2, X3, X4/ - 1 1.83434642495649805E-01, 5.25532409916328986E-01, - 2 7.96666477413626740E-01, 9.60289856497536232E-01/ - DATA W1, W2, W3, W4/ - 1 3.62683783378361983E-01, 3.13706645877887287E-01, - 2 2.22381034453374471E-01, 1.01228536290376259E-01/ - DATA SQ2/1.41421356E0/ - DATA NLMN/1/,KMX/5000/,KML/6/ - G8(X,H)=H*((W1*(FUN(X-X1*H) + FUN(X+X1*H)) - 1 +W2*(FUN(X-X2*H) + FUN(X+X2*H))) - 2 +(W3*(FUN(X-X3*H) + FUN(X+X3*H)) - 3 +W4*(FUN(X-X4*H) + FUN(X+X4*H)))) -C***FIRST EXECUTABLE STATEMENT GAUS8 -C -C Initialize -C - K = I1MACH(11) - ANIB = R1MACH(5)*K/0.30102000E0 - NBITS = ANIB - NLMX = MIN(30,(NBITS*5)/8) - ANS = 0.0E0 - IERR = 1 - CE = 0.0E0 - IF (A .EQ. B) GO TO 140 - LMX = NLMX - LMN = NLMN - IF (B .EQ. 0.0E0) GO TO 10 - IF (SIGN(1.0E0,B)*A .LE. 0.0E0) GO TO 10 - C = ABS(1.0E0-A/B) - IF (C .GT. 0.1E0) GO TO 10 - IF (C .LE. 0.0E0) GO TO 140 - ANIB = 0.5E0 - LOG(C)/0.69314718E0 - NIB = ANIB - LMX = MIN(NLMX,NBITS-NIB-7) - IF (LMX .LT. 1) GO TO 130 - LMN = MIN(LMN,LMX) - 10 TOL = MAX(ABS(ERR),2.0E0**(5-NBITS))/2.0E0 - IF (ERR .EQ. 0.0E0) TOL = SQRT(R1MACH(4)) - EPS = TOL - HH(1) = (B-A)/4.0E0 - AA(1) = A - LR(1) = 1 - L = 1 - EST = G8(AA(L)+2.0E0*HH(L),2.0E0*HH(L)) - K = 8 - AREA = ABS(EST) - EF = 0.5E0 - MXL = 0 -C -C Compute refined estimates, estimate the error, etc. -C - 20 GL = G8(AA(L)+HH(L),HH(L)) - GR(L) = G8(AA(L)+3.0E0*HH(L),HH(L)) - K = K + 16 - AREA = AREA + (ABS(GL)+ABS(GR(L))-ABS(EST)) -C IF (L .LT. LMN) GO TO 11 - GLR = GL + GR(L) - EE = ABS(EST-GLR)*EF - AE = MAX(EPS*AREA,TOL*ABS(GLR)) - IF (EE-AE) 40, 40, 50 - 30 MXL = 1 - 40 CE = CE + (EST-GLR) - IF (LR(L)) 60, 60, 80 -C -C Consider the left half of this level -C - 50 IF (K .GT. KMX) LMX = KML - IF (L .GE. LMX) GO TO 30 - L = L + 1 - EPS = EPS*0.5E0 - EF = EF/SQ2 - HH(L) = HH(L-1)*0.5E0 - LR(L) = -1 - AA(L) = AA(L-1) - EST = GL - GO TO 20 -C -C Proceed to right half at this level -C - 60 VL(L) = GLR - 70 EST = GR(L-1) - LR(L) = 1 - AA(L) = AA(L) + 4.0E0*HH(L) - GO TO 20 -C -C Return one level -C - 80 VR = GLR - 90 IF (L .LE. 1) GO TO 120 - L = L - 1 - EPS = EPS*2.0E0 - EF = EF*SQ2 - IF (LR(L)) 100, 100, 110 - 100 VL(L) = VL(L+1) + VR - GO TO 70 - 110 VR = VL(L+1) + VR - GO TO 90 -C -C Exit -C - 120 ANS = VR - IF ((MXL.EQ.0) .OR. (ABS(CE).LE.2.0E0*TOL*AREA)) GO TO 140 - IERR = 2 - CALL XERMSG ('SLATEC', 'GAUS8', - + 'ANS is probably insufficiently accurate.', 3, 1) - GO TO 140 - 130 IERR = -1 - CALL XERMSG ('SLATEC', 'GAUS8', - + 'A and B are too nearly equal to allow normal integration. $$' - + // 'ANS is set to zero and IERR to -1.', 1, -1) - 140 IF (ERR .LT. 0.0E0) ERR = CE - RETURN - END diff --git a/slatec/genbun.f b/slatec/genbun.f deleted file mode 100644 index 0e56d35..0000000 --- a/slatec/genbun.f +++ /dev/null @@ -1,368 +0,0 @@ -*DECK GENBUN - SUBROUTINE GENBUN (NPEROD, N, MPEROD, M, A, B, C, IDIMY, Y, - + IERROR, W) -C***BEGIN PROLOGUE GENBUN -C***PURPOSE Solve by a cyclic reduction algorithm the linear system -C of equations that results from a finite difference -C approximation to certain 2-d elliptic PDE's on a centered -C grid . -C***LIBRARY SLATEC (FISHPACK) -C***CATEGORY I2B4B -C***TYPE SINGLE PRECISION (GENBUN-S, CMGNBN-C) -C***KEYWORDS ELLIPTIC, FISHPACK, PDE, TRIDIAGONAL -C***AUTHOR Adams, J., (NCAR) -C Swarztrauber, P. N., (NCAR) -C Sweet, R., (NCAR) -C***DESCRIPTION -C -C Subroutine GENBUN solves the linear system of equations -C -C A(I)*X(I-1,J) + B(I)*X(I,J) + C(I)*X(I+1,J) -C -C + X(I,J-1) - 2.*X(I,J) + X(I,J+1) = Y(I,J) -C -C for I = 1,2,...,M and J = 1,2,...,N. -C -C The indices I+1 and I-1 are evaluated modulo M, i.e., -C X(0,J) = X(M,J) and X(M+1,J) = X(1,J), and X(I,0) may be equal to -C 0, X(I,2), or X(I,N) and X(I,N+1) may be equal to 0, X(I,N-1), or -C X(I,1) depending on an input parameter. -C -C -C * * * * * * * * Parameter Description * * * * * * * * * * -C -C * * * * * * On Input * * * * * * -C -C NPEROD -C Indicates the values that X(I,0) and X(I,N+1) are assumed to -C have. -C -C = 0 If X(I,0) = X(I,N) and X(I,N+1) = X(I,1). -C = 1 If X(I,0) = X(I,N+1) = 0 . -C = 2 If X(I,0) = 0 and X(I,N+1) = X(I,N-1). -C = 3 If X(I,0) = X(I,2) and X(I,N+1) = X(I,N-1). -C = 4 If X(I,0) = X(I,2) and X(I,N+1) = 0. -C -C N -C The number of unknowns in the J-direction. N must be greater -C than 2. -C -C MPEROD -C = 0 if A(1) and C(M) are not zero. -C = 1 if A(1) = C(M) = 0. -C -C M -C The number of unknowns in the I-direction. M must be greater -C than 2. -C -C A,B,C -C One-dimensional arrays of length M that specify the -C coefficients in the linear equations given above. If MPEROD = 0 -C the array elements must not depend upon the index I, but must be -C constant. Specifically, the subroutine checks the following -C condition -C -C A(I) = C(1) -C C(I) = C(1) -C B(I) = B(1) -C -C for I=1,2,...,M. -C -C IDIMY -C The row (or first) dimension of the two-dimensional array Y as -C it appears in the program calling GENBUN. This parameter is -C used to specify the variable dimension of Y. IDIMY must be at -C least M. -C -C Y -C A two-dimensional array that specifies the values of the right -C side of the linear system of equations given above. Y must be -C dimensioned at least M*N. -C -C W -C A one-dimensional array that must be provided by the user for -C work space. W may require up to 4*N + (10 + INT(log2(N)))*M -C locations. The actual number of locations used is computed by -C GENBUN and is returned in location W(1). -C -C -C * * * * * * On Output * * * * * * -C -C Y -C Contains the solution X. -C -C IERROR -C An error flag that indicates invalid input parameters. Except -C for number zero, a solution is not attempted. -C -C = 0 No error. -C = 1 M .LE. 2 -C = 2 N .LE. 2 -C = 3 IDIMY .LT. M -C = 4 NPEROD .LT. 0 or NPEROD .GT. 4 -C = 5 MPEROD .LT. 0 or MPEROD .GT. 1 -C = 6 A(I) .NE. C(1) or C(I) .NE. C(1) or B(I) .NE. B(1) for -C some I=1,2,...,M. -C = 7 A(1) .NE. 0 or C(M) .NE. 0 and MPEROD = 1 -C -C W -C W(1) contains the required length of W. -C -C *Long Description: -C -C * * * * * * * Program Specifications * * * * * * * * * * * * -C -C Dimension of A(M),B(M),C(M),Y(IDIMY,N),W(see parameter list) -C Arguments -C -C Latest June 1, 1976 -C Revision -C -C Subprograms GENBUN,POISD2,POISN2,POISP2,COSGEN,MERGE,TRIX,TRI3, -C Required PIMACH -C -C Special NONE -C Conditions -C -C Common NONE -C Blocks -C -C I/O NONE -C -C Precision Single -C -C Specialist Roland Sweet -C -C Language FORTRAN -C -C History Standardized April 1, 1973 -C Revised August 20,1973 -C Revised January 1, 1976 -C -C Algorithm The linear system is solved by a cyclic reduction -C algorithm described in the reference. -C -C Space 4944(decimal) = 11520(octal) locations on the NCAR -C Required Control Data 7600. -C -C Timing and The execution time T on the NCAR Control Data -C Accuracy 7600 for subroutine GENBUN is roughly proportional -C to M*N*log2(N), but also depends on the input -C parameter NPEROD. Some typical values are listed -C in the table below. More comprehensive timing -C charts may be found in the reference. -C To measure the accuracy of the algorithm a -C uniform random number generator was used to create -C a solution array X for the system given in the -C 'PURPOSE' with -C -C A(I) = C(I) = -0.5*B(I) = 1, I=1,2,...,M -C -C and, when MPEROD = 1 -C -C A(1) = C(M) = 0 -C A(M) = C(1) = 2. -C -C The solution X was substituted into the given sys- -C tem and, using double precision, a right side Y was -C computed. Using this array Y subroutine GENBUN was -C called to produce an approximate solution Z. Then -C the relative error, defined as -C -C E = MAX(ABS(Z(I,J)-X(I,J)))/MAX(ABS(X(I,J))) -C -C where the two maxima are taken over all I=1,2,...,M -C and J=1,2,...,N, was computed. The value of E is -C given in the table below for some typical values of -C M and N. -C -C -C M (=N) MPEROD NPEROD T(MSECS) E -C ------ ------ ------ -------- ------ -C -C 31 0 0 36 6.E-14 -C 31 1 1 21 4.E-13 -C 31 1 3 41 3.E-13 -C 32 0 0 29 9.E-14 -C 32 1 1 32 3.E-13 -C 32 1 3 48 1.E-13 -C 33 0 0 36 9.E-14 -C 33 1 1 30 4.E-13 -C 33 1 3 34 1.E-13 -C 63 0 0 150 1.E-13 -C 63 1 1 91 1.E-12 -C 63 1 3 173 2.E-13 -C 64 0 0 122 1.E-13 -C 64 1 1 128 1.E-12 -C 64 1 3 199 6.E-13 -C 65 0 0 143 2.E-13 -C 65 1 1 120 1.E-12 -C 65 1 3 138 4.E-13 -C -C Portability American National Standards Institute Fortran. -C The machine dependent constant PI is defined in -C function PIMACH. -C -C Required COS -C Resident -C Routines -C -C Reference Sweet, R., 'A Cyclic Reduction Algorithm For -C Solving Block Tridiagonal Systems Of Arbitrary -C Dimensions,' SIAM J. on Numer. Anal., -C 14(Sept., 1977), PP. 706-720. -C -C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -C -C***REFERENCES R. Sweet, A cyclic reduction algorithm for solving -C block tridiagonal systems of arbitrary dimensions, -C SIAM Journal on Numerical Analysis 14, (September -C 1977), pp. 706-720. -C***ROUTINES CALLED POISD2, POISN2, POISP2 -C***REVISION HISTORY (YYMMDD) -C 801001 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 GENBUN -C -C - DIMENSION Y(IDIMY,*) - DIMENSION W(*) ,B(*) ,A(*) ,C(*) -C***FIRST EXECUTABLE STATEMENT GENBUN - IERROR = 0 - IF (M .LE. 2) IERROR = 1 - IF (N .LE. 2) IERROR = 2 - IF (IDIMY .LT. M) IERROR = 3 - IF (NPEROD.LT.0 .OR. NPEROD.GT.4) IERROR = 4 - IF (MPEROD.LT.0 .OR. MPEROD.GT.1) IERROR = 5 - IF (MPEROD .EQ. 1) GO TO 102 - DO 101 I=2,M - IF (A(I) .NE. C(1)) GO TO 103 - IF (C(I) .NE. C(1)) GO TO 103 - IF (B(I) .NE. B(1)) GO TO 103 - 101 CONTINUE - GO TO 104 - 102 IF (A(1).NE.0. .OR. C(M).NE.0.) IERROR = 7 - GO TO 104 - 103 IERROR = 6 - 104 IF (IERROR .NE. 0) RETURN - MP1 = M+1 - IWBA = MP1 - IWBB = IWBA+M - IWBC = IWBB+M - IWB2 = IWBC+M - IWB3 = IWB2+M - IWW1 = IWB3+M - IWW2 = IWW1+M - IWW3 = IWW2+M - IWD = IWW3+M - IWTCOS = IWD+M - IWP = IWTCOS+4*N - DO 106 I=1,M - K = IWBA+I-1 - W(K) = -A(I) - K = IWBC+I-1 - W(K) = -C(I) - K = IWBB+I-1 - W(K) = 2.-B(I) - DO 105 J=1,N - Y(I,J) = -Y(I,J) - 105 CONTINUE - 106 CONTINUE - MP = MPEROD+1 - NP = NPEROD+1 - GO TO (114,107),MP - 107 GO TO (108,109,110,111,123),NP - 108 CALL POISP2 (M,N,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWB2), - 1 W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS), - 2 W(IWP)) - GO TO 112 - 109 CALL POISD2 (M,N,1,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWW1), - 1 W(IWD),W(IWTCOS),W(IWP)) - GO TO 112 - 110 CALL POISN2 (M,N,1,2,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWB2), - 1 W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS), - 2 W(IWP)) - GO TO 112 - 111 CALL POISN2 (M,N,1,1,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWB2), - 1 W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS), - 2 W(IWP)) - 112 IPSTOR = W(IWW1) - IREV = 2 - IF (NPEROD .EQ. 4) GO TO 124 - 113 GO TO (127,133),MP - 114 CONTINUE -C -C REORDER UNKNOWNS WHEN MP =0 -C - MH = (M+1)/2 - MHM1 = MH-1 - MODD = 1 - IF (MH*2 .EQ. M) MODD = 2 - DO 119 J=1,N - DO 115 I=1,MHM1 - MHPI = MH+I - MHMI = MH-I - W(I) = Y(MHMI,J)-Y(MHPI,J) - W(MHPI) = Y(MHMI,J)+Y(MHPI,J) - 115 CONTINUE - W(MH) = 2.*Y(MH,J) - GO TO (117,116),MODD - 116 W(M) = 2.*Y(M,J) - 117 CONTINUE - DO 118 I=1,M - Y(I,J) = W(I) - 118 CONTINUE - 119 CONTINUE - K = IWBC+MHM1-1 - I = IWBA+MHM1 - W(K) = 0. - W(I) = 0. - W(K+1) = 2.*W(K+1) - GO TO (120,121),MODD - 120 CONTINUE - K = IWBB+MHM1-1 - W(K) = W(K)-W(I-1) - W(IWBC-1) = W(IWBC-1)+W(IWBB-1) - GO TO 122 - 121 W(IWBB-1) = W(K+1) - 122 CONTINUE - GO TO 107 -C -C REVERSE COLUMNS WHEN NPEROD = 4. -C - 123 IREV = 1 - NBY2 = N/2 - 124 DO 126 J=1,NBY2 - MSKIP = N+1-J - DO 125 I=1,M - A1 = Y(I,J) - Y(I,J) = Y(I,MSKIP) - Y(I,MSKIP) = A1 - 125 CONTINUE - 126 CONTINUE - GO TO (110,113),IREV - 127 CONTINUE - DO 132 J=1,N - DO 128 I=1,MHM1 - MHMI = MH-I - MHPI = MH+I - W(MHMI) = .5*(Y(MHPI,J)+Y(I,J)) - W(MHPI) = .5*(Y(MHPI,J)-Y(I,J)) - 128 CONTINUE - W(MH) = .5*Y(MH,J) - GO TO (130,129),MODD - 129 W(M) = .5*Y(M,J) - 130 CONTINUE - DO 131 I=1,M - Y(I,J) = W(I) - 131 CONTINUE - 132 CONTINUE - 133 CONTINUE -C -C RETURN STORAGE REQUIREMENTS FOR W ARRAY. -C - W(1) = IPSTOR+IWP-1 - RETURN - END diff --git a/slatec/guide b/slatec/guide deleted file mode 100644 index a7f9a19..0000000 --- a/slatec/guide +++ /dev/null @@ -1,2768 +0,0 @@ - - - - - ********************************************************* - * * - * Guide to the SLATEC Common Mathematical Library * - * * - ********************************************************* - - - Kirby W. Fong - National Magnetic Fusion Energy Computer Center - Lawrence Livermore National Laboratory - - - Thomas H. Jefferson - Operating Systems Division - Sandia National Laboratories Livermore - - - Tokihiko Suyehiro - Computing and Mathematics Research Division - Lawrence Livermore National Laboratory - - - Lee Walton - Network Analysis Division - Sandia National Laboratories Albuquerque - - July 1993 - - - - -******************************************************************************* - - Table of Contents - - -SECTION 1. ABSTRACT -SECTION 2. BACKGROUND -SECTION 3. MEMBERS OF THE SLATEC COMMON MATHEMATICAL LIBRARY SUBCOMMITTEE -SECTION 4. OBTAINING THE LIBRARY -SECTION 5. CODE SUBMISSION PROCEDURES -SECTION 6. CODING GUIDELINES--GENERAL REQUIREMENTS FOR SLATEC -SECTION 7. SOURCE CODE FORMAT -SECTION 8. PROLOGUE FORMAT FOR SUBPROGRAMS -SECTION 9. EXAMPLES OF PROLOGUES -SECTION 10. SLATEC QUICK CHECK PHILOSOPHY -SECTION 11. SPECIFIC PROGRAMMING STANDARDS FOR SLATEC QUICK CHECKS -SECTION 12. QUICK CHECK DRIVERS (MAIN PROGRAMS) -SECTION 13. QUICK CHECK SUBROUTINE EXAMPLE -SECTION 14. QUICK CHECK MAIN PROGRAM EXAMPLE - -APPENDIX A. GAMS (AND SLATEC) CLASSIFICATION SCHEME -APPENDIX B. MACHINE CONSTANTS -APPENDIX C. ERROR HANDLING -APPENDIX D. DISTRIBUTION FILE STRUCTURE -APPENDIX E. SUGGESTED FORMAT FOR A SLATEC SUBPROGRAM - -ACKNOWLEDGEMENT -REFERENCES - - - - -******************************************************************************* - -SECTION 1. ABSTRACT - -This document is a guide to the SLATEC Common Mathematical Library (CML) [1]. -The SLATEC CML is written in FORTRAN 77 (ANSI standard FORTRAN as defined by -ANSI X3.9-1978, reference [6]) and contains general purpose mathematical and -statistical routines. Included in this document are a Library description, -code submission procedures, and a detailed description of the source file -format. This report serves as a guide for programmers who are preparing codes -for inclusion in the library. It also provides the information needed to -process the source file automatically for purposes such as extracting -documentation or inserting usage monitoring calls. This guide will be updated -periodically, so be sure to contact a SLATEC CML subcommittee member to ensure -you have the latest version. - - - - -******************************************************************************* - -SECTION 2. BACKGROUND - -SLATEC is the acronym for the Sandia, Los Alamos, Air Force Weapons Laboratory -Technical Exchange Committee. This organization was formed in 1974 by the -computer centers of Sandia National Laboratories Albuquerque, Los Alamos -National Laboratory, and Air Force Weapons Laboratory to foster the exchange of -technical information. The parent committee established several subcommittees -to deal with various computing specialties. The SLATEC Common Mathematical -Library (CML) Subcommittee decided in 1977 to construct a mathematical FORTRAN -subprogram library that could be used on a variety of computers at the three -sites. A primary impetus for the library development was to provide portable, -non-proprietary, mathematical software for member sites' supercomputers. - -In l980 the computer centers of Sandia National Laboratories Livermore and the -Lawrence Livermore National Laboratory were admitted as members of the parent -committee and subcommittees. Lawrence Livermore National Laboratory, unlike the -others, has two separate computer centers: the National Magnetic Fusion Energy -Computer Center (NMFECC) and the Livermore Computer Center (LCC). In 1981 the -National Bureau of Standards (now the National Institute of Standards and -Technology) and the Oak Ridge National Laboratory were invited to participate -in the math library subcommittee because of their great interest in the -project. - -Version 1.0 of the CML was released in April 1982 with 114,328 records and 491 -user-callable routines. In May 1984 Version 2.0, with 151,864 records and 646 -user-callable routines was released. This was followed in April 1986 by -Version 3.0 with 196,013 records and 704 user-callable routines. Version 3.1 -followed in August 1987 with 197,931 records and 707 user-callable routines -and Version 3.2 in August 1989 with 203,587 records and 709 user-callable -routines. The committee released Version 4.0 in December 1992 with 298,954 -records and 901 user-callable routines. Finally, on July 1, 1993, Version 4.1 -was released with 290,907 records and 902 user-callable routines. - -The sole documentation provided by SLATEC for the routines of the SLATEC -Library is via comment lines in the source code. Although the library comes -with portable documentation programs to help users access the documentation in -the source code, various installations may wish to use their own documentation -programs. To facilitate automatic extraction of documentation or further -processing by other computer programs, the source file for each routine must -be arranged in a precise format. This document describes that format for the -benefit of potential library contributors and for those interested in -extracting library documentation from the source code. - - - - -******************************************************************************* - -SECTION 3. MEMBERS OF THE SLATEC COMMON MATHEMATICAL LIBRARY SUBCOMMITTEE - -Current member sites and voting members of the subcommittee are the -following. - - -Air Force Phillips Laboratory, Kirtland (PLK) Reginald Clemens - -Lawrence Livermore National Laboratory (LCC) Fred N. Fritsch - -Lawrence Livermore National Laboratory (NERSC) Steve Buonincontri - -Los Alamos National Laboratory (LANL) W. Robert Boland - (Chairman) - -National Institute of Standards and Technology (NIST) Daniel W. Lozier - -Oak Ridge National Laboratory (ORNL) Thomas H. Rowan - -Sandia National Laboratories/California (SNL/CA) Thomas H. Jefferson - -Sandia National Laboratories/New Mexico (SNL/NM) Sue Goudy - - - - -******************************************************************************* - -SECTION 4. OBTAINING THE LIBRARY - -The Library is in the public domain and distributed by the Energy Science -and Technology Software Center. - - Energy Science and Technology Software Center - P.O. Box 1020 - Oak Ridge, TN 37831 - - Telephone 615-576-2606 - E-mail estsc%a1.adonis.mrouter@zeus.osti.gov - - - -******************************************************************************* - -SECTION 5. CODE SUBMISSION PROCEDURES - -The SLATEC Library is continuously searching for portable high-quality routines -written in FORTRAN 77 that would be of interest to the member sites. The -subcommittee meets several times annually with the member sites rotating as -meeting hosts. At these meetings new routines are introduced, discussed, and -eventually voted on for inclusion in the library. Some of the factors that are -considered in deciding whether to accept a routine into the Library are the -following: - - -1. Usefulness. Does the routine fill a void in the Library? Will the routine - have widespread appeal? Will it add a new capability? - -2. Robustness. Does the routine give accurate results over a wide range of - problems? Does it diagnose errors? Is the routine well tested? - -3. Maintainability. Is the author willing to respond to bugs in the routine? - Does the source code follow good programming practices? - -4. Adherence to SLATEC standards and coding guidelines. These standards - are described further in this guide and include such things as the order - of subprogram arguments, the presence of a correctly formatted prologue at - the start of each routine, and the naming of routines. - -5. Good documentation. Is clear, concise computer readable documentation - built into the source code? - -6. Freely distributable. Is the program in the public domain? - - -A typical submission procedure begins with contact between an author and a -Library committee member. Preliminary discussions with the member are -encouraged for initial screening of any code and to gain insight into the -workings of SLATEC. This member champions the routine to be considered. The -code is introduced at a meeting where the author or committee member describes -the code and explains why it would be suitable for SLATEC. Copies of the code -are distributed to all committee members. Hopefully, the code already adheres -to SLATEC standards. However, most codes do not. At this first formal -discussion, the committee members are able to provide some useful suggestions -for improving the code and revising it for SLATEC. - -Between meetings, changes are made to the code and the modified code is -distributed in machine readable format for testing. The code is then -considered at a subsequent meeting, to be voted on and accepted. However, -because committee members and authors do not always see eye to eye, and because -time constraints affect all, the code is usually discussed at several meetings. - -If codes adhered to the programming practices and formatting described in this -guide, the time for acceptance could be greatly reduced. - - - - -******************************************************************************* - -SECTION 6. CODING GUIDELINES--GENERAL REQUIREMENTS FOR SLATEC - -A software collection of the size of the SLATEC Library that is designed to run -on a variety of computers demands uniformity in handling machine dependencies, -in handling error conditions, and in installation procedures. Thus, while the -decision to add a new subroutine to the library depends mostly on its quality -and whether it fills a gap in the library, these are not the only -considerations. Programming style must also be considered, so that the library -as a whole behaves in a consistent manner. We now list the stylistic and -documentational recommendations and requirements for routines to be -incorporated into the library. - - -1. The SLATEC Library is intended to have no restriction on its distribution; - therefore, new routines must be in the public domain. This is generally - not a problem since most authors are proud of their work and would like - their routines to be used widely. - -2. Routines must be written in FORTRAN 77 (ANSI standard FORTRAN as - defined by ANSI X3.9-1978, reference [6]). Care must be taken so that - machine dependent features are not used. - -3. To enhance maintainability codes are to be modular in structure. Codes - must be composed of reasonably small subprograms which in turn are made - up of easily understandable blocks. - -4. Equivalent routines of different precision are to look the same where - possible. That is, the logical structure, statement numbers, variable - names, etc. are to be as close to identical as possible. This implies - that generic intrinsics must be used instead of specific intrinsics. - Extraneous use of INT, REAL and DBLE are strongly discouraged; use - mixed-mode expressions in accordance with the Fortran 77 standard. - -5. New routines must build on existing routines in the Library, unless - there are compelling reasons to do otherwise. For example, the SLATEC - Library contains the LINPACK and EISPACK routines, so new routines - should use the existing linear system and eigensystem routines rather - than introduce new ones. - -6. System or machine dependent values must be obtained by calling routines - D1MACH, I1MACH, and R1MACH. The SLATEC Library has adopted these routines - from the Bell Laboratories' PORT Library [2] [3]. See Appendix B - for a description of these machine dependent routines. - -7. The SLATEC Library has a set of routines for handling error messages. - Each user-callable routine, if it can detect errors, must have as one - of its arguments an error flag, whose value upon exiting the routine - indicates the success or failure of the routine. It is acceptable for a - routine to set the error flag and RETURN; however, if the routine wishes - to write an error message, it must call XERMSG (see Appendix C) rather - than use WRITE or PRINT statements. In general, all errors (even serious - ones) should be designated as "recoverable" rather than "fatal," and the - routine should RETURN to the user. This permits the user to try an - alternate strategy if a routine decides a particular calculation is - inappropriate. A description of the entire original error handling - package appears in reference [4]. - -8. Each user-callable routine (and subsidiary routine if appropriate) must - have a small demonstration routine that can be used as a quick check. This - demonstration routine can be more exhaustive, but in general, it should be - structured to provide a "pass" or "fail" answer on whether the library - routine appears to be functioning properly. A more detailed description - of the required format of the quick checks appears later in this document. - -9. Common blocks and SAVEd variables must be avoided. Use subprogram - arguments for interprogram communication. The use of these constructs - often obstructs multiprocessing. - - Variables that are statically allocated in memory and are used as - working storage cannot be used simultaneously by several processors. - SAVEd variables and common block variables are most likely to fall into - this category. Such variables are acceptable if they are DATA loaded or - set at run time to values that are to be read (but not written) since it - does not matter in what order multiple processors read the values. - However, such variables should not be used as working storage since no - processor can use the work space while some other processor is using it. - Library routines should ask the user to provide any needed work space - by passing it in as an argument. The user is then responsible for - giving each processor a different work space even though each processor - may be executing the same library routine. - -10. Complete self-contained documentation must be supplied as comments in - user-callable routines. This documentation must be self-contained because - SLATEC provides no other documentation for using the routines. This - documentation is called the "prologue" for the routine. The rigid prologue - format for user-callable routines is described below. The prologue must - tell the user how to call the routine but need not go into algorithmic - details since such explanations often require diagrams or non-ASCII - symbols. Subsidiary routines are those called by other library routines - but which are not intended to be called directly by the user. Subsidiary - routines also have prologues, but these prologues are considerably less - elaborate than those of user-callable routines. - -11. No output should be printed. Instead, information should be returned - to the user via the subprogram arguments or function values. If there is - some overriding reason that printed output is necessary, the user must be - able to suppress all output by means of a subprogram input variable. - - - - -******************************************************************************* - -SECTION 7. SOURCE CODE FORMAT - -In this section and the two sections on prologues, we use the caret (^) -character to indicate a position in which a single blank character must -appear. Upper case letters are used for information that appears literally. -Lower case is used for material specific to the routine. - -1. The first line of a subprogram must start with one of: - - SUBROUTINE^name^(arg1,^arg2,^...argn) - FUNCTION^name^(arg1,^arg2,^...argn) - COMPLEX^FUNCTION^name^(arg1,^arg2,^...argn) - DOUBLE^PRECISION^FUNCTION^name^(arg1,^arg2,^...argn) - INTEGER^FUNCTION^name^(arg1,^arg2,^...argn) - REAL^FUNCTION^name^(arg1,^arg2,^...argn) - LOGICAL^FUNCTION^name^(arg1,^arg2,^...argn) - CHARACTER[*len]^FUNCTION^name^(arg1,^arg2,^...argn) - - Each of the above lines starts in column 7. If there is an argument - list, then there is exactly one blank after the subprogram name and - after each comma (except if the comma appears in column 72). There is - no embedded blank in any formal parameter, after the leading left - parenthesis, before the trailing right parenthesis, or before any - comma. Formal parameters are never split across lines. Any line to be - continued must end with a comma. - - For continuation lines, any legal continuation character may be used in - column 6, columns 7-9 must be blank and arguments or formal parameters - start in column 10 of a continuation line and continue up to the right - parenthesis (or comma if another continuation line is needed). The - brackets in the CHARACTER declaration do not appear literally but - indicate the optional length specification described in the FORTRAN 77 - standard. - -2. The author must supply a prologue for each subprogram. The prologue - must be in the format that will subsequently be described. The - prologue begins with the first line after the subprogram declaration - (including continuation lines for long argument lists). - -3. Except for the "C***" lines (to be described) in the prologue and - the "C***" line marking the first executable statement, no other line - may begin with "C***". - -4. The first line of the prologue is the comment line - - C***BEGIN^PROLOGUE^^name - - where "name", starting in column 21, is the name of the subprogram. - -5. The last line of a subprogram is the word "END" starting in column 7. - -6. All alphabetic characters, except for those on comment lines or in - character constants, must be upper case, as specified by the FORTRAN 77 - standard (see [6]). - -7. In the prologue, the comment character in column 1 must be the upper - case "C". - -8. All subprogram, common block, and any formal parameter names mentioned in - the prologue must be in upper case. - -9. Neither FORTRAN statements nor comment lines can extend beyond column 72. - Columns 73 through 80 are reserved for identification or sequence numbers. - -10. Before the first executable statement of every subprogram, user-callable - or not, is the line - - C***FIRST^EXECUTABLE^STATEMENT^^name - - where "name" (starting in column 33) is the name of the subprogram. - Only comment lines may appear between the C***FIRST EXECUTABLE - STATEMENT line and the first executable statement. - -11. The subprogram name consists of a maximum of six characters. Authors - should choose unusual and distinctive subprogram names to minimize - possible name conflicts. Double precision routines should begin with - "D". Subprograms of type complex should begin with "C". The letter "Z" - is reserved for future use by possible double precision complex - subprograms. No other subprograms should begin with either "D", "C", or - "Z". - -12. The recommended order for the formal parameters is: - - 1. Names of external subprograms. - - 2. Input variables. - - 3. Variables that are both input and output (except error flags). - - 4. Output variables. - - 5. Work arrays. - - 6. Error flags. - - However, array dimensioning parameters should immediately follow the - associated array name. - - - - -******************************************************************************* - -SECTION 8. PROLOGUE FORMAT FOR SUBPROGRAMS - -Each subprogram has a section called a prologue that gives standardized -information about the routine. The prologue consists of comment lines only. A -subsidiary subprogram is one that is usually called by another SLATEC Library -subprogram only and is not meant to be called by a user's routine. The -prologue for a user-callable subprogram is more extensive than the prologue for -a subsidiary subprogram. The prologue for a user-callable subprogram has up to -14 sections, of which 12 are required and one is required if and only if a -common block is present. Several of these sections are optional in subsidiary -programs and in the quick check routines. The sections are always in the -order described in the table below. - - - Section User-callable Subsidiary Quick Checks - - 1. BEGIN PROLOGUE Required Required Required - 2. SUBSIDIARY Not present Required Optional - 3. PURPOSE Required Required Required - 4. LIBRARY SLATEC Required Required Required - 5. CATEGORY Required Optional Optional - 6. TYPE Required Required Required - 7. KEYWORDS Required Optional Optional - 8. AUTHOR Required Required Required - 9. DESCRIPTION Required Optional Optional - 10. SEE ALSO Optional Optional Optional - 11. REFERENCES Required Optional Optional - 12. ROUTINES CALLED Required Required Required - 13. COMMON BLOCKS Required*** Required*** Required*** - 14. REVISION HISTORY Required Required Required - 15. END PROLOGUE Required Required Required - - ***Note: The COMMON BLOCKS section appears in a subprogram prologue - if and only if the subprogram contains a common block. - -In the prologue section descriptions that follow, the caret (^) -character is used for emphasis to indicate a required blank character. - - -1. BEGIN PROLOGUE - This section is a single line that immediately follows the subprogram - declaration and its continuation lines. It is - - C***BEGIN^PROLOGUE^^name - - where "name" (beginning in column 21) is the name of the subprogram. - -2. SUBSIDIARY - This section is the single line - - C***SUBSIDIARY - - and indicates the routine in which this appears is not intended to be - user-callable. - -3. PURPOSE - This section gives one to six lines of information on the purpose of the - subprogram. The letters may be in upper or lower case. There are no blank - lines in the purpose section; i.e., there are no lines consisting solely of - a "C" in column 1. The format for the first line and any continuation - lines is - - C***PURPOSE^^information - C^^^^^^^^^^^^more information - - Information begins in column 14 of the first line and no earlier than - column 14 of continuation lines. - -4. LIBRARY SLATEC - The section is a single line used to show that the routine is a part - of the SLATEC library and, optionally, to indicate other libraries, - collections, or packages (sublibraries) of which the routine is a part - or from which the routine has been derived. The format is - - C***LIBRARY^^^SLATEC - or - C***LIBRARY^^^SLATEC^(sublib1,^sublib2,^...sublibn) - - The leading left parenthesis is immediately followed by the first member - of the list. Each member, except for the last, is immediately followed by - a comma and a single blank. The last member is immediately followed by - the trailing right parenthesis. - -5. CATEGORY - This section is a list of classification system categories to which - this subprogram might reasonably be assigned. There must be at least - one list item. The first category listed is termed the primary - category, and others, if given, should be listed in monotonically - decreasing order of importance. Categories must be chosen from the - classification scheme listed in Appendix A. The required format for the - initial line and any continuation lines is - - C***CATEGORY^^cat1,^cat2,^cat3,^...catn, - C^^^^^^^^^^^^^continued list - - All alphabetic characters are in upper case. - - Items in the list are separated by the two characters, comma and space. - If the list will not fit on one line, the line may be ended at a comma - (with zero or more trailing spaces), and be continued on the next line. - The list and any continuations of the list begin with a nonblank character - in column 15. - -6. TYPE - This section gives the datatype of the routine and indicates which - routines, including itself, are equivalent (except possibly for type) to - the routine. The format for this section is - - C***TYPE^^^^^^routine_type^(equivalence list - C^^^^^^^^^^^^^continued equivalence list - C^^^^^^^^^^^^^continued equivalence list) - - Routine_type, starting in column 15, is the data type of the routine, - and is either SINGLE PRECISION, DOUBLE PRECISION, COMPLEX, INTEGER, - CHARACTER, LOGICAL, or ALL. ALL is a pseudo-type given to routines that - could not reasonably be converted to some other type. Their purpose is - typeless. An example would be the SLATEC routine that prints error - messages. - - Equivalence list is a list of the routines (including this one) that are - equivalent to this one, but perhaps of a different type. Each item in the - list consists of a routine name followed by the "-" character and then - followed by the first letter of the type (except use "H" for type - CHARACTER) of the equivalent routine. The order of the items is S, D, C, - I, H, L and A. - - The initial item in the list is immediately preceded by a blank and a - left parenthesis and the final item is immediately followed by a right - parenthesis. Items in the list are separated by the two characters, - comma and space. If the list will not fit on one line, the line may be - ended at a comma (with zero or more trailing spaces), and be continued - on the next line. The list and any continuations of the list begin with - a nonblank character in column 15. - - All alphabetic characters in this section are in upper case. - - Example - - C***TYPE SINGLE PRECISION (ACOSH-S, DACOSH-D, CACOSH-C) - -7. KEYWORDS - This section gives keywords or keyphrases that can be used by - information retrieval systems to identify subprograms that pertain to - the topic suggested by the keywords. There must be at least one - keyword. Keywords can have embedded blanks but may not have leading or - trailing blanks. A keyword cannot be continued on the next line; it - must be short enough to fit on one line. No keyword can have an embedded - comma. Characters are limited to the FORTRAN 77 character set (in - particular, no lower case letters). There is no comma after the last - keyword in the list. It is suggested that keywords be in either - alphabetical order or decreasing order of importance. The format for - the initial line and any continuation lines is - - C***KEYWORDS^^list - C^^^^^^^^^^^^^continued list - - Items in the list are separated by the two characters, comma and space. - If the list will not fit on one line, the line may be ended at a comma - (with zero or more trailing spaces), and be continued on the next line. - The list and any continuations of the list begin with a nonblank character - in column 15. - -8. AUTHOR - This required section gives the author's name. There must be at least one - author, and there may be coauthors. At least the last name of the author - must be given. The first name (or initials) is optional. The company, - organization, or affiliation of the author is also optional. The brackets - below indicate optional information. Note that if an organization is to be - listed, the remainder of the author's name must also be given. If the - remainder of the author's name is given, the last name is immediately - followed by a comma. If the organization is given, the first name (or - initials) is immediately followed by a comma. The remainder of the name - and the organization name may have embedded blanks. The remainder of the - name may not have embedded commas. This makes it possible for an - information retrieval system to count commas to identify the remainder of - the name and the name of an organization. Additional information about the - author (e.g., address or telephone number) may be given on subsequent - lines. The templates used are - - C***AUTHOR^^last-name[,^first-name[,^(org)]] - C^^^^^^^^^^^^^more information - C^^^^^^^^^^^^^more information - . - . - . - C^^^^^^^^^^^last-name[,^first-name[,^(org)]] - C^^^^^^^^^^^^^more information - . - . - . - - Each author's name starts in column 13. Continued information starts in - column 15. - -9. DESCRIPTION - This section is a description giving the program abstract, method used, - argument descriptions, dimension information, consultants, etc. The - description of the arguments is in exactly the same order in which the - arguments appear in the calling sequence. The description section may use - standard, 7-bit ASCII graphic characters, i.e., the 94 printing characters - plus the blank. Names of subprograms, common blocks, externals, and formal - parameters are all in upper case. Names of variables are also in upper - case. The first line of this section is "C***DESCRIPTION" starting in - column 1. All subsequent lines in this section start with a "C" in column - 1 and no character other than a blank in column 2. Lines with only a "C" - in column 1 may be used to improve the appearance of the description. - - A suggested format for the DESCRIPTION section is given in Appendix E. - -10. SEE ALSO - This section is used for listing other SLATEC routines whose prologues - contain documentation on the routine in which this section appears. - The form is - - C***SEE ALSO^^name,^name,^name - - where each "name" is the name of a user-callable SLATEC CML subprogram - whose prologue provides a description of this routine. The names are - given as a list (starting in column 15), with successive names separated - by a comma and a single blank. - -11. REFERENCES - This section is for references. Any of the 94 ASCII printing characters - plus the blank may be used. There may be more than one reference. If there - are no references, the section will consist of the single line - - C***REFERENCES^^(NONE) - - If there are references, they will be in the following format: - - C***REFERENCES^^reference 1 - C^^^^^^^^^^^^^^^^^continuation of reference 1 - . - . - . - C^^^^^^^^^^^^^^^reference 2 - C^^^^^^^^^^^^^^^^^continuation of reference 2 - . - . - . - - Information starts in column 17 of the first line of a reference and no - earlier than column 19 of continuation lines. - - References should be listed in either alphabetical order by last name or - order of citation. They should be in upper and lower case, have initials - or first names ahead of last names, and (for multiple authors) have - "and" ahead of the last author's name instead of just a comma. The first - word of the title of journal articles should be capitalized as should all - important words in titles of books, pamphlets, research reports, and - proceedings. Titles should be given without quotation marks. The names - of journals should be spelled out completely, or nearly so, because - software users may not be familiar with them. - - A complete example of a journal reference is: - - C F. N. Fritsch and R. E. Carlson, Monotone piecewise - C cubic interpolation, SIAM Journal on Numerical Ana- - C lysis, 17 (1980), pp. 238-246. - - A complete example of a book reference is: - - C Carl de Boor, A Practical Guide to Splines, Applied - C Mathematics Series 27, Springer-Verlag, New York, - C 1978. - -12. ROUTINES CALLED - This section gives the names of routines in the SLATEC Common Mathematical - Library that are either directly referenced or declared in an EXTERNAL - statement and passed as an argument to a subprogram. Note that the FORTRAN - intrinsics and other formal parameters that represent externals are not - listed. A list is always given for routines called; however, if no routine - is called, the list will be the single item "(NONE)" where the parentheses - are included. If there are genuine items in the list, the items are in - alphabetical order. The collating sequence has "0" through "9" first, then - "A" through "Z". The format is - - C***ROUTINES^CALLED^^name,^name,^name,^name, - C^^^^^^^^^^^^^^^^^^^^name,^name,^name - - Items in the list are separated by the two characters, comma and space. - If the list will not fit on one line, the line may be ended at a comma - (with zero or more trailing spaces), and be continued on the next line. - The list and any continuations of the list begin with a nonblank character - in column 22. - -13. COMMON BLOCKS - This section, that may or may not be required, tells what common blocks are - used by this subprogram. If this subprogram uses no common blocks, this - section does not appear. If this subprogram does use common blocks, this - section must appear. The list of common blocks is in exactly the same - format as the list of routines called and uses the same collating sequence. - In addition, the name of blank common is "(BLANK)" where the parentheses - are included. Blank common should be last in the list if it appears. The - format for this section is - - C***COMMON^BLOCKS^^^^name,^name,^name,^name, - C^^^^^^^^^^^^^^^^^^^^name,^name,^name^ - - The list starts in column 22. - -14. REVISION HISTORY - This section provides a summary of the revisions made to this code. - Revision dates and brief reasons for revisions are given. The format is - - C***REVISION^HISTORY^^(YYMMDD) - C^^^yymmdd^^DATE^WRITTEN - C^^^yymmdd^^revision description - C^^^^^^^^^^^more revision description - C^^^^^^^^^^^... - C^^^yymmdd^^revision description - C^^^^^^^^^^^more revision description - C^^^^^^^^^^^... - C^^^^^^^^^^^... - - where, for each revision, "yy" (starting in column 5) is the last two - digits of the year, "mm" is the month (01, 02, ..., 12), and "dd" is the - day of the month (01, 02, ..., 31). Because this ANSI standard form for - the date may not be familiar to some people, the character string - "(YYMMDD)" (starting in column 23) is included in the first line of the - section to assist in interpreting the sequence of digits. Each line of the - revision descriptions starts in column 13. The second line of this section - contains the date the routine was written, with the characters "DATE - WRITTEN" beginning in column 13. These items must be in chronological - order. - -15. END PROLOGUE - The last section is the single line - - C***END^PROLOGUE^^name - - where "name" is the name of the subprogram. - - - - -******************************************************************************* - -SECTION 9. EXAMPLES OF PROLOGUES - -This section contains examples of prologues for both user-callable -and subsidiary routines. The routines are not from the SLATEC CML and -should be used only as guidelines for preparing routines for SLATEC. -Note that the C***DESCRIPTION sections follow the suggested LDOC format that -is described in Appendix E. Following the suggested LDOC format with its -"C *"subsections helps to ensure that all necessary descriptive information is -provided. - - SUBROUTINE ADDXY (X, Y, Z, IERR) -C***BEGIN PROLOGUE ADDXY -C***PURPOSE This routine adds two single precision numbers together -C after forcing both operands to be stored in memory. -C***LIBRARY SLATEC -C***CATEGORY A3A -C***TYPE SINGLE PRECISION (ADDXY-S, DADDXY-D) -C***KEYWORDS ADD, ADDITION, ARITHMETIC, REAL, SUM, -C SUMMATION -C***AUTHOR Fong, K. W., (NMFECC) -C Mail Code L-560 -C Lawrence Livermore National Laboratory -C Post Office Box 5509 -C Livermore, CA 94550 -C Jefferson, T. H., (SNLL) -C Org. 8235 -C Sandia National Laboratories Livermore -C Livermore, CA 94550 -C Suyehiro, T., (LLNL) -C Mail Code L-316 -C Lawrence Livermore National Laboratory -C Post Office Box 808 -C Livermore, CA 94550 -C***DESCRIPTION -C -C *Usage: -C -C INTEGER IERR -C REAL X, Y, Z -C -C CALL ADDXY (X, Y, Z, IERR) -C -C *Arguments: -C -C X :IN This is one of the operands to be added. It will not -C be modified by ADDXY. -C -C Y :IN This is the other operand to be added. It will not be -C modified by ADDXY. -C -C Z :OUT This is the sum of X and Y. In case of an error, -C this argument will not be modified. -C -C IERR:OUT This argument will be set to 0 if ADDXY added the two -C operands. It will be set to 1 if it appears the addition -C would generate a result that might overflow. -C -C *Description: -C -C ADDXY first divides X and Y by the largest single precision number -C and then adds the quotients. If the absolute value of the sum is -C greater than 1.0, ADDXY returns with IERR set to 1. Otherwise -C ADDXY stores X and Y into an internal array and calls ADDZZ to add -C them. This increases the probability (but does not guarantee) that -C operands and result are stored into memory to avoid retention of -C extra bits in overlength registers or cache. -C -C***REFERENCES W. M. Gentleman and S. B. Marovich, More on algorithms -C that reveal properties of floating point arithmetic -C units, Communications of the ACM, 17 (1974), pp. -C 276-277. -C***ROUTINES CALLED ADDZZ, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 831109 DATE WRITTEN -C 880325 Modified to meet new SLATEC prologue standards. Only -C comment lines were modified. -C 881103 Brought DESCRIPTION section up to Appendix E standards. -C 921215 REFERENCE section modified to reflect recommended style. -C***END PROLOGUE ADDXY - DIMENSION R(3) -C***FIRST EXECUTABLE STATEMENT ADDXY - BIG = R1MACH( 2 ) -C -C This is an example program, not meant to be taken seriously. The -C following illustrates the use of XERMSG to send an error message. -C - IF ( (ABS((X/BIG)+(Y/BIG))-1.0) .GT. 0.0 ) THEN - IERR = 1 - CALL XERMSG ( 'SLATEC', 'ADDXY', 'Addition of the operands '// - * 'is likely to cause overflow', IERR, 1 ) - ELSE - IERR = 0 - R(1) = X - R(2) = Y - CALL ADDZZ( R ) - Z = R(3) - ENDIF - RETURN - END - SUBROUTINE ADDZZ (R) -C***BEGIN PROLOGUE ADDZZ -C***SUBSIDIARY -C***PURPOSE This routine adds two single precision numbers. -C***LIBRARY SLATEC -C***AUTHOR Fong, K. W., (NMFECC) -C Mail Code L-560 -C Lawrence Livermore National Laboratory -C Post Office Box 5509 -C Livermore, CA 94550 -C Jefferson, T. H., (SNLL) -C Org. 8235 -C Sandia National Laboratories Livermore -C Livermore, CA 94550 -C Suyehiro, T., (LLNL) -C Mail Code L-316 -C Lawrence Livermore National Laboratory -C Post Office Box 808 -C Livermore, CA 94550 -C***SEE ALSO ADDXY -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 831109 DATE WRITTEN -C 880325 Modified to meet new SLATEC prologue standards. Only -C comment lines were modified. -C***END PROLOGUE ADDZZ - DIMENSION R(3) -C***FIRST EXECUTABLE STATEMENT ADDZZ - R(3) = R(1) + R(2) - RETURN - END - - - - -******************************************************************************* - - -SECTION 10. SLATEC QUICK CHECK PHILOSOPHY - -The SLATEC Library is distributed with a set of test programs that may be used -as an aid to insure that the Library is installed correctly. This set of test -programs is known as the SLATEC quick checks. The quick checks are not meant -to provide an exhaustive test of the Library. Instead they are designed to -protect against gross errors, such as an unsatisfied external. Because the -SLATEC Library runs on a great variety of computers, the quick checks often -detect arithmetic difficulties with either particular Library routines or with -a particular computational environment. - -A list of the quick check guidelines follows. - -1. A quick check should test a few problems successfully solved by a - particular library subprogram. It is not intended to be an extensive - test of a subprogram. - -2. A quick check should provide consistent and minimal output in most - cases, including a "PASS" or "FAIL" indicator. However, more detailed - output should be available on request to help track down problems in the - case of failures. - -3. Some reasonable error conditions should be tested by the quick check by - purposefully referencing the routine incorrectly. - -4. A quick check subprogram is expected to execute correctly on any machine - with an ANSI Fortran 77 compiler and library. No test should have to be - skipped to avoid an abort on a particular machine. - -5. As distributed on the SLATEC tape, the quick check package consists of a - number of quick check main programs and a moderate number of subprograms. - Each quick check main program, more frequently called a quick check driver, - calls one or more quick check subprograms. Usually, a given driver - initiates the tests for a broadly related set of subprograms, e.g. for the - single precision Basic Linear Algebra Subprograms (BLAS). Each quick - check subprogram will test one or more closely related library routines of - the same precision. For example, single precision routines and their - double precision equivalents are not to be tested in the same quick check - subprogram. - -6. The format of the quick check package does not rigidly dictate how it - must be executed on a particular machine. For example, memory size of the - machine might preclude loading all quick check modules at once. - - - - -******************************************************************************* - -SECTION 11. SPECIFIC PROGRAMMING STANDARDS FOR SLATEC QUICK CHECKS - -Just as the routines in the SLATEC Common Mathematical Library must meet -certain standards, so must the quick checks. These standards are meant to -ensure that the quick checks adhere to the SLATEC quick check philosophy and -to enhance maintainability. The list of these quick check standards follow. - - -1. Each module must test only a few related library subprograms. - -2. Each module must be in the form of a subroutine with three arguments. - For example: - - SUBROUTINE ADTST (LUN, KPRINT, IPASS) - - The first is an input argument giving the unit number to which any output - should be written. The second is an input argument specifying the amount - of printing to be done by the quick check subroutine. The third is an - output flag indicating passage or failure of the subroutine. - - LUN Unit number to which any output should be written. - - KPRINT = 0 No printing is done (pass/fail is presumably monitored at a - higher level, i.e. in the driver). Error messages will not be - printed since the quick check driver sets the error handling - control flag to 0, using CALL XSETF(0) when KPRINT = 0 or 1. - - = 1 No printing is done for tests which pass; a short message - (e.g., one line) is printed for tests which fail. Error - messages will not be printed since the quick check driver sets - the error handling control flag to 0, using CALL XSETF(0) - when KPRINT = 0 or 1. - - = 2 A short message is printed for tests which pass; more detailed - information is printed for tests which fail. Error messages - describing the reason for failure should be printed. - - = 3 (Possibly) quite detailed information is printed for all tests. - Error messages describing the reason for failure should be - printed. - - IPASS = 0 Indicates failure of the quick check subroutine (i.e., at least - one test failed). - - = 1 Indicates that all tests passed in the quick check subroutine. - - In the case of a subroutine whose purpose is to produce output (e.g., a - printer-plotter), output of a more detailed nature might be produced for - KPRINT >= 1. - - The quick check must execute correctly and completely using each value - of KPRINT. KPRINT is used only to control the printing and does not - affect the tests made of the SLATEC routine. - -3. The quick check subprograms must be written in ANSI Fortran 77 and - must make use of I1MACH, R1MACH, and D1MACH for pass/fail tolerances. - -4. Where possible, compute constants in a machine independent fashion. For - example, PI = 4. * ATAN(1.0) - -5. Using one library routine to test another is permitted, though this should - be done with care. - -6. Known solutions can be stored using DATA or PARAMETER statements. Some - subprograms return a "solution" which is more than one number - for - example, the eigenvalues of a matrix. In these cases, take special care - that the quick check test passes for ALL orderings of the output which are - mathematically correct. - -7. Where subprograms are required by a routine being tested, they - should accompany the quick check. However, care should be taken so that - no two such subprograms have the same name. Choosing esoteric or odd - names is a good idea. It is extremely desirable that each such - subprogram contain comments indicating which quick check needed it - (a C***SEE ALSO line should be used). - -8. Detailed output should be self-contained yet concise. No external - reference material or additional computations should be required to - determine what, for example, the correct solution to the problem really is. - -9. For purposes of tracking down the cause of a failure, external reference - material or the name of a (willing) qualified expert should be listed in - the comment section of the quick check. - -10. Quick checks must have SLATEC prologues and be adequately commented - and cleanly written so that the average software librarian has some hope - of tracking down problems. For example, if a test problem is known to - be tricky or if difficulties are expected for short word length - machines, an appropriate comment would be helpful. - -11. After deliberately calling a library routine with incorrect arguments, - invoke the function IERR=NUMXER(NERR) to verify that the correct error - number was set. (NUMXER is a function in the SLATEC error handling - package that returns the number of the most recent error via both the - function value and the argument.) Then CALL XERCLR to clear it before - this (or the next) quick check makes another error. - -12. A quick check should be written in such a way that it will execute - identically if called several times in the same program. In particular, - there should be no modification of DATA loaded variables which cause the - quick check to start with the wrong values on subsequent calls. - - - - -******************************************************************************* - -SECTION 12. QUICK CHECK DRIVERS (MAIN PROGRAMS) - -Many people writing quick checks are not aware of the environment in which the -individual quick check is called. The following aspects of the quick check -drivers are illustrated by the example driver in Section 14. - -1. Each quick check driver will call one or more quick check subprograms. - -2. The input and output units for the tests are set in the driver. - - LIN = I1MACH(1) the input unit - LUN = I1MACH(2) the output unit - - The output unit is communicated to the quick check subprograms - through the argument list. All output should be directed to the unit LUN - that is in the argument list. - -3. Each quick check has three arguments LUN, KPRINT, and IPASS. The - meaning of these arguments within the quick checks is detailed - thoroughly in the previous section. - - a. The quick check driver reads in KPRINT without a prompt, and - passes KPRINT as an argument to each quick check it calls. KPRINT must - not be changed by any driver or quick check. The driver uses KPRINT to - help determine what output to write. - - b. The variable IPASS must be set to 0 (for fail) or to 1 (for pass) by - each quick check before returning to the driver. Within the driver, - the variable NFAIL is set to 0. If IPASS = 0 upon return to the - driver, then NFAIL is incremented. After calling all the quick checks, - NFAIL will then have the number of quick checks which failed. - - c. Quick check driver output should follow this chart: - - NFAIL OUTPUT - ----- ------ - - not 0 driver writes fail message - 0 driver writes pass message - -4. There are calls to three SLATEC error handler routines in each quick check - driver: - - - CALL XSETUN(LUN) Selects unit LUN as the unit to which - error messages will be sent. - CALL XSETF(1) Only fatal (not recoverable) error messages - or XSETF(0) will cause an abort. XSETF sets the - KONTROL variable for the error handler - routines to the value of the XSETF - argument. A value of either 0 or 1 will - make only fatal errors cause a program - abort. A value of 1 will allow printing - of error messages, while a value of zero - will print only fatal error messages. - CALL XERMAX(1000) Increase the number of times any - single message may be printed. - - - - -******************************************************************************* - -SECTION 13. QUICK CHECK SUBROUTINE EXAMPLE - -The following program provides a very minimal check of the sample routine -from Section 9. - - - SUBROUTINE ADTST (LUN, KPRINT, IPASS) -C***BEGIN PROLOGUE ADTST -C***SUBSIDIARY -C***PURPOSE Quick check for SLATEC routine ADDXY -C***LIBRARY SLATEC -C***CATEGORY A3A -C***TYPE SINGLE PRECISION (ADTST-S, DADTST-D) -C***KEYWORDS QUICK CHECK, ADDXY, -C***AUTHOR Suyehiro, Tok, (LLNL) -C Walton, Lee, (SNL) -C***ROUTINES CALLED ADDXY, R1MACH -C***REVISION HISTORY (YYMMDD) -C 880511 DATE WRITTEN -C 880608 Revised to meet new prologue standards. -C***END PROLOGUE ADTST -C -C***FIRST EXECUTABLE STATEMENT ADTST - IF ( KPRINT .GE. 2 ) WRITE (LUN,99999) -99999 FORMAT ('OUTPUT FROM ADTST') - IPASS = 1 -C -C EXAMPLE PROBLEM - X = 1. - Y = 2. - CALL ADDXY(X, Y, Z, IERR) - EPS = R1MACH(4) - IF( (ABS(Z-3.) .GT. EPS) .OR. (IERR .EQ. 1) ) IPASS = 0 - IF ( KPRINT .GE. 2 ) THEN - WRITE (LUN,99995)X, Y, Z -99995 FORMAT (/' EXAMPLE PROBLEM ',/' X = ',E20.13,' Y = ',E20.13,' Z = ', - * E20.13) - ENDIF - IF ( (IPASS .EQ. 1 ) .AND. (KPRINT .GT. 1) ) WRITE (LUN,99994) - IF ( (IPASS .EQ. 0 ) .AND. (KPRINT .NE. 0) ) WRITE (LUN,99993) -99994 FORMAT(/' ***************ADDXY PASSED ALL TESTS***************') -99993 FORMAT(/' ***************ADDXY FAILED SOME TESTS***************') - RETURN - END - - - - -******************************************************************************* - -SECTION 14. QUICK CHECK MAIN PROGRAM EXAMPLE - -The following is an example main program which should be used to drive a quick -check. The names of the quick check subroutines it calls, ADTST and DADTST, -should be replaced with the name or names of real quick checks. The dummy -names of the SLATEC routines being tested, ADDXY and DADDXY, should be -replaced with the names of the routines which are actually being tested. - - - PROGRAM TEST00 -C***BEGIN PROLOGUE TEST00 -C***SUBSIDIARY -C***PURPOSE Driver for testing SLATEC subprograms -C ADDXY DADDXY -C***LIBRARY SLATEC -C***CATEGORY A3 -C***TYPE ALL (TEST00-A) -C***KEYWORDS QUICK CHECK DRIVER, ADDXY, DADDXY -C***AUTHOR Suyehiro, Tok, (LLNL) -C Walton, Lee, (SNL) -C***DESCRIPTION -C -C *Usage: -C One input data record is required -C READ (LIN,990) KPRINT -C 990 FORMAT (I1) -C -C *Arguments: -C KPRINT = 0 Quick checks - No printing. -C Driver - Short pass or fail message printed. -C 1 Quick checks - No message printed for passed tests, -C short message printed for failed tests. -C Driver - Short pass or fail message printed. -C 2 Quick checks - Print short message for passed tests, -C fuller information for failed tests. -C Driver - Pass or fail message printed. -C 3 Quick checks - Print complete quick check results. -C Driver - Pass or fail message printed. -C -C *Description: -C Driver for testing SLATEC subprograms -C ADDXY DADDXY -C -C***REFERENCES (NONE) -C***ROUTINES CALLED ADTST, DADTST, I1MACH, XERMAX, XSETF, XSETUN -C***REVISION HISTORY (YYMMDD) -C 880511 DATE WRITTEN -C 880608 Revised to meet the new SLATEC prologue standards. -C 881103 Brought DESCRIPTION section up to Appendix E standards. -C***END PROLOGUE TEST00 -C -C***FIRST EXECUTABLE STATEMENT TEST00 - LUN = I1MACH(2) - LIN = I1MACH(1) - NFAIL = 0 -C -C Read KPRINT parameter -C - READ (LIN,990) KPRINT - 990 FORMAT (I1) - CALL XSETUN(LUN) - IF ( KPRINT .LE. 1 ) THEN - CALL XSETF(0) - ELSE - CALL XSETF(1) - ENDIF - CALL XERMAX(1000) -C -C Test ADDXY -C - CALL ADTST(LUN, KPRINT, IPASS) - IF ( IPASS .EQ. 0 ) NFAIL = NFAIL + 1 -C -C Test DADDXY -C - CALL DADTST(LUN, KPRINT, IPASS) - IF ( IPASS .EQ. 0 ) NFAIL = NFAIL + 1 -C - IF ( NFAIL .GT. 0 ) WRITE (LUN,980) NFAIL - 980 FORMAT (/' ************* WARNING -- ', I5, - * ' TEST(S) FAILED IN PROGRAM TEST00 *************' ) - IF ( NFAIL .EQ. 0 ) WRITE (LUN,970) - 970 FORMAT - * (/' --------------TEST00 PASSED ALL TESTS----------------') - END - - - - -******************************************************************************* - -APPENDIX A. GAMS (AND SLATEC) CLASSIFICATION SCHEME - -SLATEC has adopted the GAMS (Guide to Available Mathematical Software) -Classification Scheme for Mathematical and Statistical Software, -reference [5]. - - - GAMS (and SLATEC) Classification Scheme - for - Mathematical and Statistical Software - - - Version 1.2 October 1983 - - - - -A. Arithmetic, error analysis -A1. Integer -A2. Rational -A3. Real -A3A. Single precision -A3B. Double precision -A3C. Extended precision -A3D. Extended range -A4. Complex -A4A. Single precision -A4B. Double precision -A4C. Extended precision -A4D. Extended range -A5. Interval -A5A. Real -A5B. Complex -A6. Change of representation -A6A. Type conversion -A6B. Base conversion -A6C. Decomposition, construction -A7. Sequences (e.g., convergence acceleration) -B. Number theory -C. Elementary and special functions (search also class L5) -C1. Integer-valued functions (e.g., floor, ceiling, factorial, binomial - coefficient) -C2. Powers, roots, reciprocals -C3. Polynomials -C3A. Orthogonal -C3A1. Trigonometric -C3A2. Chebyshev, Legendre -C3A3. Laguerre -C3A4. Hermite -C3B. Non-orthogonal -C4. Elementary transcendental functions -C4A. Trigonometric, inverse trigonometric -C4B. Exponential, logarithmic -C4C. Hyperbolic, inverse hyperbolic -C4D. Integrals of elementary transcendental functions -C5. Exponential and logarithmic integrals -C6. Cosine and sine integrals -C7. Gamma -C7A. Gamma, log gamma, reciprocal gamma -C7B. Beta, log beta -C7C. Psi function -C7D. Polygamma function -C7E. Incomplete gamma -C7F. Incomplete beta -C7G. Riemann zeta -C8. Error functions -C8A. Error functions, their inverses, integrals, including the normal - distribution function -C8B. Fresnel integrals -C8C. Dawson's integral -C9. Legendre functions -C10. Bessel functions -C10A. J, Y, H-(1), H-(2) -C10A1. Real argument, integer order -C10A2. Complex argument, integer order -C10A3. Real argument, real order -C10A4. Complex argument, real order -C10A5. Complex argument, complex order -C10B. I, K -C10B1. Real argument, integer order -C10B2. Complex argument, integer order -C10B3. Real argument, real order -C10B4. Complex argument, real order -C10B5. Complex argument, complex order -C10C. Kelvin functions -C10D. Airy and Scorer functions -C10E. Struve, Anger, and Weber functions -C10F. Integrals of Bessel functions -C11. Confluent hypergeometric functions -C12. Coulomb wave functions -C13. Jacobian elliptic functions, theta functions -C14. Elliptic integrals -C15. Weierstrass elliptic functions -C16. Parabolic cylinder functions -C17. Mathieu functions -C18. Spheroidal wave functions -C19. Other special functions -D. Linear Algebra -D1. Elementary vector and matrix operations -D1A. Elementary vector operations -D1A1. Set to constant -D1A2. Minimum and maximum components -D1A3. Norm -D1A3A. L-1 (sum of magnitudes) -D1A3B. L-2 (Euclidean norm) -D1A3C. L-infinity (maximum magnitude) -D1A4. Dot product (inner product) -D1A5. Copy or exchange (swap) -D1A6. Multiplication by scalar -D1A7. Triad (a*x+y for vectors x,y and scalar a) -D1A8. Elementary rotation (Givens transformation) -D1A9. Elementary reflection (Householder transformation) -D1A10. Convolutions -D1B. Elementary matrix operations -D1B1. Set to zero, to identity -D1B2. Norm -D1B3. Transpose -D1B4. Multiplication by vector -D1B5. Addition, subtraction -D1B6. Multiplication -D1B7. Matrix polynomial -D1B8. Copy -D1B9. Storage mode conversion -D1B10. Elementary rotation (Givens transformation) -D1B11. Elementary reflection (Householder transformation) -D2. Solution of systems of linear equations (including inversion, LU and - related decompositions) -D2A. Real nonsymmetric matrices -D2A1. General -D2A2. Banded -D2A2A. Tridiagonal -D2A3. Triangular -D2A4. Sparse -D2B. Real symmetric matrices -D2B1. General -D2B1A. Indefinite -D2B1B. Positive definite -D2B2. Positive definite banded -D2B2A. Tridiagonal -D2B4. Sparse -D2C. Complex non-Hermitian matrices -D2C1. General -D2C2. Banded -D2C2A. Tridiagonal -D2C3. Triangular -D2C4. Sparse -D2D. Complex Hermitian matrices -D2D1. General -D2D1A. Indefinite -D2D1B. Positive definite -D2D2. Positive definite banded -D2D2A. Tridiagonal -D2D4. Sparse -D2E. Associated operations (e.g., matrix reorderings) -D3. Determinants -D3A. Real nonsymmetric matrices -D3A1. General -D3A2. Banded -D3A2A. Tridiagonal -D3A3. Triangular -D3A4. Sparse -D3B. Real symmetric matrices -D3B1. General -D3B1A. Indefinite -D3B1B. Positive definite -D3B2. Positive definite banded -D3B2A. Tridiagonal -D3B4. Sparse -D3C. Complex non-Hermitian matrices -D3C1. General -D3C2. Banded -D3C2A. Tridiagonal -D3C3. Triangular -D3C4. Sparse -D3D. Complex Hermitian matrices -D3D1. General -D3D1A. Indefinite -D3D1B. Positive definite -D3D2. Positive definite banded -D3D2A. Tridiagonal -D3D4. Sparse -D4. Eigenvalues, eigenvectors -D4A. Ordinary eigenvalue problems (Ax = (lambda) * x) -D4A1. Real symmetric -D4A2. Real nonsymmetric -D4A3. Complex Hermitian -D4A4. Complex non-Hermitian -D4A5. Tridiagonal -D4A6. Banded -D4A7. Sparse -D4B. Generalized eigenvalue problems (e.g., Ax = (lambda)*Bx) -D4B1. Real symmetric -D4B2. Real general -D4B3. Complex Hermitian -D4B4. Complex general -D4B5. Banded -D4C. Associated operations -D4C1. Transform problem -D4C1A. Balance matrix -D4C1B. Reduce to compact form -D4C1B1. Tridiagonal -D4C1B2. Hessenberg -D4C1B3. Other -D4C1C. Standardize problem -D4C2. Compute eigenvalues of matrix in compact form -D4C2A. Tridiagonal -D4C2B. Hessenberg -D4C2C. Other -D4C3. Form eigenvectors from eigenvalues -D4C4. Back transform eigenvectors -D4C5. Determine Jordan normal form -D5. QR decomposition, Gram-Schmidt orthogonalization -D6. Singular value decomposition -D7. Update matrix decompositions -D7A. LU -D7B. Cholesky -D7C. QR -D7D. Singular value -D8. Other matrix equations (e.g., AX+XB=C) -D9. Overdetermined or underdetermined systems of equations, singular systems, - pseudo-inverses (search also classes D5, D6, K1a, L8a) -E. Interpolation -E1. Univariate data (curve fitting) -E1A. Polynomial splines (piecewise polynomials) -E1B. Polynomials -E1C. Other functions (e.g., rational, trigonometric) -E2. Multivariate data (surface fitting) -E2A. Gridded -E2B. Scattered -E3. Service routines (e.g., grid generation, evaluation of fitted functions) - (search also class N5) -F. Solution of nonlinear equations -F1. Single equation -F1A. Smooth -F1A1. Polynomial -F1A1A. Real coefficients -F1A1B. Complex coefficients -F1A2. Nonpolynomial -F1B. General (no smoothness assumed) -F2. System of equations -F2A. Smooth -F2B. General (no smoothness assumed) -F3. Service routines (e.g., check user-supplied derivatives) -G. Optimization (search also classes K, L8) -G1. Unconstrained -G1A. Univariate -G1A1. Smooth function -G1A1A. User provides no derivatives -G1A1B. User provides first derivatives -G1A1C. User provides first and second derivatives -G1A2. General function (no smoothness assumed) -G1B. Multivariate -G1B1. Smooth function -G1B1A. User provides no derivatives -G1B1B. User provides first derivatives -G1B1C. User provides first and second derivatives -G1B2. General function (no smoothness assumed) -G2. Constrained -G2A. Linear programming -G2A1. Dense matrix of constraints -G2A2. Sparse matrix of constraints -G2B. Transportation and assignments problem -G2C. Integer programming -G2C1. Zero/one -G2C2. Covering and packing problems -G2C3. Knapsack problems -G2C4. Matching problems -G2C5. Routing, scheduling, location problems -G2C6. Pure integer programming -G2C7. Mixed integer programming -G2D. Network (for network reliability search class M) -G2D1. Shortest path -G2D2. Minimum spanning tree -G2D3. Maximum flow -G2D3A. Generalized networks -G2D3B. Networks with side constraints -G2D4. Test problem generation -G2E. Quadratic programming -G2E1. Positive definite Hessian (i.e. convex problem) -G2E2. Indefinite Hessian -G2F. Geometric programming -G2G. Dynamic programming -G2H. General nonlinear programming -G2H1. Simple bounds -G2H1A. Smooth function -G2H1A1. User provides no derivatives -G2H1A2. User provides first derivatives -G2H1A3. User provides first and second derivatives -G2H1B. General function (no smoothness assumed) -G2H2. Linear equality or inequality constraints -G2H2A. Smooth function -G2H2A1. User provides no derivatives -G2H2A2. User provides first derivatives -G2H2A3. User provides first and second derivatives -G2H2B. General function (no smoothness assumed) -G2H3. Nonlinear constraints -G2H3A. Equality constraints only -G2H3A1. Smooth function and constraints -G2H3A1A. User provides no derivatives -G2H3A1B. User provides first derivatives of function and constraints -G2H3A1C. User provides first and second derivatives of function and - constraints -G2H3A2. General function and constraints (no smoothness assumed) -G2H3B. Equality and inequality constraints -G2H3B1. Smooth function and constraints -G2H3B1A. User provides no derivatives -G2H3B1B. User provides first derivatives of function and constraints -G2H3B1C. User provides first and second derivatives of function and - constraints -G2H3B2. General function and constraints (no smoothness assumed) -G2I. Global solution to nonconvex problems -G3. Optimal control -G4. Service routines -G4A. Problem input (e.g., matrix generation) -G4B. Problem scaling -G4C. Check user-supplied derivatives -G4D. Find feasible point -G4E. Check for redundancy -G4F. Other -H. Differentiation, integration -H1. Numerical differentiation -H2. Quadrature (numerical evaluation of definite integrals) -H2A. One-dimensional integrals -H2A1. Finite interval (general integrand) -H2A1A. Integrand available via user-defined procedure -H2A1A1. Automatic (user need only specify required accuracy) -H2A1A2. Nonautomatic -H2A1B. Integrand available only on grid -H2A1B1. Automatic (user need only specify required accuracy) -H2A1B2. Nonautomatic -H2A2. Finite interval (specific or special type integrand including weight - functions, oscillating and singular integrands, principal value - integrals, splines, etc.) -H2A2A. Integrand available via user-defined procedure -H2A2A1. Automatic (user need only specify required accuracy) -H2A2A2. Nonautomatic -H2A2B. Integrand available only on grid -H2A2B1. Automatic (user need only specify required accuracy) -H2A2B2. Nonautomatic -H2A3. Semi-infinite interval (including e**(-x) weight function) -H2A3A. Integrand available via user-defined procedure -H2A3A1. Automatic (user need only specify required accuracy) -H2A3A2. Nonautomatic -H2A4. Infinite interval (including e**(-x**2)) weight function) -H2A4A. Integrand available via user-defined procedure -H2A4A1. Automatic (user need only specify required accuracy) -H2A4A2. Nonautomatic -H2B. Multidimensional integrals -H2B1. One or more hyper-rectangular regions -H2B1A. Integrand available via user-defined procedure -H2B1A1. Automatic (user need only specify required accuracy) -H2B1A2. Nonautomatic -H2B1B. Integrand available only on grid -H2B1B1. Automatic (user need only specify required accuracy) -H2B1B2. Nonautomatic -H2B2. Nonrectangular region, general region -H2B2A. Integrand available via user-defined procedure -H2B2A1. Automatic (user need only specify required accuracy) -H2B2A2. Nonautomatic -H2B2B. Integrand available only on grid -H2B2B1. Automatic (user need only specify required accuracy) -H2B2B2. Nonautomatic -H2C. Service routines (compute weight and nodes for quadrature formulas) -I. Differential and integral equations -I1. Ordinary differential equations -I1A. Initial value problems -I1A1. General, nonstiff or mildly stiff -I1A1A. One-step methods (e.g., Runge-Kutta) -I1A1B. Multistep methods (e.g., Adams' predictor-corrector) -I1A1C. Extrapolation methods (e.g., Bulirsch-Stoer) -I1A2. Stiff and mixed algebraic-differential equations -I1B. Multipoint boundary value problems -I1B1. Linear -I1B2. Nonlinear -I1B3. Eigenvalue (e.g., Sturm-Liouville) -I1C. Service routines (e.g., interpolation of solutions, error handling) -I2. Partial differential equations -I2A. Initial boundary value problems -I2A1. Parabolic -I2A1A. One spatial dimension -I2A1B. Two or more spatial dimensions -I2A2. Hyperbolic -I2B. Elliptic boundary value problems -I2B1. Linear -I2B1A. Second order -I2B1A1. Poisson (Laplace) or Helmholz equation -I2B1A1A. Rectangular domain (or topologically rectangular in the coordinate - system) -I2B1A1B. Nonrectangular domain -I2B1A2. Other separable problems -I2B1A3. Nonseparable problems -I2B1C. Higher order equations (e.g., biharmonic) -I2B2. Nonlinear -I2B3. Eigenvalue -I2B4. Service routines -I2B4A. Domain triangulation (search also class P2a2c1) -I2B4B. Solution of discretized elliptic equations -I3. Integral equations -J. Integral transforms -J1. Fast Fourier transforms (search class L10 for time series analysis) -J1A. One-dimensional -J1A1. Real -J1A2. Complex -J1A3. Trigonometric (sine, cosine) -J1B. Multidimensional -J2. Convolutions -J3. Laplace transforms -J4. Hilbert transforms -K. Approximation (search also class L8) -K1. Least squares (L-2) approximation -K1A. Linear least squares (search also classes D5, D6, D9) -K1A1. Unconstrained -K1A1A. Univariate data (curve fitting) -K1A1A1. Polynomial splines (piecewise polynomials) -K1A1A2. Polynomials -K1A1A3. Other functions (e.g., rational, trigonometric, user-specified) -K1A1B. Multivariate data (surface fitting) -K1A2. Constrained -K1A2A. Linear constraints -K1A2B. Nonlinear constraints -K1B. Nonlinear least squares -K1B1. Unconstrained -K1B1A. Smooth functions -K1B1A1. User provides no derivatives -K1B1A2. User provides first derivatives -K1B1A3. User provides first and second derivatives -K1B1B. General functions -K1B2. Constrained -K1B2A. Linear constraints -K1B2B. Nonlinear constraints -K2. Minimax (L-infinity) approximation -K3. Least absolute value (L-1) approximation -K4. Other analytic approximations (e.g., Taylor polynomial, Pade) -K5. Smoothing -K6. Service routines (e.g., mesh generation, evaluation of fitted functions) - (search also class N5) -L. Statistics, probability -L1. Data summarization -L1A. One univariate quantitative sample -L1A1. Ungrouped data -L1A1A. Location -L1A1B. Dispersion -L1A1C. Shape -L1A1D. Distribution, density -L1A2. Ungrouped data with missing values -L1A3. Grouped data -L1A3A. Location -L1A3B. Dispersion -L1A3C. Shape -L1C. One univariate qualitative (proportional) sample -L1E. Two or more univariate samples or one multivariate sample -L1E1. Ungrouped data -L1E1A. Location -L1E1B. Correlation -L1E2. Ungrouped data with missing values -L1E3. Grouped data -L1F. Two or more multivariate samples -L2. Data manipulation (search also class N) -L2A. Transform (search also class N6 for sorting, ranking) -L2B. Group -L2C. Sample -L2D. Subset -L3. Graphics (search also class Q) -L3A. Histograms -L3B. Distribution functions -L3C. Scatter diagrams -L3C1. Y vs. X -L3C2. Symbol plots -L3C3. Multiple plots -L3C4. Probability plots -L3C4B. Beta, binomial -L3C4C. Cauchy, chi-squared -L3C4D. Double exponential -L3C4E. Exponential, extreme value -L3C4F. F distribution -L3C4G. Gamma, geometric -L3C4H. Halfnormal -L3C4L. Lambda, logistic, lognormal -L3C4N. Negative binomial, normal -L3C4P. Pareto, Poisson -L3C4T. t distribution -L3C4U. Uniform -L3C4W. Weibull -L3C5. Time series plots (X(i) vs. i, vertical, lag) -L3D. EDA graphics -L4. Elementary statistical inference, hypothesis testing -L4A. One univariate quantitative sample -L4A1. Ungrouped data -L4A1A. Parameter estimation -L4A1A2. Binomial -L4A1A5. Extreme value -L4A1A14. Normal -L4A1A16. Poisson -L4A1A21. Uniform -L4A1A23. Weibull -L4A1B. Distribution-free (nonparametric) analysis -L4A1C. Goodness-of-fit tests -L4A1D. Tests on sequences of numbers -L4A1E. Density and distribution function estimation -L4A1F. Tolerance limits -L4A2. Ungrouped data with missing values -L4A3. Grouped data -L4A3A. Parameter estimation -L4A3A14. Normal -L4B. Two or more univariate quantitative samples -L4B1. Ungrouped data -L4B1A. Parameter estimation -L4B1A14. Normal -L4B1B. Distribution-free (nonparametric) analysis -L4B2. Ungrouped data with missing values -L4B3. Grouped data -L4C. One univariate qualitative (proportional) sample -L4D. Two or more univariate samples -L4E. One multivariate sample -L4E1. Ungrouped data -L4E1A. Parameter estimation -L4E1A14. Normal -L4E1B. Distribution-free (nonparametric) analysis -L4E2. Ungrouped data with missing values -L4E2A. Parameter estimation -L4E2B. Distribution-free (nonparametric) analysis -L4E3. Grouped data -L4E3A. Parameter estimation -L4E3A14. Normal -L4E3B. Distribution-free (nonparametric) analysis -L4E4. Two or more multivariate samples -L4E4A. Parameter estimation -L4E4A14. Normal -L5. Function evaluation (search also class C) -L5A. Univariate -L5A1. Cumulative distribution functions, probability density functions -L5A1B. Beta, binomial -L5A1C. Cauchy, chi-squared -L5A1D. Double exponential -L5A1E. Error function, exponential, extreme value -L5A1F. F distribution -L5A1G. Gamma, general, geometric -L5A1H. Halfnormal, hypergeometric -L5A1K. Kolmogorov-Smirnov -L5A1L. Lambda, logistic, lognormal -L5A1N. Negative binomial, normal -L5A1P. Pareto, Poisson -L5A1T. t distribution -L5A1U. Uniform -L5A1W. Weibull -L5A2. Inverse cumulative distribution functions, sparsity functions -L5A2B. Beta, binomial -L5A2C. Cauchy, chi-squared -L5A2D. Double exponential -L5A2E. Exponential, extreme value -L5A2F. F distribution -L5A2G. Gamma, general, geometric -L5A2H. Halfnormal -L5A2L. Lambda, logistic, lognormal -L5A2N. Negative binomial, normal, normal scores -L5A2P. Pareto, Poisson -L5A2T. t distribution -L5A2U. Uniform -L5A2W. Weibull -L5B. Multivariate -L5B1. Cumulative distribution functions, probability density functions -L5B1N. Normal -L6. Pseudo-random number generation -L6A. Univariate -L6A2. Beta, binomial, Boolean -L6A3. Cauchy, chi-squared -L6A4. Double exponential -L6A5. Exponential, extreme value -L6A6. F distribution -L6A7. Gamma, general (continuous, discrete) distributions, geometric -L6A8. Halfnormal, hypergeometric -L6A9. Integers -L6A12. Lambda, logical, logistic, lognormal -L6A14. Negative binomial, normal -L6A15. Order statistics -L6A16. Pareto, permutations, Poisson -L6A19. Samples, stable distribution -L6A20. t distribution, time series, triangular -L6A21. Uniform -L6A22. Von Mises -L6A23. Weibull -L6B. Multivariate -L6B3. Contingency table, correlation matrix -L6B13. Multinomial -L6B14. Normal -L6B15. Orthogonal matrix -L6B21. Uniform -L6C. Service routines (e.g., seed) -L7. Experimental design, including analysis of variance -L7A. Univariate -L7A1. One-way analysis of variance -L7A1A. Parametric analysis -L7A1A1. Contrasts, multiple comparisons -L7A1A2. Analysis of variance components -L7A1B. Distribution-free (nonparametric) analysis -L7A2. Balanced multiway design -L7A2A. Complete -L7A2A1. Parametric analysis -L7A2A1A. Two-way -L7A2A1B. Factorial -L7A2A1C. Nested -L7A2A2. Distribution-free (nonparametric) analysis -L7A2B. Incomplete -L7A2B1. Parametric analysis -L7A2B1A. Latin square -L7A2B1B. Lattice designs -L7A2B2. Distribution-free (nonparametric) analysis -L7A3. Analysis of covariance -L7A4. General linear model (unbalanced design) -L7A4A. Parametric analysis -L7A4B. Distribution-free (nonparametric) analysis -L7B. Multivariate -L8. Regression (search also classes G, K) -L8A. Linear least squares (L-2) (search also classes D5, D6, D9) -L8A1. Simple -L8A1A. Ordinary -L8A1A1. Unweighted -L8A1A1A. No missing values -L8A1A1B. Missing values -L8A1A2. Weighted -L8A1B. Through the origin -L8A1C. Errors in variables -L8A1D. Calibration (inverse regression) -L8A2. Polynomial -L8A2A. Not using orthogonal polynomials -L8A2A1. Unweighted -L8A2A2. Weighted -L8A2B. Using orthogonal polynomials -L8A2B1. Unweighted -L8A2B2. Weighted -L8A3. Piecewise polynomial (i.e. multiphase or spline) -L8A4. Multiple -L8A4A. Ordinary -L8A4A1. Unweighted -L8A4A1A. No missing values -L8A4A1B. Missing values -L8A4A1C. From correlation data -L8A4A1D. Using principal components -L8A4A1E. Using preference pairs -L8A4A2. Weighted -L8A4B. Errors in variables -L8A4D. Logistic -L8A5. Variable selection -L8A6. Regression design -L8A7. Several multiple regressions -L8A8. Multivariate -L8A9. Diagnostics -L8A10. Hypothesis testing, inference -L8A10A. Lack-of-fit tests -L8A10B. Analysis of residuals -L8A10C. Inference -L8B. Biased (ridge) -L8C. Linear least absolute value (L-1) -L8D. Linear minimax (L-infinity) -L8E. Robust -L8F. EDA -L8G. Nonlinear -L8G1. Unweighted -L8G1A. Derivatives not supplied -L8G1B. Derivatives supplied -L8G2. Weighted -L8G2A. Derivatives not supplied -L8G2B. Derivatives supplied -L8H. Service routines -L9. Categorical data analysis -L9A. 2-by-2 tables -L9B. Two-way tables -L9C. Log-linear model -L9D. EDA (e.g., median polish) -L10. Time series analysis (search also class L3c5 for time series graphics) -L10A. Transformations, transforms (search also class J1) -L10B. Smoothing, filtering -L10C. Autocorrelation analysis -L10D. Complex demodulation -L10E. ARMA and ARIMA modeling and forecasting -L10E1. Model and parameter estimation -L10E2. Forecasting -L10F. Spectral analysis -L10G. Cross-correlation analysis -L10G1. Parameter estimation -L10G2. Forecasting -L11. Correlation analysis -L12. Discriminant analysis -L13. Factor analysis -L13A. Principal components analysis -L14. Cluster analysis -L14A. Unconstrained -L14A1. Nested -L14A1A. Joining (e.g., single link) -L14A1B. Divisive -L14A2. Non-nested -L14B. Constrained -L14B1. One-dimensional -L14B2. Two-dimensional -L14C. Display -L15. Life testing, survival analysis -M. Simulation, stochastic modeling (search also classes L6, L10) -M1. Simulation -M1A. Discrete -M1B. Continuous (Markov models) -M2. Queueing -M3. Reliability -M3A. Quality control -M3B. Electrical network -M4. Project optimization (e.g., PERT) -N. Data handling (search also class L2) -N1. Input, output -N2. Bit manipulation -N3. Character manipulation -N4. Storage management (e.g., stacks, heaps, trees) -N5. Searching -N5A. Extreme value -N5B. Insertion position -N5C. On a key -N6. Sorting -N6A. Internal -N6A1. Passive (i.e. construct pointer array, rank) -N6A1A. Integer -N6A1B. Real -N6A1B1. Single precision -N6A1B2. Double precision -N6A1C. Character -N6A2. Active -N6A2A. Integer -N6A2B. Real -N6A2B1. Single precision -N6A2B2. Double precision -N6A2C. Character -N6B. External -N7. Merging -N8. Permuting -O. Symbolic computation -P. Computational geometry (search also classes G, Q) -P1. One dimension -P2. Two dimensions -P2A. Points, lines -P2A1. Relationships -P2A1A. Closest and farthest points -P2A1B. Intersection -P2A2. Graph construction -P2A2A. Convex hull -P2A2B. Minimum spanning tree -P2A2C. Region partitioning -P2A2C1. Triangulation -P2A2C2. Voronoi diagram -P2B. Polygons (e.g., intersection, hidden line problems) -P2C. Circles -P3. Three dimensions -P3A. Points, lines, planes -P3B. Polytopes -P3C. Spheres -P4. More than three dimensions -Q. Graphics (search also classes L3, P) -Q1. Line printer plotting -R. Service routines -R1. Machine-dependent constants -R2. Error checking (e.g., check monotonicity) -R3. Error handling -R3A. Set criteria for fatal errors -R3B. Set unit number for error messages -R3C. Other utility programs -R4. Documentation retrieval -S. Software development tools -S1. Program transformation -S2. Static analysis -S3. Dynamic analysis -Z. Other - - - - -******************************************************************************* - -APPENDIX B. MACHINE CONSTANTS - -The SLATEC Common Math Library uses three functions for keeping machine -constants. In order to keep the source code for the Library as portable as -possible, no other Library routines should attempt to DATA load machine -dependent constants. Due to the subtlety of trying to calculate machine -constants at run time in a manner that yields correct constants for all -possible computers, no Library routines should attempt to calculate them. -Routines I1MACH, R1MACH, and D1MACH in the SLATEC Common Math Library are -derived from the routines of these names in the Bell Laboratories' PORT Library -and should be called whenever machines constants are needed. These functions -are DATA loaded with carefully determined constants of type integer, single -precision, and double precision, respectively, for a wide range of computers. -Each is called with one input argument to indicate which constant is desired. -The appropriate Fortran statements are: - -For integer constants: - - INTEGER I1MACH, I - I = I1MACH(N) where 1 .LE. N .LE. 16 - -For single precision constants: - - REAL R1MACH, R - R = R1MACH(N) where 1 .LE. N .LE. 5 - -For double precision constants: - - DOUBLE PRECISION D1MACH, D - D = D1MACH(N) where 1 .LE. N .LE. 5 - -The different constants that can be retrieved will be explained below after we -give a summary of the floating point arithmetic model which they characterize. - -The PORT and SLATEC machine constant routines acknowledge that a computer -can have some minor flaws in how it performs arithmetic and that the purpose of -machine constant routines is to keep other library routines out of trouble. -For example, a computer may have a 48-bit coefficient, but due to round-off or -other deficiencies may be able to perform only 47-bit (or even 46-bit) -arithmetic reliably. A machine can also misbehave at the extreme ends of its -exponent range. The machine constants are chosen to describe a subset of the -floating point numbers of a computer on which operations such as addition, -subtraction, multiplication, reciprocation, and comparison work as your -intuition would expect. If the actual performance of the machine is such that -results fall into the "expected" intervals of the subset floating point system, -then the usual forms of error analysis will apply. For details, see [7]. - -The machine constants normally cannot be determined by reading a computer's -hardware reference manual. Such manuals tell the range and representation of -floating point numbers but usually do not describe the errors in the floating -point addition, subtraction, multiplication, reciprocation, or division units. -The constants for I1MACH, R1MACH, and D1MACH are found by doing extensive -testing using operands on which the hardware is most likely to fail. Failure -is most likely to occur at the extreme ends of the exponent range and near -powers of the number base. If such failures are relatively minor, we can -choose machine constants for I1MACH, R1MACH, and D1MACH to restrict the domain -of floating point numbers to a subset on which arithmetic operations work. - -The subset model of floating point arithmetic is characterized by four -parameters: - - B the number base or radix. This is usually 2 or 16. - - T the number of digits in base B of the coefficient of the floating - point number. - - EMIN the smallest (most negative) exponent (power of B) - - EMAX the largest exponent (power of B) - -A floating point number is modeled as FRACTION*(B**EXP) where EXP falls between -EMIN and EMAX and the FRACTION is of the form - - + or - ( f(1)*B**(-1) + ... + f(T)*B**(-T) ) - - with f(1) in the range 1 to B-1 inclusive and - f(2) through f(T) in the range 0 to B-1 inclusive. - -In this model the fraction has the radix point at the left end. Some computers -have their radix point at the right end so that when their representation is -mapped onto this model, they appear to have an unbalanced exponent range (i.e., -EMIN is not close to the negative of EMAX). If the computer cannot correctly -calculate results near underflow, EMIN is increased to a more conservative -value. Likewise, if the computer cannot correctly calculate results near -overflow, EMAX is decreased. If a base 2 machine with a 48-bit fraction is -unable to calculate 48-bit results due to hardware round-off, T may be set to -47 (or even 46) to account for the loss of accuracy. - -The complete set of machine constants (including those not related to floating -point arithmetic) are: - -I/O Unit Numbers ----------------- - -I1MACH( 1) = the FORTRAN unit number for the standard input device. - -I1MACH( 2) = the FORTRAN unit number for the standard output device. - -I1MACH( 3) = the FORTRAN unit number for the standard punch device. - -I1MACH( 4) = the FORTRAN unit number for the standard error message device. - -Word Properties ---------------- - -I1MACH( 5) = the number of bits per integer storage unit. - -I1MACH( 6) = the number of characters per integer storage unit. - -Integer Arithmetic ------------------- - -I1MACH( 7) = the base or radix for integer arithmetic. - -I1MACH( 8) = the number of digits in radix I1MACH(7) used in integer - arithmetic. - -I1MACH( 9) = the largest magnitude integer for which the machine and compiler - perform the complete set of arithmetic operations. - -Floating Point Arithmetic -------------------------- - -I1MACH(10) = the base or radix for floating point arithmetic. This is the B - of the floating point model. - -Single Precision Arithmetic ---------------------------- - -I1MACH(11) = the number of digits in radix I1MACH(10) used in single precision - arithmetic. This is the T in the floating point model. - -I1MACH(12) = the most negative usable exponent short of underflow of radix - I1MACH(10) for a single precision number. This is the EMIN in the - floating point model. - -I1MACH(13) = the largest usable exponent short of overflow of radix I1MACH(10) - for a single precision number. This is the EMAX in the floating - point model. - -Double Precision Arithmetic ---------------------------- - -I1MACH(14) = the number of digits in radix I1MACH(10) used in double precision - arithmetic. This is the T of the floating point model. - -I1MACH(15) = the most negative usable exponent short of underflow of radix - I1MACH(10) for a double precision number. This is the EMIN of - the floating point model. - -I1MACH(16) = the largest usable exponent short of overflow of radix I1MACH(10) - for a double precision number. This is the EMAX of the floating - point model. - -Special Single Precision Values -------------------------------- - -R1MACH( 1) = B**(EMIN-1). This is the smallest, positive, single precision - number in the range for safe, accurate arithmetic. - -R1MACH( 2) = B**EMAX*(1-B**(-T)). This is the largest, positive, single - precision number in the range for safe, accurate arithmetic. - -R1MACH( 3) = B**(-T). This is the smallest relative spacing between two - adjacent single precision numbers in the floating point model. - This constant is not machine epsilon; see below for machine - epsilon. - -R1MACH( 4) = B**(1-T). This is the largest relative spacing between two - adjacent single precision numbers in the floating point model. - Any two single precision numbers that have a greater relative - spacing than R1MACH(4) can be compared correctly (with operators - like .EQ. or .LT.). This constant is an upper bound on theoretical - machine epsilon. - -R1MACH( 5) = logarithm to base ten of the machine's floating point number base. - -Special Double Precision Values -------------------------------- - -D1MACH( 1) = B**(EMIN-1). This is the smallest, positive, double precision - numbers in the range for safe, accurate arithmetic. - -D1MACH( 2) = B**EMAX*(1-B**(-T)). This is the largest, positive, double - precision number in the range for safe, accurate arithmetic. - -D1MACH( 3) = B**(-T). This is the smallest relative spacing between two - adjacent double precision numbers in the floating point model. - This constant is not machine epsilon; see below for machine - epsilon. - -D1MACH( 4) = B**(1-T). This is the largest relative spacing between two - adjacent double precision numbers in the floating point model. - Any two double precision numbers that have a greater relative - spacing than D1MACH(4) can be compared correctly (with operators - like .EQ. or .LT.). This constant is an upper bound on theoretical - machine epsilon. - -D1MACH( 5) = logarithm to base ten of the machine's floating point number base. - -In theory, all of the R1MACH and D1MACH values can be calculated from I1MACH -values; however, they are provided (1) to save having to calculate them and (2) -to avoid rousing any bugs in the exponentiation (** operator ) or logarithm -routines. - -Machine epsilon (the smallest number that can be added to 1.0 or 1.0D0 -that yields a result different from 1.0 or 1.0D0) is not one of the special -values that comes from this model. If the purpose of machine epsilon is to -decide when iterations have converged, the proper constants to use are -R1MACH(4) or D1MACH(4). These may be slightly larger than machine epsilon; -however, trying to iterate to smaller relative differences may not be possible -due to hardware round-off error. - -The Fortran standard requires that the amount of storage assigned to an INTEGER -and a REAL be the same. Thus, the number of bits that can be used to represent -an INTEGER will almost always be larger than the number of bits in the mantissa -of a REAL. In converting from an INTEGER to a REAL, some machines will -correctly round or truncate, but some will not. Authors are therefore advised -to check the magnitude of INTEGERs and not attempt to convert INTEGERs to REALs -that can not be represented exactly as REALs. Similar problems can occur when -converting INTEGERs to DOUBLEs. - - - - -******************************************************************************* - -APPENDIX C. ERROR HANDLING - -Authors of Library routines must use at least the first and preferably both of -the following techniques to handle errors that their routines detect. - -1. One argument, preferably the last, in the calling sequence must be an - error flag if the routine can detect errors. This is an integer variable - to which a value is assigned before returning to the caller. A value of - zero means the routine completed successfully. A positive value (preferably - in the range 1 to 999) should be used to indicate potential, partial, or - total failure. Separate values should be used for distinct conditions so - that the caller can determine the nature of the failure. Of course, the - possible values of this error flag and their meanings must be documented in - the description section of the prologue of the routine. - -2. In addition to returning an error flag, the routine can supply more - information by writing an error message via a call to XERMSG. XERMSG - has an error number as one of its arguments, and the same value that will - be returned in the error flag argument must be used in calling XERMSG. - -XERMSG is part of the SLATEC Common Math Library error handling package -which consists of a number of routines. It is not necessary for authors to -learn about the entire package. Instead we summarize here a few aspects of the -package that an author must know in order to use XERMSG correctly. - -1. Although XERMSG supports three levels of severity (warning, recoverable - error, and fatal error), be sparing in the use of fatal errors. XERMSG - will terminate the program for fatal errors but may return for recoverable - errors, and will definitely return after warning messages. An error should - be designated fatal only if returning to the caller is likely to be - disastrous (e.g. result in an infinite loop). - -2. The error handling package remembers the value of the error number and has - an entry point whereby the user can retrieve the most recent error number. - Successive calls to XERMSG replace this retained value. In the case of - warning messages, it is permissible to issue multiple warnings. In the - case of a recoverable error, no additional calls to XERMSG must be made by - the Library routine before returning to the caller since the caller must be - given a chance to retrieve and clear the error number (and error condition) - from the error handling package. In particular, if the user calls Library - routine X and X calls a lower level Library Y, it is permissible for Y - to call XERMSG, but after it returns to X, X must be careful to note any - recoverable errors detected in Y and not make any additional calls to - XERMSG in that case. In practice, it would be simpler if subsidiary - routines did not call XERMSG but only returned error flags indicating a - serious problem. Then the highest level Library routine could call XERMSG - just before returning to its caller. This also allows the highest level - routine the most flexibility in assigning error numbers and assures that - all possible error conditions are documented in one prologue rather than - being distributed through prologues of subsidiary routines. - -Below we describe only subroutine XERMSG. Other routines in the error -handling package are described in their prologues and in Reference [4]. -The call to XERMSG looks like - -Template: CALL XERMSG (library, routine, message, errornumber, level) - -Example: CALL XERMSG ('SLATEC', 'MMPY', - 1 'The order of the matrix exceeds the row dimension', 3, 1) - -where the meaning of the arguments is - -library 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. - -routine 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. - -message 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 '$$'. - -errornumber An integer value that is chosen by the library routine's author. - It must be in the range 1 to 999. 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 - - 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. - - - - -******************************************************************************* - -APPENDIX D. DISTRIBUTION FILE STRUCTURE - -The source files of the SLATEC library distribution tape are ASCII text files. -Each line image consists of exactly 80 characters. The first file of the tape -is text file describing the contents of the tape. - -The SLATEC source code file has the following characteristics. - -1. All subprograms in the file are in alphabetic order. The collating - sequence is 0 through 9 and then A through Z. - -2. Before each subprogram, of name for example XYZ, there is a line starting - in column 1 with - - *DECK XYZ - - This allows the source file to be used as input for a source code - maintenance program. - -3. No comments other than the *DECK lines appear between subprograms. - - - - -******************************************************************************* - -APPENDIX E. SUGGESTED FORMAT FOR A SLATEC SUBPROGRAM - -A template embodying the suggested format for a SLATEC subprogram is given -below. As elsewhere in this Guide, the caret (^) denotes a required blank -character. These should be replaced with blanks AFTER filling out the -template. The template itself begins with the *DECK line, below. All -occurrences of "NAME" are to be replaced with the actual name of the -subprogram, of course. Items in brackets [] are either explanations or -optional information. Lines that do not have C or * in column 1 are -explanatory remarks that are intended to be deleted by the programmer. In all -cases where "or" is used, exactly one of the indicated forms must occur. - -Lines that begin with C*** are standard SLATEC lines. These must be in the -indicated order. See Section 8 of this Guide for information on required vs -optional lines. In all but the C***DESCRIPTION section, the exact spacing and -punctuation are as mandated by this Guide. Spacing within this section is only -suggestive, except as noted below. The SLATEC standard mandates that no other -comments may begin "C***". All other lines between the C***BEGIN^PROLOGUE -and the C***END^PROLOGUE must be comment lines with "C^" in columns 1-2. - -Within the C***DESCRIPTION section, lines that begin with "C^*" are for the -LLNL LDOC standard [9]. If present, these lines must be exactly as given here. -They should be in the indicated order. All other lines in this section must -have "C^^" in columns 1-3. - -In the Arguments subsection, each argument must be followed by exactly one -argument qualifier. The qualifier must be preceded by a colon and followed -by at least one blank. The allowable qualifiers and their meanings follow. - - Qualifier Meaning - --------- --------- - :IN input variable. Must be set by the user prior to the call - (unless otherwise indicated). Must NOT be changed by the - routine under any circumstances. - :OUT output variable. Values will be set by the routine. - Must be initialized before first usage in the routine. - :INOUT input/output variable. Must be set by the user prior to - the call (as indicated in argument description); value(s) - may be set or changed by the routine. - :WORK workspace. Simply working storage required by the routine. - Need not be set prior to the call and will not contain - information meaningful to the user on return. (Some - routines require the contents of a work array to remain - unchanged between successive calls. Such usage should be - carefully explained in the argument description.) - :EXT external procedure. The actual argument must be the name of - a SUBROUTINE, FUNCTION, or BLOCK DATA subprogram. It must - appear in an EXTERNAL statement in the calling program. The - argument description following should precisely specify the - expected calling sequence. - :DUMMY dummy argument. Need not be set by user; will not be - referenced by the routine. [Use discouraged!] - -To avoid potential problems with automatic formatting of argument descriptions, -none of these key words should appear anywhere else in the text immediately -preceded by a colon. - -NOTES: - 1. Make a template by copying the following "*DECK^NAME" through - "^^^^^^END" lines, inclusive, from this Guide. - 2. You will probably want to customize this template by filling - in the C***AUTHOR section and adding other things you customarily - include in your prologues. If all of your routines are in the same - category(ies), you may wish to fill in the C***CATEGORY and - C***KEYWORDS sections, too. Be sure to eliminate the brackets []. - 3. Be sure to delete the "C***SUBSIDIARY" line if this is a user- - callable routine. - - -*DECK^NAME -^^^^^^SUBROUTINE^NAME[^(ARG1[,^ARG2[,^...]])] or -^^^^^^FUNCTION^NAME^(ARG1[,^ARG2[,^...]]) or -^^^^^^COMPLEX^FUNCTION^NAME^(ARG1[,^ARG2[,^...]]) or -^^^^^^DOUBLE^PRECISION^FUNCTION^NAME^(ARG1[,^ARG2[,^...]]) or -^^^^^^INTEGER^FUNCTION^NAME^(ARG1[,^ARG2[,^...]]) or -^^^^^^REAL^FUNCTION^NAME^(ARG1[,^ARG2[,^...]]) or -^^^^^^LOGICAL^FUNCTION^NAME^(ARG1[,^ARG2[,^...]]) or -^^^^^^CHARACTER[*len]^FUNCTION^NAME^(ARG1[,^ARG2[,^...]]) -C***BEGIN^PROLOGUE^^NAME -C***SUBSIDIARY -C***PURPOSE^^Brief (1-6 lines) summary of the purpose of this routine. -C^^^^^^^^^^^^(To best fit LDOC standards, first line should be suitable -C^^^^^^^^^^^^for a table of contents entry for this routine.) -C***LIBRARY^^^SLATEC[^(Package)] -C***CATEGORY^^CAT1[,^CAT2] -C***TYPE^^^^^^SINGLE PRECISION^(NAME-S,^DNAME-D) -C***KEYWORDS^^KEY1[,^KEY2[, -C^^^^^^^^^^^^^MORE]] -C***AUTHOR^^Last-name[,^First-name[,^(Organization)]][ -C^^^^^^^^^^^^^More information][ -C^^^^^^^^^^^Second-last-name[,^First-name[,^(Organization)]][ -C^^^^^^^^^^^^^More information]] -C***DESCRIPTION -C^^ -C^*Usage: -C^^ This subsection should have declarations for all arguments to the -C^^ routine and a model call of the routine. Use the actual names of -C^^ the arguments here. Ideally, arguments should be named in a way -C^^ that suggests their meaning. -C^^ The following example illustrates the use of dummy identifiers (in -C^^ lower case) to indicate that the required size of an array is -C^^ some function of the values of the other arguments. This may not -C^^ be legal Fortran, but should be easier for a knowledgeable user -C^^ to understand than giving the required size somewhere else. -C^^ -C^^ INTEGER M, N, MDIMA, IERR -C^^ PARAMETER (nfcns = 6, nwks = 3*nfcns+M+7) -C^^ REAL X(nmax), A(MDIMA,nmax), FCNS(nfcns), WKS(nwks) -C^^ -C^^ CALL NAME (M, N, X, A, MDIMA, FCNS, WKS, IERR) -C^^ -C^*Arguments: -C^^ Arguments should be described in exactly the same order as in the -C^^ CALL list. Include any restrictions, etc. -C^^ The following illustrates the recommended form of argument descrip- -C^^ tions for the example given above. Note the use of qualifiers. -C^^ -C^^ M :IN^ is the number of data points. -C^^ -C^^ N :IN^ is the number of unknowns. (Must have 0.lt.N.le.M .) -C^^ -C^^ X :IN^ is a real array containing ... -C^^ (The dimensioned length of X must be at least N.) -C^^ -C^^ A :INOUT^ should contain ... on input; will be destroyed on -C^^ return. (The second dimension of A must be at least N.) -C^^ -C^^ MDIMA:IN^ is the first dimension of array A. -C^^ (Must have M.le.MDIMA .) -C^^ -C^^ FCNS:OUT^ will contain the six summary functions based on ... -C^^ -C^^ WKS:WORK^ is a real array of working storage. Its length is a -C^^ function of the length of FCNS and the number of data -C^^ points, as indicated above. -C^^ -C^^ IERR:OUT^ is an error flag with the following possible values: -C^^ Normal return: -C^^ IERR = 0 (no errors) -C^^ Warning error: -C^^ IERR > 0 means what? -C^^ "Recoverable" errors: -C^^ IERR =-1 if M < 1 or N < 1 . -C^^ IERR =-2 if M > MDIMA . -C^^ IERR =-3 means what? -C^^ -C^*Function^Return^Values: -C^^ This subsection is present only in a FUNCTION subprogram. -C^^ In case of an integer- or character-valued function with a discrete -C^^ set of values, list all possible return values, with their -C^^ meanings, in the following form. [The colon is significant.] -C^^ value : meaning -C^^ Otherwise, something of the following sort is acceptable. -C^^ SQRT : the square root of X. -C^^ -C^*Description: -C^^ One or more paragraphs describing the intended routine use, -C^^ dependencies on other routines, etc. Specific algorithm -C^^ descriptions could go here, if appropriate. -C^^ The emphasis should be on information useful to a user (as opposed -C^^ to developer or maintainer) of the routine. -C^^ -C^*Examples: -C^^ Detailed examples of usage would go here, if desired. -C^^ -C^*Accuracy: -C^^ This optional subsection contains notes on the accuracy or -C^^ precision of the results computed by the routine. -C^^ -C^*Cautions: -C^^ List any known problems or potentially hazardous side effects -C^^ that are not otherwise described, such as not being safe for -C^^ multiprocessing or exceptional cases for arguments. -C^^ (Ideally, there should be none in a SLATEC routine!) -C^^ -C^*See^Also: -C^^ This subsection would contain notes that refer to other library -C^^ routines that interrelate to this routine in important ways. -C^^ Examples include a solver for a LU factorization routine or an -C^^ evaluator for an interpolation or approximation routine. -C^^ This subsection may amplify information in the C***SEE ALSO -C^^ section, below, which should appear only if the prologue of the -C^^ listed routine(s) contains documentation for this routine. -C^^ -C^*Long^Description: -C^^ An optional subsection containing much more detailed information. -C^^ -C***SEE^ALSO^^RTN1[,^RTN2[, -C^^^^^^^^^^^^^RTNn]] -C***REFERENCES^^(NONE) or -C***REFERENCES^^1. Reference 1 ... -C^^^^^^^^^^^^^^^^^Continuation of reference 1. -C^^^^^^^^^^^^^^^2. Reference 2 ... -C^^^^^^^^^^^^^^^^^Continuation of reference 2. -C***ROUTINES^CALLED^^(NONE) or -C***ROUTINES^CALLED^^RTN1[,^RTN2[, -C^^^^^^^^^^^^^^^^^^^^RTNn]] - [Do not include standard Fortran intrinsics or externals.] -C***COMMON^BLOCKS^^^^BLOCK1[,^BLOCK2] -C***REVISION^HISTORY^^(YYMMDD) - [ This section should contain a record of the origin and ] - [ modification history of this routine. ] -C^^^871105^^DATE^WRITTEN -C^^^880121^^Various editorial changes. (Version 6) -C^^^881102^^Converted to new SLATEC format. (Version 7) -C^^^881128^^Various editorial changes. (Version 8) -C^ -C***END^PROLOGUE^^NAME -C -C*Internal Notes: -C Implementation notes that explain details of the routine's design -C or coding, tricky dependencies that might trip up a maintainer -C later, environmental assumptions made, alternate designs that -C were considered but not used, etc. -C Details on contents of common blocks referenced, locks used, etc., -C would go here. -C Emphasis is on INTERNALLY useful information. -C -C**End -C -C Additional comments that are not appropriate even for an internal -C document, but which the programmer feels should precede declarations. -C -C Declare arguments. -C - < Declarations > -C -C Declare local variables. -C - < Declarations > -C -C***FIRST^EXECUTABLE^STATEMENT^^NAME - < Body of NAME > -^^^^^^END - - - - -******************************************************************************* - -ACKNOWLEDGEMENT - -The authors wish to acknowledge the assistance provided by Dr. Frederick N. -Fritsch of the Computing and Mathematics Research Division, Lawrence Livermore -National Laboratory, who wrote Appendix E and made corrections and comments on -the manuscript. - - - - -******************************************************************************* - -REFERENCES - -[1] W. H. Vandevender and K. H. Haskell, The SLATEC mathematical subroutine - library, SIGNUM Newsletter, 17, 3 (September 1982), pp. 16-21. - -[2] P. A. Fox, A. D. Hall and N. L. Schryer, The PORT mathematical subroutine - library, ACM Transactions on Mathematical Software, 4, 2 (June 1978), pp. - 104-126. - -[3] P. A. Fox, A. D. Hall and N. L. Schryer, Algorithm 528: framework for a - portable library, ACM Transactions on Mathematical Software, 4, 2 (June - 1978), pp. 177-188. - -[4] R. E. Jones and D. K. Kahaner, XERROR, the SLATEC error-handling package, - Software - Practice and Experience, 13, 3 (March 1983), pp. 251-257. - -[5] R. F. Boisvert, S. E. Howe and D. K. Kahaner, GAMS: a framework for the - management of scientific software, ACM Transactions on Mathematical - Software, 11, 4 (December 1985), pp. 313-355. - -[6] American National Standard Programming Language FORTRAN, ANSI X3.9-1978, - American National Standards Institute, 1430 Broadway, New York, New York - 10018, April 1978. - -[7] W. S. Brown, A simple but realistic model of floating point computation, - ACM Transactions on Mathematical Software, 7, 4 (December 1981), pp. - 445-480. - -[8] F. N. Fritsch, SLATEC/LDOC prologue: template and conversion program, - Report UCID-21357, Rev.1, Lawrence Livermore National Laboratory, - Livermore, California, November 1988. - diff --git a/slatec/h12.f b/slatec/h12.f deleted file mode 100644 index c93afac..0000000 --- a/slatec/h12.f +++ /dev/null @@ -1,118 +0,0 @@ -*DECK H12 - SUBROUTINE H12 (MODE, LPIVOT, L1, M, U, IUE, UP, C, ICE, ICV, NCV) -C***BEGIN PROLOGUE H12 -C***SUBSIDIARY -C***PURPOSE Subsidiary to HFTI, LSEI and WNNLS -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (H12-S, DH12-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C C.L.Lawson and R.J.Hanson, Jet Propulsion Laboratory, 1973 Jun 12 -C to appear in 'Solving Least Squares Problems', Prentice-Hall, 1974 -C -C Construction and/or application of a single -C Householder transformation.. Q = I + U*(U**T)/B -C -C MODE = 1 or 2 to select algorithm H1 or H2 . -C LPIVOT is the index of the pivot element. -C L1,M If L1 .LE. M the transformation will be constructed to -C zero elements indexed from L1 through M. If L1 GT. M -C THE SUBROUTINE DOES AN IDENTITY TRANSFORMATION. -C U(),IUE,UP On entry to H1 U() contains the pivot vector. -C IUE is the storage increment between elements. -C On exit from H1 U() and UP -C contain quantities defining the vector U of the -C Householder transformation. On entry to H2 U() -C and UP should contain quantities previously computed -C by H1. These will not be modified by H2. -C C() On entry to H1 or H2 C() contains a matrix which will be -C regarded as a set of vectors to which the Householder -C transformation is to be applied. On exit C() contains the -C set of transformed vectors. -C ICE Storage increment between elements of vectors in C(). -C ICV Storage increment between vectors in C(). -C NCV Number of vectors in C() to be transformed. If NCV .LE. 0 -C no operations will be done on C(). -C -C***SEE ALSO HFTI, LSEI, WNNLS -C***ROUTINES CALLED SAXPY, SDOT, SSWAP -C***REVISION HISTORY (YYMMDD) -C 790101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE H12 - DIMENSION U(IUE,*), C(*) -C***FIRST EXECUTABLE STATEMENT H12 - ONE=1. -C - IF (0.GE.LPIVOT.OR.LPIVOT.GE.L1.OR.L1.GT.M) RETURN - CL=ABS(U(1,LPIVOT)) - IF (MODE.EQ.2) GO TO 60 -C ****** CONSTRUCT THE TRANSFORMATION. ****** - DO 10 J=L1,M - 10 CL=MAX(ABS(U(1,J)),CL) - IF (CL) 130,130,20 - 20 CLINV=ONE/CL - SM=(U(1,LPIVOT)*CLINV)**2 - DO 30 J=L1,M - 30 SM=SM+(U(1,J)*CLINV)**2 - CL=CL*SQRT(SM) - IF (U(1,LPIVOT)) 50,50,40 - 40 CL=-CL - 50 UP=U(1,LPIVOT)-CL - U(1,LPIVOT)=CL - GO TO 70 -C ****** APPLY THE TRANSFORMATION I+U*(U**T)/B TO C. ****** -C - 60 IF (CL) 130,130,70 - 70 IF (NCV.LE.0) RETURN - B=UP*U(1,LPIVOT) -C B MUST BE NONPOSITIVE HERE. IF B = 0., RETURN. -C - IF (B) 80,130,130 - 80 B=ONE/B - MML1P2=M-L1+2 - IF (MML1P2.GT.20) GO TO 140 - I2=1-ICV+ICE*(LPIVOT-1) - INCR=ICE*(L1-LPIVOT) - DO 120 J=1,NCV - I2=I2+ICV - I3=I2+INCR - I4=I3 - SM=C(I2)*UP - DO 90 I=L1,M - SM=SM+C(I3)*U(1,I) - 90 I3=I3+ICE - IF (SM) 100,120,100 - 100 SM=SM*B - C(I2)=C(I2)+SM*UP - DO 110 I=L1,M - C(I4)=C(I4)+SM*U(1,I) - 110 I4=I4+ICE - 120 CONTINUE - 130 RETURN - 140 CONTINUE - L1M1=L1-1 - KL1=1+(L1M1-1)*ICE - KL2=KL1 - KLP=1+(LPIVOT-1)*ICE - UL1M1=U(1,L1M1) - U(1,L1M1)=UP - IF (LPIVOT.EQ.L1M1) GO TO 150 - CALL SSWAP(NCV,C(KL1),ICV,C(KLP),ICV) - 150 CONTINUE - DO 160 J=1,NCV - SM=SDOT(MML1P2,U(1,L1M1),IUE,C(KL1),ICE) - SM=SM*B - CALL SAXPY (MML1P2,SM,U(1,L1M1),IUE,C(KL1),ICE) - KL1=KL1+ICV - 160 CONTINUE - U(1,L1M1)=UL1M1 - IF (LPIVOT.EQ.L1M1) RETURN - KL1=KL2 - CALL SSWAP(NCV,C(KL1),ICV,C(KLP),ICV) - RETURN - END diff --git a/slatec/hfti.f b/slatec/hfti.f deleted file mode 100644 index 25c4056..0000000 --- a/slatec/hfti.f +++ /dev/null @@ -1,288 +0,0 @@ -*DECK HFTI - SUBROUTINE HFTI (A, MDA, M, N, B, MDB, NB, TAU, KRANK, RNORM, H, - + G, IP) -C***BEGIN PROLOGUE HFTI -C***PURPOSE Solve a linear least squares problems by performing a QR -C factorization of the matrix using Householder -C transformations. -C***LIBRARY SLATEC -C***CATEGORY D9 -C***TYPE SINGLE PRECISION (HFTI-S, DHFTI-D) -C***KEYWORDS CURVE FITTING, LINEAR LEAST SQUARES, QR FACTORIZATION -C***AUTHOR Lawson, C. L., (JPL) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C DIMENSION A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N) -C -C This subroutine solves a linear least squares problem or a set of -C linear least squares problems having the same matrix but different -C right-side vectors. The problem data consists of an M by N matrix -C A, an M by NB matrix B, and an absolute tolerance parameter TAU -C whose usage is described below. The NB column vectors of B -C represent right-side vectors for NB distinct linear least squares -C problems. -C -C This set of problems can also be written as the matrix least -C squares problem -C -C AX = B, -C -C where X is the N by NB solution matrix. -C -C Note that if B is the M by M identity matrix, then X will be the -C pseudo-inverse of A. -C -C This subroutine first transforms the augmented matrix (A B) to a -C matrix (R C) using premultiplying Householder transformations with -C column interchanges. All subdiagonal elements in the matrix R are -C zero and its diagonal elements satisfy -C -C ABS(R(I,I)).GE.ABS(R(I+1,I+1)), -C -C I = 1,...,L-1, where -C -C L = MIN(M,N). -C -C The subroutine will compute an integer, KRANK, equal to the number -C of diagonal terms of R that exceed TAU in magnitude. Then a -C solution of minimum Euclidean length is computed using the first -C KRANK rows of (R C). -C -C To be specific we suggest that the user consider an easily -C computable matrix norm, such as, the maximum of all column sums of -C magnitudes. -C -C Now if the relative uncertainty of B is EPS, (norm of uncertainty/ -C norm of B), it is suggested that TAU be set approximately equal to -C EPS*(norm of A). -C -C The user must dimension all arrays appearing in the call list.. -C A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N). This -C permits the solution of a range of problems in the same array -C space. -C -C The entire set of parameters for HFTI are -C -C INPUT.. -C -C A(*,*),MDA,M,N The array A(*,*) initially contains the M by N -C matrix A of the least squares problem AX = B. -C The first dimensioning parameter of the array -C A(*,*) is MDA, which must satisfy MDA.GE.M -C Either M.GE.N or M.LT.N is permitted. There -C is no restriction on the rank of A. The -C condition MDA.LT.M is considered an error. -C -C B(*),MDB,NB If NB = 0 the subroutine will perform the -C orthogonal decomposition but will make no -C references to the array B(*). If NB.GT.0 -C the array B(*) must initially contain the M by -C NB matrix B of the least squares problem AX = -C B. If NB.GE.2 the array B(*) must be doubly -C subscripted with first dimensioning parameter -C MDB.GE.MAX(M,N). If NB = 1 the array B(*) may -C be either doubly or singly subscripted. In -C the latter case the value of MDB is arbitrary -C but it should be set to some valid integer -C value such as MDB = M. -C -C The condition of NB.GT.1.AND.MDB.LT. MAX(M,N) -C is considered an error. -C -C TAU Absolute tolerance parameter provided by user -C for pseudorank determination. -C -C H(*),G(*),IP(*) Arrays of working space used by HFTI. -C -C OUTPUT.. -C -C A(*,*) The contents of the array A(*,*) will be -C modified by the subroutine. These contents -C are not generally required by the user. -C -C B(*) On return the array B(*) will contain the N by -C NB solution matrix X. -C -C KRANK Set by the subroutine to indicate the -C pseudorank of A. -C -C RNORM(*) On return, RNORM(J) will contain the Euclidean -C norm of the residual vector for the problem -C defined by the J-th column vector of the array -C B(*,*) for J = 1,...,NB. -C -C H(*),G(*) On return these arrays respectively contain -C elements of the pre- and post-multiplying -C Householder transformations used to compute -C the minimum Euclidean length solution. -C -C IP(*) Array in which the subroutine records indices -C describing the permutation of column vectors. -C The contents of arrays H(*),G(*) and IP(*) -C are not generally required by the user. -C -C***REFERENCES C. L. Lawson and R. J. Hanson, Solving Least Squares -C Problems, Prentice-Hall, Inc., 1974, Chapter 14. -C***ROUTINES CALLED H12, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790101 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 901005 Replace usage of DIFF with usage of R1MACH. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE HFTI - DIMENSION A(MDA,*),B(MDB,*),H(*),G(*),RNORM(*) - INTEGER IP(*) - DOUBLE PRECISION SM,DZERO - SAVE RELEPS - DATA RELEPS /0.E0/ -C***FIRST EXECUTABLE STATEMENT HFTI - IF (RELEPS.EQ.0) RELEPS = R1MACH(4) - SZERO=0. - DZERO=0.D0 - FACTOR=0.001 -C - K=0 - LDIAG=MIN(M,N) - IF (LDIAG.LE.0) GO TO 270 - IF (.NOT.MDA.LT.M) GO TO 5 - NERR=1 - IOPT=2 - CALL XERMSG ('SLATEC', 'HFTI', 'MDA.LT.M, PROBABLE ERROR.', - + NERR, IOPT) - RETURN - 5 CONTINUE -C - IF (.NOT.(NB.GT.1.AND.MAX(M,N).GT.MDB)) GO TO 6 - NERR=2 - IOPT=2 - CALL XERMSG ('SLATEC', 'HFTI', - + 'MDB.LT.MAX(M,N).AND.NB.GT.1. PROBABLE ERROR.', NERR, IOPT) - RETURN - 6 CONTINUE -C - DO 80 J=1,LDIAG - IF (J.EQ.1) GO TO 20 -C -C UPDATE SQUARED COLUMN LENGTHS AND FIND LMAX -C .. - LMAX=J - DO 10 L=J,N - H(L)=H(L)-A(J-1,L)**2 - IF (H(L).GT.H(LMAX)) LMAX=L - 10 CONTINUE - IF (FACTOR*H(LMAX) .GT. HMAX*RELEPS) GO TO 50 -C -C COMPUTE SQUARED COLUMN LENGTHS AND FIND LMAX -C .. - 20 LMAX=J - DO 40 L=J,N - H(L)=0. - DO 30 I=J,M - 30 H(L)=H(L)+A(I,L)**2 - IF (H(L).GT.H(LMAX)) LMAX=L - 40 CONTINUE - HMAX=H(LMAX) -C .. -C LMAX HAS BEEN DETERMINED -C -C DO COLUMN INTERCHANGES IF NEEDED. -C .. - 50 CONTINUE - IP(J)=LMAX - IF (IP(J).EQ.J) GO TO 70 - DO 60 I=1,M - TMP=A(I,J) - A(I,J)=A(I,LMAX) - 60 A(I,LMAX)=TMP - H(LMAX)=H(J) -C -C COMPUTE THE J-TH TRANSFORMATION AND APPLY IT TO A AND B. -C .. - 70 CALL H12 (1,J,J+1,M,A(1,J),1,H(J),A(1,J+1),1,MDA,N-J) - 80 CALL H12 (2,J,J+1,M,A(1,J),1,H(J),B,1,MDB,NB) -C -C DETERMINE THE PSEUDORANK, K, USING THE TOLERANCE, TAU. -C .. - DO 90 J=1,LDIAG - IF (ABS(A(J,J)).LE.TAU) GO TO 100 - 90 CONTINUE - K=LDIAG - GO TO 110 - 100 K=J-1 - 110 KP1=K+1 -C -C COMPUTE THE NORMS OF THE RESIDUAL VECTORS. -C - IF (NB.LE.0) GO TO 140 - DO 130 JB=1,NB - TMP=SZERO - IF (KP1.GT.M) GO TO 130 - DO 120 I=KP1,M - 120 TMP=TMP+B(I,JB)**2 - 130 RNORM(JB)=SQRT(TMP) - 140 CONTINUE -C SPECIAL FOR PSEUDORANK = 0 - IF (K.GT.0) GO TO 160 - IF (NB.LE.0) GO TO 270 - DO 150 JB=1,NB - DO 150 I=1,N - 150 B(I,JB)=SZERO - GO TO 270 -C -C IF THE PSEUDORANK IS LESS THAN N COMPUTE HOUSEHOLDER -C DECOMPOSITION OF FIRST K ROWS. -C .. - 160 IF (K.EQ.N) GO TO 180 - DO 170 II=1,K - I=KP1-II - 170 CALL H12 (1,I,KP1,N,A(I,1),MDA,G(I),A,MDA,1,I-1) - 180 CONTINUE -C -C - IF (NB.LE.0) GO TO 270 - DO 260 JB=1,NB -C -C SOLVE THE K BY K TRIANGULAR SYSTEM. -C .. - DO 210 L=1,K - SM=DZERO - I=KP1-L - IF (I.EQ.K) GO TO 200 - IP1=I+1 - DO 190 J=IP1,K - 190 SM=SM+A(I,J)*DBLE(B(J,JB)) - 200 SM1=SM - 210 B(I,JB)=(B(I,JB)-SM1)/A(I,I) -C -C COMPLETE COMPUTATION OF SOLUTION VECTOR. -C .. - IF (K.EQ.N) GO TO 240 - DO 220 J=KP1,N - 220 B(J,JB)=SZERO - DO 230 I=1,K - 230 CALL H12 (2,I,KP1,N,A(I,1),MDA,G(I),B(1,JB),1,MDB,1) -C -C RE-ORDER THE SOLUTION VECTOR TO COMPENSATE FOR THE -C COLUMN INTERCHANGES. -C .. - 240 DO 250 JJ=1,LDIAG - J=LDIAG+1-JJ - IF (IP(J).EQ.J) GO TO 250 - L=IP(J) - TMP=B(L,JB) - B(L,JB)=B(J,JB) - B(J,JB)=TMP - 250 CONTINUE - 260 CONTINUE -C .. -C THE SOLUTION VECTORS, X, ARE NOW -C IN THE FIRST N ROWS OF THE ARRAY B(,). -C - 270 KRANK=K - RETURN - END diff --git a/slatec/hkseq.f b/slatec/hkseq.f deleted file mode 100644 index c1b6683..0000000 --- a/slatec/hkseq.f +++ /dev/null @@ -1,158 +0,0 @@ -*DECK HKSEQ - SUBROUTINE HKSEQ (X, M, H, IERR) -C***BEGIN PROLOGUE HKSEQ -C***SUBSIDIARY -C***PURPOSE Subsidiary to BSKIN -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (HKSEQ-S, DHKSEQ-D) -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C HKSEQ is an adaptation of subroutine PSIFN described in the -C reference below. HKSEQ generates the sequence -C H(K,X) = (-X)**(K+1)*(PSI(K,X) PSI(K,X+0.5))/GAMMA(K+1), for -C K=0,...,M. -C -C***SEE ALSO BSKIN -C***REFERENCES D. E. Amos, A portable Fortran subroutine for -C derivatives of the Psi function, Algorithm 610, ACM -C Transactions on Mathematical Software 9, 4 (1983), -C pp. 494-502. -C***ROUTINES CALLED I1MACH, R1MACH -C***REVISION HISTORY (YYMMDD) -C 820601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C 920528 DESCRIPTION and REFERENCES sections revised. (WRB) -C***END PROLOGUE HKSEQ - INTEGER I, IERR, J, K, M, MX, NX - INTEGER I1MACH - REAL B, FK, FLN, FN, FNP, H, HRX, RLN, RXSQ, R1M5, S, SLOPE, T, - * TK, TRM, TRMH, TRMR, TST, U, V, WDTOL, X, XDMY, XH, XINC, XM, - * XMIN, YINT - REAL R1MACH - DIMENSION B(22), TRM(22), TRMR(25), TRMH(25), U(25), V(25), H(*) - SAVE B -C----------------------------------------------------------------------- -C SCALED BERNOULLI NUMBERS 2.0*B(2K)*(1-2**(-2K)) -C----------------------------------------------------------------------- - DATA B(1), B(2), B(3), B(4), B(5), B(6), B(7), B(8), B(9), B(10), - * B(11), B(12), B(13), B(14), B(15), B(16), B(17), B(18), B(19), - * B(20), B(21), B(22) /1.00000000000000000E+00, - * -5.00000000000000000E-01,2.50000000000000000E-01, - * -6.25000000000000000E-02,4.68750000000000000E-02, - * -6.64062500000000000E-02,1.51367187500000000E-01, - * -5.06103515625000000E-01,2.33319091796875000E+00, - * -1.41840972900390625E+01,1.09941936492919922E+02, - * -1.05824747562408447E+03,1.23842434241771698E+04, - * -1.73160495905935764E+05,2.85103429084961116E+06, - * -5.45964619322445132E+07,1.20316174668075304E+09, - * -3.02326315271452307E+10,8.59229286072319606E+11, - * -2.74233104097776039E+13,9.76664637943633248E+14, - * -3.85931586838450360E+16/ -C -C***FIRST EXECUTABLE STATEMENT HKSEQ - IERR=0 - WDTOL = MAX(R1MACH(4),1.0E-18) - FN = M - 1 - FNP = FN + 1.0E0 -C----------------------------------------------------------------------- -C COMPUTE XMIN -C----------------------------------------------------------------------- - R1M5 = R1MACH(5) - RLN = R1M5*I1MACH(11) - RLN = MIN(RLN,18.06E0) - FLN = MAX(RLN,3.0E0) - 3.0E0 - YINT = 3.50E0 + 0.40E0*FLN - SLOPE = 0.21E0 + FLN*(0.0006038E0*FLN+0.008677E0) - XM = YINT + SLOPE*FN - MX = INT(XM) + 1 - XMIN = MX -C----------------------------------------------------------------------- -C GENERATE H(M-1,XDMY)*XDMY**(M) BY THE ASYMPTOTIC EXPANSION -C----------------------------------------------------------------------- - XDMY = X - XINC = 0.0E0 - IF (X.GE.XMIN) GO TO 10 - NX = INT(X) - XINC = XMIN - NX - XDMY = X + XINC - 10 CONTINUE - RXSQ = 1.0E0/(XDMY*XDMY) - HRX = 0.5E0/XDMY - TST = 0.5E0*WDTOL - T = FNP*HRX -C----------------------------------------------------------------------- -C INITIALIZE COEFFICIENT ARRAY -C----------------------------------------------------------------------- - S = T*B(3) - IF (ABS(S).LT.TST) GO TO 30 - TK = 2.0E0 - DO 20 K=4,22 - T = T*((TK+FN+1.0E0)/(TK+1.0E0))*((TK+FN)/(TK+2.0E0))*RXSQ - TRM(K) = T*B(K) - IF (ABS(TRM(K)).LT.TST) GO TO 30 - S = S + TRM(K) - TK = TK + 2.0E0 - 20 CONTINUE - GO TO 110 - 30 CONTINUE - H(M) = S + 0.5E0 - IF (M.EQ.1) GO TO 70 -C----------------------------------------------------------------------- -C GENERATE LOWER DERIVATIVES, I.LT.M-1 -C----------------------------------------------------------------------- - DO 60 I=2,M - FNP = FN - FN = FN - 1.0E0 - S = FNP*HRX*B(3) - IF (ABS(S).LT.TST) GO TO 50 - FK = FNP + 3.0E0 - DO 40 K=4,22 - TRM(K) = TRM(K)*FNP/FK - IF (ABS(TRM(K)).LT.TST) GO TO 50 - S = S + TRM(K) - FK = FK + 2.0E0 - 40 CONTINUE - GO TO 110 - 50 CONTINUE - MX = M - I + 1 - H(MX) = S + 0.5E0 - 60 CONTINUE - 70 CONTINUE - IF (XINC.EQ.0.0E0) RETURN -C----------------------------------------------------------------------- -C RECUR BACKWARD FROM XDMY TO X -C----------------------------------------------------------------------- - XH = X + 0.5E0 - S = 0.0E0 - NX = INT(XINC) - DO 80 I=1,NX - TRMR(I) = X/(X+NX-I) - U(I) = TRMR(I) - TRMH(I) = X/(XH+NX-I) - V(I) = TRMH(I) - S = S + U(I) - V(I) - 80 CONTINUE - MX = NX + 1 - TRMR(MX) = X/XDMY - U(MX) = TRMR(MX) - H(1) = H(1)*TRMR(MX) + S - IF (M.EQ.1) RETURN - DO 100 J=2,M - S = 0.0E0 - DO 90 I=1,NX - TRMR(I) = TRMR(I)*U(I) - TRMH(I) = TRMH(I)*V(I) - S = S + TRMR(I) - TRMH(I) - 90 CONTINUE - TRMR(MX) = TRMR(MX)*U(MX) - H(J) = H(J)*TRMR(MX) + S - 100 CONTINUE - RETURN - 110 CONTINUE - IERR=2 - RETURN - END diff --git a/slatec/hpperm.f b/slatec/hpperm.f deleted file mode 100644 index ad6f3b0..0000000 --- a/slatec/hpperm.f +++ /dev/null @@ -1,95 +0,0 @@ -*DECK HPPERM - SUBROUTINE HPPERM (HX, N, IPERM, WORK, IER) -C***BEGIN PROLOGUE HPPERM -C***PURPOSE Rearrange a given array according to a prescribed -C permutation vector. -C***LIBRARY SLATEC -C***CATEGORY N8 -C***TYPE CHARACTER (SPPERM-S, DPPERM-D, IPPERM-I, HPPERM-H) -C***KEYWORDS APPLICATION OF PERMUTATION TO DATA VECTOR -C***AUTHOR McClain, M. A., (NIST) -C Rhoads, G. S., (NBS) -C***DESCRIPTION -C -C HPPERM rearranges the data vector HX according to the -C permutation IPERM: HX(I) <--- HX(IPERM(I)). IPERM could come -C from one of the sorting routines IPSORT, SPSORT, DPSORT or -C HPSORT. -C -C Description of Parameters -C HX - input/output -- character array of values to be -C rearranged. -C N - input -- number of values in character array HX. -C IPERM - input -- permutation vector. -C WORK - character variable which must have a length -C specification at least as great as that of HX. -C IER - output -- error indicator: -C = 0 if no error, -C = 1 if N is zero or negative, -C = 2 if work array is not long enough, -C = 3 if IPERM is not a valid permutation. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 901004 DATE WRITTEN -C 920507 Modified by M. McClain to revise prologue text and to add -C check for length of work array. -C***END PROLOGUE HPPERM - INTEGER N, IPERM(*), I, IER, INDX, INDX0, ISTRT - CHARACTER*(*) HX(*), WORK -C***FIRST EXECUTABLE STATEMENT HPPERM - IER=0 - IF(N.LT.1)THEN - IER=1 - CALL XERMSG ('SLATEC', 'HPPERM', - + 'The number of values to be rearranged, N, is not positive.', - + IER, 1) - RETURN - ENDIF - IF(LEN(WORK).LT.LEN(HX(1)))THEN - IER=2 - CALL XERMSG ('SLATEC', 'HPPERM', - + 'The length of the work variable, WORK, is too short.',IER,1) - RETURN - ENDIF -C -C CHECK WHETHER IPERM IS A VALID PERMUTATION -C - DO 100 I=1,N - INDX=ABS(IPERM(I)) - IF((INDX.GE.1).AND.(INDX.LE.N))THEN - IF(IPERM(INDX).GT.0)THEN - IPERM(INDX)=-IPERM(INDX) - GOTO 100 - ENDIF - ENDIF - IER=3 - CALL XERMSG ('SLATEC', 'HPPERM', - + 'The permutation vector, IPERM, is not valid.', IER, 1) - RETURN - 100 CONTINUE -C -C REARRANGE THE VALUES OF HX -C -C USE THE IPERM VECTOR AS A FLAG. -C IF IPERM(I) > 0, THEN THE I-TH VALUE IS IN CORRECT LOCATION -C - DO 330 ISTRT = 1 , N - IF (IPERM(ISTRT) .GT. 0) GOTO 330 - INDX = ISTRT - INDX0 = INDX - WORK = HX(ISTRT) - 320 CONTINUE - IF (IPERM(INDX) .GE. 0) GOTO 325 - HX(INDX) = HX(-IPERM(INDX)) - INDX0 = INDX - IPERM(INDX) = -IPERM(INDX) - INDX = IPERM(INDX) - GOTO 320 - 325 CONTINUE - HX(INDX0) = WORK - 330 CONTINUE -C - RETURN - END diff --git a/slatec/hpsort.f b/slatec/hpsort.f deleted file mode 100644 index 8b65a20..0000000 --- a/slatec/hpsort.f +++ /dev/null @@ -1,340 +0,0 @@ -*DECK HPSORT - SUBROUTINE HPSORT (HX, N, STRBEG, STREND, IPERM, KFLAG, WORK, IER) -C***BEGIN PROLOGUE HPSORT -C***PURPOSE Return the permutation vector generated by sorting a -C substring within a character array and, optionally, -C rearrange the elements of the array. The array may be -C sorted in forward or reverse lexicographical order. A -C slightly modified quicksort algorithm is used. -C***LIBRARY SLATEC -C***CATEGORY N6A1C, N6A2C -C***TYPE CHARACTER (SPSORT-S, DPSORT-D, IPSORT-I, HPSORT-H) -C***KEYWORDS PASSIVE SORTING, SINGLETON QUICKSORT, SORT, STRING SORTING -C***AUTHOR Jones, R. E., (SNLA) -C Rhoads, G. S., (NBS) -C Sullivan, F. E., (NBS) -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C -C HPSORT returns the permutation vector IPERM generated by sorting -C the substrings beginning with the character STRBEG and ending with -C the character STREND within the strings in array HX and, optionally, -C rearranges the strings in HX. HX may be sorted in increasing or -C decreasing lexicographical order. A slightly modified quicksort -C algorithm is used. -C -C IPERM is such that HX(IPERM(I)) is the Ith value in the -C rearrangement of HX. IPERM may be applied to another array by -C calling IPPERM, SPPERM, DPPERM or HPPERM. -C -C An active sort of numerical data is expected to execute somewhat -C more quickly than a passive sort because there is no need to use -C indirect references. But for the character data in HPSORT, integers -C in the IPERM vector are manipulated rather than the strings in HX. -C Moving integers may be enough faster than moving character strings -C to more than offset the penalty of indirect referencing. -C -C Description of Parameters -C HX - input/output -- array of type character to be sorted. -C For example, to sort a 80 element array of names, -C each of length 6, declare HX as character HX(100)*6. -C If ABS(KFLAG) = 2, then the values in HX will be -C rearranged on output; otherwise, they are unchanged. -C N - input -- number of values in array HX to be sorted. -C STRBEG - input -- the index of the initial character in -C the string HX that is to be sorted. -C STREND - input -- the index of the final character in -C the string HX that is to be sorted. -C IPERM - output -- permutation array such that IPERM(I) is the -C index of the string in the original order of the -C HX array that is in the Ith location in the sorted -C order. -C KFLAG - input -- control parameter: -C = 2 means return the permutation vector resulting from -C sorting HX in lexicographical order and sort HX also. -C = 1 means return the permutation vector resulting from -C sorting HX in lexicographical order and do not sort -C HX. -C = -1 means return the permutation vector resulting from -C sorting HX in reverse lexicographical order and do -C not sort HX. -C = -2 means return the permutation vector resulting from -C sorting HX in reverse lexicographical order and sort -C HX also. -C WORK - character variable which must have a length specification -C at least as great as that of HX. -C IER - output -- error indicator: -C = 0 if no error, -C = 1 if N is zero or negative, -C = 2 if KFLAG is not 2, 1, -1, or -2, -C = 3 if work array is not long enough, -C = 4 if string beginning is beyond its end, -C = 5 if string beginning is out-of-range, -C = 6 if string end is out-of-range. -C -C E X A M P L E O F U S E -C -C CHARACTER*2 HX, W -C INTEGER STRBEG, STREND -C DIMENSION HX(10), IPERM(10) -C DATA (HX(I),I=1,10)/ '05','I ',' I',' ','Rs','9R','R9','89', -C 1 ',*','N"'/ -C DATA STRBEG, STREND / 1, 2 / -C CALL HPSORT (HX,10,STRBEG,STREND,IPERM,1,W) -C PRINT 100, (HX(IPERM(I)),I=1,10) -C 100 FORMAT (2X, A2) -C STOP -C END -C -C***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm -C for sorting with minimal storage, Communications of -C the ACM, 12, 3 (1969), pp. 185-187. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 761101 DATE WRITTEN -C 761118 Modified by John A. Wisniewski to use the Singleton -C quicksort algorithm. -C 811001 Modified by Francis Sullivan for string data. -C 850326 Documentation slightly modified by D. Kahaner. -C 870423 Modified by Gregory S. Rhoads for passive sorting with the -C option for the rearrangement of the original data. -C 890620 Algorithm for rearranging the data vector corrected by R. -C Boisvert. -C 890622 Prologue upgraded to Version 4.0 style by D. Lozier. -C 920507 Modified by M. McClain to revise prologue text. -C 920818 Declarations section rebuilt and code restructured to use -C IF-THEN-ELSE-ENDIF. (SMR, WRB) -C***END PROLOGUE HPSORT -C .. Scalar Arguments .. - INTEGER IER, KFLAG, N, STRBEG, STREND - CHARACTER * (*) WORK -C .. Array Arguments .. - INTEGER IPERM(*) - CHARACTER * (*) HX(*) -C .. Local Scalars .. - REAL R - INTEGER I, IJ, INDX, INDX0, IR, ISTRT, J, K, KK, L, LM, LMT, M, - + NN, NN2 -C .. Local Arrays .. - INTEGER IL(21), IU(21) -C .. External Subroutines .. - EXTERNAL XERMSG -C .. Intrinsic Functions .. - INTRINSIC ABS, INT, LEN -C***FIRST EXECUTABLE STATEMENT HPSORT - IER = 0 - NN = N - IF (NN .LT. 1) THEN - IER = 1 - CALL XERMSG ('SLATEC', 'HPSORT', - + 'The number of values to be sorted, N, is not positive.', - + IER, 1) - RETURN - ENDIF - KK = ABS(KFLAG) - IF (KK.NE.1 .AND. KK.NE.2) THEN - IER = 2 - CALL XERMSG ('SLATEC', 'HPSORT', - + 'The sort control parameter, KFLAG, is not 2, 1, -1, or -2.', - + IER, 1) - RETURN - ENDIF -C - IF(LEN(WORK) .LT. LEN(HX(1))) THEN - IER = 3 - CALL XERMSG ('SLATEC',' HPSORT', - + 'The length of the work variable, WORK, is too short.', - + IER, 1) - RETURN - ENDIF - IF (STRBEG .GT. STREND) THEN - IER = 4 - CALL XERMSG ('SLATEC', 'HPSORT', - + 'The string beginning, STRBEG, is beyond its end, STREND.', - + IER, 1) - RETURN - ENDIF - IF (STRBEG .LT. 1 .OR. STRBEG .GT. LEN(HX(1))) THEN - IER = 5 - CALL XERMSG ('SLATEC', 'HPSORT', - + 'The string beginning, STRBEG, is out-of-range.', - + IER, 1) - RETURN - ENDIF - IF (STREND .LT. 1 .OR. STREND .GT. LEN(HX(1))) THEN - IER = 6 - CALL XERMSG ('SLATEC', 'HPSORT', - + 'The string end, STREND, is out-of-range.', - + IER, 1) - RETURN - ENDIF -C -C Initialize permutation vector -C - DO 10 I=1,NN - IPERM(I) = I - 10 CONTINUE -C -C Return if only one value is to be sorted -C - IF (NN .EQ. 1) RETURN -C -C Sort HX only -C - M = 1 - I = 1 - J = NN - R = .375E0 -C - 20 IF (I .EQ. J) GO TO 70 - IF (R .LE. 0.5898437E0) THEN - R = R+3.90625E-2 - ELSE - R = R-0.21875E0 - ENDIF -C - 30 K = I -C -C Select a central element of the array and save it in location L -C - IJ = I + INT((J-I)*R) - LM = IPERM(IJ) -C -C If first element of array is greater than LM, interchange with LM -C - IF (HX(IPERM(I))(STRBEG:STREND) .GT. HX(LM)(STRBEG:STREND)) THEN - IPERM(IJ) = IPERM(I) - IPERM(I) = LM - LM = IPERM(IJ) - ENDIF - L = J -C -C If last element of array is less than LM, interchange with LM -C - IF (HX(IPERM(J))(STRBEG:STREND) .LT. HX(LM)(STRBEG:STREND)) THEN - IPERM(IJ) = IPERM(J) - IPERM(J) = LM - LM = IPERM(IJ) -C -C If first element of array is greater than LM, interchange -C with LM -C - IF (HX(IPERM(I))(STRBEG:STREND) .GT. HX(LM)(STRBEG:STREND)) - + THEN - IPERM(IJ) = IPERM(I) - IPERM(I) = LM - LM = IPERM(IJ) - ENDIF - ENDIF - GO TO 50 - 40 LMT = IPERM(L) - IPERM(L) = IPERM(K) - IPERM(K) = LMT -C -C Find an element in the second half of the array which is smaller -C than LM -C - 50 L = L-1 - IF (HX(IPERM(L))(STRBEG:STREND) .GT. HX(LM)(STRBEG:STREND)) - + GO TO 50 -C -C Find an element in the first half of the array which is greater -C than LM -C - 60 K = K+1 - IF (HX(IPERM(K))(STRBEG:STREND) .LT. HX(LM)(STRBEG:STREND)) - + GO TO 60 -C -C Interchange these elements -C - IF (K .LE. L) GO TO 40 -C -C Save upper and lower subscripts of the array yet to be sorted -C - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 80 -C -C Begin again on another portion of the unsorted array -C - 70 M = M-1 - IF (M .EQ. 0) GO TO 110 - I = IL(M) - J = IU(M) -C - 80 IF (J-I .GE. 1) GO TO 30 - IF (I .EQ. 1) GO TO 20 - I = I-1 -C - 90 I = I+1 - IF (I .EQ. J) GO TO 70 - LM = IPERM(I+1) - IF (HX(IPERM(I))(STRBEG:STREND) .LE. HX(LM)(STRBEG:STREND)) - + GO TO 90 - K = I -C - 100 IPERM(K+1) = IPERM(K) - K = K-1 -C - IF (HX(LM)(STRBEG:STREND) .LT. HX(IPERM(K))(STRBEG:STREND)) - + GO TO 100 - IPERM(K+1) = LM - GO TO 90 -C -C Clean up -C - 110 IF (KFLAG .LE. -1) THEN -C -C Alter array to get reverse order, if necessary -C - NN2 = NN/2 - DO 120 I=1,NN2 - IR = NN-I+1 - LM = IPERM(I) - IPERM(I) = IPERM(IR) - IPERM(IR) = LM - 120 CONTINUE - ENDIF -C -C Rearrange the values of HX if desired -C - IF (KK .EQ. 2) THEN -C -C Use the IPERM vector as a flag. -C If IPERM(I) < 0, then the I-th value is in correct location -C - DO 140 ISTRT=1,NN - IF (IPERM(ISTRT) .GE. 0) THEN - INDX = ISTRT - INDX0 = INDX - WORK = HX(ISTRT) - 130 IF (IPERM(INDX) .GT. 0) THEN - HX(INDX) = HX(IPERM(INDX)) - INDX0 = INDX - IPERM(INDX) = -IPERM(INDX) - INDX = ABS(IPERM(INDX)) - GO TO 130 - ENDIF - HX(INDX0) = WORK - ENDIF - 140 CONTINUE -C -C Revert the signs of the IPERM values -C - DO 150 I=1,NN - IPERM(I) = -IPERM(I) - 150 CONTINUE -C - ENDIF -C - RETURN - END diff --git a/slatec/hqr.f b/slatec/hqr.f deleted file mode 100644 index 84be585..0000000 --- a/slatec/hqr.f +++ /dev/null @@ -1,245 +0,0 @@ -*DECK HQR - SUBROUTINE HQR (NM, N, LOW, IGH, H, WR, WI, IERR) -C***BEGIN PROLOGUE HQR -C***PURPOSE Compute the eigenvalues of a real upper Hessenberg matrix -C using the QR method. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C2B -C***TYPE SINGLE PRECISION (HQR-S, COMQR-C) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure HQR, -C NUM. MATH. 14, 219-231(1970) by Martin, Peters, and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 359-371(1971). -C -C This subroutine finds the eigenvalues of a REAL -C UPPER Hessenberg matrix by the QR method. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameter, H, as declared in the calling program -C dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix H. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C LOW and IGH are two INTEGER variables determined by the -C balancing subroutine BALANC. If BALANC has not been -C used, set LOW=1 and IGH equal to the order of the matrix, N. -C -C H contains the upper Hessenberg matrix. Information about -C the transformations used in the reduction to Hessenberg -C form by ELMHES or ORTHES, if performed, is stored -C in the remaining triangle under the Hessenberg matrix. -C H is a two-dimensional REAL array, dimensioned H(NM,N). -C -C On OUTPUT -C -C H has been destroyed. Therefore, it must be saved before -C calling HQR if subsequent calculation and back -C transformation of eigenvectors is to be performed. -C -C WR and WI contain the real and imaginary parts, respectively, -C of the eigenvalues. The eigenvalues are unordered except -C that complex conjugate pairs of values appear consecutively -C with the eigenvalue having the positive imaginary part first. -C If an error exit is made, the eigenvalues should be correct -C for indices IERR+1, IERR+2, ..., N. WR and WI are one- -C dimensional REAL arrays, dimensioned WR(N) and WI(N). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C J if the J-th eigenvalue has not been -C determined after a total of 30*N iterations. -C The eigenvalues should be correct for indices -C IERR+1, IERR+2, ..., N. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE HQR -C - INTEGER I,J,K,L,M,N,EN,LL,MM,NA,NM,IGH,ITN,ITS,LOW,MP2,ENM2,IERR - REAL H(NM,*),WR(*),WI(*) - REAL P,Q,R,S,T,W,X,Y,ZZ,NORM,S1,S2 - LOGICAL NOTLAS -C -C***FIRST EXECUTABLE STATEMENT HQR - IERR = 0 - NORM = 0.0E0 - K = 1 -C .......... STORE ROOTS ISOLATED BY BALANC -C AND COMPUTE MATRIX NORM .......... - DO 50 I = 1, N -C - DO 40 J = K, N - 40 NORM = NORM + ABS(H(I,J)) -C - K = I - IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50 - WR(I) = H(I,I) - WI(I) = 0.0E0 - 50 CONTINUE -C - EN = IGH - T = 0.0E0 - ITN = 30*N -C .......... SEARCH FOR NEXT EIGENVALUES .......... - 60 IF (EN .LT. LOW) GO TO 1001 - ITS = 0 - NA = EN - 1 - ENM2 = NA - 1 -C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT -C FOR L=EN STEP -1 UNTIL LOW DO -- .......... - 70 DO 80 LL = LOW, EN - L = EN + LOW - LL - IF (L .EQ. LOW) GO TO 100 - S = ABS(H(L-1,L-1)) + ABS(H(L,L)) - IF (S .EQ. 0.0E0) S = NORM - S2 = S + ABS(H(L,L-1)) - IF (S2 .EQ. S) GO TO 100 - 80 CONTINUE -C .......... FORM SHIFT .......... - 100 X = H(EN,EN) - IF (L .EQ. EN) GO TO 270 - Y = H(NA,NA) - W = H(EN,NA) * H(NA,EN) - IF (L .EQ. NA) GO TO 280 - IF (ITN .EQ. 0) GO TO 1000 - IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130 -C .......... FORM EXCEPTIONAL SHIFT .......... - T = T + X -C - DO 120 I = LOW, EN - 120 H(I,I) = H(I,I) - X -C - S = ABS(H(EN,NA)) + ABS(H(NA,ENM2)) - X = 0.75E0 * S - Y = X - W = -0.4375E0 * S * S - 130 ITS = ITS + 1 - ITN = ITN - 1 -C .......... LOOK FOR TWO CONSECUTIVE SMALL -C SUB-DIAGONAL ELEMENTS. -C FOR M=EN-2 STEP -1 UNTIL L DO -- .......... - DO 140 MM = L, ENM2 - M = ENM2 + L - MM - ZZ = H(M,M) - R = X - ZZ - S = Y - ZZ - P = (R * S - W) / H(M+1,M) + H(M,M+1) - Q = H(M+1,M+1) - ZZ - R - S - R = H(M+2,M+1) - S = ABS(P) + ABS(Q) + ABS(R) - P = P / S - Q = Q / S - R = R / S - IF (M .EQ. L) GO TO 150 - S1 = ABS(P) * (ABS(H(M-1,M-1)) + ABS(ZZ) + ABS(H(M+1,M+1))) - S2 = S1 + ABS(H(M,M-1)) * (ABS(Q) + ABS(R)) - IF (S2 .EQ. S1) GO TO 150 - 140 CONTINUE -C - 150 MP2 = M + 2 -C - DO 160 I = MP2, EN - H(I,I-2) = 0.0E0 - IF (I .EQ. MP2) GO TO 160 - H(I,I-3) = 0.0E0 - 160 CONTINUE -C .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND -C COLUMNS M TO EN .......... - DO 260 K = M, NA - NOTLAS = K .NE. NA - IF (K .EQ. M) GO TO 170 - P = H(K,K-1) - Q = H(K+1,K-1) - R = 0.0E0 - IF (NOTLAS) R = H(K+2,K-1) - X = ABS(P) + ABS(Q) + ABS(R) - IF (X .EQ. 0.0E0) GO TO 260 - P = P / X - Q = Q / X - R = R / X - 170 S = SIGN(SQRT(P*P+Q*Q+R*R),P) - IF (K .EQ. M) GO TO 180 - H(K,K-1) = -S * X - GO TO 190 - 180 IF (L .NE. M) H(K,K-1) = -H(K,K-1) - 190 P = P + S - X = P / S - Y = Q / S - ZZ = R / S - Q = Q / P - R = R / P -C .......... ROW MODIFICATION .......... - DO 210 J = K, EN - P = H(K,J) + Q * H(K+1,J) - IF (.NOT. NOTLAS) GO TO 200 - P = P + R * H(K+2,J) - H(K+2,J) = H(K+2,J) - P * ZZ - 200 H(K+1,J) = H(K+1,J) - P * Y - H(K,J) = H(K,J) - P * X - 210 CONTINUE -C - J = MIN(EN,K+3) -C .......... COLUMN MODIFICATION .......... - DO 230 I = L, J - P = X * H(I,K) + Y * H(I,K+1) - IF (.NOT. NOTLAS) GO TO 220 - P = P + ZZ * H(I,K+2) - H(I,K+2) = H(I,K+2) - P * R - 220 H(I,K+1) = H(I,K+1) - P * Q - H(I,K) = H(I,K) - P - 230 CONTINUE -C - 260 CONTINUE -C - GO TO 70 -C .......... ONE ROOT FOUND .......... - 270 WR(EN) = X + T - WI(EN) = 0.0E0 - EN = NA - GO TO 60 -C .......... TWO ROOTS FOUND .......... - 280 P = (Y - X) / 2.0E0 - Q = P * P + W - ZZ = SQRT(ABS(Q)) - X = X + T - IF (Q .LT. 0.0E0) GO TO 320 -C .......... REAL PAIR .......... - ZZ = P + SIGN(ZZ,P) - WR(NA) = X + ZZ - WR(EN) = WR(NA) - IF (ZZ .NE. 0.0E0) WR(EN) = X - W / ZZ - WI(NA) = 0.0E0 - WI(EN) = 0.0E0 - GO TO 330 -C .......... COMPLEX PAIR .......... - 320 WR(NA) = X + P - WR(EN) = X + P - WI(NA) = ZZ - WI(EN) = -ZZ - 330 EN = ENM2 - GO TO 60 -C .......... SET ERROR -- NO CONVERGENCE TO AN -C EIGENVALUE AFTER 30*N ITERATIONS .......... - 1000 IERR = EN - 1001 RETURN - END diff --git a/slatec/hqr2.f b/slatec/hqr2.f deleted file mode 100644 index a6c2431..0000000 --- a/slatec/hqr2.f +++ /dev/null @@ -1,434 +0,0 @@ -*DECK HQR2 - SUBROUTINE HQR2 (NM, N, LOW, IGH, H, WR, WI, Z, IERR) -C***BEGIN PROLOGUE HQR2 -C***PURPOSE Compute the eigenvalues and eigenvectors of a real upper -C Hessenberg matrix using QR method. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C2B -C***TYPE SINGLE PRECISION (HQR2-S, COMQR2-C) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure HQR2, -C NUM. MATH. 16, 181-204(1970) by Peters and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). -C -C This subroutine finds the eigenvalues and eigenvectors -C of a REAL UPPER Hessenberg matrix by the QR method. The -C eigenvectors of a REAL GENERAL matrix can also be found -C if ELMHES and ELTRAN or ORTHES and ORTRAN have -C been used to reduce this general matrix to Hessenberg form -C and to accumulate the similarity transformations. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, H and Z, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix H. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C LOW and IGH are two INTEGER variables determined by the -C balancing subroutine BALANC. If BALANC has not been -C used, set LOW=1 and IGH equal to the order of the matrix, N. -C -C H contains the upper Hessenberg matrix. H is a two-dimensional -C REAL array, dimensioned H(NM,N). -C -C Z contains the transformation matrix produced by ELTRAN -C after the reduction by ELMHES, or by ORTRAN after the -C reduction by ORTHES, if performed. If the eigenvectors -C of the Hessenberg matrix are desired, Z must contain the -C identity matrix. Z is a two-dimensional REAL array, -C dimensioned Z(NM,M). -C -C On OUTPUT -C -C H has been destroyed. -C -C WR and WI contain the real and imaginary parts, respectively, -C of the eigenvalues. The eigenvalues are unordered except -C that complex conjugate pairs of values appear consecutively -C with the eigenvalue having the positive imaginary part first. -C If an error exit is made, the eigenvalues should be correct -C for indices IERR+1, IERR+2, ..., N. WR and WI are one- -C dimensional REAL arrays, dimensioned WR(N) and WI(N). -C -C Z contains the real and imaginary parts of the eigenvectors. -C If the J-th eigenvalue is real, the J-th column of Z -C contains its eigenvector. If the J-th eigenvalue is complex -C with positive imaginary part, the J-th and (J+1)-th -C columns of Z contain the real and imaginary parts of its -C eigenvector. The eigenvectors are unnormalized. If an -C error exit is made, none of the eigenvectors has been found. -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C J if the J-th eigenvalue has not been -C determined after a total of 30*N iterations. -C The eigenvalues should be correct for indices -C IERR+1, IERR+2, ..., N, but no eigenvectors are -C computed. -C -C Calls CDIV for complex division. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED CDIV -C***REVISION HISTORY (YYMMDD) -C 760101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE HQR2 -C - INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NA,NM,NN - INTEGER IGH,ITN,ITS,LOW,MP2,ENM2,IERR - REAL H(NM,*),WR(*),WI(*),Z(NM,*) - REAL P,Q,R,S,T,W,X,Y,RA,SA,VI,VR,ZZ,NORM,S1,S2 - LOGICAL NOTLAS -C -C***FIRST EXECUTABLE STATEMENT HQR2 - IERR = 0 - NORM = 0.0E0 - K = 1 -C .......... STORE ROOTS ISOLATED BY BALANC -C AND COMPUTE MATRIX NORM .......... - DO 50 I = 1, N -C - DO 40 J = K, N - 40 NORM = NORM + ABS(H(I,J)) -C - K = I - IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50 - WR(I) = H(I,I) - WI(I) = 0.0E0 - 50 CONTINUE -C - EN = IGH - T = 0.0E0 - ITN = 30*N -C .......... SEARCH FOR NEXT EIGENVALUES .......... - 60 IF (EN .LT. LOW) GO TO 340 - ITS = 0 - NA = EN - 1 - ENM2 = NA - 1 -C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT -C FOR L=EN STEP -1 UNTIL LOW DO -- .......... - 70 DO 80 LL = LOW, EN - L = EN + LOW - LL - IF (L .EQ. LOW) GO TO 100 - S = ABS(H(L-1,L-1)) + ABS(H(L,L)) - IF (S .EQ. 0.0E0) S = NORM - S2 = S + ABS(H(L,L-1)) - IF (S2 .EQ. S) GO TO 100 - 80 CONTINUE -C .......... FORM SHIFT .......... - 100 X = H(EN,EN) - IF (L .EQ. EN) GO TO 270 - Y = H(NA,NA) - W = H(EN,NA) * H(NA,EN) - IF (L .EQ. NA) GO TO 280 - IF (ITN .EQ. 0) GO TO 1000 - IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130 -C .......... FORM EXCEPTIONAL SHIFT .......... - T = T + X -C - DO 120 I = LOW, EN - 120 H(I,I) = H(I,I) - X -C - S = ABS(H(EN,NA)) + ABS(H(NA,ENM2)) - X = 0.75E0 * S - Y = X - W = -0.4375E0 * S * S - 130 ITS = ITS + 1 - ITN = ITN - 1 -C .......... LOOK FOR TWO CONSECUTIVE SMALL -C SUB-DIAGONAL ELEMENTS. -C FOR M=EN-2 STEP -1 UNTIL L DO -- .......... - DO 140 MM = L, ENM2 - M = ENM2 + L - MM - ZZ = H(M,M) - R = X - ZZ - S = Y - ZZ - P = (R * S - W) / H(M+1,M) + H(M,M+1) - Q = H(M+1,M+1) - ZZ - R - S - R = H(M+2,M+1) - S = ABS(P) + ABS(Q) + ABS(R) - P = P / S - Q = Q / S - R = R / S - IF (M .EQ. L) GO TO 150 - S1 = ABS(P) * (ABS(H(M-1,M-1)) + ABS(ZZ) + ABS(H(M+1,M+1))) - S2 = S1 + ABS(H(M,M-1)) * (ABS(Q) + ABS(R)) - IF (S2 .EQ. S1) GO TO 150 - 140 CONTINUE -C - 150 MP2 = M + 2 -C - DO 160 I = MP2, EN - H(I,I-2) = 0.0E0 - IF (I .EQ. MP2) GO TO 160 - H(I,I-3) = 0.0E0 - 160 CONTINUE -C .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND -C COLUMNS M TO EN .......... - DO 260 K = M, NA - NOTLAS = K .NE. NA - IF (K .EQ. M) GO TO 170 - P = H(K,K-1) - Q = H(K+1,K-1) - R = 0.0E0 - IF (NOTLAS) R = H(K+2,K-1) - X = ABS(P) + ABS(Q) + ABS(R) - IF (X .EQ. 0.0E0) GO TO 260 - P = P / X - Q = Q / X - R = R / X - 170 S = SIGN(SQRT(P*P+Q*Q+R*R),P) - IF (K .EQ. M) GO TO 180 - H(K,K-1) = -S * X - GO TO 190 - 180 IF (L .NE. M) H(K,K-1) = -H(K,K-1) - 190 P = P + S - X = P / S - Y = Q / S - ZZ = R / S - Q = Q / P - R = R / P -C .......... ROW MODIFICATION .......... - DO 210 J = K, N - P = H(K,J) + Q * H(K+1,J) - IF (.NOT. NOTLAS) GO TO 200 - P = P + R * H(K+2,J) - H(K+2,J) = H(K+2,J) - P * ZZ - 200 H(K+1,J) = H(K+1,J) - P * Y - H(K,J) = H(K,J) - P * X - 210 CONTINUE -C - J = MIN(EN,K+3) -C .......... COLUMN MODIFICATION .......... - DO 230 I = 1, J - P = X * H(I,K) + Y * H(I,K+1) - IF (.NOT. NOTLAS) GO TO 220 - P = P + ZZ * H(I,K+2) - H(I,K+2) = H(I,K+2) - P * R - 220 H(I,K+1) = H(I,K+1) - P * Q - H(I,K) = H(I,K) - P - 230 CONTINUE -C .......... ACCUMULATE TRANSFORMATIONS .......... - DO 250 I = LOW, IGH - P = X * Z(I,K) + Y * Z(I,K+1) - IF (.NOT. NOTLAS) GO TO 240 - P = P + ZZ * Z(I,K+2) - Z(I,K+2) = Z(I,K+2) - P * R - 240 Z(I,K+1) = Z(I,K+1) - P * Q - Z(I,K) = Z(I,K) - P - 250 CONTINUE -C - 260 CONTINUE -C - GO TO 70 -C .......... ONE ROOT FOUND .......... - 270 H(EN,EN) = X + T - WR(EN) = H(EN,EN) - WI(EN) = 0.0E0 - EN = NA - GO TO 60 -C .......... TWO ROOTS FOUND .......... - 280 P = (Y - X) / 2.0E0 - Q = P * P + W - ZZ = SQRT(ABS(Q)) - H(EN,EN) = X + T - X = H(EN,EN) - H(NA,NA) = Y + T - IF (Q .LT. 0.0E0) GO TO 320 -C .......... REAL PAIR .......... - ZZ = P + SIGN(ZZ,P) - WR(NA) = X + ZZ - WR(EN) = WR(NA) - IF (ZZ .NE. 0.0E0) WR(EN) = X - W / ZZ - WI(NA) = 0.0E0 - WI(EN) = 0.0E0 - X = H(EN,NA) - S = ABS(X) + ABS(ZZ) - P = X / S - Q = ZZ / S - R = SQRT(P*P+Q*Q) - P = P / R - Q = Q / R -C .......... ROW MODIFICATION .......... - DO 290 J = NA, N - ZZ = H(NA,J) - H(NA,J) = Q * ZZ + P * H(EN,J) - H(EN,J) = Q * H(EN,J) - P * ZZ - 290 CONTINUE -C .......... COLUMN MODIFICATION .......... - DO 300 I = 1, EN - ZZ = H(I,NA) - H(I,NA) = Q * ZZ + P * H(I,EN) - H(I,EN) = Q * H(I,EN) - P * ZZ - 300 CONTINUE -C .......... ACCUMULATE TRANSFORMATIONS .......... - DO 310 I = LOW, IGH - ZZ = Z(I,NA) - Z(I,NA) = Q * ZZ + P * Z(I,EN) - Z(I,EN) = Q * Z(I,EN) - P * ZZ - 310 CONTINUE -C - GO TO 330 -C .......... COMPLEX PAIR .......... - 320 WR(NA) = X + P - WR(EN) = X + P - WI(NA) = ZZ - WI(EN) = -ZZ - 330 EN = ENM2 - GO TO 60 -C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND -C VECTORS OF UPPER TRIANGULAR FORM .......... - 340 IF (NORM .EQ. 0.0E0) GO TO 1001 -C .......... FOR EN=N STEP -1 UNTIL 1 DO -- .......... - DO 800 NN = 1, N - EN = N + 1 - NN - P = WR(EN) - Q = WI(EN) - NA = EN - 1 - IF (Q) 710, 600, 800 -C .......... REAL VECTOR .......... - 600 M = EN - H(EN,EN) = 1.0E0 - IF (NA .EQ. 0) GO TO 800 -C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... - DO 700 II = 1, NA - I = EN - II - W = H(I,I) - P - R = H(I,EN) - IF (M .GT. NA) GO TO 620 -C - DO 610 J = M, NA - 610 R = R + H(I,J) * H(J,EN) -C - 620 IF (WI(I) .GE. 0.0E0) GO TO 630 - ZZ = W - S = R - GO TO 700 - 630 M = I - IF (WI(I) .NE. 0.0E0) GO TO 640 - T = W - IF (T .NE. 0.0E0) GO TO 635 - T = NORM - 632 T = 0.5E0*T - IF (NORM + T .GT. NORM) GO TO 632 - T = 2.0E0*T - 635 H(I,EN) = -R / T - GO TO 700 -C .......... SOLVE REAL EQUATIONS .......... - 640 X = H(I,I+1) - Y = H(I+1,I) - Q = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) - T = (X * S - ZZ * R) / Q - H(I,EN) = T - IF (ABS(X) .LE. ABS(ZZ)) GO TO 650 - H(I+1,EN) = (-R - W * T) / X - GO TO 700 - 650 H(I+1,EN) = (-S - Y * T) / ZZ - 700 CONTINUE -C .......... END REAL VECTOR .......... - GO TO 800 -C .......... COMPLEX VECTOR .......... - 710 M = NA -C .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT -C EIGENVECTOR MATRIX IS TRIANGULAR .......... - IF (ABS(H(EN,NA)) .LE. ABS(H(NA,EN))) GO TO 720 - H(NA,NA) = Q / H(EN,NA) - H(NA,EN) = -(H(EN,EN) - P) / H(EN,NA) - GO TO 730 - 720 CALL CDIV(0.0E0,-H(NA,EN),H(NA,NA)-P,Q,H(NA,NA),H(NA,EN)) - 730 H(EN,NA) = 0.0E0 - H(EN,EN) = 1.0E0 - ENM2 = NA - 1 - IF (ENM2 .EQ. 0) GO TO 800 -C .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- .......... - DO 790 II = 1, ENM2 - I = NA - II - W = H(I,I) - P - RA = 0.0E0 - SA = H(I,EN) -C - DO 760 J = M, NA - RA = RA + H(I,J) * H(J,NA) - SA = SA + H(I,J) * H(J,EN) - 760 CONTINUE -C - IF (WI(I) .GE. 0.0E0) GO TO 770 - ZZ = W - R = RA - S = SA - GO TO 790 - 770 M = I - IF (WI(I) .NE. 0.0E0) GO TO 780 - CALL CDIV(-RA,-SA,W,Q,H(I,NA),H(I,EN)) - GO TO 790 -C .......... SOLVE COMPLEX EQUATIONS .......... - 780 X = H(I,I+1) - Y = H(I+1,I) - VR = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) - Q * Q - VI = (WR(I) - P) * 2.0E0 * Q - IF (VR .NE. 0.0E0 .OR. VI .NE. 0.0E0) GO TO 783 - S1 = NORM * (ABS(W)+ABS(Q)+ABS(X)+ABS(Y)+ABS(ZZ)) - VR = S1 - 782 VR = 0.5E0*VR - IF (S1 + VR .GT. S1) GO TO 782 - VR = 2.0E0*VR - 783 CALL CDIV(X*R-ZZ*RA+Q*SA,X*S-ZZ*SA-Q*RA,VR,VI, - 1 H(I,NA),H(I,EN)) - IF (ABS(X) .LE. ABS(ZZ) + ABS(Q)) GO TO 785 - H(I+1,NA) = (-RA - W * H(I,NA) + Q * H(I,EN)) / X - H(I+1,EN) = (-SA - W * H(I,EN) - Q * H(I,NA)) / X - GO TO 790 - 785 CALL CDIV(-R-Y*H(I,NA),-S-Y*H(I,EN),ZZ,Q, - 1 H(I+1,NA),H(I+1,EN)) - 790 CONTINUE -C .......... END COMPLEX VECTOR .......... - 800 CONTINUE -C .......... END BACK SUBSTITUTION. -C VECTORS OF ISOLATED ROOTS .......... - DO 840 I = 1, N - IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840 -C - DO 820 J = I, N - 820 Z(I,J) = H(I,J) -C - 840 CONTINUE -C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE -C VECTORS OF ORIGINAL FULL MATRIX. -C FOR J=N STEP -1 UNTIL LOW DO -- .......... - DO 880 JJ = LOW, N - J = N + LOW - JJ - M = MIN(J,IGH) -C - DO 880 I = LOW, IGH - ZZ = 0.0E0 -C - DO 860 K = LOW, M - 860 ZZ = ZZ + Z(I,K) * H(K,J) -C - Z(I,J) = ZZ - 880 CONTINUE -C - GO TO 1001 -C .......... SET ERROR -- NO CONVERGENCE TO AN -C EIGENVALUE AFTER 30*N ITERATIONS .......... - 1000 IERR = EN - 1001 RETURN - END diff --git a/slatec/hstart.f b/slatec/hstart.f deleted file mode 100644 index b4902ec..0000000 --- a/slatec/hstart.f +++ /dev/null @@ -1,328 +0,0 @@ -*DECK HSTART - SUBROUTINE HSTART (F, NEQ, A, B, Y, YPRIME, ETOL, MORDER, SMALL, - + BIG, SPY, PV, YP, SF, RPAR, IPAR, H) -C***BEGIN PROLOGUE HSTART -C***SUBSIDIARY -C***PURPOSE Subsidiary to DEABM, DEBDF and DERKF -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (HSTART-S, DHSTRT-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C HSTART computes a starting step size to be used in solving initial -C value problems in ordinary differential equations. -C ********************************************************************** -C Abstract -C -C Subroutine HSTART computes a starting step size to be used by an -C initial value method in solving ordinary differential equations. -C It is based on an estimate of the local Lipschitz constant for the -C differential equation (lower bound on a norm of the Jacobian), -C a bound on the differential equation (first derivative), and -C a bound on the partial derivative of the equation with respect to -C the independent variable. -C (All approximated near the initial point A.) -C -C Subroutine HSTART uses a function subprogram HVNRM for computing -C a vector norm. The maximum norm is presently utilized though it -C can easily be replaced by any other vector norm. It is presumed -C that any replacement norm routine would be carefully coded to -C prevent unnecessary underflows or overflows from occurring, and -C also, would not alter the vector or number of components. -C -C ********************************************************************** -C On Input you must provide the following -C -C F -- This is a subroutine of the form -C F(X,U,UPRIME,RPAR,IPAR) -C which defines the system of first order differential -C equations to be solved. For the given values of X and the -C vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must -C evaluate the NEQ components of the system of differential -C equations dU/DX=F(X,U) and store the derivatives in the -C array UPRIME(*), that is, UPRIME(I) = * dU(I)/DX * for -C equations I=1,...,NEQ. -C -C Subroutine F must not alter X or U(*). You must declare -C the name F in an EXTERNAL statement in your program that -C calls HSTART. You must dimension U and UPRIME in F. -C -C RPAR and IPAR are real and integer parameter arrays which -C you can use for communication between your program and -C subroutine F. They are not used or altered by HSTART. If -C you do not need RPAR or IPAR, ignore these parameters by -C treating them as dummy arguments. If you do choose to use -C them, dimension them in your program and in F as arrays -C of appropriate length. -C -C NEQ -- This is the number of (first order) differential equations -C to be integrated. -C -C A -- This is the initial point of integration. -C -C B -- This is a value of the independent variable used to define -C the direction of integration. A reasonable choice is to -C set B to the first point at which a solution is desired. -C You can also use B, if necessary, to restrict the length -C of the first integration step because the algorithm will -C not compute a starting step length which is bigger than -C ABS(B-A), unless B has been chosen too close to A. -C (It is presumed that HSTART has been called with B -C different from A on the machine being used. Also see -C the discussion about the parameter SMALL.) -C -C Y(*) -- This is the vector of initial values of the NEQ solution -C components at the initial point A. -C -C YPRIME(*) -- This is the vector of derivatives of the NEQ -C solution components at the initial point A. -C (defined by the differential equations in subroutine F) -C -C ETOL -- This is the vector of error tolerances corresponding to -C the NEQ solution components. It is assumed that all -C elements are positive. Following the first integration -C step, the tolerances are expected to be used by the -C integrator in an error test which roughly requires that -C ABS(local error) .LE. ETOL -C for each vector component. -C -C MORDER -- This is the order of the formula which will be used by -C the initial value method for taking the first integration -C step. -C -C SMALL -- This is a small positive machine dependent constant -C which is used for protecting against computations with -C numbers which are too small relative to the precision of -C floating point arithmetic. SMALL should be set to -C (approximately) the smallest positive real number such -C that (1.+SMALL) .GT. 1. on the machine being used. the -C quantity SMALL**(3/8) is used in computing increments of -C variables for approximating derivatives by differences. -C also the algorithm will not compute a starting step length -C which is smaller than 100*SMALL*ABS(A). -C -C BIG -- This is a large positive machine dependent constant which -C is used for preventing machine overflows. A reasonable -C choice is to set big to (approximately) the square root of -C the largest real number which can be held in the machine. -C -C SPY(*),PV(*),YP(*),SF(*) -- These are real work arrays of length -C NEQ which provide the routine with needed storage space. -C -C RPAR,IPAR -- These are parameter arrays, of real and integer -C type, respectively, which can be used for communication -C between your program and the F subroutine. They are not -C used or altered by HSTART. -C -C ********************************************************************** -C On Output (after the return from HSTART), -C -C H -- Is an appropriate starting step size to be attempted by the -C differential equation method. -C -C All parameters in the call list remain unchanged except for -C the working arrays SPY(*),PV(*),YP(*) and SF(*). -C -C ********************************************************************** -C -C***SEE ALSO DEABM, DEBDF, DERKF -C***ROUTINES CALLED HVNRM -C***REVISION HISTORY (YYMMDD) -C 800501 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891024 Changed references from VNORM to HVNRM. (WRB) -C 891024 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE HSTART -C - DIMENSION Y(*),YPRIME(*),ETOL(*),SPY(*),PV(*),YP(*),SF(*), - 1 RPAR(*),IPAR(*) - EXTERNAL F -C -C....................................................................... -C -C***FIRST EXECUTABLE STATEMENT HSTART - DX = B - A - ABSDX = ABS(DX) - RELPER = SMALL**0.375 - YNORM = HVNRM(Y,NEQ) -C -C....................................................................... -C -C COMPUTE A WEIGHTED APPROXIMATE BOUND (DFDXB) ON THE PARTIAL -C DERIVATIVE OF THE EQUATION WITH RESPECT TO THE -C INDEPENDENT VARIABLE. PROTECT AGAINST AN OVERFLOW. ALSO -C COMPUTE A WEIGHTED BOUND (FBND) ON THE FIRST DERIVATIVE LOCALLY. -C - DA = SIGN(MAX(MIN(RELPER*ABS(A),ABSDX),100.*SMALL*ABS(A)),DX) - IF (DA .EQ. 0.) DA = RELPER*DX - CALL F(A+DA,Y,SF,RPAR,IPAR) -C - IF (MORDER .EQ. 1) GO TO 20 - POWER = 2./(MORDER+1) - DO 10 J=1,NEQ - WTJ = ETOL(J)**POWER - SPY(J) = SF(J)/WTJ - YP(J) = YPRIME(J)/WTJ - 10 PV(J) = SPY(J) - YP(J) - GO TO 40 -C - 20 DO 30 J=1,NEQ - SPY(J) = SF(J)/ETOL(J) - YP(J) = YPRIME(J)/ETOL(J) - 30 PV(J) = SPY(J) - YP(J) -C - 40 DELF = HVNRM(PV,NEQ) - DFDXB = BIG - IF (DELF .LT. BIG*ABS(DA)) DFDXB = DELF/ABS(DA) - YPNORM = HVNRM(YP,NEQ) - FBND = MAX(HVNRM(SPY,NEQ),YPNORM) -C -C....................................................................... -C -C COMPUTE AN ESTIMATE (DFDUB) OF THE LOCAL LIPSCHITZ CONSTANT FOR -C THE SYSTEM OF DIFFERENTIAL EQUATIONS. THIS ALSO REPRESENTS AN -C ESTIMATE OF THE NORM OF THE JACOBIAN LOCALLY. -C THREE ITERATIONS (TWO WHEN NEQ=1) ARE USED TO ESTIMATE THE -C LIPSCHITZ CONSTANT BY NUMERICAL DIFFERENCES. THE FIRST -C PERTURBATION VECTOR IS BASED ON THE INITIAL DERIVATIVES AND -C DIRECTION OF INTEGRATION. THE SECOND PERTURBATION VECTOR IS -C FORMED USING ANOTHER EVALUATION OF THE DIFFERENTIAL EQUATION. -C THE THIRD PERTURBATION VECTOR IS FORMED USING PERTURBATIONS BASED -C ONLY ON THE INITIAL VALUES. COMPONENTS THAT ARE ZERO ARE ALWAYS -C CHANGED TO NON-ZERO VALUES (EXCEPT ON THE FIRST ITERATION). WHEN -C INFORMATION IS AVAILABLE, CARE IS TAKEN TO ENSURE THAT COMPONENTS -C OF THE PERTURBATION VECTOR HAVE SIGNS WHICH ARE CONSISTENT WITH -C THE SLOPES OF LOCAL SOLUTION CURVES. -C ALSO CHOOSE THE LARGEST BOUND (FBND) FOR THE FIRST DERIVATIVE. -C NO ATTEMPT IS MADE TO KEEP THE PERTURBATION VECTOR SIZE CONSTANT. -C - IF (YPNORM .EQ. 0.) GO TO 60 -C USE INITIAL DERIVATIVES FOR FIRST PERTURBATION - ICASE = 1 - DO 50 J=1,NEQ - SPY(J) = YPRIME(J) - 50 YP(J) = YPRIME(J) - GO TO 80 -C CANNOT HAVE A NULL PERTURBATION VECTOR - 60 ICASE = 2 - DO 70 J=1,NEQ - SPY(J) = YPRIME(J) - 70 YP(J) = ETOL(J) -C - 80 DFDUB = 0. - LK = MIN(NEQ+1,3) - DO 260 K=1,LK -C SET YPNORM AND DELX - YPNORM = HVNRM(YP,NEQ) - IF (ICASE .EQ. 1 .OR. ICASE .EQ. 3) GO TO 90 - DELX = SIGN(1.0,DX) - GO TO 120 -C TRY TO ENFORCE MEANINGFUL PERTURBATION VALUES - 90 DELX = DX - IF (ABS(DELX)*YPNORM .GE. RELPER*YNORM) GO TO 100 - DELXB = BIG - IF (RELPER*YNORM .LT. BIG*YPNORM) DELXB = RELPER*YNORM/YPNORM - DELX = SIGN(DELXB,DX) - 100 DO 110 J=1,NEQ - IF (ABS(DELX*YP(J)) .GT. ETOL(J)) DELX=SIGN(ETOL(J)/YP(J),DX) - 110 CONTINUE -C DEFINE PERTURBED VECTOR OF INITIAL VALUES - 120 DO 130 J=1,NEQ - 130 PV(J) = Y(J) + DELX*YP(J) - IF (K .EQ. 2) GO TO 150 -C EVALUATE DERIVATIVES ASSOCIATED WITH PERTURBED -C VECTOR AND COMPUTE CORRESPONDING DIFFERENCES - CALL F(A,PV,YP,RPAR,IPAR) - DO 140 J=1,NEQ - 140 PV(J) = YP(J) - YPRIME(J) - GO TO 170 -C USE A SHIFTED VALUE OF THE INDEPENDENT VARIABLE -C IN COMPUTING ONE ESTIMATE - 150 CALL F(A+DA,PV,YP,RPAR,IPAR) - DO 160 J=1,NEQ - 160 PV(J) = YP(J) - SF(J) -C CHOOSE LARGEST BOUND ON THE WEIGHTED FIRST -C DERIVATIVE - 170 IF (MORDER .EQ. 1) GO TO 190 - DO 180 J=1,NEQ - 180 YP(J) = YP(J)/ETOL(J)**POWER - GO TO 210 - 190 DO 200 J=1,NEQ - 200 YP(J) = YP(J)/ETOL(J) - 210 FBND = MAX(FBND,HVNRM(YP,NEQ)) -C COMPUTE BOUND ON A LOCAL LIPSCHITZ CONSTANT - DELF = HVNRM(PV,NEQ) - IF (DELF .EQ. 0.) GO TO 220 - DELY = ABS(DELX)*YPNORM - IF (DELF .GE. BIG*DELY) GO TO 270 - DFDUB = MAX(DFDUB,DELF/DELY) -C - 220 IF (K .EQ. LK) GO TO 280 -C CHOOSE NEXT PERTURBATION VECTOR - DO 250 J=1,NEQ - IF (K .EQ. LK-1) GO TO 230 - ICASE = 3 - DY = ABS(PV(J)) - IF (DY .EQ. 0.) DY = MAX(DELF,ETOL(J)) - GO TO 240 - 230 ICASE = 4 - DY = MAX(RELPER*ABS(Y(J)),ETOL(J)) - 240 IF (SPY(J) .EQ. 0.) SPY(J) = YP(J) - IF (SPY(J) .NE. 0.) DY = SIGN(DY,SPY(J)) - 250 YP(J) = DY - 260 CONTINUE -C -C PROTECT AGAINST AN OVERFLOW - 270 DFDUB = BIG -C -C....................................................................... -C -C COMPUTE A BOUND (YDPB) ON THE NORM OF THE SECOND DERIVATIVE -C - 280 YDPB = DFDXB + DFDUB*FBND -C -C....................................................................... -C -C COMPUTE A STARTING STEP SIZE BASED ON THE ABOVE FIRST AND SECOND -C DERIVATIVE INFORMATION -C -C RESTRICT THE STEP LENGTH TO BE NOT BIGGER THAN -C ABS(B-A). (UNLESS B IS TOO CLOSE TO A) - H = ABSDX -C - IF (YDPB .NE. 0. .OR. FBND .NE. 0.) GO TO 290 -C -C BOTH FIRST DERIVATIVE TERM (FBND) AND SECOND -C DERIVATIVE TERM (YDPB) ARE ZERO - GO TO 310 -C - 290 IF (YDPB .NE. 0.) GO TO 300 -C -C ONLY SECOND DERIVATIVE TERM (YDPB) IS ZERO - IF (1.0 .LT. FBND*ABSDX) H = 1./FBND - GO TO 310 -C -C SECOND DERIVATIVE TERM (YDPB) IS NON-ZERO - 300 SRYDPB = SQRT(0.5*YDPB) - IF (1.0 .LT. SRYDPB*ABSDX) H = 1./SRYDPB -C -C FURTHER RESTRICT THE STEP LENGTH TO BE NOT -C BIGGER THAN 1/DFDUB - 310 IF (H*DFDUB .GT. 1.) H = 1./DFDUB -C -C FINALLY, RESTRICT THE STEP LENGTH TO BE NOT -C SMALLER THAN 100*SMALL*ABS(A). HOWEVER, IF -C A=0. AND THE COMPUTED H UNDERFLOWED TO ZERO, -C THE ALGORITHM RETURNS SMALL*ABS(B) FOR THE -C STEP LENGTH. - H = MAX(H,100.*SMALL*ABS(A)) - IF (H .EQ. 0.) H = SMALL*ABS(B) -C -C NOW SET DIRECTION OF INTEGRATION - H = SIGN(H,DX) -C - RETURN - END diff --git a/slatec/hstcrt.f b/slatec/hstcrt.f deleted file mode 100644 index 77c43ac..0000000 --- a/slatec/hstcrt.f +++ /dev/null @@ -1,416 +0,0 @@ -*DECK HSTCRT - SUBROUTINE HSTCRT (A, B, M, MBDCND, BDA, BDB, C, D, N, NBDCND, - + BDC, BDD, ELMBDA, F, IDIMF, PERTRB, IERROR, W) -C***BEGIN PROLOGUE HSTCRT -C***PURPOSE Solve the standard five-point finite difference -C approximation on a staggered grid to the Helmholtz equation -C in Cartesian coordinates. -C***LIBRARY SLATEC (FISHPACK) -C***CATEGORY I2B1A1A -C***TYPE SINGLE PRECISION (HSTCRT-S) -C***KEYWORDS ELLIPTIC, FISHPACK, HELMHOLTZ, PDE -C***AUTHOR Adams, J., (NCAR) -C Swarztrauber, P. N., (NCAR) -C Sweet, R., (NCAR) -C***DESCRIPTION -C -C HSTCRT solves the standard five-point finite difference -C approximation on a staggered grid to the Helmholtz equation in -C Cartesian coordinates -C -C (d/dX)(dU/dX) + (d/dY)(dU/dY) + LAMBDA*U = F(X,Y) -C -C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -C -C * * * * * * * * Parameter Description * * * * * * * * * * -C -C * * * * * * On Input * * * * * * -C -C A,B -C The range of X, i.e. A .LE. X .LE. B. A must be less than B. -C -C M -C The number of grid points in the interval (A,B). The grid points -C in the X-direction are given by X(I) = A + (I-0.5)dX for -C I=1,2,...,M where dX =(B-A)/M. M must be greater than 2. -C -C MBDCND -C Indicates the type of boundary conditions at X = A and X = B. -C -C = 0 If the solution is periodic in X, -C U(M+I,J) = U(I,J). -C -C = 1 If the solution is specified at X = A and X = B. -C -C = 2 If the solution is specified at X = A and the derivative -C of the solution with respect to X is specified at X = B. -C -C = 3 If the derivative of the solution with respect to X is -C specified at X = A and X = B. -C -C = 4 If the derivative of the solution with respect to X is -C specified at X = A and the solution is specified at X = B. -C -C BDA -C A one-dimensional array of length N that specifies the boundary -C values (if any) of the solution at X = A. When MBDCND = 1 or 2, -C -C BDA(J) = U(A,Y(J)) , J=1,2,...,N. -C -C When MBDCND = 3 or 4, -C -C BDA(J) = (d/dX)U(A,Y(J)) , J=1,2,...,N. -C -C BDB -C A one-dimensional array of length N that specifies the boundary -C values of the solution at X = B. When MBDCND = 1 or 4 -C -C BDB(J) = U(B,Y(J)) , J=1,2,...,N. -C -C When MBDCND = 2 or 3 -C -C BDB(J) = (d/dX)U(B,Y(J)) , J=1,2,...,N. -C -C C,D -C The range of Y, i.e. C .LE. Y .LE. D. C must be less -C than D. -C -C N -C The number of unknowns in the interval (C,D). The unknowns in -C the Y-direction are given by Y(J) = C + (J-0.5)DY, -C J=1,2,...,N, where DY = (D-C)/N. N must be greater than 2. -C -C NBDCND -C Indicates the type of boundary conditions at Y = C -C and Y = D. -C -C = 0 If the solution is periodic in Y, i.e. -C U(I,J) = U(I,N+J). -C -C = 1 If the solution is specified at Y = C and Y = D. -C -C = 2 If the solution is specified at Y = C and the derivative -C of the solution with respect to Y is specified at Y = D. -C -C = 3 If the derivative of the solution with respect to Y is -C specified at Y = C and Y = D. -C -C = 4 If the derivative of the solution with respect to Y is -C specified at Y = C and the solution is specified at Y = D. -C -C BDC -C A one dimensional array of length M that specifies the boundary -C values of the solution at Y = C. When NBDCND = 1 or 2, -C -C BDC(I) = U(X(I),C) , I=1,2,...,M. -C -C When NBDCND = 3 or 4, -C -C BDC(I) = (d/dY)U(X(I),C), I=1,2,...,M. -C -C When NBDCND = 0, BDC is a dummy variable. -C -C BDD -C A one-dimensional array of length M that specifies the boundary -C values of the solution at Y = D. When NBDCND = 1 or 4, -C -C BDD(I) = U(X(I),D) , I=1,2,...,M. -C -C When NBDCND = 2 or 3, -C -C BDD(I) = (d/dY)U(X(I),D) , I=1,2,...,M. -C -C When NBDCND = 0, BDD is a dummy variable. -C -C ELMBDA -C The constant LAMBDA in the Helmholtz equation. If LAMBDA is -C greater than 0, a solution may not exist. However, HSTCRT will -C attempt to find a solution. -C -C F -C A two-dimensional array that specifies the values of the right -C side of the Helmholtz equation. For I=1,2,...,M and J=1,2,...,N -C -C F(I,J) = F(X(I),Y(J)) . -C -C F must be dimensioned at least M X N. -C -C IDIMF -C The row (or first) dimension of the array F as it appears in the -C program calling HSTCRT. This parameter is used to specify the -C variable dimension of F. IDIMF must be at least M. -C -C W -C A one-dimensional array that must be provided by the user for -C work space. W may require up to 13M + 4N + M*INT(log2(N)) -C locations. The actual number of locations used is computed by -C HSTCRT and is returned in the location W(1). -C -C -C * * * * * * On Output * * * * * * -C -C F -C Contains the solution U(I,J) of the finite difference -C approximation for the grid point (X(I),Y(J)) for -C I=1,2,...,M, J=1,2,...,N. -C -C PERTRB -C If a combination of periodic or derivative boundary conditions is -C specified for a Poisson equation (LAMBDA = 0), a solution may not -C exist. PERTRB is a constant, calculated and subtracted from F, -C which ensures that a solution exists. HSTCRT then computes this -C solution, which is a least squares solution to the original -C approximation. This solution plus any constant is also a -C solution; hence, the solution is not unique. The value of PERTRB -C should be small compared to the right side F. Otherwise, a -C solution is obtained to an essentially different problem. This -C comparison should always be made to insure that a meaningful -C solution has been obtained. -C -C IERROR -C An error flag that indicates invalid input parameters. -C Except for numbers 0 and 6, a solution is not attempted. -C -C = 0 No error -C -C = 1 A .GE. B -C -C = 2 MBDCND .LT. 0 or MBDCND .GT. 4 -C -C = 3 C .GE. D -C -C = 4 N .LE. 2 -C -C = 5 NBDCND .LT. 0 or NBDCND .GT. 4 -C -C = 6 LAMBDA .GT. 0 -C -C = 7 IDIMF .LT. M -C -C = 8 M .LE. 2 -C -C Since this is the only means of indicating a possibly -C incorrect call to HSTCRT, the user should test IERROR after -C the call. -C -C W -C W(1) contains the required length of W. -C -C *Long Description: -C -C * * * * * * * Program Specifications * * * * * * * * * * * * -C -C Dimension of BDA(N),BDB(N),BDC(M),BDD(M),F(IDIMF,N), -C Arguments W(See argument list) -C -C Latest June 1, 1977 -C Revision -C -C Subprograms HSTCRT,POISTG,POSTG2,GENBUN,POISD2,POISN2,POISP2, -C Required COSGEN,MERGE,TRIX,TRI3,PIMACH -C -C Special NONE -C Conditions -C -C Common NONE -C Blocks -C -C I/O NONE -C -C Precision Single -C -C Specialist Roland Sweet -C -C Language FORTRAN -C -C History Written by Roland Sweet at NCAR in January , 1977 -C -C Algorithm This subroutine defines the finite-difference -C equations, incorporates boundary data, adjusts the -C right side when the system is singular and calls -C either POISTG or GENBUN which solves the linear -C system of equations. -C -C Space 8131(decimal) = 17703(octal) locations on the -C Required NCAR Control Data 7600 -C -C Timing and The execution time T on the NCAR Control Data -C Accuracy 7600 for subroutine HSTCRT is roughly proportional -C to M*N*log2(N). Some typical values are listed in -C the table below. -C The solution process employed results in a loss -C of no more than FOUR significant digits for N and M -C as large as 64. More detailed information about -C accuracy can be found in the documentation for -C subroutine POISTG which is the routine that -C actually solves the finite difference equations. -C -C -C M(=N) MBDCND NBDCND T(MSECS) -C ----- ------ ------ -------- -C -C 32 1-4 1-4 56 -C 64 1-4 1-4 230 -C -C Portability American National Standards Institute Fortran. -C The machine dependent constant PI is defined in -C function PIMACH. -C -C Required COS -C Resident -C Routines -C -C Reference Schumann, U. and R. Sweet,'A Direct Method For -C The Solution Of Poisson's Equation With Neumann -C Boundary Conditions On A Staggered Grid Of -C Arbitrary Size,' J. COMP. PHYS. 20(1976), -C PP. 171-182. -C -C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -C -C***REFERENCES U. Schumann and R. Sweet, A direct method for the -C solution of Poisson's equation with Neumann boundary -C conditions on a staggered grid of arbitrary size, -C Journal of Computational Physics 20, (1976), -C pp. 171-182. -C***ROUTINES CALLED GENBUN, POISTG -C***REVISION HISTORY (YYMMDD) -C 801001 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 HSTCRT -C -C - DIMENSION F(IDIMF,*) ,BDA(*) ,BDB(*) ,BDC(*) , - 1 BDD(*) ,W(*) -C***FIRST EXECUTABLE STATEMENT HSTCRT - IERROR = 0 - IF (A .GE. B) IERROR = 1 - IF (MBDCND.LT.0 .OR. MBDCND.GT.4) IERROR = 2 - IF (C .GE. D) IERROR = 3 - IF (N .LE. 2) IERROR = 4 - IF (NBDCND.LT.0 .OR. NBDCND.GT.4) IERROR = 5 - IF (IDIMF .LT. M) IERROR = 7 - IF (M .LE. 2) IERROR = 8 - IF (IERROR .NE. 0) RETURN - NPEROD = NBDCND - MPEROD = 0 - IF (MBDCND .GT. 0) MPEROD = 1 - DELTAX = (B-A)/M - TWDELX = 1./DELTAX - DELXSQ = 2./DELTAX**2 - DELTAY = (D-C)/N - TWDELY = 1./DELTAY - DELYSQ = DELTAY**2 - TWDYSQ = 2./DELYSQ - NP = NBDCND+1 - MP = MBDCND+1 -C -C DEFINE THE A,B,C COEFFICIENTS IN W-ARRAY. -C - ID2 = M - ID3 = ID2+M - ID4 = ID3+M - S = (DELTAY/DELTAX)**2 - ST2 = 2.*S - DO 101 I=1,M - W(I) = S - J = ID2+I - W(J) = -ST2+ELMBDA*DELYSQ - J = ID3+I - W(J) = S - 101 CONTINUE -C -C ENTER BOUNDARY DATA FOR X-BOUNDARIES. -C - GO TO (111,102,102,104,104),MP - 102 DO 103 J=1,N - F(1,J) = F(1,J)-BDA(J)*DELXSQ - 103 CONTINUE - W(ID2+1) = W(ID2+1)-W(1) - GO TO 106 - 104 DO 105 J=1,N - F(1,J) = F(1,J)+BDA(J)*TWDELX - 105 CONTINUE - W(ID2+1) = W(ID2+1)+W(1) - 106 GO TO (111,107,109,109,107),MP - 107 DO 108 J=1,N - F(M,J) = F(M,J)-BDB(J)*DELXSQ - 108 CONTINUE - W(ID3) = W(ID3)-W(1) - GO TO 111 - 109 DO 110 J=1,N - F(M,J) = F(M,J)-BDB(J)*TWDELX - 110 CONTINUE - W(ID3) = W(ID3)+W(1) - 111 CONTINUE -C -C ENTER BOUNDARY DATA FOR Y-BOUNDARIES. -C - GO TO (121,112,112,114,114),NP - 112 DO 113 I=1,M - F(I,1) = F(I,1)-BDC(I)*TWDYSQ - 113 CONTINUE - GO TO 116 - 114 DO 115 I=1,M - F(I,1) = F(I,1)+BDC(I)*TWDELY - 115 CONTINUE - 116 GO TO (121,117,119,119,117),NP - 117 DO 118 I=1,M - F(I,N) = F(I,N)-BDD(I)*TWDYSQ - 118 CONTINUE - GO TO 121 - 119 DO 120 I=1,M - F(I,N) = F(I,N)-BDD(I)*TWDELY - 120 CONTINUE - 121 CONTINUE - DO 123 I=1,M - DO 122 J=1,N - F(I,J) = F(I,J)*DELYSQ - 122 CONTINUE - 123 CONTINUE - IF (MPEROD .EQ. 0) GO TO 124 - W(1) = 0. - W(ID4) = 0. - 124 CONTINUE - PERTRB = 0. - IF (ELMBDA) 133,126,125 - 125 IERROR = 6 - GO TO 133 - 126 GO TO (127,133,133,127,133),MP - 127 GO TO (128,133,133,128,133),NP -C -C FOR SINGULAR PROBLEMS MUST ADJUST DATA TO INSURE THAT A SOLUTION -C WILL EXIST. -C - 128 CONTINUE - S = 0. - DO 130 J=1,N - DO 129 I=1,M - S = S+F(I,J) - 129 CONTINUE - 130 CONTINUE - PERTRB = S/(M*N) - DO 132 J=1,N - DO 131 I=1,M - F(I,J) = F(I,J)-PERTRB - 131 CONTINUE - 132 CONTINUE - PERTRB = PERTRB/DELYSQ -C -C SOLVE THE EQUATION. -C - 133 CONTINUE - IF (NPEROD .EQ. 0) GO TO 134 - CALL POISTG (NPEROD,N,MPEROD,M,W(1),W(ID2+1),W(ID3+1),IDIMF,F, - 1 IERR1,W(ID4+1)) - GO TO 135 - 134 CONTINUE - CALL GENBUN (NPEROD,N,MPEROD,M,W(1),W(ID2+1),W(ID3+1),IDIMF,F, - 1 IERR1,W(ID4+1)) - 135 CONTINUE - W(1) = W(ID4+1)+3*M - RETURN - END diff --git a/slatec/hstcs1.f b/slatec/hstcs1.f deleted file mode 100644 index 0a811a7..0000000 --- a/slatec/hstcs1.f +++ /dev/null @@ -1,193 +0,0 @@ -*DECK HSTCS1 - SUBROUTINE HSTCS1 (INTL, A, B, M, MBDCND, BDA, BDB, C, D, N, - + NBDCND, BDC, BDD, ELMBDA, F, IDIMF, PERTRB, IERR1, AM, BM, CM, - + AN, BN, CN, SNTH, RSQ, WRK) -C***BEGIN PROLOGUE HSTCS1 -C***SUBSIDIARY -C***PURPOSE Subsidiary to HSTCSP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (HSTCS1-S) -C***AUTHOR (UNKNOWN) -C***SEE ALSO HSTCSP -C***ROUTINES CALLED BLKTRI -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE HSTCS1 - DIMENSION BDA(*) ,BDB(*) ,BDC(*) ,BDD(*) , - 1 F(IDIMF,*) ,AM(*) ,BM(*) ,CM(*) , - 2 AN(*) ,BN(*) ,CN(*) ,SNTH(*) , - 3 RSQ(*) ,WRK(*) -C***FIRST EXECUTABLE STATEMENT HSTCS1 - DTH = (B-A)/M - DTHSQ = DTH*DTH - DO 101 I=1,M - SNTH(I) = SIN(A+(I-0.5)*DTH) - 101 CONTINUE - DR = (D-C)/N - DO 102 J=1,N - RSQ(J) = (C+(J-0.5)*DR)**2 - 102 CONTINUE -C -C MULTIPLY RIGHT SIDE BY R(J)**2 -C - DO 104 J=1,N - X = RSQ(J) - DO 103 I=1,M - F(I,J) = X*F(I,J) - 103 CONTINUE - 104 CONTINUE -C -C DEFINE COEFFICIENTS AM,BM,CM -C - X = 1./(2.*COS(DTH/2.)) - DO 105 I=2,M - AM(I) = (SNTH(I-1)+SNTH(I))*X - CM(I-1) = AM(I) - 105 CONTINUE - AM(1) = SIN(A) - CM(M) = SIN(B) - DO 106 I=1,M - X = 1./SNTH(I) - Y = X/DTHSQ - AM(I) = AM(I)*Y - CM(I) = CM(I)*Y - BM(I) = ELMBDA*X*X-AM(I)-CM(I) - 106 CONTINUE -C -C DEFINE COEFFICIENTS AN,BN,CN -C - X = C/DR - DO 107 J=1,N - AN(J) = (X+J-1)**2 - CN(J) = (X+J)**2 - BN(J) = -(AN(J)+CN(J)) - 107 CONTINUE - ISW = 1 - NB = NBDCND - IF (C.EQ.0. .AND. NB.EQ.2) NB = 6 -C -C ENTER DATA ON THETA BOUNDARIES -C - GO TO (108,108,110,110,112,112,108,110,112),MBDCND - 108 BM(1) = BM(1)-AM(1) - X = 2.*AM(1) - DO 109 J=1,N - F(1,J) = F(1,J)-X*BDA(J) - 109 CONTINUE - GO TO 112 - 110 BM(1) = BM(1)+AM(1) - X = DTH*AM(1) - DO 111 J=1,N - F(1,J) = F(1,J)+X*BDA(J) - 111 CONTINUE - 112 CONTINUE - GO TO (113,115,115,113,113,115,117,117,117),MBDCND - 113 BM(M) = BM(M)-CM(M) - X = 2.*CM(M) - DO 114 J=1,N - F(M,J) = F(M,J)-X*BDB(J) - 114 CONTINUE - GO TO 117 - 115 BM(M) = BM(M)+CM(M) - X = DTH*CM(M) - DO 116 J=1,N - F(M,J) = F(M,J)-X*BDB(J) - 116 CONTINUE - 117 CONTINUE -C -C ENTER DATA ON R BOUNDARIES -C - GO TO (118,118,120,120,122,122),NB - 118 BN(1) = BN(1)-AN(1) - X = 2.*AN(1) - DO 119 I=1,M - F(I,1) = F(I,1)-X*BDC(I) - 119 CONTINUE - GO TO 122 - 120 BN(1) = BN(1)+AN(1) - X = DR*AN(1) - DO 121 I=1,M - F(I,1) = F(I,1)+X*BDC(I) - 121 CONTINUE - 122 CONTINUE - GO TO (123,125,125,123,123,125),NB - 123 BN(N) = BN(N)-CN(N) - X = 2.*CN(N) - DO 124 I=1,M - F(I,N) = F(I,N)-X*BDD(I) - 124 CONTINUE - GO TO 127 - 125 BN(N) = BN(N)+CN(N) - X = DR*CN(N) - DO 126 I=1,M - F(I,N) = F(I,N)-X*BDD(I) - 126 CONTINUE - 127 CONTINUE -C -C CHECK FOR SINGULAR PROBLEM. IF SINGULAR, PERTURB F. -C - PERTRB = 0. - GO TO (137,137,128,137,137,128,137,128,128),MBDCND - 128 GO TO (137,137,129,137,137,129),NB - 129 IF (ELMBDA) 137,131,130 - 130 IERR1 = 10 - GO TO 137 - 131 CONTINUE - ISW = 2 - DO 133 I=1,M - X = 0. - DO 132 J=1,N - X = X+F(I,J) - 132 CONTINUE - PERTRB = PERTRB+X*SNTH(I) - 133 CONTINUE - X = 0. - DO 134 J=1,N - X = X+RSQ(J) - 134 CONTINUE - PERTRB = 2.*(PERTRB*SIN(DTH/2.))/(X*(COS(A)-COS(B))) - DO 136 J=1,N - X = RSQ(J)*PERTRB - DO 135 I=1,M - F(I,J) = F(I,J)-X - 135 CONTINUE - 136 CONTINUE - 137 CONTINUE - A2 = 0. - DO 138 I=1,M - A2 = A2+F(I,1) - 138 CONTINUE - A2 = A2/RSQ(1) -C -C INITIALIZE BLKTRI -C - IF (INTL .NE. 0) GO TO 139 - CALL BLKTRI (0,1,N,AN,BN,CN,1,M,AM,BM,CM,IDIMF,F,IERR1,WRK) - 139 CONTINUE -C -C CALL BLKTRI TO SOLVE SYSTEM OF EQUATIONS. -C - CALL BLKTRI (1,1,N,AN,BN,CN,1,M,AM,BM,CM,IDIMF,F,IERR1,WRK) - IF (ISW.NE.2 .OR. C.NE.0. .OR. NBDCND.NE.2) GO TO 143 - A1 = 0. - A3 = 0. - DO 140 I=1,M - A1 = A1+SNTH(I)*F(I,1) - A3 = A3+SNTH(I) - 140 CONTINUE - A1 = A1+RSQ(1)*A2/2. - IF (MBDCND .EQ. 3) - 1 A1 = A1+(SIN(B)*BDB(1)-SIN(A)*BDA(1))/(2.*(B-A)) - A1 = A1/A3 - A1 = BDC(1)-A1 - DO 142 I=1,M - DO 141 J=1,N - F(I,J) = F(I,J)+A1 - 141 CONTINUE - 142 CONTINUE - 143 CONTINUE - RETURN - END diff --git a/slatec/hstcsp.f b/slatec/hstcsp.f deleted file mode 100644 index d420dd9..0000000 --- a/slatec/hstcsp.f +++ /dev/null @@ -1,446 +0,0 @@ -*DECK HSTCSP - SUBROUTINE HSTCSP (INTL, A, B, M, MBDCND, BDA, BDB, C, D, N, - + NBDCND, BDC, BDD, ELMBDA, F, IDIMF, PERTRB, IERROR, W) -C***BEGIN PROLOGUE HSTCSP -C***PURPOSE Solve the standard five-point finite difference -C approximation on a staggered grid to the modified Helmholtz -C equation in spherical coordinates assuming axisymmetry -C (no dependence on longitude). -C***LIBRARY SLATEC (FISHPACK) -C***CATEGORY I2B1A1A -C***TYPE SINGLE PRECISION (HSTCSP-S) -C***KEYWORDS ELLIPTIC, FISHPACK, HELMHOLTZ, PDE, SPHERICAL -C***AUTHOR Adams, J., (NCAR) -C Swarztrauber, P. N., (NCAR) -C Sweet, R., (NCAR) -C***DESCRIPTION -C -C HSTCSP solves the standard five-point finite difference -C approximation on a staggered grid to the modified Helmholtz -C equation spherical coordinates assuming axisymmetry (no dependence -C on longitude). -C -C (1/R**2)(d/dR)(R**2(dU/dR)) + -C -C 1/(R**2*SIN(THETA))(d/dTHETA)(SIN(THETA)(dU/dTHETA)) + -C -C (LAMBDA/(R*SIN(THETA))**2)U = F(THETA,R) -C -C where THETA is colatitude and R is the radial coordinate. -C This two-dimensional modified Helmholtz equation results from -C the Fourier transform of the three-dimensional Poisson equation. -C -C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -C -C -C * * * * * * * * Parameter Description * * * * * * * * * * -C -C -C * * * * * * On Input * * * * * * -C -C INTL -C = 0 On initial entry to HSTCSP or if any of the arguments -C C, D, N, or NBDCND are changed from a previous call. -C -C = 1 If C, D, N, and NBDCND are all unchanged from previous -C call to HSTCSP. -C -C NOTE: A call with INTL = 0 takes approximately 1.5 times as much -C time as a call with INTL = 1. Once a call with INTL = 0 -C has been made then subsequent solutions corresponding to -C different F, BDA, BDB, BDC, and BDD can be obtained -C faster with INTL = 1 since initialization is not repeated. -C -C A,B -C The range of THETA (colatitude), i.e. A .LE. THETA .LE. B. A -C must be less than B and A must be non-negative. A and B are in -C radians. A = 0 corresponds to the north pole and B = PI -C corresponds to the south pole. -C -C * * * IMPORTANT * * * -C -C If B is equal to PI, then B must be computed using the statement -C -C B = PIMACH(DUM) -C -C This insures that B in the user's program is equal to PI in this -C program which permits several tests of the input parameters that -C otherwise would not be possible. -C -C * * * * * * * * * * * * -C -C M -C The number of grid points in the interval (A,B). The grid points -C in the THETA-direction are given by THETA(I) = A + (I-0.5)DTHETA -C for I=1,2,...,M where DTHETA =(B-A)/M. M must be greater than 4. -C -C MBDCND -C Indicates the type of boundary conditions at THETA = A and -C THETA = B. -C -C = 1 If the solution is specified at THETA = A and THETA = B. -C (See notes 1, 2 below) -C -C = 2 If the solution is specified at THETA = A and the derivative -C of the solution with respect to THETA is specified at -C THETA = B (See notes 1, 2 below). -C -C = 3 If the derivative of the solution with respect to THETA is -C specified at THETA = A (See notes 1, 2 below) and THETA = B. -C -C = 4 If the derivative of the solution with respect to THETA is -C specified at THETA = A (See notes 1, 2 below) and the -C solution is specified at THETA = B. -C -C = 5 If the solution is unspecified at THETA = A = 0 and the -C solution is specified at THETA = B. (See note 2 below) -C -C = 6 If the solution is unspecified at THETA = A = 0 and the -C derivative of the solution with respect to THETA is -C specified at THETA = B (See note 2 below). -C -C = 7 If the solution is specified at THETA = A and the -C solution is unspecified at THETA = B = PI. -C -C = 8 If the derivative of the solution with respect to -C THETA is specified at THETA = A (See note 1 below) -C and the solution is unspecified at THETA = B = PI. -C -C = 9 If the solution is unspecified at THETA = A = 0 and -C THETA = B = PI. -C -C NOTES: 1. If A = 0, do not use MBDCND = 1,2,3,4,7 or 8, -C but instead use MBDCND = 5, 6, or 9. -C -C 2. if B = PI, do not use MBDCND = 1,2,3,4,5 or 6, -C but instead use MBDCND = 7, 8, or 9. -C -C When A = 0 and/or B = PI the only meaningful boundary -C condition is dU/dTHETA = 0. (See D. Greenspan, 'Numerical -C Analysis of Elliptic Boundary Value Problems,' Harper and -C Row, 1965, Chapter 5.) -C -C BDA -C A one-dimensional array of length N that specifies the boundary -C values (if any) of the solution at THETA = A. When -C MBDCND = 1, 2, or 7, -C -C BDA(J) = U(A,R(J)) , J=1,2,...,N. -C -C When MBDCND = 3, 4, or 8, -C -C BDA(J) = (d/dTHETA)U(A,R(J)) , J=1,2,...,N. -C -C When MBDCND has any other value, BDA is a dummy variable. -C -C BDB -C A one-dimensional array of length N that specifies the boundary -C values of the solution at THETA = B. When MBDCND = 1, 4, or 5, -C -C BDB(J) = U(B,R(J)) , J=1,2,...,N. -C -C When MBDCND = 2,3, or 6, -C -C BDB(J) = (d/dTHETA)U(B,R(J)) , J=1,2,...,N. -C -C When MBDCND has any other value, BDB is a dummy variable. -C -C C,D -C The range of R , i.e. C .LE. R .LE. D. -C C must be less than D. C must be non-negative. -C -C N -C The number of unknowns in the interval (C,D). The unknowns in -C the R-direction are given by R(J) = C + (J-0.5)DR, -C J=1,2,...,N, where DR = (D-C)/N. N must be greater than 4. -C -C NBDCND -C Indicates the type of boundary conditions at R = C -C and R = D. -C -C = 1 If the solution is specified at R = C and R = D. -C -C = 2 If the solution is specified at R = C and the derivative -C of the solution with respect to R is specified at -C R = D. (See note 1 below) -C -C = 3 If the derivative of the solution with respect to R is -C specified at R = C and R = D. -C -C = 4 If the derivative of the solution with respect to R is -C specified at R = C and the solution is specified at -C R = D. -C -C = 5 If the solution is unspecified at R = C = 0 (See note 2 -C below) and the solution is specified at R = D. -C -C = 6 If the solution is unspecified at R = C = 0 (See note 2 -C below) and the derivative of the solution with respect to R -C is specified at R = D. -C -C NOTE 1: If C = 0 and MBDCND = 3,6,8 or 9, the system of equations -C to be solved is singular. The unique solution is -C determined by extrapolation to the specification of -C U(THETA(1),C). But in these cases the right side of the -C system will be perturbed by the constant PERTRB. -C -C NOTE 2: NBDCND = 5 or 6 cannot be used with MBDCND = 1, 2, 4, 5, -C or 7 (the former indicates that the solution is -C unspecified at R = 0; the latter indicates that the -C solution is specified). Use instead NBDCND = 1 or 2. -C -C BDC -C A one dimensional array of length M that specifies the boundary -C values of the solution at R = C. When NBDCND = 1 or 2, -C -C BDC(I) = U(THETA(I),C) , I=1,2,...,M. -C -C When NBDCND = 3 or 4, -C -C BDC(I) = (d/dR)U(THETA(I),C), I=1,2,...,M. -C -C When NBDCND has any other value, BDC is a dummy variable. -C -C BDD -C A one-dimensional array of length M that specifies the boundary -C values of the solution at R = D. When NBDCND = 1 or 4, -C -C BDD(I) = U(THETA(I),D) , I=1,2,...,M. -C -C When NBDCND = 2 or 3, -C -C BDD(I) = (d/dR)U(THETA(I),D) , I=1,2,...,M. -C -C When NBDCND has any other value, BDD is a dummy variable. -C -C ELMBDA -C The constant LAMBDA in the modified Helmholtz equation. If -C LAMBDA is greater than 0, a solution may not exist. However, -C HSTCSP will attempt to find a solution. -C -C F -C A two-dimensional array that specifies the values of the right -C side of the modified Helmholtz equation. For I=1,2,...,M and -C J=1,2,...,N -C -C F(I,J) = F(THETA(I),R(J)) . -C -C F must be dimensioned at least M X N. -C -C IDIMF -C The row (or first) dimension of the array F as it appears in the -C program calling HSTCSP. This parameter is used to specify the -C variable dimension of F. IDIMF must be at least M. -C -C W -C A one-dimensional array that must be provided by the user for -C work space. With K = INT(log2(N))+1 and L = 2**(K+1), W may -C require up to (K-2)*L+K+MAX(2N,6M)+4(N+M)+5 locations. The -C actual number of locations used is computed by HSTCSP and is -C returned in the location W(1). -C -C -C * * * * * * On Output * * * * * * -C -C F -C Contains the solution U(I,J) of the finite difference -C approximation for the grid point (THETA(I),R(J)) for -C I=1,2,...,M, J=1,2,...,N. -C -C PERTRB -C If a combination of periodic, derivative, or unspecified -C boundary conditions is specified for a Poisson equation -C (LAMBDA = 0), a solution may not exist. PERTRB is a con- -C stant, calculated and subtracted from F, which ensures -C that a solution exists. HSTCSP then computes this -C solution, which is a least squares solution to the -C original approximation. This solution plus any constant is also -C a solution; hence, the solution is not unique. The value of -C PERTRB should be small compared to the right side F. -C Otherwise, a solution is obtained to an essentially different -C problem. This comparison should always be made to insure that -C a meaningful solution has been obtained. -C -C IERROR -C An error flag that indicates invalid input parameters. -C Except for numbers 0 and 10, a solution is not attempted. -C -C = 0 No error -C -C = 1 A .LT. 0 or B .GT. PI -C -C = 2 A .GE. B -C -C = 3 MBDCND .LT. 1 or MBDCND .GT. 9 -C -C = 4 C .LT. 0 -C -C = 5 C .GE. D -C -C = 6 NBDCND .LT. 1 or NBDCND .GT. 6 -C -C = 7 N .LT. 5 -C -C = 8 NBDCND = 5 or 6 and MBDCND = 1, 2, 4, 5, or 7 -C -C = 9 C .GT. 0 and NBDCND .GE. 5 -C -C = 10 ELMBDA .GT. 0 -C -C = 11 IDIMF .LT. M -C -C = 12 M .LT. 5 -C -C = 13 A = 0 and MBDCND =1,2,3,4,7 or 8 -C -C = 14 B = PI and MBDCND .LE. 6 -C -C = 15 A .GT. 0 and MBDCND = 5, 6, or 9 -C -C = 16 B .LT. PI and MBDCND .GE. 7 -C -C = 17 LAMBDA .NE. 0 and NBDCND .GE. 5 -C -C Since this is the only means of indicating a possibly -C incorrect call to HSTCSP, the user should test IERROR after -C the call. -C -C W -C W(1) contains the required length of W. Also W contains -C intermediate values that must not be destroyed if HSTCSP -C will be called again with INTL = 1. -C -C *Long Description: -C -C * * * * * * * Program Specifications * * * * * * * * * * * * -C -C Dimension of BDA(N),BDB(N),BDC(M),BDD(M),F(IDIMF,N), -C Arguments W(See argument list) -C -C Latest June 1979 -C Revision -C -C Subprograms HSTCSP,HSTCS1,BLKTRI,BLKTR1,INDXA,INDXB,INDXC, -C Required PROD,PRODP,CPROD,CPRODP,PPADD,PSGF,BSRH,PPSGF, -C PPSPF,COMPB,TEVLS,R1MACH -C -C Special NONE -C Conditions -C -C Common CBLKT -C Blocks -C -C I/O NONE -C -C Precision Single -C -C Specialist Roland Sweet -C -C Language FORTRAN -C -C History Written by Roland Sweet at NCAR in May, 1977 -C -C Algorithm This subroutine defines the finite-difference -C equations, incorporates boundary data, adjusts the -C right side when the system is singular and calls -C BLKTRI which solves the linear system of equations. -C -C Space 5269(decimal) = 12225(octal) locations on the -C Required NCAR Control Data 7600 -C -C Timing and The execution time T on the NCAR Control Data -C Accuracy 7600 for subroutine HSTCSP is roughly proportional -C to M*N*log2(N), but depends on the input parameter -C INTL. Some values are listed in the table below. -C The solution process employed results in a loss -C of no more than FOUR significant digits for N and M -C as large as 64. More detailed information about -C accuracy can be found in the documentation for -C subroutine BLKTRI which is the routine that -C actually solves the finite difference equations. -C -C -C M(=N) INTL MBDCND(=NBDCND) T(MSECS) -C ----- ---- --------------- -------- -C -C 32 0 1-6 132 -C 32 1 1-6 88 -C 64 0 1-6 546 -C 64 1 1-6 380 -C -C Portability American National Standards Institute Fortran. -C The machine accuracy is set using function R1MACH. -C -C Required COS,SIN,ABS,SQRT -C Resident -C Routines -C -C Reference Swarztrauber, P.N., 'A Direct Method For The -C Discrete Solution Of Separable Elliptic Equations,' -C SIAM J. Numer. Anal. 11(1974), pp. 1136-1150. -C -C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -C -C***REFERENCES P. N. Swarztrauber and R. Sweet, Efficient Fortran -C subprograms for the solution of elliptic equations, -C NCAR TN/IA-109, July 1975, 138 pp. -C P. N. Swarztrauber, A direct method for the discrete -C solution of separable elliptic equations, SIAM Journal -C on Numerical Analysis 11, (1974), pp. 1136-1150. -C***ROUTINES CALLED HSTCS1, PIMACH -C***REVISION HISTORY (YYMMDD) -C 801001 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 HSTCSP -C -C - DIMENSION F(IDIMF,*) ,BDA(*) ,BDB(*) ,BDC(*) , - 1 BDD(*) ,W(*) -C***FIRST EXECUTABLE STATEMENT HSTCSP - PI = PIMACH(DUM) -C -C CHECK FOR INVALID INPUT PARAMETERS -C - IERROR = 0 - IF (A.LT.0. .OR. B.GT.PI) IERROR = 1 - IF (A .GE. B) IERROR = 2 - IF (MBDCND.LT.1 .OR. MBDCND.GT.9) IERROR = 3 - IF (C .LT. 0.) IERROR = 4 - IF (C .GE. D) IERROR = 5 - IF (NBDCND.LT.1 .OR. NBDCND.GT.6) IERROR = 6 - IF (N .LT. 5) IERROR = 7 - IF ((NBDCND.EQ.5 .OR. NBDCND.EQ.6) .AND. (MBDCND.EQ.1 .OR. - 1 MBDCND.EQ.2 .OR. MBDCND.EQ.4 .OR. MBDCND.EQ.5 .OR. - 2 MBDCND.EQ.7)) - 3 IERROR = 8 - IF (C.GT.0. .AND. NBDCND.GE.5) IERROR = 9 - IF (IDIMF .LT. M) IERROR = 11 - IF (M .LT. 5) IERROR = 12 - IF (A.EQ.0. .AND. MBDCND.NE.5 .AND. MBDCND.NE.6 .AND. MBDCND.NE.9) - 1 IERROR = 13 - IF (B.EQ.PI .AND. MBDCND.LE.6) IERROR = 14 - IF (A.GT.0. .AND. (MBDCND.EQ.5 .OR. MBDCND.EQ.6 .OR. MBDCND.EQ.9)) - 1 IERROR = 15 - IF (B.LT.PI .AND. MBDCND.GE.7) IERROR = 16 - IF (ELMBDA.NE.0. .AND. NBDCND.GE.5) IERROR = 17 - IF (IERROR .NE. 0) GO TO 101 - IWBM = M+1 - IWCM = IWBM+M - IWAN = IWCM+M - IWBN = IWAN+N - IWCN = IWBN+N - IWSNTH = IWCN+N - IWRSQ = IWSNTH+M - IWWRK = IWRSQ+N - IERR1 = 0 - CALL HSTCS1 (INTL,A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD, - 1 ELMBDA,F,IDIMF,PERTRB,IERR1,W,W(IWBM),W(IWCM), - 2 W(IWAN),W(IWBN),W(IWCN),W(IWSNTH),W(IWRSQ),W(IWWRK)) - W(1) = W(IWWRK)+IWWRK-1 - IERROR = IERR1 - 101 CONTINUE - RETURN - END diff --git a/slatec/hstcyl.f b/slatec/hstcyl.f deleted file mode 100644 index 6198550..0000000 --- a/slatec/hstcyl.f +++ /dev/null @@ -1,461 +0,0 @@ -*DECK HSTCYL - SUBROUTINE HSTCYL (A, B, M, MBDCND, BDA, BDB, C, D, N, NBDCND, - + BDC, BDD, ELMBDA, F, IDIMF, PERTRB, IERROR, W) -C***BEGIN PROLOGUE HSTCYL -C***PURPOSE Solve the standard five-point finite difference -C approximation on a staggered grid to the modified -C Helmholtz equation in cylindrical coordinates. -C***LIBRARY SLATEC (FISHPACK) -C***CATEGORY I2B1A1A -C***TYPE SINGLE PRECISION (HSTCYL-S) -C***KEYWORDS CYLINDRICAL, ELLIPTIC, FISHPACK, HELMHOLTZ, PDE -C***AUTHOR Adams, J., (NCAR) -C Swarztrauber, P. N., (NCAR) -C Sweet, R., (NCAR) -C***DESCRIPTION -C -C HSTCYL solves the standard five-point finite difference -C approximation on a staggered grid to the modified Helmholtz -C equation in cylindrical coordinates -C -C (1/R)(d/dR)(R(dU/dR)) + (d/dZ)(dU/dZ)C -C + LAMBDA*(1/R**2)*U = F(R,Z) -C -C This two-dimensional modified Helmholtz equation results -C from the Fourier transform of a three-dimensional Poisson -C equation. -C -C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -C -C * * * * * * * * Parameter Description * * * * * * * * * * -C -C * * * * * * On Input * * * * * * -C -C A,B -C The range of R, i.e. A .LE. R .LE. B. A must be less than B and -C A must be non-negative. -C -C M -C The number of grid points in the interval (A,B). The grid points -C in the R-direction are given by R(I) = A + (I-0.5)DR for -C I=1,2,...,M where DR =(B-A)/M. M must be greater than 2. -C -C MBDCND -C Indicates the type of boundary conditions at R = A and R = B. -C -C = 1 If the solution is specified at R = A (see note below) and -C R = B. -C -C = 2 If the solution is specified at R = A (see note below) and -C the derivative of the solution with respect to R is -C specified at R = B. -C -C = 3 If the derivative of the solution with respect to R is -C specified at R = A (see note below) and R = B. -C -C = 4 If the derivative of the solution with respect to R is -C specified at R = A (see note below) and the solution is -C specified at R = B. -C -C = 5 If the solution is unspecified at R = A = 0 and the solution -C is specified at R = B. -C -C = 6 If the solution is unspecified at R = A = 0 and the -C derivative of the solution with respect to R is specified at -C R = B. -C -C NOTE: If A = 0, do not use MBDCND = 1,2,3, or 4, but instead -C use MBDCND = 5 or 6. The resulting approximation gives -C the only meaningful boundary condition, i.e. dU/dR = 0. -C (see D. Greenspan, 'Introductory Numerical Analysis Of -C Elliptic Boundary Value Problems,' Harper and Row, 1965, -C Chapter 5.) -C -C BDA -C A one-dimensional array of length N that specifies the boundary -C values (if any) of the solution at R = A. When MBDCND = 1 or 2, -C -C BDA(J) = U(A,Z(J)) , J=1,2,...,N. -C -C When MBDCND = 3 or 4, -C -C BDA(J) = (d/dR)U(A,Z(J)) , J=1,2,...,N. -C -C When MBDCND = 5 or 6, BDA is a dummy variable. -C -C BDB -C A one-dimensional array of length N that specifies the boundary -C values of the solution at R = B. When MBDCND = 1,4, or 5, -C -C BDB(J) = U(B,Z(J)) , J=1,2,...,N. -C -C When MBDCND = 2,3, or 6, -C -C BDB(J) = (d/dR)U(B,Z(J)) , J=1,2,...,N. -C -C C,D -C The range of Z, i.e. C .LE. Z .LE. D. C must be less -C than D. -C -C N -C The number of unknowns in the interval (C,D). The unknowns in -C the Z-direction are given by Z(J) = C + (J-0.5)DZ, -C J=1,2,...,N, where DZ = (D-C)/N. N must be greater than 2. -C -C NBDCND -C Indicates the type of boundary conditions at Z = C -C and Z = D. -C -C = 0 If the solution is periodic in Z, i.e. -C U(I,J) = U(I,N+J). -C -C = 1 If the solution is specified at Z = C and Z = D. -C -C = 2 If the solution is specified at Z = C and the derivative -C of the solution with respect to Z is specified at -C Z = D. -C -C = 3 If the derivative of the solution with respect to Z is -C specified at Z = C and Z = D. -C -C = 4 If the derivative of the solution with respect to Z is -C specified at Z = C and the solution is specified at -C Z = D. -C -C BDC -C A one dimensional array of length M that specifies the boundary -C values of the solution at Z = C. When NBDCND = 1 or 2, -C -C BDC(I) = U(R(I),C) , I=1,2,...,M. -C -C When NBDCND = 3 or 4, -C -C BDC(I) = (d/dZ)U(R(I),C), I=1,2,...,M. -C -C When NBDCND = 0, BDC is a dummy variable. -C -C BDD -C A one-dimensional array of length M that specifies the boundary -C values of the solution at Z = D. when NBDCND = 1 or 4, -C -C BDD(I) = U(R(I),D) , I=1,2,...,M. -C -C When NBDCND = 2 or 3, -C -C BDD(I) = (d/dZ)U(R(I),D) , I=1,2,...,M. -C -C When NBDCND = 0, BDD is a dummy variable. -C -C ELMBDA -C The constant LAMBDA in the modified Helmholtz equation. If -C LAMBDA is greater than 0, a solution may not exist. However, -C HSTCYL will attempt to find a solution. LAMBDA must be zero -C when MBDCND = 5 or 6. -C -C F -C A two-dimensional array that specifies the values of the right -C side of the modified Helmholtz equation. For I=1,2,...,M -C and J=1,2,...,N -C -C F(I,J) = F(R(I),Z(J)) . -C -C F must be dimensioned at least M X N. -C -C IDIMF -C The row (or first) dimension of the array F as it appears in the -C program calling HSTCYL. This parameter is used to specify the -C variable dimension of F. IDIMF must be at least M. -C -C W -C A one-dimensional array that must be provided by the user for -C work space. W may require up to 13M + 4N + M*INT(log2(N)) -C locations. The actual number of locations used is computed by -C HSTCYL and is returned in the location W(1). -C -C -C * * * * * * On Output * * * * * * -C -C F -C Contains the solution U(I,J) of the finite difference -C approximation for the grid point (R(I),Z(J)) for -C I=1,2,...,M, J=1,2,...,N. -C -C PERTRB -C If a combination of periodic, derivative, or unspecified -C boundary conditions is specified for a Poisson equation -C (LAMBDA = 0), a solution may not exist. PERTRB is a con- -C stant, calculated and subtracted from F, which ensures -C that a solution exists. HSTCYL then computes this -C solution, which is a least squares solution to the -C original approximation. This solution plus any constant is also -C a solution; hence, the solution is not unique. The value of -C PERTRB should be small compared to the right side F. -C Otherwise, a solution is obtained to an essentially different -C problem. This comparison should always be made to insure that -C a meaningful solution has been obtained. -C -C IERROR -C An error flag that indicates invalid input parameters. -C Except for numbers 0 and 11, a solution is not attempted. -C -C = 0 No error -C -C = 1 A .LT. 0 -C -C = 2 A .GE. B -C -C = 3 MBDCND .LT. 1 or MBDCND .GT. 6 -C -C = 4 C .GE. D -C -C = 5 N .LE. 2 -C -C = 6 NBDCND .LT. 0 or NBDCND .GT. 4 -C -C = 7 A = 0 and MBDCND = 1,2,3, or 4 -C -C = 8 A .GT. 0 and MBDCND .GE. 5 -C -C = 9 M .LE. 2 -C -C = 10 IDIMF .LT. M -C -C = 11 LAMBDA .GT. 0 -C -C = 12 A=0, MBDCND .GE. 5, ELMBDA .NE. 0 -C -C Since this is the only means of indicating a possibly -C incorrect call to HSTCYL, the user should test IERROR after -C the call. -C -C W -C W(1) contains the required length of W. -C -C *Long Description: -C -C * * * * * * * Program Specifications * * * * * * * * * * * * -C -C Dimension OF BDA(N),BDB(N),BDC(M),BDD(M),F(IDIMF,N), -C Arguments W(see argument list) -C -C Latest June 1, 1977 -C Revision -C -C Subprograms HSTCYL,POISTG,POSTG2,GENBUN,POISD2,POISN2,POISP2, -C Required COSGEN,MERGE,TRIX,TRI3,PIMACH -C -C Special NONE -C Conditions -C -C Common NONE -C Blocks -C -C I/O NONE -C -C Precision Single -C -C Specialist Roland Sweet -C -C Language FORTRAN -C -C History Written by Roland Sweet at NCAR in March, 1977 -C -C Algorithm This subroutine defines the finite-difference -C equations, incorporates boundary data, adjusts the -C right side when the system is singular and calls -C either POISTG or GENBUN which solves the linear -C system of equations. -C -C Space 8228(decimal) = 20044(octal) locations on the -C Required NCAR Control Data 7600 -C -C Timing and The execution time T on the NCAR Control Data -C Accuracy 7600 for subroutine HSTCYL is roughly proportional -C to M*N*log2(N). Some typical values are listed in -C the table below. -C The solution process employed results in a loss -C of no more than four significant digits for N and M -C as large as 64. More detailed information about -C accuracy can be found in the documentation for -C subroutine POISTG which is the routine that -C actually solves the finite difference equations. -C -C -C M(=N) MBDCND NBDCND T(MSECS) -C ----- ------ ------ -------- -C -C 32 1-6 1-4 56 -C 64 1-6 1-4 230 -C -C Portability American National Standards Institute Fortran. -C The machine dependent constant PI is defined in -C function PIMACH. -C -C Required COS -C Resident -C Routines -C -C Reference Schumann, U. and R. Sweet,'A Direct Method For -C The Solution of Poisson's Equation With Neumann -C Boundary Conditions On A Staggered Grid Of -C Arbitrary Size,' J. Comp. Phys. 20(1976), -C pp. 171-182. -C -C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -C -C***REFERENCES U. Schumann and R. Sweet, A direct method for the -C solution of Poisson's equation with Neumann boundary -C conditions on a staggered grid of arbitrary size, -C Journal of Computational Physics 20, (1976), -C pp. 171-182. -C***ROUTINES CALLED GENBUN, POISTG -C***REVISION HISTORY (YYMMDD) -C 801001 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 HSTCYL -C -C - DIMENSION F(IDIMF,*) ,BDA(*) ,BDB(*) ,BDC(*) , - 1 BDD(*) ,W(*) -C***FIRST EXECUTABLE STATEMENT HSTCYL - IERROR = 0 - IF (A .LT. 0.) IERROR = 1 - IF (A .GE. B) IERROR = 2 - IF (MBDCND.LE.0 .OR. MBDCND.GE.7) IERROR = 3 - IF (C .GE. D) IERROR = 4 - IF (N .LE. 2) IERROR = 5 - IF (NBDCND.LT.0 .OR. NBDCND.GE.5) IERROR = 6 - IF (A.EQ.0. .AND. MBDCND.NE.5 .AND. MBDCND.NE.6) IERROR = 7 - IF (A.GT.0. .AND. MBDCND.GE.5) IERROR = 8 - IF (IDIMF .LT. M) IERROR = 10 - IF (M .LE. 2) IERROR = 9 - IF (A.EQ.0. .AND. MBDCND.GE.5 .AND. ELMBDA.NE.0.) IERROR = 12 - IF (IERROR .NE. 0) RETURN - DELTAR = (B-A)/M - DLRSQ = DELTAR**2 - DELTHT = (D-C)/N - DLTHSQ = DELTHT**2 - NP = NBDCND+1 -C -C DEFINE A,B,C COEFFICIENTS IN W-ARRAY. -C - IWB = M - IWC = IWB+M - IWR = IWC+M - DO 101 I=1,M - J = IWR+I - W(J) = A+(I-0.5)*DELTAR - W(I) = (A+(I-1)*DELTAR)/(DLRSQ*W(J)) - K = IWC+I - W(K) = (A+I*DELTAR)/(DLRSQ*W(J)) - K = IWB+I - W(K) = ELMBDA/W(J)**2-2./DLRSQ - 101 CONTINUE -C -C ENTER BOUNDARY DATA FOR R-BOUNDARIES. -C - GO TO (102,102,104,104,106,106),MBDCND - 102 A1 = 2.*W(1) - W(IWB+1) = W(IWB+1)-W(1) - DO 103 J=1,N - F(1,J) = F(1,J)-A1*BDA(J) - 103 CONTINUE - GO TO 106 - 104 A1 = DELTAR*W(1) - W(IWB+1) = W(IWB+1)+W(1) - DO 105 J=1,N - F(1,J) = F(1,J)+A1*BDA(J) - 105 CONTINUE - 106 CONTINUE - GO TO (107,109,109,107,107,109),MBDCND - 107 W(IWC) = W(IWC)-W(IWR) - A1 = 2.*W(IWR) - DO 108 J=1,N - F(M,J) = F(M,J)-A1*BDB(J) - 108 CONTINUE - GO TO 111 - 109 W(IWC) = W(IWC)+W(IWR) - A1 = DELTAR*W(IWR) - DO 110 J=1,N - F(M,J) = F(M,J)-A1*BDB(J) - 110 CONTINUE -C -C ENTER BOUNDARY DATA FOR THETA-BOUNDARIES. -C - 111 A1 = 2./DLTHSQ - GO TO (121,112,112,114,114),NP - 112 DO 113 I=1,M - F(I,1) = F(I,1)-A1*BDC(I) - 113 CONTINUE - GO TO 116 - 114 A1 = 1./DELTHT - DO 115 I=1,M - F(I,1) = F(I,1)+A1*BDC(I) - 115 CONTINUE - 116 A1 = 2./DLTHSQ - GO TO (121,117,119,119,117),NP - 117 DO 118 I=1,M - F(I,N) = F(I,N)-A1*BDD(I) - 118 CONTINUE - GO TO 121 - 119 A1 = 1./DELTHT - DO 120 I=1,M - F(I,N) = F(I,N)-A1*BDD(I) - 120 CONTINUE - 121 CONTINUE -C -C ADJUST RIGHT SIDE OF SINGULAR PROBLEMS TO INSURE EXISTENCE OF A -C SOLUTION. -C - PERTRB = 0. - IF (ELMBDA) 130,123,122 - 122 IERROR = 11 - GO TO 130 - 123 GO TO (130,130,124,130,130,124),MBDCND - 124 GO TO (125,130,130,125,130),NP - 125 CONTINUE - DO 127 I=1,M - A1 = 0. - DO 126 J=1,N - A1 = A1+F(I,J) - 126 CONTINUE - J = IWR+I - PERTRB = PERTRB+A1*W(J) - 127 CONTINUE - PERTRB = PERTRB/(M*N*0.5*(A+B)) - DO 129 I=1,M - DO 128 J=1,N - F(I,J) = F(I,J)-PERTRB - 128 CONTINUE - 129 CONTINUE - 130 CONTINUE -C -C MULTIPLY I-TH EQUATION THROUGH BY DELTHT**2 -C - DO 132 I=1,M - W(I) = W(I)*DLTHSQ - J = IWC+I - W(J) = W(J)*DLTHSQ - J = IWB+I - W(J) = W(J)*DLTHSQ - DO 131 J=1,N - F(I,J) = F(I,J)*DLTHSQ - 131 CONTINUE - 132 CONTINUE - LP = NBDCND - W(1) = 0. - W(IWR) = 0. -C -C CALL GENBUN TO SOLVE THE SYSTEM OF EQUATIONS. -C - IF (NBDCND .EQ. 0) GO TO 133 - CALL POISTG (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1)) - GO TO 134 - 133 CALL GENBUN (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1)) - 134 CONTINUE - W(1) = W(IWR+1)+3*M - RETURN - END diff --git a/slatec/hstplr.f b/slatec/hstplr.f deleted file mode 100644 index a34fa70..0000000 --- a/slatec/hstplr.f +++ /dev/null @@ -1,498 +0,0 @@ -*DECK HSTPLR - SUBROUTINE HSTPLR (A, B, M, MBDCND, BDA, BDB, C, D, N, NBDCND, - + BDC, BDD, ELMBDA, F, IDIMF, PERTRB, IERROR, W) -C***BEGIN PROLOGUE HSTPLR -C***PURPOSE Solve the standard five-point finite difference -C approximation on a staggered grid to the Helmholtz equation -C in polar coordinates. -C***LIBRARY SLATEC (FISHPACK) -C***CATEGORY I2B1A1A -C***TYPE SINGLE PRECISION (HSTPLR-S) -C***KEYWORDS ELLIPTIC, FISHPACK, HELMHOLTZ, PDE, POLAR -C***AUTHOR Adams, J., (NCAR) -C Swarztrauber, P. N., (NCAR) -C Sweet, R., (NCAR) -C***DESCRIPTION -C -C HSTPLR solves the standard five-point finite difference -C approximation on a staggered grid to the Helmholtz equation in -C polar coordinates -C -C (1/R)(d/DR)(R(dU/DR)) + (1/R**2)(d/dTHETA)(dU/dTHETA) -C -C + LAMBDA*U = F(R,THETA) -C -C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -C -C * * * * * * * * Parameter Description * * * * * * * * * * -C -C * * * * * * On Input * * * * * * -C -C A,B -C The range of R, i.e. A .LE. R .LE. B. A must be less than B and -C A must be non-negative. -C -C M -C The number of grid points in the interval (A,B). The grid points -C in the R-direction are given by R(I) = A + (I-0.5)DR for -C I=1,2,...,M where DR =(B-A)/M. M must be greater than 2. -C -C MBDCND -C Indicates the type of boundary conditions at R = A and R = B. -C -C = 1 If the solution is specified at R = A and R = B. -C -C = 2 If the solution is specified at R = A and the derivative -C of the solution with respect to R is specified at R = B. -C (see note 1 below) -C -C = 3 If the derivative of the solution with respect to R is -C specified at R = A (see note 2 below) and R = B. -C -C = 4 If the derivative of the solution with respect to R is -C specified at R = A (see note 2 below) and the solution is -C specified at R = B. -C -C = 5 If the solution is unspecified at R = A = 0 and the solution -C is specified at R = B. -C -C = 6 If the solution is unspecified at R = A = 0 and the -C derivative of the solution with respect to R is specified at -C R = B. -C -C NOTE 1: If A = 0, MBDCND = 2, and NBDCND = 0 or 3, the system of -C equations to be solved is singular. The unique solution -C is determined by extrapolation to the specification of -C U(0,THETA(1)). But in this case the right side of the -C system will be perturbed by the constant PERTRB. -C -C NOTE 2: If A = 0, do not use MBDCND = 3 or 4, but instead use -C MBDCND = 1,2,5, or 6. -C -C BDA -C A one-dimensional array of length N that specifies the boundary -C values (if any) of the solution at R = A. When MBDCND = 1 or 2, -C -C BDA(J) = U(A,THETA(J)) , J=1,2,...,N. -C -C When MBDCND = 3 or 4, -C -C BDA(J) = (d/dR)U(A,THETA(J)) , J=1,2,...,N. -C -C When MBDCND = 5 or 6, BDA is a dummy variable. -C -C BDB -C A one-dimensional array of length N that specifies the boundary -C values of the solution at R = B. When MBDCND = 1,4, or 5, -C -C BDB(J) = U(B,THETA(J)) , J=1,2,...,N. -C -C When MBDCND = 2,3, or 6, -C -C BDB(J) = (d/dR)U(B,THETA(J)) , J=1,2,...,N. -C -C C,D -C The range of THETA, i.e. C .LE. THETA .LE. D. C must be less -C than D. -C -C N -C The number of unknowns in the interval (C,D). The unknowns in -C the THETA-direction are given by THETA(J) = C + (J-0.5)DT, -C J=1,2,...,N, where DT = (D-C)/N. N must be greater than 2. -C -C NBDCND -C Indicates the type of boundary conditions at THETA = C -C and THETA = D. -C -C = 0 If the solution is periodic in THETA, i.e. -C U(I,J) = U(I,N+J). -C -C = 1 If the solution is specified at THETA = C and THETA = D -C (see note below). -C -C = 2 If the solution is specified at THETA = C and the derivative -C of the solution with respect to THETA is specified at -C THETA = D (see note below). -C -C = 3 If the derivative of the solution with respect to THETA is -C specified at THETA = C and THETA = D. -C -C = 4 If the derivative of the solution with respect to THETA is -C specified at THETA = C and the solution is specified at -C THETA = d (see note below). -C -C NOTE: When NBDCND = 1, 2, or 4, do not use MBDCND = 5 or 6 (the -C former indicates that the solution is specified at R = 0; the -C latter indicates the solution is unspecified at R = 0). Use -C instead MBDCND = 1 or 2. -C -C BDC -C A one dimensional array of length M that specifies the boundary -C values of the solution at THETA = C. When NBDCND = 1 or 2, -C -C BDC(I) = U(R(I),C) , I=1,2,...,M. -C -C When NBDCND = 3 or 4, -C -C BDC(I) = (d/dTHETA)U(R(I),C), I=1,2,...,M. -C -C When NBDCND = 0, BDC is a dummy variable. -C -C BDD -C A one-dimensional array of length M that specifies the boundary -C values of the solution at THETA = D. When NBDCND = 1 or 4, -C -C BDD(I) = U(R(I),D) , I=1,2,...,M. -C -C When NBDCND = 2 or 3, -C -C BDD(I) = (d/dTHETA)U(R(I),D) , I=1,2,...,M. -C -C When NBDCND = 0, BDD is a dummy variable. -C -C ELMBDA -C The constant LAMBDA in the Helmholtz equation. If LAMBDA is -C greater than 0, a solution may not exist. However, HSTPLR will -C attempt to find a solution. -C -C F -C A two-dimensional array that specifies the values of the right -C side of the Helmholtz equation. For I=1,2,...,M and J=1,2,...,N -C -C F(I,J) = F(R(I),THETA(J)) . -C -C F must be dimensioned at least M X N. -C -C IDIMF -C The row (or first) dimension of the array F as it appears in the -C program calling HSTPLR. This parameter is used to specify the -C variable dimension of F. IDIMF must be at least M. -C -C W -C A one-dimensional array that must be provided by the user for -C work space. W may require up to 13M + 4N + M*INT(log2(N)) -C locations. The actual number of locations used is computed by -C HSTPLR and is returned in the location W(1). -C -C -C * * * * * * On Output * * * * * * -C -C F -C Contains the solution U(I,J) of the finite difference -C approximation for the grid point (R(I),THETA(J)) for -C I=1,2,...,M, J=1,2,...,N. -C -C PERTRB -C If a combination of periodic, derivative, or unspecified -C boundary conditions is specified for a Poisson equation -C (LAMBDA = 0), a solution may not exist. PERTRB is a con- -C stant, calculated and subtracted from F, which ensures -C that a solution exists. HSTPLR then computes this -C solution, which is a least squares solution to the -C original approximation. This solution plus any constant is also -C a solution; hence, the solution is not unique. The value of -C PERTRB should be small compared to the right side F. -C Otherwise, a solution is obtained to an essentially different -C problem. This comparison should always be made to insure that -C a meaningful solution has been obtained. -C -C IERROR -C An error flag that indicates invalid input parameters. -C Except for numbers 0 and 11, a solution is not attempted. -C -C = 0 No error -C -C = 1 A .LT. 0 -C -C = 2 A .GE. B -C -C = 3 MBDCND .LT. 1 or MBDCND .GT. 6 -C -C = 4 C .GE. D -C -C = 5 N .LE. 2 -C -C = 6 NBDCND .LT. 0 or NBDCND .GT. 4 -C -C = 7 A = 0 and MBDCND = 3 or 4 -C -C = 8 A .GT. 0 and MBDCND .GE. 5 -C -C = 9 MBDCND .GE. 5 and NBDCND .NE. 0 or 3 -C -C = 10 IDIMF .LT. M -C -C = 11 LAMBDA .GT. 0 -C -C = 12 M .LE. 2 -C -C Since this is the only means of indicating a possibly -C incorrect call to HSTPLR, the user should test IERROR after -C the call. -C -C W -C W(1) contains the required length of W. -C -C *Long Description: -C -C * * * * * * * Program Specifications * * * * * * * * * * * * -C -C Dimension of BDA(N),BDB(N),BDC(M),BDD(M),F(IDIMF,N), -C Arguments W(see ARGUMENT LIST) -C -C Latest June 1, 1977 -C Revision -C -C Subprograms HSTPLR,POISTG,POSTG2,GENBUN,POISD2,POISN2,POISP2, -C Required COSGEN,MERGE,TRIX,TRI3,PIMACH -C -C Special NONE -C Conditions -C -C Common NONE -C Blocks -C -C I/O NONE -C -C Precision Single -C -C Specialist Roland Sweet -C -C Language FORTRAN -C -C History Written by Roland Sweet at NCAR in February, 1977 -C -C Algorithm This subroutine defines the finite-difference -C equations, incorporates boundary data, adjusts the -C right side when the system is singular and calls -C either POISTG or GENBUN which solves the linear -C system of equations. -C -C Space 8265(decimal) = 20111(octal) LOCATIONS ON THE -C Required NCAR Control Data 7600 -C -C Timing and The execution time T on the NCAR Control Data -C Accuracy 7600 for subroutine HSTPLR is roughly proportional -C to M*N*log2(N). Some typical values are listed in -C the table below. -C The solution process employed results in a loss -C of no more than four significant digits for N and M -C as large as 64. More detailed information about -C accuracy can be found in the documentation for -C subroutine POISTG which is the routine that -C actually solves the finite difference equations. -C -C -C M(=N) MBDCND NBDCND T(MSECS) -C ----- ------ ------ -------- -C -C 32 1-6 1-4 56 -C 64 1-6 1-4 230 -C -C Portability American National Standards Institute Fortran. -C The machine dependent constant PI is defined in -C function PIMACH. -C -C Required COS -C Resident -C Routines -C -C Reference Schumann, U. and R. Sweet,'A Direct Method For -C The Solution Of Poisson's Equation With Neumann -C Boundary Conditions On A Staggered Grid of -C Arbitrary Size,' J. Comp. Phys. 20(1976), -C pp. 171-182. -C -C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -C -C***REFERENCES U. Schumann and R. Sweet, A direct method for the -C solution of Poisson's equation with Neumann boundary -C conditions on a staggered grid of arbitrary size, -C Journal of Computational Physics 20, (1976), -C pp. 171-182. -C***ROUTINES CALLED GENBUN, POISTG -C***REVISION HISTORY (YYMMDD) -C 801001 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 HSTPLR -C -C - DIMENSION F(IDIMF,*) - DIMENSION BDA(*) ,BDB(*) ,BDC(*) ,BDD(*) , - 1 W(*) -C***FIRST EXECUTABLE STATEMENT HSTPLR - IERROR = 0 - IF (A .LT. 0.) IERROR = 1 - IF (A .GE. B) IERROR = 2 - IF (MBDCND.LE.0 .OR. MBDCND.GE.7) IERROR = 3 - IF (C .GE. D) IERROR = 4 - IF (N .LE. 2) IERROR = 5 - IF (NBDCND.LT.0 .OR. NBDCND.GE.5) IERROR = 6 - IF (A.EQ.0. .AND. (MBDCND.EQ.3 .OR. MBDCND.EQ.4)) IERROR = 7 - IF (A.GT.0. .AND. MBDCND.GE.5) IERROR = 8 - IF (MBDCND.GE.5 .AND. NBDCND.NE.0 .AND. NBDCND.NE.3) IERROR = 9 - IF (IDIMF .LT. M) IERROR = 10 - IF (M .LE. 2) IERROR = 12 - IF (IERROR .NE. 0) RETURN - DELTAR = (B-A)/M - DLRSQ = DELTAR**2 - DELTHT = (D-C)/N - DLTHSQ = DELTHT**2 - NP = NBDCND+1 - ISW = 1 - MB = MBDCND - IF (A.EQ.0. .AND. MBDCND.EQ.2) MB = 6 -C -C DEFINE A,B,C COEFFICIENTS IN W-ARRAY. -C - IWB = M - IWC = IWB+M - IWR = IWC+M - DO 101 I=1,M - J = IWR+I - W(J) = A+(I-0.5)*DELTAR - W(I) = (A+(I-1)*DELTAR)/DLRSQ - K = IWC+I - W(K) = (A+I*DELTAR)/DLRSQ - K = IWB+I - W(K) = (ELMBDA-2./DLRSQ)*W(J) - 101 CONTINUE - DO 103 I=1,M - J = IWR+I - A1 = W(J) - DO 102 J=1,N - F(I,J) = A1*F(I,J) - 102 CONTINUE - 103 CONTINUE -C -C ENTER BOUNDARY DATA FOR R-BOUNDARIES. -C - GO TO (104,104,106,106,108,108),MB - 104 A1 = 2.*W(1) - W(IWB+1) = W(IWB+1)-W(1) - DO 105 J=1,N - F(1,J) = F(1,J)-A1*BDA(J) - 105 CONTINUE - GO TO 108 - 106 A1 = DELTAR*W(1) - W(IWB+1) = W(IWB+1)+W(1) - DO 107 J=1,N - F(1,J) = F(1,J)+A1*BDA(J) - 107 CONTINUE - 108 GO TO (109,111,111,109,109,111),MB - 109 A1 = 2.*W(IWR) - W(IWC) = W(IWC)-W(IWR) - DO 110 J=1,N - F(M,J) = F(M,J)-A1*BDB(J) - 110 CONTINUE - GO TO 113 - 111 A1 = DELTAR*W(IWR) - W(IWC) = W(IWC)+W(IWR) - DO 112 J=1,N - F(M,J) = F(M,J)-A1*BDB(J) - 112 CONTINUE -C -C ENTER BOUNDARY DATA FOR THETA-BOUNDARIES. -C - 113 A1 = 2./DLTHSQ - GO TO (123,114,114,116,116),NP - 114 DO 115 I=1,M - J = IWR+I - F(I,1) = F(I,1)-A1*BDC(I)/W(J) - 115 CONTINUE - GO TO 118 - 116 A1 = 1./DELTHT - DO 117 I=1,M - J = IWR+I - F(I,1) = F(I,1)+A1*BDC(I)/W(J) - 117 CONTINUE - 118 A1 = 2./DLTHSQ - GO TO (123,119,121,121,119),NP - 119 DO 120 I=1,M - J = IWR+I - F(I,N) = F(I,N)-A1*BDD(I)/W(J) - 120 CONTINUE - GO TO 123 - 121 A1 = 1./DELTHT - DO 122 I=1,M - J = IWR+I - F(I,N) = F(I,N)-A1*BDD(I)/W(J) - 122 CONTINUE - 123 CONTINUE -C -C ADJUST RIGHT SIDE OF SINGULAR PROBLEMS TO INSURE EXISTENCE OF A -C SOLUTION. -C - PERTRB = 0. - IF (ELMBDA) 133,125,124 - 124 IERROR = 11 - GO TO 133 - 125 GO TO (133,133,126,133,133,126),MB - 126 GO TO (127,133,133,127,133),NP - 127 CONTINUE - ISW = 2 - DO 129 J=1,N - DO 128 I=1,M - PERTRB = PERTRB+F(I,J) - 128 CONTINUE - 129 CONTINUE - PERTRB = PERTRB/(M*N*0.5*(A+B)) - DO 131 I=1,M - J = IWR+I - A1 = PERTRB*W(J) - DO 130 J=1,N - F(I,J) = F(I,J)-A1 - 130 CONTINUE - 131 CONTINUE - A2 = 0. - DO 132 J=1,N - A2 = A2+F(1,J) - 132 CONTINUE - A2 = A2/W(IWR+1) - 133 CONTINUE -C -C MULTIPLY I-TH EQUATION THROUGH BY R(I)*DELTHT**2 -C - DO 135 I=1,M - J = IWR+I - A1 = DLTHSQ*W(J) - W(I) = A1*W(I) - J = IWC+I - W(J) = A1*W(J) - J = IWB+I - W(J) = A1*W(J) - DO 134 J=1,N - F(I,J) = A1*F(I,J) - 134 CONTINUE - 135 CONTINUE - LP = NBDCND - W(1) = 0. - W(IWR) = 0. -C -C CALL POISTG OR GENBUN TO SOLVE THE SYSTEM OF EQUATIONS. -C - IF (LP .EQ. 0) GO TO 136 - CALL POISTG (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1)) - GO TO 137 - 136 CALL GENBUN (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1)) - 137 CONTINUE - W(1) = W(IWR+1)+3*M - IF (A.NE.0. .OR. MBDCND.NE.2 .OR. ISW.NE.2) GO TO 141 - A1 = 0. - DO 138 J=1,N - A1 = A1+F(1,J) - 138 CONTINUE - A1 = (A1-DLRSQ*A2/16.)/N - IF (NBDCND .EQ. 3) A1 = A1+(BDD(1)-BDC(1))/(D-C) - A1 = BDA(1)-A1 - DO 140 I=1,M - DO 139 J=1,N - F(I,J) = F(I,J)+A1 - 139 CONTINUE - 140 CONTINUE - 141 CONTINUE - RETURN - END diff --git a/slatec/hstssp.f b/slatec/hstssp.f deleted file mode 100644 index 1f9d6ef..0000000 --- a/slatec/hstssp.f +++ /dev/null @@ -1,583 +0,0 @@ -*DECK HSTSSP - SUBROUTINE HSTSSP (A, B, M, MBDCND, BDA, BDB, C, D, N, NBDCND, - + BDC, BDD, ELMBDA, F, IDIMF, PERTRB, IERROR, W) -C***BEGIN PROLOGUE HSTSSP -C***PURPOSE Solve the standard five-point finite difference -C approximation on a staggered grid to the Helmholtz -C equation in spherical coordinates and on the surface of -C the unit sphere (radius of 1). -C***LIBRARY SLATEC (FISHPACK) -C***CATEGORY I2B1A1A -C***TYPE SINGLE PRECISION (HSTSSP-S) -C***KEYWORDS ELLIPTIC, FISHPACK, HELMHOLTZ, PDE, SPHERICAL -C***AUTHOR Adams, J., (NCAR) -C Swarztrauber, P. N., (NCAR) -C Sweet, R., (NCAR) -C***DESCRIPTION -C -C HSTSSP solves the standard five-point finite difference -C approximation on a staggered grid to the Helmholtz equation in -C spherical coordinates and on the surface of the unit sphere -C (radius of 1) -C -C (1/SIN(THETA))(d/dTHETA)(SIN(THETA)(dU/dTHETA)) + -C -C (1/SIN(THETA)**2)(d/dPHI)(dU/dPHI) + LAMBDA*U = F(THETA,PHI) -C -C where THETA is colatitude and PHI is longitude. -C -C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -C -C * * * * * * * * Parameter Description * * * * * * * * * * -C -C * * * * * * On Input * * * * * * -C -C A,B -C The range of THETA (colatitude), i.e. A .LE. THETA .LE. B. A -C must be less than B and A must be non-negative. A and B are in -C radians. A = 0 corresponds to the north pole and B = PI -C corresponds to the south pole. -C -C -C * * * IMPORTANT * * * -C -C If B is equal to PI, then B must be computed using the statement -C -C B = PIMACH(DUM) -C -C This insures that B in the user's program is equal to PI in this -C program which permits several tests of the input parameters that -C otherwise would not be possible. -C -C * * * * * * * * * * * * -C -C -C -C M -C The number of grid points in the interval (A,B). The grid points -C in the THETA-direction are given by THETA(I) = A + (I-0.5)DTHETA -C for I=1,2,...,M where DTHETA =(B-A)/M. M must be greater than 2. -C -C MBDCND -C Indicates the type of boundary conditions at THETA = A and -C THETA = B. -C -C = 1 If the solution is specified at THETA = A and THETA = B. -C (see note 3 below) -C -C = 2 If the solution is specified at THETA = A and the derivative -C of the solution with respect to THETA is specified at -C THETA = B (see notes 2 and 3 below). -C -C = 3 If the derivative of the solution with respect to THETA is -C specified at THETA = A (see notes 1, 2 below) and THETA = B. -C -C = 4 If the derivative of the solution with respect to THETA is -C specified at THETA = A (see notes 1 and 2 below) and the -C solution is specified at THETA = B. -C -C = 5 If the solution is unspecified at THETA = A = 0 and the -C solution is specified at THETA = B. (see note 3 below) -C -C = 6 If the solution is unspecified at THETA = A = 0 and the -C derivative of the solution with respect to THETA is -C specified at THETA = B (see note 2 below). -C -C = 7 If the solution is specified at THETA = A and the -C solution is unspecified at THETA = B = PI. (see note 3 below) -C -C = 8 If the derivative of the solution with respect to -C THETA is specified at THETA = A (see note 1 below) -C and the solution is unspecified at THETA = B = PI. -C -C = 9 If the solution is unspecified at THETA = A = 0 and -C THETA = B = PI. -C -C NOTES: 1. If A = 0, do not use MBDCND = 3, 4, or 8, -C but instead use MBDCND = 5, 6, or 9. -C -C 2. If B = PI, do not use MBDCND = 2, 3, or 6, -C but instead use MBDCND = 7, 8, or 9. -C -C 3. When the solution is specified at THETA = 0 and/or -C THETA = PI and the other boundary conditions are -C combinations of unspecified, normal derivative, or -C periodicity a singular system results. The unique -C solution is determined by extrapolation to the -C specification of the solution at either THETA = 0 or -C THETA = PI. But in these cases the right side of the -C system will be perturbed by the constant PERTRB. -C -C BDA -C A one-dimensional array of length N that specifies the boundary -C values (if any) of the solution at THETA = A. When -C MBDCND = 1, 2, or 7, -C -C BDA(J) = U(A,PHI(J)) , J=1,2,...,N. -C -C When MBDCND = 3, 4, or 8, -C -C BDA(J) = (d/dTHETA)U(A,PHI(J)) , J=1,2,...,N. -C -C When MBDCND has any other value, BDA is a dummy variable. -C -C BDB -C A one-dimensional array of length N that specifies the boundary -C values of the solution at THETA = B. When MBDCND = 1,4, or 5, -C -C BDB(J) = U(B,PHI(J)) , J=1,2,...,N. -C -C When MBDCND = 2,3, or 6, -C -C BDB(J) = (d/dTHETA)U(B,PHI(J)) , J=1,2,...,N. -C -C When MBDCND has any other value, BDB is a dummy variable. -C -C C,D -C The range of PHI (longitude), i.e. C .LE. PHI .LE. D. -C C must be less than D. If D-C = 2*PI, periodic boundary -C conditions are usually prescribed. -C -C N -C The number of unknowns in the interval (C,D). The unknowns in -C the PHI-direction are given by PHI(J) = C + (J-0.5)DPHI, -C J=1,2,...,N, where DPHI = (D-C)/N. N must be greater than 2. -C -C NBDCND -C Indicates the type of boundary conditions at PHI = C -C and PHI = D. -C -C = 0 If the solution is periodic in PHI, i.e. -C U(I,J) = U(I,N+J). -C -C = 1 If the solution is specified at PHI = C and PHI = D -C (see note below). -C -C = 2 If the solution is specified at PHI = C and the derivative -C of the solution with respect to PHI is specified at -C PHI = D (see note below). -C -C = 3 If the derivative of the solution with respect to PHI is -C specified at PHI = C and PHI = D. -C -C = 4 If the derivative of the solution with respect to PHI is -C specified at PHI = C and the solution is specified at -C PHI = D (see note below). -C -C NOTE: When NBDCND = 1, 2, or 4, do not use MBDCND = 5, 6, 7, 8, -C or 9 (the former indicates that the solution is specified at -C a pole; the latter indicates the solution is unspecified). Use -C instead MBDCND = 1 or 2. -C -C BDC -C A one dimensional array of length M that specifies the boundary -C values of the solution at PHI = C. When NBDCND = 1 or 2, -C -C BDC(I) = U(THETA(I),C) , I=1,2,...,M. -C -C When NBDCND = 3 or 4, -C -C BDC(I) = (d/dPHI)U(THETA(I),C), I=1,2,...,M. -C -C When NBDCND = 0, BDC is a dummy variable. -C -C BDD -C A one-dimensional array of length M that specifies the boundary -C values of the solution at PHI = D. When NBDCND = 1 or 4, -C -C BDD(I) = U(THETA(I),D) , I=1,2,...,M. -C -C When NBDCND = 2 or 3, -C -C BDD(I) = (d/dPHI)U(THETA(I),D) , I=1,2,...,M. -C -C When NBDCND = 0, BDD is a dummy variable. -C -C ELMBDA -C The constant LAMBDA in the Helmholtz equation. If LAMBDA is -C greater than 0, a solution may not exist. However, HSTSSP will -C attempt to find a solution. -C -C F -C A two-dimensional array that specifies the values of the right -C side of the Helmholtz equation. For I=1,2,...,M and J=1,2,...,N -C -C F(I,J) = F(THETA(I),PHI(J)) . -C -C F must be dimensioned at least M X N. -C -C IDIMF -C The row (or first) dimension of the array F as it appears in the -C program calling HSTSSP. This parameter is used to specify the -C variable dimension of F. IDIMF must be at least M. -C -C W -C A one-dimensional array that must be provided by the user for -C work space. W may require up to 13M + 4N + M*INT(log2(N)) -C locations. The actual number of locations used is computed by -C HSTSSP and is returned in the location W(1). -C -C -C * * * * * * On Output * * * * * * -C -C F -C Contains the solution U(I,J) of the finite difference -C approximation for the grid point (THETA(I),PHI(J)) for -C I=1,2,...,M, J=1,2,...,N. -C -C PERTRB -C If a combination of periodic, derivative, or unspecified -C boundary conditions is specified for a Poisson equation -C (LAMBDA = 0), a solution may not exist. PERTRB is a con- -C stant, calculated and subtracted from F, which ensures -C that a solution exists. HSTSSP then computes this -C solution, which is a least squares solution to the -C original approximation. This solution plus any constant is also -C a solution; hence, the solution is not unique. The value of -C PERTRB should be small compared to the right side F. -C Otherwise, a solution is obtained to an essentially different -C problem. This comparison should always be made to insure that -C a meaningful solution has been obtained. -C -C IERROR -C An error flag that indicates invalid input parameters. -C Except for numbers 0 and 14, a solution is not attempted. -C -C = 0 No error -C -C = 1 A .LT. 0 or B .GT. PI -C -C = 2 A .GE. B -C -C = 3 MBDCND .LT. 1 or MBDCND .GT. 9 -C -C = 4 C .GE. D -C -C = 5 N .LE. 2 -C -C = 6 NBDCND .LT. 0 or NBDCND .GT. 4 -C -C = 7 A .GT. 0 and MBDCND = 5, 6, or 9 -C -C = 8 A = 0 and MBDCND = 3, 4, or 8 -C -C = 9 B .LT. PI and MBDCND .GE. 7 -C -C = 10 B = PI and MBDCND = 2,3, or 6 -C -C = 11 MBDCND .GE. 5 and NDBCND = 1, 2, or 4 -C -C = 12 IDIMF .LT. M -C -C = 13 M .LE. 2 -C -C = 14 LAMBDA .GT. 0 -C -C Since this is the only means of indicating a possibly -C incorrect call to HSTSSP, the user should test IERROR after -C the call. -C -C W -C W(1) contains the required length of W. -C -C *Long Description: -C -C * * * * * * * Program Specifications * * * * * * * * * * * * -C -C Dimension of BDA(N),BDB(N),BDC(M),BDD(M),F(IDIMF,N), -C Arguments W(see argument list) -C -C Latest June 1, 1977 -C Revision -C -C Subprograms HSTSSP,POISTG,POSTG2,GENBUN,POISD2,POISN2,POISP2, -C Required COSGEN,MERGE,TRIX,TRI3,PIMACH -C -C Special NONE -C Conditions -C -C Common NONE -C Blocks -C -C I/O NONE -C -C Precision Single -C -C Specialist Roland Sweet -C -C Language FORTRAN -C -C History Written by Roland Sweet at NCAR in April, 1977 -C -C Algorithm This subroutine defines the finite-difference -C equations, incorporates boundary data, adjusts the -C right side when the system is singular and calls -C either POISTG or GENBUN which solves the linear -C system of equations. -C -C Space 8427(decimal) = 20353(octal) locations on the -C Required NCAR Control Data 7600 -C -C Timing and The execution time T on the NCAR Control Data -C Accuracy 7600 for subroutine HSTSSP is roughly proportional -C to M*N*log2(N). Some typical values are listed in -C the table below. -C The solution process employed results in a loss -C of no more than four significant digits for N and M -C as large as 64. More detailed information about -C accuracy can be found in the documentation for -C subroutine POISTG which is the routine that -C actually solves the finite difference equations. -C -C -C M(=N) MBDCND NBDCND T(MSECS) -C ----- ------ ------ -------- -C -C 32 1-9 1-4 56 -C 64 1-9 1-4 230 -C -C Portability American National Standards Institute FORTRAN. -C The machine dependent constant PI is defined in -C function PIMACH. -C -C Required COS -C Resident -C Routines -C -C Reference Schumann, U. and R. Sweet,'A Direct Method For -C The Solution Of Poisson's Equation With Neumann -C Boundary Conditions On A Staggered Grid Of -C Arbitrary Size,' J. Comp. Phys. 20(1976), -C pp. 171-182. -C -C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -C -C***REFERENCES U. Schumann and R. Sweet, A direct method for the -C solution of Poisson's equation with Neumann boundary -C conditions on a staggered grid of arbitrary size, -C Journal of Computational Physics 20, (1976), -C pp. 171-182. -C***ROUTINES CALLED GENBUN, PIMACH, POISTG -C***REVISION HISTORY (YYMMDD) -C 801001 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 HSTSSP -C -C - DIMENSION F(IDIMF,*) ,BDA(*) ,BDB(*) ,BDC(*) , - 1 BDD(*) ,W(*) -C***FIRST EXECUTABLE STATEMENT HSTSSP - IERROR = 0 - PI = PIMACH(DUM) - IF (A.LT.0. .OR. B.GT.PI) IERROR = 1 - IF (A .GE. B) IERROR = 2 - IF (MBDCND.LE.0 .OR. MBDCND.GT.9) IERROR = 3 - IF (C .GE. D) IERROR = 4 - IF (N .LE. 2) IERROR = 5 - IF (NBDCND.LT.0 .OR. NBDCND.GE.5) IERROR = 6 - IF (A.GT.0. .AND. (MBDCND.EQ.5 .OR. MBDCND.EQ.6 .OR. MBDCND.EQ.9)) - 1 IERROR = 7 - IF (A.EQ.0. .AND. (MBDCND.EQ.3 .OR. MBDCND.EQ.4 .OR. MBDCND.EQ.8)) - 1 IERROR = 8 - IF (B.LT.PI .AND. MBDCND.GE.7) IERROR = 9 - IF (B.EQ.PI .AND. (MBDCND.EQ.2 .OR. MBDCND.EQ.3 .OR. MBDCND.EQ.6)) - 1 IERROR = 10 - IF (MBDCND.GE.5 .AND. - 1 (NBDCND.EQ.1 .OR. NBDCND.EQ.2 .OR. NBDCND.EQ.4)) IERROR = 11 - IF (IDIMF .LT. M) IERROR = 12 - IF (M .LE. 2) IERROR = 13 - IF (IERROR .NE. 0) RETURN - DELTAR = (B-A)/M - DLRSQ = DELTAR**2 - DELTHT = (D-C)/N - DLTHSQ = DELTHT**2 - NP = NBDCND+1 - ISW = 1 - JSW = 1 - MB = MBDCND - IF (ELMBDA .NE. 0.) GO TO 105 - GO TO (101,102,105,103,101,105,101,105,105),MBDCND - 101 IF (A.NE.0. .OR. B.NE.PI) GO TO 105 - MB = 9 - GO TO 104 - 102 IF (A .NE. 0.) GO TO 105 - MB = 6 - GO TO 104 - 103 IF (B .NE. PI) GO TO 105 - MB = 8 - 104 JSW = 2 - 105 CONTINUE -C -C DEFINE A,B,C COEFFICIENTS IN W-ARRAY. -C - IWB = M - IWC = IWB+M - IWR = IWC+M - IWS = IWR+M - DO 106 I=1,M - J = IWR+I - W(J) = SIN(A+(I-0.5)*DELTAR) - W(I) = SIN((A+(I-1)*DELTAR))/DLRSQ - 106 CONTINUE - MM1 = M-1 - DO 107 I=1,MM1 - K = IWC+I - W(K) = W(I+1) - J = IWR+I - K = IWB+I - W(K) = ELMBDA*W(J)-(W(I)+W(I+1)) - 107 CONTINUE - W(IWR) = SIN(B)/DLRSQ - W(IWC) = ELMBDA*W(IWS)-(W(M)+W(IWR)) - DO 109 I=1,M - J = IWR+I - A1 = W(J) - DO 108 J=1,N - F(I,J) = A1*F(I,J) - 108 CONTINUE - 109 CONTINUE -C -C ENTER BOUNDARY DATA FOR THETA-BOUNDARIES. -C - GO TO (110,110,112,112,114,114,110,112,114),MB - 110 A1 = 2.*W(1) - W(IWB+1) = W(IWB+1)-W(1) - DO 111 J=1,N - F(1,J) = F(1,J)-A1*BDA(J) - 111 CONTINUE - GO TO 114 - 112 A1 = DELTAR*W(1) - W(IWB+1) = W(IWB+1)+W(1) - DO 113 J=1,N - F(1,J) = F(1,J)+A1*BDA(J) - 113 CONTINUE - 114 GO TO (115,117,117,115,115,117,119,119,119),MB - 115 A1 = 2.*W(IWR) - W(IWC) = W(IWC)-W(IWR) - DO 116 J=1,N - F(M,J) = F(M,J)-A1*BDB(J) - 116 CONTINUE - GO TO 119 - 117 A1 = DELTAR*W(IWR) - W(IWC) = W(IWC)+W(IWR) - DO 118 J=1,N - F(M,J) = F(M,J)-A1*BDB(J) - 118 CONTINUE -C -C ENTER BOUNDARY DATA FOR PHI-BOUNDARIES. -C - 119 A1 = 2./DLTHSQ - GO TO (129,120,120,122,122),NP - 120 DO 121 I=1,M - J = IWR+I - F(I,1) = F(I,1)-A1*BDC(I)/W(J) - 121 CONTINUE - GO TO 124 - 122 A1 = 1./DELTHT - DO 123 I=1,M - J = IWR+I - F(I,1) = F(I,1)+A1*BDC(I)/W(J) - 123 CONTINUE - 124 A1 = 2./DLTHSQ - GO TO (129,125,127,127,125),NP - 125 DO 126 I=1,M - J = IWR+I - F(I,N) = F(I,N)-A1*BDD(I)/W(J) - 126 CONTINUE - GO TO 129 - 127 A1 = 1./DELTHT - DO 128 I=1,M - J = IWR+I - F(I,N) = F(I,N)-A1*BDD(I)/W(J) - 128 CONTINUE - 129 CONTINUE -C -C ADJUST RIGHT SIDE OF SINGULAR PROBLEMS TO INSURE EXISTENCE OF A -C SOLUTION. -C - PERTRB = 0. - IF (ELMBDA) 139,131,130 - 130 IERROR = 14 - GO TO 139 - 131 GO TO (139,139,132,139,139,132,139,132,132),MB - 132 GO TO (133,139,139,133,139),NP - 133 CONTINUE - ISW = 2 - DO 135 J=1,N - DO 134 I=1,M - PERTRB = PERTRB+F(I,J) - 134 CONTINUE - 135 CONTINUE - A1 = N*(COS(A)-COS(B))/(2.*SIN(0.5*DELTAR)) - PERTRB = PERTRB/A1 - DO 137 I=1,M - J = IWR+I - A1 = PERTRB*W(J) - DO 136 J=1,N - F(I,J) = F(I,J)-A1 - 136 CONTINUE - 137 CONTINUE - A2 = 0. - A3 = 0. - DO 138 J=1,N - A2 = A2+F(1,J) - A3 = A3+F(M,J) - 138 CONTINUE - A2 = A2/W(IWR+1) - A3 = A3/W(IWS) - 139 CONTINUE -C -C MULTIPLY I-TH EQUATION THROUGH BY R(I)*DELTHT**2 -C - DO 141 I=1,M - J = IWR+I - A1 = DLTHSQ*W(J) - W(I) = A1*W(I) - J = IWC+I - W(J) = A1*W(J) - J = IWB+I - W(J) = A1*W(J) - DO 140 J=1,N - F(I,J) = A1*F(I,J) - 140 CONTINUE - 141 CONTINUE - LP = NBDCND - W(1) = 0. - W(IWR) = 0. -C -C CALL POISTG OR GENBUN TO SOLVE THE SYSTEM OF EQUATIONS. -C - IF (NBDCND .EQ. 0) GO TO 142 - CALL POISTG (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1)) - GO TO 143 - 142 CALL GENBUN (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1)) - 143 CONTINUE - W(1) = W(IWR+1)+3*M - IF (ISW.NE.2 .OR. JSW.NE.2) GO TO 150 - IF (MB .NE. 8) GO TO 145 - A1 = 0. - DO 144 J=1,N - A1 = A1+F(M,J) - 144 CONTINUE - A1 = (A1-DLRSQ*A3/16.)/N - IF (NBDCND .EQ. 3) A1 = A1+(BDD(M)-BDC(M))/(D-C) - A1 = BDB(1)-A1 - GO TO 147 - 145 A1 = 0. - DO 146 J=1,N - A1 = A1+F(1,J) - 146 CONTINUE - A1 = (A1-DLRSQ*A2/16.)/N - IF (NBDCND .EQ. 3) A1 = A1+(BDD(1)-BDC(1))/(D-C) - A1 = BDA(1)-A1 - 147 DO 149 I=1,M - DO 148 J=1,N - F(I,J) = F(I,J)+A1 - 148 CONTINUE - 149 CONTINUE - 150 CONTINUE - RETURN - END diff --git a/slatec/htrib3.f b/slatec/htrib3.f deleted file mode 100644 index e023e67..0000000 --- a/slatec/htrib3.f +++ /dev/null @@ -1,117 +0,0 @@ -*DECK HTRIB3 - SUBROUTINE HTRIB3 (NM, N, A, TAU, M, ZR, ZI) -C***BEGIN PROLOGUE HTRIB3 -C***PURPOSE Compute the eigenvectors of a complex Hermitian matrix from -C the eigenvectors of a real symmetric tridiagonal matrix -C output from HTRID3. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C4 -C***TYPE SINGLE PRECISION (HTRIB3-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of a complex analogue of -C the ALGOL procedure TRBAK3, NUM. MATH. 11, 181-195(1968) -C by Martin, Reinsch, and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). -C -C This subroutine forms the eigenvectors of a COMPLEX HERMITIAN -C matrix by back transforming those of the corresponding -C real symmetric tridiagonal matrix determined by HTRID3. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, A, ZR, and ZI, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C A contains some information about the unitary transformations -C used in the reduction by HTRID3. A is a two-dimensional -C REAL array, dimensioned A(NM,N). -C -C TAU contains further information about the transformations. -C TAU is a one-dimensional REAL array, dimensioned TAU(2,N). -C -C M is the number of eigenvectors to be back transformed. -C M is an INTEGER variable. -C -C ZR contains the eigenvectors to be back transformed in its -C first M columns. The contents of ZI are immaterial. ZR and -C ZI are two-dimensional REAL arrays, dimensioned ZR(NM,M) and -C ZI(NM,M). -C -C On OUTPUT -C -C ZR and ZI contain the real and imaginary parts, respectively, -C of the transformed eigenvectors in their first M columns. -C -C NOTE that the last component of each returned vector -C is real and that vector Euclidean norms are preserved. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE HTRIB3 -C - INTEGER I,J,K,L,M,N,NM - REAL A(NM,*),TAU(2,*),ZR(NM,*),ZI(NM,*) - REAL H,S,SI -C -C***FIRST EXECUTABLE STATEMENT HTRIB3 - IF (M .EQ. 0) GO TO 200 -C .......... TRANSFORM THE EIGENVECTORS OF THE REAL SYMMETRIC -C TRIDIAGONAL MATRIX TO THOSE OF THE HERMITIAN -C TRIDIAGONAL MATRIX. .......... - DO 50 K = 1, N -C - DO 50 J = 1, M - ZI(K,J) = -ZR(K,J) * TAU(2,K) - ZR(K,J) = ZR(K,J) * TAU(1,K) - 50 CONTINUE -C - IF (N .EQ. 1) GO TO 200 -C .......... RECOVER AND APPLY THE HOUSEHOLDER MATRICES .......... - DO 140 I = 2, N - L = I - 1 - H = A(I,I) - IF (H .EQ. 0.0E0) GO TO 140 -C - DO 130 J = 1, M - S = 0.0E0 - SI = 0.0E0 -C - DO 110 K = 1, L - S = S + A(I,K) * ZR(K,J) - A(K,I) * ZI(K,J) - SI = SI + A(I,K) * ZI(K,J) + A(K,I) * ZR(K,J) - 110 CONTINUE -C .......... DOUBLE DIVISIONS AVOID POSSIBLE UNDERFLOW .......... - S = (S / H) / H - SI = (SI / H) / H -C - DO 120 K = 1, L - ZR(K,J) = ZR(K,J) - S * A(I,K) - SI * A(K,I) - ZI(K,J) = ZI(K,J) - SI * A(I,K) + S * A(K,I) - 120 CONTINUE -C - 130 CONTINUE -C - 140 CONTINUE -C - 200 RETURN - END diff --git a/slatec/htribk.f b/slatec/htribk.f deleted file mode 100644 index 6b86a5c..0000000 --- a/slatec/htribk.f +++ /dev/null @@ -1,121 +0,0 @@ -*DECK HTRIBK - SUBROUTINE HTRIBK (NM, N, AR, AI, TAU, M, ZR, ZI) -C***BEGIN PROLOGUE HTRIBK -C***PURPOSE Form the eigenvectors of a complex Hermitian matrix from -C the eigenvectors of a real symmetric tridiagonal matrix -C output from HTRIDI. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C4 -C***TYPE SINGLE PRECISION (HTRIBK-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of a complex analogue of -C the ALGOL procedure TRBAK1, NUM. MATH. 11, 181-195(1968) -C by Martin, Reinsch, and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). -C -C This subroutine forms the eigenvectors of a COMPLEX HERMITIAN -C matrix by back transforming those of the corresponding -C real symmetric tridiagonal matrix determined by HTRIDI. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, AR, AI, ZR, and ZI, as declared in the -C calling program dimension statement. NM is an INTEGER -C variable. -C -C N is the order of the matrix. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C AR and AI contain some information about the unitary -C transformations used in the reduction by HTRIDI in the -C strict lower triangle of AR and the full lower triangle of -C AI. The remaining upper parts of the matrices are arbitrary. -C AR and AI are two-dimensional REAL arrays, dimensioned -C AR(NM,N) and AI(NM,N). -C -C TAU contains further information about the transformations. -C TAU is a one-dimensional REAL array, dimensioned TAU(2,N). -C -C M is the number of eigenvectors to be back transformed. -C M is an INTEGER variable. -C -C ZR contains the eigenvectors to be back transformed in its first -C M columns. The contents of ZI are immaterial. ZR and ZI are -C two-dimensional REAL arrays, dimensioned ZR(NM,M) and -C ZI(NM,M). -C -C On OUTPUT -C -C ZR and ZI contain the real and imaginary parts, respectively, -C of the transformed eigenvectors in their first M columns. -C -C Note that the last component of each returned vector -C is real and that vector Euclidean norms are preserved. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE HTRIBK -C - INTEGER I,J,K,L,M,N,NM - REAL AR(NM,*),AI(NM,*),TAU(2,*),ZR(NM,*),ZI(NM,*) - REAL H,S,SI -C -C***FIRST EXECUTABLE STATEMENT HTRIBK - IF (M .EQ. 0) GO TO 200 -C .......... TRANSFORM THE EIGENVECTORS OF THE REAL SYMMETRIC -C TRIDIAGONAL MATRIX TO THOSE OF THE HERMITIAN -C TRIDIAGONAL MATRIX. .......... - DO 50 K = 1, N -C - DO 50 J = 1, M - ZI(K,J) = -ZR(K,J) * TAU(2,K) - ZR(K,J) = ZR(K,J) * TAU(1,K) - 50 CONTINUE -C - IF (N .EQ. 1) GO TO 200 -C .......... RECOVER AND APPLY THE HOUSEHOLDER MATRICES .......... - DO 140 I = 2, N - L = I - 1 - H = AI(I,I) - IF (H .EQ. 0.0E0) GO TO 140 -C - DO 130 J = 1, M - S = 0.0E0 - SI = 0.0E0 -C - DO 110 K = 1, L - S = S + AR(I,K) * ZR(K,J) - AI(I,K) * ZI(K,J) - SI = SI + AR(I,K) * ZI(K,J) + AI(I,K) * ZR(K,J) - 110 CONTINUE -C .......... DOUBLE DIVISIONS AVOID POSSIBLE UNDERFLOW .......... - S = (S / H) / H - SI = (SI / H) / H -C - DO 120 K = 1, L - ZR(K,J) = ZR(K,J) - S * AR(I,K) - SI * AI(I,K) - ZI(K,J) = ZI(K,J) - SI * AR(I,K) + S * AI(I,K) - 120 CONTINUE -C - 130 CONTINUE -C - 140 CONTINUE -C - 200 RETURN - END diff --git a/slatec/htrid3.f b/slatec/htrid3.f deleted file mode 100644 index e0418e7..0000000 --- a/slatec/htrid3.f +++ /dev/null @@ -1,190 +0,0 @@ -*DECK HTRID3 - SUBROUTINE HTRID3 (NM, N, A, D, E, E2, TAU) -C***BEGIN PROLOGUE HTRID3 -C***PURPOSE Reduce a complex Hermitian (packed) matrix to a real -C symmetric tridiagonal matrix by unitary similarity -C transformations. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C1B1 -C***TYPE SINGLE PRECISION (HTRID3-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of a complex analogue of -C the ALGOL procedure TRED3, NUM. MATH. 11, 181-195(1968) -C by Martin, Reinsch, and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). -C -C This subroutine reduces a COMPLEX HERMITIAN matrix, stored as -C a single square array, to a real symmetric tridiagonal matrix -C using unitary similarity transformations. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameter, A, as declared in the calling program -C dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C A contains the lower triangle of the complex Hermitian input -C matrix. The real parts of the matrix elements are stored -C in the full lower triangle of A, and the imaginary parts -C are stored in the transposed positions of the strict upper -C triangle of A. No storage is required for the zero -C imaginary parts of the diagonal elements. A is a two- -C dimensional REAL array, dimensioned A(NM,N). -C -C On OUTPUT -C -C A contains some information about the unitary transformations -C used in the reduction. -C -C D contains the diagonal elements of the real symmetric -C tridiagonal matrix. D is a one-dimensional REAL array, -C dimensioned D(N). -C -C E contains the subdiagonal elements of the real tridiagonal -C matrix in its last N-1 positions. E(1) is set to zero. -C E is a one-dimensional REAL array, dimensioned E(N). -C -C E2 contains the squares of the corresponding elements of E. -C E2(1) is set to zero. E2 may coincide with E if the squares -C are not needed. E2 is a one-dimensional REAL array, -C dimensioned E2(N). -C -C TAU contains further information about the transformations. -C TAU is a one-dimensional REAL array, dimensioned TAU(2,N). -C -C Calls PYTHAG(A,B) for sqrt(A**2 + B**2). -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED PYTHAG -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE HTRID3 -C - INTEGER I,J,K,L,N,II,NM,JM1,JP1 - REAL A(NM,*),D(*),E(*),E2(*),TAU(2,*) - REAL F,G,H,FI,GI,HH,SI,SCALE - REAL PYTHAG -C -C***FIRST EXECUTABLE STATEMENT HTRID3 - TAU(1,N) = 1.0E0 - TAU(2,N) = 0.0E0 -C .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... - DO 300 II = 1, N - I = N + 1 - II - L = I - 1 - H = 0.0E0 - SCALE = 0.0E0 - IF (L .LT. 1) GO TO 130 -C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... - DO 120 K = 1, L - 120 SCALE = SCALE + ABS(A(I,K)) + ABS(A(K,I)) -C - IF (SCALE .NE. 0.0E0) GO TO 140 - TAU(1,L) = 1.0E0 - TAU(2,L) = 0.0E0 - 130 E(I) = 0.0E0 - E2(I) = 0.0E0 - GO TO 290 -C - 140 DO 150 K = 1, L - A(I,K) = A(I,K) / SCALE - A(K,I) = A(K,I) / SCALE - H = H + A(I,K) * A(I,K) + A(K,I) * A(K,I) - 150 CONTINUE -C - E2(I) = SCALE * SCALE * H - G = SQRT(H) - E(I) = SCALE * G - F = PYTHAG(A(I,L),A(L,I)) -C .......... FORM NEXT DIAGONAL ELEMENT OF MATRIX T .......... - IF (F .EQ. 0.0E0) GO TO 160 - TAU(1,L) = (A(L,I) * TAU(2,I) - A(I,L) * TAU(1,I)) / F - SI = (A(I,L) * TAU(2,I) + A(L,I) * TAU(1,I)) / F - H = H + F * G - G = 1.0E0 + G / F - A(I,L) = G * A(I,L) - A(L,I) = G * A(L,I) - IF (L .EQ. 1) GO TO 270 - GO TO 170 - 160 TAU(1,L) = -TAU(1,I) - SI = TAU(2,I) - A(I,L) = G - 170 F = 0.0E0 -C - DO 240 J = 1, L - G = 0.0E0 - GI = 0.0E0 - IF (J .EQ. 1) GO TO 190 - JM1 = J - 1 -C .......... FORM ELEMENT OF A*U .......... - DO 180 K = 1, JM1 - G = G + A(J,K) * A(I,K) + A(K,J) * A(K,I) - GI = GI - A(J,K) * A(K,I) + A(K,J) * A(I,K) - 180 CONTINUE -C - 190 G = G + A(J,J) * A(I,J) - GI = GI - A(J,J) * A(J,I) - JP1 = J + 1 - IF (L .LT. JP1) GO TO 220 -C - DO 200 K = JP1, L - G = G + A(K,J) * A(I,K) - A(J,K) * A(K,I) - GI = GI - A(K,J) * A(K,I) - A(J,K) * A(I,K) - 200 CONTINUE -C .......... FORM ELEMENT OF P .......... - 220 E(J) = G / H - TAU(2,J) = GI / H - F = F + E(J) * A(I,J) - TAU(2,J) * A(J,I) - 240 CONTINUE -C - HH = F / (H + H) -C .......... FORM REDUCED A .......... - DO 260 J = 1, L - F = A(I,J) - G = E(J) - HH * F - E(J) = G - FI = -A(J,I) - GI = TAU(2,J) - HH * FI - TAU(2,J) = -GI - A(J,J) = A(J,J) - 2.0E0 * (F * G + FI * GI) - IF (J .EQ. 1) GO TO 260 - JM1 = J - 1 -C - DO 250 K = 1, JM1 - A(J,K) = A(J,K) - F * E(K) - G * A(I,K) - 1 + FI * TAU(2,K) + GI * A(K,I) - A(K,J) = A(K,J) - F * TAU(2,K) - G * A(K,I) - 1 - FI * E(K) - GI * A(I,K) - 250 CONTINUE -C - 260 CONTINUE -C - 270 DO 280 K = 1, L - A(I,K) = SCALE * A(I,K) - A(K,I) = SCALE * A(K,I) - 280 CONTINUE -C - TAU(2,L) = -SI - 290 D(I) = A(I,I) - A(I,I) = SCALE * SQRT(H) - 300 CONTINUE -C - RETURN - END diff --git a/slatec/htridi.f b/slatec/htridi.f deleted file mode 100644 index 4145bd5..0000000 --- a/slatec/htridi.f +++ /dev/null @@ -1,185 +0,0 @@ -*DECK HTRIDI - SUBROUTINE HTRIDI (NM, N, AR, AI, D, E, E2, TAU) -C***BEGIN PROLOGUE HTRIDI -C***PURPOSE Reduce a complex Hermitian matrix to a real symmetric -C tridiagonal matrix using unitary similarity -C transformations. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C1B1 -C***TYPE SINGLE PRECISION (HTRIDI-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of a complex analogue of -C the ALGOL procedure TRED1, NUM. MATH. 11, 181-195(1968) -C by Martin, Reinsch, and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). -C -C This subroutine reduces a COMPLEX HERMITIAN matrix -C to a real symmetric tridiagonal matrix using -C unitary similarity transformations. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, AR and AI, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix A=(AR,AI). N is an INTEGER -C variable. N must be less than or equal to NM. -C -C AR and AI contain the real and imaginary parts, respectively, -C of the complex Hermitian input matrix. Only the lower -C triangle of the matrix need be supplied. AR and AI are two- -C dimensional REAL arrays, dimensioned AR(NM,N) and AI(NM,N). -C -C On OUTPUT -C -C AR and AI contain some information about the unitary trans- -C formations used in the reduction in the strict lower triangle -C of AR and the full lower triangle of AI. The rest of the -C matrices are unaltered. -C -C D contains the diagonal elements of the real symmetric -C tridiagonal matrix. D is a one-dimensional REAL array, -C dimensioned D(N). -C -C E contains the subdiagonal elements of the real tridiagonal -C matrix in its last N-1 positions. E(1) is set to zero. -C E is a one-dimensional REAL array, dimensioned E(N). -C -C E2 contains the squares of the corresponding elements of E. -C E2(1) is set to zero. E2 may coincide with E if the squares -C are not needed. E2 is a one-dimensional REAL array, -C dimensioned E2(N). -C -C TAU contains further information about the transformations. -C TAU is a one-dimensional REAL array, dimensioned TAU(2,N). -C -C Calls PYTHAG(A,B) for sqrt(A**2 + B**2). -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED PYTHAG -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE HTRIDI -C - INTEGER I,J,K,L,N,II,NM,JP1 - REAL AR(NM,*),AI(NM,*),D(*),E(*),E2(*),TAU(2,*) - REAL F,G,H,FI,GI,HH,SI,SCALE - REAL PYTHAG -C -C***FIRST EXECUTABLE STATEMENT HTRIDI - TAU(1,N) = 1.0E0 - TAU(2,N) = 0.0E0 -C - DO 100 I = 1, N - 100 D(I) = AR(I,I) -C .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... - DO 300 II = 1, N - I = N + 1 - II - L = I - 1 - H = 0.0E0 - SCALE = 0.0E0 - IF (L .LT. 1) GO TO 130 -C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... - DO 120 K = 1, L - 120 SCALE = SCALE + ABS(AR(I,K)) + ABS(AI(I,K)) -C - IF (SCALE .NE. 0.0E0) GO TO 140 - TAU(1,L) = 1.0E0 - TAU(2,L) = 0.0E0 - 130 E(I) = 0.0E0 - E2(I) = 0.0E0 - GO TO 290 -C - 140 DO 150 K = 1, L - AR(I,K) = AR(I,K) / SCALE - AI(I,K) = AI(I,K) / SCALE - H = H + AR(I,K) * AR(I,K) + AI(I,K) * AI(I,K) - 150 CONTINUE -C - E2(I) = SCALE * SCALE * H - G = SQRT(H) - E(I) = SCALE * G - F = PYTHAG(AR(I,L),AI(I,L)) -C .......... FORM NEXT DIAGONAL ELEMENT OF MATRIX T .......... - IF (F .EQ. 0.0E0) GO TO 160 - TAU(1,L) = (AI(I,L) * TAU(2,I) - AR(I,L) * TAU(1,I)) / F - SI = (AR(I,L) * TAU(2,I) + AI(I,L) * TAU(1,I)) / F - H = H + F * G - G = 1.0E0 + G / F - AR(I,L) = G * AR(I,L) - AI(I,L) = G * AI(I,L) - IF (L .EQ. 1) GO TO 270 - GO TO 170 - 160 TAU(1,L) = -TAU(1,I) - SI = TAU(2,I) - AR(I,L) = G - 170 F = 0.0E0 -C - DO 240 J = 1, L - G = 0.0E0 - GI = 0.0E0 -C .......... FORM ELEMENT OF A*U .......... - DO 180 K = 1, J - G = G + AR(J,K) * AR(I,K) + AI(J,K) * AI(I,K) - GI = GI - AR(J,K) * AI(I,K) + AI(J,K) * AR(I,K) - 180 CONTINUE -C - JP1 = J + 1 - IF (L .LT. JP1) GO TO 220 -C - DO 200 K = JP1, L - G = G + AR(K,J) * AR(I,K) - AI(K,J) * AI(I,K) - GI = GI - AR(K,J) * AI(I,K) - AI(K,J) * AR(I,K) - 200 CONTINUE -C .......... FORM ELEMENT OF P .......... - 220 E(J) = G / H - TAU(2,J) = GI / H - F = F + E(J) * AR(I,J) - TAU(2,J) * AI(I,J) - 240 CONTINUE -C - HH = F / (H + H) -C .......... FORM REDUCED A .......... - DO 260 J = 1, L - F = AR(I,J) - G = E(J) - HH * F - E(J) = G - FI = -AI(I,J) - GI = TAU(2,J) - HH * FI - TAU(2,J) = -GI -C - DO 260 K = 1, J - AR(J,K) = AR(J,K) - F * E(K) - G * AR(I,K) - 1 + FI * TAU(2,K) + GI * AI(I,K) - AI(J,K) = AI(J,K) - F * TAU(2,K) - G * AI(I,K) - 1 - FI * E(K) - GI * AR(I,K) - 260 CONTINUE -C - 270 DO 280 K = 1, L - AR(I,K) = SCALE * AR(I,K) - AI(I,K) = SCALE * AI(I,K) - 280 CONTINUE -C - TAU(2,L) = -SI - 290 HH = D(I) - D(I) = AR(I,I) - AR(I,I) = HH - AI(I,I) = SCALE * SQRT(H) - 300 CONTINUE -C - RETURN - END diff --git a/slatec/hvnrm.f b/slatec/hvnrm.f deleted file mode 100644 index cc5687f..0000000 --- a/slatec/hvnrm.f +++ /dev/null @@ -1,31 +0,0 @@ -*DECK HVNRM - FUNCTION HVNRM (V, NCOMP) -C***BEGIN PROLOGUE HVNRM -C***SUBSIDIARY -C***PURPOSE Subsidiary to DEABM, DEBDF and DERKF -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (HVNRM-S, DHVNRM-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C Compute the maximum norm of the vector V(*) of length NCOMP and -C return the result as HVNRM. -C -C***SEE ALSO DEABM, DEBDF, DERKF -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 800501 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891024 Changed routine name from VNORM to HVNRM. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE HVNRM - DIMENSION V(*) -C***FIRST EXECUTABLE STATEMENT HVNRM - HVNRM=0. - DO 10 K=1,NCOMP - 10 HVNRM=MAX(HVNRM,ABS(V(K))) - RETURN - END diff --git a/slatec/hw3crt.f b/slatec/hw3crt.f deleted file mode 100644 index 043098d..0000000 --- a/slatec/hw3crt.f +++ /dev/null @@ -1,627 +0,0 @@ -*DECK HW3CRT - SUBROUTINE HW3CRT (XS, XF, L, LBDCND, BDXS, BDXF, YS, YF, M, - + MBDCND, BDYS, BDYF, ZS, ZF, N, NBDCND, BDZS, BDZF, ELMBDA, - + LDIMF, MDIMF, F, PERTRB, IERROR, W) -C***BEGIN PROLOGUE HW3CRT -C***PURPOSE Solve the standard seven-point finite difference -C approximation to the Helmholtz equation in Cartesian -C coordinates. -C***LIBRARY SLATEC (FISHPACK) -C***CATEGORY I2B1A1A -C***TYPE SINGLE PRECISION (HW3CRT-S) -C***KEYWORDS CARTESIAN, ELLIPTIC, FISHPACK, HELMHOLTZ, PDE -C***AUTHOR Adams, J., (NCAR) -C Swarztrauber, P. N., (NCAR) -C Sweet, R., (NCAR) -C***DESCRIPTION -C -C Subroutine HW3CRT solves the standard seven-point finite -C difference approximation to the Helmholtz equation in Cartesian -C coordinates: -C -C (d/dX)(dU/dX) + (d/dY)(dU/dY) + (d/dZ)(dU/dZ) -C -C + LAMBDA*U = F(X,Y,Z) . -C -C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -C -C -C * * * * * * * * Parameter Description * * * * * * * * * * -C -C -C * * * * * * On Input * * * * * * -C -C XS,XF -C The range of X, i.e. XS .LE. X .LE. XF . -C XS must be less than XF. -C -C L -C The number of panels into which the interval (XS,XF) is -C subdivided. Hence, there will be L+1 grid points in the -C X-direction given by X(I) = XS+(I-1)DX for I=1,2,...,L+1, -C where DX = (XF-XS)/L is the panel width. L must be at -C least 5 . -C -C LBDCND -C Indicates the type of boundary conditions at X = XS and X = XF. -C -C = 0 If the solution is periodic in X, i.e. -C U(L+I,J,K) = U(I,J,K). -C = 1 If the solution is specified at X = XS and X = XF. -C = 2 If the solution is specified at X = XS and the derivative -C of the solution with respect to X is specified at X = XF. -C = 3 If the derivative of the solution with respect to X is -C specified at X = XS and X = XF. -C = 4 If the derivative of the solution with respect to X is -C specified at X = XS and the solution is specified at X=XF. -C -C BDXS -C A two-dimensional array that specifies the values of the -C derivative of the solution with respect to X at X = XS. -C when LBDCND = 3 or 4, -C -C BDXS(J,K) = (d/dX)U(XS,Y(J),Z(K)), J=1,2,...,M+1, -C K=1,2,...,N+1. -C -C When LBDCND has any other value, BDXS is a dummy variable. -C BDXS must be dimensioned at least (M+1)*(N+1). -C -C BDXF -C A two-dimensional array that specifies the values of the -C derivative of the solution with respect to X at X = XF. -C When LBDCND = 2 or 3, -C -C BDXF(J,K) = (d/dX)U(XF,Y(J),Z(K)), J=1,2,...,M+1, -C K=1,2,...,N+1. -C -C When LBDCND has any other value, BDXF is a dummy variable. -C BDXF must be dimensioned at least (M+1)*(N+1). -C -C YS,YF -C The range of Y, i.e. YS .LE. Y .LE. YF. -C YS must be less than YF. -C -C M -C The number of panels into which the interval (YS,YF) is -C subdivided. Hence, there will be M+1 grid points in the -C Y-direction given by Y(J) = YS+(J-1)DY for J=1,2,...,M+1, -C where DY = (YF-YS)/M is the panel width. M must be at -C least 5 . -C -C MBDCND -C Indicates the type of boundary conditions at Y = YS and Y = YF. -C -C = 0 If the solution is periodic in Y, i.e. -C U(I,M+J,K) = U(I,J,K). -C = 1 If the solution is specified at Y = YS and Y = YF. -C = 2 If the solution is specified at Y = YS and the derivative -C of the solution with respect to Y is specified at Y = YF. -C = 3 If the derivative of the solution with respect to Y is -C specified at Y = YS and Y = YF. -C = 4 If the derivative of the solution with respect to Y is -C specified at Y = YS and the solution is specified at Y=YF. -C -C BDYS -C A two-dimensional array that specifies the values of the -C derivative of the solution with respect to Y at Y = YS. -C When MBDCND = 3 or 4, -C -C BDYS(I,K) = (d/dY)U(X(I),YS,Z(K)), I=1,2,...,L+1, -C K=1,2,...,N+1. -C -C When MBDCND has any other value, BDYS is a dummy variable. -C BDYS must be dimensioned at least (L+1)*(N+1). -C -C BDYF -C A two-dimensional array that specifies the values of the -C derivative of the solution with respect to Y at Y = YF. -C When MBDCND = 2 or 3, -C -C BDYF(I,K) = (d/dY)U(X(I),YF,Z(K)), I=1,2,...,L+1, -C K=1,2,...,N+1. -C -C When MBDCND has any other value, BDYF is a dummy variable. -C BDYF must be dimensioned at least (L+1)*(N+1). -C -C ZS,ZF -C The range of Z, i.e. ZS .LE. Z .LE. ZF. -C ZS must be less than ZF. -C -C N -C The number of panels into which the interval (ZS,ZF) is -C subdivided. Hence, there will be N+1 grid points in the -C Z-direction given by Z(K) = ZS+(K-1)DZ for K=1,2,...,N+1, -C where DZ = (ZF-ZS)/N is the panel width. N must be at least 5. -C -C NBDCND -C Indicates the type of boundary conditions at Z = ZS and Z = ZF. -C -C = 0 If the solution is periodic in Z, i.e. -C U(I,J,N+K) = U(I,J,K). -C = 1 If the solution is specified at Z = ZS and Z = ZF. -C = 2 If the solution is specified at Z = ZS and the derivative -C of the solution with respect to Z is specified at Z = ZF. -C = 3 If the derivative of the solution with respect to Z is -C specified at Z = ZS and Z = ZF. -C = 4 If the derivative of the solution with respect to Z is -C specified at Z = ZS and the solution is specified at Z=ZF. -C -C BDZS -C A two-dimensional array that specifies the values of the -C derivative of the solution with respect to Z at Z = ZS. -C When NBDCND = 3 or 4, -C -C BDZS(I,J) = (d/dZ)U(X(I),Y(J),ZS), I=1,2,...,L+1, -C J=1,2,...,M+1. -C -C When NBDCND has any other value, BDZS is a dummy variable. -C BDZS must be dimensioned at least (L+1)*(M+1). -C -C BDZF -C A two-dimensional array that specifies the values of the -C derivative of the solution with respect to Z at Z = ZF. -C When NBDCND = 2 or 3, -C -C BDZF(I,J) = (d/dZ)U(X(I),Y(J),ZF), I=1,2,...,L+1, -C J=1,2,...,M+1. -C -C When NBDCND has any other value, BDZF is a dummy variable. -C BDZF must be dimensioned at least (L+1)*(M+1). -C -C ELMBDA -C The constant LAMBDA in the Helmholtz equation. If -C LAMBDA .GT. 0, a solution may not exist. However, HW3CRT will -C attempt to find a solution. -C -C F -C A three-dimensional array that specifies the values of the -C right side of the Helmholtz equation and boundary values (if -C any). For I=2,3,...,L, J=2,3,...,M, and K=2,3,...,N -C -C F(I,J,K) = F(X(I),Y(J),Z(K)). -C -C On the boundaries F is defined by -C -C LBDCND F(1,J,K) F(L+1,J,K) -C ------ --------------- --------------- -C -C 0 F(XS,Y(J),Z(K)) F(XS,Y(J),Z(K)) -C 1 U(XS,Y(J),Z(K)) U(XF,Y(J),Z(K)) -C 2 U(XS,Y(J),Z(K)) F(XF,Y(J),Z(K)) J=1,2,...,M+1 -C 3 F(XS,Y(J),Z(K)) F(XF,Y(J),Z(K)) K=1,2,...,N+1 -C 4 F(XS,Y(J),Z(K)) U(XF,Y(J),Z(K)) -C -C MBDCND F(I,1,K) F(I,M+1,K) -C ------ --------------- --------------- -C -C 0 F(X(I),YS,Z(K)) F(X(I),YS,Z(K)) -C 1 U(X(I),YS,Z(K)) U(X(I),YF,Z(K)) -C 2 U(X(I),YS,Z(K)) F(X(I),YF,Z(K)) I=1,2,...,L+1 -C 3 F(X(I),YS,Z(K)) F(X(I),YF,Z(K)) K=1,2,...,N+1 -C 4 F(X(I),YS,Z(K)) U(X(I),YF,Z(K)) -C -C NBDCND F(I,J,1) F(I,J,N+1) -C ------ --------------- --------------- -C -C 0 F(X(I),Y(J),ZS) F(X(I),Y(J),ZS) -C 1 U(X(I),Y(J),ZS) U(X(I),Y(J),ZF) -C 2 U(X(I),Y(J),ZS) F(X(I),Y(J),ZF) I=1,2,...,L+1 -C 3 F(X(I),Y(J),ZS) F(X(I),Y(J),ZF) J=1,2,...,M+1 -C 4 F(X(I),Y(J),ZS) U(X(I),Y(J),ZF) -C -C F must be dimensioned at least (L+1)*(M+1)*(N+1). -C -C NOTE: -C -C If the table calls for both the solution U and the right side F -C on a boundary, then the solution must be specified. -C -C LDIMF -C The row (or first) dimension of the arrays F,BDYS,BDYF,BDZS, -C and BDZF as it appears in the program calling HW3CRT. this -C parameter is used to specify the variable dimension of these -C arrays. LDIMF must be at least L+1. -C -C MDIMF -C The column (or second) dimension of the array F and the row (or -C first) dimension of the arrays BDXS and BDXF as it appears in -C the program calling HW3CRT. This parameter is used to specify -C the variable dimension of these arrays. -C MDIMF must be at least M+1. -C -C W -C A one-dimensional array that must be provided by the user for -C work space. The length of W must be at least 30 + L + M + 5*N -C + MAX(L,M,N) + 7*(INT((L+1)/2) + INT((M+1)/2)) -C -C -C * * * * * * On Output * * * * * * -C -C F -C Contains the solution U(I,J,K) of the finite difference -C approximation for the grid point (X(I),Y(J),Z(K)) for -C I=1,2,...,L+1, J=1,2,...,M+1, and K=1,2,...,N+1. -C -C PERTRB -C If a combination of periodic or derivative boundary conditions -C is specified for a Poisson equation (LAMBDA = 0), a solution -C may not exist. PERTRB is a constant, calculated and subtracted -C from F, which ensures that a solution exists. PWSCRT then -C computes this solution, which is a least squares solution to -C the original approximation. This solution is not unique and is -C unnormalized. The value of PERTRB should be small compared to -C the right side F. Otherwise, a solution is obtained to an -C essentially different problem. This comparison should always -C be made to insure that a meaningful solution has been obtained. -C -C IERROR -C An error flag that indicates invalid input parameters. Except -C for numbers 0 and 12, a solution is not attempted. -C -C = 0 No error -C = 1 XS .GE. XF -C = 2 L .LT. 5 -C = 3 LBDCND .LT. 0 .OR. LBDCND .GT. 4 -C = 4 YS .GE. YF -C = 5 M .LT. 5 -C = 6 MBDCND .LT. 0 .OR. MBDCND .GT. 4 -C = 7 ZS .GE. ZF -C = 8 N .LT. 5 -C = 9 NBDCND .LT. 0 .OR. NBDCND .GT. 4 -C = 10 LDIMF .LT. L+1 -C = 11 MDIMF .LT. M+1 -C = 12 LAMBDA .GT. 0 -C -C Since this is the only means of indicating a possibly incorrect -C call to HW3CRT, the user should test IERROR after the call. -C -C *Long Description: -C -C * * * * * * * Program Specifications * * * * * * * * * * * * -C -C Dimension of BDXS(MDIMF,N+1),BDXF(MDIMF,N+1),BDYS(LDIMF,N+1), -C Arguments BDYF(LDIMF,N+1),BDZS(LDIMF,M+1),BDZF(LDIMF,M+1), -C F(LDIMF,MDIMF,N+1),W(see argument list) -C -C Latest December 1, 1978 -C Revision -C -C Subprograms HW3CRT,POIS3D,POS3D1,TRIDQ,RFFTI,RFFTF,RFFTF1, -C Required RFFTB,RFFTB1,COSTI,COST,SINTI,SINT,COSQI,COSQF, -C COSQF1,COSQB,COSQB1,SINQI,SINQF,SINQB,CFFTI, -C CFFTI1,CFFTB,CFFTB1,PASSB2,PASSB3,PASSB4,PASSB, -C CFFTF,CFFTF1,PASSF1,PASSF2,PASSF3,PASSF4,PASSF, -C PIMACH -C -C Special NONE -C Conditions -C -C Common NONE -C Blocks -C -C I/O NONE -C -C Precision Single -C -C Specialist Roland Sweet -C -C Language FORTRAN -C -C History Written by Roland Sweet at NCAR in July 1977 -C -C Algorithm This subroutine defines the finite difference -C equations, incorporates boundary data, and -C adjusts the right side of singular systems and -C then calls POIS3D to solve the system. -C -C Space 7862(decimal) = 17300(octal) locations on the -C Required NCAR Control Data 7600 -C -C Timing and The execution time T on the NCAR Control Data -C Accuracy 7600 for subroutine HW3CRT is roughly proportional -C to L*M*N*(log2(L)+log2(M)+5), but also depends on -C input parameters LBDCND and MBDCND. Some typical -C values are listed in the table below. -C The solution process employed results in a loss -C of no more than three significant digits for L,M -C and N as large as 32. More detailed information -C about accuracy can be found in the documentation -C for subroutine POIS3D which is the routine that -C actually solves the finite difference equations. -C -C -C L(=M=N) LBDCND(=MBDCND=NBDCND) T(MSECS) -C ------- ---------------------- -------- -C -C 16 0 300 -C 16 1 302 -C 16 3 348 -C 32 0 1925 -C 32 1 1929 -C 32 3 2109 -C -C Portability American National Standards Institute FORTRAN. -C The machine dependent constant PI is defined in -C function PIMACH. -C -C Required COS,SIN,ATAN -C Resident -C Routines -C -C Reference NONE -C -C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -C -C***REFERENCES (NONE) -C***ROUTINES CALLED POIS3D -C***REVISION HISTORY (YYMMDD) -C 801001 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***END PROLOGUE HW3CRT -C -C - DIMENSION BDXS(MDIMF,*) ,BDXF(MDIMF,*) , - 1 BDYS(LDIMF,*) ,BDYF(LDIMF,*) , - 2 BDZS(LDIMF,*) ,BDZF(LDIMF,*) , - 3 F(LDIMF,MDIMF,*) ,W(*) -C***FIRST EXECUTABLE STATEMENT HW3CRT - IERROR = 0 - IF (XF .LE. XS) IERROR = 1 - IF (L .LT. 5) IERROR = 2 - IF (LBDCND.LT.0 .OR. LBDCND.GT.4) IERROR = 3 - IF (YF .LE. YS) IERROR = 4 - IF (M .LT. 5) IERROR = 5 - IF (MBDCND.LT.0 .OR. MBDCND.GT.4) IERROR = 6 - IF (ZF .LE. ZS) IERROR = 7 - IF (N .LT. 5) IERROR = 8 - IF (NBDCND.LT.0 .OR. NBDCND.GT.4) IERROR = 9 - IF (LDIMF .LT. L+1) IERROR = 10 - IF (MDIMF .LT. M+1) IERROR = 11 - IF (IERROR .NE. 0) GO TO 188 - DY = (YF-YS)/M - TWBYDY = 2./DY - C2 = 1./(DY**2) - MSTART = 1 - MSTOP = M - MP1 = M+1 - MP = MBDCND+1 - GO TO (104,101,101,102,102),MP - 101 MSTART = 2 - 102 GO TO (104,104,103,103,104),MP - 103 MSTOP = MP1 - 104 MUNK = MSTOP-MSTART+1 - DZ = (ZF-ZS)/N - TWBYDZ = 2./DZ - NP = NBDCND+1 - C3 = 1./(DZ**2) - NP1 = N+1 - NSTART = 1 - NSTOP = N - GO TO (108,105,105,106,106),NP - 105 NSTART = 2 - 106 GO TO (108,108,107,107,108),NP - 107 NSTOP = NP1 - 108 NUNK = NSTOP-NSTART+1 - LP1 = L+1 - DX = (XF-XS)/L - C1 = 1./(DX**2) - TWBYDX = 2./DX - LP = LBDCND+1 - LSTART = 1 - LSTOP = L -C -C ENTER BOUNDARY DATA FOR X-BOUNDARIES. -C - GO TO (122,109,109,112,112),LP - 109 LSTART = 2 - DO 111 J=MSTART,MSTOP - DO 110 K=NSTART,NSTOP - F(2,J,K) = F(2,J,K)-C1*F(1,J,K) - 110 CONTINUE - 111 CONTINUE - GO TO 115 - 112 DO 114 J=MSTART,MSTOP - DO 113 K=NSTART,NSTOP - F(1,J,K) = F(1,J,K)+TWBYDX*BDXS(J,K) - 113 CONTINUE - 114 CONTINUE - 115 GO TO (122,116,119,119,116),LP - 116 DO 118 J=MSTART,MSTOP - DO 117 K=NSTART,NSTOP - F(L,J,K) = F(L,J,K)-C1*F(LP1,J,K) - 117 CONTINUE - 118 CONTINUE - GO TO 122 - 119 LSTOP = LP1 - DO 121 J=MSTART,MSTOP - DO 120 K=NSTART,NSTOP - F(LP1,J,K) = F(LP1,J,K)-TWBYDX*BDXF(J,K) - 120 CONTINUE - 121 CONTINUE - 122 LUNK = LSTOP-LSTART+1 -C -C ENTER BOUNDARY DATA FOR Y-BOUNDARIES. -C - GO TO (136,123,123,126,126),MP - 123 DO 125 I=LSTART,LSTOP - DO 124 K=NSTART,NSTOP - F(I,2,K) = F(I,2,K)-C2*F(I,1,K) - 124 CONTINUE - 125 CONTINUE - GO TO 129 - 126 DO 128 I=LSTART,LSTOP - DO 127 K=NSTART,NSTOP - F(I,1,K) = F(I,1,K)+TWBYDY*BDYS(I,K) - 127 CONTINUE - 128 CONTINUE - 129 GO TO (136,130,133,133,130),MP - 130 DO 132 I=LSTART,LSTOP - DO 131 K=NSTART,NSTOP - F(I,M,K) = F(I,M,K)-C2*F(I,MP1,K) - 131 CONTINUE - 132 CONTINUE - GO TO 136 - 133 DO 135 I=LSTART,LSTOP - DO 134 K=NSTART,NSTOP - F(I,MP1,K) = F(I,MP1,K)-TWBYDY*BDYF(I,K) - 134 CONTINUE - 135 CONTINUE - 136 CONTINUE -C -C ENTER BOUNDARY DATA FOR Z-BOUNDARIES. -C - GO TO (150,137,137,140,140),NP - 137 DO 139 I=LSTART,LSTOP - DO 138 J=MSTART,MSTOP - F(I,J,2) = F(I,J,2)-C3*F(I,J,1) - 138 CONTINUE - 139 CONTINUE - GO TO 143 - 140 DO 142 I=LSTART,LSTOP - DO 141 J=MSTART,MSTOP - F(I,J,1) = F(I,J,1)+TWBYDZ*BDZS(I,J) - 141 CONTINUE - 142 CONTINUE - 143 GO TO (150,144,147,147,144),NP - 144 DO 146 I=LSTART,LSTOP - DO 145 J=MSTART,MSTOP - F(I,J,N) = F(I,J,N)-C3*F(I,J,NP1) - 145 CONTINUE - 146 CONTINUE - GO TO 150 - 147 DO 149 I=LSTART,LSTOP - DO 148 J=MSTART,MSTOP - F(I,J,NP1) = F(I,J,NP1)-TWBYDZ*BDZF(I,J) - 148 CONTINUE - 149 CONTINUE -C -C DEFINE A,B,C COEFFICIENTS IN W-ARRAY. -C - 150 CONTINUE - IWB = NUNK+1 - IWC = IWB+NUNK - IWW = IWC+NUNK - DO 151 K=1,NUNK - I = IWC+K-1 - W(K) = C3 - W(I) = C3 - I = IWB+K-1 - W(I) = -2.*C3+ELMBDA - 151 CONTINUE - GO TO (155,155,153,152,152),NP - 152 W(IWC) = 2.*C3 - 153 GO TO (155,155,154,154,155),NP - 154 W(IWB-1) = 2.*C3 - 155 CONTINUE - PERTRB = 0. -C -C FOR SINGULAR PROBLEMS ADJUST DATA TO INSURE A SOLUTION WILL EXIST. -C - GO TO (156,172,172,156,172),LP - 156 GO TO (157,172,172,157,172),MP - 157 GO TO (158,172,172,158,172),NP - 158 IF (ELMBDA) 172,160,159 - 159 IERROR = 12 - GO TO 172 - 160 CONTINUE - MSTPM1 = MSTOP-1 - LSTPM1 = LSTOP-1 - NSTPM1 = NSTOP-1 - XLP = (2+LP)/3 - YLP = (2+MP)/3 - ZLP = (2+NP)/3 - S1 = 0. - DO 164 K=2,NSTPM1 - DO 162 J=2,MSTPM1 - DO 161 I=2,LSTPM1 - S1 = S1+F(I,J,K) - 161 CONTINUE - S1 = S1+(F(1,J,K)+F(LSTOP,J,K))/XLP - 162 CONTINUE - S2 = 0. - DO 163 I=2,LSTPM1 - S2 = S2+F(I,1,K)+F(I,MSTOP,K) - 163 CONTINUE - S2 = (S2+(F(1,1,K)+F(1,MSTOP,K)+F(LSTOP,1,K)+F(LSTOP,MSTOP,K))/ - 1 XLP)/YLP - S1 = S1+S2 - 164 CONTINUE - S = (F(1,1,1)+F(LSTOP,1,1)+F(1,1,NSTOP)+F(LSTOP,1,NSTOP)+ - 1 F(1,MSTOP,1)+F(LSTOP,MSTOP,1)+F(1,MSTOP,NSTOP)+ - 2 F(LSTOP,MSTOP,NSTOP))/(XLP*YLP) - DO 166 J=2,MSTPM1 - DO 165 I=2,LSTPM1 - S = S+F(I,J,1)+F(I,J,NSTOP) - 165 CONTINUE - 166 CONTINUE - S2 = 0. - DO 167 I=2,LSTPM1 - S2 = S2+F(I,1,1)+F(I,1,NSTOP)+F(I,MSTOP,1)+F(I,MSTOP,NSTOP) - 167 CONTINUE - S = S2/YLP+S - S2 = 0. - DO 168 J=2,MSTPM1 - S2 = S2+F(1,J,1)+F(1,J,NSTOP)+F(LSTOP,J,1)+F(LSTOP,J,NSTOP) - 168 CONTINUE - S = S2/XLP+S - PERTRB = (S/ZLP+S1)/((LUNK+1.-XLP)*(MUNK+1.-YLP)* - 1 (NUNK+1.-ZLP)) - DO 171 I=1,LUNK - DO 170 J=1,MUNK - DO 169 K=1,NUNK - F(I,J,K) = F(I,J,K)-PERTRB - 169 CONTINUE - 170 CONTINUE - 171 CONTINUE - 172 CONTINUE - NPEROD = 0 - IF (NBDCND .EQ. 0) GO TO 173 - NPEROD = 1 - W(1) = 0. - W(IWW-1) = 0. - 173 CONTINUE - CALL POIS3D (LBDCND,LUNK,C1,MBDCND,MUNK,C2,NPEROD,NUNK,W,W(IWB), - 1 W(IWC),LDIMF,MDIMF,F(LSTART,MSTART,NSTART),IR,W(IWW)) -C -C FILL IN SIDES FOR PERIODIC BOUNDARY CONDITIONS. -C - IF (LP .NE. 1) GO TO 180 - IF (MP .NE. 1) GO TO 175 - DO 174 K=NSTART,NSTOP - F(1,MP1,K) = F(1,1,K) - 174 CONTINUE - MSTOP = MP1 - 175 IF (NP .NE. 1) GO TO 177 - DO 176 J=MSTART,MSTOP - F(1,J,NP1) = F(1,J,1) - 176 CONTINUE - NSTOP = NP1 - 177 DO 179 J=MSTART,MSTOP - DO 178 K=NSTART,NSTOP - F(LP1,J,K) = F(1,J,K) - 178 CONTINUE - 179 CONTINUE - 180 CONTINUE - IF (MP .NE. 1) GO TO 185 - IF (NP .NE. 1) GO TO 182 - DO 181 I=LSTART,LSTOP - F(I,1,NP1) = F(I,1,1) - 181 CONTINUE - NSTOP = NP1 - 182 DO 184 I=LSTART,LSTOP - DO 183 K=NSTART,NSTOP - F(I,MP1,K) = F(I,1,K) - 183 CONTINUE - 184 CONTINUE - 185 CONTINUE - IF (NP .NE. 1) GO TO 188 - DO 187 I=LSTART,LSTOP - DO 186 J=MSTART,MSTOP - F(I,J,NP1) = F(I,J,1) - 186 CONTINUE - 187 CONTINUE - 188 CONTINUE - RETURN - END diff --git a/slatec/hwscrt.f b/slatec/hwscrt.f deleted file mode 100644 index a66af1e..0000000 --- a/slatec/hwscrt.f +++ /dev/null @@ -1,466 +0,0 @@ -*DECK HWSCRT - SUBROUTINE HWSCRT (A, B, M, MBDCND, BDA, BDB, C, D, N, NBDCND, - + BDC, BDD, ELMBDA, F, IDIMF, PERTRB, IERROR, W) -C***BEGIN PROLOGUE HWSCRT -C***PURPOSE Solves the standard five-point finite difference -C approximation to the Helmholtz equation in Cartesian -C coordinates. -C***LIBRARY SLATEC (FISHPACK) -C***CATEGORY I2B1A1A -C***TYPE SINGLE PRECISION (HWSCRT-S) -C***KEYWORDS CARTESIAN, ELLIPTIC, FISHPACK, HELMHOLTZ, PDE -C***AUTHOR Adams, J., (NCAR) -C Swarztrauber, P. N., (NCAR) -C Sweet, R., (NCAR) -C***DESCRIPTION -C -C Subroutine HWSCRT solves the standard five-point finite -C difference approximation to the Helmholtz equation in Cartesian -C coordinates: -C -C (d/dX)(dU/dX) + (d/dY)(dU/dY) + LAMBDA*U = F(X,Y). -C -C -C -C * * * * * * * * Parameter Description * * * * * * * * * * -C -C * * * * * * On Input * * * * * * -C -C A,B -C The range of X, i.e., A .LE. X .LE. B. A must be less than B. -C -C M -C The number of panels into which the interval (A,B) is -C subdivided. Hence, there will be M+1 grid points in the -C X-direction given by X(I) = A+(I-1)DX for I = 1,2,...,M+1, -C where DX = (B-A)/M is the panel width. M must be greater than 3. -C -C MBDCND -C Indicates the type of boundary conditions at X = A and X = B. -C -C = 0 If the solution is periodic in X, i.e., U(I,J) = U(M+I,J). -C = 1 If the solution is specified at X = A and X = B. -C = 2 If the solution is specified at X = A and the derivative of -C the solution with respect to X is specified at X = B. -C = 3 If the derivative of the solution with respect to X is -C specified at X = A and X = B. -C = 4 If the derivative of the solution with respect to X is -C specified at X = A and the solution is specified at X = B. -C -C BDA -C A one-dimensional array of length N+1 that specifies the values -C of the derivative of the solution with respect to X at X = A. -C When MBDCND = 3 or 4, -C -C BDA(J) = (d/dX)U(A,Y(J)), J = 1,2,...,N+1 . -C -C When MBDCND has any other value, BDA is a dummy variable. -C -C BDB -C A one-dimensional array of length N+1 that specifies the values -C of the derivative of the solution with respect to X at X = B. -C When MBDCND = 2 or 3, -C -C BDB(J) = (d/dX)U(B,Y(J)), J = 1,2,...,N+1 . -C -C When MBDCND has any other value BDB is a dummy variable. -C -C C,D -C The range of Y, i.e., C .LE. Y .LE. D. C must be less than D. -C -C N -C The number of panels into which the interval (C,D) is -C subdivided. Hence, there will be N+1 grid points in the -C Y-direction given by Y(J) = C+(J-1)DY for J = 1,2,...,N+1, where -C DY = (D-C)/N is the panel width. N must be greater than 3. -C -C NBDCND -C Indicates the type of boundary conditions at Y = C and Y = D. -C -C = 0 If the solution is periodic in Y, i.e., U(I,J) = U(I,N+J). -C = 1 If the solution is specified at Y = C and Y = D. -C = 2 If the solution is specified at Y = C and the derivative of -C the solution with respect to Y is specified at Y = D. -C = 3 If the derivative of the solution with respect to Y is -C specified at Y = C and Y = D. -C = 4 If the derivative of the solution with respect to Y is -C specified at Y = C and the solution is specified at Y = D. -C -C BDC -C A one-dimensional array of length M+1 that specifies the values -C of the derivative of the solution with respect to Y at Y = C. -C When NBDCND = 3 or 4, -C -C BDC(I) = (d/dY)U(X(I),C), I = 1,2,...,M+1 . -C -C When NBDCND has any other value, BDC is a dummy variable. -C -C BDD -C A one-dimensional array of length M+1 that specifies the values -C of the derivative of the solution with respect to Y at Y = D. -C When NBDCND = 2 or 3, -C -C BDD(I) = (d/dY)U(X(I),D), I = 1,2,...,M+1 . -C -C When NBDCND has any other value, BDD is a dummy variable. -C -C ELMBDA -C The constant LAMBDA in the Helmholtz equation. If -C LAMBDA .GT. 0, a solution may not exist. However, HWSCRT will -C attempt to find a solution. -C -C F -C A two-dimensional array which specifies the values of the right -C side of the Helmholtz equation and boundary values (if any). -C For I = 2,3,...,M and J = 2,3,...,N -C -C F(I,J) = F(X(I),Y(J)). -C -C On the boundaries F is defined by -C -C MBDCND F(1,J) F(M+1,J) -C ------ --------- -------- -C -C 0 F(A,Y(J)) F(A,Y(J)) -C 1 U(A,Y(J)) U(B,Y(J)) -C 2 U(A,Y(J)) F(B,Y(J)) J = 1,2,...,N+1 -C 3 F(A,Y(J)) F(B,Y(J)) -C 4 F(A,Y(J)) U(B,Y(J)) -C -C -C NBDCND F(I,1) F(I,N+1) -C ------ --------- -------- -C -C 0 F(X(I),C) F(X(I),C) -C 1 U(X(I),C) U(X(I),D) -C 2 U(X(I),C) F(X(I),D) I = 1,2,...,M+1 -C 3 F(X(I),C) F(X(I),D) -C 4 F(X(I),C) U(X(I),D) -C -C F must be dimensioned at least (M+1)*(N+1). -C -C NOTE: -C -C If the table calls for both the solution U and the right side F -C at a corner then the solution must be specified. -C -C IDIMF -C The row (or first) dimension of the array F as it appears in the -C program calling HWSCRT. This parameter is used to specify the -C variable dimension of F. IDIMF must be at least M+1 . -C -C W -C A one-dimensional array that must be provided by the user for -C work space. W may require up to 4*(N+1) + -C (13 + INT(log2(N+1)))*(M+1) locations. The actual number of -C locations used is computed by HWSCRT and is returned in location -C W(1). -C -C -C * * * * * * On Output * * * * * * -C -C F -C Contains the solution U(I,J) of the finite difference -C approximation for the grid point (X(I),Y(J)), I = 1,2,...,M+1, -C J = 1,2,...,N+1 . -C -C PERTRB -C If a combination of periodic or derivative boundary conditions -C is specified for a Poisson equation (LAMBDA = 0), a solution may -C not exist. PERTRB is a constant, calculated and subtracted from -C F, which ensures that a solution exists. HWSCRT then computes -C this solution, which is a least squares solution to the original -C approximation. This solution plus any constant is also a -C solution. Hence, the solution is not unique. The value of -C PERTRB should be small compared to the right side F. Otherwise, -C a solution is obtained to an essentially different problem. -C This comparison should always be made to insure that a -C meaningful solution has been obtained. -C -C IERROR -C An error flag that indicates invalid input parameters. Except -C for numbers 0 and 6, a solution is not attempted. -C -C = 0 No error. -C = 1 A .GE. B. -C = 2 MBDCND .LT. 0 or MBDCND .GT. 4 . -C = 3 C .GE. D. -C = 4 N .LE. 3 -C = 5 NBDCND .LT. 0 or NBDCND .GT. 4 . -C = 6 LAMBDA .GT. 0 . -C = 7 IDIMF .LT. M+1 . -C = 8 M .LE. 3 -C -C Since this is the only means of indicating a possibly incorrect -C call to HWSCRT, the user should test IERROR after the call. -C -C W -C W(1) contains the required length of W. -C -C *Long Description: -C -C * * * * * * * Program Specifications * * * * * * * * * * * * -C -C -C Dimension of BDA(N+1),BDB(N+1),BDC(M+1),BDD(M+1),F(IDIMF,N+1), -C Arguments W(see argument list) -C -C Latest June 1, 1976 -C Revision -C -C Subprograms HWSCRT,GENBUN,POISD2,POISN2,POISP2,COSGEN,MERGE, -C Required TRIX,TRI3,PIMACH -C -C Special NONE -C Conditions -C -C Common NONE -C Blocks -C -C I/O NONE -C -C Precision Single -C -C Specialist Roland Sweet -C -C Language FORTRAN -C -C History Standardized September 1, 1973 -C Revised April 1, 1976 -C -C Algorithm The routine defines the finite difference -C equations, incorporates boundary data, and adjusts -C the right side of singular systems and then calls -C GENBUN to solve the system. -C -C Space 13110(octal) = 5704(decimal) locations on the NCAR -C Required Control Data 7600 -C -C Timing and The execution time T on the NCAR Control Data -C Accuracy 7600 for subroutine HWSCRT is roughly proportional -C to M*N*log2(N), but also depends on the input -C parameters NBDCND and MBDCND. Some typical values -C are listed in the table below. -C The solution process employed results in a loss -C of no more than three significant digits for N and -C M as large as 64. More detailed information about -C accuracy can be found in the documentation for -C subroutine GENBUN which is the routine that -C solves the finite difference equations. -C -C -C M(=N) MBDCND NBDCND T(MSECS) -C ----- ------ ------ -------- -C -C 32 0 0 31 -C 32 1 1 23 -C 32 3 3 36 -C 64 0 0 128 -C 64 1 1 96 -C 64 3 3 142 -C -C Portability American National Standards Institute FORTRAN. -C The machine dependent constant PI is defined in -C function PIMACH. -C -C Reference Swarztrauber, P. and R. Sweet, 'Efficient FORTRAN -C Subprograms for The Solution Of Elliptic Equations' -C NCAR TN/IA-109, July, 1975, 138 pp. -C -C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -C -C***REFERENCES P. N. Swarztrauber and R. Sweet, Efficient Fortran -C subprograms for the solution of elliptic equations, -C NCAR TN/IA-109, July 1975, 138 pp. -C***ROUTINES CALLED GENBUN -C***REVISION HISTORY (YYMMDD) -C 801001 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 HWSCRT -C -C - DIMENSION F(IDIMF,*) - DIMENSION BDA(*) ,BDB(*) ,BDC(*) ,BDD(*) , - 1 W(*) -C***FIRST EXECUTABLE STATEMENT HWSCRT - IERROR = 0 - IF (A .GE. B) IERROR = 1 - IF (MBDCND.LT.0 .OR. MBDCND.GT.4) IERROR = 2 - IF (C .GE. D) IERROR = 3 - IF (N .LE. 3) IERROR = 4 - IF (NBDCND.LT.0 .OR. NBDCND.GT.4) IERROR = 5 - IF (IDIMF .LT. M+1) IERROR = 7 - IF (M .LE. 3) IERROR = 8 - IF (IERROR .NE. 0) RETURN - NPEROD = NBDCND - MPEROD = 0 - IF (MBDCND .GT. 0) MPEROD = 1 - DELTAX = (B-A)/M - TWDELX = 2./DELTAX - DELXSQ = 1./DELTAX**2 - DELTAY = (D-C)/N - TWDELY = 2./DELTAY - DELYSQ = 1./DELTAY**2 - NP = NBDCND+1 - NP1 = N+1 - MP = MBDCND+1 - MP1 = M+1 - NSTART = 1 - NSTOP = N - NSKIP = 1 - GO TO (104,101,102,103,104),NP - 101 NSTART = 2 - GO TO 104 - 102 NSTART = 2 - 103 NSTOP = NP1 - NSKIP = 2 - 104 NUNK = NSTOP-NSTART+1 -C -C ENTER BOUNDARY DATA FOR X-BOUNDARIES. -C - MSTART = 1 - MSTOP = M - MSKIP = 1 - GO TO (117,105,106,109,110),MP - 105 MSTART = 2 - GO TO 107 - 106 MSTART = 2 - MSTOP = MP1 - MSKIP = 2 - 107 DO 108 J=NSTART,NSTOP - F(2,J) = F(2,J)-F(1,J)*DELXSQ - 108 CONTINUE - GO TO 112 - 109 MSTOP = MP1 - MSKIP = 2 - 110 DO 111 J=NSTART,NSTOP - F(1,J) = F(1,J)+BDA(J)*TWDELX - 111 CONTINUE - 112 GO TO (113,115),MSKIP - 113 DO 114 J=NSTART,NSTOP - F(M,J) = F(M,J)-F(MP1,J)*DELXSQ - 114 CONTINUE - GO TO 117 - 115 DO 116 J=NSTART,NSTOP - F(MP1,J) = F(MP1,J)-BDB(J)*TWDELX - 116 CONTINUE - 117 MUNK = MSTOP-MSTART+1 -C -C ENTER BOUNDARY DATA FOR Y-BOUNDARIES. -C - GO TO (127,118,118,120,120),NP - 118 DO 119 I=MSTART,MSTOP - F(I,2) = F(I,2)-F(I,1)*DELYSQ - 119 CONTINUE - GO TO 122 - 120 DO 121 I=MSTART,MSTOP - F(I,1) = F(I,1)+BDC(I)*TWDELY - 121 CONTINUE - 122 GO TO (123,125),NSKIP - 123 DO 124 I=MSTART,MSTOP - F(I,N) = F(I,N)-F(I,NP1)*DELYSQ - 124 CONTINUE - GO TO 127 - 125 DO 126 I=MSTART,MSTOP - F(I,NP1) = F(I,NP1)-BDD(I)*TWDELY - 126 CONTINUE -C -C MULTIPLY RIGHT SIDE BY DELTAY**2. -C - 127 DELYSQ = DELTAY*DELTAY - DO 129 I=MSTART,MSTOP - DO 128 J=NSTART,NSTOP - F(I,J) = F(I,J)*DELYSQ - 128 CONTINUE - 129 CONTINUE -C -C DEFINE THE A,B,C COEFFICIENTS IN W-ARRAY. -C - ID2 = MUNK - ID3 = ID2+MUNK - ID4 = ID3+MUNK - S = DELYSQ*DELXSQ - ST2 = 2.*S - DO 130 I=1,MUNK - W(I) = S - J = ID2+I - W(J) = -ST2+ELMBDA*DELYSQ - J = ID3+I - W(J) = S - 130 CONTINUE - IF (MP .EQ. 1) GO TO 131 - W(1) = 0. - W(ID4) = 0. - 131 CONTINUE - GO TO (135,135,132,133,134),MP - 132 W(ID2) = ST2 - GO TO 135 - 133 W(ID2) = ST2 - 134 W(ID3+1) = ST2 - 135 CONTINUE - PERTRB = 0. - IF (ELMBDA) 144,137,136 - 136 IERROR = 6 - GO TO 144 - 137 IF ((NBDCND.EQ.0 .OR. NBDCND.EQ.3) .AND. - 1 (MBDCND.EQ.0 .OR. MBDCND.EQ.3)) GO TO 138 - GO TO 144 -C -C FOR SINGULAR PROBLEMS MUST ADJUST DATA TO INSURE THAT A SOLUTION -C WILL EXIST. -C - 138 A1 = 1. - A2 = 1. - IF (NBDCND .EQ. 3) A2 = 2. - IF (MBDCND .EQ. 3) A1 = 2. - S1 = 0. - MSP1 = MSTART+1 - MSTM1 = MSTOP-1 - NSP1 = NSTART+1 - NSTM1 = NSTOP-1 - DO 140 J=NSP1,NSTM1 - S = 0. - DO 139 I=MSP1,MSTM1 - S = S+F(I,J) - 139 CONTINUE - S1 = S1+S*A1+F(MSTART,J)+F(MSTOP,J) - 140 CONTINUE - S1 = A2*S1 - S = 0. - DO 141 I=MSP1,MSTM1 - S = S+F(I,NSTART)+F(I,NSTOP) - 141 CONTINUE - S1 = S1+S*A1+F(MSTART,NSTART)+F(MSTART,NSTOP)+F(MSTOP,NSTART)+ - 1 F(MSTOP,NSTOP) - S = (2.+(NUNK-2)*A2)*(2.+(MUNK-2)*A1) - PERTRB = S1/S - DO 143 J=NSTART,NSTOP - DO 142 I=MSTART,MSTOP - F(I,J) = F(I,J)-PERTRB - 142 CONTINUE - 143 CONTINUE - PERTRB = PERTRB/DELYSQ -C -C SOLVE THE EQUATION. -C - 144 CALL GENBUN (NPEROD,NUNK,MPEROD,MUNK,W(1),W(ID2+1),W(ID3+1), - 1 IDIMF,F(MSTART,NSTART),IERR1,W(ID4+1)) - W(1) = W(ID4+1)+3*MUNK -C -C FILL IN IDENTICAL VALUES WHEN HAVE PERIODIC BOUNDARY CONDITIONS. -C - IF (NBDCND .NE. 0) GO TO 146 - DO 145 I=MSTART,MSTOP - F(I,NP1) = F(I,1) - 145 CONTINUE - 146 IF (MBDCND .NE. 0) GO TO 148 - DO 147 J=NSTART,NSTOP - F(MP1,J) = F(1,J) - 147 CONTINUE - IF (NBDCND .EQ. 0) F(MP1,NP1) = F(1,NP1) - 148 CONTINUE - RETURN - END diff --git a/slatec/hwscs1.f b/slatec/hwscs1.f deleted file mode 100644 index f57f1d9..0000000 --- a/slatec/hwscs1.f +++ /dev/null @@ -1,264 +0,0 @@ -*DECK HWSCS1 - SUBROUTINE HWSCS1 (INTL, TS, TF, M, MBDCND, BDTS, BDTF, RS, RF, N, - + NBDCND, BDRS, BDRF, ELMBDA, F, IDIMF, PERTRB, W, S, AN, BN, CN, - + R, AM, BM, CM, SINT, BMH) -C***BEGIN PROLOGUE HWSCS1 -C***SUBSIDIARY -C***PURPOSE Subsidiary to HWSCSP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (HWSCS1-S) -C***AUTHOR (UNKNOWN) -C***SEE ALSO HWSCSP -C***ROUTINES CALLED BLKTRI -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891009 Removed unreferenced variables. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE HWSCS1 - DIMENSION F(IDIMF,*) ,BDRS(*) ,BDRF(*) ,BDTS(*) , - 1 BDTF(*) ,AM(*) ,BM(*) ,CM(*) , - 2 AN(*) ,BN(*) ,CN(*) ,S(*) , - 3 R(*) ,SINT(*) ,BMH(*) ,W(*) -C***FIRST EXECUTABLE STATEMENT HWSCS1 - MP1 = M+1 - DTH = (TF-TS)/M - TDT = DTH+DTH - HDTH = DTH/2. - SDTS = 1./(DTH*DTH) - DO 102 I=1,MP1 - THETA = TS+(I-1)*DTH - SINT(I) = SIN(THETA) - IF (SINT(I)) 101,102,101 - 101 T1 = SDTS/SINT(I) - AM(I) = T1*SIN(THETA-HDTH) - CM(I) = T1*SIN(THETA+HDTH) - BM(I) = -(AM(I)+CM(I)) - 102 CONTINUE - NP1 = N+1 - DR = (RF-RS)/N - HDR = DR/2. - TDR = DR+DR - DR2 = DR*DR - CZR = 6.*DTH/(DR2*(COS(TS)-COS(TF))) - DO 103 J=1,NP1 - R(J) = RS+(J-1)*DR - AN(J) = (R(J)-HDR)**2/DR2 - CN(J) = (R(J)+HDR)**2/DR2 - BN(J) = -(AN(J)+CN(J)) - 103 CONTINUE - MP = 1 - NP = 1 -C -C BOUNDARY CONDITION AT PHI=PS -C - GO TO (104,104,105,105,106,106,104,105,106),MBDCND - 104 AT = AM(2) - ITS = 2 - GO TO 107 - 105 AT = AM(1) - ITS = 1 - CM(1) = CM(1)+AM(1) - GO TO 107 - 106 ITS = 1 - BM(1) = -4.*SDTS - CM(1) = -BM(1) -C -C BOUNDARY CONDITION AT PHI=PF -C - 107 GO TO (108,109,109,108,108,109,110,110,110),MBDCND - 108 CT = CM(M) - ITF = M - GO TO 111 - 109 CT = CM(M+1) - AM(M+1) = AM(M+1)+CM(M+1) - ITF = M+1 - GO TO 111 - 110 ITF = M+1 - AM(M+1) = 4.*SDTS - BM(M+1) = -AM(M+1) - 111 WTS = SINT(ITS+1)*AM(ITS+1)/CM(ITS) - WTF = SINT(ITF-1)*CM(ITF-1)/AM(ITF) - ITSP = ITS+1 - ITFM = ITF-1 -C -C BOUNDARY CONDITION AT R=RS -C - ICTR = 0 - GO TO (112,112,113,113,114,114),NBDCND - 112 AR = AN(2) - JRS = 2 - GO TO 118 - 113 AR = AN(1) - JRS = 1 - CN(1) = CN(1)+AN(1) - GO TO 118 - 114 JRS = 2 - ICTR = 1 - S(N) = AN(N)/BN(N) - DO 115 J=3,N - L = N-J+2 - S(L) = AN(L)/(BN(L)-CN(L)*S(L+1)) - 115 CONTINUE - S(2) = -S(2) - DO 116 J=3,N - S(J) = -S(J)*S(J-1) - 116 CONTINUE - WTNM = WTS+WTF - DO 117 I=ITSP,ITFM - WTNM = WTNM+SINT(I) - 117 CONTINUE - YPS = CZR*WTNM*(S(2)-1.) -C -C BOUNDARY CONDITION AT R=RF -C - 118 GO TO (119,120,120,119,119,120),NBDCND - 119 CR = CN(N) - JRF = N - GO TO 121 - 120 CR = CN(N+1) - AN(N+1) = AN(N+1)+CN(N+1) - JRF = N+1 - 121 WRS = AN(JRS+1)*R(JRS)**2/CN(JRS) - WRF = CN(JRF-1)*R(JRF)**2/AN(JRF) - WRZ = AN(JRS)/CZR - JRSP = JRS+1 - JRFM = JRF-1 - MUNK = ITF-ITS+1 - NUNK = JRF-JRS+1 - DO 122 I=ITS,ITF - BMH(I) = BM(I) - 122 CONTINUE - ISING = 0 - GO TO (132,132,123,132,132,123),NBDCND - 123 GO TO (132,132,124,132,132,124,132,124,124),MBDCND - 124 IF (ELMBDA) 132,125,125 - 125 ISING = 1 - SUM = WTS*WRS+WTS*WRF+WTF*WRS+WTF*WRF - IF (ICTR) 126,127,126 - 126 SUM = SUM+WRZ - 127 DO 129 J=JRSP,JRFM - R2 = R(J)**2 - DO 128 I=ITSP,ITFM - SUM = SUM+R2*SINT(I) - 128 CONTINUE - 129 CONTINUE - DO 130 J=JRSP,JRFM - SUM = SUM+(WTS+WTF)*R(J)**2 - 130 CONTINUE - DO 131 I=ITSP,ITFM - SUM = SUM+(WRS+WRF)*SINT(I) - 131 CONTINUE - HNE = SUM - 132 GO TO (133,133,133,133,134,134,133,133,134),MBDCND - 133 BM(ITS) = BMH(ITS)+ELMBDA/SINT(ITS)**2 - 134 GO TO (135,135,135,135,135,135,136,136,136),MBDCND - 135 BM(ITF) = BMH(ITF)+ELMBDA/SINT(ITF)**2 - 136 DO 137 I=ITSP,ITFM - BM(I) = BMH(I)+ELMBDA/SINT(I)**2 - 137 CONTINUE - GO TO (138,138,140,140,142,142,138,140,142),MBDCND - 138 DO 139 J=JRS,JRF - F(2,J) = F(2,J)-AT*F(1,J)/R(J)**2 - 139 CONTINUE - GO TO 142 - 140 DO 141 J=JRS,JRF - F(1,J) = F(1,J)+TDT*BDTS(J)*AT/R(J)**2 - 141 CONTINUE - 142 GO TO (143,145,145,143,143,145,147,147,147),MBDCND - 143 DO 144 J=JRS,JRF - F(M,J) = F(M,J)-CT*F(M+1,J)/R(J)**2 - 144 CONTINUE - GO TO 147 - 145 DO 146 J=JRS,JRF - F(M+1,J) = F(M+1,J)-TDT*BDTF(J)*CT/R(J)**2 - 146 CONTINUE - 147 GO TO (151,151,153,153,148,148),NBDCND - 148 IF (MBDCND-3) 155,149,155 - 149 YHLD = F(ITS,1)-CZR/TDT*(SIN(TF)*BDTF(2)-SIN(TS)*BDTS(2)) - DO 150 I=1,MP1 - F(I,1) = YHLD - 150 CONTINUE - GO TO 155 - 151 RS2 = (RS+DR)**2 - DO 152 I=ITS,ITF - F(I,2) = F(I,2)-AR*F(I,1)/RS2 - 152 CONTINUE - GO TO 155 - 153 DO 154 I=ITS,ITF - F(I,1) = F(I,1)+TDR*BDRS(I)*AR/RS**2 - 154 CONTINUE - 155 GO TO (156,158,158,156,156,158),NBDCND - 156 RF2 = (RF-DR)**2 - DO 157 I=ITS,ITF - F(I,N) = F(I,N)-CR*F(I,N+1)/RF2 - 157 CONTINUE - GO TO 160 - 158 DO 159 I=ITS,ITF - F(I,N+1) = F(I,N+1)-TDR*BDRF(I)*CR/RF**2 - 159 CONTINUE - 160 CONTINUE - PERTRB = 0. - IF (ISING) 161,170,161 - 161 SUM = WTS*WRS*F(ITS,JRS)+WTS*WRF*F(ITS,JRF)+WTF*WRS*F(ITF,JRS)+ - 1 WTF*WRF*F(ITF,JRF) - IF (ICTR) 162,163,162 - 162 SUM = SUM+WRZ*F(ITS,1) - 163 DO 165 J=JRSP,JRFM - R2 = R(J)**2 - DO 164 I=ITSP,ITFM - SUM = SUM+R2*SINT(I)*F(I,J) - 164 CONTINUE - 165 CONTINUE - DO 166 J=JRSP,JRFM - SUM = SUM+R(J)**2*(WTS*F(ITS,J)+WTF*F(ITF,J)) - 166 CONTINUE - DO 167 I=ITSP,ITFM - SUM = SUM+SINT(I)*(WRS*F(I,JRS)+WRF*F(I,JRF)) - 167 CONTINUE - PERTRB = SUM/HNE - DO 169 J=1,NP1 - DO 168 I=1,MP1 - F(I,J) = F(I,J)-PERTRB - 168 CONTINUE - 169 CONTINUE - 170 DO 172 J=JRS,JRF - RSQ = R(J)**2 - DO 171 I=ITS,ITF - F(I,J) = RSQ*F(I,J) - 171 CONTINUE - 172 CONTINUE - IFLG = INTL - 173 CALL BLKTRI (IFLG,NP,NUNK,AN(JRS),BN(JRS),CN(JRS),MP,MUNK, - 1 AM(ITS),BM(ITS),CM(ITS),IDIMF,F(ITS,JRS),IERROR,W) - IFLG = IFLG+1 - IF (IFLG-1) 174,173,174 - 174 IF (NBDCND) 177,175,177 - 175 DO 176 I=1,MP1 - F(I,JRF+1) = F(I,JRS) - 176 CONTINUE - 177 IF (MBDCND) 180,178,180 - 178 DO 179 J=1,NP1 - F(ITF+1,J) = F(ITS,J) - 179 CONTINUE - 180 XP = 0. - IF (ICTR) 181,188,181 - 181 IF (ISING) 186,182,186 - 182 SUM = WTS*F(ITS,2)+WTF*F(ITF,2) - DO 183 I=ITSP,ITFM - SUM = SUM+SINT(I)*F(I,2) - 183 CONTINUE - YPH = CZR*SUM - XP = (F(ITS,1)-YPH)/YPS - DO 185 J=JRS,JRF - XPS = XP*S(J) - DO 184 I=ITS,ITF - F(I,J) = F(I,J)+XPS - 184 CONTINUE - 185 CONTINUE - 186 DO 187 I=1,MP1 - F(I,1) = XP - 187 CONTINUE - 188 RETURN - END diff --git a/slatec/hwscsp.f b/slatec/hwscsp.f deleted file mode 100644 index 1946aee..0000000 --- a/slatec/hwscsp.f +++ /dev/null @@ -1,405 +0,0 @@ -*DECK HWSCSP - SUBROUTINE HWSCSP (INTL, TS, TF, M, MBDCND, BDTS, BDTF, RS, RF, N, - + NBDCND, BDRS, BDRF, ELMBDA, F, IDIMF, PERTRB, IERROR, W) -C***BEGIN PROLOGUE HWSCSP -C***PURPOSE Solve a finite difference approximation to the modified -C Helmholtz equation in spherical coordinates assuming -C axisymmetry (no dependence on longitude). -C***LIBRARY SLATEC (FISHPACK) -C***CATEGORY I2B1A1A -C***TYPE SINGLE PRECISION (HWSCSP-S) -C***KEYWORDS ELLIPTIC, FISHPACK, HELMHOLTZ, PDE, SPHERICAL -C***AUTHOR Adams, J., (NCAR) -C Swarztrauber, P. N., (NCAR) -C Sweet, R., (NCAR) -C***DESCRIPTION -C -C Subroutine HWSCSP solves a finite difference approximation to the -C modified Helmholtz equation in spherical coordinates assuming -C axisymmetry (no dependence on longitude) -C -C (1/R**2)(d/dR)((R**2)(d/dR)U) -C -C + (1/(R**2)SIN(THETA))(d/dTHETA)(SIN(THETA)(d/dTHETA)U) -C -C + (LAMBDA/(RSIN(THETA))**2)U = F(THETA,R). -C -C This two dimensional modified Helmholtz equation results from -C the Fourier transform of the three dimensional Poisson equation -C -C * * * * * * * * * * On Input * * * * * * * * * * -C -C INTL -C = 0 On initial entry to HWSCSP or if any of the arguments -C RS, RF, N, NBDCND are changed from a previous call. -C = 1 If RS, RF, N, NBDCND are all unchanged from previous call -C to HWSCSP. -C -C NOTE A call with INTL=0 takes approximately 1.5 times as -C much time as a call with INTL = 1. Once a call with -C INTL = 0 has been made then subsequent solutions -C corresponding to different F, BDTS, BDTF, BDRS, BDRF can -C be obtained faster with INTL = 1 since initialization is -C not repeated. -C -C TS,TF -C The range of THETA (colatitude), i.e., TS .LE. THETA .LE. TF. -C TS must be less than TF. TS and TF are in radians. A TS of -C zero corresponds to the north pole and a TF of PI corresponds -C to the south pole. -C -C * * * * * * * * * * * * * * IMPORTANT * * * * * * * * * * * * * * -C -C If TF is equal to PI then it must be computed using the statement -C TF = PIMACH(DUM). This insures that TF in the users program is -C equal to PI in this program which permits several tests of the -C input parameters that otherwise would not be possible. -C -C M -C The number of panels into which the interval (TS,TF) is -C subdivided. Hence, there will be M+1 grid points in the -C THETA-direction given by THETA(K) = (I-1)DTHETA+TS for -C I = 1,2,...,M+1, where DTHETA = (TF-TS)/M is the panel width. -C -C MBDCND -C Indicates the type of boundary condition at THETA = TS and -C THETA = TF. -C -C = 1 If the solution is specified at THETA = TS and THETA = TF. -C = 2 If the solution is specified at THETA = TS and the -C derivative of the solution with respect to THETA is -C specified at THETA = TF (see note 2 below). -C = 3 If the derivative of the solution with respect to THETA is -C specified at THETA = TS and THETA = TF (see notes 1,2 -C below). -C = 4 If the derivative of the solution with respect to THETA is -C specified at THETA = TS (see note 1 below) and the -C solution is specified at THETA = TF. -C = 5 If the solution is unspecified at THETA = TS = 0 and the -C solution is specified at THETA = TF. -C = 6 If the solution is unspecified at THETA = TS = 0 and the -C derivative of the solution with respect to THETA is -C specified at THETA = TF (see note 2 below). -C = 7 If the solution is specified at THETA = TS and the -C solution is unspecified at THETA = TF = PI. -C = 8 If the derivative of the solution with respect to THETA is -C specified at THETA = TS (see note 1 below) and the solution -C is unspecified at THETA = TF = PI. -C = 9 If the solution is unspecified at THETA = TS = 0 and -C THETA = TF = PI. -C -C NOTES: 1. If TS = 0, do not use MBDCND = 3,4, or 8, but -C instead use MBDCND = 5,6, or 9 . -C 2. If TF = PI, do not use MBDCND = 2,3, or 6, but -C instead use MBDCND = 7,8, or 9 . -C -C BDTS -C A one-dimensional array of length N+1 that specifies the values -C of the derivative of the solution with respect to THETA at -C THETA = TS. When MBDCND = 3,4, or 8, -C -C BDTS(J) = (d/dTHETA)U(TS,R(J)), J = 1,2,...,N+1 . -C -C When MBDCND has any other value, BDTS is a dummy variable. -C -C BDTF -C A one-dimensional array of length N+1 that specifies the values -C of the derivative of the solution with respect to THETA at -C THETA = TF. When MBDCND = 2,3, or 6, -C -C BDTF(J) = (d/dTHETA)U(TF,R(J)), J = 1,2,...,N+1 . -C -C When MBDCND has any other value, BDTF is a dummy variable. -C -C RS,RF -C The range of R, i.e., RS .LE. R .LT. RF. RS must be less than -C RF. RS must be non-negative. -C -C N -C The number of panels into which the interval (RS,RF) is -C subdivided. Hence, there will be N+1 grid points in the -C R-direction given by R(J) = (J-1)DR+RS for J = 1,2,...,N+1, -C where DR = (RF-RS)/N is the panel width. -C N must be greater than 2 -C -C NBDCND -C Indicates the type of boundary condition at R = RS and R = RF. -C -C = 1 If the solution is specified at R = RS and R = RF. -C = 2 If the solution is specified at R = RS and the derivative -C of the solution with respect to R is specified at R = RF. -C = 3 If the derivative of the solution with respect to R is -C specified at R = RS and R = RF. -C = 4 If the derivative of the solution with respect to R is -C specified at RS and the solution is specified at R = RF. -C = 5 If the solution is unspecified at R = RS = 0 (see note -C below) and the solution is specified at R = RF. -C = 6 If the solution is unspecified at R = RS = 0 (see note -C below) and the derivative of the solution with respect to -C R is specified at R = RF. -C -C NOTE: NBDCND = 5 or 6 cannot be used with -C MBDCND = 1,2,4,5, or 7 (the former indicates that the -C solution is unspecified at R = 0, the latter -C indicates that the solution is specified). -C Use instead -C NBDCND = 1 or 2 . -C -C BDRS -C A one-dimensional array of length M+1 that specifies the values -C of the derivative of the solution with respect to R at R = RS. -C When NBDCND = 3 or 4, -C -C BDRS(I) = (d/dR)U(THETA(I),RS), I = 1,2,...,M+1 . -C -C When NBDCND has any other value, BDRS is a dummy variable. -C -C BDRF -C A one-dimensional array of length M+1 that specifies the values -C of the derivative of the solution with respect to R at R = RF. -C When NBDCND = 2,3, or 6, -C -C BDRF(I) = (d/dR)U(THETA(I),RF), I = 1,2,...,M+1 . -C -C When NBDCND has any other value, BDRF is a dummy variable. -C -C ELMBDA -C The constant LAMBDA in the Helmholtz equation. If -C LAMBDA .GT. 0, a solution may not exist. However, HWSCSP will -C attempt to find a solution. If NBDCND = 5 or 6 or -C MBDCND = 5,6,7,8, or 9, ELMBDA must be zero. -C -C F -C A two-dimensional array that specifies the value of the right -C side of the Helmholtz equation and boundary values (if any). -C for I = 2,3,...,M and J = 2,3,...,N -C -C F(I,J) = F(THETA(I),R(J)). -C -C On the boundaries F is defined by -C -C MBDCND F(1,J) F(M+1,J) -C ------ ---------- ---------- -C -C 1 U(TS,R(J)) U(TF,R(J)) -C 2 U(TS,R(J)) F(TF,R(J)) -C 3 F(TS,R(J)) F(TF,R(J)) -C 4 F(TS,R(J)) U(TF,R(J)) -C 5 F(0,R(J)) U(TF,R(J)) J = 1,2,...,N+1 -C 6 F(0,R(J)) F(TF,R(J)) -C 7 U(TS,R(J)) F(PI,R(J)) -C 8 F(TS,R(J)) F(PI,R(J)) -C 9 F(0,R(J)) F(PI,R(J)) -C -C NBDCND F(I,1) F(I,N+1) -C ------ -------------- -------------- -C -C 1 U(THETA(I),RS) U(THETA(I),RF) -C 2 U(THETA(I),RS) F(THETA(I),RF) -C 3 F(THETA(I),RS) F(THETA(I),RF) -C 4 F(THETA(I),RS) U(THETA(I),RF) I = 1,2,...,M+1 -C 5 F(TS,0) U(THETA(I),RF) -C 6 F(TS,0) F(THETA(I),RF) -C -C F must be dimensioned at least (M+1)*(N+1). -C -C NOTE -C -C If the table calls for both the solution U and the right side F -C at a corner then the solution must be specified. -C -C IDIMF -C The row (or first) dimension of the array F as it appears in the -C program calling HWSCSP. This parameter is used to specify the -C variable dimension of F. IDIMF must be at least M+1 . -C -C W -C A one-dimensional array that must be provided by the user for -C work space. Its length can be computed from the formula below -C which depends on the value of NBDCND. -C -C If NBDCND=2,4 or 6 define NUNK=N -C If NBDCND=1 or 5 define NUNK=N-1 -C If NBDCND=3 define NUNK=N+1 -C -C Now set K=INT(log2(NUNK))+1 and L=2**(K+1) then W must be -C dimensioned at least (K-2)*L+K+5*(M+N)+MAX(2*N,6*M)+23 -C -C **IMPORTANT** For purposes of checking, the required length -C of W is computed by HWSCSP and stored in W(1) -C in floating point format. -C -C -C * * * * * * * * * * On Output * * * * * * * * * * -C -C F -C Contains the solution U(I,J) of the finite difference -C approximation for the grid point (THETA(I),R(J)), -C I = 1,2,...,M+1, J = 1,2,...,N+1 . -C -C PERTRB -C If a combination of periodic or derivative boundary conditions -C is specified for a Poisson equation (LAMBDA = 0), a solution may -C not exist. PERTRB is a constant, calculated and subtracted from -C F, which ensures that a solution exists. HWSCSP then computes -C this solution, which is a least squares solution to the original -C approximation. This solution is not unique and is unnormalized. -C The value of PERTRB should be small compared to the right side -C F. Otherwise , a solution is obtained to an essentially -C different problem. This comparison should always be made to -C insure that a meaningful solution has been obtained. -C -C IERROR -C An error flag that indicates invalid input parameters. Except -C for numbers 0 and 10, a solution is not attempted. -C -C = 1 TS.LT.0. or TF.GT.PI -C = 2 TS.GE.TF -C = 3 M.LT.5 -C = 4 MBDCND.LT.1 or MBDCND.GT.9 -C = 5 RS.LT.0 -C = 6 RS.GE.RF -C = 7 N.LT.5 -C = 8 NBDCND.LT.1 or NBDCND.GT.6 -C = 9 ELMBDA.GT.0 -C = 10 IDIMF.LT.M+1 -C = 11 ELMBDA.NE.0 and MBDCND.GE.5 -C = 12 ELMBDA.NE.0 and NBDCND equals 5 or 6 -C = 13 MBDCND equals 5,6 or 9 and TS.NE.0 -C = 14 MBDCND.GE.7 and TF.NE.PI -C = 15 TS.EQ.0 and MBDCND equals 3,4 or 8 -C = 16 TF.EQ.PI and MBDCND equals 2,3 or 6 -C = 17 NBDCND.GE.5 and RS.NE.0 -C = 18 NBDCND.GE.5 and MBDCND equals 1,2,4,5 or 7 -C -C Since this is the only means of indicating a possibly incorrect -C call to HWSCSP, the user should test IERROR after a call. -C -C W -C Contains intermediate values that must not be destroyed if -C HWSCSP will be called again with INTL = 1. W(1) contains the -C number of locations which W must have. -C -C *Long Description: -C -C * * * * * * * Program Specifications * * * * * * * * * * * * -C -C Dimension of BDTS(N+1),BDTF(N+1),BDRS(M+1),BDRF(M+1), -C Arguments F(IDIMF,N+1),W(see argument list) -C -C Latest June 1979 -C Revision -C -C Subprograms HWSCSP,HWSCS1,BLKTRI,BLKTR1,PROD,PRODP,CPROD,CPRODP -C Required ,COMBP,PPADD,PSGF,BSRH,PPSGF,PPSPF,TEVLS,INDXA, -C ,INDXB,INDXC,R1MACH -C -C Special -C Conditions -C -C Common CBLKT -C Blocks -C -C I/O NONE -C -C Precision Single -C -C Specialist Paul N Swarztrauber -C -C Language FORTRAN -C -C History Version 1 September 1973 -C Version 2 April 1976 -C Version 3 June 1979 -C -C Algorithm The routine defines the finite difference -C equations, incorporates boundary data, and adjusts -C the right side of singular systems and then calls -C BLKTRI to solve the system. -C -C Space -C Required -C -C Portability American National Standards Institute FORTRAN. -C The machine accuracy is set using function R1MACH. -C -C Required NONE -C Resident -C Routines -C -C Reference Swarztrauber,P. and R. Sweet, 'Efficient FORTRAN -C Subprograms for The Solution Of Elliptic Equations' -C NCAR TN/IA-109, July, 1975, 138 pp. -C -C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -C -C***REFERENCES P. N. Swarztrauber and R. Sweet, Efficient Fortran -C subprograms for the solution of elliptic equations, -C NCAR TN/IA-109, July 1975, 138 pp. -C***ROUTINES CALLED HWSCS1, PIMACH -C***REVISION HISTORY (YYMMDD) -C 801001 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 HWSCSP -C - DIMENSION F(IDIMF,*) ,BDTS(*) ,BDTF(*) ,BDRS(*) , - 1 BDRF(*) ,W(*) -C***FIRST EXECUTABLE STATEMENT HWSCSP - PI = PIMACH(DUM) - IERROR = 0 - IF (TS.LT.0. .OR. TF.GT.PI) IERROR = 1 - IF (TS .GE. TF) IERROR = 2 - IF (M .LT. 5) IERROR = 3 - IF (MBDCND.LT.1 .OR. MBDCND.GT.9) IERROR = 4 - IF (RS .LT. 0.) IERROR = 5 - IF (RS .GE. RF) IERROR = 6 - IF (N .LT. 5) IERROR = 7 - IF (NBDCND.LT.1 .OR. NBDCND.GT.6) IERROR = 8 - IF (ELMBDA .GT. 0.) IERROR = 9 - IF (IDIMF .LT. M+1) IERROR = 10 - IF (ELMBDA.NE.0. .AND. MBDCND.GE.5) IERROR = 11 - IF (ELMBDA.NE.0. .AND. (NBDCND.EQ.5 .OR. NBDCND.EQ.6)) IERROR = 12 - IF ((MBDCND.EQ.5 .OR. MBDCND.EQ.6 .OR. MBDCND.EQ.9) .AND. - 1 TS.NE.0.) IERROR = 13 - IF (MBDCND.GE.7 .AND. TF.NE.PI) IERROR = 14 - IF (TS.EQ.0. .AND. - 1 (MBDCND.EQ.4 .OR. MBDCND.EQ.8 .OR. MBDCND.EQ.3)) IERROR = 15 - IF (TF.EQ.PI .AND. - 1 (MBDCND.EQ.2 .OR. MBDCND.EQ.3 .OR. MBDCND.EQ.6)) IERROR = 16 - IF (NBDCND.GE.5 .AND. RS.NE.0.) IERROR = 17 - IF (NBDCND.GE.5 .AND. (MBDCND.EQ.1 .OR. MBDCND.EQ.2 .OR. - 1 MBDCND.EQ.5 .OR. MBDCND.EQ.7)) - 2 IERROR = 18 - IF (IERROR.NE.0 .AND. IERROR.NE.9) RETURN - NCK = N - GO TO (101,103,102,103,101,103),NBDCND - 101 NCK = NCK-1 - GO TO 103 - 102 NCK = NCK+1 - 103 L = 2 - K = 1 - 104 L = L+L - K = K+1 - IF (NCK-L) 105,105,104 - 105 L = L+L - NP1 = N+1 - MP1 = M+1 - I1 = (K-2)*L+K+MAX(2*N,6*M)+13 - I2 = I1+NP1 - I3 = I2+NP1 - I4 = I3+NP1 - I5 = I4+NP1 - I6 = I5+NP1 - I7 = I6+MP1 - I8 = I7+MP1 - I9 = I8+MP1 - I10 = I9+MP1 - W(1) = I10+M - CALL HWSCS1 (INTL,TS,TF,M,MBDCND,BDTS,BDTF,RS,RF,N,NBDCND,BDRS, - 1 BDRF,ELMBDA,F,IDIMF,PERTRB,W(2),W(I1),W(I2),W(I3), - 2 W(I4),W(I5),W(I6),W(I7),W(I8),W(I9),W(I10)) - RETURN - END diff --git a/slatec/hwscyl.f b/slatec/hwscyl.f deleted file mode 100644 index badf2d4..0000000 --- a/slatec/hwscyl.f +++ /dev/null @@ -1,499 +0,0 @@ -*DECK HWSCYL - SUBROUTINE HWSCYL (A, B, M, MBDCND, BDA, BDB, C, D, N, NBDCND, - + BDC, BDD, ELMBDA, F, IDIMF, PERTRB, IERROR, W) -C***BEGIN PROLOGUE HWSCYL -C***PURPOSE Solve a standard finite difference approximation -C to the Helmholtz equation in cylindrical coordinates. -C***LIBRARY SLATEC (FISHPACK) -C***CATEGORY I2B1A1A -C***TYPE SINGLE PRECISION (HWSCYL-S) -C***KEYWORDS CYLINDRICAL, ELLIPTIC, FISHPACK, HELMHOLTZ, PDE -C***AUTHOR Adams, J., (NCAR) -C Swarztrauber, P. N., (NCAR) -C Sweet, R., (NCAR) -C***DESCRIPTION -C -C Subroutine HWSCYL solves a finite difference approximation to the -C Helmholtz equation in cylindrical coordinates: -C -C (1/R)(d/dR)(R(dU/dR)) + (d/dZ)(dU/dZ) -C -C + (LAMBDA/R**2)U = F(R,Z) -C -C This modified Helmholtz equation results from the Fourier -C transform of the three-dimensional Poisson equation. -C -C * * * * * * * * Parameter Description * * * * * * * * * * -C -C * * * * * * On Input * * * * * * -C -C A,B -C The range of R, i.e., A .LE. R .LE. B. A must be less than B -C and A must be non-negative. -C -C M -C The number of panels into which the interval (A,B) is -C subdivided. Hence, there will be M+1 grid points in the -C R-direction given by R(I) = A+(I-1)DR, for I = 1,2,...,M+1, -C where DR = (B-A)/M is the panel width. M must be greater than 3. -C -C MBDCND -C Indicates the type of boundary conditions at R = A and R = B. -C -C = 1 If the solution is specified at R = A and R = B. -C = 2 If the solution is specified at R = A and the derivative of -C the solution with respect to R is specified at R = B. -C = 3 If the derivative of the solution with respect to R is -C specified at R = A (see note below) and R = B. -C = 4 If the derivative of the solution with respect to R is -C specified at R = A (see note below) and the solution is -C specified at R = B. -C = 5 If the solution is unspecified at R = A = 0 and the -C solution is specified at R = B. -C = 6 If the solution is unspecified at R = A = 0 and the -C derivative of the solution with respect to R is specified -C at R = B. -C -C NOTE: If A = 0, do not use MBDCND = 3 or 4, but instead use -C MBDCND = 1,2,5, or 6 . -C -C BDA -C A one-dimensional array of length N+1 that specifies the values -C of the derivative of the solution with respect to R at R = A. -C When MBDCND = 3 or 4, -C -C BDA(J) = (d/dR)U(A,Z(J)), J = 1,2,...,N+1 . -C -C When MBDCND has any other value, BDA is a dummy variable. -C -C BDB -C A one-dimensional array of length N+1 that specifies the values -C of the derivative of the solution with respect to R at R = B. -C When MBDCND = 2,3, or 6, -C -C BDB(J) = (d/dR)U(B,Z(J)), J = 1,2,...,N+1 . -C -C When MBDCND has any other value, BDB is a dummy variable. -C -C C,D -C The range of Z, i.e., C .LE. Z .LE. D. C must be less than D. -C -C N -C The number of panels into which the interval (C,D) is -C subdivided. Hence, there will be N+1 grid points in the -C Z-direction given by Z(J) = C+(J-1)DZ, for J = 1,2,...,N+1, -C where DZ = (D-C)/N is the panel width. N must be greater than 3. -C -C NBDCND -C Indicates the type of boundary conditions at Z = C and Z = D. -C -C = 0 If the solution is periodic in Z, i.e., U(I,1) = U(I,N+1). -C = 1 If the solution is specified at Z = C and Z = D. -C = 2 If the solution is specified at Z = C and the derivative of -C the solution with respect to Z is specified at Z = D. -C = 3 If the derivative of the solution with respect to Z is -C specified at Z = C and Z = D. -C = 4 If the derivative of the solution with respect to Z is -C specified at Z = C and the solution is specified at Z = D. -C -C BDC -C A one-dimensional array of length M+1 that specifies the values -C of the derivative of the solution with respect to Z at Z = C. -C When NBDCND = 3 or 4, -C -C BDC(I) = (d/dZ)U(R(I),C), I = 1,2,...,M+1 . -C -C When NBDCND has any other value, BDC is a dummy variable. -C -C BDD -C A one-dimensional array of length M+1 that specifies the values -C of the derivative of the solution with respect to Z at Z = D. -C When NBDCND = 2 or 3, -C -C BDD(I) = (d/dZ)U(R(I),D), I = 1,2,...,M+1 . -C -C When NBDCND has any other value, BDD is a dummy variable. -C -C ELMBDA -C The constant LAMBDA in the Helmholtz equation. If -C LAMBDA .GT. 0, a solution may not exist. However, HWSCYL will -C attempt to find a solution. LAMBDA must be zero when -C MBDCND = 5 or 6 . -C -C F -C A two-dimensional array that specifies the values of the right -C side of the Helmholtz equation and boundary data (if any). For -C I = 2,3,...,M and J = 2,3,...,N -C -C F(I,J) = F(R(I),Z(J)). -C -C On the boundaries F is defined by -C -C MBDCND F(1,J) F(M+1,J) -C ------ --------- --------- -C -C 1 U(A,Z(J)) U(B,Z(J)) -C 2 U(A,Z(J)) F(B,Z(J)) -C 3 F(A,Z(J)) F(B,Z(J)) J = 1,2,...,N+1 -C 4 F(A,Z(J)) U(B,Z(J)) -C 5 F(0,Z(J)) U(B,Z(J)) -C 6 F(0,Z(J)) F(B,Z(J)) -C -C NBDCND F(I,1) F(I,N+1) -C ------ --------- --------- -C -C 0 F(R(I),C) F(R(I),C) -C 1 U(R(I),C) U(R(I),D) -C 2 U(R(I),C) F(R(I),D) I = 1,2,...,M+1 -C 3 F(R(I),C) F(R(I),D) -C 4 F(R(I),C) U(R(I),D) -C -C F must be dimensioned at least (M+1)*(N+1). -C -C NOTE -C -C If the table calls for both the solution U and the right side F -C at a corner then the solution must be specified. -C -C IDIMF -C The row (or first) dimension of the array F as it appears in the -C program calling HWSCYL. This parameter is used to specify the -C variable dimension of F. IDIMF must be at least M+1 . -C -C W -C A one-dimensional array that must be provided by the user for -C work space. W may require up to 4*(N+1) + -C (13 + INT(log2(N+1)))*(M+1) locations. The actual number of -C locations used is computed by HWSCYL and is returned in location -C W(1). -C -C -C * * * * * * On Output * * * * * * -C -C F -C Contains the solution U(I,J) of the finite difference -C approximation for the grid point (R(I),Z(J)), I = 1,2,...,M+1, -C J = 1,2,...,N+1 . -C -C PERTRB -C If one specifies a combination of periodic, derivative, and -C unspecified boundary conditions for a Poisson equation -C (LAMBDA = 0), a solution may not exist. PERTRB is a constant, -C calculated and subtracted from F, which ensures that a solution -C exists. HWSCYL then computes this solution, which is a least -C squares solution to the original approximation. This solution -C plus any constant is also a solution. Hence, the solution is -C not unique. The value of PERTRB should be small compared to the -C right side F. Otherwise, a solution is obtained to an -C essentially different problem. This comparison should always -C be made to insure that a meaningful solution has been obtained. -C -C IERROR -C An error flag which indicates invalid input parameters. Except -C for numbers 0 and 11, a solution is not attempted. -C -C = 0 No error. -C = 1 A .LT. 0 . -C = 2 A .GE. B. -C = 3 MBDCND .LT. 1 or MBDCND .GT. 6 . -C = 4 C .GE. D. -C = 5 N .LE. 3 -C = 6 NBDCND .LT. 0 or NBDCND .GT. 4 . -C = 7 A = 0, MBDCND = 3 or 4 . -C = 8 A .GT. 0, MBDCND .GE. 5 . -C = 9 A = 0, LAMBDA .NE. 0, MBDCND .GE. 5 . -C = 10 IDIMF .LT. M+1 . -C = 11 LAMBDA .GT. 0 . -C = 12 M .LE. 3 -C -C Since this is the only means of indicating a possibly incorrect -C call to HWSCYL, the user should test IERROR after the call. -C -C W -C W(1) contains the required length of W. -C -C *Long Description: -C -C * * * * * * * Program Specifications * * * * * * * * * * * * -C -C Dimension of BDA(N+1),BDB(N+1),BDC(M+1),BDD(M+1),F(IDIMF,N+1), -C Arguments W(see argument list) -C -C Latest June 1, 1976 -C Revision -C -C Subprograms HWSCYL,GENBUN,POISD2,POISN2,POISP2,COSGEN,MERGE, -C Required TRIX,TRI3,PIMACH -C -C Special NONE -C Conditions -C -C Common NONE -C Blocks -C -C I/O NONE -C -C Precision Single -C -C Specialist Roland Sweet -C -C Language FORTRAN -C -C History Standardized September 1, 1973 -C Revised April 1, 1976 -C -C Algorithm The routine defines the finite difference -C equations, incorporates boundary data, and adjusts -C the right side of singular systems and then calls -C GENBUN to solve the system. -C -C Space 5818(decimal) = 13272(octal) locations on the NCAR -C Required Control Data 7600 -C -C Timing and The execution time T on the NCAR Control Data -C Accuracy 7600 for subroutine HWSCYL is roughly proportional -C to M*N*log2(N), but also depends on the input -C parameters NBDCND and MBDCND. Some typical values -C are listed in the table below. -C The solution process employed results in a loss -C of no more than three significant digits for N and -C M as large as 64. More detailed information about -C accuracy can be found in the documentation for -C subroutine GENBUN which is the routine that -C solves the finite difference equations. -C -C -C M(=N) MBDCND NBDCND T(MSECS) -C ----- ------ ------ -------- -C -C 32 1 0 31 -C 32 1 1 23 -C 32 3 3 36 -C 64 1 0 128 -C 64 1 1 96 -C 64 3 3 142 -C -C Portability American National Standards Institute FORTRAN. -C The machine dependent constant PI is defined in -C function PIMACH. -C -C Required COS -C Resident -C Routines -C -C Reference Swarztrauber, P. and R. Sweet, 'Efficient FORTRAN -C Subprograms for the Solution of Elliptic Equations' -C NCAR TN/IA-109, July, 1975, 138 pp. -C -C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -C -C***REFERENCES P. N. Swarztrauber and R. Sweet, Efficient Fortran -C subprograms for the solution of elliptic equations, -C NCAR TN/IA-109, July 1975, 138 pp. -C***ROUTINES CALLED GENBUN -C***REVISION HISTORY (YYMMDD) -C 801001 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 HWSCYL -C -C - DIMENSION F(IDIMF,*) - DIMENSION BDA(*) ,BDB(*) ,BDC(*) ,BDD(*) , - 1 W(*) -C***FIRST EXECUTABLE STATEMENT HWSCYL - IERROR = 0 - IF (A .LT. 0.) IERROR = 1 - IF (A .GE. B) IERROR = 2 - IF (MBDCND.LE.0 .OR. MBDCND.GE.7) IERROR = 3 - IF (C .GE. D) IERROR = 4 - IF (N .LE. 3) IERROR = 5 - IF (NBDCND.LE.-1 .OR. NBDCND.GE.5) IERROR = 6 - IF (A.EQ.0. .AND. (MBDCND.EQ.3 .OR. MBDCND.EQ.4)) IERROR = 7 - IF (A.GT.0. .AND. MBDCND.GE.5) IERROR = 8 - IF (A.EQ.0. .AND. ELMBDA.NE.0. .AND. MBDCND.GE.5) IERROR = 9 - IF (IDIMF .LT. M+1) IERROR = 10 - IF (M .LE. 3) IERROR = 12 - IF (IERROR .NE. 0) RETURN - MP1 = M+1 - DELTAR = (B-A)/M - DLRBY2 = DELTAR/2. - DLRSQ = DELTAR**2 - NP1 = N+1 - DELTHT = (D-C)/N - DLTHSQ = DELTHT**2 - NP = NBDCND+1 -C -C DEFINE RANGE OF INDICES I AND J FOR UNKNOWNS U(I,J). -C - MSTART = 2 - MSTOP = M - GO TO (104,103,102,101,101,102),MBDCND - 101 MSTART = 1 - GO TO 104 - 102 MSTART = 1 - 103 MSTOP = MP1 - 104 MUNK = MSTOP-MSTART+1 - NSTART = 1 - NSTOP = N - GO TO (108,105,106,107,108),NP - 105 NSTART = 2 - GO TO 108 - 106 NSTART = 2 - 107 NSTOP = NP1 - 108 NUNK = NSTOP-NSTART+1 -C -C DEFINE A,B,C COEFFICIENTS IN W-ARRAY. -C - ID2 = MUNK - ID3 = ID2+MUNK - ID4 = ID3+MUNK - ID5 = ID4+MUNK - ID6 = ID5+MUNK - ISTART = 1 - A1 = 2./DLRSQ - IJ = 0 - IF (MBDCND.EQ.3 .OR. MBDCND.EQ.4) IJ = 1 - IF (MBDCND .LE. 4) GO TO 109 - W(1) = 0. - W(ID2+1) = -2.*A1 - W(ID3+1) = 2.*A1 - ISTART = 2 - IJ = 1 - 109 DO 110 I=ISTART,MUNK - R = A+(I-IJ)*DELTAR - J = ID5+I - W(J) = R - J = ID6+I - W(J) = 1./R**2 - W(I) = (R-DLRBY2)/(R*DLRSQ) - J = ID3+I - W(J) = (R+DLRBY2)/(R*DLRSQ) - K = ID6+I - J = ID2+I - W(J) = -A1+ELMBDA*W(K) - 110 CONTINUE - GO TO (114,111,112,113,114,112),MBDCND - 111 W(ID2) = A1 - GO TO 114 - 112 W(ID2) = A1 - 113 W(ID3+1) = A1*ISTART - 114 CONTINUE -C -C ENTER BOUNDARY DATA FOR R-BOUNDARIES. -C - GO TO (115,115,117,117,119,119),MBDCND - 115 A1 = W(1) - DO 116 J=NSTART,NSTOP - F(2,J) = F(2,J)-A1*F(1,J) - 116 CONTINUE - GO TO 119 - 117 A1 = 2.*DELTAR*W(1) - DO 118 J=NSTART,NSTOP - F(1,J) = F(1,J)+A1*BDA(J) - 118 CONTINUE - 119 GO TO (120,122,122,120,120,122),MBDCND - 120 A1 = W(ID4) - DO 121 J=NSTART,NSTOP - F(M,J) = F(M,J)-A1*F(MP1,J) - 121 CONTINUE - GO TO 124 - 122 A1 = 2.*DELTAR*W(ID4) - DO 123 J=NSTART,NSTOP - F(MP1,J) = F(MP1,J)-A1*BDB(J) - 123 CONTINUE -C -C ENTER BOUNDARY DATA FOR Z-BOUNDARIES. -C - 124 A1 = 1./DLTHSQ - L = ID5-MSTART+1 - GO TO (134,125,125,127,127),NP - 125 DO 126 I=MSTART,MSTOP - F(I,2) = F(I,2)-A1*F(I,1) - 126 CONTINUE - GO TO 129 - 127 A1 = 2./DELTHT - DO 128 I=MSTART,MSTOP - F(I,1) = F(I,1)+A1*BDC(I) - 128 CONTINUE - 129 A1 = 1./DLTHSQ - GO TO (134,130,132,132,130),NP - 130 DO 131 I=MSTART,MSTOP - F(I,N) = F(I,N)-A1*F(I,NP1) - 131 CONTINUE - GO TO 134 - 132 A1 = 2./DELTHT - DO 133 I=MSTART,MSTOP - F(I,NP1) = F(I,NP1)-A1*BDD(I) - 133 CONTINUE - 134 CONTINUE -C -C ADJUST RIGHT SIDE OF SINGULAR PROBLEMS TO INSURE EXISTENCE OF A -C SOLUTION. -C - PERTRB = 0. - IF (ELMBDA) 146,136,135 - 135 IERROR = 11 - GO TO 146 - 136 W(ID5+1) = .5*(W(ID5+2)-DLRBY2) - GO TO (146,146,138,146,146,137),MBDCND - 137 W(ID5+1) = .5*W(ID5+1) - 138 GO TO (140,146,146,139,146),NP - 139 A2 = 2. - GO TO 141 - 140 A2 = 1. - 141 K = ID5+MUNK - W(K) = .5*(W(K-1)+DLRBY2) - S = 0. - DO 143 I=MSTART,MSTOP - S1 = 0. - NSP1 = NSTART+1 - NSTM1 = NSTOP-1 - DO 142 J=NSP1,NSTM1 - S1 = S1+F(I,J) - 142 CONTINUE - K = I+L - S = S+(A2*S1+F(I,NSTART)+F(I,NSTOP))*W(K) - 143 CONTINUE - S2 = M*A+(.75+(M-1)*(M+1))*DLRBY2 - IF (MBDCND .EQ. 3) S2 = S2+.25*DLRBY2 - S1 = (2.+A2*(NUNK-2))*S2 - PERTRB = S/S1 - DO 145 I=MSTART,MSTOP - DO 144 J=NSTART,NSTOP - F(I,J) = F(I,J)-PERTRB - 144 CONTINUE - 145 CONTINUE - 146 CONTINUE -C -C MULTIPLY I-TH EQUATION THROUGH BY DELTHT**2 TO PUT EQUATION INTO -C CORRECT FORM FOR SUBROUTINE GENBUN. -C - DO 148 I=MSTART,MSTOP - K = I-MSTART+1 - W(K) = W(K)*DLTHSQ - J = ID2+K - W(J) = W(J)*DLTHSQ - J = ID3+K - W(J) = W(J)*DLTHSQ - DO 147 J=NSTART,NSTOP - F(I,J) = F(I,J)*DLTHSQ - 147 CONTINUE - 148 CONTINUE - W(1) = 0. - W(ID4) = 0. -C -C CALL GENBUN TO SOLVE THE SYSTEM OF EQUATIONS. -C - CALL GENBUN (NBDCND,NUNK,1,MUNK,W(1),W(ID2+1),W(ID3+1),IDIMF, - 1 F(MSTART,NSTART),IERR1,W(ID4+1)) - W(1) = W(ID4+1)+3*MUNK - IF (NBDCND .NE. 0) GO TO 150 - DO 149 I=MSTART,MSTOP - F(I,NP1) = F(I,1) - 149 CONTINUE - 150 CONTINUE - RETURN - END diff --git a/slatec/hwsplr.f b/slatec/hwsplr.f deleted file mode 100644 index 31a1771..0000000 --- a/slatec/hwsplr.f +++ /dev/null @@ -1,561 +0,0 @@ -*DECK HWSPLR - SUBROUTINE HWSPLR (A, B, M, MBDCND, BDA, BDB, C, D, N, NBDCND, - + BDC, BDD, ELMBDA, F, IDIMF, PERTRB, IERROR, W) -C***BEGIN PROLOGUE HWSPLR -C***PURPOSE Solve a finite difference approximation to the Helmholtz -C equation in polar coordinates. -C***LIBRARY SLATEC (FISHPACK) -C***CATEGORY I2B1A1A -C***TYPE SINGLE PRECISION (HWSPLR-S) -C***KEYWORDS ELLIPTIC, FISHPACK, HELMHOLTZ, PDE, POLAR -C***AUTHOR Adams, J., (NCAR) -C Swarztrauber, P. N., (NCAR) -C Sweet, R., (NCAR) -C***DESCRIPTION -C -C Subroutine HWSPLR solves a finite difference approximation to the -C Helmholtz equation in polar coordinates: -C -C (1/R)(d/dR)(R(dU/dR)) + (1/R**2)(d/dTHETA)(dU/dTHETA) -C -C + LAMBDA*U = F(R,THETA). -C -C -C -C -C * * * * * * * * Parameter Description * * * * * * * * * * -C -C * * * * * * On Input * * * * * * -C -C A,B -C The range of R, i.e., A .LE. R .LE. B. A must be less than B -C and A must be non-negative. -C -C M -C The number of panels into which the interval (A,B) is -C subdivided. Hence, there will be M+1 grid points in the -C R-direction given by R(I) = A+(I-1)DR, for I = 1,2,...,M+1, -C where DR = (B-A)/M is the panel width. M must be greater than 3. -C -C MBDCND -C Indicates the type of boundary condition at R = A and R = B. -C -C = 1 If the solution is specified at R = A and R = B. -C = 2 If the solution is specified at R = A and the derivative of -C the solution with respect to R is specified at R = B. -C = 3 If the derivative of the solution with respect to R is -C specified at R = A (see note below) and R = B. -C = 4 If the derivative of the solution with respect to R is -C specified at R = A (see note below) and the solution is -C specified at R = B. -C = 5 If the solution is unspecified at R = A = 0 and the -C solution is specified at R = B. -C = 6 If the solution is unspecified at R = A = 0 and the -C derivative of the solution with respect to R is specified -C at R = B. -C -C NOTE: If A = 0, do not use MBDCND = 3 or 4, but instead use -C MBDCND = 1,2,5, or 6 . -C -C BDA -C A one-dimensional array of length N+1 that specifies the values -C of the derivative of the solution with respect to R at R = A. -C When MBDCND = 3 or 4, -C -C BDA(J) = (d/dR)U(A,THETA(J)), J = 1,2,...,N+1 . -C -C When MBDCND has any other value, BDA is a dummy variable. -C -C BDB -C A one-dimensional array of length N+1 that specifies the values -C of the derivative of the solution with respect to R at R = B. -C When MBDCND = 2,3, or 6, -C -C BDB(J) = (d/dR)U(B,THETA(J)), J = 1,2,...,N+1 . -C -C When MBDCND has any other value, BDB is a dummy variable. -C -C C,D -C The range of THETA, i.e., C .LE. THETA .LE. D. C must be less -C than D. -C -C N -C The number of panels into which the interval (C,D) is -C subdivided. Hence, there will be N+1 grid points in the -C THETA-direction given by THETA(J) = C+(J-1)DTHETA for -C J = 1,2,...,N+1, where DTHETA = (D-C)/N is the panel width. N -C must be greater than 3. -C -C NBDCND -C Indicates the type of boundary conditions at THETA = C and -C at THETA = D. -C -C = 0 If the solution is periodic in THETA, i.e., -C U(I,J) = U(I,N+J). -C = 1 If the solution is specified at THETA = C and THETA = D -C (see note below). -C = 2 If the solution is specified at THETA = C and the -C derivative of the solution with respect to THETA is -C specified at THETA = D (see note below). -C = 4 If the derivative of the solution with respect to THETA is -C specified at THETA = C and the solution is specified at -C THETA = D (see note below). -C -C NOTE: When NBDCND = 1,2, or 4, do not use MBDCND = 5 or 6 -C (the former indicates that the solution is specified at -C R = 0, the latter indicates the solution is unspecified -C at R = 0). Use instead MBDCND = 1 or 2 . -C -C BDC -C A one-dimensional array of length M+1 that specifies the values -C of the derivative of the solution with respect to THETA at -C THETA = C. When NBDCND = 3 or 4, -C -C BDC(I) = (d/dTHETA)U(R(I),C), I = 1,2,...,M+1 . -C -C When NBDCND has any other value, BDC is a dummy variable. -C -C BDD -C A one-dimensional array of length M+1 that specifies the values -C of the derivative of the solution with respect to THETA at -C THETA = D. When NBDCND = 2 or 3, -C -C BDD(I) = (d/dTHETA)U(R(I),D), I = 1,2,...,M+1 . -C -C When NBDCND has any other value, BDD is a dummy variable. -C -C ELMBDA -C The constant LAMBDA in the Helmholtz equation. If -C LAMBDA .LT. 0, a solution may not exist. However, HWSPLR will -C attempt to find a solution. -C -C F -C A two-dimensional array that specifies the values of the right -C side of the Helmholtz equation and boundary values (if any). -C For I = 2,3,...,M and J = 2,3,...,N -C -C F(I,J) = F(R(I),THETA(J)). -C -C On the boundaries F is defined by -C -C MBDCND F(1,J) F(M+1,J) -C ------ ------------- ------------- -C -C 1 U(A,THETA(J)) U(B,THETA(J)) -C 2 U(A,THETA(J)) F(B,THETA(J)) -C 3 F(A,THETA(J)) F(B,THETA(J)) -C 4 F(A,THETA(J)) U(B,THETA(J)) J = 1,2,...,N+1 -C 5 F(0,0) U(B,THETA(J)) -C 6 F(0,0) F(B,THETA(J)) -C -C NBDCND F(I,1) F(I,N+1) -C ------ --------- --------- -C -C 0 F(R(I),C) F(R(I),C) -C 1 U(R(I),C) U(R(I),D) -C 2 U(R(I),C) F(R(I),D) I = 1,2,...,M+1 -C 3 F(R(I),C) F(R(I),D) -C 4 F(R(I),C) U(R(I),D) -C -C F must be dimensioned at least (M+1)*(N+1). -C -C NOTE -C -C If the table calls for both the solution U and the right side F -C at a corner then the solution must be specified. -C -C -C IDIMF -C The row (or first) dimension of the array F as it appears in the -C program calling HWSPLR. This parameter is used to specify the -C variable dimension of F. IDIMF must be at least M+1 . -C -C W -C A one-dimensional array that must be provided by the user for -C work space. W may require up to 4*(N+1) + -C (13 + INT(log2(N+1)))*(M+1) locations. The actual number of -C locations used is computed by HWSPLR and is returned in location -C W(1). -C -C -C * * * * * * On Output * * * * * * -C -C F -C Contains the solution U(I,J) of the finite difference -C approximation for the grid point (R(I),THETA(J)), -C I = 1,2,...,M+1, J = 1,2,...,N+1 . -C -C PERTRB -C If a combination of periodic, derivative, or unspecified -C boundary conditions is specified for a Poisson equation -C (LAMBDA = 0), a solution may not exist. PERTRB is a constant, -C calculated and subtracted from F, which ensures that a solution -C exists. HWSPLR then computes this solution, which is a least -C squares solution to the original approximation. This solution -C plus any constant is also a solution. Hence, the solution is -C not unique. PERTRB should be small compared to the right side. -C Otherwise, a solution is obtained to an essentially different -C problem. This comparison should always be made to insure that a -C meaningful solution has been obtained. -C -C IERROR -C An error flag that indicates invalid input parameters. Except -C for numbers 0 and 11, a solution is not attempted. -C -C = 0 No error. -C = 1 A .LT. 0 . -C = 2 A .GE. B. -C = 3 MBDCND .LT. 1 or MBDCND .GT. 6 . -C = 4 C .GE. D. -C = 5 N .LE. 3 -C = 6 NBDCND .LT. 0 or .GT. 4 . -C = 7 A = 0, MBDCND = 3 or 4 . -C = 8 A .GT. 0, MBDCND .GE. 5 . -C = 9 MBDCND .GE. 5, NBDCND .NE. 0 and NBDCND .NE. 3 . -C = 10 IDIMF .LT. M+1 . -C = 11 LAMBDA .GT. 0 . -C = 12 M .LE. 3 -C -C Since this is the only means of indicating a possibly incorrect -C call to HWSPLR, the user should test IERROR after the call. -C -C W -C W(1) contains the required length of W. -C -C *Long Description: -C -C * * * * * * * Program Specifications * * * * * * * * * * * * -C -C Dimension of BDA(N+1),BDB(N+1),BDC(M+1),BDD(M+1),F(IDIMF,N+1), -C Arguments W(see argument list) -C -C Latest June 1, 1976 -C Revision -C -C Subprograms HWSPLR,GENBUN,POISD2,POISN2,POISP2,COSGEN,MERGE, -C Required TRIX,TRI3,PIMACH -C -C Special None -C Conditions -C -C Common NONE -C Blocks -C -C I/O -C -C Precision Single -C -C Specialist Roland Sweet -C -C Language FORTRAN -C -C History Standardized April 1, 1973 -C Revised January 1, 1976 -C -C Algorithm The routine defines the finite difference -C equations, incorporates boundary data, and adjusts -C the right side of singular systems and then calls -C GENBUN to solve the system. -C -C Space 13430(octal) = 5912(decimal) locations on the NCAR -C Required Control Data 7600 -C -C Timing and The execution time T on the NCAR Control Data -C Accuracy 7600 for subroutine HWSPLR is roughly proportional -C to M*N*log2(N), but also depends on the input -C parameters NBDCND and MBDCND. Some typical values -C are listed in the table below. -C The solution process employed results in a loss -C of no more than three significant digits for N and -C M as large as 64. More detailed information about -C accuracy can be found in the documentation for -C subroutine GENBUN which is the routine that -C solves the finite difference equations. -C -C -C M(=N) MBDCND NBDCND T(MSECS) -C ----- ------ ------ -------- -C -C 32 1 0 31 -C 32 1 1 23 -C 32 3 3 36 -C 64 1 0 128 -C 64 1 1 96 -C 64 3 3 142 -C -C Portability American National Standards Institute FORTRAN. -C The machine dependent constant PI is defined in -C function PIMACH. -C -C Required COS -C Resident -C Routines -C -C Reference Swarztrauber, P. and R. Sweet, 'Efficient FORTRAN -C Subprograms For The Solution Of Elliptic Equations' -C NCAR TN/IA-109, July, 1975, 138 pp. -C -C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -C -C***REFERENCES P. N. Swarztrauber and R. Sweet, Efficient Fortran -C subprograms for the solution of elliptic equations, -C NCAR TN/IA-109, July 1975, 138 pp. -C***ROUTINES CALLED GENBUN -C***REVISION HISTORY (YYMMDD) -C 801001 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 HWSPLR -C -C - DIMENSION F(IDIMF,*) - DIMENSION BDA(*) ,BDB(*) ,BDC(*) ,BDD(*) , - 1 W(*) -C***FIRST EXECUTABLE STATEMENT HWSPLR - IERROR = 0 - IF (A .LT. 0.) IERROR = 1 - IF (A .GE. B) IERROR = 2 - IF (MBDCND.LE.0 .OR. MBDCND.GE.7) IERROR = 3 - IF (C .GE. D) IERROR = 4 - IF (N .LE. 3) IERROR = 5 - IF (NBDCND.LE.-1 .OR. NBDCND.GE.5) IERROR = 6 - IF (A.EQ.0. .AND. (MBDCND.EQ.3 .OR. MBDCND.EQ.4)) IERROR = 7 - IF (A.GT.0. .AND. MBDCND.GE.5) IERROR = 8 - IF (MBDCND.GE.5 .AND. NBDCND.NE.0 .AND. NBDCND.NE.3) IERROR = 9 - IF (IDIMF .LT. M+1) IERROR = 10 - IF (M .LE. 3) IERROR = 12 - IF (IERROR .NE. 0) RETURN - MP1 = M+1 - DELTAR = (B-A)/M - DLRBY2 = DELTAR/2. - DLRSQ = DELTAR**2 - NP1 = N+1 - DELTHT = (D-C)/N - DLTHSQ = DELTHT**2 - NP = NBDCND+1 -C -C DEFINE RANGE OF INDICES I AND J FOR UNKNOWNS U(I,J). -C - MSTART = 2 - MSTOP = MP1 - GO TO (101,105,102,103,104,105),MBDCND - 101 MSTOP = M - GO TO 105 - 102 MSTART = 1 - GO TO 105 - 103 MSTART = 1 - 104 MSTOP = M - 105 MUNK = MSTOP-MSTART+1 - NSTART = 1 - NSTOP = N - GO TO (109,106,107,108,109),NP - 106 NSTART = 2 - GO TO 109 - 107 NSTART = 2 - 108 NSTOP = NP1 - 109 NUNK = NSTOP-NSTART+1 -C -C DEFINE A,B,C COEFFICIENTS IN W-ARRAY. -C - ID2 = MUNK - ID3 = ID2+MUNK - ID4 = ID3+MUNK - ID5 = ID4+MUNK - ID6 = ID5+MUNK - A1 = 2./DLRSQ - IJ = 0 - IF (MBDCND.EQ.3 .OR. MBDCND.EQ.4) IJ = 1 - DO 110 I=1,MUNK - R = A+(I-IJ)*DELTAR - J = ID5+I - W(J) = R - J = ID6+I - W(J) = 1./R**2 - W(I) = (R-DLRBY2)/(R*DLRSQ) - J = ID3+I - W(J) = (R+DLRBY2)/(R*DLRSQ) - J = ID2+I - W(J) = -A1+ELMBDA - 110 CONTINUE - GO TO (114,111,112,113,114,111),MBDCND - 111 W(ID2) = A1 - GO TO 114 - 112 W(ID2) = A1 - 113 W(ID3+1) = A1 - 114 CONTINUE -C -C ENTER BOUNDARY DATA FOR R-BOUNDARIES. -C - GO TO (115,115,117,117,119,119),MBDCND - 115 A1 = W(1) - DO 116 J=NSTART,NSTOP - F(2,J) = F(2,J)-A1*F(1,J) - 116 CONTINUE - GO TO 119 - 117 A1 = 2.*DELTAR*W(1) - DO 118 J=NSTART,NSTOP - F(1,J) = F(1,J)+A1*BDA(J) - 118 CONTINUE - 119 GO TO (120,122,122,120,120,122),MBDCND - 120 A1 = W(ID4) - DO 121 J=NSTART,NSTOP - F(M,J) = F(M,J)-A1*F(MP1,J) - 121 CONTINUE - GO TO 124 - 122 A1 = 2.*DELTAR*W(ID4) - DO 123 J=NSTART,NSTOP - F(MP1,J) = F(MP1,J)-A1*BDB(J) - 123 CONTINUE -C -C ENTER BOUNDARY DATA FOR THETA-BOUNDARIES. -C - 124 A1 = 1./DLTHSQ - L = ID5-MSTART+1 - LP = ID6-MSTART+1 - GO TO (134,125,125,127,127),NP - 125 DO 126 I=MSTART,MSTOP - J = I+LP - F(I,2) = F(I,2)-A1*W(J)*F(I,1) - 126 CONTINUE - GO TO 129 - 127 A1 = 2./DELTHT - DO 128 I=MSTART,MSTOP - J = I+LP - F(I,1) = F(I,1)+A1*W(J)*BDC(I) - 128 CONTINUE - 129 A1 = 1./DLTHSQ - GO TO (134,130,132,132,130),NP - 130 DO 131 I=MSTART,MSTOP - J = I+LP - F(I,N) = F(I,N)-A1*W(J)*F(I,NP1) - 131 CONTINUE - GO TO 134 - 132 A1 = 2./DELTHT - DO 133 I=MSTART,MSTOP - J = I+LP - F(I,NP1) = F(I,NP1)-A1*W(J)*BDD(I) - 133 CONTINUE - 134 CONTINUE -C -C ADJUST RIGHT SIDE OF EQUATION FOR UNKNOWN AT POLE WHEN HAVE -C DERIVATIVE SPECIFIED BOUNDARY CONDITIONS. -C - IF (MBDCND.GE.5 .AND. NBDCND.EQ.3) - 1 F(1,1) = F(1,1)-(BDD(2)-BDC(2))*4./(N*DELTHT*DLRSQ) -C -C ADJUST RIGHT SIDE OF SINGULAR PROBLEMS TO INSURE EXISTENCE OF A -C SOLUTION. -C - PERTRB = 0. - IF (ELMBDA) 144,136,135 - 135 IERROR = 11 - GO TO 144 - 136 IF (NBDCND.NE.0 .AND. NBDCND.NE.3) GO TO 144 - S2 = 0. - GO TO (144,144,137,144,144,138),MBDCND - 137 W(ID5+1) = .5*(W(ID5+2)-DLRBY2) - S2 = .25*DELTAR - 138 A2 = 2. - IF (NBDCND .EQ. 0) A2 = 1. - J = ID5+MUNK - W(J) = .5*(W(J-1)+DLRBY2) - S = 0. - DO 140 I=MSTART,MSTOP - S1 = 0. - IJ = NSTART+1 - K = NSTOP-1 - DO 139 J=IJ,K - S1 = S1+F(I,J) - 139 CONTINUE - J = I+L - S = S+(A2*S1+F(I,NSTART)+F(I,NSTOP))*W(J) - 140 CONTINUE - S2 = M*A+DELTAR*((M-1)*(M+1)*.5+.25)+S2 - S1 = (2.+A2*(NUNK-2))*S2 - IF (MBDCND .EQ. 3) GO TO 141 - S2 = N*A2*DELTAR/8. - S = S+F(1,1)*S2 - S1 = S1+S2 - 141 CONTINUE - PERTRB = S/S1 - DO 143 I=MSTART,MSTOP - DO 142 J=NSTART,NSTOP - F(I,J) = F(I,J)-PERTRB - 142 CONTINUE - 143 CONTINUE - 144 CONTINUE -C -C MULTIPLY I-TH EQUATION THROUGH BY (R(I)*DELTHT)**2. -C - DO 146 I=MSTART,MSTOP - K = I-MSTART+1 - J = I+LP - A1 = DLTHSQ/W(J) - W(K) = A1*W(K) - J = ID2+K - W(J) = A1*W(J) - J = ID3+K - W(J) = A1*W(J) - DO 145 J=NSTART,NSTOP - F(I,J) = A1*F(I,J) - 145 CONTINUE - 146 CONTINUE - W(1) = 0. - W(ID4) = 0. -C -C CALL GENBUN TO SOLVE THE SYSTEM OF EQUATIONS. -C - CALL GENBUN (NBDCND,NUNK,1,MUNK,W(1),W(ID2+1),W(ID3+1),IDIMF, - 1 F(MSTART,NSTART),IERR1,W(ID4+1)) - IWSTOR = W(ID4+1)+3*MUNK - GO TO (157,157,157,157,148,147),MBDCND -C -C ADJUST THE SOLUTION AS NECESSARY FOR THE PROBLEMS WHERE A = 0. -C - 147 IF (ELMBDA .NE. 0.) GO TO 148 - YPOLE = 0. - GO TO 155 - 148 CONTINUE - J = ID5+MUNK - W(J) = W(ID2)/W(ID3) - DO 149 IP=3,MUNK - I = MUNK-IP+2 - J = ID5+I - LP = ID2+I - K = ID3+I - W(J) = W(I)/(W(LP)-W(K)*W(J+1)) - 149 CONTINUE - W(ID5+1) = -.5*DLTHSQ/(W(ID2+1)-W(ID3+1)*W(ID5+2)) - DO 150 I=2,MUNK - J = ID5+I - W(J) = -W(J)*W(J-1) - 150 CONTINUE - S = 0. - DO 151 J=NSTART,NSTOP - S = S+F(2,J) - 151 CONTINUE - A2 = NUNK - IF (NBDCND .EQ. 0) GO TO 152 - S = S-.5*(F(2,NSTART)+F(2,NSTOP)) - A2 = A2-1. - 152 YPOLE = (.25*DLRSQ*F(1,1)-S/A2)/(W(ID5+1)-1.+ELMBDA*DLRSQ*.25) - DO 154 I=MSTART,MSTOP - K = L+I - DO 153 J=NSTART,NSTOP - F(I,J) = F(I,J)+YPOLE*W(K) - 153 CONTINUE - 154 CONTINUE - 155 DO 156 J=1,NP1 - F(1,J) = YPOLE - 156 CONTINUE - 157 CONTINUE - IF (NBDCND .NE. 0) GO TO 159 - DO 158 I=MSTART,MSTOP - F(I,NP1) = F(I,1) - 158 CONTINUE - 159 CONTINUE - W(1) = IWSTOR - RETURN - END diff --git a/slatec/hwsss1.f b/slatec/hwsss1.f deleted file mode 100644 index 9f5039d..0000000 --- a/slatec/hwsss1.f +++ /dev/null @@ -1,343 +0,0 @@ -*DECK HWSSS1 - SUBROUTINE HWSSS1 (TS, TF, M, MBDCND, BDTS, BDTF, PS, PF, N, - + NBDCND, BDPS, BDPF, ELMBDA, F, IDIMF, PERTRB, AM, BM, CM, SN, - + SS, SINT, D) -C***BEGIN PROLOGUE HWSSS1 -C***SUBSIDIARY -C***PURPOSE Subsidiary to HWSSSP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (HWSSS1-S) -C***AUTHOR (UNKNOWN) -C***SEE ALSO HWSSSP -C***ROUTINES CALLED GENBUN -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891009 Removed unreferenced variables. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE HWSSS1 - DIMENSION F(IDIMF,*) ,BDTS(*) ,BDTF(*) ,BDPS(*) , - 1 BDPF(*) ,AM(*) ,BM(*) ,CM(*) , - 2 SS(*) ,SN(*) ,D(*) ,SINT(*) -C -C***FIRST EXECUTABLE STATEMENT HWSSS1 - MP1 = M+1 - NP1 = N+1 - FN = N - FM = M - DTH = (TF-TS)/FM - HDTH = DTH/2. - TDT = DTH+DTH - DPHI = (PF-PS)/FN - TDP = DPHI+DPHI - DPHI2 = DPHI*DPHI - DTH2 = DTH*DTH - CP = 4./(FN*DTH2) - WP = FN*SIN(HDTH)/4. - DO 102 I=1,MP1 - FIM1 = I-1 - THETA = FIM1*DTH+TS - SINT(I) = SIN(THETA) - IF (SINT(I)) 101,102,101 - 101 T1 = 1./(DTH2*SINT(I)) - AM(I) = T1*SIN(THETA-HDTH) - CM(I) = T1*SIN(THETA+HDTH) - BM(I) = -AM(I)-CM(I)+ELMBDA - 102 CONTINUE - INP = 0 - ISP = 0 -C -C BOUNDARY CONDITION AT THETA=TS -C - MBR = MBDCND+1 - GO TO (103,104,104,105,105,106,106,104,105,106),MBR - 103 ITS = 1 - GO TO 107 - 104 AT = AM(2) - ITS = 2 - GO TO 107 - 105 AT = AM(1) - ITS = 1 - CM(1) = AM(1)+CM(1) - GO TO 107 - 106 AT = AM(2) - INP = 1 - ITS = 2 -C -C BOUNDARY CONDITION THETA=TF -C - 107 GO TO (108,109,110,110,109,109,110,111,111,111),MBR - 108 ITF = M - GO TO 112 - 109 CT = CM(M) - ITF = M - GO TO 112 - 110 CT = CM(M+1) - AM(M+1) = AM(M+1)+CM(M+1) - ITF = M+1 - GO TO 112 - 111 ITF = M - ISP = 1 - CT = CM(M) -C -C COMPUTE HOMOGENEOUS SOLUTION WITH SOLUTION AT POLE EQUAL TO ONE -C - 112 ITSP = ITS+1 - ITFM = ITF-1 - WTS = SINT(ITS+1)*AM(ITS+1)/CM(ITS) - WTF = SINT(ITF-1)*CM(ITF-1)/AM(ITF) - MUNK = ITF-ITS+1 - IF (ISP) 116,116,113 - 113 D(ITS) = CM(ITS)/BM(ITS) - DO 114 I=ITSP,M - D(I) = CM(I)/(BM(I)-AM(I)*D(I-1)) - 114 CONTINUE - SS(M) = -D(M) - IID = M-ITS - DO 115 II=1,IID - I = M-II - SS(I) = -D(I)*SS(I+1) - 115 CONTINUE - SS(M+1) = 1. - 116 IF (INP) 120,120,117 - 117 SN(1) = 1. - D(ITF) = AM(ITF)/BM(ITF) - IID = ITF-2 - DO 118 II=1,IID - I = ITF-II - D(I) = AM(I)/(BM(I)-CM(I)*D(I+1)) - 118 CONTINUE - SN(2) = -D(2) - DO 119 I=3,ITF - SN(I) = -D(I)*SN(I-1) - 119 CONTINUE -C -C BOUNDARY CONDITIONS AT PHI=PS -C - 120 NBR = NBDCND+1 - WPS = 1. - WPF = 1. - GO TO (121,122,122,123,123),NBR - 121 JPS = 1 - GO TO 124 - 122 JPS = 2 - GO TO 124 - 123 JPS = 1 - WPS = .5 -C -C BOUNDARY CONDITION AT PHI=PF -C - 124 GO TO (125,126,127,127,126),NBR - 125 JPF = N - GO TO 128 - 126 JPF = N - GO TO 128 - 127 WPF = .5 - JPF = N+1 - 128 JPSP = JPS+1 - JPFM = JPF-1 - NUNK = JPF-JPS+1 - FJJ = JPFM-JPSP+1 -C -C SCALE COEFFICIENTS FOR SUBROUTINE GENBUN -C - DO 129 I=ITS,ITF - CF = DPHI2*SINT(I)*SINT(I) - AM(I) = CF*AM(I) - BM(I) = CF*BM(I) - CM(I) = CF*CM(I) - 129 CONTINUE - AM(ITS) = 0. - CM(ITF) = 0. - ISING = 0 - GO TO (130,138,138,130,138,138,130,138,130,130),MBR - 130 GO TO (131,138,138,131,138),NBR - 131 IF (ELMBDA) 138,132,132 - 132 ISING = 1 - SUM = WTS*WPS+WTS*WPF+WTF*WPS+WTF*WPF - IF (INP) 134,134,133 - 133 SUM = SUM+WP - 134 IF (ISP) 136,136,135 - 135 SUM = SUM+WP - 136 SUM1 = 0. - DO 137 I=ITSP,ITFM - SUM1 = SUM1+SINT(I) - 137 CONTINUE - SUM = SUM+FJJ*(SUM1+WTS+WTF) - SUM = SUM+(WPS+WPF)*SUM1 - HNE = SUM - 138 GO TO (146,142,142,144,144,139,139,142,144,139),MBR - 139 IF (NBDCND-3) 146,140,146 - 140 YHLD = F(1,JPS)-4./(FN*DPHI*DTH2)*(BDPF(2)-BDPS(2)) - DO 141 J=1,NP1 - F(1,J) = YHLD - 141 CONTINUE - GO TO 146 - 142 DO 143 J=JPS,JPF - F(2,J) = F(2,J)-AT*F(1,J) - 143 CONTINUE - GO TO 146 - 144 DO 145 J=JPS,JPF - F(1,J) = F(1,J)+TDT*BDTS(J)*AT - 145 CONTINUE - 146 GO TO (154,150,152,152,150,150,152,147,147,147),MBR - 147 IF (NBDCND-3) 154,148,154 - 148 YHLD = F(M+1,JPS)-4./(FN*DPHI*DTH2)*(BDPF(M)-BDPS(M)) - DO 149 J=1,NP1 - F(M+1,J) = YHLD - 149 CONTINUE - GO TO 154 - 150 DO 151 J=JPS,JPF - F(M,J) = F(M,J)-CT*F(M+1,J) - 151 CONTINUE - GO TO 154 - 152 DO 153 J=JPS,JPF - F(M+1,J) = F(M+1,J)-TDT*BDTF(J)*CT - 153 CONTINUE - 154 GO TO (159,155,155,157,157),NBR - 155 DO 156 I=ITS,ITF - F(I,2) = F(I,2)-F(I,1)/(DPHI2*SINT(I)*SINT(I)) - 156 CONTINUE - GO TO 159 - 157 DO 158 I=ITS,ITF - F(I,1) = F(I,1)+TDP*BDPS(I)/(DPHI2*SINT(I)*SINT(I)) - 158 CONTINUE - 159 GO TO (164,160,162,162,160),NBR - 160 DO 161 I=ITS,ITF - F(I,N) = F(I,N)-F(I,N+1)/(DPHI2*SINT(I)*SINT(I)) - 161 CONTINUE - GO TO 164 - 162 DO 163 I=ITS,ITF - F(I,N+1) = F(I,N+1)-TDP*BDPF(I)/(DPHI2*SINT(I)*SINT(I)) - 163 CONTINUE - 164 CONTINUE - PERTRB = 0. - IF (ISING) 165,176,165 - 165 SUM = WTS*WPS*F(ITS,JPS)+WTS*WPF*F(ITS,JPF)+WTF*WPS*F(ITF,JPS)+ - 1 WTF*WPF*F(ITF,JPF) - IF (INP) 167,167,166 - 166 SUM = SUM+WP*F(1,JPS) - 167 IF (ISP) 169,169,168 - 168 SUM = SUM+WP*F(M+1,JPS) - 169 DO 171 I=ITSP,ITFM - SUM1 = 0. - DO 170 J=JPSP,JPFM - SUM1 = SUM1+F(I,J) - 170 CONTINUE - SUM = SUM+SINT(I)*SUM1 - 171 CONTINUE - SUM1 = 0. - SUM2 = 0. - DO 172 J=JPSP,JPFM - SUM1 = SUM1+F(ITS,J) - SUM2 = SUM2+F(ITF,J) - 172 CONTINUE - SUM = SUM+WTS*SUM1+WTF*SUM2 - SUM1 = 0. - SUM2 = 0. - DO 173 I=ITSP,ITFM - SUM1 = SUM1+SINT(I)*F(I,JPS) - SUM2 = SUM2+SINT(I)*F(I,JPF) - 173 CONTINUE - SUM = SUM+WPS*SUM1+WPF*SUM2 - PERTRB = SUM/HNE - DO 175 J=1,NP1 - DO 174 I=1,MP1 - F(I,J) = F(I,J)-PERTRB - 174 CONTINUE - 175 CONTINUE -C -C SCALE RIGHT SIDE FOR SUBROUTINE GENBUN -C - 176 DO 178 I=ITS,ITF - CF = DPHI2*SINT(I)*SINT(I) - DO 177 J=JPS,JPF - F(I,J) = CF*F(I,J) - 177 CONTINUE - 178 CONTINUE - CALL GENBUN (NBDCND,NUNK,1,MUNK,AM(ITS),BM(ITS),CM(ITS),IDIMF, - 1 F(ITS,JPS),IERROR,D) - IF (ISING) 186,186,179 - 179 IF (INP) 183,183,180 - 180 IF (ISP) 181,181,186 - 181 DO 182 J=1,NP1 - F(1,J) = 0. - 182 CONTINUE - GO TO 209 - 183 IF (ISP) 186,186,184 - 184 DO 185 J=1,NP1 - F(M+1,J) = 0. - 185 CONTINUE - GO TO 209 - 186 IF (INP) 193,193,187 - 187 SUM = WPS*F(ITS,JPS)+WPF*F(ITS,JPF) - DO 188 J=JPSP,JPFM - SUM = SUM+F(ITS,J) - 188 CONTINUE - DFN = CP*SUM - DNN = CP*((WPS+WPF+FJJ)*(SN(2)-1.))+ELMBDA - DSN = CP*(WPS+WPF+FJJ)*SN(M) - IF (ISP) 189,189,194 - 189 CNP = (F(1,1)-DFN)/DNN - DO 191 I=ITS,ITF - HLD = CNP*SN(I) - DO 190 J=JPS,JPF - F(I,J) = F(I,J)+HLD - 190 CONTINUE - 191 CONTINUE - DO 192 J=1,NP1 - F(1,J) = CNP - 192 CONTINUE - GO TO 209 - 193 IF (ISP) 209,209,194 - 194 SUM = WPS*F(ITF,JPS)+WPF*F(ITF,JPF) - DO 195 J=JPSP,JPFM - SUM = SUM+F(ITF,J) - 195 CONTINUE - DFS = CP*SUM - DSS = CP*((WPS+WPF+FJJ)*(SS(M)-1.))+ELMBDA - DNS = CP*(WPS+WPF+FJJ)*SS(2) - IF (INP) 196,196,200 - 196 CSP = (F(M+1,1)-DFS)/DSS - DO 198 I=ITS,ITF - HLD = CSP*SS(I) - DO 197 J=JPS,JPF - F(I,J) = F(I,J)+HLD - 197 CONTINUE - 198 CONTINUE - DO 199 J=1,NP1 - F(M+1,J) = CSP - 199 CONTINUE - GO TO 209 - 200 RTN = F(1,1)-DFN - RTS = F(M+1,1)-DFS - IF (ISING) 202,202,201 - 201 CSP = 0. - CNP = RTN/DNN - GO TO 205 - 202 IF (ABS(DNN)-ABS(DSN)) 204,204,203 - 203 DEN = DSS-DNS*DSN/DNN - RTS = RTS-RTN*DSN/DNN - CSP = RTS/DEN - CNP = (RTN-CSP*DNS)/DNN - GO TO 205 - 204 DEN = DNS-DSS*DNN/DSN - RTN = RTN-RTS*DNN/DSN - CSP = RTN/DEN - CNP = (RTS-DSS*CSP)/DSN - 205 DO 207 I=ITS,ITF - HLD = CNP*SN(I)+CSP*SS(I) - DO 206 J=JPS,JPF - F(I,J) = F(I,J)+HLD - 206 CONTINUE - 207 CONTINUE - DO 208 J=1,NP1 - F(1,J) = CNP - F(M+1,J) = CSP - 208 CONTINUE - 209 IF (NBDCND) 212,210,212 - 210 DO 211 I=1,MP1 - F(I,JPF+1) = F(I,JPS) - 211 CONTINUE - 212 RETURN - END diff --git a/slatec/hwsssp.f b/slatec/hwsssp.f deleted file mode 100644 index 819f61f..0000000 --- a/slatec/hwsssp.f +++ /dev/null @@ -1,400 +0,0 @@ -*DECK HWSSSP - SUBROUTINE HWSSSP (TS, TF, M, MBDCND, BDTS, BDTF, PS, PF, N, - + NBDCND, BDPS, BDPF, ELMBDA, F, IDIMF, PERTRB, IERROR, W) -C***BEGIN PROLOGUE HWSSSP -C***PURPOSE Solve a finite difference approximation to the Helmholtz -C equation in spherical coordinates and on the surface of the -C unit sphere (radius of 1). -C***LIBRARY SLATEC (FISHPACK) -C***CATEGORY I2B1A1A -C***TYPE SINGLE PRECISION (HWSSSP-S) -C***KEYWORDS ELLIPTIC, FISHPACK, HELMHOLTZ, PDE, SPHERICAL -C***AUTHOR Adams, J., (NCAR) -C Swarztrauber, P. N., (NCAR) -C Sweet, R., (NCAR) -C***DESCRIPTION -C -C Subroutine HWSSSP solves a finite difference approximation to the -C Helmholtz equation in spherical coordinates and on the surface of -C the unit sphere (radius of 1): -C -C (1/SIN(THETA))(d/dTHETA)(SIN(THETA)(dU/dTHETA)) -C -C + (1/SIN(THETA)**2)(d/dPHI)(dU/dPHI) -C -C + LAMBDA*U = F(THETA,PHI) -C -C Where THETA is colatitude and PHI is longitude. -C -C * * * * * * * * Parameter Description * * * * * * * * * * -C -C * * * * * * On Input * * * * * * -C -C TS,TF -C The range of THETA (colatitude), i.e., TS .LE. THETA .LE. TF. -C TS must be less than TF. TS and TF are in radians. A TS of -C zero corresponds to the north pole and a TF of PI corresponds to -C the south pole. -C -C * * * * * * * * * * * * * * IMPORTANT * * * * * * * * * * * * * * -C -C If TF is equal to PI then it must be computed using the statement -C TF = PIMACH(DUM). This insures that TF in the users program is -C equal to PI in this program which permits several tests of the -C input parameters that otherwise would not be possible. -C -C -C M -C The number of panels into which the interval (TS,TF) is -C subdivided. Hence, there will be M+1 grid points in the -C THETA-direction given by THETA(I) = (I-1)DTHETA+TS for -C I = 1,2,...,M+1, where DTHETA = (TF-TS)/M is the panel width. -C M must be greater than 5. -C -C MBDCND -C Indicates the type of boundary condition at THETA = TS and -C THETA = TF. -C -C = 1 If the solution is specified at THETA = TS and THETA = TF. -C = 2 If the solution is specified at THETA = TS and the -C derivative of the solution with respect to THETA is -C specified at THETA = TF (see note 2 below). -C = 3 If the derivative of the solution with respect to THETA is -C specified at THETA = TS and THETA = TF (see notes 1,2 -C below). -C = 4 If the derivative of the solution with respect to THETA is -C specified at THETA = TS (see note 1 below) and the -C solution is specified at THETA = TF. -C = 5 If the solution is unspecified at THETA = TS = 0 and the -C solution is specified at THETA = TF. -C = 6 If the solution is unspecified at THETA = TS = 0 and the -C derivative of the solution with respect to THETA is -C specified at THETA = TF (see note 2 below). -C = 7 If the solution is specified at THETA = TS and the -C solution is unspecified at THETA = TF = PI. -C = 8 If the derivative of the solution with respect to THETA is -C specified at THETA = TS (see note 1 below) and the -C solution is unspecified at THETA = TF = PI. -C = 9 If the solution is unspecified at THETA = TS = 0 and -C THETA = TF = PI. -C -C NOTES: 1. If TS = 0, do not use MBDCND = 3,4, or 8, but -C instead use MBDCND = 5,6, or 9 . -C 2. If TF = PI, do not use MBDCND = 2,3, or 6, but -C instead use MBDCND = 7,8, or 9 . -C -C BDTS -C A one-dimensional array of length N+1 that specifies the values -C of the derivative of the solution with respect to THETA at -C THETA = TS. When MBDCND = 3,4, or 8, -C -C BDTS(J) = (d/dTHETA)U(TS,PHI(J)), J = 1,2,...,N+1 . -C -C When MBDCND has any other value, BDTS is a dummy variable. -C -C BDTF -C A one-dimensional array of length N+1 that specifies the values -C of the derivative of the solution with respect to THETA at -C THETA = TF. When MBDCND = 2,3, or 6, -C -C BDTF(J) = (d/dTHETA)U(TF,PHI(J)), J = 1,2,...,N+1 . -C -C When MBDCND has any other value, BDTF is a dummy variable. -C -C PS,PF -C The range of PHI (longitude), i.e., PS .LE. PHI .LE. PF. PS -C must be less than PF. PS and PF are in radians. If PS = 0 and -C PF = 2*PI, periodic boundary conditions are usually prescribed. -C -C * * * * * * * * * * * * * * IMPORTANT * * * * * * * * * * * * * * -C -C If PF is equal to 2*PI then it must be computed using the -C statement PF = 2.*PIMACH(DUM). This insures that PF in the users -C program is equal to 2*PI in this program which permits tests of -C the input parameters that otherwise would not be possible. -C -C -C N -C The number of panels into which the interval (PS,PF) is -C subdivided. Hence, there will be N+1 grid points in the -C PHI-direction given by PHI(J) = (J-1)DPHI+PS for -C J = 1,2,...,N+1, where DPHI = (PF-PS)/N is the panel width. -C N must be greater than 4. -C -C NBDCND -C Indicates the type of boundary condition at PHI = PS and -C PHI = PF. -C -C = 0 If the solution is periodic in PHI, i.e., -C U(I,J) = U(I,N+J). -C = 1 If the solution is specified at PHI = PS and PHI = PF -C (see note below). -C = 2 If the solution is specified at PHI = PS (see note below) -C and the derivative of the solution with respect to PHI is -C specified at PHI = PF. -C = 3 If the derivative of the solution with respect to PHI is -C specified at PHI = PS and PHI = PF. -C = 4 If the derivative of the solution with respect to PHI is -C specified at PS and the solution is specified at PHI = PF -C (see note below). -C -C NOTE: NBDCND = 1,2, or 4 cannot be used with -C MBDCND = 5,6,7,8, or 9 (the former indicates that the -C solution is specified at a pole, the latter -C indicates that the solution is unspecified). -C Use instead -C MBDCND = 1 or 2 . -C -C BDPS -C A one-dimensional array of length M+1 that specifies the values -C of the derivative of the solution with respect to PHI at -C PHI = PS. When NBDCND = 3 or 4, -C -C BDPS(I) = (d/dPHI)U(THETA(I),PS), I = 1,2,...,M+1 . -C -C When NBDCND has any other value, BDPS is a dummy variable. -C -C BDPF -C A one-dimensional array of length M+1 that specifies the values -C of the derivative of the solution with respect to PHI at -C PHI = PF. When NBDCND = 2 or 3, -C -C BDPF(I) = (d/dPHI)U(THETA(I),PF), I = 1,2,...,M+1 . -C -C When NBDCND has any other value, BDPF is a dummy variable. -C -C ELMBDA -C The constant LAMBDA in the Helmholtz equation. If -C LAMBDA .GT. 0, a solution may not exist. However, HWSSSP will -C attempt to find a solution. -C -C F -C A two-dimensional array that specifies the value of the right -C side of the Helmholtz equation and boundary values (if any). -C For I = 2,3,...,M and J = 2,3,...,N -C -C F(I,J) = F(THETA(I),PHI(J)). -C -C On the boundaries F is defined by -C -C MBDCND F(1,J) F(M+1,J) -C ------ ------------ ------------ -C -C 1 U(TS,PHI(J)) U(TF,PHI(J)) -C 2 U(TS,PHI(J)) F(TF,PHI(J)) -C 3 F(TS,PHI(J)) F(TF,PHI(J)) -C 4 F(TS,PHI(J)) U(TF,PHI(J)) -C 5 F(0,PS) U(TF,PHI(J)) J = 1,2,...,N+1 -C 6 F(0,PS) F(TF,PHI(J)) -C 7 U(TS,PHI(J)) F(PI,PS) -C 8 F(TS,PHI(J)) F(PI,PS) -C 9 F(0,PS) F(PI,PS) -C -C NBDCND F(I,1) F(I,N+1) -C ------ -------------- -------------- -C -C 0 F(THETA(I),PS) F(THETA(I),PS) -C 1 U(THETA(I),PS) U(THETA(I),PF) -C 2 U(THETA(I),PS) F(THETA(I),PF) I = 1,2,...,M+1 -C 3 F(THETA(I),PS) F(THETA(I),PF) -C 4 F(THETA(I),PS) U(THETA(I),PF) -C -C F must be dimensioned at least (M+1)*(N+1). -C -C *NOTE* -C -C If the table calls for both the solution U and the right side F -C at a corner then the solution must be specified. -C -C -C IDIMF -C The row (or first) dimension of the array F as it appears in the -C program calling HWSSSP. This parameter is used to specify the -C variable dimension of F. IDIMF must be at least M+1 . -C -C W -C A one-dimensional array that must be provided by the user for -C work space. W may require up to 4*(N+1)+(16+INT(log2(N+1)))(M+1) -C locations. The actual number of locations used is computed by -C HWSSSP and is output in location W(1). INT( ) denotes the -C FORTRAN integer function. -C -C -C * * * * * * * * * * On Output * * * * * * * * * * -C -C F -C Contains the solution U(I,J) of the finite difference -C approximation for the grid point (THETA(I),PHI(J)), -C I = 1,2,...,M+1, J = 1,2,...,N+1 . -C -C PERTRB -C If one specifies a combination of periodic, derivative or -C unspecified boundary conditions for a Poisson equation -C (LAMBDA = 0), a solution may not exist. PERTRB is a constant, -C calculated and subtracted from F, which ensures that a solution -C exists. HWSSSP then computes this solution, which is a least -C squares solution to the original approximation. This solution -C is not unique and is unnormalized. The value of PERTRB should -C be small compared to the right side F. Otherwise , a solution -C is obtained to an essentially different problem. This comparison -C should always be made to insure that a meaningful solution has -C been obtained. -C -C IERROR -C An error flag that indicates invalid input parameters. Except -C for numbers 0 and 8, a solution is not attempted. -C -C = 0 No error -C = 1 TS.LT.0 or TF.GT.PI -C = 2 TS.GE.TF -C = 3 MBDCND.LT.1 or MBDCND.GT.9 -C = 4 PS.LT.0 or PS.GT.PI+PI -C = 5 PS.GE.PF -C = 6 N.LT.5 -C = 7 M.LT.5 -C = 8 NBDCND.LT.0 or NBDCND.GT.4 -C = 9 ELMBDA.GT.0 -C = 10 IDIMF.LT.M+1 -C = 11 NBDCND equals 1,2 or 4 and MBDCND.GE.5 -C = 12 TS.EQ.0 and MBDCND equals 3,4 or 8 -C = 13 TF.EQ.PI and MBDCND equals 2,3 or 6 -C = 14 MBDCND equals 5,6 or 9 and TS.NE.0 -C = 15 MBDCND.GE.7 and TF.NE.PI -C -C Since this is the only means of indicating a possibly incorrect -C call to HWSSSP, the user should test IERROR after a call. -C -C W -C Contains intermediate values that must not be destroyed if -C HWSSSP will be called again with INTL = 1. W(1) contains the -C required length of W . -C -C *Long Description: -C -C * * * * * * * Program Specifications * * * * * * * * * * * * -C -C Dimension of BDTS(N+1),BDTF(N+1),BDPS(M+1),BDPF(M+1), -C Arguments F(IDIMF,N+1),W(see argument list) -C -C Latest January 1978 -C Revision -C -C -C Subprograms HWSSSP,HWSSS1,GENBUN,POISD2,POISN2,POISP2,COSGEN,ME -C Required TRIX,TRI3,PIMACH -C -C Special NONE -C Conditions -C -C Common NONE -C Blocks -C -C I/O NONE -C -C Precision Single -C -C Specialist Paul Swarztrauber -C -C Language FORTRAN -C -C History Version 1 - September 1973 -C Version 2 - April 1976 -C Version 3 - January 1978 -C -C Algorithm The routine defines the finite difference -C equations, incorporates boundary data, and adjusts -C the right side of singular systems and then calls -C GENBUN to solve the system. -C -C Space -C Required CONTROL DATA 7600 -C -C Timing and The execution time T on the NCAR Control Data -C Accuracy 7600 for subroutine HWSSSP is roughly proportional -C to M*N*log2(N), but also depends on the input -C parameters NBDCND and MBDCND. Some typical values -C are listed in the table below. -C The solution process employed results in a loss -C of no more than three significant digits for N and -C M as large as 64. More detailed information about -C accuracy can be found in the documentation for -C subroutine GENBUN which is the routine that -C solves the finite difference equations. -C -C -C M(=N) MBDCND NBDCND T(MSECS) -C ----- ------ ------ -------- -C -C 32 0 0 31 -C 32 1 1 23 -C 32 3 3 36 -C 64 0 0 128 -C 64 1 1 96 -C 64 3 3 142 -C -C Portability American National Standards Institute FORTRAN. -C The machine dependent constant PI is defined in -C function PIMACH. -C -C Required SIN,COS -C Resident -C Routines -C -C References P. N. Swarztrauber,'The Direct Solution Of The -C Discrete Poisson Equation On The Surface Of a -C Sphere, SIAM J. Numer. Anal.,15(1974), pp 212-215 -C -C Swarztrauber,P. and R. Sweet, 'Efficient FORTRAN -C Subprograms for The Solution of Elliptic Equations' -C NCAR TN/IA-109, July, 1975, 138 pp. -C -C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -C -C***REFERENCES P. N. Swarztrauber and R. Sweet, Efficient Fortran -C subprograms for the solution of elliptic equations, -C NCAR TN/IA-109, July 1975, 138 pp. -C P. N. Swarztrauber, The direct solution of the discrete -C Poisson equation on the surface of a sphere, SIAM -C Journal on Numerical Analysis 15 (1974), pp. 212-215. -C***ROUTINES CALLED HWSSS1, PIMACH -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891009 Removed unreferenced variable. (WRB) -C 891009 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 HWSSSP -C - DIMENSION F(IDIMF,*) ,BDTS(*) ,BDTF(*) ,BDPS(*) , - 1 BDPF(*) ,W(*) -C***FIRST EXECUTABLE STATEMENT HWSSSP - PI = PIMACH(DUM) - TPI = 2.*PI - IERROR = 0 - IF (TS.LT.0. .OR. TF.GT.PI) IERROR = 1 - IF (TS .GE. TF) IERROR = 2 - IF (MBDCND.LT.1 .OR. MBDCND.GT.9) IERROR = 3 - IF (PS.LT.0. .OR. PF.GT.TPI) IERROR = 4 - IF (PS .GE. PF) IERROR = 5 - IF (N .LT. 5) IERROR = 6 - IF (M .LT. 5) IERROR = 7 - IF (NBDCND.LT.0 .OR. NBDCND.GT.4) IERROR = 8 - IF (ELMBDA .GT. 0.) IERROR = 9 - IF (IDIMF .LT. M+1) IERROR = 10 - IF ((NBDCND.EQ.1 .OR. NBDCND.EQ.2 .OR. NBDCND.EQ.4) .AND. - 1 MBDCND.GE.5) IERROR = 11 - IF (TS.EQ.0. .AND. - 1 (MBDCND.EQ.3 .OR. MBDCND.EQ.4 .OR. MBDCND.EQ.8)) IERROR = 12 - IF (TF.EQ.PI .AND. - 1 (MBDCND.EQ.2 .OR. MBDCND.EQ.3 .OR. MBDCND.EQ.6)) IERROR = 13 - IF ((MBDCND.EQ.5 .OR. MBDCND.EQ.6 .OR. MBDCND.EQ.9) .AND. - 1 TS.NE.0.) IERROR = 14 - IF (MBDCND.GE.7 .AND. TF.NE.PI) IERROR = 15 - IF (IERROR.NE.0 .AND. IERROR.NE.9) RETURN - CALL HWSSS1 (TS,TF,M,MBDCND,BDTS,BDTF,PS,PF,N,NBDCND,BDPS,BDPF, - 1 ELMBDA,F,IDIMF,PERTRB,W,W(M+2),W(2*M+3),W(3*M+4), - 2 W(4*M+5),W(5*M+6),W(6*M+7)) - W(1) = W(6*M+7)+6*(M+1) - RETURN - END diff --git a/slatec/i1mach.f b/slatec/i1mach.f deleted file mode 100644 index ad04e7b..0000000 --- a/slatec/i1mach.f +++ /dev/null @@ -1,888 +0,0 @@ -*DECK I1MACH - INTEGER FUNCTION I1MACH (I) -C***BEGIN PROLOGUE I1MACH -C***PURPOSE Return integer machine dependent constants. -C***LIBRARY SLATEC -C***CATEGORY R1 -C***TYPE INTEGER (I1MACH-I) -C***KEYWORDS MACHINE CONSTANTS -C***AUTHOR Fox, P. A., (Bell Labs) -C Hall, A. D., (Bell Labs) -C Schryer, N. L., (Bell Labs) -C***DESCRIPTION -C -C I1MACH can be used to obtain machine-dependent parameters for the -C local machine environment. It is a function subprogram with one -C (input) argument and can be referenced as follows: -C -C K = I1MACH(I) -C -C where I=1,...,16. The (output) value of K above is determined by -C the (input) value of I. The results for various values of I are -C discussed below. -C -C I/O unit numbers: -C I1MACH( 1) = the standard input unit. -C I1MACH( 2) = the standard output unit. -C I1MACH( 3) = the standard punch unit. -C I1MACH( 4) = the standard error message unit. -C -C Words: -C I1MACH( 5) = the number of bits per integer storage unit. -C I1MACH( 6) = the number of characters per integer storage unit. -C -C Integers: -C assume integers are represented in the S-digit, base-A form -C -C sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) -C -C where 0 .LE. X(I) .LT. A for I=0,...,S-1. -C I1MACH( 7) = A, the base. -C I1MACH( 8) = S, the number of base-A digits. -C I1MACH( 9) = A**S - 1, the largest magnitude. -C -C Floating-Point Numbers: -C Assume floating-point numbers are represented in the T-digit, -C base-B form -C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) -C -C where 0 .LE. X(I) .LT. B for I=1,...,T, -C 0 .LT. X(1), and EMIN .LE. E .LE. EMAX. -C I1MACH(10) = B, the base. -C -C Single-Precision: -C I1MACH(11) = T, the number of base-B digits. -C I1MACH(12) = EMIN, the smallest exponent E. -C I1MACH(13) = EMAX, the largest exponent E. -C -C Double-Precision: -C I1MACH(14) = T, the number of base-B digits. -C I1MACH(15) = EMIN, the smallest exponent E. -C I1MACH(16) = EMAX, the largest exponent E. -C -C To alter this function for a particular environment, the desired -C set of DATA statements should be activated by removing the C from -C column 1. Also, the values of I1MACH(1) - I1MACH(4) should be -C checked for consistency with the local operating system. -C -C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for -C a portable library, ACM Transactions on Mathematical -C Software 4, 2 (June 1978), pp. 177-188. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 891012 Added VAX G-floating constants. (WRB) -C 891012 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900618 Added DEC RISC constants. (WRB) -C 900723 Added IBM RS 6000 constants. (WRB) -C 901009 Correct I1MACH(7) for IBM Mainframes. Should be 2 not 16. -C (RWC) -C 910710 Added HP 730 constants. (SMR) -C 911114 Added Convex IEEE constants. (WRB) -C 920121 Added SUN -r8 compiler option constants. (WRB) -C 920229 Added Touchstone Delta i860 constants. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 920625 Added Convex -p8 and -pd8 compiler option constants. -C (BKS, WRB) -C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) -C 930618 Corrected I1MACH(5) for Convex -p8 and -pd8 compiler -C options. (DWL, RWC and WRB). -C***END PROLOGUE I1MACH -C - INTEGER IMACH(16),OUTPUT - SAVE IMACH - EQUIVALENCE (IMACH(4),OUTPUT) -C -C MACHINE CONSTANTS FOR THE AMIGA -C ABSOFT COMPILER -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1022 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE APOLLO -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 129 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1025 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM -C -C DATA IMACH( 1) / 7 / -C DATA IMACH( 2) / 2 / -C DATA IMACH( 3) / 2 / -C DATA IMACH( 4) / 2 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 33 / -C DATA IMACH( 9) / Z1FFFFFFFF / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -256 / -C DATA IMACH(13) / 255 / -C DATA IMACH(14) / 60 / -C DATA IMACH(15) / -256 / -C DATA IMACH(16) / 255 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 48 / -C DATA IMACH( 6) / 6 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 39 / -C DATA IMACH( 9) / O0007777777777777 / -C DATA IMACH(10) / 8 / -C DATA IMACH(11) / 13 / -C DATA IMACH(12) / -50 / -C DATA IMACH(13) / 76 / -C DATA IMACH(14) / 26 / -C DATA IMACH(15) / -50 / -C DATA IMACH(16) / 76 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 48 / -C DATA IMACH( 6) / 6 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 39 / -C DATA IMACH( 9) / O0007777777777777 / -C DATA IMACH(10) / 8 / -C DATA IMACH(11) / 13 / -C DATA IMACH(12) / -50 / -C DATA IMACH(13) / 76 / -C DATA IMACH(14) / 26 / -C DATA IMACH(15) / -32754 / -C DATA IMACH(16) / 32780 / -C -C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 64 / -C DATA IMACH( 6) / 8 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 9223372036854775807 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -4095 / -C DATA IMACH(13) / 4094 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -4095 / -C DATA IMACH(16) / 4094 / -C -C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6LOUTPUT/ -C DATA IMACH( 5) / 60 / -C DATA IMACH( 6) / 10 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 48 / -C DATA IMACH( 9) / 00007777777777777777B / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -929 / -C DATA IMACH(13) / 1070 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -929 / -C DATA IMACH(16) / 1069 / -C -C MACHINE CONSTANTS FOR THE CELERITY C1260 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 0 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / Z'7FFFFFFF' / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1022 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fn COMPILER OPTION -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fi COMPILER OPTION -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -p8 COMPILER OPTION -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 64 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 9223372036854775807 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 53 / -C DATA IMACH(12) / -1023 / -C DATA IMACH(13) / 1023 / -C DATA IMACH(14) / 113 / -C DATA IMACH(15) / -16383 / -C DATA IMACH(16) / 16383 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -pd8 COMPILER OPTION -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 64 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 9223372036854775807 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 53 / -C DATA IMACH(12) / -1023 / -C DATA IMACH(13) / 1023 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE CRAY -C USING THE 46 BIT INTEGER COMPILER OPTION -C -C DATA IMACH( 1) / 100 / -C DATA IMACH( 2) / 101 / -C DATA IMACH( 3) / 102 / -C DATA IMACH( 4) / 101 / -C DATA IMACH( 5) / 64 / -C DATA IMACH( 6) / 8 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 46 / -C DATA IMACH( 9) / 1777777777777777B / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -8189 / -C DATA IMACH(13) / 8190 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -8099 / -C DATA IMACH(16) / 8190 / -C -C MACHINE CONSTANTS FOR THE CRAY -C USING THE 64 BIT INTEGER COMPILER OPTION -C -C DATA IMACH( 1) / 100 / -C DATA IMACH( 2) / 101 / -C DATA IMACH( 3) / 102 / -C DATA IMACH( 4) / 101 / -C DATA IMACH( 5) / 64 / -C DATA IMACH( 6) / 8 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 777777777777777777777B / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -8189 / -C DATA IMACH(13) / 8190 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -8099 / -C DATA IMACH(16) / 8190 / -C -C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 -C -C DATA IMACH( 1) / 11 / -C DATA IMACH( 2) / 12 / -C DATA IMACH( 3) / 8 / -C DATA IMACH( 4) / 10 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 16 / -C DATA IMACH(11) / 6 / -C DATA IMACH(12) / -64 / -C DATA IMACH(13) / 63 / -C DATA IMACH(14) / 14 / -C DATA IMACH(15) / -64 / -C DATA IMACH(16) / 63 / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING G_FLOAT -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING IEEE_FLOAT -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE DEC RISC -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING D_FLOATING -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 56 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING G_FLOATING -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE ELXSI 6400 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 32 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1022 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE HARRIS 220 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 0 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 24 / -C DATA IMACH( 6) / 3 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 23 / -C DATA IMACH( 9) / 8388607 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 23 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 38 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 43 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 6 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 35 / -C DATA IMACH( 9) / O377777777777 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 27 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 63 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HP 730 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C 3 WORD DOUBLE PRECISION OPTION WITH FTN4 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 4 / -C DATA IMACH( 4) / 1 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 23 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 39 / -C DATA IMACH(15) / -128 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C 4 WORD DOUBLE PRECISION OPTION WITH FTN4 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 4 / -C DATA IMACH( 4) / 1 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 23 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 55 / -C DATA IMACH(15) / -128 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HP 9000 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 7 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 32 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1015 / -C DATA IMACH(16) / 1017 / -C -C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, -C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND -C THE PERKIN ELMER (INTERDATA) 7/32. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / Z7FFFFFFF / -C DATA IMACH(10) / 16 / -C DATA IMACH(11) / 6 / -C DATA IMACH(12) / -64 / -C DATA IMACH(13) / 63 / -C DATA IMACH(14) / 14 / -C DATA IMACH(15) / -64 / -C DATA IMACH(16) / 63 / -C -C MACHINE CONSTANTS FOR THE IBM PC -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 0 / -C DATA IMACH( 4) / 0 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE IBM RS 6000 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 0 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE INTEL i860 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 5 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 35 / -C DATA IMACH( 9) / "377777777777 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 27 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 54 / -C DATA IMACH(15) / -101 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 5 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 35 / -C DATA IMACH( 9) / "377777777777 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 27 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 62 / -C DATA IMACH(15) / -128 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 32-BIT INTEGER ARITHMETIC. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 56 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 16-BIT INTEGER ARITHMETIC. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 56 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE SILICON GRAPHICS -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE SUN -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE SUN -C USING THE -r8 COMPILER OPTION -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 53 / -C DATA IMACH(12) / -1021 / -C DATA IMACH(13) / 1024 / -C DATA IMACH(14) / 113 / -C DATA IMACH(15) / -16381 / -C DATA IMACH(16) / 16384 / -C -C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 1 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 35 / -C DATA IMACH( 9) / O377777777777 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 27 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 60 / -C DATA IMACH(15) / -1024 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR -C -C DATA IMACH( 1) / 1 / -C DATA IMACH( 2) / 1 / -C DATA IMACH( 3) / 0 / -C DATA IMACH( 4) / 1 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 56 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 / -C -C***FIRST EXECUTABLE STATEMENT I1MACH - IF (I .LT. 1 .OR. I .GT. 16) GO TO 10 -C - I1MACH = IMACH(I) - RETURN -C - 10 CONTINUE - WRITE (UNIT = OUTPUT, FMT = 9000) - 9000 FORMAT ('1ERROR 1 IN I1MACH - I OUT OF BOUNDS') -C -C CALL FDUMP -C - STOP - END diff --git a/slatec/i1merg.f b/slatec/i1merg.f deleted file mode 100644 index 7b47470..0000000 --- a/slatec/i1merg.f +++ /dev/null @@ -1,60 +0,0 @@ -*DECK I1MERG - SUBROUTINE I1MERG (ICOS, I1, M1, I2, M2, I3) -C***BEGIN PROLOGUE I1MERG -C***SUBSIDIARY -C***PURPOSE Merge two strings of ascending integers. -C***LIBRARY SLATEC -C***TYPE INTEGER (S1MERG-S, D1MERG-D, C1MERG-C, I1MERG-I) -C***AUTHOR Boland, W. Robert, (LANL) -C Clemens, Reginald, (PLK) -C***DESCRIPTION -C -C This subroutine merges two ascending strings of integers in the -C array ICOS. The first string is of length M1 and starts at -C ICOS(I1+1). The second string is of length M2 and starts at -C ICOS(I2+1). The merged string goes into ICOS(I3+1). -C -C***ROUTINES CALLED ICOPY -C***REVISION HISTORY (YYMMDD) -C 920202 DATE WRITTEN -C***END PROLOGUE I1MERG - INTEGER I1, I2, I3, M1, M2 - REAL ICOS(*) -C - INTEGER J1, J2, J3 -C -C***FIRST EXECUTABLE STATEMENT I1MERG - IF (M1.EQ.0 .AND. M2.EQ.0) RETURN -C - IF (M1.EQ.0 .AND. M2.NE.0) THEN - CALL ICOPY (M2, ICOS(I2+1), 1, ICOS(I3+1), 1) - RETURN - ENDIF -C - IF (M1.NE.0 .AND. M2.EQ.0) THEN - CALL ICOPY (M1, ICOS(I1+1), 1, ICOS(I3+1), 1) - RETURN - ENDIF -C - J1 = 1 - J2 = 1 - J3 = 1 -C - 10 IF (ICOS(I1+J1) .LE. ICOS(I2+J2)) THEN - ICOS(I3+J3) = ICOS(I1+J1) - J1 = J1+1 - IF (J1 .GT. M1) THEN - CALL ICOPY (M2-J2+1, ICOS(I2+J2), 1, ICOS(I3+J3+1), 1) - RETURN - ENDIF - ELSE - ICOS(I3+J3) = ICOS(I2+J2) - J2 = J2+1 - IF (J2 .GT. M2) THEN - CALL ICOPY (M1-J1+1, ICOS(I1+J1), 1, ICOS(I3+J3+1), 1) - RETURN - ENDIF - ENDIF - J3 = J3+1 - GO TO 10 - END diff --git a/slatec/icamax.f b/slatec/icamax.f deleted file mode 100644 index 761e7bd..0000000 --- a/slatec/icamax.f +++ /dev/null @@ -1,88 +0,0 @@ -*DECK ICAMAX - INTEGER FUNCTION ICAMAX (N, CX, INCX) -C***BEGIN PROLOGUE ICAMAX -C***PURPOSE Find the smallest index of the component of a complex -C vector having the maximum sum of magnitudes of real -C and imaginary parts. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A2 -C***TYPE COMPLEX (ISAMAX-S, IDAMAX-D, ICAMAX-C) -C***KEYWORDS BLAS, LINEAR ALGEBRA, MAXIMUM COMPONENT, 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 CX complex vector with N elements -C INCX storage spacing between elements of CX -C -C --Output-- -C ICAMAX smallest index (zero if N .LE. 0) -C -C Returns the smallest index of the component of CX having the -C largest sum of magnitudes of real and imaginary parts. -C ICAMAX = first I, I = 1 to N, to maximize -C ABS(REAL(CX(IX+(I-1)*INCX))) + ABS(IMAG(CX(IX+(I-1)*INCX))), -C where IX = 1 if INCX .GE. 0, else IX = 1+(1-N)*INCX. -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 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900821 Modified to correct problem with a negative increment. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE ICAMAX - COMPLEX CX(*) - REAL SMAX, XMAG - INTEGER I, INCX, IX, N - COMPLEX ZDUM - REAL CABS1 - CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) -C***FIRST EXECUTABLE STATEMENT ICAMAX - ICAMAX = 0 - IF (N .LE. 0) RETURN - ICAMAX = 1 - IF (N .EQ. 1) RETURN -C - IF (INCX .EQ. 1) GOTO 20 -C -C Code for increment not equal to 1. -C - IX = 1 - IF (INCX .LT. 0) IX = (-N+1)*INCX + 1 - SMAX = CABS1(CX(IX)) - IX = IX + INCX - DO 10 I = 2,N - XMAG = CABS1(CX(IX)) - IF (XMAG .GT. SMAX) THEN - ICAMAX = I - SMAX = XMAG - ENDIF - 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 - XMAG = CABS1(CX(I)) - IF (XMAG .GT. SMAX) THEN - ICAMAX = I - SMAX = XMAG - ENDIF - 30 CONTINUE - RETURN - END diff --git a/slatec/icopy.f b/slatec/icopy.f deleted file mode 100644 index 92f5f9f..0000000 --- a/slatec/icopy.f +++ /dev/null @@ -1,86 +0,0 @@ -*DECK ICOPY - SUBROUTINE ICOPY (N, IX, INCX, IY, INCY) -C***BEGIN PROLOGUE ICOPY -C***PURPOSE Copy a vector. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A5 -C***TYPE INTEGER (ICOPY-S, DCOPY-D, CCOPY-C, ICOPY-I) -C***KEYWORDS BLAS, COPY, LINEAR ALGEBRA, VECTOR -C***AUTHOR Boland, W. Robert, (LANL) -C Clemens, Reginald, (PLK) -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 IX integer vector with N elements -C INCX storage spacing between elements of IX -C IY integer vector with N elements -C INCY storage spacing between elements of IY -C -C --Output-- -C IY copy of vector IX (unchanged if N .LE. 0) -C -C Copy integer IX to integer IY. -C For I = 0 to N-1, copy IX(LX+I*INCX) to IY(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 930201 DATE WRITTEN -C***END PROLOGUE ICOPY - INTEGER IX(*), IY(*) -C***FIRST EXECUTABLE STATEMENT ICOPY - IF (N .LE. 0) RETURN - IF (INCX .EQ. INCY) IF (INCX-1) 5,20,60 -C -C Code for unequal or nonpositive increments. -C - 5 IIX = 1 - IIY = 1 - IF (INCX .LT. 0) IIX = (-N+1)*INCX + 1 - IF (INCY .LT. 0) IIY = (-N+1)*INCY + 1 - DO 10 I = 1,N - IY(IIY) = IX(IIX) - IIX = IIX + INCX - IIY = IIY + INCY - 10 CONTINUE - RETURN -C -C Code for both increments equal to 1. -C -C Clean-up loop so remaining vector length is a multiple of 7. -C - 20 M = MOD(N,7) - IF (M .EQ. 0) GO TO 40 - DO 30 I = 1,M - IY(I) = IX(I) - 30 CONTINUE - IF (N .LT. 7) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,7 - IY(I) = IX(I) - IY(I+1) = IX(I+1) - IY(I+2) = IX(I+2) - IY(I+3) = IX(I+3) - IY(I+4) = IX(I+4) - IY(I+5) = IX(I+5) - IY(I+6) = IX(I+6) - 50 CONTINUE - RETURN -C -C Code for equal, positive, non-unit increments. -C - 60 NS = N*INCX - DO 70 I = 1,NS,INCX - IY(I) = IX(I) - 70 CONTINUE - RETURN - END diff --git a/slatec/idamax.f b/slatec/idamax.f deleted file mode 100644 index f6e6afa..0000000 --- a/slatec/idamax.f +++ /dev/null @@ -1,82 +0,0 @@ -*DECK IDAMAX - INTEGER FUNCTION IDAMAX (N, DX, INCX) -C***BEGIN PROLOGUE IDAMAX -C***PURPOSE Find the smallest index of that component of a vector -C having the maximum magnitude. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A2 -C***TYPE DOUBLE PRECISION (ISAMAX-S, IDAMAX-D, ICAMAX-C) -C***KEYWORDS BLAS, LINEAR ALGEBRA, MAXIMUM COMPONENT, 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 DX double precision vector with N elements -C INCX storage spacing between elements of DX -C -C --Output-- -C IDAMAX smallest index (zero if N .LE. 0) -C -C Find smallest index of maximum magnitude of double precision DX. -C IDAMAX = first I, I = 1 to N, to maximize ABS(DX(IX+(I-1)*INCX)), -C where IX = 1 if INCX .GE. 0, else IX = 1+(1-N)*INCX. -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 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 900821 Modified to correct problem with a negative increment. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE IDAMAX - DOUBLE PRECISION DX(*), DMAX, XMAG - INTEGER I, INCX, IX, N -C***FIRST EXECUTABLE STATEMENT IDAMAX - IDAMAX = 0 - IF (N .LE. 0) RETURN - IDAMAX = 1 - IF (N .EQ. 1) RETURN -C - IF (INCX .EQ. 1) GOTO 20 -C -C Code for increments not equal to 1. -C - IX = 1 - IF (INCX .LT. 0) IX = (-N+1)*INCX + 1 - DMAX = ABS(DX(IX)) - IX = IX + INCX - DO 10 I = 2,N - XMAG = ABS(DX(IX)) - IF (XMAG .GT. DMAX) THEN - IDAMAX = I - DMAX = XMAG - ENDIF - IX = IX + INCX - 10 CONTINUE - RETURN -C -C Code for increments equal to 1. -C - 20 DMAX = ABS(DX(1)) - DO 30 I = 2,N - XMAG = ABS(DX(I)) - IF (XMAG .GT. DMAX) THEN - IDAMAX = I - DMAX = XMAG - ENDIF - 30 CONTINUE - RETURN - END diff --git a/slatec/idloc.f b/slatec/idloc.f deleted file mode 100644 index cbfe1c1..0000000 --- a/slatec/idloc.f +++ /dev/null @@ -1,74 +0,0 @@ -*DECK IDLOC - INTEGER FUNCTION IDLOC (LOC, SX, IX) -C***BEGIN PROLOGUE IDLOC -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSPLP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (IPLOC-S, IDLOC-D) -C***KEYWORDS RELATIVE ADDRESS DETERMINATION FUNCTION, SLATEC -C***AUTHOR Boland, W. Robert, (LANL) -C Nicol, Tom, (University of British Columbia) -C***DESCRIPTION -C -C Given a "virtual" location, IDLOC returns the relative working -C address of the vector component stored in SX, IX. Any necessary -C page swaps are performed automatically for the user in this -C function subprogram. -C -C LOC is the "virtual" address of the data to be retrieved. -C SX ,IX represent the matrix where the data is stored. -C -C***SEE ALSO DSPLP -C***ROUTINES CALLED DPRWPG, XERMSG -C***REVISION HISTORY (YYMMDD) -C 890606 DATE WRITTEN -C 890606 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 910731 Added code to set IDLOC to 0 if LOC is non-positive. (WRB) -C***END PROLOGUE IDLOC - DOUBLE PRECISION SX(*) - INTEGER IX(*) -C***FIRST EXECUTABLE STATEMENT IDLOC - IF (LOC.LE.0) THEN - CALL XERMSG ('SLATEC', 'IDLOC', - + 'A value of LOC, the first argument, .LE. 0 was encountered', - + 55, 1) - IDLOC = 0 - RETURN - ENDIF -C -C Two cases exist: (1.LE.LOC.LE.K) .OR. (LOC.GT.K). -C - K = IX(3) + 4 - LMX = IX(1) - LMXM1 = LMX - 1 - IF (LOC.LE.K) THEN - IDLOC = LOC - RETURN - ENDIF -C -C Compute length of the page, starting address of the page, page -C number and relative working address. -C - LPG = LMX-K - ITEMP = LOC - K - 1 - IPAGE = ITEMP/LPG + 1 - IDLOC = MOD(ITEMP,LPG) + K + 1 - NP = ABS(IX(LMXM1)) -C -C Determine if a page fault has occurred. If so, write page NP -C and read page IPAGE. Write the page only if it has been -C modified. -C - IF (IPAGE.NE.NP) THEN - IF (SX(LMX).EQ.1.0) THEN - SX(LMX) = 0.0 - KEY = 2 - CALL DPRWPG (KEY, NP, LPG, SX, IX) - ENDIF - KEY = 1 - CALL DPRWPG (KEY, IPAGE, LPG, SX, IX) - ENDIF - RETURN - END diff --git a/slatec/imtql1.f b/slatec/imtql1.f deleted file mode 100644 index 59ad563..0000000 --- a/slatec/imtql1.f +++ /dev/null @@ -1,151 +0,0 @@ -*DECK IMTQL1 - SUBROUTINE IMTQL1 (N, D, E, IERR) -C***BEGIN PROLOGUE IMTQL1 -C***PURPOSE Compute the eigenvalues of a symmetric tridiagonal matrix -C using the implicit QL method. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4A5, D4C2A -C***TYPE SINGLE PRECISION (IMTQL1-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure IMTQL1, -C NUM. MATH. 12, 377-383(1968) by Martin and Wilkinson, -C as modified in NUM. MATH. 15, 450(1970) by Dubrulle. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971). -C -C This subroutine finds the eigenvalues of a SYMMETRIC -C TRIDIAGONAL matrix by the implicit QL method. -C -C On INPUT -C -C N is the order of the matrix. N is an INTEGER variable. -C -C D contains the diagonal elements of the symmetric tridiagonal -C matrix. D is a one-dimensional REAL array, dimensioned D(N). -C -C E contains the subdiagonal elements of the symmetric -C tridiagonal matrix in its last N-1 positions. E(1) is -C arbitrary. E is a one-dimensional REAL array, dimensioned -C E(N). -C -C On OUTPUT -C -C D contains the eigenvalues in ascending order. If an error -C exit is made, the eigenvalues are correct and ordered for -C indices 1, 2, ..., IERR-1, but may not be the smallest -C eigenvalues. -C -C E has been destroyed. -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C J if the J-th eigenvalue has not been -C determined after 30 iterations. -C The eigenvalues should be correct for indices -C 1, 2, ..., IERR-1. These eigenvalues are -C ordered, but are not necessarily the smallest. -C -C Calls PYTHAG(A,B) for sqrt(A**2 + B**2). -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED PYTHAG -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE IMTQL1 -C - INTEGER I,J,L,M,N,II,MML,IERR - REAL D(*),E(*) - REAL B,C,F,G,P,R,S,S1,S2 - REAL PYTHAG -C -C***FIRST EXECUTABLE STATEMENT IMTQL1 - IERR = 0 - IF (N .EQ. 1) GO TO 1001 -C - DO 100 I = 2, N - 100 E(I-1) = E(I) -C - E(N) = 0.0E0 -C - DO 290 L = 1, N - J = 0 -C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... - 105 DO 110 M = L, N - IF (M .EQ. N) GO TO 120 - S1 = ABS(D(M)) + ABS(D(M+1)) - S2 = S1 + ABS(E(M)) - IF (S2 .EQ. S1) GO TO 120 - 110 CONTINUE -C - 120 P = D(L) - IF (M .EQ. L) GO TO 215 - IF (J .EQ. 30) GO TO 1000 - J = J + 1 -C .......... FORM SHIFT .......... - G = (D(L+1) - P) / (2.0E0 * E(L)) - R = PYTHAG(G,1.0E0) - G = D(M) - P + E(L) / (G + SIGN(R,G)) - S = 1.0E0 - C = 1.0E0 - P = 0.0E0 - MML = M - L -C .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... - DO 200 II = 1, MML - I = M - II - F = S * E(I) - B = C * E(I) - IF (ABS(F) .LT. ABS(G)) GO TO 150 - C = G / F - R = SQRT(C*C+1.0E0) - E(I+1) = F * R - S = 1.0E0 / R - C = C * S - GO TO 160 - 150 S = F / G - R = SQRT(S*S+1.0E0) - E(I+1) = G * R - C = 1.0E0 / R - S = S * C - 160 G = D(I+1) - P - R = (D(I) - G) * S + 2.0E0 * C * B - P = S * R - D(I+1) = G + P - G = C * R - B - 200 CONTINUE -C - D(L) = D(L) - P - E(L) = G - E(M) = 0.0E0 - GO TO 105 -C .......... ORDER EIGENVALUES .......... - 215 IF (L .EQ. 1) GO TO 250 -C .......... FOR I=L STEP -1 UNTIL 2 DO -- .......... - DO 230 II = 2, L - I = L + 2 - II - IF (P .GE. D(I-1)) GO TO 270 - D(I) = D(I-1) - 230 CONTINUE -C - 250 I = 1 - 270 D(I) = P - 290 CONTINUE -C - GO TO 1001 -C .......... SET ERROR -- NO CONVERGENCE TO AN -C EIGENVALUE AFTER 30 ITERATIONS .......... - 1000 IERR = L - 1001 RETURN - END diff --git a/slatec/imtql2.f b/slatec/imtql2.f deleted file mode 100644 index 9beeb11..0000000 --- a/slatec/imtql2.f +++ /dev/null @@ -1,190 +0,0 @@ -*DECK IMTQL2 - SUBROUTINE IMTQL2 (NM, N, D, E, Z, IERR) -C***BEGIN PROLOGUE IMTQL2 -C***PURPOSE Compute the eigenvalues and eigenvectors of a symmetric -C tridiagonal matrix using the implicit QL method. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4A5, D4C2A -C***TYPE SINGLE PRECISION (IMTQL2-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure IMTQL2, -C NUM. MATH. 12, 377-383(1968) by Martin and Wilkinson, -C as modified in NUM. MATH. 15, 450(1970) by Dubrulle. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971). -C -C This subroutine finds the eigenvalues and eigenvectors -C of a SYMMETRIC TRIDIAGONAL matrix by the implicit QL method. -C The eigenvectors of a FULL SYMMETRIC matrix can also -C be found if TRED2 has been used to reduce this -C full matrix to tridiagonal form. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameter, Z, as declared in the calling program -C dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C D contains the diagonal elements of the symmetric tridiagonal -C matrix. D is a one-dimensional REAL array, dimensioned D(N). -C -C E contains the subdiagonal elements of the symmetric -C tridiagonal matrix in its last N-1 positions. E(1) is -C arbitrary. E is a one-dimensional REAL array, dimensioned -C E(N). -C -C Z contains the transformation matrix produced in the reduction -C by TRED2, if performed. This transformation matrix is -C necessary if you want to obtain the eigenvectors of the full -C symmetric matrix. If the eigenvectors of the symmetric -C tridiagonal matrix are desired, Z must contain the identity -C matrix. Z is a two-dimensional REAL array, dimensioned -C Z(NM,N). -C -C On OUTPUT -C -C D contains the eigenvalues in ascending order. If an -C error exit is made, the eigenvalues are correct but -C unordered for indices 1, 2, ..., IERR-1. -C -C E has been destroyed. -C -C Z contains orthonormal eigenvectors of the full symmetric -C or symmetric tridiagonal matrix, depending on what it -C contained on input. If an error exit is made, Z contains -C the eigenvectors associated with the stored eigenvalues. -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C J if the J-th eigenvalue has not been -C determined after 30 iterations. -C The eigenvalues and eigenvectors should be correct -C for indices 1, 2, ..., IERR-1, but the eigenvalues -C are not ordered. -C -C Calls PYTHAG(A,B) for sqrt(A**2 + B**2). -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED PYTHAG -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE IMTQL2 -C - INTEGER I,J,K,L,M,N,II,NM,MML,IERR - REAL D(*),E(*),Z(NM,*) - REAL B,C,F,G,P,R,S,S1,S2 - REAL PYTHAG -C -C***FIRST EXECUTABLE STATEMENT IMTQL2 - IERR = 0 - IF (N .EQ. 1) GO TO 1001 -C - DO 100 I = 2, N - 100 E(I-1) = E(I) -C - E(N) = 0.0E0 -C - DO 240 L = 1, N - J = 0 -C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... - 105 DO 110 M = L, N - IF (M .EQ. N) GO TO 120 - S1 = ABS(D(M)) + ABS(D(M+1)) - S2 = S1 + ABS(E(M)) - IF (S2 .EQ. S1) GO TO 120 - 110 CONTINUE -C - 120 P = D(L) - IF (M .EQ. L) GO TO 240 - IF (J .EQ. 30) GO TO 1000 - J = J + 1 -C .......... FORM SHIFT .......... - G = (D(L+1) - P) / (2.0E0 * E(L)) - R = PYTHAG(G,1.0E0) - G = D(M) - P + E(L) / (G + SIGN(R,G)) - S = 1.0E0 - C = 1.0E0 - P = 0.0E0 - MML = M - L -C .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... - DO 200 II = 1, MML - I = M - II - F = S * E(I) - B = C * E(I) - IF (ABS(F) .LT. ABS(G)) GO TO 150 - C = G / F - R = SQRT(C*C+1.0E0) - E(I+1) = F * R - S = 1.0E0 / R - C = C * S - GO TO 160 - 150 S = F / G - R = SQRT(S*S+1.0E0) - E(I+1) = G * R - C = 1.0E0 / R - S = S * C - 160 G = D(I+1) - P - R = (D(I) - G) * S + 2.0E0 * C * B - P = S * R - D(I+1) = G + P - G = C * R - B -C .......... FORM VECTOR .......... - DO 180 K = 1, N - F = Z(K,I+1) - Z(K,I+1) = S * Z(K,I) + C * F - Z(K,I) = C * Z(K,I) - S * F - 180 CONTINUE -C - 200 CONTINUE -C - D(L) = D(L) - P - E(L) = G - E(M) = 0.0E0 - GO TO 105 - 240 CONTINUE -C .......... ORDER EIGENVALUES AND EIGENVECTORS .......... - DO 300 II = 2, N - I = II - 1 - K = I - P = D(I) -C - DO 260 J = II, N - IF (D(J) .GE. P) GO TO 260 - K = J - P = D(J) - 260 CONTINUE -C - IF (K .EQ. I) GO TO 300 - D(K) = D(I) - D(I) = P -C - DO 280 J = 1, N - P = Z(J,I) - Z(J,I) = Z(J,K) - Z(J,K) = P - 280 CONTINUE -C - 300 CONTINUE -C - GO TO 1001 -C .......... SET ERROR -- NO CONVERGENCE TO AN -C EIGENVALUE AFTER 30 ITERATIONS .......... - 1000 IERR = L - 1001 RETURN - END diff --git a/slatec/imtqlv.f b/slatec/imtqlv.f deleted file mode 100644 index cb65693..0000000 --- a/slatec/imtqlv.f +++ /dev/null @@ -1,185 +0,0 @@ -*DECK IMTQLV - SUBROUTINE IMTQLV (N, D, E, E2, W, IND, IERR, RV1) -C***BEGIN PROLOGUE IMTQLV -C***PURPOSE Compute the eigenvalues of a symmetric tridiagonal matrix -C using the implicit QL method. Eigenvectors may be computed -C later. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4A5, D4C2A -C***TYPE SINGLE PRECISION (IMTQLV-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a variant of IMTQL1 which is a translation of -C ALGOL procedure IMTQL1, NUM. MATH. 12, 377-383(1968) by Martin and -C Wilkinson, as modified in NUM. MATH. 15, 450(1970) by Dubrulle. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971). -C -C This subroutine finds the eigenvalues of a SYMMETRIC TRIDIAGONAL -C matrix by the implicit QL method and associates with them -C their corresponding submatrix indices. -C -C On INPUT -C -C N is the order of the matrix. N is an INTEGER variable. -C -C D contains the diagonal elements of the symmetric tridiagonal -C matrix. D is a one-dimensional REAL array, dimensioned D(N). -C -C E contains the subdiagonal elements of the symmetric -C tridiagonal matrix in its last N-1 positions. E(1) is -C arbitrary. E is a one-dimensional REAL array, dimensioned -C E(N). -C -C E2 contains the squares of the corresponding elements of E in -C its last N-1 positions. E2(1) is arbitrary. E2 is a one- -C dimensional REAL array, dimensioned E2(N). -C -C On OUTPUT -C -C D and E are unaltered. -C -C Elements of E2, corresponding to elements of E regarded as -C negligible, have been replaced by zero causing the matrix to -C split into a direct sum of submatrices. E2(1) is also set -C to zero. -C -C W contains the eigenvalues in ascending order. If an error -C exit is made, the eigenvalues are correct and ordered for -C indices 1, 2, ..., IERR-1, but may not be the smallest -C eigenvalues. W is a one-dimensional REAL array, dimensioned -C W(N). -C -C IND contains the submatrix indices associated with the -C corresponding eigenvalues in W -- 1 for eigenvalues belonging -C to the first submatrix from the top, 2 for those belonging to -C the second submatrix, etc. IND is a one-dimensional REAL -C array, dimensioned IND(N). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C J if the J-th eigenvalue has not been -C determined after 30 iterations. -C The eigenvalues should be correct for indices -C 1, 2, ..., IERR-1. These eigenvalues are -C ordered, but are not necessarily the smallest. -C -C RV1 is a one-dimensional REAL array used for temporary storage, -C dimensioned RV1(N). -C -C Calls PYTHAG(A,B) for sqrt(A**2 + B**2). -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED PYTHAG -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE IMTQLV -C - INTEGER I,J,K,L,M,N,II,MML,TAG,IERR - REAL D(*),E(*),E2(*),W(*),RV1(*) - REAL B,C,F,G,P,R,S,S1,S2 - REAL PYTHAG - INTEGER IND(*) -C -C***FIRST EXECUTABLE STATEMENT IMTQLV - IERR = 0 - K = 0 - TAG = 0 -C - DO 100 I = 1, N - W(I) = D(I) - IF (I .NE. 1) RV1(I-1) = E(I) - 100 CONTINUE -C - E2(1) = 0.0E0 - RV1(N) = 0.0E0 -C - DO 290 L = 1, N - J = 0 -C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... - 105 DO 110 M = L, N - IF (M .EQ. N) GO TO 120 - S1 = ABS(W(M)) + ABS(W(M+1)) - S2 = S1 + ABS(RV1(M)) - IF (S2 .EQ. S1) GO TO 120 -C .......... GUARD AGAINST UNDERFLOWED ELEMENT OF E2 .......... - IF (E2(M+1) .EQ. 0.0E0) GO TO 125 - 110 CONTINUE -C - 120 IF (M .LE. K) GO TO 130 - IF (M .NE. N) E2(M+1) = 0.0E0 - 125 K = M - TAG = TAG + 1 - 130 P = W(L) - IF (M .EQ. L) GO TO 215 - IF (J .EQ. 30) GO TO 1000 - J = J + 1 -C .......... FORM SHIFT .......... - G = (W(L+1) - P) / (2.0E0 * RV1(L)) - R = PYTHAG(G,1.0E0) - G = W(M) - P + RV1(L) / (G + SIGN(R,G)) - S = 1.0E0 - C = 1.0E0 - P = 0.0E0 - MML = M - L -C .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... - DO 200 II = 1, MML - I = M - II - F = S * RV1(I) - B = C * RV1(I) - IF (ABS(F) .LT. ABS(G)) GO TO 150 - C = G / F - R = SQRT(C*C+1.0E0) - RV1(I+1) = F * R - S = 1.0E0 / R - C = C * S - GO TO 160 - 150 S = F / G - R = SQRT(S*S+1.0E0) - RV1(I+1) = G * R - C = 1.0E0 / R - S = S * C - 160 G = W(I+1) - P - R = (W(I) - G) * S + 2.0E0 * C * B - P = S * R - W(I+1) = G + P - G = C * R - B - 200 CONTINUE -C - W(L) = W(L) - P - RV1(L) = G - RV1(M) = 0.0E0 - GO TO 105 -C .......... ORDER EIGENVALUES .......... - 215 IF (L .EQ. 1) GO TO 250 -C .......... FOR I=L STEP -1 UNTIL 2 DO -- .......... - DO 230 II = 2, L - I = L + 2 - II - IF (P .GE. W(I-1)) GO TO 270 - W(I) = W(I-1) - IND(I) = IND(I-1) - 230 CONTINUE -C - 250 I = 1 - 270 W(I) = P - IND(I) = TAG - 290 CONTINUE -C - GO TO 1001 -C .......... SET ERROR -- NO CONVERGENCE TO AN -C EIGENVALUE AFTER 30 ITERATIONS .......... - 1000 IERR = L - 1001 RETURN - END diff --git a/slatec/indxa.f b/slatec/indxa.f deleted file mode 100644 index 2f31718..0000000 --- a/slatec/indxa.f +++ /dev/null @@ -1,25 +0,0 @@ -*DECK INDXA - SUBROUTINE INDXA (I, IR, IDXA, NA) -C***BEGIN PROLOGUE INDXA -C***SUBSIDIARY -C***PURPOSE Subsidiary to BLKTRI -C***LIBRARY SLATEC -C***TYPE INTEGER (INDXA-I) -C***AUTHOR (UNKNOWN) -C***SEE ALSO BLKTRI -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS CBLKT -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE INDXA - COMMON /CBLKT/ NPP ,K ,EPS ,CNV , - 1 NM ,NCMPLX ,IK -C***FIRST EXECUTABLE STATEMENT INDXA - NA = 2**IR - IDXA = I-NA+1 - IF (I-NM) 102,102,101 - 101 NA = 0 - 102 RETURN - END diff --git a/slatec/indxb.f b/slatec/indxb.f deleted file mode 100644 index 5ed85fc..0000000 --- a/slatec/indxb.f +++ /dev/null @@ -1,40 +0,0 @@ -*DECK INDXB - SUBROUTINE INDXB (I, IR, IDX, IDP) -C***BEGIN PROLOGUE INDXB -C***SUBSIDIARY -C***PURPOSE Subsidiary to BLKTRI -C***LIBRARY SLATEC -C***TYPE INTEGER (INDXB-I) -C***AUTHOR (UNKNOWN) -C***SEE ALSO BLKTRI -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS CBLKT -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 920422 Added statement so IDX would always be defined. (WRB) -C***END PROLOGUE INDXB -C - COMMON /CBLKT/ NPP ,K ,EPS ,CNV , - 1 NM ,NCMPLX ,IK -C***FIRST EXECUTABLE STATEMENT INDXB - IDX = I - IDP = 0 - IF (IR) 107,101,103 - 101 IF (I-NM) 102,102,107 - 102 IDX = I - IDP = 1 - RETURN - 103 IZH = 2**IR - ID = I-IZH-IZH - IDX = ID+ID+(IR-1)*IK+IR+(IK-I)/IZH+4 - IPL = IZH-1 - IDP = IZH+IZH-1 - IF (I-IPL-NM) 105,105,104 - 104 IDP = 0 - RETURN - 105 IF (I+IPL-NM) 107,107,106 - 106 IDP = NM+IPL-I+1 - 107 RETURN - END diff --git a/slatec/indxc.f b/slatec/indxc.f deleted file mode 100644 index 20c984f..0000000 --- a/slatec/indxc.f +++ /dev/null @@ -1,25 +0,0 @@ -*DECK INDXC - SUBROUTINE INDXC (I, IR, IDXC, NC) -C***BEGIN PROLOGUE INDXC -C***SUBSIDIARY -C***PURPOSE Subsidiary to BLKTRI -C***LIBRARY SLATEC -C***TYPE INTEGER (INDXC-I) -C***AUTHOR (UNKNOWN) -C***SEE ALSO BLKTRI -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS CBLKT -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE INDXC - COMMON /CBLKT/ NPP ,K ,EPS ,CNV , - 1 NM ,NCMPLX ,IK -C***FIRST EXECUTABLE STATEMENT INDXC - NC = 2**IR - IDXC = I - IF (IDXC+NC-1-NM) 102,102,101 - 101 NC = 0 - 102 RETURN - END diff --git a/slatec/initds.f b/slatec/initds.f deleted file mode 100644 index 36eca15..0000000 --- a/slatec/initds.f +++ /dev/null @@ -1,54 +0,0 @@ -*DECK INITDS - FUNCTION INITDS (OS, NOS, ETA) -C***BEGIN PROLOGUE INITDS -C***PURPOSE Determine the number of terms needed in an orthogonal -C polynomial series so that it meets a specified accuracy. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C3A2 -C***TYPE DOUBLE PRECISION (INITS-S, INITDS-D) -C***KEYWORDS CHEBYSHEV, FNLIB, INITIALIZE, ORTHOGONAL POLYNOMIAL, -C ORTHOGONAL SERIES, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Initialize the orthogonal series, represented by the array OS, so -C that INITDS is the number of terms needed to insure the error is no -C larger than ETA. Ordinarily, ETA will be chosen to be one-tenth -C machine precision. -C -C Input Arguments -- -C OS double precision array of NOS coefficients in an orthogonal -C series. -C NOS number of coefficients in OS. -C ETA single precision scalar containing requested accuracy of -C series. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891115 Modified error message. (WRB) -C 891115 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***END PROLOGUE INITDS - DOUBLE PRECISION OS(*) -C***FIRST EXECUTABLE STATEMENT INITDS - IF (NOS .LT. 1) CALL XERMSG ('SLATEC', 'INITDS', - + 'Number of coefficients is less than 1', 2, 1) -C - ERR = 0. - DO 10 II = 1,NOS - I = NOS + 1 - II - ERR = ERR + ABS(REAL(OS(I))) - IF (ERR.GT.ETA) GO TO 20 - 10 CONTINUE -C - 20 IF (I .EQ. NOS) CALL XERMSG ('SLATEC', 'INITDS', - + 'Chebyshev series too short for specified accuracy', 1, 1) - INITDS = I -C - RETURN - END diff --git a/slatec/inits.f b/slatec/inits.f deleted file mode 100644 index e34154f..0000000 --- a/slatec/inits.f +++ /dev/null @@ -1,53 +0,0 @@ -*DECK INITS - FUNCTION INITS (OS, NOS, ETA) -C***BEGIN PROLOGUE INITS -C***PURPOSE Determine the number of terms needed in an orthogonal -C polynomial series so that it meets a specified accuracy. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C3A2 -C***TYPE SINGLE PRECISION (INITS-S, INITDS-D) -C***KEYWORDS CHEBYSHEV, FNLIB, INITIALIZE, ORTHOGONAL POLYNOMIAL, -C ORTHOGONAL SERIES, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Initialize the orthogonal series, represented by the array OS, so -C that INITS is the number of terms needed to insure the error is no -C larger than ETA. Ordinarily, ETA will be chosen to be one-tenth -C machine precision. -C -C Input Arguments -- -C OS single precision array of NOS coefficients in an orthogonal -C series. -C NOS number of coefficients in OS. -C ETA single precision scalar containing requested accuracy of -C series. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891115 Modified error message. (WRB) -C 891115 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***END PROLOGUE INITS - REAL OS(*) -C***FIRST EXECUTABLE STATEMENT INITS - IF (NOS .LT. 1) CALL XERMSG ('SLATEC', 'INITS', - + 'Number of coefficients is less than 1', 2, 1) -C - ERR = 0. - DO 10 II = 1,NOS - I = NOS + 1 - II - ERR = ERR + ABS(OS(I)) - IF (ERR.GT.ETA) GO TO 20 - 10 CONTINUE -C - 20 IF (I .EQ. NOS) CALL XERMSG ('SLATEC', 'INITS', - + 'Chebyshev series too short for specified accuracy', 1, 1) - INITS = I -C - RETURN - END diff --git a/slatec/intrv.f b/slatec/intrv.f deleted file mode 100644 index 11e1f45..0000000 --- a/slatec/intrv.f +++ /dev/null @@ -1,117 +0,0 @@ -*DECK INTRV - SUBROUTINE INTRV (XT, LXT, X, ILO, ILEFT, MFLAG) -C***BEGIN PROLOGUE INTRV -C***PURPOSE Compute the largest integer ILEFT in 1 .LE. ILEFT .LE. LXT -C such that XT(ILEFT) .LE. X where XT(*) is a subdivision -C of the X interval. -C***LIBRARY SLATEC -C***CATEGORY E3, K6 -C***TYPE SINGLE PRECISION (INTRV-S, DINTRV-D) -C***KEYWORDS B-SPLINE, DATA FITTING, INTERPOLATION, SPLINES -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Written by Carl de Boor and modified by D. E. Amos -C -C Abstract -C INTRV is the INTERV routine of the reference. -C -C INTRV computes the largest integer ILEFT in 1 .LE. ILEFT .LE. -C LXT such that XT(ILEFT) .LE. X where XT(*) is a subdivision of -C the X interval. Precisely, -C -C X .LT. XT(1) 1 -1 -C if XT(I) .LE. X .LT. XT(I+1) then ILEFT=I , MFLAG=0 -C XT(LXT) .LE. X LXT 1, -C -C That is, when multiplicities are present in the break point -C to the left of X, the largest index is taken for ILEFT. -C -C Description of Arguments -C Input -C XT - XT is a knot or break point vector of length LXT -C LXT - length of the XT vector -C X - argument -C ILO - an initialization parameter which must be set -C to 1 the first time the spline array XT is -C processed by INTRV. -C -C Output -C ILO - ILO contains information for efficient process- -C ing after the initial call, and ILO must not be -C changed by the user. Distinct splines require -C distinct ILO parameters. -C ILEFT - largest integer satisfying XT(ILEFT) .LE. X -C MFLAG - signals when X lies out of bounds -C -C Error Conditions -C None -C -C***REFERENCES Carl de Boor, Package for calculating with B-splines, -C SIAM Journal on Numerical Analysis 14, 3 (June 1977), -C pp. 441-472. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 800901 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE INTRV -C - INTEGER IHI, ILEFT, ILO, ISTEP, LXT, MFLAG, MIDDLE - REAL X, XT - DIMENSION XT(*) -C***FIRST EXECUTABLE STATEMENT INTRV - IHI = ILO + 1 - IF (IHI.LT.LXT) GO TO 10 - IF (X.GE.XT(LXT)) GO TO 110 - IF (LXT.LE.1) GO TO 90 - ILO = LXT - 1 - IHI = LXT -C - 10 IF (X.GE.XT(IHI)) GO TO 40 - IF (X.GE.XT(ILO)) GO TO 100 -C -C *** NOW X .LT. XT(IHI) . FIND LOWER BOUND - ISTEP = 1 - 20 IHI = ILO - ILO = IHI - ISTEP - IF (ILO.LE.1) GO TO 30 - IF (X.GE.XT(ILO)) GO TO 70 - ISTEP = ISTEP*2 - GO TO 20 - 30 ILO = 1 - IF (X.LT.XT(1)) GO TO 90 - GO TO 70 -C *** NOW X .GE. XT(ILO) . FIND UPPER BOUND - 40 ISTEP = 1 - 50 ILO = IHI - IHI = ILO + ISTEP - IF (IHI.GE.LXT) GO TO 60 - IF (X.LT.XT(IHI)) GO TO 70 - ISTEP = ISTEP*2 - GO TO 50 - 60 IF (X.GE.XT(LXT)) GO TO 110 - IHI = LXT -C -C *** NOW XT(ILO) .LE. X .LT. XT(IHI) . NARROW THE INTERVAL - 70 MIDDLE = (ILO+IHI)/2 - IF (MIDDLE.EQ.ILO) GO TO 100 -C NOTE. IT IS ASSUMED THAT MIDDLE = ILO IN CASE IHI = ILO+1 - IF (X.LT.XT(MIDDLE)) GO TO 80 - ILO = MIDDLE - GO TO 70 - 80 IHI = MIDDLE - GO TO 70 -C *** SET OUTPUT AND RETURN - 90 MFLAG = -1 - ILEFT = 1 - RETURN - 100 MFLAG = 0 - ILEFT = ILO - RETURN - 110 MFLAG = 1 - ILEFT = LXT - RETURN - END diff --git a/slatec/intyd.f b/slatec/intyd.f deleted file mode 100644 index 69331a5..0000000 --- a/slatec/intyd.f +++ /dev/null @@ -1,99 +0,0 @@ -*DECK INTYD - SUBROUTINE INTYD (T, K, YH, NYH, DKY, IFLAG) -C***BEGIN PROLOGUE INTYD -C***SUBSIDIARY -C***PURPOSE Subsidiary to DEBDF -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (INTYD-S, DINTYD-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C INTYD approximates the solution and derivatives at T by polynomial -C interpolation. Must be used in conjunction with the integrator -C package DEBDF. -C ---------------------------------------------------------------------- -C INTYD computes interpolated values of the K-th derivative of the -C dependent variable vector Y, and stores it in DKY. -C This routine is called by DEBDF with K = 0,1 and T = TOUT, but may -C also be called by the user for any K up to the current order. -C (see detailed instructions in LSODE usage documentation.) -C ---------------------------------------------------------------------- -C The computed values in DKY are gotten by interpolation using the -C Nordsieck history array YH. This array corresponds uniquely to a -C vector-valued polynomial of degree NQCUR or less, and DKY is set -C to the K-th derivative of this polynomial at T. -C The formula for DKY is.. -C Q -C DKY(I) = sum C(J,K) * (T - TN)**(J-K) * H**(-J) * YH(I,J+1) -C J=K -C where C(J,K) = J*(J-1)*...*(J-K+1), Q = NQCUR, TN = TCUR, H = HCUR. -C The quantities NQ = NQCUR, L = NQ+1, N = NEQ, TN, and H are -C communicated by common. The above sum is done in reverse order. -C IFLAG is returned negative if either K or T is out of bounds. -C ---------------------------------------------------------------------- -C -C***SEE ALSO DEBDF -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS DEBDF1 -C***REVISION HISTORY (YYMMDD) -C 800901 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE INTYD -C -CLLL. OPTIMIZE - INTEGER K, NYH, IFLAG, I, IC, IER, IOWND, IOWNS, J, JB, JB2, - 1 JJ, JJ1, JP1, JSTART, KFLAG, L, MAXORD, METH, MITER, N, NFE, - 2 NJE, NQ, NQU, NST - REAL T, YH, DKY, - 1 ROWND, ROWNS, EL0, H, HMIN, HMXI, HU, TN, UROUND, - 2 C, R, S, TP - DIMENSION YH(NYH,*), DKY(*) - COMMON /DEBDF1/ ROWND, ROWNS(210), - 1 EL0, H, HMIN, HMXI, HU, TN, UROUND, IOWND(14), IOWNS(6), - 2 IER, JSTART, KFLAG, L, METH, MITER, MAXORD, N, NQ, NST, NFE, - 3 NJE, NQU -C -C***FIRST EXECUTABLE STATEMENT INTYD - IFLAG = 0 - IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80 - TP = TN - HU*(1.0E0 + 100.0E0*UROUND) - IF ((T-TP)*(T-TN) .GT. 0.0E0) GO TO 90 -C - S = (T - TN)/H - IC = 1 - IF (K .EQ. 0) GO TO 15 - JJ1 = L - K - DO 10 JJ = JJ1,NQ - 10 IC = IC*JJ - 15 C = IC - DO 20 I = 1,N - 20 DKY(I) = C*YH(I,L) - IF (K .EQ. NQ) GO TO 55 - JB2 = NQ - K - DO 50 JB = 1,JB2 - J = NQ - JB - JP1 = J + 1 - IC = 1 - IF (K .EQ. 0) GO TO 35 - JJ1 = JP1 - K - DO 30 JJ = JJ1,J - 30 IC = IC*JJ - 35 C = IC - DO 40 I = 1,N - 40 DKY(I) = C*YH(I,JP1) + S*DKY(I) - 50 CONTINUE - IF (K .EQ. 0) RETURN - 55 R = H**(-K) - DO 60 I = 1,N - 60 DKY(I) = R*DKY(I) - RETURN -C - 80 IFLAG = -1 - RETURN - 90 IFLAG = -2 - RETURN -C----------------------- END OF SUBROUTINE INTYD ----------------------- - END diff --git a/slatec/invit.f b/slatec/invit.f deleted file mode 100644 index 964e10d..0000000 --- a/slatec/invit.f +++ /dev/null @@ -1,433 +0,0 @@ -*DECK INVIT - SUBROUTINE INVIT (NM, N, A, WR, WI, SELECT, MM, M, Z, IERR, RM1, - + RV1, RV2) -C***BEGIN PROLOGUE INVIT -C***PURPOSE Compute the eigenvectors of a real upper Hessenberg -C matrix associated with specified eigenvalues by inverse -C iteration. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C2B -C***TYPE SINGLE PRECISION (INVIT-S, CINVIT-C) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure INVIT -C by Peters and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). -C -C This subroutine finds those eigenvectors of a REAL UPPER -C Hessenberg matrix corresponding to specified eigenvalues, -C using inverse iteration. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, A and Z, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix A. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C A contains the upper Hessenberg matrix. A is a two-dimensional -C REAL array, dimensioned A(NM,N). -C -C WR and WI contain the real and imaginary parts, respectively, -C of the eigenvalues of the Hessenberg matrix. The eigenvalues -C must be stored in a manner identical to that output by -C subroutine HQR, which recognizes possible splitting of the -C matrix. WR and WI are one-dimensional REAL arrays, -C dimensioned WR(N) and WI(N). -C -C SELECT specifies the eigenvectors to be found. The -C eigenvector corresponding to the J-th eigenvalue is -C specified by setting SELECT(J) to .TRUE. SELECT is a -C one-dimensional LOGICAL array, dimensioned SELECT(N). -C -C MM should be set to an upper bound for the number of -C columns required to store the eigenvectors to be found. -C NOTE that two columns are required to store the -C eigenvector corresponding to a complex eigenvalue. One -C column is required to store the eigenvector corresponding -C to a real eigenvalue. MM is an INTEGER variable. -C -C On OUTPUT -C -C A and WI are unaltered. -C -C WR may have been altered since close eigenvalues are perturbed -C slightly in searching for independent eigenvectors. -C -C SELECT may have been altered. If the elements corresponding -C to a pair of conjugate complex eigenvalues were each -C initially set to .TRUE., the program resets the second of -C the two elements to .FALSE. -C -C M is the number of columns actually used to store the -C eigenvectors. M is an INTEGER variable. -C -C Z contains the real and imaginary parts of the eigenvectors. -C The eigenvectors are packed into the columns of Z starting -C at the first column. If the next selected eigenvalue is -C real, the next column of Z contains its eigenvector. If the -C eigenvalue is complex, the next two columns of Z contain the -C real and imaginary parts of its eigenvector, with the real -C part first. The eigenvectors are normalized so that the -C component of largest magnitude is 1. Any vector which fails -C the acceptance test is set to zero. Z is a two-dimensional -C REAL array, dimensioned Z(NM,MM). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C -(2*N+1) if more than MM columns of Z are necessary -C to store the eigenvectors corresponding to -C the specified eigenvalues (in this case, M is -C equal to the number of columns of Z containing -C eigenvectors already computed), -C -K if the iteration corresponding to the K-th -C value fails (if this occurs more than once, K -C is the index of the last occurrence); the -C corresponding columns of Z are set to zero -C vectors, -C -(N+K) if both error situations occur. -C -C RM1 is a two-dimensional REAL array used for temporary storage. -C This array holds the triangularized form of the upper -C Hessenberg matrix used in the inverse iteration process. -C RM1 is dimensioned RM1(N,N). -C -C RV1 and RV2 are one-dimensional REAL arrays used for temporary -C storage. They hold the approximate eigenvectors during the -C inverse iteration process. RV1 and RV2 are dimensioned -C RV1(N) and RV2(N). -C -C The ALGOL procedure GUESSVEC appears in INVIT in-line. -C -C Calls PYTHAG(A,B) for sqrt(A**2 + B**2). -C Calls CDIV for complex division. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED CDIV, PYTHAG -C***REVISION HISTORY (YYMMDD) -C 760101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE INVIT -C - INTEGER I,J,K,L,M,N,S,II,IP,MM,MP,NM,NS,N1,UK,IP1,ITS,KM1,IERR - REAL A(NM,*),WR(*),WI(*),Z(NM,*) - REAL RM1(N,*),RV1(*),RV2(*) - REAL T,W,X,Y,EPS3 - REAL NORM,NORMV,GROWTO,ILAMBD,RLAMBD,UKROOT - REAL PYTHAG - LOGICAL SELECT(N) -C -C***FIRST EXECUTABLE STATEMENT INVIT - IERR = 0 - UK = 0 - S = 1 -C .......... IP = 0, REAL EIGENVALUE -C 1, FIRST OF CONJUGATE COMPLEX PAIR -C -1, SECOND OF CONJUGATE COMPLEX PAIR .......... - IP = 0 - N1 = N - 1 -C - DO 980 K = 1, N - IF (WI(K) .EQ. 0.0E0 .OR. IP .LT. 0) GO TO 100 - IP = 1 - IF (SELECT(K) .AND. SELECT(K+1)) SELECT(K+1) = .FALSE. - 100 IF (.NOT. SELECT(K)) GO TO 960 - IF (WI(K) .NE. 0.0E0) S = S + 1 - IF (S .GT. MM) GO TO 1000 - IF (UK .GE. K) GO TO 200 -C .......... CHECK FOR POSSIBLE SPLITTING .......... - DO 120 UK = K, N - IF (UK .EQ. N) GO TO 140 - IF (A(UK+1,UK) .EQ. 0.0E0) GO TO 140 - 120 CONTINUE -C .......... COMPUTE INFINITY NORM OF LEADING UK BY UK -C (HESSENBERG) MATRIX .......... - 140 NORM = 0.0E0 - MP = 1 -C - DO 180 I = 1, UK - X = 0.0E0 -C - DO 160 J = MP, UK - 160 X = X + ABS(A(I,J)) -C - IF (X .GT. NORM) NORM = X - MP = I - 180 CONTINUE -C .......... EPS3 REPLACES ZERO PIVOT IN DECOMPOSITION -C AND CLOSE ROOTS ARE MODIFIED BY EPS3 .......... - IF (NORM .EQ. 0.0E0) NORM = 1.0E0 - EPS3 = NORM - 190 EPS3 = 0.5E0*EPS3 - IF (NORM + EPS3 .GT. NORM) GO TO 190 - EPS3 = 2.0E0*EPS3 -C .......... GROWTO IS THE CRITERION FOR THE GROWTH .......... - UKROOT = SQRT(REAL(UK)) - GROWTO = 0.1E0 / UKROOT - 200 RLAMBD = WR(K) - ILAMBD = WI(K) - IF (K .EQ. 1) GO TO 280 - KM1 = K - 1 - GO TO 240 -C .......... PERTURB EIGENVALUE IF IT IS CLOSE -C TO ANY PREVIOUS EIGENVALUE .......... - 220 RLAMBD = RLAMBD + EPS3 -C .......... FOR I=K-1 STEP -1 UNTIL 1 DO -- .......... - 240 DO 260 II = 1, KM1 - I = K - II - IF (SELECT(I) .AND. ABS(WR(I)-RLAMBD) .LT. EPS3 .AND. - 1 ABS(WI(I)-ILAMBD) .LT. EPS3) GO TO 220 - 260 CONTINUE -C - WR(K) = RLAMBD -C .......... PERTURB CONJUGATE EIGENVALUE TO MATCH .......... - IP1 = K + IP - WR(IP1) = RLAMBD -C .......... FORM UPPER HESSENBERG A-RLAMBD*I (TRANSPOSED) -C AND INITIAL REAL VECTOR .......... - 280 MP = 1 -C - DO 320 I = 1, UK -C - DO 300 J = MP, UK - 300 RM1(J,I) = A(I,J) -C - RM1(I,I) = RM1(I,I) - RLAMBD - MP = I - RV1(I) = EPS3 - 320 CONTINUE -C - ITS = 0 - IF (ILAMBD .NE. 0.0E0) GO TO 520 -C .......... REAL EIGENVALUE. -C TRIANGULAR DECOMPOSITION WITH INTERCHANGES, -C REPLACING ZERO PIVOTS BY EPS3 .......... - IF (UK .EQ. 1) GO TO 420 -C - DO 400 I = 2, UK - MP = I - 1 - IF (ABS(RM1(MP,I)) .LE. ABS(RM1(MP,MP))) GO TO 360 -C - DO 340 J = MP, UK - Y = RM1(J,I) - RM1(J,I) = RM1(J,MP) - RM1(J,MP) = Y - 340 CONTINUE -C - 360 IF (RM1(MP,MP) .EQ. 0.0E0) RM1(MP,MP) = EPS3 - X = RM1(MP,I) / RM1(MP,MP) - IF (X .EQ. 0.0E0) GO TO 400 -C - DO 380 J = I, UK - 380 RM1(J,I) = RM1(J,I) - X * RM1(J,MP) -C - 400 CONTINUE -C - 420 IF (RM1(UK,UK) .EQ. 0.0E0) RM1(UK,UK) = EPS3 -C .......... BACK SUBSTITUTION FOR REAL VECTOR -C FOR I=UK STEP -1 UNTIL 1 DO -- .......... - 440 DO 500 II = 1, UK - I = UK + 1 - II - Y = RV1(I) - IF (I .EQ. UK) GO TO 480 - IP1 = I + 1 -C - DO 460 J = IP1, UK - 460 Y = Y - RM1(J,I) * RV1(J) -C - 480 RV1(I) = Y / RM1(I,I) - 500 CONTINUE -C - GO TO 740 -C .......... COMPLEX EIGENVALUE. -C TRIANGULAR DECOMPOSITION WITH INTERCHANGES, -C REPLACING ZERO PIVOTS BY EPS3. STORE IMAGINARY -C PARTS IN UPPER TRIANGLE STARTING AT (1,3) .......... - 520 NS = N - S - Z(1,S-1) = -ILAMBD - Z(1,S) = 0.0E0 - IF (N .EQ. 2) GO TO 550 - RM1(1,3) = -ILAMBD - Z(1,S-1) = 0.0E0 - IF (N .EQ. 3) GO TO 550 -C - DO 540 I = 4, N - 540 RM1(1,I) = 0.0E0 -C - 550 DO 640 I = 2, UK - MP = I - 1 - W = RM1(MP,I) - IF (I .LT. N) T = RM1(MP,I+1) - IF (I .EQ. N) T = Z(MP,S-1) - X = RM1(MP,MP) * RM1(MP,MP) + T * T - IF (W * W .LE. X) GO TO 580 - X = RM1(MP,MP) / W - Y = T / W - RM1(MP,MP) = W - IF (I .LT. N) RM1(MP,I+1) = 0.0E0 - IF (I .EQ. N) Z(MP,S-1) = 0.0E0 -C - DO 560 J = I, UK - W = RM1(J,I) - RM1(J,I) = RM1(J,MP) - X * W - RM1(J,MP) = W - IF (J .LT. N1) GO TO 555 - L = J - NS - Z(I,L) = Z(MP,L) - Y * W - Z(MP,L) = 0.0E0 - GO TO 560 - 555 RM1(I,J+2) = RM1(MP,J+2) - Y * W - RM1(MP,J+2) = 0.0E0 - 560 CONTINUE -C - RM1(I,I) = RM1(I,I) - Y * ILAMBD - IF (I .LT. N1) GO TO 570 - L = I - NS - Z(MP,L) = -ILAMBD - Z(I,L) = Z(I,L) + X * ILAMBD - GO TO 640 - 570 RM1(MP,I+2) = -ILAMBD - RM1(I,I+2) = RM1(I,I+2) + X * ILAMBD - GO TO 640 - 580 IF (X .NE. 0.0E0) GO TO 600 - RM1(MP,MP) = EPS3 - IF (I .LT. N) RM1(MP,I+1) = 0.0E0 - IF (I .EQ. N) Z(MP,S-1) = 0.0E0 - T = 0.0E0 - X = EPS3 * EPS3 - 600 W = W / X - X = RM1(MP,MP) * W - Y = -T * W -C - DO 620 J = I, UK - IF (J .LT. N1) GO TO 610 - L = J - NS - T = Z(MP,L) - Z(I,L) = -X * T - Y * RM1(J,MP) - GO TO 615 - 610 T = RM1(MP,J+2) - RM1(I,J+2) = -X * T - Y * RM1(J,MP) - 615 RM1(J,I) = RM1(J,I) - X * RM1(J,MP) + Y * T - 620 CONTINUE -C - IF (I .LT. N1) GO TO 630 - L = I - NS - Z(I,L) = Z(I,L) - ILAMBD - GO TO 640 - 630 RM1(I,I+2) = RM1(I,I+2) - ILAMBD - 640 CONTINUE -C - IF (UK .LT. N1) GO TO 650 - L = UK - NS - T = Z(UK,L) - GO TO 655 - 650 T = RM1(UK,UK+2) - 655 IF (RM1(UK,UK) .EQ. 0.0E0 .AND. T .EQ. 0.0E0) RM1(UK,UK) = EPS3 -C .......... BACK SUBSTITUTION FOR COMPLEX VECTOR -C FOR I=UK STEP -1 UNTIL 1 DO -- .......... - 660 DO 720 II = 1, UK - I = UK + 1 - II - X = RV1(I) - Y = 0.0E0 - IF (I .EQ. UK) GO TO 700 - IP1 = I + 1 -C - DO 680 J = IP1, UK - IF (J .LT. N1) GO TO 670 - L = J - NS - T = Z(I,L) - GO TO 675 - 670 T = RM1(I,J+2) - 675 X = X - RM1(J,I) * RV1(J) + T * RV2(J) - Y = Y - RM1(J,I) * RV2(J) - T * RV1(J) - 680 CONTINUE -C - 700 IF (I .LT. N1) GO TO 710 - L = I - NS - T = Z(I,L) - GO TO 715 - 710 T = RM1(I,I+2) - 715 CALL CDIV(X,Y,RM1(I,I),T,RV1(I),RV2(I)) - 720 CONTINUE -C .......... ACCEPTANCE TEST FOR REAL OR COMPLEX -C EIGENVECTOR AND NORMALIZATION .......... - 740 ITS = ITS + 1 - NORM = 0.0E0 - NORMV = 0.0E0 -C - DO 780 I = 1, UK - IF (ILAMBD .EQ. 0.0E0) X = ABS(RV1(I)) - IF (ILAMBD .NE. 0.0E0) X = PYTHAG(RV1(I),RV2(I)) - IF (NORMV .GE. X) GO TO 760 - NORMV = X - J = I - 760 NORM = NORM + X - 780 CONTINUE -C - IF (NORM .LT. GROWTO) GO TO 840 -C .......... ACCEPT VECTOR .......... - X = RV1(J) - IF (ILAMBD .EQ. 0.0E0) X = 1.0E0 / X - IF (ILAMBD .NE. 0.0E0) Y = RV2(J) -C - DO 820 I = 1, UK - IF (ILAMBD .NE. 0.0E0) GO TO 800 - Z(I,S) = RV1(I) * X - GO TO 820 - 800 CALL CDIV(RV1(I),RV2(I),X,Y,Z(I,S-1),Z(I,S)) - 820 CONTINUE -C - IF (UK .EQ. N) GO TO 940 - J = UK + 1 - GO TO 900 -C .......... IN-LINE PROCEDURE FOR CHOOSING -C A NEW STARTING VECTOR .......... - 840 IF (ITS .GE. UK) GO TO 880 - X = UKROOT - Y = EPS3 / (X + 1.0E0) - RV1(1) = EPS3 -C - DO 860 I = 2, UK - 860 RV1(I) = Y -C - J = UK - ITS + 1 - RV1(J) = RV1(J) - EPS3 * X - IF (ILAMBD .EQ. 0.0E0) GO TO 440 - GO TO 660 -C .......... SET ERROR -- UNACCEPTED EIGENVECTOR .......... - 880 J = 1 - IERR = -K -C .......... SET REMAINING VECTOR COMPONENTS TO ZERO .......... - 900 DO 920 I = J, N - Z(I,S) = 0.0E0 - IF (ILAMBD .NE. 0.0E0) Z(I,S-1) = 0.0E0 - 920 CONTINUE -C - 940 S = S + 1 - 960 IF (IP .EQ. (-1)) IP = 0 - IF (IP .EQ. 1) IP = -1 - 980 CONTINUE -C - GO TO 1001 -C .......... SET ERROR -- UNDERESTIMATE OF EIGENVECTOR -C SPACE REQUIRED .......... - 1000 IF (IERR .NE. 0) IERR = IERR - N - IF (IERR .EQ. 0) IERR = -(2 * N + 1) - 1001 M = S - 1 - ABS(IP) - RETURN - END diff --git a/slatec/inxca.f b/slatec/inxca.f deleted file mode 100644 index 7b1a0a6..0000000 --- a/slatec/inxca.f +++ /dev/null @@ -1,25 +0,0 @@ -*DECK INXCA - SUBROUTINE INXCA (I, IR, IDXA, NA) -C***BEGIN PROLOGUE INXCA -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBLKTR -C***LIBRARY SLATEC -C***TYPE INTEGER (INXCA-I) -C***AUTHOR (UNKNOWN) -C***SEE ALSO CBLKTR -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS CCBLK -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE INXCA - COMMON /CCBLK/ NPP ,K ,EPS ,CNV , - 1 NM ,NCMPLX ,IK -C***FIRST EXECUTABLE STATEMENT INXCA - NA = 2**IR - IDXA = I-NA+1 - IF (I-NM) 102,102,101 - 101 NA = 0 - 102 RETURN - END diff --git a/slatec/inxcb.f b/slatec/inxcb.f deleted file mode 100644 index a166e33..0000000 --- a/slatec/inxcb.f +++ /dev/null @@ -1,38 +0,0 @@ -*DECK INXCB - SUBROUTINE INXCB (I, IR, IDX, IDP) -C***BEGIN PROLOGUE INXCB -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBLKTR -C***LIBRARY SLATEC -C***TYPE INTEGER (INXCB-I) -C***AUTHOR (UNKNOWN) -C***SEE ALSO CBLKTR -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS CCBLK -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE INXCB -C - COMMON /CCBLK/ NPP ,K ,EPS ,CNV , - 1 NM ,NCMPLX ,IK -C***FIRST EXECUTABLE STATEMENT INXCB - IDP = 0 - IF (IR) 107,101,103 - 101 IF (I-NM) 102,102,107 - 102 IDX = I - IDP = 1 - RETURN - 103 IZH = 2**IR - ID = I-IZH-IZH - IDX = ID+ID+(IR-1)*IK+IR+(IK-I)/IZH+4 - IPL = IZH-1 - IDP = IZH+IZH-1 - IF (I-IPL-NM) 105,105,104 - 104 IDP = 0 - RETURN - 105 IF (I+IPL-NM) 107,107,106 - 106 IDP = NM+IPL-I+1 - 107 RETURN - END diff --git a/slatec/inxcc.f b/slatec/inxcc.f deleted file mode 100644 index 1ed18d1..0000000 --- a/slatec/inxcc.f +++ /dev/null @@ -1,25 +0,0 @@ -*DECK INXCC - SUBROUTINE INXCC (I, IR, IDXC, NC) -C***BEGIN PROLOGUE INXCC -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBLKTR -C***LIBRARY SLATEC -C***TYPE INTEGER (INXCC-I) -C***AUTHOR (UNKNOWN) -C***SEE ALSO CBLKTR -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS CCBLK -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE INXCC - COMMON /CCBLK/ NPP ,K ,EPS ,CNV , - 1 NM ,NCMPLX ,IK -C***FIRST EXECUTABLE STATEMENT INXCC - NC = 2**IR - IDXC = I - IF (IDXC+NC-1-NM) 102,102,101 - 101 NC = 0 - 102 RETURN - END diff --git a/slatec/iploc.f b/slatec/iploc.f deleted file mode 100644 index fd9aeb0..0000000 --- a/slatec/iploc.f +++ /dev/null @@ -1,76 +0,0 @@ -*DECK IPLOC - INTEGER FUNCTION IPLOC (LOC, SX, IX) -C***BEGIN PROLOGUE IPLOC -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (IPLOC-S, IDLOC-D) -C***KEYWORDS RELATIVE ADDRESS DETERMINATION FUNCTION, SLATEC -C***AUTHOR Hanson, R. J., (SNLA) -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C -C Given a "virtual" location, IPLOC returns the relative working -C address of the vector component stored in SX, IX. Any necessary -C page swaps are performed automatically for the user in this -C function subprogram. -C -C LOC is the "virtual" address of the data to be retrieved. -C SX ,IX represent the matrix where the data is stored. -C -C***SEE ALSO SPLP -C***ROUTINES CALLED PRWPGE, XERMSG -C***REVISION HISTORY (YYMMDD) -C 810306 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890606 Restructured to match double precision version. (WRB) -C 890606 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 910731 Added code to set IPLOC to 0 if LOC is non-positive. (WRB) -C***END PROLOGUE IPLOC - REAL SX(*) - INTEGER IX(*) -C***FIRST EXECUTABLE STATEMENT IPLOC - IF (LOC.LE.0) THEN - CALL XERMSG ('SLATEC', 'IPLOC', - + 'A value of LOC, the first argument, .LE. 0 was encountered', - + 55, 1) - IPLOC = 0 - RETURN - ENDIF -C -C Two cases exist: (1.LE.LOC.LE.K) .OR. (LOC.GT.K). -C - K = IX(3) + 4 - LMX = IX(1) - LMXM1 = LMX - 1 - IF (LOC.LE.K) THEN - IPLOC = LOC - RETURN - ENDIF -C -C Compute length of the page, starting address of the page, page -C number and relative working address. -C - LPG = LMX-K - ITEMP = LOC - K - 1 - IPAGE = ITEMP/LPG + 1 - IPLOC = MOD(ITEMP,LPG) + K + 1 - NP = ABS(IX(LMXM1)) -C -C Determine if a page fault has occurred. If so, write page NP -C and read page IPAGE. Write the page only if it has been -C modified. -C - IF (IPAGE.NE.NP) THEN - IF (SX(LMX).EQ.1.0) THEN - SX(LMX) = 0.0 - KEY = 2 - CALL PRWPGE (KEY, NP, LPG, SX, IX) - ENDIF - KEY = 1 - CALL PRWPGE (KEY, IPAGE, LPG, SX, IX) - ENDIF - RETURN - END diff --git a/slatec/ipperm.f b/slatec/ipperm.f deleted file mode 100644 index 6fe0b5b..0000000 --- a/slatec/ipperm.f +++ /dev/null @@ -1,83 +0,0 @@ -*DECK IPPERM - SUBROUTINE IPPERM (IX, N, IPERM, IER) -C***BEGIN PROLOGUE IPPERM -C***PURPOSE Rearrange a given array according to a prescribed -C permutation vector. -C***LIBRARY SLATEC -C***CATEGORY N8 -C***TYPE INTEGER (SPPERM-S, DPPERM-D, IPPERM-I, HPPERM-H) -C***KEYWORDS APPLICATION OF PERMUTATION TO DATA VECTOR -C***AUTHOR McClain, M. A., (NIST) -C Rhoads, G. S., (NBS) -C***DESCRIPTION -C -C IPPERM rearranges the data vector IX according to the -C permutation IPERM: IX(I) <--- IX(IPERM(I)). IPERM could come -C from one of the sorting routines IPSORT, SPSORT, DPSORT or -C HPSORT. -C -C Description of Parameters -C IX - input/output -- integer array of values to be rearranged. -C N - input -- number of values in integer array IX. -C IPERM - input -- permutation vector. -C IER - output -- error indicator: -C = 0 if no error, -C = 1 if N is zero or negative, -C = 2 if IPERM is not a valid permutation. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 900618 DATE WRITTEN -C 920507 Modified by M. McClain to revise prologue text. -C***END PROLOGUE IPPERM - INTEGER IX(*), N, IPERM(*), I, IER, INDX, INDX0, ITEMP, ISTRT -C***FIRST EXECUTABLE STATEMENT IPPERM - IER=0 - IF(N.LT.1)THEN - IER=1 - CALL XERMSG ('SLATEC', 'IPPERM', - + 'The number of values to be rearranged, N, is not positive.', - + IER, 1) - RETURN - ENDIF -C -C CHECK WHETHER IPERM IS A VALID PERMUTATION -C - DO 100 I=1,N - INDX=ABS(IPERM(I)) - IF((INDX.GE.1).AND.(INDX.LE.N))THEN - IF(IPERM(INDX).GT.0)THEN - IPERM(INDX)=-IPERM(INDX) - GOTO 100 - ENDIF - ENDIF - IER=2 - CALL XERMSG ('SLATEC', 'IPPERM', - + 'The permutation vector, IPERM, is not valid.', IER, 1) - RETURN - 100 CONTINUE -C -C REARRANGE THE VALUES OF IX -C -C USE THE IPERM VECTOR AS A FLAG. -C IF IPERM(I) > 0, THEN THE I-TH VALUE IS IN CORRECT LOCATION -C - DO 330 ISTRT = 1 , N - IF (IPERM(ISTRT) .GT. 0) GOTO 330 - INDX = ISTRT - INDX0 = INDX - ITEMP = IX(ISTRT) - 320 CONTINUE - IF (IPERM(INDX) .GE. 0) GOTO 325 - IX(INDX) = IX(-IPERM(INDX)) - INDX0 = INDX - IPERM(INDX) = -IPERM(INDX) - INDX = IPERM(INDX) - GOTO 320 - 325 CONTINUE - IX(INDX0) = ITEMP - 330 CONTINUE -C - RETURN - END diff --git a/slatec/ipsort.f b/slatec/ipsort.f deleted file mode 100644 index cf62bf5..0000000 --- a/slatec/ipsort.f +++ /dev/null @@ -1,270 +0,0 @@ -*DECK IPSORT - SUBROUTINE IPSORT (IX, N, IPERM, KFLAG, IER) -C***BEGIN PROLOGUE IPSORT -C***PURPOSE Return the permutation vector generated by sorting a given -C array and, optionally, rearrange the elements of the array. -C The array may be sorted in increasing or decreasing order. -C A slightly modified quicksort algorithm is used. -C***LIBRARY SLATEC -C***CATEGORY N6A1A, N6A2A -C***TYPE INTEGER (SPSORT-S, DPSORT-D, IPSORT-I, HPSORT-H) -C***KEYWORDS NUMBER SORTING, PASSIVE SORTING, SINGLETON QUICKSORT, SORT -C***AUTHOR Jones, R. E., (SNLA) -C Kahaner, D. K., (NBS) -C Rhoads, G. S., (NBS) -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C -C IPSORT returns the permutation vector IPERM generated by sorting -C the array IX and, optionally, rearranges the values in IX. IX may -C be sorted in increasing or decreasing order. A slightly modified -C quicksort algorithm is used. -C -C IPERM is such that IX(IPERM(I)) is the Ith value in the -C rearrangement of IX. IPERM may be applied to another array by -C calling IPPERM, SPPERM, DPPERM or HPPERM. -C -C The main difference between IPSORT and its active sorting equivalent -C ISORT is that the data are referenced indirectly rather than -C directly. Therefore, IPSORT should require approximately twice as -C long to execute as ISORT. However, IPSORT is more general. -C -C Description of Parameters -C IX - input/output -- integer array of values to be sorted. -C If ABS(KFLAG) = 2, then the values in IX will be -C rearranged on output; otherwise, they are unchanged. -C N - input -- number of values in array IX to be sorted. -C IPERM - output -- permutation array such that IPERM(I) is the -C index of the value in the original order of the -C IX array that is in the Ith location in the sorted -C order. -C KFLAG - input -- control parameter: -C = 2 means return the permutation vector resulting from -C sorting IX in increasing order and sort IX also. -C = 1 means return the permutation vector resulting from -C sorting IX in increasing order and do not sort IX. -C = -1 means return the permutation vector resulting from -C sorting IX in decreasing order and do not sort IX. -C = -2 means return the permutation vector resulting from -C sorting IX in decreasing order and sort IX also. -C IER - output -- error indicator: -C = 0 if no error, -C = 1 if N is zero or negative, -C = 2 if KFLAG is not 2, 1, -1, or -2. -C***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm -C for sorting with minimal storage, Communications of -C the ACM, 12, 3 (1969), pp. 185-187. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 761101 DATE WRITTEN -C 761118 Modified by John A. Wisniewski to use the Singleton -C quicksort algorithm. -C 810801 Further modified by David K. Kahaner. -C 870423 Modified by Gregory S. Rhoads for passive sorting with the -C option for the rearrangement of the original data. -C 890620 Algorithm for rearranging the data vector corrected by R. -C Boisvert. -C 890622 Prologue upgraded to Version 4.0 style by D. Lozier. -C 891128 Error when KFLAG.LT.0 and N=1 corrected by R. Boisvert. -C 920507 Modified by M. McClain to revise prologue text. -C 920818 Declarations section rebuilt and code restructured to use -C IF-THEN-ELSE-ENDIF. (SMR, WRB) -C***END PROLOGUE IPSORT -C .. Scalar Arguments .. - INTEGER IER, KFLAG, N -C .. Array Arguments .. - INTEGER IPERM(*), IX(*) -C .. Local Scalars .. - REAL R - INTEGER I, IJ, INDX, INDX0, ISTRT, ITEMP, J, K, KK, L, LM, LMT, M, - + NN -C .. Local Arrays .. - INTEGER IL(21), IU(21) -C .. External Subroutines .. - EXTERNAL XERMSG -C .. Intrinsic Functions .. - INTRINSIC ABS, INT -C***FIRST EXECUTABLE STATEMENT IPSORT - IER = 0 - NN = N - IF (NN .LT. 1) THEN - IER = 1 - CALL XERMSG ('SLATEC', 'IPSORT', - + 'The number of values to be sorted, N, is not positive.', - + IER, 1) - RETURN - ENDIF - KK = ABS(KFLAG) - IF (KK.NE.1 .AND. KK.NE.2) THEN - IER = 2 - CALL XERMSG ('SLATEC', 'IPSORT', - + 'The sort control parameter, KFLAG, is not 2, 1, -1, or -2.', - + IER, 1) - RETURN - ENDIF -C -C Initialize permutation vector -C - DO 10 I=1,NN - IPERM(I) = I - 10 CONTINUE -C -C Return if only one value is to be sorted -C - IF (NN .EQ. 1) RETURN -C -C Alter array IX to get decreasing order if needed -C - IF (KFLAG .LE. -1) THEN - DO 20 I=1,NN - IX(I) = -IX(I) - 20 CONTINUE - ENDIF -C -C Sort IX only -C - M = 1 - I = 1 - J = NN - R = .375E0 -C - 30 IF (I .EQ. J) GO TO 80 - IF (R .LE. 0.5898437E0) THEN - R = R+3.90625E-2 - ELSE - R = R-0.21875E0 - ENDIF -C - 40 K = I -C -C Select a central element of the array and save it in location L -C - IJ = I + INT((J-I)*R) - LM = IPERM(IJ) -C -C If first element of array is greater than LM, interchange with LM -C - IF (IX(IPERM(I)) .GT. IX(LM)) THEN - IPERM(IJ) = IPERM(I) - IPERM(I) = LM - LM = IPERM(IJ) - ENDIF - L = J -C -C If last element of array is less than LM, interchange with LM -C - IF (IX(IPERM(J)) .LT. IX(LM)) THEN - IPERM(IJ) = IPERM(J) - IPERM(J) = LM - LM = IPERM(IJ) -C -C If first element of array is greater than LM, interchange -C with LM -C - IF (IX(IPERM(I)) .GT. IX(LM)) THEN - IPERM(IJ) = IPERM(I) - IPERM(I) = LM - LM = IPERM(IJ) - ENDIF - ENDIF - GO TO 60 - 50 LMT = IPERM(L) - IPERM(L) = IPERM(K) - IPERM(K) = LMT -C -C Find an element in the second half of the array which is smaller -C than LM -C - 60 L = L-1 - IF (IX(IPERM(L)) .GT. IX(LM)) GO TO 60 -C -C Find an element in the first half of the array which is greater -C than LM -C - 70 K = K+1 - IF (IX(IPERM(K)) .LT. IX(LM)) GO TO 70 -C -C Interchange these elements -C - IF (K .LE. L) GO TO 50 -C -C Save upper and lower subscripts of the array yet to be sorted -C - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 90 -C -C Begin again on another portion of the unsorted array -C - 80 M = M-1 - IF (M .EQ. 0) GO TO 120 - I = IL(M) - J = IU(M) -C - 90 IF (J-I .GE. 1) GO TO 40 - IF (I .EQ. 1) GO TO 30 - I = I-1 -C - 100 I = I+1 - IF (I .EQ. J) GO TO 80 - LM = IPERM(I+1) - IF (IX(IPERM(I)) .LE. IX(LM)) GO TO 100 - K = I -C - 110 IPERM(K+1) = IPERM(K) - K = K-1 -C - IF (IX(LM) .LT. IX(IPERM(K))) GO TO 110 - IPERM(K+1) = LM - GO TO 100 -C -C Clean up -C - 120 IF (KFLAG .LE. -1) THEN - DO 130 I=1,NN - IX(I) = -IX(I) - 130 CONTINUE - ENDIF -C -C Rearrange the values of IX if desired -C - IF (KK .EQ. 2) THEN -C -C Use the IPERM vector as a flag. -C If IPERM(I) < 0, then the I-th value is in correct location -C - DO 150 ISTRT=1,NN - IF (IPERM(ISTRT) .GE. 0) THEN - INDX = ISTRT - INDX0 = INDX - ITEMP = IX(ISTRT) - 140 IF (IPERM(INDX) .GT. 0) THEN - IX(INDX) = IX(IPERM(INDX)) - INDX0 = INDX - IPERM(INDX) = -IPERM(INDX) - INDX = ABS(IPERM(INDX)) - GO TO 140 - ENDIF - IX(INDX0) = ITEMP - ENDIF - 150 CONTINUE -C -C Revert the signs of the IPERM values -C - DO 160 I=1,NN - IPERM(I) = -IPERM(I) - 160 CONTINUE -C - ENDIF -C - RETURN - END diff --git a/slatec/isamax.f b/slatec/isamax.f deleted file mode 100644 index 80d9f3b..0000000 --- a/slatec/isamax.f +++ /dev/null @@ -1,82 +0,0 @@ -*DECK ISAMAX - INTEGER FUNCTION ISAMAX (N, SX, INCX) -C***BEGIN PROLOGUE ISAMAX -C***PURPOSE Find the smallest index of that component of a vector -C having the maximum magnitude. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A2 -C***TYPE SINGLE PRECISION (ISAMAX-S, IDAMAX-D, ICAMAX-C) -C***KEYWORDS BLAS, LINEAR ALGEBRA, MAXIMUM COMPONENT, 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 -C --Output-- -C ISAMAX smallest index (zero if N .LE. 0) -C -C Find smallest index of maximum magnitude of single precision SX. -C ISAMAX = first I, I = 1 to N, to maximize ABS(SX(IX+(I-1)*INCX)), -C where IX = 1 if INCX .GE. 0, else IX = 1+(1-N)*INCX. -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 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900821 Modified to correct problem with a negative increment. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 920618 Slight restructuring of code. (RWC, WRB) -C***END PROLOGUE ISAMAX - REAL SX(*), SMAX, XMAG - INTEGER I, INCX, IX, N -C***FIRST EXECUTABLE STATEMENT ISAMAX - ISAMAX = 0 - IF (N .LE. 0) RETURN - ISAMAX = 1 - IF (N .EQ. 1) RETURN -C - IF (INCX .EQ. 1) GOTO 20 -C -C Code for increment not equal to 1. -C - IX = 1 - IF (INCX .LT. 0) IX = (-N+1)*INCX + 1 - SMAX = ABS(SX(IX)) - IX = IX + INCX - DO 10 I = 2,N - XMAG = ABS(SX(IX)) - IF (XMAG .GT. SMAX) THEN - ISAMAX = I - SMAX = XMAG - ENDIF - IX = IX + INCX - 10 CONTINUE - RETURN -C -C Code for increments equal to 1. -C - 20 SMAX = ABS(SX(1)) - DO 30 I = 2,N - XMAG = ABS(SX(I)) - IF (XMAG .GT. SMAX) THEN - ISAMAX = I - SMAX = XMAG - ENDIF - 30 CONTINUE - RETURN - END diff --git a/slatec/isdbcg.f b/slatec/isdbcg.f deleted file mode 100644 index b42dd69..0000000 --- a/slatec/isdbcg.f +++ /dev/null @@ -1,239 +0,0 @@ -*DECK ISDBCG - INTEGER FUNCTION ISDBCG (N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, - + ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, RR, ZZ, PP, - + DZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) -C***BEGIN PROLOGUE ISDBCG -C***SUBSIDIARY -C***PURPOSE Preconditioned BiConjugate Gradient Stop Test. -C This routine calculates the stop test for the BiConjugate -C Gradient iteration scheme. It returns a non-zero if the -C error estimate (the type of which is determined by ITOL) -C is less than the user specified tolerance TOL. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (ISSBCG-S, ISDBCG-D) -C***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, SLAP, -C SPARSE, STOP TEST -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER -C INTEGER IERR, IUNIT, IWORK(USER DEFINED) -C DOUBLE PRECISION B(N), X(N), A(N), TOL, ERR, R(N), Z(N), P(N) -C DOUBLE PRECISION RR(N), ZZ(N), PP(N), DZ(N) -C DOUBLE PRECISION RWORK(USER DEFINED), AK, BK, BNRM, SOLNRM -C EXTERNAL MSOLVE -C -C IF( ISDBCG(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, RR, ZZ, PP, DZ, -C $ RWORK, IWORK, AK, BK, BNRM, SOLNRM) .NE. 0 ) -C $ THEN ITERATION DONE -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right-hand side vector. -C X :INOUT Double Precision X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Double Precision A(NELT). -C These arrays contain the matrix data structure for A. -C It could take any form. See "Description", in the SLAP -C routine DBCG for more details. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C MSOLVE :EXT External. -C Name of a routine which solves a linear system MZ = R for Z -C given R with the preconditioning matrix M (M is supplied via -C RWORK and IWORK arrays). The name of the MSOLVE routine -C must be declared external in the calling program. The -C calling sequence of MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, R is the right-hand side -C vector, and Z is the solution upon return. NELT, IA, JA, A, -C and ISYM define the SLAP matrix data structure. -C RWORK is a double precision array that can be used to pass -C necessary preconditioning information and/or workspace to -C MSOLVE. -C IWORK is an integer work array for the same purpose as RWORK. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /DSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :IN Double Precision. -C Convergence criterion, as described above. -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :IN Integer. -C Current iteration count. (Must be zero on first call.) -C ERR :OUT Double Precision. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Error flag. IERR is set to 3 if ITOL is not one of the -C acceptable values, see above. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C R :IN Double Precision R(N). -C The residual r = b - Ax. -C Z :WORK Double Precision Z(N). -C P :DUMMY Double Precision P(N). -C RR :DUMMY Double Precision RR(N). -C ZZ :DUMMY Double Precision ZZ(N). -C PP :DUMMY Double Precision PP(N). -C Double Precision arrays used for workspace. -C DZ :WORK Double Precision DZ(N). -C If ITOL.eq.0 then DZ is used to hold M-inv * B on the first -C call. If ITOL.eq.11 then DZ is used to hold X-SOLN. -C RWORK :WORK Double Precision RWORK(USER DEFINED). -C Double Precision array that can be used for workspace in -C MSOLVE and MTSOLV. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used for workspace in MSOLVE -C and MTSOLV. -C AK :IN Double Precision. -C Current iterate BiConjugate Gradient iteration parameter. -C BK :IN Double Precision. -C Current iterate BiConjugate Gradient iteration parameter. -C BNRM :INOUT Double Precision. -C Norm of the right hand side. Type of norm depends on ITOL. -C Calculated only on the first call. -C SOLNRM :INOUT Double Precision. -C 2-Norm of the true solution, SOLN. Only computed and used -C if ITOL = 11. -C -C *Function Return Values: -C 0 : Error estimate (determined by ITOL) is *NOT* less than the -C specified tolerance, TOL. The iteration must continue. -C 1 : Error estimate (determined by ITOL) is less than the -C specified tolerance, TOL. The iteration can be considered -C complete. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO DBCG -C***ROUTINES CALLED D1MACH, DNRM2 -C***COMMON BLOCKS DSLBLK -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 891003 Removed C***REFER TO line, per MKS. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MSOLVE from ROUTINES CALLED list. (FNF) -C 910506 Made subsidiary to DBCG. (FNF) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920930 Corrected to not print AK,BK when ITER=0. (FNF) -C 921026 Changed 1.0E10 to D1MACH(2) and corrected D to E in -C output format. (FNF) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE ISDBCG -C .. Scalar Arguments .. - DOUBLE PRECISION AK, BK, BNRM, ERR, SOLNRM, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), B(N), DZ(N), P(N), PP(N), R(N), RR(N), - + RWORK(*), X(N), Z(N), ZZ(N) - INTEGER IA(NELT), IWORK(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MSOLVE -C .. Arrays in Common .. - DOUBLE PRECISION SOLN(1) -C .. Local Scalars .. - INTEGER I -C .. External Functions .. - DOUBLE PRECISION D1MACH, DNRM2 - EXTERNAL D1MACH, DNRM2 -C .. Common blocks .. - COMMON /DSLBLK/ SOLN -C***FIRST EXECUTABLE STATEMENT ISDBCG - ISDBCG = 0 -C - IF( ITOL.EQ.1 ) THEN -C err = ||Residual||/||RightHandSide|| (2-Norms). - IF(ITER .EQ. 0) BNRM = DNRM2(N, B, 1) - ERR = DNRM2(N, R, 1)/BNRM - ELSE IF( ITOL.EQ.2 ) THEN -C -1 -1 -C err = ||M Residual||/||M RightHandSide|| (2-Norms). - IF(ITER .EQ. 0) THEN - CALL MSOLVE(N, B, DZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) - BNRM = DNRM2(N, DZ, 1) - ENDIF - ERR = DNRM2(N, Z, 1)/BNRM - ELSE IF( ITOL.EQ.11 ) THEN -C err = ||x-TrueSolution||/||TrueSolution|| (2-Norms). - IF(ITER .EQ. 0) SOLNRM = DNRM2(N, SOLN, 1) - DO 10 I = 1, N - DZ(I) = X(I) - SOLN(I) - 10 CONTINUE - ERR = DNRM2(N, DZ, 1)/SOLNRM - ELSE -C -C If we get here ITOL is not one of the acceptable values. - ERR = D1MACH(2) - IERR = 3 - ENDIF -C - IF(IUNIT .NE. 0) THEN - IF( ITER.EQ.0 ) THEN - WRITE(IUNIT,1000) N, ITOL - WRITE(IUNIT,1010) ITER, ERR - ELSE - WRITE(IUNIT,1010) ITER, ERR, AK, BK - ENDIF - ENDIF - IF(ERR .LE. TOL) ISDBCG = 1 -C - RETURN - 1000 FORMAT(' Preconditioned BiConjugate Gradient for N, ITOL = ', - $ I5,I5,/' ITER',' Error Estimate',' Alpha', - $ ' Beta') - 1010 FORMAT(1X,I4,1X,D16.7,1X,D16.7,1X,D16.7) -C------------- LAST LINE OF ISDBCG FOLLOWS ---------------------------- - END diff --git a/slatec/isdcg.f b/slatec/isdcg.f deleted file mode 100644 index 7ffb93b..0000000 --- a/slatec/isdcg.f +++ /dev/null @@ -1,229 +0,0 @@ -*DECK ISDCG - INTEGER FUNCTION ISDCG (N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, - + ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, DZ, RWORK, - + IWORK, AK, BK, BNRM, SOLNRM) -C***BEGIN PROLOGUE ISDCG -C***SUBSIDIARY -C***PURPOSE Preconditioned Conjugate Gradient Stop Test. -C This routine calculates the stop test for the Conjugate -C Gradient iteration scheme. It returns a non-zero if the -C error estimate (the type of which is determined by ITOL) -C is less than the user specified tolerance TOL. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2B4 -C***TYPE DOUBLE PRECISION (ISSCG-S, ISDCG-D) -C***KEYWORDS LINEAR SYSTEM, SLAP, SPARSE, STOP TEST -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER -C INTEGER IERR, IUNIT, IWORK(USER DEFINED) -C DOUBLE PRECISION B(N), X(N), A(N), TOL, ERR, R(N), Z(N) -C DOUBLE PRECISION P(N), DZ(N), RWORK(USER DEFINED), AK, BK -C DOUBLE PRECISION BNRM, SOLNRM -C EXTERNAL MSOLVE -C -C IF( ISDCG(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, DZ, RWORK, IWORK, -C $ AK, BK, BNRM, SOLNRM) .NE. 0 ) THEN ITERATION DONE -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right-hand side vector. -C X :IN Double Precision X(N). -C The current approximate solution vector. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Double Precision A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description" -C in the DCG, DSDCG or DSICCG routines. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C MSOLVE :EXT External. -C Name of a routine which solves a linear system MZ = R for -C Z given R with the preconditioning matrix M (M is supplied via -C RWORK and IWORK arrays). The name of the MSOLVE routine must -C be declared external in the calling program. The calling -C sequence to MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, R is the right-hand side -C vector and Z is the solution upon return. NELT, IA, JA, A and -C ISYM are defined as above. RWORK is a double precision array -C that can be used to pass necessary preconditioning information -C and/or workspace to MSOLVE. IWORK is an integer work array -C for the same purpose as RWORK. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /DSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :IN Double Precision. -C Convergence criterion, as described above. -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :IN Integer. -C Current iteration count. (Must be zero on first call.) -C ERR :OUT Double Precision. -C Error estimate of error in the X(N) approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Error flag. IERR is set to 3 if ITOL is not one of the -C acceptable values, see above. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C R :IN Double Precision R(N). -C The residual R = B-AX. -C Z :WORK Double Precision Z(N). -C Workspace used to hold the pseudo-residual M Z = R. -C P :IN Double Precision P(N). -C The conjugate direction vector. -C DZ :WORK Double Precision DZ(N). -C Workspace used to hold temporary vector(s). -C RWORK :WORK Double Precision RWORK(USER DEFINED). -C Double Precision array that can be used by MSOLVE. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used by MSOLVE. -C AK :IN Double Precision. -C BK :IN Double Precision. -C Current conjugate gradient parameters alpha and beta. -C BNRM :INOUT Double Precision. -C Norm of the right hand side. Type of norm depends on ITOL. -C Calculated only on the first call. -C SOLNRM :INOUT Double Precision. -C 2-Norm of the true solution, SOLN. Only computed and used -C if ITOL = 11. -C -C *Function Return Values: -C 0 : Error estimate (determined by ITOL) is *NOT* less than the -C specified tolerance, TOL. The iteration must continue. -C 1 : Error estimate (determined by ITOL) is less than the -C specified tolerance, TOL. The iteration can be considered -C complete. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO DCG, DSDCG, DSICCG -C***ROUTINES CALLED D1MACH, DNRM2 -C***COMMON BLOCKS DSLBLK -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 891003 Removed C***REFER TO line, per MKS. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MSOLVE from ROUTINES CALLED list. (FNF) -C 910506 Made subsidiary to DCG. (FNF) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920930 Corrected to not print AK,BK when ITER=0. (FNF) -C 921026 Changed 1.0E10 to D1MACH(2) and corrected D to E in -C output format. (FNF) -C***END PROLOGUE ISDCG -C .. Scalar Arguments .. - DOUBLE PRECISION AK, BK, BNRM, ERR, SOLNRM, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), B(N), DZ(N), P(N), R(N), RWORK(*), X(N), - + Z(N) - INTEGER IA(NELT), IWORK(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MSOLVE -C .. Arrays in Common .. - DOUBLE PRECISION SOLN(1) -C .. Local Scalars .. - INTEGER I -C .. External Functions .. - DOUBLE PRECISION D1MACH, DNRM2 - EXTERNAL D1MACH, DNRM2 -C .. Common blocks .. - COMMON /DSLBLK/ SOLN -C***FIRST EXECUTABLE STATEMENT ISDCG - ISDCG = 0 -C - IF( ITOL.EQ.1 ) THEN -C err = ||Residual||/||RightHandSide|| (2-Norms). - IF(ITER .EQ. 0) BNRM = DNRM2(N, B, 1) - ERR = DNRM2(N, R, 1)/BNRM - ELSE IF( ITOL.EQ.2 ) THEN -C -1 -1 -C err = ||M Residual||/||M RightHandSide|| (2-Norms). - IF(ITER .EQ. 0) THEN - CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) - BNRM = DNRM2(N, DZ, 1) - ENDIF - ERR = DNRM2(N, Z, 1)/BNRM - ELSE IF( ITOL.EQ.11 ) THEN -C err = ||x-TrueSolution||/||TrueSolution|| (2-Norms). - IF(ITER .EQ. 0) SOLNRM = DNRM2(N, SOLN, 1) - DO 10 I = 1, N - DZ(I) = X(I) - SOLN(I) - 10 CONTINUE - ERR = DNRM2(N, DZ, 1)/SOLNRM - ELSE -C -C If we get here ITOL is not one of the acceptable values. - ERR = D1MACH(2) - IERR = 3 - ENDIF -C - IF(IUNIT .NE. 0) THEN - IF( ITER.EQ.0 ) THEN - WRITE(IUNIT,1000) N, ITOL - WRITE(IUNIT,1010) ITER, ERR - ELSE - WRITE(IUNIT,1010) ITER, ERR, AK, BK - ENDIF - ENDIF - IF(ERR .LE. TOL) ISDCG = 1 - RETURN - 1000 FORMAT(' Preconditioned Conjugate Gradient for ', - $ 'N, ITOL = ',I5, I5, - $ /' ITER',' Error Estimate',' Alpha', - $ ' Beta') - 1010 FORMAT(1X,I4,1X,D16.7,1X,D16.7,1X,D16.7) -C------------- LAST LINE OF ISDCG FOLLOWS ------------------------------ - END diff --git a/slatec/isdcgn.f b/slatec/isdcgn.f deleted file mode 100644 index a48eb57..0000000 --- a/slatec/isdcgn.f +++ /dev/null @@ -1,264 +0,0 @@ -*DECK ISDCGN - INTEGER FUNCTION ISDCGN (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, - + MTTVEC, MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, - + P, ATP, ATZ, DZ, ATDZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) -C***BEGIN PROLOGUE ISDCGN -C***SUBSIDIARY -C***PURPOSE Preconditioned CG on Normal Equations Stop Test. -C This routine calculates the stop test for the Conjugate -C Gradient iteration scheme applied to the normal equations. -C It returns a non-zero if the error estimate (the type of -C which is determined by ITOL) is less than the user -C specified tolerance TOL. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (ISSCGN-S, ISDCGN-D) -C***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, -C NORMAL EQUATIONS, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER -C INTEGER IERR, IUNIT, IWORK(USER DEFINED) -C DOUBLE PRECISION B(N), X(N), A(N), TOL, ERR, R(N), Z(N), P(N) -C DOUBLE PRECISION ATP(N), ATZ(N), DZ(N), ATDZ(N) -C DOUBLE PRECISION RWORK(USER DEFINED), AK, BK, BNRM, SOLNRM -C EXTERNAL MATVEC, MTTVEC, MSOLVE -C -C IF( ISTPCGN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, -C $ MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, -C $ ATP, ATZ, DZ, ATDZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) -C $ .NE. 0 ) THEN ITERATION DONE -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right-hand side vector. -C X :IN Double Precision X(N). -C The current approximate solution vector. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Double Precision A(NELT). -C These arrays contain the matrix data structure for A. -C It could take any form. See "Description" in the -C DCGN routine. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C MATVEC :EXT External. -C Name of a routine which performs the matrix vector multiply -C Y = A*X given A and X. The name of the MATVEC routine must -C be declared external in the calling program. The calling -C sequence to MATVEC is: -C CALL MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) -C Where N is the number of unknowns, Y is the product A*X -C upon return X is an input vector, NELT is the number of -C non-zeros in the SLAP-Column IA, JA, A storage for the matrix -C A. ISYM is a flag which, if non-zero, denotes that A is -C symmetric and only the lower or upper triangle is stored. -C MTTVEC :EXT External. -C Name of a routine which performs the matrix transpose vector -C multiply y = A'*X given A and X (where ' denotes transpose). -C The name of the MTTVEC routine must be declared external in -C the calling program. The calling sequence to MTTVEC is the -C same as that for MATVEC, viz.: -C CALL MTTVEC( N, X, Y, NELT, IA, JA, A, ISYM ) -C Where N is the number of unknowns, Y is the product A'*X -C upon return X is an input vector, NELT is the number of -C non-zeros in the SLAP-Column IA, JA, A storage for the matrix -C A. ISYM is a flag which, if non-zero, denotes that A is -C symmetric and only the lower or upper triangle is stored. -C MSOLVE :EXT External. -C Name of a routine which solves a linear system MZ = R for -C Z given R with the preconditioning matrix M (M is supplied via -C RWORK and IWORK arrays). The name of the MSOLVE routine must -C be declared external in the calling program. The calling -C sequence to MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, R is the right-hand side -C vector and Z is the solution upon return. NELT, IA, JA, A and -C ISYM are defined as above. RWORK is a double precision array -C that can be used to pass necessary preconditioning information -C and/or workspace to MSOLVE. IWORK is an integer work array -C for the same purpose as RWORK. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /DSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :IN Double Precision. -C Convergence criterion, as described above. -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :IN Integer. -C Current iteration count. (Must be zero on first call.) -C ERR :OUT Double Precision. -C Error estimate of error in the X(N) approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Error flag. IERR is set to 3 if ITOL is not one of the -C acceptable values, see above. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C R :IN Double Precision R(N). -C The residual R = B-AX. -C Z :WORK Double Precision Z(N). -C Double Precision array used for workspace. -C P :IN Double Precision P(N). -C The conjugate direction vector. -C ATP :IN Double Precision ATP(N). -C A-transpose times the conjugate direction vector. -C ATZ :IN Double Precision ATZ(N). -C A-transpose times the pseudo-residual. -C DZ :IN Double Precision DZ(N). -C Workspace used to hold temporary vector(s). -C ATDZ :WORK Double Precision ATDZ(N). -C Workspace. -C RWORK :WORK Double Precision RWORK(USER DEFINED). -C Double Precision array that can be used by MSOLVE. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used by MSOLVE. -C AK :IN Double Precision. -C BK :IN Double Precision. -C Current conjugate gradient parameters alpha and beta. -C BNRM :INOUT Double Precision. -C Norm of the right hand side. Type of norm depends on ITOL. -C Calculated only on the first call. -C SOLNRM :INOUT Double Precision. -C 2-Norm of the true solution, SOLN. Only computed and used -C if ITOL = 11. -C -C *Function Return Values: -C 0 : Error estimate (determined by ITOL) is *NOT* less than the -C specified tolerance, TOL. The iteration must continue. -C 1 : Error estimate (determined by ITOL) is less than the -C specified tolerance, TOL. The iteration can be considered -C complete. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO DCGN -C***ROUTINES CALLED D1MACH, DNRM2 -C***COMMON BLOCKS DSLBLK -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 891003 Removed C***REFER TO line, per MKS. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MATVEC, MTTVEC and MSOLVE from ROUTINES CALLED -C list. (FNF) -C 910506 Made subsidiary to DCGN. (FNF) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920930 Corrected to not print AK,BK when ITER=0. (FNF) -C 921026 Changed 1.0E10 to D1MACH(2) and corrected D to E in -C output format. (FNF) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE ISDCGN -C .. Scalar Arguments .. - DOUBLE PRECISION AK, BK, BNRM, ERR, SOLNRM, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(N), ATDZ(N), ATP(N), ATZ(N), B(N), DZ(N), P(N), - + R(N), RWORK(*), X(N), Z(N) - INTEGER IA(NELT), IWORK(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MATVEC, MSOLVE, MTTVEC -C .. Arrays in Common .. - DOUBLE PRECISION SOLN(1) -C .. Local Scalars .. - INTEGER I -C .. External Functions .. - DOUBLE PRECISION D1MACH, DNRM2 - EXTERNAL D1MACH, DNRM2 -C .. Common blocks .. - COMMON /DSLBLK/ SOLN -C***FIRST EXECUTABLE STATEMENT ISDCGN - ISDCGN = 0 -C - IF( ITOL.EQ.1 ) THEN -C err = ||Residual||/||RightHandSide|| (2-Norms). - IF(ITER .EQ. 0) BNRM = DNRM2(N, B, 1) - ERR = DNRM2(N, R, 1)/BNRM - ELSE IF( ITOL.EQ.2 ) THEN -C -1 -1 -C err = ||M Residual||/||M RightHandSide|| (2-Norms). - IF(ITER .EQ. 0) THEN - CALL MSOLVE(N, B, DZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) - CALL MTTVEC(N, DZ, ATDZ, NELT, IA, JA, A, ISYM) - BNRM = DNRM2(N, ATDZ, 1) - ENDIF - ERR = DNRM2(N, ATZ, 1)/BNRM - ELSE IF( ITOL.EQ.11 ) THEN -C err = ||x-TrueSolution||/||TrueSolution|| (2-Norms). - IF(ITER .EQ. 0) SOLNRM = DNRM2(N, SOLN, 1) - DO 10 I = 1, N - DZ(I) = X(I) - SOLN(I) - 10 CONTINUE - ERR = DNRM2(N, DZ, 1)/SOLNRM - ELSE -C -C If we get here ITOL is not one of the acceptable values. - ERR = D1MACH(2) - IERR = 3 - ENDIF -C - IF( IUNIT.NE.0 ) THEN - IF( ITER.EQ.0 ) THEN - WRITE(IUNIT,1000) N, ITOL - WRITE(IUNIT,1010) ITER, ERR - ELSE - WRITE(IUNIT,1010) ITER, ERR, AK, BK - ENDIF - ENDIF - IF( ERR.LE.TOL ) ISDCGN = 1 -C - RETURN - 1000 FORMAT(' PCG Applied to the Normal Equations for ', - $ 'N, ITOL = ',I5, I5, - $ /' ITER',' Error Estimate',' Alpha', - $ ' Beta') - 1010 FORMAT(1X,I4,1X,D16.7,1X,D16.7,1X,D16.7) -C------------- LAST LINE OF ISDCGN FOLLOWS ---------------------------- - END diff --git a/slatec/isdcgs.f b/slatec/isdcgs.f deleted file mode 100644 index 91c1721..0000000 --- a/slatec/isdcgs.f +++ /dev/null @@ -1,261 +0,0 @@ -*DECK ISDCGS - INTEGER FUNCTION ISDCGS (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, - + MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, R0, P, Q, - + U, V1, V2, RWORK, IWORK, AK, BK, BNRM, SOLNRM) -C***BEGIN PROLOGUE ISDCGS -C***SUBSIDIARY -C***PURPOSE Preconditioned BiConjugate Gradient Squared Stop Test. -C This routine calculates the stop test for the BiConjugate -C Gradient Squared iteration scheme. It returns a non-zero -C if the error estimate (the type of which is determined by -C ITOL) is less than the user specified tolerance TOL. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (ISSCGS-S, ISDCGS-D) -C***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, SLAP, -C SPARSE, STOP TEST -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER -C INTEGER IERR, IUNIT, IWORK(USER DEFINED) -C DOUBLE PRECISION B(N), X(N), A(N), TOL, ERR, R(N), R0(N), P(N) -C DOUBLE PRECISION Q(N), U(N), V1(N), V2(N) -C DOUBLE PRECISION RWORK(USER DEFINED), AK, BK, BNRM, SOLNRM -C EXTERNAL MATVEC, MSOLVE -C -C IF( ISDCGS(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, ITOL, -C $ TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, R0, P, Q, U, V1, -C $ V2, RWORK, IWORK, AK, BK, BNRM, SOLNRM) .NE. 0 ) -C $ THEN ITERATION DONE -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right-hand side vector. -C X :INOUT Double Precision X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Double Precision A(NELT). -C These arrays contain the matrix data structure for A. -C It could take any form. See "Description" in SLAP routine -C DCGS for more details. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C MATVEC :EXT External. -C Name of a routine which performs the matrix vector multiply -C operation Y = A*X given A and X. The name of the MATVEC -C routine must be declared external in the calling program. -C The calling sequence of MATVEC is: -C CALL MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) -C Where N is the number of unknowns, Y is the product A*X upon -C return, X is an input vector. NELT, IA, JA, A, and ISYM -C define the SLAP matrix data structure. -C MSOLVE :EXT External. -C Name of a routine which solves a linear system MZ = R for Z -C given R with the preconditioning matrix M (M is supplied via -C RWORK and IWORK arrays). The name of the MSOLVE routine -C must be declared external in the calling program. The -C calling sequence of MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, R is the right-hand side -C vector, and Z is the solution upon return. NELT, IA, JA, A, -C and ISYM define the SLAP matrix data structure. -C RWORK is a double precision array that can be used to pass -C necessary preconditioning information and/or workspace to -C MSOLVE. -C IWORK is an integer work array for the same purpose as RWORK. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C This routine must calculate the residual from R = A*X - B. -C This is unnatural and hence expensive for this type of iter- -C ative method. ITOL=2 is *STRONGLY* recommended. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv time a vector is the pre- -C conditioning step. This is the *NATURAL* stopping for this -C iterative method and is *STRONGLY* recommended. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /DSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :IN Double Precision. -C Convergence criterion, as described above. -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :IN Integer. -C Current iteration count. (Must be zero on first call.) -C ITMAX iterations. -C ERR :OUT Double Precision. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Error flag. IERR is set to 3 if ITOL is not one of the -C acceptable values, see above. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C R :IN Double Precision R(N). -C The residual r = b - Ax. -C R0 :WORK Double Precision R0(N). -C P :DUMMY Double Precision P(N). -C Q :DUMMY Double Precision Q(N). -C U :DUMMY Double Precision U(N). -C V1 :DUMMY Double Precision V1(N). -C Double Precision arrays used for workspace. -C V2 :WORK Double Precision V2(N). -C If ITOL.eq.1 then V2 is used to hold A * X - B on every call. -C If ITOL.eq.2 then V2 is used to hold M-inv * B on the first -C call. -C If ITOL.eq.11 then V2 is used to X - SOLN. -C RWORK :WORK Double Precision RWORK(USER DEFINED). -C Double Precision array that can be used for workspace in -C MSOLVE. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used for workspace in MSOLVE. -C AK :IN Double Precision. -C Current iterate BiConjugate Gradient iteration parameter. -C BK :IN Double Precision. -C Current iterate BiConjugate Gradient iteration parameter. -C BNRM :INOUT Double Precision. -C Norm of the right hand side. Type of norm depends on ITOL. -C Calculated only on the first call. -C SOLNRM :INOUT Double Precision. -C 2-Norm of the true solution, SOLN. Only computed and used -C if ITOL = 11. -C -C *Function Return Values: -C 0 : Error estimate (determined by ITOL) is *NOT* less than the -C specified tolerance, TOL. The iteration must continue. -C 1 : Error estimate (determined by ITOL) is less than the -C specified tolerance, TOL. The iteration can be considered -C complete. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO DCGS -C***ROUTINES CALLED D1MACH, DNRM2 -C***COMMON BLOCKS DSLBLK -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 891003 Removed C***REFER TO line, per MKS. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MATVEC and MSOLVE from ROUTINES CALLED list. (FNF) -C 910506 Made subsidiary to DCGS. (FNF) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920930 Corrected to not print AK,BK when ITER=0. (FNF) -C 921026 Changed 1.0E10 to D1MACH(2) and corrected D to E in -C output format. (FNF) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE ISDCGS -C .. Scalar Arguments .. - DOUBLE PRECISION AK, BK, BNRM, ERR, SOLNRM, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), B(N), P(N), Q(N), R(N), R0(N), RWORK(*), - + U(N), V1(N), V2(N), X(N) - INTEGER IA(NELT), IWORK(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MATVEC, MSOLVE -C .. Arrays in Common .. - DOUBLE PRECISION SOLN(1) -C .. Local Scalars .. - INTEGER I -C .. External Functions .. - DOUBLE PRECISION D1MACH, DNRM2 - EXTERNAL D1MACH, DNRM2 -C .. Common blocks .. - COMMON /DSLBLK/ SOLN -C***FIRST EXECUTABLE STATEMENT ISDCGS - ISDCGS = 0 -C - IF( ITOL.EQ.1 ) THEN -C err = ||Residual||/||RightHandSide|| (2-Norms). - IF(ITER .EQ. 0) BNRM = DNRM2(N, B, 1) - CALL MATVEC(N, X, V2, NELT, IA, JA, A, ISYM ) - DO 5 I = 1, N - V2(I) = V2(I) - B(I) - 5 CONTINUE - ERR = DNRM2(N, V2, 1)/BNRM - ELSE IF( ITOL.EQ.2 ) THEN -C -1 -1 -C err = ||M Residual||/||M RightHandSide|| (2-Norms). - IF(ITER .EQ. 0) THEN - CALL MSOLVE(N, B, V2, NELT, IA, JA, A, ISYM, RWORK, IWORK) - BNRM = DNRM2(N, V2, 1) - ENDIF - ERR = DNRM2(N, R, 1)/BNRM - ELSE IF( ITOL.EQ.11 ) THEN -C err = ||x-TrueSolution||/||TrueSolution|| (2-Norms). - IF(ITER .EQ. 0) SOLNRM = DNRM2(N, SOLN, 1) - DO 10 I = 1, N - V2(I) = X(I) - SOLN(I) - 10 CONTINUE - ERR = DNRM2(N, V2, 1)/SOLNRM - ELSE -C -C If we get here ITOL is not one of the acceptable values. - ERR = D1MACH(2) - IERR = 3 - ENDIF -C -C Print the error and Coefficients AK, BK on each step, -C if desired. - IF(IUNIT .NE. 0) THEN - IF( ITER.EQ.0 ) THEN - WRITE(IUNIT,1000) N, ITOL - WRITE(IUNIT,1010) ITER, ERR - ELSE - WRITE(IUNIT,1010) ITER, ERR, AK, BK - ENDIF - ENDIF - IF(ERR .LE. TOL) ISDCGS = 1 -C - RETURN - 1000 FORMAT(' Preconditioned BiConjugate Gradient Squared for ', - $ 'N, ITOL = ',I5, I5, - $ /' ITER',' Error Estimate',' Alpha', - $ ' Beta') - 1010 FORMAT(1X,I4,1X,D16.7,1X,D16.7,1X,D16.7) -C------------- LAST LINE OF ISDCGS FOLLOWS ---------------------------- - END diff --git a/slatec/isdgmr.f b/slatec/isdgmr.f deleted file mode 100644 index a2e2569..0000000 --- a/slatec/isdgmr.f +++ /dev/null @@ -1,402 +0,0 @@ -*DECK ISDGMR - INTEGER FUNCTION ISDGMR (N, B, X, XL, NELT, IA, JA, A, ISYM, - + MSOLVE, NMSL, ITOL, TOL, ITMAX, ITER, ERR, IUNIT, R, Z, DZ, - + RWORK, IWORK, RNRM, BNRM, SB, SX, JSCAL, KMP, LGMR, MAXL, - + MAXLP1, V, Q, SNORMW, PROD, R0NRM, HES, JPRE) -C***BEGIN PROLOGUE ISDGMR -C***SUBSIDIARY -C***PURPOSE Generalized Minimum Residual Stop Test. -C This routine calculates the stop test for the Generalized -C Minimum RESidual (GMRES) iteration scheme. It returns a -C non-zero if the error estimate (the type of which is -C determined by ITOL) is less than the user specified -C tolerance TOL. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (ISSGMR-S, ISDGMR-D) -C***KEYWORDS GMRES, LINEAR SYSTEM, SLAP, SPARSE, STOP TEST -C***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov -C Hindmarsh, Alan, (LLNL), alanh@llnl.gov -C Seager, Mark K., (LLNL), seager@llnl.gov -C Lawrence Livermore National Laboratory -C PO Box 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NMSL, ITOL -C INTEGER ITMAX, ITER, IUNIT, IWORK(USER DEFINED), JSCAL -C INTEGER KMP, LGMR, MAXL, MAXLP1, JPRE -C DOUBLE PRECISION B(N), X(N), XL(MAXL), A(NELT), TOL, ERR, -C $ R(N), Z(N), DZ(N), RWORK(USER DEFINED), -C $ RNRM, BNRM, SB(N), SX(N), V(N,MAXLP1), -C $ Q(2*MAXL), SNORMW, PROD, R0NRM, -C $ HES(MAXLP1,MAXL) -C EXTERNAL MSOLVE -C -C IF (ISDGMR(N, B, X, XL, NELT, IA, JA, A, ISYM, MSOLVE, -C $ NMSL, ITOL, TOL, ITMAX, ITER, ERR, IUNIT, R, Z, DZ, -C $ RWORK, IWORK, RNRM, BNRM, SB, SX, JSCAL, -C $ KMP, LGMR, MAXL, MAXLP1, V, Q, SNORMW, PROD, R0NRM, -C $ HES, JPRE) .NE. 0) THEN ITERATION DONE -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right-hand-side vector. -C X :IN Double Precision X(N). -C Approximate solution vector as of the last restart. -C XL :OUT Double Precision XL(N) -C An array of length N used to hold the approximate -C solution as of the current iteration. Only computed by -C this routine when ITOL=11. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Double Precision A(NELT). -C These arrays contain the matrix data structure for A. -C It could take any form. See "Description", in the DGMRES, -C DSLUGM and DSDGMR routines for more details. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C MSOLVE :EXT External. -C Name of a routine which solves a linear system Mz = r for z -C given r with the preconditioning matrix M (M is supplied via -C RWORK and IWORK arrays. The name of the MSOLVE routine must -C be declared external in the calling program. The calling -C sequence to MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, R is the right-hand side -C vector and Z is the solution upon return. NELT, IA, JA, A and -C ISYM are defined as above. RWORK is a double precision array -C that can be used to pass necessary preconditioning information -C and/or workspace to MSOLVE. IWORK is an integer work array -C for the same purpose as RWORK. -C NMSL :INOUT Integer. -C A counter for the number of calls to MSOLVE. -C ITOL :IN Integer. -C Flag to indicate the type of convergence criterion used. -C ITOL=0 Means the iteration stops when the test described -C below on the residual RL is satisfied. This is -C the "Natural Stopping Criteria" for this routine. -C Other values of ITOL cause extra, otherwise -C unnecessary, computation per iteration and are -C therefore much less efficient. -C ITOL=1 Means the iteration stops when the first test -C described below on the residual RL is satisfied, -C and there is either right or no preconditioning -C being used. -C ITOL=2 Implies that the user is using left -C preconditioning, and the second stopping criterion -C below is used. -C ITOL=3 Means the iteration stops when the third test -C described below on Minv*Residual is satisfied, and -C there is either left or no preconditioning begin -C used. -C ITOL=11 is often useful for checking and comparing -C different routines. For this case, the user must -C supply the "exact" solution or a very accurate -C approximation (one with an error much less than -C TOL) through a common block, -C COMMON /DSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the -C difference between the iterative approximation and -C the user-supplied solution divided by the 2-norm -C of the user-supplied solution is less than TOL. -C Note that this requires the user to set up the -C "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling -C routine. The routine with this declaration should -C be loaded before the stop test so that the correct -C length is used by the loader. This procedure is -C not standard Fortran and may not work correctly on -C your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 -C then this common block is indeed standard Fortran. -C TOL :IN Double Precision. -C Convergence criterion, as described above. -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :IN Integer. -C The iteration for which to check for convergence. -C ERR :OUT Double Precision. -C Error estimate of error in final approximate solution, as -C defined by ITOL. Letting norm() denote the Euclidean -C norm, ERR is defined as follows.. -C -C If ITOL=0, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), -C for right or no preconditioning, and -C ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ -C norm(SB*(M-inverse)*B), -C for left preconditioning. -C If ITOL=1, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), -C since right or no preconditioning -C being used. -C If ITOL=2, then ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ -C norm(SB*(M-inverse)*B), -C since left preconditioning is being -C used. -C If ITOL=3, then ERR = Max |(Minv*(B-A*X(L)))(i)/x(i)| -C i=1,n -C If ITOL=11, then ERR = norm(SB*(X(L)-SOLN))/norm(SB*SOLN). -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C R :INOUT Double Precision R(N). -C Work array used in calling routine. It contains -C information necessary to compute the residual RL = B-A*XL. -C Z :WORK Double Precision Z(N). -C Workspace used to hold the pseudo-residual M z = r. -C DZ :WORK Double Precision DZ(N). -C Workspace used to hold temporary vector(s). -C RWORK :WORK Double Precision RWORK(USER DEFINED). -C Double Precision array that can be used by MSOLVE. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used by MSOLVE. -C RNRM :IN Double Precision. -C Norm of the current residual. Type of norm depends on ITOL. -C BNRM :IN Double Precision. -C Norm of the right hand side. Type of norm depends on ITOL. -C SB :IN Double Precision SB(N). -C Scaling vector for B. -C SX :IN Double Precision SX(N). -C Scaling vector for X. -C JSCAL :IN Integer. -C Flag indicating if scaling arrays SB and SX are being -C used in the calling routine DPIGMR. -C JSCAL=0 means SB and SX are not used and the -C algorithm will perform as if all -C SB(i) = 1 and SX(i) = 1. -C JSCAL=1 means only SX is used, and the algorithm -C performs as if all SB(i) = 1. -C JSCAL=2 means only SB is used, and the algorithm -C performs as if all SX(i) = 1. -C JSCAL=3 means both SB and SX are used. -C KMP :IN Integer -C The number of previous vectors the new vector VNEW -C must be made orthogonal to. (KMP .le. MAXL) -C LGMR :IN Integer -C The number of GMRES iterations performed on the current call -C to DPIGMR (i.e., # iterations since the last restart) and -C the current order of the upper Hessenberg -C matrix HES. -C MAXL :IN Integer -C The maximum allowable order of the matrix H. -C MAXLP1 :IN Integer -C MAXPL1 = MAXL + 1, used for dynamic dimensioning of HES. -C V :IN Double Precision V(N,MAXLP1) -C The N by (LGMR+1) array containing the LGMR -C orthogonal vectors V(*,1) to V(*,LGMR). -C Q :IN Double Precision Q(2*MAXL) -C A double precision array of length 2*MAXL containing the -C components of the Givens rotations used in the QR -C decomposition of HES. -C SNORMW :IN Double Precision -C A scalar containing the scaled norm of VNEW before it -C is renormalized in DPIGMR. -C PROD :IN Double Precision -C The product s1*s2*...*sl = the product of the sines of the -C Givens rotations used in the QR factorization of the -C Hessenberg matrix HES. -C R0NRM :IN Double Precision -C The scaled norm of initial residual R0. -C HES :IN Double Precision HES(MAXLP1,MAXL) -C 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 JPRE :IN Integer -C Preconditioner type flag. -C (See description of IGWK(4) in DGMRES.) -C -C *Description -C When using the GMRES solver, the preferred value for ITOL -C is 0. This is due to the fact that when ITOL=0 the norm of -C the residual required in the stopping test is obtained for -C free, since this value is already calculated in the GMRES -C algorithm. The variable RNRM contains the appropriate -C norm, which is equal to norm(SB*(RL - A*XL)) when right or -C no preconditioning is being performed, and equal to -C norm(SB*Minv*(RL - A*XL)) when using left preconditioning. -C Here, norm() is the Euclidean norm. Nonzero values of ITOL -C require additional work to calculate the actual scaled -C residual or its scaled/preconditioned form, and/or the -C approximate solution XL. Hence, these values of ITOL will -C not be as efficient as ITOL=0. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C This routine does not verify that ITOL has a valid value. -C The calling routine should make such a test before calling -C ISDGMR, as is done in DGMRES. -C -C***SEE ALSO DGMRES -C***ROUTINES CALLED D1MACH, DCOPY, DNRM2, DRLCAL, DSCAL, DXLCAL -C***COMMON BLOCKS DSLBLK -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Corrected conversion errors, etc. (FNF) -C 910502 Removed MSOLVE from ROUTINES CALLED list. (FNF) -C 910506 Made subsidiary to DGMRES. (FNF) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 921026 Corrected D to E in output format. (FNF) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE ISDGMR -C .. Scalar Arguments .. - DOUBLE PRECISION BNRM, ERR, PROD, R0NRM, RNRM, SNORMW, TOL - INTEGER ISYM, ITER, ITMAX, ITOL, IUNIT, JPRE, JSCAL, KMP, LGMR, - + MAXL, MAXLP1, N, NELT, NMSL -C .. Array Arguments .. - DOUBLE PRECISION A(*), B(*), DZ(*), HES(MAXLP1, MAXL), Q(*), R(*), - + RWORK(*), SB(*), SX(*), V(N,*), X(*), XL(*), Z(*) - INTEGER IA(*), IWORK(*), JA(*) -C .. Subroutine Arguments .. - EXTERNAL MSOLVE -C .. Arrays in Common .. - DOUBLE PRECISION SOLN(1) -C .. Local Scalars .. - DOUBLE PRECISION DXNRM, FUZZ, RAT, RATMAX, SOLNRM, TEM - INTEGER I, IELMAX -C .. External Functions .. - DOUBLE PRECISION D1MACH, DNRM2 - EXTERNAL D1MACH, DNRM2 -C .. External Subroutines .. - EXTERNAL DCOPY, DRLCAL, DSCAL, DXLCAL -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -C .. Common blocks .. - COMMON /DSLBLK/ SOLN -C .. Save statement .. - SAVE SOLNRM -C***FIRST EXECUTABLE STATEMENT ISDGMR - ISDGMR = 0 - IF ( ITOL.EQ.0 ) THEN -C -C Use input from DPIGMR to determine if stop conditions are met. -C - ERR = RNRM/BNRM - ENDIF - IF ( (ITOL.GT.0) .AND. (ITOL.LE.3) ) THEN -C -C Use DRLCAL to calculate the scaled residual vector. -C Store answer in R. -C - IF ( LGMR.NE.0 ) CALL DRLCAL(N, KMP, LGMR, MAXL, V, Q, R, - $ SNORMW, PROD, R0NRM) - IF ( ITOL.LE.2 ) THEN -C err = ||Residual||/||RightHandSide||(2-Norms). - ERR = DNRM2(N, R, 1)/BNRM -C -C Unscale R by R0NRM*PROD when KMP < MAXL. -C - IF ( (KMP.LT.MAXL) .AND. (LGMR.NE.0) ) THEN - TEM = 1.0D0/(R0NRM*PROD) - CALL DSCAL(N, TEM, R, 1) - ENDIF - ELSEIF ( ITOL.EQ.3 ) THEN -C err = Max |(Minv*Residual)(i)/x(i)| -C When JPRE .lt. 0, R already contains Minv*Residual. - IF ( JPRE.GT.0 ) THEN - CALL MSOLVE(N, R, DZ, NELT, IA, JA, A, ISYM, RWORK, - $ IWORK) - NMSL = NMSL + 1 - ENDIF -C -C Unscale R by R0NRM*PROD when KMP < MAXL. -C - IF ( (KMP.LT.MAXL) .AND. (LGMR.NE.0) ) THEN - TEM = 1.0D0/(R0NRM*PROD) - CALL DSCAL(N, TEM, R, 1) - ENDIF -C - FUZZ = D1MACH(1) - IELMAX = 1 - RATMAX = ABS(DZ(1))/MAX(ABS(X(1)),FUZZ) - DO 25 I = 2, N - RAT = ABS(DZ(I))/MAX(ABS(X(I)),FUZZ) - IF( RAT.GT.RATMAX ) THEN - IELMAX = I - RATMAX = RAT - ENDIF - 25 CONTINUE - ERR = RATMAX - IF( RATMAX.LE.TOL ) ISDGMR = 1 - IF( IUNIT.GT.0 ) WRITE(IUNIT,1020) ITER, IELMAX, RATMAX - RETURN - ENDIF - ENDIF - IF ( ITOL.EQ.11 ) THEN -C -C Use DXLCAL to calculate the approximate solution XL. -C - IF ( (LGMR.NE.0) .AND. (ITER.GT.0) ) THEN - CALL DXLCAL(N, LGMR, X, XL, XL, HES, MAXLP1, Q, V, R0NRM, - $ DZ, SX, JSCAL, JPRE, MSOLVE, NMSL, RWORK, IWORK, - $ NELT, IA, JA, A, ISYM) - ELSEIF ( ITER.EQ.0 ) THEN -C Copy X to XL to check if initial guess is good enough. - CALL DCOPY(N, X, 1, XL, 1) - ELSE -C Return since this is the first call to DPIGMR on a restart. - RETURN - ENDIF -C - IF ((JSCAL .EQ. 0) .OR.(JSCAL .EQ. 2)) THEN -C err = ||x-TrueSolution||/||TrueSolution||(2-Norms). - IF ( ITER.EQ.0 ) SOLNRM = DNRM2(N, SOLN, 1) - DO 30 I = 1, N - DZ(I) = XL(I) - SOLN(I) - 30 CONTINUE - ERR = DNRM2(N, DZ, 1)/SOLNRM - ELSE - IF (ITER .EQ. 0) THEN - SOLNRM = 0 - DO 40 I = 1,N - SOLNRM = SOLNRM + (SX(I)*SOLN(I))**2 - 40 CONTINUE - SOLNRM = SQRT(SOLNRM) - ENDIF - DXNRM = 0 - DO 50 I = 1,N - DXNRM = DXNRM + (SX(I)*(XL(I)-SOLN(I)))**2 - 50 CONTINUE - DXNRM = SQRT(DXNRM) -C err = ||SX*(x-TrueSolution)||/||SX*TrueSolution|| (2-Norms). - ERR = DXNRM/SOLNRM - ENDIF - ENDIF -C - IF( IUNIT.NE.0 ) THEN - IF( ITER.EQ.0 ) THEN - WRITE(IUNIT,1000) N, ITOL, MAXL, KMP - ENDIF - WRITE(IUNIT,1010) ITER, RNRM/BNRM, ERR - ENDIF - IF ( ERR.LE.TOL ) ISDGMR = 1 -C - RETURN - 1000 FORMAT(' Generalized Minimum Residual(',I3,I3,') for ', - $ 'N, ITOL = ',I5, I5, - $ /' ITER',' Natural Err Est',' Error Estimate') - 1010 FORMAT(1X,I4,1X,D16.7,1X,D16.7) - 1020 FORMAT(1X,' ITER = ',I5, ' IELMAX = ',I5, - $ ' |R(IELMAX)/X(IELMAX)| = ',D12.5) -C------------- LAST LINE OF ISDGMR FOLLOWS ---------------------------- - END diff --git a/slatec/isdir.f b/slatec/isdir.f deleted file mode 100644 index 7fc2c7c..0000000 --- a/slatec/isdir.f +++ /dev/null @@ -1,212 +0,0 @@ -*DECK ISDIR - INTEGER FUNCTION ISDIR (N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, - + ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, - + IWORK, BNRM, SOLNRM) -C***BEGIN PROLOGUE ISDIR -C***SUBSIDIARY -C***PURPOSE Preconditioned Iterative Refinement Stop Test. -C This routine calculates the stop test for the iterative -C refinement iteration scheme. It returns a non-zero if the -C error estimate (the type of which is determined by ITOL) -C is less than the user specified tolerance TOL. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (ISSIR-S, ISDIR-D) -C***KEYWORDS LINEAR SYSTEM, SLAP, SPARSE, STOP TEST -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER -C INTEGER IERR, IUNIT, IWORK(USER DEFINED) -C DOUBLE PRECISION B(N), X(N), A(N), TOL, ERR, R(N), Z(N), DZ(N) -C DOUBLE PRECISION RWORK(USER DEFINED), BNRM, SOLNRM -C EXTERNAL MSOLVE -C -C IF( ISDIR(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, IWORK, -C $ BNRM, SOLNRM) .NE. 0 ) THEN ITERATION DONE -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Double Precision B(N). -C Right-hand side vector. -C X :IN Double Precision X(N). -C The current approximate solution vector. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Double Precision A(NELT). -C These arrays contain the matrix data structure for A. -C It could take any form. See "C *Description" in the -C DIR routine. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C MSOLVE :EXT External. -C Name of a routine which solves a linear system Mz = r for -C z given r with the preconditioning matrix M (M is supplied via -C RWORK and IWORK arrays. The name of the MSOLVE routine must -C be declared external in the calling program. The calling -C sequence to MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, R is the right-hand side -C vector and Z is the solution upon return. NELT, IA, JA, A and -C ISYM are defined as above. RWORK is a double precision array -C that can be used to pass necessary preconditioning information -C and/or workspace to MSOLVE. IWORK is an integer work array -C for the same purpose as RWORK. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /DSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :IN Double Precision. -C Convergence criterion, as described above. -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :IN Integer. -C Current iteration count. (Must be zero on first call.) -C ERR :OUT Double Precision. -C Error estimate of error in the X(N) approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Error flag. IERR is set to 3 if ITOL is not one of the -C acceptable values, see above. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C R :IN Double Precision R(N). -C The residual R = B-AX. -C Z :WORK Double Precision Z(N). -C Workspace used to hold the pseudo-residual M z = r. -C DZ :WORK Double Precision DZ(N). -C Workspace used to hold temporary vector(s). -C RWORK :WORK Double Precision RWORK(USER DEFINED). -C Double Precision array that can be used by MSOLVE. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used by MSOLVE. -C BNRM :INOUT Double Precision. -C Norm of the right hand side. Type of norm depends on ITOL. -C Calculated only on the first call. -C SOLNRM :INOUT Double Precision. -C 2-Norm of the true solution, SOLN. Only computed and used -C if ITOL = 11. -C -C *Function Return Values: -C 0 : Error estimate (determined by ITOL) is *NOT* less than the -C specified tolerance, TOL. The iteration must continue. -C 1 : Error estimate (determined by ITOL) is less than the -C specified tolerance, TOL. The iteration can be considered -C complete. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO DIR, DSJAC, DSGS -C***ROUTINES CALLED D1MACH, DNRM2 -C***COMMON BLOCKS DSLBLK -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 880320 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 891003 Removed C***REFER TO line, per MKS. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MSOLVE from ROUTINES CALLED list. (FNF) -C 910506 Made subsidiary to DIR. (FNF) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 921026 Changed 1.0E10 to D1MACH(2) and corrected E to D in -C output format. (FNF) -C***END PROLOGUE ISDIR -C .. Scalar Arguments .. - DOUBLE PRECISION BNRM, ERR, SOLNRM, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), B(N), DZ(N), R(N), RWORK(*), X(N), Z(N) - INTEGER IA(NELT), IWORK(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MSOLVE -C .. Arrays in Common .. - DOUBLE PRECISION SOLN(1) -C .. Local Scalars .. - INTEGER I -C .. External Functions .. - DOUBLE PRECISION D1MACH, DNRM2 - EXTERNAL D1MACH, DNRM2 -C .. Common blocks .. - COMMON /DSLBLK/ SOLN -C***FIRST EXECUTABLE STATEMENT ISDIR - ISDIR = 0 - IF( ITOL.EQ.1 ) THEN -C err = ||Residual||/||RightHandSide|| (2-Norms). - IF(ITER .EQ. 0) BNRM = DNRM2(N, B, 1) - ERR = DNRM2(N, R, 1)/BNRM - ELSE IF( ITOL.EQ.2 ) THEN -C -1 -1 -C err = ||M Residual||/||M RightHandSide|| (2-Norms). - IF(ITER .EQ. 0) THEN - CALL MSOLVE(N, B, DZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) - BNRM = DNRM2(N, DZ, 1) - ENDIF - ERR = DNRM2(N, Z, 1)/BNRM - ELSE IF( ITOL.EQ.11 ) THEN -C err = ||x-TrueSolution||/||TrueSolution|| (2-Norms). - IF( ITER.EQ.0 ) SOLNRM = DNRM2(N, SOLN, 1) - DO 10 I = 1, N - DZ(I) = X(I) - SOLN(I) - 10 CONTINUE - ERR = DNRM2(N, DZ, 1)/SOLNRM - ELSE -C -C If we get here ITOL is not one of the acceptable values. - ERR = D1MACH(2) - IERR = 3 - ENDIF -C - IF( IUNIT.NE.0 ) THEN - WRITE(IUNIT,1000) ITER,ERR - ENDIF -C - IF( ERR.LE.TOL ) ISDIR = 1 -C - RETURN - 1000 FORMAT(5X,'ITER = ',I4,' Error Estimate = ',D16.7) -C------------- LAST LINE OF ISDIR FOLLOWS ----------------------------- - END diff --git a/slatec/isdomn.f b/slatec/isdomn.f deleted file mode 100644 index f7df0b7..0000000 --- a/slatec/isdomn.f +++ /dev/null @@ -1,239 +0,0 @@ -*DECK ISDOMN - INTEGER FUNCTION ISDOMN (N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, - + NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, AP, - + EMAP, DZ, CSAV, RWORK, IWORK, AK, BNRM, SOLNRM) -C***BEGIN PROLOGUE ISDOMN -C***SUBSIDIARY -C***PURPOSE Preconditioned Orthomin Stop Test. -C This routine calculates the stop test for the Orthomin -C iteration scheme. It returns a non-zero if the error -C estimate (the type of which is determined by ITOL) is -C less than the user specified tolerance TOL. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE DOUBLE PRECISION (ISSOMN-S, ISDOMN-D) -C***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, -C ORTHOMIN, SLAP, SPARSE, STOP TEST -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NSAVE, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) -C DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N) -C DOUBLE PRECISION P(N,0:NSAVE), AP(N,0:NSAVE), EMAP(N,0:NSAVE) -C DOUBLE PRECISION DZ(N), CSAV(NSAVE), RWORK(USER DEFINED), AK -C DOUBLE PRECISION BNRM, SOLNRM -C EXTERNAL MSOLVE -C -C IF( ISDOMN(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, NSAVE, -C $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, AP, -C $ EMAP, DZ, CSAV, RWORK, IWORK, AK, BNRM, SOLNRM) -C $ .NE.0 ) THEN ITERATION CONVERGED -C -C *Arguments: -C N :IN Integer. -C Order of the matrix. -C B :IN Double Precision B(N). -C Right-hand side vector. -C X :IN Double Precision X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Double Precision A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description" -C in the DSDOMN or DSLUOM prologue. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C MSOLVE :EXT External. -C Name of a routine which solves a linear system MZ = R for -C Z given R with the preconditioning matrix M (M is supplied via -C RWORK and IWORK arrays). The name of the MSOLVE routine must -C be declared external in the calling program. The calling -C sequence to MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, R is the right-hand side -C vector and Z is the solution upon return. NELT, IA, JA, A and -C ISYM are defined as above. RWORK is a double precision array -C that can be used to pass necessary preconditioning information -C and/or workspace to MSOLVE. IWORK is an integer work array -C for the same purpose as RWORK. -C NSAVE :IN Integer. -C Number of direction vectors to save and orthogonalize against. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /DSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :IN Double Precision. -C Convergence criterion, as described above. -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :IN Integer. -C Current iteration count. (Must be zero on first call.) -C ERR :OUT Double Precision. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Error flag. IERR is set to 3 if ITOL is not one of the -C acceptable values, see above. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C R :IN Double Precision R(N). -C The residual R = B-AX. -C Z :WORK Double Precision Z(N). -C P :IN Double Precision P(N,0:NSAVE). -C Workspace used to hold the conjugate direction vector(s). -C AP :IN Double Precision AP(N,0:NSAVE). -C Workspace used to hold the matrix A times the P vector(s). -C EMAP :IN Double Precision EMAP(N,0:NSAVE). -C Workspace used to hold M-inv times the AP vector(s). -C DZ :WORK Double Precision DZ(N). -C Workspace. -C CSAV :DUMMY Double Precision CSAV(NSAVE) -C Reserved for future use. -C RWORK :WORK Double Precision RWORK(USER DEFINED). -C Double Precision array that can be used for workspace in -C MSOLVE. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used for workspace in MSOLVE. -C AK :IN Double Precision. -C Current iterate Orthomin iteration parameter. -C BNRM :OUT Double Precision. -C Current solution B-norm, if ITOL = 1 or 2. -C SOLNRM :OUT Double Precision. -C True solution norm, if ITOL = 11. -C -C *Function Return Values: -C 0 : Error estimate (determined by ITOL) is *NOT* less than the -C specified tolerance, TOL. The iteration must continue. -C 1 : Error estimate (determined by ITOL) is less than the -C specified tolerance, TOL. The iteration can be considered -C complete. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO DOMN, DSDOMN, DSLUOM -C***ROUTINES CALLED D1MACH, DNRM2 -C***COMMON BLOCKS DSLBLK -C***REVISION HISTORY (YYMMDD) -C 890404 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 891003 Removed C***REFER TO line, per MKS. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MSOLVE from ROUTINES CALLED list. (FNF) -C 910506 Made subsidiary to DOMN. (FNF) -C 920407 COMMON BLOCK renamed DSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920930 Corrected to not print AK when ITER=0. (FNF) -C 921026 Changed 1.0E10 to D1MACH(2) and corrected D to E in -C output format. (FNF) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE ISDOMN -C .. Scalar Arguments .. - DOUBLE PRECISION AK, BNRM, ERR, SOLNRM, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT, NSAVE -C .. Array Arguments .. - DOUBLE PRECISION A(NELT), AP(N,0:NSAVE), B(N), CSAV(NSAVE), - + DZ(N), EMAP(N,0:NSAVE), P(N,0:NSAVE), R(N), - + RWORK(*), X(N), Z(N) - INTEGER IA(NELT), IWORK(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MSOLVE -C .. Arrays in Common .. - DOUBLE PRECISION SOLN(1) -C .. Local Scalars .. - INTEGER I -C .. External Functions .. - DOUBLE PRECISION D1MACH, DNRM2 - EXTERNAL D1MACH, DNRM2 -C .. Common blocks .. - COMMON /DSLBLK/ SOLN -C***FIRST EXECUTABLE STATEMENT ISDOMN - ISDOMN = 0 -C - IF( ITOL.EQ.1 ) THEN -C err = ||Residual||/||RightHandSide|| (2-Norms). - IF(ITER .EQ. 0) BNRM = DNRM2(N, B, 1) - ERR = DNRM2(N, R, 1)/BNRM - ELSE IF( ITOL.EQ.2 ) THEN -C -1 -1 -C err = ||M Residual||/||M RightHandSide|| (2-Norms). - IF(ITER .EQ. 0) THEN - CALL MSOLVE(N, B, DZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) - BNRM = DNRM2(N, DZ, 1) - ENDIF - ERR = DNRM2(N, Z, 1)/BNRM - ELSE IF( ITOL.EQ.11 ) THEN -C err = ||x-TrueSolution||/||TrueSolution|| (2-Norms). - IF(ITER .EQ. 0) SOLNRM = DNRM2(N, SOLN, 1) - DO 10 I = 1, N - DZ(I) = X(I) - SOLN(I) - 10 CONTINUE - ERR = DNRM2(N, DZ, 1)/SOLNRM - ELSE -C -C If we get here ITOL is not one of the acceptable values. - ERR = D1MACH(2) - IERR = 3 - ENDIF -C - IF(IUNIT .NE. 0) THEN - IF( ITER.EQ.0 ) THEN - WRITE(IUNIT,1000) NSAVE, N, ITOL - WRITE(IUNIT,1010) ITER, ERR - ELSE - WRITE(IUNIT,1010) ITER, ERR, AK - ENDIF - ENDIF - IF(ERR .LE. TOL) ISDOMN = 1 -C - RETURN - 1000 FORMAT(' Preconditioned Orthomin(',I3,') for ', - $ 'N, ITOL = ',I5, I5, - $ /' ITER',' Error Estimate',' Alpha') - 1010 FORMAT(1X,I4,1X,D16.7,1X,D16.7) -C------------- LAST LINE OF ISDOMN FOLLOWS ---------------------------- - END diff --git a/slatec/isort.f b/slatec/isort.f deleted file mode 100644 index 10e9f90..0000000 --- a/slatec/isort.f +++ /dev/null @@ -1,323 +0,0 @@ -*DECK ISORT - SUBROUTINE ISORT (IX, IY, N, KFLAG) -C***BEGIN PROLOGUE ISORT -C***PURPOSE Sort an array and optionally make the same interchanges in -C an auxiliary array. The array may be sorted in increasing -C or decreasing order. A slightly modified QUICKSORT -C algorithm is used. -C***LIBRARY SLATEC -C***CATEGORY N6A2A -C***TYPE INTEGER (SSORT-S, DSORT-D, ISORT-I) -C***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING -C***AUTHOR Jones, R. E., (SNLA) -C Kahaner, D. K., (NBS) -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C -C ISORT sorts array IX and optionally makes the same interchanges in -C array IY. The array IX may be sorted in increasing order or -C decreasing order. A slightly modified quicksort algorithm is used. -C -C Description of Parameters -C IX - integer array of values to be sorted -C IY - integer array to be (optionally) carried along -C N - number of values in integer array IX to be sorted -C KFLAG - control parameter -C = 2 means sort IX in increasing order and carry IY along. -C = 1 means sort IX in increasing order (ignoring IY) -C = -1 means sort IX in decreasing order (ignoring IY) -C = -2 means sort IX in decreasing order and carry IY along. -C -C***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm -C for sorting with minimal storage, Communications of -C the ACM, 12, 3 (1969), pp. 185-187. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 761118 DATE WRITTEN -C 810801 Modified by David K. Kahaner. -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891009 Removed unreferenced statement labels. (WRB) -C 891009 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 901012 Declared all variables; changed X,Y to IX,IY. (M. McClain) -C 920501 Reformatted the REFERENCES section. (DWL, WRB) -C 920519 Clarified error messages. (DWL) -C 920801 Declarations section rebuilt and code restructured to use -C IF-THEN-ELSE-ENDIF. (RWC, WRB) -C***END PROLOGUE ISORT -C .. Scalar Arguments .. - INTEGER KFLAG, N -C .. Array Arguments .. - INTEGER IX(*), IY(*) -C .. Local Scalars .. - REAL R - INTEGER I, IJ, J, K, KK, L, M, NN, T, TT, TTY, TY -C .. Local Arrays .. - INTEGER IL(21), IU(21) -C .. External Subroutines .. - EXTERNAL XERMSG -C .. Intrinsic Functions .. - INTRINSIC ABS, INT -C***FIRST EXECUTABLE STATEMENT ISORT - NN = N - IF (NN .LT. 1) THEN - CALL XERMSG ('SLATEC', 'ISORT', - + 'The number of values to be sorted is not positive.', 1, 1) - RETURN - ENDIF -C - KK = ABS(KFLAG) - IF (KK.NE.1 .AND. KK.NE.2) THEN - CALL XERMSG ('SLATEC', 'ISORT', - + 'The sort control parameter, K, is not 2, 1, -1, or -2.', 2, - + 1) - RETURN - ENDIF -C -C Alter array IX to get decreasing order if needed -C - IF (KFLAG .LE. -1) THEN - DO 10 I=1,NN - IX(I) = -IX(I) - 10 CONTINUE - ENDIF -C - IF (KK .EQ. 2) GO TO 100 -C -C Sort IX only -C - M = 1 - I = 1 - J = NN - R = 0.375E0 -C - 20 IF (I .EQ. J) GO TO 60 - IF (R .LE. 0.5898437E0) THEN - R = R+3.90625E-2 - ELSE - R = R-0.21875E0 - ENDIF -C - 30 K = I -C -C Select a central element of the array and save it in location T -C - IJ = I + INT((J-I)*R) - T = IX(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (IX(I) .GT. T) THEN - IX(IJ) = IX(I) - IX(I) = T - T = IX(IJ) - ENDIF - L = J -C -C If last element of array is less than than T, interchange with T -C - IF (IX(J) .LT. T) THEN - IX(IJ) = IX(J) - IX(J) = T - T = IX(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (IX(I) .GT. T) THEN - IX(IJ) = IX(I) - IX(I) = T - T = IX(IJ) - ENDIF - ENDIF -C -C Find an element in the second half of the array which is smaller -C than T -C - 40 L = L-1 - IF (IX(L) .GT. T) GO TO 40 -C -C Find an element in the first half of the array which is greater -C than T -C - 50 K = K+1 - IF (IX(K) .LT. T) GO TO 50 -C -C Interchange these elements -C - IF (K .LE. L) THEN - TT = IX(L) - IX(L) = IX(K) - IX(K) = TT - GO TO 40 - ENDIF -C -C Save upper and lower subscripts of the array yet to be sorted -C - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 70 -C -C Begin again on another portion of the unsorted array -C - 60 M = M-1 - IF (M .EQ. 0) GO TO 190 - I = IL(M) - J = IU(M) -C - 70 IF (J-I .GE. 1) GO TO 30 - IF (I .EQ. 1) GO TO 20 - I = I-1 -C - 80 I = I+1 - IF (I .EQ. J) GO TO 60 - T = IX(I+1) - IF (IX(I) .LE. T) GO TO 80 - K = I -C - 90 IX(K+1) = IX(K) - K = K-1 - IF (T .LT. IX(K)) GO TO 90 - IX(K+1) = T - GO TO 80 -C -C Sort IX and carry IY along -C - 100 M = 1 - I = 1 - J = NN - R = 0.375E0 -C - 110 IF (I .EQ. J) GO TO 150 - IF (R .LE. 0.5898437E0) THEN - R = R+3.90625E-2 - ELSE - R = R-0.21875E0 - ENDIF -C - 120 K = I -C -C Select a central element of the array and save it in location T -C - IJ = I + INT((J-I)*R) - T = IX(IJ) - TY = IY(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (IX(I) .GT. T) THEN - IX(IJ) = IX(I) - IX(I) = T - T = IX(IJ) - IY(IJ) = IY(I) - IY(I) = TY - TY = IY(IJ) - ENDIF - L = J -C -C If last element of array is less than T, interchange with T -C - IF (IX(J) .LT. T) THEN - IX(IJ) = IX(J) - IX(J) = T - T = IX(IJ) - IY(IJ) = IY(J) - IY(J) = TY - TY = IY(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (IX(I) .GT. T) THEN - IX(IJ) = IX(I) - IX(I) = T - T = IX(IJ) - IY(IJ) = IY(I) - IY(I) = TY - TY = IY(IJ) - ENDIF - ENDIF -C -C Find an element in the second half of the array which is smaller -C than T -C - 130 L = L-1 - IF (IX(L) .GT. T) GO TO 130 -C -C Find an element in the first half of the array which is greater -C than T -C - 140 K = K+1 - IF (IX(K) .LT. T) GO TO 140 -C -C Interchange these elements -C - IF (K .LE. L) THEN - TT = IX(L) - IX(L) = IX(K) - IX(K) = TT - TTY = IY(L) - IY(L) = IY(K) - IY(K) = TTY - GO TO 130 - ENDIF -C -C Save upper and lower subscripts of the array yet to be sorted -C - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 160 -C -C Begin again on another portion of the unsorted array -C - 150 M = M-1 - IF (M .EQ. 0) GO TO 190 - I = IL(M) - J = IU(M) -C - 160 IF (J-I .GE. 1) GO TO 120 - IF (I .EQ. 1) GO TO 110 - I = I-1 -C - 170 I = I+1 - IF (I .EQ. J) GO TO 150 - T = IX(I+1) - TY = IY(I+1) - IF (IX(I) .LE. T) GO TO 170 - K = I -C - 180 IX(K+1) = IX(K) - IY(K+1) = IY(K) - K = K-1 - IF (T .LT. IX(K)) GO TO 180 - IX(K+1) = T - IY(K+1) = TY - GO TO 170 -C -C Clean up -C - 190 IF (KFLAG .LE. -1) THEN - DO 200 I=1,NN - IX(I) = -IX(I) - 200 CONTINUE - ENDIF - RETURN - END diff --git a/slatec/issbcg.f b/slatec/issbcg.f deleted file mode 100644 index 4216040..0000000 --- a/slatec/issbcg.f +++ /dev/null @@ -1,237 +0,0 @@ -*DECK ISSBCG - INTEGER FUNCTION ISSBCG (N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, - + ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, RR, ZZ, PP, - + DZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) -C***BEGIN PROLOGUE ISSBCG -C***SUBSIDIARY -C***PURPOSE Preconditioned BiConjugate Gradient Stop Test. -C This routine calculates the stop test for the BiConjugate -C Gradient iteration scheme. It returns a non-zero if the -C error estimate (the type of which is determined by ITOL) -C is less than the user specified tolerance TOL. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (ISSBCG-S, ISDBCG-D) -C***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, SLAP, -C SPARSE, STOP TEST -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER -C INTEGER IERR, IUNIT, IWORK(USER DEFINED) -C REAL B(N), X(N), A(N), TOL, ERR, R(N), Z(N), P(N) -C REAL RR(N), ZZ(N), PP(N), DZ(N) -C REAL RWORK(USER DEFINED), AK, BK, BNRM, SOLNRM -C EXTERNAL MSOLVE -C -C IF( ISSBCG(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, RR, ZZ, PP, DZ, -C $ RWORK, IWORK, AK, BK, BNRM, SOLNRM) .NE. 0 ) -C $ THEN ITERATION DONE -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Real B(N). -C Right-hand side vector. -C X :INOUT Real X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Real A(NELT). -C These arrays contain the matrix data structure for A. -C It could take any form. See "Description", in the SLAP -C routine SBCG for more details. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C MSOLVE :EXT External. -C Name of a routine which solves a linear system MZ = R for Z -C given R with the preconditioning matrix M (M is supplied via -C RWORK and IWORK arrays). The name of the MSOLVE routine -C must be declared external in the calling program. The -C calling sequence of MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, R is the right-hand side -C vector, and Z is the solution upon return. NELT, IA, JA, A, -C and ISYM define the SLAP matrix data structure. -C RWORK is a real array that can be used to pass necessary -C preconditioning information and/or workspace to MSOLVE. -C IWORK is an integer work array for the same purpose as RWORK. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /SSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :IN Real. -C Convergence criterion, as described above. -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :IN Integer. -C Current iteration count. (Must be zero on first call.) -C ERR :OUT Real. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Error flag. IERR is set to 3 if ITOL is not one of the -C acceptable values, see above. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C R :IN Real R(N). -C The residual r = b - Ax. -C Z :WORK Real Z(N). -C P :DUMMY Real P(N). -C RR :DUMMY Real RR(N). -C ZZ :DUMMY Real ZZ(N). -C PP :DUMMY Real PP(N). -C Real arrays used for workspace. -C DZ :WORK Real DZ(N). -C If ITOL.eq.0 then DZ is used to hold M-inv * B on the first -C call. If ITOL.eq.11 then DZ is used to hold X-SOLN. -C RWORK :WORK Real RWORK(USER DEFINED). -C Real array that can be used for workspace in MSOLVE -C and MTSOLV. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used for workspace in MSOLVE -C and MTSOLV. -C AK :IN Real. -C Current iterate BiConjugate Gradient iteration parameter. -C BK :IN Real. -C Current iterate BiConjugate Gradient iteration parameter. -C BNRM :INOUT Real. -C Norm of the right hand side. Type of norm depends on ITOL. -C Calculated only on the first call. -C SOLNRM :INOUT Real. -C 2-Norm of the true solution, SOLN. Only computed and used -C if ITOL = 11. -C -C *Function Return Values: -C 0 : Error estimate (determined by ITOL) is *NOT* less than the -C specified tolerance, TOL. The iteration must continue. -C 1 : Error estimate (determined by ITOL) is less than the -C specified tolerance, TOL. The iteration can be considered -C complete. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO SBCG -C***ROUTINES CALLED R1MACH, SNRM2 -C***COMMON BLOCKS SSLBLK -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 891003 Removed C***REFER TO line, per MKS. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MSOLVE from ROUTINES CALLED list. (FNF) -C 910506 Made subsidiary to SBCG. (FNF) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920930 Corrected to not print AK,BK when ITER=0. (FNF) -C 921026 Changed 1.0E10 to R1MACH(2). (FNF) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE ISSBCG -C .. Scalar Arguments .. - REAL AK, BK, BNRM, ERR, SOLNRM, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT -C .. Array Arguments .. - REAL A(NELT), B(N), DZ(N), P(N), PP(N), R(N), RR(N), RWORK(*), - + X(N), Z(N), ZZ(N) - INTEGER IA(NELT), IWORK(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MSOLVE -C .. Arrays in Common .. - REAL SOLN(1) -C .. Local Scalars .. - INTEGER I -C .. External Functions .. - REAL R1MACH, SNRM2 - EXTERNAL R1MACH, SNRM2 -C .. Common blocks .. - COMMON /SSLBLK/ SOLN -C***FIRST EXECUTABLE STATEMENT ISSBCG - ISSBCG = 0 -C - IF( ITOL.EQ.1 ) THEN -C err = ||Residual||/||RightHandSide|| (2-Norms). - IF(ITER .EQ. 0) BNRM = SNRM2(N, B, 1) - ERR = SNRM2(N, R, 1)/BNRM - ELSE IF( ITOL.EQ.2 ) THEN -C -1 -1 -C err = ||M Residual||/||M RightHandSide|| (2-Norms). - IF(ITER .EQ. 0) THEN - CALL MSOLVE(N, B, DZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) - BNRM = SNRM2(N, DZ, 1) - ENDIF - ERR = SNRM2(N, Z, 1)/BNRM - ELSE IF( ITOL.EQ.11 ) THEN -C err = ||x-TrueSolution||/||TrueSolution|| (2-Norms). - IF(ITER .EQ. 0) SOLNRM = SNRM2(N, SOLN, 1) - DO 10 I = 1, N - DZ(I) = X(I) - SOLN(I) - 10 CONTINUE - ERR = SNRM2(N, DZ, 1)/SOLNRM - ELSE -C -C If we get here ITOL is not one of the acceptable values. - ERR = R1MACH(2) - IERR = 3 - ENDIF -C - IF(IUNIT .NE. 0) THEN - IF( ITER.EQ.0 ) THEN - WRITE(IUNIT,1000) N, ITOL - WRITE(IUNIT,1010) ITER, ERR - ELSE - WRITE(IUNIT,1010) ITER, ERR, AK, BK - ENDIF - ENDIF - IF(ERR .LE. TOL) ISSBCG = 1 -C - RETURN - 1000 FORMAT(' Preconditioned BiConjugate Gradient for N, ITOL = ', - $ I5,I5,/' ITER',' Error Estimate',' Alpha', - $ ' Beta') - 1010 FORMAT(1X,I4,1X,E16.7,1X,E16.7,1X,E16.7) -C------------- LAST LINE OF ISSBCG FOLLOWS ---------------------------- - END diff --git a/slatec/isscg.f b/slatec/isscg.f deleted file mode 100644 index 58e5117..0000000 --- a/slatec/isscg.f +++ /dev/null @@ -1,227 +0,0 @@ -*DECK ISSCG - INTEGER FUNCTION ISSCG (N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, - + ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, DZ, RWORK, - + IWORK, AK, BK, BNRM, SOLNRM) -C***BEGIN PROLOGUE ISSCG -C***SUBSIDIARY -C***PURPOSE Preconditioned Conjugate Gradient Stop Test. -C This routine calculates the stop test for the Conjugate -C Gradient iteration scheme. It returns a non-zero if the -C error estimate (the type of which is determined by ITOL) -C is less than the user specified tolerance TOL. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2B4 -C***TYPE SINGLE PRECISION (ISSCG-S, ISDCG-D) -C***KEYWORDS LINEAR SYSTEM, SLAP, SPARSE, STOP TEST -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER -C INTEGER IERR, IUNIT, IWORK(USER DEFINED) -C REAL B(N), X(N), A(N), TOL, ERR, R(N), Z(N) -C REAL P(N), DZ(N), RWORK(USER DEFINED), AK, BK -C REAL BNRM, SOLNRM -C EXTERNAL MSOLVE -C -C IF( ISSCG(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, DZ, RWORK, IWORK, -C $ AK, BK, BNRM, SOLNRM) .NE. 0 ) THEN ITERATION DONE -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Real B(N). -C Right-hand side vector. -C X :IN Real X(N). -C The current approximate solution vector. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Real A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description" -C in the SCG, SSDCG or SSICCG routines. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C MSOLVE :EXT External. -C Name of a routine which solves a linear system MZ = R for -C Z given R with the preconditioning matrix M (M is supplied via -C RWORK and IWORK arrays). The name of the MSOLVE routine must -C be declared external in the calling program. The calling -C sequence to MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, R is the right-hand side -C vector and Z is the solution upon return. NELT, IA, JA, A and -C ISYM are defined as above. RWORK is a real array that can -C be used to pass necessary preconditioning information and/or -C workspace to MSOLVE. IWORK is an integer work array for -C the same purpose as RWORK. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /SSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :IN Real. -C Convergence criterion, as described above. -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :IN Integer. -C Current iteration count. (Must be zero on first call.) -C ERR :OUT Real. -C Error estimate of error in the X(N) approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Error flag. IERR is set to 3 if ITOL is not one of the -C acceptable values, see above. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C R :IN Real R(N). -C The residual R = B-AX. -C Z :WORK Real Z(N). -C Workspace used to hold the pseudo-residual M Z = R. -C P :IN Real P(N). -C The conjugate direction vector. -C DZ :WORK Real DZ(N). -C Workspace used to hold temporary vector(s). -C RWORK :WORK Real RWORK(USER DEFINED). -C Real array that can be used by MSOLVE. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used by MSOLVE. -C AK :IN Real. -C BK :IN Real. -C Current conjugate gradient parameters alpha and beta. -C BNRM :INOUT Real. -C Norm of the right hand side. Type of norm depends on ITOL. -C Calculated only on the first call. -C SOLNRM :INOUT Real. -C 2-Norm of the true solution, SOLN. Only computed and used -C if ITOL = 11. -C -C *Function Return Values: -C 0 : Error estimate (determined by ITOL) is *NOT* less than the -C specified tolerance, TOL. The iteration must continue. -C 1 : Error estimate (determined by ITOL) is less than the -C specified tolerance, TOL. The iteration can be considered -C complete. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO SCG, SSDCG, SSICCG -C***ROUTINES CALLED R1MACH, SNRM2 -C***COMMON BLOCKS SSLBLK -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 891003 Removed C***REFER TO line, per MKS. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MSOLVE from ROUTINES CALLED list. (FNF) -C 910506 Made subsidiary to SCG. (FNF) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920930 Corrected to not print AK,BK when ITER=0. (FNF) -C 921026 Changed 1.0E10 to R1MACH(2). (FNF) -C***END PROLOGUE ISSCG -C .. Scalar Arguments .. - REAL AK, BK, BNRM, ERR, SOLNRM, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT -C .. Array Arguments .. - REAL A(NELT), B(N), DZ(N), P(N), R(N), RWORK(*), X(N), Z(N) - INTEGER IA(NELT), IWORK(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MSOLVE -C .. Arrays in Common .. - REAL SOLN(1) -C .. Local Scalars .. - INTEGER I -C .. External Functions .. - REAL R1MACH, SNRM2 - EXTERNAL R1MACH, SNRM2 -C .. Common blocks .. - COMMON /SSLBLK/ SOLN -C***FIRST EXECUTABLE STATEMENT ISSCG - ISSCG = 0 -C - IF( ITOL.EQ.1 ) THEN -C err = ||Residual||/||RightHandSide|| (2-Norms). - IF(ITER .EQ. 0) BNRM = SNRM2(N, B, 1) - ERR = SNRM2(N, R, 1)/BNRM - ELSE IF( ITOL.EQ.2 ) THEN -C -1 -1 -C err = ||M Residual||/||M RightHandSide|| (2-Norms). - IF(ITER .EQ. 0) THEN - CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) - BNRM = SNRM2(N, DZ, 1) - ENDIF - ERR = SNRM2(N, Z, 1)/BNRM - ELSE IF( ITOL.EQ.11 ) THEN -C err = ||x-TrueSolution||/||TrueSolution|| (2-Norms). - IF(ITER .EQ. 0) SOLNRM = SNRM2(N, SOLN, 1) - DO 10 I = 1, N - DZ(I) = X(I) - SOLN(I) - 10 CONTINUE - ERR = SNRM2(N, DZ, 1)/SOLNRM - ELSE -C -C If we get here ITOL is not one of the acceptable values. - ERR = R1MACH(2) - IERR = 3 - ENDIF -C - IF(IUNIT .NE. 0) THEN - IF( ITER.EQ.0 ) THEN - WRITE(IUNIT,1000) N, ITOL - WRITE(IUNIT,1010) ITER, ERR - ELSE - WRITE(IUNIT,1010) ITER, ERR, AK, BK - ENDIF - ENDIF - IF(ERR .LE. TOL) ISSCG = 1 - RETURN - 1000 FORMAT(' Preconditioned Conjugate Gradient for ', - $ 'N, ITOL = ',I5, I5, - $ /' ITER',' Error Estimate',' Alpha', - $ ' Beta') - 1010 FORMAT(1X,I4,1X,E16.7,1X,E16.7,1X,E16.7) -C------------- LAST LINE OF ISSCG FOLLOWS ------------------------------ - END diff --git a/slatec/isscgn.f b/slatec/isscgn.f deleted file mode 100644 index 781e0b3..0000000 --- a/slatec/isscgn.f +++ /dev/null @@ -1,263 +0,0 @@ -*DECK ISSCGN - INTEGER FUNCTION ISSCGN (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, - + MTTVEC, MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, - + P, ATP, ATZ, DZ, ATDZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) -C***BEGIN PROLOGUE ISSCGN -C***SUBSIDIARY -C***PURPOSE Preconditioned CG on Normal Equations Stop Test. -C This routine calculates the stop test for the Conjugate -C Gradient iteration scheme applied to the normal equations. -C It returns a non-zero if the error estimate (the type of -C which is determined by ITOL) is less than the user -C specified tolerance TOL. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (ISSCGN-S, ISDCGN-D) -C***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, -C NORMAL EQUATIONS, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER -C INTEGER IERR, IUNIT, IWORK(USER DEFINED) -C REAL B(N), X(N), A(N), TOL, ERR, R(N), Z(N), P(N) -C REAL ATP(N), ATZ(N), DZ(N), ATDZ(N) -C REAL RWORK(USER DEFINED), AK, BK, BNRM, SOLNRM -C EXTERNAL MATVEC, MTTVEC, MSOLVE -C -C IF( ISTPCGN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, -C $ MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, -C $ ATP, ATZ, DZ, ATDZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) -C $ .NE. 0 ) THEN ITERATION DONE -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Real B(N). -C Right-hand side vector. -C X :IN Real X(N). -C The current approximate solution vector. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Real A(NELT). -C These arrays contain the matrix data structure for A. -C It could take any form. See "Description" in the -C SCGN routine. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C MATVEC :EXT External. -C Name of a routine which performs the matrix vector multiply -C Y = A*X given A and X. The name of the MATVEC routine must -C be declared external in the calling program. The calling -C sequence to MATVEC is: -C CALL MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) -C Where N is the number of unknowns, Y is the product A*X -C upon return X is an input vector, NELT is the number of -C non-zeros in the SLAP-Column IA, JA, A storage for the matrix -C A. ISYM is a flag which, if non-zero, denotes that A is -C symmetric and only the lower or upper triangle is stored. -C MTTVEC :EXT External. -C Name of a routine which performs the matrix transpose vector -C multiply y = A'*X given A and X (where ' denotes transpose). -C The name of the MTTVEC routine must be declared external in -C the calling program. The calling sequence to MTTVEC is the -C same as that for MATVEC, viz.: -C CALL MTTVEC( N, X, Y, NELT, IA, JA, A, ISYM ) -C Where N is the number of unknowns, Y is the product A'*X -C upon return X is an input vector, NELT is the number of -C non-zeros in the SLAP-Column IA, JA, A storage for the matrix -C A. ISYM is a flag which, if non-zero, denotes that A is -C symmetric and only the lower or upper triangle is stored. -C MSOLVE :EXT External. -C Name of a routine which solves a linear system MZ = R for -C Z given R with the preconditioning matrix M (M is supplied via -C RWORK and IWORK arrays). The name of the MSOLVE routine must -C be declared external in the calling program. The calling -C sequence to MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, R is the right-hand side -C vector and Z is the solution upon return. NELT, IA, JA, A and -C ISYM are defined as above. RWORK is a real array that can -C be used to pass necessary preconditioning information and/or -C workspace to MSOLVE. IWORK is an integer work array for -C the same purpose as RWORK. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /SSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :IN Real. -C Convergence criterion, as described above. -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :IN Integer. -C Current iteration count. (Must be zero on first call.) -C ERR :OUT Real. -C Error estimate of error in the X(N) approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Error flag. IERR is set to 3 if ITOL is not one of the -C acceptable values, see above. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C R :IN Real R(N). -C The residual R = B-AX. -C Z :WORK Real Z(N). -C Real array used for workspace. -C P :IN Real P(N). -C The conjugate direction vector. -C ATP :IN Real ATP(N). -C A-transpose times the conjugate direction vector. -C ATZ :IN Real ATZ(N). -C A-transpose times the pseudo-residual. -C DZ :IN Real DZ(N). -C Workspace used to hold temporary vector(s). -C ATDZ :WORK Real ATDZ(N). -C Workspace. -C RWORK :WORK Real RWORK(USER DEFINED). -C Real array that can be used by MSOLVE. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used by MSOLVE. -C AK :IN Real. -C BK :IN Real. -C Current conjugate gradient parameters alpha and beta. -C BNRM :INOUT Real. -C Norm of the right hand side. Type of norm depends on ITOL. -C Calculated only on the first call. -C SOLNRM :INOUT Real. -C 2-Norm of the true solution, SOLN. Only computed and used -C if ITOL = 11. -C -C *Function Return Values: -C 0 : Error estimate (determined by ITOL) is *NOT* less than the -C specified tolerance, TOL. The iteration must continue. -C 1 : Error estimate (determined by ITOL) is less than the -C specified tolerance, TOL. The iteration can be considered -C complete. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO SCGN -C***ROUTINES CALLED R1MACH, SNRM2 -C***COMMON BLOCKS SSLBLK -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 891003 Removed C***REFER TO line, per MKS. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MATVEC, MTTVEC and MSOLVE from ROUTINES CALLED -C list. (FNF) -C 910506 Made subsidiary to SCGN. (FNF) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920930 Corrected to not print AK,BK when ITER=0. (FNF) -C 921026 Changed 1.0E10 to R1MACH(2). (FNF) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE ISSCGN -C .. Scalar Arguments .. - REAL AK, BK, BNRM, ERR, SOLNRM, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT -C .. Array Arguments .. - REAL A(N), ATDZ(N), ATP(N), ATZ(N), B(N), DZ(N), P(N), R(N), - + RWORK(*), X(N), Z(N) - INTEGER IA(NELT), IWORK(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MATVEC, MSOLVE, MTTVEC -C .. Arrays in Common .. - REAL SOLN(1) -C .. Local Scalars .. - INTEGER I -C .. External Functions .. - REAL R1MACH, SNRM2 - EXTERNAL R1MACH, SNRM2 -C .. Common blocks .. - COMMON /SSLBLK/ SOLN -C***FIRST EXECUTABLE STATEMENT ISSCGN - ISSCGN = 0 -C - IF( ITOL.EQ.1 ) THEN -C err = ||Residual||/||RightHandSide|| (2-Norms). - IF(ITER .EQ. 0) BNRM = SNRM2(N, B, 1) - ERR = SNRM2(N, R, 1)/BNRM - ELSE IF( ITOL.EQ.2 ) THEN -C -1 -1 -C err = ||M Residual||/||M RightHandSide|| (2-Norms). - IF(ITER .EQ. 0) THEN - CALL MSOLVE(N, B, DZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) - CALL MTTVEC(N, DZ, ATDZ, NELT, IA, JA, A, ISYM) - BNRM = SNRM2(N, ATDZ, 1) - ENDIF - ERR = SNRM2(N, ATZ, 1)/BNRM - ELSE IF( ITOL.EQ.11 ) THEN -C err = ||x-TrueSolution||/||TrueSolution|| (2-Norms). - IF(ITER .EQ. 0) SOLNRM = SNRM2(N, SOLN, 1) - DO 10 I = 1, N - DZ(I) = X(I) - SOLN(I) - 10 CONTINUE - ERR = SNRM2(N, DZ, 1)/SOLNRM - ELSE -C -C If we get here ITOL is not one of the acceptable values. - ERR = R1MACH(2) - IERR = 3 - ENDIF -C - IF( IUNIT.NE.0 ) THEN - IF( ITER.EQ.0 ) THEN - WRITE(IUNIT,1000) N, ITOL - WRITE(IUNIT,1010) ITER, ERR - ELSE - WRITE(IUNIT,1010) ITER, ERR, AK, BK - ENDIF - ENDIF - IF( ERR.LE.TOL ) ISSCGN = 1 -C - RETURN - 1000 FORMAT(' PCG Applied to the Normal Equations for ', - $ 'N, ITOL = ',I5, I5, - $ /' ITER',' Error Estimate',' Alpha', - $ ' Beta') - 1010 FORMAT(1X,I4,1X,E16.7,1X,E16.7,1X,E16.7) -C------------- LAST LINE OF ISSCGN FOLLOWS ---------------------------- - END diff --git a/slatec/isscgs.f b/slatec/isscgs.f deleted file mode 100644 index 7b46c52..0000000 --- a/slatec/isscgs.f +++ /dev/null @@ -1,257 +0,0 @@ -*DECK ISSCGS - INTEGER FUNCTION ISSCGS (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, - + MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, R0, P, Q, - + U, V1, V2, RWORK, IWORK, AK, BK, BNRM, SOLNRM) -C***BEGIN PROLOGUE ISSCGS -C***SUBSIDIARY -C***PURPOSE Preconditioned BiConjugate Gradient Squared Stop Test. -C This routine calculates the stop test for the BiConjugate -C Gradient Squared iteration scheme. It returns a non-zero -C if the error estimate (the type of which is determined by -C ITOL) is less than the user specified tolerance TOL. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (ISSCGS-S, ISDCGS-D) -C***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, SLAP, -C SPARSE, STOP TEST -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER -C INTEGER IERR, IUNIT, IWORK(USER DEFINED) -C REAL B(N), X(N), A(N), TOL, ERR, R(N), R0(N), P(N) -C REAL Q(N), U(N), V1(N), V2(N) -C REAL RWORK(USER DEFINED), AK, BK, BNRM, SOLNRM -C EXTERNAL MATVEC, MSOLVE -C -C IF( ISSCGS(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, ITOL, -C $ TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, R0, P, Q, U, V1, -C $ V2, RWORK, IWORK, AK, BK, BNRM, SOLNRM) .NE. 0 ) -C $ THEN ITERATION DONE -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Real B(N). -C Right-hand side vector. -C X :INOUT Real X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Real A(NELT). -C These arrays contain the matrix data structure for A. -C It could take any form. See "Description" in SLAP routine -C SCGS for more details. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C MATVEC :EXT External. -C Name of a routine which performs the matrix vector multiply -C operation Y = A*X given A and X. The name of the MATVEC -C routine must be declared external in the calling program. -C The calling sequence of MATVEC is: -C CALL MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) -C Where N is the number of unknowns, Y is the product A*X upon -C return, X is an input vector. NELT, IA, JA, A, and ISYM -C define the SLAP matrix data structure. -C MSOLVE :EXT External. -C Name of a routine which solves a linear system MZ = R for Z -C given R with the preconditioning matrix M (M is supplied via -C RWORK and IWORK arrays). The name of the MSOLVE routine -C must be declared external in the calling program. The -C calling sequence of MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, R is the right-hand side -C vector, and Z is the solution upon return. NELT, IA, JA, A, -C and ISYM define the SLAP matrix data structure. -C RWORK is a real array that can be used to pass necessary -C preconditioning information and/or workspace to MSOLVE. -C IWORK is an integer work array for the same purpose as RWORK. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C This routine must calculate the residual from R = A*X - B. -C This is unnatural and hence expensive for this type of iter- -C ative method. ITOL=2 is *STRONGLY* recommended. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv time a vector is the pre- -C conditioning step. This is the *NATURAL* stopping for this -C iterative method and is *STRONGLY* recommended. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /SSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :IN Real. -C Convergence criterion, as described above. -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :IN Integer. -C Current iteration count. (Must be zero on first call.) -C ERR :OUT Real. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Error flag. IERR is set to 3 if ITOL is not one of the -C acceptable values, see above. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C R :IN Real R(N). -C The residual r = b - Ax. -C R0 :WORK Real R0(N). -C P :DUMMY Real P(N). -C Q :DUMMY Real Q(N). -C U :DUMMY Real U(N). -C V1 :DUMMY Real V1(N). -C Real arrays used for workspace. -C V2 :WORK Real V2(N). -C If ITOL.eq.1 then V2 is used to hold A * X - B on every call. -C If ITOL.eq.2 then V2 is used to hold M-inv * B on the first -C call. -C If ITOL.eq.11 then V2 is used to X - SOLN. -C RWORK :WORK Real RWORK(USER DEFINED). -C Real array that can be used for workspace in MSOLVE. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used for workspace in MSOLVE. -C AK :IN Real. -C Current iterate BiConjugate Gradient iteration parameter. -C BK :IN Real. -C Current iterate BiConjugate Gradient iteration parameter. -C BNRM :INOUT Real. -C Norm of the right hand side. Type of norm depends on ITOL. -C Calculated only on the first call. -C SOLNRM :INOUT Real. -C 2-Norm of the true solution, SOLN. Only computed and used -C if ITOL = 11. -C -C *Function Return Values: -C 0 : Error estimate (determined by ITOL) is *NOT* less than the -C specified tolerance, TOL. The iteration must continue. -C 1 : Error estimate (determined by ITOL) is less than the -C specified tolerance, TOL. The iteration can be considered -C complete. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO SCGS -C***ROUTINES CALLED R1MACH, SNRM2 -C***COMMON BLOCKS SSLBLK -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 891003 Removed C***REFER TO line, per MKS. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MATVEC and MSOLVE from ROUTINES CALLED list. (FNF) -C 910506 Made subsidiary to SCGS. (FNF) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920930 Corrected to not print AK,BK when ITER=0. (FNF) -C 921026 Changed 1.0E10 to R1MACH(2). (FNF) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE ISSCGS -C .. Scalar Arguments .. - REAL AK, BK, BNRM, ERR, SOLNRM, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT -C .. Array Arguments .. - REAL A(NELT), B(N), P(N), Q(N), R(N), R0(N), RWORK(*), U(N), - + V1(N), V2(N), X(N) - INTEGER IA(NELT), IWORK(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MATVEC, MSOLVE -C .. Arrays in Common .. - REAL SOLN(1) -C .. Local Scalars .. - INTEGER I -C .. External Functions .. - REAL R1MACH, SNRM2 - EXTERNAL R1MACH, SNRM2 -C .. Common blocks .. - COMMON /SSLBLK/ SOLN -C***FIRST EXECUTABLE STATEMENT ISSCGS - ISSCGS = 0 -C - IF( ITOL.EQ.1 ) THEN -C err = ||Residual||/||RightHandSide|| (2-Norms). - IF(ITER .EQ. 0) BNRM = SNRM2(N, B, 1) - CALL MATVEC(N, X, V2, NELT, IA, JA, A, ISYM ) - DO 5 I = 1, N - V2(I) = V2(I) - B(I) - 5 CONTINUE - ERR = SNRM2(N, V2, 1)/BNRM - ELSE IF( ITOL.EQ.2 ) THEN -C -1 -1 -C err = ||M Residual||/||M RightHandSide|| (2-Norms). - IF(ITER .EQ. 0) THEN - CALL MSOLVE(N, B, V2, NELT, IA, JA, A, ISYM, RWORK, IWORK) - BNRM = SNRM2(N, V2, 1) - ENDIF - ERR = SNRM2(N, R, 1)/BNRM - ELSE IF( ITOL.EQ.11 ) THEN -C err = ||x-TrueSolution||/||TrueSolution|| (2-Norms). - IF(ITER .EQ. 0) SOLNRM = SNRM2(N, SOLN, 1) - DO 10 I = 1, N - V2(I) = X(I) - SOLN(I) - 10 CONTINUE - ERR = SNRM2(N, V2, 1)/SOLNRM - ELSE -C -C If we get here ITOL is not one of the acceptable values. - ERR = R1MACH(2) - IERR = 3 - ENDIF -C -C Print the error and coefficients AK, BK on each step, -C if desired. - IF(IUNIT .NE. 0) THEN - IF( ITER.EQ.0 ) THEN - WRITE(IUNIT,1000) N, ITOL - WRITE(IUNIT,1010) ITER, ERR - ELSE - WRITE(IUNIT,1010) ITER, ERR, AK, BK - ENDIF - ENDIF - IF(ERR .LE. TOL) ISSCGS = 1 -C - RETURN - 1000 FORMAT(' Preconditioned BiConjugate Gradient Squared for ', - $ 'N, ITOL = ',I5, I5, - $ /' ITER',' Error Estimate',' Alpha', - $ ' Beta') - 1010 FORMAT(1X,I4,1X,E16.7,1X,E16.7,1X,E16.7) -C------------- LAST LINE OF ISSCGS FOLLOWS ---------------------------- - END diff --git a/slatec/issgmr.f b/slatec/issgmr.f deleted file mode 100644 index a380582..0000000 --- a/slatec/issgmr.f +++ /dev/null @@ -1,400 +0,0 @@ -*DECK ISSGMR - INTEGER FUNCTION ISSGMR (N, B, X, XL, NELT, IA, JA, A, ISYM, - + MSOLVE, NMSL, ITOL, TOL, ITMAX, ITER, ERR, IUNIT, R, Z, DZ, - + RWORK, IWORK, RNRM, BNRM, SB, SX, JSCAL, KMP, LGMR, MAXL, - + MAXLP1, V, Q, SNORMW, PROD, R0NRM, HES, JPRE) -C***BEGIN PROLOGUE ISSGMR -C***SUBSIDIARY -C***PURPOSE Generalized Minimum Residual Stop Test. -C This routine calculates the stop test for the Generalized -C Minimum RESidual (GMRES) iteration scheme. It returns a -C non-zero if the error estimate (the type of which is -C determined by ITOL) is less than the user specified -C tolerance TOL. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (ISSGMR-S, ISDGMR-D) -C***KEYWORDS GMRES, LINEAR SYSTEM, SLAP, SPARSE, STOP TEST -C***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov -C Hindmarsh, Alan, (LLNL), alanh@llnl.gov -C Seager, Mark K., (LLNL), seager@llnl.gov -C Lawrence Livermore National Laboratory -C PO Box 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NMSL, ITOL -C INTEGER ITMAX, ITER, IUNIT, IWORK(USER DEFINED), JSCAL -C INTEGER KMP, LGMR, MAXL, MAXLP1, JPRE -C REAL B(N), X(N), XL(MAXL), A(NELT), TOL, ERR, R(N), Z(N), -C $ DZ(N), RWORK(USER DEFINED), RNRM, BNRM, SB(N), SX(N), -C $ V(N,MAXLP1), Q(2*MAXL), SNORMW, PROD, R0NRM, -C $ HES(MAXLP1,MAXL) -C EXTERNAL MSOLVE -C -C IF (ISSGMR(N, B, X, XL, NELT, IA, JA, A, ISYM, MSOLVE, -C $ NMSL, ITOL, TOL, ITMAX, ITER, ERR, IUNIT, R, Z, DZ, -C $ RWORK, IWORK, RNRM, BNRM, SB, SX, JSCAL, -C $ KMP, LGMR, MAXL, MAXLP1, V, Q, SNORMW, PROD, R0NRM, -C $ HES, JPRE) .NE. 0) THEN ITERATION DONE -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Real B(N). -C Right-hand-side vector. -C X :IN Real X(N). -C Approximate solution vector as of the last restart. -C XL :OUT Real XL(N) -C An array of length N used to hold the approximate -C solution as of the current iteration. Only computed by -C this routine when ITOL=11. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Real A(NELT). -C These arrays contain the matrix data structure for A. -C It could take any form. See "Description", in the SGMRES, -C SSLUGM and SSDGMR routines for more details. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C MSOLVE :EXT External. -C Name of a routine which solves a linear system Mz = r for z -C given r with the preconditioning matrix M (M is supplied via -C RWORK and IWORK arrays. The name of the MSOLVE routine must -C be declared external in the calling program. The calling -C sequence to MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, R is the right-hand side -C vector and Z is the solution upon return. NELT, IA, JA, A and -C ISYM are defined as above. RWORK is a real array that can -C be used to pass necessary preconditioning information and/or -C workspace to MSOLVE. IWORK is an integer work array for -C the same purpose as RWORK. -C NMSL :INOUT Integer. -C A counter for the number of calls to MSOLVE. -C ITOL :IN Integer. -C Flag to indicate the type of convergence criterion used. -C ITOL=0 Means the iteration stops when the test described -C below on the residual RL is satisfied. This is -C the "Natural Stopping Criteria" for this routine. -C Other values of ITOL cause extra, otherwise -C unnecessary, computation per iteration and are -C therefore much less efficient. -C ITOL=1 Means the iteration stops when the first test -C described below on the residual RL is satisfied, -C and there is either right or no preconditioning -C being used. -C ITOL=2 Implies that the user is using left -C preconditioning, and the second stopping criterion -C below is used. -C ITOL=3 Means the iteration stops when the third test -C described below on Minv*Residual is satisfied, and -C there is either left or no preconditioning begin -C used. -C ITOL=11 is often useful for checking and comparing -C different routines. For this case, the user must -C supply the "exact" solution or a very accurate -C approximation (one with an error much less than -C TOL) through a common block, -C COMMON /SSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the -C difference between the iterative approximation and -C the user-supplied solution divided by the 2-norm -C of the user-supplied solution is less than TOL. -C Note that this requires the user to set up the -C "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling -C routine. The routine with this declaration should -C be loaded before the stop test so that the correct -C length is used by the loader. This procedure is -C not standard Fortran and may not work correctly on -C your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 -C then this common block is indeed standard Fortran. -C TOL :IN Real. -C Convergence criterion, as described above. -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :IN Integer. -C The iteration for which to check for convergence. -C ERR :OUT Real. -C Error estimate of error in final approximate solution, as -C defined by ITOL. Letting norm() denote the Euclidean -C norm, ERR is defined as follows.. -C -C If ITOL=0, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), -C for right or no preconditioning, and -C ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ -C norm(SB*(M-inverse)*B), -C for left preconditioning. -C If ITOL=1, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), -C since right or no preconditioning -C being used. -C If ITOL=2, then ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ -C norm(SB*(M-inverse)*B), -C since left preconditioning is being -C used. -C If ITOL=3, then ERR = Max |(Minv*(B-A*X(L)))(i)/x(i)| -C i=1,n -C If ITOL=11, then ERR = norm(SB*(X(L)-SOLN))/norm(SB*SOLN). -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C R :INOUT Real R(N). -C Work array used in calling routine. It contains -C information necessary to compute the residual RL = B-A*XL. -C Z :WORK Real Z(N). -C Workspace used to hold the pseudo-residual M z = r. -C DZ :WORK Real DZ(N). -C Workspace used to hold temporary vector(s). -C RWORK :WORK Real RWORK(USER DEFINED). -C Real array that can be used by MSOLVE. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used by MSOLVE. -C RNRM :IN Real. -C Norm of the current residual. Type of norm depends on ITOL. -C BNRM :IN Real. -C Norm of the right hand side. Type of norm depends on ITOL. -C SB :IN Real SB(N). -C Scaling vector for B. -C SX :IN Real SX(N). -C Scaling vector for X. -C JSCAL :IN Integer. -C Flag indicating if scaling arrays SB and SX are being -C used in the calling routine SPIGMR. -C JSCAL=0 means SB and SX are not used and the -C algorithm will perform as if all -C SB(i) = 1 and SX(i) = 1. -C JSCAL=1 means only SX is used, and the algorithm -C performs as if all SB(i) = 1. -C JSCAL=2 means only SB is used, and the algorithm -C performs as if all SX(i) = 1. -C JSCAL=3 means both SB and SX are used. -C KMP :IN Integer -C The number of previous vectors the new vector VNEW -C must be made orthogonal to. (KMP .le. MAXL) -C LGMR :IN Integer -C The number of GMRES iterations performed on the current call -C to SPIGMR (i.e., # iterations since the last restart) and -C the current order of the upper Hessenberg -C matrix HES. -C MAXL :IN Integer -C The maximum allowable order of the matrix H. -C MAXLP1 :IN Integer -C MAXPL1 = MAXL + 1, used for dynamic dimensioning of HES. -C V :IN Real V(N,MAXLP1) -C The N by (LGMR+1) array containing the LGMR -C orthogonal vectors V(*,1) to V(*,LGMR). -C Q :IN Real Q(2*MAXL) -C A real array of length 2*MAXL containing the components -C of the Givens rotations used in the QR decomposition -C of HES. -C SNORMW :IN Real -C A scalar containing the scaled norm of VNEW before it -C is renormalized in SPIGMR. -C PROD :IN Real -C The product s1*s2*...*sl = the product of the sines of the -C Givens rotations used in the QR factorization of the -C Hessenberg matrix HES. -C R0NRM :IN Real -C The scaled norm of initial residual R0. -C HES :IN Real HES(MAXLP1,MAXL) -C 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 JPRE :IN Integer -C Preconditioner type flag. -C (See description of IGWK(4) in SGMRES.) -C -C *Description -C When using the GMRES solver, the preferred value for ITOL -C is 0. This is due to the fact that when ITOL=0 the norm of -C the residual required in the stopping test is obtained for -C free, since this value is already calculated in the GMRES -C algorithm. The variable RNRM contains the appropriate -C norm, which is equal to norm(SB*(RL - A*XL)) when right or -C no preconditioning is being performed, and equal to -C norm(SB*Minv*(RL - A*XL)) when using left preconditioning. -C Here, norm() is the Euclidean norm. Nonzero values of ITOL -C require additional work to calculate the actual scaled -C residual or its scaled/preconditioned form, and/or the -C approximate solution XL. Hence, these values of ITOL will -C not be as efficient as ITOL=0. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C This routine does not verify that ITOL has a valid value. -C The calling routine should make such a test before calling -C ISSGMR, as is done in SGMRES. -C -C***SEE ALSO SGMRES -C***ROUTINES CALLED R1MACH, SCOPY, SNRM2, SRLCAL, SSCAL, SXLCAL -C***COMMON BLOCKS SSLBLK -C***REVISION HISTORY (YYMMDD) -C 871211 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Corrected conversion errors, etc. (FNF) -C 910502 Removed MSOLVE from ROUTINES CALLED list. (FNF) -C 910506 Made subsidiary to SGMRES. (FNF) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE ISSGMR -C .. Scalar Arguments .. - REAL BNRM, ERR, PROD, R0NRM, RNRM, SNORMW, TOL - INTEGER ISYM, ITER, ITMAX, ITOL, IUNIT, JPRE, JSCAL, KMP, LGMR, - + MAXL, MAXLP1, N, NELT, NMSL -C .. Array Arguments .. - REAL A(*), B(*), DZ(*), HES(MAXLP1, MAXL), Q(*), R(*), RWORK(*), - + SB(*), SX(*), V(N,*), X(*), XL(*), Z(*) - INTEGER IA(*), IWORK(*), JA(*) -C .. Subroutine Arguments .. - EXTERNAL MSOLVE -C .. Arrays in Common .. - REAL SOLN(1) -C .. Local Scalars .. - REAL DXNRM, FUZZ, RAT, RATMAX, SOLNRM, TEM - INTEGER I, IELMAX -C .. External Functions .. - REAL R1MACH, SNRM2 - EXTERNAL R1MACH, SNRM2 -C .. External Subroutines .. - EXTERNAL SCOPY, SRLCAL, SSCAL, SXLCAL -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -C .. Common blocks .. - COMMON /SSLBLK/ SOLN -C .. Save statement .. - SAVE SOLNRM -C***FIRST EXECUTABLE STATEMENT ISSGMR - ISSGMR = 0 - IF ( ITOL.EQ.0 ) THEN -C -C Use input from SPIGMR to determine if stop conditions are met. -C - ERR = RNRM/BNRM - ENDIF - IF ( (ITOL.GT.0) .AND. (ITOL.LE.3) ) THEN -C -C Use SRLCAL to calculate the scaled residual vector. -C Store answer in R. -C - IF ( LGMR.NE.0 ) CALL SRLCAL(N, KMP, LGMR, MAXL, V, Q, R, - $ SNORMW, PROD, R0NRM) - IF ( ITOL.LE.2 ) THEN -C err = ||Residual||/||RightHandSide||(2-Norms). - ERR = SNRM2(N, R, 1)/BNRM -C -C Unscale R by R0NRM*PROD when KMP < MAXL. -C - IF ( (KMP.LT.MAXL) .AND. (LGMR.NE.0) ) THEN - TEM = 1.0E0/(R0NRM*PROD) - CALL SSCAL(N, TEM, R, 1) - ENDIF - ELSEIF ( ITOL.EQ.3 ) THEN -C err = Max |(Minv*Residual)(i)/x(i)| -C When JPRE .lt. 0, R already contains Minv*Residual. - IF ( JPRE.GT.0 ) THEN - CALL MSOLVE(N, R, DZ, NELT, IA, JA, A, ISYM, RWORK, - $ IWORK) - NMSL = NMSL + 1 - ENDIF -C -C Unscale R by R0NRM*PROD when KMP < MAXL. -C - IF ( (KMP.LT.MAXL) .AND. (LGMR.NE.0) ) THEN - TEM = 1.0E0/(R0NRM*PROD) - CALL SSCAL(N, TEM, R, 1) - ENDIF -C - FUZZ = R1MACH(1) - IELMAX = 1 - RATMAX = ABS(DZ(1))/MAX(ABS(X(1)),FUZZ) - DO 25 I = 2, N - RAT = ABS(DZ(I))/MAX(ABS(X(I)),FUZZ) - IF( RAT.GT.RATMAX ) THEN - IELMAX = I - RATMAX = RAT - ENDIF - 25 CONTINUE - ERR = RATMAX - IF( RATMAX.LE.TOL ) ISSGMR = 1 - IF( IUNIT.GT.0 ) WRITE(IUNIT,1020) ITER, IELMAX, RATMAX - RETURN - ENDIF - ENDIF - IF ( ITOL.EQ.11 ) THEN -C -C Use SXLCAL to calculate the approximate solution XL. -C - IF ( (LGMR.NE.0) .AND. (ITER.GT.0) ) THEN - CALL SXLCAL(N, LGMR, X, XL, XL, HES, MAXLP1, Q, V, R0NRM, - $ DZ, SX, JSCAL, JPRE, MSOLVE, NMSL, RWORK, IWORK, - $ NELT, IA, JA, A, ISYM) - ELSEIF ( ITER.EQ.0 ) THEN -C Copy X to XL to check if initial guess is good enough. - CALL SCOPY(N, X, 1, XL, 1) - ELSE -C Return since this is the first call to SPIGMR on a restart. - RETURN - ENDIF -C - IF ((JSCAL .EQ. 0) .OR.(JSCAL .EQ. 2)) THEN -C err = ||x-TrueSolution||/||TrueSolution||(2-Norms). - IF ( ITER.EQ.0 ) SOLNRM = SNRM2(N, SOLN, 1) - DO 30 I = 1, N - DZ(I) = XL(I) - SOLN(I) - 30 CONTINUE - ERR = SNRM2(N, DZ, 1)/SOLNRM - ELSE - IF (ITER .EQ. 0) THEN - SOLNRM = 0 - DO 40 I = 1,N - SOLNRM = SOLNRM + (SX(I)*SOLN(I))**2 - 40 CONTINUE - SOLNRM = SQRT(SOLNRM) - ENDIF - DXNRM = 0 - DO 50 I = 1,N - DXNRM = DXNRM + (SX(I)*(XL(I)-SOLN(I)))**2 - 50 CONTINUE - DXNRM = SQRT(DXNRM) -C err = ||SX*(x-TrueSolution)||/||SX*TrueSolution|| (2-Norms). - ERR = DXNRM/SOLNRM - ENDIF - ENDIF -C - IF( IUNIT.NE.0 ) THEN - IF( ITER.EQ.0 ) THEN - WRITE(IUNIT,1000) N, ITOL, MAXL, KMP - ENDIF - WRITE(IUNIT,1010) ITER, RNRM/BNRM, ERR - ENDIF - IF ( ERR.LE.TOL ) ISSGMR = 1 -C - RETURN - 1000 FORMAT(' Generalized Minimum Residual(',I3,I3,') for ', - $ 'N, ITOL = ',I5, I5, - $ /' ITER',' Natural Err Est',' Error Estimate') - 1010 FORMAT(1X,I4,1X,E16.7,1X,E16.7) - 1020 FORMAT(1X,' ITER = ',I5, ' IELMAX = ',I5, - $ ' |R(IELMAX)/X(IELMAX)| = ',E12.5) -C------------- LAST LINE OF ISSGMR FOLLOWS ---------------------------- - END diff --git a/slatec/issir.f b/slatec/issir.f deleted file mode 100644 index 737d52a..0000000 --- a/slatec/issir.f +++ /dev/null @@ -1,211 +0,0 @@ -*DECK ISSIR - INTEGER FUNCTION ISSIR (N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, - + ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, - + IWORK, BNRM, SOLNRM) -C***BEGIN PROLOGUE ISSIR -C***SUBSIDIARY -C***PURPOSE Preconditioned Iterative Refinement Stop Test. -C This routine calculates the stop test for the iterative -C refinement iteration scheme. It returns a non-zero if the -C error estimate (the type of which is determined by ITOL) -C is less than the user specified tolerance TOL. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (ISSIR-S, ISDIR-D) -C***KEYWORDS LINEAR SYSTEM, SLAP, SPARSE, STOP TEST -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER -C INTEGER IERR, IUNIT, IWORK(USER DEFINED) -C REAL B(N), X(N), A(N), TOL, ERR, R(N), Z(N), DZ(N) -C REAL RWORK(USER DEFINED), BNRM, SOLNRM -C EXTERNAL MSOLVE -C -C IF( ISSIR(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, IWORK, -C $ BNRM, SOLNRM) .NE. 0 ) THEN ITERATION DONE -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Real B(N). -C Right-hand side vector. -C X :IN Real X(N). -C The current approximate solution vector. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Real A(NELT). -C These arrays contain the matrix data structure for A. -C It could take any form. See "C *Description" in the -C SIR routine. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C MSOLVE :EXT External. -C Name of a routine which solves a linear system Mz = r for -C z given r with the preconditioning matrix M (M is supplied via -C RWORK and IWORK arrays. The name of the MSOLVE routine must -C be declared external in the calling program. The calling -C sequence to MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, R is the right-hand side -C vector and Z is the solution upon return. NELT, IA, JA, A and -C ISYM are defined as above. RWORK is a real array that can -C be used to pass necessary preconditioning information and/or -C workspace to MSOLVE. IWORK is an integer work array for -C the same purpose as RWORK. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /SSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :IN Real. -C Convergence criterion, as described above. -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :IN Integer. -C Current iteration count. (Must be zero on first call.) -C ERR :OUT Real. -C Error estimate of error in the X(N) approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Error flag. IERR is set to 3 if ITOL is not one of the -C acceptable values, see above. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C R :IN Real R(N). -C The residual R = B-AX. -C Z :WORK Real Z(N). -C Workspace used to hold the pseudo-residual M z = r. -C DZ :WORK Real DZ(N). -C Workspace used to hold temporary vector(s). -C RWORK :WORK Real RWORK(USER DEFINED). -C Real array that can be used by MSOLVE. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used by MSOLVE. -C BNRM :INOUT Real. -C Norm of the right hand side. Type of norm depends on ITOL. -C Calculated only on the first call. -C SOLNRM :INOUT Real. -C 2-Norm of the true solution, SOLN. Only computed and used -C if ITOL = 11. -C -C *Function Return Values: -C 0 : Error estimate (determined by ITOL) is *NOT* less than the -C specified tolerance, TOL. The iteration must continue. -C 1 : Error estimate (determined by ITOL) is less than the -C specified tolerance, TOL. The iteration can be considered -C complete. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO SIR, SSJAC, SSGS -C***ROUTINES CALLED R1MACH, SNRM2 -C***COMMON BLOCKS SSLBLK -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 880320 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 891003 Removed C***REFER TO line, per MKS. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MSOLVE from ROUTINES CALLED list. (FNF) -C 910506 Made subsidiary to SIR. (FNF) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 921026 Changed 1.0E10 to R1MACH(2). (FNF) -C***END PROLOGUE ISSIR -C .. Scalar Arguments .. - REAL BNRM, ERR, SOLNRM, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT -C .. Array Arguments .. - REAL A(NELT), B(N), DZ(N), R(N), RWORK(*), X(N), Z(N) - INTEGER IA(NELT), IWORK(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MSOLVE -C .. Arrays in Common .. - REAL SOLN(1) -C .. Local Scalars .. - INTEGER I -C .. External Functions .. - REAL R1MACH, SNRM2 - EXTERNAL R1MACH, SNRM2 -C .. Common blocks .. - COMMON /SSLBLK/ SOLN -C***FIRST EXECUTABLE STATEMENT ISSIR - ISSIR = 0 - IF( ITOL.EQ.1 ) THEN -C err = ||Residual||/||RightHandSide|| (2-Norms). - IF(ITER .EQ. 0) BNRM = SNRM2(N, B, 1) - ERR = SNRM2(N, R, 1)/BNRM - ELSE IF( ITOL.EQ.2 ) THEN -C -1 -1 -C err = ||M Residual||/||M RightHandSide|| (2-Norms). - IF(ITER .EQ. 0) THEN - CALL MSOLVE(N, B, DZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) - BNRM = SNRM2(N, DZ, 1) - ENDIF - ERR = SNRM2(N, Z, 1)/BNRM - ELSE IF( ITOL.EQ.11 ) THEN -C err = ||x-TrueSolution||/||TrueSolution|| (2-Norms). - IF( ITER.EQ.0 ) SOLNRM = SNRM2(N, SOLN, 1) - DO 10 I = 1, N - DZ(I) = X(I) - SOLN(I) - 10 CONTINUE - ERR = SNRM2(N, DZ, 1)/SOLNRM - ELSE -C -C If we get here ITOL is not one of the acceptable values. - ERR = R1MACH(2) - IERR = 3 - ENDIF -C - IF( IUNIT.NE.0 ) THEN - WRITE(IUNIT,1000) ITER,ERR - ENDIF -C - IF( ERR.LE.TOL ) ISSIR = 1 -C - RETURN - 1000 FORMAT(5X,'ITER = ',I4,' Error Estimate = ',E16.7) -C------------- LAST LINE OF ISSIR FOLLOWS ----------------------------- - END diff --git a/slatec/issomn.f b/slatec/issomn.f deleted file mode 100644 index 400a874..0000000 --- a/slatec/issomn.f +++ /dev/null @@ -1,236 +0,0 @@ -*DECK ISSOMN - INTEGER FUNCTION ISSOMN (N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, - + NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, AP, - + EMAP, DZ, CSAV, RWORK, IWORK, AK, BNRM, SOLNRM) -C***BEGIN PROLOGUE ISSOMN -C***SUBSIDIARY -C***PURPOSE Preconditioned Orthomin Stop Test. -C This routine calculates the stop test for the Orthomin -C iteration scheme. It returns a non-zero if the error -C estimate (the type of which is determined by ITOL) is -C less than the user specified tolerance TOL. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (ISSOMN-S, ISDOMN-D) -C***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, -C ORTHOMIN, SLAP, SPARSE, STOP TEST -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NSAVE, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) -C REAL B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N) -C REAL P(N,0:NSAVE), AP(N,0:NSAVE), EMAP(N,0:NSAVE) -C REAL DZ(N), CSAV(NSAVE), RWORK(USER DEFINED), AK -C REAL BNRM, SOLNRM -C EXTERNAL MSOLVE -C -C IF( ISSOMN(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, NSAVE, -C $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, AP, -C $ EMAP, DZ, CSAV, RWORK, IWORK, AK, BNRM, SOLNRM) -C $ .NE.0 ) THEN ITERATION CONVERGED -C -C *Arguments: -C N :IN Integer. -C Order of the matrix. -C B :IN Real B(N). -C Right-hand side vector. -C X :IN Real X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Real A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description" -C in the SSDOMN or SSLUOM prologue. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C MSOLVE :EXT External. -C Name of a routine which solves a linear system MZ = R for -C Z given R with the preconditioning matrix M (M is supplied via -C RWORK and IWORK arrays). The name of the MSOLVE routine must -C be declared external in the calling program. The calling -C sequence to MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, R is the right-hand side -C vector and Z is the solution upon return. NELT, IA, JA, A and -C ISYM are defined as above. RWORK is a real array that can -C be used to pass necessary preconditioning information and/or -C workspace to MSOLVE. IWORK is an integer work array for -C the same purpose as RWORK. -C NSAVE :IN Integer. -C Number of direction vectors to save and orthogonalize against. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /SSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :IN Real. -C Convergence criterion, as described above. -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :IN Integer. -C Current iteration count. (Must be zero on first call.) -C ERR :OUT Real. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Error flag. IERR is set to 3 if ITOL is not one of the -C acceptable values, see above. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C R :IN Real R(N). -C The residual R = B-AX. -C Z :WORK Real Z(N). -C P :IN Real P(N,0:NSAVE). -C Workspace used to hold the conjugate direction vector(s). -C AP :IN Real AP(N,0:NSAVE). -C Workspace used to hold the matrix A times the P vector(s). -C EMAP :IN Real EMAP(N,0:NSAVE). -C Workspace used to hold M-inv times the AP vector(s). -C DZ :WORK Real DZ(N). -C Workspace. -C CSAV :DUMMY Real CSAV(NSAVE) -C Reserved for future use. -C RWORK :WORK Real RWORK(USER DEFINED). -C Real array that can be used for workspace in MSOLVE. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used for workspace in MSOLVE. -C AK :IN Real. -C Current iterate Orthomin iteration parameter. -C BNRM :OUT Real. -C Current solution B-norm, if ITOL = 1 or 2. -C SOLNRM :OUT Real. -C True solution norm, if ITOL = 11. -C -C *Function Return Values: -C 0 : Error estimate (determined by ITOL) is *NOT* less than the -C specified tolerance, TOL. The iteration must continue. -C 1 : Error estimate (determined by ITOL) is less than the -C specified tolerance, TOL. The iteration can be considered -C complete. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO SOMN, SSDOMN, SSLUOM -C***ROUTINES CALLED R1MACH, SNRM2 -C***COMMON BLOCKS SSLBLK -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 891003 Removed C***REFER TO line, per MKS. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MSOLVE from ROUTINES CALLED list. (FNF) -C 910506 Made subsidiary to SOMN. (FNF) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920930 Corrected to not print AK when ITER=0. (FNF) -C 921026 Changed 1.0E10 to R1MACH(2). (FNF) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE ISSOMN -C .. Scalar Arguments .. - REAL AK, BNRM, ERR, SOLNRM, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT, NSAVE -C .. Array Arguments .. - REAL A(NELT), AP(N,0:NSAVE), B(N), CSAV(NSAVE), DZ(N), - + EMAP(N,0:NSAVE), P(N,0:NSAVE), R(N), RWORK(*), X(N), Z(N) - INTEGER IA(NELT), IWORK(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MSOLVE -C .. Arrays in Common .. - REAL SOLN(1) -C .. Local Scalars .. - INTEGER I -C .. External Functions .. - REAL R1MACH, SNRM2 - EXTERNAL R1MACH, SNRM2 -C .. Common blocks .. - COMMON /SSLBLK/ SOLN -C***FIRST EXECUTABLE STATEMENT ISSOMN - ISSOMN = 0 -C - IF( ITOL.EQ.1 ) THEN -C err = ||Residual||/||RightHandSide|| (2-Norms). - IF(ITER .EQ. 0) BNRM = SNRM2(N, B, 1) - ERR = SNRM2(N, R, 1)/BNRM - ELSE IF( ITOL.EQ.2 ) THEN -C -1 -1 -C err = ||M Residual||/||M RightHandSide|| (2-Norms). - IF(ITER .EQ. 0) THEN - CALL MSOLVE(N, B, DZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) - BNRM = SNRM2(N, DZ, 1) - ENDIF - ERR = SNRM2(N, Z, 1)/BNRM - ELSE IF( ITOL.EQ.11 ) THEN -C err = ||x-TrueSolution||/||TrueSolution|| (2-Norms). - IF(ITER .EQ. 0) SOLNRM = SNRM2(N, SOLN, 1) - DO 10 I = 1, N - DZ(I) = X(I) - SOLN(I) - 10 CONTINUE - ERR = SNRM2(N, DZ, 1)/SOLNRM - ELSE -C -C If we get here ITOL is not one of the acceptable values. - ERR = R1MACH(2) - IERR = 3 - ENDIF -C - IF(IUNIT .NE. 0) THEN - IF( ITER.EQ.0 ) THEN - WRITE(IUNIT,1000) NSAVE, N, ITOL - WRITE(IUNIT,1010) ITER, ERR - ELSE - WRITE(IUNIT,1010) ITER, ERR, AK - ENDIF - ENDIF - IF(ERR .LE. TOL) ISSOMN = 1 -C - RETURN - 1000 FORMAT(' Preconditioned Orthomin(',I3,') for ', - $ 'N, ITOL = ',I5, I5, - $ /' ITER',' Error Estimate',' Alpha') - 1010 FORMAT(1X,I4,1X,E16.7,1X,E16.7) -C------------- LAST LINE OF ISSOMN FOLLOWS ---------------------------- - END diff --git a/slatec/iswap.f b/slatec/iswap.f deleted file mode 100644 index d76b334..0000000 --- a/slatec/iswap.f +++ /dev/null @@ -1,99 +0,0 @@ -*DECK ISWAP - SUBROUTINE ISWAP (N, IX, INCX, IY, INCY) -C***BEGIN PROLOGUE ISWAP -C***PURPOSE Interchange two vectors. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A5 -C***TYPE INTEGER (SSWAP-S, DSWAP-D, CSWAP-C, ISWAP-I) -C***KEYWORDS BLAS, INTERCHANGE, LINEAR ALGEBRA, VECTOR -C***AUTHOR Vandevender, W. H., (SNLA) -C***DESCRIPTION -C -C Extended B L A S Subprogram -C Description of Parameters -C -C --Input-- -C N number of elements in input vector(s) -C IX integer vector with N elements -C INCX storage spacing between elements of IX -C IY integer vector with N elements -C INCY storage spacing between elements of IY -C -C --Output-- -C IX input vector IY (unchanged if N .LE. 0) -C IY input vector IX (unchanged if N .LE. 0) -C -C Interchange integer IX and integer IY. -C For I = 0 to N-1, interchange IX(LX+I*INCX) and IY(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 850601 DATE WRITTEN -C 861211 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 ISWAP - INTEGER IX(*), IY(*), ITEMP1, ITEMP2, ITEMP3 -C***FIRST EXECUTABLE STATEMENT ISWAP - IF (N .LE. 0) RETURN - IF (INCX .NE. INCY) GO TO 5 - IF (INCX-1) 5,20,60 -C -C Code for unequal or nonpositive increments. -C - 5 IIX = 1 - IIY = 1 - IF (INCX .LT. 0) IIX = (1-N)*INCX + 1 - IF (INCY .LT. 0) IIY = (1-N)*INCY + 1 - DO 10 I = 1,N - ITEMP1 = IX(IIX) - IX(IIX) = IY(IIY) - IY(IIY) = ITEMP1 - IIX = IIX + INCX - IIY = IIY + INCY - 10 CONTINUE - RETURN -C -C Code for both increments equal to 1. -C -C Clean-up loop so remaining vector length is a multiple of 3. -C - 20 M = MOD(N,3) - IF (M .EQ. 0) GO TO 40 - DO 30 I = 1,M - ITEMP1 = IX(I) - IX(I) = IY(I) - IY(I) = ITEMP1 - 30 CONTINUE - IF (N .LT. 3) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,3 - ITEMP1 = IX(I) - ITEMP2 = IX(I+1) - ITEMP3 = IX(I+2) - IX(I) = IY(I) - IX(I+1) = IY(I+1) - IX(I+2) = IY(I+2) - IY(I) = ITEMP1 - IY(I+1) = ITEMP2 - IY(I+2) = ITEMP3 - 50 CONTINUE - RETURN -C -C Code for equal, positive, non-unit increments. -C - 60 NS = N*INCX - DO 70 I = 1,NS,INCX - ITEMP1 = IX(I) - IX(I) = IY(I) - IY(I) = ITEMP1 - 70 CONTINUE - RETURN - END diff --git a/slatec/ivout.f b/slatec/ivout.f deleted file mode 100644 index 26f0fac..0000000 --- a/slatec/ivout.f +++ /dev/null @@ -1,137 +0,0 @@ -*DECK IVOUT - SUBROUTINE IVOUT (N, IX, IFMT, IDIGIT) -C***BEGIN PROLOGUE IVOUT -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE INTEGER (IVOUT-I) -C***AUTHOR Hanson, R. J., (SNLA) -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C -C INTEGER VECTOR OUTPUT ROUTINE. -C -C INPUT.. -C -C N,IX(*) PRINT THE INTEGER ARRAY IX(I),I=1,...,N, ON OUTPUT -C UNIT LOUT. THE HEADING IN THE FORTRAN FORMAT -C STATEMENT IFMT(*), DESCRIBED BELOW, IS PRINTED AS A FIRST -C STEP. THE COMPONENTS IX(I) ARE INDEXED, ON OUTPUT, -C IN A PLEASANT FORMAT. -C IFMT(*) A FORTRAN FORMAT STATEMENT. THIS IS PRINTED ON OUTPUT -C UNIT LOUT WITH THE VARIABLE FORMAT FORTRAN STATEMENT -C WRITE(LOUT,IFMT) -C IDIGIT PRINT UP TO ABS(IDIGIT) DECIMAL DIGITS PER NUMBER. -C THE SUBPROGRAM WILL CHOOSE THAT INTEGER 4,6,10 OR 14 -C WHICH WILL PRINT AT LEAST ABS(IDIGIT) NUMBER OF -C PLACES. IF IDIGIT.LT.0, 72 PRINTING COLUMNS ARE UTILIZED -C TO WRITE EACH LINE OF OUTPUT OF THE ARRAY IX(*). (THIS -C CAN BE USED ON MOST TIME-SHARING TERMINALS). IF -C IDIGIT.GE.0, 133 PRINTING COLUMNS ARE UTILIZED. (THIS CAN -C BE USED ON MOST LINE PRINTERS). -C -C EXAMPLE.. -C -C PRINT AN ARRAY CALLED (COSTS OF PURCHASES) OF LENGTH 100 SHOWING -C 6 DECIMAL DIGITS PER NUMBER. THE USER IS RUNNING ON A TIME-SHARING -C SYSTEM WITH A 72 COLUMN OUTPUT DEVICE. -C -C DIMENSION ICOSTS(100) -C N = 100 -C IDIGIT = -6 -C CALL IVOUT(N,ICOSTS,'(''1COSTS OF PURCHASES'')',IDIGIT) -C -C***SEE ALSO SPLP -C***ROUTINES CALLED I1MACH -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 910403 Updated AUTHOR section. (WRB) -C***END PROLOGUE IVOUT - DIMENSION IX(*) - CHARACTER IFMT*(*) -C -C GET THE UNIT NUMBER WHERE OUTPUT WILL BE WRITTEN. -C***FIRST EXECUTABLE STATEMENT IVOUT - J=2 - LOUT=I1MACH(J) - WRITE(LOUT,IFMT) - IF(N.LE.0) RETURN - NDIGIT = IDIGIT - IF(IDIGIT.EQ.0) NDIGIT = 4 - IF(IDIGIT.GE.0) GO TO 80 -C - NDIGIT = -IDIGIT - IF(NDIGIT.GT.4) GO TO 20 -C - DO 10 K1=1,N,10 - K2 = MIN(N,K1+9) - WRITE(LOUT,1000) K1,K2,(IX(I),I=K1,K2) - 10 CONTINUE - RETURN -C - 20 CONTINUE - IF(NDIGIT.GT.6) GO TO 40 -C - DO 30 K1=1,N,7 - K2 = MIN(N,K1+6) - WRITE(LOUT,1001) K1,K2,(IX(I),I=K1,K2) - 30 CONTINUE - RETURN -C - 40 CONTINUE - IF(NDIGIT.GT.10) GO TO 60 -C - DO 50 K1=1,N,5 - K2=MIN(N,K1+4) - WRITE(LOUT,1002) K1,K2,(IX(I),I=K1,K2) - 50 CONTINUE - RETURN -C - 60 CONTINUE - DO 70 K1=1,N,3 - K2 = MIN(N,K1+2) - WRITE(LOUT,1003) K1,K2,(IX(I),I=K1,K2) - 70 CONTINUE - RETURN -C - 80 CONTINUE - IF(NDIGIT.GT.4) GO TO 100 -C - DO 90 K1=1,N,20 - K2 = MIN(N,K1+19) - WRITE(LOUT,1000) K1,K2,(IX(I),I=K1,K2) - 90 CONTINUE - RETURN -C - 100 CONTINUE - IF(NDIGIT.GT.6) GO TO 120 -C - DO 110 K1=1,N,15 - K2 = MIN(N,K1+14) - WRITE(LOUT,1001) K1,K2,(IX(I),I=K1,K2) - 110 CONTINUE - RETURN -C - 120 CONTINUE - IF(NDIGIT.GT.10) GO TO 140 -C - DO 130 K1=1,N,10 - K2 = MIN(N,K1+9) - WRITE(LOUT,1002) K1,K2,(IX(I),I=K1,K2) - 130 CONTINUE - RETURN -C - 140 CONTINUE - DO 150 K1=1,N,7 - K2 = MIN(N,K1+6) - WRITE(LOUT,1003) K1,K2,(IX(I),I=K1,K2) - 150 CONTINUE - RETURN - 1000 FORMAT(1X,I4,' - ',I4,20(1X,I5)) - 1001 FORMAT(1X,I4,' - ',I4,15(1X,I7)) - 1002 FORMAT(1X,I4,' - ',I4,10(1X,I11)) - 1003 FORMAT(1X,I4,' - ',I4,7(1X,I15)) - END diff --git a/slatec/j4save.f b/slatec/j4save.f deleted file mode 100644 index 6ec799b..0000000 --- a/slatec/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) - 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/slatec/jairy.f b/slatec/jairy.f deleted file mode 100644 index 7cb5e61..0000000 --- a/slatec/jairy.f +++ /dev/null @@ -1,344 +0,0 @@ -*DECK JAIRY - SUBROUTINE JAIRY (X, RX, C, AI, DAI) -C***BEGIN PROLOGUE JAIRY -C***SUBSIDIARY -C***PURPOSE Subsidiary to BESJ and BESY -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (JAIRY-S, DJAIRY-D) -C***AUTHOR Amos, D. E., (SNLA) -C Daniel, S. L., (SNLA) -C Weston, M. K., (SNLA) -C***DESCRIPTION -C -C JAIRY computes the Airy function AI(X) -C and its derivative DAI(X) for ASYJY -C -C INPUT -C -C X - Argument, computed by ASYJY, X unrestricted -C RX - RX=SQRT(ABS(X)), computed by ASYJY -C C - C=2.*(ABS(X)**1.5)/3., computed by ASYJY -C -C OUTPUT -C -C AI - Value of function AI(X) -C DAI - Value of the derivative DAI(X) -C -C***SEE ALSO BESJ, BESY -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 891009 Removed unreferenced variable. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910408 Updated the AUTHOR section. (WRB) -C***END PROLOGUE JAIRY -C - INTEGER I, J, M1, M1D, M2, M2D, M3, M3D, M4, M4D, N1, N1D, N2, - 1 N2D, N3, N3D, N4, N4D - REAL A, AI, AJN, AJP, AK1, AK2, AK3, B, C, CCV, CON2, CON3, - 1 CON4, CON5, CV, DA, DAI, DAJN, DAJP, DAK1, DAK2, DAK3, DB, EC, - 2 E1, E2, FPI12, F1, F2, RTRX, RX, SCV, T, TEMP1, TEMP2, TT, X - DIMENSION AJP(19), AJN(19), A(15), B(15) - DIMENSION AK1(14), AK2(23), AK3(14) - DIMENSION DAJP(19), DAJN(19), DA(15), DB(15) - DIMENSION DAK1(14), DAK2(24), DAK3(14) - SAVE N1, N2, N3, N4, M1, M2, M3, M4, FPI12, CON2, - 1 CON3, CON4, CON5,AK1, AK2, AK3, AJP, AJN, A, B, - 2 N1D, N2D, N3D, N4D, M1D, M2D, M3D, M4D, - 3 DAK1, DAK2, DAK3, DAJP, DAJN, DA, DB - DATA N1,N2,N3,N4/14,23,19,15/ - DATA M1,M2,M3,M4/12,21,17,13/ - DATA FPI12,CON2,CON3,CON4,CON5/ - 1 1.30899693899575E+00, 5.03154716196777E+00, 3.80004589867293E-01, - 2 8.33333333333333E-01, 8.66025403784439E-01/ - DATA AK1(1), AK1(2), AK1(3), AK1(4), AK1(5), AK1(6), AK1(7), - 1 AK1(8), AK1(9), AK1(10),AK1(11),AK1(12),AK1(13), - 2 AK1(14) / 2.20423090987793E-01,-1.25290242787700E-01, - 3 1.03881163359194E-02, 8.22844152006343E-04,-2.34614345891226E-04, - 4 1.63824280172116E-05, 3.06902589573189E-07,-1.29621999359332E-07, - 5 8.22908158823668E-09, 1.53963968623298E-11,-3.39165465615682E-11, - 6 2.03253257423626E-12,-1.10679546097884E-14,-5.16169497785080E-15/ - DATA AK2(1), AK2(2), AK2(3), AK2(4), AK2(5), AK2(6), AK2(7), - 1 AK2(8), AK2(9), AK2(10),AK2(11),AK2(12),AK2(13),AK2(14), - 2 AK2(15),AK2(16),AK2(17),AK2(18),AK2(19),AK2(20),AK2(21), - 3 AK2(22),AK2(23) / 2.74366150869598E-01, 5.39790969736903E-03, - 4-1.57339220621190E-03, 4.27427528248750E-04,-1.12124917399925E-04, - 5 2.88763171318904E-05,-7.36804225370554E-06, 1.87290209741024E-06, - 6-4.75892793962291E-07, 1.21130416955909E-07,-3.09245374270614E-08, - 7 7.92454705282654E-09,-2.03902447167914E-09, 5.26863056595742E-10, - 8-1.36704767639569E-10, 3.56141039013708E-11,-9.31388296548430E-12, - 9 2.44464450473635E-12,-6.43840261990955E-13, 1.70106030559349E-13, - 1-4.50760104503281E-14, 1.19774799164811E-14,-3.19077040865066E-15/ - DATA AK3(1), AK3(2), AK3(3), AK3(4), AK3(5), AK3(6), AK3(7), - 1 AK3(8), AK3(9), AK3(10),AK3(11),AK3(12),AK3(13), - 2 AK3(14) / 2.80271447340791E-01,-1.78127042844379E-03, - 3 4.03422579628999E-05,-1.63249965269003E-06, 9.21181482476768E-08, - 4-6.52294330229155E-09, 5.47138404576546E-10,-5.24408251800260E-11, - 5 5.60477904117209E-12,-6.56375244639313E-13, 8.31285761966247E-14, - 6-1.12705134691063E-14, 1.62267976598129E-15,-2.46480324312426E-16/ - DATA AJP(1), AJP(2), AJP(3), AJP(4), AJP(5), AJP(6), AJP(7), - 1 AJP(8), AJP(9), AJP(10),AJP(11),AJP(12),AJP(13),AJP(14), - 2 AJP(15),AJP(16),AJP(17),AJP(18), - 3 AJP(19) / 7.78952966437581E-02,-1.84356363456801E-01, - 4 3.01412605216174E-02, 3.05342724277608E-02,-4.95424702513079E-03, - 5-1.72749552563952E-03, 2.43137637839190E-04, 5.04564777517082E-05, - 6-6.16316582695208E-06,-9.03986745510768E-07, 9.70243778355884E-08, - 7 1.09639453305205E-08,-1.04716330588766E-09,-9.60359441344646E-11, - 8 8.25358789454134E-12, 6.36123439018768E-13,-4.96629614116015E-14, - 9-3.29810288929615E-15, 2.35798252031104E-16/ - DATA AJN(1), AJN(2), AJN(3), AJN(4), AJN(5), AJN(6), AJN(7), - 1 AJN(8), AJN(9), AJN(10),AJN(11),AJN(12),AJN(13),AJN(14), - 2 AJN(15),AJN(16),AJN(17),AJN(18), - 3 AJN(19) / 3.80497887617242E-02,-2.45319541845546E-01, - 4 1.65820623702696E-01, 7.49330045818789E-02,-2.63476288106641E-02, - 5-5.92535597304981E-03, 1.44744409589804E-03, 2.18311831322215E-04, - 6-4.10662077680304E-05,-4.66874994171766E-06, 7.15218807277160E-07, - 7 6.52964770854633E-08,-8.44284027565946E-09,-6.44186158976978E-10, - 8 7.20802286505285E-11, 4.72465431717846E-12,-4.66022632547045E-13, - 9-2.67762710389189E-14, 2.36161316570019E-15/ - DATA A(1), A(2), A(3), A(4), A(5), A(6), A(7), - 1 A(8), A(9), A(10), A(11), A(12), A(13), A(14), - 2 A(15) / 4.90275424742791E-01, 1.57647277946204E-03, - 3-9.66195963140306E-05, 1.35916080268815E-07, 2.98157342654859E-07, - 4-1.86824767559979E-08,-1.03685737667141E-09, 3.28660818434328E-10, - 5-2.57091410632780E-11,-2.32357655300677E-12, 9.57523279048255E-13, - 6-1.20340828049719E-13,-2.90907716770715E-15, 4.55656454580149E-15, - 7-9.99003874810259E-16/ - DATA B(1), B(2), B(3), B(4), B(5), B(6), B(7), - 1 B(8), B(9), B(10), B(11), B(12), B(13), B(14), - 2 B(15) / 2.78593552803079E-01,-3.52915691882584E-03, - 3-2.31149677384994E-05, 4.71317842263560E-06,-1.12415907931333E-07, - 4-2.00100301184339E-08, 2.60948075302193E-09,-3.55098136101216E-11, - 5-3.50849978423875E-11, 5.83007187954202E-12,-2.04644828753326E-13, - 6-1.10529179476742E-13, 2.87724778038775E-14,-2.88205111009939E-15, - 7-3.32656311696166E-16/ - DATA N1D,N2D,N3D,N4D/14,24,19,15/ - DATA M1D,M2D,M3D,M4D/12,22,17,13/ - DATA DAK1(1), DAK1(2), DAK1(3), DAK1(4), DAK1(5), DAK1(6), - 1 DAK1(7), DAK1(8), DAK1(9), DAK1(10),DAK1(11),DAK1(12), - 2 DAK1(13),DAK1(14)/ 2.04567842307887E-01,-6.61322739905664E-02, - 3-8.49845800989287E-03, 3.12183491556289E-03,-2.70016489829432E-04, - 4-6.35636298679387E-06, 3.02397712409509E-06,-2.18311195330088E-07, - 5-5.36194289332826E-10, 1.13098035622310E-09,-7.43023834629073E-11, - 6 4.28804170826891E-13, 2.23810925754539E-13,-1.39140135641182E-14/ - DATA DAK2(1), DAK2(2), DAK2(3), DAK2(4), DAK2(5), DAK2(6), - 1 DAK2(7), DAK2(8), DAK2(9), DAK2(10),DAK2(11),DAK2(12), - 2 DAK2(13),DAK2(14),DAK2(15),DAK2(16),DAK2(17),DAK2(18), - 3 DAK2(19),DAK2(20),DAK2(21),DAK2(22),DAK2(23), - 4 DAK2(24) / 2.93332343883230E-01,-8.06196784743112E-03, - 5 2.42540172333140E-03,-6.82297548850235E-04, 1.85786427751181E-04, - 6-4.97457447684059E-05, 1.32090681239497E-05,-3.49528240444943E-06, - 7 9.24362451078835E-07,-2.44732671521867E-07, 6.49307837648910E-08, - 8-1.72717621501538E-08, 4.60725763604656E-09,-1.23249055291550E-09, - 9 3.30620409488102E-10,-8.89252099772401E-11, 2.39773319878298E-11, - 1-6.48013921153450E-12, 1.75510132023731E-12,-4.76303829833637E-13, - 2 1.29498241100810E-13,-3.52679622210430E-14, 9.62005151585923E-15, - 3-2.62786914342292E-15/ - DATA DAK3(1), DAK3(2), DAK3(3), DAK3(4), DAK3(5), DAK3(6), - 1 DAK3(7), DAK3(8), DAK3(9), DAK3(10),DAK3(11),DAK3(12), - 2 DAK3(13),DAK3(14)/ 2.84675828811349E-01, 2.53073072619080E-03, - 3-4.83481130337976E-05, 1.84907283946343E-06,-1.01418491178576E-07, - 4 7.05925634457153E-09,-5.85325291400382E-10, 5.56357688831339E-11, - 5-5.90889094779500E-12, 6.88574353784436E-13,-8.68588256452194E-14, - 6 1.17374762617213E-14,-1.68523146510923E-15, 2.55374773097056E-16/ - DATA DAJP(1), DAJP(2), DAJP(3), DAJP(4), DAJP(5), DAJP(6), - 1 DAJP(7), DAJP(8), DAJP(9), DAJP(10),DAJP(11),DAJP(12), - 2 DAJP(13),DAJP(14),DAJP(15),DAJP(16),DAJP(17),DAJP(18), - 3 DAJP(19) / 6.53219131311457E-02,-1.20262933688823E-01, - 4 9.78010236263823E-03, 1.67948429230505E-02,-1.97146140182132E-03, - 5-8.45560295098867E-04, 9.42889620701976E-05, 2.25827860945475E-05, - 6-2.29067870915987E-06,-3.76343991136919E-07, 3.45663933559565E-08, - 7 4.29611332003007E-09,-3.58673691214989E-10,-3.57245881361895E-11, - 8 2.72696091066336E-12, 2.26120653095771E-13,-1.58763205238303E-14, - 9-1.12604374485125E-15, 7.31327529515367E-17/ - DATA DAJN(1), DAJN(2), DAJN(3), DAJN(4), DAJN(5), DAJN(6), - 1 DAJN(7), DAJN(8), DAJN(9), DAJN(10),DAJN(11),DAJN(12), - 2 DAJN(13),DAJN(14),DAJN(15),DAJN(16),DAJN(17),DAJN(18), - 3 DAJN(19) / 1.08594539632967E-02, 8.53313194857091E-02, - 4-3.15277068113058E-01,-8.78420725294257E-02, 5.53251906976048E-02, - 5 9.41674060503241E-03,-3.32187026018996E-03,-4.11157343156826E-04, - 6 1.01297326891346E-04, 9.87633682208396E-06,-1.87312969812393E-06, - 7-1.50798500131468E-07, 2.32687669525394E-08, 1.59599917419225E-09, - 8-2.07665922668385E-10,-1.24103350500302E-11, 1.39631765331043E-12, - 9 7.39400971155740E-14,-7.32887475627500E-15/ - DATA DA(1), DA(2), DA(3), DA(4), DA(5), DA(6), DA(7), - 1 DA(8), DA(9), DA(10), DA(11), DA(12), DA(13), DA(14), - 2 DA(15) / 4.91627321104601E-01, 3.11164930427489E-03, - 3 8.23140762854081E-05,-4.61769776172142E-06,-6.13158880534626E-08, - 4 2.87295804656520E-08,-1.81959715372117E-09,-1.44752826642035E-10, - 5 4.53724043420422E-11,-3.99655065847223E-12,-3.24089119830323E-13, - 6 1.62098952568741E-13,-2.40765247974057E-14, 1.69384811284491E-16, - 7 8.17900786477396E-16/ - DATA DB(1), DB(2), DB(3), DB(4), DB(5), DB(6), DB(7), - 1 DB(8), DB(9), DB(10), DB(11), DB(12), DB(13), DB(14), - 2 DB(15) /-2.77571356944231E-01, 4.44212833419920E-03, - 3-8.42328522190089E-05,-2.58040318418710E-06, 3.42389720217621E-07, - 4-6.24286894709776E-09,-2.36377836844577E-09, 3.16991042656673E-10, - 5-4.40995691658191E-12,-5.18674221093575E-12, 9.64874015137022E-13, - 6-4.90190576608710E-14,-1.77253430678112E-14, 5.55950610442662E-15, - 7-7.11793337579530E-16/ -C***FIRST EXECUTABLE STATEMENT JAIRY - IF (X.LT.0.0E0) GO TO 90 - IF (C.GT.5.0E0) GO TO 60 - IF (X.GT.1.20E0) GO TO 30 - T = (X+X-1.2E0)*CON4 - TT = T + T - J = N1 - F1 = AK1(J) - F2 = 0.0E0 - DO 10 I=1,M1 - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + AK1(J) - F2 = TEMP1 - 10 CONTINUE - AI = T*F1 - F2 + AK1(1) -C - J = N1D - F1 = DAK1(J) - F2 = 0.0E0 - DO 20 I=1,M1D - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + DAK1(J) - F2 = TEMP1 - 20 CONTINUE - DAI = -(T*F1-F2+DAK1(1)) - RETURN -C - 30 CONTINUE - T = (X+X-CON2)*CON3 - TT = T + T - J = N2 - F1 = AK2(J) - F2 = 0.0E0 - DO 40 I=1,M2 - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + AK2(J) - F2 = TEMP1 - 40 CONTINUE - RTRX = SQRT(RX) - EC = EXP(-C) - AI = EC*(T*F1-F2+AK2(1))/RTRX - J = N2D - F1 = DAK2(J) - F2 = 0.0E0 - DO 50 I=1,M2D - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + DAK2(J) - F2 = TEMP1 - 50 CONTINUE - DAI = -EC*(T*F1-F2+DAK2(1))*RTRX - RETURN -C - 60 CONTINUE - T = 10.0E0/C - 1.0E0 - TT = T + T - J = N1 - F1 = AK3(J) - F2 = 0.0E0 - DO 70 I=1,M1 - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + AK3(J) - F2 = TEMP1 - 70 CONTINUE - RTRX = SQRT(RX) - EC = EXP(-C) - AI = EC*(T*F1-F2+AK3(1))/RTRX - J = N1D - F1 = DAK3(J) - F2 = 0.0E0 - DO 80 I=1,M1D - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + DAK3(J) - F2 = TEMP1 - 80 CONTINUE - DAI = -RTRX*EC*(T*F1-F2+DAK3(1)) - RETURN -C - 90 CONTINUE - IF (C.GT.5.0E0) GO TO 120 - T = 0.4E0*C - 1.0E0 - TT = T + T - J = N3 - F1 = AJP(J) - E1 = AJN(J) - F2 = 0.0E0 - E2 = 0.0E0 - DO 100 I=1,M3 - J = J - 1 - TEMP1 = F1 - TEMP2 = E1 - F1 = TT*F1 - F2 + AJP(J) - E1 = TT*E1 - E2 + AJN(J) - F2 = TEMP1 - E2 = TEMP2 - 100 CONTINUE - AI = (T*E1-E2+AJN(1)) - X*(T*F1-F2+AJP(1)) - J = N3D - F1 = DAJP(J) - E1 = DAJN(J) - F2 = 0.0E0 - E2 = 0.0E0 - DO 110 I=1,M3D - J = J - 1 - TEMP1 = F1 - TEMP2 = E1 - F1 = TT*F1 - F2 + DAJP(J) - E1 = TT*E1 - E2 + DAJN(J) - F2 = TEMP1 - E2 = TEMP2 - 110 CONTINUE - DAI = X*X*(T*F1-F2+DAJP(1)) + (T*E1-E2+DAJN(1)) - RETURN -C - 120 CONTINUE - T = 10.0E0/C - 1.0E0 - TT = T + T - J = N4 - F1 = A(J) - E1 = B(J) - F2 = 0.0E0 - E2 = 0.0E0 - DO 130 I=1,M4 - J = J - 1 - TEMP1 = F1 - TEMP2 = E1 - F1 = TT*F1 - F2 + A(J) - E1 = TT*E1 - E2 + B(J) - F2 = TEMP1 - E2 = TEMP2 - 130 CONTINUE - TEMP1 = T*F1 - F2 + A(1) - TEMP2 = T*E1 - E2 + B(1) - RTRX = SQRT(RX) - CV = C - FPI12 - CCV = COS(CV) - SCV = SIN(CV) - AI = (TEMP1*CCV-TEMP2*SCV)/RTRX - J = N4D - F1 = DA(J) - E1 = DB(J) - F2 = 0.0E0 - E2 = 0.0E0 - DO 140 I=1,M4D - J = J - 1 - TEMP1 = F1 - TEMP2 = E1 - F1 = TT*F1 - F2 + DA(J) - E1 = TT*E1 - E2 + DB(J) - F2 = TEMP1 - E2 = TEMP2 - 140 CONTINUE - TEMP1 = T*F1 - F2 + DA(1) - TEMP2 = T*E1 - E2 + DB(1) - E1 = CCV*CON5 + 0.5E0*SCV - E2 = SCV*CON5 - 0.5E0*CCV - DAI = (TEMP1*E1-TEMP2*E2)*RTRX - RETURN - END diff --git a/slatec/la05ad.f b/slatec/la05ad.f deleted file mode 100644 index c8ed0cc..0000000 --- a/slatec/la05ad.f +++ /dev/null @@ -1,516 +0,0 @@ -*DECK LA05AD - SUBROUTINE LA05AD (A, IND, NZ, IA, N, IP, IW, W, G, U) -C***BEGIN PROLOGUE LA05AD -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSPLP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (LA05AS-S, LA05AD-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM -C FROM THE C. 1979 AERE HARWELL LIBRARY. THE NAME OF THE -C CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING -C THE FINAL LETTER =D= IN THE NAMES USED HERE. -C REVISIONS MADE BY R J HANSON, SNLA, AUGUST, 1979. -C REVISED SEP. 13, 1979. -C -C ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES -C IN THE PACKAGE GIVEN HERE. ANY PRIMARY USAGE OF THE HARWELL -C SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN -C THE USER AND AERE-UK. ANY USAGE OF THE SANDIA WRITTEN CODES -C DSPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED. -C -C IP(I,1),IP(I,2) POINT TO THE START OF ROW/COL I. -C IW(I,1),IW(I,2) HOLD THE NUMBER OF NON-ZEROS IN ROW/COL I. -C DURING THE MAIN BODY OF THIS SUBROUTINE THE VECTORS IW(.,3),IW(.,5), -C IW(.,7) ARE USED TO HOLD DOUBLY LINKED LISTS OF ROWS THAT HAVE -C NOT BEEN PIVOTAL AND HAVE EQUAL NUMBERS OF NON-ZEROS. -C IW(.,4),IW(.,6),IW(.,8) HOLD SIMILAR LISTS FOR THE COLUMNS. -C IW(I,3),IW(I,4) HOLD FIRST ROW/COLUMN TO HAVE I NON-ZEROS -C OR ZERO IF THERE ARE NONE. -C IW(I,5), IW(I,6) HOLD ROW/COL NUMBER OF ROW/COL PRIOR TO ROW/COL I -C IN ITS LIST, OR ZERO IF NONE. -C IW(I,7), IW(I,8) HOLD ROW/COL NUMBER OF ROW/COL AFTER ROW/COL I -C IN ITS LIST, OR ZERO IF NONE. -C FOR ROWS/COLS THAT HAVE BEEN PIVOTAL IW(I,5),IW(I,6) HOLD NEGATION OF -C POSITION OF ROW/COL I IN THE PIVOTAL ORDERING. -C -C***SEE ALSO DSPLP -C***ROUTINES CALLED D1MACH, LA05ED, MC20AD, XERMSG, XSETUN -C***COMMON BLOCKS LA05DD -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890605 Added D1MACH to list of DOUBLE PRECISION variables. -C 890605 Corrected references to XERRWV. (WRB) -C (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900402 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C***END PROLOGUE LA05AD - INTEGER IP(N,2) - INTEGER IND(IA,2), IW(N,8) - DOUBLE PRECISION A(*), AMAX, AU, AM, D1MACH, EPS, G, U, SMALL, - * W(*) - LOGICAL FIRST - CHARACTER*8 XERN0, XERN1, XERN2 -C - COMMON /LA05DD/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL -C EPS IS THE RELATIVE ACCURACY OF FLOATING-POINT COMPUTATION - SAVE EPS, FIRST - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT LA05AD - IF (FIRST) THEN - EPS = 2.0D0 * D1MACH(4) - ENDIF - FIRST = .FALSE. -C -C SET THE OUTPUT UNIT NUMBER FOR THE ERROR PROCESSOR. -C THE USAGE OF THIS ERROR PROCESSOR IS DOCUMENTED IN THE -C SANDIA LABS. TECH. REPT. SAND78-1189, BY R E JONES. - CALL XSETUN(LP) - IF (U.GT.1.0D0) U = 1.0D0 - IF (U.LT.EPS) U = EPS - IF (N.LT.1) GO TO 670 - G = 0. - DO 50 I=1,N - W(I) = 0. - DO 40 J=1,5 - IW(I,J) = 0 - 40 CONTINUE - 50 CONTINUE -C -C FLUSH OUT SMALL ENTRIES, COUNT ELEMENTS IN ROWS AND COLUMNS - L = 1 - LENU = NZ - DO 80 IDUMMY=1,NZ - IF (L.GT.LENU) GO TO 90 - DO 60 K=L,LENU - IF (ABS(A(K)).LE.SMALL) GO TO 70 - I = IND(K,1) - J = IND(K,2) - G = MAX(ABS(A(K)),G) - IF (I.LT.1 .OR. I.GT.N) GO TO 680 - IF (J.LT.1 .OR. J.GT.N) GO TO 680 - IW(I,1) = IW(I,1) + 1 - IW(J,2) = IW(J,2) + 1 - 60 CONTINUE - GO TO 90 - 70 L = K - A(L) = A(LENU) - IND(L,1) = IND(LENU,1) - IND(L,2) = IND(LENU,2) - LENU = LENU - 1 - 80 CONTINUE -C - 90 LENL = 0 - LROW = LENU - LCOL = LROW -C MCP IS THE MAXIMUM NUMBER OF COMPRESSES PERMITTED BEFORE AN -C ERROR RETURN RESULTS. - MCP = MAX(N/10,20) - NCP = 0 -C CHECK FOR NULL ROW OR COLUMN AND INITIALIZE IP(I,2) TO POINT -C JUST BEYOND WHERE THE LAST COMPONENT OF COLUMN I OF A WILL -C BE STORED. - K = 1 - DO 110 IR=1,N - K = K + IW(IR,2) - IP(IR,2) = K - DO 100 L=1,2 - IF (IW(IR,L).LE.0) GO TO 700 - 100 CONTINUE - 110 CONTINUE -C REORDER BY ROWS -C CHECK FOR DOUBLE ENTRIES WHILE USING THE NEWLY CONSTRUCTED -C ROW FILE TO CONSTRUCT THE COLUMN FILE. NOTE THAT BY PUTTING -C THE ENTRIES IN BACKWARDS AND DECREASING IP(J,2) EACH TIME IT -C IS USED WE AUTOMATICALLY LEAVE IT POINTING TO THE FIRST ELEMENT. - CALL MC20AD(N, LENU, A, IND(1,2), IP, IND(1,1), 0) - KL = LENU - DO 130 II=1,N - IR = N + 1 - II - KP = IP(IR,1) - DO 120 K=KP,KL - J = IND(K,2) - IF (IW(J,5).EQ.IR) GO TO 660 - IW(J,5) = IR - KR = IP(J,2) - 1 - IP(J,2) = KR - IND(KR,1) = IR - 120 CONTINUE - KL = KP - 1 - 130 CONTINUE -C -C SET UP LINKED LISTS OF ROWS AND COLS WITH EQUAL NUMBERS OF NON-ZEROS. - DO 150 L=1,2 - DO 140 I=1,N - NZ = IW(I,L) - IN = IW(NZ,L+2) - IW(NZ,L+2) = I - IW(I,L+6) = IN - IW(I,L+4) = 0 - IF (IN.NE.0) IW(IN,L+4) = I - 140 CONTINUE - 150 CONTINUE -C -C -C START OF MAIN ELIMINATION LOOP. - DO 590 IPV=1,N -C FIND PIVOT. JCOST IS MARKOWITZ COST OF CHEAPEST PIVOT FOUND SO FAR, -C WHICH IS IN ROW IPP AND COLUMN JP. - JCOST = N*N -C LOOP ON LENGTH OF COLUMN TO BE SEARCHED - DO 240 NZ=1,N - IF (JCOST.LE.(NZ-1)**2) GO TO 250 - J = IW(NZ,4) -C SEARCH COLUMNS WITH NZ NON-ZEROS. - DO 190 IDUMMY=1,N - IF (J.LE.0) GO TO 200 - KP = IP(J,2) - KL = KP + IW(J,2) - 1 - DO 180 K=KP,KL - I = IND(K,1) - KCOST = (NZ-1)*(IW(I,1)-1) - IF (KCOST.GE.JCOST) GO TO 180 - IF (NZ.EQ.1) GO TO 170 -C FIND LARGEST ELEMENT IN ROW OF POTENTIAL PIVOT. - AMAX = 0. - K1 = IP(I,1) - K2 = IW(I,1) + K1 - 1 - DO 160 KK=K1,K2 - AMAX = MAX(AMAX,ABS(A(KK))) - IF (IND(KK,2).EQ.J) KJ = KK - 160 CONTINUE -C PERFORM STABILITY TEST. - IF (ABS(A(KJ)).LT.AMAX*U) GO TO 180 - 170 JCOST = KCOST - IPP = I - JP = J - IF (JCOST.LE.(NZ-1)**2) GO TO 250 - 180 CONTINUE - J = IW(J,8) - 190 CONTINUE -C SEARCH ROWS WITH NZ NON-ZEROS. - 200 I = IW(NZ,3) - DO 230 IDUMMY=1,N - IF (I.LE.0) GO TO 240 - AMAX = 0. - KP = IP(I,1) - KL = KP + IW(I,1) - 1 -C FIND LARGEST ELEMENT IN THE ROW - DO 210 K=KP,KL - AMAX = MAX(ABS(A(K)),AMAX) - 210 CONTINUE - AU = AMAX*U - DO 220 K=KP,KL -C PERFORM STABILITY TEST. - IF (ABS(A(K)).LT.AU) GO TO 220 - J = IND(K,2) - KCOST = (NZ-1)*(IW(J,2)-1) - IF (KCOST.GE.JCOST) GO TO 220 - JCOST = KCOST - IPP = I - JP = J - IF (JCOST.LE.(NZ-1)**2) GO TO 250 - 220 CONTINUE - I = IW(I,7) - 230 CONTINUE - 240 CONTINUE -C -C PIVOT FOUND. -C REMOVE ROWS AND COLUMNS INVOLVED IN ELIMINATION FROM ORDERING VECTORS. - 250 KP = IP(JP,2) - KL = IW(JP,2) + KP - 1 - DO 290 L=1,2 - DO 280 K=KP,KL - I = IND(K,L) - IL = IW(I,L+4) - IN = IW(I,L+6) - IF (IL.EQ.0) GO TO 260 - IW(IL,L+6) = IN - GO TO 270 - 260 NZ = IW(I,L) - IW(NZ,L+2) = IN - 270 IF (IN.GT.0) IW(IN,L+4) = IL - 280 CONTINUE - KP = IP(IPP,1) - KL = KP + IW(IPP,1) - 1 - 290 CONTINUE -C STORE PIVOT - IW(IPP,5) = -IPV - IW(JP,6) = -IPV -C ELIMINATE PIVOTAL ROW FROM COLUMN FILE AND FIND PIVOT IN ROW FILE. - DO 320 K=KP,KL - J = IND(K,2) - KPC = IP(J,2) - IW(J,2) = IW(J,2) - 1 - KLC = KPC + IW(J,2) - DO 300 KC=KPC,KLC - IF (IPP.EQ.IND(KC,1)) GO TO 310 - 300 CONTINUE - 310 IND(KC,1) = IND(KLC,1) - IND(KLC,1) = 0 - IF (J.EQ.JP) KR = K - 320 CONTINUE -C BRING PIVOT TO FRONT OF PIVOTAL ROW. - AU = A(KR) - A(KR) = A(KP) - A(KP) = AU - IND(KR,2) = IND(KP,2) - IND(KP,2) = JP -C -C PERFORM ELIMINATION ITSELF, LOOPING ON NON-ZEROS IN PIVOT COLUMN. - NZC = IW(JP,2) - IF (NZC.EQ.0) GO TO 550 - DO 540 NC=1,NZC - KC = IP(JP,2) + NC - 1 - IR = IND(KC,1) -C SEARCH NON-PIVOT ROW FOR ELEMENT TO BE ELIMINATED. - KR = IP(IR,1) - KRL = KR + IW(IR,1) - 1 - DO 330 KNP=KR,KRL - IF (JP.EQ.IND(KNP,2)) GO TO 340 - 330 CONTINUE -C BRING ELEMENT TO BE ELIMINATED TO FRONT OF ITS ROW. - 340 AM = A(KNP) - A(KNP) = A(KR) - A(KR) = AM - IND(KNP,2) = IND(KR,2) - IND(KR,2) = JP - AM = -A(KR)/A(KP) -C COMPRESS ROW FILE UNLESS IT IS CERTAIN THAT THERE IS ROOM FOR NEW ROW. - IF (LROW+IW(IR,1)+IW(IPP,1)+LENL.LE.IA) GO TO 350 - IF (NCP.GE.MCP .OR. LENU+IW(IR,1)+IW(IPP,1)+LENL.GT.IA) GO - * TO 710 - CALL LA05ED(A, IND(1,2), IP, N, IW, IA, .TRUE.) - KP = IP(IPP,1) - KR = IP(IR,1) - 350 KRL = KR + IW(IR,1) - 1 - KQ = KP + 1 - KPL = KP + IW(IPP,1) - 1 -C PLACE PIVOT ROW (EXCLUDING PIVOT ITSELF) IN W. - IF (KQ.GT.KPL) GO TO 370 - DO 360 K=KQ,KPL - J = IND(K,2) - W(J) = A(K) - 360 CONTINUE - 370 IP(IR,1) = LROW + 1 -C -C TRANSFER MODIFIED ELEMENTS. - IND(KR,2) = 0 - KR = KR + 1 - IF (KR.GT.KRL) GO TO 430 - DO 420 KS=KR,KRL - J = IND(KS,2) - AU = A(KS) + AM*W(J) - IND(KS,2) = 0 -C IF ELEMENT IS VERY SMALL REMOVE IT FROM U. - IF (ABS(AU).LE.SMALL) GO TO 380 - G = MAX(G,ABS(AU)) - LROW = LROW + 1 - A(LROW) = AU - IND(LROW,2) = J - GO TO 410 - 380 LENU = LENU - 1 -C REMOVE ELEMENT FROM COL FILE. - K = IP(J,2) - KL = K + IW(J,2) - 1 - IW(J,2) = KL - K - DO 390 KK=K,KL - IF (IND(KK,1).EQ.IR) GO TO 400 - 390 CONTINUE - 400 IND(KK,1) = IND(KL,1) - IND(KL,1) = 0 - 410 W(J) = 0. - 420 CONTINUE -C -C SCAN PIVOT ROW FOR FILLS. - 430 IF (KQ.GT.KPL) GO TO 520 - DO 510 KS=KQ,KPL - J = IND(KS,2) - AU = AM*W(J) - IF (ABS(AU).LE.SMALL) GO TO 500 - LROW = LROW + 1 - A(LROW) = AU - IND(LROW,2) = J - LENU = LENU + 1 -C -C CREATE FILL IN COLUMN FILE. - NZ = IW(J,2) - K = IP(J,2) - KL = K + NZ - 1 - IF (NZ .EQ. 0) GO TO 460 -C IF POSSIBLE PLACE NEW ELEMENT AT END OF PRESENT ENTRY. - IF (KL.NE.LCOL) GO TO 440 - IF (LCOL+LENL.GE.IA) GO TO 460 - LCOL = LCOL + 1 - GO TO 450 - 440 IF (IND(KL+1,1).NE.0) GO TO 460 - 450 IND(KL+1,1) = IR - GO TO 490 -C NEW ENTRY HAS TO BE CREATED. - 460 IF (LCOL+LENL+NZ+1.LT.IA) GO TO 470 -C COMPRESS COLUMN FILE IF THERE IS NOT ROOM FOR NEW ENTRY. - IF (NCP.GE.MCP .OR. LENU+LENL+NZ+1.GE.IA) GO TO 710 - CALL LA05ED(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.) - K = IP(J,2) - KL = K + NZ - 1 -C TRANSFER OLD ENTRY INTO NEW. - 470 IP(J,2) = LCOL + 1 - IF (KL .LT. K) GO TO 485 - DO 480 KK=K,KL - LCOL = LCOL + 1 - IND(LCOL,1) = IND(KK,1) - IND(KK,1) = 0 - 480 CONTINUE - 485 CONTINUE -C ADD NEW ELEMENT. - LCOL = LCOL + 1 - IND(LCOL,1) = IR - 490 G = MAX(G,ABS(AU)) - IW(J,2) = NZ + 1 - 500 W(J) = 0. - 510 CONTINUE - 520 IW(IR,1) = LROW + 1 - IP(IR,1) -C -C STORE MULTIPLIER - IF (LENL+LCOL+1.LE.IA) GO TO 530 -C COMPRESS COL FILE IF NECESSARY. - IF (NCP.GE.MCP) GO TO 710 - CALL LA05ED(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.) - 530 K = IA - LENL - LENL = LENL + 1 - A(K) = AM - IND(K,1) = IPP - IND(K,2) = IR - LENU = LENU - 1 - 540 CONTINUE -C -C INSERT ROWS AND COLUMNS INVOLVED IN ELIMINATION IN LINKED LISTS -C OF EQUAL NUMBERS OF NON-ZEROS. - 550 K1 = IP(JP,2) - K2 = IW(JP,2) + K1 - 1 - IW(JP,2) = 0 - DO 580 L=1,2 - IF (K2.LT.K1) GO TO 570 - DO 560 K=K1,K2 - IR = IND(K,L) - IF (L.EQ.1) IND(K,L) = 0 - NZ = IW(IR,L) - IF (NZ.LE.0) GO TO 720 - IN = IW(NZ,L+2) - IW(IR,L+6) = IN - IW(IR,L+4) = 0 - IW(NZ,L+2) = IR - IF (IN.NE.0) IW(IN,L+4) = IR - 560 CONTINUE - 570 K1 = IP(IPP,1) + 1 - K2 = IW(IPP,1) + K1 - 2 - 580 CONTINUE - 590 CONTINUE -C -C RESET COLUMN FILE TO REFER TO U AND STORE ROW/COL NUMBERS IN -C PIVOTAL ORDER IN IW(.,3),IW(.,4) - DO 600 I=1,N - J = -IW(I,5) - IW(J,3) = I - J = -IW(I,6) - IW(J,4) = I - IW(I,2) = 0 - 600 CONTINUE - DO 620 I=1,N - KP = IP(I,1) - KL = IW(I,1) + KP - 1 - DO 610 K=KP,KL - J = IND(K,2) - IW(J,2) = IW(J,2) + 1 - 610 CONTINUE - 620 CONTINUE - K = 1 - DO 630 I=1,N - K = K + IW(I,2) - IP(I,2) = K - 630 CONTINUE - LCOL = K - 1 - DO 650 II=1,N - I = IW(II,3) - KP = IP(I,1) - KL = IW(I,1) + KP - 1 - DO 640 K=KP,KL - J = IND(K,2) - KN = IP(J,2) - 1 - IP(J,2) = KN - IND(KN,1) = I - 640 CONTINUE - 650 CONTINUE - RETURN -C -C THE FOLLOWING INSTRUCTIONS IMPLEMENT THE FAILURE EXITS. -C - 660 IF (LP.GT.0) THEN - WRITE (XERN1, '(I8)') IR - WRITE (XERN2, '(I8)') J - CALL XERMSG ('SLATEC', 'LA05AD', 'MORE THAN ONE MATRIX ' // - * 'ENTRY. HERE ROW = ' // XERN1 // ' AND COL = ' // XERN2, - * -4, 1) - ENDIF - G = -4. - RETURN -C - 670 IF (LP.GT.0) CALL XERMSG ('SLATEC', 'LA05AD', - * 'THE ORDER OF THE SYSTEM, N, IS NOT POSITIVE.', -1, 1) - G = -1.0D0 - RETURN -C - 680 IF (LP.GT.0) THEN - WRITE (XERN0, '(I8)') K - WRITE (XERN1, '(I8)') I - WRITE (XERN2, '(I8)') J - CALL XERMSG ('SLATEC', 'LA05AD', 'ELEMENT K = ' // XERN0 // - * ' IS OUT OF BOUNDS.$$HERE ROW = ' // XERN1 // - * ' AND COL = ' // XERN2, -3, 1) - ENDIF - G = -3. - RETURN -C - 700 IF (LP.GT.0) THEN - WRITE (XERN1, '(I8)') L - CALL XERMSG ('SLATEC', 'LA05AD', 'ROW OR COLUMN HAS NO ' // - * 'ELEMENTS. HERE INDEX = ' // XERN1, -2, 1) - ENDIF - G = -2. - RETURN -C - 710 IF (LP.GT.0) CALL XERMSG ('SLATEC', 'LA05AD', - * 'LENGTHS OF ARRAYS A(*) AND IND(*,2) ARE TOO SMALL.', -7, 1) - G = -7. - RETURN -C - 720 IPV = IPV + 1 - IW(IPV,1) = IR - DO 730 I=1,N - II = -IW(I,L+4) - IF (II.GT.0) IW(II,1) = I - 730 CONTINUE -C - IF (LP.GT.0) THEN - XERN1 = 'ROWS' - IF (L.EQ.2) XERN1 = 'COLUMNS' - CALL XERMSG ('SLATEC', 'LA05AD', 'DEPENDANT ' // XERN1, -5, 1) -C - 740 WRITE (XERN1, '(I8)') IW(I,1) - XERN2 = ' ' - IF (I+1.LE.IPV) WRITE (XERN2, '(I8)') IW(I+1,1) - CALL XERMSG ('SLATEC', 'LA05AD', - * 'DEPENDENT VECTOR INDICES ARE ' // XERN1 // ' AND ' // - * XERN2, -5, 1) - I = I + 2 - IF (I.LE.IPV) GO TO 740 - ENDIF - G = -5. - RETURN - END diff --git a/slatec/la05as.f b/slatec/la05as.f deleted file mode 100644 index d4e136d..0000000 --- a/slatec/la05as.f +++ /dev/null @@ -1,513 +0,0 @@ -*DECK LA05AS - SUBROUTINE LA05AS (A, IND, NZ, IA, N, IP, IW, W, G, U) -C***BEGIN PROLOGUE LA05AS -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (LA05AS-S, LA05AD-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM -C FROM THE C. 1979 AERE HARWELL LIBRARY. THE NAME OF THE -C CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING -C THE FINAL LETTER =S= IN THE NAMES USED HERE. -C REVISIONS MADE BY R J HANSON, SNLA, AUGUST, 1979. -C REVISED SEP. 13, 1979. -C -C ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES -C IN THE PACKAGE GIVEN HERE. ANY PRIMARY USAGE OF THE HARWELL -C SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN -C THE USER AND AERE-UK. ANY USAGE OF THE SANDIA WRITTEN CODES -C SPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED. -C -C IP(I,1),IP(I,2) POINT TO THE START OF ROW/COL I. -C IW(I,1),IW(I,2) HOLD THE NUMBER OF NON-ZEROS IN ROW/COL I. -C DURING THE MAIN BODY OF THIS SUBROUTINE THE VECTORS IW(.,3),IW(.,5), -C IW(.,7) ARE USED TO HOLD DOUBLY LINKED LISTS OF ROWS THAT HAVE -C NOT BEEN PIVOTAL AND HAVE EQUAL NUMBERS OF NON-ZEROS. -C IW(.,4),IW(.,6),IW(.,8) HOLD SIMILAR LISTS FOR THE COLUMNS. -C IW(I,3),IW(I,4) HOLD FIRST ROW/COLUMN TO HAVE I NON-ZEROS -C OR ZERO IF THERE ARE NONE. -C IW(I,5), IW(I,6) HOLD ROW/COL NUMBER OF ROW/COL PRIOR TO ROW/COL I -C IN ITS LIST, OR ZERO IF NONE. -C IW(I,7), IW(I,8) HOLD ROW/COL NUMBER OF ROW/COL AFTER ROW/COL I -C IN ITS LIST, OR ZERO IF NONE. -C FOR ROWS/COLS THAT HAVE BEEN PIVOTAL IW(I,5),IW(I,6) HOLD NEGATION OF -C POSITION OF ROW/COL I IN THE PIVOTAL ORDERING. -C -C***SEE ALSO SPLP -C***ROUTINES CALLED LA05ES, MC20AS, R1MACH, XERMSG, XSETUN -C***COMMON BLOCKS LA05DS -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890605 Corrected references to XERRWV. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900402 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C***END PROLOGUE LA05AS - INTEGER IP(N,2) - INTEGER IND(IA,2), IW(N,8) - REAL A(*), AMAX, AU, AM, G, U, SMALL, W(*) - LOGICAL FIRST - CHARACTER*8 XERN0, XERN1, XERN2 -C - COMMON /LA05DS/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL -C EPS IS THE RELATIVE ACCURACY OF FLOATING-POINT COMPUTATION - SAVE EPS, FIRST - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT LA05AS - IF (FIRST) THEN - EPS = 2.0E0 * R1MACH(4) - ENDIF - FIRST = .FALSE. -C -C SET THE OUTPUT UNIT NUMBER FOR THE ERROR PROCESSOR. -C THE USAGE OF THIS ERROR PROCESSOR IS DOCUMENTED IN THE -C SANDIA LABS. TECH. REPT. SAND78-1189, BY R E JONES. - CALL XSETUN(LP) - IF (U.GT.1.0E0) U = 1.0E0 - IF (U.LT.EPS) U = EPS - IF (N.LT.1) GO TO 670 - G = 0. - DO 50 I=1,N - W(I) = 0. - DO 40 J=1,5 - IW(I,J) = 0 - 40 CONTINUE - 50 CONTINUE -C -C FLUSH OUT SMALL ENTRIES, COUNT ELEMENTS IN ROWS AND COLUMNS - L = 1 - LENU = NZ - DO 80 IDUMMY=1,NZ - IF (L.GT.LENU) GO TO 90 - DO 60 K=L,LENU - IF (ABS(A(K)).LE.SMALL) GO TO 70 - I = IND(K,1) - J = IND(K,2) - G = MAX(ABS(A(K)),G) - IF (I.LT.1 .OR. I.GT.N) GO TO 680 - IF (J.LT.1 .OR. J.GT.N) GO TO 680 - IW(I,1) = IW(I,1) + 1 - IW(J,2) = IW(J,2) + 1 - 60 CONTINUE - GO TO 90 - 70 L = K - A(L) = A(LENU) - IND(L,1) = IND(LENU,1) - IND(L,2) = IND(LENU,2) - LENU = LENU - 1 - 80 CONTINUE -C - 90 LENL = 0 - LROW = LENU - LCOL = LROW -C MCP IS THE MAXIMUM NUMBER OF COMPRESSES PERMITTED BEFORE AN -C ERROR RETURN RESULTS. - MCP = MAX(N/10,20) - NCP = 0 -C CHECK FOR NULL ROW OR COLUMN AND INITIALIZE IP(I,2) TO POINT -C JUST BEYOND WHERE THE LAST COMPONENT OF COLUMN I OF A WILL -C BE STORED. - K = 1 - DO 110 IR=1,N - K = K + IW(IR,2) - IP(IR,2) = K - DO 100 L=1,2 - IF (IW(IR,L).LE.0) GO TO 700 - 100 CONTINUE - 110 CONTINUE -C REORDER BY ROWS -C CHECK FOR DOUBLE ENTRIES WHILE USING THE NEWLY CONSTRUCTED -C ROW FILE TO CONSTRUCT THE COLUMN FILE. NOTE THAT BY PUTTING -C THE ENTRIES IN BACKWARDS AND DECREASING IP(J,2) EACH TIME IT -C IS USED WE AUTOMATICALLY LEAVE IT POINTING TO THE FIRST ELEMENT. - CALL MC20AS(N, LENU, A, IND(1,2), IP, IND(1,1), 0) - KL = LENU - DO 130 II=1,N - IR = N + 1 - II - KP = IP(IR,1) - DO 120 K=KP,KL - J = IND(K,2) - IF (IW(J,5).EQ.IR) GO TO 660 - IW(J,5) = IR - KR = IP(J,2) - 1 - IP(J,2) = KR - IND(KR,1) = IR - 120 CONTINUE - KL = KP - 1 - 130 CONTINUE -C -C SET UP LINKED LISTS OF ROWS AND COLS WITH EQUAL NUMBERS OF NON-ZEROS. - DO 150 L=1,2 - DO 140 I=1,N - NZ = IW(I,L) - IN = IW(NZ,L+2) - IW(NZ,L+2) = I - IW(I,L+6) = IN - IW(I,L+4) = 0 - IF (IN.NE.0) IW(IN,L+4) = I - 140 CONTINUE - 150 CONTINUE -C -C -C START OF MAIN ELIMINATION LOOP. - DO 590 IPV=1,N -C FIND PIVOT. JCOST IS MARKOWITZ COST OF CHEAPEST PIVOT FOUND SO FAR, -C WHICH IS IN ROW IPP AND COLUMN JP. - JCOST = N*N -C LOOP ON LENGTH OF COLUMN TO BE SEARCHED - DO 240 NZ=1,N - IF (JCOST.LE.(NZ-1)**2) GO TO 250 - J = IW(NZ,4) -C SEARCH COLUMNS WITH NZ NON-ZEROS. - DO 190 IDUMMY=1,N - IF (J.LE.0) GO TO 200 - KP = IP(J,2) - KL = KP + IW(J,2) - 1 - DO 180 K=KP,KL - I = IND(K,1) - KCOST = (NZ-1)*(IW(I,1)-1) - IF (KCOST.GE.JCOST) GO TO 180 - IF (NZ.EQ.1) GO TO 170 -C FIND LARGEST ELEMENT IN ROW OF POTENTIAL PIVOT. - AMAX = 0. - K1 = IP(I,1) - K2 = IW(I,1) + K1 - 1 - DO 160 KK=K1,K2 - AMAX = MAX(AMAX,ABS(A(KK))) - IF (IND(KK,2).EQ.J) KJ = KK - 160 CONTINUE -C PERFORM STABILITY TEST. - IF (ABS(A(KJ)).LT.AMAX*U) GO TO 180 - 170 JCOST = KCOST - IPP = I - JP = J - IF (JCOST.LE.(NZ-1)**2) GO TO 250 - 180 CONTINUE - J = IW(J,8) - 190 CONTINUE -C SEARCH ROWS WITH NZ NON-ZEROS. - 200 I = IW(NZ,3) - DO 230 IDUMMY=1,N - IF (I.LE.0) GO TO 240 - AMAX = 0. - KP = IP(I,1) - KL = KP + IW(I,1) - 1 -C FIND LARGEST ELEMENT IN THE ROW - DO 210 K=KP,KL - AMAX = MAX(ABS(A(K)),AMAX) - 210 CONTINUE - AU = AMAX*U - DO 220 K=KP,KL -C PERFORM STABILITY TEST. - IF (ABS(A(K)).LT.AU) GO TO 220 - J = IND(K,2) - KCOST = (NZ-1)*(IW(J,2)-1) - IF (KCOST.GE.JCOST) GO TO 220 - JCOST = KCOST - IPP = I - JP = J - IF (JCOST.LE.(NZ-1)**2) GO TO 250 - 220 CONTINUE - I = IW(I,7) - 230 CONTINUE - 240 CONTINUE -C -C PIVOT FOUND. -C REMOVE ROWS AND COLUMNS INVOLVED IN ELIMINATION FROM ORDERING VECTORS. - 250 KP = IP(JP,2) - KL = IW(JP,2) + KP - 1 - DO 290 L=1,2 - DO 280 K=KP,KL - I = IND(K,L) - IL = IW(I,L+4) - IN = IW(I,L+6) - IF (IL.EQ.0) GO TO 260 - IW(IL,L+6) = IN - GO TO 270 - 260 NZ = IW(I,L) - IW(NZ,L+2) = IN - 270 IF (IN.GT.0) IW(IN,L+4) = IL - 280 CONTINUE - KP = IP(IPP,1) - KL = KP + IW(IPP,1) - 1 - 290 CONTINUE -C STORE PIVOT - IW(IPP,5) = -IPV - IW(JP,6) = -IPV -C ELIMINATE PIVOTAL ROW FROM COLUMN FILE AND FIND PIVOT IN ROW FILE. - DO 320 K=KP,KL - J = IND(K,2) - KPC = IP(J,2) - IW(J,2) = IW(J,2) - 1 - KLC = KPC + IW(J,2) - DO 300 KC=KPC,KLC - IF (IPP.EQ.IND(KC,1)) GO TO 310 - 300 CONTINUE - 310 IND(KC,1) = IND(KLC,1) - IND(KLC,1) = 0 - IF (J.EQ.JP) KR = K - 320 CONTINUE -C BRING PIVOT TO FRONT OF PIVOTAL ROW. - AU = A(KR) - A(KR) = A(KP) - A(KP) = AU - IND(KR,2) = IND(KP,2) - IND(KP,2) = JP -C -C PERFORM ELIMINATION ITSELF, LOOPING ON NON-ZEROS IN PIVOT COLUMN. - NZC = IW(JP,2) - IF (NZC.EQ.0) GO TO 550 - DO 540 NC=1,NZC - KC = IP(JP,2) + NC - 1 - IR = IND(KC,1) -C SEARCH NON-PIVOT ROW FOR ELEMENT TO BE ELIMINATED. - KR = IP(IR,1) - KRL = KR + IW(IR,1) - 1 - DO 330 KNP=KR,KRL - IF (JP.EQ.IND(KNP,2)) GO TO 340 - 330 CONTINUE -C BRING ELEMENT TO BE ELIMINATED TO FRONT OF ITS ROW. - 340 AM = A(KNP) - A(KNP) = A(KR) - A(KR) = AM - IND(KNP,2) = IND(KR,2) - IND(KR,2) = JP - AM = -A(KR)/A(KP) -C COMPRESS ROW FILE UNLESS IT IS CERTAIN THAT THERE IS ROOM FOR NEW ROW. - IF (LROW+IW(IR,1)+IW(IPP,1)+LENL.LE.IA) GO TO 350 - IF (NCP.GE.MCP .OR. LENU+IW(IR,1)+IW(IPP,1)+LENL.GT.IA) GO - * TO 710 - CALL LA05ES(A, IND(1,2), IP, N, IW, IA, .TRUE.) - KP = IP(IPP,1) - KR = IP(IR,1) - 350 KRL = KR + IW(IR,1) - 1 - KQ = KP + 1 - KPL = KP + IW(IPP,1) - 1 -C PLACE PIVOT ROW (EXCLUDING PIVOT ITSELF) IN W. - IF (KQ.GT.KPL) GO TO 370 - DO 360 K=KQ,KPL - J = IND(K,2) - W(J) = A(K) - 360 CONTINUE - 370 IP(IR,1) = LROW + 1 -C -C TRANSFER MODIFIED ELEMENTS. - IND(KR,2) = 0 - KR = KR + 1 - IF (KR.GT.KRL) GO TO 430 - DO 420 KS=KR,KRL - J = IND(KS,2) - AU = A(KS) + AM*W(J) - IND(KS,2) = 0 -C IF ELEMENT IS VERY SMALL REMOVE IT FROM U. - IF (ABS(AU).LE.SMALL) GO TO 380 - G = MAX(G,ABS(AU)) - LROW = LROW + 1 - A(LROW) = AU - IND(LROW,2) = J - GO TO 410 - 380 LENU = LENU - 1 -C REMOVE ELEMENT FROM COL FILE. - K = IP(J,2) - KL = K + IW(J,2) - 1 - IW(J,2) = KL - K - DO 390 KK=K,KL - IF (IND(KK,1).EQ.IR) GO TO 400 - 390 CONTINUE - 400 IND(KK,1) = IND(KL,1) - IND(KL,1) = 0 - 410 W(J) = 0. - 420 CONTINUE -C -C SCAN PIVOT ROW FOR FILLS. - 430 IF (KQ.GT.KPL) GO TO 520 - DO 510 KS=KQ,KPL - J = IND(KS,2) - AU = AM*W(J) - IF (ABS(AU).LE.SMALL) GO TO 500 - LROW = LROW + 1 - A(LROW) = AU - IND(LROW,2) = J - LENU = LENU + 1 -C -C CREATE FILL IN COLUMN FILE. - NZ = IW(J,2) - K = IP(J,2) - KL = K + NZ - 1 - IF (NZ .EQ. 0) GO TO 460 -C IF POSSIBLE PLACE NEW ELEMENT AT END OF PRESENT ENTRY. - IF (KL.NE.LCOL) GO TO 440 - IF (LCOL+LENL.GE.IA) GO TO 460 - LCOL = LCOL + 1 - GO TO 450 - 440 IF (IND(KL+1,1).NE.0) GO TO 460 - 450 IND(KL+1,1) = IR - GO TO 490 -C NEW ENTRY HAS TO BE CREATED. - 460 IF (LCOL+LENL+NZ+1.LT.IA) GO TO 470 -C COMPRESS COLUMN FILE IF THERE IS NOT ROOM FOR NEW ENTRY. - IF (NCP.GE.MCP .OR. LENU+LENL+NZ+1.GE.IA) GO TO 710 - CALL LA05ES(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.) - K = IP(J,2) - KL = K + NZ - 1 -C TRANSFER OLD ENTRY INTO NEW. - 470 IP(J,2) = LCOL + 1 - IF (KL .LT. K) GO TO 485 - DO 480 KK=K,KL - LCOL = LCOL + 1 - IND(LCOL,1) = IND(KK,1) - IND(KK,1) = 0 - 480 CONTINUE - 485 CONTINUE -C ADD NEW ELEMENT. - LCOL = LCOL + 1 - IND(LCOL,1) = IR - 490 G = MAX(G,ABS(AU)) - IW(J,2) = NZ + 1 - 500 W(J) = 0. - 510 CONTINUE - 520 IW(IR,1) = LROW + 1 - IP(IR,1) -C -C STORE MULTIPLIER - IF (LENL+LCOL+1.LE.IA) GO TO 530 -C COMPRESS COL FILE IF NECESSARY. - IF (NCP.GE.MCP) GO TO 710 - CALL LA05ES(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.) - 530 K = IA - LENL - LENL = LENL + 1 - A(K) = AM - IND(K,1) = IPP - IND(K,2) = IR - LENU = LENU - 1 - 540 CONTINUE -C -C INSERT ROWS AND COLUMNS INVOLVED IN ELIMINATION IN LINKED LISTS -C OF EQUAL NUMBERS OF NON-ZEROS. - 550 K1 = IP(JP,2) - K2 = IW(JP,2) + K1 - 1 - IW(JP,2) = 0 - DO 580 L=1,2 - IF (K2.LT.K1) GO TO 570 - DO 560 K=K1,K2 - IR = IND(K,L) - IF (L.EQ.1) IND(K,L) = 0 - NZ = IW(IR,L) - IF (NZ.LE.0) GO TO 720 - IN = IW(NZ,L+2) - IW(IR,L+6) = IN - IW(IR,L+4) = 0 - IW(NZ,L+2) = IR - IF (IN.NE.0) IW(IN,L+4) = IR - 560 CONTINUE - 570 K1 = IP(IPP,1) + 1 - K2 = IW(IPP,1) + K1 - 2 - 580 CONTINUE - 590 CONTINUE -C -C RESET COLUMN FILE TO REFER TO U AND STORE ROW/COL NUMBERS IN -C PIVOTAL ORDER IN IW(.,3),IW(.,4) - DO 600 I=1,N - J = -IW(I,5) - IW(J,3) = I - J = -IW(I,6) - IW(J,4) = I - IW(I,2) = 0 - 600 CONTINUE - DO 620 I=1,N - KP = IP(I,1) - KL = IW(I,1) + KP - 1 - DO 610 K=KP,KL - J = IND(K,2) - IW(J,2) = IW(J,2) + 1 - 610 CONTINUE - 620 CONTINUE - K = 1 - DO 630 I=1,N - K = K + IW(I,2) - IP(I,2) = K - 630 CONTINUE - LCOL = K - 1 - DO 650 II=1,N - I = IW(II,3) - KP = IP(I,1) - KL = IW(I,1) + KP - 1 - DO 640 K=KP,KL - J = IND(K,2) - KN = IP(J,2) - 1 - IP(J,2) = KN - IND(KN,1) = I - 640 CONTINUE - 650 CONTINUE - RETURN -C -C THE FOLLOWING INSTRUCTIONS IMPLEMENT THE FAILURE EXITS. -C - 660 IF (LP.GT.0) THEN - WRITE (XERN1, '(I8)') IR - WRITE (XERN2, '(I8)') J - CALL XERMSG ('SLATEC', 'LA05AS', 'MORE THAN ONE MATRIX ' // - * 'ENTRY. HERE ROW = ' // XERN1 // ' AND COL = ' // XERN2, - * -4, 1) - ENDIF - G = -4. - RETURN -C - 670 IF (LP.GT.0) CALL XERMSG ('SLATEC', 'LA05AS', - * 'THE ORDER OF THE SYSTEM, N, IS NOT POSITIVE.', -1, 1) - G = -1.0E0 - RETURN -C - 680 IF (LP.GT.0) THEN - WRITE (XERN0, '(I8)') K - WRITE (XERN1, '(I8)') I - WRITE (XERN2, '(I8)') J - CALL XERMSG ('SLATEC', 'LA05AS', 'ELEMENT K = ' // XERN0 // - * ' IS OUT OF BOUNDS.$$HERE ROW = ' // XERN1 // - * ' AND COL = ' // XERN2, -3, 1) - ENDIF - G = -3. - RETURN -C - 700 IF (LP.GT.0) THEN - WRITE (XERN1, '(I8)') L - CALL XERMSG ('SLATEC', 'LA05AS', 'ROW OR COLUMN HAS NO ' // - * 'ELEMENTS. HERE INDEX = ' // XERN1, -2, 1) - ENDIF - G = -2. - RETURN -C - 710 IF (LP.GT.0) CALL XERMSG ('SLATEC', 'LA05AS', - * 'LENGTHS OF ARRAYS A(*) AND IND(*,2) ARE TOO SMALL.', -7, 1) - G = -7. - RETURN -C - 720 IPV = IPV + 1 - IW(IPV,1) = IR - DO 730 I=1,N - II = -IW(I,L+4) - IF (II.GT.0) IW(II,1) = I - 730 CONTINUE -C - IF (LP.GT.0) THEN - XERN1 = 'ROWS' - IF (L.EQ.2) XERN1 = 'COLUMNS' - CALL XERMSG ('SLATEC', 'LA05AS', 'DEPENDANT ' // XERN1, -5, 1) -C - 740 WRITE (XERN1, '(I8)') IW(I,1) - XERN2 = ' ' - IF (I+1.LE.IPV) WRITE (XERN2, '(I8)') IW(I+1,1) - CALL XERMSG ('SLATEC', 'LA05AS', - * 'DEPENDENT VECTOR INDICES ARE ' // XERN1 // ' AND ' // - * XERN2, -5, 1) - I = I + 2 - IF (I.LE.IPV) GO TO 740 - ENDIF - G = -5. - RETURN - END diff --git a/slatec/la05bd.f b/slatec/la05bd.f deleted file mode 100644 index c6ddf49..0000000 --- a/slatec/la05bd.f +++ /dev/null @@ -1,131 +0,0 @@ -*DECK LA05BD - SUBROUTINE LA05BD (A, IND, IA, N, IP, IW, W, G, B, TRANS) -C***BEGIN PROLOGUE LA05BD -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSPLP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (LA05BS-S, LA05BD-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM -C FROM THE C. 1979 AERE HARWELL LIBRARY. THE NAME OF THE -C CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING -C THE FINAL LETTER =D= IN THE NAMES USED HERE. -C REVISED SEP. 13, 1979. -C -C ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES -C IN THE PACKAGE GIVEN HERE. ANY PRIMARY USAGE OF THE HARWELL -C SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN -C THE USER AND AERE-UK. ANY USAGE OF THE SANDIA WRITTEN CODES -C DSPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED. -C -C IP(I,1),IP(I,2) POINT TO START OF ROW/COLUMN I OF U. -C IW(I,1),IW(I,2) ARE LENGTHS OF ROW/COL I OF U. -C IW(.,3),IW(.,4) HOLD ROW/COL NUMBERS IN PIVOTAL ORDER. -C -C***SEE ALSO DSPLP -C***ROUTINES CALLED XERMSG, XSETUN -C***COMMON BLOCKS LA05DD -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900402 Added TYPE section. (WRB) -C 920410 Corrected second dimension on IW declaration. (WRB) -C***END PROLOGUE LA05BD - DOUBLE PRECISION A(*), B(*), AM, W(*), G, SMALL - LOGICAL TRANS - INTEGER IND(IA,2), IW(N,8) - INTEGER IP(N,2) - COMMON /LA05DD/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL -C***FIRST EXECUTABLE STATEMENT LA05BD - IF (G.LT.0.D0) GO TO 130 - KLL = IA - LENL + 1 - IF (TRANS) GO TO 80 -C -C MULTIPLY VECTOR BY INVERSE OF L - IF (LENL.LE.0) GO TO 20 - L1 = IA + 1 - DO 10 KK=1,LENL - K = L1 - KK - I = IND(K,1) - IF (B(I).EQ.0.D0) GO TO 10 - J = IND(K,2) - B(J) = B(J) + A(K)*B(I) - 10 CONTINUE - 20 DO 30 I=1,N - W(I) = B(I) - B(I) = 0.D0 - 30 CONTINUE -C -C MULTIPLY VECTOR BY INVERSE OF U - N1 = N + 1 - DO 70 II=1,N - I = N1 - II - I = IW(I,3) - AM = W(I) - KP = IP(I,1) - IF (KP.GT.0) GO TO 50 - KP = -KP - IP(I,1) = KP - NZ = IW(I,1) - KL = KP - 1 + NZ - K2 = KP + 1 - DO 40 K=K2,KL - J = IND(K,2) - AM = AM - A(K)*B(J) - 40 CONTINUE - 50 IF (AM.EQ.0.) GO TO 70 - J = IND(KP,2) - B(J) = AM/A(KP) - KPC = IP(J,2) - KL = IW(J,2) + KPC - 1 - IF (KL.EQ.KPC) GO TO 70 - K2 = KPC + 1 - DO 60 K=K2,KL - I = IND(K,1) - IP(I,1) = -ABS(IP(I,1)) - 60 CONTINUE - 70 CONTINUE - GO TO 140 -C -C MULTIPLY VECTOR BY INVERSE OF TRANSPOSE OF U - 80 DO 90 I=1,N - W(I) = B(I) - B(I) = 0.D0 - 90 CONTINUE - DO 110 II=1,N - I = IW(II,4) - AM = W(I) - IF (AM.EQ.0.D0) GO TO 110 - J = IW(II,3) - KP = IP(J,1) - AM = AM/A(KP) - B(J) = AM - KL = IW(J,1) + KP - 1 - IF (KP.EQ.KL) GO TO 110 - K2 = KP + 1 - DO 100 K=K2,KL - I = IND(K,2) - W(I) = W(I) - AM*A(K) - 100 CONTINUE - 110 CONTINUE -C -C MULTIPLY VECTOR BY INVERSE OF TRANSPOSE OF L - IF (KLL.GT.IA) RETURN - DO 120 K=KLL,IA - J = IND(K,2) - IF (B(J).EQ.0.D0) GO TO 120 - I = IND(K,1) - B(I) = B(I) + A(K)*B(J) - 120 CONTINUE - GO TO 140 -C - 130 CALL XSETUN(LP) - IF (LP .GT. 0) CALL XERMSG ('SLATEC', 'LA05BD', - + 'EARLIER ENTRY GAVE ERROR RETURN.', -8, 2) - 140 RETURN - END diff --git a/slatec/la05bs.f b/slatec/la05bs.f deleted file mode 100644 index 79f1cbc..0000000 --- a/slatec/la05bs.f +++ /dev/null @@ -1,131 +0,0 @@ -*DECK LA05BS - SUBROUTINE LA05BS (A, IND, IA, N, IP, IW, W, G, B, TRANS) -C***BEGIN PROLOGUE LA05BS -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (LA05BS-S, LA05BD-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM -C FROM THE C. 1979 AERE HARWELL LIBRARY. THE NAME OF THE -C CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING -C THE FINAL LETTER =S= IN THE NAMES USED HERE. -C REVISED SEP. 13, 1979. -C -C ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES -C IN THE PACKAGE GIVEN HERE. ANY PRIMARY USAGE OF THE HARWELL -C SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN -C THE USER AND AERE-UK. ANY USAGE OF THE SANDIA WRITTEN CODES -C SPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED. -C -C IP(I,1),IP(I,2) POINT TO START OF ROW/COLUMN I OF U. -C IW(I,1),IW(I,2) ARE LENGTHS OF ROW/COL I OF U. -C IW(.,3),IW(.,4) HOLD ROW/COL NUMBERS IN PIVOTAL ORDER. -C -C***SEE ALSO SPLP -C***ROUTINES CALLED XERMSG, XSETUN -C***COMMON BLOCKS LA05DS -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900402 Added TYPE section. (WRB) -C 920410 Corrected second dimension on IW declaration. (WRB) -C***END PROLOGUE LA05BS - REAL A(IA), B(*), AM, W(*), G, SMALL - LOGICAL TRANS - INTEGER IND(IA,2), IW(N,8) - INTEGER IP(N,2) - COMMON /LA05DS/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL -C***FIRST EXECUTABLE STATEMENT LA05BS - IF (G.LT.0.) GO TO 130 - KLL = IA - LENL + 1 - IF (TRANS) GO TO 80 -C -C MULTIPLY VECTOR BY INVERSE OF L - IF (LENL.LE.0) GO TO 20 - L1 = IA + 1 - DO 10 KK=1,LENL - K = L1 - KK - I = IND(K,1) - IF (B(I).EQ.0.) GO TO 10 - J = IND(K,2) - B(J) = B(J) + A(K)*B(I) - 10 CONTINUE - 20 DO 30 I=1,N - W(I) = B(I) - B(I) = 0. - 30 CONTINUE -C -C MULTIPLY VECTOR BY INVERSE OF U - N1 = N + 1 - DO 70 II=1,N - I = N1 - II - I = IW(I,3) - AM = W(I) - KP = IP(I,1) - IF (KP.GT.0) GO TO 50 - KP = -KP - IP(I,1) = KP - NZ = IW(I,1) - KL = KP - 1 + NZ - K2 = KP + 1 - DO 40 K=K2,KL - J = IND(K,2) - AM = AM - A(K)*B(J) - 40 CONTINUE - 50 IF (AM.EQ.0.) GO TO 70 - J = IND(KP,2) - B(J) = AM/A(KP) - KPC = IP(J,2) - KL = IW(J,2) + KPC - 1 - IF (KL.EQ.KPC) GO TO 70 - K2 = KPC + 1 - DO 60 K=K2,KL - I = IND(K,1) - IP(I,1) = -ABS(IP(I,1)) - 60 CONTINUE - 70 CONTINUE - GO TO 140 -C -C MULTIPLY VECTOR BY INVERSE OF TRANSPOSE OF U - 80 DO 90 I=1,N - W(I) = B(I) - B(I) = 0. - 90 CONTINUE - DO 110 II=1,N - I = IW(II,4) - AM = W(I) - IF (AM.EQ.0.) GO TO 110 - J = IW(II,3) - KP = IP(J,1) - AM = AM/A(KP) - B(J) = AM - KL = IW(J,1) + KP - 1 - IF (KP.EQ.KL) GO TO 110 - K2 = KP + 1 - DO 100 K=K2,KL - I = IND(K,2) - W(I) = W(I) - AM*A(K) - 100 CONTINUE - 110 CONTINUE -C -C MULTIPLY VECTOR BY INVERSE OF TRANSPOSE OF L - IF (KLL.GT.IA) RETURN - DO 120 K=KLL,IA - J = IND(K,2) - IF (B(J).EQ.0.) GO TO 120 - I = IND(K,1) - B(I) = B(I) + A(K)*B(J) - 120 CONTINUE - GO TO 140 -C - 130 CALL XSETUN(LP) - IF (LP .GT. 0) CALL XERMSG ('SLATEC', 'LA05BS', - + 'EARLIER ENTRY GAVE ERROR RETURN.', -8, 2) - 140 RETURN - END diff --git a/slatec/la05cd.f b/slatec/la05cd.f deleted file mode 100644 index 85946ac..0000000 --- a/slatec/la05cd.f +++ /dev/null @@ -1,415 +0,0 @@ -*DECK LA05CD - SUBROUTINE LA05CD (A, IND, IA, N, IP, IW, W, G, U, MM) -C***BEGIN PROLOGUE LA05CD -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSPLP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (LA05CS-D, LA05CD-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM -C FROM THE C. 1979 AERE HARWELL LIBRARY. THE NAME OF THE -C CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING -C THE FINAL LETTER =D= IN THE NAMES USED HERE. -C REVISED SEP. 13, 1979. -C -C ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES -C IN THE PACKAGE GIVEN HERE. ANY PRIMARY USAGE OF THE HARWELL -C SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN -C THE USER AND AERE-UK. ANY USAGE OF THE SANDIA WRITTEN CODES -C DSPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED. -C -C***SEE ALSO DSPLP -C***ROUTINES CALLED LA05ED, XERMSG, XSETUN -C***COMMON BLOCKS LA05DD -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900402 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C 920410 Corrected second dimension on IW declaration. (WRB) -C 920422 Changed upper limit on DO from LAST to LAST-1. (WRB) -C***END PROLOGUE LA05CD - DOUBLE PRECISION A(*), G, U, AM, W(*), SMALL, AU - INTEGER IND(IA,2), IW(N,8) - INTEGER IP(N,2) - CHARACTER*8 XERN1 -C - COMMON /LA05DD/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL -C***FIRST EXECUTABLE STATEMENT LA05CD - CALL XSETUN(LP) - IF (G.LT.0.0D0) GO TO 620 - JM = MM -C MCP LIMITS THE VALUE OF NCP PERMITTED BEFORE AN ERROR RETURN RESULTS. - MCP = NCP + 20 -C REMOVE OLD COLUMN - LENU = LENU - IW(JM,2) - KP = IP(JM,2) - IM = IND(KP,1) - KL = KP + IW(JM,2) - 1 - IW(JM,2) = 0 - DO 30 K=KP,KL - I = IND(K,1) - IND(K,1) = 0 - KR = IP(I,1) - NZ = IW(I,1) - 1 - IW(I,1) = NZ - KRL = KR + NZ - DO 10 KM=KR,KRL - IF (IND(KM,2).EQ.JM) GO TO 20 - 10 CONTINUE - 20 A(KM) = A(KRL) - IND(KM,2) = IND(KRL,2) - IND(KRL,2) = 0 - 30 CONTINUE -C -C INSERT NEW COLUMN - DO 110 II=1,N - I = IW(II,3) - IF (I.EQ.IM) M = II - IF (ABS(W(I)).LE.SMALL) GO TO 100 - LENU = LENU + 1 - LAST = II - IF (LCOL+LENL.LT.IA) GO TO 40 -C COMPRESS COLUMN FILE IF NECESSARY. - IF (NCP.GE.MCP .OR. LENL+LENU.GE.IA) GO TO 610 - CALL LA05ED(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.) - 40 LCOL = LCOL + 1 - NZ = IW(JM,2) - IF (NZ.EQ.0) IP(JM,2) = LCOL - IW(JM,2) = NZ + 1 - IND(LCOL,1) = I - NZ = IW(I,1) - KPL = IP(I,1) + NZ - IF (KPL.GT.LROW) GO TO 50 - IF (IND(KPL,2).EQ.0) GO TO 90 -C NEW ENTRY HAS TO BE CREATED. - 50 IF (LENL+LROW+NZ.LT.IA) GO TO 60 - IF (NCP.GE.MCP .OR. LENL+LENU+NZ.GE.IA) GO TO 610 -C COMPRESS ROW FILE IF NECESSARY. - CALL LA05ED(A, IND(1,2), IP, N, IW, IA, .TRUE.) - 60 KP = IP(I,1) - IP(I,1) = LROW + 1 - IF (NZ.EQ.0) GO TO 80 - KPL = KP + NZ - 1 - DO 70 K=KP,KPL - LROW = LROW + 1 - A(LROW) = A(K) - IND(LROW,2) = IND(K,2) - IND(K,2) = 0 - 70 CONTINUE - 80 LROW = LROW + 1 - KPL = LROW -C PLACE NEW ELEMENT AT END OF ROW. - 90 IW(I,1) = NZ + 1 - A(KPL) = W(I) - IND(KPL,2) = JM - 100 W(I) = 0.0D0 - 110 CONTINUE - IF (IW(IM,1).EQ.0 .OR. IW(JM,2).EQ.0 .OR. M.GT.LAST) GO TO 590 -C -C FIND COLUMN SINGLETONS, OTHER THAN THE SPIKE. NON-SINGLETONS ARE -C MARKED WITH W(J)=1. ONLY IW(.,3) IS REVISED AND IW(.,4) IS USED -C FOR WORKSPACE. - INS = M - M1 = M - W(JM) = 1.0D0 - DO 140 II=M,LAST - I = IW(II,3) - J = IW(II,4) - IF (W(J).EQ.0.) GO TO 130 - KP = IP(I,1) - KL = KP + IW(I,1) - 1 - DO 120 K=KP,KL - J = IND(K,2) - W(J) = 1.0D0 - 120 CONTINUE - IW(INS,4) = I - INS = INS + 1 - GO TO 140 -C PLACE SINGLETONS IN NEW POSITION. - 130 IW(M1,3) = I - M1 = M1 + 1 - 140 CONTINUE -C PLACE NON-SINGLETONS IN NEW POSITION. - IJ = M + 1 - DO 150 II=M1,LAST-1 - IW(II,3) = IW(IJ,4) - IJ = IJ + 1 - 150 CONTINUE -C PLACE SPIKE AT END. - IW(LAST,3) = IM -C -C FIND ROW SINGLETONS, APART FROM SPIKE ROW. NON-SINGLETONS ARE MARKED -C WITH W(I)=2. AGAIN ONLY IW(.,3) IS REVISED AND IW(.,4) IS USED -C FOR WORKSPACE. - LAST1 = LAST - JNS = LAST - W(IM) = 2.0D0 - J = JM - DO 180 IJ=M1,LAST - II = LAST + M1 - IJ - I = IW(II,3) - IF (W(I).NE.2.0D0) GO TO 170 - K = IP(I,1) - IF (II.NE.LAST) J = IND(K,2) - KP = IP(J,2) - KL = KP + IW(J,2) - 1 - IW(JNS,4) = I - JNS = JNS - 1 - DO 160 K=KP,KL - I = IND(K,1) - W(I) = 2.0D0 - 160 CONTINUE - GO TO 180 - 170 IW(LAST1,3) = I - LAST1 = LAST1 - 1 - 180 CONTINUE - DO 190 II=M1,LAST1 - JNS = JNS + 1 - I = IW(JNS,4) - W(I) = 3.0D0 - IW(II,3) = I - 190 CONTINUE -C -C DEAL WITH SINGLETON SPIKE COLUMN. NOTE THAT BUMP ROWS ARE MARKED BY -C W(I)=3. - DO 230 II=M1,LAST1 - KP = IP(JM,2) - KL = KP + IW(JM,2) - 1 - IS = 0 - DO 200 K=KP,KL - L = IND(K,1) - IF (W(L).NE.3.0D0) GO TO 200 - IF (IS.NE.0) GO TO 240 - I = L - KNP = K - IS = 1 - 200 CONTINUE - IF (IS.EQ.0) GO TO 590 -C MAKE A(I,JM) A PIVOT. - IND(KNP,1) = IND(KP,1) - IND(KP,1) = I - KP = IP(I,1) - DO 210 K=KP,IA - IF (IND(K,2).EQ.JM) GO TO 220 - 210 CONTINUE - 220 AM = A(KP) - A(KP) = A(K) - A(K) = AM - IND(K,2) = IND(KP,2) - IND(KP,2) = JM - JM = IND(K,2) - IW(II,4) = I - W(I) = 2.0D0 - 230 CONTINUE - II = LAST1 - GO TO 260 - 240 IN = M1 - DO 250 IJ=II,LAST1 - IW(IJ,4) = IW(IN,3) - IN = IN + 1 - 250 CONTINUE - 260 LAST2 = LAST1 - 1 - IF (M1.EQ.LAST1) GO TO 570 - DO 270 I=M1,LAST2 - IW(I,3) = IW(I,4) - 270 CONTINUE - M1 = II - IF (M1.EQ.LAST1) GO TO 570 -C -C CLEAR W - DO 280 I=1,N - W(I) = 0.0D0 - 280 CONTINUE -C -C PERFORM ELIMINATION - IR = IW(LAST1,3) - DO 560 II=M1,LAST1 - IPP = IW(II,3) - KP = IP(IPP,1) - KR = IP(IR,1) - JP = IND(KP,2) - IF (II.EQ.LAST1) JP = JM -C SEARCH NON-PIVOT ROW FOR ELEMENT TO BE ELIMINATED. -C AND BRING IT TO FRONT OF ITS ROW - KRL = KR + IW(IR,1) - 1 - DO 290 KNP=KR,KRL - IF (JP.EQ.IND(KNP,2)) GO TO 300 - 290 CONTINUE - IF (II-LAST1) 560, 590, 560 -C BRING ELEMENT TO BE ELIMINATED TO FRONT OF ITS ROW. - 300 AM = A(KNP) - A(KNP) = A(KR) - A(KR) = AM - IND(KNP,2) = IND(KR,2) - IND(KR,2) = JP - IF (II.EQ.LAST1) GO TO 310 - IF (ABS(A(KP)).LT.U*ABS(AM)) GO TO 310 - IF (ABS(AM).LT.U*ABS(A(KP))) GO TO 340 - IF (IW(IPP,1).LE.IW(IR,1)) GO TO 340 -C PERFORM INTERCHANGE - 310 IW(LAST1,3) = IPP - IW(II,3) = IR - IR = IPP - IPP = IW(II,3) - K = KR - KR = KP - KP = K - KJ = IP(JP,2) - DO 320 K=KJ,IA - IF (IND(K,1).EQ.IPP) GO TO 330 - 320 CONTINUE - 330 IND(K,1) = IND(KJ,1) - IND(KJ,1) = IPP - 340 IF (A(KP).EQ.0.0D0) GO TO 590 - IF (II.EQ.LAST1) GO TO 560 - AM = -A(KR)/A(KP) -C COMPRESS ROW FILE UNLESS IT IS CERTAIN THAT THERE IS ROOM FOR NEW ROW. - IF (LROW+IW(IR,1)+IW(IPP,1)+LENL.LE.IA) GO TO 350 - IF (NCP.GE.MCP .OR. LENU+IW(IR,1)+IW(IPP,1)+LENL.GT.IA) GO TO - * 610 - CALL LA05ED(A, IND(1,2), IP, N, IW, IA, .TRUE.) - KP = IP(IPP,1) - KR = IP(IR,1) - 350 KRL = KR + IW(IR,1) - 1 - KQ = KP + 1 - KPL = KP + IW(IPP,1) - 1 -C PLACE PIVOT ROW (EXCLUDING PIVOT ITSELF) IN W. - IF (KQ.GT.KPL) GO TO 370 - DO 360 K=KQ,KPL - J = IND(K,2) - W(J) = A(K) - 360 CONTINUE - 370 IP(IR,1) = LROW + 1 -C -C TRANSFER MODIFIED ELEMENTS. - IND(KR,2) = 0 - KR = KR + 1 - IF (KR.GT.KRL) GO TO 430 - DO 420 KS=KR,KRL - J = IND(KS,2) - AU = A(KS) + AM*W(J) - IND(KS,2) = 0 -C IF ELEMENT IS VERY SMALL REMOVE IT FROM U. - IF (ABS(AU).LE.SMALL) GO TO 380 - G = MAX(G,ABS(AU)) - LROW = LROW + 1 - A(LROW) = AU - IND(LROW,2) = J - GO TO 410 - 380 LENU = LENU - 1 -C REMOVE ELEMENT FROM COL FILE. - K = IP(J,2) - KL = K + IW(J,2) - 1 - IW(J,2) = KL - K - DO 390 KK=K,KL - IF (IND(KK,1).EQ.IR) GO TO 400 - 390 CONTINUE - 400 IND(KK,1) = IND(KL,1) - IND(KL,1) = 0 - 410 W(J) = 0.0D0 - 420 CONTINUE -C -C SCAN PIVOT ROW FOR FILLS. - 430 IF (KQ.GT.KPL) GO TO 520 - DO 510 KS=KQ,KPL - J = IND(KS,2) - AU = AM*W(J) - IF (ABS(AU).LE.SMALL) GO TO 500 - LROW = LROW + 1 - A(LROW) = AU - IND(LROW,2) = J - LENU = LENU + 1 -C -C CREATE FILL IN COLUMN FILE. - NZ = IW(J,2) - K = IP(J,2) - KL = K + NZ - 1 -C IF POSSIBLE PLACE NEW ELEMENT AT END OF PRESENT ENTRY. - IF (KL.NE.LCOL) GO TO 440 - IF (LCOL+LENL.GE.IA) GO TO 460 - LCOL = LCOL + 1 - GO TO 450 - 440 IF (IND(KL+1,1).NE.0) GO TO 460 - 450 IND(KL+1,1) = IR - GO TO 490 -C NEW ENTRY HAS TO BE CREATED. - 460 IF (LCOL+LENL+NZ+1.LT.IA) GO TO 470 -C COMPRESS COLUMN FILE IF THERE IS NOT ROOM FOR NEW ENTRY. - IF (NCP.GE.MCP .OR. LENU+LENL+NZ+1.GE.IA) GO TO 610 - CALL LA05ED(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.) - K = IP(J,2) - KL = K + NZ - 1 -C TRANSFER OLD ENTRY INTO NEW. - 470 IP(J,2) = LCOL + 1 - DO 480 KK=K,KL - LCOL = LCOL + 1 - IND(LCOL,1) = IND(KK,1) - IND(KK,1) = 0 - 480 CONTINUE -C ADD NEW ELEMENT. - LCOL = LCOL + 1 - IND(LCOL,1) = IR - 490 G = MAX(G,ABS(AU)) - IW(J,2) = NZ + 1 - 500 W(J) = 0.0D0 - 510 CONTINUE - 520 IW(IR,1) = LROW + 1 - IP(IR,1) -C -C STORE MULTIPLIER - IF (LENL+LCOL+1.LE.IA) GO TO 530 -C COMPRESS COL FILE IF NECESSARY. - IF (NCP.GE.MCP) GO TO 610 - CALL LA05ED(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.) - 530 K = IA - LENL - LENL = LENL + 1 - A(K) = AM - IND(K,1) = IPP - IND(K,2) = IR -C CREATE BLANK IN PIVOTAL COLUMN. - KP = IP(JP,2) - NZ = IW(JP,2) - 1 - KL = KP + NZ - DO 540 K=KP,KL - IF (IND(K,1).EQ.IR) GO TO 550 - 540 CONTINUE - 550 IND(K,1) = IND(KL,1) - IW(JP,2) = NZ - IND(KL,1) = 0 - LENU = LENU - 1 - 560 CONTINUE -C -C CONSTRUCT COLUMN PERMUTATION AND STORE IT IN IW(.,4) - 570 DO 580 II=M,LAST - I = IW(II,3) - K = IP(I,1) - J = IND(K,2) - IW(II,4) = J - 580 CONTINUE - RETURN -C -C THE FOLLOWING INSTRUCTIONS IMPLEMENT THE FAILURE EXITS. -C - 590 IF (LP.GT.0) THEN - WRITE (XERN1, '(I8)') MM - CALL XERMSG ('SLATEC', 'LA05CD', 'SINGULAR MATRIX AFTER ' // - * 'REPLACEMENT OF COLUMN. INDEX = ' // XERN1, -6, 1) - ENDIF - G = -6.0D0 - RETURN -C - 610 IF (LP.GT.0) CALL XERMSG ('SLATEC', 'LA05CD', - * 'LENGTHS OF ARRAYS A(*) AND IND(*,2) ARE TOO SMALL.', -7, 1) - G = -7.0D0 - RETURN -C - 620 IF (LP.GT.0) CALL XERMSG ('SLATEC', 'LA05CD', - * 'EARLIER ENTRY GAVE ERROR RETURN.', -8, 2) - G = -8.0D0 - RETURN - END diff --git a/slatec/la05cs.f b/slatec/la05cs.f deleted file mode 100644 index 333550e..0000000 --- a/slatec/la05cs.f +++ /dev/null @@ -1,416 +0,0 @@ -*DECK LA05CS - SUBROUTINE LA05CS (A, IND, IA, N, IP, IW, W, G, U, MM) -C***BEGIN PROLOGUE LA05CS -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (LA05CS-S, LA05CD-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM -C FROM THE C. 1979 AERE HARWELL LIBRARY. THE NAME OF THE -C CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING -C THE FINAL LETTER =S= IN THE NAMES USED HERE. -C REVISED SEP. 13, 1979. -C -C ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES -C IN THE PACKAGE GIVEN HERE. ANY PRIMARY USAGE OF THE HARWELL -C SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN -C THE USER AND AERE-UK. ANY USAGE OF THE SANDIA WRITTEN CODES -C SPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED. -C -C***SEE ALSO SPLP -C***ROUTINES CALLED LA05ES, XERMSG, XSETUN -C***COMMON BLOCKS LA05DS -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890605 Corrected references to XERRWV. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900402 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C 920410 Corrected second dimension on IW declaration. (WRB) -C 920422 Changed upper limit on DO from LAST to LAST-1. (WRB) -C***END PROLOGUE LA05CS - REAL A(*), G, U, AM, W(*), SMALL, AU - INTEGER IND(IA,2), IW(N,8) - INTEGER IP(N,2) - CHARACTER*8 XERN1 -C - COMMON /LA05DS/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL -C***FIRST EXECUTABLE STATEMENT LA05CS - CALL XSETUN(LP) - IF (G.LT.0.0E0) GO TO 620 - JM = MM -C MCP LIMITS THE VALUE OF NCP PERMITTED BEFORE AN ERROR RETURN RESULTS. - MCP = NCP + 20 -C REMOVE OLD COLUMN - LENU = LENU - IW(JM,2) - KP = IP(JM,2) - IM = IND(KP,1) - KL = KP + IW(JM,2) - 1 - IW(JM,2) = 0 - DO 30 K=KP,KL - I = IND(K,1) - IND(K,1) = 0 - KR = IP(I,1) - NZ = IW(I,1) - 1 - IW(I,1) = NZ - KRL = KR + NZ - DO 10 KM=KR,KRL - IF (IND(KM,2).EQ.JM) GO TO 20 - 10 CONTINUE - 20 A(KM) = A(KRL) - IND(KM,2) = IND(KRL,2) - IND(KRL,2) = 0 - 30 CONTINUE -C -C INSERT NEW COLUMN - DO 110 II=1,N - I = IW(II,3) - IF (I.EQ.IM) M = II - IF (ABS(W(I)).LE.SMALL) GO TO 100 - LENU = LENU + 1 - LAST = II - IF (LCOL+LENL.LT.IA) GO TO 40 -C COMPRESS COLUMN FILE IF NECESSARY. - IF (NCP.GE.MCP .OR. LENL+LENU.GE.IA) GO TO 610 - CALL LA05ES(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.) - 40 LCOL = LCOL + 1 - NZ = IW(JM,2) - IF (NZ.EQ.0) IP(JM,2) = LCOL - IW(JM,2) = NZ + 1 - IND(LCOL,1) = I - NZ = IW(I,1) - KPL = IP(I,1) + NZ - IF (KPL.GT.LROW) GO TO 50 - IF (IND(KPL,2).EQ.0) GO TO 90 -C NEW ENTRY HAS TO BE CREATED. - 50 IF (LENL+LROW+NZ.LT.IA) GO TO 60 - IF (NCP.GE.MCP .OR. LENL+LENU+NZ.GE.IA) GO TO 610 -C COMPRESS ROW FILE IF NECESSARY. - CALL LA05ES(A, IND(1,2), IP, N, IW, IA, .TRUE.) - 60 KP = IP(I,1) - IP(I,1) = LROW + 1 - IF (NZ.EQ.0) GO TO 80 - KPL = KP + NZ - 1 - DO 70 K=KP,KPL - LROW = LROW + 1 - A(LROW) = A(K) - IND(LROW,2) = IND(K,2) - IND(K,2) = 0 - 70 CONTINUE - 80 LROW = LROW + 1 - KPL = LROW -C PLACE NEW ELEMENT AT END OF ROW. - 90 IW(I,1) = NZ + 1 - A(KPL) = W(I) - IND(KPL,2) = JM - 100 W(I) = 0.0E0 - 110 CONTINUE - IF (IW(IM,1).EQ.0 .OR. IW(JM,2).EQ.0 .OR. M.GT.LAST) GO TO 590 -C -C FIND COLUMN SINGLETONS, OTHER THAN THE SPIKE. NON-SINGLETONS ARE -C MARKED WITH W(J)=1. ONLY IW(.,3) IS REVISED AND IW(.,4) IS USED -C FOR WORKSPACE. - INS = M - M1 = M - W(JM) = 1.0E0 - DO 140 II=M,LAST - I = IW(II,3) - J = IW(II,4) - IF (W(J).EQ.0.0E0) GO TO 130 - KP = IP(I,1) - KL = KP + IW(I,1) - 1 - DO 120 K=KP,KL - J = IND(K,2) - W(J) = 1.0E0 - 120 CONTINUE - IW(INS,4) = I - INS = INS + 1 - GO TO 140 -C PLACE SINGLETONS IN NEW POSITION. - 130 IW(M1,3) = I - M1 = M1 + 1 - 140 CONTINUE -C PLACE NON-SINGLETONS IN NEW POSITION. - IJ = M + 1 - DO 150 II=M1,LAST-1 - IW(II,3) = IW(IJ,4) - IJ = IJ + 1 - 150 CONTINUE -C PLACE SPIKE AT END. - IW(LAST,3) = IM -C -C FIND ROW SINGLETONS, APART FROM SPIKE ROW. NON-SINGLETONS ARE MARKED -C WITH W(I)=2. AGAIN ONLY IW(.,3) IS REVISED AND IW(.,4) IS USED -C FOR WORKSPACE. - LAST1 = LAST - JNS = LAST - W(IM) = 2.0E0 - J = JM - DO 180 IJ=M1,LAST - II = LAST + M1 - IJ - I = IW(II,3) - IF (W(I).NE.2.0E0) GO TO 170 - K = IP(I,1) - IF (II.NE.LAST) J = IND(K,2) - KP = IP(J,2) - KL = KP + IW(J,2) - 1 - IW(JNS,4) = I - JNS = JNS - 1 - DO 160 K=KP,KL - I = IND(K,1) - W(I) = 2.0E0 - 160 CONTINUE - GO TO 180 - 170 IW(LAST1,3) = I - LAST1 = LAST1 - 1 - 180 CONTINUE - DO 190 II=M1,LAST1 - JNS = JNS + 1 - I = IW(JNS,4) - W(I) = 3.0E0 - IW(II,3) = I - 190 CONTINUE -C -C DEAL WITH SINGLETON SPIKE COLUMN. NOTE THAT BUMP ROWS ARE MARKED BY -C W(I)=3.0E0 - DO 230 II=M1,LAST1 - KP = IP(JM,2) - KL = KP + IW(JM,2) - 1 - IS = 0 - DO 200 K=KP,KL - L = IND(K,1) - IF (W(L).NE.3.0E0) GO TO 200 - IF (IS.NE.0) GO TO 240 - I = L - KNP = K - IS = 1 - 200 CONTINUE - IF (IS.EQ.0) GO TO 590 -C MAKE A(I,JM) A PIVOT. - IND(KNP,1) = IND(KP,1) - IND(KP,1) = I - KP = IP(I,1) - DO 210 K=KP,IA - IF (IND(K,2).EQ.JM) GO TO 220 - 210 CONTINUE - 220 AM = A(KP) - A(KP) = A(K) - A(K) = AM - IND(K,2) = IND(KP,2) - IND(KP,2) = JM - JM = IND(K,2) - IW(II,4) = I - W(I) = 2.0E0 - 230 CONTINUE - II = LAST1 - GO TO 260 - 240 IN = M1 - DO 250 IJ=II,LAST1 - IW(IJ,4) = IW(IN,3) - IN = IN + 1 - 250 CONTINUE - 260 LAST2 = LAST1 - 1 - IF (M1.EQ.LAST1) GO TO 570 - DO 270 I=M1,LAST2 - IW(I,3) = IW(I,4) - 270 CONTINUE - M1 = II - IF (M1.EQ.LAST1) GO TO 570 -C -C CLEAR W - DO 280 I=1,N - W(I) = 0.0E0 - 280 CONTINUE -C -C PERFORM ELIMINATION - IR = IW(LAST1,3) - DO 560 II=M1,LAST1 - IPP = IW(II,3) - KP = IP(IPP,1) - KR = IP(IR,1) - JP = IND(KP,2) - IF (II.EQ.LAST1) JP = JM -C SEARCH NON-PIVOT ROW FOR ELEMENT TO BE ELIMINATED. -C AND BRING IT TO FRONT OF ITS ROW - KRL = KR + IW(IR,1) - 1 - DO 290 KNP=KR,KRL - IF (JP.EQ.IND(KNP,2)) GO TO 300 - 290 CONTINUE - IF (II-LAST1) 560, 590, 560 -C BRING ELEMENT TO BE ELIMINATED TO FRONT OF ITS ROW. - 300 AM = A(KNP) - A(KNP) = A(KR) - A(KR) = AM - IND(KNP,2) = IND(KR,2) - IND(KR,2) = JP - IF (II.EQ.LAST1) GO TO 310 - IF (ABS(A(KP)).LT.U*ABS(AM)) GO TO 310 - IF (ABS(AM).LT.U*ABS(A(KP))) GO TO 340 - IF (IW(IPP,1).LE.IW(IR,1)) GO TO 340 -C PERFORM INTERCHANGE - 310 IW(LAST1,3) = IPP - IW(II,3) = IR - IR = IPP - IPP = IW(II,3) - K = KR - KR = KP - KP = K - KJ = IP(JP,2) - DO 320 K=KJ,IA - IF (IND(K,1).EQ.IPP) GO TO 330 - 320 CONTINUE - 330 IND(K,1) = IND(KJ,1) - IND(KJ,1) = IPP - 340 IF (A(KP).EQ.0.0E0) GO TO 590 - IF (II.EQ.LAST1) GO TO 560 - AM = -A(KR)/A(KP) -C COMPRESS ROW FILE UNLESS IT IS CERTAIN THAT THERE IS ROOM FOR NEW ROW. - IF (LROW+IW(IR,1)+IW(IPP,1)+LENL.LE.IA) GO TO 350 - IF (NCP.GE.MCP .OR. LENU+IW(IR,1)+IW(IPP,1)+LENL.GT.IA) GO TO - * 610 - CALL LA05ES(A, IND(1,2), IP, N, IW, IA, .TRUE.) - KP = IP(IPP,1) - KR = IP(IR,1) - 350 KRL = KR + IW(IR,1) - 1 - KQ = KP + 1 - KPL = KP + IW(IPP,1) - 1 -C PLACE PIVOT ROW (EXCLUDING PIVOT ITSELF) IN W. - IF (KQ.GT.KPL) GO TO 370 - DO 360 K=KQ,KPL - J = IND(K,2) - W(J) = A(K) - 360 CONTINUE - 370 IP(IR,1) = LROW + 1 -C -C TRANSFER MODIFIED ELEMENTS. - IND(KR,2) = 0 - KR = KR + 1 - IF (KR.GT.KRL) GO TO 430 - DO 420 KS=KR,KRL - J = IND(KS,2) - AU = A(KS) + AM*W(J) - IND(KS,2) = 0 -C IF ELEMENT IS VERY SMALL REMOVE IT FROM U. - IF (ABS(AU).LE.SMALL) GO TO 380 - G = MAX(G,ABS(AU)) - LROW = LROW + 1 - A(LROW) = AU - IND(LROW,2) = J - GO TO 410 - 380 LENU = LENU - 1 -C REMOVE ELEMENT FROM COL FILE. - K = IP(J,2) - KL = K + IW(J,2) - 1 - IW(J,2) = KL - K - DO 390 KK=K,KL - IF (IND(KK,1).EQ.IR) GO TO 400 - 390 CONTINUE - 400 IND(KK,1) = IND(KL,1) - IND(KL,1) = 0 - 410 W(J) = 0.0E0 - 420 CONTINUE -C -C SCAN PIVOT ROW FOR FILLS. - 430 IF (KQ.GT.KPL) GO TO 520 - DO 510 KS=KQ,KPL - J = IND(KS,2) - AU = AM*W(J) - IF (ABS(AU).LE.SMALL) GO TO 500 - LROW = LROW + 1 - A(LROW) = AU - IND(LROW,2) = J - LENU = LENU + 1 -C -C CREATE FILL IN COLUMN FILE. - NZ = IW(J,2) - K = IP(J,2) - KL = K + NZ - 1 -C IF POSSIBLE PLACE NEW ELEMENT AT END OF PRESENT ENTRY. - IF (KL.NE.LCOL) GO TO 440 - IF (LCOL+LENL.GE.IA) GO TO 460 - LCOL = LCOL + 1 - GO TO 450 - 440 IF (IND(KL+1,1).NE.0) GO TO 460 - 450 IND(KL+1,1) = IR - GO TO 490 -C NEW ENTRY HAS TO BE CREATED. - 460 IF (LCOL+LENL+NZ+1.LT.IA) GO TO 470 -C COMPRESS COLUMN FILE IF THERE IS NOT ROOM FOR NEW ENTRY. - IF (NCP.GE.MCP .OR. LENU+LENL+NZ+1.GE.IA) GO TO 610 - CALL LA05ES(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.) - K = IP(J,2) - KL = K + NZ - 1 -C TRANSFER OLD ENTRY INTO NEW. - 470 IP(J,2) = LCOL + 1 - DO 480 KK=K,KL - LCOL = LCOL + 1 - IND(LCOL,1) = IND(KK,1) - IND(KK,1) = 0 - 480 CONTINUE -C ADD NEW ELEMENT. - LCOL = LCOL + 1 - IND(LCOL,1) = IR - 490 G = MAX(G,ABS(AU)) - IW(J,2) = NZ + 1 - 500 W(J) = 0.0E0 - 510 CONTINUE - 520 IW(IR,1) = LROW + 1 - IP(IR,1) -C -C STORE MULTIPLIER - IF (LENL+LCOL+1.LE.IA) GO TO 530 -C COMPRESS COL FILE IF NECESSARY. - IF (NCP.GE.MCP) GO TO 610 - CALL LA05ES(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.) - 530 K = IA - LENL - LENL = LENL + 1 - A(K) = AM - IND(K,1) = IPP - IND(K,2) = IR -C CREATE BLANK IN PIVOTAL COLUMN. - KP = IP(JP,2) - NZ = IW(JP,2) - 1 - KL = KP + NZ - DO 540 K=KP,KL - IF (IND(K,1).EQ.IR) GO TO 550 - 540 CONTINUE - 550 IND(K,1) = IND(KL,1) - IW(JP,2) = NZ - IND(KL,1) = 0 - LENU = LENU - 1 - 560 CONTINUE -C -C CONSTRUCT COLUMN PERMUTATION AND STORE IT IN IW(.,4) - 570 DO 580 II=M,LAST - I = IW(II,3) - K = IP(I,1) - J = IND(K,2) - IW(II,4) = J - 580 CONTINUE - RETURN -C -C THE FOLLOWING INSTRUCTIONS IMPLEMENT THE FAILURE EXITS. -C - 590 IF (LP.GT.0) THEN - WRITE (XERN1, '(I8)') MM - CALL XERMSG ('SLATEC', 'LA05CS', 'SINGULAR MATRIX AFTER ' // - * 'REPLACEMENT OF COLUMN. INDEX = ' // XERN1, -6, 1) - ENDIF - G = -6.0E0 - RETURN -C - 610 IF (LP.GT.0) CALL XERMSG ('SLATEC', 'LA05CS', - * 'LENGTHS OF ARRAYS A(*) AND IND(*,2) ARE TOO SMALL.', -7, 1) - G = -7.0E0 - RETURN -C - 620 IF (LP.GT.0) CALL XERMSG ('SLATEC', 'LA05CS', - * 'EARLIER ENTRY GAVE ERROR RETURN.', -8, 2) - G = -8.0E0 - RETURN - END diff --git a/slatec/la05ed.f b/slatec/la05ed.f deleted file mode 100644 index 4dc2367..0000000 --- a/slatec/la05ed.f +++ /dev/null @@ -1,83 +0,0 @@ -*DECK LA05ED - SUBROUTINE LA05ED (A, IRN, IP, N, IW, IA, REALS) -C***BEGIN PROLOGUE LA05ED -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSPLP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (LA05ES-S, LA05ED-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM -C FROM THE C. 1979 AERE HARWELL LIBRARY. THE NAME OF THE -C CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING -C THE FINAL LETTER =D= IN THE NAMES USED HERE. -C REVISED SEP. 13, 1979. -C -C ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES -C IN THE PACKAGE GIVEN HERE. ANY PRIMARY USAGE OF THE HARWELL -C SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN -C THE USER AND AERE-UK. ANY USAGE OF THE SANDIA WRITTEN CODES -C DSPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED. -C -C***SEE ALSO DSPLP -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS LA05DD -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE LA05ED - LOGICAL REALS - DOUBLE PRECISION A(*),SMALL - INTEGER IRN(*), IW(*) - INTEGER IP(*) - COMMON /LA05DD/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL -C***FIRST EXECUTABLE STATEMENT LA05ED - NCP = NCP + 1 -C COMPRESS FILE OF POSITIVE INTEGERS. ENTRY J STARTS AT IRN(IP(J)) -C AND CONTAINS IW(J) INTEGERS,J=1,N. OTHER COMPONENTS OF IRN ARE ZERO. -C LENGTH OF COMPRESSED FILE PLACED IN LROW IF REALS IS .TRUE. OR LCOL -C OTHERWISE. -C IF REALS IS .TRUE. ARRAY A CONTAINS A FILE ASSOCIATED WITH IRN -C AND THIS IS COMPRESSED TOO. -C A,IRN,IP,IW,IA ARE INPUT/OUTPUT VARIABLES. -C N,REALS ARE INPUT/UNCHANGED VARIABLES. -C - DO 10 J=1,N -C STORE THE LAST ELEMENT OF ENTRY J IN IW(J) THEN OVERWRITE IT BY -J. - NZ = IW(J) - IF (NZ.LE.0) GO TO 10 - K = IP(J) + NZ - 1 - IW(J) = IRN(K) - IRN(K) = -J - 10 CONTINUE -C KN IS THE POSITION OF NEXT ENTRY IN COMPRESSED FILE. - KN = 0 - IPI = 0 - KL = LCOL - IF (REALS) KL = LROW -C LOOP THROUGH THE OLD FILE SKIPPING ZERO (DUMMY) ELEMENTS AND -C MOVING GENUINE ELEMENTS FORWARD. THE ENTRY NUMBER BECOMES -C KNOWN ONLY WHEN ITS END IS DETECTED BY THE PRESENCE OF A NEGATIVE -C INTEGER. - DO 30 K=1,KL - IF (IRN(K).EQ.0) GO TO 30 - KN = KN + 1 - IF (REALS) A(KN) = A(K) - IF (IRN(K).GE.0) GO TO 20 -C END OF ENTRY. RESTORE IRN(K), SET POINTER TO START OF ENTRY AND -C STORE CURRENT KN IN IPI READY FOR USE WHEN NEXT LAST ENTRY -C IS DETECTED. - J = -IRN(K) - IRN(K) = IW(J) - IP(J) = IPI + 1 - IW(J) = KN - IPI - IPI = KN - 20 IRN(KN) = IRN(K) - 30 CONTINUE - IF (REALS) LROW = KN - IF (.NOT.REALS) LCOL = KN - RETURN - END diff --git a/slatec/la05es.f b/slatec/la05es.f deleted file mode 100644 index c657843..0000000 --- a/slatec/la05es.f +++ /dev/null @@ -1,83 +0,0 @@ -*DECK LA05ES - SUBROUTINE LA05ES (A, IRN, IP, N, IW, IA, REALS) -C***BEGIN PROLOGUE LA05ES -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (LA05ES-S, LA05ED-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM -C FROM THE C. 1979 AERE HARWELL LIBRARY. THE NAME OF THE -C CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING -C THE FINAL LETTER =S= IN THE NAMES USED HERE. -C REVISED SEP. 13, 1979. -C -C ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES -C IN THE PACKAGE GIVEN HERE. ANY PRIMARY USAGE OF THE HARWELL -C SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN -C THE USER AND AERE-UK. ANY USAGE OF THE SANDIA WRITTEN CODES -C SPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED. -C -C***SEE ALSO SPLP -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS LA05DS -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE LA05ES - LOGICAL REALS - REAL A(*) - INTEGER IRN(*), IW(*) - INTEGER IP(*) - COMMON /LA05DS/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL -C***FIRST EXECUTABLE STATEMENT LA05ES - NCP = NCP + 1 -C COMPRESS FILE OF POSITIVE INTEGERS. ENTRY J STARTS AT IRN(IP(J)) -C AND CONTAINS IW(J) INTEGERS,J=1,N. OTHER COMPONENTS OF IRN ARE ZERO. -C LENGTH OF COMPRESSED FILE PLACED IN LROW IF REALS IS .TRUE. OR LCOL -C OTHERWISE. -C IF REALS IS .TRUE. ARRAY A CONTAINS A REAL FILE ASSOCIATED WITH IRN -C AND THIS IS COMPRESSED TOO. -C A,IRN,IP,IW,IA ARE INPUT/OUTPUT VARIABLES. -C N,REALS ARE INPUT/UNCHANGED VARIABLES. -C - DO 10 J=1,N -C STORE THE LAST ELEMENT OF ENTRY J IN IW(J) THEN OVERWRITE IT BY -J. - NZ = IW(J) - IF (NZ.LE.0) GO TO 10 - K = IP(J) + NZ - 1 - IW(J) = IRN(K) - IRN(K) = -J - 10 CONTINUE -C KN IS THE POSITION OF NEXT ENTRY IN COMPRESSED FILE. - KN = 0 - IPI = 0 - KL = LCOL - IF (REALS) KL = LROW -C LOOP THROUGH THE OLD FILE SKIPPING ZERO (DUMMY) ELEMENTS AND -C MOVING GENUINE ELEMENTS FORWARD. THE ENTRY NUMBER BECOMES -C KNOWN ONLY WHEN ITS END IS DETECTED BY THE PRESENCE OF A NEGATIVE -C INTEGER. - DO 30 K=1,KL - IF (IRN(K).EQ.0) GO TO 30 - KN = KN + 1 - IF (REALS) A(KN) = A(K) - IF (IRN(K).GE.0) GO TO 20 -C END OF ENTRY. RESTORE IRN(K), SET POINTER TO START OF ENTRY AND -C STORE CURRENT KN IN IPI READY FOR USE WHEN NEXT LAST ENTRY -C IS DETECTED. - J = -IRN(K) - IRN(K) = IW(J) - IP(J) = IPI + 1 - IW(J) = KN - IPI - IPI = KN - 20 IRN(KN) = IRN(K) - 30 CONTINUE - IF (REALS) LROW = KN - IF (.NOT.REALS) LCOL = KN - RETURN - END diff --git a/slatec/llsia.f b/slatec/llsia.f deleted file mode 100644 index 65ac6cc..0000000 --- a/slatec/llsia.f +++ /dev/null @@ -1,312 +0,0 @@ -*DECK LLSIA - SUBROUTINE LLSIA (A, MDA, M, N, B, MDB, NB, RE, AE, KEY, MODE, NP, - + KRANK, KSURE, RNORM, W, LW, IWORK, LIW, INFO) -C***BEGIN PROLOGUE LLSIA -C***PURPOSE Solve a linear least squares problems by performing a QR -C factorization of the matrix using Householder -C transformations. Emphasis is put on detecting possible -C rank deficiency. -C***LIBRARY SLATEC -C***CATEGORY D9, D5 -C***TYPE SINGLE PRECISION (LLSIA-S, DLLSIA-D) -C***KEYWORDS LINEAR LEAST SQUARES, QR FACTORIZATION -C***AUTHOR Manteuffel, T. A., (LANL) -C***DESCRIPTION -C -C LLSIA computes the least squares solution(s) to the problem AX=B -C where A is an M by N matrix with M.GE.N and B is the M by NB -C matrix of right hand sides. User input bounds on the uncertainty -C in the elements of A are used to detect numerical rank deficiency. -C The algorithm employs a row and column pivot strategy to -C minimize the growth of uncertainty and round-off errors. -C -C LLSIA requires (MDA+6)*N + (MDB+1)*NB + M dimensioned space -C -C ****************************************************************** -C * * -C * WARNING - All input arrays are changed on exit. * -C * * -C ****************************************************************** -C SUBROUTINE LLSIA(A,MDA,M,N,B,MDB,NB,RE,AE,KEY,MODE,NP, -C 1 KRANK,KSURE,RNORM,W,LW,IWORK,LIW,INFO) -C -C Input.. -C -C A(,) Linear coefficient matrix of AX=B, with MDA the -C MDA,M,N actual first dimension of A in the calling program. -C M is the row dimension (no. of EQUATIONS of the -C problem) and N the col dimension (no. of UNKNOWNS). -C Must have MDA.GE.M and M.GE.N. -C -C B(,) Right hand side(s), with MDB the actual first -C MDB,NB dimension of B in the calling program. NB is the -C number of M by 1 right hand sides. Must have -C MDB.GE.M. If NB = 0, B is never accessed. -C -C ****************************************************************** -C * * -C * Note - Use of RE and AE are what make this * -C * code significantly different from * -C * other linear least squares solvers. * -C * However, the inexperienced user is * -C * advised to set RE=0.,AE=0.,KEY=0. * -C * * -C ****************************************************************** -C RE(),AE(),KEY -C RE() RE() is a vector of length N such that RE(I) is -C the maximum relative uncertainty in column I of -C the matrix A. The values of RE() must be between -C 0 and 1. A minimum of 10*machine precision will -C be enforced. -C -C AE() AE() is a vector of length N such that AE(I) is -C the maximum absolute uncertainty in column I of -C the matrix A. The values of AE() must be greater -C than or equal to 0. -C -C KEY For ease of use, RE and AE may be input as either -C vectors or scalars. If a scalar is input, the algo- -C rithm will use that value for each column of A. -C The parameter key indicates whether scalars or -C vectors are being input. -C KEY=0 RE scalar AE scalar -C KEY=1 RE vector AE scalar -C KEY=2 RE scalar AE vector -C KEY=3 RE vector AE vector -C -C MODE The integer mode indicates how the routine -C is to react if rank deficiency is detected. -C If MODE = 0 return immediately, no solution -C 1 compute truncated solution -C 2 compute minimal length solution -C The inexperienced user is advised to set MODE=0 -C -C NP The first NP columns of A will not be interchanged -C with other columns even though the pivot strategy -C would suggest otherwise. -C The inexperienced user is advised to set NP=0. -C -C WORK() A real work array dimensioned 5*N. However, if -C RE or AE have been specified as vectors, dimension -C WORK 4*N. If both RE and AE have been specified -C as vectors, dimension WORK 3*N. -C -C LW Actual dimension of WORK -C -C IWORK() Integer work array dimensioned at least N+M. -C -C LIW Actual dimension of IWORK. -C -C INFO Is a flag which provides for the efficient -C solution of subsequent problems involving the -C same A but different B. -C If INFO = 0 original call -C INFO = 1 subsequent calls -C On subsequent calls, the user must supply A, KRANK, -C LW, IWORK, LIW, and the first 2*N locations of WORK -C as output by the original call to LLSIA. MODE must -C be equal to the value of MODE in the original call. -C If MODE.LT.2, only the first N locations of WORK -C are accessed. AE, RE, KEY, and NP are not accessed. -C -C Output.. -C -C A(,) Contains the upper triangular part of the reduced -C matrix and the transformation information. It togeth -C with the first N elements of WORK (see below) -C completely specify the QR factorization of A. -C -C B(,) Contains the N by NB solution matrix for X. -C -C KRANK,KSURE The numerical rank of A, based upon the relative -C and absolute bounds on uncertainty, is bounded -C above by KRANK and below by KSURE. The algorithm -C returns a solution based on KRANK. KSURE provides -C an indication of the precision of the rank. -C -C RNORM() Contains the Euclidean length of the NB residual -C vectors B(I)-AX(I), I=1,NB. -C -C WORK() The first N locations of WORK contain values -C necessary to reproduce the Householder -C transformation. -C -C IWORK() The first N locations contain the order in -C which the columns of A were used. The next -C M locations contain the order in which the -C rows of A were used. -C -C INFO Flag to indicate status of computation on completion -C -1 Parameter error(s) -C 0 - Rank deficient, no solution -C 1 - Rank deficient, truncated solution -C 2 - Rank deficient, minimal length solution -C 3 - Numerical rank 0, zero solution -C 4 - Rank .LT. NP -C 5 - Full rank -C -C***REFERENCES T. Manteuffel, An interval analysis approach to rank -C determination in linear least squares problems, -C Report SAND80-0655, Sandia Laboratories, June 1980. -C***ROUTINES CALLED R1MACH, U11LS, U12LS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 810801 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891009 Removed unreferenced variable. (WRB) -C 891009 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 Fixed an error message. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE LLSIA - DIMENSION A(MDA,*),B(MDB,*),RE(*),AE(*),RNORM(*),W(*) - INTEGER IWORK(*) -C -C***FIRST EXECUTABLE STATEMENT LLSIA - IF(INFO.LT.0 .OR. INFO.GT.1) GO TO 514 - IT=INFO - INFO=-1 - IF(NB.EQ.0 .AND. IT.EQ.1) GO TO 501 - IF(M.LT.1) GO TO 502 - IF(N.LT.1) GO TO 503 - IF(N.GT.M) GO TO 504 - IF(MDA.LT.M) GO TO 505 - IF(LIW.LT.M+N) GO TO 506 - IF(MODE.LT.0 .OR. MODE.GT.3) GO TO 515 - IF(NB.EQ.0) GO TO 4 - IF(NB.LT.0) GO TO 507 - IF(MDB.LT.M) GO TO 508 - IF(IT.EQ.0) GO TO 4 - GO TO 400 - 4 IF(KEY.LT.0.OR.KEY.GT.3) GO TO 509 - IF(KEY.EQ.0 .AND. LW.LT.5*N) GO TO 510 - IF(KEY.EQ.1 .AND. LW.LT.4*N) GO TO 510 - IF(KEY.EQ.2 .AND. LW.LT.4*N) GO TO 510 - IF(KEY.EQ.3 .AND. LW.LT.3*N) GO TO 510 - IF(NP.LT.0 .OR. NP.GT.N) GO TO 516 -C - EPS=10.*R1MACH(4) - N1=1 - N2=N1+N - N3=N2+N - N4=N3+N - N5=N4+N -C - IF(KEY.EQ.1) GO TO 100 - IF(KEY.EQ.2) GO TO 200 - IF(KEY.EQ.3) GO TO 300 -C - IF(RE(1).LT.0.0) GO TO 511 - IF(RE(1).GT.1.0) GO TO 512 - IF(RE(1).LT.EPS) RE(1)=EPS - IF(AE(1).LT.0.0) GO TO 513 - DO 20 I=1,N - W(N4-1+I)=RE(1) - W(N5-1+I)=AE(1) - 20 CONTINUE - CALL U11LS(A,MDA,M,N,W(N4),W(N5),MODE,NP,KRANK,KSURE, - 1 W(N1),W(N2),W(N3),IWORK(N1),IWORK(N2)) - GO TO 400 -C - 100 CONTINUE - IF(AE(1).LT.0.0) GO TO 513 - DO 120 I=1,N - IF(RE(I).LT.0.0) GO TO 511 - IF(RE(I).GT.1.0) GO TO 512 - IF(RE(I).LT.EPS) RE(I)=EPS - W(N4-1+I)=AE(1) - 120 CONTINUE - CALL U11LS(A,MDA,M,N,RE,W(N4),MODE,NP,KRANK,KSURE, - 1 W(N1),W(N2),W(N3),IWORK(N1),IWORK(N2)) - GO TO 400 -C - 200 CONTINUE - IF(RE(1).LT.0.0) GO TO 511 - IF(RE(1).GT.1.0) GO TO 512 - IF(RE(1).LT.EPS) RE(1)=EPS - DO 220 I=1,N - W(N4-1+I)=RE(1) - IF(AE(I).LT.0.0) GO TO 513 - 220 CONTINUE - CALL U11LS(A,MDA,M,N,W(N4),AE,MODE,NP,KRANK,KSURE, - 1 W(N1),W(N2),W(N3),IWORK(N1),IWORK(N2)) - GO TO 400 -C - 300 CONTINUE - DO 320 I=1,N - IF(RE(I).LT.0.0) GO TO 511 - IF(RE(I).GT.1.0) GO TO 512 - IF(RE(I).LT.EPS) RE(I)=EPS - IF(AE(I).LT.0.0) GO TO 513 - 320 CONTINUE - CALL U11LS(A,MDA,M,N,RE,AE,MODE,NP,KRANK,KSURE, - 1 W(N1),W(N2),W(N3),IWORK(N1),IWORK(N2)) -C -C DETERMINE INFO -C - 400 IF(KRANK.NE.N) GO TO 402 - INFO=5 - GO TO 410 - 402 IF(KRANK.NE.0) GO TO 404 - INFO=3 - GO TO 410 - 404 IF(KRANK.GE.NP) GO TO 406 - INFO=4 - RETURN - 406 INFO=MODE - IF(MODE.EQ.0) RETURN - 410 IF(NB.EQ.0) RETURN -C -C SOLUTION PHASE -C - N1=1 - N2=N1+N - N3=N2+N - IF(INFO.EQ.2) GO TO 420 - IF(LW.LT.N2-1) GO TO 510 - CALL U12LS(A,MDA,M,N,B,MDB,NB,MODE,KRANK, - 1 RNORM,W(N1),W(N1),IWORK(N1),IWORK(N2)) - RETURN -C - 420 IF(LW.LT.N3-1) GO TO 510 - CALL U12LS(A,MDA,M,N,B,MDB,NB,MODE,KRANK, - 1 RNORM,W(N1),W(N2),IWORK(N1),IWORK(N2)) - RETURN -C -C ERROR MESSAGES -C - 501 CALL XERMSG ('SLATEC', 'LLSIA', - + 'SOLUTION ONLY (INFO=1) BUT NO RIGHT HAND SIDE (NB=0)', 1, 0) - RETURN - 502 CALL XERMSG ('SLATEC', 'LLSIA', 'M.LT.1', 2, 1) - RETURN - 503 CALL XERMSG ('SLATEC', 'LLSIA', 'N.LT.1', 2, 1) - RETURN - 504 CALL XERMSG ('SLATEC', 'LLSIA', 'N.GT.M', 2, 1) - RETURN - 505 CALL XERMSG ('SLATEC', 'LLSIA', 'MDA.LT.M', 2, 1) - RETURN - 506 CALL XERMSG ('SLATEC', 'LLSIA', 'LIW.LT.M+N', 2, 1) - RETURN - 507 CALL XERMSG ('SLATEC', 'LLSIA', 'NB.LT.0', 2, 1) - RETURN - 508 CALL XERMSG ('SLATEC', 'LLSIA', 'MDB.LT.M', 2, 1) - RETURN - 509 CALL XERMSG ('SLATEC', 'LLSIA', 'KEY OUT OF RANGE', 2, 1) - RETURN - 510 CALL XERMSG ('SLATEC', 'LLSIA', 'INSUFFICIENT WORK SPACE', 8, 1) - INFO=-1 - RETURN - 511 CALL XERMSG ('SLATEC', 'LLSIA', 'RE(I) .LT. 0', 2, 1) - RETURN - 512 CALL XERMSG ('SLATEC', 'LLSIA', 'RE(I) .GT. 1', 2, 1) - RETURN - 513 CALL XERMSG ('SLATEC', 'LLSIA', 'AE(I) .LT. 0', 2, 1) - RETURN - 514 CALL XERMSG ('SLATEC', 'LLSIA', 'INFO OUT OF RANGE', 2, 1) - RETURN - 515 CALL XERMSG ('SLATEC', 'LLSIA', 'MODE OUT OF RANGE', 2, 1) - RETURN - 516 CALL XERMSG ('SLATEC', 'LLSIA', 'NP OUT OF RANGE', 2, 1) - RETURN - END diff --git a/slatec/lmpar.f b/slatec/lmpar.f deleted file mode 100644 index b81e4e9..0000000 --- a/slatec/lmpar.f +++ /dev/null @@ -1,267 +0,0 @@ -*DECK LMPAR - SUBROUTINE LMPAR (N, R, LDR, IPVT, DIAG, QTB, DELTA, PAR, X, - + SIGMA, WA1, WA2) -C***BEGIN PROLOGUE LMPAR -C***SUBSIDIARY -C***PURPOSE Subsidiary to SNLS1 and SNLS1E -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (LMPAR-S, DMPAR-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Given an M by N matrix A, an N by N nonsingular DIAGONAL -C matrix D, an M-vector B, and a positive number DELTA, -C the problem is to determine a value for the parameter -C PAR such that if X solves the system -C -C A*X = B , SQRT(PAR)*D*X = 0 , -C -C in the least squares sense, and DXNORM is the Euclidean -C norm of D*X, then either PAR is zero and -C -C (DXNORM-DELTA) .LE. 0.1*DELTA , -C -C or PAR is positive and -C -C ABS(DXNORM-DELTA) .LE. 0.1*DELTA . -C -C This subroutine completes the solution of the problem -C if it is provided with the necessary information from the -C QR factorization, with column pivoting, of A. That is, if -C A*P = Q*R, where P is a permutation matrix, Q has orthogonal -C columns, and R is an upper triangular matrix with diagonal -C elements of nonincreasing magnitude, then LMPAR expects -C the full upper triangle of R, the permutation matrix P, -C and the first N components of (Q TRANSPOSE)*B. On output -C LMPAR also provides an upper triangular matrix S such that -C -C T T T -C P *(A *A + PAR*D*D)*P = S *S . -C -C S is employed within LMPAR and may be of separate interest. -C -C Only a few iterations are generally needed for convergence -C of the algorithm. If, however, the limit of 10 iterations -C is reached, then the output PAR will contain the best -C value obtained so far. -C -C The subroutine statement is -C -C SUBROUTINE LMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SIGMA, -C WA1,WA2) -C -C where -C -C N is a positive integer input variable set to the order of R. -C -C R is an N by N array. On input the full upper triangle -C must contain the full upper triangle of the matrix R. -C On output the full upper triangle is unaltered, and the -C strict lower triangle contains the strict upper triangle -C (transposed) of the upper triangular matrix S. -C -C LDR is a positive integer input variable not less than N -C which specifies the leading dimension of the array R. -C -C IPVT is an integer input array of length N which defines the -C permutation matrix P such that A*P = Q*R. Column J of P -C is column IPVT(J) of the identity matrix. -C -C DIAG is an input array of length N which must contain the -C diagonal elements of the matrix D. -C -C QTB is an input array of length N which must contain the first -C N elements of the vector (Q TRANSPOSE)*B. -C -C DELTA is a positive input variable which specifies an upper -C bound on the Euclidean norm of D*X. -C -C PAR is a nonnegative variable. On input PAR contains an -C initial estimate of the Levenberg-Marquardt parameter. -C On output PAR contains the final estimate. -C -C X is an output array of length N which contains the least -C squares solution of the system A*X = B, SQRT(PAR)*D*X = 0, -C for the output PAR. -C -C SIGMA is an output array of length N which contains the -C diagonal elements of the upper triangular matrix S. -C -C WA1 and WA2 are work arrays of length N. -C -C***SEE ALSO SNLS1, SNLS1E -C***ROUTINES CALLED ENORM, QRSOLV, R1MACH -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE LMPAR - INTEGER N,LDR - INTEGER IPVT(*) - REAL DELTA,PAR - REAL R(LDR,*),DIAG(*),QTB(*),X(*),SIGMA(*),WA1(*),WA2(*) - INTEGER I,ITER,J,JM1,JP1,K,L,NSING - REAL DXNORM,DWARF,FP,GNORM,PARC,PARL,PARU,P1,P001,SUM,TEMP,ZERO - REAL R1MACH,ENORM - SAVE P1, P001, ZERO - DATA P1,P001,ZERO /1.0E-1,1.0E-3,0.0E0/ -C***FIRST EXECUTABLE STATEMENT LMPAR - DWARF = R1MACH(1) -C -C COMPUTE AND STORE IN X THE GAUSS-NEWTON DIRECTION. IF THE -C JACOBIAN IS RANK-DEFICIENT, OBTAIN A LEAST SQUARES SOLUTION. -C - NSING = N - DO 10 J = 1, N - WA1(J) = QTB(J) - IF (R(J,J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1 - IF (NSING .LT. N) WA1(J) = ZERO - 10 CONTINUE - IF (NSING .LT. 1) GO TO 50 - DO 40 K = 1, NSING - J = NSING - K + 1 - WA1(J) = WA1(J)/R(J,J) - TEMP = WA1(J) - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 30 - DO 20 I = 1, JM1 - WA1(I) = WA1(I) - R(I,J)*TEMP - 20 CONTINUE - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - DO 60 J = 1, N - L = IPVT(J) - X(L) = WA1(J) - 60 CONTINUE -C -C INITIALIZE THE ITERATION COUNTER. -C EVALUATE THE FUNCTION AT THE ORIGIN, AND TEST -C FOR ACCEPTANCE OF THE GAUSS-NEWTON DIRECTION. -C - ITER = 0 - DO 70 J = 1, N - WA2(J) = DIAG(J)*X(J) - 70 CONTINUE - DXNORM = ENORM(N,WA2) - FP = DXNORM - DELTA - IF (FP .LE. P1*DELTA) GO TO 220 -C -C IF THE JACOBIAN IS NOT RANK DEFICIENT, THE NEWTON -C STEP PROVIDES A LOWER BOUND, PARL, FOR THE ZERO OF -C THE FUNCTION. OTHERWISE SET THIS BOUND TO ZERO. -C - PARL = ZERO - IF (NSING .LT. N) GO TO 120 - DO 80 J = 1, N - L = IPVT(J) - WA1(J) = DIAG(L)*(WA2(L)/DXNORM) - 80 CONTINUE - DO 110 J = 1, N - SUM = ZERO - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 100 - DO 90 I = 1, JM1 - SUM = SUM + R(I,J)*WA1(I) - 90 CONTINUE - 100 CONTINUE - WA1(J) = (WA1(J) - SUM)/R(J,J) - 110 CONTINUE - TEMP = ENORM(N,WA1) - PARL = ((FP/DELTA)/TEMP)/TEMP - 120 CONTINUE -C -C CALCULATE AN UPPER BOUND, PARU, FOR THE ZERO OF THE FUNCTION. -C - DO 140 J = 1, N - SUM = ZERO - DO 130 I = 1, J - SUM = SUM + R(I,J)*QTB(I) - 130 CONTINUE - L = IPVT(J) - WA1(J) = SUM/DIAG(L) - 140 CONTINUE - GNORM = ENORM(N,WA1) - PARU = GNORM/DELTA - IF (PARU .EQ. ZERO) PARU = DWARF/MIN(DELTA,P1) -C -C IF THE INPUT PAR LIES OUTSIDE OF THE INTERVAL (PARL,PARU), -C SET PAR TO THE CLOSER ENDPOINT. -C - PAR = MAX(PAR,PARL) - PAR = MIN(PAR,PARU) - IF (PAR .EQ. ZERO) PAR = GNORM/DXNORM -C -C BEGINNING OF AN ITERATION. -C - 150 CONTINUE - ITER = ITER + 1 -C -C EVALUATE THE FUNCTION AT THE CURRENT VALUE OF PAR. -C - IF (PAR .EQ. ZERO) PAR = MAX(DWARF,P001*PARU) - TEMP = SQRT(PAR) - DO 160 J = 1, N - WA1(J) = TEMP*DIAG(J) - 160 CONTINUE - CALL QRSOLV(N,R,LDR,IPVT,WA1,QTB,X,SIGMA,WA2) - DO 170 J = 1, N - WA2(J) = DIAG(J)*X(J) - 170 CONTINUE - DXNORM = ENORM(N,WA2) - TEMP = FP - FP = DXNORM - DELTA -C -C IF THE FUNCTION IS SMALL ENOUGH, ACCEPT THE CURRENT VALUE -C OF PAR. ALSO TEST FOR THE EXCEPTIONAL CASES WHERE PARL -C IS ZERO OR THE NUMBER OF ITERATIONS HAS REACHED 10. -C - IF (ABS(FP) .LE. P1*DELTA - 1 .OR. PARL .EQ. ZERO .AND. FP .LE. TEMP - 2 .AND. TEMP .LT. ZERO .OR. ITER .EQ. 10) GO TO 220 -C -C COMPUTE THE NEWTON CORRECTION. -C - DO 180 J = 1, N - L = IPVT(J) - WA1(J) = DIAG(L)*(WA2(L)/DXNORM) - 180 CONTINUE - DO 210 J = 1, N - WA1(J) = WA1(J)/SIGMA(J) - TEMP = WA1(J) - JP1 = J + 1 - IF (N .LT. JP1) GO TO 200 - DO 190 I = JP1, N - WA1(I) = WA1(I) - R(I,J)*TEMP - 190 CONTINUE - 200 CONTINUE - 210 CONTINUE - TEMP = ENORM(N,WA1) - PARC = ((FP/DELTA)/TEMP)/TEMP -C -C DEPENDING ON THE SIGN OF THE FUNCTION, UPDATE PARL OR PARU. -C - IF (FP .GT. ZERO) PARL = MAX(PARL,PAR) - IF (FP .LT. ZERO) PARU = MIN(PARU,PAR) -C -C COMPUTE AN IMPROVED ESTIMATE FOR PAR. -C - PAR = MAX(PARL,PAR+PARC) -C -C END OF AN ITERATION. -C - GO TO 150 - 220 CONTINUE -C -C TERMINATION. -C - IF (ITER .EQ. 0) PAR = ZERO - RETURN -C -C LAST CARD OF SUBROUTINE LMPAR. -C - END diff --git a/slatec/lpdp.f b/slatec/lpdp.f deleted file mode 100644 index 11b0194..0000000 --- a/slatec/lpdp.f +++ /dev/null @@ -1,199 +0,0 @@ -*DECK LPDP - SUBROUTINE LPDP (A, MDA, M, N1, N2, PRGOPT, X, WNORM, MODE, WS, - + IS) -C***BEGIN PROLOGUE LPDP -C***SUBSIDIARY -C***PURPOSE Subsidiary to LSEI -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (LPDP-S, DLPDP-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C DIMENSION A(MDA,N+1),PRGOPT(*),X(N),WS((M+2)*(N+7)),IS(M+N+1), -C where N=N1+N2. This is a slight overestimate for WS(*). -C -C Determine an N1-vector W, and -C an N2-vector Z -C which minimizes the Euclidean length of W -C subject to G*W+H*Z .GE. Y. -C This is the least projected distance problem, LPDP. -C The matrices G and H are of respective -C dimensions M by N1 and M by N2. -C -C Called by subprogram LSI( ). -C -C The matrix -C (G H Y) -C -C occupies rows 1,...,M and cols 1,...,N1+N2+1 of A(*,*). -C -C The solution (W) is returned in X(*). -C (Z) -C -C The value of MODE indicates the status of -C the computation after returning to the user. -C -C MODE=1 The solution was successfully obtained. -C -C MODE=2 The inequalities are inconsistent. -C -C***SEE ALSO LSEI -C***ROUTINES CALLED SCOPY, SDOT, SNRM2, SSCAL, WNNLS -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910408 Updated the AUTHOR section. (WRB) -C***END PROLOGUE LPDP -C -C SUBROUTINES CALLED -C -C WNNLS SOLVES A NONNEGATIVELY CONSTRAINED LINEAR LEAST -C SQUARES PROBLEM WITH LINEAR EQUALITY CONSTRAINTS. -C PART OF THIS PACKAGE. -C -C++ -C SDOT, SUBROUTINES FROM THE BLAS PACKAGE. -C SSCAL,SNRM2, SEE TRANS. MATH. SOFT., VOL. 5, NO. 3, P. 308. -C SCOPY -C - REAL A(MDA,*), PRGOPT(*), WS(*), WNORM, X(*) - INTEGER IS(*) - REAL FAC, ONE, RNORM, SC, YNORM, ZERO - REAL SDOT, SNRM2 - SAVE ZERO, ONE, FAC - DATA ZERO, ONE /0.E0,1.E0/, FAC /0.1E0/ -C***FIRST EXECUTABLE STATEMENT LPDP - N = N1 + N2 - MODE = 1 - IF (.NOT.(M.LE.0)) GO TO 20 - IF (.NOT.(N.GT.0)) GO TO 10 - X(1) = ZERO - CALL SCOPY(N, X, 0, X, 1) - 10 WNORM = ZERO - RETURN - 20 NP1 = N + 1 -C -C SCALE NONZERO ROWS OF INEQUALITY MATRIX TO HAVE LENGTH ONE. - DO 40 I=1,M - SC = SNRM2(N,A(I,1),MDA) - IF (.NOT.(SC.NE.ZERO)) GO TO 30 - SC = ONE/SC - CALL SSCAL(NP1, SC, A(I,1), MDA) - 30 CONTINUE - 40 CONTINUE -C -C SCALE RT.-SIDE VECTOR TO HAVE LENGTH ONE (OR ZERO). - YNORM = SNRM2(M,A(1,NP1),1) - IF (.NOT.(YNORM.NE.ZERO)) GO TO 50 - SC = ONE/YNORM - CALL SSCAL(M, SC, A(1,NP1), 1) -C -C SCALE COLS OF MATRIX H. - 50 J = N1 + 1 - 60 IF (.NOT.(J.LE.N)) GO TO 70 - SC = SNRM2(M,A(1,J),1) - IF (SC.NE.ZERO) SC = ONE/SC - CALL SSCAL(M, SC, A(1,J), 1) - X(J) = SC - J = J + 1 - GO TO 60 - 70 IF (.NOT.(N1.GT.0)) GO TO 130 -C -C COPY TRANSPOSE OF (H G Y) TO WORK ARRAY WS(*). - IW = 0 - DO 80 I=1,M -C -C MOVE COL OF TRANSPOSE OF H INTO WORK ARRAY. - CALL SCOPY(N2, A(I,N1+1), MDA, WS(IW+1), 1) - IW = IW + N2 -C -C MOVE COL OF TRANSPOSE OF G INTO WORK ARRAY. - CALL SCOPY(N1, A(I,1), MDA, WS(IW+1), 1) - IW = IW + N1 -C -C MOVE COMPONENT OF VECTOR Y INTO WORK ARRAY. - WS(IW+1) = A(I,NP1) - IW = IW + 1 - 80 CONTINUE - WS(IW+1) = ZERO - CALL SCOPY(N, WS(IW+1), 0, WS(IW+1), 1) - IW = IW + N - WS(IW+1) = ONE - IW = IW + 1 -C -C SOLVE EU=F SUBJECT TO (TRANSPOSE OF H)U=0, U.GE.0. THE -C MATRIX E = TRANSPOSE OF (G Y), AND THE (N+1)-VECTOR -C F = TRANSPOSE OF (0,...,0,1). - IX = IW + 1 - IW = IW + M -C -C DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF WNNLS( ). - IS(1) = 0 - IS(2) = 0 - CALL WNNLS(WS, NP1, N2, NP1-N2, M, 0, PRGOPT, WS(IX), RNORM, - 1 MODEW, IS, WS(IW+1)) -C -C COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY W. - SC = ONE - SDOT(M,A(1,NP1),1,WS(IX),1) - IF (.NOT.(ONE+FAC*ABS(SC).NE.ONE .AND. RNORM.GT.ZERO)) GO TO 110 - SC = ONE/SC - DO 90 J=1,N1 - X(J) = SC*SDOT(M,A(1,J),1,WS(IX),1) - 90 CONTINUE -C -C COMPUTE THE VECTOR Q=Y-GW. OVERWRITE Y WITH THIS VECTOR. - DO 100 I=1,M - A(I,NP1) = A(I,NP1) - SDOT(N1,A(I,1),MDA,X,1) - 100 CONTINUE - GO TO 120 - 110 MODE = 2 - RETURN - 120 CONTINUE - 130 IF (.NOT.(N2.GT.0)) GO TO 180 -C -C COPY TRANSPOSE OF (H Q) TO WORK ARRAY WS(*). - IW = 0 - DO 140 I=1,M - CALL SCOPY(N2, A(I,N1+1), MDA, WS(IW+1), 1) - IW = IW + N2 - WS(IW+1) = A(I,NP1) - IW = IW + 1 - 140 CONTINUE - WS(IW+1) = ZERO - CALL SCOPY(N2, WS(IW+1), 0, WS(IW+1), 1) - IW = IW + N2 - WS(IW+1) = ONE - IW = IW + 1 - IX = IW + 1 - IW = IW + M -C -C SOLVE RV=S SUBJECT TO V.GE.0. THE MATRIX R =(TRANSPOSE -C OF (H Q)), WHERE Q=Y-GW. THE (N2+1)-VECTOR S =(TRANSPOSE -C OF (0,...,0,1)). -C -C DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF WNNLS( ). - IS(1) = 0 - IS(2) = 0 - CALL WNNLS(WS, N2+1, 0, N2+1, M, 0, PRGOPT, WS(IX), RNORM, MODEW, - 1 IS, WS(IW+1)) -C -C COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY Z. - SC = ONE - SDOT(M,A(1,NP1),1,WS(IX),1) - IF (.NOT.(ONE+FAC*ABS(SC).NE.ONE .AND. RNORM.GT.ZERO)) GO TO 160 - SC = ONE/SC - DO 150 J=1,N2 - L = N1 + J - X(L) = SC*SDOT(M,A(1,L),1,WS(IX),1)*X(L) - 150 CONTINUE - GO TO 170 - 160 MODE = 2 - RETURN - 170 CONTINUE -C -C ACCOUNT FOR SCALING OF RT.-SIDE VECTOR IN SOLUTION. - 180 CALL SSCAL(N, YNORM, X, 1) - WNORM = SNRM2(N1,X,1) - RETURN - END diff --git a/slatec/lsame.f b/slatec/lsame.f deleted file mode 100644 index c329c51..0000000 --- a/slatec/lsame.f +++ /dev/null @@ -1,101 +0,0 @@ -*DECK LSAME - LOGICAL FUNCTION LSAME (CA, CB) -C***BEGIN PROLOGUE LSAME -C***SUBSIDIARY -C***PURPOSE Test two characters to determine if they are the same -C letter, except for case. -C***LIBRARY SLATEC -C***CATEGORY R, N3 -C***TYPE LOGICAL (LSAME-L) -C***KEYWORDS CHARACTER COMPARISON, LEVEL 2 BLAS, LEVEL 3 BLAS -C***AUTHOR Hanson, R., (SNLA) -C Du Croz, J., (NAG) -C***DESCRIPTION -C -C LSAME tests if CA is the same letter as CB regardless of case. -C CB is assumed to be an upper case letter. LSAME returns .TRUE. if -C CA is either the same as CB or the equivalent lower case letter. -C -C N.B. This version of the code is correct for both ASCII and EBCDIC -C systems. Installers must modify the routine for other -C character-codes. -C -C For CDC systems using 6-12 bit representations, the system- -C specific code in comments must be activated. -C -C Parameters -C ========== -C -C CA - CHARACTER*1 -C CB - CHARACTER*1 -C On entry, CA and CB specify characters to be compared. -C Unchanged on exit. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 860720 DATE WRITTEN -C 910606 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C 910607 Modified to handle ASCII and EBCDIC codes. (WRB) -C 930201 Tests for equality and equivalence combined. (RWC and WRB) -C***END PROLOGUE LSAME -C .. Scalar Arguments .. - CHARACTER CA*1, CB*1 -C .. Local Scalars .. - INTEGER IOFF - LOGICAL FIRST -C .. Intrinsic Functions .. - INTRINSIC ICHAR -C .. Save statement .. - SAVE FIRST, IOFF -C .. Data statements .. - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT LSAME - IF (FIRST) IOFF = ICHAR('a') - ICHAR('A') -C - FIRST = .FALSE. -C -C Test if the characters are equal or equivalent. -C - LSAME = (CA.EQ.CB) .OR. (ICHAR(CA)-IOFF.EQ.ICHAR(CB)) -C - RETURN -C -C The following comments contain code for CDC systems using 6-12 bit -C representations. -C -C .. Parameters .. -C INTEGER ICIRFX -C PARAMETER ( ICIRFX=62 ) -C .. Scalar Arguments .. -C CHARACTER*1 CB -C .. Array Arguments .. -C CHARACTER*1 CA(*) -C .. Local Scalars .. -C INTEGER IVAL -C .. Intrinsic Functions .. -C INTRINSIC ICHAR, CHAR -C .. Executable Statements .. -C INTRINSIC ICHAR, CHAR -C -C See if the first character in string CA equals string CB. -C -C LSAME = CA(1) .EQ. CB .AND. CA(1) .NE. CHAR(ICIRFX) -C -C IF (LSAME) RETURN -C -C The characters are not identical. Now check them for equivalence. -C Look for the 'escape' character, circumflex, followed by the -C letter. -C -C IVAL = ICHAR(CA(2)) -C IF (IVAL.GE.ICHAR('A') .AND. IVAL.LE.ICHAR('Z')) THEN -C LSAME = CA(1) .EQ. CHAR(ICIRFX) .AND. CA(2) .EQ. CB -C ENDIF -C -C RETURN -C -C End of LSAME. -C - END diff --git a/slatec/lsei.f b/slatec/lsei.f deleted file mode 100644 index ad0cedd..0000000 --- a/slatec/lsei.f +++ /dev/null @@ -1,733 +0,0 @@ -*DECK LSEI - SUBROUTINE LSEI (W, MDW, ME, MA, MG, N, PRGOPT, X, RNORME, RNORML, - + MODE, WS, IP) -C***BEGIN PROLOGUE LSEI -C***PURPOSE Solve a linearly constrained least squares problem with -C equality and inequality constraints, and optionally compute -C a covariance matrix. -C***LIBRARY SLATEC -C***CATEGORY K1A2A, D9 -C***TYPE SINGLE PRECISION (LSEI-S, DLSEI-D) -C***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, -C EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, -C QUADRATIC PROGRAMMING -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C Abstract -C -C This subprogram solves a linearly constrained least squares -C problem with both equality and inequality constraints, and, if the -C user requests, obtains a covariance matrix of the solution -C parameters. -C -C Suppose there are given matrices E, A and G of respective -C dimensions ME by N, MA by N and MG by N, and vectors F, B and H of -C respective lengths ME, MA and MG. This subroutine solves the -C linearly constrained least squares problem -C -C EX = F, (E ME by N) (equations to be exactly -C satisfied) -C AX = B, (A MA by N) (equations to be -C approximately satisfied, -C least squares sense) -C GX .GE. H,(G MG by N) (inequality constraints) -C -C The inequalities GX .GE. H mean that every component of the -C product GX must be .GE. the corresponding component of H. -C -C In case the equality constraints cannot be satisfied, a -C generalized inverse solution residual vector length is obtained -C for F-EX. This is the minimal length possible for F-EX. -C -C Any values ME .GE. 0, MA .GE. 0, or MG .GE. 0 are permitted. The -C rank of the matrix E is estimated during the computation. We call -C this value KRANKE. It is an output parameter in IP(1) defined -C below. Using a generalized inverse solution of EX=F, a reduced -C least squares problem with inequality constraints is obtained. -C The tolerances used in these tests for determining the rank -C of E and the rank of the reduced least squares problem are -C given in Sandia Tech. Rept. SAND-78-1290. They can be -C modified by the user if new values are provided in -C the option list of the array PRGOPT(*). -C -C The user must dimension all arrays appearing in the call list.. -C W(MDW,N+1),PRGOPT(*),X(N),WS(2*(ME+N)+K+(MG+2)*(N+7)),IP(MG+2*N+2) -C where K=MAX(MA+MG,N). This allows for a solution of a range of -C problems in the given working space. The dimension of WS(*) -C given is a necessary overestimate. Once a particular problem -C has been run, the output parameter IP(3) gives the actual -C dimension required for that problem. -C -C The parameters for LSEI( ) are -C -C Input.. -C -C W(*,*),MDW, The array W(*,*) is doubly subscripted with -C ME,MA,MG,N first dimensioning parameter equal to MDW. -C For this discussion let us call M = ME+MA+MG. Then -C MDW must satisfy MDW .GE. M. The condition -C MDW .LT. M is an error. -C -C The array W(*,*) contains the matrices and vectors -C -C (E F) -C (A B) -C (G H) -C -C in rows and columns 1,...,M and 1,...,N+1 -C respectively. -C -C The integers ME, MA, and MG are the -C respective matrix row dimensions -C of E, A and G. Each matrix has N columns. -C -C PRGOPT(*) This real-valued array is the option vector. -C If the user is satisfied with the nominal -C subprogram features set -C -C PRGOPT(1)=1 (or PRGOPT(1)=1.0) -C -C Otherwise PRGOPT(*) is a linked list consisting of -C groups of data of the following form -C -C LINK -C KEY -C DATA SET -C -C The parameters LINK and KEY are each one word. -C The DATA SET can be comprised of several words. -C The number of items depends on the value of KEY. -C The value of LINK points to the first -C entry of the next group of data within -C PRGOPT(*). The exception is when there are -C no more options to change. In that -C case, LINK=1 and the values KEY and DATA SET -C are not referenced. The general layout of -C PRGOPT(*) is as follows. -C -C ...PRGOPT(1) = LINK1 (link to first entry of next group) -C . PRGOPT(2) = KEY1 (key to the option change) -C . PRGOPT(3) = data value (data value for this change) -C . . -C . . -C . . -C ...PRGOPT(LINK1) = LINK2 (link to the first entry of -C . next group) -C . PRGOPT(LINK1+1) = KEY2 (key to the option change) -C . PRGOPT(LINK1+2) = data value -C ... . -C . . -C . . -C ...PRGOPT(LINK) = 1 (no more options to change) -C -C Values of LINK that are nonpositive are errors. -C A value of LINK .GT. NLINK=100000 is also an error. -C This helps prevent using invalid but positive -C values of LINK that will probably extend -C beyond the program limits of PRGOPT(*). -C Unrecognized values of KEY are ignored. The -C order of the options is arbitrary and any number -C of options can be changed with the following -C restriction. To prevent cycling in the -C processing of the option array, a count of the -C number of options changed is maintained. -C Whenever this count exceeds NOPT=1000, an error -C message is printed and the subprogram returns. -C -C Options.. -C -C KEY=1 -C Compute in W(*,*) the N by N -C covariance matrix of the solution variables -C as an output parameter. Nominally the -C covariance matrix will not be computed. -C (This requires no user input.) -C The data set for this option is a single value. -C It must be nonzero when the covariance matrix -C is desired. If it is zero, the covariance -C matrix is not computed. When the covariance matrix -C is computed, the first dimensioning parameter -C of the array W(*,*) must satisfy MDW .GE. MAX(M,N). -C -C KEY=10 -C Suppress scaling of the inverse of the -C normal matrix by the scale factor RNORM**2/ -C MAX(1, no. of degrees of freedom). This option -C only applies when the option for computing the -C covariance matrix (KEY=1) is used. With KEY=1 and -C KEY=10 used as options the unscaled inverse of the -C normal matrix is returned in W(*,*). -C The data set for this option is a single value. -C When it is nonzero no scaling is done. When it is -C zero scaling is done. The nominal case is to do -C scaling so if option (KEY=1) is used alone, the -C matrix will be scaled on output. -C -C KEY=2 -C Scale the nonzero columns of the -C entire data matrix. -C (E) -C (A) -C (G) -C -C to have length one. The data set for this -C option is a single value. It must be -C nonzero if unit length column scaling -C is desired. -C -C KEY=3 -C Scale columns of the entire data matrix -C (E) -C (A) -C (G) -C -C with a user-provided diagonal matrix. -C The data set for this option consists -C of the N diagonal scaling factors, one for -C each matrix column. -C -C KEY=4 -C Change the rank determination tolerance for -C the equality constraint equations from -C the nominal value of SQRT(SRELPR). This quantity can -C be no smaller than SRELPR, the arithmetic- -C storage precision. The quantity SRELPR is the -C largest positive number such that T=1.+SRELPR -C satisfies T .EQ. 1. The quantity used -C here is internally restricted to be at -C least SRELPR. The data set for this option -C is the new tolerance. -C -C KEY=5 -C Change the rank determination tolerance for -C the reduced least squares equations from -C the nominal value of SQRT(SRELPR). This quantity can -C be no smaller than SRELPR, the arithmetic- -C storage precision. The quantity used -C here is internally restricted to be at -C least SRELPR. The data set for this option -C is the new tolerance. -C -C For example, suppose we want to change -C the tolerance for the reduced least squares -C problem, compute the covariance matrix of -C the solution parameters, and provide -C column scaling for the data matrix. For -C these options the dimension of PRGOPT(*) -C must be at least N+9. The Fortran statements -C defining these options would be as follows: -C -C PRGOPT(1)=4 (link to entry 4 in PRGOPT(*)) -C PRGOPT(2)=1 (covariance matrix key) -C PRGOPT(3)=1 (covariance matrix wanted) -C -C PRGOPT(4)=7 (link to entry 7 in PRGOPT(*)) -C PRGOPT(5)=5 (least squares equas. tolerance key) -C PRGOPT(6)=... (new value of the tolerance) -C -C PRGOPT(7)=N+9 (link to entry N+9 in PRGOPT(*)) -C PRGOPT(8)=3 (user-provided column scaling key) -C -C CALL SCOPY (N, D, 1, PRGOPT(9), 1) (Copy the N -C scaling factors from the user array D(*) -C to PRGOPT(9)-PRGOPT(N+8)) -C -C PRGOPT(N+9)=1 (no more options to change) -C -C The contents of PRGOPT(*) are not modified -C by the subprogram. -C The options for WNNLS( ) can also be included -C in this array. The values of KEY recognized -C by WNNLS( ) are 6, 7 and 8. Their functions -C are documented in the usage instructions for -C subroutine WNNLS( ). Normally these options -C do not need to be modified when using LSEI( ). -C -C IP(1), The amounts of working storage actually -C IP(2) allocated for the working arrays WS(*) and -C IP(*), respectively. These quantities are -C compared with the actual amounts of storage -C needed by LSEI( ). Insufficient storage -C allocated for either WS(*) or IP(*) is an -C error. This feature was included in LSEI( ) -C because miscalculating the storage formulas -C for WS(*) and IP(*) might very well lead to -C subtle and hard-to-find execution errors. -C -C The length of WS(*) must be at least -C -C LW = 2*(ME+N)+K+(MG+2)*(N+7) -C -C where K = max(MA+MG,N) -C This test will not be made if IP(1).LE.0. -C -C The length of IP(*) must be at least -C -C LIP = MG+2*N+2 -C This test will not be made if IP(2).LE.0. -C -C Output.. -C -C X(*),RNORME, The array X(*) contains the solution parameters -C RNORML if the integer output flag MODE = 0 or 1. -C The definition of MODE is given directly below. -C When MODE = 0 or 1, RNORME and RNORML -C respectively contain the residual vector -C Euclidean lengths of F - EX and B - AX. When -C MODE=1 the equality constraint equations EX=F -C are contradictory, so RNORME .NE. 0. The residual -C vector F-EX has minimal Euclidean length. For -C MODE .GE. 2, none of these parameters is defined. -C -C MODE Integer flag that indicates the subprogram -C status after completion. If MODE .GE. 2, no -C solution has been computed. -C -C MODE = -C -C 0 Both equality and inequality constraints -C are compatible and have been satisfied. -C -C 1 Equality constraints are contradictory. -C A generalized inverse solution of EX=F was used -C to minimize the residual vector length F-EX. -C In this sense, the solution is still meaningful. -C -C 2 Inequality constraints are contradictory. -C -C 3 Both equality and inequality constraints -C are contradictory. -C -C The following interpretation of -C MODE=1,2 or 3 must be made. The -C sets consisting of all solutions -C of the equality constraints EX=F -C and all vectors satisfying GX .GE. H -C have no points in common. (In -C particular this does not say that -C each individual set has no points -C at all, although this could be the -C case.) -C -C 4 Usage error occurred. The value -C of MDW is .LT. ME+MA+MG, MDW is -C .LT. N and a covariance matrix is -C requested, or the option vector -C PRGOPT(*) is not properly defined, -C or the lengths of the working arrays -C WS(*) and IP(*), when specified in -C IP(1) and IP(2) respectively, are not -C long enough. -C -C W(*,*) The array W(*,*) contains the N by N symmetric -C covariance matrix of the solution parameters, -C provided this was requested on input with -C the option vector PRGOPT(*) and the output -C flag is returned with MODE = 0 or 1. -C -C IP(*) The integer working array has three entries -C that provide rank and working array length -C information after completion. -C -C IP(1) = rank of equality constraint -C matrix. Define this quantity -C as KRANKE. -C -C IP(2) = rank of reduced least squares -C problem. -C -C IP(3) = the amount of storage in the -C working array WS(*) that was -C actually used by the subprogram. -C The formula given above for the length -C of WS(*) is a necessary overestimate. -C If exactly the same problem matrices -C are used in subsequent executions, -C the declared dimension of WS(*) can -C be reduced to this output value. -C User Designated -C Working Arrays.. -C -C WS(*),IP(*) These are respectively type real -C and type integer working arrays. -C Their required minimal lengths are -C given above. -C -C***REFERENCES K. H. Haskell and R. J. Hanson, An algorithm for -C linear least squares problems with equality and -C nonnegativity constraints, Report SAND77-0552, Sandia -C Laboratories, June 1978. -C K. H. Haskell and R. J. Hanson, Selected algorithms for -C the linearly constrained least squares problem - a -C users guide, Report SAND78-1290, Sandia Laboratories, -C August 1979. -C K. H. Haskell and R. J. Hanson, An algorithm for -C linear least squares problems with equality and -C nonnegativity constraints, Mathematical Programming -C 21 (1981), pp. 98-118. -C R. J. Hanson and K. H. Haskell, Two algorithms for the -C linearly constrained least squares problem, ACM -C Transactions on Mathematical Software, September 1982. -C***ROUTINES CALLED H12, LSI, R1MACH, SASUM, SAXPY, SCOPY, SDOT, SNRM2, -C SSCAL, SSWAP, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and extensively revised (WRB & RWC) -C 890831 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 LSEI - INTEGER IP(3), MA, MDW, ME, MG, MODE, N - REAL PRGOPT(*), RNORME, RNORML, W(MDW,*), WS(*), X(*) -C - EXTERNAL H12, LSI, R1MACH, SASUM, SAXPY, SCOPY, SDOT, SNRM2, - * SSCAL, SSWAP, XERMSG - REAL R1MACH, SASUM, SDOT, SNRM2 -C - REAL ENORM, FNORM, GAM, RB, RN, RNMAX, SIZE, SN, - * SNMAX, SRELPR, T, TAU, UJ, UP, VJ, XNORM, XNRME - INTEGER I, IMAX, J, JP1, K, KEY, KRANKE, LAST, LCHK, LINK, M, - * MAPKE1, MDEQC, MEND, MEP1, N1, N2, NEXT, NLINK, NOPT, NP1, - * NTIMES - LOGICAL COV, FIRST - CHARACTER*8 XERN1, XERN2, XERN3, XERN4 - SAVE FIRST, SRELPR -C - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT LSEI -C -C Set the nominal tolerance used in the code for the equality -C constraint equations. -C - IF (FIRST) SRELPR = R1MACH(4) - FIRST = .FALSE. - TAU = SQRT(SRELPR) -C -C Check that enough storage was allocated in WS(*) and IP(*). -C - MODE = 4 - IF (MIN(N,ME,MA,MG) .LT. 0) THEN - WRITE (XERN1, '(I8)') N - WRITE (XERN2, '(I8)') ME - WRITE (XERN3, '(I8)') MA - WRITE (XERN4, '(I8)') MG - CALL XERMSG ('SLATEC', 'LSEI', 'ALL OF THE VARIABLES N, ME,' // - * ' MA, MG MUST BE .GE. 0$$ENTERED ROUTINE WITH' // - * '$$N = ' // XERN1 // - * '$$ME = ' // XERN2 // - * '$$MA = ' // XERN3 // - * '$$MG = ' // XERN4, 2, 1) - RETURN - ENDIF -C - IF (IP(1).GT.0) THEN - LCHK = 2*(ME+N) + MAX(MA+MG,N) + (MG+2)*(N+7) - IF (IP(1).LT.LCHK) THEN - WRITE (XERN1, '(I8)') LCHK - CALL XERMSG ('SLATEC', 'LSEI', 'INSUFFICIENT STORAGE ' // - * 'ALLOCATED FOR WS(*), NEED LW = ' // XERN1, 2, 1) - RETURN - ENDIF - ENDIF -C - IF (IP(2).GT.0) THEN - LCHK = MG + 2*N + 2 - IF (IP(2).LT.LCHK) THEN - WRITE (XERN1, '(I8)') LCHK - CALL XERMSG ('SLATEC', 'LSEI', 'INSUFFICIENT STORAGE ' // - * 'ALLOCATED FOR IP(*), NEED LIP = ' // XERN1, 2, 1) - RETURN - ENDIF - ENDIF -C -C Compute number of possible right multiplying Householder -C transformations. -C - M = ME + MA + MG - IF (N.LE.0 .OR. M.LE.0) THEN - MODE = 0 - RNORME = 0 - RNORML = 0 - RETURN - ENDIF -C - IF (MDW.LT.M) THEN - CALL XERMSG ('SLATEC', 'LSEI', 'MDW.LT.ME+MA+MG IS AN ERROR', - + 2, 1) - RETURN - ENDIF -C - NP1 = N + 1 - KRANKE = MIN(ME,N) - N1 = 2*KRANKE + 1 - N2 = N1 + N -C -C Set nominal values. -C -C The nominal column scaling used in the code is -C the identity scaling. -C - CALL SCOPY (N, 1.E0, 0, WS(N1), 1) -C -C No covariance matrix is nominally computed. -C - COV = .FALSE. -C -C Process option vector. -C Define bound for number of options to change. -C - NOPT = 1000 - NTIMES = 0 -C -C Define bound for positive values of LINK. -C - NLINK = 100000 - LAST = 1 - LINK = PRGOPT(1) - IF (LINK.EQ.0 .OR. LINK.GT.NLINK) THEN - CALL XERMSG ('SLATEC', 'LSEI', - + 'THE OPTION VECTOR IS UNDEFINED', 2, 1) - RETURN - ENDIF -C - 100 IF (LINK.GT.1) THEN - NTIMES = NTIMES + 1 - IF (NTIMES.GT.NOPT) THEN - CALL XERMSG ('SLATEC', 'LSEI', - + 'THE LINKS IN THE OPTION VECTOR ARE CYCLING.', 2, 1) - RETURN - ENDIF -C - KEY = PRGOPT(LAST+1) - IF (KEY.EQ.1) THEN - COV = PRGOPT(LAST+2) .NE. 0.E0 - ELSEIF (KEY.EQ.2 .AND. PRGOPT(LAST+2).NE.0.E0) THEN - DO 110 J = 1,N - T = SNRM2(M,W(1,J),1) - IF (T.NE.0.E0) T = 1.E0/T - WS(J+N1-1) = T - 110 CONTINUE - ELSEIF (KEY.EQ.3) THEN - CALL SCOPY (N, PRGOPT(LAST+2), 1, WS(N1), 1) - ELSEIF (KEY.EQ.4) THEN - TAU = MAX(SRELPR,PRGOPT(LAST+2)) - ENDIF -C - NEXT = PRGOPT(LINK) - IF (NEXT.LE.0 .OR. NEXT.GT.NLINK) THEN - CALL XERMSG ('SLATEC', 'LSEI', - + 'THE OPTION VECTOR IS UNDEFINED', 2, 1) - RETURN - ENDIF -C - LAST = LINK - LINK = NEXT - GO TO 100 - ENDIF -C - DO 120 J = 1,N - CALL SSCAL (M, WS(N1+J-1), W(1,J), 1) - 120 CONTINUE -C - IF (COV .AND. MDW.LT.N) THEN - CALL XERMSG ('SLATEC', 'LSEI', - + 'MDW .LT. N WHEN COV MATRIX NEEDED, IS AN ERROR', 2, 1) - RETURN - ENDIF -C -C Problem definition and option vector OK. -C - MODE = 0 -C -C Compute norm of equality constraint matrix and right side. -C - ENORM = 0.E0 - DO 130 J = 1,N - ENORM = MAX(ENORM,SASUM(ME,W(1,J),1)) - 130 CONTINUE -C - FNORM = SASUM(ME,W(1,NP1),1) - SNMAX = 0.E0 - RNMAX = 0.E0 - DO 150 I = 1,KRANKE -C -C Compute maximum ratio of vector lengths. Partition is at -C column I. -C - DO 140 K = I,ME - SN = SDOT(N-I+1,W(K,I),MDW,W(K,I),MDW) - RN = SDOT(I-1,W(K,1),MDW,W(K,1),MDW) - IF (RN.EQ.0.E0 .AND. SN.GT.SNMAX) THEN - SNMAX = SN - IMAX = K - ELSEIF (K.EQ.I .OR. SN*RNMAX.GT.RN*SNMAX) THEN - SNMAX = SN - RNMAX = RN - IMAX = K - ENDIF - 140 CONTINUE -C -C Interchange rows if necessary. -C - IF (I.NE.IMAX) CALL SSWAP (NP1, W(I,1), MDW, W(IMAX,1), MDW) - IF (SNMAX.GT.RNMAX*TAU**2) THEN -C -C Eliminate elements I+1,...,N in row I. -C - CALL H12 (1, I, I+1, N, W(I,1), MDW, WS(I), W(I+1,1), MDW, - + 1, M-I) - ELSE - KRANKE = I - 1 - GO TO 160 - ENDIF - 150 CONTINUE -C -C Save diagonal terms of lower trapezoidal matrix. -C - 160 CALL SCOPY (KRANKE, W, MDW+1, WS(KRANKE+1), 1) -C -C Use Householder transformation from left to achieve -C KRANKE by KRANKE upper triangular form. -C - IF (KRANKE.LT.ME) THEN - DO 170 K = KRANKE,1,-1 -C -C Apply transformation to matrix cols. 1,...,K-1. -C - CALL H12 (1, K, KRANKE+1, ME, W(1,K), 1, UP, W, 1, MDW, K-1) -C -C Apply to rt side vector. -C - CALL H12 (2, K, KRANKE+1, ME, W(1,K), 1, UP, W(1,NP1), 1, 1, - + 1) - 170 CONTINUE - ENDIF -C -C Solve for variables 1,...,KRANKE in new coordinates. -C - CALL SCOPY (KRANKE, W(1, NP1), 1, X, 1) - DO 180 I = 1,KRANKE - X(I) = (X(I)-SDOT(I-1,W(I,1),MDW,X,1))/W(I,I) - 180 CONTINUE -C -C Compute residuals for reduced problem. -C - MEP1 = ME + 1 - RNORML = 0.E0 - DO 190 I = MEP1,M - W(I,NP1) = W(I,NP1) - SDOT(KRANKE,W(I,1),MDW,X,1) - SN = SDOT(KRANKE,W(I,1),MDW,W(I,1),MDW) - RN = SDOT(N-KRANKE,W(I,KRANKE+1),MDW,W(I,KRANKE+1),MDW) - IF (RN.LE.SN*TAU**2 .AND. KRANKE.LT.N) - * CALL SCOPY (N-KRANKE, 0.E0, 0, W(I,KRANKE+1), MDW) - 190 CONTINUE -C -C Compute equality constraint equations residual length. -C - RNORME = SNRM2(ME-KRANKE,W(KRANKE+1,NP1),1) -C -C Move reduced problem data upward if KRANKE.LT.ME. -C - IF (KRANKE.LT.ME) THEN - DO 200 J = 1,NP1 - CALL SCOPY (M-ME, W(ME+1,J), 1, W(KRANKE+1,J), 1) - 200 CONTINUE - ENDIF -C -C Compute solution of reduced problem. -C - CALL LSI(W(KRANKE+1, KRANKE+1), MDW, MA, MG, N-KRANKE, PRGOPT, - + X(KRANKE+1), RNORML, MODE, WS(N2), IP(2)) -C -C Test for consistency of equality constraints. -C - IF (ME.GT.0) THEN - MDEQC = 0 - XNRME = SASUM(KRANKE,W(1,NP1),1) - IF (RNORME.GT.TAU*(ENORM*XNRME+FNORM)) MDEQC = 1 - MODE = MODE + MDEQC -C -C Check if solution to equality constraints satisfies inequality -C constraints when there are no degrees of freedom left. -C - IF (KRANKE.EQ.N .AND. MG.GT.0) THEN - XNORM = SASUM(N,X,1) - MAPKE1 = MA + KRANKE + 1 - MEND = MA + KRANKE + MG - DO 210 I = MAPKE1,MEND - SIZE = SASUM(N,W(I,1),MDW)*XNORM + ABS(W(I,NP1)) - IF (W(I,NP1).GT.TAU*SIZE) THEN - MODE = MODE + 2 - GO TO 290 - ENDIF - 210 CONTINUE - ENDIF - ENDIF -C -C Replace diagonal terms of lower trapezoidal matrix. -C - IF (KRANKE.GT.0) THEN - CALL SCOPY (KRANKE, WS(KRANKE+1), 1, W, MDW+1) -C -C Reapply transformation to put solution in original coordinates. -C - DO 220 I = KRANKE,1,-1 - CALL H12 (2, I, I+1, N, W(I,1), MDW, WS(I), X, 1, 1, 1) - 220 CONTINUE -C -C Compute covariance matrix of equality constrained problem. -C - IF (COV) THEN - DO 270 J = MIN(KRANKE,N-1),1,-1 - RB = WS(J)*W(J,J) - IF (RB.NE.0.E0) RB = 1.E0/RB - JP1 = J + 1 - DO 230 I = JP1,N - W(I,J) = RB*SDOT(N-J,W(I,JP1),MDW,W(J,JP1),MDW) - 230 CONTINUE -C - GAM = 0.5E0*RB*SDOT(N-J,W(JP1,J),1,W(J,JP1),MDW) - CALL SAXPY (N-J, GAM, W(J,JP1), MDW, W(JP1,J), 1) - DO 250 I = JP1,N - DO 240 K = I,N - W(I,K) = W(I,K) + W(J,I)*W(K,J) + W(I,J)*W(J,K) - W(K,I) = W(I,K) - 240 CONTINUE - 250 CONTINUE - UJ = WS(J) - VJ = GAM*UJ - W(J,J) = UJ*VJ + UJ*VJ - DO 260 I = JP1,N - W(J,I) = UJ*W(I,J) + VJ*W(J,I) - 260 CONTINUE - CALL SCOPY (N-J, W(J, JP1), MDW, W(JP1,J), 1) - 270 CONTINUE - ENDIF - ENDIF -C -C Apply the scaling to the covariance matrix. -C - IF (COV) THEN - DO 280 I = 1,N - CALL SSCAL (N, WS(I+N1-1), W(I,1), MDW) - CALL SSCAL (N, WS(I+N1-1), W(1,I), 1) - 280 CONTINUE - ENDIF -C -C Rescale solution vector. -C - 290 IF (MODE.LE.1) THEN - DO 300 J = 1,N - X(J) = X(J)*WS(N1+J-1) - 300 CONTINUE - ENDIF -C - IP(1) = KRANKE - IP(3) = IP(3) + 2*KRANKE + N - RETURN - END diff --git a/slatec/lsi.f b/slatec/lsi.f deleted file mode 100644 index 2795fe1..0000000 --- a/slatec/lsi.f +++ /dev/null @@ -1,336 +0,0 @@ -*DECK LSI - SUBROUTINE LSI (W, MDW, MA, MG, N, PRGOPT, X, RNORM, MODE, WS, IP) -C***BEGIN PROLOGUE LSI -C***SUBSIDIARY -C***PURPOSE Subsidiary to LSEI -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (LSI-S, DLSI-D) -C***AUTHOR Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C This is a companion subprogram to LSEI. The documentation for -C LSEI has complete usage instructions. -C -C Solve.. -C AX = B, A MA by N (least squares equations) -C subject to.. -C -C GX.GE.H, G MG by N (inequality constraints) -C -C Input.. -C -C W(*,*) contains (A B) in rows 1,...,MA+MG, cols 1,...,N+1. -C (G H) -C -C MDW,MA,MG,N -C contain (resp) var. dimension of W(*,*), -C and matrix dimensions. -C -C PRGOPT(*), -C Program option vector. -C -C OUTPUT.. -C -C X(*),RNORM -C -C Solution vector(unless MODE=2), length of AX-B. -C -C MODE -C =0 Inequality constraints are compatible. -C =2 Inequality constraints contradictory. -C -C WS(*), -C Working storage of dimension K+N+(MG+2)*(N+7), -C where K=MAX(MA+MG,N). -C IP(MG+2*N+1) -C Integer working storage -C -C***ROUTINES CALLED H12, HFTI, LPDP, R1MACH, SASUM, SAXPY, SCOPY, SDOT, -C SSCAL, SSWAP -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and extensively revised (WRB & RWC) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 920422 Changed CALL to HFTI to include variable MA. (WRB) -C***END PROLOGUE LSI - INTEGER IP(*), MA, MDW, MG, MODE, N - REAL PRGOPT(*), RNORM, W(MDW,*), WS(*), X(*) -C - EXTERNAL H12, HFTI, LPDP, R1MACH, SASUM, SAXPY, SCOPY, SDOT, - * SSCAL, SSWAP - REAL R1MACH, SASUM, SDOT -C - REAL ANORM, FAC, GAM, RB, SRELPR, TAU, TOL, XNORM - INTEGER I, J, K, KEY, KRANK, KRM1, KRP1, L, LAST, LINK, M, MAP1, - * MDLPDP, MINMAN, N1, N2, N3, NEXT, NP1 - LOGICAL COV, FIRST, SCLCOV -C - SAVE SRELPR, FIRST - DATA FIRST /.TRUE./ -C -C***FIRST EXECUTABLE STATEMENT LSI -C -C Set the nominal tolerance used in the code. -C - IF (FIRST) SRELPR = R1MACH(4) - FIRST = .FALSE. - TOL = SQRT(SRELPR) -C - MODE = 0 - RNORM = 0.E0 - M = MA + MG - NP1 = N + 1 - KRANK = 0 - IF (N.LE.0 .OR. M.LE.0) GO TO 370 -C -C To process option vector. -C - COV = .FALSE. - SCLCOV = .TRUE. - LAST = 1 - LINK = PRGOPT(1) -C - 100 IF (LINK.GT.1) THEN - KEY = PRGOPT(LAST+1) - IF (KEY.EQ.1) COV = PRGOPT(LAST+2) .NE. 0.E0 - IF (KEY.EQ.10) SCLCOV = PRGOPT(LAST+2) .EQ. 0.E0 - IF (KEY.EQ.5) TOL = MAX(SRELPR,PRGOPT(LAST+2)) - NEXT = PRGOPT(LINK) - LAST = LINK - LINK = NEXT - GO TO 100 - ENDIF -C -C Compute matrix norm of least squares equations. -C - ANORM = 0.E0 - DO 110 J = 1,N - ANORM = MAX(ANORM,SASUM(MA,W(1,J),1)) - 110 CONTINUE -C -C Set tolerance for HFTI( ) rank test. -C - TAU = TOL*ANORM -C -C Compute Householder orthogonal decomposition of matrix. -C - CALL SCOPY (N, 0.E0, 0, WS, 1) - CALL SCOPY (MA, W(1, NP1), 1, WS, 1) - K = MAX(M,N) - MINMAN = MIN(MA,N) - N1 = K + 1 - N2 = N1 + N - CALL HFTI (W, MDW, MA, N, WS, MA, 1, TAU, KRANK, RNORM, WS(N2), - + WS(N1), IP) - FAC = 1.E0 - GAM = MA - KRANK - IF (KRANK.LT.MA .AND. SCLCOV) FAC = RNORM**2/GAM -C -C Reduce to LPDP and solve. -C - MAP1 = MA + 1 -C -C Compute inequality rt-hand side for LPDP. -C - IF (MA.LT.M) THEN - IF (MINMAN.GT.0) THEN - DO 120 I = MAP1,M - W(I,NP1) = W(I,NP1) - SDOT(N,W(I,1),MDW,WS,1) - 120 CONTINUE -C -C Apply permutations to col. of inequality constraint matrix. -C - DO 130 I = 1,MINMAN - CALL SSWAP (MG, W(MAP1,I), 1, W(MAP1,IP(I)), 1) - 130 CONTINUE -C -C Apply Householder transformations to constraint matrix. -C - IF (KRANK.GT.0 .AND. KRANK.LT.N) THEN - DO 140 I = KRANK,1,-1 - CALL H12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1), - + W(MAP1,1), MDW, 1, MG) - 140 CONTINUE - ENDIF -C -C Compute permuted inequality constraint matrix times r-inv. -C - DO 160 I = MAP1,M - DO 150 J = 1,KRANK - W(I,J) = (W(I,J)-SDOT(J-1,W(1,J),1,W(I,1),MDW))/W(J,J) - 150 CONTINUE - 160 CONTINUE - ENDIF -C -C Solve the reduced problem with LPDP algorithm, -C the least projected distance problem. -C - CALL LPDP(W(MAP1,1), MDW, MG, KRANK, N-KRANK, PRGOPT, X, - + XNORM, MDLPDP, WS(N2), IP(N+1)) -C -C Compute solution in original coordinates. -C - IF (MDLPDP.EQ.1) THEN - DO 170 I = KRANK,1,-1 - X(I) = (X(I)-SDOT(KRANK-I,W(I,I+1),MDW,X(I+1),1))/W(I,I) - 170 CONTINUE -C -C Apply Householder transformation to solution vector. -C - IF (KRANK.LT.N) THEN - DO 180 I = 1,KRANK - CALL H12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1), - + X, 1, 1, 1) - 180 CONTINUE - ENDIF -C -C Repermute variables to their input order. -C - IF (MINMAN.GT.0) THEN - DO 190 I = MINMAN,1,-1 - CALL SSWAP (1, X(I), 1, X(IP(I)), 1) - 190 CONTINUE -C -C Variables are now in original coordinates. -C Add solution of unconstrained problem. -C - DO 200 I = 1,N - X(I) = X(I) + WS(I) - 200 CONTINUE -C -C Compute the residual vector norm. -C - RNORM = SQRT(RNORM**2+XNORM**2) - ENDIF - ELSE - MODE = 2 - ENDIF - ELSE - CALL SCOPY (N, WS, 1, X, 1) - ENDIF -C -C Compute covariance matrix based on the orthogonal decomposition -C from HFTI( ). -C - IF (.NOT.COV .OR. KRANK.LE.0) GO TO 370 - KRM1 = KRANK - 1 - KRP1 = KRANK + 1 -C -C Copy diagonal terms to working array. -C - CALL SCOPY (KRANK, W, MDW+1, WS(N2), 1) -C -C Reciprocate diagonal terms. -C - DO 210 J = 1,KRANK - W(J,J) = 1.E0/W(J,J) - 210 CONTINUE -C -C Invert the upper triangular QR factor on itself. -C - IF (KRANK.GT.1) THEN - DO 230 I = 1,KRM1 - DO 220 J = I+1,KRANK - W(I,J) = -SDOT(J-I,W(I,I),MDW,W(I,J),1)*W(J,J) - 220 CONTINUE - 230 CONTINUE - ENDIF -C -C Compute the inverted factor times its transpose. -C - DO 250 I = 1,KRANK - DO 240 J = I,KRANK - W(I,J) = SDOT(KRANK+1-J,W(I,J),MDW,W(J,J),MDW) - 240 CONTINUE - 250 CONTINUE -C -C Zero out lower trapezoidal part. -C Copy upper triangular to lower triangular part. -C - IF (KRANK.LT.N) THEN - DO 260 J = 1,KRANK - CALL SCOPY (J, W(1,J), 1, W(J,1), MDW) - 260 CONTINUE -C - DO 270 I = KRP1,N - CALL SCOPY (I, 0.E0, 0, W(I,1), MDW) - 270 CONTINUE -C -C Apply right side transformations to lower triangle. -C - N3 = N2 + KRP1 - DO 330 I = 1,KRANK - L = N1 + I - K = N2 + I - RB = WS(L-1)*WS(K-1) -C -C If RB.GE.0.E0, transformation can be regarded as zero. -C - IF (RB.LT.0.E0) THEN - RB = 1.E0/RB -C -C Store unscaled rank one Householder update in work array. -C - CALL SCOPY (N, 0.E0, 0, WS(N3), 1) - L = N1 + I - K = N3 + I - WS(K-1) = WS(L-1) -C - DO 280 J = KRP1,N - WS(N3+J-1) = W(I,J) - 280 CONTINUE -C - DO 290 J = 1,N - WS(J) = RB*(SDOT(J-I,W(J,I),MDW,WS(N3+I-1),1)+ - + SDOT(N-J+1,W(J,J),1,WS(N3+J-1),1)) - 290 CONTINUE -C - L = N3 + I - GAM = 0.5E0*RB*SDOT(N-I+1,WS(L-1),1,WS(I),1) - CALL SAXPY (N-I+1, GAM, WS(L-1), 1, WS(I), 1) - DO 320 J = I,N - DO 300 L = 1,I-1 - W(J,L) = W(J,L) + WS(N3+J-1)*WS(L) - 300 CONTINUE -C - DO 310 L = I,J - W(J,L) = W(J,L) + WS(J)*WS(N3+L-1)+WS(L)*WS(N3+J-1) - 310 CONTINUE - 320 CONTINUE - ENDIF - 330 CONTINUE -C -C Copy lower triangle to upper triangle to symmetrize the -C covariance matrix. -C - DO 340 I = 1,N - CALL SCOPY (I, W(I,1), MDW, W(1,I), 1) - 340 CONTINUE - ENDIF -C -C Repermute rows and columns. -C - DO 350 I = MINMAN,1,-1 - K = IP(I) - IF (I.NE.K) THEN - CALL SSWAP (1, W(I,I), 1, W(K,K), 1) - CALL SSWAP (I-1, W(1,I), 1, W(1,K), 1) - CALL SSWAP (K-I-1, W(I,I+1), MDW, W(I+1,K), 1) - CALL SSWAP (N-K, W(I, K+1), MDW, W(K, K+1), MDW) - ENDIF - 350 CONTINUE -C -C Put in normalized residual sum of squares scale factor -C and symmetrize the resulting covariance matrix. -C - DO 360 J = 1,N - CALL SSCAL (J, FAC, W(1,J), 1) - CALL SCOPY (J, W(1,J), 1, W(J,1), MDW) - 360 CONTINUE -C - 370 IP(1) = KRANK - IP(2) = N + MAX(M,N) + (MG+2)*(N+7) - RETURN - END diff --git a/slatec/lsod.f b/slatec/lsod.f deleted file mode 100644 index aa9432a..0000000 --- a/slatec/lsod.f +++ /dev/null @@ -1,409 +0,0 @@ -*DECK LSOD - SUBROUTINE LSOD (F, NEQ, T, Y, TOUT, RTOL, ATOL, IDID, YPOUT, YH, - + YH1, EWT, SAVF, ACOR, WM, IWM, JAC, INTOUT, TSTOP, TOLFAC, - + DELSGN, RPAR, IPAR) -C***BEGIN PROLOGUE LSOD -C***SUBSIDIARY -C***PURPOSE Subsidiary to DEBDF -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (LSOD-S, DLSOD-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C DEBDF merely allocates storage for LSOD to relieve the user of -C the inconvenience of a long call list. Consequently LSOD is used -C as described in the comments for DEBDF . -C -C***SEE ALSO DEBDF -C***ROUTINES CALLED HSTART, INTYD, R1MACH, STOD, VNWRMS, XERMSG -C***COMMON BLOCKS DEBDF1 -C***REVISION HISTORY (YYMMDD) -C 800901 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C***END PROLOGUE LSOD -C -C - LOGICAL INTOUT -C - DIMENSION Y(*),YPOUT(*),YH(NEQ,6),YH1(*),EWT(*),SAVF(*), - 1 ACOR(*),WM(*),IWM(*),RTOL(*),ATOL(*),RPAR(*),IPAR(*) - CHARACTER*8 XERN1 - CHARACTER*16 XERN3, XERN4 -C - COMMON /DEBDF1/ TOLD, ROWNS(210), - 1 EL0, H, HMIN, HMXI, HU, X, U, - 2 IQUIT, INIT, LYH, LEWT, LACOR, LSAVF, LWM, KSTEPS, - 3 IBEGIN, ITOL, IINTEG, ITSTOP, IJAC, IBAND, IOWNS(6), - 4 IER, JSTART, KFLAG, LDUM, METH, MITER, MAXORD, N, NQ, NST, - 5 NFE, NJE, NQU -C - EXTERNAL F, JAC -C -C....................................................................... -C -C THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE -C NUMBER OF STEPS ATTEMPTED. WHEN THIS EXCEEDS MAXNUM, THE COUNTER -C IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE EXCESSIVE -C WORK. -C - SAVE MAXNUM - DATA MAXNUM/500/ -C -C....................................................................... -C -C***FIRST EXECUTABLE STATEMENT LSOD - IF (IBEGIN .EQ. 0) THEN -C -C ON THE FIRST CALL , PERFORM INITIALIZATION -- -C DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY U BY CALLING THE -C FUNCTION ROUTINE R1MACH. THE USER MUST MAKE SURE THAT THE -C VALUES SET IN R1MACH ARE RELEVANT TO THE COMPUTER BEING USED. -C - U = R1MACH(4) -C -- SET ASSOCIATED MACHINE DEPENDENT PARAMETER - WM(1) = SQRT(U) -C -- SET TERMINATION FLAG - IQUIT = 0 -C -- SET INITIALIZATION INDICATOR - INIT = 0 -C -- SET COUNTER FOR ATTEMPTED STEPS - KSTEPS = 0 -C -- SET INDICATOR FOR INTERMEDIATE-OUTPUT - INTOUT = .FALSE. -C -- SET START INDICATOR FOR STOD CODE - JSTART = 0 -C -- SET BDF METHOD INDICATOR - METH = 2 -C -- SET MAXIMUM ORDER FOR BDF METHOD - MAXORD = 5 -C -- SET ITERATION MATRIX INDICATOR -C - IF (IJAC .EQ. 0 .AND. IBAND .EQ. 0) MITER = 2 - IF (IJAC .EQ. 1 .AND. IBAND .EQ. 0) MITER = 1 - IF (IJAC .EQ. 0 .AND. IBAND .EQ. 1) MITER = 5 - IF (IJAC .EQ. 1 .AND. IBAND .EQ. 1) MITER = 4 -C -C -- SET OTHER NECESSARY ITEMS IN COMMON BLOCK - N = NEQ - NST = 0 - NJE = 0 - HMXI = 0. - NQ = 1 - H = 1. -C -- RESET IBEGIN FOR SUBSEQUENT CALLS - IBEGIN=1 - ENDIF -C -C....................................................................... -C -C CHECK VALIDITY OF INPUT PARAMETERS ON EACH ENTRY -C - IF (NEQ .LT. 1) THEN - WRITE (XERN1, '(I8)') NEQ - CALL XERMSG ('SLATEC', 'LSOD', - * 'IN DEBDF, THE NUMBER OF EQUATIONS MUST BE A POSITIVE ' // - * 'INTEGER.$$YOU HAVE CALLED THE CODE WITH NEQ = ' // XERN1, - * 6, 1) - IDID=-33 - ENDIF -C - NRTOLP = 0 - NATOLP = 0 - DO 60 K = 1,NEQ - IF (NRTOLP .LE. 0) THEN - IF (RTOL(K) .LT. 0.) THEN - WRITE (XERN1, '(I8)') K - WRITE (XERN3, '(1PE15.6)') RTOL(K) - CALL XERMSG ('SLATEC', 'LSOD', - * 'IN DEBDF, THE RELATIVE ERROR TOLERANCES MUST ' // - * 'BE NON-NEGATIVE.$$YOU HAVE CALLED THE CODE WITH ' // - * 'RTOL(' // XERN1 // ') = ' // XERN3 // '$$IN THE ' // - * 'CASE OF VECTOR ERROR TOLERANCES, NO FURTHER ' // - * 'CHECKING OF RTOL COMPONENTS IS DONE.', 7, 1) - IDID = -33 - IF (NATOLP .GT. 0) GO TO 70 - NRTOLP = 1 - ELSEIF (NATOLP .GT. 0) THEN - GO TO 50 - ENDIF - ENDIF -C - IF (ATOL(K) .LT. 0.) THEN - WRITE (XERN1, '(I8)') K - WRITE (XERN3, '(1PE15.6)') ATOL(K) - CALL XERMSG ('SLATEC', 'LSOD', - * 'IN DEBDF, THE ABSOLUTE ERROR ' // - * 'TOLERANCES MUST BE NON-NEGATIVE.$$YOU HAVE CALLED ' // - * 'THE CODE WITH ATOL(' // XERN1 // ') = ' // XERN3 // - * '$$IN THE CASE OF VECTOR ERROR TOLERANCES, NO FURTHER ' - * // 'CHECKING OF ATOL COMPONENTS IS DONE.', 8, 1) - IDID=-33 - IF (NRTOLP .GT. 0) GO TO 70 - NATOLP=1 - ENDIF - 50 IF (ITOL .EQ. 0) GO TO 70 - 60 CONTINUE -C - 70 IF (ITSTOP .EQ. 1) THEN - IF (SIGN(1.,TOUT-T) .NE. SIGN(1.,TSTOP-T) .OR. - 1 ABS(TOUT-T) .GT. ABS(TSTOP-T)) THEN - WRITE (XERN3, '(1PE15.6)') TOUT - WRITE (XERN4, '(1PE15.6)') TSTOP - CALL XERMSG ('SLATEC', 'LSOD', - * 'IN DEBDF, YOU HAVE CALLED THE ' // - * 'CODE WITH TOUT = ' // XERN3 // '$$BUT YOU HAVE ' // - * 'ALSO TOLD THE CODE NOT TO INTEGRATE PAST THE POINT ' // - * 'TSTOP = ' // XERN4 // ' BY SETTING INFO(4) = 1. ' // - * 'THESE INSTRUCTIONS CONFLICT.', 14, 1) - IDID=-33 - ENDIF - ENDIF -C -C CHECK SOME CONTINUATION POSSIBILITIES -C - IF (INIT .NE. 0) THEN - IF (T .EQ. TOUT) THEN - WRITE (XERN3, '(1PE15.6)') T - CALL XERMSG ('SLATEC', 'LSOD', - * 'IN DEBDF, YOU HAVE CALLED THE CODE WITH T = TOUT = ' // - * XERN3 // ' THIS IS NOT ALLOWED ON CONTINUATION CALLS.', - * 9, 1) - IDID=-33 - ENDIF -C - IF (T .NE. TOLD) THEN - WRITE (XERN3, '(1PE15.6)') TOLD - WRITE (XERN4, '(1PE15.6)') T - CALL XERMSG ('SLATEC', 'LSOD', - * 'IN DEBDF, YOU HAVE CHANGED THE VALUE OF T FROM ' // - * XERN3 // ' TO ' // XERN4 // - * ' THIS IS NOT ALLOWED ON CONTINUATION CALLS.', 10, 1) - IDID=-33 - ENDIF -C - IF (INIT .NE. 1) THEN - IF (DELSGN*(TOUT-T) .LT. 0.) THEN - WRITE (XERN3, '(1PE15.6)') TOUT - CALL XERMSG ('SLATEC', 'LSOD', - * 'IN DEBDF, BY CALLING THE CODE WITH TOUT = ' // - * XERN3 // ' YOU ARE ATTEMPTING TO CHANGE THE ' // - * 'DIRECTION OF INTEGRATION.$$' // - * 'THIS IS NOT ALLOWED WITHOUT RESTARTING.', 11, 1) - IDID=-33 - ENDIF - ENDIF - ENDIF -C - IF (IDID .EQ. (-33)) THEN - IF (IQUIT .NE. (-33)) THEN -C INVALID INPUT DETECTED - IQUIT=-33 - IBEGIN=-1 - ELSE - CALL XERMSG ('SLATEC', 'LSOD', - * 'IN DEBDF, INVALID INPUT WAS ' // - * 'DETECTED ON SUCCESSIVE ENTRIES. IT IS IMPOSSIBLE ' // - * 'TO PROCEED BECAUSE YOU HAVE NOT CORRECTED THE ' // - * 'PROBLEM, SO EXECUTION IS BEING TERMINATED.', 12, 2) - ENDIF - RETURN - ENDIF -C -C....................................................................... -C -C RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND INTERPRETED AS -C ASKING FOR THE MOST ACCURATE SOLUTION POSSIBLE. IN THIS CASE, -C THE RELATIVE ERROR TOLERANCE RTOL IS RESET TO THE SMALLEST VALUE -C 100*U WHICH IS LIKELY TO BE REASONABLE FOR THIS METHOD AND MACHINE -C - DO 170 K=1,NEQ - IF (RTOL(K)+ATOL(K) .GT. 0.) GO TO 160 - RTOL(K)=100.*U - IDID=-2 - 160 IF (ITOL .EQ. 0) GO TO 180 - 170 CONTINUE -C - 180 IF (IDID .NE. (-2)) GO TO 190 -C RTOL=ATOL=0 ON INPUT, SO RTOL IS CHANGED TO A -C SMALL POSITIVE VALUE - IBEGIN=-1 - RETURN -C -C BRANCH ON STATUS OF INITIALIZATION INDICATOR -C INIT=0 MEANS INITIAL DERIVATIVES AND NOMINAL STEP SIZE -C AND DIRECTION NOT YET SET -C INIT=1 MEANS NOMINAL STEP SIZE AND DIRECTION NOT YET SET -C INIT=2 MEANS NO FURTHER INITIALIZATION REQUIRED -C - 190 IF (INIT .EQ. 0) GO TO 200 - IF (INIT .EQ. 1) GO TO 220 - GO TO 240 -C -C....................................................................... -C -C MORE INITIALIZATION -- -C -- EVALUATE INITIAL DERIVATIVES -C - 200 INIT=1 - CALL F(T,Y,YH(1,2),RPAR,IPAR) - NFE=1 - IF (T .NE. TOUT) GO TO 220 - IDID=2 - DO 210 L = 1,NEQ - 210 YPOUT(L) = YH(L,2) - TOLD=T - RETURN -C -C -- COMPUTE INITIAL STEP SIZE -C -- SAVE SIGN OF INTEGRATION DIRECTION -C -- SET INDEPENDENT AND DEPENDENT VARIABLES -C X AND YH(*) FOR STOD -C - 220 LTOL = 1 - DO 225 L=1,NEQ - IF (ITOL .EQ. 1) LTOL = L - TOL = RTOL(LTOL)*ABS(Y(L)) + ATOL(LTOL) - IF (TOL .EQ. 0.) GO TO 380 - 225 EWT(L) = TOL -C - BIG = SQRT(R1MACH(2)) - CALL HSTART (F,NEQ,T,TOUT,Y,YH(1,2),EWT,1,U,BIG, - 1 YH(1,3),YH(1,4),YH(1,5),YH(1,6),RPAR,IPAR,H) -C - DELSGN = SIGN(1.0,TOUT-T) - X = T - DO 230 L = 1,NEQ - YH(L,1) = Y(L) - 230 YH(L,2) = H*YH(L,2) - INIT = 2 -C -C....................................................................... -C -C ON EACH CALL SET INFORMATION WHICH DETERMINES THE ALLOWED INTERVAL -C OF INTEGRATION BEFORE RETURNING WITH AN ANSWER AT TOUT -C - 240 DEL = TOUT - T - ABSDEL = ABS(DEL) -C -C....................................................................... -C -C IF ALREADY PAST OUTPUT POINT, INTERPOLATE AND RETURN -C - 250 IF (ABS(X-T) .LT. ABSDEL) GO TO 270 - CALL INTYD(TOUT,0,YH,NEQ,Y,INTFLG) - CALL INTYD(TOUT,1,YH,NEQ,YPOUT,INTFLG) - IDID = 3 - IF (X .NE. TOUT) GO TO 260 - IDID = 2 - INTOUT = .FALSE. - 260 T = TOUT - TOLD = T - RETURN -C -C IF CANNOT GO PAST TSTOP AND SUFFICIENTLY CLOSE, -C EXTRAPOLATE AND RETURN -C - 270 IF (ITSTOP .NE. 1) GO TO 290 - IF (ABS(TSTOP-X) .GE. 100.*U*ABS(X)) GO TO 290 - DT = TOUT - X - DO 280 L = 1,NEQ - 280 Y(L) = YH(L,1) + (DT/H)*YH(L,2) - CALL F(TOUT,Y,YPOUT,RPAR,IPAR) - NFE = NFE + 1 - IDID = 3 - T = TOUT - TOLD = T - RETURN -C - 290 IF (IINTEG .EQ. 0 .OR. .NOT.INTOUT) GO TO 300 -C -C INTERMEDIATE-OUTPUT MODE -C - IDID = 1 - GO TO 500 -C -C....................................................................... -C -C MONITOR NUMBER OF STEPS ATTEMPTED -C - 300 IF (KSTEPS .LE. MAXNUM) GO TO 330 -C -C A SIGNIFICANT AMOUNT OF WORK HAS BEEN EXPENDED - IDID=-1 - KSTEPS=0 - IBEGIN = -1 - GO TO 500 -C -C....................................................................... -C -C LIMIT STEP SIZE AND SET WEIGHT VECTOR -C - 330 HMIN = 100.*U*ABS(X) - HA = MAX(ABS(H),HMIN) - IF (ITSTOP .NE. 1) GO TO 340 - HA = MIN(HA,ABS(TSTOP-X)) - 340 H = SIGN(HA,H) - LTOL = 1 - DO 350 L = 1,NEQ - IF (ITOL .EQ. 1) LTOL = L - EWT(L) = RTOL(LTOL)*ABS(YH(L,1)) + ATOL(LTOL) - IF (EWT(L) .LE. 0.0) GO TO 380 - 350 CONTINUE - TOLFAC = U*VNWRMS(NEQ,YH,EWT) - IF (TOLFAC .LE. 1.) GO TO 400 -C -C TOLERANCES TOO SMALL - IDID = -2 - TOLFAC = 2.*TOLFAC - RTOL(1) = TOLFAC*RTOL(1) - ATOL(1) = TOLFAC*ATOL(1) - IF (ITOL .EQ. 0) GO TO 370 - DO 360 L = 2,NEQ - RTOL(L) = TOLFAC*RTOL(L) - 360 ATOL(L) = TOLFAC*ATOL(L) - 370 IBEGIN = -1 - GO TO 500 -C -C RELATIVE ERROR CRITERION INAPPROPRIATE - 380 IDID = -3 - IBEGIN = -1 - GO TO 500 -C -C....................................................................... -C -C TAKE A STEP -C - 400 CALL STOD(NEQ,Y,YH,NEQ,YH1,EWT,SAVF,ACOR,WM,IWM,F,JAC,RPAR,IPAR) -C - JSTART = -2 - INTOUT = .TRUE. - IF (KFLAG .EQ. 0) GO TO 250 -C -C....................................................................... -C - IF (KFLAG .EQ. -1) GO TO 450 -C -C REPEATED CORRECTOR CONVERGENCE FAILURES - IDID = -6 - IBEGIN = -1 - GO TO 500 -C -C REPEATED ERROR TEST FAILURES - 450 IDID = -7 - IBEGIN = -1 -C -C....................................................................... -C -C STORE VALUES BEFORE RETURNING TO DEBDF - 500 DO 555 L = 1,NEQ - Y(L) = YH(L,1) - 555 YPOUT(L) = YH(L,2)/H - T = X - TOLD = T - INTOUT = .FALSE. - RETURN - END diff --git a/slatec/lssods.f b/slatec/lssods.f deleted file mode 100644 index f599023..0000000 --- a/slatec/lssods.f +++ /dev/null @@ -1,303 +0,0 @@ -*DECK LSSODS - SUBROUTINE LSSODS (A, X, B, M, N, NRDA, IFLAG, IRANK, ISCALE, Q, - + DIAG, KPIVOT, ITER, RESNRM, XNORM, Z, R, DIV, TD, SCALES) -C***BEGIN PROLOGUE LSSODS -C***SUBSIDIARY -C***PURPOSE Subsidiary to BVSUP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (LSSODS-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C LSSODS solves the same problem as SODS (in fact, it is called by -C SODS) but is somewhat more flexible in its use. In particular, -C LSSODS allows for iterative refinement of the solution, makes the -C transformation and triangular reduction information more -C accessible, and enables the user to avoid destruction of the -C original matrix A. -C -C Modeled after the ALGOL codes in the articles in the REFERENCES -C section. -C -C ********************************************************************** -C INPUT -C ********************************************************************** -C -C A -- Contains the matrix of M equations in N unknowns and must -C be dimensioned NRDA by N. A remains unchanged -C X -- Solution array of length at least N -C B -- Given constant vector of length M, B remains unchanged -C M -- Number of equations, M greater or equal to 1 -C N -- Number of unknowns, N not larger than M -C NRDA -- Row dimension of A, NRDA greater or equal to M -C IFLAG -- Status indicator -C = 0 for the first call (and for each new problem defined by -C a new matrix A) when the matrix data is treated as exact -C =-K for the first call (and for each new problem defined by -C a new matrix A) when the matrix data is assumed to be -C accurate to about K digits -C = 1 for subsequent calls whenever the matrix A has already -C been decomposed (problems with new vectors B but -C same matrix a can be handled efficiently) -C ISCALE -- Scaling indicator -C =-1 if the matrix A is to be pre-scaled by -C columns when appropriate -C If the scaling indicator is not equal to -1 -C no scaling will be attempted -C For most problems scaling will probably not be necessary -C ITER -- Maximum number of iterative improvement steps to be -C performed, 0 .LE. ITER .LE. 10 (SODS uses ITER=0) -C Q -- Matrix used for the transformation, must be dimensioned -C NRDA by N (SODS puts A in the Q location which conserves -C storage but destroys A) -C When iterative improvement of the solution is requested, -C ITER .GT. 0, this additional storage for Q must be -C made available -C DIAG,KPIVOT,Z,R, -- Arrays of length N (except for R which is M) -C DIV,TD,SCALES used for internal storage -C -C ********************************************************************** -C OUTPUT -C ********************************************************************** -C -C IFLAG -- Status indicator -C =1 if solution was obtained -C =2 if improper input is detected -C =3 if rank of matrix is less than N -C if the minimal length least squares solution is -C desired, simply reset IFLAG=1 and call the code again -C -C The next three IFLAG values can occur only when -C the iterative improvement mode is being used. -C =4 if the problem is ill-conditioned and maximal -C machine accuracy is not achievable -C =5 if the problem is very ill-conditioned and the solution -C IS likely to have no correct digits -C =6 if the allowable number of iterative improvement steps -C has been completed without getting convergence -C X -- Least squares solution of A X = B -C IRANK -- Contains the numerically determined matrix rank -C the user must not alter this value on succeeding calls -C with input values of IFLAG=1 -C Q -- Contains the strictly upper triangular part of the reduced -C matrix and the transformation information in the lower -C triangular part -C DIAG -- Contains the diagonal elements of the triangular reduced -C matrix -C KPIVOT -- Contains the pivotal information. The column interchanges -C performed on the original matrix are recorded here -C ITER -- The actual number of iterative corrections used -C RESNRM -- The Euclidean norm of the residual vector B - A X -C XNORM -- The Euclidean norm of the solution vector -C DIV,TD -- Contains transformation information for rank -C deficient problems -C SCALES -- Contains the column scaling parameters -C -C ********************************************************************** -C -C***SEE ALSO BVSUP -C***REFERENCES G. Golub, Numerical methods for solving linear least -C squares problems, Numerische Mathematik 7, (1965), -C pp. 206-216. -C P. Businger and G. Golub, Linear least squares -C solutions by Householder transformations, Numerische -C Mathematik 7, (1965), pp. 269-276. -C***ROUTINES CALLED J4SAVE, OHTROR, ORTHOL, R1MACH, SDOT, SDSDOT, -C XERMAX, XERMSG, XGETF, XSETF -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900402 Added TYPE section. (WRB) -C 910408 Updated the REFERENCES section. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE LSSODS - DIMENSION A(NRDA,*),X(*),B(*),Q(NRDA,*),DIAG(*), - 1 Z(*),KPIVOT(*),R(*),DIV(*),TD(*),SCALES(*) -C -C ********************************************************************** -C -C MACHINE PRECISION (COMPUTER UNIT ROUNDOFF VALUE) IS DEFINED -C THE FUNCTION R1MACH. -C -C***FIRST EXECUTABLE STATEMENT LSSODS - URO = R1MACH(3) -C -C ********************************************************************** -C - IF (N .LT. 1 .OR. M .LT. N .OR. NRDA .LT. M) GO TO 1 - IF (ITER .LT. 0) GO TO 1 - IF (IFLAG .LE. 0) GO TO 5 - IF (IFLAG .EQ. 1) GO TO 15 -C -C INVALID INPUT FOR LSSODS - 1 IFLAG=2 - CALL XERMSG ('SLATEC', 'LSSODS', 'INVALID INPUT PARAMETERS.', 2, - + 1) - RETURN -C - 5 CALL XGETF (NFATAL) - MAXMES = J4SAVE (4,0,.FALSE.) - IF (IFLAG .EQ. 0) GO TO 7 - NFAT = -1 - IF(NFATAL .EQ. 0) NFAT=0 - CALL XSETF (NFAT) - CALL XERMAX (1) -C -C COPY MATRIX A INTO MATRIX Q -C - 7 DO 10 J=1,N - DO 10 K=1,M - 10 Q(K,J)=A(K,J) -C -C USE ORTHOGONAL TRANSFORMATIONS TO REDUCE Q TO -C UPPER TRIANGULAR FORM -C - CALL ORTHOL(Q,M,N,NRDA,IFLAG,IRANK,ISCALE,DIAG,KPIVOT,SCALES,Z,TD) -C - CALL XSETF (NFATAL) - CALL XERMAX (MAXMES) - IF (IRANK .EQ. N) GO TO 12 -C -C FOR RANK DEFICIENT PROBLEMS USE ADDITIONAL ORTHOGONAL -C TRANSFORMATIONS TO FURTHER REDUCE Q -C - IF (IRANK .NE. 0) CALL OHTROR(Q,N,NRDA,DIAG,IRANK,DIV,TD) - RETURN -C -C STORE DIVISORS FOR THE TRIANGULAR SOLUTION -C - 12 DO 13 K=1,N - 13 DIV(K)=DIAG(K) -C - 15 IRM=IRANK-1 - IRP=IRANK+1 - ITERP=MIN(ITER+1,11) - ACC=10.*URO -C -C ZERO OUT SOLUTION ARRAY -C - DO 20 K=1,N - 20 X(K)=0. -C - IF (IRANK .GT. 0) GO TO 25 -C -C SPECIAL CASE FOR THE NULL MATRIX - ITER=0 - XNORM=0. - RESNRM=SQRT(SDOT(M,B(1),1,B(1),1)) - RETURN -C -C COPY CONSTANT VECTOR INTO R -C - 25 DO 30 K=1,M - 30 R(K)=B(K) -C -C ********************************************************************** -C SOLUTION SECTION -C ITERATIVE REFINEMENT OF THE RESIDUAL VECTOR -C ********************************************************************** -C - DO 100 IT=1,ITERP - ITER=IT-1 -C -C APPLY ORTHOGONAL TRANSFORMATION TO R -C - DO 35 J=1,IRANK - MJ=M-J+1 - GAMMA=SDOT(MJ,Q(J,J),1,R(J),1)/(DIAG(J)*Q(J,J)) - DO 35 K=J,M - 35 R(K)=R(K)+GAMMA*Q(K,J) -C -C BACKWARD SUBSTITUTION FOR TRIANGULAR SYSTEM SOLUTION -C - Z(IRANK)=R(IRANK)/DIV(IRANK) - IF (IRM .EQ. 0) GO TO 45 - DO 40 L=1,IRM - K=IRANK-L - KP=K+1 - 40 Z(K)=(R(K)-SDOT(L,Q(K,KP),NRDA,Z(KP),1))/DIV(K) -C - 45 IF (IRANK .EQ. N) GO TO 60 -C -C FOR RANK DEFICIENT PROBLEMS OBTAIN THE -C MINIMAL LENGTH SOLUTION -C - NMIR=N-IRANK - DO 50 K=IRP,N - 50 Z(K)=0. - DO 55 K=1,IRANK - GAM=((TD(K)*Z(K))+SDOT(NMIR,Q(K,IRP),NRDA,Z(IRP),1))/ - 1 (TD(K)*DIV(K)) - Z(K)=Z(K)+GAM*TD(K) - DO 55 J=IRP,N - 55 Z(J)=Z(J)+GAM*Q(K,J) -C -C REORDER SOLUTION COMPONENTS ACCORDING TO PIVOTAL POINTS -C AND RESCALE ANSWERS AS DICTATED -C - 60 DO 65 K=1,N - Z(K)=Z(K)*SCALES(K) - L=KPIVOT(K) - 65 X(L)=X(L)+Z(K) -C -C COMPUTE CORRECTION VECTOR NORM (SOLUTION NORM) -C - ZNORM=SQRT(SDOT(N,Z(1),1,Z(1),1)) - IF (IT .EQ. 1) XNORM=ZNORM - IF (ITERP .GT. 1) GO TO 80 -C -C NO ITERATIVE CORRECTIONS TO BE PERFORMED, SO COMPUTE -C THE APPROXIMATE RESIDUAL NORM DEFINED BY THE EQUATIONS -C WHICH ARE NOT SATISFIED BY THE SOLUTION -C THEN WE ARE DONE -C - MMIR=M-IRANK - IF (MMIR .EQ. 0) GO TO 70 - RESNRM=SQRT(SDOT(MMIR,R(IRP),1,R(IRP),1)) - RETURN - 70 RESNRM=0. - RETURN -C -C COMPUTE RESIDUAL VECTOR FOR THE ITERATIVE IMPROVEMENT PROCESS -C - 80 DO 85 K=1,M - 85 R(K)=-SDSDOT(N,-B(K),A(K,1),NRDA,X(1),1) - RESNRM=SQRT(SDOT(M,R(1),1,R(1),1)) - IF (IT .EQ. 1) GO TO 100 -C -C TEST FOR CONVERGENCE -C - IF (ZNORM .LE. ACC*XNORM) RETURN -C -C COMPARE SUCCESSIVE REFINEMENT VECTOR NORMS -C FOR LOOP TERMINATION CRITERIA -C - IF (ZNORM .LE. 0.25*ZNRM0) GO TO 100 - IF (IT .EQ. 2) GO TO 90 -C - IFLAG=4 - CALL XERMSG ('SLATEC', 'LSSODS', - + 'PROBLEM MAY BE ILL-CONDITIONED. MAXIMAL MACHINE ACCURACY ' // - + 'IS NOT ACHIEVABLE.', 3, 1) - RETURN -C - 90 IFLAG=5 - CALL XERMSG ('SLATEC', 'LSSODS', - + 'PROBLEM IS VERY ILL-CONDITIONED. ITERATIVE ' // - + 'IMPROVEMENT IS INEFFECTIVE.', 8, 1) - RETURN -C - 100 ZNRM0=ZNORM -C ********************************************************************** -C -C ********************************************************************** - IFLAG=6 - CALL XERMSG ('SLATEC', 'LSSODS', - + 'CONVERGENCE HAS NOT BEEN OBTAINED WITH ALLOWABLE ' // - + 'NUMBER OF ITERATIVE IMPROVEMENT STEPS.', 8, 1) -C - RETURN - END diff --git a/slatec/lssuds.f b/slatec/lssuds.f deleted file mode 100644 index 7c0cd00..0000000 --- a/slatec/lssuds.f +++ /dev/null @@ -1,273 +0,0 @@ -*DECK LSSUDS - SUBROUTINE LSSUDS (A, X, B, N, M, NRDA, U, NRDU, IFLAG, MLSO, - + IRANK, ISCALE, Q, DIAG, KPIVOT, S, DIV, TD, ISFLG, SCALES) -C***BEGIN PROLOGUE LSSUDS -C***SUBSIDIARY -C***PURPOSE Subsidiary to BVSUP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (LSSUDS-S, DLSSUD-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C LSSUDS solves the underdetermined system of equations A Z = B, -C where A is N by M and N .LE. M. In particular, if rank A equals -C IRA, a vector X and a matrix U are determined such that X is the -C UNIQUE solution of smallest length, satisfying A X = B, and the -C columns of U form an orthonormal basis for the null space of A, -C satisfying A U = 0 . Then all solutions Z are given by -C Z = X + C(1)*U(1) + ..... + C(M-IRA)*U(M-IRA) -C where U(J) represents the J-th column of U and the C(J) are -C arbitrary constants. -C If the system of equations are not compatible, only the least -C squares solution of minimal length is computed. -C -C ********************************************************************* -C INPUT -C ********************************************************************* -C -C A -- Contains the matrix of N equations in M unknowns, A remains -C unchanged, must be dimensioned NRDA by M. -C X -- Solution array of length at least M. -C B -- Given constant vector of length N, B remains unchanged. -C N -- Number of equations, N greater or equal to 1. -C M -- Number of unknowns, M greater or equal to N. -C NRDA -- Row dimension of A, NRDA greater or equal to N. -C U -- Matrix used for solution, must be dimensioned NRDU by -C (M - rank of A). -C (storage for U may be ignored when only the minimal length -C solution X is desired) -C NRDU -- Row dimension of U, NRDU greater or equal to M. -C (if only the minimal length solution is wanted, -C NRDU=0 is acceptable) -C IFLAG -- Status indicator -C =0 for the first call (and for each new problem defined by -C a new matrix A) when the matrix data is treated as exact -C =-K for the first call (and for each new problem defined by -C a new matrix A) when the matrix data is assumed to be -C accurate to about K digits. -C =1 for subsequent calls whenever the matrix A has already -C been decomposed (problems with new vectors B but -C same matrix A can be handled efficiently). -C MLSO -- =0 if only the minimal length solution is wanted. -C =1 if the complete solution is wanted, includes the -C linear space defined by the matrix U. -C IRANK -- Variable used for the rank of A, set by the code. -C ISCALE -- Scaling indicator -C =-1 if the matrix A is to be pre-scaled by -C columns when appropriate. -C If the scaling indicator is not equal to -1 -C no scaling will be attempted. -C For most problems scaling will probably not be necessary. -C Q -- Matrix used for the transformation, must be dimensioned -C NRDA by M. -C DIAG,KPIVOT,S, -- Arrays of length at least N used for internal -C DIV,TD,SCALES storage (except for SCALES which is M). -C ISFLG -- Storage for an internal variable. -C -C ********************************************************************* -C OUTPUT -C ********************************************************************* -C -C IFLAG -- Status indicator -C =1 if solution was obtained. -C =2 if improper input is detected. -C =3 if rank of matrix is less than N. -C To continue, simply reset IFLAG=1 and call LSSUDS again. -C =4 if the system of equations appears to be inconsistent. -C However, the least squares solution of minimal length -C was obtained. -C X -- Minimal length least squares solution of A Z = B -C IRANK -- Numerically determined rank of A, must not be altered -C on succeeding calls with input values of IFLAG=1. -C U -- Matrix whose M-IRANK columns are mutually orthogonal unit -C vectors which span the null space of A. This is to be ignored -C when MLSO was set to zero or IFLAG=4 on output. -C Q -- Contains the strictly upper triangular part of the reduced -C matrix and transformation information. -C DIAG -- Contains the diagonal elements of the triangular reduced -C matrix. -C KPIVOT -- Contains the pivotal information. The row interchanges -C performed on the original matrix are recorded here. -C S -- Contains the solution of the lower triangular system. -C DIV,TD -- Contains transformation information for rank -C deficient problems. -C SCALES -- Contains the column scaling parameters. -C -C ********************************************************************* -C -C***SEE ALSO BVSUP -C***REFERENCES H. A. Watts, Solving linear least squares problems -C using SODS/SUDS/CODS, Sandia Report SAND77-0683, -C Sandia Laboratories, 1977. -C***ROUTINES CALLED J4SAVE, OHTROL, ORTHOR, R1MACH, SDOT, XERMAX, -C XERMSG, XGETF, XSETF -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 900510 Fixed an error message. (RWC) -C 910408 Updated the AUTHOR and REFERENCES sections. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE LSSUDS - DIMENSION A(NRDA,*),X(*),B(*),U(NRDU,*),Q(NRDA,*), - 1 DIAG(*),KPIVOT(*),S(*),DIV(*),TD(*),SCALES(*) -C -C ********************************************************************** -C -C MACHINE PRECISION (COMPUTER UNIT ROUNDOFF VALUE) IS DEFINED -C BY THE FUNCTION R1MACH. -C -C***FIRST EXECUTABLE STATEMENT LSSUDS - URO = R1MACH(4) -C -C ********************************************************************** -C - IF (N .LT. 1 .OR. M .LT. N .OR. NRDA .LT. N) GO TO 1 - IF (NRDU .NE. 0 .AND. NRDU .LT. M) GO TO 1 - IF (IFLAG .LE. 0) GO TO 5 - IF (IFLAG .EQ. 1) GO TO 25 -C -C INVALID INPUT FOR LSSUDS - 1 IFLAG=2 - CALL XERMSG ('SLATEC', 'LSSUDS', 'INVALID INPUT PARAMETERS.', 2, - + 1) - RETURN -C - 5 CALL XGETF(NFATAL) - MAXMES = J4SAVE (4,0,.FALSE.) - ISFLG=-15 - IF (IFLAG .EQ. 0) GO TO 7 - ISFLG=IFLAG - NFAT = -1 - IF (NFATAL .EQ. 0) NFAT=0 - CALL XSETF(NFAT) - CALL XERMAX(1) -C -C COPY MATRIX A INTO MATRIX Q -C - 7 DO 10 K=1,M - DO 10 J=1,N - 10 Q(J,K)=A(J,K) -C -C USE ORTHOGONAL TRANSFORMATIONS TO REDUCE Q TO LOWER -C TRIANGULAR FORM -C - CALL ORTHOR(Q,N,M,NRDA,IFLAG,IRANK,ISCALE,DIAG,KPIVOT,SCALES, - 1 DIV,TD) -C - CALL XSETF(NFATAL) - CALL XERMAX(MAXMES) - IF (IRANK .EQ. N) GO TO 15 -C -C FOR RANK DEFICIENT PROBLEMS USE ADDITIONAL ORTHOGONAL -C TRANSFORMATIONS TO FURTHER REDUCE Q -C - IF (IRANK .NE. 0) CALL OHTROL(Q,N,NRDA,DIAG,IRANK,DIV,TD) - RETURN -C -C STORE DIVISORS FOR THE TRIANGULAR SOLUTION -C - 15 DO 20 K=1,N - 20 DIV(K)=DIAG(K) -C -C - 25 IF (IRANK .GT. 0) GO TO 40 -C -C SPECIAL CASE FOR THE NULL MATRIX - DO 35 K=1,M - X(K)=0. - IF (MLSO .EQ. 0) GO TO 35 - U(K,K)=1. - DO 30 J=1,M - IF (J .EQ. K) GO TO 30 - U(J,K)=0. - 30 CONTINUE - 35 CONTINUE - DO 37 K=1,N - IF (B(K) .GT. 0.) IFLAG=4 - 37 CONTINUE - RETURN -C -C COPY CONSTANT VECTOR INTO S AFTER FIRST INTERCHANGING -C THE ELEMENTS ACCORDING TO THE PIVOTAL SEQUENCE -C - 40 DO 45 K=1,N - KP=KPIVOT(K) - 45 X(K)=B(KP) - DO 50 K=1,N - 50 S(K)=X(K) -C - IRP=IRANK+1 - NU=1 - IF (MLSO .EQ. 0) NU=0 - IF (IRANK .EQ. N) GO TO 60 -C -C FOR RANK DEFICIENT PROBLEMS WE MUST APPLY THE -C ORTHOGONAL TRANSFORMATION TO S -C WE ALSO CHECK TO SEE IF THE SYSTEM APPEARS TO BE INCONSISTENT -C - NMIR=N-IRANK - SS=SDOT(N,S(1),1,S(1),1) - DO 55 L=1,IRANK - K=IRP-L - GAM=((TD(K)*S(K))+SDOT(NMIR,Q(IRP,K),1,S(IRP),1))/ - 1 (TD(K)*DIV(K)) - S(K)=S(K)+GAM*TD(K) - DO 55 J=IRP,N - 55 S(J)=S(J)+GAM*Q(J,K) - RES=SDOT(NMIR,S(IRP),1,S(IRP),1) - IF (RES .LE. SS*(10.*MAX(10.**ISFLG,10.*URO))**2) GO TO 60 -C -C INCONSISTENT SYSTEM - IFLAG=4 - NU=0 -C -C APPLY FORWARD SUBSTITUTION TO SOLVE LOWER TRIANGULAR SYSTEM -C - 60 S(1)=S(1)/DIV(1) - IF (IRANK .EQ. 1) GO TO 70 - DO 65 K=2,IRANK - 65 S(K)=(S(K)-SDOT(K-1,Q(K,1),NRDA,S(1),1))/DIV(K) -C -C INITIALIZE X VECTOR AND THEN APPLY ORTHOGONAL TRANSFORMATION -C - 70 DO 75 K=1,M - X(K)=0. - IF (K .LE. IRANK) X(K)=S(K) - 75 CONTINUE -C - DO 80 JR=1,IRANK - J=IRP-JR - MJ=M-J+1 - GAMMA=SDOT(MJ,Q(J,J),NRDA,X(J),1)/(DIAG(J)*Q(J,J)) - DO 80 K=J,M - 80 X(K)=X(K)+GAMMA*Q(J,K) -C -C RESCALE ANSWERS AS DICTATED -C - DO 85 K=1,M - 85 X(K)=X(K)*SCALES(K) -C - IF ((NU .EQ. 0) .OR. (M .EQ. IRANK)) RETURN -C -C INITIALIZE U MATRIX AND THEN APPLY ORTHOGONAL TRANSFORMATION -C - L=M-IRANK - DO 100 K=1,L - DO 90 I=1,M - U(I,K)=0. - IF (I .EQ. IRANK+K) U(I,K)=1. - 90 CONTINUE -C - DO 100 JR=1,IRANK - J=IRP-JR - MJ=M-J+1 - GAMMA=SDOT(MJ,Q(J,J),NRDA,U(J,K),1)/(DIAG(J)*Q(J,J)) - DO 100 I=J,M - 100 U(I,K)=U(I,K)+GAMMA*Q(J,I) -C - RETURN - END diff --git a/slatec/macon.f b/slatec/macon.f deleted file mode 100644 index c223f89..0000000 --- a/slatec/macon.f +++ /dev/null @@ -1,36 +0,0 @@ -*DECK MACON - SUBROUTINE MACON -C***BEGIN PROLOGUE MACON -C***SUBSIDIARY -C***PURPOSE Subsidiary to BVSUP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (MACON-S, DMACON-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Sets up machine constants using R1MACH -C -C***SEE ALSO BVSUP -C***ROUTINES CALLED R1MACH -C***COMMON BLOCKS ML5MCO -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890921 Realigned order of variables in certain COMMON blocks. -C (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE MACON - COMMON /ML5MCO/ URO,SRU,EPS,SQOVFL,TWOU,FOURU,LPAR -C***FIRST EXECUTABLE STATEMENT MACON - URO=R1MACH(4) - SRU=SQRT(URO) - DD=-LOG10(URO) - LPAR=0.5*DD - KE=0.5+0.75*DD - EPS=10.**(-2*KE) - SQOVFL=SQRT(R1MACH(2)) - TWOU=2.0*URO - FOURU=4.0*URO - RETURN - END diff --git a/slatec/mc20ad.f b/slatec/mc20ad.f deleted file mode 100644 index ca6876e..0000000 --- a/slatec/mc20ad.f +++ /dev/null @@ -1,95 +0,0 @@ -*DECK MC20AD - SUBROUTINE MC20AD (NC, MAXA, A, INUM, JPTR, JNUM, JDISP) -C***BEGIN PROLOGUE MC20AD -C***SUBSIDIARY -C***PURPOSE Subsidiary to DSPLP -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (MC20AS-S, MC20AD-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM -C FROM THE C. 1979 AERE HARWELL LIBRARY. THE NAME OF THE -C CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING -C THE FINAL LETTER =D= IN THE NAMES USED HERE. -C REVISED SEP. 13, 1979. -C -C ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES -C IN THE PACKAGE GIVEN HERE. ANY PRIMARY USAGE OF THE HARWELL -C SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN -C THE USER AND AERE-UK. ANY USAGE OF THE SANDIA WRITTEN CODES -C DSPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED. -C -C***SEE ALSO DSPLP -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE MC20AD - INTEGER INUM(*), JNUM(*) - DOUBLE PRECISION A(*),ACE,ACEP - DIMENSION JPTR(NC) -C***FIRST EXECUTABLE STATEMENT MC20AD - NULL = -JDISP -C** CLEAR JPTR - DO 10 J=1,NC - JPTR(J) = 0 - 10 CONTINUE -C** COUNT THE NUMBER OF ELEMENTS IN EACH COLUMN. - DO 20 K=1,MAXA - J = JNUM(K) + JDISP - JPTR(J) = JPTR(J) + 1 - 20 CONTINUE -C** SET THE JPTR ARRAY - K = 1 - DO 30 J=1,NC - KR = K + JPTR(J) - JPTR(J) = K - K = KR - 30 CONTINUE -C -C** REORDER THE ELEMENTS INTO COLUMN ORDER. THE ALGORITHM IS AN -C IN-PLACE SORT AND IS OF ORDER MAXA. - DO 50 I=1,MAXA -C ESTABLISH THE CURRENT ENTRY. - JCE = JNUM(I) + JDISP - IF (JCE.EQ.0) GO TO 50 - ACE = A(I) - ICE = INUM(I) -C CLEAR THE LOCATION VACATED. - JNUM(I) = NULL -C CHAIN FROM CURRENT ENTRY TO STORE ITEMS. - DO 40 J=1,MAXA -C CURRENT ENTRY NOT IN CORRECT POSITION. DETERMINE CORRECT -C POSITION TO STORE ENTRY. - LOC = JPTR(JCE) - JPTR(JCE) = JPTR(JCE) + 1 -C SAVE CONTENTS OF THAT LOCATION. - ACEP = A(LOC) - ICEP = INUM(LOC) - JCEP = JNUM(LOC) -C STORE CURRENT ENTRY. - A(LOC) = ACE - INUM(LOC) = ICE - JNUM(LOC) = NULL -C CHECK IF NEXT CURRENT ENTRY NEEDS TO BE PROCESSED. - IF (JCEP.EQ.NULL) GO TO 50 -C IT DOES. COPY INTO CURRENT ENTRY. - ACE = ACEP - ICE = ICEP - JCE = JCEP + JDISP - 40 CONTINUE -C - 50 CONTINUE -C -C** RESET JPTR VECTOR. - JA = 1 - DO 60 J=1,NC - JB = JPTR(J) - JPTR(J) = JA - JA = JB - 60 CONTINUE - RETURN - END diff --git a/slatec/mc20as.f b/slatec/mc20as.f deleted file mode 100644 index ef608c2..0000000 --- a/slatec/mc20as.f +++ /dev/null @@ -1,95 +0,0 @@ -*DECK MC20AS - SUBROUTINE MC20AS (NC, MAXA, A, INUM, JPTR, JNUM, JDISP) -C***BEGIN PROLOGUE MC20AS -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (MC20AS-S, MC20AD-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM -C FROM THE C. 1979 AERE HARWELL LIBRARY. THE NAME OF THE -C CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING -C THE FINAL LETTER =S= IN THE NAMES USED HERE. -C REVISED SEP. 13, 1979. -C -C ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES -C IN THE PACKAGE GIVEN HERE. ANY PRIMARY USAGE OF THE HARWELL -C SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN -C THE USER AND AERE-UK. ANY USAGE OF THE SANDIA WRITTEN CODES -C SPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED. -C -C***SEE ALSO SPLP -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE MC20AS - INTEGER INUM(*), JNUM(*) - REAL A(*) - DIMENSION JPTR(NC) -C***FIRST EXECUTABLE STATEMENT MC20AS - NULL = -JDISP -C** CLEAR JPTR - DO 10 J=1,NC - JPTR(J) = 0 - 10 CONTINUE -C** COUNT THE NUMBER OF ELEMENTS IN EACH COLUMN. - DO 20 K=1,MAXA - J = JNUM(K) + JDISP - JPTR(J) = JPTR(J) + 1 - 20 CONTINUE -C** SET THE JPTR ARRAY - K = 1 - DO 30 J=1,NC - KR = K + JPTR(J) - JPTR(J) = K - K = KR - 30 CONTINUE -C -C** REORDER THE ELEMENTS INTO COLUMN ORDER. THE ALGORITHM IS AN -C IN-PLACE SORT AND IS OF ORDER MAXA. - DO 50 I=1,MAXA -C ESTABLISH THE CURRENT ENTRY. - JCE = JNUM(I) + JDISP - IF (JCE.EQ.0) GO TO 50 - ACE = A(I) - ICE = INUM(I) -C CLEAR THE LOCATION VACATED. - JNUM(I) = NULL -C CHAIN FROM CURRENT ENTRY TO STORE ITEMS. - DO 40 J=1,MAXA -C CURRENT ENTRY NOT IN CORRECT POSITION. DETERMINE CORRECT -C POSITION TO STORE ENTRY. - LOC = JPTR(JCE) - JPTR(JCE) = JPTR(JCE) + 1 -C SAVE CONTENTS OF THAT LOCATION. - ACEP = A(LOC) - ICEP = INUM(LOC) - JCEP = JNUM(LOC) -C STORE CURRENT ENTRY. - A(LOC) = ACE - INUM(LOC) = ICE - JNUM(LOC) = NULL -C CHECK IF NEXT CURRENT ENTRY NEEDS TO BE PROCESSED. - IF (JCEP.EQ.NULL) GO TO 50 -C IT DOES. COPY INTO CURRENT ENTRY. - ACE = ACEP - ICE = ICEP - JCE = JCEP + JDISP - 40 CONTINUE -C - 50 CONTINUE -C -C** RESET JPTR VECTOR. - JA = 1 - DO 60 J=1,NC - JB = JPTR(J) - JPTR(J) = JA - JA = JB - 60 CONTINUE - RETURN - END diff --git a/slatec/mgsbv.f b/slatec/mgsbv.f deleted file mode 100644 index 770513f..0000000 --- a/slatec/mgsbv.f +++ /dev/null @@ -1,260 +0,0 @@ -*DECK MGSBV - SUBROUTINE MGSBV (M, N, A, IA, NIV, IFLAG, S, P, IP, INHOMO, V, W, - + WCND) -C***BEGIN PROLOGUE MGSBV -C***SUBSIDIARY -C***PURPOSE Subsidiary to BVSUP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (MGSBV-S, DMGSBV-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C ********************************************************************** -C Orthogonalize a set of N real vectors and determine their rank -C -C ********************************************************************** -C INPUT -C ********************************************************************** -C M = Dimension of vectors -C N = No. of vectors -C A = Array whose first N cols contain the vectors -C IA = First dimension of array A (col length) -C NIV = Number of independent vectors needed -C INHOMO = 1 Corresponds to having a non-zero particular solution -C V = Particular solution vector (not included in the pivoting) -C INDPVT = 1 Means pivoting will not be used -C -C ********************************************************************** -C OUTPUT -C ********************************************************************** -C NIV = No. of linear independent vectors in input set -C A = Matrix whose first NIV cols. contain NIV orthogonal vectors -C which span the vector space determined by the input vectors -C IFLAG -C = 0 success -C = 1 incorrect input -C = 2 rank of new vectors less than N -C P = Decomposition matrix. P is upper triangular and -C (old vectors) = (new vectors) * P. -C The old vectors will be reordered due to pivoting -C The dimension of p must be .GE. N*(N+1)/2. -C ( N*(2*N+1) when N .NE. NFCC ) -C IP = Pivoting vector. The dimension of IP must be .GE. N. -C ( 2*N when N .NE. NFCC ) -C S = Square of norms of incoming vectors -C V = Vector which is orthogonal to the vectors of A -C W = Orthogonalization information for the vector V -C WCND = Worst case (smallest) norm decrement value of the -C vectors being orthogonalized (represents a test -C for linear dependence of the vectors) -C ********************************************************************** -C -C***SEE ALSO BVSUP -C***ROUTINES CALLED PRVEC, SDOT -C***COMMON BLOCKS ML18JR, ML5MCO -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 890921 Realigned order of variables in certain COMMON blocks. -C (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE MGSBV -C - DIMENSION A(IA,*),V(*),W(*),P(*),IP(*),S(*) -C -C - COMMON /ML18JR/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ, - 1 INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,NFCC, - 2 ICOCO -C - COMMON /ML5MCO/ URO,SRU,EPS,SQOVFL,TWOU,FOURU,LPAR -C -C***FIRST EXECUTABLE STATEMENT MGSBV - IF(M .GT. 0 .AND. N .GT. 0 .AND. IA .GE. M) GO TO 10 - IFLAG=1 - RETURN -C - 10 JP=0 - IFLAG=0 - NP1=N+1 - Y=0.0 - M2=M/2 -C -C CALCULATE SQUARE OF NORMS OF INCOMING VECTORS AND SEARCH FOR -C VECTOR WITH LARGEST MAGNITUDE -C - J=0 - DO 30 I=1,N - VL=SDOT(M,A(1,I),1,A(1,I),1) - S(I)=VL - IF (N .EQ. NFCC) GO TO 25 - J=2*I-1 - P(J)=VL - IP(J)=J - 25 J=J+1 - P(J)=VL - IP(J)=J - IF(VL .LE. Y) GO TO 30 - Y=VL - IX=I - 30 CONTINUE - IF (INDPVT .NE. 1) GO TO 33 - IX=1 - Y=P(1) - 33 LIX=IX - IF (N .NE. NFCC) LIX=2*IX-1 - P(LIX)=P(1) - S(NP1)=0. - IF (INHOMO .EQ. 1) S(NP1)=SDOT(M,V,1,V,1) - WCND=1. - NIVN=NIV - NIV=0 -C - IF(Y .EQ. 0.0) GO TO 170 -C ********************************************************************** - DO 140 NR=1,N - IF (NIVN .EQ. NIV) GO TO 150 - NIV=NR - IF(IX .EQ. NR) GO TO 80 -C -C PIVOTING OF COLUMNS OF P MATRIX -C - NN=N - LIX=IX - LR=NR - IF (N .EQ. NFCC) GO TO 40 - NN=NFCC - LIX=2*IX-1 - LR=2*NR-1 - 40 IF(NR .EQ. 1) GO TO 60 - KD=LIX-LR - KJ=LR - NRM1=LR-1 - DO 50 J=1,NRM1 - PSAVE=P(KJ) - JK=KJ+KD - P(KJ)=P(JK) - P(JK)=PSAVE - 50 KJ=KJ+NN-J - JY=JK+NMNR - JZ=JY-KD - P(JY)=P(JZ) - 60 IZ=IP(LIX) - IP(LIX)=IP(LR) - IP(LR)=IZ - SV=S(IX) - S(IX)=S(NR) - S(NR)=SV - IF (N .EQ. NFCC) GO TO 69 - IF (NR .EQ. 1) GO TO 67 - KJ=LR+1 - DO 65 K=1,NRM1 - PSAVE=P(KJ) - JK=KJ+KD - P(KJ)=P(JK) - P(JK)=PSAVE - 65 KJ=KJ+NFCC-K - 67 IZ=IP(LIX+1) - IP(LIX+1)=IP(LR+1) - IP(LR+1)=IZ -C -C PIVOTING OF COLUMNS OF VECTORS -C - 69 DO 70 L=1,M - T=A(L,IX) - A(L,IX)=A(L,NR) - 70 A(L,NR)=T -C -C CALCULATE P(NR,NR) AS NORM SQUARED OF PIVOTAL VECTOR -C - 80 JP=JP+1 - P(JP)=Y - RY=1.0/Y - NMNR=N-NR - IF (N .EQ. NFCC) GO TO 85 - NMNR=NFCC-(2*NR-1) - JP=JP+1 - P(JP)=0. - KP=JP+NMNR - P(KP)=Y - 85 IF(NR .EQ. N .OR. NIVN .EQ. NIV) GO TO 125 -C -C CALCULATE ORTHOGONAL PROJECTION VECTORS AND SEARCH FOR LARGEST NORM -C - Y=0.0 - IP1=NR+1 - IX=IP1 -C **************************************** - DO 120 J=IP1,N - DOT=SDOT(M,A(1,NR),1,A(1,J),1) - JP=JP+1 - JQ=JP+NMNR - IF (N .NE. NFCC) JQ=JQ+NMNR-1 - P(JQ)=P(JP)-DOT*(DOT*RY) - P(JP)=DOT*RY - DO 90 I = 1,M - 90 A(I,J)=A(I,J)-P(JP)*A(I,NR) - IF (N .EQ. NFCC) GO TO 99 - KP=JP+NMNR - JP=JP+1 - PJP=RY*PRVEC(M,A(1,NR),A(1,J)) - P(JP)=PJP - P(KP)=-PJP - KP=KP+1 - P(KP)=RY*DOT - DO 95 K=1,M2 - L=M2+K - A(K,J)=A(K,J)-PJP*A(L,NR) - 95 A(L,J)=A(L,J)+PJP*A(K,NR) - P(JQ)=P(JQ)-PJP*(PJP/RY) -C -C TEST FOR CANCELLATION IN RECURRENCE RELATION -C - 99 IF(P(JQ) .GT. S(J)*SRU) GO TO 100 - P(JQ)=SDOT(M,A(1,J),1,A(1,J),1) - 100 IF(P(JQ) .LE. Y) GO TO 120 - Y=P(JQ) - IX=J - 120 CONTINUE - IF (N .NE. NFCC) JP=KP -C **************************************** - IF(INDPVT .EQ. 1) IX=IP1 -C -C RECOMPUTE NORM SQUARED OF PIVOTAL VECTOR WITH SCALAR PRODUCT -C - Y=SDOT(M,A(1,IX),1,A(1,IX),1) - IF(Y .LE. EPS*S(IX)) GO TO 170 - WCND=MIN(WCND,Y/S(IX)) -C -C COMPUTE ORTHOGONAL PROJECTION OF PARTICULAR SOLUTION -C - 125 IF(INHOMO .NE. 1) GO TO 140 - LR=NR - IF (N .NE. NFCC) LR=2*NR-1 - W(LR)=SDOT(M,A(1,NR),1,V,1)*RY - DO 130 I=1,M - 130 V(I)=V(I)-W(LR)*A(I,NR) - IF (N .EQ. NFCC) GO TO 140 - LR=2*NR - W(LR)=RY*PRVEC(M,V,A(1,NR)) - DO 135 K=1,M2 - L=M2+K - V(K)=V(K)+W(LR)*A(L,NR) - 135 V(L)=V(L)-W(LR)*A(K,NR) - 140 CONTINUE -C ********************************************************************** -C -C TEST FOR LINEAR DEPENDENCE OF PARTICULAR SOLUTION -C - 150 IF(INHOMO .NE. 1) RETURN - IF ((N .GT. 1) .AND. (S(NP1) .LT. 1.0)) RETURN - VNORM=SDOT(M,V,1,V,1) - IF (S(NP1) .NE. 0.) WCND=MIN(WCND,VNORM/S(NP1)) - IF(VNORM .GE. EPS*S(NP1)) RETURN - 170 IFLAG=2 - WCND=EPS - RETURN - END diff --git a/slatec/minfit.f b/slatec/minfit.f deleted file mode 100644 index d28f7d2..0000000 --- a/slatec/minfit.f +++ /dev/null @@ -1,357 +0,0 @@ -*DECK MINFIT - SUBROUTINE MINFIT (NM, M, N, A, W, IP, B, IERR, RV1) -C***BEGIN PROLOGUE MINFIT -C***PURPOSE Compute the singular value decomposition of a rectangular -C matrix and solve the related linear least squares problem. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D9 -C***TYPE SINGLE PRECISION (MINFIT-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure MINFIT, -C NUM. MATH. 14, 403-420(1970) by Golub and Reinsch. -C HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 134-151(1971). -C -C This subroutine determines, towards the solution of the linear -C T -C system AX=B, the singular value decomposition A=USV of a real -C T -C M by N rectangular matrix, forming U B rather than U. Householder -C bidiagonalization and a variant of the QR algorithm are used. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, A and B, as declared in the calling -C program dimension statement. Note that NM must be at least -C as large as the maximum of M and N. NM is an INTEGER -C variable. -C -C M is the number of rows of A and B. M is an INTEGER variable. -C -C N is the number of columns of A and the order of V. N is an -C INTEGER variable. -C -C A contains the rectangular coefficient matrix of the system. -C A is a two-dimensional REAL array, dimensioned A(NM,N). -C -C IP is the number of columns of B. IP can be zero. -C -C B contains the constant column matrix of the system if IP is -C not zero. Otherwise, B is not referenced. B is a two- -C dimensional REAL array, dimensioned B(NM,IP). -C -C On OUTPUT -C -C A has been overwritten by the matrix V (orthogonal) of the -C decomposition in its first N rows and columns. If an -C error exit is made, the columns of V corresponding to -C indices of correct singular values should be correct. -C -C W contains the N (non-negative) singular values of A (the -C diagonal elements of S). They are unordered. If an -C error exit is made, the singular values should be correct -C for indices IERR+1, IERR+2, ..., N. W is a one-dimensional -C REAL array, dimensioned W(N). -C -C T -C B has been overwritten by U B. If an error exit is made, -C T -C the rows of U B corresponding to indices of correct singular -C values should be correct. -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C K if the K-th singular value has not been -C determined after 30 iterations. -C The singular values should be correct for -C indices IERR+1, IERR+2, ..., N. -C -C RV1 is a one-dimensional REAL array used for temporary storage, -C dimensioned RV1(N). -C -C Calls PYTHAG(A,B) for sqrt(A**2 + B**2). -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED PYTHAG -C***REVISION HISTORY (YYMMDD) -C 760101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE MINFIT -C - INTEGER I,J,K,L,M,N,II,IP,I1,KK,K1,LL,L1,M1,NM,ITS,IERR - REAL A(NM,*),W(*),B(NM,IP),RV1(*) - REAL C,F,G,H,S,X,Y,Z,SCALE,S1 - REAL PYTHAG -C -C***FIRST EXECUTABLE STATEMENT MINFIT - IERR = 0 -C .......... HOUSEHOLDER REDUCTION TO BIDIAGONAL FORM .......... - G = 0.0E0 - SCALE = 0.0E0 - S1 = 0.0E0 -C - DO 300 I = 1, N - L = I + 1 - RV1(I) = SCALE * G - G = 0.0E0 - S = 0.0E0 - SCALE = 0.0E0 - IF (I .GT. M) GO TO 210 -C - DO 120 K = I, M - 120 SCALE = SCALE + ABS(A(K,I)) -C - IF (SCALE .EQ. 0.0E0) GO TO 210 -C - DO 130 K = I, M - A(K,I) = A(K,I) / SCALE - S = S + A(K,I)**2 - 130 CONTINUE -C - F = A(I,I) - G = -SIGN(SQRT(S),F) - H = F * G - S - A(I,I) = F - G - IF (I .EQ. N) GO TO 160 -C - DO 150 J = L, N - S = 0.0E0 -C - DO 140 K = I, M - 140 S = S + A(K,I) * A(K,J) -C - F = S / H -C - DO 150 K = I, M - A(K,J) = A(K,J) + F * A(K,I) - 150 CONTINUE -C - 160 IF (IP .EQ. 0) GO TO 190 -C - DO 180 J = 1, IP - S = 0.0E0 -C - DO 170 K = I, M - 170 S = S + A(K,I) * B(K,J) -C - F = S / H -C - DO 180 K = I, M - B(K,J) = B(K,J) + F * A(K,I) - 180 CONTINUE -C - 190 DO 200 K = I, M - 200 A(K,I) = SCALE * A(K,I) -C - 210 W(I) = SCALE * G - G = 0.0E0 - S = 0.0E0 - SCALE = 0.0E0 - IF (I .GT. M .OR. I .EQ. N) GO TO 290 -C - DO 220 K = L, N - 220 SCALE = SCALE + ABS(A(I,K)) -C - IF (SCALE .EQ. 0.0E0) GO TO 290 -C - DO 230 K = L, N - A(I,K) = A(I,K) / SCALE - S = S + A(I,K)**2 - 230 CONTINUE -C - F = A(I,L) - G = -SIGN(SQRT(S),F) - H = F * G - S - A(I,L) = F - G -C - DO 240 K = L, N - 240 RV1(K) = A(I,K) / H -C - IF (I .EQ. M) GO TO 270 -C - DO 260 J = L, M - S = 0.0E0 -C - DO 250 K = L, N - 250 S = S + A(J,K) * A(I,K) -C - DO 260 K = L, N - A(J,K) = A(J,K) + S * RV1(K) - 260 CONTINUE -C - 270 DO 280 K = L, N - 280 A(I,K) = SCALE * A(I,K) -C - 290 S1 = MAX(S1,ABS(W(I))+ABS(RV1(I))) - 300 CONTINUE -C .......... ACCUMULATION OF RIGHT-HAND TRANSFORMATIONS. -C FOR I=N STEP -1 UNTIL 1 DO -- .......... - DO 400 II = 1, N - I = N + 1 - II - IF (I .EQ. N) GO TO 390 - IF (G .EQ. 0.0E0) GO TO 360 -C - DO 320 J = L, N -C .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW .......... - 320 A(J,I) = (A(I,J) / A(I,L)) / G -C - DO 350 J = L, N - S = 0.0E0 -C - DO 340 K = L, N - 340 S = S + A(I,K) * A(K,J) -C - DO 350 K = L, N - A(K,J) = A(K,J) + S * A(K,I) - 350 CONTINUE -C - 360 DO 380 J = L, N - A(I,J) = 0.0E0 - A(J,I) = 0.0E0 - 380 CONTINUE -C - 390 A(I,I) = 1.0E0 - G = RV1(I) - L = I - 400 CONTINUE -C - IF (M .GE. N .OR. IP .EQ. 0) GO TO 510 - M1 = M + 1 -C - DO 500 I = M1, N -C - DO 500 J = 1, IP - B(I,J) = 0.0E0 - 500 CONTINUE -C .......... DIAGONALIZATION OF THE BIDIAGONAL FORM .......... - 510 CONTINUE -C .......... FOR K=N STEP -1 UNTIL 1 DO -- .......... - DO 700 KK = 1, N - K1 = N - KK - K = K1 + 1 - ITS = 0 -C .......... TEST FOR SPLITTING. -C FOR L=K STEP -1 UNTIL 1 DO -- .......... - 520 DO 530 LL = 1, K - L1 = K - LL - L = L1 + 1 - IF (S1 + ABS(RV1(L)) .EQ. S1) GO TO 565 -C .......... RV1(1) IS ALWAYS ZERO, SO THERE IS NO EXIT -C THROUGH THE BOTTOM OF THE LOOP .......... - IF (S1 + ABS(W(L1)) .EQ. S1) GO TO 540 - 530 CONTINUE -C .......... CANCELLATION OF RV1(L) IF L GREATER THAN 1 .......... - 540 C = 0.0E0 - S = 1.0E0 -C - DO 560 I = L, K - F = S * RV1(I) - RV1(I) = C * RV1(I) - IF (S1 + ABS(F) .EQ. S1) GO TO 565 - G = W(I) - H = PYTHAG(F,G) - W(I) = H - C = G / H - S = -F / H - IF (IP .EQ. 0) GO TO 560 -C - DO 550 J = 1, IP - Y = B(L1,J) - Z = B(I,J) - B(L1,J) = Y * C + Z * S - B(I,J) = -Y * S + Z * C - 550 CONTINUE -C - 560 CONTINUE -C .......... TEST FOR CONVERGENCE .......... - 565 Z = W(K) - IF (L .EQ. K) GO TO 650 -C .......... SHIFT FROM BOTTOM 2 BY 2 MINOR .......... - IF (ITS .EQ. 30) GO TO 1000 - ITS = ITS + 1 - X = W(L) - Y = W(K1) - G = RV1(K1) - H = RV1(K) - F = 0.5E0 * (((G + Z) / H) * ((G - Z) / Y) + Y / H - H / Y) - G = PYTHAG(F,1.0E0) - F = X - (Z / X) * Z + (H / X) * (Y / (F + SIGN(G,F)) - H) -C .......... NEXT QR TRANSFORMATION .......... - C = 1.0E0 - S = 1.0E0 -C - DO 600 I1 = L, K1 - I = I1 + 1 - G = RV1(I) - Y = W(I) - H = S * G - G = C * G - Z = PYTHAG(F,H) - RV1(I1) = Z - C = F / Z - S = H / Z - F = X * C + G * S - G = -X * S + G * C - H = Y * S - Y = Y * C -C - DO 570 J = 1, N - X = A(J,I1) - Z = A(J,I) - A(J,I1) = X * C + Z * S - A(J,I) = -X * S + Z * C - 570 CONTINUE -C - Z = PYTHAG(F,H) - W(I1) = Z -C .......... ROTATION CAN BE ARBITRARY IF Z IS ZERO .......... - IF (Z .EQ. 0.0E0) GO TO 580 - C = F / Z - S = H / Z - 580 F = C * G + S * Y - X = -S * G + C * Y - IF (IP .EQ. 0) GO TO 600 -C - DO 590 J = 1, IP - Y = B(I1,J) - Z = B(I,J) - B(I1,J) = Y * C + Z * S - B(I,J) = -Y * S + Z * C - 590 CONTINUE -C - 600 CONTINUE -C - RV1(L) = 0.0E0 - RV1(K) = F - W(K) = X - GO TO 520 -C .......... CONVERGENCE .......... - 650 IF (Z .GE. 0.0E0) GO TO 700 -C .......... W(K) IS MADE NON-NEGATIVE .......... - W(K) = -Z -C - DO 690 J = 1, N - 690 A(J,K) = -A(J,K) -C - 700 CONTINUE -C - GO TO 1001 -C .......... SET ERROR -- NO CONVERGENCE TO A -C SINGULAR VALUE AFTER 30 ITERATIONS .......... - 1000 IERR = K - 1001 RETURN - END diff --git a/slatec/minso4.f b/slatec/minso4.f deleted file mode 100644 index 277b4cf..0000000 --- a/slatec/minso4.f +++ /dev/null @@ -1,64 +0,0 @@ -*DECK MINSO4 - SUBROUTINE MINSO4 (USOL, IDMN, ZN, ZM, PERTB) -C***BEGIN PROLOGUE MINSO4 -C***SUBSIDIARY -C***PURPOSE Subsidiary to SEPX4 -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (MINSO4-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This subroutine orthogonalizes the array USOL with respect to -C the constant array in a weighted least squares norm. -C -C Entry at MINSO4 occurs when the final solution is -C to be minimized with respect to the weighted -C least squares norm. -C -C***SEE ALSO SEPX4 -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS SPL4 -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE MINSO4 -C - COMMON /SPL4/ KSWX ,KSWY ,K ,L , - 1 AIT ,BIT ,CIT ,DIT , - 2 MIT ,NIT ,IS ,MS , - 3 JS ,NS ,DLX ,DLY , - 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 - DIMENSION USOL(IDMN,*) ,ZN(*) ,ZM(*) -C***FIRST EXECUTABLE STATEMENT MINSO4 - ISTR = 1 - IFNL = K - JSTR = 1 - JFNL = L -C -C COMPUTE WEIGHTED INNER PRODUCTS -C - UTE = 0.0 - ETE = 0.0 - DO 20 I=IS,MS - II = I-IS+1 - DO 10 J=JS,NS - JJ = J-JS+1 - ETE = ETE+ZM(II)*ZN(JJ) - UTE = UTE+USOL(I,J)*ZM(II)*ZN(JJ) - 10 CONTINUE - 20 CONTINUE -C -C SET PERTURBATION PARAMETER -C - PERTRB = UTE/ETE -C -C SUBTRACT OFF CONSTANT PERTRB -C - DO 40 I=ISTR,IFNL - DO 30 J=JSTR,JFNL - USOL(I,J) = USOL(I,J)-PERTRB - 30 CONTINUE - 40 CONTINUE - RETURN - END diff --git a/slatec/minsol.f b/slatec/minsol.f deleted file mode 100644 index 5d5db2f..0000000 --- a/slatec/minsol.f +++ /dev/null @@ -1,64 +0,0 @@ -*DECK MINSOL - SUBROUTINE MINSOL (USOL, IDMN, ZN, ZM, PERTB) -C***BEGIN PROLOGUE MINSOL -C***SUBSIDIARY -C***PURPOSE Subsidiary to SEPELI -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (MINSOL-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This subroutine orthogonalizes the array USOL with respect to -C the constant array in a weighted least squares norm. -C -C Entry at MINSOL occurs when the final solution is -C to be minimized with respect to the weighted -C least squares norm. -C -C***SEE ALSO SEPELI -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS SPLPCM -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE MINSOL -C - COMMON /SPLPCM/ KSWX ,KSWY ,K ,L , - 1 AIT ,BIT ,CIT ,DIT , - 2 MIT ,NIT ,IS ,MS , - 3 JS ,NS ,DLX ,DLY , - 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 - DIMENSION USOL(IDMN,*) ,ZN(*) ,ZM(*) -C***FIRST EXECUTABLE STATEMENT MINSOL - ISTR = 1 - IFNL = K - JSTR = 1 - JFNL = L -C -C COMPUTE WEIGHTED INNER PRODUCTS -C - UTE = 0.0 - ETE = 0.0 - DO 20 I=IS,MS - II = I-IS+1 - DO 10 J=JS,NS - JJ = J-JS+1 - ETE = ETE+ZM(II)*ZN(JJ) - UTE = UTE+USOL(I,J)*ZM(II)*ZN(JJ) - 10 CONTINUE - 20 CONTINUE -C -C SET PERTURBATION PARAMETER -C - PERTRB = UTE/ETE -C -C SUBTRACT OFF CONSTANT PERTRB -C - DO 40 I=ISTR,IFNL - DO 30 J=JSTR,JFNL - USOL(I,J) = USOL(I,J)-PERTRB - 30 CONTINUE - 40 CONTINUE - RETURN - END diff --git a/slatec/mpadd.f b/slatec/mpadd.f deleted file mode 100644 index 2edecc8..0000000 --- a/slatec/mpadd.f +++ /dev/null @@ -1,27 +0,0 @@ -*DECK MPADD - SUBROUTINE MPADD (X, Y, Z) -C***BEGIN PROLOGUE MPADD -C***SUBSIDIARY -C***PURPOSE Subsidiary to DQDOTA and DQDOTI -C***LIBRARY SLATEC -C***TYPE ALL (MPADD-A) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Adds X and Y, forming result in Z, where X, Y and Z are 'mp' -C (multiple precision) numbers. Four guard digits are used, -C and then R*-rounding. -C -C***SEE ALSO DQDOTA, DQDOTI -C***ROUTINES CALLED MPADD2 -C***REVISION HISTORY (YYMMDD) -C 791001 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE MPADD - INTEGER X(*), Y(*), Z(*) -C***FIRST EXECUTABLE STATEMENT MPADD - CALL MPADD2 (X, Y, Z, Y, 0) - RETURN - END diff --git a/slatec/mpadd2.f b/slatec/mpadd2.f deleted file mode 100644 index 636c1b6..0000000 --- a/slatec/mpadd2.f +++ /dev/null @@ -1,95 +0,0 @@ -*DECK MPADD2 - SUBROUTINE MPADD2 (X, Y, Z, Y1, TRUNC) -C***BEGIN PROLOGUE MPADD2 -C***SUBSIDIARY -C***PURPOSE Subsidiary to DQDOTA and DQDOTI -C***LIBRARY SLATEC -C***TYPE ALL (MPADD2-A) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Called by MPADD, MPSUB etc. -C X, Y and Z are MP numbers, Y1 and TRUNC are integers. -C To force call by reference rather than value/result, Y1 is -C declared as an array, but only Y1(1) is ever used. -C Sets Z = X + Y1(1)*ABS(Y), where Y1(1) = +- Y(1). -C If TRUNC .EQ. 0, R*-rounding is used; otherwise, truncation. -C R*-rounding is defined in the Kuki and Cody reference. -C -C The arguments X(*), Y(*), and Z(*) are all INTEGER arrays of size -C 30. See the comments in the routine MPBLAS for the reason for this -C choice. -C -C***SEE ALSO DQDOTA, DQDOTI, MPBLAS -C***REFERENCES H. Kuki and W. J. Cody, A statistical study of floating -C point number systems, Communications of the ACM 16, 4 -C (April 1973), pp. 223-230. -C R. P. Brent, On the precision attainable with various -C floating-point number systems, IEEE Transactions on -C Computers C-22, 6 (June 1973), pp. 601-607. -C R. P. Brent, A Fortran multiple-precision arithmetic -C package, ACM Transactions on Mathematical Software 4, -C 1 (March 1978), pp. 57-70. -C R. P. Brent, MP, a Fortran multiple-precision arithmetic -C package, Algorithm 524, ACM Transactions on Mathema- -C tical Software 4, 1 (March 1978), pp. 71-81. -C***ROUTINES CALLED MPADD3, MPCHK, MPERR, MPNZR, MPSTR -C***COMMON BLOCKS MPCOM -C***REVISION HISTORY (YYMMDD) -C 791001 DATE WRITTEN -C ?????? Modified for use with BLAS. Blank COMMON changed to named -C COMMON. R given dimension 12. -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 920528 Added a REFERENCES section revised. (WRB) -C 930124 Increased Array size in MPCON for SUN -r8. (RWC) -C***END PROLOGUE MPADD2 - COMMON /MPCOM/ B, T, M, LUN, MXR, R(30) - INTEGER B, T, R, X(*), Y(*), Z(*), Y1(*), TRUNC - INTEGER S, ED, RS, RE -C***FIRST EXECUTABLE STATEMENT MPADD2 - IF (X(1).NE.0) GO TO 20 - 10 CALL MPSTR(Y, Z) - Z(1) = Y1(1) - RETURN - 20 IF (Y1(1).NE.0) GO TO 40 - 30 CALL MPSTR (X, Z) - RETURN -C COMPARE SIGNS - 40 S = X(1)*Y1(1) - IF (ABS(S).LE.1) GO TO 60 - CALL MPCHK (1, 4) - WRITE (LUN, 50) - 50 FORMAT (' *** SIGN NOT 0, +1 OR -1 IN CALL TO MPADD2,', - 1 ' POSSIBLE OVERWRITING PROBLEM ***') - CALL MPERR - Z(1) = 0 - RETURN -C COMPARE EXPONENTS - 60 ED = X(2) - Y(2) - MED = ABS(ED) - IF (ED) 90, 70, 120 -C EXPONENTS EQUAL SO COMPARE SIGNS, THEN FRACTIONS IF NEC. - 70 IF (S.GT.0) GO TO 100 - DO 80 J = 1, T - IF (X(J+2) - Y(J+2)) 100, 80, 130 - 80 CONTINUE -C RESULT IS ZERO - Z(1) = 0 - RETURN -C HERE EXPONENT(Y) .GE. EXPONENT(X) - 90 IF (MED.GT.T) GO TO 10 - 100 RS = Y1(1) - RE = Y(2) - CALL MPADD3 (X, Y, S, MED, RE) -C NORMALIZE, ROUND OR TRUNCATE, AND RETURN - 110 CALL MPNZR (RS, RE, Z, TRUNC) - RETURN -C ABS(X) .GT. ABS(Y) - 120 IF (MED.GT.T) GO TO 30 - 130 RS = X(1) - RE = X(2) - CALL MPADD3 (Y, X, S, MED, RE) - GO TO 110 - END diff --git a/slatec/mpadd3.f b/slatec/mpadd3.f deleted file mode 100644 index 64c3e5f..0000000 --- a/slatec/mpadd3.f +++ /dev/null @@ -1,116 +0,0 @@ -*DECK MPADD3 - SUBROUTINE MPADD3 (X, Y, S, MED, RE) -C***BEGIN PROLOGUE MPADD3 -C***SUBSIDIARY -C***PURPOSE Subsidiary to DQDOTA and DQDOTI -C***LIBRARY SLATEC -C***TYPE ALL (MPADD3-A) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Called by MPADD2; does inner loops of addition -C -C The arguments X(*) and Y(*) and the variable R in COMMON are all -C INTEGER arrays of size 30. See the comments in the routine MPBLAS -C for the reason for this choice. -C -C***SEE ALSO DQDOTA, DQDOTI, MPBLAS -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS MPCOM -C***REVISION HISTORY (YYMMDD) -C 791001 DATE WRITTEN -C ?????? Modified for use with BLAS. Blank COMMON changed to named -C COMMON. R given dimension 12. -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 930124 Increased Array size in MPCON for SUN -r8. (RWC) -C***END PROLOGUE MPADD3 - COMMON /MPCOM/ B, T, M, LUN, MXR, R(30) - INTEGER B, T, R, X(*), Y(*), S, RE, C, TED -C***FIRST EXECUTABLE STATEMENT MPADD3 - TED = T + MED - I2 = T + 4 - I = I2 - C = 0 -C CLEAR GUARD DIGITS TO RIGHT OF X DIGITS - 10 IF (I.LE.TED) GO TO 20 - R(I) = 0 - I = I - 1 - GO TO 10 - 20 IF (S.LT.0) GO TO 130 -C HERE DO ADDITION, EXPONENT(Y) .GE. EXPONENT(X) - IF (I.LT.T) GO TO 40 - 30 J = I - MED - R(I) = X(J+2) - I = I - 1 - IF (I.GT.T) GO TO 30 - 40 IF (I.LE.MED) GO TO 60 - J = I - MED - C = Y(I+2) + X(J+2) + C - IF (C.LT.B) GO TO 50 -C CARRY GENERATED HERE - R(I) = C - B - C = 1 - I = I - 1 - GO TO 40 -C NO CARRY GENERATED HERE - 50 R(I) = C - C = 0 - I = I - 1 - GO TO 40 - 60 IF (I.LE.0) GO TO 90 - C = Y(I+2) + C - IF (C.LT.B) GO TO 70 - R(I) = 0 - C = 1 - I = I - 1 - GO TO 60 - 70 R(I) = C - I = I - 1 -C NO CARRY POSSIBLE HERE - 80 IF (I.LE.0) RETURN - R(I) = Y(I+2) - I = I - 1 - GO TO 80 - 90 IF (C.EQ.0) RETURN -C MUST SHIFT RIGHT HERE AS CARRY OFF END - I2P = I2 + 1 - DO 100 J = 2, I2 - I = I2P - J - 100 R(I+1) = R(I) - R(1) = 1 - RE = RE + 1 - RETURN -C HERE DO SUBTRACTION, ABS(Y) .GT. ABS(X) - 110 J = I - MED - R(I) = C - X(J+2) - C = 0 - IF (R(I).GE.0) GO TO 120 -C BORROW GENERATED HERE - C = -1 - R(I) = R(I) + B - 120 I = I - 1 - 130 IF (I.GT.T) GO TO 110 - 140 IF (I.LE.MED) GO TO 160 - J = I - MED - C = Y(I+2) + C - X(J+2) - IF (C.GE.0) GO TO 150 -C BORROW GENERATED HERE - R(I) = C + B - C = -1 - I = I - 1 - GO TO 140 -C NO BORROW GENERATED HERE - 150 R(I) = C - C = 0 - I = I - 1 - GO TO 140 - 160 IF (I.LE.0) RETURN - C = Y(I+2) + C - IF (C.GE.0) GO TO 70 - R(I) = C + B - C = -1 - I = I - 1 - GO TO 160 - END diff --git a/slatec/mpblas.f b/slatec/mpblas.f deleted file mode 100644 index 2882714..0000000 --- a/slatec/mpblas.f +++ /dev/null @@ -1,78 +0,0 @@ -*DECK MPBLAS - SUBROUTINE MPBLAS (I1) -C***BEGIN PROLOGUE MPBLAS -C***SUBSIDIARY -C***PURPOSE Subsidiary to DQDOTA and DQDOTI -C***LIBRARY SLATEC -C***TYPE ALL (MPBLAS-A) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This subroutine is called to set up Brent's 'mp' package -C for use by the extended precision inner products from the BLAS. -C -C In the SLATEC library we require the Extended Precision MP number -C to have a mantissa twice as long as Double Precision numbers. -C The calculation of MPT (and MPMXR which is the actual array size) -C in this routine will give 2x (or slightly more) on the machine -C that we are running on. The INTEGER array size of 30 was chosen -C to be slightly longer than the longest INTEGER array needed on -C any machine that we are currently aware of. -C -C***SEE ALSO DQDOTA, DQDOTI -C***REFERENCES R. P. Brent, A Fortran multiple-precision arithmetic -C package, ACM Transactions on Mathematical Software 4, -C 1 (March 1978), pp. 57-70. -C R. P. Brent, MP, a Fortran multiple-precision arithmetic -C package, Algorithm 524, ACM Transactions on Mathema- -C tical Software 4, 1 (March 1978), pp. 71-81. -C***ROUTINES CALLED I1MACH, XERMSG -C***COMMON BLOCKS MPCOM -C***REVISION HISTORY (YYMMDD) -C 791001 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 900402 Added TYPE section. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 930124 Increased Array size in MPCON for SUN -r8, and calculate -C size for Quad Precision for 2x DP. (RWC) -C***END PROLOGUE MPBLAS - COMMON /MPCOM/ MPB, MPT, MPM, MPLUN, MPMXR, MPR(30) -C***FIRST EXECUTABLE STATEMENT MPBLAS - I1 = 1 -C -C For full extended precision accuracy, MPB should be as large as -C possible, subject to the restrictions in Brent's paper. -C -C Statements below are for an integer wordlength of 48, 36, 32, -C 24, 18, and 16. Pick one, or generate a new one. -C 48 MPB = 4194304 -C 36 MPB = 65536 -C 32 MPB = 16384 -C 24 MPB = 1024 -C 18 MPB = 128 -C 16 MPB = 64 -C - MPBEXP = I1MACH(8)/2-2 - MPB = 2**MPBEXP -C -C Set up remaining parameters -C UNIT FOR ERROR MESSAGES - MPLUN = I1MACH(4) -C NUMBER OF MP DIGITS - MPT = (2*I1MACH(14)+MPBEXP-1)/MPBEXP -C DIMENSION OF R - MPMXR = MPT+4 -C - if (MPMXR.GT.30) THEN - CALL XERMSG('SLATEC', 'MPBLAS', - * 'Array space not sufficient for Quad Precision 2x ' // - * 'Double Precision, Proceeding.', 1, 1) - MPT = 26 - MPMXR = 30 - ENDIF -C EXPONENT RANGE - MPM = MIN(32767,I1MACH(9)/4-1) - RETURN - END diff --git a/slatec/mpcdm.f b/slatec/mpcdm.f deleted file mode 100644 index a471d48..0000000 --- a/slatec/mpcdm.f +++ /dev/null @@ -1,92 +0,0 @@ -*DECK MPCDM - SUBROUTINE MPCDM (DX, Z) -C***BEGIN PROLOGUE MPCDM -C***SUBSIDIARY -C***PURPOSE Subsidiary to DQDOTA and DQDOTI -C***LIBRARY SLATEC -C***TYPE ALL (MPCDM-A) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Converts double-precision number DX to multiple-precision Z. -C Some numbers will not convert exactly on machines with base -C other than two, four or sixteen. This routine is not called -C by any other routine in 'mp', so may be omitted if double- -C precision is not available. -C -C The argument Z(*) and the variable R in COMMON are both INTEGER -C arrays of size 30. See the comments in the routine MPBLAS for the -C for the reason for this choice. -C -C***SEE ALSO DQDOTA, DQDOTI, MPBLAS -C***ROUTINES CALLED MPCHK, MPDIVI, MPMULI, MPNZR -C***COMMON BLOCKS MPCOM -C***REVISION HISTORY (YYMMDD) -C 791001 DATE WRITTEN -C ?????? Modified for use with BLAS. Blank COMMON changed to named -C COMMON. R given dimension 12. -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 930124 Increased Array size in MPCON for SUN -r8. (RWC) -C***END PROLOGUE MPCDM - DOUBLE PRECISION DB, DJ, DX - COMMON /MPCOM/ B, T, M, LUN, MXR, R(30) - INTEGER B, T, R, Z(*), RS, RE, TP -C***FIRST EXECUTABLE STATEMENT MPCDM - CALL MPCHK (1, 4) - I2 = T + 4 -C CHECK SIGN - IF (DX) 20, 10, 30 -C IF DX = 0D0 RETURN 0 - 10 Z(1) = 0 - RETURN -C DX .LT. 0D0 - 20 RS = -1 - DJ = -DX - GO TO 40 -C DX .GT. 0D0 - 30 RS = 1 - DJ = DX - 40 IE = 0 - 50 IF (DJ.LT.1D0) GO TO 60 -C INCREASE IE AND DIVIDE DJ BY 16. - IE = IE + 1 - DJ = 0.0625D0*DJ - GO TO 50 - 60 IF (DJ.GE.0.0625D0) GO TO 70 - IE = IE - 1 - DJ = 16D0*DJ - GO TO 60 -C NOW DJ IS DY DIVIDED BY SUITABLE POWER OF 16 -C SET EXPONENT TO 0 - 70 RE = 0 - DB = DBLE(B) -C CONVERSION LOOP (ASSUME DOUBLE-PRECISION OPS. EXACT) - DO 80 I = 1, I2 - DJ = DB*DJ - R(I) = INT(DJ) - 80 DJ = DJ - DBLE(R(I)) -C NORMALIZE RESULT - CALL MPNZR (RS, RE, Z, 0) - IB = MAX(7*B*B, 32767)/16 - TP = 1 -C NOW MULTIPLY BY 16**IE - IF (IE) 90, 130, 110 - 90 K = -IE - DO 100 I = 1, K - TP = 16*TP - IF ((TP.LE.IB).AND.(TP.NE.B).AND.(I.LT.K)) GO TO 100 - CALL MPDIVI (Z, TP, Z) - TP = 1 - 100 CONTINUE - RETURN - 110 DO 120 I = 1, IE - TP = 16*TP - IF ((TP.LE.IB).AND.(TP.NE.B).AND.(I.LT.IE)) GO TO 120 - CALL MPMULI (Z, TP, Z) - TP = 1 - 120 CONTINUE - 130 RETURN - END diff --git a/slatec/mpchk.f b/slatec/mpchk.f deleted file mode 100644 index ae14c95..0000000 --- a/slatec/mpchk.f +++ /dev/null @@ -1,66 +0,0 @@ -*DECK MPCHK - SUBROUTINE MPCHK (I, J) -C***BEGIN PROLOGUE MPCHK -C***SUBSIDIARY -C***PURPOSE Subsidiary to DQDOTA and DQDOTI -C***LIBRARY SLATEC -C***TYPE ALL (MPCHK-A) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Checks legality of B, T, M, MXR and LUN which should be set -C in COMMON. The condition on MXR (the dimension of the EP arrays) -C is that MXR .GE. (I*T + J) -C -C***SEE ALSO DQDOTA, DQDOTI, MPBLAS -C***ROUTINES CALLED I1MACH, MPERR -C***COMMON BLOCKS MPCOM -C***REVISION HISTORY (YYMMDD) -C 791001 DATE WRITTEN -C ?????? Modified for use with BLAS. Blank COMMON changed to named -C COMMON. R given dimension 12. -C 891009 Removed unreferenced statement label. (WRB) -C 891009 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 930124 Increased Array size in MPCON for SUN -r8. (RWC) -C***END PROLOGUE MPCHK - COMMON /MPCOM/ B, T, M, LUN, MXR, R(30) - INTEGER B, T, R -C***FIRST EXECUTABLE STATEMENT MPCHK - LUN = I1MACH(4) -C NOW CHECK LEGALITY OF B, T AND M - IF (B.GT.1) GO TO 40 - WRITE (LUN, 30) B - 30 FORMAT (' *** B =', I10, ' ILLEGAL IN CALL TO MPCHK,'/ - 1 ' PERHAPS NOT SET BEFORE CALL TO AN MP ROUTINE ***') - CALL MPERR - 40 IF (T.GT.1) GO TO 60 - WRITE (LUN, 50) T - 50 FORMAT (' *** T =', I10, ' ILLEGAL IN CALL TO MPCHK,'/ - 1 ' PERHAPS NOT SET BEFORE CALL TO AN MP ROUTINE ***') - CALL MPERR - 60 IF (M.GT.T) GO TO 80 - WRITE (LUN, 70) - 70 FORMAT (' *** M .LE. T IN CALL TO MPCHK,'/ - 1 ' PERHAPS NOT SET BEFORE CALL TO AN MP ROUTINE ***') - CALL MPERR -C 8*B*B-1 SHOULD BE REPRESENTABLE, IF NOT WILL OVERFLOW -C AND MAY BECOME NEGATIVE, SO CHECK FOR THIS - 80 IB = 4*B*B - 1 - IF ((IB.GT.0).AND.((2*IB+1).GT.0)) GO TO 100 - WRITE (LUN, 90) - 90 FORMAT (' *** B TOO LARGE IN CALL TO MPCHK ***') - CALL MPERR -C CHECK THAT SPACE IN COMMON IS SUFFICIENT - 100 MX = I*T + J - IF (MXR.GE.MX) RETURN -C HERE COMMON IS TOO SMALL, SO GIVE ERROR MESSAGE. - WRITE (LUN, 110) I, J, MX, MXR, T - 110 FORMAT (' *** MXR TOO SMALL OR NOT SET TO DIM(R) BEFORE CALL', - 1 ' TO AN MP ROUTINE *** ' / - 2 ' *** MXR SHOULD BE AT LEAST', I3, '*T +', I4, ' =', I6, ' ***' - 3 / ' *** ACTUALLY MXR =', I10, ', AND T =', I10, ' ***') - CALL MPERR - RETURN - END diff --git a/slatec/mpcmd.f b/slatec/mpcmd.f deleted file mode 100644 index 84e5e77..0000000 --- a/slatec/mpcmd.f +++ /dev/null @@ -1,62 +0,0 @@ -*DECK MPCMD - SUBROUTINE MPCMD (X, DZ) -C***BEGIN PROLOGUE MPCMD -C***SUBSIDIARY -C***PURPOSE Subsidiary to DQDOTA and DQDOTI -C***LIBRARY SLATEC -C***TYPE ALL (MPCMD-A) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Converts multiple-precision X to double-precision DZ. Assumes -C X is in allowable range for double-precision numbers. There is -C some loss of accuracy if the exponent is large. -C -C The argument X(*) is INTEGER array of size 30. See the comments in -C the routine MPBLAS for the reason for this choice. -C -C***SEE ALSO DQDOTA, DQDOTI, MPBLAS -C***ROUTINES CALLED MPCHK, MPERR -C***COMMON BLOCKS MPCOM -C***REVISION HISTORY (YYMMDD) -C 791001 DATE WRITTEN -C ?????? Modified for use with BLAS. Blank COMMON changed to named -C COMMON. R given dimension 12. -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 930124 Increased Array size in MPCON for SUN -r8. (RWC) -C***END PROLOGUE MPCMD - DOUBLE PRECISION DB, DZ, DZ2 - COMMON /MPCOM/ B, T, M, LUN, MXR, R(30) - INTEGER B, T, R, X(*), TM -C***FIRST EXECUTABLE STATEMENT MPCMD - CALL MPCHK (1, 4) - DZ = 0D0 - IF (X(1).EQ.0) RETURN - DB = DBLE(B) - DO 10 I = 1, T - DZ = DB*DZ + DBLE(X(I+2)) - TM = I -C CHECK IF FULL DOUBLE-PRECISION ACCURACY ATTAINED - DZ2 = DZ + 1D0 -C TEST BELOW NOT ALWAYS EQUIVALENT TO - IF (DZ2.LE.DZ) GO TO 20, -C FOR EXAMPLE ON CYBER 76. - IF ((DZ2-DZ).LE.0D0) GO TO 20 - 10 CONTINUE -C NOW ALLOW FOR EXPONENT - 20 DZ = DZ*(DB**(X(2)-TM)) -C CHECK REASONABLENESS OF RESULT. - IF (DZ.LE.0D0) GO TO 30 -C LHS SHOULD BE .LE. 0.5 BUT ALLOW FOR SOME ERROR IN LOG - IF (ABS(DBLE(X(2))-(LOG(DZ)/ - 1 LOG(DBLE(B))+0.5D0)).GT.0.6D0) GO TO 30 - IF (X(1).LT.0) DZ = -DZ - RETURN -C FOLLOWING MESSAGE INDICATES THAT X IS TOO LARGE OR SMALL - -C TRY USING MPCMDE INSTEAD. - 30 WRITE (LUN, 40) - 40 FORMAT (' *** FLOATING-POINT OVER/UNDER-FLOW IN MPCMD ***') - CALL MPERR - RETURN - END diff --git a/slatec/mpdivi.f b/slatec/mpdivi.f deleted file mode 100644 index 0e09009..0000000 --- a/slatec/mpdivi.f +++ /dev/null @@ -1,139 +0,0 @@ -*DECK MPDIVI - SUBROUTINE MPDIVI (X, IY, Z) -C***BEGIN PROLOGUE MPDIVI -C***SUBSIDIARY -C***PURPOSE Subsidiary to DQDOTA and DQDOTI -C***LIBRARY SLATEC -C***TYPE ALL (MPDIVI-A) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Divides 'mp' X by the single-precision integer IY giving 'mp' Z. -C This is much faster than division by an 'mp' number. -C -C The arguments X(*) and Z(*), and the variable R in COMMON are all -C INTEGER arrays of size 30. See the comments in the routine MPBLAS -C for the reason for this choice. -C -C***SEE ALSO DQDOTA, DQDOTI, MPBLAS -C***ROUTINES CALLED MPCHK, MPERR, MPNZR, MPSTR, MPUNFL -C***COMMON BLOCKS MPCOM -C***REVISION HISTORY (YYMMDD) -C 791001 DATE WRITTEN -C ?????? Modified for use with BLAS. Blank COMMON changed to named -C COMMON. R given dimension 12. -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 930124 Increased Array size in MPCON for SUN -r8. (RWC) -C***END PROLOGUE MPDIVI - COMMON /MPCOM/ B, T, M, LUN, MXR, R(30) - INTEGER B, T, R, X(*), Z(*), RS, RE, R1, C, C2, B2 -C***FIRST EXECUTABLE STATEMENT MPDIVI - RS = X(1) - J = IY - IF (J) 30, 10, 40 - 10 WRITE (LUN, 20) - 20 FORMAT (' *** ATTEMPTED DIVISION BY ZERO IN CALL TO MPDIVI ***') - GO TO 230 - 30 J = -J - RS = -RS - 40 RE = X(2) -C CHECK FOR ZERO DIVIDEND - IF (RS.EQ.0) GO TO 120 -C CHECK FOR DIVISION BY B - IF (J.NE.B) GO TO 50 - CALL MPSTR (X, Z) - IF (RE.LE.(-M)) GO TO 240 - Z(1) = RS - Z(2) = RE - 1 - RETURN -C CHECK FOR DIVISION BY 1 OR -1 - 50 IF (J.NE.1) GO TO 60 - CALL MPSTR (X, Z) - Z(1) = RS - RETURN - 60 C = 0 - I2 = T + 4 - I = 0 -C IF J*B NOT REPRESENTABLE AS AN INTEGER HAVE TO SIMULATE -C LONG DIVISION. ASSUME AT LEAST 16-BIT WORD. - B2 = MAX(8*B,32767/B) - IF (J.GE.B2) GO TO 130 -C LOOK FOR FIRST NONZERO DIGIT IN QUOTIENT - 70 I = I + 1 - C = B*C - IF (I.LE.T) C = C + X(I+2) - R1 = C/J - IF (R1) 210, 70, 80 -C ADJUST EXPONENT AND GET T+4 DIGITS IN QUOTIENT - 80 RE = RE + 1 - I - R(1) = R1 - C = B*(C - J*R1) - KH = 2 - IF (I.GE.T) GO TO 100 - KH = 1 + T - I - DO 90 K = 2, KH - I = I + 1 - C = C + X(I+2) - R(K) = C/J - 90 C = B*(C - J*R(K)) - IF (C.LT.0) GO TO 210 - KH = KH + 1 - 100 DO 110 K = KH, I2 - R(K) = C/J - 110 C = B*(C - J*R(K)) - IF (C.LT.0) GO TO 210 -C NORMALIZE AND ROUND RESULT - 120 CALL MPNZR (RS, RE, Z, 0) - RETURN -C HERE NEED SIMULATED DOUBLE-PRECISION DIVISION - 130 C2 = 0 - J1 = J/B - J2 = J - J1*B - J11 = J1 + 1 -C LOOK FOR FIRST NONZERO DIGIT - 140 I = I + 1 - C = B*C + C2 - C2 = 0 - IF (I.LE.T) C2 = X(I+2) - IF (C-J1) 140, 150, 160 - 150 IF (C2.LT.J2) GO TO 140 -C COMPUTE T+4 QUOTIENT DIGITS - 160 RE = RE + 1 - I - K = 1 - GO TO 180 -C MAIN LOOP FOR LARGE ABS(IY) CASE - 170 K = K + 1 - IF (K.GT.I2) GO TO 120 - I = I + 1 -C GET APPROXIMATE QUOTIENT FIRST - 180 IR = C/J11 -C NOW REDUCE SO OVERFLOW DOES NOT OCCUR - IQ = C - IR*J1 - IF (IQ.LT.B2) GO TO 190 -C HERE IQ*B WOULD POSSIBLY OVERFLOW SO INCREASE IR - IR = IR + 1 - IQ = IQ - J1 - 190 IQ = IQ*B - IR*J2 - IF (IQ.GE.0) GO TO 200 -C HERE IQ NEGATIVE SO IR WAS TOO LARGE - IR = IR - 1 - IQ = IQ + J - 200 IF (I.LE.T) IQ = IQ + X(I+2) - IQJ = IQ/J -C R(K) = QUOTIENT, C = REMAINDER - R(K) = IQJ + IR - C = IQ - J*IQJ - IF (C.GE.0) GO TO 170 -C CARRY NEGATIVE SO OVERFLOW MUST HAVE OCCURRED - 210 CALL MPCHK (1, 4) - WRITE (LUN, 220) - 220 FORMAT (' *** INTEGER OVERFLOW IN MPDIVI, B TOO LARGE ***') - 230 CALL MPERR - Z(1) = 0 - RETURN -C UNDERFLOW HERE - 240 CALL MPUNFL(Z) - RETURN - END diff --git a/slatec/mperr.f b/slatec/mperr.f deleted file mode 100644 index e38ed50..0000000 --- a/slatec/mperr.f +++ /dev/null @@ -1,41 +0,0 @@ -*DECK MPERR - SUBROUTINE MPERR -C***BEGIN PROLOGUE MPERR -C***SUBSIDIARY -C***PURPOSE Subsidiary to DQDOTA and DQDOTI -C***LIBRARY SLATEC -C***TYPE ALL (MPERR-A) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This routine is called when a fatal error condition is -C encountered, and after a message has been written on -C logical unit LUN. -C -C***SEE ALSO DQDOTA, DQDOTI, MPBLAS -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS MPCOM -C***REVISION HISTORY (YYMMDD) -C 791001 DATE WRITTEN -C ?????? Modified for use with BLAS. Blank COMMON changed to named -C COMMON. R given dimension 12. -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 930124 Increased Array size in MPCON for SUN -r8. (RWC) -C***END PROLOGUE MPERR - COMMON /MPCOM/ B, T, M, LUN, MXR, R(30) - INTEGER B, T, R -C***FIRST EXECUTABLE STATEMENT MPERR - CALL XERMSG('SLATEC', 'MPERR', - 1 ' *** EXECUTION TERMINATED BY CALL TO MPERR' // - 2 ' IN MP VERSION 770217 ***', 1, 2) -C -C AT PRESENT JUST STOP, BUT COULD DUMP B, T, ETC. HERE. -C ACTION COULD EASILY BE CONTROLLED BY A FLAG IN LABELLED COMMON. -C ANSI VERSION USES STOP, UNIVAC 1108 VERSION USES -C RETURN 0 IN ORDER TO GIVE A TRACE-BACK. -C FOR DEBUGGING PURPOSES IT MAY BE USEFUL SIMPLY TO -C RETURN HERE. MOST MP ROUTINES RETURN WITH RESULT -C ZERO AFTER CALLING MPERR. - STOP - END diff --git a/slatec/mpmaxr.f b/slatec/mpmaxr.f deleted file mode 100644 index 9eaba4f..0000000 --- a/slatec/mpmaxr.f +++ /dev/null @@ -1,39 +0,0 @@ -*DECK MPMAXR - SUBROUTINE MPMAXR (X) -C***BEGIN PROLOGUE MPMAXR -C***SUBSIDIARY -C***PURPOSE Subsidiary to DQDOTA and DQDOTI -C***LIBRARY SLATEC -C***TYPE ALL (MPMAXR-A) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Sets X to the largest possible positive 'mp' number. -C -C The argument X(*) is an INTEGER arrays of size 30. See the comments -C in the routine MPBLAS for the reason for this choice. -C -C***SEE ALSO DQDOTA, DQDOTI, MPBLAS -C***ROUTINES CALLED MPCHK -C***COMMON BLOCKS MPCOM -C***REVISION HISTORY (YYMMDD) -C 791001 DATE WRITTEN -C ?????? Modified for use with BLAS. Blank COMMON changed to named -C COMMON. R given dimension 12. -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 930124 Increased Array size in MPCON for SUN -r8. (RWC) -C***END PROLOGUE MPMAXR - COMMON /MPCOM/ B, T, M, LUN, MXR, R(30) - INTEGER B, T, R, X(*) -C***FIRST EXECUTABLE STATEMENT MPMAXR - CALL MPCHK (1, 4) - IT = B - 1 -C SET FRACTION DIGITS TO B-1 - DO 10 I = 1, T - 10 X(I+2) = IT -C SET SIGN AND EXPONENT - X(1) = 1 - X(2) = M - RETURN - END diff --git a/slatec/mpmlp.f b/slatec/mpmlp.f deleted file mode 100644 index 2d6a0a7..0000000 --- a/slatec/mpmlp.f +++ /dev/null @@ -1,27 +0,0 @@ -*DECK MPMLP - SUBROUTINE MPMLP (U, V, W, J) -C***BEGIN PROLOGUE MPMLP -C***SUBSIDIARY -C***PURPOSE Subsidiary to DQDOTA and DQDOTI -C***LIBRARY SLATEC -C***TYPE ALL (MPMLP-A) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Performs inner multiplication loop for MPMUL. Carries are not pro- -C pagated in inner loop, which saves time at the expense of space. -C -C***SEE ALSO DQDOTA, DQDOTI -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 791001 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE MPMLP - INTEGER U(*), V(*), W -C***FIRST EXECUTABLE STATEMENT MPMLP - DO 10 I = 1, J - 10 U(I) = U(I) + W*V(I) - RETURN - END diff --git a/slatec/mpmul.f b/slatec/mpmul.f deleted file mode 100644 index bc8dd73..0000000 --- a/slatec/mpmul.f +++ /dev/null @@ -1,98 +0,0 @@ -*DECK MPMUL - SUBROUTINE MPMUL (X, Y, Z) -C***BEGIN PROLOGUE MPMUL -C***SUBSIDIARY -C***PURPOSE Subsidiary to DQDOTA and DQDOTI -C***LIBRARY SLATEC -C***TYPE ALL (MPMUL-A) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Multiplies X and Y, returning result in Z, for 'mp' X, Y and Z. -C The simple o(t**2) algorithm is used, with four guard digits and -C R*-rounding. Advantage is taken of zero digits in X, but not in Y. -C Asymptotically faster algorithms are known (see Knuth, VOL. 2), -C but are difficult to implement in FORTRAN in an efficient and -C machine-independent manner. In comments to other 'mp' routines, -C M(t) is the time to perform t-digit 'mp' multiplication. Thus -C M(t) = o(t**2) with the present version of MPMUL, but -C M(t) = o(t.log(t).log(log(t))) is theoretically possible. -C -C The arguments X(*), Y(*), and Z(*), and the variable R in COMMON are -C all INTEGER arrays of size 30. See the comments in the routine -C MPBLAS for the reason for this choice. -C -C***SEE ALSO DQDOTA, DQDOTI, MPBLAS -C***ROUTINES CALLED MPCHK, MPERR, MPMLP, MPNZR -C***COMMON BLOCKS MPCOM -C***REVISION HISTORY (YYMMDD) -C 791001 DATE WRITTEN -C ?????? Modified for use with BLAS. Blank COMMON changed to named -C COMMON. R given dimension 12. -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 930124 Increased Array size in MPCON for SUN -r8. (RWC) -C***END PROLOGUE MPMUL - COMMON /MPCOM/ B, T, M, LUN, MXR, R(30) - INTEGER B, T, R, X(*), Y(*), Z(*), RS, RE, XI, C, RI -C***FIRST EXECUTABLE STATEMENT MPMUL - CALL MPCHK (1, 4) - I2 = T + 4 - I2P = I2 + 1 -C FORM SIGN OF PRODUCT - RS = X(1)*Y(1) - IF (RS.NE.0) GO TO 10 -C SET RESULT TO ZERO - Z(1) = 0 - RETURN -C FORM EXPONENT OF PRODUCT - 10 RE = X(2) + Y(2) -C CLEAR ACCUMULATOR - DO 20 I = 1, I2 - 20 R(I) = 0 -C PERFORM MULTIPLICATION - C = 8 - DO 40 I = 1, T - XI = X(I+2) -C FOR SPEED, PUT THE NUMBER WITH MANY ZEROS FIRST - IF (XI.EQ.0) GO TO 40 - CALL MPMLP (R(I+1), Y(3), XI, MIN (T, I2 - I)) - C = C - 1 - IF (C.GT.0) GO TO 40 -C CHECK FOR LEGAL BASE B DIGIT - IF ((XI.LT.0).OR.(XI.GE.B)) GO TO 90 -C PROPAGATE CARRIES AT END AND EVERY EIGHTH TIME, -C FASTER THAN DOING IT EVERY TIME. - DO 30 J = 1, I2 - J1 = I2P - J - RI = R(J1) + C - IF (RI.LT.0) GO TO 70 - C = RI/B - 30 R(J1) = RI - B*C - IF (C.NE.0) GO TO 90 - C = 8 - 40 CONTINUE - IF (C.EQ.8) GO TO 60 - IF ((XI.LT.0).OR.(XI.GE.B)) GO TO 90 - C = 0 - DO 50 J = 1, I2 - J1 = I2P - J - RI = R(J1) + C - IF (RI.LT.0) GO TO 70 - C = RI/B - 50 R(J1) = RI - B*C - IF (C.NE.0) GO TO 90 -C NORMALIZE AND ROUND RESULT - 60 CALL MPNZR (RS, RE, Z, 0) - RETURN - 70 WRITE (LUN, 80) - 80 FORMAT (' *** INTEGER OVERFLOW IN MPMUL, B TOO LARGE ***') - GO TO 110 - 90 WRITE (LUN, 100) - 100 FORMAT (' *** ILLEGAL BASE B DIGIT IN CALL TO MPMUL,', - 1 ' POSSIBLE OVERWRITING PROBLEM ***') - 110 CALL MPERR - Z(1) = 0 - RETURN - END diff --git a/slatec/mpmul2.f b/slatec/mpmul2.f deleted file mode 100644 index 660ec1c..0000000 --- a/slatec/mpmul2.f +++ /dev/null @@ -1,114 +0,0 @@ -*DECK MPMUL2 - SUBROUTINE MPMUL2 (X, IY, Z, TRUNC) -C***BEGIN PROLOGUE MPMUL2 -C***SUBSIDIARY -C***PURPOSE Subsidiary to DQDOTA and DQDOTI -C***LIBRARY SLATEC -C***TYPE ALL (MPMUL2-A) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Multiplies 'mp' X by single-precision integer IY giving 'mp' Z. -C Multiplication by 1 may be used to normalize a number even if some -C digits are greater than B-1. Result is rounded if TRUNC.EQ.0, -C otherwise truncated. -C -C The arguments X(*) and Z(*), and the variable R in COMMON are all -C INTEGER arrays of size 30. See the comments in the routine MPBLAS -C for the reason for this choice. -C -C***SEE ALSO DQDOTA, DQDOTI, MPBLAS -C***ROUTINES CALLED MPCHK, MPERR, MPNZR, MPOVFL, MPSTR -C***COMMON BLOCKS MPCOM -C***REVISION HISTORY (YYMMDD) -C 791001 DATE WRITTEN -C ?????? Modified for use with BLAS. Blank COMMON changed to named -C COMMON. R given dimension 12. -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 930124 Increased Array size in MPCON for SUN -r8. (RWC) -C***END PROLOGUE MPMUL2 - COMMON /MPCOM/ B, T, M, LUN, MXR, R(30) - INTEGER B, T, R, X(*), Z(*), TRUNC, RE, RS - INTEGER C, C1, C2, RI, T1, T3, T4 -C***FIRST EXECUTABLE STATEMENT MPMUL2 - RS = X(1) - IF (RS.EQ.0) GO TO 10 - J = IY - IF (J) 20, 10, 50 -C RESULT ZERO - 10 Z(1) = 0 - RETURN - 20 J = -J - RS = -RS -C CHECK FOR MULTIPLICATION BY B - IF (J.NE.B) GO TO 50 - IF (X(2).LT.M) GO TO 40 - CALL MPCHK (1, 4) - WRITE (LUN, 30) - 30 FORMAT (' *** OVERFLOW OCCURRED IN MPMUL2 ***') - CALL MPOVFL (Z) - RETURN - 40 CALL MPSTR (X, Z) - Z(1) = RS - Z(2) = X(2) + 1 - RETURN -C SET EXPONENT TO EXPONENT(X) + 4 - 50 RE = X(2) + 4 -C FORM PRODUCT IN ACCUMULATOR - C = 0 - T1 = T + 1 - T3 = T + 3 - T4 = T + 4 -C IF J*B NOT REPRESENTABLE AS AN INTEGER WE HAVE TO SIMULATE -C DOUBLE-PRECISION MULTIPLICATION. - IF (J.GE.MAX(8*B, 32767/B)) GO TO 110 - DO 60 IJ = 1, T - I = T1 - IJ - RI = J*X(I+2) + C - C = RI/B - 60 R(I+4) = RI - B*C -C CHECK FOR INTEGER OVERFLOW - IF (RI.LT.0) GO TO 130 -C HAVE TO TREAT FIRST FOUR WORDS OF R SEPARATELY - DO 70 IJ = 1, 4 - I = 5 - IJ - RI = C - C = RI/B - 70 R(I) = RI - B*C - IF (C.EQ.0) GO TO 100 -C HAVE TO SHIFT RIGHT HERE AS CARRY OFF END - 80 DO 90 IJ = 1, T3 - I = T4 - IJ - 90 R(I+1) = R(I) - RI = C - C = RI/B - R(1) = RI - B*C - RE = RE + 1 - IF (C) 130, 100, 80 -C NORMALIZE AND ROUND OR TRUNCATE RESULT - 100 CALL MPNZR (RS, RE, Z, TRUNC) - RETURN -C HERE J IS TOO LARGE FOR SINGLE-PRECISION MULTIPLICATION - 110 J1 = J/B - J2 = J - J1*B -C FORM PRODUCT - DO 120 IJ = 1, T4 - C1 = C/B - C2 = C - B*C1 - I = T1 - IJ - IX = 0 - IF (I.GT.0) IX = X(I+2) - RI = J2*IX + C2 - IS = RI/B - C = J1*IX + C1 + IS - 120 R(I+4) = RI - B*IS - IF (C) 130, 100, 80 -C CAN ONLY GET HERE IF INTEGER OVERFLOW OCCURRED - 130 CALL MPCHK (1, 4) - WRITE (LUN, 140) - 140 FORMAT (' *** INTEGER OVERFLOW IN MPMUL2, B TOO LARGE ***') - CALL MPERR - GO TO 10 - END diff --git a/slatec/mpmuli.f b/slatec/mpmuli.f deleted file mode 100644 index beedbb7..0000000 --- a/slatec/mpmuli.f +++ /dev/null @@ -1,28 +0,0 @@ -*DECK MPMULI - SUBROUTINE MPMULI (X, IY, Z) -C***BEGIN PROLOGUE MPMULI -C***SUBSIDIARY -C***PURPOSE Subsidiary to DQDOTA and DQDOTI -C***LIBRARY SLATEC -C***TYPE ALL (MPMULI-A) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Multiplies 'mp' X by single-precision integer IY giving 'mp' Z. -C This is faster than using MPMUL. Result is ROUNDED. -C Multiplication by 1 may be used to normalize a number -C even if the last digit is B. -C -C***SEE ALSO DQDOTA, DQDOTI -C***ROUTINES CALLED MPMUL2 -C***REVISION HISTORY (YYMMDD) -C 791001 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE MPMULI - INTEGER X(*), Z(*) -C***FIRST EXECUTABLE STATEMENT MPMULI - CALL MPMUL2 (X, IY, Z, 0) - RETURN - END diff --git a/slatec/mpnzr.f b/slatec/mpnzr.f deleted file mode 100644 index 568a364..0000000 --- a/slatec/mpnzr.f +++ /dev/null @@ -1,105 +0,0 @@ -*DECK MPNZR - SUBROUTINE MPNZR (RS, RE, Z, TRUNC) -C***BEGIN PROLOGUE MPNZR -C***SUBSIDIARY -C***PURPOSE Subsidiary to DQDOTA and DQDOTI -C***LIBRARY SLATEC -C***TYPE ALL (MPNZR-A) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Modified for use with BLAS. Blank COMMON changed to named COMMON. -C Assumes long (i.e. (t+4)-DIGIT) fraction in R, sign = RS, exponent -C = RE. Normalizes, and returns 'mp' result in Z. Integer arguments -C RS and RE are not preserved. R*-rounding is used if TRUNC.EQ.0 -C -C The argument Z(*) and the variable R in COMMON are INTEGER arrays -C of size 30. See the comments in the routine MPBLAS for the reason -C for this choice. -C -C***SEE ALSO DQDOTA, DQDOTI, MPBLAS -C***ROUTINES CALLED MPERR, MPOVFL, MPUNFL -C***COMMON BLOCKS MPCOM -C***REVISION HISTORY (YYMMDD) -C 791001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 930124 Increased Array size in MPCON for SUN -r8. (RWC) -C***END PROLOGUE MPNZR - COMMON /MPCOM/ B, T, M, LUN, MXR, R(30) - INTEGER B, T, R, Z(*), RE, RS, TRUNC, B2 -C***FIRST EXECUTABLE STATEMENT MPNZR - I2 = T + 4 - IF (RS.NE.0) GO TO 20 -C STORE ZERO IN Z - 10 Z(1) = 0 - RETURN -C CHECK THAT SIGN = +-1 - 20 IF (ABS(RS).LE.1) GO TO 40 - WRITE (LUN, 30) - 30 FORMAT (' *** SIGN NOT 0, +1 OR -1 IN CALL TO MPNZR,', - 1 ' POSSIBLE OVERWRITING PROBLEM ***') - CALL MPERR - GO TO 10 -C LOOK FOR FIRST NONZERO DIGIT - 40 DO 50 I = 1, I2 - IS = I - 1 - IF (R(I).GT.0) GO TO 60 - 50 CONTINUE -C FRACTION ZERO - GO TO 10 - 60 IF (IS.EQ.0) GO TO 90 -C NORMALIZE - RE = RE - IS - I2M = I2 - IS - DO 70 J = 1, I2M - K = J + IS - 70 R(J) = R(K) - I2P = I2M + 1 - DO 80 J = I2P, I2 - 80 R(J) = 0 -C CHECK TO SEE IF TRUNCATION IS DESIRED - 90 IF (TRUNC.NE.0) GO TO 150 -C SEE IF ROUNDING NECESSARY -C TREAT EVEN AND ODD BASES DIFFERENTLY - B2 = B/2 - IF ((2*B2).NE.B) GO TO 130 -C B EVEN. ROUND IF R(T+1).GE.B2 UNLESS R(T) ODD AND ALL ZEROS -C AFTER R(T+2). - IF (R(T+1) - B2) 150, 100, 110 - 100 IF (MOD(R(T),2).EQ.0) GO TO 110 - IF ((R(T+2)+R(T+3)+R(T+4)).EQ.0) GO TO 150 -C ROUND - 110 DO 120 J = 1, T - I = T + 1 - J - R(I) = R(I) + 1 - IF (R(I).LT.B) GO TO 150 - 120 R(I) = 0 -C EXCEPTIONAL CASE, ROUNDED UP TO .10000... - RE = RE + 1 - R(1) = 1 - GO TO 150 -C ODD BASE, ROUND IF R(T+1)... .GT. 1/2 - 130 DO 140 I = 1, 4 - IT = T + I - IF (R(IT) - B2) 150, 140, 110 - 140 CONTINUE -C CHECK FOR OVERFLOW - 150 IF (RE.LE.M) GO TO 170 - WRITE (LUN, 160) - 160 FORMAT (' *** OVERFLOW OCCURRED IN MPNZR ***') - CALL MPOVFL (Z) - RETURN -C CHECK FOR UNDERFLOW - 170 IF (RE.LT.(-M)) GO TO 190 -C STORE RESULT IN Z - Z(1) = RS - Z(2) = RE - DO 180 I = 1, T - 180 Z(I+2) = R(I) - RETURN -C UNDERFLOW HERE - 190 CALL MPUNFL (Z) - RETURN - END diff --git a/slatec/mpovfl.f b/slatec/mpovfl.f deleted file mode 100644 index 5042342..0000000 --- a/slatec/mpovfl.f +++ /dev/null @@ -1,44 +0,0 @@ -*DECK MPOVFL - SUBROUTINE MPOVFL (X) -C***BEGIN PROLOGUE MPOVFL -C***SUBSIDIARY -C***PURPOSE Subsidiary to DQDOTA and DQDOTI -C***LIBRARY SLATEC -C***TYPE ALL (MPOVFL-A) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Called on multiple-precision overflow, i.e. when the -C exponent of 'mp' number X would exceed M. At present execution is -C terminated with an error message after calling MPMAXR(X), but it -C would be possible to return, possibly updating a counter and -C terminating execution after a preset number of overflows. Action -C could easily be determined by a flag in labelled common. -C -C The argument X(*) is an INTEGER array of size 30. See the comments -C in the routine MPBLAS for the reason for this choice. -C -C***SEE ALSO DQDOTA, DQDOTI, MPBLAS -C***ROUTINES CALLED MPCHK, MPERR, MPMAXR -C***COMMON BLOCKS MPCOM -C***REVISION HISTORY (YYMMDD) -C 791001 DATE WRITTEN -C ?????? Modified for use with BLAS. Blank COMMON changed to named -C COMMON. R given dimension 12. -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 930124 Increased Array size in MPCON for SUN -r8. (RWC) -C***END PROLOGUE MPOVFL - COMMON /MPCOM/ B, T, M, LUN, MXR, R(30) - INTEGER B, T, R, X(*) -C***FIRST EXECUTABLE STATEMENT MPOVFL - CALL MPCHK (1, 4) -C SET X TO LARGEST POSSIBLE POSITIVE NUMBER - CALL MPMAXR (X) - WRITE (LUN, 10) - 10 FORMAT (' *** CALL TO MPOVFL, MP OVERFLOW OCCURRED ***') -C TERMINATE EXECUTION BY CALLING MPERR - CALL MPERR - RETURN - END diff --git a/slatec/mpstr.f b/slatec/mpstr.f deleted file mode 100644 index 30ab4a2..0000000 --- a/slatec/mpstr.f +++ /dev/null @@ -1,35 +0,0 @@ -*DECK MPSTR - SUBROUTINE MPSTR (X, Y) -C***BEGIN PROLOGUE MPSTR -C***SUBSIDIARY -C***PURPOSE Subsidiary to DQDOTA and DQDOTI -C***LIBRARY SLATEC -C***TYPE ALL (MPSTR-A) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Sets Y = X for 'mp' X and Y. -C -C The arguments X(*) and Y(*) are INTEGER arrays of size 30. See the -C comments in the routine MPBLAS for the reason for this choice. -C -C***SEE ALSO DQDOTA, DQDOTI, MPBLAS -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS MPCOM -C***REVISION HISTORY (YYMMDD) -C 791001 DATE WRITTEN -C ?????? Modified for use with BLAS. Blank COMMON changed to named -C COMMON. R given dimension 12. -C 890206 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 930124 Increased Array size in MPCON for SUN -r8. (RWC) -C***END PROLOGUE MPSTR - COMMON /MPCOM/ B, T, M, LUN, MXR, R(30) - INTEGER B, T, R, X(*), Y(*) -C***FIRST EXECUTABLE STATEMENT MPSTR - DO 10 I = 1, T+2 - Y(I) = X(I) - 10 CONTINUE - RETURN - END diff --git a/slatec/mpunfl.f b/slatec/mpunfl.f deleted file mode 100644 index 75f7e2f..0000000 --- a/slatec/mpunfl.f +++ /dev/null @@ -1,32 +0,0 @@ -*DECK MPUNFL - SUBROUTINE MPUNFL (X) -C***BEGIN PROLOGUE MPUNFL -C***SUBSIDIARY -C***PURPOSE Subsidiary to DQDOTA and DQDOTI -C***LIBRARY SLATEC -C***TYPE ALL (MPUNFL-A) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Called on multiple-precision underflow, i.e. when the -C exponent of 'mp' number X would be less than -M. -C -C***SEE ALSO DQDOTA, DQDOTI -C***ROUTINES CALLED MPCHK -C***REVISION HISTORY (YYMMDD) -C 791001 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE MPUNFL - INTEGER X(*) -C***FIRST EXECUTABLE STATEMENT MPUNFL - CALL MPCHK (1, 4) -C THE UNDERFLOWING NUMBER IS SET TO ZERO -C AN ALTERNATIVE WOULD BE TO CALL MPMINR (X) AND RETURN, -C POSSIBLY UPDATING A COUNTER AND TERMINATING EXECUTION -C AFTER A PRESET NUMBER OF UNDERFLOWS. ACTION COULD EASILY -C BE DETERMINED BY A FLAG IN LABELLED COMMON. - X(1) = 0 - RETURN - END diff --git a/slatec/numxer.f b/slatec/numxer.f deleted file mode 100644 index 9a5486c..0000000 --- a/slatec/numxer.f +++ /dev/null @@ -1,31 +0,0 @@ -*DECK NUMXER - FUNCTION NUMXER (NERR) -C***BEGIN PROLOGUE NUMXER -C***PURPOSE Return the most recent error number. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE INTEGER (NUMXER-I) -C***KEYWORDS ERROR NUMBER, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C NUMXER returns the most recent error number, -C in both NUMXER and the parameter NERR. -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 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 910411 Made user-callable and added KEYWORDS section. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE NUMXER -C***FIRST EXECUTABLE STATEMENT NUMXER - NERR = J4SAVE(1,0,.FALSE.) - NUMXER = NERR - RETURN - END diff --git a/slatec/ohtrol.f b/slatec/ohtrol.f deleted file mode 100644 index 6eaa29b..0000000 --- a/slatec/ohtrol.f +++ /dev/null @@ -1,52 +0,0 @@ -*DECK OHTROL - SUBROUTINE OHTROL (Q, N, NRDA, DIAG, IRANK, DIV, TD) -C***BEGIN PROLOGUE OHTROL -C***SUBSIDIARY -C***PURPOSE Subsidiary to BVSUP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (OHTROL-S, DOHTRL-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C For a rank deficient problem, additional orthogonal -C HOUSEHOLDER transformations are applied to the left side -C of Q to further reduce the triangular form. -C Thus, after application of the routines ORTHOR and OHTROL -C to the original matrix, the result is a nonsingular -C triangular matrix while the remainder of the matrix -C has been zeroed out. -C -C***SEE ALSO BVSUP -C***ROUTINES CALLED SDOT -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE OHTROL - DIMENSION Q(NRDA,*),DIAG(*),DIV(*),TD(*) -C***FIRST EXECUTABLE STATEMENT OHTROL - NMIR=N-IRANK - IRP=IRANK+1 - DO 30 K=1,IRANK - KIR=IRP-K - DIAGK=DIAG(KIR) - SIG=(DIAGK*DIAGK)+SDOT(NMIR,Q(IRP,KIR),1,Q(IRP,KIR),1) - DD=SIGN(SQRT(SIG),-DIAGK) - DIV(KIR)=DD - TDV=DIAGK-DD - TD(KIR)=TDV - IF (K .EQ. IRANK) GO TO 30 - KIRM=KIR-1 - SQD=DD*DIAGK-SIG - DO 20 J=1,KIRM - QS=((TDV*Q(KIR,J))+SDOT(NMIR,Q(IRP,J),1,Q(IRP,KIR),1)) - 1 /SQD - Q(KIR,J)=Q(KIR,J)+QS*TDV - DO 10 L=IRP,N - 10 Q(L,J)=Q(L,J)+QS*Q(L,KIR) - 20 CONTINUE - 30 CONTINUE - RETURN - END diff --git a/slatec/ohtror.f b/slatec/ohtror.f deleted file mode 100644 index 622c258..0000000 --- a/slatec/ohtror.f +++ /dev/null @@ -1,52 +0,0 @@ -*DECK OHTROR - SUBROUTINE OHTROR (Q, N, NRDA, DIAG, IRANK, DIV, TD) -C***BEGIN PROLOGUE OHTROR -C***SUBSIDIARY -C***PURPOSE Subsidiary to BVSUP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (OHTROR-S) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C For a rank deficient problem, additional orthogonal -C HOUSEHOLDER transformations are applied to the right side -C of Q to further reduce the triangular form. -C Thus, after application of the routines ORTHOL and OHTROR -C to the original matrix, the result is a nonsingular -C triangular matrix while the remainder of the matrix -C has been zeroed out. -C -C***SEE ALSO BVSUP -C***ROUTINES CALLED SDOT -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE OHTROR - DIMENSION Q(NRDA,*),DIAG(*),DIV(*),TD(*) -C***FIRST EXECUTABLE STATEMENT OHTROR - NMIR=N-IRANK - IRP=IRANK+1 - DO 30 K=1,IRANK - KIR=IRP-K - DIAGK=DIAG(KIR) - SIG=(DIAGK*DIAGK)+SDOT(NMIR,Q(KIR,IRP),NRDA,Q(KIR,IRP),NRDA) - DD=SIGN(SQRT(SIG),-DIAGK) - DIV(KIR)=DD - TDV=DIAGK-DD - TD(KIR)=TDV - IF (K .EQ. IRANK) GO TO 30 - KIRM=KIR-1 - SQD=DD*DIAGK-SIG - DO 20 J=1,KIRM - QS=((TDV*Q(J,KIR))+SDOT(NMIR,Q(J,IRP),NRDA,Q(KIR,IRP),NRDA)) - 1 /SQD - Q(J,KIR)=Q(J,KIR)+QS*TDV - DO 10 L=IRP,N - 10 Q(J,L)=Q(J,L)+QS*Q(KIR,L) - 20 CONTINUE - 30 CONTINUE - RETURN - END diff --git a/slatec/ortbak.f b/slatec/ortbak.f deleted file mode 100644 index 5238fe7..0000000 --- a/slatec/ortbak.f +++ /dev/null @@ -1,110 +0,0 @@ -*DECK ORTBAK - SUBROUTINE ORTBAK (NM, LOW, IGH, A, ORT, M, Z) -C***BEGIN PROLOGUE ORTBAK -C***PURPOSE Form the eigenvectors of a general real matrix from the -C eigenvectors of the upper Hessenberg matrix output from -C ORTHES. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C4 -C***TYPE SINGLE PRECISION (ORTBAK-S, CORTB-C) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure ORTBAK, -C NUM. MATH. 12, 349-368(1968) by Martin and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). -C -C This subroutine forms the eigenvectors of a REAL GENERAL -C matrix by back transforming those of the corresponding -C upper Hessenberg matrix determined by ORTHES. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, A and Z, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C LOW and IGH are two INTEGER variables determined by the -C balancing subroutine BALANC. If BALANC has not been -C used, set LOW=1 and IGH equal to the order of the matrix. -C -C A contains some information about the orthogonal trans- -C formations used in the reduction to Hessenberg form by -C ORTHES in its strict lower triangle. A is a two-dimensional -C REAL array, dimensioned A(NM,IGH). -C -C ORT contains further information about the orthogonal trans- -C formations used in the reduction by ORTHES. Only elements -C LOW through IGH are used. ORT is a one-dimensional REAL -C array, dimensioned ORT(IGH). -C -C M is the number of columns of Z to be back transformed. -C M is an INTEGER variable. -C -C Z contains the real and imaginary parts of the eigenvectors to -C be back transformed in its first M columns. Z is a two- -C dimensional REAL array, dimensioned Z(NM,M). -C -C On OUTPUT -C -C Z contains the real and imaginary parts of the transformed -C eigenvectors in its first M columns. -C -C ORT has been used for temporary storage as is not restored. -C -C NOTE that ORTBAK preserves vector Euclidean norms. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE ORTBAK -C - INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1 - REAL A(NM,*),ORT(*),Z(NM,*) - REAL G -C -C***FIRST EXECUTABLE STATEMENT ORTBAK - IF (M .EQ. 0) GO TO 200 - LA = IGH - 1 - KP1 = LOW + 1 - IF (LA .LT. KP1) GO TO 200 -C .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... - DO 140 MM = KP1, LA - MP = LOW + IGH - MM - IF (A(MP,MP-1) .EQ. 0.0E0) GO TO 140 - MP1 = MP + 1 -C - DO 100 I = MP1, IGH - 100 ORT(I) = A(I,MP-1) -C - DO 130 J = 1, M - G = 0.0E0 -C - DO 110 I = MP, IGH - 110 G = G + ORT(I) * Z(I,J) -C .......... DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHES. -C DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW .......... - G = (G / ORT(MP)) / A(MP,MP-1) -C - DO 120 I = MP, IGH - 120 Z(I,J) = Z(I,J) + G * ORT(I) -C - 130 CONTINUE -C - 140 CONTINUE -C - 200 RETURN - END diff --git a/slatec/orthes.f b/slatec/orthes.f deleted file mode 100644 index 4ac438b..0000000 --- a/slatec/orthes.f +++ /dev/null @@ -1,133 +0,0 @@ -*DECK ORTHES - SUBROUTINE ORTHES (NM, N, LOW, IGH, A, ORT) -C***BEGIN PROLOGUE ORTHES -C***PURPOSE Reduce a real general matrix to upper Hessenberg form -C using orthogonal similarity transformations. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C1B2 -C***TYPE SINGLE PRECISION (ORTHES-S, CORTH-C) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure ORTHES, -C NUM. MATH. 12, 349-368(1968) by Martin and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). -C -C Given a REAL GENERAL matrix, this subroutine -C reduces a submatrix situated in rows and columns -C LOW through IGH to upper Hessenberg form by -C orthogonal similarity transformations. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameter, A, as declared in the calling program -C dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix A. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C LOW and IGH are two INTEGER variables determined by the -C balancing subroutine BALANC. If BALANC has not been -C used, set LOW=1 and IGH equal to the order of the matrix, N. -C -C A contains the general matrix to be reduced to upper -C Hessenberg form. A is a two-dimensional REAL array, -C dimensioned A(NM,N). -C -C On OUTPUT -C -C A contains the upper Hessenberg matrix. Some information about -C the orthogonal transformations used in the reduction -C is stored in the remaining triangle under the Hessenberg -C matrix. -C -C ORT contains further information about the orthogonal trans- -C formations used in the reduction. Only elements LOW+1 -C through IGH are used. ORT is a one-dimensional REAL array, -C dimensioned ORT(IGH). -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE ORTHES -C - INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW - REAL A(NM,*),ORT(*) - REAL F,G,H,SCALE -C -C***FIRST EXECUTABLE STATEMENT ORTHES - LA = IGH - 1 - KP1 = LOW + 1 - IF (LA .LT. KP1) GO TO 200 -C - DO 180 M = KP1, LA - H = 0.0E0 - ORT(M) = 0.0E0 - SCALE = 0.0E0 -C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) .......... - DO 90 I = M, IGH - 90 SCALE = SCALE + ABS(A(I,M-1)) -C - IF (SCALE .EQ. 0.0E0) GO TO 180 - MP = M + IGH -C .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... - DO 100 II = M, IGH - I = MP - II - ORT(I) = A(I,M-1) / SCALE - H = H + ORT(I) * ORT(I) - 100 CONTINUE -C - G = -SIGN(SQRT(H),ORT(M)) - H = H - ORT(M) * G - ORT(M) = ORT(M) - G -C .......... FORM (I-(U*UT)/H) * A .......... - DO 130 J = M, N - F = 0.0E0 -C .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... - DO 110 II = M, IGH - I = MP - II - F = F + ORT(I) * A(I,J) - 110 CONTINUE -C - F = F / H -C - DO 120 I = M, IGH - 120 A(I,J) = A(I,J) - F * ORT(I) -C - 130 CONTINUE -C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) .......... - DO 160 I = 1, IGH - F = 0.0E0 -C .......... FOR J=IGH STEP -1 UNTIL M DO -- .......... - DO 140 JJ = M, IGH - J = MP - JJ - F = F + ORT(J) * A(I,J) - 140 CONTINUE -C - F = F / H -C - DO 150 J = M, IGH - 150 A(I,J) = A(I,J) - F * ORT(J) -C - 160 CONTINUE -C - ORT(M) = SCALE * ORT(M) - A(M,M-1) = SCALE * G - 180 CONTINUE -C - 200 RETURN - END diff --git a/slatec/ortho4.f b/slatec/ortho4.f deleted file mode 100644 index 8c6880f..0000000 --- a/slatec/ortho4.f +++ /dev/null @@ -1,60 +0,0 @@ -*DECK ORTHO4 - SUBROUTINE ORTHO4 (USOL, IDMN, ZN, ZM, PERTRB) -C***BEGIN PROLOGUE ORTHO4 -C***SUBSIDIARY -C***PURPOSE Subsidiary to SEPX4 -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (ORTHO4-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This subroutine orthogonalizes the array USOL with respect to -C the constant array in a weighted least squares norm. -C -C***SEE ALSO SEPX4 -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS SPL4 -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE ORTHO4 -C - COMMON /SPL4/ KSWX ,KSWY ,K ,L , - 1 AIT ,BIT ,CIT ,DIT , - 2 MIT ,NIT ,IS ,MS , - 3 JS ,NS ,DLX ,DLY , - 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 - DIMENSION USOL(IDMN,*) ,ZN(*) ,ZM(*) -C***FIRST EXECUTABLE STATEMENT ORTHO4 - ISTR = IS - IFNL = MS - JSTR = JS - JFNL = NS -C -C COMPUTE WEIGHTED INNER PRODUCTS -C - UTE = 0.0 - ETE = 0.0 - DO 20 I=IS,MS - II = I-IS+1 - DO 10 J=JS,NS - JJ = J-JS+1 - ETE = ETE+ZM(II)*ZN(JJ) - UTE = UTE+USOL(I,J)*ZM(II)*ZN(JJ) - 10 CONTINUE - 20 CONTINUE -C -C SET PERTURBATION PARAMETER -C - PERTRB = UTE/ETE -C -C SUBTRACT OFF CONSTANT PERTRB -C - DO 40 I=ISTR,IFNL - DO 30 J=JSTR,JFNL - USOL(I,J) = USOL(I,J)-PERTRB - 30 CONTINUE - 40 CONTINUE - RETURN - END diff --git a/slatec/orthog.f b/slatec/orthog.f deleted file mode 100644 index e4585e5..0000000 --- a/slatec/orthog.f +++ /dev/null @@ -1,60 +0,0 @@ -*DECK ORTHOG - SUBROUTINE ORTHOG (USOL, IDMN, ZN, ZM, PERTRB) -C***BEGIN PROLOGUE ORTHOG -C***SUBSIDIARY -C***PURPOSE Subsidiary to SEPELI -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (ORTHOG-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This subroutine orthogonalizes the array USOL with respect to -C the constant array in a weighted least squares norm. -C -C***SEE ALSO SEPELI -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS SPLPCM -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE ORTHOG -C - COMMON /SPLPCM/ KSWX ,KSWY ,K ,L , - 1 AIT ,BIT ,CIT ,DIT , - 2 MIT ,NIT ,IS ,MS , - 3 JS ,NS ,DLX ,DLY , - 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 - DIMENSION USOL(IDMN,*) ,ZN(*) ,ZM(*) -C***FIRST EXECUTABLE STATEMENT ORTHOG - ISTR = IS - IFNL = MS - JSTR = JS - JFNL = NS -C -C COMPUTE WEIGHTED INNER PRODUCTS -C - UTE = 0.0 - ETE = 0.0 - DO 20 I=IS,MS - II = I-IS+1 - DO 10 J=JS,NS - JJ = J-JS+1 - ETE = ETE+ZM(II)*ZN(JJ) - UTE = UTE+USOL(I,J)*ZM(II)*ZN(JJ) - 10 CONTINUE - 20 CONTINUE -C -C SET PERTURBATION PARAMETER -C - PERTRB = UTE/ETE -C -C SUBTRACT OFF CONSTANT PERTRB -C - DO 40 I=ISTR,IFNL - DO 30 J=JSTR,JFNL - USOL(I,J) = USOL(I,J)-PERTRB - 30 CONTINUE - 40 CONTINUE - RETURN - END diff --git a/slatec/orthol.f b/slatec/orthol.f deleted file mode 100644 index 4ce4b30..0000000 --- a/slatec/orthol.f +++ /dev/null @@ -1,187 +0,0 @@ -*DECK ORTHOL - SUBROUTINE ORTHOL (A, M, N, NRDA, IFLAG, IRANK, ISCALE, DIAG, - + KPIVOT, SCALES, COLS, CS) -C***BEGIN PROLOGUE ORTHOL -C***SUBSIDIARY -C***PURPOSE Subsidiary to BVSUP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (ORTHOL-S) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C Reduction of the matrix A to upper triangular form by a sequence of -C orthogonal HOUSEHOLDER transformations pre-multiplying A -C -C Modeled after the ALGOL codes in the articles in the REFERENCES -C section. -C -C ********************************************************************** -C INPUT -C ********************************************************************** -C -C A -- Contains the matrix to be decomposed, must be dimensioned -C NRDA by N -C M -- Number of rows in the matrix, M greater or equal to N -C N -- Number of columns in the matrix, N greater or equal to 1 -C IFLAG -- Indicates the uncertainty in the matrix data -C = 0 when the data is to be treated as exact -C =-K when the data is assumed to be accurate to about -C K digits -C ISCALE -- Scaling indicator -C =-1 if the matrix A is to be pre-scaled by -C columns when appropriate. -C Otherwise no scaling will be attempted -C NRDA -- Row dimension of A, NRDA greater or equal to M -C DIAG,KPIVOT,COLS -- Arrays of length at least n used internally -C ,CS,SCALES -C -C ********************************************************************** -C OUTPUT -C ********************************************************************** -C -C IFLAG - Status indicator -C =1 for successful decomposition -C =2 if improper input is detected -C =3 if rank of the matrix is less than N -C A -- Contains the reduced matrix in the strictly upper triangular -C part and transformation information in the lower part -C IRANK -- Contains the numerically determined matrix rank -C DIAG -- Contains the diagonal elements of the reduced -C triangular matrix -C KPIVOT -- Contains the pivotal information, the column -C interchanges performed on the original matrix are -C recorded here. -C SCALES -- Contains the column scaling parameters -C -C ********************************************************************** -C -C***SEE ALSO BVSUP -C***REFERENCES G. Golub, Numerical methods for solving linear least -C squares problems, Numerische Mathematik 7, (1965), -C pp. 206-216. -C P. Businger and G. Golub, Linear least squares -C solutions by Householder transformations, Numerische -C Mathematik 7, (1965), pp. 269-276. -C***ROUTINES CALLED CSCALE, R1MACH, SDOT, XERMSG -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900402 Added TYPE section. (WRB) -C 910408 Updated the AUTHOR and REFERENCES sections. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE ORTHOL - DIMENSION A(NRDA,*),DIAG(*),KPIVOT(*),COLS(*),CS(*),SCALES(*) -C -C ********************************************************************** -C -C MACHINE PRECISION (COMPUTER UNIT ROUNDOFF VALUE) IS DEFINED -C BY THE FUNCTION R1MACH. -C -C***FIRST EXECUTABLE STATEMENT ORTHOL - URO = R1MACH(3) -C -C ********************************************************************** -C - IF (M .GE. N .AND. N .GE. 1 .AND. NRDA .GE. M) GO TO 1 - IFLAG=2 - CALL XERMSG ('SLATEC', 'ORTHOL', 'INVALID INPUT PARAMETERS.', 2, - + 1) - RETURN -C - 1 ACC=10.*URO - IF (IFLAG .LT. 0) ACC=MAX(ACC,10.**IFLAG) - SRURO=SQRT(URO) - IFLAG=1 - IRANK=N -C -C COMPUTE NORM**2 OF JTH COLUMN AND A MATRIX NORM -C - ANORM=0. - DO 2 J=1,N - KPIVOT(J)=J - COLS(J)=SDOT(M,A(1,J),1,A(1,J),1) - CS(J)=COLS(J) - ANORM=ANORM+COLS(J) - 2 CONTINUE -C -C PERFORM COLUMN SCALING ON A WHEN SPECIFIED -C - CALL CSCALE(A,NRDA,M,N,COLS,CS,DUM,DUM,ANORM,SCALES,ISCALE,0) -C - ANORM=SQRT(ANORM) -C -C -C CONSTRUCTION OF UPPER TRIANGULAR MATRIX AND RECORDING OF -C ORTHOGONAL TRANSFORMATIONS -C -C - DO 50 K=1,N - MK=M-K+1 - IF (K .EQ. N) GO TO 25 - KP=K+1 -C -C SEARCHING FOR PIVOTAL COLUMN -C - DO 10 J=K,N - IF (COLS(J) .GE. SRURO*CS(J)) GO TO 5 - COLS(J)=SDOT(MK,A(K,J),1,A(K,J),1) - CS(J)=COLS(J) - 5 IF (J .EQ. K) GO TO 7 - IF (SIGMA .GE. 0.99*COLS(J)) GO TO 10 - 7 SIGMA=COLS(J) - JCOL=J - 10 CONTINUE - IF (JCOL .EQ. K) GO TO 25 -C -C PERFORM COLUMN INTERCHANGE -C - L=KPIVOT(K) - KPIVOT(K)=KPIVOT(JCOL) - KPIVOT(JCOL)=L - COLS(JCOL)=COLS(K) - COLS(K)=SIGMA - CSS=CS(K) - CS(K)=CS(JCOL) - CS(JCOL)=CSS - SC=SCALES(K) - SCALES(K)=SCALES(JCOL) - SCALES(JCOL)=SC - DO 20 L=1,M - ASAVE=A(L,K) - A(L,K)=A(L,JCOL) - 20 A(L,JCOL)=ASAVE -C -C CHECK RANK OF THE MATRIX -C - 25 SIG=SDOT(MK,A(K,K),1,A(K,K),1) - DIAGK=SQRT(SIG) - IF (DIAGK .GT. ACC*ANORM) GO TO 30 -C -C RANK DEFICIENT PROBLEM - IFLAG=3 - IRANK=K-1 - CALL XERMSG ('SLATEC', 'ORTHOL', - + 'RANK OF MATRIX IS LESS THAN THE NUMBER OF COLUMNS.', 1, 1) - RETURN -C -C CONSTRUCT AND APPLY TRANSFORMATION TO MATRIX A -C - 30 AKK=A(K,K) - IF (AKK .GT. 0.) DIAGK=-DIAGK - DIAG(K)=DIAGK - A(K,K)=AKK-DIAGK - IF (K .EQ. N) GO TO 50 - SAD=DIAGK*AKK-SIG - DO 40 J=KP,N - AS=SDOT(MK,A(K,K),1,A(K,J),1)/SAD - DO 35 L=K,M - 35 A(L,J)=A(L,J)+AS*A(L,K) - 40 COLS(J)=COLS(J)-A(K,J)**2 - 50 CONTINUE -C -C - RETURN - END diff --git a/slatec/orthor.f b/slatec/orthor.f deleted file mode 100644 index 001416e..0000000 --- a/slatec/orthor.f +++ /dev/null @@ -1,185 +0,0 @@ -*DECK ORTHOR - SUBROUTINE ORTHOR (A, N, M, NRDA, IFLAG, IRANK, ISCALE, DIAG, - + KPIVOT, SCALES, ROWS, RS) -C***BEGIN PROLOGUE ORTHOR -C***SUBSIDIARY -C***PURPOSE Subsidiary to BVSUP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (ORTHOR-S, DORTHR-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C Reduction of the matrix A to lower triangular form by a sequence of -C orthogonal HOUSEHOLDER transformations post-multiplying A -C -C Modeled after the ALGOL codes in the articles in the REFERENCES -C section. -C -C ********************************************************************** -C INPUT -C ********************************************************************** -C -C A -- Contains the matrix to be decomposed, must be dimensioned -C NRDA by N -C N -- Number of rows in the matrix, N greater or equal to 1 -C M -- Number of columns in the matrix, M greater or equal to N -C IFLAG -- Indicates the uncertainty in the matrix data -C = 0 when the data is to be treated as exact -C =-K when the data is assumed to be accurate to about -C K digits -C ISCALE -- Scaling indicator -C =-1 if the matrix is to be pre-scaled by -C columns when appropriate. -C Otherwise no scaling will be attempted -C NRDA -- Row dimension of A, NRDA greater or equal to N -C DIAG,KPIVOT,ROWS -- Arrays of length at least N used internally -C ,RS,SCALES (except for SCALES which is M) -C -C ********************************************************************** -C OUTPUT -C ********************************************************************** -C -C IFLAG - status indicator -C =1 for successful decomposition -C =2 if improper input is detected -C =3 if rank of the matrix is less than N -C A -- contains the reduced matrix in the strictly lower triangular -C part and transformation information -C IRANK -- contains the numerically determined matrix rank -C DIAG -- contains the diagonal elements of the reduced -C triangular matrix -C KPIVOT -- Contains the pivotal information, the column -C interchanges performed on the original matrix are -C recorded here. -C SCALES -- contains the column scaling parameters -C -C ********************************************************************** -C -C***SEE ALSO BVSUP -C***REFERENCES G. Golub, Numerical methods for solving linear least -C squares problems, Numerische Mathematik 7, (1965), -C pp. 206-216. -C P. Businger and G. Golub, Linear least squares -C solutions by Householder transformations, Numerische -C Mathematik 7, (1965), pp. 269-276. -C***ROUTINES CALLED CSCALE, R1MACH, SDOT, XERMSG -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 910408 Updated the AUTHOR and REFERENCES sections. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE ORTHOR - DIMENSION A(NRDA,*),DIAG(*),KPIVOT(*),ROWS(*),RS(*),SCALES(*) -C -C END OF ABSTRACT -C -C ********************************************************************** -C -C MACHINE PRECISION (COMPUTER UNIT ROUNDOFF VALUE) IS DEFINED -C BY THE FUNCTION R1MACH. -C -C ********************************************************************** -C -C***FIRST EXECUTABLE STATEMENT ORTHOR - URO = R1MACH(4) - IF (M .GE. N .AND. N .GE. 1 .AND. NRDA .GE. N) GO TO 1 - IFLAG=2 - CALL XERMSG ('SLATEC', 'ORTHOR', 'INVALID INPUT PARAMETERS.', 2, - + 1) - RETURN -C - 1 ACC=10.*URO - IF (IFLAG .LT. 0) ACC=MAX(ACC,10.**IFLAG) - SRURO=SQRT(URO) - IFLAG=1 - IRANK=N -C -C COMPUTE NORM**2 OF JTH ROW AND A MATRIX NORM -C - ANORM=0. - DO 2 J=1,N - KPIVOT(J)=J - ROWS(J)=SDOT(M,A(J,1),NRDA,A(J,1),NRDA) - RS(J)=ROWS(J) - ANORM=ANORM+ROWS(J) - 2 CONTINUE -C -C PERFORM COLUMN SCALING ON A WHEN SPECIFIED -C - CALL CSCALE(A,NRDA,N,M,SCALES,DUM,ROWS,RS,ANORM,SCALES,ISCALE,1) -C - ANORM=SQRT(ANORM) -C -C -C CONSTRUCTION OF LOWER TRIANGULAR MATRIX AND RECORDING OF -C ORTHOGONAL TRANSFORMATIONS -C -C - DO 50 K=1,N - MK=M-K+1 - IF (K .EQ. N) GO TO 25 - KP=K+1 -C -C SEARCHING FOR PIVOTAL ROW -C - DO 10 J=K,N - IF (ROWS(J) .GE. SRURO*RS(J)) GO TO 5 - ROWS(J)=SDOT(MK,A(J,K),NRDA,A(J,K),NRDA) - RS(J)=ROWS(J) - 5 IF (J .EQ. K) GO TO 7 - IF (SIGMA .GE. 0.99*ROWS(J)) GO TO 10 - 7 SIGMA=ROWS(J) - JROW=J - 10 CONTINUE - IF (JROW .EQ. K) GO TO 25 -C -C PERFORM ROW INTERCHANGE -C - L=KPIVOT(K) - KPIVOT(K)=KPIVOT(JROW) - KPIVOT(JROW)=L - ROWS(JROW)=ROWS(K) - ROWS(K)=SIGMA - RSS=RS(K) - RS(K)=RS(JROW) - RS(JROW)=RSS - DO 20 L=1,M - ASAVE=A(K,L) - A(K,L)=A(JROW,L) - 20 A(JROW,L)=ASAVE -C -C CHECK RANK OF THE MATRIX -C - 25 SIG=SDOT(MK,A(K,K),NRDA,A(K,K),NRDA) - DIAGK=SQRT(SIG) - IF (DIAGK .GT. ACC*ANORM) GO TO 30 -C -C RANK DEFICIENT PROBLEM - IFLAG=3 - IRANK=K-1 - CALL XERMSG ('SLATEC', 'ORTHOR', - + 'RANK OF MATRIX IS LESS THAN THE NUMBER OF ROWS.', 1, 1) - RETURN -C -C CONSTRUCT AND APPLY TRANSFORMATION TO MATRIX A -C - 30 AKK=A(K,K) - IF (AKK .GT. 0.) DIAGK=-DIAGK - DIAG(K)=DIAGK - A(K,K)=AKK-DIAGK - IF (K .EQ. N) GO TO 50 - SAD=DIAGK*AKK-SIG - DO 40 J=KP,N - AS=SDOT(MK,A(K,K),NRDA,A(J,K),NRDA)/SAD - DO 35 L=K,M - 35 A(J,L)=A(J,L)+AS*A(K,L) - 40 ROWS(J)=ROWS(J)-A(J,K)**2 - 50 CONTINUE -C -C - RETURN - END diff --git a/slatec/ortran.f b/slatec/ortran.f deleted file mode 100644 index 409ce41..0000000 --- a/slatec/ortran.f +++ /dev/null @@ -1,111 +0,0 @@ -*DECK ORTRAN - SUBROUTINE ORTRAN (NM, N, LOW, IGH, A, ORT, Z) -C***BEGIN PROLOGUE ORTRAN -C***PURPOSE Accumulate orthogonal similarity transformations in the -C reduction of real general matrix by ORTHES. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C4 -C***TYPE SINGLE PRECISION (ORTRAN-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure ORTRANS, -C NUM. MATH. 16, 181-204(1970) by Peters and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). -C -C This subroutine accumulates the orthogonal similarity -C transformations used in the reduction of a REAL GENERAL -C matrix to upper Hessenberg form by ORTHES. -C -C On INPUT -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, A and Z, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix A. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C LOW and IGH are two INTEGER variables determined by the -C balancing subroutine BALANC. If BALANC has not been -C used, set LOW=1 and IGH equal to the order of the matrix, N. -C -C A contains some information about the orthogonal trans- -C formations used in the reduction to Hessenberg form by -C ORTHES in its strict lower triangle. A is a two-dimensional -C REAL array, dimensioned A(NM,IGH). -C -C ORT contains further information about the orthogonal trans- -C formations used in the reduction by ORTHES. Only elements -C LOW through IGH are used. ORT is a one-dimensional REAL -C array, dimensioned ORT(IGH). -C -C On OUTPUT -C -C Z contains the transformation matrix produced in the reduction -C by ORTHES to the upper Hessenberg form. Z is a two- -C dimensional REAL array, dimensioned Z(NM,N). -C -C ORT has been used for temporary storage as is not restored. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE ORTRAN -C - INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1 - REAL A(NM,*),ORT(*),Z(NM,*) - REAL G -C -C .......... INITIALIZE Z TO IDENTITY MATRIX .......... -C***FIRST EXECUTABLE STATEMENT ORTRAN - DO 80 I = 1, N -C - DO 60 J = 1, N - 60 Z(I,J) = 0.0E0 -C - Z(I,I) = 1.0E0 - 80 CONTINUE -C - KL = IGH - LOW - 1 - IF (KL .LT. 1) GO TO 200 -C .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... - DO 140 MM = 1, KL - MP = IGH - MM - IF (A(MP,MP-1) .EQ. 0.0E0) GO TO 140 - MP1 = MP + 1 -C - DO 100 I = MP1, IGH - 100 ORT(I) = A(I,MP-1) -C - DO 130 J = MP, IGH - G = 0.0E0 -C - DO 110 I = MP, IGH - 110 G = G + ORT(I) * Z(I,J) -C .......... DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHES. -C DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW .......... - G = (G / ORT(MP)) / A(MP,MP-1) -C - DO 120 I = MP, IGH - 120 Z(I,J) = Z(I,J) + G * ORT(I) -C - 130 CONTINUE -C - 140 CONTINUE -C - 200 RETURN - END diff --git a/slatec/passb.f b/slatec/passb.f deleted file mode 100644 index be8d292..0000000 --- a/slatec/passb.f +++ /dev/null @@ -1,146 +0,0 @@ -*DECK PASSB - SUBROUTINE PASSB (NAC, IDO, IP, L1, IDL1, CC, C1, C2, CH, CH2, WA) -C***BEGIN PROLOGUE PASSB -C***SUBSIDIARY -C***PURPOSE Calculate the fast Fourier transform of subvectors of -C arbitrary length. -C***LIBRARY SLATEC (FFTPACK) -C***TYPE SINGLE PRECISION (PASSB-S) -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C changing dummy array size declarations (1) to (*). -C 881128 Modified by Dick Valent to meet prologue standards. -C 890831 Modified array declarations. (WRB) -C 891009 Removed unreferenced variable. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE PASSB - DIMENSION CH(IDO,L1,*), CC(IDO,IP,*), C1(IDO,L1,*), WA(*), - + C2(IDL1,*), CH2(IDL1,*) -C***FIRST EXECUTABLE STATEMENT PASSB - IDOT = IDO/2 - IPP2 = IP+2 - IPPH = (IP+1)/2 - IDP = IP*IDO -C - IF (IDO .LT. L1) GO TO 106 - DO 103 J=2,IPPH - JC = IPP2-J - DO 102 K=1,L1 -CDIR$ IVDEP - DO 101 I=1,IDO - CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) - CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) - 101 CONTINUE - 102 CONTINUE - 103 CONTINUE - DO 105 K=1,L1 -CDIR$ IVDEP - DO 104 I=1,IDO - CH(I,K,1) = CC(I,1,K) - 104 CONTINUE - 105 CONTINUE - GO TO 112 - 106 DO 109 J=2,IPPH - JC = IPP2-J - DO 108 I=1,IDO -CDIR$ IVDEP - DO 107 K=1,L1 - CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) - CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) - 107 CONTINUE - 108 CONTINUE - 109 CONTINUE - DO 111 I=1,IDO -CDIR$ IVDEP - DO 110 K=1,L1 - CH(I,K,1) = CC(I,1,K) - 110 CONTINUE - 111 CONTINUE - 112 IDL = 2-IDO - INC = 0 - DO 116 L=2,IPPH - LC = IPP2-L - IDL = IDL+IDO -CDIR$ IVDEP - DO 113 IK=1,IDL1 - C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2) - C2(IK,LC) = WA(IDL)*CH2(IK,IP) - 113 CONTINUE - IDLJ = IDL - INC = INC+IDO - DO 115 J=3,IPPH - JC = IPP2-J - IDLJ = IDLJ+INC - IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP - WAR = WA(IDLJ-1) - WAI = WA(IDLJ) -CDIR$ IVDEP - DO 114 IK=1,IDL1 - C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J) - C2(IK,LC) = C2(IK,LC)+WAI*CH2(IK,JC) - 114 CONTINUE - 115 CONTINUE - 116 CONTINUE - DO 118 J=2,IPPH -CDIR$ IVDEP - DO 117 IK=1,IDL1 - CH2(IK,1) = CH2(IK,1)+CH2(IK,J) - 117 CONTINUE - 118 CONTINUE - DO 120 J=2,IPPH - JC = IPP2-J -CDIR$ IVDEP - DO 119 IK=2,IDL1,2 - CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC) - CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC) - CH2(IK,J) = C2(IK,J)+C2(IK-1,JC) - CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC) - 119 CONTINUE - 120 CONTINUE - NAC = 1 - IF (IDO .EQ. 2) RETURN - NAC = 0 - DO 121 IK=1,IDL1 - C2(IK,1) = CH2(IK,1) - 121 CONTINUE - DO 123 J=2,IP -CDIR$ IVDEP - DO 122 K=1,L1 - C1(1,K,J) = CH(1,K,J) - C1(2,K,J) = CH(2,K,J) - 122 CONTINUE - 123 CONTINUE - IF (IDOT .GT. L1) GO TO 127 - IDIJ = 0 - DO 126 J=2,IP - IDIJ = IDIJ+2 - DO 125 I=4,IDO,2 - IDIJ = IDIJ+2 -CDIR$ IVDEP - DO 124 K=1,L1 - C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) - C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) - 124 CONTINUE - 125 CONTINUE - 126 CONTINUE - RETURN - 127 IDJ = 2-IDO - DO 130 J=2,IP - IDJ = IDJ+IDO - DO 129 K=1,L1 - IDIJ = IDJ -CDIR$ IVDEP - DO 128 I=4,IDO,2 - IDIJ = IDIJ+2 - C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) - C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) - 128 CONTINUE - 129 CONTINUE - 130 CONTINUE - RETURN - END diff --git a/slatec/passb2.f b/slatec/passb2.f deleted file mode 100644 index bfa1a77..0000000 --- a/slatec/passb2.f +++ /dev/null @@ -1,56 +0,0 @@ -*DECK PASSB2 - SUBROUTINE PASSB2 (IDO, L1, CC, CH, WA1) -C***BEGIN PROLOGUE PASSB2 -C***SUBSIDIARY -C***PURPOSE Calculate the fast Fourier transform of subvectors of -C length two. -C***LIBRARY SLATEC (FFTPACK) -C***TYPE SINGLE PRECISION (PASSB2-S) -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C changing dummy array size declarations (1) to (*). -C 881128 Modified by Dick Valent to meet prologue standards. -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE PASSB2 - DIMENSION CC(IDO,2,*), CH(IDO,L1,2), WA1(*) -C***FIRST EXECUTABLE STATEMENT PASSB2 - IF (IDO .GT. 2) GO TO 102 - DO 101 K=1,L1 - CH(1,K,1) = CC(1,1,K)+CC(1,2,K) - CH(1,K,2) = CC(1,1,K)-CC(1,2,K) - CH(2,K,1) = CC(2,1,K)+CC(2,2,K) - CH(2,K,2) = CC(2,1,K)-CC(2,2,K) - 101 CONTINUE - RETURN - 102 IF(IDO/2.LT.L1) GO TO 105 - DO 104 K=1,L1 -CDIR$ IVDEP - DO 103 I=2,IDO,2 - CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) - TR2 = CC(I-1,1,K)-CC(I-1,2,K) - CH(I,K,1) = CC(I,1,K)+CC(I,2,K) - TI2 = CC(I,1,K)-CC(I,2,K) - CH(I,K,2) = WA1(I-1)*TI2+WA1(I)*TR2 - CH(I-1,K,2) = WA1(I-1)*TR2-WA1(I)*TI2 - 103 CONTINUE - 104 CONTINUE - RETURN - 105 DO 107 I=2,IDO,2 -CDIR$ IVDEP - DO 106 K=1,L1 - CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) - TR2 = CC(I-1,1,K)-CC(I-1,2,K) - CH(I,K,1) = CC(I,1,K)+CC(I,2,K) - TI2 = CC(I,1,K)-CC(I,2,K) - CH(I,K,2) = WA1(I-1)*TI2+WA1(I)*TR2 - CH(I-1,K,2) = WA1(I-1)*TR2-WA1(I)*TI2 - 106 CONTINUE - 107 CONTINUE - RETURN - END diff --git a/slatec/passb3.f b/slatec/passb3.f deleted file mode 100644 index 66435a6..0000000 --- a/slatec/passb3.f +++ /dev/null @@ -1,89 +0,0 @@ -*DECK PASSB3 - SUBROUTINE PASSB3 (IDO, L1, CC, CH, WA1, WA2) -C***BEGIN PROLOGUE PASSB3 -C***SUBSIDIARY -C***PURPOSE Calculate the fast Fourier transform of subvectors of -C length three. -C***LIBRARY SLATEC (FFTPACK) -C***TYPE SINGLE PRECISION (PASSB3-S) -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C (a) changing dummy array size declarations (1) to (*), -C (b) changing definition of variable TAUI by using -C FORTRAN intrinsic function SQRT instead of a DATA -C statement. -C 881128 Modified by Dick Valent to meet prologue standards. -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE PASSB3 - DIMENSION CC(IDO,3,*), CH(IDO,L1,3), WA1(*), WA2(*) -C***FIRST EXECUTABLE STATEMENT PASSB3 - TAUR = -.5 - TAUI = .5*SQRT(3.) - IF (IDO .NE. 2) GO TO 102 - DO 101 K=1,L1 - TR2 = CC(1,2,K)+CC(1,3,K) - CR2 = CC(1,1,K)+TAUR*TR2 - CH(1,K,1) = CC(1,1,K)+TR2 - TI2 = CC(2,2,K)+CC(2,3,K) - CI2 = CC(2,1,K)+TAUR*TI2 - CH(2,K,1) = CC(2,1,K)+TI2 - CR3 = TAUI*(CC(1,2,K)-CC(1,3,K)) - CI3 = TAUI*(CC(2,2,K)-CC(2,3,K)) - CH(1,K,2) = CR2-CI3 - CH(1,K,3) = CR2+CI3 - CH(2,K,2) = CI2+CR3 - CH(2,K,3) = CI2-CR3 - 101 CONTINUE - RETURN - 102 IF(IDO/2.LT.L1) GO TO 105 - DO 104 K=1,L1 -CDIR$ IVDEP - DO 103 I=2,IDO,2 - TR2 = CC(I-1,2,K)+CC(I-1,3,K) - CR2 = CC(I-1,1,K)+TAUR*TR2 - CH(I-1,K,1) = CC(I-1,1,K)+TR2 - TI2 = CC(I,2,K)+CC(I,3,K) - CI2 = CC(I,1,K)+TAUR*TI2 - CH(I,K,1) = CC(I,1,K)+TI2 - CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) - CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) - DR2 = CR2-CI3 - DR3 = CR2+CI3 - DI2 = CI2+CR3 - DI3 = CI2-CR3 - CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 - CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 - CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 - CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 - 103 CONTINUE - 104 CONTINUE - RETURN - 105 DO 107 I=2,IDO,2 -CDIR$ IVDEP - DO 106 K=1,L1 - TR2 = CC(I-1,2,K)+CC(I-1,3,K) - CR2 = CC(I-1,1,K)+TAUR*TR2 - CH(I-1,K,1) = CC(I-1,1,K)+TR2 - TI2 = CC(I,2,K)+CC(I,3,K) - CI2 = CC(I,1,K)+TAUR*TI2 - CH(I,K,1) = CC(I,1,K)+TI2 - CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) - CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) - DR2 = CR2-CI3 - DR3 = CR2+CI3 - DI2 = CI2+CR3 - DI3 = CI2-CR3 - CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 - CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 - CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 - CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 - 106 CONTINUE - 107 CONTINUE - RETURN - END diff --git a/slatec/passb4.f b/slatec/passb4.f deleted file mode 100644 index b9437b0..0000000 --- a/slatec/passb4.f +++ /dev/null @@ -1,100 +0,0 @@ -*DECK PASSB4 - SUBROUTINE PASSB4 (IDO, L1, CC, CH, WA1, WA2, WA3) -C***BEGIN PROLOGUE PASSB4 -C***SUBSIDIARY -C***PURPOSE Calculate the fast Fourier transform of subvectors of -C length four. -C***LIBRARY SLATEC (FFTPACK) -C***TYPE SINGLE PRECISION (PASSB4-S) -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C changing dummy array size declarations (1) to (*). -C 881128 Modified by Dick Valent to meet prologue standards. -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE PASSB4 - DIMENSION CC(IDO,4,*), CH(IDO,L1,4), WA1(*), WA2(*), WA3(*) -C***FIRST EXECUTABLE STATEMENT PASSB4 - IF (IDO .NE. 2) GO TO 102 - DO 101 K=1,L1 - TI1 = CC(2,1,K)-CC(2,3,K) - TI2 = CC(2,1,K)+CC(2,3,K) - TR4 = CC(2,4,K)-CC(2,2,K) - TI3 = CC(2,2,K)+CC(2,4,K) - TR1 = CC(1,1,K)-CC(1,3,K) - TR2 = CC(1,1,K)+CC(1,3,K) - TI4 = CC(1,2,K)-CC(1,4,K) - TR3 = CC(1,2,K)+CC(1,4,K) - CH(1,K,1) = TR2+TR3 - CH(1,K,3) = TR2-TR3 - CH(2,K,1) = TI2+TI3 - CH(2,K,3) = TI2-TI3 - CH(1,K,2) = TR1+TR4 - CH(1,K,4) = TR1-TR4 - CH(2,K,2) = TI1+TI4 - CH(2,K,4) = TI1-TI4 - 101 CONTINUE - RETURN - 102 IF(IDO/2.LT.L1) GO TO 105 - DO 104 K=1,L1 -CDIR$ IVDEP - DO 103 I=2,IDO,2 - TI1 = CC(I,1,K)-CC(I,3,K) - TI2 = CC(I,1,K)+CC(I,3,K) - TI3 = CC(I,2,K)+CC(I,4,K) - TR4 = CC(I,4,K)-CC(I,2,K) - TR1 = CC(I-1,1,K)-CC(I-1,3,K) - TR2 = CC(I-1,1,K)+CC(I-1,3,K) - TI4 = CC(I-1,2,K)-CC(I-1,4,K) - TR3 = CC(I-1,2,K)+CC(I-1,4,K) - CH(I-1,K,1) = TR2+TR3 - CR3 = TR2-TR3 - CH(I,K,1) = TI2+TI3 - CI3 = TI2-TI3 - CR2 = TR1+TR4 - CR4 = TR1-TR4 - CI2 = TI1+TI4 - CI4 = TI1-TI4 - CH(I-1,K,2) = WA1(I-1)*CR2-WA1(I)*CI2 - CH(I,K,2) = WA1(I-1)*CI2+WA1(I)*CR2 - CH(I-1,K,3) = WA2(I-1)*CR3-WA2(I)*CI3 - CH(I,K,3) = WA2(I-1)*CI3+WA2(I)*CR3 - CH(I-1,K,4) = WA3(I-1)*CR4-WA3(I)*CI4 - CH(I,K,4) = WA3(I-1)*CI4+WA3(I)*CR4 - 103 CONTINUE - 104 CONTINUE - RETURN - 105 DO 107 I=2,IDO,2 -CDIR$ IVDEP - DO 106 K=1,L1 - TI1 = CC(I,1,K)-CC(I,3,K) - TI2 = CC(I,1,K)+CC(I,3,K) - TI3 = CC(I,2,K)+CC(I,4,K) - TR4 = CC(I,4,K)-CC(I,2,K) - TR1 = CC(I-1,1,K)-CC(I-1,3,K) - TR2 = CC(I-1,1,K)+CC(I-1,3,K) - TI4 = CC(I-1,2,K)-CC(I-1,4,K) - TR3 = CC(I-1,2,K)+CC(I-1,4,K) - CH(I-1,K,1) = TR2+TR3 - CR3 = TR2-TR3 - CH(I,K,1) = TI2+TI3 - CI3 = TI2-TI3 - CR2 = TR1+TR4 - CR4 = TR1-TR4 - CI2 = TI1+TI4 - CI4 = TI1-TI4 - CH(I-1,K,2) = WA1(I-1)*CR2-WA1(I)*CI2 - CH(I,K,2) = WA1(I-1)*CI2+WA1(I)*CR2 - CH(I-1,K,3) = WA2(I-1)*CR3-WA2(I)*CI3 - CH(I,K,3) = WA2(I-1)*CI3+WA2(I)*CR3 - CH(I-1,K,4) = WA3(I-1)*CR4-WA3(I)*CI4 - CH(I,K,4) = WA3(I-1)*CI4+WA3(I)*CR4 - 106 CONTINUE - 107 CONTINUE - RETURN - END diff --git a/slatec/passb5.f b/slatec/passb5.f deleted file mode 100644 index d72c501..0000000 --- a/slatec/passb5.f +++ /dev/null @@ -1,143 +0,0 @@ -*DECK PASSB5 - SUBROUTINE PASSB5 (IDO, L1, CC, CH, WA1, WA2, WA3, WA4) -C***BEGIN PROLOGUE PASSB5 -C***SUBSIDIARY -C***PURPOSE Calculate the fast Fourier transform of subvectors of -C length five. -C***LIBRARY SLATEC (FFTPACK) -C***TYPE SINGLE PRECISION (PASSB5-S) -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C (a) changing dummy array size declarations (1) to (*), -C (b) changing definition of variables PI, TI11, TI12, -C TR11, TR12 by using FORTRAN intrinsic functions ATAN -C and SIN instead of DATA statements. -C 881128 Modified by Dick Valent to meet prologue standards. -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE PASSB5 - DIMENSION CC(IDO,5,*), CH(IDO,L1,5), WA1(*), WA2(*), WA3(*), - + WA4(*) -C***FIRST EXECUTABLE STATEMENT PASSB5 - PI = 4.*ATAN(1.) - TR11 = SIN(.1*PI) - TI11 = SIN(.4*PI) - TR12 = -SIN(.3*PI) - TI12 = SIN(.2*PI) - IF (IDO .NE. 2) GO TO 102 - DO 101 K=1,L1 - TI5 = CC(2,2,K)-CC(2,5,K) - TI2 = CC(2,2,K)+CC(2,5,K) - TI4 = CC(2,3,K)-CC(2,4,K) - TI3 = CC(2,3,K)+CC(2,4,K) - TR5 = CC(1,2,K)-CC(1,5,K) - TR2 = CC(1,2,K)+CC(1,5,K) - TR4 = CC(1,3,K)-CC(1,4,K) - TR3 = CC(1,3,K)+CC(1,4,K) - CH(1,K,1) = CC(1,1,K)+TR2+TR3 - CH(2,K,1) = CC(2,1,K)+TI2+TI3 - CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 - CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3 - CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 - CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3 - CR5 = TI11*TR5+TI12*TR4 - CI5 = TI11*TI5+TI12*TI4 - CR4 = TI12*TR5-TI11*TR4 - CI4 = TI12*TI5-TI11*TI4 - CH(1,K,2) = CR2-CI5 - CH(1,K,5) = CR2+CI5 - CH(2,K,2) = CI2+CR5 - CH(2,K,3) = CI3+CR4 - CH(1,K,3) = CR3-CI4 - CH(1,K,4) = CR3+CI4 - CH(2,K,4) = CI3-CR4 - CH(2,K,5) = CI2-CR5 - 101 CONTINUE - RETURN - 102 IF(IDO/2.LT.L1) GO TO 105 - DO 104 K=1,L1 -CDIR$ IVDEP - DO 103 I=2,IDO,2 - TI5 = CC(I,2,K)-CC(I,5,K) - TI2 = CC(I,2,K)+CC(I,5,K) - TI4 = CC(I,3,K)-CC(I,4,K) - TI3 = CC(I,3,K)+CC(I,4,K) - TR5 = CC(I-1,2,K)-CC(I-1,5,K) - TR2 = CC(I-1,2,K)+CC(I-1,5,K) - TR4 = CC(I-1,3,K)-CC(I-1,4,K) - TR3 = CC(I-1,3,K)+CC(I-1,4,K) - CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 - CH(I,K,1) = CC(I,1,K)+TI2+TI3 - CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 - CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 - CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 - CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 - CR5 = TI11*TR5+TI12*TR4 - CI5 = TI11*TI5+TI12*TI4 - CR4 = TI12*TR5-TI11*TR4 - CI4 = TI12*TI5-TI11*TI4 - DR3 = CR3-CI4 - DR4 = CR3+CI4 - DI3 = CI3+CR4 - DI4 = CI3-CR4 - DR5 = CR2+CI5 - DR2 = CR2-CI5 - DI5 = CI2-CR5 - DI2 = CI2+CR5 - CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 - CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 - CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 - CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 - CH(I-1,K,4) = WA3(I-1)*DR4-WA3(I)*DI4 - CH(I,K,4) = WA3(I-1)*DI4+WA3(I)*DR4 - CH(I-1,K,5) = WA4(I-1)*DR5-WA4(I)*DI5 - CH(I,K,5) = WA4(I-1)*DI5+WA4(I)*DR5 - 103 CONTINUE - 104 CONTINUE - RETURN - 105 DO 107 I=2,IDO,2 -CDIR$ IVDEP - DO 106 K=1,L1 - TI5 = CC(I,2,K)-CC(I,5,K) - TI2 = CC(I,2,K)+CC(I,5,K) - TI4 = CC(I,3,K)-CC(I,4,K) - TI3 = CC(I,3,K)+CC(I,4,K) - TR5 = CC(I-1,2,K)-CC(I-1,5,K) - TR2 = CC(I-1,2,K)+CC(I-1,5,K) - TR4 = CC(I-1,3,K)-CC(I-1,4,K) - TR3 = CC(I-1,3,K)+CC(I-1,4,K) - CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 - CH(I,K,1) = CC(I,1,K)+TI2+TI3 - CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 - CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 - CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 - CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 - CR5 = TI11*TR5+TI12*TR4 - CI5 = TI11*TI5+TI12*TI4 - CR4 = TI12*TR5-TI11*TR4 - CI4 = TI12*TI5-TI11*TI4 - DR3 = CR3-CI4 - DR4 = CR3+CI4 - DI3 = CI3+CR4 - DI4 = CI3-CR4 - DR5 = CR2+CI5 - DR2 = CR2-CI5 - DI5 = CI2-CR5 - DI2 = CI2+CR5 - CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 - CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 - CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 - CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 - CH(I-1,K,4) = WA3(I-1)*DR4-WA3(I)*DI4 - CH(I,K,4) = WA3(I-1)*DI4+WA3(I)*DR4 - CH(I-1,K,5) = WA4(I-1)*DR5-WA4(I)*DI5 - CH(I,K,5) = WA4(I-1)*DI5+WA4(I)*DR5 - 106 CONTINUE - 107 CONTINUE - RETURN - END diff --git a/slatec/passf.f b/slatec/passf.f deleted file mode 100644 index dd1509d..0000000 --- a/slatec/passf.f +++ /dev/null @@ -1,147 +0,0 @@ -*DECK PASSF - SUBROUTINE PASSF (NAC, IDO, IP, L1, IDL1, CC, C1, C2, CH, CH2, WA) -C***BEGIN PROLOGUE PASSF -C***SUBSIDIARY -C***PURPOSE Calculate the fast Fourier transform of subvectors of -C arbitrary length. -C***LIBRARY SLATEC (FFTPACK) -C***TYPE SINGLE PRECISION (PASSF-S) -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C changing dummy array size declarations (1) to (*). -C 881128 Modified by Dick Valent to meet prologue standards. -C 890831 Modified array declarations. (WRB) -C 891009 Removed unreferenced variable. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE PASSF - DIMENSION CH(IDO,L1,*), CC(IDO,IP,*), C1(IDO,L1,*), WA(*), - + C2(IDL1,*), CH2(IDL1,*) -C***FIRST EXECUTABLE STATEMENT PASSF - IDOT = IDO/2 - IPP2 = IP+2 - IPPH = (IP+1)/2 - IDP = IP*IDO -C - IF (IDO .LT. L1) GO TO 106 - DO 103 J=2,IPPH - JC = IPP2-J - DO 102 K=1,L1 -CDIR$ IVDEP - DO 101 I=1,IDO - CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) - CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) - 101 CONTINUE - 102 CONTINUE - 103 CONTINUE - DO 105 K=1,L1 -CDIR$ IVDEP - DO 104 I=1,IDO - CH(I,K,1) = CC(I,1,K) - 104 CONTINUE - 105 CONTINUE - GO TO 112 - 106 DO 109 J=2,IPPH - JC = IPP2-J - DO 108 I=1,IDO -CDIR$ IVDEP - DO 107 K=1,L1 - CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) - CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) - 107 CONTINUE - 108 CONTINUE - 109 CONTINUE - DO 111 I=1,IDO -CDIR$ IVDEP - DO 110 K=1,L1 - CH(I,K,1) = CC(I,1,K) - 110 CONTINUE - 111 CONTINUE - 112 IDL = 2-IDO - INC = 0 - DO 116 L=2,IPPH - LC = IPP2-L - IDL = IDL+IDO -CDIR$ IVDEP - DO 113 IK=1,IDL1 - C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2) - C2(IK,LC) = -WA(IDL)*CH2(IK,IP) - 113 CONTINUE - IDLJ = IDL - INC = INC+IDO - DO 115 J=3,IPPH - JC = IPP2-J - IDLJ = IDLJ+INC - IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP - WAR = WA(IDLJ-1) - WAI = WA(IDLJ) -CDIR$ IVDEP - DO 114 IK=1,IDL1 - C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J) - C2(IK,LC) = C2(IK,LC)-WAI*CH2(IK,JC) - 114 CONTINUE - 115 CONTINUE - 116 CONTINUE - DO 118 J=2,IPPH -CDIR$ IVDEP - DO 117 IK=1,IDL1 - CH2(IK,1) = CH2(IK,1)+CH2(IK,J) - 117 CONTINUE - 118 CONTINUE - DO 120 J=2,IPPH - JC = IPP2-J -CDIR$ IVDEP - DO 119 IK=2,IDL1,2 - CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC) - CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC) - CH2(IK,J) = C2(IK,J)+C2(IK-1,JC) - CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC) - 119 CONTINUE - 120 CONTINUE - NAC = 1 - IF (IDO .EQ. 2) RETURN - NAC = 0 -CDIR$ IVDEP - DO 121 IK=1,IDL1 - C2(IK,1) = CH2(IK,1) - 121 CONTINUE - DO 123 J=2,IP -CDIR$ IVDEP - DO 122 K=1,L1 - C1(1,K,J) = CH(1,K,J) - C1(2,K,J) = CH(2,K,J) - 122 CONTINUE - 123 CONTINUE - IF (IDOT .GT. L1) GO TO 127 - IDIJ = 0 - DO 126 J=2,IP - IDIJ = IDIJ+2 - DO 125 I=4,IDO,2 - IDIJ = IDIJ+2 -CDIR$ IVDEP - DO 124 K=1,L1 - C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J) - C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J) - 124 CONTINUE - 125 CONTINUE - 126 CONTINUE - RETURN - 127 IDJ = 2-IDO - DO 130 J=2,IP - IDJ = IDJ+IDO - DO 129 K=1,L1 - IDIJ = IDJ -CDIR$ IVDEP - DO 128 I=4,IDO,2 - IDIJ = IDIJ+2 - C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J) - C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J) - 128 CONTINUE - 129 CONTINUE - 130 CONTINUE - RETURN - END diff --git a/slatec/passf2.f b/slatec/passf2.f deleted file mode 100644 index dc6776f..0000000 --- a/slatec/passf2.f +++ /dev/null @@ -1,56 +0,0 @@ -*DECK PASSF2 - SUBROUTINE PASSF2 (IDO, L1, CC, CH, WA1) -C***BEGIN PROLOGUE PASSF2 -C***SUBSIDIARY -C***PURPOSE Calculate the fast Fourier transform of subvectors of -C length two. -C***LIBRARY SLATEC (FFTPACK) -C***TYPE SINGLE PRECISION (PASSF2-S) -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C changing dummy array size declarations (1) to (*). -C 881128 Modified by Dick Valent to meet prologue standards. -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE PASSF2 - DIMENSION CC(IDO,2,*), CH(IDO,L1,2), WA1(*) -C***FIRST EXECUTABLE STATEMENT PASSF2 - IF (IDO .GT. 2) GO TO 102 - DO 101 K=1,L1 - CH(1,K,1) = CC(1,1,K)+CC(1,2,K) - CH(1,K,2) = CC(1,1,K)-CC(1,2,K) - CH(2,K,1) = CC(2,1,K)+CC(2,2,K) - CH(2,K,2) = CC(2,1,K)-CC(2,2,K) - 101 CONTINUE - RETURN - 102 IF(IDO/2.LT.L1) GO TO 105 - DO 104 K=1,L1 -CDIR$ IVDEP - DO 103 I=2,IDO,2 - CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) - TR2 = CC(I-1,1,K)-CC(I-1,2,K) - CH(I,K,1) = CC(I,1,K)+CC(I,2,K) - TI2 = CC(I,1,K)-CC(I,2,K) - CH(I,K,2) = WA1(I-1)*TI2-WA1(I)*TR2 - CH(I-1,K,2) = WA1(I-1)*TR2+WA1(I)*TI2 - 103 CONTINUE - 104 CONTINUE - RETURN - 105 DO 107 I=2,IDO,2 -CDIR$ IVDEP - DO 106 K=1,L1 - CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) - TR2 = CC(I-1,1,K)-CC(I-1,2,K) - CH(I,K,1) = CC(I,1,K)+CC(I,2,K) - TI2 = CC(I,1,K)-CC(I,2,K) - CH(I,K,2) = WA1(I-1)*TI2-WA1(I)*TR2 - CH(I-1,K,2) = WA1(I-1)*TR2+WA1(I)*TI2 - 106 CONTINUE - 107 CONTINUE - RETURN - END diff --git a/slatec/passf3.f b/slatec/passf3.f deleted file mode 100644 index 23e2f8d..0000000 --- a/slatec/passf3.f +++ /dev/null @@ -1,89 +0,0 @@ -*DECK PASSF3 - SUBROUTINE PASSF3 (IDO, L1, CC, CH, WA1, WA2) -C***BEGIN PROLOGUE PASSF3 -C***SUBSIDIARY -C***PURPOSE Calculate the fast Fourier transform of subvectors of -C length three. -C***LIBRARY SLATEC (FFTPACK) -C***TYPE SINGLE PRECISION (PASSF3-S) -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C (a) changing dummy array size declarations (1) to (*), -C (b) changing definition of variable TAUI by using -C FORTRAN intrinsic function SQRT instead of a DATA -C statement. -C 881128 Modified by Dick Valent to meet prologue standards. -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE PASSF3 - DIMENSION CC(IDO,3,*), CH(IDO,L1,3), WA1(*), WA2(*) -C***FIRST EXECUTABLE STATEMENT PASSF3 - TAUR = -.5 - TAUI = -.5*SQRT(3.) - IF (IDO .NE. 2) GO TO 102 - DO 101 K=1,L1 - TR2 = CC(1,2,K)+CC(1,3,K) - CR2 = CC(1,1,K)+TAUR*TR2 - CH(1,K,1) = CC(1,1,K)+TR2 - TI2 = CC(2,2,K)+CC(2,3,K) - CI2 = CC(2,1,K)+TAUR*TI2 - CH(2,K,1) = CC(2,1,K)+TI2 - CR3 = TAUI*(CC(1,2,K)-CC(1,3,K)) - CI3 = TAUI*(CC(2,2,K)-CC(2,3,K)) - CH(1,K,2) = CR2-CI3 - CH(1,K,3) = CR2+CI3 - CH(2,K,2) = CI2+CR3 - CH(2,K,3) = CI2-CR3 - 101 CONTINUE - RETURN - 102 IF(IDO/2.LT.L1) GO TO 105 - DO 104 K=1,L1 -CDIR$ IVDEP - DO 103 I=2,IDO,2 - TR2 = CC(I-1,2,K)+CC(I-1,3,K) - CR2 = CC(I-1,1,K)+TAUR*TR2 - CH(I-1,K,1) = CC(I-1,1,K)+TR2 - TI2 = CC(I,2,K)+CC(I,3,K) - CI2 = CC(I,1,K)+TAUR*TI2 - CH(I,K,1) = CC(I,1,K)+TI2 - CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) - CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) - DR2 = CR2-CI3 - DR3 = CR2+CI3 - DI2 = CI2+CR3 - DI3 = CI2-CR3 - CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 - CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 - CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 - CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 - 103 CONTINUE - 104 CONTINUE - RETURN - 105 DO 107 I=2,IDO,2 -CDIR$ IVDEP - DO 106 K=1,L1 - TR2 = CC(I-1,2,K)+CC(I-1,3,K) - CR2 = CC(I-1,1,K)+TAUR*TR2 - CH(I-1,K,1) = CC(I-1,1,K)+TR2 - TI2 = CC(I,2,K)+CC(I,3,K) - CI2 = CC(I,1,K)+TAUR*TI2 - CH(I,K,1) = CC(I,1,K)+TI2 - CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) - CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) - DR2 = CR2-CI3 - DR3 = CR2+CI3 - DI2 = CI2+CR3 - DI3 = CI2-CR3 - CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 - CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 - CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 - CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 - 106 CONTINUE - 107 CONTINUE - RETURN - END diff --git a/slatec/passf4.f b/slatec/passf4.f deleted file mode 100644 index 5928bf5..0000000 --- a/slatec/passf4.f +++ /dev/null @@ -1,100 +0,0 @@ -*DECK PASSF4 - SUBROUTINE PASSF4 (IDO, L1, CC, CH, WA1, WA2, WA3) -C***BEGIN PROLOGUE PASSF4 -C***SUBSIDIARY -C***PURPOSE Calculate the fast Fourier transform of subvectors of -C length four. -C***LIBRARY SLATEC (FFTPACK) -C***TYPE SINGLE PRECISION (PASSF4-S) -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C changing dummy array size declarations (1) to (*). -C 881128 Modified by Dick Valent to meet prologue standards. -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE PASSF4 - DIMENSION CC(IDO,4,*), CH(IDO,L1,4), WA1(*), WA2(*), WA3(*) -C***FIRST EXECUTABLE STATEMENT PASSF4 - IF (IDO .NE. 2) GO TO 102 - DO 101 K=1,L1 - TI1 = CC(2,1,K)-CC(2,3,K) - TI2 = CC(2,1,K)+CC(2,3,K) - TR4 = CC(2,2,K)-CC(2,4,K) - TI3 = CC(2,2,K)+CC(2,4,K) - TR1 = CC(1,1,K)-CC(1,3,K) - TR2 = CC(1,1,K)+CC(1,3,K) - TI4 = CC(1,4,K)-CC(1,2,K) - TR3 = CC(1,2,K)+CC(1,4,K) - CH(1,K,1) = TR2+TR3 - CH(1,K,3) = TR2-TR3 - CH(2,K,1) = TI2+TI3 - CH(2,K,3) = TI2-TI3 - CH(1,K,2) = TR1+TR4 - CH(1,K,4) = TR1-TR4 - CH(2,K,2) = TI1+TI4 - CH(2,K,4) = TI1-TI4 - 101 CONTINUE - RETURN - 102 IF(IDO/2.LT.L1) GO TO 105 - DO 104 K=1,L1 -CDIR$ IVDEP - DO 103 I=2,IDO,2 - TI1 = CC(I,1,K)-CC(I,3,K) - TI2 = CC(I,1,K)+CC(I,3,K) - TI3 = CC(I,2,K)+CC(I,4,K) - TR4 = CC(I,2,K)-CC(I,4,K) - TR1 = CC(I-1,1,K)-CC(I-1,3,K) - TR2 = CC(I-1,1,K)+CC(I-1,3,K) - TI4 = CC(I-1,4,K)-CC(I-1,2,K) - TR3 = CC(I-1,2,K)+CC(I-1,4,K) - CH(I-1,K,1) = TR2+TR3 - CR3 = TR2-TR3 - CH(I,K,1) = TI2+TI3 - CI3 = TI2-TI3 - CR2 = TR1+TR4 - CR4 = TR1-TR4 - CI2 = TI1+TI4 - CI4 = TI1-TI4 - CH(I-1,K,2) = WA1(I-1)*CR2+WA1(I)*CI2 - CH(I,K,2) = WA1(I-1)*CI2-WA1(I)*CR2 - CH(I-1,K,3) = WA2(I-1)*CR3+WA2(I)*CI3 - CH(I,K,3) = WA2(I-1)*CI3-WA2(I)*CR3 - CH(I-1,K,4) = WA3(I-1)*CR4+WA3(I)*CI4 - CH(I,K,4) = WA3(I-1)*CI4-WA3(I)*CR4 - 103 CONTINUE - 104 CONTINUE - RETURN - 105 DO 107 I=2,IDO,2 -CDIR$ IVDEP - DO 106 K=1,L1 - TI1 = CC(I,1,K)-CC(I,3,K) - TI2 = CC(I,1,K)+CC(I,3,K) - TI3 = CC(I,2,K)+CC(I,4,K) - TR4 = CC(I,2,K)-CC(I,4,K) - TR1 = CC(I-1,1,K)-CC(I-1,3,K) - TR2 = CC(I-1,1,K)+CC(I-1,3,K) - TI4 = CC(I-1,4,K)-CC(I-1,2,K) - TR3 = CC(I-1,2,K)+CC(I-1,4,K) - CH(I-1,K,1) = TR2+TR3 - CR3 = TR2-TR3 - CH(I,K,1) = TI2+TI3 - CI3 = TI2-TI3 - CR2 = TR1+TR4 - CR4 = TR1-TR4 - CI2 = TI1+TI4 - CI4 = TI1-TI4 - CH(I-1,K,2) = WA1(I-1)*CR2+WA1(I)*CI2 - CH(I,K,2) = WA1(I-1)*CI2-WA1(I)*CR2 - CH(I-1,K,3) = WA2(I-1)*CR3+WA2(I)*CI3 - CH(I,K,3) = WA2(I-1)*CI3-WA2(I)*CR3 - CH(I-1,K,4) = WA3(I-1)*CR4+WA3(I)*CI4 - CH(I,K,4) = WA3(I-1)*CI4-WA3(I)*CR4 - 106 CONTINUE - 107 CONTINUE - RETURN - END diff --git a/slatec/passf5.f b/slatec/passf5.f deleted file mode 100644 index 53c7ff7..0000000 --- a/slatec/passf5.f +++ /dev/null @@ -1,143 +0,0 @@ -*DECK PASSF5 - SUBROUTINE PASSF5 (IDO, L1, CC, CH, WA1, WA2, WA3, WA4) -C***BEGIN PROLOGUE PASSF5 -C***SUBSIDIARY -C***PURPOSE Calculate the fast Fourier transform of subvectors of -C length five. -C***LIBRARY SLATEC (FFTPACK) -C***TYPE SINGLE PRECISION (PASSF5-S) -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C (a) changing dummy array size declarations (1) to (*), -C (b) changing definition of variables PI, TI11, TI12, -C TR11, TR12 by using FORTRAN intrinsic functions ATAN -C and SIN instead of DATA statements. -C 881128 Modified by Dick Valent to meet prologue standards. -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE PASSF5 - DIMENSION CC(IDO,5,*), CH(IDO,L1,5), WA1(*), WA2(*), WA3(*), - + WA4(*) -C***FIRST EXECUTABLE STATEMENT PASSF5 - PI = 4.*ATAN(1.) - TR11 = SIN(.1*PI) - TI11 = -SIN(.4*PI) - TR12 = -SIN(.3*PI) - TI12 = -SIN(.2*PI) - IF (IDO .NE. 2) GO TO 102 - DO 101 K=1,L1 - TI5 = CC(2,2,K)-CC(2,5,K) - TI2 = CC(2,2,K)+CC(2,5,K) - TI4 = CC(2,3,K)-CC(2,4,K) - TI3 = CC(2,3,K)+CC(2,4,K) - TR5 = CC(1,2,K)-CC(1,5,K) - TR2 = CC(1,2,K)+CC(1,5,K) - TR4 = CC(1,3,K)-CC(1,4,K) - TR3 = CC(1,3,K)+CC(1,4,K) - CH(1,K,1) = CC(1,1,K)+TR2+TR3 - CH(2,K,1) = CC(2,1,K)+TI2+TI3 - CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 - CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3 - CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 - CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3 - CR5 = TI11*TR5+TI12*TR4 - CI5 = TI11*TI5+TI12*TI4 - CR4 = TI12*TR5-TI11*TR4 - CI4 = TI12*TI5-TI11*TI4 - CH(1,K,2) = CR2-CI5 - CH(1,K,5) = CR2+CI5 - CH(2,K,2) = CI2+CR5 - CH(2,K,3) = CI3+CR4 - CH(1,K,3) = CR3-CI4 - CH(1,K,4) = CR3+CI4 - CH(2,K,4) = CI3-CR4 - CH(2,K,5) = CI2-CR5 - 101 CONTINUE - RETURN - 102 IF(IDO/2.LT.L1) GO TO 105 - DO 104 K=1,L1 -CDIR$ IVDEP - DO 103 I=2,IDO,2 - TI5 = CC(I,2,K)-CC(I,5,K) - TI2 = CC(I,2,K)+CC(I,5,K) - TI4 = CC(I,3,K)-CC(I,4,K) - TI3 = CC(I,3,K)+CC(I,4,K) - TR5 = CC(I-1,2,K)-CC(I-1,5,K) - TR2 = CC(I-1,2,K)+CC(I-1,5,K) - TR4 = CC(I-1,3,K)-CC(I-1,4,K) - TR3 = CC(I-1,3,K)+CC(I-1,4,K) - CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 - CH(I,K,1) = CC(I,1,K)+TI2+TI3 - CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 - CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 - CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 - CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 - CR5 = TI11*TR5+TI12*TR4 - CI5 = TI11*TI5+TI12*TI4 - CR4 = TI12*TR5-TI11*TR4 - CI4 = TI12*TI5-TI11*TI4 - DR3 = CR3-CI4 - DR4 = CR3+CI4 - DI3 = CI3+CR4 - DI4 = CI3-CR4 - DR5 = CR2+CI5 - DR2 = CR2-CI5 - DI5 = CI2-CR5 - DI2 = CI2+CR5 - CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 - CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 - CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 - CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 - CH(I-1,K,4) = WA3(I-1)*DR4+WA3(I)*DI4 - CH(I,K,4) = WA3(I-1)*DI4-WA3(I)*DR4 - CH(I-1,K,5) = WA4(I-1)*DR5+WA4(I)*DI5 - CH(I,K,5) = WA4(I-1)*DI5-WA4(I)*DR5 - 103 CONTINUE - 104 CONTINUE - RETURN - 105 DO 107 I=2,IDO,2 -CDIR$ IVDEP - DO 106 K=1,L1 - TI5 = CC(I,2,K)-CC(I,5,K) - TI2 = CC(I,2,K)+CC(I,5,K) - TI4 = CC(I,3,K)-CC(I,4,K) - TI3 = CC(I,3,K)+CC(I,4,K) - TR5 = CC(I-1,2,K)-CC(I-1,5,K) - TR2 = CC(I-1,2,K)+CC(I-1,5,K) - TR4 = CC(I-1,3,K)-CC(I-1,4,K) - TR3 = CC(I-1,3,K)+CC(I-1,4,K) - CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 - CH(I,K,1) = CC(I,1,K)+TI2+TI3 - CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 - CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 - CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 - CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 - CR5 = TI11*TR5+TI12*TR4 - CI5 = TI11*TI5+TI12*TI4 - CR4 = TI12*TR5-TI11*TR4 - CI4 = TI12*TI5-TI11*TI4 - DR3 = CR3-CI4 - DR4 = CR3+CI4 - DI3 = CI3+CR4 - DI4 = CI3-CR4 - DR5 = CR2+CI5 - DR2 = CR2-CI5 - DI5 = CI2-CR5 - DI2 = CI2+CR5 - CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 - CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 - CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 - CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 - CH(I-1,K,4) = WA3(I-1)*DR4+WA3(I)*DI4 - CH(I,K,4) = WA3(I-1)*DI4-WA3(I)*DR4 - CH(I-1,K,5) = WA4(I-1)*DR5+WA4(I)*DI5 - CH(I,K,5) = WA4(I-1)*DI5-WA4(I)*DR5 - 106 CONTINUE - 107 CONTINUE - RETURN - END diff --git a/slatec/pchbs.f b/slatec/pchbs.f deleted file mode 100644 index 2738ca1..0000000 --- a/slatec/pchbs.f +++ /dev/null @@ -1,216 +0,0 @@ -*DECK PCHBS - SUBROUTINE PCHBS (N, X, F, D, INCFD, KNOTYP, NKNOTS, T, BCOEF, - + NDIM, KORD, IERR) -C***BEGIN PROLOGUE PCHBS -C***PURPOSE Piecewise Cubic Hermite to B-Spline converter. -C***LIBRARY SLATEC (PCHIP) -C***CATEGORY E3 -C***TYPE SINGLE PRECISION (PCHBS-S, DPCHBS-D) -C***KEYWORDS B-SPLINES, CONVERSION, CUBIC HERMITE INTERPOLATION, -C PIECEWISE CUBIC INTERPOLATION -C***AUTHOR Fritsch, F. N., (LLNL) -C Computing and Mathematics Research Division -C Lawrence Livermore National Laboratory -C P.O. Box 808 (L-316) -C Livermore, CA 94550 -C FTS 532-4275, (510) 422-4275 -C***DESCRIPTION -C -C *Usage: -C -C INTEGER N, INCFD, KNOTYP, NKNOTS, NDIM, KORD, IERR -C PARAMETER (INCFD = ...) -C REAL X(nmax), F(INCFD,nmax), D(INCFD,nmax), T(2*nmax+4), -C * BCOEF(2*nmax) -C -C CALL PCHBS (N, X, F, D, INCFD, KNOTYP, NKNOTS, T, BCOEF, -C * NDIM, KORD, IERR) -C -C *Arguments: -C -C N:IN is the number of data points, N.ge.2 . (not checked) -C -C X:IN is the real array of independent variable values. The -C elements of X must be strictly increasing: -C X(I-1) .LT. X(I), I = 2(1)N. (not checked) -C nmax, the dimension of X, must be .ge.N. -C -C F:IN is the real array of dependent variable values. -C F(1+(I-1)*INCFD) is the value corresponding to X(I). -C nmax, the second dimension of F, must be .ge.N. -C -C D:IN is the real array of derivative values at the data points. -C D(1+(I-1)*INCFD) is the value corresponding to X(I). -C nmax, the second dimension of D, must be .ge.N. -C -C INCFD:IN is the increment between successive values in F and D. -C This argument is provided primarily for 2-D applications. -C It may have the value 1 for one-dimensional applications, -C in which case F and D may be singly-subscripted arrays. -C -C KNOTYP:IN is a flag to control the knot sequence. -C The knot sequence T is normally computed from X by putting -C a double knot at each X and setting the end knot pairs -C according to the value of KNOTYP: -C KNOTYP = 0: Quadruple knots at X(1) and X(N). (default) -C KNOTYP = 1: Replicate lengths of extreme subintervals: -C T( 1 ) = T( 2 ) = X(1) - (X(2)-X(1)) ; -C T(M+4) = T(M+3) = X(N) + (X(N)-X(N-1)). -C KNOTYP = 2: Periodic placement of boundary knots: -C T( 1 ) = T( 2 ) = X(1) - (X(N)-X(N-1)); -C T(M+4) = T(M+3) = X(N) + (X(2)-X(1)) . -C Here M=NDIM=2*N. -C If the input value of KNOTYP is negative, however, it is -C assumed that NKNOTS and T were set in a previous call. -C This option is provided for improved efficiency when used -C in a parametric setting. -C -C NKNOTS:INOUT is the number of knots. -C If KNOTYP.GE.0, then NKNOTS will be set to NDIM+4. -C If KNOTYP.LT.0, then NKNOTS is an input variable, and an -C error return will be taken if it is not equal to NDIM+4. -C -C T:INOUT is the array of 2*N+4 knots for the B-representation. -C If KNOTYP.GE.0, T will be returned by PCHBS with the -C interior double knots equal to the X-values and the -C boundary knots set as indicated above. -C If KNOTYP.LT.0, it is assumed that T was set by a -C previous call to PCHBS. (This routine does **not** -C verify that T forms a legitimate knot sequence.) -C -C BCOEF:OUT is the array of 2*N B-spline coefficients. -C -C NDIM:OUT is the dimension of the B-spline space. (Set to 2*N.) -C -C KORD:OUT is the order of the B-spline. (Set to 4.) -C -C IERR:OUT is an error flag. -C Normal return: -C IERR = 0 (no errors). -C "Recoverable" errors: -C IERR = -4 if KNOTYP.GT.2 . -C IERR = -5 if KNOTYP.LT.0 and NKNOTS.NE.(2*N+4). -C -C *Description: -C PCHBS computes the B-spline representation of the PCH function -C determined by N,X,F,D. To be compatible with the rest of PCHIP, -C PCHBS includes INCFD, the increment between successive values of -C the F- and D-arrays. -C -C The output is the B-representation for the function: NKNOTS, T, -C BCOEF, NDIM, KORD. -C -C *Caution: -C Since it is assumed that the input PCH function has been -C computed by one of the other routines in the package PCHIP, -C input arguments N, X, INCFD are **not** checked for validity. -C -C *Restrictions/assumptions: -C 1. N.GE.2 . (not checked) -C 2. X(i).LT.X(i+1), i=1,...,N . (not checked) -C 3. INCFD.GT.0 . (not checked) -C 4. KNOTYP.LE.2 . (error return if not) -C *5. NKNOTS = NDIM+4 = 2*N+4 . (error return if not) -C *6. T(2*k+1) = T(2*k) = X(k), k=1,...,N . (not checked) -C -C * Indicates this applies only if KNOTYP.LT.0 . -C -C *Portability: -C Argument INCFD is used only to cause the compiler to generate -C efficient code for the subscript expressions (1+(I-1)*INCFD) . -C The normal usage, in which PCHBS is called with one-dimensional -C arrays F and D, is probably non-Fortran 77, in the strict sense, -C but it works on all systems on which PCHBS has been tested. -C -C *See Also: -C PCHIC, PCHIM, or PCHSP can be used to determine an interpolating -C PCH function from a set of data. -C The B-spline routine BVALU can be used to evaluate the -C B-representation that is output by PCHBS. -C (See BSPDOC for more information.) -C -C***REFERENCES F. N. Fritsch, "Representations for parametric cubic -C splines," Computer Aided Geometric Design 6 (1989), -C pp.79-82. -C***ROUTINES CALLED PCHKT, XERMSG -C***REVISION HISTORY (YYMMDD) -C 870701 DATE WRITTEN -C 900405 Converted Fortran to upper case. -C 900405 Removed requirement that X be dimensioned N+1. -C 900406 Modified to make PCHKT a subsidiary routine to simplify -C usage. In the process, added argument INCFD to be com- -C patible with the rest of PCHIP. -C 900410 Converted prologue to SLATEC 4.0 format. -C 900410 Added calls to XERMSG and changed constant 3. to 3 to -C reduce single/double differences. -C 900411 Added reference. -C 900501 Corrected declarations. -C 930317 Minor cosmetic changes. (FNF) -C 930514 Corrected problems with dimensioning of arguments and -C clarified DESCRIPTION. (FNF) -C 930604 Removed NKNOTS from PCHKT call list. (FNF) -C***END PROLOGUE PCHBS -C -C*Internal Notes: -C -C**End -C -C Declare arguments. -C - INTEGER N, INCFD, KNOTYP, NKNOTS, NDIM, KORD, IERR - REAL X(*), F(INCFD,*), D(INCFD,*), T(*), BCOEF(*) -C -C Declare local variables. -C - INTEGER K, KK - REAL DOV3, HNEW, HOLD - CHARACTER*8 LIBNAM, SUBNAM -C***FIRST EXECUTABLE STATEMENT PCHBS -C -C Initialize. -C - NDIM = 2*N - KORD = 4 - IERR = 0 - LIBNAM = 'SLATEC' - SUBNAM = 'PCHBS' -C -C Check argument validity. Set up knot sequence if OK. -C - IF ( KNOTYP.GT.2 ) THEN - IERR = -1 - CALL XERMSG (LIBNAM, SUBNAM, 'KNOTYP GREATER THAN 2', IERR, 1) - RETURN - ENDIF - IF ( KNOTYP.LT.0 ) THEN - IF ( NKNOTS.NE.NDIM+4 ) THEN - IERR = -2 - CALL XERMSG (LIBNAM, SUBNAM, - * 'KNOTYP.LT.0 AND NKNOTS.NE.(2*N+4)', IERR, 1) - RETURN - ENDIF - ELSE -C Set up knot sequence. - NKNOTS = NDIM + 4 - CALL PCHKT (N, X, KNOTYP, T) - ENDIF -C -C Compute B-spline coefficients. -C - HNEW = T(3) - T(1) - DO 40 K = 1, N - KK = 2*K - HOLD = HNEW -C The following requires mixed mode arithmetic. - DOV3 = D(1,K)/3 - BCOEF(KK-1) = F(1,K) - HOLD*DOV3 -C The following assumes T(2*K+1) = X(K). - HNEW = T(KK+3) - T(KK+1) - BCOEF(KK) = F(1,K) + HNEW*DOV3 - 40 CONTINUE -C -C Terminate. -C - RETURN -C------------- LAST LINE OF PCHBS FOLLOWS ------------------------------ - END diff --git a/slatec/pchce.f b/slatec/pchce.f deleted file mode 100644 index 8ec390a..0000000 --- a/slatec/pchce.f +++ /dev/null @@ -1,246 +0,0 @@ -*DECK PCHCE - SUBROUTINE PCHCE (IC, VC, N, X, H, SLOPE, D, INCFD, IERR) -C***BEGIN PROLOGUE PCHCE -C***SUBSIDIARY -C***PURPOSE Set boundary conditions for PCHIC -C***LIBRARY SLATEC (PCHIP) -C***TYPE SINGLE PRECISION (PCHCE-S, DPCHCE-D) -C***AUTHOR Fritsch, F. N., (LLNL) -C***DESCRIPTION -C -C PCHCE: PCHIC End Derivative Setter. -C -C Called by PCHIC to set end derivatives as requested by the user. -C It must be called after interior derivative values have been set. -C ----- -C -C To facilitate two-dimensional applications, includes an increment -C between successive values of the D-array. -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C PARAMETER (INCFD = ...) -C INTEGER IC(2), N, IERR -C REAL VC(2), X(N), H(N), SLOPE(N), D(INCFD,N) -C -C CALL PCHCE (IC, VC, N, X, H, SLOPE, D, INCFD, IERR) -C -C Parameters: -C -C IC -- (input) integer array of length 2 specifying desired -C boundary conditions: -C IC(1) = IBEG, desired condition at beginning of data. -C IC(2) = IEND, desired condition at end of data. -C ( see prologue to PCHIC for details. ) -C -C VC -- (input) real array of length 2 specifying desired boundary -C values. VC(1) need be set only if IC(1) = 2 or 3 . -C VC(2) need be set only if IC(2) = 2 or 3 . -C -C N -- (input) number of data points. (assumes N.GE.2) -C -C X -- (input) real array of independent variable values. (the -C elements of X are assumed to be strictly increasing.) -C -C H -- (input) real array of interval lengths. -C SLOPE -- (input) real array of data slopes. -C If the data are (X(I),Y(I)), I=1(1)N, then these inputs are: -C H(I) = X(I+1)-X(I), -C SLOPE(I) = (Y(I+1)-Y(I))/H(I), I=1(1)N-1. -C -C D -- (input) real array of derivative values at the data points. -C The value corresponding to X(I) must be stored in -C D(1+(I-1)*INCFD), I=1(1)N. -C (output) the value of D at X(1) and/or X(N) is changed, if -C necessary, to produce the requested boundary conditions. -C no other entries in D are changed. -C -C INCFD -- (input) increment between successive values in D. -C This argument is provided primarily for 2-D applications. -C -C IERR -- (output) error flag. -C Normal return: -C IERR = 0 (no errors). -C Warning errors: -C IERR = 1 if IBEG.LT.0 and D(1) had to be adjusted for -C monotonicity. -C IERR = 2 if IEND.LT.0 and D(1+(N-1)*INCFD) had to be -C adjusted for monotonicity. -C IERR = 3 if both of the above are true. -C -C ------- -C WARNING: This routine does no validity-checking of arguments. -C ------- -C -C Fortran intrinsics used: ABS. -C -C***SEE ALSO PCHIC -C***ROUTINES CALLED PCHDF, PCHST, XERMSG -C***REVISION HISTORY (YYMMDD) -C 820218 DATE WRITTEN -C 820805 Converted to SLATEC library version. -C 870707 Minor corrections made to prologue.. -C 890411 Added SAVE statements (Vers. 3.2). -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 910408 Updated AUTHOR section in prologue. (WRB) -C 930503 Improved purpose. (FNF) -C***END PROLOGUE PCHCE -C -C Programming notes: -C 1. The function PCHST(ARG1,ARG2) is assumed to return zero if -C either argument is zero, +1 if they are of the same sign, and -C -1 if they are of opposite sign. -C 2. One could reduce the number of arguments and amount of local -C storage, at the expense of reduced code clarity, by passing in -C the array WK (rather than splitting it into H and SLOPE) and -C increasing its length enough to incorporate STEMP and XTEMP. -C 3. The two monotonicity checks only use the sufficient conditions. -C Thus, it is possible (but unlikely) for a boundary condition to -C be changed, even though the original interpolant was monotonic. -C (At least the result is a continuous function of the data.) -C**End -C -C DECLARE ARGUMENTS. -C - INTEGER IC(2), N, INCFD, IERR - REAL VC(2), X(*), H(*), SLOPE(*), D(INCFD,*) -C -C DECLARE LOCAL VARIABLES. -C - INTEGER IBEG, IEND, IERF, INDEX, J, K - REAL HALF, STEMP(3), THREE, TWO, XTEMP(4), ZERO - SAVE ZERO, HALF, TWO, THREE - REAL PCHDF, PCHST -C -C INITIALIZE. -C - DATA ZERO /0./, HALF /0.5/, TWO /2./, THREE /3./ -C -C***FIRST EXECUTABLE STATEMENT PCHCE - IBEG = IC(1) - IEND = IC(2) - IERR = 0 -C -C SET TO DEFAULT BOUNDARY CONDITIONS IF N IS TOO SMALL. -C - IF ( ABS(IBEG).GT.N ) IBEG = 0 - IF ( ABS(IEND).GT.N ) IEND = 0 -C -C TREAT BEGINNING BOUNDARY CONDITION. -C - IF (IBEG .EQ. 0) GO TO 2000 - K = ABS(IBEG) - IF (K .EQ. 1) THEN -C BOUNDARY VALUE PROVIDED. - D(1,1) = VC(1) - ELSE IF (K .EQ. 2) THEN -C BOUNDARY SECOND DERIVATIVE PROVIDED. - D(1,1) = HALF*( (THREE*SLOPE(1) - D(1,2)) - HALF*VC(1)*H(1) ) - ELSE IF (K .LT. 5) THEN -C USE K-POINT DERIVATIVE FORMULA. -C PICK UP FIRST K POINTS, IN REVERSE ORDER. - DO 10 J = 1, K - INDEX = K-J+1 -C INDEX RUNS FROM K DOWN TO 1. - XTEMP(J) = X(INDEX) - IF (J .LT. K) STEMP(J) = SLOPE(INDEX-1) - 10 CONTINUE -C ----------------------------- - D(1,1) = PCHDF (K, XTEMP, STEMP, IERF) -C ----------------------------- - IF (IERF .NE. 0) GO TO 5001 - ELSE -C USE 'NOT A KNOT' CONDITION. - D(1,1) = ( THREE*(H(1)*SLOPE(2) + H(2)*SLOPE(1)) - * - TWO*(H(1)+H(2))*D(1,2) - H(1)*D(1,3) ) / H(2) - ENDIF -C - IF (IBEG .GT. 0) GO TO 2000 -C -C CHECK D(1,1) FOR COMPATIBILITY WITH MONOTONICITY. -C - IF (SLOPE(1) .EQ. ZERO) THEN - IF (D(1,1) .NE. ZERO) THEN - D(1,1) = ZERO - IERR = IERR + 1 - ENDIF - ELSE IF ( PCHST(D(1,1),SLOPE(1)) .LT. ZERO) THEN - D(1,1) = ZERO - IERR = IERR + 1 - ELSE IF ( ABS(D(1,1)) .GT. THREE*ABS(SLOPE(1)) ) THEN - D(1,1) = THREE*SLOPE(1) - IERR = IERR + 1 - ENDIF -C -C TREAT END BOUNDARY CONDITION. -C - 2000 CONTINUE - IF (IEND .EQ. 0) GO TO 5000 - K = ABS(IEND) - IF (K .EQ. 1) THEN -C BOUNDARY VALUE PROVIDED. - D(1,N) = VC(2) - ELSE IF (K .EQ. 2) THEN -C BOUNDARY SECOND DERIVATIVE PROVIDED. - D(1,N) = HALF*( (THREE*SLOPE(N-1) - D(1,N-1)) + - * HALF*VC(2)*H(N-1) ) - ELSE IF (K .LT. 5) THEN -C USE K-POINT DERIVATIVE FORMULA. -C PICK UP LAST K POINTS. - DO 2010 J = 1, K - INDEX = N-K+J -C INDEX RUNS FROM N+1-K UP TO N. - XTEMP(J) = X(INDEX) - IF (J .LT. K) STEMP(J) = SLOPE(INDEX) - 2010 CONTINUE -C ----------------------------- - D(1,N) = PCHDF (K, XTEMP, STEMP, IERF) -C ----------------------------- - IF (IERF .NE. 0) GO TO 5001 - ELSE -C USE 'NOT A KNOT' CONDITION. - D(1,N) = ( THREE*(H(N-1)*SLOPE(N-2) + H(N-2)*SLOPE(N-1)) - * - TWO*(H(N-1)+H(N-2))*D(1,N-1) - H(N-1)*D(1,N-2) ) - * / H(N-2) - ENDIF -C - IF (IEND .GT. 0) GO TO 5000 -C -C CHECK D(1,N) FOR COMPATIBILITY WITH MONOTONICITY. -C - IF (SLOPE(N-1) .EQ. ZERO) THEN - IF (D(1,N) .NE. ZERO) THEN - D(1,N) = ZERO - IERR = IERR + 2 - ENDIF - ELSE IF ( PCHST(D(1,N),SLOPE(N-1)) .LT. ZERO) THEN - D(1,N) = ZERO - IERR = IERR + 2 - ELSE IF ( ABS(D(1,N)) .GT. THREE*ABS(SLOPE(N-1)) ) THEN - D(1,N) = THREE*SLOPE(N-1) - IERR = IERR + 2 - ENDIF -C -C NORMAL RETURN. -C - 5000 CONTINUE - RETURN -C -C ERROR RETURN. -C - 5001 CONTINUE -C ERROR RETURN FROM PCHDF. -C *** THIS CASE SHOULD NEVER OCCUR *** - IERR = -1 - CALL XERMSG ('SLATEC', 'PCHCE', 'ERROR RETURN FROM PCHDF', IERR, - + 1) - RETURN -C------------- LAST LINE OF PCHCE FOLLOWS ------------------------------ - END diff --git a/slatec/pchci.f b/slatec/pchci.f deleted file mode 100644 index 072cf24..0000000 --- a/slatec/pchci.f +++ /dev/null @@ -1,184 +0,0 @@ -*DECK PCHCI - SUBROUTINE PCHCI (N, H, SLOPE, D, INCFD) -C***BEGIN PROLOGUE PCHCI -C***SUBSIDIARY -C***PURPOSE Set interior derivatives for PCHIC -C***LIBRARY SLATEC (PCHIP) -C***TYPE SINGLE PRECISION (PCHCI-S, DPCHCI-D) -C***AUTHOR Fritsch, F. N., (LLNL) -C***DESCRIPTION -C -C PCHCI: PCHIC Initial Derivative Setter. -C -C Called by PCHIC to set derivatives needed to determine a monotone -C piecewise cubic Hermite interpolant to the data. -C -C Default boundary conditions are provided which are compatible -C with monotonicity. If the data are only piecewise monotonic, the -C interpolant will have an extremum at each point where monotonicity -C switches direction. -C -C To facilitate two-dimensional applications, includes an increment -C between successive values of the D-array. -C -C The resulting piecewise cubic Hermite function should be identical -C (within roundoff error) to that produced by PCHIM. -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C PARAMETER (INCFD = ...) -C INTEGER N -C REAL H(N), SLOPE(N), D(INCFD,N) -C -C CALL PCHCI (N, H, SLOPE, D, INCFD) -C -C Parameters: -C -C N -- (input) number of data points. -C If N=2, simply does linear interpolation. -C -C H -- (input) real array of interval lengths. -C SLOPE -- (input) real array of data slopes. -C If the data are (X(I),Y(I)), I=1(1)N, then these inputs are: -C H(I) = X(I+1)-X(I), -C SLOPE(I) = (Y(I+1)-Y(I))/H(I), I=1(1)N-1. -C -C D -- (output) real array of derivative values at the data points. -C If the data are monotonic, these values will determine a -C a monotone cubic Hermite function. -C The value corresponding to X(I) is stored in -C D(1+(I-1)*INCFD), I=1(1)N. -C No other entries in D are changed. -C -C INCFD -- (input) increment between successive values in D. -C This argument is provided primarily for 2-D applications. -C -C ------- -C WARNING: This routine does no validity-checking of arguments. -C ------- -C -C Fortran intrinsics used: ABS, MAX, MIN. -C -C***SEE ALSO PCHIC -C***ROUTINES CALLED PCHST -C***REVISION HISTORY (YYMMDD) -C 820218 DATE WRITTEN -C 820601 Modified end conditions to be continuous functions of -C data when monotonicity switches in next interval. -C 820602 1. Modified formulas so end conditions are less prone -C to over/underflow problems. -C 2. Minor modification to HSUM calculation. -C 820805 Converted to SLATEC library version. -C 890411 Added SAVE statements (Vers. 3.2). -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900328 Added TYPE section. (WRB) -C 910408 Updated AUTHOR section in prologue. (WRB) -C 930503 Improved purpose. (FNF) -C***END PROLOGUE PCHCI -C -C Programming notes: -C 1. The function PCHST(ARG1,ARG2) is assumed to return zero if -C either argument is zero, +1 if they are of the same sign, and -C -1 if they are of opposite sign. -C**End -C -C DECLARE ARGUMENTS. -C - INTEGER N, INCFD - REAL H(*), SLOPE(*), D(INCFD,*) -C -C DECLARE LOCAL VARIABLES. -C - INTEGER I, NLESS1 - REAL DEL1, DEL2, DMAX, DMIN, DRAT1, DRAT2, HSUM, HSUMT3, THREE, - * W1, W2, ZERO - SAVE ZERO, THREE - REAL PCHST -C -C INITIALIZE. -C - DATA ZERO /0./, THREE /3./ -C***FIRST EXECUTABLE STATEMENT PCHCI - NLESS1 = N - 1 - DEL1 = SLOPE(1) -C -C SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION. -C - IF (NLESS1 .GT. 1) GO TO 10 - D(1,1) = DEL1 - D(1,N) = DEL1 - GO TO 5000 -C -C NORMAL CASE (N .GE. 3). -C - 10 CONTINUE - DEL2 = SLOPE(2) -C -C SET D(1) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE -C SHAPE-PRESERVING. -C - HSUM = H(1) + H(2) - W1 = (H(1) + HSUM)/HSUM - W2 = -H(1)/HSUM - D(1,1) = W1*DEL1 + W2*DEL2 - IF ( PCHST(D(1,1),DEL1) .LE. ZERO) THEN - D(1,1) = ZERO - ELSE IF ( PCHST(DEL1,DEL2) .LT. ZERO) THEN -C NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. - DMAX = THREE*DEL1 - IF (ABS(D(1,1)) .GT. ABS(DMAX)) D(1,1) = DMAX - ENDIF -C -C LOOP THROUGH INTERIOR POINTS. -C - DO 50 I = 2, NLESS1 - IF (I .EQ. 2) GO TO 40 -C - HSUM = H(I-1) + H(I) - DEL1 = DEL2 - DEL2 = SLOPE(I) - 40 CONTINUE -C -C SET D(I)=0 UNLESS DATA ARE STRICTLY MONOTONIC. -C - D(1,I) = ZERO - IF ( PCHST(DEL1,DEL2) .LE. ZERO) GO TO 50 -C -C USE BRODLIE MODIFICATION OF BUTLAND FORMULA. -C - HSUMT3 = HSUM+HSUM+HSUM - W1 = (HSUM + H(I-1))/HSUMT3 - W2 = (HSUM + H(I) )/HSUMT3 - DMAX = MAX( ABS(DEL1), ABS(DEL2) ) - DMIN = MIN( ABS(DEL1), ABS(DEL2) ) - DRAT1 = DEL1/DMAX - DRAT2 = DEL2/DMAX - D(1,I) = DMIN/(W1*DRAT1 + W2*DRAT2) -C - 50 CONTINUE -C -C SET D(N) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE -C SHAPE-PRESERVING. -C - W1 = -H(N-1)/HSUM - W2 = (H(N-1) + HSUM)/HSUM - D(1,N) = W1*DEL1 + W2*DEL2 - IF ( PCHST(D(1,N),DEL2) .LE. ZERO) THEN - D(1,N) = ZERO - ELSE IF ( PCHST(DEL1,DEL2) .LT. ZERO) THEN -C NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. - DMAX = THREE*DEL2 - IF (ABS(D(1,N)) .GT. ABS(DMAX)) D(1,N) = DMAX - ENDIF -C -C NORMAL RETURN. -C - 5000 CONTINUE - RETURN -C------------- LAST LINE OF PCHCI FOLLOWS ------------------------------ - END diff --git a/slatec/pchcm.f b/slatec/pchcm.f deleted file mode 100644 index 7b82380..0000000 --- a/slatec/pchcm.f +++ /dev/null @@ -1,236 +0,0 @@ -*DECK PCHCM - SUBROUTINE PCHCM (N, X, F, D, INCFD, SKIP, ISMON, IERR) -C***BEGIN PROLOGUE PCHCM -C***PURPOSE Check a cubic Hermite function for monotonicity. -C***LIBRARY SLATEC (PCHIP) -C***CATEGORY E3 -C***TYPE SINGLE PRECISION (PCHCM-S, DPCHCM-D) -C***KEYWORDS CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION, -C PCHIP, PIECEWISE CUBIC INTERPOLATION, UTILITY ROUTINE -C***AUTHOR Fritsch, F. N., (LLNL) -C Computing & Mathematics Research Division -C Lawrence Livermore National Laboratory -C P.O. Box 808 (L-316) -C Livermore, CA 94550 -C FTS 532-4275, (510) 422-4275 -C***DESCRIPTION -C -C *Usage: -C -C PARAMETER (INCFD = ...) -C INTEGER N, ISMON(N), IERR -C REAL X(N), F(INCFD,N), D(INCFD,N) -C LOGICAL SKIP -C -C CALL PCHCM (N, X, F, D, INCFD, SKIP, ISMON, IERR) -C -C *Arguments: -C -C N:IN is the number of data points. (Error return if N.LT.2 .) -C -C X:IN is a real array of independent variable values. The -C elements of X must be strictly increasing: -C X(I-1) .LT. X(I), I = 2(1)N. -C (Error return if not.) -C -C F:IN is a real array of function values. F(1+(I-1)*INCFD) is -C the value corresponding to X(I). -C -C D:IN is a real array of derivative values. D(1+(I-1)*INCFD) is -C the value corresponding to X(I). -C -C INCFD:IN is the increment between successive values in F and D. -C (Error return if INCFD.LT.1 .) -C -C SKIP:INOUT is a logical variable which should be set to -C .TRUE. if the user wishes to skip checks for validity of -C preceding parameters, or to .FALSE. otherwise. -C This will save time in case these checks have already -C been performed. -C SKIP will be set to .TRUE. on normal return. -C -C ISMON:OUT is an integer array indicating on which intervals the -C PCH function defined by N, X, F, D is monotonic. -C For data interval [X(I),X(I+1)], -C ISMON(I) = -3 if function is probably decreasing; -C ISMON(I) = -1 if function is strictly decreasing; -C ISMON(I) = 0 if function is constant; -C ISMON(I) = 1 if function is strictly increasing; -C ISMON(I) = 2 if function is non-monotonic; -C ISMON(I) = 3 if function is probably increasing. -C If ABS(ISMON)=3, this means that the D-values are near -C the boundary of the monotonicity region. A small -C increase produces non-monotonicity; decrease, strict -C monotonicity. -C The above applies to I=1(1)N-1. ISMON(N) indicates whether -C the entire function is monotonic on [X(1),X(N)]. -C -C IERR:OUT is an error flag. -C Normal return: -C IERR = 0 (no errors). -C "Recoverable" errors: -C IERR = -1 if N.LT.2 . -C IERR = -2 if INCFD.LT.1 . -C IERR = -3 if the X-array is not strictly increasing. -C (The ISMON-array has not been changed in any of these cases.) -C NOTE: The above errors are checked in the order listed, -C and following arguments have **NOT** been validated. -C -C *Description: -C -C PCHCM: Piecewise Cubic Hermite -- Check Monotonicity. -C -C Checks the piecewise cubic Hermite function defined by N,X,F,D -C for monotonicity. -C -C To provide compatibility with PCHIM and PCHIC, includes an -C increment between successive values of the F- and D-arrays. -C -C *Cautions: -C This provides the same capability as old PCHMC, except that a -C new output value, -3, was added February 1989. (Formerly, -3 -C and +3 were lumped together in the single value 3.) Codes that -C flag nonmonotonicity by "IF (ISMON.EQ.2)" need not be changed. -C Codes that check via "IF (ISMON.GE.3)" should change the test to -C "IF (IABS(ISMON).GE.3)". Codes that declare monotonicity via -C "IF (ISMON.LE.1)" should change to "IF (IABS(ISMON).LE.1)". -C -C***REFERENCES F. N. Fritsch and R. E. Carlson, Monotone piecewise -C cubic interpolation, SIAM Journal on Numerical Ana- -C lysis 17, 2 (April 1980), pp. 238-246. -C***ROUTINES CALLED CHFCM, XERMSG -C***REVISION HISTORY (YYMMDD) -C 820518 DATE WRITTEN -C 820804 Converted to SLATEC library version. -C 831201 Reversed order of subscripts of F and D, so that the -C routine will work properly when INCFD.GT.1 . (Bug!!) -C 870707 Minor cosmetic changes to prologue. -C 890208 Added possible ISMON value of -3 and modified code so -C that 1,3,-1 produces ISMON(N)=2, rather than 3. -C 890306 Added caution about changed output. -C 890407 Changed name from PCHMC to PCHCM, as requested at the -C March 1989 SLATEC CML meeting, and made a few other -C minor modifications necessitated by this change. -C 890407 Converted to new SLATEC format. -C 890407 Modified DESCRIPTION to LDOC format. -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 920429 Revised format and order of references. (WRB,FNF) -C***END PROLOGUE PCHCM -C -C Fortran intrinsics used: ISIGN. -C Other routines used: CHFCM, XERMSG. -C -C ---------------------------------------------------------------------- -C -C Programming notes: -C -C An alternate organization would have separate loops for computing -C ISMON(i), i=1,...,NSEG, and for the computation of ISMON(N). The -C first loop can be readily parallelized, since the NSEG calls to -C CHFCM are independent. The second loop can be cut short if -C ISMON(N) is ever equal to 2, for it cannot be changed further. -C -C To produce a double precision version, simply: -C a. Change PCHCM to DPCHCM wherever it occurs, -C b. Change CHFCM to DCHFCM wherever it occurs, and -C c. Change the real declarations to double precision. -C -C DECLARE ARGUMENTS. -C - INTEGER N, INCFD, ISMON(N), IERR - REAL X(N), F(INCFD,N), D(INCFD,N) - LOGICAL SKIP -C -C DECLARE LOCAL VARIABLES. -C - INTEGER I, NSEG - REAL DELTA - INTEGER CHFCM -C -C VALIDITY-CHECK ARGUMENTS. -C -C***FIRST EXECUTABLE STATEMENT PCHCM - IF (SKIP) GO TO 5 -C - IF ( N.LT.2 ) GO TO 5001 - IF ( INCFD.LT.1 ) GO TO 5002 - DO 1 I = 2, N - IF ( X(I).LE.X(I-1) ) GO TO 5003 - 1 CONTINUE - SKIP = .TRUE. -C -C FUNCTION DEFINITION IS OK -- GO ON. -C - 5 CONTINUE - NSEG = N - 1 - DO 90 I = 1, NSEG - DELTA = (F(1,I+1)-F(1,I))/(X(I+1)-X(I)) -C ------------------------------- - ISMON(I) = CHFCM (D(1,I), D(1,I+1), DELTA) -C ------------------------------- - IF (I .EQ. 1) THEN - ISMON(N) = ISMON(1) - ELSE -C Need to figure out cumulative monotonicity from following -C "multiplication table": -C -C + I S M O N (I) -C + -3 -1 0 1 3 2 -C +------------------------+ -C I -3 I -3 -3 -3 2 2 2 I -C S -1 I -3 -1 -1 2 2 2 I -C M 0 I -3 -1 0 1 3 2 I -C O 1 I 2 2 1 1 3 2 I -C N 3 I 2 2 3 3 3 2 I -C (N) 2 I 2 2 2 2 2 2 I -C +------------------------+ -C Note that the 2 row and column are out of order so as not -C to obscure the symmetry in the rest of the table. -C -C No change needed if equal or constant on this interval or -C already declared nonmonotonic. - IF ( (ISMON(I).NE.ISMON(N)) .AND. (ISMON(I).NE.0) - . .AND. (ISMON(N).NE.2) ) THEN - IF ( (ISMON(I).EQ.2) .OR. (ISMON(N).EQ.0) ) THEN - ISMON(N) = ISMON(I) - ELSE IF (ISMON(I)*ISMON(N) .LT. 0) THEN -C This interval has opposite sense from curve so far. - ISMON(N) = 2 - ELSE -C At this point, both are nonzero with same sign, and -C we have already eliminated case both +-1. - ISMON(N) = ISIGN (3, ISMON(N)) - ENDIF - ENDIF - ENDIF - 90 CONTINUE -C -C NORMAL RETURN. -C - IERR = 0 - RETURN -C -C ERROR RETURNS. -C - 5001 CONTINUE -C N.LT.2 RETURN. - IERR = -1 - CALL XERMSG ('SLATEC', 'PCHCM', - + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) - RETURN -C - 5002 CONTINUE -C INCFD.LT.1 RETURN. - IERR = -2 - CALL XERMSG ('SLATEC', 'PCHCM', 'INCREMENT LESS THAN ONE', IERR, - + 1) - RETURN -C - 5003 CONTINUE -C X-ARRAY NOT STRICTLY INCREASING. - IERR = -3 - CALL XERMSG ('SLATEC', 'PCHCM', 'X-ARRAY NOT STRICTLY INCREASING' - + , IERR, 1) - RETURN -C------------- LAST LINE OF PCHCM FOLLOWS ------------------------------ - END diff --git a/slatec/pchcs.f b/slatec/pchcs.f deleted file mode 100644 index c7f0357..0000000 --- a/slatec/pchcs.f +++ /dev/null @@ -1,235 +0,0 @@ -*DECK PCHCS - SUBROUTINE PCHCS (SWITCH, N, H, SLOPE, D, INCFD, IERR) -C***BEGIN PROLOGUE PCHCS -C***SUBSIDIARY -C***PURPOSE Adjusts derivative values for PCHIC -C***LIBRARY SLATEC (PCHIP) -C***TYPE SINGLE PRECISION (PCHCS-S, DPCHCS-D) -C***AUTHOR Fritsch, F. N., (LLNL) -C***DESCRIPTION -C -C PCHCS: PCHIC Monotonicity Switch Derivative Setter. -C -C Called by PCHIC to adjust the values of D in the vicinity of a -C switch in direction of monotonicity, to produce a more "visually -C pleasing" curve than that given by PCHIM . -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C PARAMETER (INCFD = ...) -C INTEGER N, IERR -C REAL SWITCH, H(N), SLOPE(N), D(INCFD,N) -C -C CALL PCHCS (SWITCH, N, H, SLOPE, D, INCFD, IERR) -C -C Parameters: -C -C SWITCH -- (input) indicates the amount of control desired over -C local excursions from data. -C -C N -- (input) number of data points. (assumes N.GT.2 .) -C -C H -- (input) real array of interval lengths. -C SLOPE -- (input) real array of data slopes. -C If the data are (X(I),Y(I)), I=1(1)N, then these inputs are: -C H(I) = X(I+1)-X(I), -C SLOPE(I) = (Y(I+1)-Y(I))/H(I), I=1(1)N-1. -C -C D -- (input) real array of derivative values at the data points, -C as determined by PCHCI. -C (output) derivatives in the vicinity of switches in direction -C of monotonicity may be adjusted to produce a more "visually -C pleasing" curve. -C The value corresponding to X(I) is stored in -C D(1+(I-1)*INCFD), I=1(1)N. -C No other entries in D are changed. -C -C INCFD -- (input) increment between successive values in D. -C This argument is provided primarily for 2-D applications. -C -C IERR -- (output) error flag. should be zero. -C If negative, trouble in PCHSW. (should never happen.) -C -C ------- -C WARNING: This routine does no validity-checking of arguments. -C ------- -C -C Fortran intrinsics used: ABS, MAX, MIN. -C -C***SEE ALSO PCHIC -C***ROUTINES CALLED PCHST, PCHSW -C***REVISION HISTORY (YYMMDD) -C 820218 DATE WRITTEN -C 820617 Redesigned to (1) fix problem with lack of continuity -C approaching a flat-topped peak (2) be cleaner and -C easier to verify. -C Eliminated subroutines PCHSA and PCHSX in the process. -C 820622 1. Limited fact to not exceed one, so computed D is a -C convex combination of PCHCI value and PCHSD value. -C 2. Changed fudge from 1 to 4 (based on experiments). -C 820623 Moved PCHSD to an inline function (eliminating MSWTYP). -C 820805 Converted to SLATEC library version. -C 870813 Minor cosmetic changes. -C 890411 Added SAVE statements (Vers. 3.2). -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900328 Added TYPE section. (WRB) -C 910408 Updated AUTHOR section in prologue. (WRB) -C 930503 Improved purpose. (FNF) -C***END PROLOGUE PCHCS -C -C Programming notes: -C 1. The function PCHST(ARG1,ARG2) is assumed to return zero if -C either argument is zero, +1 if they are of the same sign, and -C -1 if they are of opposite sign. -C**End -C -C DECLARE ARGUMENTS. -C - INTEGER N, INCFD, IERR - REAL SWITCH, H(*), SLOPE(*), D(INCFD,*) -C -C DECLARE LOCAL VARIABLES. -C - INTEGER I, INDX, K, NLESS1 - REAL DEL(3), DEXT, DFLOC, DFMX, FACT, FUDGE, ONE, SLMAX, - * WTAVE(2), ZERO - SAVE ZERO, ONE, FUDGE - REAL PCHST -C -C DEFINE INLINE FUNCTION FOR WEIGHTED AVERAGE OF SLOPES. -C - REAL PCHSD, S1, S2, H1, H2 - PCHSD(S1,S2,H1,H2) = (H2/(H1+H2))*S1 + (H1/(H1+H2))*S2 -C -C INITIALIZE. -C - DATA ZERO /0./, ONE /1./ - DATA FUDGE /4./ -C***FIRST EXECUTABLE STATEMENT PCHCS - IERR = 0 - NLESS1 = N - 1 -C -C LOOP OVER SEGMENTS. -C - DO 900 I = 2, NLESS1 - IF ( PCHST(SLOPE(I-1),SLOPE(I)) ) 100, 300, 900 -C -------------------------- -C - 100 CONTINUE -C -C....... SLOPE SWITCHES MONOTONICITY AT I-TH POINT ..................... -C -C DO NOT CHANGE D IF 'UP-DOWN-UP'. - IF (I .GT. 2) THEN - IF ( PCHST(SLOPE(I-2),SLOPE(I)) .GT. ZERO) GO TO 900 -C -------------------------- - ENDIF - IF (I .LT. NLESS1) THEN - IF ( PCHST(SLOPE(I+1),SLOPE(I-1)) .GT. ZERO) GO TO 900 -C ---------------------------- - ENDIF -C -C ....... COMPUTE PROVISIONAL VALUE FOR D(1,I). -C - DEXT = PCHSD (SLOPE(I-1), SLOPE(I), H(I-1), H(I)) -C -C ....... DETERMINE WHICH INTERVAL CONTAINS THE EXTREMUM. -C - IF ( PCHST(DEXT, SLOPE(I-1)) ) 200, 900, 250 -C ----------------------- -C - 200 CONTINUE -C DEXT AND SLOPE(I-1) HAVE OPPOSITE SIGNS -- -C EXTREMUM IS IN (X(I-1),X(I)). - K = I-1 -C SET UP TO COMPUTE NEW VALUES FOR D(1,I-1) AND D(1,I). - WTAVE(2) = DEXT - IF (K .GT. 1) - * WTAVE(1) = PCHSD (SLOPE(K-1), SLOPE(K), H(K-1), H(K)) - GO TO 400 -C - 250 CONTINUE -C DEXT AND SLOPE(I) HAVE OPPOSITE SIGNS -- -C EXTREMUM IS IN (X(I),X(I+1)). - K = I -C SET UP TO COMPUTE NEW VALUES FOR D(1,I) AND D(1,I+1). - WTAVE(1) = DEXT - IF (K .LT. NLESS1) - * WTAVE(2) = PCHSD (SLOPE(K), SLOPE(K+1), H(K), H(K+1)) - GO TO 400 -C - 300 CONTINUE -C -C....... AT LEAST ONE OF SLOPE(I-1) AND SLOPE(I) IS ZERO -- -C CHECK FOR FLAT-TOPPED PEAK ....................... -C - IF (I .EQ. NLESS1) GO TO 900 - IF ( PCHST(SLOPE(I-1), SLOPE(I+1)) .GE. ZERO) GO TO 900 -C ----------------------------- -C -C WE HAVE FLAT-TOPPED PEAK ON (X(I),X(I+1)). - K = I -C SET UP TO COMPUTE NEW VALUES FOR D(1,I) AND D(1,I+1). - WTAVE(1) = PCHSD (SLOPE(K-1), SLOPE(K), H(K-1), H(K)) - WTAVE(2) = PCHSD (SLOPE(K), SLOPE(K+1), H(K), H(K+1)) -C - 400 CONTINUE -C -C....... AT THIS POINT WE HAVE DETERMINED THAT THERE WILL BE AN EXTREMUM -C ON (X(K),X(K+1)), WHERE K=I OR I-1, AND HAVE SET ARRAY WTAVE-- -C WTAVE(1) IS A WEIGHTED AVERAGE OF SLOPE(K-1) AND SLOPE(K), -C IF K.GT.1 -C WTAVE(2) IS A WEIGHTED AVERAGE OF SLOPE(K) AND SLOPE(K+1), -C IF K.LT.N-1 -C - SLMAX = ABS(SLOPE(K)) - IF (K .GT. 1) SLMAX = MAX( SLMAX, ABS(SLOPE(K-1)) ) - IF (K.LT.NLESS1) SLMAX = MAX( SLMAX, ABS(SLOPE(K+1)) ) -C - IF (K .GT. 1) DEL(1) = SLOPE(K-1) / SLMAX - DEL(2) = SLOPE(K) / SLMAX - IF (K.LT.NLESS1) DEL(3) = SLOPE(K+1) / SLMAX -C - IF ((K.GT.1) .AND. (K.LT.NLESS1)) THEN -C NORMAL CASE -- EXTREMUM IS NOT IN A BOUNDARY INTERVAL. - FACT = FUDGE* ABS(DEL(3)*(DEL(1)-DEL(2))*(WTAVE(2)/SLMAX)) - D(1,K) = D(1,K) + MIN(FACT,ONE)*(WTAVE(1) - D(1,K)) - FACT = FUDGE* ABS(DEL(1)*(DEL(3)-DEL(2))*(WTAVE(1)/SLMAX)) - D(1,K+1) = D(1,K+1) + MIN(FACT,ONE)*(WTAVE(2) - D(1,K+1)) - ELSE -C SPECIAL CASE K=1 (WHICH CAN OCCUR ONLY IF I=2) OR -C K=NLESS1 (WHICH CAN OCCUR ONLY IF I=NLESS1). - FACT = FUDGE* ABS(DEL(2)) - D(1,I) = MIN(FACT,ONE) * WTAVE(I-K+1) -C NOTE THAT I-K+1 = 1 IF K=I (=NLESS1), -C I-K+1 = 2 IF K=I-1(=1). - ENDIF -C -C -C....... ADJUST IF NECESSARY TO LIMIT EXCURSIONS FROM DATA. -C - IF (SWITCH .LE. ZERO) GO TO 900 -C - DFLOC = H(K)*ABS(SLOPE(K)) - IF (K .GT. 1) DFLOC = MAX( DFLOC, H(K-1)*ABS(SLOPE(K-1)) ) - IF (K.LT.NLESS1) DFLOC = MAX( DFLOC, H(K+1)*ABS(SLOPE(K+1)) ) - DFMX = SWITCH*DFLOC - INDX = I-K+1 -C INDX = 1 IF K=I, 2 IF K=I-1. -C --------------------------------------------------------------- - CALL PCHSW (DFMX, INDX, D(1,K), D(1,K+1), H(K), SLOPE(K), IERR) -C --------------------------------------------------------------- - IF (IERR .NE. 0) RETURN -C -C....... END OF SEGMENT LOOP. -C - 900 CONTINUE -C - RETURN -C------------- LAST LINE OF PCHCS FOLLOWS ------------------------------ - END diff --git a/slatec/pchdf.f b/slatec/pchdf.f deleted file mode 100644 index e40a900..0000000 --- a/slatec/pchdf.f +++ /dev/null @@ -1,106 +0,0 @@ -*DECK PCHDF - REAL FUNCTION PCHDF (K, X, S, IERR) -C***BEGIN PROLOGUE PCHDF -C***SUBSIDIARY -C***PURPOSE Computes divided differences for PCHCE and PCHSP -C***LIBRARY SLATEC (PCHIP) -C***TYPE SINGLE PRECISION (PCHDF-S, DPCHDF-D) -C***AUTHOR Fritsch, F. N., (LLNL) -C***DESCRIPTION -C -C PCHDF: PCHIP Finite Difference Formula -C -C Uses a divided difference formulation to compute a K-point approx- -C imation to the derivative at X(K) based on the data in X and S. -C -C Called by PCHCE and PCHSP to compute 3- and 4-point boundary -C derivative approximations. -C -C ---------------------------------------------------------------------- -C -C On input: -C K is the order of the desired derivative approximation. -C K must be at least 3 (error return if not). -C X contains the K values of the independent variable. -C X need not be ordered, but the values **MUST** be -C distinct. (Not checked here.) -C S contains the associated slope values: -C S(I) = (F(I+1)-F(I))/(X(I+1)-X(I)), I=1(1)K-1. -C (Note that S need only be of length K-1.) -C -C On return: -C S will be destroyed. -C IERR will be set to -1 if K.LT.2 . -C PCHDF will be set to the desired derivative approximation if -C IERR=0 or to zero if IERR=-1. -C -C ---------------------------------------------------------------------- -C -C***SEE ALSO PCHCE, PCHSP -C***REFERENCES Carl de Boor, A Practical Guide to Splines, Springer- -C Verlag, New York, 1978, pp. 10-16. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 820503 DATE WRITTEN -C 820805 Converted to SLATEC library version. -C 870813 Minor cosmetic changes. -C 890411 Added SAVE statements (Vers. 3.2). -C 890411 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 900328 Added TYPE section. (WRB) -C 910408 Updated AUTHOR and DATE WRITTEN sections in prologue. (WRB) -C 920429 Revised format and order of references. (WRB,FNF) -C 930503 Improved purpose. (FNF) -C***END PROLOGUE PCHDF -C -C**End -C -C DECLARE ARGUMENTS. -C - INTEGER K, IERR - REAL X(K), S(K) -C -C DECLARE LOCAL VARIABLES. -C - INTEGER I, J - REAL VALUE, ZERO - SAVE ZERO - DATA ZERO /0./ -C -C CHECK FOR LEGAL VALUE OF K. -C -C***FIRST EXECUTABLE STATEMENT PCHDF - IF (K .LT. 3) GO TO 5001 -C -C COMPUTE COEFFICIENTS OF INTERPOLATING POLYNOMIAL. -C - DO 10 J = 2, K-1 - DO 9 I = 1, K-J - S(I) = (S(I+1)-S(I))/(X(I+J)-X(I)) - 9 CONTINUE - 10 CONTINUE -C -C EVALUATE DERIVATIVE AT X(K). -C - VALUE = S(1) - DO 20 I = 2, K-1 - VALUE = S(I) + VALUE*(X(K)-X(I)) - 20 CONTINUE -C -C NORMAL RETURN. -C - IERR = 0 - PCHDF = VALUE - RETURN -C -C ERROR RETURN. -C - 5001 CONTINUE -C K.LT.3 RETURN. - IERR = -1 - CALL XERMSG ('SLATEC', 'PCHDF', 'K LESS THAN THREE', IERR, 1) - PCHDF = ZERO - RETURN -C------------- LAST LINE OF PCHDF FOLLOWS ------------------------------ - END diff --git a/slatec/pchdoc.f b/slatec/pchdoc.f deleted file mode 100644 index fd67266..0000000 --- a/slatec/pchdoc.f +++ /dev/null @@ -1,213 +0,0 @@ -*DECK PCHDOC - SUBROUTINE PCHDOC -C***BEGIN PROLOGUE PCHDOC -C***PURPOSE Documentation for PCHIP, a Fortran package for piecewise -C cubic Hermite interpolation of data. -C***LIBRARY SLATEC (PCHIP) -C***CATEGORY E1A, Z -C***TYPE ALL (PCHDOC-A) -C***KEYWORDS CUBIC HERMITE INTERPOLATION, DOCUMENTATION, -C MONOTONE INTERPOLATION, PCHIP, -C PIECEWISE CUBIC INTERPOLATION -C***AUTHOR Fritsch, F. N., (LLNL) -C Lawrence Livermore National Laboratory -C P.O. Box 808 (L-316) -C Livermore, CA 94550 -C FTS 532-4275, (510) 422-4275 -C***DESCRIPTION -C -C PCHIP: Piecewise Cubic Hermite Interpolation Package -C -C This document describes the contents of PCHIP, which is a -C Fortran package for piecewise cubic Hermite interpolation of data. -C It features software to produce a monotone and "visually pleasing" -C interpolant to monotone data. As is demonstrated in Reference 4, -C such an interpolant may be more reasonable than a cubic spline if -C the data contains both "steep" and "flat" sections. Interpola- -C tion of cumulative probability distribution functions is another -C application. (See References 2-4 for examples.) -C -C -C All piecewise cubic functions in PCHIP are represented in -C cubic Hermite form; that is, f(x) is determined by its values -C F(I) and derivatives D(I) at the breakpoints X(I), I=1(1)N. -C Throughout the package a PCH function is represented by the -C five variables N, X, F, D, INCFD: -C N - number of data points; -C X - abscissa values for the data points; -C F - ordinates (function values) for the data points; -C D - slopes (derivative values) at the data points; -C INCFD - increment between successive elements in the F- and -C D-arrays (more on this later). -C These appear together and in the same order in all calls. -C -C The double precision equivalents of the PCHIP routines are -C obtained from the single precision names by prefixing the -C single precision names with a D. For example, the double -C precision equivalent of PCHIM is DPCHIM. -C -C The contents of the package are as follows: -C -C 1. Determine Derivative Values. -C -C NOTE: These routines provide alternate ways of determining D -C if these values are not already known. -C -C PCHIM -- Piecewise Cubic Hermite Interpolation to Monotone -C data. -C Used if the data are monotonic or if the user wants -C to guarantee that the interpolant stays within the -C limits of the data. (See Reference 3.) -C -C PCHIC -- Piecewise Cubic Hermite Interpolation Coefficients. -C Used if neither of the above conditions holds, or if -C the user wishes control over boundary derivatives. -C Will generally reproduce monotonicity on subintervals -C over which the data are monotonic. -C -C PCHSP -- Piecewise Cubic Hermite Spline. -C Produces a cubic spline interpolator in cubic Hermite -C form. Provided primarily for easy comparison of the -C spline with other piecewise cubic interpolants. (A -C modified version of de Boor's CUBSPL, Reference 1.) -C -C 2. Evaluate, Differentiate, or Integrate Resulting PCH Function. -C -C NOTE: If derivative values are available from some other -C source, these routines can be used without calling -C any of the previous routines. -C -C CHFEV -- Cubic Hermite Function EValuator. -C Evaluates a single cubic Hermite function at an array -C of points. Used when the interval is known, as in -C graphing applications. Called by PCHFE. -C -C PCHFE -- Piecewise Cubic Hermite Function Evaluator. -C Used when the interval is unknown or the evaluation -C array spans more than one data interval. -C -C CHFDV -- Cubic Hermite Function and Derivative Evaluator. -C Evaluates a single cubic Hermite function and its -C first derivative at an array of points. Used when -C the interval is known, as in graphing applications. -C Called by PCHFD. -C -C PCHFD -- Piecewise Cubic Hermite Function and Derivative -C Evaluator. -C Used when the interval is unknown or the evaluation -C array spans more than one data interval. -C -C PCHID -- Piecewise Cubic Hermite Integrator, Data Limits. -C Computes the definite integral of a piecewise cubic -C Hermite function when the integration limits are data -C points. -C -C PCHIA -- Piecewise Cubic Hermite Integrator, Arbitrary Limits. -C Computes the definite integral of a piecewise cubic -C Hermite function over an arbitrary finite interval. -C -C 3. Utility routines. -C -C PCHBS -- Piecewise Cubic Hermite to B-Spline converter. -C Converts a PCH function to B-representation, so that -C it can be used with other elements of the B-spline -C package (see BSPDOC). -C -C PCHCM -- Piecewise Cubic Hermite, Check Monotonicity of. -C Checks the monotonicity of an arbitrary PCH function. -C Might be used with PCHSP to build a polyalgorithm for -C piecewise C-2 interpolation. -C -C 4. Internal routines. -C -C CHFIE -- Cubic Hermite Function Integral Evaluator. -C (Real function called by PCHIA.) -C -C CHFCM -- Cubic Hermite Function, Check Monotonicity of. -C (Integer function called by PCHCM.) -C -C PCHCE -- PCHIC End Derivative Setter. -C (Called by PCHIC.) -C -C PCHCI -- PCHIC Initial Derivative Setter. -C (Called by PCHIC.) -C -C PCHCS -- PCHIC Monotonicity Switch Derivative Setter. -C (Called by PCHIC.) -C -C PCHDF -- PCHIP Finite Difference Formula. -C (Real function called by PCHCE and PCHSP.) -C -C PCHST -- PCHIP Sign Testing Routine. -C (Real function called by various PCHIP routines.) -C -C PCHSW -- PCHCS Switch Excursion Adjuster. -C (Called by PCHCS.) -C -C The calling sequences for these routines are described in the -C prologues of the respective routines. -C -C -C INCFD, the increment between successive elements in the F- -C and D-arrays is included in the representation of a PCH function -C in this package to facilitate two-dimensional applications. For -C "normal" usage INCFD=1, and F and D are one-dimensional arrays. -C one would call PCHxx (where "xx" is "IM", "IC", or "SP") with -C -C N, X, F, D, 1 . -C -C Suppose, however, that one has data on a rectangular mesh, -C -C F2D(I,J) = value at (X(I), Y(J)), I=1(1)NX, -C J=1(1)NY. -C Assume the following dimensions: -C -C REAL X(NXMAX), Y(NYMAX) -C REAL F2D(NXMAX,NYMAX), FX(NXMAX,NYMAX), FY(NXMAX,NYMAX) -C -C where 2.LE.NX.LE.NXMAX AND 2.LE.NY.LE.NYMAX . To interpolate -C in X along the line Y = Y(J), call PCHxx with -C -C NX, X, F2D(1,J), FX(1,J), 1 . -C -C To interpolate along the line X = X(I), call PCHxx with -C -C NY, Y, F2D(I,1), FY(I,1), NXMAX . -C -C (This example assumes the usual columnwise storage of 2-D arrays -C in Fortran.) -C -C***REFERENCES 1. Carl de Boor, A Practical Guide to Splines, Springer- -C Verlag, New York, 1978 (esp. Chapter IV, pp.49-62). -C 2. F. N. Fritsch, Piecewise Cubic Hermite Interpolation -C Package, Report UCRL-87285, Lawrence Livermore Natio- -C nal Laboratory, July 1982. [Poster presented at the -C SIAM 30th Anniversary Meeting, 19-23 July 1982.] -C 3. F. N. Fritsch and J. Butland, A method for construc- -C ting local monotone piecewise cubic interpolants, SIAM -C Journal on Scientific and Statistical Computing 5, 2 -C (June 1984), pp. 300-304. -C 4. F. N. Fritsch and R. E. Carlson, Monotone piecewise -C cubic interpolation, SIAM Journal on Numerical Ana- -C lysis 17, 2 (April 1980), pp. 238-246. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 811106 DATE WRITTEN -C 870930 Updated Reference 3. -C 890414 Changed PCHMC and CHFMC to PCHCM and CHFCM, respectively, -C and augmented description of PCHCM. -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 910826 1. Revised purpose, clarified role of argument INCFD, -C corrected error in example, and removed redundant -C reference list. -C 2. Added description of PCHBS. (FNF) -C 920429 Revised format and order of references. (WRB,FNF) -C 930505 Changed CHFIV to CHFIE. (FNF) -C***END PROLOGUE PCHDOC -C----------------------------------------------------------------------- -C THIS IS A DUMMY SUBROUTINE, AND SHOULD NEVER BE CALLED. -C -C***FIRST EXECUTABLE STATEMENT PCHDOC - RETURN -C------------- LAST LINE OF PCHDOC FOLLOWS ----------------------------- - END diff --git a/slatec/pchfd.f b/slatec/pchfd.f deleted file mode 100644 index b073e55..0000000 --- a/slatec/pchfd.f +++ /dev/null @@ -1,320 +0,0 @@ -*DECK PCHFD - SUBROUTINE PCHFD (N, X, F, D, INCFD, SKIP, NE, XE, FE, DE, IERR) -C***BEGIN PROLOGUE PCHFD -C***PURPOSE Evaluate a piecewise cubic Hermite function and its first -C derivative at an array of points. May be used by itself -C for Hermite interpolation, or as an evaluator for PCHIM -C or PCHIC. If only function values are required, use -C PCHFE instead. -C***LIBRARY SLATEC (PCHIP) -C***CATEGORY E3, H1 -C***TYPE SINGLE PRECISION (PCHFD-S, DPCHFD-D) -C***KEYWORDS CUBIC HERMITE DIFFERENTIATION, CUBIC HERMITE EVALUATION, -C HERMITE INTERPOLATION, PCHIP, PIECEWISE CUBIC EVALUATION -C***AUTHOR Fritsch, F. N., (LLNL) -C Lawrence Livermore National Laboratory -C P.O. Box 808 (L-316) -C Livermore, CA 94550 -C FTS 532-4275, (510) 422-4275 -C***DESCRIPTION -C -C PCHFD: Piecewise Cubic Hermite Function and Derivative -C evaluator -C -C Evaluates the cubic Hermite function defined by N, X, F, D, to- -C gether with its first derivative, at the points XE(J), J=1(1)NE. -C -C If only function values are required, use PCHFE, instead. -C -C To provide compatibility with PCHIM and PCHIC, includes an -C increment between successive values of the F- and D-arrays. -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C PARAMETER (INCFD = ...) -C INTEGER N, NE, IERR -C REAL X(N), F(INCFD,N), D(INCFD,N), XE(NE), FE(NE), DE(NE) -C LOGICAL SKIP -C -C CALL PCHFD (N, X, F, D, INCFD, SKIP, NE, XE, FE, DE, IERR) -C -C Parameters: -C -C N -- (input) number of data points. (Error return if N.LT.2 .) -C -C X -- (input) real array of independent variable values. The -C elements of X must be strictly increasing: -C X(I-1) .LT. X(I), I = 2(1)N. -C (Error return if not.) -C -C F -- (input) real array of function values. F(1+(I-1)*INCFD) is -C the value corresponding to X(I). -C -C D -- (input) real array of derivative values. D(1+(I-1)*INCFD) is -C the value corresponding to X(I). -C -C INCFD -- (input) increment between successive values in F and D. -C (Error return if INCFD.LT.1 .) -C -C SKIP -- (input/output) logical variable which should be set to -C .TRUE. if the user wishes to skip checks for validity of -C preceding parameters, or to .FALSE. otherwise. -C This will save time in case these checks have already -C been performed (say, in PCHIM or PCHIC). -C SKIP will be set to .TRUE. on normal return. -C -C NE -- (input) number of evaluation points. (Error return if -C NE.LT.1 .) -C -C XE -- (input) real array of points at which the functions are to -C be evaluated. -C -C -C NOTES: -C 1. The evaluation will be most efficient if the elements -C of XE are increasing relative to X; -C that is, XE(J) .GE. X(I) -C implies XE(K) .GE. X(I), all K.GE.J . -C 2. If any of the XE are outside the interval [X(1),X(N)], -C values are extrapolated from the nearest extreme cubic, -C and a warning error is returned. -C -C FE -- (output) real array of values of the cubic Hermite function -C defined by N, X, F, D at the points XE. -C -C DE -- (output) real array of values of the first derivative of -C the same function at the points XE. -C -C IERR -- (output) error flag. -C Normal return: -C IERR = 0 (no errors). -C Warning error: -C IERR.GT.0 means that extrapolation was performed at -C IERR points. -C "Recoverable" errors: -C IERR = -1 if N.LT.2 . -C IERR = -2 if INCFD.LT.1 . -C IERR = -3 if the X-array is not strictly increasing. -C IERR = -4 if NE.LT.1 . -C (Output arrays have not been changed in any of these cases.) -C NOTE: The above errors are checked in the order listed, -C and following arguments have **NOT** been validated. -C IERR = -5 if an error has occurred in the lower-level -C routine CHFDV. NB: this should never happen. -C Notify the author **IMMEDIATELY** if it does. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CHFDV, XERMSG -C***REVISION HISTORY (YYMMDD) -C 811020 DATE WRITTEN -C 820803 Minor cosmetic changes for release 1. -C 870707 Minor cosmetic changes to prologue. -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE PCHFD -C Programming notes: -C -C 1. To produce a double precision version, simply: -C a. Change PCHFD to DPCHFD, and CHFDV to DCHFDV, wherever they -C occur, -C b. Change the real declaration to double precision, -C -C 2. Most of the coding between the call to CHFDV and the end of -C the IR-loop could be eliminated if it were permissible to -C assume that XE is ordered relative to X. -C -C 3. CHFDV does not assume that X1 is less than X2. thus, it would -C be possible to write a version of PCHFD that assumes a strict- -C ly decreasing X-array by simply running the IR-loop backwards -C (and reversing the order of appropriate tests). -C -C 4. The present code has a minor bug, which I have decided is not -C worth the effort that would be required to fix it. -C If XE contains points in [X(N-1),X(N)], followed by points .LT. -C X(N-1), followed by points .GT.X(N), the extrapolation points -C will be counted (at least) twice in the total returned in IERR. -C -C DECLARE ARGUMENTS. -C - INTEGER N, INCFD, NE, IERR - REAL X(*), F(INCFD,*), D(INCFD,*), XE(*), FE(*), DE(*) - LOGICAL SKIP -C -C DECLARE LOCAL VARIABLES. -C - INTEGER I, IERC, IR, J, JFIRST, NEXT(2), NJ -C -C VALIDITY-CHECK ARGUMENTS. -C -C***FIRST EXECUTABLE STATEMENT PCHFD - IF (SKIP) GO TO 5 -C - IF ( N.LT.2 ) GO TO 5001 - IF ( INCFD.LT.1 ) GO TO 5002 - DO 1 I = 2, N - IF ( X(I).LE.X(I-1) ) GO TO 5003 - 1 CONTINUE -C -C FUNCTION DEFINITION IS OK, GO ON. -C - 5 CONTINUE - IF ( NE.LT.1 ) GO TO 5004 - IERR = 0 - SKIP = .TRUE. -C -C LOOP OVER INTERVALS. ( INTERVAL INDEX IS IL = IR-1 . ) -C ( INTERVAL IS X(IL).LE.X.LT.X(IR) . ) - JFIRST = 1 - IR = 2 - 10 CONTINUE -C -C SKIP OUT OF LOOP IF HAVE PROCESSED ALL EVALUATION POINTS. -C - IF (JFIRST .GT. NE) GO TO 5000 -C -C LOCATE ALL POINTS IN INTERVAL. -C - DO 20 J = JFIRST, NE - IF (XE(J) .GE. X(IR)) GO TO 30 - 20 CONTINUE - J = NE + 1 - GO TO 40 -C -C HAVE LOCATED FIRST POINT BEYOND INTERVAL. -C - 30 CONTINUE - IF (IR .EQ. N) J = NE + 1 -C - 40 CONTINUE - NJ = J - JFIRST -C -C SKIP EVALUATION IF NO POINTS IN INTERVAL. -C - IF (NJ .EQ. 0) GO TO 50 -C -C EVALUATE CUBIC AT XE(I), I = JFIRST (1) J-1 . -C -C ---------------------------------------------------------------- - CALL CHFDV (X(IR-1),X(IR), F(1,IR-1),F(1,IR), D(1,IR-1),D(1,IR), - * NJ, XE(JFIRST), FE(JFIRST), DE(JFIRST), NEXT, IERC) -C ---------------------------------------------------------------- - IF (IERC .LT. 0) GO TO 5005 -C - IF (NEXT(2) .EQ. 0) GO TO 42 -C IF (NEXT(2) .GT. 0) THEN -C IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(2) TO THE -C RIGHT OF X(IR). -C - IF (IR .LT. N) GO TO 41 -C IF (IR .EQ. N) THEN -C THESE ARE ACTUALLY EXTRAPOLATION POINTS. - IERR = IERR + NEXT(2) - GO TO 42 - 41 CONTINUE -C ELSE -C WE SHOULD NEVER HAVE GOTTEN HERE. - GO TO 5005 -C ENDIF -C ENDIF - 42 CONTINUE -C - IF (NEXT(1) .EQ. 0) GO TO 49 -C IF (NEXT(1) .GT. 0) THEN -C IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(1) TO THE -C LEFT OF X(IR-1). -C - IF (IR .GT. 2) GO TO 43 -C IF (IR .EQ. 2) THEN -C THESE ARE ACTUALLY EXTRAPOLATION POINTS. - IERR = IERR + NEXT(1) - GO TO 49 - 43 CONTINUE -C ELSE -C XE IS NOT ORDERED RELATIVE TO X, SO MUST ADJUST -C EVALUATION INTERVAL. -C -C FIRST, LOCATE FIRST POINT TO LEFT OF X(IR-1). - DO 44 I = JFIRST, J-1 - IF (XE(I) .LT. X(IR-1)) GO TO 45 - 44 CONTINUE -C NOTE-- CANNOT DROP THROUGH HERE UNLESS THERE IS AN ERROR -C IN CHFDV. - GO TO 5005 -C - 45 CONTINUE -C RESET J. (THIS WILL BE THE NEW JFIRST.) - J = I -C -C NOW FIND OUT HOW FAR TO BACK UP IN THE X-ARRAY. - DO 46 I = 1, IR-1 - IF (XE(J) .LT. X(I)) GO TO 47 - 46 CONTINUE -C NB-- CAN NEVER DROP THROUGH HERE, SINCE XE(J).LT.X(IR-1). -C - 47 CONTINUE -C AT THIS POINT, EITHER XE(J) .LT. X(1) -C OR X(I-1) .LE. XE(J) .LT. X(I) . -C RESET IR, RECOGNIZING THAT IT WILL BE INCREMENTED BEFORE -C CYCLING. - IR = MAX(1, I-1) -C ENDIF -C ENDIF - 49 CONTINUE -C - JFIRST = J -C -C END OF IR-LOOP. -C - 50 CONTINUE - IR = IR + 1 - IF (IR .LE. N) GO TO 10 -C -C NORMAL RETURN. -C - 5000 CONTINUE - RETURN -C -C ERROR RETURNS. -C - 5001 CONTINUE -C N.LT.2 RETURN. - IERR = -1 - CALL XERMSG ('SLATEC', 'PCHFD', - + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) - RETURN -C - 5002 CONTINUE -C INCFD.LT.1 RETURN. - IERR = -2 - CALL XERMSG ('SLATEC', 'PCHFD', 'INCREMENT LESS THAN ONE', IERR, - + 1) - RETURN -C - 5003 CONTINUE -C X-ARRAY NOT STRICTLY INCREASING. - IERR = -3 - CALL XERMSG ('SLATEC', 'PCHFD', 'X-ARRAY NOT STRICTLY INCREASING' - + , IERR, 1) - RETURN -C - 5004 CONTINUE -C NE.LT.1 RETURN. - IERR = -4 - CALL XERMSG ('SLATEC', 'PCHFD', - + 'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1) - RETURN -C - 5005 CONTINUE -C ERROR RETURN FROM CHFDV. -C *** THIS CASE SHOULD NEVER OCCUR *** - IERR = -5 - CALL XERMSG ('SLATEC', 'PCHFD', - + 'ERROR RETURN FROM CHFDV -- FATAL', IERR, 2) - RETURN -C------------- LAST LINE OF PCHFD FOLLOWS ------------------------------ - END diff --git a/slatec/pchfe.f b/slatec/pchfe.f deleted file mode 100644 index 5bd9a28..0000000 --- a/slatec/pchfe.f +++ /dev/null @@ -1,308 +0,0 @@ -*DECK PCHFE - SUBROUTINE PCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR) -C***BEGIN PROLOGUE PCHFE -C***PURPOSE Evaluate a piecewise cubic Hermite function at an array of -C points. May be used by itself for Hermite interpolation, -C or as an evaluator for PCHIM or PCHIC. -C***LIBRARY SLATEC (PCHIP) -C***CATEGORY E3 -C***TYPE SINGLE PRECISION (PCHFE-S, DPCHFE-D) -C***KEYWORDS CUBIC HERMITE EVALUATION, HERMITE INTERPOLATION, PCHIP, -C PIECEWISE CUBIC EVALUATION -C***AUTHOR Fritsch, F. N., (LLNL) -C Lawrence Livermore National Laboratory -C P.O. Box 808 (L-316) -C Livermore, CA 94550 -C FTS 532-4275, (510) 422-4275 -C***DESCRIPTION -C -C PCHFE: Piecewise Cubic Hermite Function Evaluator -C -C Evaluates the cubic Hermite function defined by N, X, F, D at -C the points XE(J), J=1(1)NE. -C -C To provide compatibility with PCHIM and PCHIC, includes an -C increment between successive values of the F- and D-arrays. -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C PARAMETER (INCFD = ...) -C INTEGER N, NE, IERR -C REAL X(N), F(INCFD,N), D(INCFD,N), XE(NE), FE(NE) -C LOGICAL SKIP -C -C CALL PCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR) -C -C Parameters: -C -C N -- (input) number of data points. (Error return if N.LT.2 .) -C -C X -- (input) real array of independent variable values. The -C elements of X must be strictly increasing: -C X(I-1) .LT. X(I), I = 2(1)N. -C (Error return if not.) -C -C F -- (input) real array of function values. F(1+(I-1)*INCFD) is -C the value corresponding to X(I). -C -C D -- (input) real array of derivative values. D(1+(I-1)*INCFD) is -C the value corresponding to X(I). -C -C INCFD -- (input) increment between successive values in F and D. -C (Error return if INCFD.LT.1 .) -C -C SKIP -- (input/output) logical variable which should be set to -C .TRUE. if the user wishes to skip checks for validity of -C preceding parameters, or to .FALSE. otherwise. -C This will save time in case these checks have already -C been performed (say, in PCHIM or PCHIC). -C SKIP will be set to .TRUE. on normal return. -C -C NE -- (input) number of evaluation points. (Error return if -C NE.LT.1 .) -C -C XE -- (input) real array of points at which the function is to be -C evaluated. -C -C NOTES: -C 1. The evaluation will be most efficient if the elements -C of XE are increasing relative to X; -C that is, XE(J) .GE. X(I) -C implies XE(K) .GE. X(I), all K.GE.J . -C 2. If any of the XE are outside the interval [X(1),X(N)], -C values are extrapolated from the nearest extreme cubic, -C and a warning error is returned. -C -C FE -- (output) real array of values of the cubic Hermite function -C defined by N, X, F, D at the points XE. -C -C IERR -- (output) error flag. -C Normal return: -C IERR = 0 (no errors). -C Warning error: -C IERR.GT.0 means that extrapolation was performed at -C IERR points. -C "Recoverable" errors: -C IERR = -1 if N.LT.2 . -C IERR = -2 if INCFD.LT.1 . -C IERR = -3 if the X-array is not strictly increasing. -C IERR = -4 if NE.LT.1 . -C (The FE-array has not been changed in any of these cases.) -C NOTE: The above errors are checked in the order listed, -C and following arguments have **NOT** been validated. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CHFEV, XERMSG -C***REVISION HISTORY (YYMMDD) -C 811020 DATE WRITTEN -C 820803 Minor cosmetic changes for release 1. -C 870707 Minor cosmetic changes to prologue. -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE PCHFE -C Programming notes: -C -C 1. To produce a double precision version, simply: -C a. Change PCHFE to DPCHFE, and CHFEV to DCHFEV, wherever they -C occur, -C b. Change the real declaration to double precision, -C -C 2. Most of the coding between the call to CHFEV and the end of -C the IR-loop could be eliminated if it were permissible to -C assume that XE is ordered relative to X. -C -C 3. CHFEV does not assume that X1 is less than X2. thus, it would -C be possible to write a version of PCHFE that assumes a strict- -C ly decreasing X-array by simply running the IR-loop backwards -C (and reversing the order of appropriate tests). -C -C 4. The present code has a minor bug, which I have decided is not -C worth the effort that would be required to fix it. -C If XE contains points in [X(N-1),X(N)], followed by points .LT. -C X(N-1), followed by points .GT.X(N), the extrapolation points -C will be counted (at least) twice in the total returned in IERR. -C -C DECLARE ARGUMENTS. -C - INTEGER N, INCFD, NE, IERR - REAL X(*), F(INCFD,*), D(INCFD,*), XE(*), FE(*) - LOGICAL SKIP -C -C DECLARE LOCAL VARIABLES. -C - INTEGER I, IERC, IR, J, JFIRST, NEXT(2), NJ -C -C VALIDITY-CHECK ARGUMENTS. -C -C***FIRST EXECUTABLE STATEMENT PCHFE - IF (SKIP) GO TO 5 -C - IF ( N.LT.2 ) GO TO 5001 - IF ( INCFD.LT.1 ) GO TO 5002 - DO 1 I = 2, N - IF ( X(I).LE.X(I-1) ) GO TO 5003 - 1 CONTINUE -C -C FUNCTION DEFINITION IS OK, GO ON. -C - 5 CONTINUE - IF ( NE.LT.1 ) GO TO 5004 - IERR = 0 - SKIP = .TRUE. -C -C LOOP OVER INTERVALS. ( INTERVAL INDEX IS IL = IR-1 . ) -C ( INTERVAL IS X(IL).LE.X.LT.X(IR) . ) - JFIRST = 1 - IR = 2 - 10 CONTINUE -C -C SKIP OUT OF LOOP IF HAVE PROCESSED ALL EVALUATION POINTS. -C - IF (JFIRST .GT. NE) GO TO 5000 -C -C LOCATE ALL POINTS IN INTERVAL. -C - DO 20 J = JFIRST, NE - IF (XE(J) .GE. X(IR)) GO TO 30 - 20 CONTINUE - J = NE + 1 - GO TO 40 -C -C HAVE LOCATED FIRST POINT BEYOND INTERVAL. -C - 30 CONTINUE - IF (IR .EQ. N) J = NE + 1 -C - 40 CONTINUE - NJ = J - JFIRST -C -C SKIP EVALUATION IF NO POINTS IN INTERVAL. -C - IF (NJ .EQ. 0) GO TO 50 -C -C EVALUATE CUBIC AT XE(I), I = JFIRST (1) J-1 . -C -C ---------------------------------------------------------------- - CALL CHFEV (X(IR-1),X(IR), F(1,IR-1),F(1,IR), D(1,IR-1),D(1,IR), - * NJ, XE(JFIRST), FE(JFIRST), NEXT, IERC) -C ---------------------------------------------------------------- - IF (IERC .LT. 0) GO TO 5005 -C - IF (NEXT(2) .EQ. 0) GO TO 42 -C IF (NEXT(2) .GT. 0) THEN -C IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(2) TO THE -C RIGHT OF X(IR). -C - IF (IR .LT. N) GO TO 41 -C IF (IR .EQ. N) THEN -C THESE ARE ACTUALLY EXTRAPOLATION POINTS. - IERR = IERR + NEXT(2) - GO TO 42 - 41 CONTINUE -C ELSE -C WE SHOULD NEVER HAVE GOTTEN HERE. - GO TO 5005 -C ENDIF -C ENDIF - 42 CONTINUE -C - IF (NEXT(1) .EQ. 0) GO TO 49 -C IF (NEXT(1) .GT. 0) THEN -C IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(1) TO THE -C LEFT OF X(IR-1). -C - IF (IR .GT. 2) GO TO 43 -C IF (IR .EQ. 2) THEN -C THESE ARE ACTUALLY EXTRAPOLATION POINTS. - IERR = IERR + NEXT(1) - GO TO 49 - 43 CONTINUE -C ELSE -C XE IS NOT ORDERED RELATIVE TO X, SO MUST ADJUST -C EVALUATION INTERVAL. -C -C FIRST, LOCATE FIRST POINT TO LEFT OF X(IR-1). - DO 44 I = JFIRST, J-1 - IF (XE(I) .LT. X(IR-1)) GO TO 45 - 44 CONTINUE -C NOTE-- CANNOT DROP THROUGH HERE UNLESS THERE IS AN ERROR -C IN CHFEV. - GO TO 5005 -C - 45 CONTINUE -C RESET J. (THIS WILL BE THE NEW JFIRST.) - J = I -C -C NOW FIND OUT HOW FAR TO BACK UP IN THE X-ARRAY. - DO 46 I = 1, IR-1 - IF (XE(J) .LT. X(I)) GO TO 47 - 46 CONTINUE -C NB-- CAN NEVER DROP THROUGH HERE, SINCE XE(J).LT.X(IR-1). -C - 47 CONTINUE -C AT THIS POINT, EITHER XE(J) .LT. X(1) -C OR X(I-1) .LE. XE(J) .LT. X(I) . -C RESET IR, RECOGNIZING THAT IT WILL BE INCREMENTED BEFORE -C CYCLING. - IR = MAX(1, I-1) -C ENDIF -C ENDIF - 49 CONTINUE -C - JFIRST = J -C -C END OF IR-LOOP. -C - 50 CONTINUE - IR = IR + 1 - IF (IR .LE. N) GO TO 10 -C -C NORMAL RETURN. -C - 5000 CONTINUE - RETURN -C -C ERROR RETURNS. -C - 5001 CONTINUE -C N.LT.2 RETURN. - IERR = -1 - CALL XERMSG ('SLATEC', 'PCHFE', - + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) - RETURN -C - 5002 CONTINUE -C INCFD.LT.1 RETURN. - IERR = -2 - CALL XERMSG ('SLATEC', 'PCHFE', 'INCREMENT LESS THAN ONE', IERR, - + 1) - RETURN -C - 5003 CONTINUE -C X-ARRAY NOT STRICTLY INCREASING. - IERR = -3 - CALL XERMSG ('SLATEC', 'PCHFE', 'X-ARRAY NOT STRICTLY INCREASING' - + , IERR, 1) - RETURN -C - 5004 CONTINUE -C NE.LT.1 RETURN. - IERR = -4 - CALL XERMSG ('SLATEC', 'PCHFE', - + 'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1) - RETURN -C - 5005 CONTINUE -C ERROR RETURN FROM CHFEV. -C *** THIS CASE SHOULD NEVER OCCUR *** - IERR = -5 - CALL XERMSG ('SLATEC', 'PCHFE', - + 'ERROR RETURN FROM CHFEV -- FATAL', IERR, 2) - RETURN -C------------- LAST LINE OF PCHFE FOLLOWS ------------------------------ - END diff --git a/slatec/pchia.f b/slatec/pchia.f deleted file mode 100644 index 91ed672..0000000 --- a/slatec/pchia.f +++ /dev/null @@ -1,265 +0,0 @@ -*DECK PCHIA - REAL FUNCTION PCHIA (N, X, F, D, INCFD, SKIP, A, B, IERR) -C***BEGIN PROLOGUE PCHIA -C***PURPOSE Evaluate the definite integral of a piecewise cubic -C Hermite function over an arbitrary interval. -C***LIBRARY SLATEC (PCHIP) -C***CATEGORY E3, H2A1B2 -C***TYPE SINGLE PRECISION (PCHIA-S, DPCHIA-D) -C***KEYWORDS CUBIC HERMITE INTERPOLATION, NUMERICAL INTEGRATION, PCHIP, -C QUADRATURE -C***AUTHOR Fritsch, F. N., (LLNL) -C Lawrence Livermore National Laboratory -C P.O. Box 808 (L-316) -C Livermore, CA 94550 -C FTS 532-4275, (510) 422-4275 -C***DESCRIPTION -C -C PCHIA: Piecewise Cubic Hermite Integrator, Arbitrary limits -C -C Evaluates the definite integral of the cubic Hermite function -C defined by N, X, F, D over the interval [A, B]. -C -C To provide compatibility with PCHIM and PCHIC, includes an -C increment between successive values of the F- and D-arrays. -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C PARAMETER (INCFD = ...) -C INTEGER N, IERR -C REAL X(N), F(INCFD,N), D(INCFD,N), A, B -C REAL VALUE, PCHIA -C LOGICAL SKIP -C -C VALUE = PCHIA (N, X, F, D, INCFD, SKIP, A, B, IERR) -C -C Parameters: -C -C VALUE -- (output) value of the requested integral. -C -C N -- (input) number of data points. (Error return if N.LT.2 .) -C -C X -- (input) real array of independent variable values. The -C elements of X must be strictly increasing: -C X(I-1) .LT. X(I), I = 2(1)N. -C (Error return if not.) -C -C F -- (input) real array of function values. F(1+(I-1)*INCFD) is -C the value corresponding to X(I). -C -C D -- (input) real array of derivative values. D(1+(I-1)*INCFD) is -C the value corresponding to X(I). -C -C INCFD -- (input) increment between successive values in F and D. -C (Error return if INCFD.LT.1 .) -C -C SKIP -- (input/output) logical variable which should be set to -C .TRUE. if the user wishes to skip checks for validity of -C preceding parameters, or to .FALSE. otherwise. -C This will save time in case these checks have already -C been performed (say, in PCHIM or PCHIC). -C SKIP will be set to .TRUE. on return with IERR.GE.0 . -C -C A,B -- (input) the limits of integration. -C NOTE: There is no requirement that [A,B] be contained in -C [X(1),X(N)]. However, the resulting integral value -C will be highly suspect, if not. -C -C IERR -- (output) error flag. -C Normal return: -C IERR = 0 (no errors). -C Warning errors: -C IERR = 1 if A is outside the interval [X(1),X(N)]. -C IERR = 2 if B is outside the interval [X(1),X(N)]. -C IERR = 3 if both of the above are true. (Note that this -C means that either [A,B] contains data interval -C or the intervals do not intersect at all.) -C "Recoverable" errors: -C IERR = -1 if N.LT.2 . -C IERR = -2 if INCFD.LT.1 . -C IERR = -3 if the X-array is not strictly increasing. -C (VALUE will be zero in any of these cases.) -C NOTE: The above errors are checked in the order listed, -C and following arguments have **NOT** been validated. -C IERR = -4 in case of an error return from PCHID (which -C should never occur). -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CHFIE, PCHID, XERMSG -C***REVISION HISTORY (YYMMDD) -C 820730 DATE WRITTEN -C 820804 Converted to SLATEC library version. -C 870707 Corrected double precision conversion instructions. -C 870813 Minor cosmetic changes. -C 890411 Added SAVE statements (Vers. 3.2). -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890703 Corrected category record. (WRB) -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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 930503 Corrected to set VALUE=0 when IERR.lt.0. (FNF) -C 930504 Changed CHFIV to CHFIE. (FNF) -C***END PROLOGUE PCHIA -C -C Programming notes: -C 1. The error flag from PCHID is tested, because a logic flaw -C could conceivably result in IERD=-4, which should be reported. -C**End -C -C DECLARE ARGUMENTS. -C - INTEGER N, INCFD, IERR - REAL X(*), F(INCFD,*), D(INCFD,*), A, B - LOGICAL SKIP -C -C DECLARE LOCAL VARIABLES. -C - INTEGER I, IA, IB, IERD, IL, IR - REAL VALUE, XA, XB, ZERO - SAVE ZERO - REAL CHFIE, PCHID -C -C INITIALIZE. -C - DATA ZERO /0./ -C***FIRST EXECUTABLE STATEMENT PCHIA - VALUE = ZERO -C -C VALIDITY-CHECK ARGUMENTS. -C - IF (SKIP) GO TO 5 -C - IF ( N.LT.2 ) GO TO 5001 - IF ( INCFD.LT.1 ) GO TO 5002 - DO 1 I = 2, N - IF ( X(I).LE.X(I-1) ) GO TO 5003 - 1 CONTINUE -C -C FUNCTION DEFINITION IS OK, GO ON. -C - 5 CONTINUE - SKIP = .TRUE. - IERR = 0 - IF ( (A.LT.X(1)) .OR. (A.GT.X(N)) ) IERR = IERR + 1 - IF ( (B.LT.X(1)) .OR. (B.GT.X(N)) ) IERR = IERR + 2 -C -C COMPUTE INTEGRAL VALUE. -C - IF (A .NE. B) THEN - XA = MIN (A, B) - XB = MAX (A, B) - IF (XB .LE. X(2)) THEN -C INTERVAL IS TO LEFT OF X(2), SO USE FIRST CUBIC. -C -------------------------------------- - VALUE = CHFIE (X(1),X(2), F(1,1),F(1,2), - + D(1,1),D(1,2), A, B) -C -------------------------------------- - ELSE IF (XA .GE. X(N-1)) THEN -C INTERVAL IS TO RIGHT OF X(N-1), SO USE LAST CUBIC. -C ----------------------------------------- - VALUE = CHFIE(X(N-1),X(N), F(1,N-1),F(1,N), - + D(1,N-1),D(1,N), A, B) -C ----------------------------------------- - ELSE -C 'NORMAL' CASE -- XA.LT.XB, XA.LT.X(N-1), XB.GT.X(2). -C ......LOCATE IA AND IB SUCH THAT -C X(IA-1).LT.XA.LE.X(IA).LE.X(IB).LE.XB.LE.X(IB+1) - IA = 1 - DO 10 I = 1, N-1 - IF (XA .GT. X(I)) IA = I + 1 - 10 CONTINUE -C IA = 1 IMPLIES XA.LT.X(1) . OTHERWISE, -C IA IS LARGEST INDEX SUCH THAT X(IA-1).LT.XA,. -C - IB = N - DO 20 I = N, IA, -1 - IF (XB .LT. X(I)) IB = I - 1 - 20 CONTINUE -C IB = N IMPLIES XB.GT.X(N) . OTHERWISE, -C IB IS SMALLEST INDEX SUCH THAT XB.LT.X(IB+1) . -C -C ......COMPUTE THE INTEGRAL. - IF (IB .LT. IA) THEN -C THIS MEANS IB = IA-1 AND -C (A,B) IS A SUBSET OF (X(IB),X(IA)). -C ------------------------------------------ - VALUE = CHFIE (X(IB),X(IA), F(1,IB),F(1,IA), - + D(1,IB),D(1,IA), A, B) -C ------------------------------------------ - ELSE -C -C FIRST COMPUTE INTEGRAL OVER (X(IA),X(IB)). -C (Case (IB .EQ. IA) is taken care of by initialization -C of VALUE to ZERO.) - IF (IB .GT. IA) THEN -C --------------------------------------------- - VALUE = PCHID (N, X, F, D, INCFD, SKIP, IA, IB, IERD) -C --------------------------------------------- - IF (IERD .LT. 0) GO TO 5004 - ENDIF -C -C THEN ADD ON INTEGRAL OVER (XA,X(IA)). - IF (XA .LT. X(IA)) THEN - IL = MAX(1, IA-1) - IR = IL + 1 -C ------------------------------------- - VALUE = VALUE + CHFIE (X(IL),X(IR), F(1,IL),F(1,IR), - + D(1,IL),D(1,IR), XA, X(IA)) -C ------------------------------------- - ENDIF -C -C THEN ADD ON INTEGRAL OVER (X(IB),XB). - IF (XB .GT. X(IB)) THEN - IR = MIN (IB+1, N) - IL = IR - 1 -C ------------------------------------- - VALUE = VALUE + CHFIE (X(IL),X(IR), F(1,IL),F(1,IR), - + D(1,IL),D(1,IR), X(IB), XB) -C ------------------------------------- - ENDIF -C -C FINALLY, ADJUST SIGN IF NECESSARY. - IF (A .GT. B) VALUE = -VALUE - ENDIF - ENDIF - ENDIF -C -C NORMAL RETURN. -C - 5000 CONTINUE - PCHIA = VALUE - RETURN -C -C ERROR RETURNS. -C - 5001 CONTINUE -C N.LT.2 RETURN. - IERR = -1 - CALL XERMSG ('SLATEC', 'PCHIA', - + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) - GO TO 5000 -C - 5002 CONTINUE -C INCFD.LT.1 RETURN. - IERR = -2 - CALL XERMSG ('SLATEC', 'PCHIA', 'INCREMENT LESS THAN ONE', IERR, - + 1) - GO TO 5000 -C - 5003 CONTINUE -C X-ARRAY NOT STRICTLY INCREASING. - IERR = -3 - CALL XERMSG ('SLATEC', 'PCHIA', - + 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) - GO TO 5000 -C - 5004 CONTINUE -C TROUBLE IN PCHID. (SHOULD NEVER OCCUR.) - IERR = -4 - CALL XERMSG ('SLATEC', 'PCHIA', 'TROUBLE IN PCHID', IERR, 1) - GO TO 5000 -C------------- LAST LINE OF PCHIA FOLLOWS ------------------------------ - END diff --git a/slatec/pchic.f b/slatec/pchic.f deleted file mode 100644 index cd0eda6..0000000 --- a/slatec/pchic.f +++ /dev/null @@ -1,341 +0,0 @@ -*DECK PCHIC - SUBROUTINE PCHIC (IC, VC, SWITCH, N, X, F, D, INCFD, WK, NWK, - + IERR) -C***BEGIN PROLOGUE PCHIC -C***PURPOSE Set derivatives needed to determine a piecewise monotone -C piecewise cubic Hermite interpolant to given data. -C User control is available over boundary conditions and/or -C treatment of points where monotonicity switches direction. -C***LIBRARY SLATEC (PCHIP) -C***CATEGORY E1A -C***TYPE SINGLE PRECISION (PCHIC-S, DPCHIC-D) -C***KEYWORDS CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION, -C PCHIP, PIECEWISE CUBIC INTERPOLATION, -C SHAPE-PRESERVING INTERPOLATION -C***AUTHOR Fritsch, F. N., (LLNL) -C Lawrence Livermore National Laboratory -C P.O. Box 808 (L-316) -C Livermore, CA 94550 -C FTS 532-4275, (510) 422-4275 -C***DESCRIPTION -C -C PCHIC: Piecewise Cubic Hermite Interpolation Coefficients. -C -C Sets derivatives needed to determine a piecewise monotone piece- -C wise cubic interpolant to the data given in X and F satisfying the -C boundary conditions specified by IC and VC. -C -C The treatment of points where monotonicity switches direction is -C controlled by argument SWITCH. -C -C To facilitate two-dimensional applications, includes an increment -C between successive values of the F- and D-arrays. -C -C The resulting piecewise cubic Hermite function may be evaluated -C by PCHFE or PCHFD. -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C PARAMETER (INCFD = ...) -C INTEGER IC(2), N, NWK, IERR -C REAL VC(2), SWITCH, X(N), F(INCFD,N), D(INCFD,N), WK(NWK) -C -C CALL PCHIC (IC, VC, SWITCH, N, X, F, D, INCFD, WK, NWK, IERR) -C -C Parameters: -C -C IC -- (input) integer array of length 2 specifying desired -C boundary conditions: -C IC(1) = IBEG, desired condition at beginning of data. -C IC(2) = IEND, desired condition at end of data. -C -C IBEG = 0 for the default boundary condition (the same as -C used by PCHIM). -C If IBEG.NE.0, then its sign indicates whether the boundary -C derivative is to be adjusted, if necessary, to be -C compatible with monotonicity: -C IBEG.GT.0 if no adjustment is to be performed. -C IBEG.LT.0 if the derivative is to be adjusted for -C monotonicity. -C -C Allowable values for the magnitude of IBEG are: -C IBEG = 1 if first derivative at X(1) is given in VC(1). -C IBEG = 2 if second derivative at X(1) is given in VC(1). -C IBEG = 3 to use the 3-point difference formula for D(1). -C (Reverts to the default b.c. if N.LT.3 .) -C IBEG = 4 to use the 4-point difference formula for D(1). -C (Reverts to the default b.c. if N.LT.4 .) -C IBEG = 5 to set D(1) so that the second derivative is con- -C tinuous at X(2). (Reverts to the default b.c. if N.LT.4.) -C This option is somewhat analogous to the "not a knot" -C boundary condition provided by PCHSP. -C -C NOTES (IBEG): -C 1. An error return is taken if ABS(IBEG).GT.5 . -C 2. Only in case IBEG.LE.0 is it guaranteed that the -C interpolant will be monotonic in the first interval. -C If the returned value of D(1) lies between zero and -C 3*SLOPE(1), the interpolant will be monotonic. This -C is **NOT** checked if IBEG.GT.0 . -C 3. If IBEG.LT.0 and D(1) had to be changed to achieve mono- -C tonicity, a warning error is returned. -C -C IEND may take on the same values as IBEG, but applied to -C derivative at X(N). In case IEND = 1 or 2, the value is -C given in VC(2). -C -C NOTES (IEND): -C 1. An error return is taken if ABS(IEND).GT.5 . -C 2. Only in case IEND.LE.0 is it guaranteed that the -C interpolant will be monotonic in the last interval. -C If the returned value of D(1+(N-1)*INCFD) lies between -C zero and 3*SLOPE(N-1), the interpolant will be monotonic. -C This is **NOT** checked if IEND.GT.0 . -C 3. If IEND.LT.0 and D(1+(N-1)*INCFD) had to be changed to -C achieve monotonicity, a warning error is returned. -C -C VC -- (input) real array of length 2 specifying desired boundary -C values, as indicated above. -C VC(1) need be set only if IC(1) = 1 or 2 . -C VC(2) need be set only if IC(2) = 1 or 2 . -C -C SWITCH -- (input) indicates desired treatment of points where -C direction of monotonicity switches: -C Set SWITCH to zero if interpolant is required to be mono- -C tonic in each interval, regardless of monotonicity of data. -C NOTES: -C 1. This will cause D to be set to zero at all switch -C points, thus forcing extrema there. -C 2. The result of using this option with the default boun- -C dary conditions will be identical to using PCHIM, but -C will generally cost more compute time. -C This option is provided only to facilitate comparison -C of different switch and/or boundary conditions. -C Set SWITCH nonzero to use a formula based on the 3-point -C difference formula in the vicinity of switch points. -C If SWITCH is positive, the interpolant on each interval -C containing an extremum is controlled to not deviate from -C the data by more than SWITCH*DFLOC, where DFLOC is the -C maximum of the change of F on this interval and its two -C immediate neighbors. -C If SWITCH is negative, no such control is to be imposed. -C -C N -- (input) number of data points. (Error return if N.LT.2 .) -C -C X -- (input) real array of independent variable values. The -C elements of X must be strictly increasing: -C X(I-1) .LT. X(I), I = 2(1)N. -C (Error return if not.) -C -C F -- (input) real array of dependent variable values to be inter- -C polated. F(1+(I-1)*INCFD) is value corresponding to X(I). -C -C D -- (output) real array of derivative values at the data points. -C These values will determine a monotone cubic Hermite func- -C tion on each subinterval on which the data are monotonic, -C except possibly adjacent to switches in monotonicity. -C The value corresponding to X(I) is stored in -C D(1+(I-1)*INCFD), I=1(1)N. -C No other entries in D are changed. -C -C INCFD -- (input) increment between successive values in F and D. -C This argument is provided primarily for 2-D applications. -C (Error return if INCFD.LT.1 .) -C -C WK -- (scratch) real array of working storage. The user may wish -C to know that the returned values are: -C WK(I) = H(I) = X(I+1) - X(I) ; -C WK(N-1+I) = SLOPE(I) = (F(1,I+1) - F(1,I)) / H(I) -C for I = 1(1)N-1. -C -C NWK -- (input) length of work array. -C (Error return if NWK.LT.2*(N-1) .) -C -C IERR -- (output) error flag. -C Normal return: -C IERR = 0 (no errors). -C Warning errors: -C IERR = 1 if IBEG.LT.0 and D(1) had to be adjusted for -C monotonicity. -C IERR = 2 if IEND.LT.0 and D(1+(N-1)*INCFD) had to be -C adjusted for monotonicity. -C IERR = 3 if both of the above are true. -C "Recoverable" errors: -C IERR = -1 if N.LT.2 . -C IERR = -2 if INCFD.LT.1 . -C IERR = -3 if the X-array is not strictly increasing. -C IERR = -4 if ABS(IBEG).GT.5 . -C IERR = -5 if ABS(IEND).GT.5 . -C IERR = -6 if both of the above are true. -C IERR = -7 if NWK.LT.2*(N-1) . -C (The D-array has not been changed in any of these cases.) -C NOTE: The above errors are checked in the order listed, -C and following arguments have **NOT** been validated. -C -C***REFERENCES 1. F. N. Fritsch, Piecewise Cubic Hermite Interpolation -C Package, Report UCRL-87285, Lawrence Livermore Nation- -C al Laboratory, July 1982. [Poster presented at the -C SIAM 30th Anniversary Meeting, 19-23 July 1982.] -C 2. F. N. Fritsch and J. Butland, A method for construc- -C ting local monotone piecewise cubic interpolants, SIAM -C Journal on Scientific and Statistical Computing 5, 2 -C (June 1984), pp. 300-304. -C 3. F. N. Fritsch and R. E. Carlson, Monotone piecewise -C cubic interpolation, SIAM Journal on Numerical Ana- -C lysis 17, 2 (April 1980), pp. 238-246. -C***ROUTINES CALLED PCHCE, PCHCI, PCHCS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 820218 DATE WRITTEN -C 820804 Converted to SLATEC library version. -C 870813 Updated Reference 2. -C 890411 Added SAVE statements (Vers. 3.2). -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890703 Corrected category record. (WRB) -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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 920429 Revised format and order of references. (WRB,FNF) -C***END PROLOGUE PCHIC -C Programming notes: -C -C To produce a double precision version, simply: -C a. Change PCHIC to DPCHIC wherever it occurs, -C b. Change PCHCE to DPCHCE wherever it occurs, -C c. Change PCHCI to DPCHCI wherever it occurs, -C d. Change PCHCS to DPCHCS wherever it occurs, -C e. Change the real declarations to double precision, and -C f. Change the constant ZERO to double precision. -C -C DECLARE ARGUMENTS. -C - INTEGER IC(2), N, INCFD, NWK, IERR - REAL VC(2), SWITCH, X(*), F(INCFD,*), D(INCFD,*), WK(NWK) -C -C DECLARE LOCAL VARIABLES. -C - INTEGER I, IBEG, IEND, NLESS1 - REAL ZERO - SAVE ZERO - DATA ZERO /0./ -C -C VALIDITY-CHECK ARGUMENTS. -C -C***FIRST EXECUTABLE STATEMENT PCHIC - IF ( N.LT.2 ) GO TO 5001 - IF ( INCFD.LT.1 ) GO TO 5002 - DO 1 I = 2, N - IF ( X(I).LE.X(I-1) ) GO TO 5003 - 1 CONTINUE -C - IBEG = IC(1) - IEND = IC(2) - IERR = 0 - IF (ABS(IBEG) .GT. 5) IERR = IERR - 1 - IF (ABS(IEND) .GT. 5) IERR = IERR - 2 - IF (IERR .LT. 0) GO TO 5004 -C -C FUNCTION DEFINITION IS OK -- GO ON. -C - NLESS1 = N - 1 - IF ( NWK .LT. 2*NLESS1 ) GO TO 5007 -C -C SET UP H AND SLOPE ARRAYS. -C - DO 20 I = 1, NLESS1 - WK(I) = X(I+1) - X(I) - WK(NLESS1+I) = (F(1,I+1) - F(1,I)) / WK(I) - 20 CONTINUE -C -C SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION. -C - IF (NLESS1 .GT. 1) GO TO 1000 - D(1,1) = WK(2) - D(1,N) = WK(2) - GO TO 3000 -C -C NORMAL CASE (N .GE. 3) . -C - 1000 CONTINUE -C -C SET INTERIOR DERIVATIVES AND DEFAULT END CONDITIONS. -C -C -------------------------------------- - CALL PCHCI (N, WK(1), WK(N), D, INCFD) -C -------------------------------------- -C -C SET DERIVATIVES AT POINTS WHERE MONOTONICITY SWITCHES DIRECTION. -C - IF (SWITCH .EQ. ZERO) GO TO 3000 -C ---------------------------------------------------- - CALL PCHCS (SWITCH, N, WK(1), WK(N), D, INCFD, IERR) -C ---------------------------------------------------- - IF (IERR .NE. 0) GO TO 5008 -C -C SET END CONDITIONS. -C - 3000 CONTINUE - IF ( (IBEG.EQ.0) .AND. (IEND.EQ.0) ) GO TO 5000 -C ------------------------------------------------------- - CALL PCHCE (IC, VC, N, X, WK(1), WK(N), D, INCFD, IERR) -C ------------------------------------------------------- - IF (IERR .LT. 0) GO TO 5009 -C -C NORMAL RETURN. -C - 5000 CONTINUE - RETURN -C -C ERROR RETURNS. -C - 5001 CONTINUE -C N.LT.2 RETURN. - IERR = -1 - CALL XERMSG ('SLATEC', 'PCHIC', - + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) - RETURN -C - 5002 CONTINUE -C INCFD.LT.1 RETURN. - IERR = -2 - CALL XERMSG ('SLATEC', 'PCHIC', 'INCREMENT LESS THAN ONE', IERR, - + 1) - RETURN -C - 5003 CONTINUE -C X-ARRAY NOT STRICTLY INCREASING. - IERR = -3 - CALL XERMSG ('SLATEC', 'PCHIC', 'X-ARRAY NOT STRICTLY INCREASING' - + , IERR, 1) - RETURN -C - 5004 CONTINUE -C IC OUT OF RANGE RETURN. - IERR = IERR - 3 - CALL XERMSG ('SLATEC', 'PCHIC', 'IC OUT OF RANGE', IERR, 1) - RETURN -C - 5007 CONTINUE -C NWK .LT. 2*(N-1) RETURN. - IERR = -7 - CALL XERMSG ('SLATEC', 'PCHIC', 'WORK ARRAY TOO SMALL', IERR, 1) - RETURN -C - 5008 CONTINUE -C ERROR RETURN FROM PCHCS. - IERR = -8 - CALL XERMSG ('SLATEC', 'PCHIC', 'ERROR RETURN FROM PCHCS', IERR, - + 1) - RETURN -C - 5009 CONTINUE -C ERROR RETURN FROM PCHCE. -C *** THIS CASE SHOULD NEVER OCCUR *** - IERR = -9 - CALL XERMSG ('SLATEC', 'PCHIC', 'ERROR RETURN FROM PCHCE', IERR, - + 1) - RETURN -C------------- LAST LINE OF PCHIC FOLLOWS ------------------------------ - END diff --git a/slatec/pchid.f b/slatec/pchid.f deleted file mode 100644 index dc9de85..0000000 --- a/slatec/pchid.f +++ /dev/null @@ -1,190 +0,0 @@ -*DECK PCHID - REAL FUNCTION PCHID (N, X, F, D, INCFD, SKIP, IA, IB, IERR) -C***BEGIN PROLOGUE PCHID -C***PURPOSE Evaluate the definite integral of a piecewise cubic -C Hermite function over an interval whose endpoints are data -C points. -C***LIBRARY SLATEC (PCHIP) -C***CATEGORY E3, H2A1B2 -C***TYPE SINGLE PRECISION (PCHID-S, DPCHID-D) -C***KEYWORDS CUBIC HERMITE INTERPOLATION, NUMERICAL INTEGRATION, PCHIP, -C QUADRATURE -C***AUTHOR Fritsch, F. N., (LLNL) -C Lawrence Livermore National Laboratory -C P.O. Box 808 (L-316) -C Livermore, CA 94550 -C FTS 532-4275, (510) 422-4275 -C***DESCRIPTION -C -C PCHID: Piecewise Cubic Hermite Integrator, Data limits -C -C Evaluates the definite integral of the cubic Hermite function -C defined by N, X, F, D over the interval [X(IA), X(IB)]. -C -C To provide compatibility with PCHIM and PCHIC, includes an -C increment between successive values of the F- and D-arrays. -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C PARAMETER (INCFD = ...) -C INTEGER N, IA, IB, IERR -C REAL X(N), F(INCFD,N), D(INCFD,N) -C LOGICAL SKIP -C -C VALUE = PCHID (N, X, F, D, INCFD, SKIP, IA, IB, IERR) -C -C Parameters: -C -C VALUE -- (output) value of the requested integral. -C -C N -- (input) number of data points. (Error return if N.LT.2 .) -C -C X -- (input) real array of independent variable values. The -C elements of X must be strictly increasing: -C X(I-1) .LT. X(I), I = 2(1)N. -C (Error return if not.) -C -C F -- (input) real array of function values. F(1+(I-1)*INCFD) is -C the value corresponding to X(I). -C -C D -- (input) real array of derivative values. D(1+(I-1)*INCFD) is -C the value corresponding to X(I). -C -C INCFD -- (input) increment between successive values in F and D. -C (Error return if INCFD.LT.1 .) -C -C SKIP -- (input/output) logical variable which should be set to -C .TRUE. if the user wishes to skip checks for validity of -C preceding parameters, or to .FALSE. otherwise. -C This will save time in case these checks have already -C been performed (say, in PCHIM or PCHIC). -C SKIP will be set to .TRUE. on return with IERR = 0 or -4. -C -C IA,IB -- (input) indices in X-array for the limits of integration. -C both must be in the range [1,N]. (Error return if not.) -C No restrictions on their relative values. -C -C IERR -- (output) error flag. -C Normal return: -C IERR = 0 (no errors). -C "Recoverable" errors: -C IERR = -1 if N.LT.2 . -C IERR = -2 if INCFD.LT.1 . -C IERR = -3 if the X-array is not strictly increasing. -C IERR = -4 if IA or IB is out of range. -C (VALUE will be zero in any of these cases.) -C NOTE: The above errors are checked in the order listed, -C and following arguments have **NOT** been validated. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 820723 DATE WRITTEN -C 820804 Converted to SLATEC library version. -C 870813 Minor cosmetic changes. -C 890411 Added SAVE statements (Vers. 3.2). -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890703 Corrected category record. (WRB) -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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 930504 Corrected to set VALUE=0 when IERR.ne.0. (FNF) -C***END PROLOGUE PCHID -C -C Programming notes: -C 1. This routine uses a special formula that is valid only for -C integrals whose limits coincide with data values. This is -C mathematically equivalent to, but much more efficient than, -C calls to CHFIE. -C**End -C -C DECLARE ARGUMENTS. -C - INTEGER N, INCFD, IA, IB, IERR - REAL X(*), F(INCFD,*), D(INCFD,*) - LOGICAL SKIP -C -C DECLARE LOCAL VARIABLES. -C - INTEGER I, IUP, LOW - REAL H, HALF, SIX, SUM, VALUE, ZERO - SAVE ZERO, HALF, SIX -C -C INITIALIZE. -C - DATA ZERO /0./, HALF /0.5/, SIX /6./ -C***FIRST EXECUTABLE STATEMENT PCHID - VALUE = ZERO -C -C VALIDITY-CHECK ARGUMENTS. -C - IF (SKIP) GO TO 5 -C - IF ( N.LT.2 ) GO TO 5001 - IF ( INCFD.LT.1 ) GO TO 5002 - DO 1 I = 2, N - IF ( X(I).LE.X(I-1) ) GO TO 5003 - 1 CONTINUE -C -C FUNCTION DEFINITION IS OK, GO ON. -C - 5 CONTINUE - SKIP = .TRUE. - IF ((IA.LT.1) .OR. (IA.GT.N)) GO TO 5004 - IF ((IB.LT.1) .OR. (IB.GT.N)) GO TO 5004 - IERR = 0 -C -C COMPUTE INTEGRAL VALUE. -C - IF (IA .NE. IB) THEN - LOW = MIN(IA, IB) - IUP = MAX(IA, IB) - 1 - SUM = ZERO - DO 10 I = LOW, IUP - H = X(I+1) - X(I) - SUM = SUM + H*( (F(1,I) + F(1,I+1)) + - * (D(1,I) - D(1,I+1))*(H/SIX) ) - 10 CONTINUE - VALUE = HALF * SUM - IF (IA .GT. IB) VALUE = -VALUE - ENDIF -C -C NORMAL RETURN. -C - 5000 CONTINUE - PCHID = VALUE - RETURN -C -C ERROR RETURNS. -C - 5001 CONTINUE -C N.LT.2 RETURN. - IERR = -1 - CALL XERMSG ('SLATEC', 'PCHID', - + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) - GO TO 5000 -C - 5002 CONTINUE -C INCFD.LT.1 RETURN. - IERR = -2 - CALL XERMSG ('SLATEC', 'PCHID', 'INCREMENT LESS THAN ONE', IERR, - + 1) - GO TO 5000 -C - 5003 CONTINUE -C X-ARRAY NOT STRICTLY INCREASING. - IERR = -3 - CALL XERMSG ('SLATEC', 'PCHID', - + 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) - GO TO 5000 -C - 5004 CONTINUE -C IA OR IB OUT OF RANGE RETURN. - IERR = -4 - CALL XERMSG ('SLATEC', 'PCHID', 'IA OR IB OUT OF RANGE', IERR, 1) - GO TO 5000 -C------------- LAST LINE OF PCHID FOLLOWS ------------------------------ - END diff --git a/slatec/pchim.f b/slatec/pchim.f deleted file mode 100644 index 8c12f00..0000000 --- a/slatec/pchim.f +++ /dev/null @@ -1,280 +0,0 @@ -*DECK PCHIM - SUBROUTINE PCHIM (N, X, F, D, INCFD, IERR) -C***BEGIN PROLOGUE PCHIM -C***PURPOSE Set derivatives needed to determine a monotone piecewise -C cubic Hermite interpolant to given data. Boundary values -C are provided which are compatible with monotonicity. The -C interpolant will have an extremum at each point where mono- -C tonicity switches direction. (See PCHIC if user control is -C desired over boundary or switch conditions.) -C***LIBRARY SLATEC (PCHIP) -C***CATEGORY E1A -C***TYPE SINGLE PRECISION (PCHIM-S, DPCHIM-D) -C***KEYWORDS CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION, -C PCHIP, PIECEWISE CUBIC INTERPOLATION -C***AUTHOR Fritsch, F. N., (LLNL) -C Lawrence Livermore National Laboratory -C P.O. Box 808 (L-316) -C Livermore, CA 94550 -C FTS 532-4275, (510) 422-4275 -C***DESCRIPTION -C -C PCHIM: Piecewise Cubic Hermite Interpolation to -C Monotone data. -C -C Sets derivatives needed to determine a monotone piecewise cubic -C Hermite interpolant to the data given in X and F. -C -C Default boundary conditions are provided which are compatible -C with monotonicity. (See PCHIC if user control of boundary con- -C ditions is desired.) -C -C If the data are only piecewise monotonic, the interpolant will -C have an extremum at each point where monotonicity switches direc- -C tion. (See PCHIC if user control is desired in such cases.) -C -C To facilitate two-dimensional applications, includes an increment -C between successive values of the F- and D-arrays. -C -C The resulting piecewise cubic Hermite function may be evaluated -C by PCHFE or PCHFD. -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C PARAMETER (INCFD = ...) -C INTEGER N, IERR -C REAL X(N), F(INCFD,N), D(INCFD,N) -C -C CALL PCHIM (N, X, F, D, INCFD, IERR) -C -C Parameters: -C -C N -- (input) number of data points. (Error return if N.LT.2 .) -C If N=2, simply does linear interpolation. -C -C X -- (input) real array of independent variable values. The -C elements of X must be strictly increasing: -C X(I-1) .LT. X(I), I = 2(1)N. -C (Error return if not.) -C -C F -- (input) real array of dependent variable values to be inter- -C polated. F(1+(I-1)*INCFD) is value corresponding to X(I). -C PCHIM is designed for monotonic data, but it will work for -C any F-array. It will force extrema at points where mono- -C tonicity switches direction. If some other treatment of -C switch points is desired, PCHIC should be used instead. -C ----- -C D -- (output) real array of derivative values at the data points. -C If the data are monotonic, these values will determine a -C a monotone cubic Hermite function. -C The value corresponding to X(I) is stored in -C D(1+(I-1)*INCFD), I=1(1)N. -C No other entries in D are changed. -C -C INCFD -- (input) increment between successive values in F and D. -C This argument is provided primarily for 2-D applications. -C (Error return if INCFD.LT.1 .) -C -C IERR -- (output) error flag. -C Normal return: -C IERR = 0 (no errors). -C Warning error: -C IERR.GT.0 means that IERR switches in the direction -C of monotonicity were detected. -C "Recoverable" errors: -C IERR = -1 if N.LT.2 . -C IERR = -2 if INCFD.LT.1 . -C IERR = -3 if the X-array is not strictly increasing. -C (The D-array has not been changed in any of these cases.) -C NOTE: The above errors are checked in the order listed, -C and following arguments have **NOT** been validated. -C -C***REFERENCES 1. F. N. Fritsch and J. Butland, A method for construc- -C ting local monotone piecewise cubic interpolants, SIAM -C Journal on Scientific and Statistical Computing 5, 2 -C (June 1984), pp. 300-304. -C 2. F. N. Fritsch and R. E. Carlson, Monotone piecewise -C cubic interpolation, SIAM Journal on Numerical Ana- -C lysis 17, 2 (April 1980), pp. 238-246. -C***ROUTINES CALLED PCHST, XERMSG -C***REVISION HISTORY (YYMMDD) -C 811103 DATE WRITTEN -C 820201 1. Introduced PCHST to reduce possible over/under- -C flow problems. -C 2. Rearranged derivative formula for same reason. -C 820602 1. Modified end conditions to be continuous functions -C of data when monotonicity switches in next interval. -C 2. Modified formulas so end conditions are less prone -C of over/underflow problems. -C 820803 Minor cosmetic changes for release 1. -C 870813 Updated Reference 1. -C 890411 Added SAVE statements (Vers. 3.2). -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890703 Corrected category record. (WRB) -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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 920429 Revised format and order of references. (WRB,FNF) -C***END PROLOGUE PCHIM -C Programming notes: -C -C 1. The function PCHST(ARG1,ARG2) is assumed to return zero if -C either argument is zero, +1 if they are of the same sign, and -C -1 if they are of opposite sign. -C 2. To produce a double precision version, simply: -C a. Change PCHIM to DPCHIM wherever it occurs, -C b. Change PCHST to DPCHST wherever it occurs, -C c. Change all references to the Fortran intrinsics to their -C double precision equivalents, -C d. Change the real declarations to double precision, and -C e. Change the constants ZERO and THREE to double precision. -C -C DECLARE ARGUMENTS. -C - INTEGER N, INCFD, IERR - REAL X(*), F(INCFD,*), D(INCFD,*) -C -C DECLARE LOCAL VARIABLES. -C - INTEGER I, NLESS1 - REAL DEL1, DEL2, DMAX, DMIN, DRAT1, DRAT2, DSAVE, - * H1, H2, HSUM, HSUMT3, THREE, W1, W2, ZERO - SAVE ZERO, THREE - REAL PCHST - DATA ZERO /0./, THREE /3./ -C -C VALIDITY-CHECK ARGUMENTS. -C -C***FIRST EXECUTABLE STATEMENT PCHIM - IF ( N.LT.2 ) GO TO 5001 - IF ( INCFD.LT.1 ) GO TO 5002 - DO 1 I = 2, N - IF ( X(I).LE.X(I-1) ) GO TO 5003 - 1 CONTINUE -C -C FUNCTION DEFINITION IS OK, GO ON. -C - IERR = 0 - NLESS1 = N - 1 - H1 = X(2) - X(1) - DEL1 = (F(1,2) - F(1,1))/H1 - DSAVE = DEL1 -C -C SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION. -C - IF (NLESS1 .GT. 1) GO TO 10 - D(1,1) = DEL1 - D(1,N) = DEL1 - GO TO 5000 -C -C NORMAL CASE (N .GE. 3). -C - 10 CONTINUE - H2 = X(3) - X(2) - DEL2 = (F(1,3) - F(1,2))/H2 -C -C SET D(1) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE -C SHAPE-PRESERVING. -C - HSUM = H1 + H2 - W1 = (H1 + HSUM)/HSUM - W2 = -H1/HSUM - D(1,1) = W1*DEL1 + W2*DEL2 - IF ( PCHST(D(1,1),DEL1) .LE. ZERO) THEN - D(1,1) = ZERO - ELSE IF ( PCHST(DEL1,DEL2) .LT. ZERO) THEN -C NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. - DMAX = THREE*DEL1 - IF (ABS(D(1,1)) .GT. ABS(DMAX)) D(1,1) = DMAX - ENDIF -C -C LOOP THROUGH INTERIOR POINTS. -C - DO 50 I = 2, NLESS1 - IF (I .EQ. 2) GO TO 40 -C - H1 = H2 - H2 = X(I+1) - X(I) - HSUM = H1 + H2 - DEL1 = DEL2 - DEL2 = (F(1,I+1) - F(1,I))/H2 - 40 CONTINUE -C -C SET D(I)=0 UNLESS DATA ARE STRICTLY MONOTONIC. -C - D(1,I) = ZERO - IF ( PCHST(DEL1,DEL2) ) 42, 41, 45 -C -C COUNT NUMBER OF CHANGES IN DIRECTION OF MONOTONICITY. -C - 41 CONTINUE - IF (DEL2 .EQ. ZERO) GO TO 50 - IF ( PCHST(DSAVE,DEL2) .LT. ZERO) IERR = IERR + 1 - DSAVE = DEL2 - GO TO 50 -C - 42 CONTINUE - IERR = IERR + 1 - DSAVE = DEL2 - GO TO 50 -C -C USE BRODLIE MODIFICATION OF BUTLAND FORMULA. -C - 45 CONTINUE - HSUMT3 = HSUM+HSUM+HSUM - W1 = (HSUM + H1)/HSUMT3 - W2 = (HSUM + H2)/HSUMT3 - DMAX = MAX( ABS(DEL1), ABS(DEL2) ) - DMIN = MIN( ABS(DEL1), ABS(DEL2) ) - DRAT1 = DEL1/DMAX - DRAT2 = DEL2/DMAX - D(1,I) = DMIN/(W1*DRAT1 + W2*DRAT2) -C - 50 CONTINUE -C -C SET D(N) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE -C SHAPE-PRESERVING. -C - W1 = -H2/HSUM - W2 = (H2 + HSUM)/HSUM - D(1,N) = W1*DEL1 + W2*DEL2 - IF ( PCHST(D(1,N),DEL2) .LE. ZERO) THEN - D(1,N) = ZERO - ELSE IF ( PCHST(DEL1,DEL2) .LT. ZERO) THEN -C NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. - DMAX = THREE*DEL2 - IF (ABS(D(1,N)) .GT. ABS(DMAX)) D(1,N) = DMAX - ENDIF -C -C NORMAL RETURN. -C - 5000 CONTINUE - RETURN -C -C ERROR RETURNS. -C - 5001 CONTINUE -C N.LT.2 RETURN. - IERR = -1 - CALL XERMSG ('SLATEC', 'PCHIM', - + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) - RETURN -C - 5002 CONTINUE -C INCFD.LT.1 RETURN. - IERR = -2 - CALL XERMSG ('SLATEC', 'PCHIM', 'INCREMENT LESS THAN ONE', IERR, - + 1) - RETURN -C - 5003 CONTINUE -C X-ARRAY NOT STRICTLY INCREASING. - IERR = -3 - CALL XERMSG ('SLATEC', 'PCHIM', 'X-ARRAY NOT STRICTLY INCREASING' - + , IERR, 1) - RETURN -C------------- LAST LINE OF PCHIM FOLLOWS ------------------------------ - END diff --git a/slatec/pchkt.f b/slatec/pchkt.f deleted file mode 100644 index 2662c37..0000000 --- a/slatec/pchkt.f +++ /dev/null @@ -1,95 +0,0 @@ -*DECK PCHKT - SUBROUTINE PCHKT (N, X, KNOTYP, T) -C***BEGIN PROLOGUE PCHKT -C***SUBSIDIARY -C***PURPOSE Compute B-spline knot sequence for PCHBS. -C***LIBRARY SLATEC (PCHIP) -C***CATEGORY E3 -C***TYPE SINGLE PRECISION (PCHKT-S, DPCHKT-D) -C***AUTHOR Fritsch, F. N., (LLNL) -C***DESCRIPTION -C -C Set a knot sequence for the B-spline representation of a PCH -C function with breakpoints X. All knots will be at least double. -C Endknots are set as: -C (1) quadruple knots at endpoints if KNOTYP=0; -C (2) extrapolate the length of end interval if KNOTYP=1; -C (3) periodic if KNOTYP=2. -C -C Input arguments: N, X, KNOTYP. -C Output arguments: T. -C -C Restrictions/assumptions: -C 1. N.GE.2 . (not checked) -C 2. X(i).LT.X(i+1), i=1,...,N . (not checked) -C 3. 0.LE.KNOTYP.LE.2 . (Acts like KNOTYP=0 for any other value.) -C -C***SEE ALSO PCHBS -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 870701 DATE WRITTEN -C 900405 Converted Fortran to upper case. -C 900410 Converted prologue to SLATEC 4.0 format. -C 900410 Minor cosmetic changes. -C 930514 Changed NKNOTS from an output to an input variable. (FNF) -C 930604 Removed unused variable NKNOTS from argument list. (FNF) -C***END PROLOGUE PCHKT -C -C*Internal Notes: -C -C Since this is subsidiary to PCHBS, which validates its input before -C calling, it is unnecessary for such validation to be done here. -C -C**End -C -C Declare arguments. -C - INTEGER N, KNOTYP - REAL X(*), T(*) -C -C Declare local variables. -C - INTEGER J, K, NDIM - REAL HBEG, HEND -C***FIRST EXECUTABLE STATEMENT PCHKT -C -C Initialize. -C - NDIM = 2*N -C -C Set interior knots. -C - J = 1 - DO 20 K = 1, N - J = J + 2 - T(J) = X(K) - T(J+1) = T(J) - 20 CONTINUE -C Assertion: At this point T(3),...,T(NDIM+2) have been set and -C J=NDIM+1. -C -C Set end knots according to KNOTYP. -C - HBEG = X(2) - X(1) - HEND = X(N) - X(N-1) - IF (KNOTYP.EQ.1 ) THEN -C Extrapolate. - T(2) = X(1) - HBEG - T(NDIM+3) = X(N) + HEND - ELSE IF ( KNOTYP.EQ.2 ) THEN -C Periodic. - T(2) = X(1) - HEND - T(NDIM+3) = X(N) + HBEG - ELSE -C Quadruple end knots. - T(2) = X(1) - T(NDIM+3) = X(N) - ENDIF - T(1) = T(2) - T(NDIM+4) = T(NDIM+3) -C -C Terminate. -C - RETURN -C------------- LAST LINE OF PCHKT FOLLOWS ------------------------------ - END diff --git a/slatec/pchngs.f b/slatec/pchngs.f deleted file mode 100644 index 86d9e1e..0000000 --- a/slatec/pchngs.f +++ /dev/null @@ -1,257 +0,0 @@ -*DECK PCHNGS - SUBROUTINE PCHNGS (II, XVAL, IPLACE, SX, IX, IRCX) -C***BEGIN PROLOGUE PCHNGS -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (PCHNGS-S, DPCHNG-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C -C PCHNGS LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SCHEME. -C SPARSE MATRIX ELEMENT ALTERATION SUBROUTINE. -C -C SUBROUTINE PCHNGS() CHANGES ELEMENT II IN VECTOR +/- IRCX TO THE -C VALUE XVAL. -C -C II THE ABSOLUTE VALUE OF THIS INTEGER IS THE SUBSCRIPT FOR -C THE ELEMENT TO BE CHANGED. -C XVAL NEW VALUE OF THE MATRIX ELEMENT BEING CHANGED. -C IPLACE POINTER INFORMATION WHICH IS MAINTAINED BY THE PACKAGE. -C SX(*),IX(*) THE WORK ARRAYS WHICH ARE USED TO STORE THE SPARSE -C MATRIX. THESE ARRAYS ARE AUTOMATICALLY MAINTAINED BY THE -C PACKAGE FOR THE USER. -C IRCX POINTS TO THE VECTOR OF THE MATRIX BEING UPDATED. -C A NEGATIVE VALUE OF IRCX INDICATES THAT ROW -IRCX IS -C BEING UPDATED. A POSITIVE VALUE OF IRCX INDICATES THAT -C COLUMN IRCX IS BEING UPDATED. A ZERO VALUE OF IRCX IS -C AN ERROR. -C -C SINCE DATA ITEMS ARE KEPT SORTED IN THE SEQUENTIAL DATA STRUCTURE, -C CHANGING A MATRIX ELEMENT CAN REQUIRE THE MOVEMENT OF ALL THE DATA -C ITEMS IN THE MATRIX. FOR THIS REASON, IT IS SUGGESTED THAT DATA -C ITEMS BE ADDED A COL. AT A TIME, IN ASCENDING COL. SEQUENCE. -C FURTHERMORE, SINCE DELETING ITEMS FROM THE DATA STRUCTURE MAY ALSO -C REQUIRE MOVING LARGE AMOUNTS OF DATA, ZERO ELEMENTS ARE EXPLICITLY -C STORED IN THE MATRIX. -C -C THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LCHNGS, -C SANDIA LABS. REPT. SAND78-0785. -C MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON -C REVISED 811130-1000 -C REVISED YYMMDD-HHMM -C -C***SEE ALSO SPLP -C***ROUTINES CALLED IPLOC, PRWPGE, XERMSG -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 910403 Updated AUTHOR and DESCRIPTION sections. (WRB) -C***END PROLOGUE PCHNGS - DIMENSION IX(*) - INTEGER IPLOC - REAL SX(*),XVAL,ZERO,ONE,SXLAST,SXVAL - SAVE ZERO, ONE - DATA ZERO,ONE /0.E0,1.E0/ -C***FIRST EXECUTABLE STATEMENT PCHNGS - IOPT=1 -C -C DETERMINE NULL-CASES.. - IF(II.EQ.0) RETURN -C -C CHECK VALIDITY OF ROW/COL. INDEX. -C - IF (.NOT.(IRCX.EQ.0)) GO TO 20002 - NERR=55 - CALL XERMSG ('SLATEC', 'PCHNGS', 'IRCX=0.', NERR, IOPT) -20002 LMX = IX(1) -C -C LMX IS THE LENGTH OF THE IN-MEMORY STORAGE AREA. -C - IF (.NOT.(IRCX.LT.0)) GO TO 20005 -C -C CHECK SUBSCRIPTS OF THE ROW. THE ROW NUMBER MUST BE .LE. M AND -C THE INDEX MUST BE .LE. N. -C - IF (.NOT.(IX(2).LT.-IRCX .OR. IX(3).LT.ABS(II))) GO TO 20008 - NERR=55 - CALL XERMSG ('SLATEC', 'PCHNGS', - + 'SUBSCRIPTS FOR ARRAY ELEMENT TO BE ACCESSED WERE OUT OF ' // - + 'BOUNDS.', NERR, IOPT) -20008 GO TO 20006 -C -C CHECK SUBSCRIPTS OF THE COLUMN. THE COL. NUMBER MUST BE .LE. N AND -C THE INDEX MUST BE .LE. M. -C -20005 IF (.NOT.(IX(3).LT.IRCX .OR. IX(2).LT.ABS(II))) GO TO 20011 - NERR=55 - CALL XERMSG ('SLATEC', 'PCHNGS', - + 'SUBSCRIPTS FOR ARRAY ELEMENT TO BE ACCESSED WERE OUT OF ' // - + 'BOUNDS.', NERR, IOPT) -20011 CONTINUE -C -C SET I TO BE THE ELEMENT OF ROW/COLUMN J TO BE CHANGED. -C -20006 IF (.NOT.(IRCX.GT.0)) GO TO 20014 - I = ABS(II) - J = ABS(IRCX) - GO TO 20015 -20014 I = ABS(IRCX) - J = ABS(II) -C -C THE INTEGER LL POINTS TO THE START OF THE MATRIX ELEMENT DATA. -C -20015 LL=IX(3)+4 - II = ABS(II) - LPG = LMX - LL -C -C SET IPLACE TO START OUR SCAN FOR THE ELEMENT AT THE BEGINNING -C OF THE VECTOR. -C - IF (.NOT.(J.EQ.1)) GO TO 20017 - IPLACE=LL+1 - GO TO 20018 -20017 IPLACE=IX(J+3)+1 -C -C IEND POINTS TO THE LAST ELEMENT OF THE VECTOR TO BE SCANNED. -C -20018 IEND = IX(J+4) -C -C SCAN THROUGH SEVERAL PAGES, IF NECESSARY, TO FIND MATRIX ELEMENT. -C - IPL = IPLOC(IPLACE,SX,IX) - NP = ABS(IX(LMX-1)) - GO TO 20021 -20020 IF (ILAST.EQ.IEND) GO TO 20022 -C -C THE VIRTUAL END OF DATA FOR THIS PAGE IS ILAST. -C -20021 ILAST = MIN(IEND,NP*LPG+LL-2) -C -C THE RELATIVE END OF DATA FOR THIS PAGE IS IL. -C SEARCH FOR A MATRIX VALUE WITH AN INDEX .GE. I ON THE PRESENT -C PAGE. -C - IL = IPLOC(ILAST,SX,IX) - IL = MIN(IL,LMX-2) -20023 IF (.NOT.(.NOT.(IPL.GE.IL .OR. IX(IPL).GE.I))) GO TO 20024 - IPL=IPL+1 - GO TO 20023 -C -C SET IPLACE AND STORE DATA ITEM IF FOUND. -C -20024 IF (.NOT.(IX(IPL).EQ.I .AND. IPL.LE.IL)) GO TO 20025 - SX(IPL) = XVAL - SX(LMX) = ONE - RETURN -C -C EXIT FROM LOOP IF ITEM WAS FOUND. -C -20025 IF(IX(IPL).GT.I .AND. IPL.LE.IL) ILAST = IEND - IF (.NOT.(ILAST.NE.IEND)) GO TO 20028 - IPL = LL + 1 - NP = NP + 1 -20028 GO TO 20020 -C -C INSERT NEW DATA ITEM INTO LOCATION AT IPLACE(IPL). -C -20022 IF (.NOT.(IPL.GT.IL.OR.(IPL.EQ.IL.AND.I.GT.IX(IPL)))) GO TO 20031 - IPL = IL + 1 - IF(IPL.EQ.LMX-1) IPL = IPL + 2 -20031 IPLACE = (NP-1)*LPG + IPL -C -C GO TO A NEW PAGE, IF NECESSARY, TO INSERT THE ITEM. -C - IF (.NOT.(IPL.LE.LMX .OR. IX(LMX-1).GE.0)) GO TO 20034 - IPL=IPLOC(IPLACE,SX,IX) -20034 IEND = IX(LL) - NP = ABS(IX(LMX-1)) - SXVAL = XVAL -C -C LOOP THROUGH ALL SUBSEQUENT PAGES OF THE MATRIX MOVING DATA DOWN. -C THIS IS NECESSARY TO MAKE ROOM FOR THE NEW MATRIX ELEMENT AND -C KEEP THE ENTRIES SORTED. -C - GO TO 20038 -20037 IF (IX(LMX-1).LE.0) GO TO 20039 -20038 ILAST = MIN(IEND,NP*LPG+LL-2) - IL = IPLOC(ILAST,SX,IX) - IL = MIN(IL,LMX-2) - SXLAST = SX(IL) - IXLAST = IX(IL) - ISTART = IPL + 1 - IF (.NOT.(ISTART.LE.IL)) GO TO 20040 - K = ISTART + IL - DO 50 JJ=ISTART,IL - SX(K-JJ) = SX(K-JJ-1) - IX(K-JJ) = IX(K-JJ-1) -50 CONTINUE - SX(LMX) = ONE -20040 IF (.NOT.(IPL.LE.LMX)) GO TO 20043 - SX(IPL) = SXVAL - IX(IPL) = I - SXVAL = SXLAST - I = IXLAST - SX(LMX) = ONE - IF (.NOT.(IX(LMX-1).GT.0)) GO TO 20046 - IPL = LL + 1 - NP = NP + 1 -20046 CONTINUE -20043 GO TO 20037 -20039 NP = ABS(IX(LMX-1)) -C -C DETERMINE IF A NEW PAGE IS TO BE CREATED FOR THE LAST ELEMENT -C MOVED DOWN. -C - IL = IL + 1 - IF (.NOT.(IL.EQ.LMX-1)) GO TO 20049 -C -C CREATE A NEW PAGE. -C - IX(LMX-1) = NP -C -C WRITE THE OLD PAGE. -C - SX(LMX) = ZERO - KEY = 2 - CALL PRWPGE(KEY,NP,LPG,SX,IX) - SX(LMX) = ONE -C -C STORE LAST ELEMENT MOVED DOWN IN A NEW PAGE. -C - IPL = LL + 1 - NP = NP + 1 - IX(LMX-1) = -NP - SX(IPL) = SXVAL - IX(IPL) = I - GO TO 20050 -C -C LAST ELEMENT MOVED REMAINED ON THE OLD PAGE. -C -20049 IF (.NOT.(IPL.NE.IL)) GO TO 20052 - SX(IL) = SXVAL - IX(IL) = I - SX(LMX) = ONE -20052 CONTINUE -C -C INCREMENT POINTERS TO LAST ELEMENT IN VECTORS J,J+1,... . -C -20050 JSTART = J + 4 - JJ=JSTART - N20055=LL - GO TO 20056 -20055 JJ=JJ+1 -20056 IF ((N20055-JJ).LT.0) GO TO 20057 - IX(JJ) = IX(JJ) + 1 - IF(MOD(IX(JJ)-LL,LPG).EQ.LPG-1) IX(JJ) = IX(JJ) + 2 - GO TO 20055 -C -C IPLACE POINTS TO THE INSERTED DATA ITEM. -C -20057 IPL=IPLOC(IPLACE,SX,IX) - RETURN - END diff --git a/slatec/pchsp.f b/slatec/pchsp.f deleted file mode 100644 index e192011..0000000 --- a/slatec/pchsp.f +++ /dev/null @@ -1,388 +0,0 @@ -*DECK PCHSP - SUBROUTINE PCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR) -C***BEGIN PROLOGUE PCHSP -C***PURPOSE Set derivatives needed to determine the Hermite represen- -C tation of the cubic spline interpolant to given data, with -C specified boundary conditions. -C***LIBRARY SLATEC (PCHIP) -C***CATEGORY E1A -C***TYPE SINGLE PRECISION (PCHSP-S, DPCHSP-D) -C***KEYWORDS CUBIC HERMITE INTERPOLATION, PCHIP, -C PIECEWISE CUBIC INTERPOLATION, SPLINE INTERPOLATION -C***AUTHOR Fritsch, F. N., (LLNL) -C Lawrence Livermore National Laboratory -C P.O. Box 808 (L-316) -C Livermore, CA 94550 -C FTS 532-4275, (510) 422-4275 -C***DESCRIPTION -C -C PCHSP: Piecewise Cubic Hermite Spline -C -C Computes the Hermite representation of the cubic spline inter- -C polant to the data given in X and F satisfying the boundary -C conditions specified by IC and VC. -C -C To facilitate two-dimensional applications, includes an increment -C between successive values of the F- and D-arrays. -C -C The resulting piecewise cubic Hermite function may be evaluated -C by PCHFE or PCHFD. -C -C NOTE: This is a modified version of C. de Boor's cubic spline -C routine CUBSPL. -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C PARAMETER (INCFD = ...) -C INTEGER IC(2), N, NWK, IERR -C REAL VC(2), X(N), F(INCFD,N), D(INCFD,N), WK(NWK) -C -C CALL PCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR) -C -C Parameters: -C -C IC -- (input) integer array of length 2 specifying desired -C boundary conditions: -C IC(1) = IBEG, desired condition at beginning of data. -C IC(2) = IEND, desired condition at end of data. -C -C IBEG = 0 to set D(1) so that the third derivative is con- -C tinuous at X(2). This is the "not a knot" condition -C provided by de Boor's cubic spline routine CUBSPL. -C < This is the default boundary condition. > -C IBEG = 1 if first derivative at X(1) is given in VC(1). -C IBEG = 2 if second derivative at X(1) is given in VC(1). -C IBEG = 3 to use the 3-point difference formula for D(1). -C (Reverts to the default b.c. if N.LT.3 .) -C IBEG = 4 to use the 4-point difference formula for D(1). -C (Reverts to the default b.c. if N.LT.4 .) -C NOTES: -C 1. An error return is taken if IBEG is out of range. -C 2. For the "natural" boundary condition, use IBEG=2 and -C VC(1)=0. -C -C IEND may take on the same values as IBEG, but applied to -C derivative at X(N). In case IEND = 1 or 2, the value is -C given in VC(2). -C -C NOTES: -C 1. An error return is taken if IEND is out of range. -C 2. For the "natural" boundary condition, use IEND=2 and -C VC(2)=0. -C -C VC -- (input) real array of length 2 specifying desired boundary -C values, as indicated above. -C VC(1) need be set only if IC(1) = 1 or 2 . -C VC(2) need be set only if IC(2) = 1 or 2 . -C -C N -- (input) number of data points. (Error return if N.LT.2 .) -C -C X -- (input) real array of independent variable values. The -C elements of X must be strictly increasing: -C X(I-1) .LT. X(I), I = 2(1)N. -C (Error return if not.) -C -C F -- (input) real array of dependent variable values to be inter- -C polated. F(1+(I-1)*INCFD) is value corresponding to X(I). -C -C D -- (output) real array of derivative values at the data points. -C These values will determine the cubic spline interpolant -C with the requested boundary conditions. -C The value corresponding to X(I) is stored in -C D(1+(I-1)*INCFD), I=1(1)N. -C No other entries in D are changed. -C -C INCFD -- (input) increment between successive values in F and D. -C This argument is provided primarily for 2-D applications. -C (Error return if INCFD.LT.1 .) -C -C WK -- (scratch) real array of working storage. -C -C NWK -- (input) length of work array. -C (Error return if NWK.LT.2*N .) -C -C IERR -- (output) error flag. -C Normal return: -C IERR = 0 (no errors). -C "Recoverable" errors: -C IERR = -1 if N.LT.2 . -C IERR = -2 if INCFD.LT.1 . -C IERR = -3 if the X-array is not strictly increasing. -C IERR = -4 if IBEG.LT.0 or IBEG.GT.4 . -C IERR = -5 if IEND.LT.0 of IEND.GT.4 . -C IERR = -6 if both of the above are true. -C IERR = -7 if NWK is too small. -C NOTE: The above errors are checked in the order listed, -C and following arguments have **NOT** been validated. -C (The D-array has not been changed in any of these cases.) -C IERR = -8 in case of trouble solving the linear system -C for the interior derivative values. -C (The D-array may have been changed in this case.) -C ( Do **NOT** use it! ) -C -C***REFERENCES Carl de Boor, A Practical Guide to Splines, Springer- -C Verlag, New York, 1978, pp. 53-59. -C***ROUTINES CALLED PCHDF, XERMSG -C***REVISION HISTORY (YYMMDD) -C 820503 DATE WRITTEN -C 820804 Converted to SLATEC library version. -C 870707 Minor cosmetic changes to prologue. -C 890411 Added SAVE statements (Vers. 3.2). -C 890703 Corrected category record. (WRB) -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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 920429 Revised format and order of references. (WRB,FNF) -C***END PROLOGUE PCHSP -C Programming notes: -C -C To produce a double precision version, simply: -C a. Change PCHSP to DPCHSP wherever it occurs, -C b. Change the real declarations to double precision, and -C c. Change the constants ZERO, HALF, ... to double precision. -C -C DECLARE ARGUMENTS. -C - INTEGER IC(2), N, INCFD, NWK, IERR - REAL VC(2), X(*), F(INCFD,*), D(INCFD,*), WK(2,*) -C -C DECLARE LOCAL VARIABLES. -C - INTEGER IBEG, IEND, INDEX, J, NM1 - REAL G, HALF, ONE, STEMP(3), THREE, TWO, XTEMP(4), ZERO - SAVE ZERO, HALF, ONE, TWO, THREE - REAL PCHDF -C - DATA ZERO /0./, HALF /0.5/, ONE /1./, TWO /2./, THREE /3./ -C -C VALIDITY-CHECK ARGUMENTS. -C -C***FIRST EXECUTABLE STATEMENT PCHSP - IF ( N.LT.2 ) GO TO 5001 - IF ( INCFD.LT.1 ) GO TO 5002 - DO 1 J = 2, N - IF ( X(J).LE.X(J-1) ) GO TO 5003 - 1 CONTINUE -C - IBEG = IC(1) - IEND = IC(2) - IERR = 0 - IF ( (IBEG.LT.0).OR.(IBEG.GT.4) ) IERR = IERR - 1 - IF ( (IEND.LT.0).OR.(IEND.GT.4) ) IERR = IERR - 2 - IF ( IERR.LT.0 ) GO TO 5004 -C -C FUNCTION DEFINITION IS OK -- GO ON. -C - IF ( NWK .LT. 2*N ) GO TO 5007 -C -C COMPUTE FIRST DIFFERENCES OF X SEQUENCE AND STORE IN WK(1,.). ALSO, -C COMPUTE FIRST DIVIDED DIFFERENCE OF DATA AND STORE IN WK(2,.). - DO 5 J=2,N - WK(1,J) = X(J) - X(J-1) - WK(2,J) = (F(1,J) - F(1,J-1))/WK(1,J) - 5 CONTINUE -C -C SET TO DEFAULT BOUNDARY CONDITIONS IF N IS TOO SMALL. -C - IF ( IBEG.GT.N ) IBEG = 0 - IF ( IEND.GT.N ) IEND = 0 -C -C SET UP FOR BOUNDARY CONDITIONS. -C - IF ( (IBEG.EQ.1).OR.(IBEG.EQ.2) ) THEN - D(1,1) = VC(1) - ELSE IF (IBEG .GT. 2) THEN -C PICK UP FIRST IBEG POINTS, IN REVERSE ORDER. - DO 10 J = 1, IBEG - INDEX = IBEG-J+1 -C INDEX RUNS FROM IBEG DOWN TO 1. - XTEMP(J) = X(INDEX) - IF (J .LT. IBEG) STEMP(J) = WK(2,INDEX) - 10 CONTINUE -C -------------------------------- - D(1,1) = PCHDF (IBEG, XTEMP, STEMP, IERR) -C -------------------------------- - IF (IERR .NE. 0) GO TO 5009 - IBEG = 1 - ENDIF -C - IF ( (IEND.EQ.1).OR.(IEND.EQ.2) ) THEN - D(1,N) = VC(2) - ELSE IF (IEND .GT. 2) THEN -C PICK UP LAST IEND POINTS. - DO 15 J = 1, IEND - INDEX = N-IEND+J -C INDEX RUNS FROM N+1-IEND UP TO N. - XTEMP(J) = X(INDEX) - IF (J .LT. IEND) STEMP(J) = WK(2,INDEX+1) - 15 CONTINUE -C -------------------------------- - D(1,N) = PCHDF (IEND, XTEMP, STEMP, IERR) -C -------------------------------- - IF (IERR .NE. 0) GO TO 5009 - IEND = 1 - ENDIF -C -C --------------------( BEGIN CODING FROM CUBSPL )-------------------- -C -C **** A TRIDIAGONAL LINEAR SYSTEM FOR THE UNKNOWN SLOPES S(J) OF -C F AT X(J), J=1,...,N, IS GENERATED AND THEN SOLVED BY GAUSS ELIM- -C INATION, WITH S(J) ENDING UP IN D(1,J), ALL J. -C WK(1,.) AND WK(2,.) ARE USED FOR TEMPORARY STORAGE. -C -C CONSTRUCT FIRST EQUATION FROM FIRST BOUNDARY CONDITION, OF THE FORM -C WK(2,1)*S(1) + WK(1,1)*S(2) = D(1,1) -C - IF (IBEG .EQ. 0) THEN - IF (N .EQ. 2) THEN -C NO CONDITION AT LEFT END AND N = 2. - WK(2,1) = ONE - WK(1,1) = ONE - D(1,1) = TWO*WK(2,2) - ELSE -C NOT-A-KNOT CONDITION AT LEFT END AND N .GT. 2. - WK(2,1) = WK(1,3) - WK(1,1) = WK(1,2) + WK(1,3) - D(1,1) =((WK(1,2) + TWO*WK(1,1))*WK(2,2)*WK(1,3) - * + WK(1,2)**2*WK(2,3)) / WK(1,1) - ENDIF - ELSE IF (IBEG .EQ. 1) THEN -C SLOPE PRESCRIBED AT LEFT END. - WK(2,1) = ONE - WK(1,1) = ZERO - ELSE -C SECOND DERIVATIVE PRESCRIBED AT LEFT END. - WK(2,1) = TWO - WK(1,1) = ONE - D(1,1) = THREE*WK(2,2) - HALF*WK(1,2)*D(1,1) - ENDIF -C -C IF THERE ARE INTERIOR KNOTS, GENERATE THE CORRESPONDING EQUATIONS AND -C CARRY OUT THE FORWARD PASS OF GAUSS ELIMINATION, AFTER WHICH THE J-TH -C EQUATION READS WK(2,J)*S(J) + WK(1,J)*S(J+1) = D(1,J). -C - NM1 = N-1 - IF (NM1 .GT. 1) THEN - DO 20 J=2,NM1 - IF (WK(2,J-1) .EQ. ZERO) GO TO 5008 - G = -WK(1,J+1)/WK(2,J-1) - D(1,J) = G*D(1,J-1) - * + THREE*(WK(1,J)*WK(2,J+1) + WK(1,J+1)*WK(2,J)) - WK(2,J) = G*WK(1,J-1) + TWO*(WK(1,J) + WK(1,J+1)) - 20 CONTINUE - ENDIF -C -C CONSTRUCT LAST EQUATION FROM SECOND BOUNDARY CONDITION, OF THE FORM -C (-G*WK(2,N-1))*S(N-1) + WK(2,N)*S(N) = D(1,N) -C -C IF SLOPE IS PRESCRIBED AT RIGHT END, ONE CAN GO DIRECTLY TO BACK- -C SUBSTITUTION, SINCE ARRAYS HAPPEN TO BE SET UP JUST RIGHT FOR IT -C AT THIS POINT. - IF (IEND .EQ. 1) GO TO 30 -C - IF (IEND .EQ. 0) THEN - IF (N.EQ.2 .AND. IBEG.EQ.0) THEN -C NOT-A-KNOT AT RIGHT ENDPOINT AND AT LEFT ENDPOINT AND N = 2. - D(1,2) = WK(2,2) - GO TO 30 - ELSE IF ((N.EQ.2) .OR. (N.EQ.3 .AND. IBEG.EQ.0)) THEN -C EITHER (N=3 AND NOT-A-KNOT ALSO AT LEFT) OR (N=2 AND *NOT* -C NOT-A-KNOT AT LEFT END POINT). - D(1,N) = TWO*WK(2,N) - WK(2,N) = ONE - IF (WK(2,N-1) .EQ. ZERO) GO TO 5008 - G = -ONE/WK(2,N-1) - ELSE -C NOT-A-KNOT AND N .GE. 3, AND EITHER N.GT.3 OR ALSO NOT-A- -C KNOT AT LEFT END POINT. - G = WK(1,N-1) + WK(1,N) -C DO NOT NEED TO CHECK FOLLOWING DENOMINATORS (X-DIFFERENCES). - D(1,N) = ((WK(1,N)+TWO*G)*WK(2,N)*WK(1,N-1) - * + WK(1,N)**2*(F(1,N-1)-F(1,N-2))/WK(1,N-1))/G - IF (WK(2,N-1) .EQ. ZERO) GO TO 5008 - G = -G/WK(2,N-1) - WK(2,N) = WK(1,N-1) - ENDIF - ELSE -C SECOND DERIVATIVE PRESCRIBED AT RIGHT ENDPOINT. - D(1,N) = THREE*WK(2,N) + HALF*WK(1,N)*D(1,N) - WK(2,N) = TWO - IF (WK(2,N-1) .EQ. ZERO) GO TO 5008 - G = -ONE/WK(2,N-1) - ENDIF -C -C COMPLETE FORWARD PASS OF GAUSS ELIMINATION. -C - WK(2,N) = G*WK(1,N-1) + WK(2,N) - IF (WK(2,N) .EQ. ZERO) GO TO 5008 - D(1,N) = (G*D(1,N-1) + D(1,N))/WK(2,N) -C -C CARRY OUT BACK SUBSTITUTION -C - 30 CONTINUE - DO 40 J=NM1,1,-1 - IF (WK(2,J) .EQ. ZERO) GO TO 5008 - D(1,J) = (D(1,J) - WK(1,J)*D(1,J+1))/WK(2,J) - 40 CONTINUE -C --------------------( END CODING FROM CUBSPL )-------------------- -C -C NORMAL RETURN. -C - RETURN -C -C ERROR RETURNS. -C - 5001 CONTINUE -C N.LT.2 RETURN. - IERR = -1 - CALL XERMSG ('SLATEC', 'PCHSP', - + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) - RETURN -C - 5002 CONTINUE -C INCFD.LT.1 RETURN. - IERR = -2 - CALL XERMSG ('SLATEC', 'PCHSP', 'INCREMENT LESS THAN ONE', IERR, - + 1) - RETURN -C - 5003 CONTINUE -C X-ARRAY NOT STRICTLY INCREASING. - IERR = -3 - CALL XERMSG ('SLATEC', 'PCHSP', 'X-ARRAY NOT STRICTLY INCREASING' - + , IERR, 1) - RETURN -C - 5004 CONTINUE -C IC OUT OF RANGE RETURN. - IERR = IERR - 3 - CALL XERMSG ('SLATEC', 'PCHSP', 'IC OUT OF RANGE', IERR, 1) - RETURN -C - 5007 CONTINUE -C NWK TOO SMALL RETURN. - IERR = -7 - CALL XERMSG ('SLATEC', 'PCHSP', 'WORK ARRAY TOO SMALL', IERR, 1) - RETURN -C - 5008 CONTINUE -C SINGULAR SYSTEM. -C *** THEORETICALLY, THIS CAN ONLY OCCUR IF SUCCESSIVE X-VALUES *** -C *** ARE EQUAL, WHICH SHOULD ALREADY HAVE BEEN CAUGHT (IERR=-3). *** - IERR = -8 - CALL XERMSG ('SLATEC', 'PCHSP', 'SINGULAR LINEAR SYSTEM', IERR, - + 1) - RETURN -C - 5009 CONTINUE -C ERROR RETURN FROM PCHDF. -C *** THIS CASE SHOULD NEVER OCCUR *** - IERR = -9 - CALL XERMSG ('SLATEC', 'PCHSP', 'ERROR RETURN FROM PCHDF', IERR, - + 1) - RETURN -C------------- LAST LINE OF PCHSP FOLLOWS ------------------------------ - END diff --git a/slatec/pchst.f b/slatec/pchst.f deleted file mode 100644 index e623120..0000000 --- a/slatec/pchst.f +++ /dev/null @@ -1,57 +0,0 @@ -*DECK PCHST - REAL FUNCTION PCHST (ARG1, ARG2) -C***BEGIN PROLOGUE PCHST -C***SUBSIDIARY -C***PURPOSE PCHIP Sign-Testing Routine -C***LIBRARY SLATEC (PCHIP) -C***TYPE SINGLE PRECISION (PCHST-S, DPCHST-D) -C***AUTHOR Fritsch, F. N., (LLNL) -C***DESCRIPTION -C -C PCHST: PCHIP Sign-Testing Routine. -C -C Returns: -C -1. if ARG1 and ARG2 are of opposite sign. -C 0. if either argument is zero. -C +1. if ARG1 and ARG2 are of the same sign. -C -C The object is to do this without multiplying ARG1*ARG2, to avoid -C possible over/underflow problems. -C -C Fortran intrinsics used: SIGN. -C -C***SEE ALSO PCHCE, PCHCI, PCHCS, PCHIM -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 811103 DATE WRITTEN -C 820805 Converted to SLATEC library version. -C 870813 Minor cosmetic changes. -C 890411 Added SAVE statements (Vers. 3.2). -C 890411 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910408 Updated AUTHOR and DATE WRITTEN sections in prologue. (WRB) -C 930503 Improved purpose. (FNF) -C***END PROLOGUE PCHST -C -C**End -C -C DECLARE ARGUMENTS. -C - REAL ARG1, ARG2 -C -C DECLARE LOCAL VARIABLES. -C - REAL ONE, ZERO - SAVE ZERO, ONE - DATA ZERO /0./, ONE /1./ -C -C PERFORM THE TEST. -C -C***FIRST EXECUTABLE STATEMENT PCHST - PCHST = SIGN(ONE,ARG1) * SIGN(ONE,ARG2) - IF ((ARG1.EQ.ZERO) .OR. (ARG2.EQ.ZERO)) PCHST = ZERO -C - RETURN -C------------- LAST LINE OF PCHST FOLLOWS ------------------------------ - END diff --git a/slatec/pchsw.f b/slatec/pchsw.f deleted file mode 100644 index 11d7fb5..0000000 --- a/slatec/pchsw.f +++ /dev/null @@ -1,192 +0,0 @@ -*DECK PCHSW - SUBROUTINE PCHSW (DFMAX, IEXTRM, D1, D2, H, SLOPE, IERR) -C***BEGIN PROLOGUE PCHSW -C***SUBSIDIARY -C***PURPOSE Limits excursion from data for PCHCS -C***LIBRARY SLATEC (PCHIP) -C***TYPE SINGLE PRECISION (PCHSW-S, DPCHSW-D) -C***AUTHOR Fritsch, F. N., (LLNL) -C***DESCRIPTION -C -C PCHSW: PCHCS Switch Excursion Limiter. -C -C Called by PCHCS to adjust D1 and D2 if necessary to insure that -C the extremum on this interval is not further than DFMAX from the -C extreme data value. -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C INTEGER IEXTRM, IERR -C REAL DFMAX, D1, D2, H, SLOPE -C -C CALL PCHSW (DFMAX, IEXTRM, D1, D2, H, SLOPE, IERR) -C -C Parameters: -C -C DFMAX -- (input) maximum allowed difference between F(IEXTRM) and -C the cubic determined by derivative values D1,D2. (assumes -C DFMAX.GT.0.) -C -C IEXTRM -- (input) index of the extreme data value. (assumes -C IEXTRM = 1 or 2 . Any value .NE.1 is treated as 2.) -C -C D1,D2 -- (input) derivative values at the ends of the interval. -C (Assumes D1*D2 .LE. 0.) -C (output) may be modified if necessary to meet the restriction -C imposed by DFMAX. -C -C H -- (input) interval length. (Assumes H.GT.0.) -C -C SLOPE -- (input) data slope on the interval. -C -C IERR -- (output) error flag. should be zero. -C If IERR=-1, assumption on D1 and D2 is not satisfied. -C If IERR=-2, quadratic equation locating extremum has -C negative discriminant (should never occur). -C -C ------- -C WARNING: This routine does no validity-checking of arguments. -C ------- -C -C Fortran intrinsics used: ABS, SIGN, SQRT. -C -C***SEE ALSO PCHCS -C***ROUTINES CALLED R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 820218 DATE WRITTEN -C 820805 Converted to SLATEC library version. -C 870707 Replaced DATA statement for SMALL with a use of R1MACH. -C 890411 1. Added SAVE statements (Vers. 3.2). -C 2. Added REAL R1MACH for consistency with D.P. version. -C 890411 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 900328 Added TYPE section. (WRB) -C 910408 Updated AUTHOR and DATE WRITTEN sections in prologue. (WRB) -C 920526 Eliminated possible divide by zero problem. (FNF) -C 930503 Improved purpose. (FNF) -C***END PROLOGUE PCHSW -C -C**End -C -C DECLARE ARGUMENTS. -C - INTEGER IEXTRM, IERR - REAL DFMAX, D1, D2, H, SLOPE -C -C DECLARE LOCAL VARIABLES. -C - REAL CP, FACT, HPHI, LAMBDA, NU, ONE, PHI, RADCAL, RHO, SIGMA, - * SMALL, THAT, THIRD, THREE, TWO, ZERO - SAVE ZERO, ONE, TWO, THREE, FACT - SAVE THIRD - REAL R1MACH -C - DATA ZERO /0./, ONE /1./, TWO /2./, THREE /3./, FACT /100./ -C THIRD SHOULD BE SLIGHTLY LESS THAN 1/3. - DATA THIRD /0.33333/ -C -C NOTATION AND GENERAL REMARKS. -C -C RHO IS THE RATIO OF THE DATA SLOPE TO THE DERIVATIVE BEING TESTED. -C LAMBDA IS THE RATIO OF D2 TO D1. -C THAT = T-HAT(RHO) IS THE NORMALIZED LOCATION OF THE EXTREMUM. -C PHI IS THE NORMALIZED VALUE OF P(X)-F1 AT X = XHAT = X-HAT(RHO), -C WHERE THAT = (XHAT - X1)/H . -C THAT IS, P(XHAT)-F1 = D*H*PHI, WHERE D=D1 OR D2. -C SIMILARLY, P(XHAT)-F2 = D*H*(PHI-RHO) . -C -C SMALL SHOULD BE A FEW ORDERS OF MAGNITUDE GREATER THAN MACHEPS. -C***FIRST EXECUTABLE STATEMENT PCHSW - SMALL = FACT*R1MACH(4) -C -C DO MAIN CALCULATION. -C - IF (D1 .EQ. ZERO) THEN -C -C SPECIAL CASE -- D1.EQ.ZERO . -C -C IF D2 IS ALSO ZERO, THIS ROUTINE SHOULD NOT HAVE BEEN CALLED. - IF (D2 .EQ. ZERO) GO TO 5001 -C - RHO = SLOPE/D2 -C EXTREMUM IS OUTSIDE INTERVAL WHEN RHO .GE. 1/3 . - IF (RHO .GE. THIRD) GO TO 5000 - THAT = (TWO*(THREE*RHO-ONE)) / (THREE*(TWO*RHO-ONE)) - PHI = THAT**2 * ((THREE*RHO-ONE)/THREE) -C -C CONVERT TO DISTANCE FROM F2 IF IEXTRM.NE.1 . - IF (IEXTRM .NE. 1) PHI = PHI - RHO -C -C TEST FOR EXCEEDING LIMIT, AND ADJUST ACCORDINGLY. - HPHI = H * ABS(PHI) - IF (HPHI*ABS(D2) .GT. DFMAX) THEN -C AT THIS POINT, HPHI.GT.0, SO DIVIDE IS OK. - D2 = SIGN (DFMAX/HPHI, D2) - ENDIF - ELSE -C - RHO = SLOPE/D1 - LAMBDA = -D2/D1 - IF (D2 .EQ. ZERO) THEN -C -C SPECIAL CASE -- D2.EQ.ZERO . -C -C EXTREMUM IS OUTSIDE INTERVAL WHEN RHO .GE. 1/3 . - IF (RHO .GE. THIRD) GO TO 5000 - CP = TWO - THREE*RHO - NU = ONE - TWO*RHO - THAT = ONE / (THREE*NU) - ELSE - IF (LAMBDA .LE. ZERO) GO TO 5001 -C -C NORMAL CASE -- D1 AND D2 BOTH NONZERO, OPPOSITE SIGNS. -C - NU = ONE - LAMBDA - TWO*RHO - SIGMA = ONE - RHO - CP = NU + SIGMA - IF (ABS(NU) .GT. SMALL) THEN - RADCAL = (NU - (TWO*RHO+ONE))*NU + SIGMA**2 - IF (RADCAL .LT. ZERO) GO TO 5002 - THAT = (CP - SQRT(RADCAL)) / (THREE*NU) - ELSE - THAT = ONE/(TWO*SIGMA) - ENDIF - ENDIF - PHI = THAT*((NU*THAT - CP)*THAT + ONE) -C -C CONVERT TO DISTANCE FROM F2 IF IEXTRM.NE.1 . - IF (IEXTRM .NE. 1) PHI = PHI - RHO -C -C TEST FOR EXCEEDING LIMIT, AND ADJUST ACCORDINGLY. - HPHI = H * ABS(PHI) - IF (HPHI*ABS(D1) .GT. DFMAX) THEN -C AT THIS POINT, HPHI.GT.0, SO DIVIDE IS OK. - D1 = SIGN (DFMAX/HPHI, D1) - D2 = -LAMBDA*D1 - ENDIF - ENDIF -C -C NORMAL RETURN. -C - 5000 CONTINUE - IERR = 0 - RETURN -C -C ERROR RETURNS. -C - 5001 CONTINUE -C D1 AND D2 BOTH ZERO, OR BOTH NONZERO AND SAME SIGN. - IERR = -1 - CALL XERMSG ('SLATEC', 'PCHSW', 'D1 AND/OR D2 INVALID', IERR, 1) - RETURN -C - 5002 CONTINUE -C NEGATIVE VALUE OF RADICAL (SHOULD NEVER OCCUR). - IERR = -2 - CALL XERMSG ('SLATEC', 'PCHSW', 'NEGATIVE RADICAL', IERR, 1) - RETURN -C------------- LAST LINE OF PCHSW FOLLOWS ------------------------------ - END diff --git a/slatec/pcoef.f b/slatec/pcoef.f deleted file mode 100644 index 5f6e63d..0000000 --- a/slatec/pcoef.f +++ /dev/null @@ -1,78 +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 diff --git a/slatec/pfqad.f b/slatec/pfqad.f deleted file mode 100644 index 9d733da..0000000 --- a/slatec/pfqad.f +++ /dev/null @@ -1,129 +0,0 @@ -*DECK PFQAD - SUBROUTINE PFQAD (F, LDC, C, XI, LXI, K, ID, X1, X2, TOL, QUAD, - + IERR) -C***BEGIN PROLOGUE PFQAD -C***PURPOSE Compute the integral on (X1,X2) of a product of a function -C F and the ID-th derivative of a B-spline, -C (PP-representation). -C***LIBRARY SLATEC -C***CATEGORY H2A2A1, E3, K6 -C***TYPE SINGLE PRECISION (PFQAD-S, DPFQAD-D) -C***KEYWORDS B-SPLINE, DATA FITTING, INTERPOLATION, QUADRATURE, SPLINES -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C PFQAD computes the integral on (X1,X2) of a product of a -C function F and the ID-th derivative of a B-spline, using the -C PP-representation (C,XI,LXI,K). (X1,X2) is normally a sub- -C interval of XI(1) .LE. X .LE. XI(LXI+1). An integration rou- -C tine, PPGQ8(a modification of GAUS8), integrates the product -C on sub-intervals of (X1,X2) formed by the included break -C points. Integration outside of (XI(1),XI(LXI+1)) is permitted -C provided F is defined. -C -C Description of Arguments -C Input -C F - external function of one argument for the -C integrand PF(X)=F(X)*PPVAL(LDC,C,XI,LXI,K,ID,X, -C INPPV) -C LDC - leading dimension of matrix C, LDC .GE. K -C C(I,J) - right Taylor derivatives at XI(J), I=1,K , J=1,LXI -C XI(*) - break point array of length LXI+1 -C LXI - number of polynomial pieces -C K - order of B-spline, K .GE. 1 -C ID - order of the spline derivative, 0 .LE. ID .LE. K-1 -C ID=0 gives the spline function -C X1,X2 - end points of quadrature interval, normally in -C XI(1) .LE. X .LE. XI(LXI+1) -C TOL - desired accuracy for the quadrature, suggest -C 10.*STOL .LT. TOL .LE. 0.1 where STOL is the single -C precision unit roundoff for the machine = R1MACH(4) -C -C Output -C QUAD - integral of PF(X) on (X1,X2) -C IERR - a status code -C IERR=1 normal return -C 2 some quadrature does not meet the -C requested tolerance -C -C Error Conditions -C TOL not greater than the single precision unit roundoff or -C less than 0.1 is a fatal error. -C Some quadrature does not meet the requested tolerance. -C -C***REFERENCES D. E. Amos, Quadrature subroutines for splines and -C B-splines, Report SAND79-1825, Sandia Laboratories, -C December 1979. -C***ROUTINES CALLED INTRV, PPGQ8, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800901 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE PFQAD -C - INTEGER ID,IERR,IFLG,ILO,IL1,IL2,INPPV,K,LDC,LEFT,LXI,MF1,MF2 - REAL A, AA, ANS, B, BB, C, Q, QUAD, TA, TB, TOL, WTOL, XI, X1, X2 - REAL R1MACH, F - DIMENSION XI(*), C(LDC,*) - EXTERNAL F -C -C***FIRST EXECUTABLE STATEMENT PFQAD - IERR = 1 - QUAD = 0.0E0 - IF(K.LT.1) GO TO 100 - IF(LDC.LT.K) GO TO 105 - IF(ID.LT.0 .OR. ID.GE.K) GO TO 110 - IF(LXI.LT.1) GO TO 115 - WTOL = R1MACH(4) - IF (TOL.LT.WTOL .OR. TOL.GT.0.1E0) GO TO 20 - AA = MIN(X1,X2) - BB = MAX(X1,X2) - IF (AA.EQ.BB) RETURN - ILO = 1 - CALL INTRV(XI, LXI, AA, ILO, IL1, MF1) - CALL INTRV(XI, LXI, BB, ILO, IL2, MF2) - Q = 0.0E0 - INPPV = 1 - DO 10 LEFT=IL1,IL2 - TA = XI(LEFT) - A = MAX(AA,TA) - IF (LEFT.EQ.1) A = AA - TB = BB - IF (LEFT.LT.LXI) TB = XI(LEFT+1) - B = MIN(BB,TB) - CALL PPGQ8(F,LDC,C,XI,LXI,K,ID,A,B,INPPV,TOL,ANS,IFLG) - IF (IFLG.GT.1) IERR = 2 - Q = Q + ANS - 10 CONTINUE - IF (X1.GT.X2) Q = -Q - QUAD = Q - RETURN -C - 20 CONTINUE - CALL XERMSG ('SLATEC', 'PFQAD', - + 'TOL IS LESS THAN THE SINGLE PRECISION TOLERANCE OR ' // - + 'GREATER THAN 0.1', 2, 1) - RETURN - 100 CONTINUE - CALL XERMSG ('SLATEC', 'PFQAD', 'K DOES NOT SATISFY K.GE.1', 2, - + 1) - RETURN - 105 CONTINUE - CALL XERMSG ('SLATEC', 'PFQAD', 'LDC DOES NOT SATISFY LDC.GE.K', - + 2, 1) - RETURN - 110 CONTINUE - CALL XERMSG ('SLATEC', 'PFQAD', - + 'ID DOES NOT SATISFY 0.LE.ID.LT.K', 2, 1) - RETURN - 115 CONTINUE - CALL XERMSG ('SLATEC', 'PFQAD', 'LXI DOES NOT SATISFY LXI.GE.1', - + 2, 1) - RETURN - END diff --git a/slatec/pgsf.f b/slatec/pgsf.f deleted file mode 100644 index 85402ee..0000000 --- a/slatec/pgsf.f +++ /dev/null @@ -1,30 +0,0 @@ -*DECK PGSF - FUNCTION PGSF (X, IZ, C, A, BH) -C***BEGIN PROLOGUE PGSF -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBLKTR -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (PGSF-S) -C***AUTHOR (UNKNOWN) -C***SEE ALSO CBLKTR -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE PGSF - DIMENSION A(*) ,C(*) ,BH(*) -C***FIRST EXECUTABLE STATEMENT PGSF - FSG = 1. - HSG = 1. - DO 101 J=1,IZ - DD = 1./(X-BH(J)) - FSG = FSG*A(J)*DD - HSG = HSG*C(J)*DD - 101 CONTINUE - IF (MOD(IZ,2)) 103,102,103 - 102 PGSF = 1.-FSG-HSG - RETURN - 103 PGSF = 1.+FSG+HSG - RETURN - END diff --git a/slatec/pimach.f b/slatec/pimach.f deleted file mode 100644 index 2a04206..0000000 --- a/slatec/pimach.f +++ /dev/null @@ -1,27 +0,0 @@ -*DECK PIMACH - FUNCTION PIMACH (DUM) -C***BEGIN PROLOGUE PIMACH -C***SUBSIDIARY -C***PURPOSE Subsidiary to HSTCSP, HSTSSP and HWSCSP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (PIMACH-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This subprogram supplies the value of the constant PI correct to -C machine precision where -C -C PI=3.1415926535897932384626433832795028841971693993751058209749446 -C -C***SEE ALSO HSTCSP, HSTSSP, HWSCSP -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE PIMACH -C -C***FIRST EXECUTABLE STATEMENT PIMACH - PIMACH = 3.14159265358979 - RETURN - END diff --git a/slatec/pinitm.f b/slatec/pinitm.f deleted file mode 100644 index 32985c1..0000000 --- a/slatec/pinitm.f +++ /dev/null @@ -1,105 +0,0 @@ -*DECK PINITM - SUBROUTINE PINITM (M, N, SX, IX, LMX, IPAGEF) -C***BEGIN PROLOGUE PINITM -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (PINITM-S, DPINTM-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C -C PINITM LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SCHEME. -C THE MATRIX IS STORED BY COLUMNS. -C SPARSE MATRIX INITIALIZATION SUBROUTINE. -C -C M=NUMBER OF ROWS OF THE MATRIX. -C N=NUMBER OF COLUMNS OF THE MATRIX. -C SX(*),IX(*)=THE WORK ARRAYS WHICH ARE USED TO STORE THE SPARSE -C MATRIX. THESE ARRAYS ARE AUTOMATICALLY MAINTAINED BY -C THE PACKAGE FOR THE USER. -C LMX=LENGTH OF THE WORK ARRAY SX(*). -C LMX MUST BE AT LEAST N+7 WHERE -C FOR GREATEST EFFICIENCY LMX SHOULD BE AT LEAST N+NZ+6 -C WHERE NZ IS THE MAXIMUM NUMBER OF NONZEROES TO BE -C STORED IN THE MATRIX. VALUES OF LMX BETWEEN N+7 AND -C N+NZ+6 WILL CAUSE DEMAND PAGING TO OCCUR. -C THIS IS IMPLEMENTED BY THE PACKAGE. -C IX(*) MUST BE DIMENSIONED AT LEAST LMX -C IPAGEF=UNIT NUMBER WHERE DEMAND PAGES WILL BE STORED. -C -C THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LINITM, -C SANDIA LABS. REPT. SAND78-0785. -C MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON -C REVISED 811130-1000 -C REVISED YYMMDD-HHMM -C -C***SEE ALSO SPLP -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 910403 Updated AUTHOR and DESCRIPTION sections. (WRB) -C***END PROLOGUE PINITM - REAL SX(LMX),ZERO,ONE - DIMENSION IX(*) - SAVE ZERO, ONE - DATA ZERO,ONE /0.E0,1.E0/ -C***FIRST EXECUTABLE STATEMENT PINITM - IOPT=1 -C -C CHECK FOR INPUT ERRORS. -C - IF (.NOT.(M.LE.0 .OR. N.LE.0)) GO TO 20002 - NERR=55 - CALL XERMSG ('SLATEC', 'PINITM', - + 'MATRIX DIMENSION M OR N .LE. 0.', NERR, IOPT) -C -C VERIFY IF VALUE OF LMX IS LARGE ENOUGH. -C -20002 IF (.NOT.(LMX.LT.N+7)) GO TO 20005 - NERR=55 - CALL XERMSG ('SLATEC', 'PINITM', - + 'THE VALUE OF LMX IS TOO SMALL.', NERR, IOPT) -C -C INITIALIZE DATA STRUCTURE INDEPENDENT VALUES. -C -20005 SX(1)=ZERO - SX(2)=ZERO - SX(3)=IPAGEF - IX(1)=LMX - IX(2)=M - IX(3)=N - IX(4)=0 - SX(LMX-1)=ZERO - SX(LMX)=-ONE - IX(LMX-1)=-1 - LP4=N+4 -C -C INITIALIZE DATA STRUCTURE DEPENDENT VALUES. -C - I=4 - N20008=LP4 - GO TO 20009 -20008 I=I+1 -20009 IF ((N20008-I).LT.0) GO TO 20010 - SX(I)=ZERO - GO TO 20008 -20010 I=5 - N20012=LP4 - GO TO 20013 -20012 I=I+1 -20013 IF ((N20012-I).LT.0) GO TO 20014 - IX(I)=LP4 - GO TO 20012 -20014 SX(N+5)=ZERO - IX(N+5)=0 - IX(LMX)=0 -C -C INITIALIZATION COMPLETE. -C - RETURN - END diff --git a/slatec/pjac.f b/slatec/pjac.f deleted file mode 100644 index b2c7c47..0000000 --- a/slatec/pjac.f +++ /dev/null @@ -1,184 +0,0 @@ -*DECK PJAC - SUBROUTINE PJAC (NEQ, Y, YH, NYH, EWT, FTEM, SAVF, WM, IWM, F, - + JAC, RPAR, IPAR) -C***BEGIN PROLOGUE PJAC -C***SUBSIDIARY -C***PURPOSE Subsidiary to DEBDF -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (PJAC-S, DPJAC-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C PJAC sets up the iteration matrix (involving the Jacobian) for the -C integration package DEBDF. -C -C***SEE ALSO DEBDF -C***ROUTINES CALLED SGBFA, SGEFA, VNWRMS -C***COMMON BLOCKS DEBDF1 -C***REVISION HISTORY (YYMMDD) -C 800901 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C 920422 Changed DIMENSION statement. (WRB) -C***END PROLOGUE PJAC -C -CLLL. OPTIMIZE - INTEGER NEQ, NYH, IWM, I, I1, I2, IER, II, IOWND, IOWNS, J, J1, - 1 JJ, JSTART, KFLAG, L, LENP, MAXORD, MBA, MBAND, MEB1, MEBAND, - 2 METH, MITER, ML, ML3, MU, N, NFE, NJE, NQ, NQU, NST - EXTERNAL F, JAC - REAL Y, YH, EWT, FTEM, SAVF, WM, - 1 ROWND, ROWNS, EL0, H, HMIN, HMXI, HU, TN, UROUND, - 2 CON, DI, FAC, HL0, R, R0, SRUR, YI, YJ, YJJ, VNWRMS - DIMENSION Y(*), YH(NYH,*), EWT(*), FTEM(*), SAVF(*), - 1 WM(*), IWM(*), RPAR(*), IPAR(*) - COMMON /DEBDF1/ ROWND, ROWNS(210), - 1 EL0, H, HMIN, HMXI, HU, TN, UROUND, IOWND(14), IOWNS(6), - 2 IER, JSTART, KFLAG, L, METH, MITER, MAXORD, N, NQ, NST, NFE, - 3 NJE, NQU -C----------------------------------------------------------------------- -C PJAC IS CALLED BY STOD TO COMPUTE AND PROCESS THE MATRIX -C P = I - H*EL(1)*J , WHERE J IS AN APPROXIMATION TO THE JACOBIAN. -C HERE J IS COMPUTED BY THE USER-SUPPLIED ROUTINE JAC IF -C MITER = 1 OR 4, OR BY FINITE DIFFERENCING IF MITER = 2, 3, OR 5. -C IF MITER = 3, A DIAGONAL APPROXIMATION TO J IS USED. -C J IS STORED IN WM AND REPLACED BY P. IF MITER .NE. 3, P IS THEN -C SUBJECTED TO LU DECOMPOSITION IN PREPARATION FOR LATER SOLUTION -C OF LINEAR SYSTEMS WITH P AS COEFFICIENT MATRIX. THIS IS DONE -C BY SGEFA IF MITER = 1 OR 2, AND BY SGBFA IF MITER = 4 OR 5. -C -C IN ADDITION TO VARIABLES DESCRIBED PREVIOUSLY, COMMUNICATION -C WITH PJAC USES THE FOLLOWING.. -C Y = ARRAY CONTAINING PREDICTED VALUES ON ENTRY. -C FTEM = WORK ARRAY OF LENGTH N (ACOR IN STOD ). -C SAVF = ARRAY CONTAINING F EVALUATED AT PREDICTED Y. -C WM = REAL WORK SPACE FOR MATRICES. ON OUTPUT IT CONTAINS THE -C INVERSE DIAGONAL MATRIX IF MITER = 3 AND THE LU DECOMPOSITION -C OF P IF MITER IS 1, 2 , 4, OR 5. -C STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). -C WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA.. -C WM(1) = SQRT(UROUND), USED IN NUMERICAL JACOBIAN INCREMENTS. -C WM(2) = H*EL0, SAVED FOR LATER USE IF MITER = 3. -C IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING AT -C IWM(21), IF MITER IS 1, 2, 4, OR 5. IWM ALSO CONTAINS THE -C BAND PARAMETERS ML = IWM(1) AND MU = IWM(2) IF MITER IS 4 OR 5. -C EL0 = EL(1) (INPUT). -C IER = OUTPUT ERROR FLAG, = 0 IF NO TROUBLE, .NE. 0 IF -C P MATRIX FOUND TO BE SINGULAR. -C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, TN, UROUND, -C MITER, N, NFE, AND NJE. -C----------------------------------------------------------------------- -C***FIRST EXECUTABLE STATEMENT PJAC - NJE = NJE + 1 - HL0 = H*EL0 - GO TO (100, 200, 300, 400, 500), MITER -C IF MITER = 1, CALL JAC AND MULTIPLY BY SCALAR. ----------------------- - 100 LENP = N*N - DO 110 I = 1,LENP - 110 WM(I+2) = 0.0E0 - CALL JAC (TN, Y, WM(3), N, RPAR, IPAR) - CON = -HL0 - DO 120 I = 1,LENP - 120 WM(I+2) = WM(I+2)*CON - GO TO 240 -C IF MITER = 2, MAKE N CALLS TO F TO APPROXIMATE J. -------------------- - 200 FAC = VNWRMS (N, SAVF, EWT) - R0 = 1000.0E0*ABS(H)*UROUND*N*FAC - IF (R0 .EQ. 0.0E0) R0 = 1.0E0 - SRUR = WM(1) - J1 = 2 - DO 230 J = 1,N - YJ = Y(J) - R = MAX(SRUR*ABS(YJ),R0*EWT(J)) - Y(J) = Y(J) + R - FAC = -HL0/R - CALL F (TN, Y, FTEM, RPAR, IPAR) - DO 220 I = 1,N - 220 WM(I+J1) = (FTEM(I) - SAVF(I))*FAC - Y(J) = YJ - J1 = J1 + N - 230 CONTINUE - NFE = NFE + N -C ADD IDENTITY MATRIX. ------------------------------------------------- - 240 J = 3 - DO 250 I = 1,N - WM(J) = WM(J) + 1.0E0 - 250 J = J + (N + 1) -C DO LU DECOMPOSITION ON P. -------------------------------------------- - CALL SGEFA (WM(3), N, N, IWM(21), IER) - RETURN -C IF MITER = 3, CONSTRUCT A DIAGONAL APPROXIMATION TO J AND P. --------- - 300 WM(2) = HL0 - IER = 0 - R = EL0*0.1E0 - DO 310 I = 1,N - 310 Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) - CALL F (TN, Y, WM(3), RPAR, IPAR) - NFE = NFE + 1 - DO 320 I = 1,N - R0 = H*SAVF(I) - YH(I,2) - DI = 0.1E0*R0 - H*(WM(I+2) - SAVF(I)) - WM(I+2) = 1.0E0 - IF (ABS(R0) .LT. UROUND*EWT(I)) GO TO 320 - IF (ABS(DI) .EQ. 0.0E0) GO TO 330 - WM(I+2) = 0.1E0*R0/DI - 320 CONTINUE - RETURN - 330 IER = -1 - RETURN -C IF MITER = 4, CALL JAC AND MULTIPLY BY SCALAR. ----------------------- - 400 ML = IWM(1) - MU = IWM(2) - ML3 = 3 - MBAND = ML + MU + 1 - MEBAND = MBAND + ML - LENP = MEBAND*N - DO 410 I = 1,LENP - 410 WM(I+2) = 0.0E0 - CALL JAC (TN, Y, WM(ML3), MEBAND, RPAR, IPAR) - CON = -HL0 - DO 420 I = 1,LENP - 420 WM(I+2) = WM(I+2)*CON - GO TO 570 -C IF MITER = 5, MAKE MBAND CALLS TO F TO APPROXIMATE J. ---------------- - 500 ML = IWM(1) - MU = IWM(2) - MBAND = ML + MU + 1 - MBA = MIN(MBAND,N) - MEBAND = MBAND + ML - MEB1 = MEBAND - 1 - SRUR = WM(1) - FAC = VNWRMS (N, SAVF, EWT) - R0 = 1000.0E0*ABS(H)*UROUND*N*FAC - IF (R0 .EQ. 0.0E0) R0 = 1.0E0 - DO 560 J = 1,MBA - DO 530 I = J,N,MBAND - YI = Y(I) - R = MAX(SRUR*ABS(YI),R0*EWT(I)) - 530 Y(I) = Y(I) + R - CALL F (TN, Y, FTEM, RPAR, IPAR) - DO 550 JJ = J,N,MBAND - Y(JJ) = YH(JJ,1) - YJJ = Y(JJ) - R = MAX(SRUR*ABS(YJJ),R0*EWT(JJ)) - FAC = -HL0/R - I1 = MAX(JJ-MU,1) - I2 = MIN(JJ+ML,N) - II = JJ*MEB1 - ML + 2 - DO 540 I = I1,I2 - 540 WM(II+I) = (FTEM(I) - SAVF(I))*FAC - 550 CONTINUE - 560 CONTINUE - NFE = NFE + MBA -C ADD IDENTITY MATRIX. ------------------------------------------------- - 570 II = MBAND + 2 - DO 580 I = 1,N - WM(II) = WM(II) + 1.0E0 - 580 II = II + MEBAND -C DO LU DECOMPOSITION OF P. -------------------------------------------- - CALL SGBFA (WM(3), MEBAND, N, ML, MU, IWM(21), IER) - RETURN -C----------------------- END OF SUBROUTINE PJAC ----------------------- - END diff --git a/slatec/pnnzrs.f b/slatec/pnnzrs.f deleted file mode 100644 index b78948b..0000000 --- a/slatec/pnnzrs.f +++ /dev/null @@ -1,259 +0,0 @@ -*DECK PNNZRS - SUBROUTINE PNNZRS (I, XVAL, IPLACE, SX, IX, IRCX) -C***BEGIN PROLOGUE PNNZRS -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (PNNZRS-S, DPNNZR-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C -C PNNZRS LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SCHEME. -C SPARSE MATRIX NON ZERO RETRIEVAL SUBROUTINE. -C -C SUBROUTINE PNNZRS() GETS THE NEXT NONZERO VALUE IN ROW OR COLUMN -C +/- IRCX WITH AN INDEX GREATER THAN THE VALUE OF I. -C -C I ABSOLUTE VALUE OF THIS SUBSCRIPT IS TO BE EXCEEDED -C IN THE SEARCH FOR THE NEXT NONZERO VALUE. A NEGATIVE -C OR ZERO VALUE OF I CAUSES THE SEARCH TO START AT -C THE BEGINNING OF THE VECTOR. A POSITIVE VALUE -C OF I CAUSES THE SEARCH TO CONTINUE FROM THE LAST PLACE -C ACCESSED. ON OUTPUT, THE ARGUMENT I -C CONTAINS THE VALUE OF THE SUBSCRIPT FOUND. AN OUTPUT -C VALUE OF I EQUAL TO ZERO INDICATES THAT ALL COMPONENTS -C WITH AN INDEX GREATER THAN THE INPUT VALUE OF I ARE -C ZERO. -C XVAL VALUE OF THE NONZERO ELEMENT FOUND. ON OUTPUT, -C XVAL=0. WHENEVER I=0. -C IPLACE POINTER INFORMATION WHICH IS MAINTAINED BY THE PACKAGE. -C SX(*),IX(*) THE WORK ARRAYS WHICH ARE USED TO STORE THE SPARSE -C MATRIX. THESE ARRAY CONTENTS ARE AUTOMATICALLY -C MAINTAINED BY THE PACKAGE FOR THE USER. -C IRCX POINTS TO THE VECTOR OF THE MATRIX BEING SCANNED. A -C NEGATIVE VALUE OF IRCX INDICATES THAT ROW -IRCX IS TO BE -C SCANNED. A POSITIVE VALUE OF IRCX INDICATES THAT -C COLUMN IRCX IS TO BE SCANNED. A ZERO VALUE OF IRCX IS -C AN ERROR. -C -C THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LNNZRS, -C SANDIA LABS. REPT. SAND78-0785. -C MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON -C REVISED 811130-1000 -C REVISED YYMMDD-HHMM -C -C***SEE ALSO SPLP -C***ROUTINES CALLED IPLOC, XERMSG -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890605 Removed unreferenced labels. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 910403 Updated AUTHOR and DESCRIPTION sections. (WRB) -C***END PROLOGUE PNNZRS - DIMENSION IX(*) - REAL XVAL,SX(*),ZERO - SAVE ZERO - DATA ZERO /0.E0/ -C***FIRST EXECUTABLE STATEMENT PNNZRS - IOPT=1 -C -C CHECK VALIDITY OF ROW/COL. INDEX. -C - IF (.NOT.(IRCX .EQ.0)) GO TO 20002 - NERR=55 - CALL XERMSG ('SLATEC', 'PNNZRS', 'IRCX=0.', NERR, IOPT) -C -C LMX IS THE LENGTH OF THE IN-MEMORY STORAGE AREA. -C -20002 LMX = IX(1) - IF (.NOT.(IRCX.LT.0)) GO TO 20005 -C -C CHECK SUBSCRIPTS OF THE ROW. THE ROW NUMBER MUST BE .LE. M AND -C THE INDEX MUST BE .LE. N. -C - IF (.NOT.(IX(2).LT.-IRCX .OR. IX(3).LT.ABS(I))) GO TO 20008 - NERR=55 - CALL XERMSG ('SLATEC', 'PNNZRS', - + 'SUBSCRIPTS FOR ARRAY ELEMENT TO BE ACCESSED WERE OUT OF ' // - + 'BOUNDS.', NERR, IOPT) -20008 L=IX(3) - GO TO 20006 -C -C CHECK SUBSCRIPTS OF THE COLUMN. THE COL. NUMBER MUST BE .LE. N AND -C THE INDEX MUST BE .LE. M. -C -20005 IF (.NOT.(IRCX.GT.IX(3) .OR. ABS(I).GT.IX(2))) GO TO 20011 - NERR=55 - CALL XERMSG ('SLATEC', 'PNNZRS', - + 'SUBSCRIPTS FOR ARRAY ELEMENT TO BE ACCESSED WERE OUT OF ' // - + 'BOUNDS.', NERR, IOPT) -20011 L=IX(2) -C -C HERE L IS THE LARGEST POSSIBLE SUBSCRIPT WITHIN THE VECTOR. -C -20006 J=ABS(IRCX) - LL=IX(3)+4 - LPG = LMX - LL - IF (.NOT.(IRCX.GT.0)) GO TO 20014 -C -C SEARCHING FOR THE NEXT NONZERO IN A COLUMN. -C -C INITIALIZE STARTING LOCATIONS.. - IF (.NOT.(I.LE.0)) GO TO 20017 - IF (.NOT.(J.EQ.1)) GO TO 20020 - IPLACE=LL+1 - GO TO 20021 -20020 IPLACE=IX(J+3)+1 -20021 CONTINUE -C -C THE CASE I.LE.0 SIGNALS THAT THE SCAN FOR THE ENTRY -C IS TO BEGIN AT THE START OF THE VECTOR. -C -20017 I = ABS(I) - IF (.NOT.(J.EQ.1)) GO TO 20023 - ISTART = LL+1 - GO TO 20024 -20023 ISTART=IX(J+3)+1 -20024 IEND = IX(J+4) -C -C VALIDATE IPLACE. SET TO START OF VECTOR IF OUT OF RANGE. -C - IF (.NOT.(ISTART.GT.IPLACE .OR. IPLACE.GT.IEND)) GO TO 20026 - IF (.NOT.(J.EQ.1)) GO TO 20029 - IPLACE=LL+1 - GO TO 20030 -20029 IPLACE=IX(J+3)+1 -20030 CONTINUE -C -C SCAN THROUGH SEVERAL PAGES, IF NECESSARY, TO FIND MATRIX ENTRY. -C -20026 IPL = IPLOC(IPLACE,SX,IX) -C -C FIX UP IPLACE AND IPL IF THEY POINT TO PAGING DATA. -C THIS IS NECESSARY BECAUSE THERE IS CONTROL INFORMATION AT THE -C END OF EACH PAGE. -C - IDIFF = LMX - IPL - IF (.NOT.(IDIFF.LE.1.AND.IX(LMX-1).GT.0)) GO TO 20032 -C -C UPDATE THE RELATIVE ADDRESS IN A NEW PAGE. -C - IPLACE = IPLACE + IDIFF + 1 - IPL = IPLOC(IPLACE,SX,IX) -20032 NP = ABS(IX(LMX-1)) - GO TO 20036 -20035 IF (ILAST.EQ.IEND) GO TO 20037 -20036 ILAST = MIN(IEND,NP*LPG+LL-2) -C -C THE VIRTUAL END OF THE DATA FOR THIS PAGE IS ILAST. -C - IL = IPLOC(ILAST,SX,IX) - IL = MIN(IL,LMX-2) -C -C THE RELATIVE END OF DATA FOR THIS PAGE IS IL. -C SEARCH FOR A NONZERO VALUE WITH AN INDEX .GT. I ON THE PRESENT -C PAGE. -C -20038 IF (.NOT.(.NOT.(IPL.GE.IL.OR.(IX(IPL).GT.I.AND.SX(IPL).NE.ZERO)))) - * GO TO 20039 - IPL=IPL+1 - GO TO 20038 -C -C TEST IF WE HAVE FOUND THE NEXT NONZERO. -C -20039 IF (.NOT.(IX(IPL).GT.I .AND. SX(IPL).NE.ZERO .AND. IPL.LE.IL)) GO - *TO 20040 - I = IX(IPL) - XVAL = SX(IPL) - IPLACE = (NP-1)*LPG + IPL - RETURN -C -C UPDATE TO SCAN THE NEXT PAGE. -20040 IPL = LL + 1 - NP = NP + 1 - GO TO 20035 -C -C NO DATA WAS FOUND. END OF VECTOR ENCOUNTERED. -C -20037 I = 0 - XVAL = ZERO - IL = IL + 1 - IF(IL.EQ.LMX-1) IL = IL + 2 -C -C IF A NEW ITEM WOULD BE INSERTED, IPLACE POINTS TO THE PLACE -C TO PUT IT. -C - IPLACE = (NP-1)*LPG + IL - RETURN -C -C SEARCH A ROW FOR THE NEXT NONZERO. -C FIND ELEMENT J=ABS(IRCX) IN ROWS ABS(I)+1,...,L. -C -20014 I=ABS(I) -C -C CHECK FOR END OF VECTOR. -C - IF (.NOT.(I.EQ.L)) GO TO 20043 - I=0 - XVAL=ZERO - RETURN -20043 I1 = I+1 - II=I1 - N20046=L - GO TO 20047 -20046 II=II+1 -20047 IF ((N20046-II).LT.0) GO TO 20048 -C -C INITIALIZE IPPLOC FOR ORTHOGONAL SCAN. -C LOOK FOR J AS A SUBSCRIPT IN ROWS II, II=I+1,...,L. -C - IF (.NOT.(II.EQ.1)) GO TO 20050 - IPPLOC = LL + 1 - GO TO 20051 -20050 IPPLOC = IX(II+3) + 1 -20051 IEND = IX(II+4) -C -C SCAN THROUGH SEVERAL PAGES, IF NECESSARY, TO FIND MATRIX ENTRY. -C - IPL = IPLOC(IPPLOC,SX,IX) -C -C FIX UP IPPLOC AND IPL TO POINT TO MATRIX DATA. -C - IDIFF = LMX - IPL - IF (.NOT.(IDIFF.LE.1.AND.IX(LMX-1).GT.0)) GO TO 20053 - IPPLOC = IPPLOC + IDIFF + 1 - IPL = IPLOC(IPPLOC,SX,IX) -20053 NP = ABS(IX(LMX-1)) - GO TO 20057 -20056 IF (ILAST.EQ.IEND) GO TO 20058 -20057 ILAST = MIN(IEND,NP*LPG+LL-2) - IL = IPLOC(ILAST,SX,IX) - IL = MIN(IL,LMX-2) -20059 IF (.NOT.(.NOT.(IPL.GE.IL .OR. IX(IPL).GE.J))) GO TO 20060 - IPL=IPL+1 - GO TO 20059 -C -C TEST IF WE HAVE FOUND THE NEXT NONZERO. -C -20060 IF (.NOT.(IX(IPL).EQ.J .AND. SX(IPL).NE.ZERO .AND. IPL.LE.IL)) GO - *TO 20061 - I = II - XVAL = SX(IPL) - RETURN -20061 IF(IX(IPL).GE.J) ILAST = IEND - IPL = LL + 1 - NP = NP + 1 - GO TO 20056 -20058 GO TO 20046 -C -C ORTHOGONAL SCAN FAILED. THE VALUE J WAS NOT A SUBSCRIPT -C IN ANY ROW. -C -20048 I=0 - XVAL=ZERO - RETURN - END diff --git a/slatec/poch.f b/slatec/poch.f deleted file mode 100644 index 405b80a..0000000 --- a/slatec/poch.f +++ /dev/null @@ -1,98 +0,0 @@ -*DECK POCH - FUNCTION POCH (A, X) -C***BEGIN PROLOGUE POCH -C***PURPOSE Evaluate a generalization of Pochhammer's symbol. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C1, C7A -C***TYPE SINGLE PRECISION (POCH-S, DPOCH-D) -C***KEYWORDS FNLIB, POCHHAMMER, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate a generalization of Pochhammer's symbol -C (A)-sub-X = GAMMA(A+X)/GAMMA(A). For X a non-negative integer, -C POCH(A,X) is just Pochhammer's symbol. A and X are single precision. -C This is a preliminary version. Error handling when POCH(A,X) is -C less than half precision is probably incorrect. Grossly incorrect -C arguments are not handled properly. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED ALGAMS, ALNREL, FAC, GAMMA, GAMR, R9LGMC, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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 900727 Added EXTERNAL statement. (WRB) -C***END PROLOGUE POCH - EXTERNAL GAMMA - SAVE PI - DATA PI / 3.1415926535 89793238 E0 / -C***FIRST EXECUTABLE STATEMENT POCH - AX = A + X - IF (AX.GT.0.0) GO TO 30 - IF (AINT(AX).NE.AX) GO TO 30 -C - IF (A .GT. 0.0 .OR. AINT(A) .NE. A) CALL XERMSG ('SLATEC', 'POCH', - + 'A+X IS NON-POSITIVE INTEGER BUT A IS NOT', 2, 2) -C -C WE KNOW HERE THAT BOTH A+X AND A ARE NON-POSITIVE INTEGERS. -C - POCH = 1.0 - IF (X.EQ.0.0) RETURN -C - N = X - IF (MIN(A+X,A).LT.(-20.0)) GO TO 20 -C - POCH = (-1.0)**N * FAC(-INT(A))/FAC(-INT(A)-N) - RETURN -C - 20 POCH = (-1.0)**N * EXP ((A-0.5)*ALNREL(X/(A-1.0)) - 1 + X*LOG(-A+1.0-X) - X + R9LGMC(-A+1.) - R9LGMC(-A-X+1.) ) - RETURN -C -C HERE WE KNOW A+X IS NOT ZERO OR A NEGATIVE INTEGER. -C - 30 POCH = 0.0 - IF (A.LE.0.0 .AND. AINT(A).EQ.A) RETURN -C - N = ABS(X) - IF (REAL(N).NE.X .OR. N.GT.20) GO TO 50 -C -C X IS A SMALL NON-POSITIVE INTEGER, PRESUMMABLY A COMMON CASE. -C - POCH = 1.0 - IF (N.EQ.0) RETURN - DO 40 I=1,N - POCH = POCH * (A+I-1) - 40 CONTINUE - RETURN -C - 50 ABSAX = ABS(A+X) - ABSA = ABS(A) - IF (MAX(ABSAX,ABSA).GT.20.0) GO TO 60 - POCH = GAMMA(A+X)*GAMR(A) - RETURN -C - 60 IF (ABS(X).GT.0.5*ABSA) GO TO 70 -C -C HERE ABS(X) IS SMALL AND BOTH ABS(A+X) AND ABS(A) ARE LARGE. THUS, -C A+X AND A MUST HAVE THE SAME SIGN. FOR NEGATIVE A, WE USE -C GAMMA(A+X)/GAMMA(A) = GAMMA(-A+1)/GAMMA(-A-X+1) * -C SIN(PI*A)/SIN(PI*(A+X)) -C - B = A - IF (B.LT.0.0) B = -A - X + 1.0 - POCH = EXP ((B-0.5)*ALNREL(X/B) + X*LOG(B+X) - X + - 1 R9LGMC(B+X) - R9LGMC(B) ) - IF (A.LT.0.0 .AND. POCH.NE.0.0) POCH = POCH/(COS(PI*X) + - 1 COT(PI*A)*SIN(PI*X)) - RETURN -C - 70 CALL ALGAMS (A+X, ALNGAX, SGNGAX) - CALL ALGAMS (A, ALNGA, SGNGA) - POCH = SGNGAX * SGNGA * EXP(ALNGAX-ALNGA) -C - RETURN - END diff --git a/slatec/poch1.f b/slatec/poch1.f deleted file mode 100644 index 49b2b78..0000000 --- a/slatec/poch1.f +++ /dev/null @@ -1,145 +0,0 @@ -*DECK POCH1 - FUNCTION POCH1 (A, X) -C***BEGIN PROLOGUE POCH1 -C***PURPOSE Calculate a generalization of Pochhammer's symbol starting -C from first order. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C1, C7A -C***TYPE SINGLE PRECISION (POCH1-S, DPOCH1-D) -C***KEYWORDS FIRST ORDER, FNLIB, POCHHAMMER, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate a generalization of Pochhammer's symbol for special -C situations that require especially accurate values when X is small in -C POCH1(A,X) = (POCH(A,X)-1)/X -C = (GAMMA(A+X)/GAMMA(A) - 1.0)/X . -C This specification is particularly suited for stably computing -C expressions such as -C (GAMMA(A+X)/GAMMA(A) - GAMMA(B+X)/GAMMA(B))/X -C = POCH1(A,X) - POCH1(B,X) -C Note that POCH1(A,0.0) = PSI(A) -C -C When ABS(X) is so small that substantial cancellation will occur if -C the straightforward formula is used, we use an expansion due -C to Fields and discussed by Y. L. Luke, The Special Functions and Their -C Approximations, Vol. 1, Academic Press, 1969, page 34. -C -C The ratio POCH(A,X) = GAMMA(A+X)/GAMMA(A) is written by Luke as -C (A+(X-1)/2)**X * polynomial in (A+(X-1)/2)**(-2) . -C In order to maintain significance in POCH1, we write for positive A -C (A+(X-1)/2)**X = EXP(X*LOG(A+(X-1)/2)) = EXP(Q) -C = 1.0 + Q*EXPREL(Q) . -C Likewise the polynomial is written -C POLY = 1.0 + X*POLY1(A,X) . -C Thus, -C POCH1(A,X) = (POCH(A,X) - 1) / X -C = EXPREL(Q)*(Q/X + Q*POLY1(A,X)) + POLY1(A,X) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED COT, EXPREL, POCH, PSI, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770801 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 900727 Added EXTERNAL statement. (WRB) -C***END PROLOGUE POCH1 - DIMENSION BERN(9), GBERN(10) - LOGICAL FIRST - EXTERNAL COT - SAVE BERN, PI, SQTBIG, ALNEPS, FIRST - DATA BERN( 1) / .8333333333 3333333E-01 / - DATA BERN( 2) / -.1388888888 8888889E-02 / - DATA BERN( 3) / .3306878306 8783069E-04 / - DATA BERN( 4) / -.8267195767 1957672E-06 / - DATA BERN( 5) / .2087675698 7868099E-07 / - DATA BERN( 6) / -.5284190138 6874932E-09 / - DATA BERN( 7) / .1338253653 0684679E-10 / - DATA BERN( 8) / -.3389680296 3225829E-12 / - DATA BERN( 9) / .8586062056 2778446E-14 / - DATA PI / 3.1415926535 8979324 E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT POCH1 - IF (FIRST) THEN - SQTBIG = 1.0/SQRT(24.0*R1MACH(1)) - ALNEPS = LOG(R1MACH(3)) - ENDIF - FIRST = .FALSE. -C - IF (X.EQ.0.0) POCH1 = PSI(A) - IF (X.EQ.0.0) RETURN -C - ABSX = ABS(X) - ABSA = ABS(A) - IF (ABSX.GT.0.1*ABSA) GO TO 70 - IF (ABSX*LOG(MAX(ABSA,2.0)).GT.0.1) GO TO 70 -C - BP = A - IF (A.LT.(-0.5)) BP = 1.0 - A - X - INCR = 0 - IF (BP.LT.10.0) INCR = 11.0 - BP - B = BP + INCR -C - VAR = B + 0.5*(X-1.0) - ALNVAR = LOG(VAR) - Q = X*ALNVAR -C - POLY1 = 0.0 - IF (VAR.GE.SQTBIG) GO TO 40 - VAR2 = (1.0/VAR)**2 -C - RHO = 0.5*(X+1.0) - GBERN(1) = 1.0 - GBERN(2) = -RHO/12.0 - TERM = VAR2 - POLY1 = GBERN(2)*TERM -C - NTERMS = -0.5*ALNEPS/ALNVAR + 1.0 - IF (NTERMS .GT. 9) CALL XERMSG ('SLATEC', 'POCH1', - + 'NTERMS IS TOO BIG, MAYBE R1MACH(3) IS BAD', 1, 2) - IF (NTERMS.LT.2) GO TO 40 -C - DO 30 K=2,NTERMS - GBK = 0.0 - DO 20 J=1,K - NDX = K - J + 1 - GBK = GBK + BERN(NDX)*GBERN(J) - 20 CONTINUE - GBERN(K+1) = -RHO*GBK/K -C - TERM = TERM * (2*K-2.-X)*(2*K-1.-X)*VAR2 - POLY1 = POLY1 + GBERN(K+1)*TERM - 30 CONTINUE -C - 40 POLY1 = (X-1.0)*POLY1 - POCH1 = EXPREL(Q)*(ALNVAR + Q*POLY1) + POLY1 -C - IF (INCR.EQ.0) GO TO 60 -C -C WE HAVE POCH1(B,X). BUT BP IS SMALL, SO WE USE BACKWARDS RECURSION -C TO OBTAIN POCH1(BP,X). -C - DO 50 II=1,INCR - I = INCR - II - BINV = 1.0/(BP+I) - POCH1 = (POCH1-BINV)/(1.0+X*BINV) - 50 CONTINUE -C - 60 IF (BP.EQ.A) RETURN -C -C WE HAVE POCH1(BP,X), BUT A IS LT -0.5. WE THEREFORE USE A REFLECTION -C FORMULA TO OBTAIN POCH1(A,X). -C - SINPXX = SIN(PI*X)/X - SINPX2 = SIN(0.5*PI*X) - TRIG = SINPXX*COT(PI*B) - 2.0*SINPX2*(SINPX2/X) -C - POCH1 = TRIG + (1.0 + X*TRIG) * POCH1 - RETURN -C - 70 POCH1 = (POCH(A,X) - 1.0) / X - RETURN -C - END diff --git a/slatec/pois3d.f b/slatec/pois3d.f deleted file mode 100644 index fa1614c..0000000 --- a/slatec/pois3d.f +++ /dev/null @@ -1,333 +0,0 @@ -*DECK POIS3D - SUBROUTINE POIS3D (LPEROD, L, C1, MPEROD, M, C2, NPEROD, N, A, B, - + C, LDIMF, MDIMF, F, IERROR, W) -C***BEGIN PROLOGUE POIS3D -C***PURPOSE Solve a three-dimensional block tridiagonal linear system -C which arises from a finite difference approximation to a -C three-dimensional Poisson equation using the Fourier -C transform package FFTPAK written by Paul Swarztrauber. -C***LIBRARY SLATEC (FISHPACK) -C***CATEGORY I2B4B -C***TYPE SINGLE PRECISION (POIS3D-S) -C***KEYWORDS ELLIPTIC PDE, FISHPACK, HELMHOLTZ, POISSON -C***AUTHOR Adams, J., (NCAR) -C Swarztrauber, P. N., (NCAR) -C Sweet, R., (NCAR) -C***DESCRIPTION -C -C Subroutine POIS3D solves the linear system of equations -C -C C1*(X(I-1,J,K)-2.*X(I,J,K)+X(I+1,J,K)) -C + C2*(X(I,J-1,K)-2.*X(I,J,K)+X(I,J+1,K)) -C + A(K)*X(I,J,K-1)+B(K)*X(I,J,K)+C(K)*X(I,J,K+1) = F(I,J,K) -C -C for I=1,2,...,L , J=1,2,...,M , and K=1,2,...,N . -C -C The indices K-1 and K+1 are evaluated modulo N, i.e. -C X(I,J,0) = X(I,J,N) and X(I,J,N+1) = X(I,J,1). The unknowns -C X(0,J,K), X(L+1,J,K), X(I,0,K), and X(I,M+1,K) are assumed to take -C on certain prescribed values described below. -C -C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -C -C -C * * * * * * * * Parameter Description * * * * * * * * * * -C -C -C * * * * * * On Input * * * * * * -C -C LPEROD Indicates the values that X(0,J,K) and X(L+1,J,K) are -C assumed to have. -C -C = 0 If X(0,J,K) = X(L,J,K) and X(L+1,J,K) = X(1,J,K). -C = 1 If X(0,J,K) = X(L+1,J,K) = 0. -C = 2 If X(0,J,K) = 0 and X(L+1,J,K) = X(L-1,J,K). -C = 3 If X(0,J,K) = X(2,J,K) and X(L+1,J,K) = X(L-1,J,K). -C = 4 If X(0,J,K) = X(2,J,K) and X(L+1,J,K) = 0. -C -C L The number of unknowns in the I-direction. L must be at -C least 3. -C -C C1 The real constant that appears in the above equation. -C -C MPEROD Indicates the values that X(I,0,K) and X(I,M+1,K) are -C assumed to have. -C -C = 0 If X(I,0,K) = X(I,M,K) and X(I,M+1,K) = X(I,1,K). -C = 1 If X(I,0,K) = X(I,M+1,K) = 0. -C = 2 If X(I,0,K) = 0 and X(I,M+1,K) = X(I,M-1,K). -C = 3 If X(I,0,K) = X(I,2,K) and X(I,M+1,K) = X(I,M-1,K). -C = 4 If X(I,0,K) = X(I,2,K) and X(I,M+1,K) = 0. -C -C M The number of unknowns in the J-direction. M must be at -C least 3. -C -C C2 The real constant which appears in the above equation. -C -C NPEROD = 0 If A(1) and C(N) are not zero. -C = 1 If A(1) = C(N) = 0. -C -C N The number of unknowns in the K-direction. N must be at -C least 3. -C -C -C A,B,C One-dimensional arrays of length N that specify the -C coefficients in the linear equations given above. -C -C If NPEROD = 0 the array elements must not depend upon the -C index K, but must be constant. Specifically, the -C subroutine checks the following condition -C -C A(K) = C(1) -C C(K) = C(1) -C B(K) = B(1) -C -C for K=1,2,...,N. -C -C LDIMF The row (or first) dimension of the three-dimensional -C array F as it appears in the program calling POIS3D. -C This parameter is used to specify the variable dimension -C of F. LDIMF must be at least L. -C -C MDIMF The column (or second) dimension of the three-dimensional -C array F as it appears in the program calling POIS3D. -C This parameter is used to specify the variable dimension -C of F. MDIMF must be at least M. -C -C F A three-dimensional array that specifies the values of -C the right side of the linear system of equations given -C above. F must be dimensioned at least L x M x N. -C -C W A one-dimensional array that must be provided by the -C user for work space. The length of W must be at least -C 30 + L + M + 2*N + MAX(L,M,N) + -C 7*(INT((L+1)/2) + INT((M+1)/2)). -C -C -C * * * * * * On Output * * * * * * -C -C F Contains the solution X. -C -C IERROR An error flag that indicates invalid input parameters. -C Except for number zero, a solution is not attempted. -C = 0 No error -C = 1 If LPEROD .LT. 0 or .GT. 4 -C = 2 If L .LT. 3 -C = 3 If MPEROD .LT. 0 or .GT. 4 -C = 4 If M .LT. 3 -C = 5 If NPEROD .LT. 0 or .GT. 1 -C = 6 If N .LT. 3 -C = 7 If LDIMF .LT. L -C = 8 If MDIMF .LT. M -C = 9 If A(K) .NE. C(1) or C(K) .NE. C(1) or B(I) .NE.B(1) -C for some K=1,2,...,N. -C = 10 If NPEROD = 1 and A(1) .NE. 0 or C(N) .NE. 0 -C -C Since this is the only means of indicating a possibly -C incorrect call to POIS3D, the user should test IERROR -C after the call. -C -C *Long Description: -C -C * * * * * * * Program Specifications * * * * * * * * * * * * -C -C Dimension of A(N),B(N),C(N),F(LDIMF,MDIMF,N), -C Arguments W(see argument list) -C -C Latest December 1, 1978 -C Revision -C -C Subprograms POIS3D,POS3D1,TRIDQ,RFFTI,RFFTF,RFFTF1,RFFTB, -C Required RFFTB1,COSTI,COST,SINTI,SINT,COSQI,COSQF,COSQF1 -C COSQB,COSQB1,SINQI,SINQF,SINQB,CFFTI,CFFTI1, -C CFFTB,CFFTB1,PASSB2,PASSB3,PASSB4,PASSB,CFFTF, -C CFFTF1,PASSF1,PASSF2,PASSF3,PASSF4,PASSF,PIMACH, -C -C Special NONE -C Conditions -C -C Common NONE -C Blocks -C -C I/O NONE -C -C Precision Single -C -C Specialist Roland Sweet -C -C Language FORTRAN -C -C History Written by Roland Sweet at NCAR in July 1977 -C -C Algorithm This subroutine solves three-dimensional block -C tridiagonal linear systems arising from finite -C difference approximations to three-dimensional -C Poisson equations using the Fourier transform -C package FFTPAK written by Paul Swarztrauber. -C -C Space 6561(decimal) = 14641(octal) locations on the -C Required NCAR Control Data 7600 -C -C Timing and The execution time T on the NCAR Control Data -C Accuracy 7600 for subroutine POIS3D is roughly proportional -C to L*M*N*(log2(L)+log2(M)+5), but also depends on -C input parameters LPEROD and MPEROD. Some typical -C values are listed in the table below when NPEROD=0. -C To measure the accuracy of the algorithm a -C uniform random number generator was used to create -C a solution array X for the system given in the -C 'PURPOSE' with -C -C A(K) = C(K) = -0.5*B(K) = 1, K=1,2,...,N -C -C and, when NPEROD = 1 -C -C A(1) = C(N) = 0 -C A(N) = C(1) = 2. -C -C The solution X was substituted into the given sys- -C tem and, using double precision, a right side Y was -C computed. Using this array Y subroutine POIS3D was -C called to produce an approximate solution Z. Then -C the relative error, defined as -C -C E = MAX(ABS(Z(I,J,K)-X(I,J,K)))/MAX(ABS(X(I,J,K))) -C -C where the two maxima are taken over I=1,2,...,L, -C J=1,2,...,M and K=1,2,...,N, was computed. The -C value of E is given in the table below for some -C typical values of L,M and N. -C -C -C L(=M=N) LPEROD MPEROD T(MSECS) E -C ------ ------ ------ -------- ------ -C -C 16 0 0 272 1.E-13 -C 15 1 1 287 4.E-13 -C 17 3 3 338 2.E-13 -C 32 0 0 1755 2.E-13 -C 31 1 1 1894 2.E-12 -C 33 3 3 2042 7.E-13 -C -C -C Portability American National Standards Institute FORTRAN. -C The machine dependent constant PI is defined in -C function PIMACH. -C -C Required COS,SIN,ATAN -C Resident -C Routines -C -C Reference NONE -C -C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -C -C***REFERENCES (NONE) -C***ROUTINES CALLED POS3D1 -C***REVISION HISTORY (YYMMDD) -C 801001 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***END PROLOGUE POIS3D - DIMENSION A(*) ,B(*) ,C(*) , - 1 F(LDIMF,MDIMF,*) ,W(*) ,SAVE(6) -C***FIRST EXECUTABLE STATEMENT POIS3D - LP = LPEROD+1 - MP = MPEROD+1 - NP = NPEROD+1 -C -C CHECK FOR INVALID INPUT. -C - IERROR = 0 - IF (LP.LT.1 .OR. LP.GT.5) IERROR = 1 - IF (L .LT. 3) IERROR = 2 - IF (MP.LT.1 .OR. MP.GT.5) IERROR = 3 - IF (M .LT. 3) IERROR = 4 - IF (NP.LT.1 .OR. NP.GT.2) IERROR = 5 - IF (N .LT. 3) IERROR = 6 - IF (LDIMF .LT. L) IERROR = 7 - IF (MDIMF .LT. M) IERROR = 8 - IF (NP .NE. 1) GO TO 103 - DO 101 K=1,N - IF (A(K) .NE. C(1)) GO TO 102 - IF (C(K) .NE. C(1)) GO TO 102 - IF (B(K) .NE. B(1)) GO TO 102 - 101 CONTINUE - GO TO 104 - 102 IERROR = 9 - 103 IF (NPEROD.EQ.1 .AND. (A(1).NE.0. .OR. C(N).NE.0.)) IERROR = 10 - 104 IF (IERROR .NE. 0) GO TO 122 - IWYRT = L+1 - IWT = IWYRT+M - IWD = IWT+MAX(L,M,N)+1 - IWBB = IWD+N - IWX = IWBB+N - IWY = IWX+7*((L+1)/2)+15 - GO TO (105,114),NP -C -C REORDER UNKNOWNS WHEN NPEROD = 0. -C - 105 NH = (N+1)/2 - NHM1 = NH-1 - NODD = 1 - IF (2*NH .EQ. N) NODD = 2 - DO 111 I=1,L - DO 110 J=1,M - DO 106 K=1,NHM1 - NHPK = NH+K - NHMK = NH-K - W(K) = F(I,J,NHMK)-F(I,J,NHPK) - W(NHPK) = F(I,J,NHMK)+F(I,J,NHPK) - 106 CONTINUE - W(NH) = 2.*F(I,J,NH) - GO TO (108,107),NODD - 107 W(N) = 2.*F(I,J,N) - 108 DO 109 K=1,N - F(I,J,K) = W(K) - 109 CONTINUE - 110 CONTINUE - 111 CONTINUE - SAVE(1) = C(NHM1) - SAVE(2) = A(NH) - SAVE(3) = C(NH) - SAVE(4) = B(NHM1) - SAVE(5) = B(N) - SAVE(6) = A(N) - C(NHM1) = 0. - A(NH) = 0. - C(NH) = 2.*C(NH) - GO TO (112,113),NODD - 112 B(NHM1) = B(NHM1)-A(NH-1) - B(N) = B(N)+A(N) - GO TO 114 - 113 A(N) = C(NH) - 114 CONTINUE - CALL POS3D1 (LP,L,MP,M,N,A,B,C,LDIMF,MDIMF,F,W,W(IWYRT),W(IWT), - 1 W(IWD),W(IWX),W(IWY),C1,C2,W(IWBB)) - GO TO (115,122),NP - 115 DO 121 I=1,L - DO 120 J=1,M - DO 116 K=1,NHM1 - NHMK = NH-K - NHPK = NH+K - W(NHMK) = .5*(F(I,J,NHPK)+F(I,J,K)) - W(NHPK) = .5*(F(I,J,NHPK)-F(I,J,K)) - 116 CONTINUE - W(NH) = .5*F(I,J,NH) - GO TO (118,117),NODD - 117 W(N) = .5*F(I,J,N) - 118 DO 119 K=1,N - F(I,J,K) = W(K) - 119 CONTINUE - 120 CONTINUE - 121 CONTINUE - C(NHM1) = SAVE(1) - A(NH) = SAVE(2) - C(NH) = SAVE(3) - B(NHM1) = SAVE(4) - B(N) = SAVE(5) - A(N) = SAVE(6) - 122 CONTINUE - RETURN - END diff --git a/slatec/poisd2.f b/slatec/poisd2.f deleted file mode 100644 index d131259..0000000 --- a/slatec/poisd2.f +++ /dev/null @@ -1,331 +0,0 @@ -*DECK POISD2 - SUBROUTINE POISD2 (MR, NR, ISTAG, BA, BB, BC, Q, IDIMQ, B, W, D, - + TCOS, P) -C***BEGIN PROLOGUE POISD2 -C***SUBSIDIARY -C***PURPOSE Subsidiary to GENBUN -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (POISD2-S, CMPOSD-C) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Subroutine to solve Poisson's equation for Dirichlet boundary -C conditions. -C -C ISTAG = 1 if the last diagonal block is the matrix A. -C ISTAG = 2 if the last diagonal block is the matrix A+I. -C -C***SEE ALSO GENBUN -C***ROUTINES CALLED COSGEN, S1MERG, TRIX -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 920130 Modified to use merge routine S1MERG rather than deleted -C routine MERGE. (WRB) -C***END PROLOGUE POISD2 -C - DIMENSION Q(IDIMQ,*) ,BA(*) ,BB(*) ,BC(*) , - 1 TCOS(*) ,B(*) ,D(*) ,W(*) , - 2 P(*) -C***FIRST EXECUTABLE STATEMENT POISD2 - M = MR - N = NR - JSH = 0 - FI = 1./ISTAG - IP = -M - IPSTOR = 0 - GO TO (101,102),ISTAG - 101 KR = 0 - IRREG = 1 - IF (N .GT. 1) GO TO 106 - TCOS(1) = 0. - GO TO 103 - 102 KR = 1 - JSTSAV = 1 - IRREG = 2 - IF (N .GT. 1) GO TO 106 - TCOS(1) = -1. - 103 DO 104 I=1,M - B(I) = Q(I,1) - 104 CONTINUE - CALL TRIX (1,0,M,BA,BB,BC,B,TCOS,D,W) - DO 105 I=1,M - Q(I,1) = B(I) - 105 CONTINUE - GO TO 183 - 106 LR = 0 - DO 107 I=1,M - P(I) = 0. - 107 CONTINUE - NUN = N - JST = 1 - JSP = N -C -C IRREG = 1 WHEN NO IRREGULARITIES HAVE OCCURRED, OTHERWISE IT IS 2. -C - 108 L = 2*JST - NODD = 2-2*((NUN+1)/2)+NUN -C -C NODD = 1 WHEN NUN IS ODD, OTHERWISE IT IS 2. -C - GO TO (110,109),NODD - 109 JSP = JSP-L - GO TO 111 - 110 JSP = JSP-JST - IF (IRREG .NE. 1) JSP = JSP-L - 111 CONTINUE -C -C REGULAR REDUCTION -C - CALL COSGEN (JST,1,0.5,0.0,TCOS) - IF (L .GT. JSP) GO TO 118 - DO 117 J=L,JSP,L - JM1 = J-JSH - JP1 = J+JSH - JM2 = J-JST - JP2 = J+JST - JM3 = JM2-JSH - JP3 = JP2+JSH - IF (JST .NE. 1) GO TO 113 - DO 112 I=1,M - B(I) = 2.*Q(I,J) - Q(I,J) = Q(I,JM2)+Q(I,JP2) - 112 CONTINUE - GO TO 115 - 113 DO 114 I=1,M - T = Q(I,J)-Q(I,JM1)-Q(I,JP1)+Q(I,JM2)+Q(I,JP2) - B(I) = T+Q(I,J)-Q(I,JM3)-Q(I,JP3) - Q(I,J) = T - 114 CONTINUE - 115 CONTINUE - CALL TRIX (JST,0,M,BA,BB,BC,B,TCOS,D,W) - DO 116 I=1,M - Q(I,J) = Q(I,J)+B(I) - 116 CONTINUE - 117 CONTINUE -C -C REDUCTION FOR LAST UNKNOWN -C - 118 GO TO (119,136),NODD - 119 GO TO (152,120),IRREG -C -C ODD NUMBER OF UNKNOWNS -C - 120 JSP = JSP+L - J = JSP - JM1 = J-JSH - JP1 = J+JSH - JM2 = J-JST - JP2 = J+JST - JM3 = JM2-JSH - GO TO (123,121),ISTAG - 121 CONTINUE - IF (JST .NE. 1) GO TO 123 - DO 122 I=1,M - B(I) = Q(I,J) - Q(I,J) = 0. - 122 CONTINUE - GO TO 130 - 123 GO TO (124,126),NODDPR - 124 DO 125 I=1,M - IP1 = IP+I - B(I) = .5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3))+P(IP1)+Q(I,J) - 125 CONTINUE - GO TO 128 - 126 DO 127 I=1,M - B(I) = .5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3))+Q(I,JP2)-Q(I,JP1)+Q(I,J) - 127 CONTINUE - 128 DO 129 I=1,M - Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) - 129 CONTINUE - 130 CALL TRIX (JST,0,M,BA,BB,BC,B,TCOS,D,W) - IP = IP+M - IPSTOR = MAX(IPSTOR,IP+M) - DO 131 I=1,M - IP1 = IP+I - P(IP1) = Q(I,J)+B(I) - B(I) = Q(I,JP2)+P(IP1) - 131 CONTINUE - IF (LR .NE. 0) GO TO 133 - DO 132 I=1,JST - KRPI = KR+I - TCOS(KRPI) = TCOS(I) - 132 CONTINUE - GO TO 134 - 133 CONTINUE - CALL COSGEN (LR,JSTSAV,0.,FI,TCOS(JST+1)) - CALL S1MERG (TCOS,0,JST,JST,LR,KR) - 134 CONTINUE - CALL COSGEN (KR,JSTSAV,0.0,FI,TCOS) - CALL TRIX (KR,KR,M,BA,BB,BC,B,TCOS,D,W) - DO 135 I=1,M - IP1 = IP+I - Q(I,J) = Q(I,JM2)+B(I)+P(IP1) - 135 CONTINUE - LR = KR - KR = KR+L - GO TO 152 -C -C EVEN NUMBER OF UNKNOWNS -C - 136 JSP = JSP+L - J = JSP - JM1 = J-JSH - JP1 = J+JSH - JM2 = J-JST - JP2 = J+JST - JM3 = JM2-JSH - GO TO (137,138),IRREG - 137 CONTINUE - JSTSAV = JST - IDEG = JST - KR = L - GO TO 139 - 138 CALL COSGEN (KR,JSTSAV,0.0,FI,TCOS) - CALL COSGEN (LR,JSTSAV,0.0,FI,TCOS(KR+1)) - IDEG = KR - KR = KR+JST - 139 IF (JST .NE. 1) GO TO 141 - IRREG = 2 - DO 140 I=1,M - B(I) = Q(I,J) - Q(I,J) = Q(I,JM2) - 140 CONTINUE - GO TO 150 - 141 DO 142 I=1,M - B(I) = Q(I,J)+.5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3)) - 142 CONTINUE - GO TO (143,145),IRREG - 143 DO 144 I=1,M - Q(I,J) = Q(I,JM2)+.5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) - 144 CONTINUE - IRREG = 2 - GO TO 150 - 145 CONTINUE - GO TO (146,148),NODDPR - 146 DO 147 I=1,M - IP1 = IP+I - Q(I,J) = Q(I,JM2)+P(IP1) - 147 CONTINUE - IP = IP-M - GO TO 150 - 148 DO 149 I=1,M - Q(I,J) = Q(I,JM2)+Q(I,J)-Q(I,JM1) - 149 CONTINUE - 150 CALL TRIX (IDEG,LR,M,BA,BB,BC,B,TCOS,D,W) - DO 151 I=1,M - Q(I,J) = Q(I,J)+B(I) - 151 CONTINUE - 152 NUN = NUN/2 - NODDPR = NODD - JSH = JST - JST = 2*JST - IF (NUN .GE. 2) GO TO 108 -C -C START SOLUTION. -C - J = JSP - DO 153 I=1,M - B(I) = Q(I,J) - 153 CONTINUE - GO TO (154,155),IRREG - 154 CONTINUE - CALL COSGEN (JST,1,0.5,0.0,TCOS) - IDEG = JST - GO TO 156 - 155 KR = LR+JST - CALL COSGEN (KR,JSTSAV,0.0,FI,TCOS) - CALL COSGEN (LR,JSTSAV,0.0,FI,TCOS(KR+1)) - IDEG = KR - 156 CONTINUE - CALL TRIX (IDEG,LR,M,BA,BB,BC,B,TCOS,D,W) - JM1 = J-JSH - JP1 = J+JSH - GO TO (157,159),IRREG - 157 DO 158 I=1,M - Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))+B(I) - 158 CONTINUE - GO TO 164 - 159 GO TO (160,162),NODDPR - 160 DO 161 I=1,M - IP1 = IP+I - Q(I,J) = P(IP1)+B(I) - 161 CONTINUE - IP = IP-M - GO TO 164 - 162 DO 163 I=1,M - Q(I,J) = Q(I,J)-Q(I,JM1)+B(I) - 163 CONTINUE - 164 CONTINUE -C -C START BACK SUBSTITUTION. -C - JST = JST/2 - JSH = JST/2 - NUN = 2*NUN - IF (NUN .GT. N) GO TO 183 - DO 182 J=JST,N,L - JM1 = J-JSH - JP1 = J+JSH - JM2 = J-JST - JP2 = J+JST - IF (J .GT. JST) GO TO 166 - DO 165 I=1,M - B(I) = Q(I,J)+Q(I,JP2) - 165 CONTINUE - GO TO 170 - 166 IF (JP2 .LE. N) GO TO 168 - DO 167 I=1,M - B(I) = Q(I,J)+Q(I,JM2) - 167 CONTINUE - IF (JST .LT. JSTSAV) IRREG = 1 - GO TO (170,171),IRREG - 168 DO 169 I=1,M - B(I) = Q(I,J)+Q(I,JM2)+Q(I,JP2) - 169 CONTINUE - 170 CONTINUE - CALL COSGEN (JST,1,0.5,0.0,TCOS) - IDEG = JST - JDEG = 0 - GO TO 172 - 171 IF (J+L .GT. N) LR = LR-JST - KR = JST+LR - CALL COSGEN (KR,JSTSAV,0.0,FI,TCOS) - CALL COSGEN (LR,JSTSAV,0.0,FI,TCOS(KR+1)) - IDEG = KR - JDEG = LR - 172 CONTINUE - CALL TRIX (IDEG,JDEG,M,BA,BB,BC,B,TCOS,D,W) - IF (JST .GT. 1) GO TO 174 - DO 173 I=1,M - Q(I,J) = B(I) - 173 CONTINUE - GO TO 182 - 174 IF (JP2 .GT. N) GO TO 177 - 175 DO 176 I=1,M - Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))+B(I) - 176 CONTINUE - GO TO 182 - 177 GO TO (175,178),IRREG - 178 IF (J+JSH .GT. N) GO TO 180 - DO 179 I=1,M - IP1 = IP+I - Q(I,J) = B(I)+P(IP1) - 179 CONTINUE - IP = IP-M - GO TO 182 - 180 DO 181 I=1,M - Q(I,J) = B(I)+Q(I,J)-Q(I,JM1) - 181 CONTINUE - 182 CONTINUE - L = L/2 - GO TO 164 - 183 CONTINUE -C -C RETURN STORAGE REQUIREMENTS FOR P VECTORS. -C - W(1) = IPSTOR - RETURN - END diff --git a/slatec/poisn2.f b/slatec/poisn2.f deleted file mode 100644 index df70e61..0000000 --- a/slatec/poisn2.f +++ /dev/null @@ -1,559 +0,0 @@ -*DECK POISN2 - SUBROUTINE POISN2 (M, N, ISTAG, MIXBND, A, BB, C, Q, IDIMQ, B, B2, - + B3, W, W2, W3, D, TCOS, P) -C***BEGIN PROLOGUE POISN2 -C***SUBSIDIARY -C***PURPOSE Subsidiary to GENBUN -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (POISN2-S, CMPOSN-C) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Subroutine to solve Poisson's equation with Neumann boundary -C conditions. -C -C ISTAG = 1 if the last diagonal block is A. -C ISTAG = 2 if the last diagonal block is A-I. -C MIXBND = 1 if have Neumann boundary conditions at both boundaries. -C MIXBND = 2 if have Neumann boundary conditions at bottom and -C Dirichlet condition at top. (for this case, must have ISTAG = 1.) -C -C***SEE ALSO GENBUN -C***ROUTINES CALLED COSGEN, S1MERG, TRI3, TRIX -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 920130 Modified to use merge routine S1MERG rather than deleted -C routine MERGE. (WRB) -C***END PROLOGUE POISN2 -C - DIMENSION A(*) ,BB(*) ,C(*) ,Q(IDIMQ,*) , - 1 B(*) ,B2(*) ,B3(*) ,W(*) , - 2 W2(*) ,W3(*) ,D(*) ,TCOS(*) , - 3 K(4) ,P(*) - EQUIVALENCE (K(1),K1) ,(K(2),K2) ,(K(3),K3) ,(K(4),K4) -C***FIRST EXECUTABLE STATEMENT POISN2 - FISTAG = 3-ISTAG - FNUM = 1./ISTAG - FDEN = 0.5*(ISTAG-1) - MR = M - IP = -MR - IPSTOR = 0 - I2R = 1 - JR = 2 - NR = N - NLAST = N - KR = 1 - LR = 0 - GO TO (101,103),ISTAG - 101 CONTINUE - DO 102 I=1,MR - Q(I,N) = .5*Q(I,N) - 102 CONTINUE - GO TO (103,104),MIXBND - 103 IF (N .LE. 3) GO TO 155 - 104 CONTINUE - JR = 2*I2R - NROD = 1 - IF ((NR/2)*2 .EQ. NR) NROD = 0 - GO TO (105,106),MIXBND - 105 JSTART = 1 - GO TO 107 - 106 JSTART = JR - NROD = 1-NROD - 107 CONTINUE - JSTOP = NLAST-JR - IF (NROD .EQ. 0) JSTOP = JSTOP-I2R - CALL COSGEN (I2R,1,0.5,0.0,TCOS) - I2RBY2 = I2R/2 - IF (JSTOP .GE. JSTART) GO TO 108 - J = JR - GO TO 116 - 108 CONTINUE -C -C REGULAR REDUCTION. -C - DO 115 J=JSTART,JSTOP,JR - JP1 = J+I2RBY2 - JP2 = J+I2R - JP3 = JP2+I2RBY2 - JM1 = J-I2RBY2 - JM2 = J-I2R - JM3 = JM2-I2RBY2 - IF (J .NE. 1) GO TO 109 - JM1 = JP1 - JM2 = JP2 - JM3 = JP3 - 109 CONTINUE - IF (I2R .NE. 1) GO TO 111 - IF (J .EQ. 1) JM2 = JP2 - DO 110 I=1,MR - B(I) = 2.*Q(I,J) - Q(I,J) = Q(I,JM2)+Q(I,JP2) - 110 CONTINUE - GO TO 113 - 111 CONTINUE - DO 112 I=1,MR - FI = Q(I,J) - Q(I,J) = Q(I,J)-Q(I,JM1)-Q(I,JP1)+Q(I,JM2)+Q(I,JP2) - B(I) = FI+Q(I,J)-Q(I,JM3)-Q(I,JP3) - 112 CONTINUE - 113 CONTINUE - CALL TRIX (I2R,0,MR,A,BB,C,B,TCOS,D,W) - DO 114 I=1,MR - Q(I,J) = Q(I,J)+B(I) - 114 CONTINUE -C -C END OF REDUCTION FOR REGULAR UNKNOWNS. -C - 115 CONTINUE -C -C BEGIN SPECIAL REDUCTION FOR LAST UNKNOWN. -C - J = JSTOP+JR - 116 NLAST = J - JM1 = J-I2RBY2 - JM2 = J-I2R - JM3 = JM2-I2RBY2 - IF (NROD .EQ. 0) GO TO 128 -C -C ODD NUMBER OF UNKNOWNS -C - IF (I2R .NE. 1) GO TO 118 - DO 117 I=1,MR - B(I) = FISTAG*Q(I,J) - Q(I,J) = Q(I,JM2) - 117 CONTINUE - GO TO 126 - 118 DO 119 I=1,MR - B(I) = Q(I,J)+.5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3)) - 119 CONTINUE - IF (NRODPR .NE. 0) GO TO 121 - DO 120 I=1,MR - II = IP+I - Q(I,J) = Q(I,JM2)+P(II) - 120 CONTINUE - IP = IP-MR - GO TO 123 - 121 CONTINUE - DO 122 I=1,MR - Q(I,J) = Q(I,J)-Q(I,JM1)+Q(I,JM2) - 122 CONTINUE - 123 IF (LR .EQ. 0) GO TO 124 - CALL COSGEN (LR,1,0.5,FDEN,TCOS(KR+1)) - GO TO 126 - 124 CONTINUE - DO 125 I=1,MR - B(I) = FISTAG*B(I) - 125 CONTINUE - 126 CONTINUE - CALL COSGEN (KR,1,0.5,FDEN,TCOS) - CALL TRIX (KR,LR,MR,A,BB,C,B,TCOS,D,W) - DO 127 I=1,MR - Q(I,J) = Q(I,J)+B(I) - 127 CONTINUE - KR = KR+I2R - GO TO 151 - 128 CONTINUE -C -C EVEN NUMBER OF UNKNOWNS -C - JP1 = J+I2RBY2 - JP2 = J+I2R - IF (I2R .NE. 1) GO TO 135 - DO 129 I=1,MR - B(I) = Q(I,J) - 129 CONTINUE - CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) - IP = 0 - IPSTOR = MR - GO TO (133,130),ISTAG - 130 DO 131 I=1,MR - P(I) = B(I) - B(I) = B(I)+Q(I,N) - 131 CONTINUE - TCOS(1) = 1. - TCOS(2) = 0. - CALL TRIX (1,1,MR,A,BB,C,B,TCOS,D,W) - DO 132 I=1,MR - Q(I,J) = Q(I,JM2)+P(I)+B(I) - 132 CONTINUE - GO TO 150 - 133 CONTINUE - DO 134 I=1,MR - P(I) = B(I) - Q(I,J) = Q(I,JM2)+2.*Q(I,JP2)+3.*B(I) - 134 CONTINUE - GO TO 150 - 135 CONTINUE - DO 136 I=1,MR - B(I) = Q(I,J)+.5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3)) - 136 CONTINUE - IF (NRODPR .NE. 0) GO TO 138 - DO 137 I=1,MR - II = IP+I - B(I) = B(I)+P(II) - 137 CONTINUE - GO TO 140 - 138 CONTINUE - DO 139 I=1,MR - B(I) = B(I)+Q(I,JP2)-Q(I,JP1) - 139 CONTINUE - 140 CONTINUE - CALL TRIX (I2R,0,MR,A,BB,C,B,TCOS,D,W) - IP = IP+MR - IPSTOR = MAX(IPSTOR,IP+MR) - DO 141 I=1,MR - II = IP+I - P(II) = B(I)+.5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) - B(I) = P(II)+Q(I,JP2) - 141 CONTINUE - IF (LR .EQ. 0) GO TO 142 - CALL COSGEN (LR,1,0.5,FDEN,TCOS(I2R+1)) - CALL S1MERG (TCOS,0,I2R,I2R,LR,KR) - GO TO 144 - 142 DO 143 I=1,I2R - II = KR+I - TCOS(II) = TCOS(I) - 143 CONTINUE - 144 CALL COSGEN (KR,1,0.5,FDEN,TCOS) - IF (LR .NE. 0) GO TO 145 - GO TO (146,145),ISTAG - 145 CONTINUE - CALL TRIX (KR,KR,MR,A,BB,C,B,TCOS,D,W) - GO TO 148 - 146 CONTINUE - DO 147 I=1,MR - B(I) = FISTAG*B(I) - 147 CONTINUE - 148 CONTINUE - DO 149 I=1,MR - II = IP+I - Q(I,J) = Q(I,JM2)+P(II)+B(I) - 149 CONTINUE - 150 CONTINUE - LR = KR - KR = KR+JR - 151 CONTINUE - GO TO (152,153),MIXBND - 152 NR = (NLAST-1)/JR+1 - IF (NR .LE. 3) GO TO 155 - GO TO 154 - 153 NR = NLAST/JR - IF (NR .LE. 1) GO TO 192 - 154 I2R = JR - NRODPR = NROD - GO TO 104 - 155 CONTINUE -C -C BEGIN SOLUTION -C - J = 1+JR - JM1 = J-I2R - JP1 = J+I2R - JM2 = NLAST-I2R - IF (NR .EQ. 2) GO TO 184 - IF (LR .NE. 0) GO TO 170 - IF (N .NE. 3) GO TO 161 -C -C CASE N = 3. -C - GO TO (156,168),ISTAG - 156 CONTINUE - DO 157 I=1,MR - B(I) = Q(I,2) - 157 CONTINUE - TCOS(1) = 0. - CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) - DO 158 I=1,MR - Q(I,2) = B(I) - B(I) = 4.*B(I)+Q(I,1)+2.*Q(I,3) - 158 CONTINUE - TCOS(1) = -2. - TCOS(2) = 2. - I1 = 2 - I2 = 0 - CALL TRIX (I1,I2,MR,A,BB,C,B,TCOS,D,W) - DO 159 I=1,MR - Q(I,2) = Q(I,2)+B(I) - B(I) = Q(I,1)+2.*Q(I,2) - 159 CONTINUE - TCOS(1) = 0. - CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) - DO 160 I=1,MR - Q(I,1) = B(I) - 160 CONTINUE - JR = 1 - I2R = 0 - GO TO 194 -C -C CASE N = 2**P+1 -C - 161 CONTINUE - GO TO (162,170),ISTAG - 162 CONTINUE - DO 163 I=1,MR - B(I) = Q(I,J)+.5*Q(I,1)-Q(I,JM1)+Q(I,NLAST)-Q(I,JM2) - 163 CONTINUE - CALL COSGEN (JR,1,0.5,0.0,TCOS) - CALL TRIX (JR,0,MR,A,BB,C,B,TCOS,D,W) - DO 164 I=1,MR - Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))+B(I) - B(I) = Q(I,1)+2.*Q(I,NLAST)+4.*Q(I,J) - 164 CONTINUE - JR2 = 2*JR - CALL COSGEN (JR,1,0.0,0.0,TCOS) - DO 165 I=1,JR - I1 = JR+I - I2 = JR+1-I - TCOS(I1) = -TCOS(I2) - 165 CONTINUE - CALL TRIX (JR2,0,MR,A,BB,C,B,TCOS,D,W) - DO 166 I=1,MR - Q(I,J) = Q(I,J)+B(I) - B(I) = Q(I,1)+2.*Q(I,J) - 166 CONTINUE - CALL COSGEN (JR,1,0.5,0.0,TCOS) - CALL TRIX (JR,0,MR,A,BB,C,B,TCOS,D,W) - DO 167 I=1,MR - Q(I,1) = .5*Q(I,1)-Q(I,JM1)+B(I) - 167 CONTINUE - GO TO 194 -C -C CASE OF GENERAL N WITH NR = 3 . -C - 168 DO 169 I=1,MR - B(I) = Q(I,2) - Q(I,2) = 0. - B2(I) = Q(I,3) - B3(I) = Q(I,1) - 169 CONTINUE - JR = 1 - I2R = 0 - J = 2 - GO TO 177 - 170 CONTINUE - DO 171 I=1,MR - B(I) = .5*Q(I,1)-Q(I,JM1)+Q(I,J) - 171 CONTINUE - IF (NROD .NE. 0) GO TO 173 - DO 172 I=1,MR - II = IP+I - B(I) = B(I)+P(II) - 172 CONTINUE - GO TO 175 - 173 DO 174 I=1,MR - B(I) = B(I)+Q(I,NLAST)-Q(I,JM2) - 174 CONTINUE - 175 CONTINUE - DO 176 I=1,MR - T = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) - Q(I,J) = T - B2(I) = Q(I,NLAST)+T - B3(I) = Q(I,1)+2.*T - 176 CONTINUE - 177 CONTINUE - K1 = KR+2*JR-1 - K2 = KR+JR - TCOS(K1+1) = -2. - K4 = K1+3-ISTAG - CALL COSGEN (K2+ISTAG-2,1,0.0,FNUM,TCOS(K4)) - K4 = K1+K2+1 - CALL COSGEN (JR-1,1,0.0,1.0,TCOS(K4)) - CALL S1MERG (TCOS,K1,K2,K1+K2,JR-1,0) - K3 = K1+K2+LR - CALL COSGEN (JR,1,0.5,0.0,TCOS(K3+1)) - K4 = K3+JR+1 - CALL COSGEN (KR,1,0.5,FDEN,TCOS(K4)) - CALL S1MERG (TCOS,K3,JR,K3+JR,KR,K1) - IF (LR .EQ. 0) GO TO 178 - CALL COSGEN (LR,1,0.5,FDEN,TCOS(K4)) - CALL S1MERG (TCOS,K3,JR,K3+JR,LR,K3-LR) - CALL COSGEN (KR,1,0.5,FDEN,TCOS(K4)) - 178 K3 = KR - K4 = KR - CALL TRI3 (MR,A,BB,C,K,B,B2,B3,TCOS,D,W,W2,W3) - DO 179 I=1,MR - B(I) = B(I)+B2(I)+B3(I) - 179 CONTINUE - TCOS(1) = 2. - CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) - DO 180 I=1,MR - Q(I,J) = Q(I,J)+B(I) - B(I) = Q(I,1)+2.*Q(I,J) - 180 CONTINUE - CALL COSGEN (JR,1,0.5,0.0,TCOS) - CALL TRIX (JR,0,MR,A,BB,C,B,TCOS,D,W) - IF (JR .NE. 1) GO TO 182 - DO 181 I=1,MR - Q(I,1) = B(I) - 181 CONTINUE - GO TO 194 - 182 CONTINUE - DO 183 I=1,MR - Q(I,1) = .5*Q(I,1)-Q(I,JM1)+B(I) - 183 CONTINUE - GO TO 194 - 184 CONTINUE - IF (N .NE. 2) GO TO 188 -C -C CASE N = 2 -C - DO 185 I=1,MR - B(I) = Q(I,1) - 185 CONTINUE - TCOS(1) = 0. - CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) - DO 186 I=1,MR - Q(I,1) = B(I) - B(I) = 2.*(Q(I,2)+B(I))*FISTAG - 186 CONTINUE - TCOS(1) = -FISTAG - TCOS(2) = 2. - CALL TRIX (2,0,MR,A,BB,C,B,TCOS,D,W) - DO 187 I=1,MR - Q(I,1) = Q(I,1)+B(I) - 187 CONTINUE - JR = 1 - I2R = 0 - GO TO 194 - 188 CONTINUE -C -C CASE OF GENERAL N AND NR = 2 . -C - DO 189 I=1,MR - II = IP+I - B3(I) = 0. - B(I) = Q(I,1)+2.*P(II) - Q(I,1) = .5*Q(I,1)-Q(I,JM1) - B2(I) = 2.*(Q(I,1)+Q(I,NLAST)) - 189 CONTINUE - K1 = KR+JR-1 - TCOS(K1+1) = -2. - K4 = K1+3-ISTAG - CALL COSGEN (KR+ISTAG-2,1,0.0,FNUM,TCOS(K4)) - K4 = K1+KR+1 - CALL COSGEN (JR-1,1,0.0,1.0,TCOS(K4)) - CALL S1MERG (TCOS,K1,KR,K1+KR,JR-1,0) - CALL COSGEN (KR,1,0.5,FDEN,TCOS(K1+1)) - K2 = KR - K4 = K1+K2+1 - CALL COSGEN (LR,1,0.5,FDEN,TCOS(K4)) - K3 = LR - K4 = 0 - CALL TRI3 (MR,A,BB,C,K,B,B2,B3,TCOS,D,W,W2,W3) - DO 190 I=1,MR - B(I) = B(I)+B2(I) - 190 CONTINUE - TCOS(1) = 2. - CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) - DO 191 I=1,MR - Q(I,1) = Q(I,1)+B(I) - 191 CONTINUE - GO TO 194 - 192 DO 193 I=1,MR - B(I) = Q(I,NLAST) - 193 CONTINUE - GO TO 196 - 194 CONTINUE -C -C START BACK SUBSTITUTION. -C - J = NLAST-JR - DO 195 I=1,MR - B(I) = Q(I,NLAST)+Q(I,J) - 195 CONTINUE - 196 JM2 = NLAST-I2R - IF (JR .NE. 1) GO TO 198 - DO 197 I=1,MR - Q(I,NLAST) = 0. - 197 CONTINUE - GO TO 202 - 198 CONTINUE - IF (NROD .NE. 0) GO TO 200 - DO 199 I=1,MR - II = IP+I - Q(I,NLAST) = P(II) - 199 CONTINUE - IP = IP-MR - GO TO 202 - 200 DO 201 I=1,MR - Q(I,NLAST) = Q(I,NLAST)-Q(I,JM2) - 201 CONTINUE - 202 CONTINUE - CALL COSGEN (KR,1,0.5,FDEN,TCOS) - CALL COSGEN (LR,1,0.5,FDEN,TCOS(KR+1)) - IF (LR .NE. 0) GO TO 204 - DO 203 I=1,MR - B(I) = FISTAG*B(I) - 203 CONTINUE - 204 CONTINUE - CALL TRIX (KR,LR,MR,A,BB,C,B,TCOS,D,W) - DO 205 I=1,MR - Q(I,NLAST) = Q(I,NLAST)+B(I) - 205 CONTINUE - NLASTP = NLAST - 206 CONTINUE - JSTEP = JR - JR = I2R - I2R = I2R/2 - IF (JR .EQ. 0) GO TO 222 - GO TO (207,208),MIXBND - 207 JSTART = 1+JR - GO TO 209 - 208 JSTART = JR - 209 CONTINUE - KR = KR-JR - IF (NLAST+JR .GT. N) GO TO 210 - KR = KR-JR - NLAST = NLAST+JR - JSTOP = NLAST-JSTEP - GO TO 211 - 210 CONTINUE - JSTOP = NLAST-JR - 211 CONTINUE - LR = KR-JR - CALL COSGEN (JR,1,0.5,0.0,TCOS) - DO 221 J=JSTART,JSTOP,JSTEP - JM2 = J-JR - JP2 = J+JR - IF (J .NE. JR) GO TO 213 - DO 212 I=1,MR - B(I) = Q(I,J)+Q(I,JP2) - 212 CONTINUE - GO TO 215 - 213 CONTINUE - DO 214 I=1,MR - B(I) = Q(I,J)+Q(I,JM2)+Q(I,JP2) - 214 CONTINUE - 215 CONTINUE - IF (JR .NE. 1) GO TO 217 - DO 216 I=1,MR - Q(I,J) = 0. - 216 CONTINUE - GO TO 219 - 217 CONTINUE - JM1 = J-I2R - JP1 = J+I2R - DO 218 I=1,MR - Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) - 218 CONTINUE - 219 CONTINUE - CALL TRIX (JR,0,MR,A,BB,C,B,TCOS,D,W) - DO 220 I=1,MR - Q(I,J) = Q(I,J)+B(I) - 220 CONTINUE - 221 CONTINUE - NROD = 1 - IF (NLAST+I2R .LE. N) NROD = 0 - IF (NLASTP .NE. NLAST) GO TO 194 - GO TO 206 - 222 CONTINUE -C -C RETURN STORAGE REQUIREMENTS FOR P VECTORS. -C - W(1) = IPSTOR - RETURN - END diff --git a/slatec/poisp2.f b/slatec/poisp2.f deleted file mode 100644 index 65bb04f..0000000 --- a/slatec/poisp2.f +++ /dev/null @@ -1,126 +0,0 @@ -*DECK POISP2 - SUBROUTINE POISP2 (M, N, A, BB, C, Q, IDIMQ, B, B2, B3, W, W2, W3, - + D, TCOS, P) -C***BEGIN PROLOGUE POISP2 -C***SUBSIDIARY -C***PURPOSE Subsidiary to GENBUN -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (POISP2-S, CMPOSP-C) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Subroutine to solve Poisson equation with periodic boundary -C conditions. -C -C***SEE ALSO GENBUN -C***ROUTINES CALLED POISD2, POISN2 -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE POISP2 -C - DIMENSION A(*) ,BB(*) ,C(*) ,Q(IDIMQ,*) , - 1 B(*) ,B2(*) ,B3(*) ,W(*) , - 2 W2(*) ,W3(*) ,D(*) ,TCOS(*) , - 3 P(*) -C***FIRST EXECUTABLE STATEMENT POISP2 - MR = M - NR = (N+1)/2 - NRM1 = NR-1 - IF (2*NR .NE. N) GO TO 107 -C -C EVEN NUMBER OF UNKNOWNS -C - DO 102 J=1,NRM1 - NRMJ = NR-J - NRPJ = NR+J - DO 101 I=1,MR - S = Q(I,NRMJ)-Q(I,NRPJ) - T = Q(I,NRMJ)+Q(I,NRPJ) - Q(I,NRMJ) = S - Q(I,NRPJ) = T - 101 CONTINUE - 102 CONTINUE - DO 103 I=1,MR - Q(I,NR) = 2.*Q(I,NR) - Q(I,N) = 2.*Q(I,N) - 103 CONTINUE - CALL POISD2 (MR,NRM1,1,A,BB,C,Q,IDIMQ,B,W,D,TCOS,P) - IPSTOR = W(1) - CALL POISN2 (MR,NR+1,1,1,A,BB,C,Q(1,NR),IDIMQ,B,B2,B3,W,W2,W3,D, - 1 TCOS,P) - IPSTOR = MAX(IPSTOR,INT(W(1))) - DO 105 J=1,NRM1 - NRMJ = NR-J - NRPJ = NR+J - DO 104 I=1,MR - S = .5*(Q(I,NRPJ)+Q(I,NRMJ)) - T = .5*(Q(I,NRPJ)-Q(I,NRMJ)) - Q(I,NRMJ) = S - Q(I,NRPJ) = T - 104 CONTINUE - 105 CONTINUE - DO 106 I=1,MR - Q(I,NR) = .5*Q(I,NR) - Q(I,N) = .5*Q(I,N) - 106 CONTINUE - GO TO 118 - 107 CONTINUE -C -C ODD NUMBER OF UNKNOWNS -C - DO 109 J=1,NRM1 - NRPJ = N+1-J - DO 108 I=1,MR - S = Q(I,J)-Q(I,NRPJ) - T = Q(I,J)+Q(I,NRPJ) - Q(I,J) = S - Q(I,NRPJ) = T - 108 CONTINUE - 109 CONTINUE - DO 110 I=1,MR - Q(I,NR) = 2.*Q(I,NR) - 110 CONTINUE - LH = NRM1/2 - DO 112 J=1,LH - NRMJ = NR-J - DO 111 I=1,MR - S = Q(I,J) - Q(I,J) = Q(I,NRMJ) - Q(I,NRMJ) = S - 111 CONTINUE - 112 CONTINUE - CALL POISD2 (MR,NRM1,2,A,BB,C,Q,IDIMQ,B,W,D,TCOS,P) - IPSTOR = W(1) - CALL POISN2 (MR,NR,2,1,A,BB,C,Q(1,NR),IDIMQ,B,B2,B3,W,W2,W3,D, - 1 TCOS,P) - IPSTOR = MAX(IPSTOR,INT(W(1))) - DO 114 J=1,NRM1 - NRPJ = NR+J - DO 113 I=1,MR - S = .5*(Q(I,NRPJ)+Q(I,J)) - T = .5*(Q(I,NRPJ)-Q(I,J)) - Q(I,NRPJ) = T - Q(I,J) = S - 113 CONTINUE - 114 CONTINUE - DO 115 I=1,MR - Q(I,NR) = .5*Q(I,NR) - 115 CONTINUE - DO 117 J=1,LH - NRMJ = NR-J - DO 116 I=1,MR - S = Q(I,J) - Q(I,J) = Q(I,NRMJ) - Q(I,NRMJ) = S - 116 CONTINUE - 117 CONTINUE - 118 CONTINUE -C -C RETURN STORAGE REQUIREMENTS FOR P VECTORS. -C - W(1) = IPSTOR - RETURN - END diff --git a/slatec/poistg.f b/slatec/poistg.f deleted file mode 100644 index e1deb5e..0000000 --- a/slatec/poistg.f +++ /dev/null @@ -1,354 +0,0 @@ -*DECK POISTG - SUBROUTINE POISTG (NPEROD, N, MPEROD, M, A, B, C, IDIMY, Y, - + IERROR, W) -C***BEGIN PROLOGUE POISTG -C***PURPOSE Solve a block tridiagonal system of linear equations -C that results from a staggered grid finite difference -C approximation to 2-D elliptic PDE's. -C***LIBRARY SLATEC (FISHPACK) -C***CATEGORY I2B4B -C***TYPE SINGLE PRECISION (POISTG-S) -C***KEYWORDS ELLIPTIC, FISHPACK, HELMHOLTZ, PDE, TRIDIAGONAL -C***AUTHOR Adams, J., (NCAR) -C Swarztrauber, P. N., (NCAR) -C Sweet, R., (NCAR) -C***DESCRIPTION -C -C Subroutine POISTG solves the linear system of equations -C -C A(I)*X(I-1,J) + B(I)*X(I,J) + C(I)*X(I+1,J) -C + X(I,J-1) - 2.*X(I,J) + X(I,J+1) = Y(I,J) -C -C for I=1,2,...,M and J=1,2,...,N. -C -C The indices I+1 and I-1 are evaluated modulo M, i.e. -C X(0,J) = X(M,J) and X(M+1,J) = X(1,J), and X(I,0) may be equal to -C X(I,1) or -X(I,1) and X(I,N+1) may be equal to X(I,N) or -X(I,N) -C depending on an input parameter. -C -C -C * * * * * * * * Parameter Description * * * * * * * * * * -C -C * * * * * * On Input * * * * * * -C -C NPEROD -C Indicates the values which X(I,0) and X(I,N+1) are assumed -C to have. -C = 1 If X(I,0) = -X(I,1) and X(I,N+1) = -X(I,N) -C = 2 If X(I,0) = -X(I,1) and X(I,N+1) = X(I,N) -C = 3 If X(I,0) = X(I,1) and X(I,N+1) = X(I,N) -C = 4 If X(I,0) = X(I,1) and X(I,N+1) = -X(I,N) -C -C N -C The number of unknowns in the J-direction. N must -C be greater than 2. -C -C MPEROD -C = 0 If A(1) and C(M) are not zero -C = 1 If A(1) = C(M) = 0 -C -C M -C The number of unknowns in the I-direction. M must -C be greater than 2. -C -C A,B,C -C One-dimensional arrays of length M that specify the coefficients -C in the linear equations given above. If MPEROD = 0 the array -C elements must not depend on the index I, but must be constant. -C Specifically, the subroutine checks the following condition -C -C A(I) = C(1) -C B(I) = B(1) -C C(I) = C(1) -C -C for I = 1, 2, ..., M. -C -C IDIMY -C The row (or first) dimension of the two-dimensional array Y as -C it appears in the program calling POISTG. This parameter is -C used to specify the variable dimension of Y. IDIMY must be at -C least M. -C -C Y -C A two-dimensional array that specifies the values of the -C right side of the linear system of equations given above. -C Y must be dimensioned at least M X N. -C -C W -C A one-dimensional work array that must be provided by the user -C for work space. W may require up to 9M + 4N + M(INT(log2(N))) -C locations. The actual number of locations used is computed by -C POISTG and returned in location W(1). -C -C -C * * * * * * On Output * * * * * * -C -C Y -C Contains the solution X. -C -C IERROR -C An error flag that indicates invalid input parameters. Except -C for number zero, a solution is not attempted. -C = 0 No error -C = 1 If M .LE. 2 -C = 2 If N .LE. 2 -C = 3 IDIMY .LT. M -C = 4 If NPEROD .LT. 1 or NPEROD .GT. 4 -C = 5 If MPEROD .LT. 0 or MPEROD .GT. 1 -C = 6 If MPEROD = 0 and -C A(I) .NE. C(1) or B(I) .NE. B(1) or C(I) .NE. C(1) -C for some I = 1, 2, ..., M. -C = 7 If MPEROD .EQ. 1 .AND. (A(1).NE.0 .OR. C(M).NE.0) -C -C W -C W(1) contains the required length of W. -C -C *Long Description: -C -C * * * * * * * Program Specifications * * * * * * * * * * * * -C -C Dimension of A(M),B(M),C(M),Y(IDIMY,N), -C Arguments W(see argument list) -C -C Latest June 1, 1977 -C Revision -C -C Subprograms POISTG,POSTG2,COSGEN,MERGE,TRIX,TRI3,PIMACH -C Required -C -C Special NONE -C Conditions -C -C Common NONE -C Blocks -C -C I/O NONE -C -C Precision Single -C -C Specialist Roland Sweet -C -C Language FORTRAN -C -C History Written by Roland Sweet in 1973 -C Revised by Roland Sweet in 1977 -C -C -C Space 3297(decimal) = 6341(octal) locations on the -C Required NCAR Control Data 7600 -C -C Timing and The execution time T on the NCAR Control Data -C Accuracy 7600 for subroutine POISTG is roughly proportional -C to M*N*log2(N). Some typical values are listed -C in the table below. More comprehensive timing -C charts may be found in the reference. -C To measure the accuracy of the algorithm a -C uniform random number generator was used to create -C a solution array X for the system given in the -C 'PURPOSE ' with -C -C A(I) = C(I) = -0.5*B(I) = 1, I=1,2,...,M -C -C and, when MPEROD = 1 -C -C A(1) = C(M) = 0 -C B(1) = B(M) =-1. -C -C The solution X was substituted into the given sys- -C tem and, using double precision, a right side Y was -C computed. Using this array Y subroutine POISTG was -C called to produce an approximate solution Z. Then -C the relative error, defined as -C -C E = MAX(ABS(Z(I,J)-X(I,J)))/MAX(ABS(X(I,J))) -C -C where the two maxima are taken over all I=1,2,...,M -C and J=1,2,...,N, was computed. The value of E is -C given in the table below for some typical values of -C M and N. -C -C -C M (=N) MPEROD NPEROD T(MSECS) E -C ------ ------ ------ -------- ------ -C -C 31 0-1 1-4 45 9.E-13 -C 31 1 1 21 4.E-13 -C 31 1 3 41 3.E-13 -C 32 0-1 1-4 51 3.E-12 -C 32 1 1 32 3.E-13 -C 32 1 3 48 1.E-13 -C 33 0-1 1-4 42 1.E-12 -C 33 1 1 30 4.E-13 -C 33 1 3 34 1.E-13 -C 63 0-1 1-4 186 3.E-12 -C 63 1 1 91 1.E-12 -C 63 1 3 173 2.E-13 -C 64 0-1 1-4 209 4.E-12 -C 64 1 1 128 1.E-12 -C 64 1 3 199 6.E-13 -C 65 0-1 1-4 143 2.E-13 -C 65 1 1 160 1.E-11 -C 65 1 3 138 4.E-13 -C -C Portability American National Standards Institute FORTRAN. -C The machine dependent constant PI is defined in -C function PIMACH. -C -C Required COS -C Resident -C Routines -C -C Reference Schumann, U. and R. Sweet,'A Direct Method for -C the Solution of Poisson's Equation With Neumann -C Boundary Conditions on a Staggered Grid of -C Arbitrary Size,' J. Comp. Phys. 20(1976), -C pp. 171-182. -C -C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -C -C***REFERENCES U. Schumann and R. Sweet, A direct method for the -C solution of Poisson's equation with Neumann boundary -C conditions on a staggered grid of arbitrary size, -C Journal of Computational Physics 20, (1976), -C pp. 171-182. -C***ROUTINES CALLED POSTG2 -C***REVISION HISTORY (YYMMDD) -C 801001 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 POISTG -C -C - DIMENSION Y(IDIMY,*) - DIMENSION W(*) ,B(*) ,A(*) ,C(*) -C***FIRST EXECUTABLE STATEMENT POISTG - IERROR = 0 - IF (M .LE. 2) IERROR = 1 - IF (N .LE. 2) IERROR = 2 - IF (IDIMY .LT. M) IERROR = 3 - IF (NPEROD.LT.1 .OR. NPEROD.GT.4) IERROR = 4 - IF (MPEROD.LT.0 .OR. MPEROD.GT.1) IERROR = 5 - IF (MPEROD .EQ. 1) GO TO 103 - DO 101 I=1,M - IF (A(I) .NE. C(1)) GO TO 102 - IF (C(I) .NE. C(1)) GO TO 102 - IF (B(I) .NE. B(1)) GO TO 102 - 101 CONTINUE - GO TO 104 - 102 IERROR = 6 - RETURN - 103 IF (A(1).NE.0. .OR. C(M).NE.0.) IERROR = 7 - 104 IF (IERROR .NE. 0) RETURN - IWBA = M+1 - IWBB = IWBA+M - IWBC = IWBB+M - IWB2 = IWBC+M - IWB3 = IWB2+M - IWW1 = IWB3+M - IWW2 = IWW1+M - IWW3 = IWW2+M - IWD = IWW3+M - IWTCOS = IWD+M - IWP = IWTCOS+4*N - DO 106 I=1,M - K = IWBA+I-1 - W(K) = -A(I) - K = IWBC+I-1 - W(K) = -C(I) - K = IWBB+I-1 - W(K) = 2.-B(I) - DO 105 J=1,N - Y(I,J) = -Y(I,J) - 105 CONTINUE - 106 CONTINUE - NP = NPEROD - MP = MPEROD+1 - GO TO (110,107),MP - 107 CONTINUE - GO TO (108,108,108,119),NPEROD - 108 CONTINUE - CALL POSTG2 (NP,N,M,W(IWBA),W(IWBB),W(IWBC),IDIMY,Y,W,W(IWB2), - 1 W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS), - 2 W(IWP)) - IPSTOR = W(IWW1) - IREV = 2 - IF (NPEROD .EQ. 4) GO TO 120 - 109 CONTINUE - GO TO (123,129),MP - 110 CONTINUE -C -C REORDER UNKNOWNS WHEN MP =0 -C - MH = (M+1)/2 - MHM1 = MH-1 - MODD = 1 - IF (MH*2 .EQ. M) MODD = 2 - DO 115 J=1,N - DO 111 I=1,MHM1 - MHPI = MH+I - MHMI = MH-I - W(I) = Y(MHMI,J)-Y(MHPI,J) - W(MHPI) = Y(MHMI,J)+Y(MHPI,J) - 111 CONTINUE - W(MH) = 2.*Y(MH,J) - GO TO (113,112),MODD - 112 W(M) = 2.*Y(M,J) - 113 CONTINUE - DO 114 I=1,M - Y(I,J) = W(I) - 114 CONTINUE - 115 CONTINUE - K = IWBC+MHM1-1 - I = IWBA+MHM1 - W(K) = 0. - W(I) = 0. - W(K+1) = 2.*W(K+1) - GO TO (116,117),MODD - 116 CONTINUE - K = IWBB+MHM1-1 - W(K) = W(K)-W(I-1) - W(IWBC-1) = W(IWBC-1)+W(IWBB-1) - GO TO 118 - 117 W(IWBB-1) = W(K+1) - 118 CONTINUE - GO TO 107 - 119 CONTINUE -C -C REVERSE COLUMNS WHEN NPEROD = 4. -C - IREV = 1 - NBY2 = N/2 - NP = 2 - 120 DO 122 J=1,NBY2 - MSKIP = N+1-J - DO 121 I=1,M - A1 = Y(I,J) - Y(I,J) = Y(I,MSKIP) - Y(I,MSKIP) = A1 - 121 CONTINUE - 122 CONTINUE - GO TO (108,109),IREV - 123 CONTINUE - DO 128 J=1,N - DO 124 I=1,MHM1 - MHMI = MH-I - MHPI = MH+I - W(MHMI) = .5*(Y(MHPI,J)+Y(I,J)) - W(MHPI) = .5*(Y(MHPI,J)-Y(I,J)) - 124 CONTINUE - W(MH) = .5*Y(MH,J) - GO TO (126,125),MODD - 125 W(M) = .5*Y(M,J) - 126 CONTINUE - DO 127 I=1,M - Y(I,J) = W(I) - 127 CONTINUE - 128 CONTINUE - 129 CONTINUE -C -C RETURN STORAGE REQUIREMENTS FOR W ARRAY. -C - W(1) = IPSTOR+IWP-1 - RETURN - END diff --git a/slatec/polcof.f b/slatec/polcof.f deleted file mode 100644 index 6fb279c..0000000 --- a/slatec/polcof.f +++ /dev/null @@ -1,94 +0,0 @@ -*DECK POLCOF - SUBROUTINE POLCOF (XX, N, X, C, D, WORK) -C***BEGIN PROLOGUE POLCOF -C***PURPOSE Compute the coefficients of the polynomial fit (including -C Hermite polynomial fits) produced by a previous call to -C POLINT. -C***LIBRARY SLATEC -C***CATEGORY E1B -C***TYPE SINGLE PRECISION (POLCOF-S, DPOLCF-D) -C***KEYWORDS COEFFICIENTS, POLYNOMIAL -C***AUTHOR Huddleston, R. E., (SNLL) -C***DESCRIPTION -C -C Written by Robert E. Huddleston, Sandia Laboratories, Livermore -C -C Abstract -C Subroutine POLCOF computes the coefficients of the polynomial -C fit (including Hermite polynomial fits ) produced by a previous -C call to POLINT. The coefficients of the polynomial, expanded about -C XX, are stored in the array D. The expansion is of the form -C P(Z) = D(1) + D(2)*(Z-XX) +D(3)*((Z-XX)**2) + ... + -C D(N)*((Z-XX)**(N-1)). -C Between the call to POLINT and the call to POLCOF the variable N -C and the arrays X and C must not be altered. -C -C ***** INPUT PARAMETERS -C -C XX - The point about which the Taylor expansion is to be made. -C -C N - **** -C * N, X, and C must remain unchanged between the -C X - * call to POLINT or the call to POLCOF. -C C - **** -C -C ***** OUTPUT PARAMETER -C -C D - The array of coefficients for the Taylor expansion as -C explained in the abstract -C -C ***** STORAGE PARAMETER -C -C WORK - This is an array to provide internal working storage. It -C must be dimensioned by at least 2*N in the calling program. -C -C -C **** Note - There are two methods for evaluating the fit produced -C by POLINT. You may call POLYVL to perform the task, or you may -C call POLCOF to obtain the coefficients of the Taylor expansion and -C then write your own evaluation scheme. Due to the inherent errors -C in the computations of the Taylor expansion from the Newton -C coefficients produced by POLINT, much more accuracy may be -C expected by calling POLYVL as opposed to writing your own scheme. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 890213 DATE WRITTEN -C 891024 Corrected KEYWORD section. (WRB) -C 891024 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE POLCOF -C - DIMENSION X(*), C(*), D(*), WORK(*) -C***FIRST EXECUTABLE STATEMENT POLCOF - DO 10010 K=1,N - D(K)=C(K) -10010 CONTINUE - IF (N.EQ.1) RETURN - WORK(1)=1.0 - PONE=C(1) - NM1=N-1 - DO 10020 K=2,N - KM1=K-1 - NPKM1=N+K-1 - WORK(NPKM1)=XX-X(KM1) - WORK(K)=WORK(NPKM1)*WORK(KM1) - PTWO=PONE+WORK(K)*C(K) - PONE=PTWO -10020 CONTINUE - D(1)=PTWO - IF (N.EQ.2) RETURN - DO 10030 K=2,NM1 - KM1=K-1 - KM2N=K-2+N - NMKP1=N-K+1 - DO 10030 I=2,NMKP1 - KM2NPI=KM2N+I - IM1=I-1 - KM1PI=KM1+I - WORK(I)=WORK(KM2NPI)*WORK(IM1)+WORK(I) - D(K)=D(K)+WORK(I)*D(KM1PI) -10030 CONTINUE - RETURN - END diff --git a/slatec/polfit.f b/slatec/polfit.f deleted file mode 100644 index 12427b1..0000000 --- a/slatec/polfit.f +++ /dev/null @@ -1,352 +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(*) - 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/ -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 - XM = M - ETST = EPS*EPS*XM - IF (W(1) .LT. 0.0) GO TO 2 - DO 1 I = 1,M - IF (W(I) .LE. 0.0) GO TO 30 - 1 CONTINUE - GO TO 4 - 2 DO 3 I = 1,M - 3 W(I) = 1.0 - 4 IF (EPS .GE. 0.0) 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. (-.55)) 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. (-.03)) KSIG = 2 - IF (EPS .LT. (-.07)) 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.0 - W11 = 0.0 - IF (N .LT. 0) GO TO 11 -C -C UNCONSTRAINED CASE -C - DO 10 I = 1,M - K4PI = K4 + I - A(K4PI) = 1.0 - 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 + DBLE(W(I))*DBLE(Y(I))*DBLE(A(K4PI)) - 14 CONTINUE - TEMD1 = TEMD1/DBLE(W11) - A(K2+1) = TEMD1 - SIGJ = 0.0 - DO 15 I = 1,M - K4PI = K4 + I - K5PI = K5 + I - TEMD2 = TEMD1*DBLE(A(K4PI)) - R(I) = TEMD2 - A(K5PI) = TEMD2 - DBLE(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 + 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 - 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 -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', 'POLFIT', '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 PVALUE (NDEG,NDER,X(I),R(I),YP,A) - 35 CONTINUE - 36 EPS = SQRT(SIG/XM) - 37 RETURN - END diff --git a/slatec/polint.f b/slatec/polint.f deleted file mode 100644 index d2cc3f9..0000000 --- a/slatec/polint.f +++ /dev/null @@ -1,62 +0,0 @@ -*DECK POLINT - SUBROUTINE POLINT (N, X, Y, C) -C***BEGIN PROLOGUE POLINT -C***PURPOSE Produce the polynomial which interpolates a set of discrete -C data points. -C***LIBRARY SLATEC -C***CATEGORY E1B -C***TYPE SINGLE PRECISION (POLINT-S, DPLINT-D) -C***KEYWORDS POLYNOMIAL INTERPOLATION -C***AUTHOR Huddleston, R. E., (SNLL) -C***DESCRIPTION -C -C Written by Robert E. Huddleston, Sandia Laboratories, Livermore -C -C Abstract -C Subroutine POLINT is designed to produce the polynomial which -C interpolates the data (X(I),Y(I)), I=1,...,N. POLINT sets up -C information in the array C which can be used by subroutine POLYVL -C to evaluate the polynomial and its derivatives and by subroutine -C POLCOF to produce the coefficients. -C -C Formal Parameters -C N - the number of data points (N .GE. 1) -C X - the array of abscissas (all of which must be distinct) -C Y - the array of ordinates -C C - an array of information used by subroutines -C ******* Dimensioning Information ******* -C Arrays X,Y, and C must be dimensioned at least N in the calling -C 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 861211 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***END PROLOGUE POLINT - DIMENSION X(*),Y(*),C(*) -C***FIRST EXECUTABLE STATEMENT POLINT - IF (N .LE. 0) GO TO 91 - C(1)=Y(1) - IF(N .EQ. 1) RETURN - DO 10010 K=2,N - C(K)=Y(K) - KM1=K-1 - DO 10010 I=1,KM1 -C CHECK FOR DISTINCT X VALUES - DIF = X(I)-X(K) - IF (DIF .EQ. 0.0) GO TO 92 - C(K) = (C(I)-C(K))/DIF -10010 CONTINUE - RETURN - 91 CALL XERMSG ('SLATEC', 'POLINT', 'N IS ZERO OR NEGATIVE.', 2, 1) - RETURN - 92 CALL XERMSG ('SLATEC', 'POLINT', - + 'THE ABSCISSAS ARE NOT DISTINCT.', 2, 1) - RETURN - END diff --git a/slatec/polyvl.f b/slatec/polyvl.f deleted file mode 100644 index b87b868..0000000 --- a/slatec/polyvl.f +++ /dev/null @@ -1,203 +0,0 @@ -*DECK POLYVL - SUBROUTINE POLYVL (NDER, XX, YFIT, YP, N, X, C, WORK, IERR) -C***BEGIN PROLOGUE POLYVL -C***PURPOSE Calculate the value of a polynomial and its first NDER -C derivatives where the polynomial was produced by a previous -C call to POLINT. -C***LIBRARY SLATEC -C***CATEGORY E3 -C***TYPE SINGLE PRECISION (POLYVL-S, DPOLVL-D) -C***KEYWORDS POLYNOMIAL EVALUATION -C***AUTHOR Huddleston, R. E., (SNLL) -C***DESCRIPTION -C -C Written by Robert E. Huddleston, Sandia Laboratories, Livermore -C -C Abstract - -C Subroutine POLYVL calculates the value of the polynomial and -C its first NDER derivatives where the polynomial was produced by -C a previous call to POLINT. -C The variable N and the arrays X and C must not be altered -C between the call to POLINT and the call to POLYVL. -C -C ****** Dimensioning Information ******* -C -C YP must be dimensioned by at least NDER -C X must be dimensioned by at least N (see the abstract ) -C C must be dimensioned by at least N (see the abstract ) -C WORK must be dimensioned by at least 2*N if NDER is .GT. 0. -C -C *** Note *** -C If NDER=0, neither YP nor WORK need to be dimensioned variables. -C If NDER=1, YP does not need to be a dimensioned variable. -C -C -C ***** Input parameters -C -C NDER - the number of derivatives to be evaluated -C -C XX - the argument at which the polynomial and its derivatives -C are to be evaluated. -C -C N - ***** -C * N, X, and C must not be altered between the call -C X - * to POLINT and the call to POLYVL. -C C - ***** -C -C -C ***** Output Parameters -C -C YFIT - the value of the polynomial at XX -C -C YP - the derivatives of the polynomial at XX. The derivative of -C order J at XX is stored in YP(J) , J = 1,...,NDER. -C -C IERR - Output error flag with the following possible values. -C = 1 indicates normal execution -C -C ***** Storage Parameters -C -C WORK = this is an array to provide internal working storage for -C POLYVL. It must be dimensioned by at least 2*N if NDER is -C .GT. 0. If NDER=0, WORK does not need to be a dimensioned -C variable. -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 (NONE) -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 POLYVL - DIMENSION YP(*),X(*),C(*),WORK(*) -C***FIRST EXECUTABLE STATEMENT POLYVL - IERR=1 - IF (NDER.GT.0) GO TO 10020 -C -C ***** CODING FOR THE CASE NDER = 0 -C - PIONE=1.0 - PONE=C(1) - YFIT=PONE - IF (N.EQ.1) RETURN - DO 10010 K=2,N - PITWO=(XX-X(K-1))*PIONE - PIONE=PITWO - PTWO=PONE+PITWO*C(K) - PONE=PTWO -10010 CONTINUE - YFIT=PTWO - RETURN -C -C ***** END OF NDER = 0 CASE -C -10020 CONTINUE - IF (N.GT.1) GO TO 10040 - YFIT=C(1) -C -C ***** CODING FOR THE CASE N=1 AND NDER .GT. 0 -C - DO 10030 K=1,NDER - YP(K)=0.0 -10030 CONTINUE - RETURN -C -C ***** END OF THE CASE N = 1 AND NDER .GT. 0 -C -10040 CONTINUE - IF (NDER.LT.N) GO TO 10050 -C -C ***** SET FLAGS FOR NUMBER OF DERIVATIVES AND FOR DERIVATIVES -C IN EXCESS OF THE DEGREE (N-1) OF THE POLYNOMIAL. -C - IZERO=1 - NDR=N-1 - GO TO 10060 -10050 CONTINUE - IZERO=0 - NDR=NDER -10060 CONTINUE - M=NDR+1 - MM=M -C -C ***** START OF THE CASE NDER .GT. 0 AND N .GT. 1 -C ***** THE POLYNOMIAL AND ITS DERIVATIVES WILL BE EVALUATED AT XX -C - DO 10070 K=1,NDR - YP(K)=C(K+1) -10070 CONTINUE -C -C ***** THE FOLLOWING SECTION OF CODE IS EASIER TO READ IF ONE -C BREAKS WORK INTO TWO ARRAYS W AND V. THE CODE WOULD THEN -C READ -C W(1) = 1. -C PONE = C(1) -C *DO K = 2,N -C * V(K-1) = XX - X(K-1) -C * W(K) = V(K-1)*W(K-1) -C * PTWO = PONE + W(K)*C(K) -C * PONE = PWO -C -C YFIT = PTWO -C - WORK(1)=1.0 - PONE=C(1) - DO 10080 K=2,N - KM1=K-1 - NPKM1=N+K-1 - WORK(NPKM1)=XX-X(KM1) - WORK(K)=WORK(NPKM1)*WORK(KM1) - PTWO=PONE+WORK(K)*C(K) - PONE=PTWO -10080 CONTINUE - YFIT=PTWO -C -C ** AT THIS POINT THE POLYNOMIAL HAS BEEN EVALUATED AND INFORMATION -C FOR THE DERIVATIVE EVALUATIONS HAVE BEEN STORED IN THE ARRAY -C WORK - IF (N.EQ.2) GO TO 10110 - IF (M.EQ.N) MM=NDR -C -C ***** EVALUATE THE DERIVATIVES AT XX -C -C ****** DO K=2,MM (FOR MOST CASES, MM = NDER + 1) -C * ****** DO I=2,N-K+1 -C * * W(I) = V(K-2+I)*W(I-1) + W(I) -C * * YP(K-1) = YP(K-1) + W(I)*C(K-1+I) -C ****** CONTINUE -C - DO 10090 K=2,MM - NMKP1=N-K+1 - KM1=K-1 - KM2PN=K-2+N - DO 10090 I=2,NMKP1 - KM2PNI=KM2PN+I - IM1=I-1 - KM1PI=KM1+I - WORK(I)=WORK(KM2PNI)*WORK(IM1)+WORK(I) - YP(KM1)=YP(KM1)+WORK(I)*C(KM1PI) -10090 CONTINUE - IF (NDR.EQ.1) GO TO 10110 - FAC=1.0 - DO 10100 K=2,NDR - XK=K - FAC=XK*FAC - YP(K)=FAC*YP(K) -10100 CONTINUE -C -C ***** END OF DERIVATIVE EVALUATIONS -C -10110 CONTINUE - IF (IZERO.EQ.0) RETURN -C -C ***** SET EXCESS DERIVATIVES TO ZERO. -C - DO 10120 K=N,NDER - YP(K)=0.0 -10120 CONTINUE - RETURN - END diff --git a/slatec/pos3d1.f b/slatec/pos3d1.f deleted file mode 100644 index fcd8790..0000000 --- a/slatec/pos3d1.f +++ /dev/null @@ -1,194 +0,0 @@ -*DECK POS3D1 - SUBROUTINE POS3D1 (LP, L, MP, M, N, A, B, C, LDIMF, MDIMF, F, XRT, - + YRT, T, D, WX, WY, C1, C2, BB) -C***BEGIN PROLOGUE POS3D1 -C***SUBSIDIARY -C***PURPOSE Subsidiary to POIS3D -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (POS3D1-S) -C***AUTHOR (UNKNOWN) -C***SEE ALSO POIS3D -C***ROUTINES CALLED COSQB, COSQF, COSQI, COST, COSTI, PIMACH, RFFTB, -C RFFTF, RFFTI, SINQB, SINQF, SINQI, SINT, SINTI, -C TRIDQ -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891009 Removed unreferenced variable. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900308 Changed call to TRID to call to TRIDQ. (WRB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE POS3D1 - DIMENSION A(*) ,B(*) ,C(*) , - 1 F(LDIMF,MDIMF,*) ,XRT(*) ,YRT(*) , - 2 T(*) ,D(*) ,WX(*) ,WY(*) , - 3 BB(*) -C***FIRST EXECUTABLE STATEMENT POS3D1 - PI = PIMACH(DUM) - LR = L - MR = M - NR = N -C -C GENERATE TRANSFORM ROOTS -C - LRDEL = ((LP-1)*(LP-3)*(LP-5))/3 - SCALX = LR+LRDEL - DX = PI/(2.*SCALX) - GO TO (108,103,101,102,101),LP - 101 DI = 0.5 - SCALX = 2.*SCALX - GO TO 104 - 102 DI = 1.0 - GO TO 104 - 103 DI = 0.0 - 104 DO 105 I=1,LR - XRT(I) = -4.*C1*(SIN((I-DI)*DX))**2 - 105 CONTINUE - SCALX = 2.*SCALX - GO TO (112,106,110,107,111),LP - 106 CALL SINTI (LR,WX) - GO TO 112 - 107 CALL COSTI (LR,WX) - GO TO 112 - 108 XRT(1) = 0. - XRT(LR) = -4.*C1 - DO 109 I=3,LR,2 - XRT(I-1) = -4.*C1*(SIN((I-1)*DX))**2 - XRT(I) = XRT(I-1) - 109 CONTINUE - CALL RFFTI (LR,WX) - GO TO 112 - 110 CALL SINQI (LR,WX) - GO TO 112 - 111 CALL COSQI (LR,WX) - 112 CONTINUE - MRDEL = ((MP-1)*(MP-3)*(MP-5))/3 - SCALY = MR+MRDEL - DY = PI/(2.*SCALY) - GO TO (120,115,113,114,113),MP - 113 DJ = 0.5 - SCALY = 2.*SCALY - GO TO 116 - 114 DJ = 1.0 - GO TO 116 - 115 DJ = 0.0 - 116 DO 117 J=1,MR - YRT(J) = -4.*C2*(SIN((J-DJ)*DY))**2 - 117 CONTINUE - SCALY = 2.*SCALY - GO TO (124,118,122,119,123),MP - 118 CALL SINTI (MR,WY) - GO TO 124 - 119 CALL COSTI (MR,WY) - GO TO 124 - 120 YRT(1) = 0. - YRT(MR) = -4.*C2 - DO 121 J=3,MR,2 - YRT(J-1) = -4.*C2*(SIN((J-1)*DY))**2 - YRT(J) = YRT(J-1) - 121 CONTINUE - CALL RFFTI (MR,WY) - GO TO 124 - 122 CALL SINQI (MR,WY) - GO TO 124 - 123 CALL COSQI (MR,WY) - 124 CONTINUE - IFWRD = 1 - 125 CONTINUE -C -C TRANSFORM X -C - DO 141 J=1,MR - DO 140 K=1,NR - DO 126 I=1,LR - T(I) = F(I,J,K) - 126 CONTINUE - GO TO (127,130,131,134,135),LP - 127 GO TO (128,129),IFWRD - 128 CALL RFFTF (LR,T,WX) - GO TO 138 - 129 CALL RFFTB (LR,T,WX) - GO TO 138 - 130 CALL SINT (LR,T,WX) - GO TO 138 - 131 GO TO (132,133),IFWRD - 132 CALL SINQF (LR,T,WX) - GO TO 138 - 133 CALL SINQB (LR,T,WX) - GO TO 138 - 134 CALL COST (LR,T,WX) - GO TO 138 - 135 GO TO (136,137),IFWRD - 136 CALL COSQF (LR,T,WX) - GO TO 138 - 137 CALL COSQB (LR,T,WX) - 138 CONTINUE - DO 139 I=1,LR - F(I,J,K) = T(I) - 139 CONTINUE - 140 CONTINUE - 141 CONTINUE - GO TO (142,164),IFWRD -C -C TRANSFORM Y -C - 142 CONTINUE - DO 158 I=1,LR - DO 157 K=1,NR - DO 143 J=1,MR - T(J) = F(I,J,K) - 143 CONTINUE - GO TO (144,147,148,151,152),MP - 144 GO TO (145,146),IFWRD - 145 CALL RFFTF (MR,T,WY) - GO TO 155 - 146 CALL RFFTB (MR,T,WY) - GO TO 155 - 147 CALL SINT (MR,T,WY) - GO TO 155 - 148 GO TO (149,150),IFWRD - 149 CALL SINQF (MR,T,WY) - GO TO 155 - 150 CALL SINQB (MR,T,WY) - GO TO 155 - 151 CALL COST (MR,T,WY) - GO TO 155 - 152 GO TO (153,154),IFWRD - 153 CALL COSQF (MR,T,WY) - GO TO 155 - 154 CALL COSQB (MR,T,WY) - 155 CONTINUE - DO 156 J=1,MR - F(I,J,K) = T(J) - 156 CONTINUE - 157 CONTINUE - 158 CONTINUE - GO TO (159,125),IFWRD - 159 CONTINUE -C -C SOLVE TRIDIAGONAL SYSTEMS IN Z -C - DO 163 I=1,LR - DO 162 J=1,MR - DO 160 K=1,NR - BB(K) = B(K)+XRT(I)+YRT(J) - T(K) = F(I,J,K) - 160 CONTINUE - CALL TRIDQ (NR,A,BB,C,T,D) - DO 161 K=1,NR - F(I,J,K) = T(K) - 161 CONTINUE - 162 CONTINUE - 163 CONTINUE - IFWRD = 2 - GO TO 142 - 164 CONTINUE - DO 167 I=1,LR - DO 166 J=1,MR - DO 165 K=1,NR - F(I,J,K) = F(I,J,K)/(SCALX*SCALY) - 165 CONTINUE - 166 CONTINUE - 167 CONTINUE - RETURN - END diff --git a/slatec/postg2.f b/slatec/postg2.f deleted file mode 100644 index 2c728b8..0000000 --- a/slatec/postg2.f +++ /dev/null @@ -1,542 +0,0 @@ -*DECK POSTG2 - SUBROUTINE POSTG2 (NPEROD, N, M, A, BB, C, IDIMQ, Q, B, B2, B3, W, - + W2, W3, D, TCOS, P) -C***BEGIN PROLOGUE POSTG2 -C***SUBSIDIARY -C***PURPOSE Subsidiary to POISTG -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (POSTG2-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Subroutine to solve Poisson's equation on a staggered grid. -C -C***SEE ALSO POISTG -C***ROUTINES CALLED COSGEN, S1MERG, TRI3, TRIX -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 920130 Modified to use merge routine S1MERG rather than deleted -C routine MERGE. (WRB) -C***END PROLOGUE POSTG2 -C - DIMENSION A(*) ,BB(*) ,C(*) ,Q(IDIMQ,*) , - 1 B(*) ,B2(*) ,B3(*) ,W(*) , - 2 W2(*) ,W3(*) ,D(*) ,TCOS(*) , - 3 K(4) ,P(*) - EQUIVALENCE (K(1),K1) ,(K(2),K2) ,(K(3),K3) ,(K(4),K4) -C***FIRST EXECUTABLE STATEMENT POSTG2 - NP = NPEROD - FNUM = 0.5*(NP/3) - FNUM2 = 0.5*(NP/2) - MR = M - IP = -MR - IPSTOR = 0 - I2R = 1 - JR = 2 - NR = N - NLAST = N - KR = 1 - LR = 0 - IF (NR .LE. 3) GO TO 142 - 101 CONTINUE - JR = 2*I2R - NROD = 1 - IF ((NR/2)*2 .EQ. NR) NROD = 0 - JSTART = 1 - JSTOP = NLAST-JR - IF (NROD .EQ. 0) JSTOP = JSTOP-I2R - I2RBY2 = I2R/2 - IF (JSTOP .GE. JSTART) GO TO 102 - J = JR - GO TO 115 - 102 CONTINUE -C -C REGULAR REDUCTION. -C - IJUMP = 1 - DO 114 J=JSTART,JSTOP,JR - JP1 = J+I2RBY2 - JP2 = J+I2R - JP3 = JP2+I2RBY2 - JM1 = J-I2RBY2 - JM2 = J-I2R - JM3 = JM2-I2RBY2 - IF (J .NE. 1) GO TO 106 - CALL COSGEN (I2R,1,FNUM,0.5,TCOS) - IF (I2R .NE. 1) GO TO 104 - DO 103 I=1,MR - B(I) = Q(I,1) - Q(I,1) = Q(I,2) - 103 CONTINUE - GO TO 112 - 104 DO 105 I=1,MR - B(I) = Q(I,1)+0.5*(Q(I,JP2)-Q(I,JP1)-Q(I,JP3)) - Q(I,1) = Q(I,JP2)+Q(I,1)-Q(I,JP1) - 105 CONTINUE - GO TO 112 - 106 CONTINUE - GO TO (107,108),IJUMP - 107 CONTINUE - IJUMP = 2 - CALL COSGEN (I2R,1,0.5,0.0,TCOS) - 108 CONTINUE - IF (I2R .NE. 1) GO TO 110 - DO 109 I=1,MR - B(I) = 2.*Q(I,J) - Q(I,J) = Q(I,JM2)+Q(I,JP2) - 109 CONTINUE - GO TO 112 - 110 DO 111 I=1,MR - FI = Q(I,J) - Q(I,J) = Q(I,J)-Q(I,JM1)-Q(I,JP1)+Q(I,JM2)+Q(I,JP2) - B(I) = FI+Q(I,J)-Q(I,JM3)-Q(I,JP3) - 111 CONTINUE - 112 CONTINUE - CALL TRIX (I2R,0,MR,A,BB,C,B,TCOS,D,W) - DO 113 I=1,MR - Q(I,J) = Q(I,J)+B(I) - 113 CONTINUE -C -C END OF REDUCTION FOR REGULAR UNKNOWNS. -C - 114 CONTINUE -C -C BEGIN SPECIAL REDUCTION FOR LAST UNKNOWN. -C - J = JSTOP+JR - 115 NLAST = J - JM1 = J-I2RBY2 - JM2 = J-I2R - JM3 = JM2-I2RBY2 - IF (NROD .EQ. 0) GO TO 125 -C -C ODD NUMBER OF UNKNOWNS -C - IF (I2R .NE. 1) GO TO 117 - DO 116 I=1,MR - B(I) = Q(I,J) - Q(I,J) = Q(I,JM2) - 116 CONTINUE - GO TO 123 - 117 DO 118 I=1,MR - B(I) = Q(I,J)+.5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3)) - 118 CONTINUE - IF (NRODPR .NE. 0) GO TO 120 - DO 119 I=1,MR - II = IP+I - Q(I,J) = Q(I,JM2)+P(II) - 119 CONTINUE - IP = IP-MR - GO TO 122 - 120 CONTINUE - DO 121 I=1,MR - Q(I,J) = Q(I,J)-Q(I,JM1)+Q(I,JM2) - 121 CONTINUE - 122 IF (LR .EQ. 0) GO TO 123 - CALL COSGEN (LR,1,FNUM2,0.5,TCOS(KR+1)) - 123 CONTINUE - CALL COSGEN (KR,1,FNUM2,0.5,TCOS) - CALL TRIX (KR,LR,MR,A,BB,C,B,TCOS,D,W) - DO 124 I=1,MR - Q(I,J) = Q(I,J)+B(I) - 124 CONTINUE - KR = KR+I2R - GO TO 141 - 125 CONTINUE -C -C EVEN NUMBER OF UNKNOWNS -C - JP1 = J+I2RBY2 - JP2 = J+I2R - IF (I2R .NE. 1) GO TO 129 - DO 126 I=1,MR - B(I) = Q(I,J) - 126 CONTINUE - TCOS(1) = 0. - CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) - IP = 0 - IPSTOR = MR - DO 127 I=1,MR - P(I) = B(I) - B(I) = B(I)+Q(I,N) - 127 CONTINUE - TCOS(1) = -1.+2*(NP/2) - TCOS(2) = 0. - CALL TRIX (1,1,MR,A,BB,C,B,TCOS,D,W) - DO 128 I=1,MR - Q(I,J) = Q(I,JM2)+P(I)+B(I) - 128 CONTINUE - GO TO 140 - 129 CONTINUE - DO 130 I=1,MR - B(I) = Q(I,J)+.5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3)) - 130 CONTINUE - IF (NRODPR .NE. 0) GO TO 132 - DO 131 I=1,MR - II = IP+I - B(I) = B(I)+P(II) - 131 CONTINUE - GO TO 134 - 132 CONTINUE - DO 133 I=1,MR - B(I) = B(I)+Q(I,JP2)-Q(I,JP1) - 133 CONTINUE - 134 CONTINUE - CALL COSGEN (I2R,1,0.5,0.0,TCOS) - CALL TRIX (I2R,0,MR,A,BB,C,B,TCOS,D,W) - IP = IP+MR - IPSTOR = MAX(IPSTOR,IP+MR) - DO 135 I=1,MR - II = IP+I - P(II) = B(I)+.5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) - B(I) = P(II)+Q(I,JP2) - 135 CONTINUE - IF (LR .EQ. 0) GO TO 136 - CALL COSGEN (LR,1,FNUM2,0.5,TCOS(I2R+1)) - CALL S1MERG (TCOS,0,I2R,I2R,LR,KR) - GO TO 138 - 136 DO 137 I=1,I2R - II = KR+I - TCOS(II) = TCOS(I) - 137 CONTINUE - 138 CALL COSGEN (KR,1,FNUM2,0.5,TCOS) - CALL TRIX (KR,KR,MR,A,BB,C,B,TCOS,D,W) - DO 139 I=1,MR - II = IP+I - Q(I,J) = Q(I,JM2)+P(II)+B(I) - 139 CONTINUE - 140 CONTINUE - LR = KR - KR = KR+JR - 141 CONTINUE - NR = (NLAST-1)/JR+1 - IF (NR .LE. 3) GO TO 142 - I2R = JR - NRODPR = NROD - GO TO 101 - 142 CONTINUE -C -C BEGIN SOLUTION -C - J = 1+JR - JM1 = J-I2R - JP1 = J+I2R - JM2 = NLAST-I2R - IF (NR .EQ. 2) GO TO 180 - IF (LR .NE. 0) GO TO 167 - IF (N .NE. 3) GO TO 156 -C -C CASE N = 3. -C - GO TO (143,148,143),NP - 143 DO 144 I=1,MR - B(I) = Q(I,2) - B2(I) = Q(I,1)+Q(I,3) - B3(I) = 0. - 144 CONTINUE - GO TO (146,146,145),NP - 145 TCOS(1) = -1. - TCOS(2) = 1. - K1 = 1 - GO TO 147 - 146 TCOS(1) = -2. - TCOS(2) = 1. - TCOS(3) = -1. - K1 = 2 - 147 K2 = 1 - K3 = 0 - K4 = 0 - GO TO 150 - 148 DO 149 I=1,MR - B(I) = Q(I,2) - B2(I) = Q(I,3) - B3(I) = Q(I,1) - 149 CONTINUE - CALL COSGEN (3,1,0.5,0.0,TCOS) - TCOS(4) = -1. - TCOS(5) = 1. - TCOS(6) = -1. - TCOS(7) = 1. - K1 = 3 - K2 = 2 - K3 = 1 - K4 = 1 - 150 CALL TRI3 (MR,A,BB,C,K,B,B2,B3,TCOS,D,W,W2,W3) - DO 151 I=1,MR - B(I) = B(I)+B2(I)+B3(I) - 151 CONTINUE - GO TO (153,153,152),NP - 152 TCOS(1) = 2. - CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) - 153 DO 154 I=1,MR - Q(I,2) = B(I) - B(I) = Q(I,1)+B(I) - 154 CONTINUE - TCOS(1) = -1.+4.*FNUM - CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) - DO 155 I=1,MR - Q(I,1) = B(I) - 155 CONTINUE - JR = 1 - I2R = 0 - GO TO 188 -C -C CASE N = 2**P+1 -C - 156 CONTINUE - DO 157 I=1,MR - B(I) = Q(I,J)+Q(I,1)-Q(I,JM1)+Q(I,NLAST)-Q(I,JM2) - 157 CONTINUE - GO TO (158,160,158),NP - 158 DO 159 I=1,MR - B2(I) = Q(I,1)+Q(I,NLAST)+Q(I,J)-Q(I,JM1)-Q(I,JP1) - B3(I) = 0. - 159 CONTINUE - K1 = NLAST-1 - K2 = NLAST+JR-1 - CALL COSGEN (JR-1,1,0.0,1.0,TCOS(NLAST)) - TCOS(K2) = 2*NP-4 - CALL COSGEN (JR,1,0.5-FNUM,0.5,TCOS(K2+1)) - K3 = (3-NP)/2 - CALL S1MERG (TCOS,K1,JR-K3,K2-K3,JR+K3,0) - K1 = K1-1+K3 - CALL COSGEN (JR,1,FNUM,0.5,TCOS(K1+1)) - K2 = JR - K3 = 0 - K4 = 0 - GO TO 162 - 160 DO 161 I=1,MR - FI = (Q(I,J)-Q(I,JM1)-Q(I,JP1))/2. - B2(I) = Q(I,1)+FI - B3(I) = Q(I,NLAST)+FI - 161 CONTINUE - K1 = NLAST+JR-1 - K2 = K1+JR-1 - CALL COSGEN (JR-1,1,0.0,1.0,TCOS(K1+1)) - CALL COSGEN (NLAST,1,0.5,0.0,TCOS(K2+1)) - CALL S1MERG (TCOS,K1,JR-1,K2,NLAST,0) - K3 = K1+NLAST-1 - K4 = K3+JR - CALL COSGEN (JR,1,0.5,0.5,TCOS(K3+1)) - CALL COSGEN (JR,1,0.0,0.5,TCOS(K4+1)) - CALL S1MERG (TCOS,K3,JR,K4,JR,K1) - K2 = NLAST-1 - K3 = JR - K4 = JR - 162 CALL TRI3 (MR,A,BB,C,K,B,B2,B3,TCOS,D,W,W2,W3) - DO 163 I=1,MR - B(I) = B(I)+B2(I)+B3(I) - 163 CONTINUE - IF (NP .NE. 3) GO TO 164 - TCOS(1) = 2. - CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) - 164 DO 165 I=1,MR - Q(I,J) = B(I)+.5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) - B(I) = Q(I,J)+Q(I,1) - 165 CONTINUE - CALL COSGEN (JR,1,FNUM,0.5,TCOS) - CALL TRIX (JR,0,MR,A,BB,C,B,TCOS,D,W) - DO 166 I=1,MR - Q(I,1) = Q(I,1)-Q(I,JM1)+B(I) - 166 CONTINUE - GO TO 188 -C -C CASE OF GENERAL N WITH NR = 3 . -C - 167 CONTINUE - DO 168 I=1,MR - B(I) = Q(I,1)-Q(I,JM1)+Q(I,J) - 168 CONTINUE - IF (NROD .NE. 0) GO TO 170 - DO 169 I=1,MR - II = IP+I - B(I) = B(I)+P(II) - 169 CONTINUE - GO TO 172 - 170 DO 171 I=1,MR - B(I) = B(I)+Q(I,NLAST)-Q(I,JM2) - 171 CONTINUE - 172 CONTINUE - DO 173 I=1,MR - T = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) - Q(I,J) = T - B2(I) = Q(I,NLAST)+T - B3(I) = Q(I,1)+T - 173 CONTINUE - K1 = KR+2*JR - CALL COSGEN (JR-1,1,0.0,1.0,TCOS(K1+1)) - K2 = K1+JR - TCOS(K2) = 2*NP-4 - K4 = (NP-1)*(3-NP) - K3 = K2+1-K4 - CALL COSGEN (KR+JR+K4,1,K4/2.,1.-K4,TCOS(K3)) - K4 = 1-NP/3 - CALL S1MERG (TCOS,K1,JR-K4,K2-K4,KR+JR+K4,0) - IF (NP .EQ. 3) K1 = K1-1 - K2 = KR+JR - K4 = K1+K2 - CALL COSGEN (KR,1,FNUM2,0.5,TCOS(K4+1)) - K3 = K4+KR - CALL COSGEN (JR,1,FNUM,0.5,TCOS(K3+1)) - CALL S1MERG (TCOS,K4,KR,K3,JR,K1) - K4 = K3+JR - CALL COSGEN (LR,1,FNUM2,0.5,TCOS(K4+1)) - CALL S1MERG (TCOS,K3,JR,K4,LR,K1+K2) - CALL COSGEN (KR,1,FNUM2,0.5,TCOS(K3+1)) - K3 = KR - K4 = KR - CALL TRI3 (MR,A,BB,C,K,B,B2,B3,TCOS,D,W,W2,W3) - DO 174 I=1,MR - B(I) = B(I)+B2(I)+B3(I) - 174 CONTINUE - IF (NP .NE. 3) GO TO 175 - TCOS(1) = 2. - CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) - 175 DO 176 I=1,MR - Q(I,J) = Q(I,J)+B(I) - B(I) = Q(I,1)+Q(I,J) - 176 CONTINUE - CALL COSGEN (JR,1,FNUM,0.5,TCOS) - CALL TRIX (JR,0,MR,A,BB,C,B,TCOS,D,W) - IF (JR .NE. 1) GO TO 178 - DO 177 I=1,MR - Q(I,1) = B(I) - 177 CONTINUE - GO TO 188 - 178 CONTINUE - DO 179 I=1,MR - Q(I,1) = Q(I,1)-Q(I,JM1)+B(I) - 179 CONTINUE - GO TO 188 - 180 CONTINUE -C -C CASE OF GENERAL N AND NR = 2 . -C - DO 181 I=1,MR - II = IP+I - B3(I) = 0. - B(I) = Q(I,1)+P(II) - Q(I,1) = Q(I,1)-Q(I,JM1) - B2(I) = Q(I,1)+Q(I,NLAST) - 181 CONTINUE - K1 = KR+JR - K2 = K1+JR - CALL COSGEN (JR-1,1,0.0,1.0,TCOS(K1+1)) - GO TO (182,183,182),NP - 182 TCOS(K2) = 2*NP-4 - CALL COSGEN (KR,1,0.0,1.0,TCOS(K2+1)) - GO TO 184 - 183 CALL COSGEN (KR+1,1,0.5,0.0,TCOS(K2)) - 184 K4 = 1-NP/3 - CALL S1MERG (TCOS,K1,JR-K4,K2-K4,KR+K4,0) - IF (NP .EQ. 3) K1 = K1-1 - K2 = KR - CALL COSGEN (KR,1,FNUM2,0.5,TCOS(K1+1)) - K4 = K1+KR - CALL COSGEN (LR,1,FNUM2,0.5,TCOS(K4+1)) - K3 = LR - K4 = 0 - CALL TRI3 (MR,A,BB,C,K,B,B2,B3,TCOS,D,W,W2,W3) - DO 185 I=1,MR - B(I) = B(I)+B2(I) - 185 CONTINUE - IF (NP .NE. 3) GO TO 186 - TCOS(1) = 2. - CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) - 186 DO 187 I=1,MR - Q(I,1) = Q(I,1)+B(I) - 187 CONTINUE - 188 CONTINUE -C -C START BACK SUBSTITUTION. -C - J = NLAST-JR - DO 189 I=1,MR - B(I) = Q(I,NLAST)+Q(I,J) - 189 CONTINUE - JM2 = NLAST-I2R - IF (JR .NE. 1) GO TO 191 - DO 190 I=1,MR - Q(I,NLAST) = 0. - 190 CONTINUE - GO TO 195 - 191 CONTINUE - IF (NROD .NE. 0) GO TO 193 - DO 192 I=1,MR - II = IP+I - Q(I,NLAST) = P(II) - 192 CONTINUE - IP = IP-MR - GO TO 195 - 193 DO 194 I=1,MR - Q(I,NLAST) = Q(I,NLAST)-Q(I,JM2) - 194 CONTINUE - 195 CONTINUE - CALL COSGEN (KR,1,FNUM2,0.5,TCOS) - CALL COSGEN (LR,1,FNUM2,0.5,TCOS(KR+1)) - CALL TRIX (KR,LR,MR,A,BB,C,B,TCOS,D,W) - DO 196 I=1,MR - Q(I,NLAST) = Q(I,NLAST)+B(I) - 196 CONTINUE - NLASTP = NLAST - 197 CONTINUE - JSTEP = JR - JR = I2R - I2R = I2R/2 - IF (JR .EQ. 0) GO TO 210 - JSTART = 1+JR - KR = KR-JR - IF (NLAST+JR .GT. N) GO TO 198 - KR = KR-JR - NLAST = NLAST+JR - JSTOP = NLAST-JSTEP - GO TO 199 - 198 CONTINUE - JSTOP = NLAST-JR - 199 CONTINUE - LR = KR-JR - CALL COSGEN (JR,1,0.5,0.0,TCOS) - DO 209 J=JSTART,JSTOP,JSTEP - JM2 = J-JR - JP2 = J+JR - IF (J .NE. JR) GO TO 201 - DO 200 I=1,MR - B(I) = Q(I,J)+Q(I,JP2) - 200 CONTINUE - GO TO 203 - 201 CONTINUE - DO 202 I=1,MR - B(I) = Q(I,J)+Q(I,JM2)+Q(I,JP2) - 202 CONTINUE - 203 CONTINUE - IF (JR .NE. 1) GO TO 205 - DO 204 I=1,MR - Q(I,J) = 0. - 204 CONTINUE - GO TO 207 - 205 CONTINUE - JM1 = J-I2R - JP1 = J+I2R - DO 206 I=1,MR - Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) - 206 CONTINUE - 207 CONTINUE - CALL TRIX (JR,0,MR,A,BB,C,B,TCOS,D,W) - DO 208 I=1,MR - Q(I,J) = Q(I,J)+B(I) - 208 CONTINUE - 209 CONTINUE - NROD = 1 - IF (NLAST+I2R .LE. N) NROD = 0 - IF (NLASTP .NE. NLAST) GO TO 188 - GO TO 197 - 210 CONTINUE -C -C RETURN STORAGE REQUIREMENTS FOR P VECTORS. -C - W(1) = IPSTOR - RETURN - END diff --git a/slatec/ppadd.f b/slatec/ppadd.f deleted file mode 100644 index 9506f31..0000000 --- a/slatec/ppadd.f +++ /dev/null @@ -1,164 +0,0 @@ -*DECK PPADD - SUBROUTINE PPADD (N, IERROR, A, C, CBP, BP, BH) -C***BEGIN PROLOGUE PPADD -C***SUBSIDIARY -C***PURPOSE Subsidiary to BLKTRI -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (PPADD-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C PPADD computes the eigenvalues of the periodic tridiagonal matrix -C with coefficients AN,BN,CN. -C -C N is the order of the BH and BP polynomials. -C BP contains the eigenvalues on output. -C CBP is the same as BP except type complex. -C BH is used to temporarily store the roots of the B HAT polynomial -C which enters through BP. -C -C***SEE ALSO BLKTRI -C***ROUTINES CALLED BSRH, PPSGF, PPSPF, PSGF -C***COMMON BLOCKS CBLKT -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE PPADD -C - COMPLEX CX ,FSG ,HSG , - 1 DD ,F ,FP ,FPP , - 2 CDIS ,R1 ,R2 ,R3 , - 3 CBP - DIMENSION A(*) ,C(*) ,BP(*) ,BH(*) , - 1 CBP(*) - COMMON /CBLKT/ NPP ,K ,EPS ,CNV , - 1 NM ,NCMPLX ,IK - EXTERNAL PSGF ,PPSPF ,PPSGF -C***FIRST EXECUTABLE STATEMENT PPADD - SCNV = SQRT(CNV) - IZ = N - IF (BP(N)-BP(1)) 101,142,103 - 101 DO 102 J=1,N - NT = N-J - BH(J) = BP(NT+1) - 102 CONTINUE - GO TO 105 - 103 DO 104 J=1,N - BH(J) = BP(J) - 104 CONTINUE - 105 NCMPLX = 0 - MODIZ = MOD(IZ,2) - IS = 1 - IF (MODIZ) 106,107,106 - 106 IF (A(1)) 110,142,107 - 107 XL = BH(1) - DB = BH(3)-BH(1) - 108 XL = XL-DB - IF (PSGF(XL,IZ,C,A,BH)) 108,108,109 - 109 SGN = -1. - CBP(1) = CMPLX(BSRH(XL,BH(1),IZ,C,A,BH,PSGF,SGN),0.) - IS = 2 - 110 IF = IZ-1 - IF (MODIZ) 111,112,111 - 111 IF (A(1)) 112,142,115 - 112 XR = BH(IZ) - DB = BH(IZ)-BH(IZ-2) - 113 XR = XR+DB - IF (PSGF(XR,IZ,C,A,BH)) 113,114,114 - 114 SGN = 1. - CBP(IZ) = CMPLX(BSRH(BH(IZ),XR,IZ,C,A,BH,PSGF,SGN),0.) - IF = IZ-2 - 115 DO 136 IG=IS,IF,2 - XL = BH(IG) - XR = BH(IG+1) - SGN = -1. - XM = BSRH(XL,XR,IZ,C,A,BH,PPSPF,SGN) - PSG = PSGF(XM,IZ,C,A,BH) - IF (ABS(PSG)-EPS) 118,118,116 - 116 IF (PSG*PPSGF(XM,IZ,C,A,BH)) 117,118,119 -C -C CASE OF A REAL ZERO -C - 117 SGN = 1. - CBP(IG) = CMPLX(BSRH(BH(IG),XM,IZ,C,A,BH,PSGF,SGN),0.) - SGN = -1. - CBP(IG+1) = CMPLX(BSRH(XM,BH(IG+1),IZ,C,A,BH,PSGF,SGN),0.) - GO TO 136 -C -C CASE OF A MULTIPLE ZERO -C - 118 CBP(IG) = CMPLX(XM,0.) - CBP(IG+1) = CMPLX(XM,0.) - GO TO 136 -C -C CASE OF A COMPLEX ZERO -C - 119 IT = 0 - ICV = 0 - CX = CMPLX(XM,0.) - 120 FSG = (1.,0.) - HSG = (1.,0.) - FP = (0.,0.) - FPP = (0.,0.) - DO 121 J=1,IZ - DD = 1./(CX-BH(J)) - FSG = FSG*A(J)*DD - HSG = HSG*C(J)*DD - FP = FP+DD - FPP = FPP-DD*DD - 121 CONTINUE - IF (MODIZ) 123,122,123 - 122 F = (1.,0.)-FSG-HSG - GO TO 124 - 123 F = (1.,0.)+FSG+HSG - 124 I3 = 0 - IF (ABS(FP)) 126,126,125 - 125 I3 = 1 - R3 = -F/FP - 126 IF (ABS(FPP)) 132,132,127 - 127 CDIS = SQRT(FP**2-2.*F*FPP) - R1 = CDIS-FP - R2 = -FP-CDIS - IF (ABS(R1)-ABS(R2)) 129,129,128 - 128 R1 = R1/FPP - GO TO 130 - 129 R1 = R2/FPP - 130 R2 = 2.*F/FPP/R1 - IF (ABS(R2) .LT. ABS(R1)) R1 = R2 - IF (I3) 133,133,131 - 131 IF (ABS(R3) .LT. ABS(R1)) R1 = R3 - GO TO 133 - 132 R1 = R3 - 133 CX = CX+R1 - IT = IT+1 - IF (IT .GT. 50) GO TO 142 - IF (ABS(R1) .GT. SCNV) GO TO 120 - IF (ICV) 134,134,135 - 134 ICV = 1 - GO TO 120 - 135 CBP(IG) = CX - CBP(IG+1) = CONJG(CX) - 136 CONTINUE - IF (ABS(CBP(N))-ABS(CBP(1))) 137,142,139 - 137 NHALF = N/2 - DO 138 J=1,NHALF - NT = N-J - CX = CBP(J) - CBP(J) = CBP(NT+1) - CBP(NT+1) = CX - 138 CONTINUE - 139 NCMPLX = 1 - DO 140 J=2,IZ - IF (AIMAG(CBP(J))) 143,140,143 - 140 CONTINUE - NCMPLX = 0 - DO 141 J=2,IZ - BP(J) = REAL(CBP(J)) - 141 CONTINUE - GO TO 143 - 142 IERROR = 4 - 143 CONTINUE - RETURN - END diff --git a/slatec/ppgq8.f b/slatec/ppgq8.f deleted file mode 100644 index 15bea16..0000000 --- a/slatec/ppgq8.f +++ /dev/null @@ -1,193 +0,0 @@ -*DECK PPGQ8 - SUBROUTINE PPGQ8 (FUN, LDC, C, XI, LXI, KK, ID, A, B, INPPV, ERR, - + ANS, IERR) -C***BEGIN PROLOGUE PPGQ8 -C***SUBSIDIARY -C***PURPOSE Subsidiary to PFQAD -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (PPGQ8-S, DPPGQ8-D) -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C PPGQ8, a modification of GAUS8, integrates the -C product of FUN(X) by the ID-th derivative of a spline -C PPVAL(LDC,C,XI,LXI,KK,ID,X,INPPV) between limits A and B. -C -C Description of arguments -C -C INPUT-- -C FUN - Name of external function of one argument which -C multiplies PPVAL. -C LDC - Leading dimension of matrix C, LDC.GE.KK -C C - Matrix of Taylor derivatives of dimension at least -C (K,LXI) -C XI - Breakpoint vector of length LXI+1 -C LXI - Number of polynomial pieces -C KK - Order of the spline, KK.GE.1 -C ID - Order of the spline derivative, 0.LE.ID.LE.KK-1 -C A - Lower limit of integral -C B - Upper limit of integral (may be less than A) -C INPPV- Initialization parameter for PPVAL -C ERR - Is a requested pseudorelative error tolerance. Normally -C pick a value of ABS(ERR).LT.1E-3. ANS will normally -C have no more error than ABS(ERR) times the integral of -C the absolute value of FUN(X)*PPVAL(LDC,C,XI,LXI,KK,ID,X, -C INPPV). -C -C OUTPUT-- -C ERR - Will be an estimate of the absolute error in ANS if the -C input value of ERR was negative. (ERR is unchanged if -C the input value of ERR was nonnegative.) The estimated -C error is solely for information to the user and should -C not be used as a correction to the computed integral. -C ANS - Computed value of integral -C IERR- A status code -C --Normal codes -C 1 ANS most likely meets requested error tolerance, -C or A=B. -C -1 A and B ARE too nearly equal to allow normal -C integration. ANS is set to zero. -C --Abnormal code -C 2 ANS probably does not meet requested error tolerance. -C -C***SEE ALSO PFQAD -C***ROUTINES CALLED I1MACH, PPVAL, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800901 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900328 Added TYPE section. (WRB) -C 910408 Updated the AUTHOR section. (WRB) -C***END PROLOGUE PPGQ8 -C - INTEGER ID,IERR,INPPV,K,KK,KML,KMX,L,LDC,LMN,LMX,LR,LXI,MXL, - 1 NBITS, NIB, NLMN, NLMX - INTEGER I1MACH - REAL A,AA,AE,ANIB, ANS,AREA,B, BE,C,CC,EE, EF, EPS, ERR, - 1 EST,GL,GLR,GR,HH,SQ2,TOL,VL,VR,W1, W2, W3, W4, XI, X1, - 2 X2, X3, X4, X, H - REAL R1MACH, PPVAL, G8, FUN - DIMENSION XI(*), C(LDC,*) - DIMENSION AA(30), HH(30), LR(30), VL(30), GR(30) - SAVE X1, X2, X3, X4, W1, W2, W3, W4, SQ2, NLMN, KMX, KML - DATA X1, X2, X3, X4/ - 1 1.83434642495649805E-01, 5.25532409916328986E-01, - 2 7.96666477413626740E-01, 9.60289856497536232E-01/ - DATA W1, W2, W3, W4/ - 1 3.62683783378361983E-01, 3.13706645877887287E-01, - 2 2.22381034453374471E-01, 1.01228536290376259E-01/ - DATA SQ2/1.41421356E0/ - DATA NLMN/1/,KMX/5000/,KML/6/ - G8(X,H)=H*((W1*(FUN(X-X1*H)*PPVAL(LDC,C,XI,LXI,KK,ID,X-X1*H,INPPV) - 1 +FUN(X+X1*H)*PPVAL(LDC,C,XI,LXI,KK,ID,X+X1*H,INPPV)) - 2 +W2*(FUN(X-X2*H)*PPVAL(LDC,C,XI,LXI,KK,ID,X-X2*H,INPPV) - 3 +FUN(X+X2*H)*PPVAL(LDC,C,XI,LXI,KK,ID,X+X2*H,INPPV))) - 4 +(W3*(FUN(X-X3*H)*PPVAL(LDC,C,XI,LXI,KK,ID,X-X3*H,INPPV) - 5 +FUN(X+X3*H)*PPVAL(LDC,C,XI,LXI,KK,ID,X+X3*H,INPPV)) - 6 +W4*(FUN(X-X4*H)*PPVAL(LDC,C,XI,LXI,KK,ID,X-X4*H,INPPV) - 7 +FUN(X+X4*H)*PPVAL(LDC,C,XI,LXI,KK,ID,X+X4*H,INPPV)))) -C -C INITIALIZE -C -C***FIRST EXECUTABLE STATEMENT PPGQ8 - K = I1MACH(11) - ANIB = R1MACH(5)*K/0.30102000E0 - NBITS = INT(ANIB) - NLMX = (NBITS*5)/8 - ANS = 0.0E0 - IERR = 1 - BE = 0.0E0 - IF (A.EQ.B) GO TO 140 - LMX = NLMX - LMN = NLMN - IF (B.EQ.0.0E0) GO TO 10 - IF (SIGN(1.0E0,B)*A.LE.0.0E0) GO TO 10 - CC = ABS(1.0E0-A/B) - IF (CC.GT.0.1E0) GO TO 10 - IF (CC.LE.0.0E0) GO TO 140 - ANIB = 0.5E0 - LOG(CC)/0.69314718E0 - NIB = INT(ANIB) - LMX = MIN(NLMX,NBITS-NIB-7) - IF (LMX.LT.1) GO TO 130 - LMN = MIN(LMN,LMX) - 10 TOL = MAX(ABS(ERR),2.0E0**(5-NBITS))/2.0E0 - IF (ERR.EQ.0.0E0) TOL = SQRT(R1MACH(4)) - EPS = TOL - HH(1) = (B-A)/4.0E0 - AA(1) = A - LR(1) = 1 - L = 1 - EST = G8(AA(L)+2.0E0*HH(L),2.0E0*HH(L)) - K = 8 - AREA = ABS(EST) - EF = 0.5E0 - MXL = 0 -C -C COMPUTE REFINED ESTIMATES, ESTIMATE THE ERROR, ETC. -C - 20 GL = G8(AA(L)+HH(L),HH(L)) - GR(L) = G8(AA(L)+3.0E0*HH(L),HH(L)) - K = K + 16 - AREA = AREA + (ABS(GL)+ABS(GR(L))-ABS(EST)) - GLR = GL + GR(L) - EE = ABS(EST-GLR)*EF - AE = MAX(EPS*AREA,TOL*ABS(GLR)) - IF (EE-AE) 40, 40, 50 - 30 MXL = 1 - 40 BE = BE + (EST-GLR) - IF (LR(L)) 60, 60, 80 -C -C CONSIDER THE LEFT HALF OF THIS LEVEL -C - 50 IF (K.GT.KMX) LMX = KML - IF (L.GE.LMX) GO TO 30 - L = L + 1 - EPS = EPS*0.5E0 - EF = EF/SQ2 - HH(L) = HH(L-1)*0.5E0 - LR(L) = -1 - AA(L) = AA(L-1) - EST = GL - GO TO 20 -C -C PROCEED TO RIGHT HALF AT THIS LEVEL -C - 60 VL(L) = GLR - 70 EST = GR(L-1) - LR(L) = 1 - AA(L) = AA(L) + 4.0E0*HH(L) - GO TO 20 -C -C RETURN ONE LEVEL -C - 80 VR = GLR - 90 IF (L.LE.1) GO TO 120 - L = L - 1 - EPS = EPS*2.0E0 - EF = EF*SQ2 - IF (LR(L)) 100, 100, 110 - 100 VL(L) = VL(L+1) + VR - GO TO 70 - 110 VR = VL(L+1) + VR - GO TO 90 -C -C EXIT -C - 120 ANS = VR - IF ((MXL.EQ.0) .OR. (ABS(BE).LE.2.0E0*TOL*AREA)) GO TO 140 - IERR = 2 - CALL XERMSG ('SLATEC', 'PPGQ8', - + 'ANS IS PROBABLY INSUFFICIENTLY ACCURATE.', 3, 1) - GO TO 140 - 130 IERR = -1 - CALL XERMSG ('SLATEC', 'PPGQ8', - + 'A AND B ARE TOO NEARLY EQUAL TO ALLOW NORMAL INTEGRATION. ' // - + 'ANS IS SET TO ZERO AND IERR TO -1.', 1, -1) - 140 CONTINUE - IF (ERR.LT.0.0E0) ERR = BE - RETURN - END diff --git a/slatec/ppgsf.f b/slatec/ppgsf.f deleted file mode 100644 index 2bfbaaf..0000000 --- a/slatec/ppgsf.f +++ /dev/null @@ -1,24 +0,0 @@ -*DECK PPGSF - FUNCTION PPGSF (X, IZ, C, A, BH) -C***BEGIN PROLOGUE PPGSF -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBLKTR -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (PPGSF-S) -C***AUTHOR (UNKNOWN) -C***SEE ALSO CBLKTR -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE PPGSF - DIMENSION A(*) ,C(*) ,BH(*) -C***FIRST EXECUTABLE STATEMENT PPGSF - SUM = 0. - DO 101 J=1,IZ - SUM = SUM-1./(X-BH(J))**2 - 101 CONTINUE - PPGSF = SUM - RETURN - END diff --git a/slatec/pppsf.f b/slatec/pppsf.f deleted file mode 100644 index 6c9072d..0000000 --- a/slatec/pppsf.f +++ /dev/null @@ -1,24 +0,0 @@ -*DECK PPPSF - FUNCTION PPPSF (X, IZ, C, A, BH) -C***BEGIN PROLOGUE PPPSF -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBLKTR -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (PPPSF-S) -C***AUTHOR (UNKNOWN) -C***SEE ALSO CBLKTR -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE PPPSF - DIMENSION A(*) ,C(*) ,BH(*) -C***FIRST EXECUTABLE STATEMENT PPPSF - SUM = 0. - DO 101 J=1,IZ - SUM = SUM+1./(X-BH(J)) - 101 CONTINUE - PPPSF = SUM - RETURN - END diff --git a/slatec/ppqad.f b/slatec/ppqad.f deleted file mode 100644 index 7420122..0000000 --- a/slatec/ppqad.f +++ /dev/null @@ -1,110 +0,0 @@ -*DECK PPQAD - SUBROUTINE PPQAD (LDC, C, XI, LXI, K, X1, X2, PQUAD) -C***BEGIN PROLOGUE PPQAD -C***PURPOSE Compute the integral on (X1,X2) of a K-th order B-spline -C using the piecewise polynomial (PP) representation. -C***LIBRARY SLATEC -C***CATEGORY H2A2A1, E3, K6 -C***TYPE SINGLE PRECISION (PPQAD-S, DPPQAD-D) -C***KEYWORDS B-SPLINE, DATA FITTING, INTERPOLATION, QUADRATURE, SPLINES -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C PPQAD computes the integral on (X1,X2) of a K-th order -C B-spline using the piecewise polynomial representation -C (C,XI,LXI,K). Here the Taylor expansion about the left -C end point XI(J) of the J-th interval is integrated and -C evaluated on subintervals of (X1,X2) which are formed by -C included break points. Integration outside (XI(1),XI(LXI+1)) -C is permitted. -C -C Description of Arguments -C Input -C LDC - leading dimension of matrix C, LDC .GE. K -C C(I,J) - right Taylor derivatives at XI(J), I=1,K , J=1,LXI -C XI(*) - break point array of length LXI+1 -C LXI - number of polynomial pieces -C K - order of B-spline, K .GE. 1 -C X1,X2 - end points of quadrature interval, normally in -C XI(1) .LE. X .LE. XI(LXI+1) -C -C Output -C PQUAD - integral of the PP representation over (X1,X2) -C -C Error Conditions -C Improper input is a fatal error -C -C***REFERENCES D. E. Amos, Quadrature subroutines for splines and -C B-splines, Report SAND79-1825, Sandia Laboratories, -C December 1979. -C***ROUTINES CALLED INTRV, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800901 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***END PROLOGUE PPQAD -C - INTEGER I, II, IL, ILO, IL1, IL2, IM, K, LDC, LEFT, LXI, MF1, MF2 - REAL A, AA, BB, C, DX, FLK, PQUAD, Q, S, SS, TA, TB, X, XI, X1, X2 - DIMENSION XI(*), C(LDC,*), SS(2) -C -C***FIRST EXECUTABLE STATEMENT PPQAD - PQUAD = 0.0E0 - IF(K.LT.1) GO TO 100 - IF(LXI.LT.1) GO TO 105 - IF(LDC.LT.K) GO TO 110 - AA = MIN(X1,X2) - BB = MAX(X1,X2) - IF (AA.EQ.BB) RETURN - ILO = 1 - CALL INTRV(XI, LXI, AA, ILO, IL1, MF1) - CALL INTRV(XI, LXI, BB, ILO, IL2, MF2) - Q = 0.0E0 - DO 40 LEFT=IL1,IL2 - TA = XI(LEFT) - A = MAX(AA,TA) - IF (LEFT.EQ.1) A = AA - TB = BB - IF (LEFT.LT.LXI) TB = XI(LEFT+1) - X = MIN(BB,TB) - DO 30 II=1,2 - SS(II) = 0.0E0 - DX = X - XI(LEFT) - IF (DX.EQ.0.0E0) GO TO 20 - S = C(K,LEFT) - FLK = K - IM = K - 1 - IL = IM - DO 10 I=1,IL - S = S*DX/FLK + C(IM,LEFT) - IM = IM - 1 - FLK = FLK - 1.0E0 - 10 CONTINUE - SS(II) = S*DX - 20 CONTINUE - X = A - 30 CONTINUE - Q = Q + (SS(1)-SS(2)) - 40 CONTINUE - IF (X1.GT.X2) Q = -Q - PQUAD = Q - RETURN -C -C - 100 CONTINUE - CALL XERMSG ('SLATEC', 'PPQAD', 'K DOES NOT SATISFY K.GE.1', 2, - + 1) - RETURN - 105 CONTINUE - CALL XERMSG ('SLATEC', 'PPQAD', 'LXI DOES NOT SATISFY LXI.GE.1', - + 2, 1) - RETURN - 110 CONTINUE - CALL XERMSG ('SLATEC', 'PPQAD', 'LDC DOES NOT SATISFY LDC.GE.K', - + 2, 1) - RETURN - END diff --git a/slatec/ppsgf.f b/slatec/ppsgf.f deleted file mode 100644 index 476d1b8..0000000 --- a/slatec/ppsgf.f +++ /dev/null @@ -1,24 +0,0 @@ -*DECK PPSGF - FUNCTION PPSGF (X, IZ, C, A, BH) -C***BEGIN PROLOGUE PPSGF -C***SUBSIDIARY -C***PURPOSE Subsidiary to BLKTRI -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (PPSGF-S) -C***AUTHOR (UNKNOWN) -C***SEE ALSO BLKTRI -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE PPSGF - DIMENSION A(*) ,C(*) ,BH(*) -C***FIRST EXECUTABLE STATEMENT PPSGF - SUM = 0. - DO 101 J=1,IZ - SUM = SUM-1./(X-BH(J))**2 - 101 CONTINUE - PPSGF = SUM - RETURN - END diff --git a/slatec/ppspf.f b/slatec/ppspf.f deleted file mode 100644 index d728128..0000000 --- a/slatec/ppspf.f +++ /dev/null @@ -1,24 +0,0 @@ -*DECK PPSPF - FUNCTION PPSPF (X, IZ, C, A, BH) -C***BEGIN PROLOGUE PPSPF -C***SUBSIDIARY -C***PURPOSE Subsidiary to BLKTRI -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (PPSPF-S) -C***AUTHOR (UNKNOWN) -C***SEE ALSO BLKTRI -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE PPSPF - DIMENSION A(*) ,C(*) ,BH(*) -C***FIRST EXECUTABLE STATEMENT PPSPF - SUM = 0. - DO 101 J=1,IZ - SUM = SUM+1./(X-BH(J)) - 101 CONTINUE - PPSPF = SUM - RETURN - END diff --git a/slatec/ppval.f b/slatec/ppval.f deleted file mode 100644 index 4ee8002..0000000 --- a/slatec/ppval.f +++ /dev/null @@ -1,103 +0,0 @@ -*DECK PPVAL - FUNCTION PPVAL (LDC, C, XI, LXI, K, IDERIV, X, INPPV) -C***BEGIN PROLOGUE PPVAL -C***PURPOSE Calculate the value of the IDERIV-th derivative of the -C B-spline from the PP-representation. -C***LIBRARY SLATEC -C***CATEGORY E3, K6 -C***TYPE SINGLE PRECISION (PPVAL-S, DPPVAL-D) -C***KEYWORDS B-SPLINE, DATA FITTING, INTERPOLATION, SPLINES -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C Written by Carl de Boor and modified by D. E. Amos -C -C Abstract -C PPVAL is the PPVALU function of the reference. -C -C PPVAL calculates (at X) the value of the IDERIV-th -C derivative of the B-spline from the PP-representation -C (C,XI,LXI,K). The Taylor expansion about XI(J) for X in -C the interval XI(J) .LE. X .LT. XI(J+1) is evaluated, J=1,LXI. -C Right limiting values at X=XI(J) are obtained. PPVAL will -C extrapolate beyond XI(1) and XI(LXI+1). -C -C To obtain left limiting values (left derivatives) at XI(J), -C replace LXI by J-1 and set X=XI(J),J=2,LXI+1. -C -C Description of Arguments -C Input -C LDC - leading dimension of C matrix, LDC .GE. K -C C - matrix of dimension at least (K,LXI) containing -C right derivatives at break points XI(*). -C XI - break point vector of length LXI+1 -C LXI - number of polynomial pieces -C K - order of B-spline, K .GE. 1 -C IDERIV - order of the derivative, 0 .LE. IDERIV .LE. K-1 -C IDERIV=0 gives the B-spline value -C X - argument, XI(1) .LE. X .LE. XI(LXI+1) -C INPPV - an initialization parameter which must be set -C to 1 the first time PPVAL is called. -C -C Output -C INPPV - INPPV contains information for efficient process- -C ing after the initial call and INPPV must not -C be changed by the user. Distinct splines require -C distinct INPPV parameters. -C PPVAL - value of the IDERIV-th derivative at X -C -C Error Conditions -C Improper input is a fatal error -C -C***REFERENCES Carl de Boor, Package for calculating with B-splines, -C SIAM Journal on Numerical Analysis 14, 3 (June 1977), -C pp. 441-472. -C***ROUTINES CALLED INTRV, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800901 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE PPVAL -C - INTEGER I, IDERIV, INPPV, J, K, LDC, LXI, NDUMMY - REAL C, DX, FLTK, X, XI - DIMENSION XI(*), C(LDC,*) -C***FIRST EXECUTABLE STATEMENT PPVAL - PPVAL = 0.0E0 - IF(K.LT.1) GO TO 90 - IF(LDC.LT.K) GO TO 80 - IF(LXI.LT.1) GO TO 85 - IF(IDERIV.LT.0 .OR. IDERIV.GE.K) GO TO 95 - I = K - IDERIV - FLTK = I - CALL INTRV(XI, LXI, X, INPPV, I, NDUMMY) - DX = X - XI(I) - J = K - 10 PPVAL = (PPVAL/FLTK)*DX + C(J,I) - J = J - 1 - FLTK = FLTK - 1.0E0 - IF (FLTK.GT.0.0E0) GO TO 10 - RETURN -C -C - 80 CONTINUE - CALL XERMSG ('SLATEC', 'PPVAL', 'LDC DOES NOT SATISFY LDC.GE.K', - + 2, 1) - RETURN - 85 CONTINUE - CALL XERMSG ('SLATEC', 'PPVAL', 'LXI DOES NOT SATISFY LXI.GE.1', - + 2, 1) - RETURN - 90 CONTINUE - CALL XERMSG ('SLATEC', 'PPVAL', 'K DOES NOT SATISFY K.GE.1', 2, - + 1) - RETURN - 95 CONTINUE - CALL XERMSG ('SLATEC', 'PPVAL', - + 'IDERIV DOES NOT SATISFY 0.LE.IDERIV.LT.K', 2, 1) - RETURN - END diff --git a/slatec/proc.f b/slatec/proc.f deleted file mode 100644 index 9ff72ce..0000000 --- a/slatec/proc.f +++ /dev/null @@ -1,106 +0,0 @@ -*DECK PROC - SUBROUTINE PROC (ND, BD, NM1, BM1, NM2, BM2, NA, AA, X, Y, M, A, - + B, C, D, W, U) -C***BEGIN PROLOGUE PROC -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBLKTR -C***LIBRARY SLATEC -C***TYPE COMPLEX (PROD-S, PROC-C) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C PROC applies a sequence of matrix operations to the vector X and -C stores the result in Y. -C BD,BM1,BM2 are arrays containing roots of certain B polynomials. -C ND,NM1,NM2 are the lengths of the arrays BD,BM1,BM2 respectively. -C AA Array containing scalar multipliers of the vector X. -C NA is the length of the array AA. -C X,Y The matrix operations are applied to X and the result is Y. -C A,B,C are arrays which contain the tridiagonal matrix. -C M is the order of the matrix. -C D,W,U are working arrays. -C IS determines whether or not a change in sign is made. -C -C***SEE ALSO CBLKTR -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE PROC -C - DIMENSION A(*) ,B(*) ,C(*) ,X(*) , - 1 Y(*) ,D(*) ,W(*) ,BD(*) , - 2 BM1(*) ,BM2(*) ,AA(*) ,U(*) - COMPLEX X ,Y ,A ,B , - 1 C ,D ,W ,U , - 2 DEN -C***FIRST EXECUTABLE STATEMENT PROC - DO 101 J=1,M - W(J) = X(J) - Y(J) = W(J) - 101 CONTINUE - MM = M-1 - ID = ND - IBR = 0 - M1 = NM1 - M2 = NM2 - IA = NA - 102 IF (IA) 105,105,103 - 103 RT = AA(IA) - IF (ND .EQ. 0) RT = -RT - IA = IA-1 -C -C SCALAR MULTIPLICATION -C - DO 104 J=1,M - Y(J) = RT*W(J) - 104 CONTINUE - 105 IF (ID) 125,125,106 - 106 RT = BD(ID) - ID = ID-1 - IF (ID .EQ. 0) IBR = 1 -C -C BEGIN SOLUTION TO SYSTEM -C - D(M) = A(M)/(B(M)-RT) - W(M) = Y(M)/(B(M)-RT) - DO 107 J=2,MM - K = M-J - DEN = B(K+1)-RT-C(K+1)*D(K+2) - D(K+1) = A(K+1)/DEN - W(K+1) = (Y(K+1)-C(K+1)*W(K+2))/DEN - 107 CONTINUE - DEN = B(1)-RT-C(1)*D(2) - W(1) = (1.,0.) - IF (ABS(DEN)) 108,109,108 - 108 W(1) = (Y(1)-C(1)*W(2))/DEN - 109 DO 110 J=2,M - W(J) = W(J)-D(J)*W(J-1) - 110 CONTINUE - IF (NA) 113,113,102 - 111 DO 112 J=1,M - Y(J) = W(J) - 112 CONTINUE - IBR = 1 - GO TO 102 - 113 IF (M1) 114,114,115 - 114 IF (M2) 111,111,120 - 115 IF (M2) 117,117,116 - 116 IF (ABS(BM1(M1))-ABS(BM2(M2))) 120,120,117 - 117 IF (IBR) 118,118,119 - 118 IF (ABS(BM1(M1)-BD(ID))-ABS(BM1(M1)-RT)) 111,119,119 - 119 RT = RT-BM1(M1) - M1 = M1-1 - GO TO 123 - 120 IF (IBR) 121,121,122 - 121 IF (ABS(BM2(M2)-BD(ID))-ABS(BM2(M2)-RT)) 111,122,122 - 122 RT = RT-BM2(M2) - M2 = M2-1 - 123 DO 124 J=1,M - Y(J) = Y(J)+RT*W(J) - 124 CONTINUE - GO TO 102 - 125 RETURN - END diff --git a/slatec/procp.f b/slatec/procp.f deleted file mode 100644 index 247b26c..0000000 --- a/slatec/procp.f +++ /dev/null @@ -1,123 +0,0 @@ -*DECK PROCP - SUBROUTINE PROCP (ND, BD, NM1, BM1, NM2, BM2, NA, AA, X, Y, M, A, - + B, C, D, U, W) -C***BEGIN PROLOGUE PROCP -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBLKTR -C***LIBRARY SLATEC -C***TYPE COMPLEX (PRODP-C, PROCP-C) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C PROCP applies a sequence of matrix operations to the vector X and -C stores the result in Y (periodic boundary conditions). -C -C BD,BM1,BM2 are arrays containing roots of certain B polynomials. -C ND,NM1,NM2 are the lengths of the arrays BD,BM1,BM2 respectively. -C AA Array containing scalar multipliers of the vector X. -C NA is the length of the array AA. -C X,Y The matrix operations are applied to X and the result is Y. -C A,B,C are arrays which contain the tridiagonal matrix. -C M is the order of the matrix. -C D,U,W are working arrays. -C IS determines whether or not a change in sign is made. -C -C***SEE ALSO CBLKTR -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE PROCP -C - DIMENSION A(*) ,B(*) ,C(*) ,X(*) , - 1 Y(*) ,D(*) ,U(*) ,BD(*) , - 2 BM1(*) ,BM2(*) ,AA(*) ,W(*) - COMPLEX X ,Y ,A ,B , - 1 C ,D ,U ,W , - 2 DEN ,YM ,V ,BH ,AM -C***FIRST EXECUTABLE STATEMENT PROCP - DO 101 J=1,M - Y(J) = X(J) - W(J) = Y(J) - 101 CONTINUE - MM = M-1 - MM2 = M-2 - ID = ND - IBR = 0 - M1 = NM1 - M2 = NM2 - IA = NA - 102 IF (IA) 105,105,103 - 103 RT = AA(IA) - IF (ND .EQ. 0) RT = -RT - IA = IA-1 - DO 104 J=1,M - Y(J) = RT*W(J) - 104 CONTINUE - 105 IF (ID) 128,128,106 - 106 RT = BD(ID) - ID = ID-1 - IF (ID .EQ. 0) IBR = 1 -C -C BEGIN SOLUTION TO SYSTEM -C - BH = B(M)-RT - YM = Y(M) - DEN = B(1)-RT - D(1) = C(1)/DEN - U(1) = A(1)/DEN - W(1) = Y(1)/DEN - V = C(M) - IF (MM2-2) 109,107,107 - 107 DO 108 J=2,MM2 - DEN = B(J)-RT-A(J)*D(J-1) - D(J) = C(J)/DEN - U(J) = -A(J)*U(J-1)/DEN - W(J) = (Y(J)-A(J)*W(J-1))/DEN - BH = BH-V*U(J-1) - YM = YM-V*W(J-1) - V = -V*D(J-1) - 108 CONTINUE - 109 DEN = B(M-1)-RT-A(M-1)*D(M-2) - D(M-1) = (C(M-1)-A(M-1)*U(M-2))/DEN - W(M-1) = (Y(M-1)-A(M-1)*W(M-2))/DEN - AM = A(M)-V*D(M-2) - BH = BH-V*U(M-2) - YM = YM-V*W(M-2) - DEN = BH-AM*D(M-1) - IF (ABS(DEN)) 110,111,110 - 110 W(M) = (YM-AM*W(M-1))/DEN - GO TO 112 - 111 W(M) = (1.,0.) - 112 W(M-1) = W(M-1)-D(M-1)*W(M) - DO 113 J=2,MM - K = M-J - W(K) = W(K)-D(K)*W(K+1)-U(K)*W(M) - 113 CONTINUE - IF (NA) 116,116,102 - 114 DO 115 J=1,M - Y(J) = W(J) - 115 CONTINUE - IBR = 1 - GO TO 102 - 116 IF (M1) 117,117,118 - 117 IF (M2) 114,114,123 - 118 IF (M2) 120,120,119 - 119 IF (ABS(BM1(M1))-ABS(BM2(M2))) 123,123,120 - 120 IF (IBR) 121,121,122 - 121 IF (ABS(BM1(M1)-BD(ID))-ABS(BM1(M1)-RT)) 114,122,122 - 122 RT = RT-BM1(M1) - M1 = M1-1 - GO TO 126 - 123 IF (IBR) 124,124,125 - 124 IF (ABS(BM2(M2)-BD(ID))-ABS(BM2(M2)-RT)) 114,125,125 - 125 RT = RT-BM2(M2) - M2 = M2-1 - 126 DO 127 J=1,M - Y(J) = Y(J)+RT*W(J) - 127 CONTINUE - GO TO 102 - 128 RETURN - END diff --git a/slatec/prod.f b/slatec/prod.f deleted file mode 100644 index 795f973..0000000 --- a/slatec/prod.f +++ /dev/null @@ -1,103 +0,0 @@ -*DECK PROD - SUBROUTINE PROD (ND, BD, NM1, BM1, NM2, BM2, NA, AA, X, Y, M, A, - + B, C, D, W, U) -C***BEGIN PROLOGUE PROD -C***SUBSIDIARY -C***PURPOSE Subsidiary to BLKTRI -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (PROD-S, PROC-C) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C PROD applies a sequence of matrix operations to the vector X and -C stores the result in Y. -C -C BD,BM1,BM2 are arrays containing roots of certain B polynomials. -C ND,NM1,NM2 are the lengths of the arrays BD,BM1,BM2 respectively. -C AA Array containing scalar multipliers of the vector X. -C NA is the length of the array AA. -C X,Y The matrix operations are applied to X and the result is Y. -C A,B,C are arrays which contain the tridiagonal matrix. -C M is the order of the matrix. -C D,W,U are working arrays. -C IS determines whether or not a change in sign is made. -C -C***SEE ALSO BLKTRI -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE PROD -C - DIMENSION A(*) ,B(*) ,C(*) ,X(*) , - 1 Y(*) ,D(*) ,W(*) ,BD(*) , - 2 BM1(*) ,BM2(*) ,AA(*) ,U(*) -C***FIRST EXECUTABLE STATEMENT PROD - DO 101 J=1,M - W(J) = X(J) - Y(J) = W(J) - 101 CONTINUE - MM = M-1 - ID = ND - IBR = 0 - M1 = NM1 - M2 = NM2 - IA = NA - 102 IF (IA) 105,105,103 - 103 RT = AA(IA) - IF (ND .EQ. 0) RT = -RT - IA = IA-1 -C -C SCALAR MULTIPLICATION -C - DO 104 J=1,M - Y(J) = RT*W(J) - 104 CONTINUE - 105 IF (ID) 125,125,106 - 106 RT = BD(ID) - ID = ID-1 - IF (ID .EQ. 0) IBR = 1 -C -C BEGIN SOLUTION TO SYSTEM -C - D(M) = A(M)/(B(M)-RT) - W(M) = Y(M)/(B(M)-RT) - DO 107 J=2,MM - K = M-J - DEN = B(K+1)-RT-C(K+1)*D(K+2) - D(K+1) = A(K+1)/DEN - W(K+1) = (Y(K+1)-C(K+1)*W(K+2))/DEN - 107 CONTINUE - DEN = B(1)-RT-C(1)*D(2) - W(1) = 1. - IF (DEN) 108,109,108 - 108 W(1) = (Y(1)-C(1)*W(2))/DEN - 109 DO 110 J=2,M - W(J) = W(J)-D(J)*W(J-1) - 110 CONTINUE - IF (NA) 113,113,102 - 111 DO 112 J=1,M - Y(J) = W(J) - 112 CONTINUE - IBR = 1 - GO TO 102 - 113 IF (M1) 114,114,115 - 114 IF (M2) 111,111,120 - 115 IF (M2) 117,117,116 - 116 IF (ABS(BM1(M1))-ABS(BM2(M2))) 120,120,117 - 117 IF (IBR) 118,118,119 - 118 IF (ABS(BM1(M1)-BD(ID))-ABS(BM1(M1)-RT)) 111,119,119 - 119 RT = RT-BM1(M1) - M1 = M1-1 - GO TO 123 - 120 IF (IBR) 121,121,122 - 121 IF (ABS(BM2(M2)-BD(ID))-ABS(BM2(M2)-RT)) 111,122,122 - 122 RT = RT-BM2(M2) - M2 = M2-1 - 123 DO 124 J=1,M - Y(J) = Y(J)+RT*W(J) - 124 CONTINUE - GO TO 102 - 125 RETURN - END diff --git a/slatec/prodp.f b/slatec/prodp.f deleted file mode 100644 index 09f491c..0000000 --- a/slatec/prodp.f +++ /dev/null @@ -1,119 +0,0 @@ -*DECK PRODP - SUBROUTINE PRODP (ND, BD, NM1, BM1, NM2, BM2, NA, AA, X, Y, M, A, - + B, C, D, U, W) -C***BEGIN PROLOGUE PRODP -C***SUBSIDIARY -C***PURPOSE Subsidiary to BLKTRI -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (PRODP-S, PROCP-C) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C PRODP applies a sequence of matrix operations to the vector X and -C stores the result in Y (periodic boundary conditions). -C -C BD,BM1,BM2 are arrays containing roots of certain B polynomials. -C ND,NM1,NM2 are the lengths of the arrays BD,BM1,BM2 respectively. -C AA Array containing scalar multipliers of the vector X. -C NA is the length of the array AA. -C X,Y The matrix operations are applied to X and the result is Y. -C A,B,C are arrays which contain the tridiagonal matrix. -C M is the order of the matrix. -C D,W,U are working arrays. -C IS determines whether or not a change in sign is made. -C -C***SEE ALSO BLKTRI -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE PRODP -C - DIMENSION A(*) ,B(*) ,C(*) ,X(*) , - 1 Y(*) ,D(*) ,U(*) ,BD(*) , - 2 BM1(*) ,BM2(*) ,AA(*) ,W(*) -C***FIRST EXECUTABLE STATEMENT PRODP - DO 101 J=1,M - Y(J) = X(J) - W(J) = Y(J) - 101 CONTINUE - MM = M-1 - MM2 = M-2 - ID = ND - IBR = 0 - M1 = NM1 - M2 = NM2 - IA = NA - 102 IF (IA) 105,105,103 - 103 RT = AA(IA) - IF (ND .EQ. 0) RT = -RT - IA = IA-1 - DO 104 J=1,M - Y(J) = RT*W(J) - 104 CONTINUE - 105 IF (ID) 128,128,106 - 106 RT = BD(ID) - ID = ID-1 - IF (ID .EQ. 0) IBR = 1 -C -C BEGIN SOLUTION TO SYSTEM -C - BH = B(M)-RT - YM = Y(M) - DEN = B(1)-RT - D(1) = C(1)/DEN - U(1) = A(1)/DEN - W(1) = Y(1)/DEN - V = C(M) - IF (MM2-2) 109,107,107 - 107 DO 108 J=2,MM2 - DEN = B(J)-RT-A(J)*D(J-1) - D(J) = C(J)/DEN - U(J) = -A(J)*U(J-1)/DEN - W(J) = (Y(J)-A(J)*W(J-1))/DEN - BH = BH-V*U(J-1) - YM = YM-V*W(J-1) - V = -V*D(J-1) - 108 CONTINUE - 109 DEN = B(M-1)-RT-A(M-1)*D(M-2) - D(M-1) = (C(M-1)-A(M-1)*U(M-2))/DEN - W(M-1) = (Y(M-1)-A(M-1)*W(M-2))/DEN - AM = A(M)-V*D(M-2) - BH = BH-V*U(M-2) - YM = YM-V*W(M-2) - DEN = BH-AM*D(M-1) - IF (DEN) 110,111,110 - 110 W(M) = (YM-AM*W(M-1))/DEN - GO TO 112 - 111 W(M) = 1. - 112 W(M-1) = W(M-1)-D(M-1)*W(M) - DO 113 J=2,MM - K = M-J - W(K) = W(K)-D(K)*W(K+1)-U(K)*W(M) - 113 CONTINUE - IF (NA) 116,116,102 - 114 DO 115 J=1,M - Y(J) = W(J) - 115 CONTINUE - IBR = 1 - GO TO 102 - 116 IF (M1) 117,117,118 - 117 IF (M2) 114,114,123 - 118 IF (M2) 120,120,119 - 119 IF (ABS(BM1(M1))-ABS(BM2(M2))) 123,123,120 - 120 IF (IBR) 121,121,122 - 121 IF (ABS(BM1(M1)-BD(ID))-ABS(BM1(M1)-RT)) 114,122,122 - 122 RT = RT-BM1(M1) - M1 = M1-1 - GO TO 126 - 123 IF (IBR) 124,124,125 - 124 IF (ABS(BM2(M2)-BD(ID))-ABS(BM2(M2)-RT)) 114,125,125 - 125 RT = RT-BM2(M2) - M2 = M2-1 - 126 DO 127 J=1,M - Y(J) = Y(J)+RT*W(J) - 127 CONTINUE - GO TO 102 - 128 RETURN - END diff --git a/slatec/prvec.f b/slatec/prvec.f deleted file mode 100644 index 69136b2..0000000 --- a/slatec/prvec.f +++ /dev/null @@ -1,30 +0,0 @@ -*DECK PRVEC - FUNCTION PRVEC (M, U, V) -C***BEGIN PROLOGUE PRVEC -C***SUBSIDIARY -C***PURPOSE Subsidiary to BVSUP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (PRVEC-S, DPRVEC-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C This subroutine computes the inner product of a vector U -C with the imaginary product or mate vector corresponding to V -C -C***SEE ALSO BVSUP -C***ROUTINES CALLED SDOT -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE PRVEC -C - DIMENSION U(*),V(*) -C***FIRST EXECUTABLE STATEMENT PRVEC - N=M/2 - NP=N+1 - VP=SDOT(N,U(1),1,V(NP),1) - PRVEC=SDOT(N,U(NP),1,V(1),1) - VP - RETURN - END diff --git a/slatec/prwpge.f b/slatec/prwpge.f deleted file mode 100644 index d146e29..0000000 --- a/slatec/prwpge.f +++ /dev/null @@ -1,79 +0,0 @@ -*DECK PRWPGE - SUBROUTINE PRWPGE (KEY, IPAGE, LPG, SX, IX) -C***BEGIN PROLOGUE PRWPGE -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (PRWPGE-S, DPRWPG-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C -C PRWPGE LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SCHEME. -C VIRTUAL MEMORY PAGE READ/WRITE SUBROUTINE. -C -C DEPENDING ON THE VALUE OF KEY, SUBROUTINE PRWPGE() PERFORMS A PAGE -C READ OR WRITE OF PAGE IPAGE. THE PAGE HAS LENGTH LPG. -C -C KEY IS A FLAG INDICATING WHETHER A PAGE READ OR WRITE IS -C TO BE PERFORMED. -C IF KEY = 1 DATA IS READ. -C IF KEY = 2 DATA IS WRITTEN. -C IPAGE IS THE PAGE NUMBER OF THE MATRIX TO BE ACCESSED. -C LPG IS THE LENGTH OF THE PAGE OF THE MATRIX TO BE ACCESSED. -C SX(*),IX(*) IS THE MATRIX TO BE ACCESSED. -C -C THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LRWPGE, -C SANDIA LABS. REPT. SAND78-0785. -C MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON -C REVISED 811130-1000 -C REVISED YYMMDD-HHMM -C -C***SEE ALSO SPLP -C***ROUTINES CALLED PRWVIR, XERMSG -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 900510 Fixed error messages and replaced GOTOs with -C IF-THEN-ELSE. (RWC) -C 910403 Updated AUTHOR and DESCRIPTION sections. (WRB) -C***END PROLOGUE PRWPGE - REAL SX(*) - DIMENSION IX(*) -C***FIRST EXECUTABLE STATEMENT PRWPGE -C -C CHECK IF IPAGE IS IN RANGE. -C - IF (IPAGE.LT.1) THEN - CALL XERMSG ('SLATEC', 'PRWPGE', - + 'THE VALUE OF IPAGE (PAGE NUMBER) WAS NOT IN THE RANGE' // - + '1.LE.IPAGE.LE.MAXPGE.', 55, 1) - ENDIF -C -C CHECK IF LPG IS POSITIVE. -C - IF (LPG.LE.0) THEN - CALL XERMSG ('SLATEC', 'PRWPGE', - + 'THE VALUE OF LPG (PAGE LENGTH) WAS NONPOSITIVE.', 55, 1) - ENDIF -C -C DECIDE IF WE ARE READING OR WRITING. -C - IF (KEY.EQ.1) THEN -C -C CODE TO DO A PAGE READ. -C - CALL PRWVIR(KEY,IPAGE,LPG,SX,IX) - ELSE IF (KEY.EQ.2) THEN -C -C CODE TO DO A PAGE WRITE. -C - CALL PRWVIR(KEY,IPAGE,LPG,SX,IX) - ELSE - CALL XERMSG ('SLATEC', 'PRWPGE', - + 'THE VALUE OF KEY (READ-WRITE FLAG) WAS NOT 1 OR 2.', 55, 1) - ENDIF - RETURN - END diff --git a/slatec/prwvir.f b/slatec/prwvir.f deleted file mode 100644 index d2e53b0..0000000 --- a/slatec/prwvir.f +++ /dev/null @@ -1,65 +0,0 @@ -*DECK PRWVIR - SUBROUTINE PRWVIR (KEY, IPAGE, LPG, SX, IX) -C***BEGIN PROLOGUE PRWVIR -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (PRWVIR-S, DPRWVR-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C -C PRWVIR LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SPARSE MATRIX -C STORAGE SCHEME. THE PAGE STORAGE IS ON RANDOM ACCESS DISK. -C PRWVIR IS PART OF THE SPARSE LP PACKAGE, SPLP. -C -C KEY IS A FLAG WHICH INDICATES WHETHER A READ OR WRITE -C OPERATION IS TO BE PERFORMED. A VALUE OF KEY=1 INDICATES -C A READ. A VALUE OF KEY=2 INDICATES A WRITE. -C IPAGE IS THE PAGE OF MATRIX MN WE ARE ACCESSING. -C LPG IS THE LENGTH OF THE PAGE. -C SX(*),IX(*) IS THE MATRIX DATA. -C -C THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LRWVIR, -C SANDIA LABS. REPT. SAND78-0785. -C MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON -C -C***SEE ALSO SPLP -C***ROUTINES CALLED SOPENM, SREADP, SWRITP -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 891009 Removed unreferenced variables. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910403 Updated AUTHOR and DESCRIPTION sections. (WRB) -C***END PROLOGUE PRWVIR - DIMENSION IX(*) - REAL SX(*),ZERO,ONE - LOGICAL FIRST - SAVE ZERO, ONE - DATA ZERO,ONE/0.E0,1.E0/ -C***FIRST EXECUTABLE STATEMENT PRWVIR -C -C COMPUTE STARTING ADDRESS OF PAGE. -C - IPAGEF=SX(3) - ISTART = IX(3) + 5 -C -C OPEN RANDOM ACCESS FILE NUMBER IPAGEF, IF FIRST PAGE WRITE. -C - FIRST=SX(4).EQ.ZERO - IF (.NOT.(FIRST)) GO TO 20002 - CALL SOPENM(IPAGEF,LPG) - SX(4)=ONE -C -C PERFORM EITHER A READ OR A WRITE. -C -20002 IADDR = 2*IPAGE - 1 - IF (.NOT.(KEY.EQ.1)) GO TO 20005 - CALL SREADP(IPAGEF,IX(ISTART),SX(ISTART),LPG,IADDR) - GO TO 20006 -20005 IF (.NOT.(KEY.EQ.2)) GO TO 10001 - CALL SWRITP(IPAGEF,IX(ISTART),SX(ISTART),LPG,IADDR) -10001 CONTINUE -20006 RETURN - END diff --git a/slatec/psgf.f b/slatec/psgf.f deleted file mode 100644 index 0bd2882..0000000 --- a/slatec/psgf.f +++ /dev/null @@ -1,30 +0,0 @@ -*DECK PSGF - FUNCTION PSGF (X, IZ, C, A, BH) -C***BEGIN PROLOGUE PSGF -C***SUBSIDIARY -C***PURPOSE Subsidiary to BLKTRI -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (PSGF-S) -C***AUTHOR (UNKNOWN) -C***SEE ALSO BLKTRI -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE PSGF - DIMENSION A(*) ,C(*) ,BH(*) -C***FIRST EXECUTABLE STATEMENT PSGF - FSG = 1. - HSG = 1. - DO 101 J=1,IZ - DD = 1./(X-BH(J)) - FSG = FSG*A(J)*DD - HSG = HSG*C(J)*DD - 101 CONTINUE - IF (MOD(IZ,2)) 103,102,103 - 102 PSGF = 1.-FSG-HSG - RETURN - 103 PSGF = 1.+FSG+HSG - RETURN - END diff --git a/slatec/psi.f b/slatec/psi.f deleted file mode 100644 index 122bf51..0000000 --- a/slatec/psi.f +++ /dev/null @@ -1,127 +0,0 @@ -*DECK PSI - FUNCTION PSI (X) -C***BEGIN PROLOGUE PSI -C***PURPOSE Compute the Psi (or Digamma) function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7C -C***TYPE SINGLE PRECISION (PSI-S, DPSI-D, CPSI-C) -C***KEYWORDS DIGAMMA FUNCTION, FNLIB, PSI FUNCTION, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C PSI(X) calculates the psi (or digamma) function for real argument X. -C PSI(X) is the logarithmic derivative of the gamma function of X. -C -C Series for PSI on the interval 0. to 1.00000D+00 -C with weighted error 2.03E-17 -C log weighted error 16.69 -C significant figures required 16.39 -C decimal places required 17.37 -C -C Series for APSI on the interval 0. to 2.50000D-01 -C with weighted error 5.54E-17 -C log weighted error 16.26 -C significant figures required 14.42 -C decimal places required 16.86 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED COT, CSEVL, INITS, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 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 900727 Added EXTERNAL statement. (WRB) -C 920618 Removed space from variable names. (RWC, WRB) -C***END PROLOGUE PSI - DIMENSION PSICS(23), APSICS(16) - LOGICAL FIRST - EXTERNAL COT - SAVE PSICS, APSICS, PI, NTPSI, NTAPSI, XBIG, DXREL, FIRST - DATA PSICS( 1) / -.0380570808 35217922E0 / - DATA PSICS( 2) / .4914153930 2938713E0 / - DATA PSICS( 3) / -.0568157478 21244730E0 / - DATA PSICS( 4) / .0083578212 25914313E0 / - DATA PSICS( 5) / -.0013332328 57994342E0 / - DATA PSICS( 6) / .0002203132 87069308E0 / - DATA PSICS( 7) / -.0000370402 38178456E0 / - DATA PSICS( 8) / .0000062837 93654854E0 / - DATA PSICS( 9) / -.0000010712 63908506E0 / - DATA PSICS(10) / .0000001831 28394654E0 / - DATA PSICS(11) / -.0000000313 53509361E0 / - DATA PSICS(12) / .0000000053 72808776E0 / - DATA PSICS(13) / -.0000000009 21168141E0 / - DATA PSICS(14) / .0000000001 57981265E0 / - DATA PSICS(15) / -.0000000000 27098646E0 / - DATA PSICS(16) / .0000000000 04648722E0 / - DATA PSICS(17) / -.0000000000 00797527E0 / - DATA PSICS(18) / .0000000000 00136827E0 / - DATA PSICS(19) / -.0000000000 00023475E0 / - DATA PSICS(20) / .0000000000 00004027E0 / - DATA PSICS(21) / -.0000000000 00000691E0 / - DATA PSICS(22) / .0000000000 00000118E0 / - DATA PSICS(23) / -.0000000000 00000020E0 / - DATA APSICS( 1) / -.0204749044 678185E0 / - DATA APSICS( 2) / -.0101801271 534859E0 / - DATA APSICS( 3) / .0000559718 725387E0 / - DATA APSICS( 4) / -.0000012917 176570E0 / - DATA APSICS( 5) / .0000000572 858606E0 / - DATA APSICS( 6) / -.0000000038 213539E0 / - DATA APSICS( 7) / .0000000003 397434E0 / - DATA APSICS( 8) / -.0000000000 374838E0 / - DATA APSICS( 9) / .0000000000 048990E0 / - DATA APSICS(10) / -.0000000000 007344E0 / - DATA APSICS(11) / .0000000000 001233E0 / - DATA APSICS(12) / -.0000000000 000228E0 / - DATA APSICS(13) / .0000000000 000045E0 / - DATA APSICS(14) / -.0000000000 000009E0 / - DATA APSICS(15) / .0000000000 000002E0 / - DATA APSICS(16) / -.0000000000 000000E0 / - DATA PI / 3.1415926535 8979324E0/ - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT PSI - IF (FIRST) THEN - NTPSI = INITS (PSICS, 23, 0.1*R1MACH(3)) - NTAPSI = INITS (APSICS, 16, 0.1*R1MACH(3)) -C - XBIG = 1.0/SQRT(R1MACH(3)) - DXREL = SQRT (R1MACH(4)) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GE.2.0) GO TO 30 -C -C PSI(X) FOR -2. .LT. X .LT. 2. -C - N = X - IF (X.LT.0.) N = N - 1 - Y = X - N - N = N - 1 - PSI = CSEVL (2.*Y-1., PSICS, NTPSI) - IF (N.EQ.0) RETURN -C - N = -N - IF (X .EQ. 0.) CALL XERMSG ('SLATEC', 'PSI', 'X IS 0', 2, 2) - IF (X .LT. 0. .AND. X+N-2 .EQ. 0.) CALL XERMSG ('SLATEC', 'PSI', - + 'X IS A NEGATIVE INTEGER', 3, 2) - IF (X .LT. (-0.5) .AND. ABS((X-AINT(X-0.5))/X) .LT. DXREL) - + CALL XERMSG ('SLATEC', 'PSI', - + 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER', - + 1, 1) -C - DO 20 I=1,N - PSI = PSI - 1.0/(X+I-1) - 20 CONTINUE - RETURN -C -C PSI(X) FOR ABS(X) .GE. 2. -C - 30 AUX = 0. - IF (Y.LT.XBIG) AUX = CSEVL (8./Y**2-1., APSICS, NTAPSI) - IF (X.LT.0.) PSI = LOG(ABS(X)) - 0.5/X + AUX - PI*COT(PI*X) - IF (X.GT.0.) PSI = LOG(X) - 0.5/X + AUX - RETURN -C - END diff --git a/slatec/psifn.f b/slatec/psifn.f deleted file mode 100644 index 34a8824..0000000 --- a/slatec/psifn.f +++ /dev/null @@ -1,368 +0,0 @@ -*DECK PSIFN - SUBROUTINE PSIFN (X, N, KODE, M, ANS, NZ, IERR) -C***BEGIN PROLOGUE PSIFN -C***PURPOSE Compute derivatives of the Psi function. -C***LIBRARY SLATEC -C***CATEGORY C7C -C***TYPE SINGLE PRECISION (PSIFN-S, DPSIFN-D) -C***KEYWORDS DERIVATIVES OF THE GAMMA FUNCTION, POLYGAMMA FUNCTION, -C PSI FUNCTION -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C The following definitions are used in PSIFN: -C -C Definition 1 -C PSI(X) = d/dx (ln(GAMMA(X)), the first derivative of -C the LOG GAMMA function. -C Definition 2 -C K K -C PSI(K,X) = d /dx (PSI(X)), the K-th derivative of PSI(X). -C ___________________________________________________________________ -C PSIFN computes a sequence of SCALED derivatives of -C the PSI function; i.e. for fixed X and M it computes -C the M-member sequence -C -C ((-1)**(K+1)/GAMMA(K+1))*PSI(K,X) -C for K = N,...,N+M-1 -C -C where PSI(K,X) is as defined above. For KODE=1, PSIFN returns -C the scaled derivatives as described. KODE=2 is operative only -C when K=0 and in that case PSIFN returns -PSI(X) + LN(X). That -C is, the logarithmic behavior for large X is removed when KODE=1 -C and K=0. When sums or differences of PSI functions are computed -C the logarithmic terms can be combined analytically and computed -C separately to help retain significant digits. -C -C Note that CALL PSIFN(X,0,1,1,ANS) results in -C ANS = -PSI(X) -C -C Input -C X - Argument, X .gt. 0.0E0 -C N - First member of the sequence, 0 .le. N .le. 100 -C N=0 gives ANS(1) = -PSI(X) for KODE=1 -C -PSI(X)+LN(X) for KODE=2 -C KODE - Selection parameter -C KODE=1 returns scaled derivatives of the PSI -C function. -C KODE=2 returns scaled derivatives of the PSI -C function EXCEPT when N=0. In this case, -C ANS(1) = -PSI(X) + LN(X) is returned. -C M - Number of members of the sequence, M .ge. 1 -C -C Output -C ANS - A vector of length at least M whose first M -C components contain the sequence of derivatives -C scaled according to KODE. -C NZ - Underflow flag -C NZ.eq.0, A normal return -C NZ.ne.0, Underflow, last NZ components of ANS are -C set to zero, ANS(M-K+1)=0.0, K=1,...,NZ -C IERR - Error flag -C IERR=0, A normal return, computation completed -C IERR=1, Input error, no computation -C IERR=2, Overflow, X too small or N+M-1 too -C large or both -C IERR=3, Error, N too large. Dimensioned -C array TRMR(NMAX) is not large enough for N -C -C The nominal computational accuracy is the maximum of unit -C roundoff (=R1MACH(4)) and 1.0E-18 since critical constants -C are given to only 18 digits. -C -C DPSIFN is the Double Precision version of PSIFN. -C -C *Long Description: -C -C The basic method of evaluation is the asymptotic expansion -C for large X.ge.XMIN followed by backward recursion on a two -C term recursion relation -C -C W(X+1) + X**(-N-1) = W(X). -C -C This is supplemented by a series -C -C SUM( (X+K)**(-N-1) , K=0,1,2,... ) -C -C which converges rapidly for large N. Both XMIN and the -C number of terms of the series are calculated from the unit -C roundoff of the machine environment. -C -C***REFERENCES Handbook of Mathematical Functions, National Bureau -C of Standards Applied Mathematics Series 55, edited -C by M. Abramowitz and I. A. Stegun, equations 6.3.5, -C 6.3.18, 6.4.6, 6.4.9 and 6.4.10, pp.258-260, 1964. -C D. E. Amos, A portable Fortran subroutine for -C derivatives of the Psi function, Algorithm 610, ACM -C Transactions on Mathematical Software 9, 4 (1983), -C pp. 494-502. -C***ROUTINES CALLED I1MACH, R1MACH -C***REVISION HISTORY (YYMMDD) -C 820601 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 PSIFN - INTEGER I, IERR, J, K, KODE, M, MM, MX, N, NMAX, NN, NP, NX, NZ - INTEGER I1MACH - REAL ANS, ARG, B, DEN, ELIM, EPS, FLN, FN, FNP, FNS, FX, RLN, - * RXSQ, R1M4, R1M5, S, SLOPE, T, TA, TK, TOL, TOLS, TRM, TRMR, - * TSS, TST, TT, T1, T2, WDTOL, X, XDMLN, XDMY, XINC, XLN, XM, - * XMIN, XQ, YINT - REAL R1MACH - DIMENSION B(22), TRM(22), TRMR(100), ANS(*) - SAVE NMAX, B - DATA NMAX /100/ -C----------------------------------------------------------------------- -C BERNOULLI NUMBERS -C----------------------------------------------------------------------- - DATA B(1), B(2), B(3), B(4), B(5), B(6), B(7), B(8), B(9), B(10), - * B(11), B(12), B(13), B(14), B(15), B(16), B(17), B(18), B(19), - * B(20), B(21), B(22) /1.00000000000000000E+00, - * -5.00000000000000000E-01,1.66666666666666667E-01, - * -3.33333333333333333E-02,2.38095238095238095E-02, - * -3.33333333333333333E-02,7.57575757575757576E-02, - * -2.53113553113553114E-01,1.16666666666666667E+00, - * -7.09215686274509804E+00,5.49711779448621554E+01, - * -5.29124242424242424E+02,6.19212318840579710E+03, - * -8.65802531135531136E+04,1.42551716666666667E+06, - * -2.72982310678160920E+07,6.01580873900642368E+08, - * -1.51163157670921569E+10,4.29614643061166667E+11, - * -1.37116552050883328E+13,4.88332318973593167E+14, - * -1.92965793419400681E+16/ -C -C***FIRST EXECUTABLE STATEMENT PSIFN - IERR = 0 - NZ=0 - IF (X.LE.0.0E0) IERR=1 - IF (N.LT.0) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (M.LT.1) IERR=1 - IF (IERR.NE.0) RETURN - MM=M - NX = MIN(-I1MACH(12),I1MACH(13)) - R1M5 = R1MACH(5) - R1M4 = R1MACH(4)*0.5E0 - WDTOL = MAX(R1M4,0.5E-18) -C----------------------------------------------------------------------- -C ELIM = APPROXIMATE EXPONENTIAL OVER AND UNDERFLOW LIMIT -C----------------------------------------------------------------------- - ELIM = 2.302E0*(NX*R1M5-3.0E0) - XLN = LOG(X) - 41 CONTINUE - NN = N + MM - 1 - FN = NN - FNP = FN + 1.0E0 - T = FNP*XLN -C----------------------------------------------------------------------- -C OVERFLOW AND UNDERFLOW TEST FOR SMALL AND LARGE X -C----------------------------------------------------------------------- - IF (ABS(T).GT.ELIM) GO TO 290 - IF (X.LT.WDTOL) GO TO 260 -C----------------------------------------------------------------------- -C COMPUTE XMIN AND THE NUMBER OF TERMS OF THE SERIES, FLN+1 -C----------------------------------------------------------------------- - RLN = R1M5*I1MACH(11) - RLN = MIN(RLN,18.06E0) - FLN = MAX(RLN,3.0E0) - 3.0E0 - YINT = 3.50E0 + 0.40E0*FLN - SLOPE = 0.21E0 + FLN*(0.0006038E0*FLN+0.008677E0) - XM = YINT + SLOPE*FN - MX = INT(XM) + 1 - XMIN = MX - IF (N.EQ.0) GO TO 50 - XM = -2.302E0*RLN - MIN(0.0E0,XLN) - FNS = N - ARG = XM/FNS - ARG = MIN(0.0E0,ARG) - EPS = EXP(ARG) - XM = 1.0E0 - EPS - IF (ABS(ARG).LT.1.0E-3) XM = -ARG - FLN = X*XM/EPS - XM = XMIN - X - IF (XM.GT.7.0E0 .AND. FLN.LT.15.0E0) GO TO 200 - 50 CONTINUE - XDMY = X - XDMLN = XLN - XINC = 0.0E0 - IF (X.GE.XMIN) GO TO 60 - NX = INT(X) - XINC = XMIN - NX - XDMY = X + XINC - XDMLN = LOG(XDMY) - 60 CONTINUE -C----------------------------------------------------------------------- -C GENERATE W(N+MM-1,X) BY THE ASYMPTOTIC EXPANSION -C----------------------------------------------------------------------- - T = FN*XDMLN - T1 = XDMLN + XDMLN - T2 = T + XDMLN - TK = MAX(ABS(T),ABS(T1),ABS(T2)) - IF (TK.GT.ELIM) GO TO 380 - TSS = EXP(-T) - TT = 0.5E0/XDMY - T1 = TT - TST = WDTOL*TT - IF (NN.NE.0) T1 = TT + 1.0E0/FN - RXSQ = 1.0E0/(XDMY*XDMY) - TA = 0.5E0*RXSQ - T = FNP*TA - S = T*B(3) - IF (ABS(S).LT.TST) GO TO 80 - TK = 2.0E0 - DO 70 K=4,22 - T = T*((TK+FN+1.0E0)/(TK+1.0E0))*((TK+FN)/(TK+2.0E0))*RXSQ - TRM(K) = T*B(K) - IF (ABS(TRM(K)).LT.TST) GO TO 80 - S = S + TRM(K) - TK = TK + 2.0E0 - 70 CONTINUE - 80 CONTINUE - S = (S+T1)*TSS - IF (XINC.EQ.0.0E0) GO TO 100 -C----------------------------------------------------------------------- -C BACKWARD RECUR FROM XDMY TO X -C----------------------------------------------------------------------- - NX = INT(XINC) - NP = NN + 1 - IF (NX.GT.NMAX) GO TO 390 - IF (NN.EQ.0) GO TO 160 - XM = XINC - 1.0E0 - FX = X + XM -C----------------------------------------------------------------------- -C THIS LOOP SHOULD NOT BE CHANGED. FX IS ACCURATE WHEN X IS SMALL -C----------------------------------------------------------------------- - DO 90 I=1,NX - TRMR(I) = FX**(-NP) - S = S + TRMR(I) - XM = XM - 1.0E0 - FX = X + XM - 90 CONTINUE - 100 CONTINUE - ANS(MM) = S - IF (FN.EQ.0.0E0) GO TO 180 -C----------------------------------------------------------------------- -C GENERATE LOWER DERIVATIVES, J.LT.N+MM-1 -C----------------------------------------------------------------------- - IF (MM.EQ.1) RETURN - DO 150 J=2,MM - FNP = FN - FN = FN - 1.0E0 - TSS = TSS*XDMY - T1 = TT - IF (FN.NE.0.0E0) T1 = TT + 1.0E0/FN - T = FNP*TA - S = T*B(3) - IF (ABS(S).LT.TST) GO TO 120 - TK = 3.0E0 + FNP - DO 110 K=4,22 - TRM(K) = TRM(K)*FNP/TK - IF (ABS(TRM(K)).LT.TST) GO TO 120 - S = S + TRM(K) - TK = TK + 2.0E0 - 110 CONTINUE - 120 CONTINUE - S = (S+T1)*TSS - IF (XINC.EQ.0.0E0) GO TO 140 - IF (FN.EQ.0.0E0) GO TO 160 - XM = XINC - 1.0E0 - FX = X + XM - DO 130 I=1,NX - TRMR(I) = TRMR(I)*FX - S = S + TRMR(I) - XM = XM - 1.0E0 - FX = X + XM - 130 CONTINUE - 140 CONTINUE - MX = MM - J + 1 - ANS(MX) = S - IF (FN.EQ.0.0E0) GO TO 180 - 150 CONTINUE - RETURN -C----------------------------------------------------------------------- -C RECURSION FOR N = 0 -C----------------------------------------------------------------------- - 160 CONTINUE - DO 170 I=1,NX - S = S + 1.0E0/(X+NX-I) - 170 CONTINUE - 180 CONTINUE - IF (KODE.EQ.2) GO TO 190 - ANS(1) = S - XDMLN - RETURN - 190 CONTINUE - IF (XDMY.EQ.X) RETURN - XQ = XDMY/X - ANS(1) = S - LOG(XQ) - RETURN -C----------------------------------------------------------------------- -C COMPUTE BY SERIES (X+K)**(-(N+1)) , K=0,1,2,... -C----------------------------------------------------------------------- - 200 CONTINUE - NN = INT(FLN) + 1 - NP = N + 1 - T1 = (FNS+1.0E0)*XLN - T = EXP(-T1) - S = T - DEN = X - DO 210 I=1,NN - DEN = DEN + 1.0E0 - TRM(I) = DEN**(-NP) - S = S + TRM(I) - 210 CONTINUE - ANS(1) = S - IF (N.NE.0) GO TO 220 - IF (KODE.EQ.2) ANS(1) = S + XLN - 220 CONTINUE - IF (MM.EQ.1) RETURN -C----------------------------------------------------------------------- -C GENERATE HIGHER DERIVATIVES, J.GT.N -C----------------------------------------------------------------------- - TOL = WDTOL/5.0E0 - DO 250 J=2,MM - T = T/X - S = T - TOLS = T*TOL - DEN = X - DO 230 I=1,NN - DEN = DEN + 1.0E0 - TRM(I) = TRM(I)/DEN - S = S + TRM(I) - IF (TRM(I).LT.TOLS) GO TO 240 - 230 CONTINUE - 240 CONTINUE - ANS(J) = S - 250 CONTINUE - RETURN -C----------------------------------------------------------------------- -C SMALL X.LT.UNIT ROUND OFF -C----------------------------------------------------------------------- - 260 CONTINUE - ANS(1) = X**(-N-1) - IF (MM.EQ.1) GO TO 280 - K = 1 - DO 270 I=2,MM - ANS(K+1) = ANS(K)/X - K = K + 1 - 270 CONTINUE - 280 CONTINUE - IF (N.NE.0) RETURN - IF (KODE.EQ.2) ANS(1) = ANS(1) + XLN - RETURN - 290 CONTINUE - IF (T.GT.0.0E0) GO TO 380 - NZ=0 - IERR=2 - RETURN - 380 CONTINUE - NZ=NZ+1 - ANS(MM)=0.0E0 - MM=MM-1 - IF(MM.EQ.0) RETURN - GO TO 41 - 390 CONTINUE - IERR=3 - NZ=0 - RETURN - END diff --git a/slatec/psixn.f b/slatec/psixn.f deleted file mode 100644 index d00f2cd..0000000 --- a/slatec/psixn.f +++ /dev/null @@ -1,124 +0,0 @@ -*DECK PSIXN - FUNCTION PSIXN (N) -C***BEGIN PROLOGUE PSIXN -C***SUBSIDIARY -C***PURPOSE Subsidiary to EXINT -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (PSIXN-S, DPSIXN-D) -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C This subroutine returns values of PSI(X)=derivative of log -C GAMMA(X), X .GT. 0.0 at integer arguments. A table look-up is -C performed for N .LE. 100, and the asymptotic expansion is -C evaluated for N .GT. 100. -C -C***SEE ALSO EXINT -C***ROUTINES CALLED R1MACH -C***REVISION HISTORY (YYMMDD) -C 800501 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE PSIXN -C - INTEGER N, K - REAL AX, B, C, FN, RFN2, TRM, S, WDTOL - REAL R1MACH - DIMENSION B(6), C(100) -C----------------------------------------------------------------------- -C PSIXN(N), N = 1,100 -C----------------------------------------------------------------------- - DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), - 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), - 2 C(19), C(20), C(21), C(22), C(23), C(24)/ - 3 -5.77215664901532861E-01, 4.22784335098467139E-01, - 4 9.22784335098467139E-01, 1.25611766843180047E+00, - 5 1.50611766843180047E+00, 1.70611766843180047E+00, - 6 1.87278433509846714E+00, 2.01564147795561000E+00, - 7 2.14064147795561000E+00, 2.25175258906672111E+00, - 8 2.35175258906672111E+00, 2.44266167997581202E+00, - 9 2.52599501330914535E+00, 2.60291809023222227E+00, - 1 2.67434666166079370E+00, 2.74101332832746037E+00, - 2 2.80351332832746037E+00, 2.86233685773922507E+00, - 3 2.91789241329478063E+00, 2.97052399224214905E+00, - 4 3.02052399224214905E+00, 3.06814303986119667E+00, - 5 3.11359758531574212E+00, 3.15707584618530734E+00/ - DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), - 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), - 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ - 3 3.19874251285197401E+00, 3.23874251285197401E+00, - 4 3.27720405131351247E+00, 3.31424108835054951E+00, - 5 3.34995537406483522E+00, 3.38443813268552488E+00, - 6 3.41777146601885821E+00, 3.45002953053498724E+00, - 7 3.48127953053498724E+00, 3.51158256083801755E+00, - 8 3.54099432554389990E+00, 3.56956575411532847E+00, - 9 3.59734353189310625E+00, 3.62437055892013327E+00, - 1 3.65068634839381748E+00, 3.67632737403484313E+00, - 2 3.70132737403484313E+00, 3.72571761793728215E+00, - 3 3.74952714174680596E+00, 3.77278295570029433E+00, - 4 3.79551022842756706E+00, 3.81773245064978928E+00, - 5 3.83947158108457189E+00, 3.86074817682925274E+00/ - DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), - 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), - 2 C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ - 3 3.88158151016258607E+00, 3.90198967342789220E+00, - 4 3.92198967342789220E+00, 3.94159751656514710E+00, - 5 3.96082828579591633E+00, 3.97969621032421822E+00, - 6 3.99821472884273674E+00, 4.01639654702455492E+00, - 7 4.03425368988169777E+00, 4.05179754953082058E+00, - 8 4.06903892884116541E+00, 4.08598808138353829E+00, - 9 4.10265474805020496E+00, 4.11904819067315578E+00, - 1 4.13517722293122029E+00, 4.15105023880423617E+00, - 2 4.16667523880423617E+00, 4.18205985418885155E+00, - 3 4.19721136934036670E+00, 4.21213674247469506E+00, - 4 4.22684262482763624E+00, 4.24133537845082464E+00, - 5 4.25562109273653893E+00, 4.26970559977879245E+00/ - DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), - 1 C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), - 2 C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ - 3 4.28359448866768134E+00, 4.29729311880466764E+00, - 4 4.31080663231818115E+00, 4.32413996565151449E+00, - 5 4.33729786038835659E+00, 4.35028487337536958E+00, - 6 4.36310538619588240E+00, 4.37576361404398366E+00, - 7 4.38826361404398366E+00, 4.40060929305632934E+00, - 8 4.41280441500754886E+00, 4.42485260777863319E+00, - 9 4.43675736968339510E+00, 4.44852207556574804E+00, - 1 4.46014998254249223E+00, 4.47164423541605544E+00, - 2 4.48300787177969181E+00, 4.49424382683587158E+00, - 3 4.50535493794698269E+00, 4.51634394893599368E+00, - 4 4.52721351415338499E+00, 4.53796620232542800E+00, - 5 4.54860450019776842E+00, 4.55913081598724211E+00/ - DATA C(97), C(98), C(99), C(100)/ - 1 4.56954748265390877E+00, 4.57985676100442424E+00, - 2 4.59006084263707730E+00, 4.60016185273808740E+00/ -C----------------------------------------------------------------------- -C COEFFICIENTS OF ASYMPTOTIC EXPANSION -C----------------------------------------------------------------------- - DATA B(1), B(2), B(3), B(4), B(5), B(6)/ - 1 8.33333333333333333E-02, -8.33333333333333333E-03, - 2 3.96825396825396825E-03, -4.16666666666666666E-03, - 3 7.57575757575757576E-03, -2.10927960927960928E-02/ -C -C***FIRST EXECUTABLE STATEMENT PSIXN - IF (N.GT.100) GO TO 10 - PSIXN = C(N) - RETURN - 10 CONTINUE - WDTOL = MAX(R1MACH(4),1.0E-18) - FN = N - AX = 1.0E0 - S = -0.5E0/FN - IF (ABS(S).LE.WDTOL) GO TO 30 - RFN2 = 1.0E0/(FN*FN) - DO 20 K=1,6 - AX = AX*RFN2 - TRM = -B(K)*AX - IF (ABS(TRM).LT.WDTOL) GO TO 30 - S = S + TRM - 20 CONTINUE - 30 CONTINUE - PSIXN = S + LOG(FN) - RETURN - END diff --git a/slatec/pvalue.f b/slatec/pvalue.f deleted file mode 100644 index d20cb78..0000000 --- a/slatec/pvalue.f +++ /dev/null @@ -1,148 +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 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 -C - 12 CALL XERMSG ('SLATEC', 'PVALUE', - + 'INVALID INPUT PARAMETER. ORDER OF POLYNOMIAL EVALUATION ' // - + 'REQUESTED IS NEGATIVE -- EXECUTION TERMINATED.', 2, 2) - RETURN - END diff --git a/slatec/pythag.f b/slatec/pythag.f deleted file mode 100644 index dc3ef31..0000000 --- a/slatec/pythag.f +++ /dev/null @@ -1,39 +0,0 @@ -*DECK PYTHAG - REAL FUNCTION PYTHAG (A, B) -C***BEGIN PROLOGUE PYTHAG -C***SUBSIDIARY -C***PURPOSE Compute the complex square root of a complex number without -C destructive overflow or underflow. -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (PYTHAG-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Finds sqrt(A**2+B**2) without overflow or destructive underflow -C -C***SEE ALSO EISDOC -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 811101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE PYTHAG - REAL A,B -C - REAL P,Q,R,S,T -C***FIRST EXECUTABLE STATEMENT PYTHAG - P = MAX(ABS(A),ABS(B)) - Q = MIN(ABS(A),ABS(B)) - IF (Q .EQ. 0.0E0) GO TO 20 - 10 CONTINUE - R = (Q/P)**2 - T = 4.0E0 + R - IF (T .EQ. 4.0E0) GO TO 20 - S = R/T - P = P + 2.0E0*P*S - Q = Q*S - GO TO 10 - 20 PYTHAG = P - RETURN - END diff --git a/slatec/qag.f b/slatec/qag.f deleted file mode 100644 index 6688845..0000000 --- a/slatec/qag.f +++ /dev/null @@ -1,193 +0,0 @@ -*DECK QAG - SUBROUTINE QAG (F, A, B, EPSABS, EPSREL, KEY, RESULT, ABSERR, - + NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK) -C***BEGIN PROLOGUE QAG -C***PURPOSE The routine calculates an approximation result to a given -C definite integral I = integral of F over (A,B), -C hopefully satisfying following claim for accuracy -C ABS(I-RESULT)LE.MAX(EPSABS,EPSREL*ABS(I)). -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A1A1 -C***TYPE SINGLE PRECISION (QAG-S, DQAG-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, GAUSS-KRONROD RULES, -C GENERAL-PURPOSE, GLOBALLY ADAPTIVE, INTEGRAND EXAMINATOR, -C QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Computation of a definite integral -C Standard fortran subroutine -C Real version -C -C F - Real -C Function subprogram defining the integrand -C Function F(X). The actual name for F needs to be -C Declared E X T E R N A L in the driver program. -C -C A - Real -C Lower limit of integration -C -C B - Real -C Upper limit of integration -C -C EPSABS - Real -C Absolute accuracy requested -C EPSREL - Real -C Relative accuracy requested -C If EPSABS.LE.0 -C And EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C The routine will end with IER = 6. -C -C KEY - Integer -C Key for choice of local integration rule -C A GAUSS-KRONROD PAIR is used with -C 7 - 15 POINTS If KEY.LT.2, -C 10 - 21 POINTS If KEY = 2, -C 15 - 31 POINTS If KEY = 3, -C 20 - 41 POINTS If KEY = 4, -C 25 - 51 POINTS If KEY = 5, -C 30 - 61 POINTS If KEY.GT.5. -C -C ON RETURN -C RESULT - Real -C Approximation to the integral -C -C ABSERR - Real -C Estimate of the modulus of the absolute error, -C Which should EQUAL or EXCEED ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C IER.GT.0 Abnormal termination of the routine -C The estimates for RESULT and ERROR are -C Less reliable. It is assumed that the -C requested accuracy has not been achieved. -C ERROR MESSAGES -C IER = 1 Maximum number of subdivisions allowed -C has been achieved. One can allow more -C subdivisions by increasing the value of -C LIMIT (and taking the according dimension -C adjustments into account). HOWEVER, If -C this yield no improvement it is advised -C to analyze the integrand in order to -C determine the integration difficulties. -C If the position of a local difficulty can -C be determined (I.E. SINGULARITY, -C DISCONTINUITY WITHIN THE INTERVAL) One -C will probably gain from splitting up the -C interval at this point and calling the -C INTEGRATOR on the SUBRANGES. If possible, -C AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR -C should be used which is designed for -C handling the type of difficulty involved. -C = 2 The occurrence of roundoff error is -C detected, which prevents the requested -C tolerance from being achieved. -C = 3 Extremely bad integrand behaviour occurs -C at some points of the integration -C interval. -C = 6 The input is invalid, because -C (EPSABS.LE.0 AND -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)) -C OR LIMIT.LT.1 OR LENW.LT.LIMIT*4. -C RESULT, ABSERR, NEVAL, LAST are set -C to zero. -C EXCEPT when LENW is invalid, IWORK(1), -C WORK(LIMIT*2+1) and WORK(LIMIT*3+1) are -C set to zero, WORK(1) is set to A and -C WORK(LIMIT+1) to B. -C -C DIMENSIONING PARAMETERS -C LIMIT - Integer -C Dimensioning parameter for IWORK -C Limit determines the maximum number of subintervals -C in the partition of the given integration interval -C (A,B), LIMIT.GE.1. -C If LIMIT.LT.1, the routine will end with IER = 6. -C -C LENW - Integer -C Dimensioning parameter for work -C LENW must be at least LIMIT*4. -C IF LENW.LT.LIMIT*4, the routine will end with -C IER = 6. -C -C LAST - Integer -C On return, LAST equals the number of subintervals -C produced in the subdivision process, which -C determines the number of significant elements -C actually in the WORK ARRAYS. -C -C WORK ARRAYS -C IWORK - Integer -C Vector of dimension at least limit, the first K -C elements of which contain pointers to the error -C estimates over the subintervals, such that -C WORK(LIMIT*3+IWORK(1)),... , WORK(LIMIT*3+IWORK(K)) -C form a decreasing sequence with K = LAST If -C LAST.LE.(LIMIT/2+2), and K = LIMIT+1-LAST otherwise -C -C WORK - Real -C Vector of dimension at least LENW -C on return -C WORK(1), ..., WORK(LAST) contain the left end -C points of the subintervals in the partition of -C (A,B), -C WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain the -C right end points, -C WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) contain -C the integral approximations over the subintervals, -C WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) contain -C the error estimates. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED QAGE, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800101 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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE QAG - REAL A,ABSERR,B,EPSABS,EPSREL,F,RESULT,WORK - INTEGER IER,IWORK,KEY,LENW,LIMIT,LVL,L1,L2,L3,NEVAL -C - DIMENSION IWORK(*),WORK(*) -C - EXTERNAL F -C***FIRST EXECUTABLE STATEMENT QAG - IER = 6 - NEVAL = 0 - LAST = 0 - RESULT = 0.0E+00 - ABSERR = 0.0E+00 - IF (LIMIT.GE.1 .AND. LENW.GE.LIMIT*4) THEN -C -C PREPARE CALL FOR QAGE. -C - L1 = LIMIT+1 - L2 = LIMIT+L1 - L3 = LIMIT+L2 -C - CALL QAGE(F,A,B,EPSABS,EPSREL,KEY,LIMIT,RESULT,ABSERR,NEVAL, - 1 IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) -C -C CALL ERROR HANDLER IF NECESSARY. -C - LVL = 0 - ENDIF -C - IF (IER.EQ.6) LVL = 1 - IF (IER .NE. 0) CALL XERMSG ('SLATEC', 'QAG', - + 'ABNORMAL RETURN', IER, LVL) - RETURN - END diff --git a/slatec/qage.f b/slatec/qage.f deleted file mode 100644 index 24b368d..0000000 --- a/slatec/qage.f +++ /dev/null @@ -1,353 +0,0 @@ -*DECK QAGE - SUBROUTINE QAGE (F, A, B, EPSABS, EPSREL, KEY, LIMIT, RESULT, - + ABSERR, NEVAL, IER, ALIST, BLIST, RLIST, ELIST, IORD, LAST) -C***BEGIN PROLOGUE QAGE -C***PURPOSE The routine calculates an approximation result to a given -C definite integral I = Integral of F over (A,B), -C hopefully satisfying following claim for accuracy -C ABS(I-RESLT).LE.MAX(EPSABS,EPSREL*ABS(I)). -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A1A1 -C***TYPE SINGLE PRECISION (QAGE-S, DQAGE-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, GAUSS-KRONROD RULES, -C GENERAL-PURPOSE, GLOBALLY ADAPTIVE, INTEGRAND EXAMINATOR, -C QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Computation of a definite integral -C Standard fortran subroutine -C Real version -C -C PARAMETERS -C ON ENTRY -C F - Real -C Function subprogram defining the integrand -C function F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C A - Real -C Lower limit of integration -C -C B - Real -C Upper limit of integration -C -C EPSABS - Real -C Absolute accuracy requested -C EPSREL - Real -C Relative accuracy requested -C If EPSABS.LE.0 -C and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C the routine will end with IER = 6. -C -C KEY - Integer -C Key for choice of local integration rule -C A Gauss-Kronrod pair is used with -C 7 - 15 points if KEY.LT.2, -C 10 - 21 points if KEY = 2, -C 15 - 31 points if KEY = 3, -C 20 - 41 points if KEY = 4, -C 25 - 51 points if KEY = 5, -C 30 - 61 points if KEY.GT.5. -C -C LIMIT - Integer -C Gives an upper bound on the number of subintervals -C in the partition of (A,B), LIMIT.GE.1. -C -C ON RETURN -C RESULT - Real -C Approximation to the integral -C -C ABSERR - Real -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C IER.GT.0 Abnormal termination of the routine -C The estimates for result and error are -C less reliable. It is assumed that the -C requested accuracy has not been achieved. -C ERROR MESSAGES -C IER = 1 Maximum number of subdivisions allowed -C has been achieved. One can allow more -C subdivisions by increasing the value -C of LIMIT. -C However, if this yields no improvement it -C is rather advised to analyze the integrand -C in order to determine the integration -C difficulties. If the position of a local -C difficulty can be determined(e.g. -C SINGULARITY, DISCONTINUITY within the -C interval) one will probably gain from -C splitting up the interval at this point -C and calling the integrator on the -C subranges. If possible, an appropriate -C special-purpose integrator should be used -C which is designed for handling the type of -C difficulty involved. -C = 2 The occurrence of roundoff error is -C detected, which prevents the requested -C tolerance from being achieved. -C = 3 Extremely bad integrand behaviour occurs -C at some points of the integration -C interval. -C = 6 The input is invalid, because -C (EPSABS.LE.0 and -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C RESULT, ABSERR, NEVAL, LAST, RLIST(1) , -C ELIST(1) and IORD(1) are set to zero. -C ALIST(1) and BLIST(1) are set to A and B -C respectively. -C -C ALIST - Real -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the left -C end points of the subintervals in the partition -C of the given integration range (A,B) -C -C BLIST - Real -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the right -C end points of the subintervals in the partition -C of the given integration range (A,B) -C -C RLIST - Real -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the -C integral approximations on the subintervals -C -C ELIST - Real -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the moduli of the -C absolute error estimates on the subintervals -C -C IORD - Integer -C Vector of dimension at least LIMIT, the first K -C elements of which are pointers to the -C error estimates over the subintervals, -C such that ELIST(IORD(1)), ..., -C ELIST(IORD(K)) form a decreasing sequence, -C with K = LAST if LAST.LE.(LIMIT/2+2), and -C K = LIMIT+1-LAST otherwise -C -C LAST - Integer -C Number of subintervals actually produced in the -C subdivision process -C -C***REFERENCES (NONE) -C***ROUTINES CALLED QK15, QK21, QK31, QK41, QK51, QK61, QPSRT, R1MACH -C***REVISION HISTORY (YYMMDD) -C 800101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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***END PROLOGUE QAGE -C - REAL A,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1,A2,B,BLIST, - 1 B1,B2,DEFABS,DEFAB1,DEFAB2,R1MACH,ELIST,EPMACH, - 2 EPSABS,EPSREL,ERRBND,ERRMAX,ERROR1,ERROR2,ERRO12,ERRSUM,F, - 3 RESABS,RESULT,RLIST,UFLOW - INTEGER IER,IORD,IROFF1,IROFF2,K,KEY,KEYF,LAST, - 1 LIMIT,MAXERR,NEVAL,NRMAX -C - DIMENSION ALIST(*),BLIST(*),ELIST(*),IORD(*), - 1 RLIST(*) -C - EXTERNAL F -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER -C (ALIST(I),BLIST(I)) -C ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) -C MAXERR - POINTER TO THE INTERVAL WITH LARGEST -C ERROR ESTIMATE -C ERRMAX - ELIST(MAXERR) -C AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS -C ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS -C ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* -C ABS(RESULT)) -C *****1 - VARIABLE FOR THE LEFT SUBINTERVAL -C *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL -C LAST - INDEX FOR SUBDIVISION -C -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT QAGE - EPMACH = R1MACH(4) - UFLOW = R1MACH(1) -C -C TEST ON VALIDITY OF PARAMETERS -C ------------------------------ -C - IER = 0 - NEVAL = 0 - LAST = 0 - RESULT = 0.0E+00 - ABSERR = 0.0E+00 - ALIST(1) = A - BLIST(1) = B - RLIST(1) = 0.0E+00 - ELIST(1) = 0.0E+00 - IORD(1) = 0 - IF(EPSABS.LE.0.0E+00.AND. - 1 EPSREL.LT.MAX(0.5E+02*EPMACH,0.5E-14)) IER = 6 - IF(IER.EQ.6) GO TO 999 -C -C FIRST APPROXIMATION TO THE INTEGRAL -C ----------------------------------- -C - KEYF = KEY - IF(KEY.LE.0) KEYF = 1 - IF(KEY.GE.7) KEYF = 6 - NEVAL = 0 - IF(KEYF.EQ.1) CALL QK15(F,A,B,RESULT,ABSERR,DEFABS,RESABS) - IF(KEYF.EQ.2) CALL QK21(F,A,B,RESULT,ABSERR,DEFABS,RESABS) - IF(KEYF.EQ.3) CALL QK31(F,A,B,RESULT,ABSERR,DEFABS,RESABS) - IF(KEYF.EQ.4) CALL QK41(F,A,B,RESULT,ABSERR,DEFABS,RESABS) - IF(KEYF.EQ.5) CALL QK51(F,A,B,RESULT,ABSERR,DEFABS,RESABS) - IF(KEYF.EQ.6) CALL QK61(F,A,B,RESULT,ABSERR,DEFABS,RESABS) - LAST = 1 - RLIST(1) = RESULT - ELIST(1) = ABSERR - IORD(1) = 1 -C -C TEST ON ACCURACY. -C - ERRBND = MAX(EPSABS,EPSREL*ABS(RESULT)) - IF(ABSERR.LE.0.5E+02*EPMACH*DEFABS.AND.ABSERR.GT. - 1 ERRBND) IER = 2 - IF(LIMIT.EQ.1) IER = 1 - IF(IER.NE.0.OR.(ABSERR.LE.ERRBND.AND.ABSERR.NE.RESABS) - 1 .OR.ABSERR.EQ.0.0E+00) GO TO 60 -C -C INITIALIZATION -C -------------- -C -C - ERRMAX = ABSERR - MAXERR = 1 - AREA = RESULT - ERRSUM = ABSERR - NRMAX = 1 - IROFF1 = 0 - IROFF2 = 0 -C -C MAIN DO-LOOP -C ------------ -C - DO 30 LAST = 2,LIMIT -C -C BISECT THE SUBINTERVAL WITH THE LARGEST ERROR ESTIMATE. -C - A1 = ALIST(MAXERR) - B1 = 0.5E+00*(ALIST(MAXERR)+BLIST(MAXERR)) - A2 = B1 - B2 = BLIST(MAXERR) - IF(KEYF.EQ.1) CALL QK15(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) - IF(KEYF.EQ.2) CALL QK21(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) - IF(KEYF.EQ.3) CALL QK31(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) - IF(KEYF.EQ.4) CALL QK41(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) - IF(KEYF.EQ.5) CALL QK51(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) - IF(KEYF.EQ.6) CALL QK61(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) - IF(KEYF.EQ.1) CALL QK15(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) - IF(KEYF.EQ.2) CALL QK21(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) - IF(KEYF.EQ.3) CALL QK31(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) - IF(KEYF.EQ.4) CALL QK41(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) - IF(KEYF.EQ.5) CALL QK51(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) - IF(KEYF.EQ.6) CALL QK61(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) -C -C IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL -C AND ERROR AND TEST FOR ACCURACY. -C - NEVAL = NEVAL+1 - AREA12 = AREA1+AREA2 - ERRO12 = ERROR1+ERROR2 - ERRSUM = ERRSUM+ERRO12-ERRMAX - AREA = AREA+AREA12-RLIST(MAXERR) - IF(DEFAB1.EQ.ERROR1.OR.DEFAB2.EQ.ERROR2) GO TO 5 - IF(ABS(RLIST(MAXERR)-AREA12).LE.0.1E-04*ABS(AREA12) - 1 .AND.ERRO12.GE.0.99E+00*ERRMAX) IROFF1 = IROFF1+1 - IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF2 = IROFF2+1 - 5 RLIST(MAXERR) = AREA1 - RLIST(LAST) = AREA2 - ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) - IF(ERRSUM.LE.ERRBND) GO TO 8 -C -C TEST FOR ROUNDOFF ERROR AND EVENTUALLY -C SET ERROR FLAG. -C - IF(IROFF1.GE.6.OR.IROFF2.GE.20) IER = 2 -C -C SET ERROR FLAG IN THE CASE THAT THE NUMBER OF -C SUBINTERVALS EQUALS LIMIT. -C - IF(LAST.EQ.LIMIT) IER = 1 -C -C SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR -C AT A POINT OF THE INTEGRATION RANGE. -C - IF(MAX(ABS(A1),ABS(B2)).LE.(0.1E+01+0.1E+03* - 1 EPMACH)*(ABS(A2)+0.1E+04*UFLOW)) IER = 3 -C -C APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. -C - 8 IF(ERROR2.GT.ERROR1) GO TO 10 - ALIST(LAST) = A2 - BLIST(MAXERR) = B1 - BLIST(LAST) = B2 - ELIST(MAXERR) = ERROR1 - ELIST(LAST) = ERROR2 - GO TO 20 - 10 ALIST(MAXERR) = A2 - ALIST(LAST) = A1 - BLIST(LAST) = B1 - RLIST(MAXERR) = AREA2 - RLIST(LAST) = AREA1 - ELIST(MAXERR) = ERROR2 - ELIST(LAST) = ERROR1 -C -C CALL SUBROUTINE QPSRT TO MAINTAIN THE DESCENDING ORDERING -C IN THE LIST OF ERROR ESTIMATES AND SELECT THE -C SUBINTERVAL WITH THE LARGEST ERROR ESTIMATE (TO BE -C BISECTED NEXT). -C - 20 CALL QPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) -C ***JUMP OUT OF DO-LOOP - IF(IER.NE.0.OR.ERRSUM.LE.ERRBND) GO TO 40 - 30 CONTINUE -C -C COMPUTE FINAL RESULT. -C --------------------- -C - 40 RESULT = 0.0E+00 - DO 50 K=1,LAST - RESULT = RESULT+RLIST(K) - 50 CONTINUE - ABSERR = ERRSUM - 60 IF(KEYF.NE.1) NEVAL = (10*KEYF+1)*(2*NEVAL+1) - IF(KEYF.EQ.1) NEVAL = 30*NEVAL+15 - 999 RETURN - END diff --git a/slatec/qagi.f b/slatec/qagi.f deleted file mode 100644 index b7daef9..0000000 --- a/slatec/qagi.f +++ /dev/null @@ -1,204 +0,0 @@ -*DECK QAGI - SUBROUTINE QAGI (F, BOUND, INF, EPSABS, EPSREL, RESULT, ABSERR, - + NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK) -C***BEGIN PROLOGUE QAGI -C***PURPOSE The routine calculates an approximation result to a given -C INTEGRAL I = Integral of F over (BOUND,+INFINITY) -C OR I = Integral of F over (-INFINITY,BOUND) -C OR I = Integral of F over (-INFINITY,+INFINITY) -C Hopefully satisfying following claim for accuracy -C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A3A1, H2A4A1 -C***TYPE SINGLE PRECISION (QAGI-S, DQAGI-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, EXTRAPOLATION, GENERAL-PURPOSE, -C GLOBALLY ADAPTIVE, INFINITE INTERVALS, QUADPACK, -C QUADRATURE, TRANSFORMATION -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration over infinite intervals -C Standard fortran subroutine -C -C PARAMETERS -C ON ENTRY -C F - Real -C Function subprogram defining the integrand -C function F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C BOUND - Real -C Finite bound of integration range -C (has no meaning if interval is doubly-infinite) -C -C INF - Integer -C indicating the kind of integration range involved -C INF = 1 corresponds to (BOUND,+INFINITY), -C INF = -1 to (-INFINITY,BOUND), -C INF = 2 to (-INFINITY,+INFINITY). -C -C EPSABS - Real -C Absolute accuracy requested -C EPSREL - Real -C Relative accuracy requested -C If EPSABS.LE.0 -C and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C the routine will end with IER = 6. -C -C -C ON RETURN -C RESULT - Real -C Approximation to the integral -C -C ABSERR - Real -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C - IER.GT.0 abnormal termination of the routine. The -C estimates for result and error are less -C reliable. It is assumed that the requested -C accuracy has not been achieved. -C ERROR MESSAGES -C IER = 1 Maximum number of subdivisions allowed -C has been achieved. One can allow more -C subdivisions by increasing the value of -C LIMIT (and taking the according dimension -C adjustments into account). However, if -C this yields no improvement it is advised -C to analyze the integrand in order to -C determine the integration difficulties. If -C the position of a local difficulty can be -C determined (e.g. SINGULARITY, -C DISCONTINUITY within the interval) one -C will probably gain from splitting up the -C interval at this point and calling the -C integrator on the subranges. If possible, -C an appropriate special-purpose integrator -C should be used, which is designed for -C handling the type of difficulty involved. -C = 2 The occurrence of roundoff error is -C detected, which prevents the requested -C tolerance from being achieved. -C The error may be under-estimated. -C = 3 Extremely bad integrand behaviour occurs -C at some points of the integration -C interval. -C = 4 The algorithm does not converge. -C Roundoff error is detected in the -C extrapolation table. -C It is assumed that the requested tolerance -C cannot be achieved, and that the returned -C RESULT is the best which can be obtained. -C = 5 The integral is probably divergent, or -C slowly convergent. It must be noted that -C divergence can occur with any other value -C of IER. -C = 6 The input is invalid, because -C (EPSABS.LE.0 and -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)) -C or LIMIT.LT.1 or LENIW.LT.LIMIT*4. -C RESULT, ABSERR, NEVAL, LAST are set to -C zero. Except when LIMIT or LENIW is -C invalid, IWORK(1), WORK(LIMIT*2+1) and -C WORK(LIMIT*3+1) are set to ZERO, WORK(1) -C is set to A and WORK(LIMIT+1) to B. -C -C DIMENSIONING PARAMETERS -C LIMIT - Integer -C Dimensioning parameter for IWORK -C LIMIT determines the maximum number of subintervals -C in the partition of the given integration interval -C (A,B), LIMIT.GE.1. -C If LIMIT.LT.1, the routine will end with IER = 6. -C -C LENW - Integer -C Dimensioning parameter for WORK -C LENW must be at least LIMIT*4. -C If LENW.LT.LIMIT*4, the routine will end -C with IER = 6. -C -C LAST - Integer -C On return, LAST equals the number of subintervals -C produced in the subdivision process, which -C determines the number of significant elements -C actually in the WORK ARRAYS. -C -C WORK ARRAYS -C IWORK - Integer -C Vector of dimension at least LIMIT, the first -C K elements of which contain pointers -C to the error estimates over the subintervals, -C such that WORK(LIMIT*3+IWORK(1)),... , -C WORK(LIMIT*3+IWORK(K)) form a decreasing -C sequence, with K = LAST if LAST.LE.(LIMIT/2+2), and -C K = LIMIT+1-LAST otherwise -C -C WORK - Real -C Vector of dimension at least LENW -C on return -C WORK(1), ..., WORK(LAST) contain the left -C end points of the subintervals in the -C partition of (A,B), -C WORK(LIMIT+1), ..., WORK(LIMIT+LAST) Contain -C the right end points, -C WORK(LIMIT*2+1), ...,WORK(LIMIT*2+LAST) contain the -C integral approximations over the subintervals, -C WORK(LIMIT*3+1), ..., WORK(LIMIT*3) -C contain the error estimates. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED QAGIE, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800101 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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE QAGI -C - REAL ABSERR, EPSABS,EPSREL,F,RESULT,WORK - INTEGER IER,IWORK, LENW,LIMIT,LVL,L1,L2,L3,NEVAL -C - DIMENSION IWORK(*),WORK(*) -C - EXTERNAL F -C -C CHECK VALIDITY OF LIMIT AND LENW. -C -C***FIRST EXECUTABLE STATEMENT QAGI - IER = 6 - NEVAL = 0 - LAST = 0 - RESULT = 0.0E+00 - ABSERR = 0.0E+00 - IF(LIMIT.LT.1.OR.LENW.LT.LIMIT*4) GO TO 10 -C -C PREPARE CALL FOR QAGIE. -C - L1 = LIMIT+1 - L2 = LIMIT+L1 - L3 = LIMIT+L2 -C - CALL QAGIE(F,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,ABSERR, - 1 NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) -C -C CALL ERROR HANDLER IF NECESSARY. -C - LVL = 0 -10 IF(IER.EQ.6) LVL = 1 - IF (IER .NE. 0) CALL XERMSG ('SLATEC', 'QAGI', - + 'ABNORMAL RETURN', IER, LVL) - RETURN - END diff --git a/slatec/qagie.f b/slatec/qagie.f deleted file mode 100644 index 5a4bb0f..0000000 --- a/slatec/qagie.f +++ /dev/null @@ -1,469 +0,0 @@ -*DECK QAGIE - SUBROUTINE QAGIE (F, BOUND, INF, EPSABS, EPSREL, LIMIT, RESULT, - + ABSERR, NEVAL, IER, ALIST, BLIST, RLIST, ELIST, IORD, LAST) -C***BEGIN PROLOGUE QAGIE -C***PURPOSE The routine calculates an approximation result to a given -C integral I = Integral of F over (BOUND,+INFINITY) -C or I = Integral of F over (-INFINITY,BOUND) -C or I = Integral of F over (-INFINITY,+INFINITY), -C hopefully satisfying following claim for accuracy -C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)) -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A3A1, H2A4A1 -C***TYPE SINGLE PRECISION (QAGIE-S, DQAGIE-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, EXTRAPOLATION, GENERAL-PURPOSE, -C GLOBALLY ADAPTIVE, INFINITE INTERVALS, QUADPACK, -C QUADRATURE, TRANSFORMATION -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration over infinite intervals -C Standard fortran subroutine -C -C F - Real -C Function subprogram defining the integrand -C function F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C BOUND - Real -C Finite bound of integration range -C (has no meaning if interval is doubly-infinite) -C -C INF - Real -C Indicating the kind of integration range involved -C INF = 1 corresponds to (BOUND,+INFINITY), -C INF = -1 to (-INFINITY,BOUND), -C INF = 2 to (-INFINITY,+INFINITY). -C -C EPSABS - Real -C Absolute accuracy requested -C EPSREL - Real -C Relative accuracy requested -C If EPSABS.LE.0 -C and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C the routine will end with IER = 6. -C -C LIMIT - Integer -C Gives an upper bound on the number of subintervals -C in the partition of (A,B), LIMIT.GE.1 -C -C ON RETURN -C RESULT - Real -C Approximation to the integral -C -C ABSERR - Real -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C - IER.GT.0 Abnormal termination of the routine. The -C estimates for result and error are less -C reliable. It is assumed that the requested -C accuracy has not been achieved. -C ERROR MESSAGES -C IER = 1 Maximum number of subdivisions allowed -C has been achieved. One can allow more -C subdivisions by increasing the value of -C LIMIT (and taking the according dimension -C adjustments into account). However, if -C this yields no improvement it is advised -C to analyze the integrand in order to -C determine the integration difficulties. -C If the position of a local difficulty can -C be determined (e.g. SINGULARITY, -C DISCONTINUITY within the interval) one -C will probably gain from splitting up the -C interval at this point and calling the -C integrator on the subranges. If possible, -C an appropriate special-purpose integrator -C should be used, which is designed for -C handling the type of difficulty involved. -C = 2 The occurrence of roundoff error is -C detected, which prevents the requested -C tolerance from being achieved. -C The error may be under-estimated. -C = 3 Extremely bad integrand behaviour occurs -C at some points of the integration -C interval. -C = 4 The algorithm does not converge. -C Roundoff error is detected in the -C extrapolation table. -C It is assumed that the requested tolerance -C cannot be achieved, and that the returned -C result is the best which can be obtained. -C = 5 The integral is probably divergent, or -C slowly convergent. It must be noted that -C divergence can occur with any other value -C of IER. -C = 6 The input is invalid, because -C (EPSABS.LE.0 and -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C RESULT, ABSERR, NEVAL, LAST, RLIST(1), -C ELIST(1) and IORD(1) are set to zero. -C ALIST(1) and BLIST(1) are set to 0 -C and 1 respectively. -C -C ALIST - Real -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the left -C end points of the subintervals in the partition -C of the transformed integration range (0,1). -C -C BLIST - Real -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the right -C end points of the subintervals in the partition -C of the transformed integration range (0,1). -C -C RLIST - Real -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the integral -C approximations on the subintervals -C -C ELIST - Real -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the moduli of the -C absolute error estimates on the subintervals -C -C IORD - Integer -C Vector of dimension LIMIT, the first K -C elements of which are pointers to the -C error estimates over the subintervals, -C such that ELIST(IORD(1)), ..., ELIST(IORD(K)) -C form a decreasing sequence, with K = LAST -C If LAST.LE.(LIMIT/2+2), and K = LIMIT+1-LAST -C otherwise -C -C LAST - Integer -C Number of subintervals actually produced -C in the subdivision process -C -C***REFERENCES (NONE) -C***ROUTINES CALLED QELG, QK15I, QPSRT, R1MACH -C***REVISION HISTORY (YYMMDD) -C 800101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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***END PROLOGUE QAGIE -C - REAL ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1, - 1 A2,BLIST,BOUN,BOUND,B1,B2,CORREC,DEFABS,DEFAB1,DEFAB2, - 2 DRES,R1MACH,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST, - 3 ERRBND,ERRMAX,ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,F,OFLOW,RESABS, - 4 RESEPS,RESULT,RES3LA,RLIST,RLIST2,SMALL,UFLOW - INTEGER ID,IER,IERRO,INF,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K,KSGN, - 1 KTMIN,LAST,LIMIT,MAXERR,NEVAL,NRES,NRMAX,NUMRL2 - LOGICAL EXTRAP,NOEXT -C - DIMENSION ALIST(*),BLIST(*),ELIST(*),IORD(*), - 1 RES3LA(3),RLIST(*),RLIST2(52) -C - EXTERNAL F -C -C THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF -C LIMEXP IN SUBROUTINE QELG. -C -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER -C (ALIST(I),BLIST(I)) -C RLIST2 - ARRAY OF DIMENSION AT LEAST (LIMEXP+2), -C CONTAINING THE PART OF THE EPSILON TABLE -C WHICH IS STILL NEEDED FOR FURTHER COMPUTATIONS -C ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) -C MAXERR - POINTER TO THE INTERVAL WITH LARGEST ERROR -C ESTIMATE -C ERRMAX - ELIST(MAXERR) -C ERLAST - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED -C (BEFORE THAT SUBDIVISION HAS TAKEN PLACE) -C AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS -C ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS -C ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* -C ABS(RESULT)) -C *****1 - VARIABLE FOR THE LEFT SUBINTERVAL -C *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL -C LAST - INDEX FOR SUBDIVISION -C NRES - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE -C NUMRL2 - NUMBER OF ELEMENTS CURRENTLY IN RLIST2. IF AN -C APPROPRIATE APPROXIMATION TO THE COMPOUNDED -C INTEGRAL HAS BEEN OBTAINED, IT IS PUT IN -C RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED -C BY ONE. -C SMALL - LENGTH OF THE SMALLEST INTERVAL CONSIDERED UP -C TO NOW, MULTIPLIED BY 1.5 -C ERLARG - SUM OF THE ERRORS OVER THE INTERVALS LARGER -C THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW -C EXTRAP - LOGICAL VARIABLE DENOTING THAT THE ROUTINE -C IS ATTEMPTING TO PERFORM EXTRAPOLATION. I.E. -C BEFORE SUBDIVIDING THE SMALLEST INTERVAL WE -C TRY TO DECREASE THE VALUE OF ERLARG. -C NOEXT - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION -C IS NO LONGER ALLOWED (TRUE-VALUE) -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C OFLOW IS THE LARGEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT QAGIE - EPMACH = R1MACH(4) -C -C TEST ON VALIDITY OF PARAMETERS -C ----------------------------- -C - IER = 0 - NEVAL = 0 - LAST = 0 - RESULT = 0.0E+00 - ABSERR = 0.0E+00 - ALIST(1) = 0.0E+00 - BLIST(1) = 0.1E+01 - RLIST(1) = 0.0E+00 - ELIST(1) = 0.0E+00 - IORD(1) = 0 - IF(EPSABS.LE.0.0E+00.AND.EPSREL.LT.MAX(0.5E+02*EPMACH,0.5E-14)) - 1 IER = 6 - IF(IER.EQ.6) GO TO 999 -C -C -C FIRST APPROXIMATION TO THE INTEGRAL -C ----------------------------------- -C -C DETERMINE THE INTERVAL TO BE MAPPED ONTO (0,1). -C IF INF = 2 THE INTEGRAL IS COMPUTED AS I = I1+I2, WHERE -C I1 = INTEGRAL OF F OVER (-INFINITY,0), -C I2 = INTEGRAL OF F OVER (0,+INFINITY). -C - BOUN = BOUND - IF(INF.EQ.2) BOUN = 0.0E+00 - CALL QK15I(F,BOUN,INF,0.0E+00,0.1E+01,RESULT,ABSERR, - 1 DEFABS,RESABS) -C -C TEST ON ACCURACY -C - LAST = 1 - RLIST(1) = RESULT - ELIST(1) = ABSERR - IORD(1) = 1 - DRES = ABS(RESULT) - ERRBND = MAX(EPSABS,EPSREL*DRES) - IF(ABSERR.LE.1.0E+02*EPMACH*DEFABS.AND.ABSERR.GT. - 1 ERRBND) IER = 2 - IF(LIMIT.EQ.1) IER = 1 - IF(IER.NE.0.OR.(ABSERR.LE.ERRBND.AND.ABSERR.NE.RESABS).OR. - 1 ABSERR.EQ.0.0E+00) GO TO 130 -C -C INITIALIZATION -C -------------- -C - UFLOW = R1MACH(1) - OFLOW = R1MACH(2) - RLIST2(1) = RESULT - ERRMAX = ABSERR - MAXERR = 1 - AREA = RESULT - ERRSUM = ABSERR - ABSERR = OFLOW - NRMAX = 1 - NRES = 0 - KTMIN = 0 - NUMRL2 = 2 - EXTRAP = .FALSE. - NOEXT = .FALSE. - IERRO = 0 - IROFF1 = 0 - IROFF2 = 0 - IROFF3 = 0 - KSGN = -1 - IF(DRES.GE.(0.1E+01-0.5E+02*EPMACH)*DEFABS) KSGN = 1 -C -C MAIN DO-LOOP -C ------------ -C - DO 90 LAST = 2,LIMIT -C -C BISECT THE SUBINTERVAL WITH NRMAX-TH LARGEST -C ERROR ESTIMATE. -C - A1 = ALIST(MAXERR) - B1 = 0.5E+00*(ALIST(MAXERR)+BLIST(MAXERR)) - A2 = B1 - B2 = BLIST(MAXERR) - ERLAST = ERRMAX - CALL QK15I(F,BOUN,INF,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) - CALL QK15I(F,BOUN,INF,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) -C -C IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL -C AND ERROR AND TEST FOR ACCURACY. -C - AREA12 = AREA1+AREA2 - ERRO12 = ERROR1+ERROR2 - ERRSUM = ERRSUM+ERRO12-ERRMAX - AREA = AREA+AREA12-RLIST(MAXERR) - IF(DEFAB1.EQ.ERROR1.OR.DEFAB2.EQ.ERROR2)GO TO 15 - IF(ABS(RLIST(MAXERR)-AREA12).GT.0.1E-04*ABS(AREA12) - 1 .OR.ERRO12.LT.0.99E+00*ERRMAX) GO TO 10 - IF(EXTRAP) IROFF2 = IROFF2+1 - IF(.NOT.EXTRAP) IROFF1 = IROFF1+1 - 10 IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF3 = IROFF3+1 - 15 RLIST(MAXERR) = AREA1 - RLIST(LAST) = AREA2 - ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) -C -C TEST FOR ROUNDOFF ERROR AND EVENTUALLY -C SET ERROR FLAG. -C - IF(IROFF1+IROFF2.GE.10.OR.IROFF3.GE.20) IER = 2 - IF(IROFF2.GE.5) IERRO = 3 -C -C SET ERROR FLAG IN THE CASE THAT THE NUMBER OF -C SUBINTERVALS EQUALS LIMIT. -C - IF(LAST.EQ.LIMIT) IER = 1 -C -C SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR -C AT SOME POINTS OF THE INTEGRATION RANGE. -C - IF(MAX(ABS(A1),ABS(B2)).LE.(0.1E+01+0.1E+03*EPMACH)* - 1 (ABS(A2)+0.1E+04*UFLOW)) IER = 4 -C -C APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. -C - IF(ERROR2.GT.ERROR1) GO TO 20 - ALIST(LAST) = A2 - BLIST(MAXERR) = B1 - BLIST(LAST) = B2 - ELIST(MAXERR) = ERROR1 - ELIST(LAST) = ERROR2 - GO TO 30 - 20 ALIST(MAXERR) = A2 - ALIST(LAST) = A1 - BLIST(LAST) = B1 - RLIST(MAXERR) = AREA2 - RLIST(LAST) = AREA1 - ELIST(MAXERR) = ERROR2 - ELIST(LAST) = ERROR1 -C -C CALL SUBROUTINE QPSRT TO MAINTAIN THE DESCENDING ORDERING -C IN THE LIST OF ERROR ESTIMATES AND SELECT THE -C SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE -C BISECTED NEXT). -C - 30 CALL QPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) - IF(ERRSUM.LE.ERRBND) GO TO 115 - IF(IER.NE.0) GO TO 100 - IF(LAST.EQ.2) GO TO 80 - IF(NOEXT) GO TO 90 - ERLARG = ERLARG-ERLAST - IF(ABS(B1-A1).GT.SMALL) ERLARG = ERLARG+ERRO12 - IF(EXTRAP) GO TO 40 -C -C TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE -C SMALLEST INTERVAL. -C - IF(ABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90 - EXTRAP = .TRUE. - NRMAX = 2 - 40 IF(IERRO.EQ.3.OR.ERLARG.LE.ERTEST) GO TO 60 -C -C THE SMALLEST INTERVAL HAS THE LARGEST ERROR. -C BEFORE BISECTING DECREASE THE SUM OF THE ERRORS -C OVER THE LARGER INTERVALS (ERLARG) AND PERFORM -C EXTRAPOLATION. -C - ID = NRMAX - JUPBND = LAST - IF(LAST.GT.(2+LIMIT/2)) JUPBND = LIMIT+3-LAST - DO 50 K = ID,JUPBND - MAXERR = IORD(NRMAX) - ERRMAX = ELIST(MAXERR) - IF(ABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90 - NRMAX = NRMAX+1 - 50 CONTINUE -C -C PERFORM EXTRAPOLATION. -C - 60 NUMRL2 = NUMRL2+1 - RLIST2(NUMRL2) = AREA - CALL QELG(NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES) - KTMIN = KTMIN+1 - IF(KTMIN.GT.5.AND.ABSERR.LT.0.1E-02*ERRSUM) IER = 5 - IF(ABSEPS.GE.ABSERR) GO TO 70 - KTMIN = 0 - ABSERR = ABSEPS - RESULT = RESEPS - CORREC = ERLARG - ERTEST = MAX(EPSABS,EPSREL*ABS(RESEPS)) - IF(ABSERR.LE.ERTEST) GO TO 100 -C -C PREPARE BISECTION OF THE SMALLEST INTERVAL. -C - 70 IF(NUMRL2.EQ.1) NOEXT = .TRUE. - IF(IER.EQ.5) GO TO 100 - MAXERR = IORD(1) - ERRMAX = ELIST(MAXERR) - NRMAX = 1 - EXTRAP = .FALSE. - SMALL = SMALL*0.5E+00 - ERLARG = ERRSUM - GO TO 90 - 80 SMALL = 0.375E+00 - ERLARG = ERRSUM - ERTEST = ERRBND - RLIST2(2) = AREA - 90 CONTINUE -C -C SET FINAL RESULT AND ERROR ESTIMATE. -C ------------------------------------ -C - 100 IF(ABSERR.EQ.OFLOW) GO TO 115 - IF((IER+IERRO).EQ.0) GO TO 110 - IF(IERRO.EQ.3) ABSERR = ABSERR+CORREC - IF(IER.EQ.0) IER = 3 - IF(RESULT.NE.0.0E+00.AND.AREA.NE.0.0E+00)GO TO 105 - IF(ABSERR.GT.ERRSUM)GO TO 115 - IF(AREA.EQ.0.0E+00) GO TO 130 - GO TO 110 - 105 IF(ABSERR/ABS(RESULT).GT.ERRSUM/ABS(AREA))GO TO 115 -C -C TEST ON DIVERGENCE -C - 110 IF(KSGN.EQ.(-1).AND.MAX(ABS(RESULT),ABS(AREA)).LE. - 1 DEFABS*0.1E-01) GO TO 130 - IF (0.1E-01.GT.(RESULT/AREA).OR.(RESULT/AREA).GT.0.1E+03 - 1 .OR.ERRSUM.GT.ABS(AREA)) IER = 6 - GO TO 130 -C -C COMPUTE GLOBAL INTEGRAL SUM. -C - 115 RESULT = 0.0E+00 - DO 120 K = 1,LAST - RESULT = RESULT+RLIST(K) - 120 CONTINUE - ABSERR = ERRSUM - 130 NEVAL = 30*LAST-15 - IF(INF.EQ.2) NEVAL = 2*NEVAL - IF(IER.GT.2) IER=IER-1 - 999 RETURN - END diff --git a/slatec/qagp.f b/slatec/qagp.f deleted file mode 100644 index 0b70102..0000000 --- a/slatec/qagp.f +++ /dev/null @@ -1,236 +0,0 @@ -*DECK QAGP - SUBROUTINE QAGP (F, A, B, NPTS2, POINTS, EPSABS, EPSREL, RESULT, - + ABSERR, NEVAL, IER, LENIW, LENW, LAST, IWORK, WORK) -C***BEGIN PROLOGUE QAGP -C***PURPOSE The routine calculates an approximation result to a given -C definite integral I = Integral of F over (A,B), -C hopefully satisfying following claim for accuracy -C break points of the integration interval, where local -C difficulties of the integrand may occur(e.g. SINGULARITIES, -C DISCONTINUITIES), are provided by the user. -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A2A1 -C***TYPE SINGLE PRECISION (QAGP-S, DQAGP-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, EXTRAPOLATION, GENERAL-PURPOSE, -C GLOBALLY ADAPTIVE, QUADPACK, QUADRATURE, -C SINGULARITIES AT USER SPECIFIED POINTS -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Computation of a definite integral -C Standard fortran subroutine -C Real version -C -C PARAMETERS -C ON ENTRY -C F - Real -C Function subprogram defining the integrand -C Function F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C A - Real -C Lower limit of integration -C -C B - Real -C Upper limit of integration -C -C NPTS2 - Integer -C Number equal to two more than the number of -C user-supplied break points within the integration -C range, NPTS.GE.2. -C If NPTS2.LT.2, The routine will end with IER = 6. -C -C POINTS - Real -C Vector of dimension NPTS2, the first (NPTS2-2) -C elements of which are the user provided break -C points. If these points do not constitute an -C ascending sequence there will be an automatic -C sorting. -C -C EPSABS - Real -C Absolute accuracy requested -C EPSREL - Real -C Relative accuracy requested -C If EPSABS.LE.0 -C And EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C The routine will end with IER = 6. -C -C ON RETURN -C RESULT - Real -C Approximation to the integral -C -C ABSERR - Real -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C IER.GT.0 Abnormal termination of the routine. -C The estimates for integral and error are -C less reliable. it is assumed that the -C requested accuracy has not been achieved. -C ERROR MESSAGES -C IER = 1 Maximum number of subdivisions allowed -C has been achieved. one can allow more -C subdivisions by increasing the value of -C LIMIT (and taking the according dimension -C adjustments into account). However, if -C this yields no improvement it is advised -C to analyze the integrand in order to -C determine the integration difficulties. If -C the position of a local difficulty can be -C determined (i.e. SINGULARITY, -C DISCONTINUITY within the interval), it -C should be supplied to the routine as an -C element of the vector points. If necessary -C an appropriate special-purpose integrator -C must be used, which is designed for -C handling the type of difficulty involved. -C = 2 The occurrence of roundoff error is -C detected, which prevents the requested -C tolerance from being achieved. -C The error may be under-estimated. -C = 3 Extremely bad integrand behaviour occurs -C at some points of the integration -C interval. -C = 4 The algorithm does not converge. -C roundoff error is detected in the -C extrapolation table. -C It is presumed that the requested -C tolerance cannot be achieved, and that -C the returned RESULT is the best which -C can be obtained. -C = 5 The integral is probably divergent, or -C slowly convergent. it must be noted that -C divergence can occur with any other value -C of IER.GT.0. -C = 6 The input is invalid because -C NPTS2.LT.2 or -C break points are specified outside -C the integration range or -C (EPSABS.LE.0 and -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)) -C RESULT, ABSERR, NEVAL, LAST are set to -C zero. Except when LENIW or LENW or NPTS2 -C is invalid, IWORK(1), IWORK(LIMIT+1), -C WORK(LIMIT*2+1) and WORK(LIMIT*3+1) -C are set to zero. -C WORK(1) is set to A and WORK(LIMIT+1) -C to B (where LIMIT = (LENIW-NPTS2)/2). -C -C DIMENSIONING PARAMETERS -C LENIW - Integer -C Dimensioning parameter for IWORK -C LENIW determines LIMIT = (LENIW-NPTS2)/2, -C which is the maximum number of subintervals in the -C partition of the given integration interval (A,B), -C LENIW.GE.(3*NPTS2-2). -C If LENIW.LT.(3*NPTS2-2), the routine will end with -C IER = 6. -C -C LENW - Integer -C Dimensioning parameter for WORK -C LENW must be at least LENIW*2-NPTS2. -C If LENW.LT.LENIW*2-NPTS2, the routine will end -C with IER = 6. -C -C LAST - Integer -C On return, LAST equals the number of subintervals -C produced in the subdivision process, which -C determines the number of significant elements -C actually in the WORK ARRAYS. -C -C WORK ARRAYS -C IWORK - Integer -C Vector of dimension at least LENIW. on return, -C the first K elements of which contain -C pointers to the error estimates over the -C subintervals, such that WORK(LIMIT*3+IWORK(1)),..., -C WORK(LIMIT*3+IWORK(K)) form a decreasing -C sequence, with K = LAST if LAST.LE.(LIMIT/2+2), and -C K = LIMIT+1-LAST otherwise -C IWORK(LIMIT+1), ...,IWORK(LIMIT+LAST) Contain the -C subdivision levels of the subintervals, i.e. -C if (AA,BB) is a subinterval of (P1,P2) -C where P1 as well as P2 is a user-provided -C break point or integration LIMIT, then (AA,BB) has -C level L if ABS(BB-AA) = ABS(P2-P1)*2**(-L), -C IWORK(LIMIT*2+1), ..., IWORK(LIMIT*2+NPTS2) have -C no significance for the user, -C note that LIMIT = (LENIW-NPTS2)/2. -C -C WORK - Real -C Vector of dimension at least LENW -C on return -C WORK(1), ..., WORK(LAST) contain the left -C end points of the subintervals in the -C partition of (A,B), -C WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain -C the right end points, -C WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) contain -C the integral approximations over the subintervals, -C WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) -C contain the corresponding error estimates, -C WORK(LIMIT*4+1), ..., WORK(LIMIT*4+NPTS2) -C contain the integration limits and the -C break points sorted in an ascending sequence. -C note that LIMIT = (LENIW-NPTS2)/2. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED QAGPE, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800101 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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE QAGP -C - REAL A,ABSERR,B,EPSABS,EPSREL,F,POINTS,RESULT,WORK - INTEGER IER,IWORK,LENIW,LENW,LIMIT,LVL,L1,L2,L3,NEVAL,NPTS2 -C - DIMENSION IWORK(*),POINTS(*),WORK(*) -C - EXTERNAL F -C -C CHECK VALIDITY OF LIMIT AND LENW. -C -C***FIRST EXECUTABLE STATEMENT QAGP - IER = 6 - NEVAL = 0 - LAST = 0 - RESULT = 0.0E+00 - ABSERR = 0.0E+00 - IF(LENIW.LT.(3*NPTS2-2).OR.LENW.LT.(LENIW*2-NPTS2).OR.NPTS2.LT.2) - 1 GO TO 10 -C -C PREPARE CALL FOR QAGPE. -C - LIMIT = (LENIW-NPTS2)/2 - L1 = LIMIT+1 - L2 = LIMIT+L1 - L3 = LIMIT+L2 - L4 = LIMIT+L3 -C - CALL QAGPE(F,A,B,NPTS2,POINTS,EPSABS,EPSREL,LIMIT,RESULT,ABSERR, - 1 NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),WORK(L4), - 2 IWORK(1),IWORK(L1),IWORK(L2),LAST) -C -C CALL ERROR HANDLER IF NECESSARY. -C - LVL = 0 -10 IF(IER.EQ.6) LVL = 1 - IF (IER .NE. 0) CALL XERMSG ('SLATEC', 'QAGP', - + 'ABNORMAL RETURN', IER, LVL) - RETURN - END diff --git a/slatec/qagpe.f b/slatec/qagpe.f deleted file mode 100644 index 62fe2bc..0000000 --- a/slatec/qagpe.f +++ /dev/null @@ -1,569 +0,0 @@ -*DECK QAGPE - SUBROUTINE QAGPE (F, A, B, NPTS2, POINTS, EPSABS, EPSREL, LIMIT, - + RESULT, ABSERR, NEVAL, IER, ALIST, BLIST, RLIST, ELIST, PTS, - + IORD, LEVEL, NDIN, LAST) -C***BEGIN PROLOGUE QAGPE -C***PURPOSE Approximate a given definite integral I = Integral of F -C over (A,B), hopefully satisfying the accuracy claim: -C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). -C Break points of the integration interval, where local -C difficulties of the integrand may occur (e.g. singularities -C or discontinuities) are provided by the user. -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A2A1 -C***TYPE SINGLE PRECISION (QAGPE-S, DQAGPE-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, EXTRAPOLATION, GENERAL-PURPOSE, -C GLOBALLY ADAPTIVE, QUADPACK, QUADRATURE, -C SINGULARITIES AT USER SPECIFIED POINTS -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Computation of a definite integral -C Standard fortran subroutine -C Real version -C -C PARAMETERS -C ON ENTRY -C F - Real -C Function subprogram defining the integrand -C function F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C A - Real -C Lower limit of integration -C -C B - Real -C Upper limit of integration -C -C NPTS2 - Integer -C Number equal to two more than the number of -C user-supplied break points within the integration -C range, NPTS2.GE.2. -C If NPTS2.LT.2, the routine will end with IER = 6. -C -C POINTS - Real -C Vector of dimension NPTS2, the first (NPTS2-2) -C elements of which are the user provided break -C POINTS. If these POINTS do not constitute an -C ascending sequence there will be an automatic -C sorting. -C -C EPSABS - Real -C Absolute accuracy requested -C EPSREL - Real -C Relative accuracy requested -C If EPSABS.LE.0 -C and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C the routine will end with IER = 6. -C -C LIMIT - Integer -C Gives an upper bound on the number of subintervals -C in the partition of (A,B), LIMIT.GE.NPTS2 -C If LIMIT.LT.NPTS2, the routine will end with -C IER = 6. -C -C ON RETURN -C RESULT - Real -C Approximation to the integral -C -C ABSERR - Real -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C IER.GT.0 Abnormal termination of the routine. -C The estimates for integral and error are -C less reliable. It is assumed that the -C requested accuracy has not been achieved. -C ERROR MESSAGES -C IER = 1 Maximum number of subdivisions allowed -C has been achieved. One can allow more -C subdivisions by increasing the value of -C LIMIT (and taking the according dimension -C adjustments into account). However, if -C this yields no improvement it is advised -C to analyze the integrand in order to -C determine the integration difficulties. If -C the position of a local difficulty can be -C determined (i.e. SINGULARITY, -C DISCONTINUITY within the interval), it -C should be supplied to the routine as an -C element of the vector points. If necessary -C an appropriate special-purpose integrator -C must be used, which is designed for -C handling the type of difficulty involved. -C = 2 The occurrence of roundoff error is -C detected, which prevents the requested -C tolerance from being achieved. -C The error may be under-estimated. -C = 3 Extremely bad integrand behaviour occurs -C At some points of the integration -C interval. -C = 4 The algorithm does not converge. -C Roundoff error is detected in the -C extrapolation table. It is presumed that -C the requested tolerance cannot be -C achieved, and that the returned result is -C the best which can be obtained. -C = 5 The integral is probably divergent, or -C slowly convergent. It must be noted that -C divergence can occur with any other value -C of IER.GT.0. -C = 6 The input is invalid because -C NPTS2.LT.2 or -C Break points are specified outside -C the integration range or -C (EPSABS.LE.0 and -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)) -C or LIMIT.LT.NPTS2. -C RESULT, ABSERR, NEVAL, LAST, RLIST(1), -C and ELIST(1) are set to zero. ALIST(1) and -C BLIST(1) are set to A and B respectively. -C -C ALIST - Real -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the left end points -C of the subintervals in the partition of the given -C integration range (A,B) -C -C BLIST - Real -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the right end points -C of the subintervals in the partition of the given -C integration range (A,B) -C -C RLIST - Real -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the integral -C approximations on the subintervals -C -C ELIST - Real -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the moduli of the -C absolute error estimates on the subintervals -C -C PTS - Real -C Vector of dimension at least NPTS2, containing the -C integration limits and the break points of the -C interval in ascending sequence. -C -C LEVEL - Integer -C Vector of dimension at least LIMIT, containing the -C subdivision levels of the subinterval, i.e. if -C (AA,BB) is a subinterval of (P1,P2) where P1 as -C well as P2 is a user-provided break point or -C integration limit, then (AA,BB) has level L if -C ABS(BB-AA) = ABS(P2-P1)*2**(-L). -C -C NDIN - Integer -C Vector of dimension at least NPTS2, after first -C integration over the intervals (PTS(I)),PTS(I+1), -C I = 0,1, ..., NPTS2-2, the error estimates over -C some of the intervals may have been increased -C artificially, in order to put their subdivision -C forward. If this happens for the subinterval -C numbered K, NDIN(K) is put to 1, otherwise -C NDIN(K) = 0. -C -C IORD - Integer -C Vector of dimension at least LIMIT, the first K -C elements of which are pointers to the -C error estimates over the subintervals, -C such that ELIST(IORD(1)), ..., ELIST(IORD(K)) -C form a decreasing sequence, with K = LAST -C If LAST.LE.(LIMIT/2+2), and K = LIMIT+1-LAST -C otherwise -C -C LAST - Integer -C Number of subintervals actually produced in the -C subdivisions process -C -C***REFERENCES (NONE) -C***ROUTINES CALLED QELG, QK21, QPSRT, R1MACH -C***REVISION HISTORY (YYMMDD) -C 800101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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***END PROLOGUE QAGPE - REAL A,ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1, - 1 A2,B,BLIST,B1,B2,CORREC,DEFABS,DEFAB1,DEFAB2, - 2 DRES,R1MACH,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND, - 3 ERRMAX,ERROR1,ERRO12,ERROR2,ERRSUM,ERTEST,F,OFLOW,POINTS,PTS, - 4 RESA,RESABS,RESEPS,RESULT,RES3LA,RLIST,RLIST2,SIGN,TEMP, - 5 UFLOW - INTEGER I,ID,IER,IERRO,IND1,IND2,IORD,IP1,IROFF1,IROFF2, - 1 IROFF3,J,JLOW,JUPBND,K,KSGN,KTMIN,LAST,LEVCUR,LEVEL,LEVMAX, - 2 LIMIT,MAXERR,NDIN,NEVAL,NINT,NINTP1,NPTS,NPTS2,NRES, - 3 NRMAX,NUMRL2 - LOGICAL EXTRAP,NOEXT -C -C - DIMENSION ALIST(*),BLIST(*),ELIST(*),IORD(*), - 1 LEVEL(*),NDIN(*),POINTS(*),PTS(*),RES3LA(3), - 2 RLIST(*),RLIST2(52) -C - EXTERNAL F -C -C THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF -C LIMEXP IN SUBROUTINE EPSALG (RLIST2 SHOULD BE OF DIMENSION -C (LIMEXP+2) AT LEAST). -C -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER -C (ALIST(I),BLIST(I)) -C RLIST2 - ARRAY OF DIMENSION AT LEAST LIMEXP+2 -C CONTAINING THE PART OF THE EPSILON TABLE WHICH -C IS STILL NEEDED FOR FURTHER COMPUTATIONS -C ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) -C MAXERR - POINTER TO THE INTERVAL WITH LARGEST ERROR -C ESTIMATE -C ERRMAX - ELIST(MAXERR) -C ERLAST - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED -C (BEFORE THAT SUBDIVISION HAS TAKEN PLACE) -C AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS -C ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS -C ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* -C ABS(RESULT)) -C *****1 - VARIABLE FOR THE LEFT SUBINTERVAL -C *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL -C LAST - INDEX FOR SUBDIVISION -C NRES - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE -C NUMRL2 - NUMBER OF ELEMENTS IN RLIST2. IF AN -C APPROPRIATE APPROXIMATION TO THE COMPOUNDED -C INTEGRAL HAS BEEN OBTAINED, IT IS PUT IN -C RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED -C BY ONE. -C ERLARG - SUM OF THE ERRORS OVER THE INTERVALS LARGER -C THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW -C EXTRAP - LOGICAL VARIABLE DENOTING THAT THE ROUTINE -C IS ATTEMPTING TO PERFORM EXTRAPOLATION. I.E. -C BEFORE SUBDIVIDING THE SMALLEST INTERVAL WE -C TRY TO DECREASE THE VALUE OF ERLARG. -C NOEXT - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION IS -C NO LONGER ALLOWED (TRUE-VALUE) -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C OFLOW IS THE LARGEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT QAGPE - EPMACH = R1MACH(4) -C -C TEST ON VALIDITY OF PARAMETERS -C ----------------------------- -C - IER = 0 - NEVAL = 0 - LAST = 0 - RESULT = 0.0E+00 - ABSERR = 0.0E+00 - ALIST(1) = A - BLIST(1) = B - RLIST(1) = 0.0E+00 - ELIST(1) = 0.0E+00 - IORD(1) = 0 - LEVEL(1) = 0 - NPTS = NPTS2-2 - IF(NPTS2.LT.2.OR.LIMIT.LE.NPTS.OR.(EPSABS.LE.0.0E+00.AND. - 1 EPSREL.LT.MAX(0.5E+02*EPMACH,0.5E-14))) IER = 6 - IF(IER.EQ.6) GO TO 999 -C -C IF ANY BREAK POINTS ARE PROVIDED, SORT THEM INTO AN -C ASCENDING SEQUENCE. -C - SIGN = 1.0E+00 - IF(A.GT.B) SIGN = -1.0E+00 - PTS(1) = MIN(A,B) - IF(NPTS.EQ.0) GO TO 15 - DO 10 I = 1,NPTS - PTS(I+1) = POINTS(I) - 10 CONTINUE - 15 PTS(NPTS+2) = MAX(A,B) - NINT = NPTS+1 - A1 = PTS(1) - IF(NPTS.EQ.0) GO TO 40 - NINTP1 = NINT+1 - DO 20 I = 1,NINT - IP1 = I+1 - DO 20 J = IP1,NINTP1 - IF(PTS(I).LE.PTS(J)) GO TO 20 - TEMP = PTS(I) - PTS(I) = PTS(J) - PTS(J) = TEMP - 20 CONTINUE - IF(PTS(1).NE.MIN(A,B).OR.PTS(NINTP1).NE. - 1 MAX(A,B)) IER = 6 - IF(IER.EQ.6) GO TO 999 -C -C COMPUTE FIRST INTEGRAL AND ERROR APPROXIMATIONS. -C ------------------------------------------------ -C - 40 RESABS = 0.0E+00 - DO 50 I = 1,NINT - B1 = PTS(I+1) - CALL QK21(F,A1,B1,AREA1,ERROR1,DEFABS,RESA) - ABSERR = ABSERR+ERROR1 - RESULT = RESULT+AREA1 - NDIN(I) = 0 - IF(ERROR1.EQ.RESA.AND.ERROR1.NE.0.0E+00) NDIN(I) = 1 - RESABS = RESABS+DEFABS - LEVEL(I) = 0 - ELIST(I) = ERROR1 - ALIST(I) = A1 - BLIST(I) = B1 - RLIST(I) = AREA1 - IORD(I) = I - A1 = B1 - 50 CONTINUE - ERRSUM = 0.0E+00 - DO 55 I = 1,NINT - IF(NDIN(I).EQ.1) ELIST(I) = ABSERR - ERRSUM = ERRSUM+ELIST(I) - 55 CONTINUE -C -C TEST ON ACCURACY. -C - LAST = NINT - NEVAL = 21*NINT - DRES = ABS(RESULT) - ERRBND = MAX(EPSABS,EPSREL*DRES) - IF(ABSERR.LE.0.1E+03*EPMACH*RESABS.AND.ABSERR.GT. - 1 ERRBND) IER = 2 - IF(NINT.EQ.1) GO TO 80 - DO 70 I = 1,NPTS - JLOW = I+1 - IND1 = IORD(I) - DO 60 J = JLOW,NINT - IND2 = IORD(J) - IF(ELIST(IND1).GT.ELIST(IND2)) GO TO 60 - IND1 = IND2 - K = J - 60 CONTINUE - IF(IND1.EQ.IORD(I)) GO TO 70 - IORD(K) = IORD(I) - IORD(I) = IND1 - 70 CONTINUE - IF(LIMIT.LT.NPTS2) IER = 1 - 80 IF(IER.NE.0.OR.ABSERR.LE.ERRBND) GO TO 999 -C -C INITIALIZATION -C -------------- -C - RLIST2(1) = RESULT - MAXERR = IORD(1) - ERRMAX = ELIST(MAXERR) - AREA = RESULT - NRMAX = 1 - NRES = 0 - NUMRL2 = 1 - KTMIN = 0 - EXTRAP = .FALSE. - NOEXT = .FALSE. - ERLARG = ERRSUM - ERTEST = ERRBND - LEVMAX = 1 - IROFF1 = 0 - IROFF2 = 0 - IROFF3 = 0 - IERRO = 0 - UFLOW = R1MACH(1) - OFLOW = R1MACH(2) - ABSERR = OFLOW - KSGN = -1 - IF(DRES.GE.(0.1E+01-0.5E+02*EPMACH)*RESABS) KSGN = 1 -C -C MAIN DO-LOOP -C ------------ -C - DO 160 LAST = NPTS2,LIMIT -C -C BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST -C ERROR ESTIMATE. -C - LEVCUR = LEVEL(MAXERR)+1 - A1 = ALIST(MAXERR) - B1 = 0.5E+00*(ALIST(MAXERR)+BLIST(MAXERR)) - A2 = B1 - B2 = BLIST(MAXERR) - ERLAST = ERRMAX - CALL QK21(F,A1,B1,AREA1,ERROR1,RESA,DEFAB1) - CALL QK21(F,A2,B2,AREA2,ERROR2,RESA,DEFAB2) -C -C IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL -C AND ERROR AND TEST FOR ACCURACY. -C - NEVAL = NEVAL+42 - AREA12 = AREA1+AREA2 - ERRO12 = ERROR1+ERROR2 - ERRSUM = ERRSUM+ERRO12-ERRMAX - AREA = AREA+AREA12-RLIST(MAXERR) - IF(DEFAB1.EQ.ERROR1.OR.DEFAB2.EQ.ERROR2) GO TO 95 - IF(ABS(RLIST(MAXERR)-AREA12).GT.0.1E-04*ABS(AREA12) - 1 .OR.ERRO12.LT.0.99E+00*ERRMAX) GO TO 90 - IF(EXTRAP) IROFF2 = IROFF2+1 - IF(.NOT.EXTRAP) IROFF1 = IROFF1+1 - 90 IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF3 = IROFF3+1 - 95 LEVEL(MAXERR) = LEVCUR - LEVEL(LAST) = LEVCUR - RLIST(MAXERR) = AREA1 - RLIST(LAST) = AREA2 - ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) -C -C TEST FOR ROUNDOFF ERROR AND EVENTUALLY -C SET ERROR FLAG. -C - IF(IROFF1+IROFF2.GE.10.OR.IROFF3.GE.20) IER = 2 - IF(IROFF2.GE.5) IERRO = 3 -C -C SET ERROR FLAG IN THE CASE THAT THE NUMBER OF -C SUBINTERVALS EQUALS LIMIT. -C - IF(LAST.EQ.LIMIT) IER = 1 -C -C SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR -C AT A POINT OF THE INTEGRATION RANGE -C - IF(MAX(ABS(A1),ABS(B2)).LE.(0.1E+01+0.1E+03*EPMACH)* - 1 (ABS(A2)+0.1E+04*UFLOW)) IER = 4 -C -C APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. -C - IF(ERROR2.GT.ERROR1) GO TO 100 - ALIST(LAST) = A2 - BLIST(MAXERR) = B1 - BLIST(LAST) = B2 - ELIST(MAXERR) = ERROR1 - ELIST(LAST) = ERROR2 - GO TO 110 - 100 ALIST(MAXERR) = A2 - ALIST(LAST) = A1 - BLIST(LAST) = B1 - RLIST(MAXERR) = AREA2 - RLIST(LAST) = AREA1 - ELIST(MAXERR) = ERROR2 - ELIST(LAST) = ERROR1 -C -C CALL SUBROUTINE QPSRT TO MAINTAIN THE DESCENDING ORDERING -C IN THE LIST OF ERROR ESTIMATES AND SELECT THE -C SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE -C BISECTED NEXT). -C - 110 CALL QPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) -C ***JUMP OUT OF DO-LOOP - IF(ERRSUM.LE.ERRBND) GO TO 190 -C ***JUMP OUT OF DO-LOOP - IF(IER.NE.0) GO TO 170 - IF(NOEXT) GO TO 160 - ERLARG = ERLARG-ERLAST - IF(LEVCUR+1.LE.LEVMAX) ERLARG = ERLARG+ERRO12 - IF(EXTRAP) GO TO 120 -C -C TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE -C SMALLEST INTERVAL. -C - IF(LEVEL(MAXERR)+1.LE.LEVMAX) GO TO 160 - EXTRAP = .TRUE. - NRMAX = 2 - 120 IF(IERRO.EQ.3.OR.ERLARG.LE.ERTEST) GO TO 140 -C -C THE SMALLEST INTERVAL HAS THE LARGEST ERROR. -C BEFORE BISECTING DECREASE THE SUM OF THE ERRORS -C OVER THE LARGER INTERVALS (ERLARG) AND PERFORM -C EXTRAPOLATION. -C - ID = NRMAX - JUPBND = LAST - IF(LAST.GT.(2+LIMIT/2)) JUPBND = LIMIT+3-LAST - DO 130 K = ID,JUPBND - MAXERR = IORD(NRMAX) - ERRMAX = ELIST(MAXERR) -C ***JUMP OUT OF DO-LOOP - IF(LEVEL(MAXERR)+1.LE.LEVMAX) GO TO 160 - NRMAX = NRMAX+1 - 130 CONTINUE -C -C PERFORM EXTRAPOLATION. -C - 140 NUMRL2 = NUMRL2+1 - RLIST2(NUMRL2) = AREA - IF(NUMRL2.LE.2) GO TO 155 - CALL QELG(NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES) - KTMIN = KTMIN+1 - IF(KTMIN.GT.5.AND.ABSERR.LT.0.1E-02*ERRSUM) IER = 5 - IF(ABSEPS.GE.ABSERR) GO TO 150 - KTMIN = 0 - ABSERR = ABSEPS - RESULT = RESEPS - CORREC = ERLARG - ERTEST = MAX(EPSABS,EPSREL*ABS(RESEPS)) -C ***JUMP OUT OF DO-LOOP - IF(ABSERR.LT.ERTEST) GO TO 170 -C -C PREPARE BISECTION OF THE SMALLEST INTERVAL. -C - 150 IF(NUMRL2.EQ.1) NOEXT = .TRUE. - IF(IER.GE.5) GO TO 170 - 155 MAXERR = IORD(1) - ERRMAX = ELIST(MAXERR) - NRMAX = 1 - EXTRAP = .FALSE. - LEVMAX = LEVMAX+1 - ERLARG = ERRSUM - 160 CONTINUE -C -C SET THE FINAL RESULT. -C --------------------- -C -C - 170 IF(ABSERR.EQ.OFLOW) GO TO 190 - IF((IER+IERRO).EQ.0) GO TO 180 - IF(IERRO.EQ.3) ABSERR = ABSERR+CORREC - IF(IER.EQ.0) IER = 3 - IF(RESULT.NE.0.0E+00.AND.AREA.NE.0.0E+00)GO TO 175 - IF(ABSERR.GT.ERRSUM)GO TO 190 - IF(AREA.EQ.0.0E+00) GO TO 210 - GO TO 180 - 175 IF(ABSERR/ABS(RESULT).GT.ERRSUM/ABS(AREA))GO TO 190 -C -C TEST ON DIVERGENCE. -C - 180 IF(KSGN.EQ.(-1).AND.MAX(ABS(RESULT),ABS(AREA)).LE. - 1 DEFABS*0.1E-01) GO TO 210 - IF(0.1E-01.GT.(RESULT/AREA).OR.(RESULT/AREA).GT.0.1E+03.OR. - 1 ERRSUM.GT.ABS(AREA)) IER = 6 - GO TO 210 -C -C COMPUTE GLOBAL INTEGRAL SUM. -C - 190 RESULT = 0.0E+00 - DO 200 K = 1,LAST - RESULT = RESULT+RLIST(K) - 200 CONTINUE - ABSERR = ERRSUM - 210 IF(IER.GT.2) IER = IER - 1 - RESULT = RESULT*SIGN - 999 RETURN - END diff --git a/slatec/qags.f b/slatec/qags.f deleted file mode 100644 index 2dae79e..0000000 --- a/slatec/qags.f +++ /dev/null @@ -1,200 +0,0 @@ -*DECK QAGS - SUBROUTINE QAGS (F, A, B, EPSABS, EPSREL, RESULT, ABSERR, NEVAL, - + IER, LIMIT, LENW, LAST, IWORK, WORK) -C***BEGIN PROLOGUE QAGS -C***PURPOSE The routine calculates an approximation result to a given -C Definite integral I = Integral of F over (A,B), -C Hopefully satisfying following claim for accuracy -C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A1A1 -C***TYPE SINGLE PRECISION (QAGS-S, DQAGS-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, END POINT SINGULARITIES, -C EXTRAPOLATION, GENERAL-PURPOSE, GLOBALLY ADAPTIVE, -C QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Computation of a definite integral -C Standard fortran subroutine -C Real version -C -C -C PARAMETERS -C ON ENTRY -C F - Real -C Function subprogram defining the integrand -C Function F(X). The actual name for F needs to be -C Declared E X T E R N A L in the driver program. -C -C A - Real -C Lower limit of integration -C -C B - Real -C Upper limit of integration -C -C EPSABS - Real -C Absolute accuracy requested -C EPSREL - Real -C Relative accuracy requested -C If EPSABS.LE.0 -C And EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C The routine will end with IER = 6. -C -C ON RETURN -C RESULT - Real -C Approximation to the integral -C -C ABSERR - Real -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C IER.GT.0 Abnormal termination of the routine -C The estimates for integral and error are -C less reliable. It is assumed that the -C requested accuracy has not been achieved. -C ERROR MESSAGES -C IER = 1 Maximum number of subdivisions allowed -C has been achieved. One can allow more sub- -C divisions by increasing the value of LIMIT -C (and taking the according dimension -C adjustments into account. However, if -C this yields no improvement it is advised -C to analyze the integrand in order to -C determine the integration difficulties. If -C the position of a local difficulty can be -C determined (e.g. SINGULARITY, -C DISCONTINUITY within the interval) one -C will probably gain from splitting up the -C interval at this point and calling the -C integrator on the subranges. If possible, -C an appropriate special-purpose integrator -C should be used, which is designed for -C handling the type of difficulty involved. -C = 2 The occurrence of roundoff error is detec- -C ted, which prevents the requested -C tolerance from being achieved. -C The error may be under-estimated. -C = 3 Extremely bad integrand behaviour -C occurs at some points of the integration -C interval. -C = 4 The algorithm does not converge. -C Roundoff error is detected in the -C Extrapolation table. It is presumed that -C the requested tolerance cannot be -C achieved, and that the returned result is -C the best which can be obtained. -C = 5 The integral is probably divergent, or -C slowly convergent. It must be noted that -C divergence can occur with any other value -C of IER. -C = 6 The input is invalid, because -C (EPSABS.LE.0 AND -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28) -C OR LIMIT.LT.1 OR LENW.LT.LIMIT*4. -C RESULT, ABSERR, NEVAL, LAST are set to -C zero. Except when LIMIT or LENW is -C invalid, IWORK(1), WORK(LIMIT*2+1) and -C WORK(LIMIT*3+1) are set to zero, WORK(1) -C is set to A and WORK(LIMIT+1) TO B. -C -C DIMENSIONING PARAMETERS -C LIMIT - Integer -C Dimensioning parameter for IWORK -C LIMIT determines the maximum number of subintervals -C in the partition of the given integration interval -C (A,B), LIMIT.GE.1. -C IF LIMIT.LT.1, the routine will end with IER = 6. -C -C LENW - Integer -C Dimensioning parameter for WORK -C LENW must be at least LIMIT*4. -C If LENW.LT.LIMIT*4, the routine will end -C with IER = 6. -C -C LAST - Integer -C On return, LAST equals the number of subintervals -C produced in the subdivision process, determines the -C number of significant elements actually in the WORK -C Arrays. -C -C WORK ARRAYS -C IWORK - Integer -C Vector of dimension at least LIMIT, the first K -C elements of which contain pointers -C to the error estimates over the subintervals -C such that WORK(LIMIT*3+IWORK(1)),... , -C WORK(LIMIT*3+IWORK(K)) form a decreasing -C sequence, with K = LAST IF LAST.LE.(LIMIT/2+2), -C and K = LIMIT+1-LAST otherwise -C -C WORK - Real -C Vector of dimension at least LENW -C on return -C WORK(1), ..., WORK(LAST) contain the left -C end-points of the subintervals in the -C partition of (A,B), -C WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain -C the right end-points, -C WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) contain -C the integral approximations over the subintervals, -C WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) -C contain the error estimates. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED QAGSE, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800101 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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE QAGS -C -C - REAL A,ABSERR,B,EPSABS,EPSREL,F,RESULT,WORK - INTEGER IER,IWORK,LENW,LIMIT,LVL,L1,L2,L3,NEVAL -C - DIMENSION IWORK(*),WORK(*) -C - EXTERNAL F -C -C CHECK VALIDITY OF LIMIT AND LENW. -C -C***FIRST EXECUTABLE STATEMENT QAGS - IER = 6 - NEVAL = 0 - LAST = 0 - RESULT = 0.0E+00 - ABSERR = 0.0E+00 - IF(LIMIT.LT.1.OR.LENW.LT.LIMIT*4) GO TO 10 -C -C PREPARE CALL FOR QAGSE. -C - L1 = LIMIT+1 - L2 = LIMIT+L1 - L3 = LIMIT+L2 -C - CALL QAGSE(F,A,B,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,NEVAL, - 1 IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) -C -C CALL ERROR HANDLER IF NECESSARY. -C - LVL = 0 -10 IF(IER.EQ.6) LVL = 1 - IF (IER .NE. 0) CALL XERMSG ('SLATEC', 'QAGS', - + 'ABNORMAL RETURN', IER, LVL) - RETURN - END diff --git a/slatec/qagse.f b/slatec/qagse.f deleted file mode 100644 index e9adf6d..0000000 --- a/slatec/qagse.f +++ /dev/null @@ -1,459 +0,0 @@ -*DECK QAGSE - SUBROUTINE QAGSE (F, A, B, EPSABS, EPSREL, LIMIT, RESULT, ABSERR, - + NEVAL, IER, ALIST, BLIST, RLIST, ELIST, IORD, LAST) -C***BEGIN PROLOGUE QAGSE -C***PURPOSE The routine calculates an approximation result to a given -C definite integral I = Integral of F over (A,B), -C hopefully satisfying following claim for accuracy -C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A1A1 -C***TYPE SINGLE PRECISION (QAGSE-S, DQAGSE-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, END POINT SINGULARITIES, -C EXTRAPOLATION, GENERAL-PURPOSE, GLOBALLY ADAPTIVE, -C QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Computation of a definite integral -C Standard fortran subroutine -C Real version -C -C PARAMETERS -C ON ENTRY -C F - Real -C Function subprogram defining the integrand -C function F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C A - Real -C Lower limit of integration -C -C B - Real -C Upper limit of integration -C -C EPSABS - Real -C Absolute accuracy requested -C EPSREL - Real -C Relative accuracy requested -C If EPSABS.LE.0 -C and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C the routine will end with IER = 6. -C -C LIMIT - Integer -C Gives an upper bound on the number of subintervals -C in the partition of (A,B) -C -C ON RETURN -C RESULT - Real -C Approximation to the integral -C -C ABSERR - Real -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C IER.GT.0 Abnormal termination of the routine -C the estimates for integral and error are -C less reliable. It is assumed that the -C requested accuracy has not been achieved. -C ERROR MESSAGES -C = 1 Maximum number of subdivisions allowed -C has been achieved. One can allow more sub- -C divisions by increasing the value of LIMIT -C (and taking the according dimension -C adjustments into account). However, if -C this yields no improvement it is advised -C to analyze the integrand in order to -C determine the integration difficulties. If -C the position of a local difficulty can be -C determined (e.g. singularity, -C discontinuity within the interval) one -C will probably gain from splitting up the -C interval at this point and calling the -C integrator on the subranges. If possible, -C an appropriate special-purpose integrator -C should be used, which is designed for -C handling the type of difficulty involved. -C = 2 The occurrence of roundoff error is detec- -C ted, which prevents the requested -C tolerance from being achieved. -C The error may be under-estimated. -C = 3 Extremely bad integrand behaviour -C occurs at some points of the integration -C interval. -C = 4 The algorithm does not converge. -C Roundoff error is detected in the -C extrapolation table. -C It is presumed that the requested -C tolerance cannot be achieved, and that the -C returned result is the best which can be -C obtained. -C = 5 The integral is probably divergent, or -C slowly convergent. It must be noted that -C divergence can occur with any other value -C of IER. -C = 6 The input is invalid, because -C EPSABS.LE.0 and -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28). -C RESULT, ABSERR, NEVAL, LAST, RLIST(1), -C IORD(1) and ELIST(1) are set to zero. -C ALIST(1) and BLIST(1) are set to A and B -C respectively. -C -C ALIST - Real -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the left end points -C of the subintervals in the partition of the -C given integration range (A,B) -C -C BLIST - Real -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the right end points -C of the subintervals in the partition of the given -C integration range (A,B) -C -C RLIST - Real -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the integral -C approximations on the subintervals -C -C ELIST - Real -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the moduli of the -C absolute error estimates on the subintervals -C -C IORD - Integer -C Vector of dimension at least LIMIT, the first K -C elements of which are pointers to the -C error estimates over the subintervals, -C such that ELIST(IORD(1)), ..., ELIST(IORD(K)) -C form a decreasing sequence, with K = LAST -C If LAST.LE.(LIMIT/2+2), and K = LIMIT+1-LAST -C otherwise -C -C LAST - Integer -C Number of subintervals actually produced in the -C subdivision process -C -C***REFERENCES (NONE) -C***ROUTINES CALLED QELG, QK21, QPSRT, R1MACH -C***REVISION HISTORY (YYMMDD) -C 800101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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***END PROLOGUE QAGSE -C - REAL A,ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1, - 1 A2,B,BLIST,B1,B2,CORREC,DEFABS,DEFAB1,DEFAB2,R1MACH, - 2 DRES,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND, - 3 ERRMAX,ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,F,OFLOW,RESABS, - 4 RESEPS,RESULT,RES3LA,RLIST,RLIST2,SMALL,UFLOW - INTEGER ID,IER,IERRO,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K,KSGN, - 1 KTMIN,LAST,LIMIT,MAXERR,NEVAL,NRES,NRMAX,NUMRL2 - LOGICAL EXTRAP,NOEXT -C - DIMENSION ALIST(*),BLIST(*),ELIST(*),IORD(*), - 1 RES3LA(3),RLIST(*),RLIST2(52) -C - EXTERNAL F -C -C THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF -C LIMEXP IN SUBROUTINE QELG (RLIST2 SHOULD BE OF DIMENSION -C (LIMEXP+2) AT LEAST). -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER -C (ALIST(I),BLIST(I)) -C RLIST2 - ARRAY OF DIMENSION AT LEAST LIMEXP+2 -C CONTAINING THE PART OF THE EPSILON TABLE -C WHICH IS STILL NEEDED FOR FURTHER COMPUTATIONS -C ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) -C MAXERR - POINTER TO THE INTERVAL WITH LARGEST ERROR -C ESTIMATE -C ERRMAX - ELIST(MAXERR) -C ERLAST - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED -C (BEFORE THAT SUBDIVISION HAS TAKEN PLACE) -C AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS -C ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS -C ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* -C ABS(RESULT)) -C *****1 - VARIABLE FOR THE LEFT INTERVAL -C *****2 - VARIABLE FOR THE RIGHT INTERVAL -C LAST - INDEX FOR SUBDIVISION -C NRES - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE -C NUMRL2 - NUMBER OF ELEMENTS CURRENTLY IN RLIST2. IF AN -C APPROPRIATE APPROXIMATION TO THE COMPOUNDED -C INTEGRAL HAS BEEN OBTAINED IT IS PUT IN -C RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED -C BY ONE. -C SMALL - LENGTH OF THE SMALLEST INTERVAL CONSIDERED -C UP TO NOW, MULTIPLIED BY 1.5 -C ERLARG - SUM OF THE ERRORS OVER THE INTERVALS LARGER -C THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW -C EXTRAP - LOGICAL VARIABLE DENOTING THAT THE ROUTINE -C IS ATTEMPTING TO PERFORM EXTRAPOLATION -C I.E. BEFORE SUBDIVIDING THE SMALLEST INTERVAL -C WE TRY TO DECREASE THE VALUE OF ERLARG. -C NOEXT - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION -C IS NO LONGER ALLOWED (TRUE VALUE) -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C OFLOW IS THE LARGEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT QAGSE - EPMACH = R1MACH(4) -C -C TEST ON VALIDITY OF PARAMETERS -C ------------------------------ - IER = 0 - NEVAL = 0 - LAST = 0 - RESULT = 0.0E+00 - ABSERR = 0.0E+00 - ALIST(1) = A - BLIST(1) = B - RLIST(1) = 0.0E+00 - ELIST(1) = 0.0E+00 - IF(EPSABS.LE.0.0E+00.AND.EPSREL.LT.MAX(0.5E+02*EPMACH,0.5E-14)) - 1 IER = 6 - IF(IER.EQ.6) GO TO 999 -C -C FIRST APPROXIMATION TO THE INTEGRAL -C ----------------------------------- -C - UFLOW = R1MACH(1) - OFLOW = R1MACH(2) - IERRO = 0 - CALL QK21(F,A,B,RESULT,ABSERR,DEFABS,RESABS) -C -C TEST ON ACCURACY. -C - DRES = ABS(RESULT) - ERRBND = MAX(EPSABS,EPSREL*DRES) - LAST = 1 - RLIST(1) = RESULT - ELIST(1) = ABSERR - IORD(1) = 1 - IF(ABSERR.LE.1.0E+02*EPMACH*DEFABS.AND.ABSERR.GT. - 1 ERRBND) IER = 2 - IF(LIMIT.EQ.1) IER = 1 - IF(IER.NE.0.OR.(ABSERR.LE.ERRBND.AND.ABSERR.NE.RESABS).OR. - 1 ABSERR.EQ.0.0E+00) GO TO 140 -C -C INITIALIZATION -C -------------- -C - RLIST2(1) = RESULT - ERRMAX = ABSERR - MAXERR = 1 - AREA = RESULT - ERRSUM = ABSERR - ABSERR = OFLOW - NRMAX = 1 - NRES = 0 - NUMRL2 = 2 - KTMIN = 0 - EXTRAP = .FALSE. - NOEXT = .FALSE. - IROFF1 = 0 - IROFF2 = 0 - IROFF3 = 0 - KSGN = -1 - IF(DRES.GE.(0.1E+01-0.5E+02*EPMACH)*DEFABS) KSGN = 1 -C -C MAIN DO-LOOP -C ------------ -C - DO 90 LAST = 2,LIMIT -C -C BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST -C ERROR ESTIMATE. -C - A1 = ALIST(MAXERR) - B1 = 0.5E+00*(ALIST(MAXERR)+BLIST(MAXERR)) - A2 = B1 - B2 = BLIST(MAXERR) - ERLAST = ERRMAX - CALL QK21(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) - CALL QK21(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) -C -C IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL -C AND ERROR AND TEST FOR ACCURACY. -C - AREA12 = AREA1+AREA2 - ERRO12 = ERROR1+ERROR2 - ERRSUM = ERRSUM+ERRO12-ERRMAX - AREA = AREA+AREA12-RLIST(MAXERR) - IF(DEFAB1.EQ.ERROR1.OR.DEFAB2.EQ.ERROR2) GO TO 15 - IF(ABS(RLIST(MAXERR)-AREA12).GT.0.1E-04*ABS(AREA12) - 1 .OR.ERRO12.LT.0.99E+00*ERRMAX) GO TO 10 - IF(EXTRAP) IROFF2 = IROFF2+1 - IF(.NOT.EXTRAP) IROFF1 = IROFF1+1 - 10 IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF3 = IROFF3+1 - 15 RLIST(MAXERR) = AREA1 - RLIST(LAST) = AREA2 - ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) -C -C TEST FOR ROUNDOFF ERROR AND EVENTUALLY -C SET ERROR FLAG. -C - IF(IROFF1+IROFF2.GE.10.OR.IROFF3.GE.20) IER = 2 - IF(IROFF2.GE.5) IERRO = 3 -C -C SET ERROR FLAG IN THE CASE THAT THE NUMBER OF -C SUBINTERVALS EQUALS LIMIT. -C - IF(LAST.EQ.LIMIT) IER = 1 -C -C SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR -C AT A POINT OF THE INTEGRATION RANGE. -C - IF(MAX(ABS(A1),ABS(B2)).LE.(0.1E+01+0.1E+03*EPMACH)* - 1 (ABS(A2)+0.1E+04*UFLOW)) IER = 4 -C -C APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. -C - IF(ERROR2.GT.ERROR1) GO TO 20 - ALIST(LAST) = A2 - BLIST(MAXERR) = B1 - BLIST(LAST) = B2 - ELIST(MAXERR) = ERROR1 - ELIST(LAST) = ERROR2 - GO TO 30 - 20 ALIST(MAXERR) = A2 - ALIST(LAST) = A1 - BLIST(LAST) = B1 - RLIST(MAXERR) = AREA2 - RLIST(LAST) = AREA1 - ELIST(MAXERR) = ERROR2 - ELIST(LAST) = ERROR1 -C -C CALL SUBROUTINE QPSRT TO MAINTAIN THE DESCENDING ORDERING -C IN THE LIST OF ERROR ESTIMATES AND SELECT THE -C SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE -C BISECTED NEXT). -C - 30 CALL QPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) -C ***JUMP OUT OF DO-LOOP - IF(ERRSUM.LE.ERRBND) GO TO 115 -C ***JUMP OUT OF DO-LOOP - IF(IER.NE.0) GO TO 100 - IF(LAST.EQ.2) GO TO 80 - IF(NOEXT) GO TO 90 - ERLARG = ERLARG-ERLAST - IF(ABS(B1-A1).GT.SMALL) ERLARG = ERLARG+ERRO12 - IF(EXTRAP) GO TO 40 -C -C TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE -C SMALLEST INTERVAL. -C - IF(ABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90 - EXTRAP = .TRUE. - NRMAX = 2 - 40 IF(IERRO.EQ.3.OR.ERLARG.LE.ERTEST) GO TO 60 -C -C THE SMALLEST INTERVAL HAS THE LARGEST ERROR. -C BEFORE BISECTING DECREASE THE SUM OF THE ERRORS -C OVER THE LARGER INTERVALS (ERLARG) AND PERFORM -C EXTRAPOLATION. -C - ID = NRMAX - JUPBND = LAST - IF(LAST.GT.(2+LIMIT/2)) JUPBND = LIMIT+3-LAST - DO 50 K = ID,JUPBND - MAXERR = IORD(NRMAX) - ERRMAX = ELIST(MAXERR) -C ***JUMP OUT OF DO-LOOP - IF(ABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90 - NRMAX = NRMAX+1 - 50 CONTINUE -C -C PERFORM EXTRAPOLATION. -C - 60 NUMRL2 = NUMRL2+1 - RLIST2(NUMRL2) = AREA - CALL QELG(NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES) - KTMIN = KTMIN+1 - IF(KTMIN.GT.5.AND.ABSERR.LT.0.1E-02*ERRSUM) IER = 5 - IF(ABSEPS.GE.ABSERR) GO TO 70 - KTMIN = 0 - ABSERR = ABSEPS - RESULT = RESEPS - CORREC = ERLARG - ERTEST = MAX(EPSABS,EPSREL*ABS(RESEPS)) -C ***JUMP OUT OF DO-LOOP - IF(ABSERR.LE.ERTEST) GO TO 100 -C -C PREPARE BISECTION OF THE SMALLEST INTERVAL. -C - 70 IF(NUMRL2.EQ.1) NOEXT = .TRUE. - IF(IER.EQ.5) GO TO 100 - MAXERR = IORD(1) - ERRMAX = ELIST(MAXERR) - NRMAX = 1 - EXTRAP = .FALSE. - SMALL = SMALL*0.5E+00 - ERLARG = ERRSUM - GO TO 90 - 80 SMALL = ABS(B-A)*0.375E+00 - ERLARG = ERRSUM - ERTEST = ERRBND - RLIST2(2) = AREA - 90 CONTINUE -C -C SET FINAL RESULT AND ERROR ESTIMATE. -C ------------------------------------ -C - 100 IF(ABSERR.EQ.OFLOW) GO TO 115 - IF(IER+IERRO.EQ.0) GO TO 110 - IF(IERRO.EQ.3) ABSERR = ABSERR+CORREC - IF(IER.EQ.0) IER = 3 - IF(RESULT.NE.0.0E+00.AND.AREA.NE.0.0E+00) GO TO 105 - IF(ABSERR.GT.ERRSUM) GO TO 115 - IF(AREA.EQ.0.0E+00) GO TO 130 - GO TO 110 - 105 IF(ABSERR/ABS(RESULT).GT.ERRSUM/ABS(AREA)) GO TO 115 -C -C TEST ON DIVERGENCE. -C - 110 IF(KSGN.EQ.(-1).AND.MAX(ABS(RESULT),ABS(AREA)).LE. - 1 DEFABS*0.1E-01) GO TO 130 - IF(0.1E-01.GT.(RESULT/AREA).OR.(RESULT/AREA).GT.0.1E+03 - 1 .OR.ERRSUM.GT.ABS(AREA)) IER = 6 - GO TO 130 -C -C COMPUTE GLOBAL INTEGRAL SUM. -C - 115 RESULT = 0.0E+00 - DO 120 K = 1,LAST - RESULT = RESULT+RLIST(K) - 120 CONTINUE - ABSERR = ERRSUM - 130 IF(IER.GT.2) IER = IER-1 - 140 NEVAL = 42*LAST-21 - 999 RETURN - END diff --git a/slatec/qawc.f b/slatec/qawc.f deleted file mode 100644 index 0f74bcf..0000000 --- a/slatec/qawc.f +++ /dev/null @@ -1,190 +0,0 @@ -*DECK QAWC - SUBROUTINE QAWC (F, A, B, C, EPSABS, EPSREL, RESULT, ABSERR, - + NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK) -C***BEGIN PROLOGUE QAWC -C***PURPOSE The routine calculates an approximation result to a -C Cauchy principal value I = INTEGRAL of F*W over (A,B) -C (W(X) = 1/((X-C), C.NE.A, C.NE.B), hopefully satisfying -C following claim for accuracy -C ABS(I-RESULT).LE.MAX(EPSABE,EPSREL*ABS(I)). -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A2A1, J4 -C***TYPE SINGLE PRECISION (QAWC-S, DQAWC-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, CAUCHY PRINCIPAL VALUE, -C CLENSHAW-CURTIS METHOD, GLOBALLY ADAPTIVE, QUADPACK, -C QUADRATURE, SPECIAL-PURPOSE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Computation of a Cauchy principal value -C Standard fortran subroutine -C Real version -C -C -C PARAMETERS -C ON ENTRY -C F - Real -C Function subprogram defining the integrand -C Function F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C A - Real -C Under limit of integration -C -C B - Real -C Upper limit of integration -C -C C - Parameter in the weight function, C.NE.A, C.NE.B. -C If C = A or C = B, the routine will end with -C IER = 6 . -C -C EPSABS - Real -C Absolute accuracy requested -C EPSREL - Real -C Relative accuracy requested -C If EPSABS.LE.0 -C and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C the routine will end with IER = 6. -C -C ON RETURN -C RESULT - Real -C Approximation to the integral -C -C ABSERR - Real -C Estimate or the modulus of the absolute error, -C Which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C IER.GT.0 Abnormal termination of the routine -C the estimates for integral and error are -C less reliable. It is assumed that the -C requested accuracy has not been achieved. -C ERROR MESSAGES -C IER = 1 Maximum number of subdivisions allowed -C has been achieved. One can allow more sub- -C divisions by increasing the value of LIMIT -C (and taking the according dimension -C adjustments into account). However, if -C this yields no improvement it is advised -C to analyze the integrand in order to -C determine the integration difficulties. -C If the position of a local difficulty -C can be determined (e.g. SINGULARITY, -C DISCONTINUITY within the interval) one -C will probably gain from splitting up the -C interval at this point and calling -C appropriate integrators on the subranges. -C = 2 The occurrence of roundoff error is detec- -C ted, which prevents the requested -C tolerance from being achieved. -C = 3 Extremely bad integrand behaviour occurs -C at some points of the integration -C interval. -C = 6 The input is invalid, because -C C = A or C = B or -C (EPSABS.LE.0 and -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)) -C or LIMIT.LT.1 or LENW.LT.LIMIT*4. -C RESULT, ABSERR, NEVAL, LAST are set to -C zero. Except when LENW or LIMIT is -C invalid, IWORK(1), WORK(LIMIT*2+1) and -C WORK(LIMIT*3+1) are set to zero, WORK(1) -C is set to A and WORK(LIMIT+1) to B. -C -C DIMENSIONING PARAMETERS -C LIMIT - Integer -C Dimensioning parameter for IWORK -C LIMIT determines the maximum number of subintervals -C in the partition of the given integration interval -C (A,B), LIMIT.GE.1. -C If LIMIT.LT.1, the routine will end with IER = 6. -C -C LENW - Integer -C Dimensioning parameter for WORK -C LENW must be at least LIMIT*4. -C If LENW.LT.LIMIT*4, the routine will end with -C IER = 6. -C -C LAST - Integer -C On return, LAST equals the number of subintervals -C produced in the subdivision process, which -C determines the number of significant elements -C actually in the WORK ARRAYS. -C -C WORK ARRAYS -C IWORK - Integer -C Vector of dimension at least LIMIT, the first K -C elements of which contain pointers -C to the error estimates over the subintervals, -C such that WORK(LIMIT*3+IWORK(1)), ... , -C WORK(LIMIT*3+IWORK(K)) form a decreasing -C sequence, with K = LAST if LAST.LE.(LIMIT/2+2), -C and K = LIMIT+1-LAST otherwise -C -C WORK - Real -C Vector of dimension at least LENW -C On return -C WORK(1), ..., WORK(LAST) contain the left -C end points of the subintervals in the -C partition of (A,B), -C WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain -C the right end points, -C WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) contain -C the integral approximations over the subintervals, -C WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) -C contain the error estimates. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED QAWCE, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800101 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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE QAWC -C - REAL A,ABSERR,B,C,EPSABS,EPSREL,F,RESULT,WORK - INTEGER IER,IWORK,LENW,LIMIT,LVL,L1,L2,L3,NEVAL -C - DIMENSION IWORK(*),WORK(*) -C - EXTERNAL F -C -C CHECK VALIDITY OF LIMIT AND LENW. -C -C***FIRST EXECUTABLE STATEMENT QAWC - IER = 6 - NEVAL = 0 - LAST = 0 - RESULT = 0.0E+00 - ABSERR = 0.0E+00 - IF(LIMIT.LT.1.OR.LENW.LT.LIMIT*4) GO TO 10 -C -C PREPARE CALL FOR QAWCE. -C - L1 = LIMIT+1 - L2 = LIMIT+L1 - L3 = LIMIT+L2 - CALL QAWCE(F,A,B,C,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,NEVAL,IER, - 1 WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) -C -C CALL ERROR HANDLER IF NECESSARY. -C - LVL = 0 -10 IF(IER.EQ.6) LVL = 1 - IF (IER .NE. 0) CALL XERMSG ('SLATEC', 'QAWC', - + 'ABNORMAL RETURN', IER, LVL) - RETURN - END diff --git a/slatec/qawce.f b/slatec/qawce.f deleted file mode 100644 index 9825946..0000000 --- a/slatec/qawce.f +++ /dev/null @@ -1,340 +0,0 @@ -*DECK QAWCE - SUBROUTINE QAWCE (F, A, B, C, EPSABS, EPSREL, LIMIT, RESULT, - + ABSERR, NEVAL, IER, ALIST, BLIST, RLIST, ELIST, IORD, LAST) -C***BEGIN PROLOGUE QAWCE -C***PURPOSE The routine calculates an approximation result to a -C CAUCHY PRINCIPAL VALUE I = Integral of F*W over (A,B) -C (W(X) = 1/(X-C), (C.NE.A, C.NE.B), hopefully satisfying -C following claim for accuracy -C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)) -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A2A1, J4 -C***TYPE SINGLE PRECISION (QAWCE-S, DQAWCE-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, CAUCHY PRINCIPAL VALUE, -C CLENSHAW-CURTIS METHOD, QUADPACK, QUADRATURE, -C SPECIAL-PURPOSE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Computation of a CAUCHY PRINCIPAL VALUE -C Standard fortran subroutine -C Real version -C -C PARAMETERS -C ON ENTRY -C F - Real -C Function subprogram defining the integrand -C function F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C A - Real -C Lower limit of integration -C -C B - Real -C Upper limit of integration -C -C C - Real -C Parameter in the WEIGHT function, C.NE.A, C.NE.B -C If C = A OR C = B, the routine will end with -C IER = 6. -C -C EPSABS - Real -C Absolute accuracy requested -C EPSREL - Real -C Relative accuracy requested -C If EPSABS.LE.0 -C and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C the routine will end with IER = 6. -C -C LIMIT - Integer -C Gives an upper bound on the number of subintervals -C in the partition of (A,B), LIMIT.GE.1 -C -C ON RETURN -C RESULT - Real -C Approximation to the integral -C -C ABSERR - Real -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C IER.GT.0 Abnormal termination of the routine -C the estimates for integral and error are -C less reliable. It is assumed that the -C requested accuracy has not been achieved. -C ERROR MESSAGES -C IER = 1 Maximum number of subdivisions allowed -C has been achieved. One can allow more sub- -C divisions by increasing the value of -C LIMIT. However, if this yields no -C improvement it is advised to analyze the -C the integrand, in order to determine the -C the integration difficulties. If the -C position of a local difficulty can be -C determined (e.g. SINGULARITY, -C DISCONTINUITY within the interval) one -C will probably gain from splitting up the -C interval at this point and calling -C appropriate integrators on the subranges. -C = 2 The occurrence of roundoff error is detec- -C ted, which prevents the requested -C tolerance from being achieved. -C = 3 Extremely bad integrand behaviour -C occurs at some interior points of -C the integration interval. -C = 6 The input is invalid, because -C C = A or C = B or -C (EPSABS.LE.0 and -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)) -C or LIMIT.LT.1. -C RESULT, ABSERR, NEVAL, RLIST(1), ELIST(1), -C IORD(1) and LAST are set to zero. ALIST(1) -C and BLIST(1) are set to A and B -C respectively. -C -C ALIST - Real -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the left -C end points of the subintervals in the partition -C of the given integration range (A,B) -C -C BLIST - Real -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the right -C end points of the subintervals in the partition -C of the given integration range (A,B) -C -C RLIST - Real -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the integral -C approximations on the subintervals -C -C ELIST - Real -C Vector of dimension LIMIT, the first LAST -C elements of which are the moduli of the absolute -C error estimates on the subintervals -C -C IORD - Integer -C Vector of dimension at least LIMIT, the first K -C elements of which are pointers to the error -C estimates over the subintervals, so that -C ELIST(IORD(1)), ..., ELIST(IORD(K)) with K = LAST -C If LAST.LE.(LIMIT/2+2), and K = LIMIT+1-LAST -C otherwise, form a decreasing sequence -C -C LAST - Integer -C Number of subintervals actually produced in -C the subdivision process -C -C***REFERENCES (NONE) -C***ROUTINES CALLED QC25C, QPSRT, R1MACH -C***REVISION HISTORY (YYMMDD) -C 800101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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***END PROLOGUE QAWCE -C - REAL A,AA,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1,A2,B,BB,BLIST, - 1 B1,B2,C,R1MACH,ELIST,EPMACH,EPSABS,EPSREL,ERRBND,ERRMAX,ERROR1, - 2 ERROR2,ERRSUM,F,RESULT,RLIST,UFLOW - INTEGER IER,IORD,IROFF1,IROFF2,K,KRULE,LAST,LIMIT,MAXERR,NEV, - 1 NEVAL,NRMAX -C - DIMENSION ALIST(*),BLIST(*),RLIST(*),ELIST(*), - 1 IORD(*) -C - EXTERNAL F -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER -C (ALIST(I),BLIST(I)) -C ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) -C MAXERR - POINTER TO THE INTERVAL WITH LARGEST -C ERROR ESTIMATE -C ERRMAX - ELIST(MAXERR) -C AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS -C ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS -C ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* -C ABS(RESULT)) -C *****1 - VARIABLE FOR THE LEFT SUBINTERVAL -C *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL -C LAST - INDEX FOR SUBDIVISION -C -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT QAWCE - EPMACH = R1MACH(4) - UFLOW = R1MACH(1) -C -C -C TEST ON VALIDITY OF PARAMETERS -C ------------------------------ -C - IER = 6 - NEVAL = 0 - LAST = 0 - ALIST(1) = A - BLIST(1) = B - RLIST(1) = 0.0E+00 - ELIST(1) = 0.0E+00 - IORD(1) = 0 - RESULT = 0.0E+00 - ABSERR = 0.0E+00 - IF (C.EQ.A.OR.C.EQ.B.OR.(EPSABS.LE.0.0E+00.AND. - 1 EPSREL.LT.MAX(0.5E+02*EPMACH,0.5E-14))) GO TO 999 -C -C FIRST APPROXIMATION TO THE INTEGRAL -C ----------------------------------- -C - AA=A - BB=B - IF (A.LE.B) GO TO 10 - AA=B - BB=A -10 IER=0 - KRULE = 1 - CALL QC25C(F,AA,BB,C,RESULT,ABSERR,KRULE,NEVAL) - LAST = 1 - RLIST(1) = RESULT - ELIST(1) = ABSERR - IORD(1) = 1 - ALIST(1) = A - BLIST(1) = B -C -C TEST ON ACCURACY -C - ERRBND = MAX(EPSABS,EPSREL*ABS(RESULT)) - IF(LIMIT.EQ.1) IER = 1 - IF(ABSERR.LT.MIN(0.1E-01*ABS(RESULT),ERRBND) - 1 .OR.IER.EQ.1) GO TO 70 -C -C INITIALIZATION -C -------------- -C - ALIST(1) = AA - BLIST(1) = BB - RLIST(1) = RESULT - ERRMAX = ABSERR - MAXERR = 1 - AREA = RESULT - ERRSUM = ABSERR - NRMAX = 1 - IROFF1 = 0 - IROFF2 = 0 -C -C MAIN DO-LOOP -C ------------ -C - DO 40 LAST = 2,LIMIT -C -C BISECT THE SUBINTERVAL WITH NRMAX-TH LARGEST -C ERROR ESTIMATE. -C - A1 = ALIST(MAXERR) - B1 = 0.5E+00*(ALIST(MAXERR)+BLIST(MAXERR)) - B2 = BLIST(MAXERR) - IF(C.LE.B1.AND.C.GT.A1) B1 = 0.5E+00*(C+B2) - IF(C.GT.B1.AND.C.LT.B2) B1 = 0.5E+00*(A1+C) - A2 = B1 - KRULE = 2 - CALL QC25C(F,A1,B1,C,AREA1,ERROR1,KRULE,NEV) - NEVAL = NEVAL+NEV - CALL QC25C(F,A2,B2,C,AREA2,ERROR2,KRULE,NEV) - NEVAL = NEVAL+NEV -C -C IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL -C AND ERROR AND TEST FOR ACCURACY. -C - AREA12 = AREA1+AREA2 - ERRO12 = ERROR1+ERROR2 - ERRSUM = ERRSUM+ERRO12-ERRMAX - AREA = AREA+AREA12-RLIST(MAXERR) - IF(ABS(RLIST(MAXERR)-AREA12).LT.0.1E-04*ABS(AREA12) - 1 .AND.ERRO12.GE.0.99E+00*ERRMAX.AND.KRULE.EQ.0) - 2 IROFF1 = IROFF1+1 - IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX.AND.KRULE.EQ.0) - 1 IROFF2 = IROFF2+1 - RLIST(MAXERR) = AREA1 - RLIST(LAST) = AREA2 - ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) - IF(ERRSUM.LE.ERRBND) GO TO 15 -C -C TEST FOR ROUNDOFF ERROR AND EVENTUALLY -C SET ERROR FLAG. -C - IF(IROFF1.GE.6.AND.IROFF2.GT.20) IER = 2 -C -C SET ERROR FLAG IN THE CASE THAT NUMBER OF INTERVAL -C BISECTIONS EXCEEDS LIMIT. -C - IF(LAST.EQ.LIMIT) IER = 1 -C -C SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR -C AT A POINT OF THE INTEGRATION RANGE. -C - IF(MAX(ABS(A1),ABS(B2)).LE.(0.1E+01+0.1E+03*EPMACH) - 1 *(ABS(A2)+0.1E+04*UFLOW)) IER = 3 -C -C APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. -C - 15 IF(ERROR2.GT.ERROR1) GO TO 20 - ALIST(LAST) = A2 - BLIST(MAXERR) = B1 - BLIST(LAST) = B2 - ELIST(MAXERR) = ERROR1 - ELIST(LAST) = ERROR2 - GO TO 30 - 20 ALIST(MAXERR) = A2 - ALIST(LAST) = A1 - BLIST(LAST) = B1 - RLIST(MAXERR) = AREA2 - RLIST(LAST) = AREA1 - ELIST(MAXERR) = ERROR2 - ELIST(LAST) = ERROR1 -C -C CALL SUBROUTINE QPSRT TO MAINTAIN THE DESCENDING ORDERING -C IN THE LIST OF ERROR ESTIMATES AND SELECT THE -C SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE -C BISECTED NEXT). -C - 30 CALL QPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) -C ***JUMP OUT OF DO-LOOP - IF(IER.NE.0.OR.ERRSUM.LE.ERRBND) GO TO 50 - 40 CONTINUE -C -C COMPUTE FINAL RESULT. -C --------------------- -C - 50 RESULT = 0.0E+00 - DO 60 K=1,LAST - RESULT = RESULT+RLIST(K) - 60 CONTINUE - ABSERR = ERRSUM - 70 IF (AA.EQ.B) RESULT=-RESULT - 999 RETURN - END diff --git a/slatec/qawf.f b/slatec/qawf.f deleted file mode 100644 index 13f281e..0000000 --- a/slatec/qawf.f +++ /dev/null @@ -1,244 +0,0 @@ -*DECK QAWF - SUBROUTINE QAWF (F, A, OMEGA, INTEGR, EPSABS, RESULT, ABSERR, - + NEVAL, IER, LIMLST, LST, LENIW, MAXP1, LENW, IWORK, WORK) -C***BEGIN PROLOGUE QAWF -C***PURPOSE The routine calculates an approximation result to a given -C Fourier integral -C I = Integral of F(X)*W(X) over (A,INFINITY) -C where W(X) = COS(OMEGA*X) or W(X) = SIN(OMEGA*X). -C Hopefully satisfying following claim for accuracy -C ABS(I-RESULT).LE.EPSABS. -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A3A1 -C***TYPE SINGLE PRECISION (QAWF-S, DQAWF-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, CONVERGENCE ACCELERATION, -C FOURIER INTEGRALS, INTEGRATION BETWEEN ZEROS, QUADPACK, -C QUADRATURE, SPECIAL-PURPOSE INTEGRAL -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Computation of Fourier integrals -C Standard fortran subroutine -C Real version -C -C -C PARAMETERS -C ON ENTRY -C F - Real -C Function subprogram defining the integrand -C function F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C A - Real -C Lower limit of integration -C -C OMEGA - Real -C Parameter in the integrand WEIGHT function -C -C INTEGR - Integer -C Indicates which of the WEIGHT functions is used -C INTEGR = 1 W(X) = COS(OMEGA*X) -C INTEGR = 2 W(X) = SIN(OMEGA*X) -C IF INTEGR.NE.1.AND.INTEGR.NE.2, the routine -C will end with IER = 6. -C -C EPSABS - Real -C Absolute accuracy requested, EPSABS.GT.0. -C If EPSABS.LE.0, the routine will end with IER = 6. -C -C ON RETURN -C RESULT - Real -C Approximation to the integral -C -C ABSERR - Real -C Estimate of the modulus of the absolute error, -C Which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C IER.GT.0 Abnormal termination of the routine. -C The estimates for integral and error are -C less reliable. It is assumed that the -C requested accuracy has not been achieved. -C ERROR MESSAGES -C If OMEGA.NE.0 -C IER = 1 Maximum number of cycles allowed -C has been achieved, i.e. of subintervals -C (A+(K-1)C,A+KC) where -C C = (2*INT(ABS(OMEGA))+1)*PI/ABS(OMEGA), -C FOR K = 1, 2, ..., LST. -C One can allow more cycles by increasing -C the value of LIMLST (and taking the -C according dimension adjustments into -C account). Examine the array IWORK which -C contains the error flags on the cycles, in -C order to look for eventual local -C integration difficulties. -C If the position of a local difficulty -C can be determined (e.g. singularity, -C discontinuity within the interval) one -C will probably gain from splitting up the -C interval at this point and calling -C appropriate integrators on the subranges. -C = 4 The extrapolation table constructed for -C convergence acceleration of the series -C formed by the integral contributions over -C the cycles, does not converge to within -C the requested accuracy. -C As in the case of IER = 1, it is advised -C to examine the array IWORK which contains -C the error flags on the cycles. -C = 6 The input is invalid because -C (INTEGR.NE.1 AND INTEGR.NE.2) or -C EPSABS.LE.0 or LIMLST.LT.1 or -C LENIW.LT.(LIMLST+2) or MAXP1.LT.1 or -C LENW.LT.(LENIW*2+MAXP1*25). -C RESULT, ABSERR, NEVAL, LST are set to -C zero. -C = 7 Bad integrand behaviour occurs within -C one or more of the cycles. Location and -C type of the difficulty involved can be -C determined from the first LST elements of -C vector IWORK. Here LST is the number of -C cycles actually needed (see below). -C IWORK(K) = 1 The maximum number of -C subdivisions (=(LENIW-LIMLST) -C /2) has been achieved on the -C K th cycle. -C = 2 Occurrence of roundoff error -C is detected and prevents the -C tolerance imposed on the K th -C cycle, from being achieved -C on this cycle. -C = 3 Extremely bad integrand -C behaviour occurs at some -C points of the K th cycle. -C = 4 The integration procedure -C over the K th cycle does -C not converge (to within the -C required accuracy) due to -C roundoff in the extrapolation -C procedure invoked on this -C cycle. It is assumed that the -C result on this interval is -C the best which can be -C obtained. -C = 5 The integral over the K th -C cycle is probably divergent -C or slowly convergent. It must -C be noted that divergence can -C occur with any other value of -C IWORK(K). -C If OMEGA = 0 and INTEGR = 1, -C The integral is calculated by means of DQAGIE, -C and IER = IWORK(1) (with meaning as described -C for IWORK(K),K = 1). -C -C DIMENSIONING PARAMETERS -C LIMLST - Integer -C LIMLST gives an upper bound on the number of -C cycles, LIMLST.GE.3. -C If LIMLST.LT.3, the routine will end with IER = 6. -C -C LST - Integer -C On return, LST indicates the number of cycles -C actually needed for the integration. -C If OMEGA = 0, then LST is set to 1. -C -C LENIW - Integer -C Dimensioning parameter for IWORK. On entry, -C (LENIW-LIMLST)/2 equals the maximum number of -C subintervals allowed in the partition of each -C cycle, LENIW.GE.(LIMLST+2). -C If LENIW.LT.(LIMLST+2), the routine will end with -C IER = 6. -C -C MAXP1 - Integer -C MAXP1 gives an upper bound on the number of -C Chebyshev moments which can be stored, i.e. for -C the intervals of lengths ABS(B-A)*2**(-L), -C L = 0,1, ..., MAXP1-2, MAXP1.GE.1. -C If MAXP1.LT.1, the routine will end with IER = 6. -C LENW - Integer -C Dimensioning parameter for WORK -C LENW must be at least LENIW*2+MAXP1*25. -C If LENW.LT.(LENIW*2+MAXP1*25), the routine will -C end with IER = 6. -C -C WORK ARRAYS -C IWORK - Integer -C Vector of dimension at least LENIW -C On return, IWORK(K) FOR K = 1, 2, ..., LST -C contain the error flags on the cycles. -C -C WORK - Real -C Vector of dimension at least -C On return, -C WORK(1), ..., WORK(LST) contain the integral -C approximations over the cycles, -C WORK(LIMLST+1), ..., WORK(LIMLST+LST) contain -C the error estimates over the cycles. -C further elements of WORK have no specific -C meaning for the user. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED QAWFE, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800101 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891009 Removed unreferenced variable. (WRB) -C 891009 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***END PROLOGUE QAWF -C - REAL A,ABSERR,EPSABS,F,OMEGA,RESULT,WORK - INTEGER IER,INTEGR,LENIW,LIMIT,LIMLST,LVL,LST,L1,L2,L3,L4,L5,L6, - 1 MAXP1,NEVAL -C - DIMENSION IWORK(*),WORK(*) -C - EXTERNAL F -C -C CHECK VALIDITY OF LIMLST, LENIW, MAXP1 AND LENW. -C -C***FIRST EXECUTABLE STATEMENT QAWF - IER = 6 - NEVAL = 0 - RESULT = 0.0E+00 - ABSERR = 0.0E+00 - IF(LIMLST.LT.3.OR.LENIW.LT.(LIMLST+2).OR.MAXP1.LT.1.OR.LENW.LT. - 1 (LENIW*2+MAXP1*25)) GO TO 10 -C -C PREPARE CALL FOR QAWFE -C - LIMIT = (LENIW-LIMLST)/2 - L1 = LIMLST+1 - L2 = LIMLST+L1 - L3 = LIMIT+L2 - L4 = LIMIT+L3 - L5 = LIMIT+L4 - L6 = LIMIT+L5 - LL2 = LIMIT+L1 - CALL QAWFE(F,A,OMEGA,INTEGR,EPSABS,LIMLST,LIMIT,MAXP1,RESULT, - 1 ABSERR,NEVAL,IER,WORK(1),WORK(L1),IWORK(1),LST,WORK(L2), - 2 WORK(L3),WORK(L4),WORK(L5),IWORK(L1),IWORK(LL2),WORK(L6)) -C -C CALL ERROR HANDLER IF NECESSARY -C - LVL = 0 -10 IF(IER.EQ.6) LVL = 1 - IF (IER .NE. 0) CALL XERMSG ('SLATEC', 'QAWF', - + 'ABNORMAL RETURN', IER, LVL) - RETURN - END diff --git a/slatec/qawfe.f b/slatec/qawfe.f deleted file mode 100644 index 692c618..0000000 --- a/slatec/qawfe.f +++ /dev/null @@ -1,376 +0,0 @@ -*DECK QAWFE - SUBROUTINE QAWFE (F, A, OMEGA, INTEGR, EPSABS, LIMLST, LIMIT, - + MAXP1, RESULT, ABSERR, NEVAL, IER, RSLST, ERLST, IERLST, LST, - + ALIST, BLIST, RLIST, ELIST, IORD, NNLOG, CHEBMO) -C***BEGIN PROLOGUE QAWFE -C***PURPOSE The routine calculates an approximation result to a -C given Fourier integral -C I = Integral of F(X)*W(X) over (A,INFINITY) -C where W(X) = COS(OMEGA*X) or W(X) = SIN(OMEGA*X), -C hopefully satisfying following claim for accuracy -C ABS(I-RESULT).LE.EPSABS. -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A3A1 -C***TYPE SINGLE PRECISION (QAWFE-S, DQAWFE-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, CONVERGENCE ACCELERATION, -C FOURIER INTEGRALS, INTEGRATION BETWEEN ZEROS, QUADPACK, -C QUADRATURE, SPECIAL-PURPOSE INTEGRAL -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Computation of Fourier integrals -C Standard fortran subroutine -C Real version -C -C PARAMETERS -C ON ENTRY -C F - Real -C Function subprogram defining the integrand -C Function F(X). The actual name for F needs to -C be declared E X T E R N A L in the driver program. -C -C A - Real -C Lower limit of integration -C -C OMEGA - Real -C Parameter in the WEIGHT function -C -C INTEGR - Integer -C Indicates which WEIGHT function is used -C INTEGR = 1 W(X) = COS(OMEGA*X) -C INTEGR = 2 W(X) = SIN(OMEGA*X) -C If INTEGR.NE.1.AND.INTEGR.NE.2, the routine will -C end with IER = 6. -C -C EPSABS - Real -C absolute accuracy requested, EPSABS.GT.0 -C If EPSABS.LE.0, the routine will end with IER = 6. -C -C LIMLST - Integer -C LIMLST gives an upper bound on the number of -C cycles, LIMLST.GE.1. -C If LIMLST.LT.3, the routine will end with IER = 6. -C -C LIMIT - Integer -C Gives an upper bound on the number of subintervals -C allowed in the partition of each cycle, LIMIT.GE.1 -C each cycle, LIMIT.GE.1. -C -C MAXP1 - Integer -C Gives an upper bound on the number of -C Chebyshev moments which can be stored, I.E. -C for the intervals of lengths ABS(B-A)*2**(-L), -C L=0,1, ..., MAXP1-2, MAXP1.GE.1 -C -C ON RETURN -C RESULT - Real -C Approximation to the integral X -C -C ABSERR - Real -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - IER = 0 Normal and reliable termination of -C the routine. It is assumed that the -C requested accuracy has been achieved. -C IER.GT.0 Abnormal termination of the routine. The -C estimates for integral and error are less -C reliable. It is assumed that the requested -C accuracy has not been achieved. -C ERROR MESSAGES -C If OMEGA.NE.0 -C IER = 1 Maximum number of cycles allowed -C Has been achieved., i.e. of subintervals -C (A+(K-1)C,A+KC) where -C C = (2*INT(ABS(OMEGA))+1)*PI/ABS(OMEGA), -C for K = 1, 2, ..., LST. -C One can allow more cycles by increasing -C the value of LIMLST (and taking the -C according dimension adjustments into -C account). -C Examine the array IWORK which contains -C the error flags on the cycles, in order to -C look for eventual local integration -C difficulties. If the position of a local -C difficulty can be determined (e.g. -C SINGULARITY, DISCONTINUITY within the -C interval) one will probably gain from -C splitting up the interval at this point -C and calling appropriate integrators on -C the subranges. -C = 4 The extrapolation table constructed for -C convergence acceleration of the series -C formed by the integral contributions over -C the cycles, does not converge to within -C the requested accuracy. As in the case of -C IER = 1, it is advised to examine the -C array IWORK which contains the error -C flags on the cycles. -C = 6 The input is invalid because -C (INTEGR.NE.1 AND INTEGR.NE.2) or -C EPSABS.LE.0 or LIMLST.LT.3. -C RESULT, ABSERR, NEVAL, LST are set -C to zero. -C = 7 Bad integrand behaviour occurs within one -C or more of the cycles. Location and type -C of the difficulty involved can be -C determined from the vector IERLST. Here -C LST is the number of cycles actually -C needed (see below). -C IERLST(K) = 1 The maximum number of -C subdivisions (= LIMIT) has -C been achieved on the K th -C cycle. -C = 2 Occurrence of roundoff error -C is detected and prevents the -C tolerance imposed on the -C K th cycle, from being -C achieved. -C = 3 Extremely bad integrand -C behaviour occurs at some -C points of the K th cycle. -C = 4 The integration procedure -C over the K th cycle does -C not converge (to within the -C required accuracy) due to -C roundoff in the -C extrapolation procedure -C invoked on this cycle. It -C is assumed that the result -C on this interval is the -C best which can be obtained. -C = 5 The integral over the K th -C cycle is probably divergent -C or slowly convergent. It -C must be noted that -C divergence can occur with -C any other value of -C IERLST(K). -C If OMEGA = 0 and INTEGR = 1, -C The integral is calculated by means of DQAGIE -C and IER = IERLST(1) (with meaning as described -C for IERLST(K), K = 1). -C -C RSLST - Real -C Vector of dimension at least LIMLST -C RSLST(K) contains the integral contribution -C over the interval (A+(K-1)C,A+KC) where -C C = (2*INT(ABS(OMEGA))+1)*PI/ABS(OMEGA), -C K = 1, 2, ..., LST. -C Note that, if OMEGA = 0, RSLST(1) contains -C the value of the integral over (A,INFINITY). -C -C ERLST - Real -C Vector of dimension at least LIMLST -C ERLST(K) contains the error estimate corresponding -C with RSLST(K). -C -C IERLST - Integer -C Vector of dimension at least LIMLST -C IERLST(K) contains the error flag corresponding -C with RSLST(K). For the meaning of the local error -C flags see description of output parameter IER. -C -C LST - Integer -C Number of subintervals needed for the integration -C If OMEGA = 0 then LST is set to 1. -C -C ALIST, BLIST, RLIST, ELIST - Real -C vector of dimension at least LIMIT, -C -C IORD, NNLOG - Integer -C Vector of dimension at least LIMIT, providing -C space for the quantities needed in the subdivision -C process of each cycle -C -C CHEBMO - Real -C Array of dimension at least (MAXP1,25), providing -C space for the Chebyshev moments needed within the -C cycles -C -C***REFERENCES (NONE) -C***ROUTINES CALLED QAGIE, QAWOE, QELG, R1MACH -C***REVISION HISTORY (YYMMDD) -C 800101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891009 Removed unreferenced variable. (WRB) -C 891009 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE QAWFE -C - REAL A,ABSEPS,ABSERR,ALIST,BLIST,CHEBMO,CORREC,CYCLE, - 1 C1,C2,DL,DRL,ELIST,EP,EPS,EPSA,EPSABS,ERLST, - 2 ERRSUM,FACT,OMEGA,P,PI,P1,PSUM,RESEPS,RESULT,RES3LA,RLIST,RSLST - 3 ,R1MACH,UFLOW - INTEGER IER,IERLST,INTEGR,IORD,KTMIN,L,LST,LIMIT,LL,MAXP1, - 1 NEV,NEVAL,NNLOG,NRES,NUMRL2 -C - DIMENSION ALIST(*),BLIST(*),CHEBMO(MAXP1,25),ELIST(*), - 1 ERLST(*),IERLST(*),IORD(*),NNLOG(*),PSUM(52), - 2 RES3LA(3),RLIST(*),RSLST(*) -C - EXTERNAL F -C -C -C THE DIMENSION OF PSUM IS DETERMINED BY THE VALUE OF -C LIMEXP IN SUBROUTINE QELG (PSUM MUST BE -C OF DIMENSION (LIMEXP+2) AT LEAST). -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C C1, C2 - END POINTS OF SUBINTERVAL (OF LENGTH -C CYCLE) -C CYCLE - (2*INT(ABS(OMEGA))+1)*PI/ABS(OMEGA) -C PSUM - VECTOR OF DIMENSION AT LEAST (LIMEXP+2) -C (SEE ROUTINE QELG) -C PSUM CONTAINS THE PART OF THE EPSILON -C TABLE WHICH IS STILL NEEDED FOR FURTHER -C COMPUTATIONS. -C EACH ELEMENT OF PSUM IS A PARTIAL SUM OF -C THE SERIES WHICH SHOULD SUM TO THE VALUE OF -C THE INTEGRAL. -C ERRSUM - SUM OF ERROR ESTIMATES OVER THE -C SUBINTERVALS, CALCULATED CUMULATIVELY -C EPSA - ABSOLUTE TOLERANCE REQUESTED OVER CURRENT -C SUBINTERVAL -C CHEBMO - ARRAY CONTAINING THE MODIFIED CHEBYSHEV -C MOMENTS (SEE ALSO ROUTINE QC25F) -C - SAVE P, PI - DATA P/0.9E+00/,PI/0.31415926535897932E+01/ -C -C TEST ON VALIDITY OF PARAMETERS -C ------------------------------ -C -C***FIRST EXECUTABLE STATEMENT QAWFE - RESULT = 0.0E+00 - ABSERR = 0.0E+00 - NEVAL = 0 - LST = 0 - IER = 0 - IF((INTEGR.NE.1.AND.INTEGR.NE.2).OR.EPSABS.LE.0.0E+00.OR. - 1 LIMLST.LT.3) IER = 6 - IF(IER.EQ.6) GO TO 999 - IF(OMEGA.NE.0.0E+00) GO TO 10 -C -C INTEGRATION BY QAGIE IF OMEGA IS ZERO -C -------------------------------------- -C - IF(INTEGR.EQ.1) CALL QAGIE(F,A,1,EPSABS,0.0E+00,LIMIT, - 1 RESULT,ABSERR,NEVAL,IER,ALIST,BLIST,RLIST,ELIST,IORD,LAST) - RSLST(1) = RESULT - ERLST(1) = ABSERR - IERLST(1) = IER - LST = 1 - GO TO 999 -C -C INITIALIZATIONS -C --------------- -C - 10 L = ABS(OMEGA) - DL = 2*L+1 - CYCLE = DL*PI/ABS(OMEGA) - IER = 0 - KTMIN = 0 - NEVAL = 0 - NUMRL2 = 0 - NRES = 0 - C1 = A - C2 = CYCLE+A - P1 = 0.1E+01-P - EPS = EPSABS - UFLOW = R1MACH(1) - IF(EPSABS.GT.UFLOW/P1) EPS = EPSABS*P1 - EP = EPS - FACT = 0.1E+01 - CORREC = 0.0E+00 - ABSERR = 0.0E+00 - ERRSUM = 0.0E+00 -C -C MAIN DO-LOOP -C ------------ -C - DO 50 LST = 1,LIMLST -C -C INTEGRATE OVER CURRENT SUBINTERVAL. -C - EPSA = EPS*FACT - CALL QAWOE(F,C1,C2,OMEGA,INTEGR,EPSA,0.0E+00,LIMIT,LST,MAXP1, - 1 RSLST(LST),ERLST(LST),NEV,IERLST(LST),LAST,ALIST,BLIST,RLIST, - 2 ELIST,IORD,NNLOG,MOMCOM,CHEBMO) - NEVAL = NEVAL+NEV - FACT = FACT*P - ERRSUM = ERRSUM+ERLST(LST) - DRL = 0.5E+02*ABS(RSLST(LST)) -C -C TEST ON ACCURACY WITH PARTIAL SUM -C - IF(ERRSUM+DRL.LE.EPSABS.AND.LST.GE.6) GO TO 80 - CORREC = MAX(CORREC,ERLST(LST)) - IF(IERLST(LST).NE.0) EPS = MAX(EP,CORREC*P1) - IF(IERLST(LST).NE.0) IER = 7 - IF(IER.EQ.7.AND.(ERRSUM+DRL).LE.CORREC*0.1E+02.AND. - 1 LST.GT.5) GO TO 80 - NUMRL2 = NUMRL2+1 - IF(LST.GT.1) GO TO 20 - PSUM(1) = RSLST(1) - GO TO 40 - 20 PSUM(NUMRL2) = PSUM(LL)+RSLST(LST) - IF(LST.EQ.2) GO TO 40 -C -C TEST ON MAXIMUM NUMBER OF SUBINTERVALS -C - IF(LST.EQ.LIMLST) IER = 1 -C -C PERFORM NEW EXTRAPOLATION -C - CALL QELG(NUMRL2,PSUM,RESEPS,ABSEPS,RES3LA,NRES) -C -C TEST WHETHER EXTRAPOLATED RESULT IS INFLUENCED BY -C ROUNDOFF -C - KTMIN = KTMIN+1 - IF(KTMIN.GE.15.AND.ABSERR.LE.0.1E-02*(ERRSUM+DRL)) IER = 4 - IF(ABSEPS.GT.ABSERR.AND.LST.NE.3) GO TO 30 - ABSERR = ABSEPS - RESULT = RESEPS - KTMIN = 0 -C -C IF IER IS NOT 0, CHECK WHETHER DIRECT RESULT (PARTIAL -C SUM) OR EXTRAPOLATED RESULT YIELDS THE BEST INTEGRAL -C APPROXIMATION -C - IF((ABSERR+0.1E+02*CORREC).LE.EPSABS.OR. - 1 (ABSERR.LE.EPSABS.AND.0.1E+02*CORREC.GE.EPSABS)) GO TO 60 - 30 IF(IER.NE.0.AND.IER.NE.7) GO TO 60 - 40 LL = NUMRL2 - C1 = C2 - C2 = C2+CYCLE - 50 CONTINUE -C -C SET FINAL RESULT AND ERROR ESTIMATE -C ----------------------------------- -C - 60 ABSERR = ABSERR+0.1E+02*CORREC - IF(IER.EQ.0) GO TO 999 - IF(RESULT.NE.0.0E+00.AND.PSUM(NUMRL2).NE.0.0E+00) GO TO 70 - IF(ABSERR.GT.ERRSUM) GO TO 80 - IF(PSUM(NUMRL2).EQ.0.0E+00) GO TO 999 - 70 IF(ABSERR/ABS(RESULT).GT.(ERRSUM+DRL)/ABS(PSUM(NUMRL2))) - 1 GO TO 80 - IF(IER.GE.1.AND.IER.NE.7) ABSERR = ABSERR+DRL - GO TO 999 - 80 RESULT = PSUM(NUMRL2) - ABSERR = ERRSUM+DRL - 999 RETURN - END diff --git a/slatec/qawo.f b/slatec/qawo.f deleted file mode 100644 index 0dc8adb..0000000 --- a/slatec/qawo.f +++ /dev/null @@ -1,236 +0,0 @@ -*DECK QAWO - SUBROUTINE QAWO (F, A, B, OMEGA, INTEGR, EPSABS, EPSREL, RESULT, - + ABSERR, NEVAL, IER, LENIW, MAXP1, LENW, LAST, IWORK, WORK) -C***BEGIN PROLOGUE QAWO -C***PURPOSE Calculate an approximation to a given definite integral -C I = Integral of F(X)*W(X) over (A,B), where -C W(X) = COS(OMEGA*X) -C or W(X) = SIN(OMEGA*X), -C hopefully satisfying the following claim for accuracy -C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A2A1 -C***TYPE SINGLE PRECISION (QAWO-S, DQAWO-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, CLENSHAW-CURTIS METHOD, -C EXTRAPOLATION, GLOBALLY ADAPTIVE, -C INTEGRAND WITH OSCILLATORY COS OR SIN FACTOR, QUADPACK, -C QUADRATURE, SPECIAL-PURPOSE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Computation of oscillatory integrals -C Standard fortran subroutine -C Real version -C -C PARAMETERS -C ON ENTRY -C F - Real -C Function subprogram defining the function -C F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C A - Real -C Lower limit of integration -C -C B - Real -C Upper limit of integration -C -C OMEGA - Real -C Parameter in the integrand weight function -C -C INTEGR - Integer -C Indicates which of the weight functions is used -C INTEGR = 1 W(X) = COS(OMEGA*X) -C INTEGR = 2 W(X) = SIN(OMEGA*X) -C If INTEGR.NE.1.AND.INTEGR.NE.2, the routine will -C end with IER = 6. -C -C EPSABS - Real -C Absolute accuracy requested -C EPSREL - Real -C Relative accuracy requested -C If EPSABS.LE.0 and -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C the routine will end with IER = 6. -C -C ON RETURN -C RESULT - Real -C Approximation to the integral -C -C ABSERR - Real -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C - IER.GT.0 Abnormal termination of the routine. -C The estimates for integral and error are -C less reliable. It is assumed that the -C requested accuracy has not been achieved. -C ERROR MESSAGES -C IER = 1 Maximum number of subdivisions allowed -C has been achieved(= LENIW/2). One can -C allow more subdivisions by increasing the -C value of LENIW (and taking the according -C dimension adjustments into account). -C However, if this yields no improvement it -C is advised to analyze the integrand in -C order to determine the integration -C difficulties. If the position of a local -C difficulty can be determined (e.g. -C SINGULARITY, DISCONTINUITY within the -C interval) one will probably gain from -C splitting up the interval at this point -C and calling the integrator on the -C subranges. If possible, an appropriate -C special-purpose integrator should be used -C which is designed for handling the type of -C difficulty involved. -C = 2 The occurrence of roundoff error is -C detected, which prevents the requested -C tolerance from being achieved. -C The error may be under-estimated. -C = 3 Extremely bad integrand behaviour occurs -C at some interior points of the -C integration interval. -C = 4 The algorithm does not converge. -C Roundoff error is detected in the -C extrapolation table. It is presumed that -C the requested tolerance cannot be achieved -C due to roundoff in the extrapolation -C table, and that the returned result is -C the best which can be obtained. -C = 5 The integral is probably divergent, or -C slowly convergent. It must be noted that -C divergence can occur with any other value -C of IER. -C = 6 The input is invalid, because -C (EPSABS.LE.0 and -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)) -C or (INTEGR.NE.1 AND INTEGR.NE.2), -C or LENIW.LT.2 OR MAXP1.LT.1 or -C LENW.LT.LENIW*2+MAXP1*25. -C RESULT, ABSERR, NEVAL, LAST are set to -C zero. Except when LENIW, MAXP1 or LENW are -C invalid, WORK(LIMIT*2+1), WORK(LIMIT*3+1), -C IWORK(1), IWORK(LIMIT+1) are set to zero, -C WORK(1) is set to A and WORK(LIMIT+1) to -C B. -C -C DIMENSIONING PARAMETERS -C LENIW - Integer -C Dimensioning parameter for IWORK. -C LENIW/2 equals the maximum number of subintervals -C allowed in the partition of the given integration -C interval (A,B), LENIW.GE.2. -C If LENIW.LT.2, the routine will end with IER = 6. -C -C MAXP1 - Integer -C Gives an upper bound on the number of Chebyshev -C moments which can be stored, i.e. for the -C intervals of lengths ABS(B-A)*2**(-L), -C L=0,1, ..., MAXP1-2, MAXP1.GE.1 -C If MAXP1.LT.1, the routine will end with IER = 6. -C -C LENW - Integer -C Dimensioning parameter for WORK -C LENW must be at least LENIW*2+MAXP1*25. -C If LENW.LT.(LENIW*2+MAXP1*25), the routine will -C end with IER = 6. -C -C LAST - Integer -C On return, LAST equals the number of subintervals -C produced in the subdivision process, which -C determines the number of significant elements -C actually in the WORK ARRAYS. -C -C WORK ARRAYS -C IWORK - Integer -C Vector of dimension at least LENIW -C on return, the first K elements of which contain -C pointers to the error estimates over the -C subintervals, such that WORK(LIMIT*3+IWORK(1)), .. -C WORK(LIMIT*3+IWORK(K)) form a decreasing -C sequence, with LIMIT = LENW/2 , and K = LAST -C if LAST.LE.(LIMIT/2+2), and K = LIMIT+1-LAST -C otherwise. -C Furthermore, IWORK(LIMIT+1), ..., IWORK(LIMIT+ -C LAST) indicate the subdivision levels of the -C subintervals, such that IWORK(LIMIT+I) = L means -C that the subinterval numbered I is of length -C ABS(B-A)*2**(1-L). -C -C WORK - Real -C Vector of dimension at least LENW -C On return -C WORK(1), ..., WORK(LAST) contain the left -C end points of the subintervals in the -C partition of (A,B), -C WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain -C the right end points, -C WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) contain -C the integral approximations over the -C subintervals, -C WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) -C contain the error estimates. -C WORK(LIMIT*4+1), ..., WORK(LIMIT*4+MAXP1*25) -C Provide space for storing the Chebyshev moments. -C Note that LIMIT = LENW/2. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED QAWOE, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800101 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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE QAWO -C - REAL A,ABSERR,B,EPSABS,EPSREL,F,OMEGA,RESULT - INTEGER IER,INTEGR,LENIW,LVL,L1,L2,L3,L4,MAXP1,MOMCOM,NEVAL -C - DIMENSION IWORK(*),WORK(*) -C - EXTERNAL F -C -C CHECK VALIDITY OF LENIW, MAXP1 AND LENW. -C -C***FIRST EXECUTABLE STATEMENT QAWO - IER = 6 - NEVAL = 0 - LAST = 0 - RESULT = 0.0E+00 - ABSERR = 0.0E+00 - IF(LENIW.LT.2.OR.MAXP1.LT.1.OR.LENW.LT.(LENIW*2+MAXP1*25)) - 1 GO TO 10 -C -C PREPARE CALL FOR QAWOE -C - LIMIT = LENIW/2 - L1 = LIMIT+1 - L2 = LIMIT+L1 - L3 = LIMIT+L2 - L4 = LIMIT+L3 - CALL QAWOE(F,A,B,OMEGA,INTEGR,EPSABS,EPSREL,LIMIT,1,MAXP1,RESULT, - 1 ABSERR,NEVAL,IER,LAST,WORK(1),WORK(L1),WORK(L2),WORK(L3), - 2 IWORK(1),IWORK(L1),MOMCOM,WORK(L4)) -C -C CALL ERROR HANDLER IF NECESSARY -C - LVL = 0 -10 IF(IER.EQ.6) LVL = 1 - IF (IER .NE. 0) CALL XERMSG ('SLATEC', 'QAWO', - + 'ABNORMAL RETURN', IER, LVL) - RETURN - END diff --git a/slatec/qawoe.f b/slatec/qawoe.f deleted file mode 100644 index e53a238..0000000 --- a/slatec/qawoe.f +++ /dev/null @@ -1,547 +0,0 @@ -*DECK QAWOE - SUBROUTINE QAWOE (F, A, B, OMEGA, INTEGR, EPSABS, EPSREL, LIMIT, - + ICALL, MAXP1, RESULT, ABSERR, NEVAL, IER, LAST, ALIST, BLIST, - + RLIST, ELIST, IORD, NNLOG, MOMCOM, CHEBMO) -C***BEGIN PROLOGUE QAWOE -C***PURPOSE Calculate an approximation to a given definite integral -C I = Integral of F(X)*W(X) over (A,B), where -C W(X) = COS(OMEGA*X) -C or W(X) = SIN(OMEGA*X), -C hopefully satisfying the following claim for accuracy -C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A2A1 -C***TYPE SINGLE PRECISION (QAWOE-S, DQAWOE-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, CLENSHAW-CURTIS METHOD, -C EXTRAPOLATION, GLOBALLY ADAPTIVE, -C INTEGRAND WITH OSCILLATORY COS OR SIN FACTOR, QUADPACK, -C QUADRATURE, SPECIAL-PURPOSE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Computation of Oscillatory integrals -C Standard fortran subroutine -C Real version -C -C PARAMETERS -C ON ENTRY -C F - Real -C Function subprogram defining the integrand -C function F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C A - Real -C Lower limit of integration -C -C B - Real -C Upper limit of integration -C -C OMEGA - Real -C Parameter in the integrand weight function -C -C INTEGR - Integer -C Indicates which of the WEIGHT functions is to be -C used -C INTEGR = 1 W(X) = COS(OMEGA*X) -C INTEGR = 2 W(X) = SIN(OMEGA*X) -C If INTEGR.NE.1 and INTEGR.NE.2, the routine -C will end with IER = 6. -C -C EPSABS - Real -C Absolute accuracy requested -C EPSREL - Real -C Relative accuracy requested -C If EPSABS.LE.0 -C and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C the routine will end with IER = 6. -C -C LIMIT - Integer -C Gives an upper bound on the number of subdivisions -C in the partition of (A,B), LIMIT.GE.1. -C -C ICALL - Integer -C If QAWOE is to be used only once, ICALL must -C be set to 1. Assume that during this call, the -C Chebyshev moments (for CLENSHAW-CURTIS integration -C of degree 24) have been computed for intervals of -C lengths (ABS(B-A))*2**(-L), L=0,1,2,...MOMCOM-1. -C If ICALL.GT.1 this means that QAWOE has been -C called twice or more on intervals of the same -C length ABS(B-A). The Chebyshev moments already -C computed are then re-used in subsequent calls. -C If ICALL.LT.1, the routine will end with IER = 6. -C -C MAXP1 - Integer -C Gives an upper bound on the number of Chebyshev -C moments which can be stored, i.e. for the -C intervals of lengths ABS(B-A)*2**(-L), -C L=0,1, ..., MAXP1-2, MAXP1.GE.1. -C If MAXP1.LT.1, the routine will end with IER = 6. -C -C ON RETURN -C RESULT - Real -C Approximation to the integral -C -C ABSERR - Real -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the -C requested accuracy has been achieved. -C - IER.GT.0 Abnormal termination of the routine. -C The estimates for integral and error are -C less reliable. It is assumed that the -C requested accuracy has not been achieved. -C ERROR MESSAGES -C IER = 1 Maximum number of subdivisions allowed -C has been achieved. One can allow more -C subdivisions by increasing the value of -C LIMIT (and taking according dimension -C adjustments into account). However, if -C this yields no improvement it is advised -C to analyze the integrand, in order to -C determine the integration difficulties. -C If the position of a local difficulty can -C be determined (e.g. SINGULARITY, -C DISCONTINUITY within the interval) one -C will probably gain from splitting up the -C interval at this point and calling the -C integrator on the subranges. If possible, -C an appropriate special-purpose integrator -C should be used which is designed for -C handling the type of difficulty involved. -C = 2 The occurrence of roundoff error is -C detected, which prevents the requested -C tolerance from being achieved. -C The error may be under-estimated. -C = 3 Extremely bad integrand behaviour occurs -C at some points of the integration -C interval. -C = 4 The algorithm does not converge. -C Roundoff error is detected in the -C extrapolation table. -C It is presumed that the requested -C tolerance cannot be achieved due to -C roundoff in the extrapolation table, -C and that the returned result is the -C best which can be obtained. -C = 5 The integral is probably divergent, or -C slowly convergent. It must be noted that -C divergence can occur with any other value -C of IER.GT.0. -C = 6 The input is invalid, because -C (EPSABS.LE.0 and -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)) -C or (INTEGR.NE.1 and INTEGR.NE.2) or -C ICALL.LT.1 or MAXP1.LT.1. -C RESULT, ABSERR, NEVAL, LAST, RLIST(1), -C ELIST(1), IORD(1) and NNLOG(1) are set -C to ZERO. ALIST(1) and BLIST(1) are set -C to A and B respectively. -C -C LAST - Integer -C On return, LAST equals the number of -C subintervals produces in the subdivision -C process, which determines the number of -C significant elements actually in the -C WORK ARRAYS. -C ALIST - Real -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the left -C end points of the subintervals in the partition -C of the given integration range (A,B) -C -C BLIST - Real -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the right -C end points of the subintervals in the partition -C of the given integration range (A,B) -C -C RLIST - Real -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the integral -C approximations on the subintervals -C -C ELIST - Real -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the moduli of the -C absolute error estimates on the subintervals -C -C IORD - Integer -C Vector of dimension at least LIMIT, the first K -C elements of which are pointers to the error -C estimates over the subintervals, -C such that ELIST(IORD(1)), ..., -C ELIST(IORD(K)) form a decreasing sequence, with -C K = LAST if LAST.LE.(LIMIT/2+2), and -C K = LIMIT+1-LAST otherwise. -C -C NNLOG - Integer -C Vector of dimension at least LIMIT, containing the -C subdivision levels of the subintervals, i.e. -C IWORK(I) = L means that the subinterval -C numbered I is of length ABS(B-A)*2**(1-L) -C -C ON ENTRY AND RETURN -C MOMCOM - Integer -C Indicating that the Chebyshev moments -C have been computed for intervals of lengths -C (ABS(B-A))*2**(-L), L=0,1,2, ..., MOMCOM-1, -C MOMCOM.LT.MAXP1 -C -C CHEBMO - Real -C Array of dimension (MAXP1,25) containing the -C Chebyshev moments -C -C***REFERENCES (NONE) -C***ROUTINES CALLED QC25F, QELG, QPSRT, R1MACH -C***REVISION HISTORY (YYMMDD) -C 800101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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***END PROLOGUE QAWOE -C - REAL A,ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1, - 1 A2,B,BLIST,B1,B2,CHEBMO,CORREC,DEFAB1,DEFAB2,DEFABS, - 2 DOMEGA,R1MACH,DRES,ELIST,EPMACH,EPSABS,EPSREL,ERLARG, - 3 ERLAST,ERRBND,ERRMAX,ERROR1,ERRO12,ERROR2,ERRSUM,ERTEST,F,OFLOW, - 4 OMEGA,RESABS,RESEPS,RESULT,RES3LA,RLIST,RLIST2,SMALL,UFLOW,WIDTH - INTEGER ICALL,ID,IER,IERRO,INTEGR,IORD,IROFF1,IROFF2,IROFF3, - 1 JUPBND,K,KSGN,KTMIN,LAST,LIMIT,MAXERR,MAXP1,MOMCOM,NEV, - 2 NEVAL,NNLOG,NRES,NRMAX,NRMOM,NUMRL2 - LOGICAL EXTRAP,NOEXT,EXTALL -C - DIMENSION ALIST(*),BLIST(*),RLIST(*),ELIST(*), - 1 IORD(*),RLIST2(52),RES3LA(3),CHEBMO(MAXP1,25),NNLOG(*) -C - EXTERNAL F -C -C THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF -C LIMEXP IN SUBROUTINE QELG (RLIST2 SHOULD BE OF -C DIMENSION (LIMEXP+2) AT LEAST). -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER -C (ALIST(I),BLIST(I)) -C RLIST2 - ARRAY OF DIMENSION AT LEAST LIMEXP+2 -C CONTAINING THE PART OF THE EPSILON TABLE -C WHICH IS STILL NEEDED FOR FURTHER COMPUTATIONS -C ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) -C MAXERR - POINTER TO THE INTERVAL WITH LARGEST -C ERROR ESTIMATE -C ERRMAX - ELIST(MAXERR) -C ERLAST - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED -C AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS -C ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS -C ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* -C ABS(RESULT)) -C *****1 - VARIABLE FOR THE LEFT SUBINTERVAL -C *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL -C LAST - INDEX FOR SUBDIVISION -C NRES - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE -C NUMRL2 - NUMBER OF ELEMENTS IN RLIST2. IF AN APPROPRIATE -C APPROXIMATION TO THE COMPOUNDED INTEGRAL HAS -C BEEN OBTAINED IT IS PUT IN RLIST2(NUMRL2) AFTER -C NUMRL2 HAS BEEN INCREASED BY ONE -C SMALL - LENGTH OF THE SMALLEST INTERVAL CONSIDERED -C UP TO NOW, MULTIPLIED BY 1.5 -C ERLARG - SUM OF THE ERRORS OVER THE INTERVALS LARGER -C THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW -C EXTRAP - LOGICAL VARIABLE DENOTING THAT THE ROUTINE IS -C ATTEMPTING TO PERFORM EXTRAPOLATION, I.E. BEFORE -C SUBDIVIDING THE SMALLEST INTERVAL WE TRY TO -C DECREASE THE VALUE OF ERLARG -C NOEXT - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION -C IS NO LONGER ALLOWED (TRUE VALUE) -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C OFLOW IS THE LARGEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT QAWOE - EPMACH = R1MACH(4) -C -C TEST ON VALIDITY OF PARAMETERS -C ------------------------------ -C - IER = 0 - NEVAL = 0 - LAST = 0 - RESULT = 0.0E+00 - ABSERR = 0.0E+00 - ALIST(1) = A - BLIST(1) = B - RLIST(1) = 0.0E+00 - ELIST(1) = 0.0E+00 - IORD(1) = 0 - NNLOG(1) = 0 - IF((INTEGR.NE.1.AND.INTEGR.NE.2).OR.(EPSABS.LE.0.0E+00.AND. - 1 EPSREL.LT.MAX(0.5E+02*EPMACH,0.5E-14)).OR.ICALL.LT.1.OR. - 2 MAXP1.LT.1) IER = 6 - IF(IER.EQ.6) GO TO 999 -C -C FIRST APPROXIMATION TO THE INTEGRAL -C ----------------------------------- -C - DOMEGA = ABS(OMEGA) - NRMOM = 0 - IF (ICALL.GT.1) GO TO 5 - MOMCOM = 0 - 5 CALL QC25F(F,A,B,DOMEGA,INTEGR,NRMOM,MAXP1,0,RESULT,ABSERR, - 1 NEVAL,DEFABS,RESABS,MOMCOM,CHEBMO) -C -C TEST ON ACCURACY. -C - DRES = ABS(RESULT) - ERRBND = MAX(EPSABS,EPSREL*DRES) - RLIST(1) = RESULT - ELIST(1) = ABSERR - IORD(1) = 1 - IF(ABSERR.LE.0.1E+03*EPMACH*DEFABS.AND.ABSERR.GT. - 1 ERRBND) IER = 2 - IF(LIMIT.EQ.1) IER = 1 - IF(IER.NE.0.OR.ABSERR.LE.ERRBND) GO TO 200 -C -C INITIALIZATIONS -C --------------- -C - UFLOW = R1MACH(1) - OFLOW = R1MACH(2) - ERRMAX = ABSERR - MAXERR = 1 - AREA = RESULT - ERRSUM = ABSERR - ABSERR = OFLOW - NRMAX = 1 - EXTRAP = .FALSE. - NOEXT = .FALSE. - IERRO = 0 - IROFF1 = 0 - IROFF2 = 0 - IROFF3 = 0 - KTMIN = 0 - SMALL = ABS(B-A)*0.75E+00 - NRES = 0 - NUMRL2 = 0 - EXTALL = .FALSE. - IF(0.5E+00*ABS(B-A)*DOMEGA.GT.0.2E+01) GO TO 10 - NUMRL2 = 1 - EXTALL = .TRUE. - RLIST2(1) = RESULT - 10 IF(0.25E+00*ABS(B-A)*DOMEGA.LE.0.2E+01) EXTALL = .TRUE. - KSGN = -1 - IF(DRES.GE.(0.1E+01-0.5E+02*EPMACH)*DEFABS) KSGN = 1 -C -C MAIN DO-LOOP -C ------------ -C - DO 140 LAST = 2,LIMIT -C -C BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST -C ERROR ESTIMATE. -C - NRMOM = NNLOG(MAXERR)+1 - A1 = ALIST(MAXERR) - B1 = 0.5E+00*(ALIST(MAXERR)+BLIST(MAXERR)) - A2 = B1 - B2 = BLIST(MAXERR) - ERLAST = ERRMAX - CALL QC25F(F,A1,B1,DOMEGA,INTEGR,NRMOM,MAXP1,0, - 1 AREA1,ERROR1,NEV,RESABS,DEFAB1,MOMCOM,CHEBMO) - NEVAL = NEVAL+NEV - CALL QC25F(F,A2,B2,DOMEGA,INTEGR,NRMOM,MAXP1,1, - 1 AREA2,ERROR2,NEV,RESABS,DEFAB2,MOMCOM,CHEBMO) - NEVAL = NEVAL+NEV -C -C IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL -C AND ERROR AND TEST FOR ACCURACY. -C - AREA12 = AREA1+AREA2 - ERRO12 = ERROR1+ERROR2 - ERRSUM = ERRSUM+ERRO12-ERRMAX - AREA = AREA+AREA12-RLIST(MAXERR) - IF(DEFAB1.EQ.ERROR1.OR.DEFAB2.EQ.ERROR2) GO TO 25 - IF(ABS(RLIST(MAXERR)-AREA12).GT.0.1E-04*ABS(AREA12) - 1 .OR.ERRO12.LT.0.99E+00*ERRMAX) GO TO 20 - IF(EXTRAP) IROFF2 = IROFF2+1 - IF(.NOT.EXTRAP) IROFF1 = IROFF1+1 - 20 IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF3 = IROFF3+1 - 25 RLIST(MAXERR) = AREA1 - RLIST(LAST) = AREA2 - NNLOG(MAXERR) = NRMOM - NNLOG(LAST) = NRMOM - ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) -C -C TEST FOR ROUNDOFF ERROR AND EVENTUALLY -C SET ERROR FLAG -C - IF(IROFF1+IROFF2.GE.10.OR.IROFF3.GE.20) IER = 2 - IF(IROFF2.GE.5) IERRO = 3 -C -C SET ERROR FLAG IN THE CASE THAT THE NUMBER OF -C SUBINTERVALS EQUALS LIMIT. -C - IF(LAST.EQ.LIMIT) IER = 1 -C -C SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR -C AT A POINT OF THE INTEGRATION RANGE. -C - IF(MAX(ABS(A1),ABS(B2)).LE.(0.1E+01+0.1E+03*EPMACH) - 1 *(ABS(A2)+0.1E+04*UFLOW)) IER = 4 -C -C APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. -C - IF(ERROR2.GT.ERROR1) GO TO 30 - ALIST(LAST) = A2 - BLIST(MAXERR) = B1 - BLIST(LAST) = B2 - ELIST(MAXERR) = ERROR1 - ELIST(LAST) = ERROR2 - GO TO 40 - 30 ALIST(MAXERR) = A2 - ALIST(LAST) = A1 - BLIST(LAST) = B1 - RLIST(MAXERR) = AREA2 - RLIST(LAST) = AREA1 - ELIST(MAXERR) = ERROR2 - ELIST(LAST) = ERROR1 -C -C CALL SUBROUTINE QPSRT TO MAINTAIN THE DESCENDING ORDERING -C IN THE LIST OF ERROR ESTIMATES AND SELECT THE -C SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE -C BISECTED NEXT). -C - 40 CALL QPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) -C ***JUMP OUT OF DO-LOOP - IF(ERRSUM.LE.ERRBND) GO TO 170 - IF(IER.NE.0) GO TO 150 - IF(LAST.EQ.2.AND.EXTALL) GO TO 120 - IF(NOEXT) GO TO 140 - IF(.NOT.EXTALL) GO TO 50 - ERLARG = ERLARG-ERLAST - IF(ABS(B1-A1).GT.SMALL) ERLARG = ERLARG+ERRO12 - IF(EXTRAP) GO TO 70 -C -C TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE -C SMALLEST INTERVAL. -C - 50 WIDTH = ABS(BLIST(MAXERR)-ALIST(MAXERR)) - IF(WIDTH.GT.SMALL) GO TO 140 - IF(EXTALL) GO TO 60 -C -C TEST WHETHER WE CAN START WITH THE EXTRAPOLATION -C PROCEDURE (WE DO THIS IF WE INTEGRATE OVER THE -C NEXT INTERVAL WITH USE OF A GAUSS-KRONROD RULE - SEE -C SUBROUTINE QC25F). -C - SMALL = SMALL*0.5E+00 - IF(0.25E+00*WIDTH*DOMEGA.GT.0.2E+01) GO TO 140 - EXTALL = .TRUE. - GO TO 130 - 60 EXTRAP = .TRUE. - NRMAX = 2 - 70 IF(IERRO.EQ.3.OR.ERLARG.LE.ERTEST) GO TO 90 -C -C THE SMALLEST INTERVAL HAS THE LARGEST ERROR. -C BEFORE BISECTING DECREASE THE SUM OF THE ERRORS -C OVER THE LARGER INTERVALS (ERLARG) AND PERFORM -C EXTRAPOLATION. -C - JUPBND = LAST - IF (LAST.GT.(LIMIT/2+2)) JUPBND = LIMIT+3-LAST - ID = NRMAX - DO 80 K = ID,JUPBND - MAXERR = IORD(NRMAX) - ERRMAX = ELIST(MAXERR) - IF(ABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 140 - NRMAX = NRMAX+1 - 80 CONTINUE -C -C PERFORM EXTRAPOLATION. -C - 90 NUMRL2 = NUMRL2+1 - RLIST2(NUMRL2) = AREA - IF(NUMRL2.LT.3) GO TO 110 - CALL QELG(NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES) - KTMIN = KTMIN+1 - IF(KTMIN.GT.5.AND.ABSERR.LT.0.1E-02*ERRSUM) IER = 5 - IF(ABSEPS.GE.ABSERR) GO TO 100 - KTMIN = 0 - ABSERR = ABSEPS - RESULT = RESEPS - CORREC = ERLARG - ERTEST = MAX(EPSABS,EPSREL*ABS(RESEPS)) -C ***JUMP OUT OF DO-LOOP - IF(ABSERR.LE.ERTEST) GO TO 150 -C -C PREPARE BISECTION OF THE SMALLEST INTERVAL. -C - 100 IF(NUMRL2.EQ.1) NOEXT = .TRUE. - IF(IER.EQ.5) GO TO 150 - 110 MAXERR = IORD(1) - ERRMAX = ELIST(MAXERR) - NRMAX = 1 - EXTRAP = .FALSE. - SMALL = SMALL*0.5E+00 - ERLARG = ERRSUM - GO TO 140 - 120 SMALL = SMALL*0.5E+00 - NUMRL2 = NUMRL2+1 - RLIST2(NUMRL2) = AREA - 130 ERTEST = ERRBND - ERLARG = ERRSUM - 140 CONTINUE -C -C SET THE FINAL RESULT. -C --------------------- -C - 150 IF(ABSERR.EQ.OFLOW.OR.NRES.EQ.0) GO TO 170 - IF(IER+IERRO.EQ.0) GO TO 165 - IF(IERRO.EQ.3) ABSERR = ABSERR+CORREC - IF(IER.EQ.0) IER = 3 - IF(RESULT.NE.0.0E+00.AND.AREA.NE.0.0E+00) GO TO 160 - IF(ABSERR.GT.ERRSUM) GO TO 170 - IF(AREA.EQ.0.0E+00) GO TO 190 - GO TO 165 - 160 IF(ABSERR/ABS(RESULT).GT.ERRSUM/ABS(AREA)) GO TO 170 -C -C TEST ON DIVERGENCE. -C - 165 IF(KSGN.EQ.(-1).AND.MAX(ABS(RESULT),ABS(AREA)).LE. - 1 DEFABS*0.1E-01) GO TO 190 - IF(0.1E-01.GT.(RESULT/AREA).OR.(RESULT/AREA).GT.0.1E+03 - 1 .OR.ERRSUM.GE.ABS(AREA)) IER = 6 - GO TO 190 -C -C COMPUTE GLOBAL INTEGRAL SUM. -C - 170 RESULT = 0.0E+00 - DO 180 K=1,LAST - RESULT = RESULT+RLIST(K) - 180 CONTINUE - ABSERR = ERRSUM - 190 IF (IER.GT.2) IER=IER-1 - 200 IF (INTEGR.EQ.2.AND.OMEGA.LT.0.0E+00) RESULT=-RESULT - 999 RETURN - END diff --git a/slatec/qaws.f b/slatec/qaws.f deleted file mode 100644 index 0c8c7d5..0000000 --- a/slatec/qaws.f +++ /dev/null @@ -1,212 +0,0 @@ -*DECK QAWS - SUBROUTINE QAWS (F, A, B, ALFA, BETA, INTEGR, EPSABS, EPSREL, - + RESULT, ABSERR, NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK) -C***BEGIN PROLOGUE QAWS -C***PURPOSE The routine calculates an approximation result to a given -C definite integral I = Integral of F*W over (A,B), -C (where W shows a singular behaviour at the end points -C see parameter INTEGR). -C Hopefully satisfying following claim for accuracy -C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A2A1 -C***TYPE SINGLE PRECISION (QAWS-S, DQAWS-D) -C***KEYWORDS ALGEBRAIC-LOGARITHMIC END POINT SINGULARITIES, -C AUTOMATIC INTEGRATOR, CLENSHAW-CURTIS METHOD, -C GLOBALLY ADAPTIVE, QUADPACK, QUADRATURE, SPECIAL-PURPOSE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration of functions having algebraico-logarithmic -C end point singularities -C Standard fortran subroutine -C Real version -C -C PARAMETERS -C ON ENTRY -C F - Real -C Function subprogram defining the integrand -C function F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C A - Real -C Lower limit of integration -C -C B - Real -C Upper limit of integration, B.GT.A -C If B.LE.A, the routine will end with IER = 6. -C -C ALFA - Real -C Parameter in the integrand function, ALFA.GT.(-1) -C If ALFA.LE.(-1), the routine will end with -C IER = 6. -C -C BETA - Real -C Parameter in the integrand function, BETA.GT.(-1) -C If BETA.LE.(-1), the routine will end with -C IER = 6. -C -C INTEGR - Integer -C Indicates which WEIGHT function is to be used -C = 1 (X-A)**ALFA*(B-X)**BETA -C = 2 (X-A)**ALFA*(B-X)**BETA*LOG(X-A) -C = 3 (X-A)**ALFA*(B-X)**BETA*LOG(B-X) -C = 4 (X-A)**ALFA*(B-X)**BETA*LOG(X-A)*LOG(B-X) -C If INTEGR.LT.1 or INTEGR.GT.4, the routine -C will end with IER = 6. -C -C EPSABS - Real -C Absolute accuracy requested -C EPSREL - Real -C Relative accuracy requested -C If EPSABS.LE.0 -C and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C the routine will end with IER = 6. -C -C ON RETURN -C RESULT - Real -C Approximation to the integral -C -C ABSERR - Real -C Estimate of the modulus of the absolute error, -C Which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C IER.GT.0 Abnormal termination of the routine -C The estimates for the integral and error -C are less reliable. It is assumed that the -C requested accuracy has not been achieved. -C ERROR MESSAGES -C IER = 1 Maximum number of subdivisions allowed -C has been achieved. One can allow more -C subdivisions by increasing the value of -C LIMIT (and taking the according dimension -C adjustments into account). However, if -C this yields no improvement it is advised -C to analyze the integrand, in order to -C determine the integration difficulties -C which prevent the requested tolerance from -C being achieved. In case of a jump -C discontinuity or a local singularity -C of algebraico-logarithmic type at one or -C more interior points of the integration -C range, one should proceed by splitting up -C the interval at these points and calling -C the integrator on the subranges. -C = 2 The occurrence of roundoff error is -C detected, which prevents the requested -C tolerance from being achieved. -C = 3 Extremely bad integrand behaviour occurs -C at some points of the integration -C interval. -C = 6 The input is invalid, because -C B.LE.A or ALFA.LE.(-1) or BETA.LE.(-1) or -C or INTEGR.LT.1 or INTEGR.GT.4 or -C (EPSABS.LE.0 and -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)) -C or LIMIT.LT.2 or LENW.LT.LIMIT*4. -C RESULT, ABSERR, NEVAL, LAST are set to -C zero. Except when LENW or LIMIT is invalid -C IWORK(1), WORK(LIMIT*2+1) and -C WORK(LIMIT*3+1) are set to zero, WORK(1) -C is set to A and WORK(LIMIT+1) to B. -C -C DIMENSIONING PARAMETERS -C LIMIT - Integer -C Dimensioning parameter for IWORK -C LIMIT determines the maximum number of -C subintervals in the partition of the given -C integration interval (A,B), LIMIT.GE.2. -C If LIMIT.LT.2, the routine will end with IER = 6. -C -C LENW - Integer -C Dimensioning parameter for WORK -C LENW must be at least LIMIT*4. -C If LENW.LT.LIMIT*4, the routine will end -C with IER = 6. -C -C LAST - Integer -C On return, LAST equals the number of -C subintervals produced in the subdivision process, -C which determines the significant number of -C elements actually in the WORK ARRAYS. -C -C WORK ARRAYS -C IWORK - Integer -C Vector of dimension LIMIT, the first K -C elements of which contain pointers -C to the error estimates over the subintervals, -C such that WORK(LIMIT*3+IWORK(1)), ..., -C WORK(LIMIT*3+IWORK(K)) form a decreasing -C sequence with K = LAST if LAST.LE.(LIMIT/2+2), -C and K = LIMIT+1-LAST otherwise -C -C WORK - Real -C Vector of dimension LENW -C On return -C WORK(1), ..., WORK(LAST) contain the left -C end points of the subintervals in the -C partition of (A,B), -C WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain -C the right end points, -C WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) -C contain the integral approximations over -C the subintervals, -C WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) -C contain the error estimates. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED QAWSE, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800101 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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE QAWS -C - REAL A,ABSERR,ALFA,B,BETA,EPSABS,EPSREL,F,RESULT,WORK - INTEGER IER,INTEGR,IWORK,LENW,LIMIT,LVL,L1,L2,L3,NEVAL -C - DIMENSION IWORK(*),WORK(*) -C - EXTERNAL F -C -C CHECK VALIDITY OF LIMIT AND LENW. -C -C***FIRST EXECUTABLE STATEMENT QAWS - IER = 6 - NEVAL = 0 - LAST = 0 - RESULT = 0.0E+00 - ABSERR = 0.0E+00 - IF(LIMIT.LT.2.OR.LENW.LT.LIMIT*4) GO TO 10 -C -C PREPARE CALL FOR QAWSE. -C - L1 = LIMIT+1 - L2 = LIMIT+L1 - L3 = LIMIT+L2 -C - CALL QAWSE(F,A,B,ALFA,BETA,INTEGR,EPSABS,EPSREL,LIMIT,RESULT, - 1 ABSERR,NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) -C -C CALL ERROR HANDLER IF NECESSARY. -C - LVL = 0 -10 IF(IER.EQ.6) LVL = 1 - IF (IER .NE. 0) CALL XERMSG ('SLATEC', 'QAWS', - + 'ABNORMAL RETURN', IER, LVL) - RETURN - END diff --git a/slatec/qawse.f b/slatec/qawse.f deleted file mode 100644 index 8d6726f..0000000 --- a/slatec/qawse.f +++ /dev/null @@ -1,384 +0,0 @@ -*DECK QAWSE - SUBROUTINE QAWSE (F, A, B, ALFA, BETA, INTEGR, EPSABS, EPSREL, - + LIMIT, RESULT, ABSERR, NEVAL, IER, ALIST, BLIST, RLIST, ELIST, - + IORD, LAST) -C***BEGIN PROLOGUE QAWSE -C***PURPOSE The routine calculates an approximation result to a given -C definite integral I = Integral of F*W over (A,B), -C (where W shows a singular behaviour at the end points, -C see parameter INTEGR). -C Hopefully satisfying following claim for accuracy -C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A2A1 -C***TYPE SINGLE PRECISION (QAWSE-S, DQAWSE-D) -C***KEYWORDS ALGEBRAIC-LOGARITHMIC END POINT SINGULARITIES, -C AUTOMATIC INTEGRATOR, CLENSHAW-CURTIS METHOD, QUADPACK, -C QUADRATURE, SPECIAL-PURPOSE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration of functions having algebraico-logarithmic -C end point singularities -C Standard fortran subroutine -C Real version -C -C PARAMETERS -C ON ENTRY -C F - Real -C Function subprogram defining the integrand -C function F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C A - Real -C Lower limit of integration -C -C B - Real -C Upper limit of integration, B.GT.A -C If B.LE.A, the routine will end with IER = 6. -C -C ALFA - Real -C Parameter in the WEIGHT function, ALFA.GT.(-1) -C If ALFA.LE.(-1), the routine will end with -C IER = 6. -C -C BETA - Real -C Parameter in the WEIGHT function, BETA.GT.(-1) -C If BETA.LE.(-1), the routine will end with -C IER = 6. -C -C INTEGR - Integer -C Indicates which WEIGHT function is to be used -C = 1 (X-A)**ALFA*(B-X)**BETA -C = 2 (X-A)**ALFA*(B-X)**BETA*LOG(X-A) -C = 3 (X-A)**ALFA*(B-X)**BETA*LOG(B-X) -C = 4 (X-A)**ALFA*(B-X)**BETA*LOG(X-A)*LOG(B-X) -C If INTEGR.LT.1 or INTEGR.GT.4, the routine -C will end with IER = 6. -C -C EPSABS - Real -C Absolute accuracy requested -C EPSREL - Real -C Relative accuracy requested -C If EPSABS.LE.0 -C and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C the routine will end with IER = 6. -C -C LIMIT - Integer -C Gives an upper bound on the number of subintervals -C in the partition of (A,B), LIMIT.GE.2 -C If LIMIT.LT.2, the routine will end with IER = 6. -C -C ON RETURN -C RESULT - Real -C Approximation to the integral -C -C ABSERR - Real -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - Integer -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C IER.GT.0 Abnormal termination of the routine -C the estimates for the integral and error -C are less reliable. It is assumed that the -C requested accuracy has not been achieved. -C ERROR MESSAGES -C = 1 Maximum number of subdivisions allowed -C has been achieved. One can allow more -C subdivisions by increasing the value of -C LIMIT. However, if this yields no -C improvement, it is advised to analyze the -C integrand in order to determine the -C integration difficulties which prevent the -C requested tolerance from being achieved. -C In case of a jump DISCONTINUITY or a local -C SINGULARITY of algebraico-logarithmic type -C at one or more interior points of the -C integration range, one should proceed by -C splitting up the interval at these -C points and calling the integrator on the -C subranges. -C = 2 The occurrence of roundoff error is -C detected, which prevents the requested -C tolerance from being achieved. -C = 3 Extremely bad integrand behaviour occurs -C at some points of the integration -C interval. -C = 6 The input is invalid, because -C B.LE.A or ALFA.LE.(-1) or BETA.LE.(-1), or -C INTEGR.LT.1 or INTEGR.GT.4, or -C (EPSABS.LE.0 and -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C or LIMIT.LT.2. -C RESULT, ABSERR, NEVAL, RLIST(1), ELIST(1), -C IORD(1) and LAST are set to zero. ALIST(1) -C and BLIST(1) are set to A and B -C respectively. -C -C ALIST - Real -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the left -C end points of the subintervals in the partition -C of the given integration range (A,B) -C -C BLIST - Real -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the right -C end points of the subintervals in the partition -C of the given integration range (A,B) -C -C RLIST - Real -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the integral -C approximations on the subintervals -C -C ELIST - Real -C Vector of dimension at least LIMIT, the first -C LAST elements of which are the moduli of the -C absolute error estimates on the subintervals -C -C IORD - Integer -C Vector of dimension at least LIMIT, the first K -C of which are pointers to the error -C estimates over the subintervals, so that -C ELIST(IORD(1)), ..., ELIST(IORD(K)) with K = LAST -C If LAST.LE.(LIMIT/2+2), and K = LIMIT+1-LAST -C otherwise form a decreasing sequence -C -C LAST - Integer -C Number of subintervals actually produced in -C the subdivision process -C -C***REFERENCES (NONE) -C***ROUTINES CALLED QC25S, QMOMO, QPSRT, R1MACH -C***REVISION HISTORY (YYMMDD) -C 800101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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***END PROLOGUE QAWSE -C - REAL A,ABSERR,ALFA,ALIST,AREA,AREA1,AREA12, - 1 AREA2,A1,A2,B,BETA,BLIST,B1,B2,CENTRE, - 2 R1MACH,ELIST,EPMACH,EPSABS,EPSREL,ERRBND,ERRMAX, - 3 ERROR1,ERRO12,ERROR2,ERRSUM,F,RESAS1,RESAS2,RESULT,RG,RH,RI,RJ, - 4 RLIST,UFLOW - INTEGER IER,INTEGR,IORD,IROFF1,IROFF2,K,LAST, - 1 LIMIT,MAXERR,NEV,NEVAL,NRMAX -C - EXTERNAL F -C - DIMENSION ALIST(*),BLIST(*),RLIST(*),ELIST(*), - 1 IORD(*),RI(25),RJ(25),RH(25),RG(25) -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER -C (ALIST(I),BLIST(I)) -C ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) -C MAXERR - POINTER TO THE INTERVAL WITH LARGEST -C ERROR ESTIMATE -C ERRMAX - ELIST(MAXERR) -C AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS -C ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS -C ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* -C ABS(RESULT)) -C *****1 - VARIABLE FOR THE LEFT SUBINTERVAL -C *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL -C LAST - INDEX FOR SUBDIVISION -C -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT QAWSE - EPMACH = R1MACH(4) - UFLOW = R1MACH(1) -C -C TEST ON VALIDITY OF PARAMETERS -C ------------------------------ -C - IER = 6 - NEVAL = 0 - LAST = 0 - RLIST(1) = 0.0E+00 - ELIST(1) = 0.0E+00 - IORD(1) = 0 - RESULT = 0.0E+00 - ABSERR = 0.0E+00 - IF (B.LE.A.OR.(EPSABS.EQ.0.0E+00.AND. - 1 EPSREL.LT.MAX(0.5E+02*EPMACH,0.5E-14)).OR.ALFA.LE.(-0.1E+01) - 2 .OR.BETA.LE.(-0.1E+01).OR.INTEGR.LT.1.OR.INTEGR.GT.4.OR. - 3 LIMIT.LT.2) GO TO 999 - IER = 0 -C -C COMPUTE THE MODIFIED CHEBYSHEV MOMENTS. -C - CALL QMOMO(ALFA,BETA,RI,RJ,RG,RH,INTEGR) -C -C INTEGRATE OVER THE INTERVALS (A,(A+B)/2) -C AND ((A+B)/2,B). -C - CENTRE = 0.5E+00*(B+A) - CALL QC25S(F,A,B,A,CENTRE,ALFA,BETA,RI,RJ,RG,RH,AREA1, - 1 ERROR1,RESAS1,INTEGR,NEV) - NEVAL = NEV - CALL QC25S(F,A,B,CENTRE,B,ALFA,BETA,RI,RJ,RG,RH,AREA2, - 1 ERROR2,RESAS2,INTEGR,NEV) - LAST = 2 - NEVAL = NEVAL+NEV - RESULT = AREA1+AREA2 - ABSERR = ERROR1+ERROR2 -C -C TEST ON ACCURACY. -C - ERRBND = MAX(EPSABS,EPSREL*ABS(RESULT)) -C -C INITIALIZATION -C -------------- -C - IF(ERROR2.GT.ERROR1) GO TO 10 - ALIST(1) = A - ALIST(2) = CENTRE - BLIST(1) = CENTRE - BLIST(2) = B - RLIST(1) = AREA1 - RLIST(2) = AREA2 - ELIST(1) = ERROR1 - ELIST(2) = ERROR2 - GO TO 20 - 10 ALIST(1) = CENTRE - ALIST(2) = A - BLIST(1) = B - BLIST(2) = CENTRE - RLIST(1) = AREA2 - RLIST(2) = AREA1 - ELIST(1) = ERROR2 - ELIST(2) = ERROR1 - 20 IORD(1) = 1 - IORD(2) = 2 - IF(LIMIT.EQ.2) IER = 1 - IF(ABSERR.LE.ERRBND.OR.IER.EQ.1) GO TO 999 - ERRMAX = ELIST(1) - MAXERR = 1 - NRMAX = 1 - AREA = RESULT - ERRSUM = ABSERR - IROFF1 = 0 - IROFF2 = 0 -C -C MAIN DO-LOOP -C ------------ -C - DO 60 LAST = 3,LIMIT -C -C BISECT THE SUBINTERVAL WITH LARGEST ERROR ESTIMATE. -C - A1 = ALIST(MAXERR) - B1 = 0.5E+00*(ALIST(MAXERR)+BLIST(MAXERR)) - A2 = B1 - B2 = BLIST(MAXERR) -C - CALL QC25S(F,A,B,A1,B1,ALFA,BETA,RI,RJ,RG,RH,AREA1, - 1 ERROR1,RESAS1,INTEGR,NEV) - NEVAL = NEVAL+NEV - CALL QC25S(F,A,B,A2,B2,ALFA,BETA,RI,RJ,RG,RH,AREA2, - 1 ERROR2,RESAS2,INTEGR,NEV) - NEVAL = NEVAL+NEV -C -C IMPROVE PREVIOUS APPROXIMATIONS INTEGRAL AND ERROR -C AND TEST FOR ACCURACY. -C - AREA12 = AREA1+AREA2 - ERRO12 = ERROR1+ERROR2 - ERRSUM = ERRSUM+ERRO12-ERRMAX - AREA = AREA+AREA12-RLIST(MAXERR) - IF(A.EQ.A1.OR.B.EQ.B2) GO TO 30 - IF(RESAS1.EQ.ERROR1.OR.RESAS2.EQ.ERROR2) GO TO 30 -C -C TEST FOR ROUNDOFF ERROR. -C - IF(ABS(RLIST(MAXERR)-AREA12).LT.0.1E-04*ABS(AREA12) - 1 .AND.ERRO12.GE.0.99E+00*ERRMAX) IROFF1 = IROFF1+1 - IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF2 = IROFF2+1 - 30 RLIST(MAXERR) = AREA1 - RLIST(LAST) = AREA2 -C -C TEST ON ACCURACY. -C - ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) - IF(ERRSUM.LE.ERRBND) GO TO 35 -C -C SET ERROR FLAG IN THE CASE THAT THE NUMBER OF INTERVAL -C BISECTIONS EXCEEDS LIMIT. -C - IF(LAST.EQ.LIMIT) IER = 1 -C -C -C SET ERROR FLAG IN THE CASE OF ROUNDOFF ERROR. -C - IF(IROFF1.GE.6.OR.IROFF2.GE.20) IER = 2 -C -C SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR -C AT INTERIOR POINTS OF INTEGRATION RANGE. -C - IF(MAX(ABS(A1),ABS(B2)).LE.(0.1E+01+0.1E+03*EPMACH)* - 1 (ABS(A2)+0.1E+04*UFLOW)) IER = 3 -C -C APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. -C - 35 IF(ERROR2.GT.ERROR1) GO TO 40 - ALIST(LAST) = A2 - BLIST(MAXERR) = B1 - BLIST(LAST) = B2 - ELIST(MAXERR) = ERROR1 - ELIST(LAST) = ERROR2 - GO TO 50 - 40 ALIST(MAXERR) = A2 - ALIST(LAST) = A1 - BLIST(LAST) = B1 - RLIST(MAXERR) = AREA2 - RLIST(LAST) = AREA1 - ELIST(MAXERR) = ERROR2 - ELIST(LAST) = ERROR1 -C -C CALL SUBROUTINE QPSRT TO MAINTAIN THE DESCENDING ORDERING -C IN THE LIST OF ERROR ESTIMATES AND SELECT THE -C SUBINTERVAL WITH LARGEST ERROR ESTIMATE (TO BE -C BISECTED NEXT). -C - 50 CALL QPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) -C ***JUMP OUT OF DO-LOOP - IF (IER.NE.0.OR.ERRSUM.LE.ERRBND) GO TO 70 - 60 CONTINUE -C -C COMPUTE FINAL RESULT. -C --------------------- -C - 70 RESULT = 0.0E+00 - DO 80 K=1,LAST - RESULT = RESULT+RLIST(K) - 80 CONTINUE - ABSERR = ERRSUM - 999 RETURN - END diff --git a/slatec/qc25c.f b/slatec/qc25c.f deleted file mode 100644 index 5fc87eb..0000000 --- a/slatec/qc25c.f +++ /dev/null @@ -1,170 +0,0 @@ -*DECK QC25C - SUBROUTINE QC25C (F, A, B, C, RESULT, ABSERR, KRUL, NEVAL) -C***BEGIN PROLOGUE QC25C -C***PURPOSE To compute I = Integral of F*W over (A,B) with -C error estimate, where W(X) = 1/(X-C) -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A2A2, J4 -C***TYPE SINGLE PRECISION (QC25C-S, DQC25C-D) -C***KEYWORDS 25-POINT CLENSHAW-CURTIS INTEGRATION, QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration rules for the computation of CAUCHY -C PRINCIPAL VALUE integrals -C Standard fortran subroutine -C Real version -C -C PARAMETERS -C F - Real -C Function subprogram defining the integrand function -C F(X). The actual name for F needs to be declared -C E X T E R N A L in the driver program. -C -C A - Real -C Left end point of the integration interval -C -C B - Real -C Right end point of the integration interval, B.GT.A -C -C C - Real -C Parameter in the WEIGHT function -C -C RESULT - Real -C Approximation to the integral -C result is computed by using a generalized -C Clenshaw-Curtis method if C lies within ten percent -C of the integration interval. In the other case the -C 15-point Kronrod rule obtained by optimal addition -C of abscissae to the 7-point Gauss rule, is applied. -C -C ABSERR - Real -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C KRUL - Integer -C Key which is decreased by 1 if the 15-point -C Gauss-Kronrod scheme has been used -C -C NEVAL - Integer -C Number of integrand evaluations -C -C***REFERENCES (NONE) -C***ROUTINES CALLED QCHEB, QK15W, QWGTC -C***REVISION HISTORY (YYMMDD) -C 810101 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***END PROLOGUE QC25C -C - REAL A,ABSERR,AK22,AMOM0,AMOM1,AMOM2,B,C,CC, - 1 CENTR,CHEB12,CHEB24,QWGTC,F,FVAL,HLGTH,P2,P3,P4, - 2 RESABS,RESASC,RESULT,RES12,RES24,U,X - INTEGER I,ISYM,K,KP,KRUL,NEVAL -C - DIMENSION X(11),FVAL(25),CHEB12(13),CHEB24(25) -C - EXTERNAL F, QWGTC -C -C THE VECTOR X CONTAINS THE VALUES COS(K*PI/24), -C K = 1, ..., 11, TO BE USED FOR THE CHEBYSHEV SERIES -C EXPANSION OF F -C - SAVE X - DATA X(1),X(2),X(3),X(4),X(5),X(6),X(7),X(8),X(9),X(10), - 1 X(11)/ - 2 0.9914448613738104E+00, 0.9659258262890683E+00, - 3 0.9238795325112868E+00, 0.8660254037844386E+00, - 4 0.7933533402912352E+00, 0.7071067811865475E+00, - 5 0.6087614290087206E+00, 0.5000000000000000E+00, - 6 0.3826834323650898E+00, 0.2588190451025208E+00, - 7 0.1305261922200516E+00/ -C -C LIST OF MAJOR VARIABLES -C ---------------------- -C FVAL - VALUE OF THE FUNCTION F AT THE POINTS -C COS(K*PI/24), K = 0, ..., 24 -C CHEB12 - CHEBYSHEV SERIES EXPANSION COEFFICIENTS, -C FOR THE FUNCTION F, OF DEGREE 12 -C CHEB24 - CHEBYSHEV SERIES EXPANSION COEFFICIENTS, -C FOR THE FUNCTION F, OF DEGREE 24 -C RES12 - APPROXIMATION TO THE INTEGRAL CORRESPONDING -C TO THE USE OF CHEB12 -C RES24 - APPROXIMATION TO THE INTEGRAL CORRESPONDING -C TO THE USE OF CHEB24 -C QWGTC - EXTERNAL FUNCTION SUBPROGRAM DEFINING -C THE WEIGHT FUNCTION -C HLGTH - HALF-LENGTH OF THE INTERVAL -C CENTR - MID POINT OF THE INTERVAL -C -C -C CHECK THE POSITION OF C. -C -C***FIRST EXECUTABLE STATEMENT QC25C - CC = (0.2E+01*C-B-A)/(B-A) - IF(ABS(CC).LT.0.11E+01) GO TO 10 -C -C APPLY THE 15-POINT GAUSS-KRONROD SCHEME. -C - KRUL = KRUL-1 - CALL QK15W(F,QWGTC,C,P2,P3,P4,KP,A,B,RESULT,ABSERR, - 1 RESABS,RESASC) - NEVAL = 15 - IF (RESASC.EQ.ABSERR) KRUL = KRUL+1 - GO TO 50 -C -C USE THE GENERALIZED CLENSHAW-CURTIS METHOD. -C - 10 HLGTH = 0.5E+00*(B-A) - CENTR = 0.5E+00*(B+A) - NEVAL = 25 - FVAL(1) = 0.5E+00*F(HLGTH+CENTR) - FVAL(13) = F(CENTR) - FVAL(25) = 0.5E+00*F(CENTR-HLGTH) - DO 20 I=2,12 - U = HLGTH*X(I-1) - ISYM = 26-I - FVAL(I) = F(U+CENTR) - FVAL(ISYM) = F(CENTR-U) - 20 CONTINUE -C -C COMPUTE THE CHEBYSHEV SERIES EXPANSION. -C - CALL QCHEB(X,FVAL,CHEB12,CHEB24) -C -C THE MODIFIED CHEBYSHEV MOMENTS ARE COMPUTED -C BY FORWARD RECURSION, USING AMOM0 AND AMOM1 -C AS STARTING VALUES. -C - AMOM0 = LOG(ABS((0.1E+01-CC)/(0.1E+01+CC))) - AMOM1 = 0.2E+01+CC*AMOM0 - RES12 = CHEB12(1)*AMOM0+CHEB12(2)*AMOM1 - RES24 = CHEB24(1)*AMOM0+CHEB24(2)*AMOM1 - DO 30 K=3,13 - AMOM2 = 0.2E+01*CC*AMOM1-AMOM0 - AK22 = (K-2)*(K-2) - IF((K/2)*2.EQ.K) AMOM2 = AMOM2-0.4E+01/(AK22-0.1E+01) - RES12 = RES12+CHEB12(K)*AMOM2 - RES24 = RES24+CHEB24(K)*AMOM2 - AMOM0 = AMOM1 - AMOM1 = AMOM2 - 30 CONTINUE - DO 40 K=14,25 - AMOM2 = 0.2E+01*CC*AMOM1-AMOM0 - AK22 = (K-2)*(K-2) - IF((K/2)*2.EQ.K) AMOM2 = AMOM2-0.4E+01/ - 1 (AK22-0.1E+01) - RES24 = RES24+CHEB24(K)*AMOM2 - AMOM0 = AMOM1 - AMOM1 = AMOM2 - 40 CONTINUE - RESULT = RES24 - ABSERR = ABS(RES24-RES12) - 50 RETURN - END diff --git a/slatec/qc25f.f b/slatec/qc25f.f deleted file mode 100644 index 8a799bf..0000000 --- a/slatec/qc25f.f +++ /dev/null @@ -1,359 +0,0 @@ -*DECK QC25F - SUBROUTINE QC25F (F, A, B, OMEGA, INTEGR, NRMOM, MAXP1, KSAVE, - + RESULT, ABSERR, NEVAL, RESABS, RESASC, MOMCOM, CHEBMO) -C***BEGIN PROLOGUE QC25F -C***PURPOSE To compute the integral I=Integral of F(X) over (A,B) -C Where W(X) = COS(OMEGA*X) Or (WX)=SIN(OMEGA*X) -C and to compute J=Integral of ABS(F) over (A,B). For small -C value of OMEGA or small intervals (A,B) 15-point GAUSS- -C KRONROD Rule used. Otherwise generalized CLENSHAW-CURTIS us -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A2A2 -C***TYPE SINGLE PRECISION (QC25F-S, DQC25F-D) -C***KEYWORDS CLENSHAW-CURTIS METHOD, GAUSS-KRONROD RULES, -C INTEGRATION RULES FOR FUNCTIONS WITH COS OR SIN FACTOR, -C QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration rules for functions with COS or SIN factor -C Standard fortran subroutine -C Real version -C -C PARAMETERS -C ON ENTRY -C F - Real -C Function subprogram defining the integrand -C function F(X). The actual name for F needs to -C be declared E X T E R N A L in the calling program. -C -C A - Real -C Lower limit of integration -C -C B - Real -C Upper limit of integration -C -C OMEGA - Real -C Parameter in the WEIGHT function -C -C INTEGR - Integer -C Indicates which WEIGHT function is to be used -C INTEGR = 1 W(X) = COS(OMEGA*X) -C INTEGR = 2 W(X) = SIN(OMEGA*X) -C -C NRMOM - Integer -C The length of interval (A,B) is equal to the length -C of the original integration interval divided by -C 2**NRMOM (we suppose that the routine is used in an -C adaptive integration process, otherwise set -C NRMOM = 0). NRMOM must be zero at the first call. -C -C MAXP1 - Integer -C Gives an upper bound on the number of Chebyshev -C moments which can be stored, i.e. for the -C intervals of lengths ABS(BB-AA)*2**(-L), -C L = 0,1,2, ..., MAXP1-2. -C -C KSAVE - Integer -C Key which is one when the moments for the -C current interval have been computed -C -C ON RETURN -C RESULT - Real -C Approximation to the integral I -C -C ABSERR - Real -C Estimate of the modulus of the absolute -C error, which should equal or exceed ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C RESABS - Real -C Approximation to the integral J -C -C RESASC - Real -C Approximation to the integral of ABS(F-I/(B-A)) -C -C ON ENTRY AND RETURN -C MOMCOM - Integer -C For each interval length we need to compute the -C Chebyshev moments. MOMCOM counts the number of -C intervals for which these moments have already been -C computed. If NRMOM.LT.MOMCOM or KSAVE = 1, the -C Chebyshev moments for the interval (A,B) have -C already been computed and stored, otherwise we -C compute them and we increase MOMCOM. -C -C CHEBMO - Real -C Array of dimension at least (MAXP1,25) containing -C the modified Chebyshev moments for the first MOMCOM -C MOMCOM interval lengths -C -C***REFERENCES (NONE) -C***ROUTINES CALLED QCHEB, QK15W, QWGTF, R1MACH, SGTSL -C***REVISION HISTORY (YYMMDD) -C 810101 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE QC25F -C - REAL A,ABSERR,AC,AN,AN2,AS,ASAP,ASS,B,CENTR,CHEBMO, - 1 CHEB12,CHEB24,CONC,CONS,COSPAR,D,QWGTF, - 2 D1,R1MACH,D2,ESTC,ESTS,F,FVAL,HLGTH,OFLOW,OMEGA,PARINT,PAR2, - 3 PAR22,P2,P3,P4,RESABS,RESASC,RESC12,RESC24,RESS12,RESS24, - 4 RESULT,SINPAR,V,X - INTEGER I,IERS,INTEGR,ISYM,J,K,KSAVE,M,MAXP1,MOMCOM,NEVAL, - 1 NOEQU,NOEQ1,NRMOM -C - DIMENSION CHEBMO(MAXP1,25),CHEB12(13),CHEB24(25),D(25),D1(25), - 1 D2(25),FVAL(25),V(28),X(11) -C - EXTERNAL F, QWGTF -C -C THE VECTOR X CONTAINS THE VALUES COS(K*PI/24) -C K = 1, ...,11, TO BE USED FOR THE CHEBYSHEV EXPANSION OF F -C - SAVE X - DATA X(1),X(2),X(3),X(4),X(5),X(6),X(7),X(8),X(9), - 1 X(10),X(11)/ - 2 0.9914448613738104E+00, 0.9659258262890683E+00, - 3 0.9238795325112868E+00, 0.8660254037844386E+00, - 4 0.7933533402912352E+00, 0.7071067811865475E+00, - 5 0.6087614290087206E+00, 0.5000000000000000E+00, - 6 0.3826834323650898E+00, 0.2588190451025208E+00, - 7 0.1305261922200516E+00/ -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C CENTR - MID POINT OF THE INTEGRATION INTERVAL -C HLGTH - HALF-LENGTH OF THE INTEGRATION INTERVAL -C FVAL - VALUE OF THE FUNCTION F AT THE POINTS -C (B-A)*0.5*COS(K*PI/12) + (B+A)*0.5, -C K = 0, ..., 24 -C CHEB12 - COEFFICIENTS OF THE CHEBYSHEV SERIES EXPANSION -C OF DEGREE 12, FOR THE FUNCTION F, IN THE -C INTERVAL (A,B) -C CHEB24 - COEFFICIENTS OF THE CHEBYSHEV SERIES EXPANSION -C OF DEGREE 24, FOR THE FUNCTION F, IN THE -C INTERVAL (A,B) -C RESC12 - APPROXIMATION TO THE INTEGRAL OF -C COS(0.5*(B-A)*OMEGA*X)*F(0.5*(B-A)*X+0.5*(B+A)) -C OVER (-1,+1), USING THE CHEBYSHEV SERIES -C EXPANSION OF DEGREE 12 -C RESC24 - APPROXIMATION TO THE SAME INTEGRAL, USING THE -C CHEBYSHEV SERIES EXPANSION OF DEGREE 24 -C RESS12 - THE ANALOGUE OF RESC12 FOR THE SINE -C RESS24 - THE ANALOGUE OF RESC24 FOR THE SINE -C -C -C MACHINE DEPENDENT CONSTANT -C -------------------------- -C -C OFLOW IS THE LARGEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT QC25F - OFLOW = R1MACH(2) -C - CENTR = 0.5E+00*(B+A) - HLGTH = 0.5E+00*(B-A) - PARINT = OMEGA*HLGTH -C -C COMPUTE THE INTEGRAL USING THE 15-POINT GAUSS-KRONROD -C FORMULA IF THE VALUE OF THE PARAMETER IN THE INTEGRAND -C IS SMALL. -C - IF(ABS(PARINT).GT.0.2E+01) GO TO 10 - CALL QK15W(F,QWGTF,OMEGA,P2,P3,P4,INTEGR,A,B,RESULT, - 1 ABSERR,RESABS,RESASC) - NEVAL = 15 - GO TO 170 -C -C COMPUTE THE INTEGRAL USING THE GENERALIZED CLENSHAW- -C CURTIS METHOD. -C - 10 CONC = HLGTH*COS(CENTR*OMEGA) - CONS = HLGTH*SIN(CENTR*OMEGA) - RESASC = OFLOW - NEVAL = 25 -C -C CHECK WHETHER THE CHEBYSHEV MOMENTS FOR THIS INTERVAL -C HAVE ALREADY BEEN COMPUTED. -C - IF(NRMOM.LT.MOMCOM.OR.KSAVE.EQ.1) GO TO 120 -C -C COMPUTE A NEW SET OF CHEBYSHEV MOMENTS. -C - M = MOMCOM+1 - PAR2 = PARINT*PARINT - PAR22 = PAR2+0.2E+01 - SINPAR = SIN(PARINT) - COSPAR = COS(PARINT) -C -C COMPUTE THE CHEBYSHEV MOMENTS WITH RESPECT TO COSINE. -C - V(1) = 0.2E+01*SINPAR/PARINT - V(2) = (0.8E+01*COSPAR+(PAR2+PAR2-0.8E+01)*SINPAR/ - 1 PARINT)/PAR2 - V(3) = (0.32E+02*(PAR2-0.12E+02)*COSPAR+(0.2E+01* - 1 ((PAR2-0.80E+02)*PAR2+0.192E+03)*SINPAR)/ - 2 PARINT)/(PAR2*PAR2) - AC = 0.8E+01*COSPAR - AS = 0.24E+02*PARINT*SINPAR - IF(ABS(PARINT).GT.0.24E+02) GO TO 30 -C -C COMPUTE THE CHEBYSHEV MOMENTS AS THE -C SOLUTIONS OF A BOUNDARY VALUE PROBLEM WITH 1 -C INITIAL VALUE (V(3)) AND 1 END VALUE (COMPUTED -C USING AN ASYMPTOTIC FORMULA). -C - NOEQU = 25 - NOEQ1 = NOEQU-1 - AN = 0.6E+01 - DO 20 K = 1,NOEQ1 - AN2 = AN*AN - D(K) = -0.2E+01*(AN2-0.4E+01)*(PAR22-AN2-AN2) - D2(K) = (AN-0.1E+01)*(AN-0.2E+01)*PAR2 - D1(K+1) = (AN+0.3E+01)*(AN+0.4E+01)*PAR2 - V(K+3) = AS-(AN2-0.4E+01)*AC - AN = AN+0.2E+01 - 20 CONTINUE - AN2 = AN*AN - D(NOEQU) = -0.2E+01*(AN2-0.4E+01)*(PAR22-AN2-AN2) - V(NOEQU+3) = AS-(AN2-0.4E+01)*AC - V(4) = V(4)-0.56E+02*PAR2*V(3) - ASS = PARINT*SINPAR - ASAP = (((((0.210E+03*PAR2-0.1E+01)*COSPAR-(0.105E+03*PAR2 - 1 -0.63E+02)*ASS)/AN2-(0.1E+01-0.15E+02*PAR2)*COSPAR - 2 +0.15E+02*ASS)/AN2-COSPAR+0.3E+01*ASS)/AN2-COSPAR)/AN2 - V(NOEQU+3) = V(NOEQU+3)-0.2E+01*ASAP*PAR2*(AN-0.1E+01)* - 1 (AN-0.2E+01) -C -C SOLVE THE TRIDIAGONAL SYSTEM BY MEANS OF GAUSSIAN -C ELIMINATION WITH PARTIAL PIVOTING. -C - CALL SGTSL(NOEQU,D1,D,D2,V(4),IERS) - GO TO 50 -C -C COMPUTE THE CHEBYSHEV MOMENTS BY MEANS OF FORWARD -C RECURSION. -C - 30 AN = 0.4E+01 - DO 40 I = 4,13 - AN2 = AN*AN - V(I) = ((AN2-0.4E+01)*(0.2E+01*(PAR22-AN2-AN2)*V(I-1)-AC) - 1 +AS-PAR2*(AN+0.1E+01)*(AN+0.2E+01)*V(I-2))/ - 2 (PAR2*(AN-0.1E+01)*(AN-0.2E+01)) - AN = AN+0.2E+01 - 40 CONTINUE - 50 DO 60 J = 1,13 - CHEBMO(M,2*J-1) = V(J) - 60 CONTINUE -C -C COMPUTE THE CHEBYSHEV MOMENTS WITH RESPECT TO SINE. -C - V(1) = 0.2E+01*(SINPAR-PARINT*COSPAR)/PAR2 - V(2) = (0.18E+02-0.48E+02/PAR2)*SINPAR/PAR2 - 1 +(-0.2E+01+0.48E+02/PAR2)*COSPAR/PARINT - AC = -0.24E+02*PARINT*COSPAR - AS = -0.8E+01*SINPAR - IF(ABS(PARINT).GT.0.24E+02) GO TO 80 -C -C COMPUTE THE CHEBYSHEV MOMENTS AS THE -C SOLUTIONS OF A BOUNDARY VALUE PROBLEM WITH 1 -C INITIAL VALUE (V(2)) AND 1 END VALUE (COMPUTED -C USING AN ASYMPTOTIC FORMULA). -C - AN = 0.5E+01 - DO 70 K = 1,NOEQ1 - AN2 = AN*AN - D(K) = -0.2E+01*(AN2-0.4E+01)*(PAR22-AN2-AN2) - D2(K) = (AN-0.1E+01)*(AN-0.2E+01)*PAR2 - D1(K+1) = (AN+0.3E+01)*(AN+0.4E+01)*PAR2 - V(K+2) = AC+(AN2-0.4E+01)*AS - AN = AN+0.2E+01 - 70 CONTINUE - AN2 = AN*AN - D(NOEQU) = -0.2E+01*(AN2-0.4E+01)*(PAR22-AN2-AN2) - V(NOEQU+2) = AC+(AN2-0.4E+01)*AS - V(3) = V(3)-0.42E+02*PAR2*V(2) - ASS = PARINT*COSPAR - ASAP = (((((0.105E+03*PAR2-0.63E+02)*ASS+(0.210E+03*PAR2 - 1 -0.1E+01)*SINPAR)/AN2+(0.15E+02*PAR2-0.1E+01)*SINPAR- - 2 0.15E+02*ASS)/AN2-0.3E+01*ASS-SINPAR)/AN2-SINPAR)/AN2 - V(NOEQU+2) = V(NOEQU+2)-0.2E+01*ASAP*PAR2*(AN-0.1E+01) - 1 *(AN-0.2E+01) -C -C SOLVE THE TRIDIAGONAL SYSTEM BY MEANS OF GAUSSIAN -C ELIMINATION WITH PARTIAL PIVOTING. -C - CALL SGTSL(NOEQU,D1,D,D2,V(3),IERS) - GO TO 100 -C -C COMPUTE THE CHEBYSHEV MOMENTS BY MEANS OF -C FORWARD RECURSION. -C - 80 AN = 0.3E+01 - DO 90 I = 3,12 - AN2 = AN*AN - V(I) = ((AN2-0.4E+01)*(0.2E+01*(PAR22-AN2-AN2)*V(I-1)+AS) - 1 +AC-PAR2*(AN+0.1E+01)*(AN+0.2E+01)*V(I-2)) - 2 /(PAR2*(AN-0.1E+01)*(AN-0.2E+01)) - AN = AN+0.2E+01 - 90 CONTINUE - 100 DO 110 J = 1,12 - CHEBMO(M,2*J) = V(J) - 110 CONTINUE - 120 IF (NRMOM.LT.MOMCOM) M = NRMOM+1 - IF (MOMCOM.LT.MAXP1-1.AND.NRMOM.GE.MOMCOM) MOMCOM = MOMCOM+1 -C -C COMPUTE THE COEFFICIENTS OF THE CHEBYSHEV EXPANSIONS -C OF DEGREES 12 AND 24 OF THE FUNCTION F. -C - FVAL(1) = 0.5E+00*F(CENTR+HLGTH) - FVAL(13) = F(CENTR) - FVAL(25) = 0.5E+00*F(CENTR-HLGTH) - DO 130 I = 2,12 - ISYM = 26-I - FVAL(I) = F(HLGTH*X(I-1)+CENTR) - FVAL(ISYM) = F(CENTR-HLGTH*X(I-1)) - 130 CONTINUE - CALL QCHEB(X,FVAL,CHEB12,CHEB24) -C -C COMPUTE THE INTEGRAL AND ERROR ESTIMATES. -C - RESC12 = CHEB12(13)*CHEBMO(M,13) - RESS12 = 0.0E+00 - K = 11 - DO 140 J = 1,6 - RESC12 = RESC12+CHEB12(K)*CHEBMO(M,K) - RESS12 = RESS12+CHEB12(K+1)*CHEBMO(M,K+1) - K = K-2 - 140 CONTINUE - RESC24 = CHEB24(25)*CHEBMO(M,25) - RESS24 = 0.0E+00 - RESABS = ABS(CHEB24(25)) - K = 23 - DO 150 J = 1,12 - RESC24 = RESC24+CHEB24(K)*CHEBMO(M,K) - RESS24 = RESS24+CHEB24(K+1)*CHEBMO(M,K+1) - RESABS = ABS(CHEB24(K))+ABS(CHEB24(K+1)) - K = K-2 - 150 CONTINUE - ESTC = ABS(RESC24-RESC12) - ESTS = ABS(RESS24-RESS12) - RESABS = RESABS*ABS(HLGTH) - IF(INTEGR.EQ.2) GO TO 160 - RESULT = CONC*RESC24-CONS*RESS24 - ABSERR = ABS(CONC*ESTC)+ABS(CONS*ESTS) - GO TO 170 - 160 RESULT = CONC*RESS24+CONS*RESC24 - ABSERR = ABS(CONC*ESTS)+ABS(CONS*ESTC) - 170 RETURN - END diff --git a/slatec/qc25s.f b/slatec/qc25s.f deleted file mode 100644 index d3dd49d..0000000 --- a/slatec/qc25s.f +++ /dev/null @@ -1,346 +0,0 @@ -*DECK QC25S - SUBROUTINE QC25S (F, A, B, BL, BR, ALFA, BETA, RI, RJ, RG, RH, - + RESULT, ABSERR, RESASC, INTEGR, NEV) -C***BEGIN PROLOGUE QC25S -C***PURPOSE To compute I = Integral of F*W over (BL,BR), with error -C estimate, where the weight function W has a singular -C behaviour of ALGEBRAICO-LOGARITHMIC type at the points -C A and/or B. (BL,BR) is a part of (A,B). -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A2A2 -C***TYPE SINGLE PRECISION (QC25S-S, DQC25S-D) -C***KEYWORDS 25-POINT CLENSHAW-CURTIS INTEGRATION, QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration rules for integrands having ALGEBRAICO-LOGARITHMIC -C end point singularities -C Standard fortran subroutine -C Real version -C -C PARAMETERS -C F - Real -C Function subprogram defining the integrand -C F(X). The actual name for F needs to be declared -C E X T E R N A L in the driver program. -C -C A - Real -C Left end point of the original interval -C -C B - Real -C Right end point of the original interval, B.GT.A -C -C BL - Real -C Lower limit of integration, BL.GE.A -C -C BR - Real -C Upper limit of integration, BR.LE.B -C -C ALFA - Real -C PARAMETER IN THE WEIGHT FUNCTION -C -C BETA - Real -C Parameter in the weight function -C -C RI,RJ,RG,RH - Real -C Modified CHEBYSHEV moments for the application -C of the generalized CLENSHAW-CURTIS -C method (computed in subroutine DQMOMO) -C -C RESULT - Real -C Approximation to the integral -C RESULT is computed by using a generalized -C CLENSHAW-CURTIS method if B1 = A or BR = B. -C in all other cases the 15-POINT KRONROD -C RULE is applied, obtained by optimal addition of -C Abscissae to the 7-POINT GAUSS RULE. -C -C ABSERR - Real -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C RESASC - Real -C Approximation to the integral of ABS(F*W-I/(B-A)) -C -C INTEGR - Integer -C Which determines the weight function -C = 1 W(X) = (X-A)**ALFA*(B-X)**BETA -C = 2 W(X) = (X-A)**ALFA*(B-X)**BETA*LOG(X-A) -C = 3 W(X) = (X-A)**ALFA*(B-X)**BETA*LOG(B-X) -C = 4 W(X) = (X-A)**ALFA*(B-X)**BETA*LOG(X-A)* -C LOG(B-X) -C -C NEV - Integer -C Number of integrand evaluations -C -C***REFERENCES (NONE) -C***ROUTINES CALLED QCHEB, QK15W, QWGTS -C***REVISION HISTORY (YYMMDD) -C 810101 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***END PROLOGUE QC25S -C - REAL A,ABSERR,ALFA,B,BETA,BL,BR,CENTR,CHEB12,CHEB24, - 1 DC,F,FACTOR,FIX,FVAL,HLGTH,RESABS,RESASC, - 2 RESULT,RES12,RES24,RG,RH,RI,RJ,U,QWGTS,X - INTEGER I,INTEGR,ISYM,NEV -C - DIMENSION CHEB12(13),CHEB24(25),FVAL(25),RG(25),RH(25),RI(25), - 1 RJ(25),X(11) -C - EXTERNAL F, QWGTS -C -C THE VECTOR X CONTAINS THE VALUES COS(K*PI/24) -C K = 1, ..., 11, TO BE USED FOR THE COMPUTATION OF THE -C CHEBYSHEV SERIES EXPANSION OF F. -C - SAVE X - DATA X(1),X(2),X(3),X(4),X(5),X(6),X(7),X(8),X(9),X(10), - 1 X(11)/ - 2 0.9914448613738104E+00, 0.9659258262890683E+00, - 3 0.9238795325112868E+00, 0.8660254037844386E+00, - 4 0.7933533402912352E+00, 0.7071067811865475E+00, - 5 0.6087614290087206E+00, 0.5000000000000000E+00, - 6 0.3826834323650898E+00, 0.2588190451025208E+00, - 7 0.1305261922200516E+00/ -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C FVAL - VALUE OF THE FUNCTION F AT THE POINTS -C (BR-BL)*0.5*COS(K*PI/24)+(BR+BL)*0.5 -C K = 0, ..., 24 -C CHEB12 - COEFFICIENTS OF THE CHEBYSHEV SERIES EXPANSION -C OF DEGREE 12, FOR THE FUNCTION F, IN THE -C INTERVAL (BL,BR) -C CHEB24 - COEFFICIENTS OF THE CHEBYSHEV SERIES EXPANSION -C OF DEGREE 24, FOR THE FUNCTION F, IN THE -C INTERVAL (BL,BR) -C RES12 - APPROXIMATION TO THE INTEGRAL OBTAINED FROM CHEB12 -C RES24 - APPROXIMATION TO THE INTEGRAL OBTAINED FROM CHEB24 -C QWGTS - EXTERNAL FUNCTION SUBPROGRAM DEFINING -C THE FOUR POSSIBLE WEIGHT FUNCTIONS -C HLGTH - HALF-LENGTH OF THE INTERVAL (BL,BR) -C CENTR - MID POINT OF THE INTERVAL (BL,BR) -C -C***FIRST EXECUTABLE STATEMENT QC25S - NEV = 25 - IF(BL.EQ.A.AND.(ALFA.NE.0.0E+00.OR.INTEGR.EQ.2.OR.INTEGR.EQ.4)) - 1 GO TO 10 - IF(BR.EQ.B.AND.(BETA.NE.0.0E+00.OR.INTEGR.EQ.3.OR.INTEGR.EQ.4)) - 1 GO TO 140 -C -C IF A.GT.BL AND B.LT.BR, APPLY THE 15-POINT GAUSS-KRONROD -C SCHEME. -C -C - CALL QK15W(F,QWGTS,A,B,ALFA,BETA,INTEGR,BL,BR, - 1 RESULT,ABSERR,RESABS,RESASC) - NEV = 15 - GO TO 270 -C -C THIS PART OF THE PROGRAM IS EXECUTED ONLY IF A = BL. -C ---------------------------------------------------- -C -C COMPUTE THE CHEBYSHEV SERIES EXPANSION OF THE -C FOLLOWING FUNCTION -C F1 = (0.5*(B+B-BR-A)-0.5*(BR-A)*X)**BETA -C *F(0.5*(BR-A)*X+0.5*(BR+A)) -C - 10 HLGTH = 0.5E+00*(BR-BL) - CENTR = 0.5E+00*(BR+BL) - FIX = B-CENTR - FVAL(1) = 0.5E+00*F(HLGTH+CENTR)*(FIX-HLGTH)**BETA - FVAL(13) = F(CENTR)*(FIX**BETA) - FVAL(25) = 0.5E+00*F(CENTR-HLGTH)*(FIX+HLGTH)**BETA - DO 20 I=2,12 - U = HLGTH*X(I-1) - ISYM = 26-I - FVAL(I) = F(U+CENTR)*(FIX-U)**BETA - FVAL(ISYM) = F(CENTR-U)*(FIX+U)**BETA - 20 CONTINUE - FACTOR = HLGTH**(ALFA+0.1E+01) - RESULT = 0.0E+00 - ABSERR = 0.0E+00 - RES12 = 0.0E+00 - RES24 = 0.0E+00 - IF(INTEGR.GT.2) GO TO 70 - CALL QCHEB(X,FVAL,CHEB12,CHEB24) -C -C INTEGR = 1 (OR 2) -C - DO 30 I=1,13 - RES12 = RES12+CHEB12(I)*RI(I) - RES24 = RES24+CHEB24(I)*RI(I) - 30 CONTINUE - DO 40 I=14,25 - RES24 = RES24+CHEB24(I)*RI(I) - 40 CONTINUE - IF(INTEGR.EQ.1) GO TO 130 -C -C INTEGR = 2 -C - DC = LOG(BR-BL) - RESULT = RES24*DC - ABSERR = ABS((RES24-RES12)*DC) - RES12 = 0.0E+00 - RES24 = 0.0E+00 - DO 50 I=1,13 - RES12 = RES12+CHEB12(I)*RG(I) - RES24 = RES12+CHEB24(I)*RG(I) - 50 CONTINUE - DO 60 I=14,25 - RES24 = RES24+CHEB24(I)*RG(I) - 60 CONTINUE - GO TO 130 -C -C COMPUTE THE CHEBYSHEV SERIES EXPANSION OF THE -C FOLLOWING FUNCTION -C F4 = F1*LOG(0.5*(B+B-BR-A)-0.5*(BR-A)*X) -C - 70 FVAL(1) = FVAL(1)*LOG(FIX-HLGTH) - FVAL(13) = FVAL(13)*LOG(FIX) - FVAL(25) = FVAL(25)*LOG(FIX+HLGTH) - DO 80 I=2,12 - U = HLGTH*X(I-1) - ISYM = 26-I - FVAL(I) = FVAL(I)*LOG(FIX-U) - FVAL(ISYM) = FVAL(ISYM)*LOG(FIX+U) - 80 CONTINUE - CALL QCHEB(X,FVAL,CHEB12,CHEB24) -C -C INTEGR = 3 (OR 4) -C - DO 90 I=1,13 - RES12 = RES12+CHEB12(I)*RI(I) - RES24 = RES24+CHEB24(I)*RI(I) - 90 CONTINUE - DO 100 I=14,25 - RES24 = RES24+CHEB24(I)*RI(I) - 100 CONTINUE - IF(INTEGR.EQ.3) GO TO 130 -C -C INTEGR = 4 -C - DC = LOG(BR-BL) - RESULT = RES24*DC - ABSERR = ABS((RES24-RES12)*DC) - RES12 = 0.0E+00 - RES24 = 0.0E+00 - DO 110 I=1,13 - RES12 = RES12+CHEB12(I)*RG(I) - RES24 = RES24+CHEB24(I)*RG(I) - 110 CONTINUE - DO 120 I=14,25 - RES24 = RES24+CHEB24(I)*RG(I) - 120 CONTINUE - 130 RESULT = (RESULT+RES24)*FACTOR - ABSERR = (ABSERR+ABS(RES24-RES12))*FACTOR - GO TO 270 -C -C THIS PART OF THE PROGRAM IS EXECUTED ONLY IF B = BR. -C ---------------------------------------------------- -C -C COMPUTE THE CHEBYSHEV SERIES EXPANSION OF THE -C FOLLOWING FUNCTION -C F2 = (0.5*(B+BL-A-A)+0.5*(B-BL)*X)**ALFA -C *F(0.5*(B-BL)*X+0.5*(B+BL)) -C - 140 HLGTH = 0.5E+00*(BR-BL) - CENTR = 0.5E+00*(BR+BL) - FIX = CENTR-A - FVAL(1) = 0.5E+00*F(HLGTH+CENTR)*(FIX+HLGTH)**ALFA - FVAL(13) = F(CENTR)*(FIX**ALFA) - FVAL(25) = 0.5E+00*F(CENTR-HLGTH)*(FIX-HLGTH)**ALFA - DO 150 I=2,12 - U = HLGTH*X(I-1) - ISYM = 26-I - FVAL(I) = F(U+CENTR)*(FIX+U)**ALFA - FVAL(ISYM) = F(CENTR-U)*(FIX-U)**ALFA - 150 CONTINUE - FACTOR = HLGTH**(BETA+0.1E+01) - RESULT = 0.0E+00 - ABSERR = 0.0E+00 - RES12 = 0.0E+00 - RES24 = 0.0E+00 - IF(INTEGR.EQ.2.OR.INTEGR.EQ.4) GO TO 200 -C -C INTEGR = 1 (OR 3) -C - CALL QCHEB(X,FVAL,CHEB12,CHEB24) - DO 160 I=1,13 - RES12 = RES12+CHEB12(I)*RJ(I) - RES24 = RES24+CHEB24(I)*RJ(I) - 160 CONTINUE - DO 170 I=14,25 - RES24 = RES24+CHEB24(I)*RJ(I) - 170 CONTINUE - IF(INTEGR.EQ.1) GO TO 260 -C -C INTEGR = 3 -C - DC = LOG(BR-BL) - RESULT = RES24*DC - ABSERR = ABS((RES24-RES12)*DC) - RES12 = 0.0E+00 - RES24 = 0.0E+00 - DO 180 I=1,13 - RES12 = RES12+CHEB12(I)*RH(I) - RES24 = RES24+CHEB24(I)*RH(I) - 180 CONTINUE - DO 190 I=14,25 - RES24 = RES24+CHEB24(I)*RH(I) - 190 CONTINUE - GO TO 260 -C -C COMPUTE THE CHEBYSHEV SERIES EXPANSION OF THE -C FOLLOWING FUNCTION -C F3 = F2*LOG(0.5*(B-BL)*X+0.5*(B+BL-A-A)) -C - 200 FVAL(1) = FVAL(1)*LOG(FIX+HLGTH) - FVAL(13) = FVAL(13)*LOG(FIX) - FVAL(25) = FVAL(25)*LOG(FIX-HLGTH) - DO 210 I=2,12 - U = HLGTH*X(I-1) - ISYM = 26-I - FVAL(I) = FVAL(I)*LOG(FIX+U) - FVAL(ISYM) = FVAL(ISYM)*LOG(FIX-U) - 210 CONTINUE - CALL QCHEB(X,FVAL,CHEB12,CHEB24) -C -C INTEGR = 2 (OR 4) -C - DO 220 I=1,13 - RES12 = RES12+CHEB12(I)*RJ(I) - RES24 = RES24+CHEB24(I)*RJ(I) - 220 CONTINUE - DO 230 I=14,25 - RES24 = RES24+CHEB24(I)*RJ(I) - 230 CONTINUE - IF(INTEGR.EQ.2) GO TO 260 - DC = LOG(BR-BL) - RESULT = RES24*DC - ABSERR = ABS((RES24-RES12)*DC) - RES12 = 0.0E+00 - RES24 = 0.0E+00 -C -C INTEGR = 4 -C - DO 240 I=1,13 - RES12 = RES12+CHEB12(I)*RH(I) - RES24 = RES24+CHEB24(I)*RH(I) - 240 CONTINUE - DO 250 I=14,25 - RES24 = RES24+CHEB24(I)*RH(I) - 250 CONTINUE - 260 RESULT = (RESULT+RES24)*FACTOR - ABSERR = (ABSERR+ABS(RES24-RES12))*FACTOR - 270 RETURN - END diff --git a/slatec/qcheb.f b/slatec/qcheb.f deleted file mode 100644 index 23ff3a9..0000000 --- a/slatec/qcheb.f +++ /dev/null @@ -1,160 +0,0 @@ -*DECK QCHEB - SUBROUTINE QCHEB (X, FVAL, CHEB12, CHEB24) -C***BEGIN PROLOGUE QCHEB -C***SUBSIDIARY -C***PURPOSE This routine computes the CHEBYSHEV series expansion -C of degrees 12 and 24 of a function using A -C FAST FOURIER TRANSFORM METHOD -C F(X) = SUM(K=1,..,13) (CHEB12(K)*T(K-1,X)), -C F(X) = SUM(K=1,..,25) (CHEB24(K)*T(K-1,X)), -C Where T(K,X) is the CHEBYSHEV POLYNOMIAL OF DEGREE K. -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (QCHEB-S, DQCHEB-D) -C***KEYWORDS CHEBYSHEV SERIES EXPANSION, FAST FOURIER TRANSFORM -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Chebyshev Series Expansion -C Standard Fortran Subroutine -C Real version -C -C PARAMETERS -C ON ENTRY -C X - Real -C Vector of dimension 11 containing the -C Values COS(K*PI/24), K = 1, ..., 11 -C -C FVAL - Real -C Vector of dimension 25 containing the -C function values at the points -C (B+A+(B-A)*COS(K*PI/24))/2, K = 0, ...,24, -C where (A,B) is the approximation interval. -C FVAL(1) and FVAL(25) are divided by two -C (these values are destroyed at output). -C -C ON RETURN -C CHEB12 - Real -C Vector of dimension 13 containing the -C CHEBYSHEV coefficients for degree 12 -C -C CHEB24 - Real -C Vector of dimension 25 containing the -C CHEBYSHEV Coefficients for degree 24 -C -C***SEE ALSO QC25C, QC25F, QC25S -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 810101 DATE WRITTEN -C 830518 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE QCHEB -C - REAL ALAM,ALAM1,ALAM2,CHEB12,CHEB24, - 1 FVAL,PART1,PART2,PART3,V,X - INTEGER I,J -C - DIMENSION CHEB12(13),CHEB24(25),FVAL(25),V(12),X(11) -C -C***FIRST EXECUTABLE STATEMENT QCHEB - DO 10 I=1,12 - J = 26-I - V(I) = FVAL(I)-FVAL(J) - FVAL(I) = FVAL(I)+FVAL(J) - 10 CONTINUE - ALAM1 = V(1)-V(9) - ALAM2 = X(6)*(V(3)-V(7)-V(11)) - CHEB12(4) = ALAM1+ALAM2 - CHEB12(10) = ALAM1-ALAM2 - ALAM1 = V(2)-V(8)-V(10) - ALAM2 = V(4)-V(6)-V(12) - ALAM = X(3)*ALAM1+X(9)*ALAM2 - CHEB24(4) = CHEB12(4)+ALAM - CHEB24(22) = CHEB12(4)-ALAM - ALAM = X(9)*ALAM1-X(3)*ALAM2 - CHEB24(10) = CHEB12(10)+ALAM - CHEB24(16) = CHEB12(10)-ALAM - PART1 = X(4)*V(5) - PART2 = X(8)*V(9) - PART3 = X(6)*V(7) - ALAM1 = V(1)+PART1+PART2 - ALAM2 = X(2)*V(3)+PART3+X(10)*V(11) - CHEB12(2) = ALAM1+ALAM2 - CHEB12(12) = ALAM1-ALAM2 - ALAM = X(1)*V(2)+X(3)*V(4)+X(5)*V(6)+X(7)*V(8) - 1 +X(9)*V(10)+X(11)*V(12) - CHEB24(2) = CHEB12(2)+ALAM - CHEB24(24) = CHEB12(2)-ALAM - ALAM = X(11)*V(2)-X(9)*V(4)+X(7)*V(6)-X(5)*V(8) - 1 +X(3)*V(10)-X(1)*V(12) - CHEB24(12) = CHEB12(12)+ALAM - CHEB24(14) = CHEB12(12)-ALAM - ALAM1 = V(1)-PART1+PART2 - ALAM2 = X(10)*V(3)-PART3+X(2)*V(11) - CHEB12(6) = ALAM1+ALAM2 - CHEB12(8) = ALAM1-ALAM2 - ALAM = X(5)*V(2)-X(9)*V(4)-X(1)*V(6) - 1 -X(11)*V(8)+X(3)*V(10)+X(7)*V(12) - CHEB24(6) = CHEB12(6)+ALAM - CHEB24(20) = CHEB12(6)-ALAM - ALAM = X(7)*V(2)-X(3)*V(4)-X(11)*V(6)+X(1)*V(8) - 1 -X(9)*V(10)-X(5)*V(12) - CHEB24(8) = CHEB12(8)+ALAM - CHEB24(18) = CHEB12(8)-ALAM - DO 20 I=1,6 - J = 14-I - V(I) = FVAL(I)-FVAL(J) - FVAL(I) = FVAL(I)+FVAL(J) - 20 CONTINUE - ALAM1 = V(1)+X(8)*V(5) - ALAM2 = X(4)*V(3) - CHEB12(3) = ALAM1+ALAM2 - CHEB12(11) = ALAM1-ALAM2 - CHEB12(7) = V(1)-V(5) - ALAM = X(2)*V(2)+X(6)*V(4)+X(10)*V(6) - CHEB24(3) = CHEB12(3)+ALAM - CHEB24(23) = CHEB12(3)-ALAM - ALAM = X(6)*(V(2)-V(4)-V(6)) - CHEB24(7) = CHEB12(7)+ALAM - CHEB24(19) = CHEB12(7)-ALAM - ALAM = X(10)*V(2)-X(6)*V(4)+X(2)*V(6) - CHEB24(11) = CHEB12(11)+ALAM - CHEB24(15) = CHEB12(11)-ALAM - DO 30 I=1,3 - J = 8-I - V(I) = FVAL(I)-FVAL(J) - FVAL(I) = FVAL(I)+FVAL(J) - 30 CONTINUE - CHEB12(5) = V(1)+X(8)*V(3) - CHEB12(9) = FVAL(1)-X(8)*FVAL(3) - ALAM = X(4)*V(2) - CHEB24(5) = CHEB12(5)+ALAM - CHEB24(21) = CHEB12(5)-ALAM - ALAM = X(8)*FVAL(2)-FVAL(4) - CHEB24(9) = CHEB12(9)+ALAM - CHEB24(17) = CHEB12(9)-ALAM - CHEB12(1) = FVAL(1)+FVAL(3) - ALAM = FVAL(2)+FVAL(4) - CHEB24(1) = CHEB12(1)+ALAM - CHEB24(25) = CHEB12(1)-ALAM - CHEB12(13) = V(1)-V(3) - CHEB24(13) = CHEB12(13) - ALAM = 0.1E+01/0.6E+01 - DO 40 I=2,12 - CHEB12(I) = CHEB12(I)*ALAM - 40 CONTINUE - ALAM = 0.5E+00*ALAM - CHEB12(1) = CHEB12(1)*ALAM - CHEB12(13) = CHEB12(13)*ALAM - DO 50 I=2,24 - CHEB24(I) = CHEB24(I)*ALAM - 50 CONTINUE - CHEB24(1) = 0.5E+00*ALAM*CHEB24(1) - CHEB24(25) = 0.5E+00*ALAM*CHEB24(25) - RETURN - END diff --git a/slatec/qelg.f b/slatec/qelg.f deleted file mode 100644 index 05cbebb..0000000 --- a/slatec/qelg.f +++ /dev/null @@ -1,196 +0,0 @@ -*DECK QELG - SUBROUTINE QELG (N, EPSTAB, RESULT, ABSERR, RES3LA, NRES) -C***BEGIN PROLOGUE QELG -C***SUBSIDIARY -C***PURPOSE The routine determines the limit of a given sequence of -C approximations, by means of the Epsilon algorithm of -C P. Wynn. An estimate of the absolute error is also given. -C The condensed Epsilon table is computed. Only those -C elements needed for the computation of the next diagonal -C are preserved. -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (QELG-S, DQELG-D) -C***KEYWORDS CONVERGENCE ACCELERATION, EPSILON ALGORITHM, EXTRAPOLATION -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Epsilon algorithm -C Standard fortran subroutine -C Real version -C -C PARAMETERS -C N - Integer -C EPSTAB(N) contains the new element in the -C first column of the epsilon table. -C -C EPSTAB - Real -C Vector of dimension 52 containing the elements -C of the two lower diagonals of the triangular -C epsilon table. The elements are numbered -C starting at the right-hand corner of the -C triangle. -C -C RESULT - Real -C Resulting approximation to the integral -C -C ABSERR - Real -C Estimate of the absolute error computed from -C RESULT and the 3 previous results -C -C RES3LA - Real -C Vector of dimension 3 containing the last 3 -C results -C -C NRES - Integer -C Number of calls to the routine -C (should be zero at first call) -C -C***SEE ALSO QAGIE, QAGOE, QAGPE, QAGSE -C***ROUTINES CALLED R1MACH -C***REVISION HISTORY (YYMMDD) -C 800101 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 900328 Added TYPE section. (WRB) -C***END PROLOGUE QELG -C - REAL ABSERR,DELTA1,DELTA2,DELTA3,R1MACH, - 1 EPMACH,EPSINF,EPSTAB,ERROR,ERR1,ERR2,ERR3,E0,E1,E1ABS,E2,E3, - 2 OFLOW,RES,RESULT,RES3LA,SS,TOL1,TOL2,TOL3 - INTEGER I,IB,IB2,IE,INDX,K1,K2,K3,LIMEXP,N,NEWELM,NRES,NUM - DIMENSION EPSTAB(52),RES3LA(3) -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C E0 - THE 4 ELEMENTS ON WHICH THE -C E1 COMPUTATION OF A NEW ELEMENT IN -C E2 THE EPSILON TABLE IS BASED -C E3 E0 -C E3 E1 NEW -C E2 -C NEWELM - NUMBER OF ELEMENTS TO BE COMPUTED IN THE NEW -C DIAGONAL -C ERROR - ERROR = ABS(E1-E0)+ABS(E2-E1)+ABS(NEW-E2) -C RESULT - THE ELEMENT IN THE NEW DIAGONAL WITH LEAST VALUE -C OF ERROR -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C OFLOW IS THE LARGEST POSITIVE MAGNITUDE. -C LIMEXP IS THE MAXIMUM NUMBER OF ELEMENTS THE EPSILON -C TABLE CAN CONTAIN. IF THIS NUMBER IS REACHED, THE UPPER -C DIAGONAL OF THE EPSILON TABLE IS DELETED. -C -C***FIRST EXECUTABLE STATEMENT QELG - EPMACH = R1MACH(4) - OFLOW = R1MACH(2) - NRES = NRES+1 - ABSERR = OFLOW - RESULT = EPSTAB(N) - IF(N.LT.3) GO TO 100 - LIMEXP = 50 - EPSTAB(N+2) = EPSTAB(N) - NEWELM = (N-1)/2 - EPSTAB(N) = OFLOW - NUM = N - K1 = N - DO 40 I = 1,NEWELM - K2 = K1-1 - K3 = K1-2 - RES = EPSTAB(K1+2) - E0 = EPSTAB(K3) - E1 = EPSTAB(K2) - E2 = RES - E1ABS = ABS(E1) - DELTA2 = E2-E1 - ERR2 = ABS(DELTA2) - TOL2 = MAX(ABS(E2),E1ABS)*EPMACH - DELTA3 = E1-E0 - ERR3 = ABS(DELTA3) - TOL3 = MAX(E1ABS,ABS(E0))*EPMACH - IF(ERR2.GT.TOL2.OR.ERR3.GT.TOL3) GO TO 10 -C -C IF E0, E1 AND E2 ARE EQUAL TO WITHIN MACHINE -C ACCURACY, CONVERGENCE IS ASSUMED. -C RESULT = E2 -C ABSERR = ABS(E1-E0)+ABS(E2-E1) -C - RESULT = RES - ABSERR = ERR2+ERR3 -C ***JUMP OUT OF DO-LOOP - GO TO 100 - 10 E3 = EPSTAB(K1) - EPSTAB(K1) = E1 - DELTA1 = E1-E3 - ERR1 = ABS(DELTA1) - TOL1 = MAX(E1ABS,ABS(E3))*EPMACH -C -C IF TWO ELEMENTS ARE VERY CLOSE TO EACH OTHER, OMIT -C A PART OF THE TABLE BY ADJUSTING THE VALUE OF N -C - IF(ERR1.LE.TOL1.OR.ERR2.LE.TOL2.OR.ERR3.LE.TOL3) GO TO 20 - SS = 0.1E+01/DELTA1+0.1E+01/DELTA2-0.1E+01/DELTA3 - EPSINF = ABS(SS*E1) -C -C TEST TO DETECT IRREGULAR BEHAVIOUR IN THE TABLE, AND -C EVENTUALLY OMIT A PART OF THE TABLE ADJUSTING THE VALUE -C OF N. -C - IF(EPSINF.GT.0.1E-03) GO TO 30 - 20 N = I+I-1 -C ***JUMP OUT OF DO-LOOP - GO TO 50 -C -C COMPUTE A NEW ELEMENT AND EVENTUALLY ADJUST -C THE VALUE OF RESULT. -C - 30 RES = E1+0.1E+01/SS - EPSTAB(K1) = RES - K1 = K1-2 - ERROR = ERR2+ABS(RES-E2)+ERR3 - IF(ERROR.GT.ABSERR) GO TO 40 - ABSERR = ERROR - RESULT = RES - 40 CONTINUE -C -C SHIFT THE TABLE. -C - 50 IF(N.EQ.LIMEXP) N = 2*(LIMEXP/2)-1 - IB = 1 - IF((NUM/2)*2.EQ.NUM) IB = 2 - IE = NEWELM+1 - DO 60 I=1,IE - IB2 = IB+2 - EPSTAB(IB) = EPSTAB(IB2) - IB = IB2 - 60 CONTINUE - IF(NUM.EQ.N) GO TO 80 - INDX = NUM-N+1 - DO 70 I = 1,N - EPSTAB(I)= EPSTAB(INDX) - INDX = INDX+1 - 70 CONTINUE - 80 IF(NRES.GE.4) GO TO 90 - RES3LA(NRES) = RESULT - ABSERR = OFLOW - GO TO 100 -C -C COMPUTE ERROR ESTIMATE -C - 90 ABSERR = ABS(RESULT-RES3LA(3))+ABS(RESULT-RES3LA(2)) - 1 +ABS(RESULT-RES3LA(1)) - RES3LA(1) = RES3LA(2) - RES3LA(2) = RES3LA(3) - RES3LA(3) = RESULT - 100 ABSERR = MAX(ABSERR,0.5E+01*EPMACH*ABS(RESULT)) - RETURN - END diff --git a/slatec/qform.f b/slatec/qform.f deleted file mode 100644 index 764221f..0000000 --- a/slatec/qform.f +++ /dev/null @@ -1,102 +0,0 @@ -*DECK QFORM - SUBROUTINE QFORM (M, N, Q, LDQ, WA) -C***BEGIN PROLOGUE QFORM -C***SUBSIDIARY -C***PURPOSE Subsidiary to SNSQ and SNSQE -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (QFORM-S, DQFORM-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This subroutine proceeds from the computed QR factorization of -C an M by N matrix A to accumulate the M by M orthogonal matrix -C Q from its factored form. -C -C The subroutine statement is -C -C SUBROUTINE QFORM(M,N,Q,LDQ,WA) -C -C where -C -C M is a positive integer input variable set to the number -C of rows of A and the order of Q. -C -C N is a positive integer input variable set to the number -C of columns of A. -C -C Q is an M by M array. On input the full lower trapezoid in -C the first min(M,N) columns of Q contains the factored form. -C On output Q has been accumulated into a square matrix. -C -C LDQ is a positive integer input variable not less than M -C which specifies the leading dimension of the array Q. -C -C WA is a work array of length M. -C -C***SEE ALSO SNSQ, SNSQE -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE QFORM - INTEGER M,N,LDQ - REAL Q(LDQ,*),WA(*) - INTEGER I,J,JM1,K,L,MINMN,NP1 - REAL ONE,SUM,TEMP,ZERO - SAVE ONE, ZERO - DATA ONE,ZERO /1.0E0,0.0E0/ -C***FIRST EXECUTABLE STATEMENT QFORM - MINMN = MIN(M,N) - IF (MINMN .LT. 2) GO TO 30 - DO 20 J = 2, MINMN - JM1 = J - 1 - DO 10 I = 1, JM1 - Q(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE -C -C INITIALIZE REMAINING COLUMNS TO THOSE OF THE IDENTITY MATRIX. -C - NP1 = N + 1 - IF (M .LT. NP1) GO TO 60 - DO 50 J = NP1, M - DO 40 I = 1, M - Q(I,J) = ZERO - 40 CONTINUE - Q(J,J) = ONE - 50 CONTINUE - 60 CONTINUE -C -C ACCUMULATE Q FROM ITS FACTORED FORM. -C - DO 120 L = 1, MINMN - K = MINMN - L + 1 - DO 70 I = K, M - WA(I) = Q(I,K) - Q(I,K) = ZERO - 70 CONTINUE - Q(K,K) = ONE - IF (WA(K) .EQ. ZERO) GO TO 110 - DO 100 J = K, M - SUM = ZERO - DO 80 I = K, M - SUM = SUM + Q(I,J)*WA(I) - 80 CONTINUE - TEMP = SUM/WA(K) - DO 90 I = K, M - Q(I,J) = Q(I,J) - TEMP*WA(I) - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE QFORM. -C - END diff --git a/slatec/qk15.f b/slatec/qk15.f deleted file mode 100644 index f056288..0000000 --- a/slatec/qk15.f +++ /dev/null @@ -1,172 +0,0 @@ -*DECK QK15 - SUBROUTINE QK15 (F, A, B, RESULT, ABSERR, RESABS, RESASC) -C***BEGIN PROLOGUE QK15 -C***PURPOSE To compute I = Integral of F over (A,B), with error -C estimate -C J = integral of ABS(F) over (A,B) -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A1A2 -C***TYPE SINGLE PRECISION (QK15-S, DQK15-D) -C***KEYWORDS 15-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration rules -C Standard fortran subroutine -C Real version -C -C PARAMETERS -C ON ENTRY -C F - Real -C Function subprogram defining the integrand -C FUNCTION F(X). The actual name for F needs to be -C Declared E X T E R N A L in the calling program. -C -C A - Real -C Lower limit of integration -C -C B - Real -C Upper limit of integration -C -C ON RETURN -C RESULT - Real -C Approximation to the integral I -C Result is computed by applying the 15-POINT -C KRONROD RULE (RESK) obtained by optimal addition -C of abscissae to the 7-POINT GAUSS RULE(RESG). -C -C ABSERR - Real -C Estimate of the modulus of the absolute error, -C which should not exceed ABS(I-RESULT) -C -C RESABS - Real -C Approximation to the integral J -C -C RESASC - Real -C Approximation to the integral of ABS(F-I/(B-A)) -C over (A,B) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH -C***REVISION HISTORY (YYMMDD) -C 800101 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***END PROLOGUE QK15 -C - REAL A,ABSC,ABSERR,B,CENTR,DHLGTH,EPMACH,F,FC,FSUM,FVAL1,FVAL2, - 1 FV1,FV2,HLGTH,RESABS,RESASC,RESG,RESK,RESKH,RESULT,R1MACH,UFLOW, - 2 WG,WGK,XGK - INTEGER J,JTW,JTWM1 - EXTERNAL F -C - DIMENSION FV1(7),FV2(7),WG(4),WGK(8),XGK(8) -C -C THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). -C BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR -C CORRESPONDING WEIGHTS ARE GIVEN. -C -C XGK - ABSCISSAE OF THE 15-POINT KRONROD RULE -C XGK(2), XGK(4), ... ABSCISSAE OF THE 7-POINT -C GAUSS RULE -C XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY -C ADDED TO THE 7-POINT GAUSS RULE -C -C WGK - WEIGHTS OF THE 15-POINT KRONROD RULE -C -C WG - WEIGHTS OF THE 7-POINT GAUSS RULE -C - SAVE XGK, WGK, WG - DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7),XGK(8)/ - 1 0.9914553711208126E+00, 0.9491079123427585E+00, - 2 0.8648644233597691E+00, 0.7415311855993944E+00, - 3 0.5860872354676911E+00, 0.4058451513773972E+00, - 4 0.2077849550078985E+00, 0.0E+00 / - DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7),WGK(8)/ - 1 0.2293532201052922E-01, 0.6309209262997855E-01, - 2 0.1047900103222502E+00, 0.1406532597155259E+00, - 3 0.1690047266392679E+00, 0.1903505780647854E+00, - 4 0.2044329400752989E+00, 0.2094821410847278E+00/ - DATA WG(1),WG(2),WG(3),WG(4)/ - 1 0.1294849661688697E+00, 0.2797053914892767E+00, - 2 0.3818300505051189E+00, 0.4179591836734694E+00/ -C -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C CENTR - MID POINT OF THE INTERVAL -C HLGTH - HALF-LENGTH OF THE INTERVAL -C ABSC - ABSCISSA -C FVAL* - FUNCTION VALUE -C RESG - RESULT OF THE 7-POINT GAUSS FORMULA -C RESK - RESULT OF THE 15-POINT KRONROD FORMULA -C RESKH - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B), -C I.E. TO I/(B-A) -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT QK15 - EPMACH = R1MACH(4) - UFLOW = R1MACH(1) -C - CENTR = 0.5E+00*(A+B) - HLGTH = 0.5E+00*(B-A) - DHLGTH = ABS(HLGTH) -C -C COMPUTE THE 15-POINT KRONROD APPROXIMATION TO -C THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. -C - FC = F(CENTR) - RESG = FC*WG(4) - RESK = FC*WGK(8) - RESABS = ABS(RESK) - DO 10 J=1,3 - JTW = J*2 - ABSC = HLGTH*XGK(JTW) - FVAL1 = F(CENTR-ABSC) - FVAL2 = F(CENTR+ABSC) - FV1(JTW) = FVAL1 - FV2(JTW) = FVAL2 - FSUM = FVAL1+FVAL2 - RESG = RESG+WG(J)*FSUM - RESK = RESK+WGK(JTW)*FSUM - RESABS = RESABS+WGK(JTW)*(ABS(FVAL1)+ABS(FVAL2)) - 10 CONTINUE - DO 15 J = 1,4 - JTWM1 = J*2-1 - ABSC = HLGTH*XGK(JTWM1) - FVAL1 = F(CENTR-ABSC) - FVAL2 = F(CENTR+ABSC) - FV1(JTWM1) = FVAL1 - FV2(JTWM1) = FVAL2 - FSUM = FVAL1+FVAL2 - RESK = RESK+WGK(JTWM1)*FSUM - RESABS = RESABS+WGK(JTWM1)*(ABS(FVAL1)+ABS(FVAL2)) - 15 CONTINUE - RESKH = RESK*0.5E+00 - RESASC = WGK(8)*ABS(FC-RESKH) - DO 20 J=1,7 - RESASC = RESASC+WGK(J)*(ABS(FV1(J)-RESKH)+ABS(FV2(J)-RESKH)) - 20 CONTINUE - RESULT = RESK*HLGTH - RESABS = RESABS*DHLGTH - RESASC = RESASC*DHLGTH - ABSERR = ABS((RESK-RESG)*HLGTH) - IF(RESASC.NE.0.0E+00.AND.ABSERR.NE.0.0E+00) - 1 ABSERR = RESASC*MIN(0.1E+01, - 2 (0.2E+03*ABSERR/RESASC)**1.5E+00) - IF(RESABS.GT.UFLOW/(0.5E+02*EPMACH)) ABSERR = MAX - 1 ((EPMACH*0.5E+02)*RESABS,ABSERR) - RETURN - END diff --git a/slatec/qk15i.f b/slatec/qk15i.f deleted file mode 100644 index bb454bb..0000000 --- a/slatec/qk15i.f +++ /dev/null @@ -1,200 +0,0 @@ -*DECK QK15I - SUBROUTINE QK15I (F, BOUN, INF, A, B, RESULT, ABSERR, RESABS, - + RESASC) -C***BEGIN PROLOGUE QK15I -C***PURPOSE The original (infinite integration range is mapped -C onto the interval (0,1) and (A,B) is a part of (0,1). -C it is the purpose to compute -C I = Integral of transformed integrand over (A,B), -C J = Integral of ABS(Transformed Integrand) over (A,B). -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A3A2, H2A4A2 -C***TYPE SINGLE PRECISION (QK15I-S, DQK15I-D) -C***KEYWORDS 15-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration Rule -C Standard Fortran subroutine -C Real version -C -C PARAMETERS -C ON ENTRY -C F - Real -C Function subprogram defining the integrand -C FUNCTION F(X). The actual name for F needs to be -C Declared E X T E R N A L in the calling program. -C -C BOUN - Real -C Finite bound of original integration -C Range (SET TO ZERO IF INF = +2) -C -C INF - Integer -C If INF = -1, the original interval is -C (-INFINITY,BOUND), -C If INF = +1, the original interval is -C (BOUND,+INFINITY), -C If INF = +2, the original interval is -C (-INFINITY,+INFINITY) AND -C The integral is computed as the sum of two -C integrals, one over (-INFINITY,0) and one over -C (0,+INFINITY). -C -C A - Real -C Lower limit for integration over subrange -C of (0,1) -C -C B - Real -C Upper limit for integration over subrange -C of (0,1) -C -C ON RETURN -C RESULT - Real -C Approximation to the integral I -C Result is computed by applying the 15-POINT -C KRONROD RULE(RESK) obtained by optimal addition -C of abscissae to the 7-POINT GAUSS RULE(RESG). -C -C ABSERR - Real -C Estimate of the modulus of the absolute error, -C WHICH SHOULD EQUAL or EXCEED ABS(I-RESULT) -C -C RESABS - Real -C Approximation to the integral J -C -C RESASC - Real -C Approximation to the integral of -C ABS((TRANSFORMED INTEGRAND)-I/(B-A)) over (A,B) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH -C***REVISION HISTORY (YYMMDD) -C 800101 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***END PROLOGUE QK15I -C - REAL A,ABSC,ABSC1,ABSC2,ABSERR,B,BOUN,CENTR, - 1 DINF,R1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1, - 2 FV2,HLGTH,RESABS,RESASC,RESG,RESK,RESKH,RESULT,TABSC1,TABSC2, - 3 UFLOW,WG,WGK,XGK - INTEGER INF,J - EXTERNAL F -C - DIMENSION FV1(7),FV2(7),XGK(8),WGK(8),WG(8) -C -C THE ABSCISSAE AND WEIGHTS ARE SUPPLIED FOR THE INTERVAL -C (-1,1). BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND -C THEIR CORRESPONDING WEIGHTS ARE GIVEN. -C -C XGK - ABSCISSAE OF THE 15-POINT KRONROD RULE -C XGK(2), XGK(4), ... ABSCISSAE OF THE 7-POINT -C GAUSS RULE -C XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY -C ADDED TO THE 7-POINT GAUSS RULE -C -C WGK - WEIGHTS OF THE 15-POINT KRONROD RULE -C -C WG - WEIGHTS OF THE 7-POINT GAUSS RULE, CORRESPONDING -C TO THE ABSCISSAE XGK(2), XGK(4), ... -C WG(1), WG(3), ... ARE SET TO ZERO. -C - SAVE XGK, WGK, WG - DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7), - 1 XGK(8)/ - 2 0.9914553711208126E+00, 0.9491079123427585E+00, - 3 0.8648644233597691E+00, 0.7415311855993944E+00, - 4 0.5860872354676911E+00, 0.4058451513773972E+00, - 5 0.2077849550078985E+00, 0.0000000000000000E+00/ -C - DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7), - 1 WGK(8)/ - 2 0.2293532201052922E-01, 0.6309209262997855E-01, - 3 0.1047900103222502E+00, 0.1406532597155259E+00, - 4 0.1690047266392679E+00, 0.1903505780647854E+00, - 5 0.2044329400752989E+00, 0.2094821410847278E+00/ -C - DATA WG(1),WG(2),WG(3),WG(4),WG(5),WG(6),WG(7),WG(8)/ - 1 0.0000000000000000E+00, 0.1294849661688697E+00, - 2 0.0000000000000000E+00, 0.2797053914892767E+00, - 3 0.0000000000000000E+00, 0.3818300505051189E+00, - 4 0.0000000000000000E+00, 0.4179591836734694E+00/ -C -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C CENTR - MID POINT OF THE INTERVAL -C HLGTH - HALF-LENGTH OF THE INTERVAL -C ABSC* - ABSCISSA -C TABSC* - TRANSFORMED ABSCISSA -C FVAL* - FUNCTION VALUE -C RESG - RESULT OF THE 7-POINT GAUSS FORMULA -C RESK - RESULT OF THE 15-POINT KRONROD FORMULA -C RESKH - APPROXIMATION TO THE MEAN VALUE OF THE TRANSFORMED -C INTEGRAND OVER (A,B), I.E. TO I/(B-A) -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT QK15I - EPMACH = R1MACH(4) - UFLOW = R1MACH(1) - DINF = MIN(1,INF) -C - CENTR = 0.5E+00*(A+B) - HLGTH = 0.5E+00*(B-A) - TABSC1 = BOUN+DINF*(0.1E+01-CENTR)/CENTR - FVAL1 = F(TABSC1) - IF(INF.EQ.2) FVAL1 = FVAL1+F(-TABSC1) - FC = (FVAL1/CENTR)/CENTR -C -C COMPUTE THE 15-POINT KRONROD APPROXIMATION TO -C THE INTEGRAL, AND ESTIMATE THE ERROR. -C - RESG = WG(8)*FC - RESK = WGK(8)*FC - RESABS = ABS(RESK) - DO 10 J=1,7 - ABSC = HLGTH*XGK(J) - ABSC1 = CENTR-ABSC - ABSC2 = CENTR+ABSC - TABSC1 = BOUN+DINF*(0.1E+01-ABSC1)/ABSC1 - TABSC2 = BOUN+DINF*(0.1E+01-ABSC2)/ABSC2 - FVAL1 = F(TABSC1) - FVAL2 = F(TABSC2) - IF(INF.EQ.2) FVAL1 = FVAL1+F(-TABSC1) - IF(INF.EQ.2) FVAL2 = FVAL2+F(-TABSC2) - FVAL1 = (FVAL1/ABSC1)/ABSC1 - FVAL2 = (FVAL2/ABSC2)/ABSC2 - FV1(J) = FVAL1 - FV2(J) = FVAL2 - FSUM = FVAL1+FVAL2 - RESG = RESG+WG(J)*FSUM - RESK = RESK+WGK(J)*FSUM - RESABS = RESABS+WGK(J)*(ABS(FVAL1)+ABS(FVAL2)) - 10 CONTINUE - RESKH = RESK*0.5E+00 - RESASC = WGK(8)*ABS(FC-RESKH) - DO 20 J=1,7 - RESASC = RESASC+WGK(J)*(ABS(FV1(J)-RESKH)+ABS(FV2(J)-RESKH)) - 20 CONTINUE - RESULT = RESK*HLGTH - RESASC = RESASC*HLGTH - RESABS = RESABS*HLGTH - ABSERR = ABS((RESK-RESG)*HLGTH) - IF(RESASC.NE.0.0E+00.AND.ABSERR.NE.0.E0) ABSERR = RESASC* - 1 MIN(0.1E+01,(0.2E+03*ABSERR/RESASC)**1.5E+00) - IF(RESABS.GT.UFLOW/(0.5E+02*EPMACH)) ABSERR = MAX - 1 ((EPMACH*0.5E+02)*RESABS,ABSERR) - RETURN - END diff --git a/slatec/qk15w.f b/slatec/qk15w.f deleted file mode 100644 index 66e2048..0000000 --- a/slatec/qk15w.f +++ /dev/null @@ -1,193 +0,0 @@ -*DECK QK15W - SUBROUTINE QK15W (F, W, P1, P2, P3, P4, KP, A, B, RESULT, ABSERR, - + RESABS, RESASC) -C***BEGIN PROLOGUE QK15W -C***PURPOSE To compute I = Integral of F*W over (A,B), with error -C estimate -C J = Integral of ABS(F*W) over (A,B) -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A2A2 -C***TYPE SINGLE PRECISION (QK15W-S, DQK15W-D) -C***KEYWORDS 15-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration rules -C Standard fortran subroutine -C Real version -C -C PARAMETERS -C ON ENTRY -C F - Real -C Function subprogram defining the integrand -C function F(X). The actual name for F needs to be -C declared E X T E R N A L in the driver program. -C -C W - Real -C Function subprogram defining the integrand -C WEIGHT function W(X). The actual name for W -C needs to be declared E X T E R N A L in the -C calling program. -C -C P1, P2, P3, P4 - Real -C Parameters in the WEIGHT function -C -C KP - Integer -C Key for indicating the type of WEIGHT function -C -C A - Real -C Lower limit of integration -C -C B - Real -C Upper limit of integration -C -C ON RETURN -C RESULT - Real -C Approximation to the integral I -C RESULT is computed by applying the 15-point -C Kronrod rule (RESK) obtained by optimal addition -C of abscissae to the 7-point Gauss rule (RESG). -C -C ABSERR - Real -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C RESABS - Real -C Approximation to the integral of ABS(F) -C -C RESASC - Real -C Approximation to the integral of ABS(F-I/(B-A)) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH -C***REVISION HISTORY (YYMMDD) -C 810101 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***END PROLOGUE QK15W -C - REAL A,ABSC,ABSC1,ABSC2,ABSERR,B,CENTR,DHLGTH, - 1 R1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2, - 2 HLGTH,P1,P2,P3,P4,RESABS,RESASC,RESG,RESK,RESKH,RESULT,UFLOW, - 3 W,WG,WGK,XGK - INTEGER J,JTW,JTWM1,KP - EXTERNAL F, W -C - DIMENSION FV1(7),FV2(7),XGK(8),WGK(8),WG(4) -C -C THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). -C BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR -C CORRESPONDING WEIGHTS ARE GIVEN. -C -C XGK - ABSCISSAE OF THE 15-POINT GAUSS-KRONROD RULE -C XGK(2), XGK(4), ... ABSCISSAE OF THE 7-POINT -C GAUSS RULE -C XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY -C ADDED TO THE 7-POINT GAUSS RULE -C -C WGK - WEIGHTS OF THE 15-POINT GAUSS-KRONROD RULE -C -C WG - WEIGHTS OF THE 7-POINT GAUSS RULE -C - SAVE XGK, WGK, WG - DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7), - 1 XGK(8)/ - 2 0.9914553711208126E+00, 0.9491079123427585E+00, - 3 0.8648644233597691E+00, 0.7415311855993944E+00, - 4 0.5860872354676911E+00, 0.4058451513773972E+00, - 5 0.2077849550078985E+00, 0.0000000000000000E+00/ -C - DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7), - 1 WGK(8)/ - 2 0.2293532201052922E-01, 0.6309209262997855E-01, - 3 0.1047900103222502E+00, 0.1406532597155259E+00, - 4 0.1690047266392679E+00, 0.1903505780647854E+00, - 5 0.2044329400752989E+00, 0.2094821410847278E+00/ -C - DATA WG(1),WG(2),WG(3),WG(4)/ - 1 0.1294849661688697E+00, 0.2797053914892767E+00, - 2 0.3818300505051889E+00, 0.4179591836734694E+00/ -C -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C CENTR - MID POINT OF THE INTERVAL -C HLGTH - HALF-LENGTH OF THE INTERVAL -C ABSC* - ABSCISSA -C FVAL* - FUNCTION VALUE -C RESG - RESULT OF THE 7-POINT GAUSS FORMULA -C RESK - RESULT OF THE 15-POINT KRONROD FORMULA -C RESKH - APPROXIMATION TO THE MEAN VALUE OF F*W OVER (A,B), -C I.E. TO I/(B-A) -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT QK15W - EPMACH = R1MACH(4) - UFLOW = R1MACH(1) -C - CENTR = 0.5E+00*(A+B) - HLGTH = 0.5E+00*(B-A) - DHLGTH = ABS(HLGTH) -C -C COMPUTE THE 15-POINT KRONROD APPROXIMATION TO THE -C INTEGRAL, AND ESTIMATE THE ERROR. -C - FC = F(CENTR)*W(CENTR,P1,P2,P3,P4,KP) - RESG = WG(4)*FC - RESK = WGK(8)*FC - RESABS = ABS(RESK) - DO 10 J=1,3 - JTW = J*2 - ABSC = HLGTH*XGK(JTW) - ABSC1 = CENTR-ABSC - ABSC2 = CENTR+ABSC - FVAL1 = F(ABSC1)*W(ABSC1,P1,P2,P3,P4,KP) - FVAL2 = F(ABSC2)*W(ABSC2,P1,P2,P3,P4,KP) - FV1(JTW) = FVAL1 - FV2(JTW) = FVAL2 - FSUM = FVAL1+FVAL2 - RESG = RESG+WG(J)*FSUM - RESK = RESK+WGK(JTW)*FSUM - RESABS = RESABS+WGK(JTW)*(ABS(FVAL1)+ABS(FVAL2)) - 10 CONTINUE - DO 15 J=1,4 - JTWM1 = J*2-1 - ABSC = HLGTH*XGK(JTWM1) - ABSC1 = CENTR-ABSC - ABSC2 = CENTR+ABSC - FVAL1 = F(ABSC1)*W(ABSC1,P1,P2,P3,P4,KP) - FVAL2 = F(ABSC2)*W(ABSC2,P1,P2,P3,P4,KP) - FV1(JTWM1) = FVAL1 - FV2(JTWM1) = FVAL2 - FSUM = FVAL1+FVAL2 - RESK = RESK+WGK(JTWM1)*FSUM - RESABS = RESABS+WGK(JTWM1)*(ABS(FVAL1)+ABS(FVAL2)) - 15 CONTINUE - RESKH = RESK*0.5E+00 - RESASC = WGK(8)*ABS(FC-RESKH) - DO 20 J=1,7 - RESASC = RESASC+WGK(J)*(ABS(FV1(J)-RESKH)+ABS(FV2(J)-RESKH)) - 20 CONTINUE - RESULT = RESK*HLGTH - RESABS = RESABS*DHLGTH - RESASC = RESASC*DHLGTH - ABSERR = ABS((RESK-RESG)*HLGTH) - IF(RESASC.NE.0.0E+00.AND.ABSERR.NE.0.0E+00) - 1 ABSERR = RESASC*MIN(0.1E+01, - 2 (0.2E+03*ABSERR/RESASC)**1.5E+00) - IF(RESABS.GT.UFLOW/(0.5E+02*EPMACH)) ABSERR = MAX((EPMACH* - 1 0.5E+02)*RESABS,ABSERR) - RETURN - END diff --git a/slatec/qk21.f b/slatec/qk21.f deleted file mode 100644 index f6a9326..0000000 --- a/slatec/qk21.f +++ /dev/null @@ -1,182 +0,0 @@ -*DECK QK21 - SUBROUTINE QK21 (F, A, B, RESULT, ABSERR, RESABS, RESASC) -C***BEGIN PROLOGUE QK21 -C***PURPOSE To compute I = Integral of F over (A,B), with error -C estimate -C J = Integral of ABS(F) over (A,B) -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A1A2 -C***TYPE SINGLE PRECISION (QK21-S, DQK21-D) -C***KEYWORDS 21-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration rules -C Standard fortran subroutine -C Real version -C -C PARAMETERS -C ON ENTRY -C F - Real -C Function subprogram defining the integrand -C FUNCTION F(X). The actual name for F needs to be -C Declared E X T E R N A L in the driver program. -C -C A - Real -C Lower limit of integration -C -C B - Real -C Upper limit of integration -C -C ON RETURN -C RESULT - Real -C Approximation to the integral I -C RESULT is computed by applying the 21-POINT -C KRONROD RULE (RESK) obtained by optimal addition -C of abscissae to the 10-POINT GAUSS RULE (RESG). -C -C ABSERR - Real -C Estimate of the modulus of the absolute error, -C which should not exceed ABS(I-RESULT) -C -C RESABS - Real -C Approximation to the integral J -C -C RESASC - Real -C Approximation to the integral of ABS(F-I/(B-A)) -C over (A,B) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH -C***REVISION HISTORY (YYMMDD) -C 800101 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***END PROLOGUE QK21 -C - REAL A,ABSC,ABSERR,B,CENTR,DHLGTH,EPMACH,F,FC,FSUM,FVAL1,FVAL2, - 1 FV1,FV2,HLGTH,RESABS,RESG,RESK,RESKH,RESULT,R1MACH,UFLOW,WG,WGK, - 2 XGK - INTEGER J,JTW,JTWM1 - EXTERNAL F -C - DIMENSION FV1(10),FV2(10),WG(5),WGK(11),XGK(11) -C -C THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). -C BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR -C CORRESPONDING WEIGHTS ARE GIVEN. -C -C XGK - ABSCISSAE OF THE 21-POINT KRONROD RULE -C XGK(2), XGK(4), ... ABSCISSAE OF THE 10-POINT -C GAUSS RULE -C XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY -C ADDED TO THE 10-POINT GAUSS RULE -C -C WGK - WEIGHTS OF THE 21-POINT KRONROD RULE -C -C WG - WEIGHTS OF THE 10-POINT GAUSS RULE -C - SAVE XGK, WGK, WG - DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7), - 1 XGK(8),XGK(9),XGK(10),XGK(11)/ - 2 0.9956571630258081E+00, 0.9739065285171717E+00, - 3 0.9301574913557082E+00, 0.8650633666889845E+00, - 4 0.7808177265864169E+00, 0.6794095682990244E+00, - 5 0.5627571346686047E+00, 0.4333953941292472E+00, - 6 0.2943928627014602E+00, 0.1488743389816312E+00, - 7 0.0000000000000000E+00/ -C - DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7), - 1 WGK(8),WGK(9),WGK(10),WGK(11)/ - 2 0.1169463886737187E-01, 0.3255816230796473E-01, - 3 0.5475589657435200E-01, 0.7503967481091995E-01, - 4 0.9312545458369761E-01, 0.1093871588022976E+00, - 5 0.1234919762620659E+00, 0.1347092173114733E+00, - 6 0.1427759385770601E+00, 0.1477391049013385E+00, - 7 0.1494455540029169E+00/ -C - DATA WG(1),WG(2),WG(3),WG(4),WG(5)/ - 1 0.6667134430868814E-01, 0.1494513491505806E+00, - 2 0.2190863625159820E+00, 0.2692667193099964E+00, - 3 0.2955242247147529E+00/ -C -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C CENTR - MID POINT OF THE INTERVAL -C HLGTH - HALF-LENGTH OF THE INTERVAL -C ABSC - ABSCISSA -C FVAL* - FUNCTION VALUE -C RESG - RESULT OF THE 10-POINT GAUSS FORMULA -C RESK - RESULT OF THE 21-POINT KRONROD FORMULA -C RESKH - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B), -C I.E. TO I/(B-A) -C -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT QK21 - EPMACH = R1MACH(4) - UFLOW = R1MACH(1) -C - CENTR = 0.5E+00*(A+B) - HLGTH = 0.5E+00*(B-A) - DHLGTH = ABS(HLGTH) -C -C COMPUTE THE 21-POINT KRONROD APPROXIMATION TO -C THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. -C - RESG = 0.0E+00 - FC = F(CENTR) - RESK = WGK(11)*FC - RESABS = ABS(RESK) - DO 10 J=1,5 - JTW = 2*J - ABSC = HLGTH*XGK(JTW) - FVAL1 = F(CENTR-ABSC) - FVAL2 = F(CENTR+ABSC) - FV1(JTW) = FVAL1 - FV2(JTW) = FVAL2 - FSUM = FVAL1+FVAL2 - RESG = RESG+WG(J)*FSUM - RESK = RESK+WGK(JTW)*FSUM - RESABS = RESABS+WGK(JTW)*(ABS(FVAL1)+ABS(FVAL2)) - 10 CONTINUE - DO 15 J = 1,5 - JTWM1 = 2*J-1 - ABSC = HLGTH*XGK(JTWM1) - FVAL1 = F(CENTR-ABSC) - FVAL2 = F(CENTR+ABSC) - FV1(JTWM1) = FVAL1 - FV2(JTWM1) = FVAL2 - FSUM = FVAL1+FVAL2 - RESK = RESK+WGK(JTWM1)*FSUM - RESABS = RESABS+WGK(JTWM1)*(ABS(FVAL1)+ABS(FVAL2)) - 15 CONTINUE - RESKH = RESK*0.5E+00 - RESASC = WGK(11)*ABS(FC-RESKH) - DO 20 J=1,10 - RESASC = RESASC+WGK(J)*(ABS(FV1(J)-RESKH)+ABS(FV2(J)-RESKH)) - 20 CONTINUE - RESULT = RESK*HLGTH - RESABS = RESABS*DHLGTH - RESASC = RESASC*DHLGTH - ABSERR = ABS((RESK-RESG)*HLGTH) - IF(RESASC.NE.0.0E+00.AND.ABSERR.NE.0.0E+00) - 1 ABSERR = RESASC*MIN(0.1E+01, - 2 (0.2E+03*ABSERR/RESASC)**1.5E+00) - IF(RESABS.GT.UFLOW/(0.5E+02*EPMACH)) ABSERR = MAX - 1 ((EPMACH*0.5E+02)*RESABS,ABSERR) - RETURN - END diff --git a/slatec/qk31.f b/slatec/qk31.f deleted file mode 100644 index 8048e43..0000000 --- a/slatec/qk31.f +++ /dev/null @@ -1,184 +0,0 @@ -*DECK QK31 - SUBROUTINE QK31 (F, A, B, RESULT, ABSERR, RESABS, RESASC) -C***BEGIN PROLOGUE QK31 -C***PURPOSE To compute I = Integral of F over (A,B) with error -C estimate -C J = Integral of ABS(F) over (A,B) -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A1A2 -C***TYPE SINGLE PRECISION (QK31-S, DQK31-D) -C***KEYWORDS 31-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration rules -C Standard fortran subroutine -C Real version -C -C PARAMETERS -C ON ENTRY -C F - Real -C Function subprogram defining the integrand -C FUNCTION F(X). The actual name for F needs to be -C Declared E X T E R N A L in the calling program. -C -C A - Real -C Lower limit of integration -C -C B - Real -C Upper limit of integration -C -C ON RETURN -C RESULT - Real -C Approximation to the integral I -C RESULT is computed by applying the 31-POINT -C GAUSS-KRONROD RULE (RESK), obtained by optimal -C addition of abscissae to the 15-POINT GAUSS -C RULE (RESG). -C -C ABSERR - Real -C Estimate of the modulus of the modulus, -C which should not exceed ABS(I-RESULT) -C -C RESABS - Real -C Approximation to the integral J -C -C RESASC - Real -C Approximation to the integral of ABS(F-I/(B-A)) -C over (A,B) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH -C***REVISION HISTORY (YYMMDD) -C 800101 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***END PROLOGUE QK31 - REAL A,ABSC,ABSERR,B,CENTR,DHLGTH,EPMACH,F,FC,FSUM,FVAL1,FVAL2, - 1 FV1,FV2,HLGTH,RESABS,RESASC,RESG,RESK,RESKH,RESULT,R1MACH,UFLOW, - 2 WG,WGK,XGK - INTEGER J,JTW,JTWM1 - EXTERNAL F -C - DIMENSION FV1(15),FV2(15),XGK(16),WGK(16),WG(8) -C -C THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). -C BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR -C CORRESPONDING WEIGHTS ARE GIVEN. -C -C XGK - ABSCISSAE OF THE 31-POINT KRONROD RULE -C XGK(2), XGK(4), ... ABSCISSAE OF THE 15-POINT -C GAUSS RULE -C XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY -C ADDED TO THE 15-POINT GAUSS RULE -C -C WGK - WEIGHTS OF THE 31-POINT KRONROD RULE -C -C WG - WEIGHTS OF THE 15-POINT GAUSS RULE -C - SAVE XGK, WGK, WG - DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7),XGK(8), - 1 XGK(9),XGK(10),XGK(11),XGK(12),XGK(13),XGK(14),XGK(15), - 2 XGK(16)/ - 3 0.9980022986933971E+00, 0.9879925180204854E+00, - 4 0.9677390756791391E+00, 0.9372733924007059E+00, - 5 0.8972645323440819E+00, 0.8482065834104272E+00, - 6 0.7904185014424659E+00, 0.7244177313601700E+00, - 7 0.6509967412974170E+00, 0.5709721726085388E+00, - 8 0.4850818636402397E+00, 0.3941513470775634E+00, - 9 0.2991800071531688E+00, 0.2011940939974345E+00, - 1 0.1011420669187175E+00, 0.0E+00 / - DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7),WGK(8), - 1 WGK(9),WGK(10),WGK(11),WGK(12),WGK(13),WGK(14),WGK(15), - 2 WGK(16)/ - 3 0.5377479872923349E-02, 0.1500794732931612E-01, - 4 0.2546084732671532E-01, 0.3534636079137585E-01, - 5 0.4458975132476488E-01, 0.5348152469092809E-01, - 6 0.6200956780067064E-01, 0.6985412131872826E-01, - 7 0.7684968075772038E-01, 0.8308050282313302E-01, - 8 0.8856444305621177E-01, 0.9312659817082532E-01, - 9 0.9664272698362368E-01, 0.9917359872179196E-01, - 1 0.1007698455238756E+00, 0.1013300070147915E+00/ - DATA WG(1),WG(2),WG(3),WG(4),WG(5),WG(6),WG(7),WG(8)/ - 1 0.3075324199611727E-01, 0.7036604748810812E-01, - 2 0.1071592204671719E+00, 0.1395706779261543E+00, - 3 0.1662692058169939E+00, 0.1861610000155622E+00, - 4 0.1984314853271116E+00, 0.2025782419255613E+00/ -C -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C CENTR - MID POINT OF THE INTERVAL -C HLGTH - HALF-LENGTH OF THE INTERVAL -C ABSC - ABSCISSA -C FVAL* - FUNCTION VALUE -C RESG - RESULT OF THE 15-POINT GAUSS FORMULA -C RESK - RESULT OF THE 31-POINT KRONROD FORMULA -C RESKH - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B), -C I.E. TO I/(B-A) -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT QK31 - EPMACH = R1MACH(4) - UFLOW = R1MACH(1) -C - CENTR = 0.5E+00*(A+B) - HLGTH = 0.5E+00*(B-A) - DHLGTH = ABS(HLGTH) -C -C COMPUTE THE 31-POINT KRONROD APPROXIMATION TO -C THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. -C - FC = F(CENTR) - RESG = WG(8)*FC - RESK = WGK(16)*FC - RESABS = ABS(RESK) - DO 10 J=1,7 - JTW = J*2 - ABSC = HLGTH*XGK(JTW) - FVAL1 = F(CENTR-ABSC) - FVAL2 = F(CENTR+ABSC) - FV1(JTW) = FVAL1 - FV2(JTW) = FVAL2 - FSUM = FVAL1+FVAL2 - RESG = RESG+WG(J)*FSUM - RESK = RESK+WGK(JTW)*FSUM - RESABS = RESABS+WGK(JTW)*(ABS(FVAL1)+ABS(FVAL2)) - 10 CONTINUE - DO 15 J = 1,8 - JTWM1 = J*2-1 - ABSC = HLGTH*XGK(JTWM1) - FVAL1 = F(CENTR-ABSC) - FVAL2 = F(CENTR+ABSC) - FV1(JTWM1) = FVAL1 - FV2(JTWM1) = FVAL2 - FSUM = FVAL1+FVAL2 - RESK = RESK+WGK(JTWM1)*FSUM - RESABS = RESABS+WGK(JTWM1)*(ABS(FVAL1)+ABS(FVAL2)) - 15 CONTINUE - RESKH = RESK*0.5E+00 - RESASC = WGK(16)*ABS(FC-RESKH) - DO 20 J=1,15 - RESASC = RESASC+WGK(J)*(ABS(FV1(J)-RESKH)+ABS(FV2(J)-RESKH)) - 20 CONTINUE - RESULT = RESK*HLGTH - RESABS = RESABS*DHLGTH - RESASC = RESASC*DHLGTH - ABSERR = ABS((RESK-RESG)*HLGTH) - IF(RESASC.NE.0.0E+00.AND.ABSERR.NE.0.0E+00) - 1 ABSERR = RESASC*MIN(0.1E+01, - 2 (0.2E+03*ABSERR/RESASC)**1.5E+00) - IF(RESABS.GT.UFLOW/(0.5E+02*EPMACH)) ABSERR = MAX - 1 ((EPMACH*0.5E+02)*RESABS,ABSERR) - RETURN - END diff --git a/slatec/qk41.f b/slatec/qk41.f deleted file mode 100644 index 9d16f8c..0000000 --- a/slatec/qk41.f +++ /dev/null @@ -1,195 +0,0 @@ -*DECK QK41 - SUBROUTINE QK41 (F, A, B, RESULT, ABSERR, RESABS, RESASC) -C***BEGIN PROLOGUE QK41 -C***PURPOSE To compute I = Integral of F over (A,B), with error -C estimate -C J = Integral of ABS(F) over (A,B) -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A1A2 -C***TYPE SINGLE PRECISION (QK41-S, DQK41-D) -C***KEYWORDS 41-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration rules -C Standard fortran subroutine -C Real version -C -C PARAMETERS -C ON ENTRY -C F - Real -C Function subprogram defining the integrand -C FUNCTION F(X). The actual name for F needs to be -C declared E X T E R N A L in the calling program. -C -C A - Real -C Lower limit of integration -C -C B - Real -C Upper limit of integration -C -C ON RETURN -C RESULT - Real -C Approximation to the integral I -C RESULT is computed by applying the 41-POINT -C GAUSS-KRONROD RULE (RESK) obtained by optimal -C addition of abscissae to the 20-POINT GAUSS -C RULE (RESG). -C -C ABSERR - Real -C Estimate of the modulus of the absolute error, -C which should not exceed ABS(I-RESULT) -C -C RESABS - Real -C Approximation to the integral J -C -C RESASC - Real -C Approximation to the integral of ABS(F-I/(B-A)) -C over (A,B) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH -C***REVISION HISTORY (YYMMDD) -C 800101 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***END PROLOGUE QK41 -C - REAL A,ABSC,ABSERR,B,CENTR,DHLGTH,EPMACH,F,FC,FSUM,FVAL1,FVAL2, - 1 FV1,FV2,HLGTH,RESABS, - 2 RESASC,RESG,RESK,RESKH,RESULT,R1MACH,UFLOW, - 3 WG,WGK,XGK - INTEGER J,JTW,JTWM1 - EXTERNAL F -C - DIMENSION FV1(20),FV2(20),XGK(21),WGK(21),WG(10) -C -C THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). -C BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR -C CORRESPONDING WEIGHTS ARE GIVEN. -C -C XGK - ABSCISSAE OF THE 41-POINT GAUSS-KRONROD RULE -C XGK(2), XGK(4), ... ABSCISSAE OF THE 20-POINT -C GAUSS RULE -C XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY -C ADDED TO THE 20-POINT GAUSS RULE -C -C WGK - WEIGHTS OF THE 41-POINT GAUSS-KRONROD RULE -C -C WG - WEIGHTS OF THE 20-POINT GAUSS RULE -C - SAVE XGK, WGK, WG - DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7),XGK(8), - 1 XGK(9),XGK(10),XGK(11),XGK(12),XGK(13),XGK(14),XGK(15), - 2 XGK(16),XGK(17),XGK(18),XGK(19),XGK(20),XGK(21)/ - 3 0.9988590315882777E+00, 0.9931285991850949E+00, - 4 0.9815078774502503E+00, 0.9639719272779138E+00, - 5 0.9408226338317548E+00, 0.9122344282513259E+00, - 6 0.8782768112522820E+00, 0.8391169718222188E+00, - 7 0.7950414288375512E+00, 0.7463319064601508E+00, - 8 0.6932376563347514E+00, 0.6360536807265150E+00, - 9 0.5751404468197103E+00, 0.5108670019508271E+00, - 1 0.4435931752387251E+00, 0.3737060887154196E+00, - 2 0.3016278681149130E+00, 0.2277858511416451E+00, - 3 0.1526054652409227E+00, 0.7652652113349733E-01, - 4 0.0E+00 / - DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7),WGK(8), - 1 WGK(9),WGK(10),WGK(11),WGK(12),WGK(13),WGK(14),WGK(15),WGK(16), - 2 WGK(17),WGK(18),WGK(19),WGK(20),WGK(21)/ - 3 0.3073583718520532E-02, 0.8600269855642942E-02, - 4 0.1462616925697125E-01, 0.2038837346126652E-01, - 5 0.2588213360495116E-01, 0.3128730677703280E-01, - 6 0.3660016975820080E-01, 0.4166887332797369E-01, - 7 0.4643482186749767E-01, 0.5094457392372869E-01, - 8 0.5519510534828599E-01, 0.5911140088063957E-01, - 9 0.6265323755478117E-01, 0.6583459713361842E-01, - 1 0.6864867292852162E-01, 0.7105442355344407E-01, - 2 0.7303069033278667E-01, 0.7458287540049919E-01, - 3 0.7570449768455667E-01, 0.7637786767208074E-01, - 4 0.7660071191799966E-01/ - DATA WG(1),WG(2),WG(3),WG(4),WG(5),WG(6),WG(7),WG(8),WG(9),WG(10)/ - 1 0.1761400713915212E-01, 0.4060142980038694E-01, - 2 0.6267204833410906E-01, 0.8327674157670475E-01, - 3 0.1019301198172404E+00, 0.1181945319615184E+00, - 4 0.1316886384491766E+00, 0.1420961093183821E+00, - 5 0.1491729864726037E+00, 0.1527533871307259E+00/ -C -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C CENTR - MID POINT OF THE INTERVAL -C HLGTH - HALF-LENGTH OF THE INTERVAL -C ABSC - ABSCISSA -C FVAL* - FUNCTION VALUE -C RESG - RESULT OF THE 20-POINT GAUSS FORMULA -C RESK - RESULT OF THE 41-POINT KRONROD FORMULA -C RESKH - APPROXIMATION TO MEAN VALUE OF F OVER (A,B), I.E. -C TO I/(B-A) -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT QK41 - EPMACH = R1MACH(4) - UFLOW = R1MACH(1) -C - CENTR = 0.5E+00*(A+B) - HLGTH = 0.5E+00*(B-A) - DHLGTH = ABS(HLGTH) -C -C COMPUTE THE 41-POINT GAUSS-KRONROD APPROXIMATION TO -C THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. -C - RESG = 0.0E+00 - FC = F(CENTR) - RESK = WGK(21)*FC - RESABS = ABS(RESK) - DO 10 J=1,10 - JTW = J*2 - ABSC = HLGTH*XGK(JTW) - FVAL1 = F(CENTR-ABSC) - FVAL2 = F(CENTR+ABSC) - FV1(JTW) = FVAL1 - FV2(JTW) = FVAL2 - FSUM = FVAL1+FVAL2 - RESG = RESG+WG(J)*FSUM - RESK = RESK+WGK(JTW)*FSUM - RESABS = RESABS+WGK(JTW)*(ABS(FVAL1)+ABS(FVAL2)) - 10 CONTINUE - DO 15 J = 1,10 - JTWM1 = J*2-1 - ABSC = HLGTH*XGK(JTWM1) - FVAL1 = F(CENTR-ABSC) - FVAL2 = F(CENTR+ABSC) - FV1(JTWM1) = FVAL1 - FV2(JTWM1) = FVAL2 - FSUM = FVAL1+FVAL2 - RESK = RESK+WGK(JTWM1)*FSUM - RESABS = RESABS+WGK(JTWM1)*(ABS(FVAL1)+ABS(FVAL2)) - 15 CONTINUE - RESKH = RESK*0.5E+00 - RESASC = WGK(21)*ABS(FC-RESKH) - DO 20 J=1,20 - RESASC = RESASC+WGK(J)*(ABS(FV1(J)-RESKH)+ABS(FV2(J)-RESKH)) - 20 CONTINUE - RESULT = RESK*HLGTH - RESABS = RESABS*DHLGTH - RESASC = RESASC*DHLGTH - ABSERR = ABS((RESK-RESG)*HLGTH) - IF(RESASC.NE.0.0E+00.AND.ABSERR.NE.0.E+00) - 1 ABSERR = RESASC*MIN(0.1E+01, - 2 (0.2E+03*ABSERR/RESASC)**1.5E+00) - IF(RESABS.GT.UFLOW/(0.5E+02*EPMACH)) ABSERR = MAX - 1 ((EPMACH*0.5E+02)*RESABS,ABSERR) - RETURN - END diff --git a/slatec/qk51.f b/slatec/qk51.f deleted file mode 100644 index b2303da..0000000 --- a/slatec/qk51.f +++ /dev/null @@ -1,202 +0,0 @@ -*DECK QK51 - SUBROUTINE QK51 (F, A, B, RESULT, ABSERR, RESABS, RESASC) -C***BEGIN PROLOGUE QK51 -C***PURPOSE To compute I = Integral of F over (A,B) with error -C estimate -C J = Integral of ABS(F) over (A,B) -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A1A2 -C***TYPE SINGLE PRECISION (QK51-S, DQK51-D) -C***KEYWORDS 51-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration rules -C Standard fortran subroutine -C Real version -C -C PARAMETERS -C ON ENTRY -C F - Real -C Function subroutine defining the integrand -C function F(X). The actual name for F needs to be -C declared E X T E R N A L in the calling program. -C -C A - Real -C Lower limit of integration -C -C B - Real -C Upper limit of integration -C -C ON RETURN -C RESULT - Real -C Approximation to the integral I -C RESULT is computed by applying the 51-point -C Kronrod rule (RESK) obtained by optimal addition -C of abscissae to the 25-point Gauss rule (RESG). -C -C ABSERR - Real -C Estimate of the modulus of the absolute error, -C which should not exceed ABS(I-RESULT) -C -C RESABS - Real -C Approximation to the integral J -C -C RESASC - Real -C Approximation to the integral of ABS(F-I/(B-A)) -C over (A,B) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH -C***REVISION HISTORY (YYMMDD) -C 800101 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***END PROLOGUE QK51 -C - REAL A,ABSC,ABSERR,B,CENTR,DHLGTH,EPMACH,F,FC,FSUM,FVAL1,FVAL2, - 1 FV1,FV2,HLGTH,RESABS,RESASC,RESG,RESK,RESKH,RESULT,R1MACH,UFLOW, - 2 WG,WGK,XGK - INTEGER J,JTW,JTWM1 - EXTERNAL F -C - DIMENSION FV1(25),FV2(25),XGK(26),WGK(26),WG(13) -C -C THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). -C BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR -C CORRESPONDING WEIGHTS ARE GIVEN. -C -C XGK - ABSCISSAE OF THE 51-POINT KRONROD RULE -C XGK(2), XGK(4), ... ABSCISSAE OF THE 25-POINT -C GAUSS RULE -C XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY -C ADDED TO THE 25-POINT GAUSS RULE -C -C WGK - WEIGHTS OF THE 51-POINT KRONROD RULE -C -C WG - WEIGHTS OF THE 25-POINT GAUSS RULE -C - SAVE XGK, WGK, WG - DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7),XGK(8), - 1 XGK(9),XGK(10),XGK(11),XGK(12),XGK(13),XGK(14)/ - 2 0.9992621049926098E+00, 0.9955569697904981E+00, - 3 0.9880357945340772E+00, 0.9766639214595175E+00, - 4 0.9616149864258425E+00, 0.9429745712289743E+00, - 5 0.9207471152817016E+00, 0.8949919978782754E+00, - 6 0.8658470652932756E+00, 0.8334426287608340E+00, - 7 0.7978737979985001E+00, 0.7592592630373576E+00, - 8 0.7177664068130844E+00, 0.6735663684734684E+00/ - DATA XGK(15),XGK(16),XGK(17),XGK(18),XGK(19),XGK(20),XGK(21), - 1 XGK(22),XGK(23),XGK(24),XGK(25),XGK(26)/ - 2 0.6268100990103174E+00, 0.5776629302412230E+00, - 3 0.5263252843347192E+00, 0.4730027314457150E+00, - 4 0.4178853821930377E+00, 0.3611723058093878E+00, - 5 0.3030895389311078E+00, 0.2438668837209884E+00, - 6 0.1837189394210489E+00, 0.1228646926107104E+00, - 7 0.6154448300568508E-01, 0.0E+00 / - DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7),WGK(8), - 1 WGK(9),WGK(10),WGK(11),WGK(12),WGK(13),WGK(14)/ - 2 0.1987383892330316E-02, 0.5561932135356714E-02, - 3 0.9473973386174152E-02, 0.1323622919557167E-01, - 4 0.1684781770912830E-01, 0.2043537114588284E-01, - 5 0.2400994560695322E-01, 0.2747531758785174E-01, - 6 0.3079230016738749E-01, 0.3400213027432934E-01, - 7 0.3711627148341554E-01, 0.4008382550403238E-01, - 8 0.4287284502017005E-01, 0.4550291304992179E-01/ - DATA WGK(15),WGK(16),WGK(17),WGK(18),WGK(19),WGK(20),WGK(21) - 1 ,WGK(22),WGK(23),WGK(24),WGK(25),WGK(26)/ - 2 0.4798253713883671E-01, 0.5027767908071567E-01, - 3 0.5236288580640748E-01, 0.5425112988854549E-01, - 4 0.5595081122041232E-01, 0.5743711636156783E-01, - 5 0.5868968002239421E-01, 0.5972034032417406E-01, - 6 0.6053945537604586E-01, 0.6112850971705305E-01, - 7 0.6147118987142532E-01, 0.6158081806783294E-01/ - DATA WG(1),WG(2),WG(3),WG(4),WG(5),WG(6),WG(7),WG(8),WG(9), - 1 WG(10),WG(11),WG(12),WG(13)/ - 2 0.1139379850102629E-01, 0.2635498661503214E-01, - 3 0.4093915670130631E-01, 0.5490469597583519E-01, - 4 0.6803833381235692E-01, 0.8014070033500102E-01, - 5 0.9102826198296365E-01, 0.1005359490670506E+00, - 6 0.1085196244742637E+00, 0.1148582591457116E+00, - 7 0.1194557635357848E+00, 0.1222424429903100E+00, - 8 0.1231760537267155E+00/ -C -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C CENTR - MID POINT OF THE INTERVAL -C HLGTH - HALF-LENGTH OF THE INTERVAL -C ABSC - ABSCISSA -C FVAL* - FUNCTION VALUE -C RESG - RESULT OF THE 25-POINT GAUSS FORMULA -C RESK - RESULT OF THE 51-POINT KRONROD FORMULA -C RESKH - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B), -C I.E. TO I/(B-A) -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT QK51 - EPMACH = R1MACH(4) - UFLOW = R1MACH(1) -C - CENTR = 0.5E+00*(A+B) - HLGTH = 0.5E+00*(B-A) - DHLGTH = ABS(HLGTH) -C -C COMPUTE THE 51-POINT KRONROD APPROXIMATION TO -C THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. -C - FC = F(CENTR) - RESG = WG(13)*FC - RESK = WGK(26)*FC - RESABS = ABS(RESK) - DO 10 J=1,12 - JTW = J*2 - ABSC = HLGTH*XGK(JTW) - FVAL1 = F(CENTR-ABSC) - FVAL2 = F(CENTR+ABSC) - FV1(JTW) = FVAL1 - FV2(JTW) = FVAL2 - FSUM = FVAL1+FVAL2 - RESG = RESG+WG(J)*FSUM - RESK = RESK+WGK(JTW)*FSUM - RESABS = RESABS+WGK(JTW)*(ABS(FVAL1)+ABS(FVAL2)) - 10 CONTINUE - DO 15 J = 1,13 - JTWM1 = J*2-1 - ABSC = HLGTH*XGK(JTWM1) - FVAL1 = F(CENTR-ABSC) - FVAL2 = F(CENTR+ABSC) - FV1(JTWM1) = FVAL1 - FV2(JTWM1) = FVAL2 - FSUM = FVAL1+FVAL2 - RESK = RESK+WGK(JTWM1)*FSUM - RESABS = RESABS+WGK(JTWM1)*(ABS(FVAL1)+ABS(FVAL2)) - 15 CONTINUE - RESKH = RESK*0.5E+00 - RESASC = WGK(26)*ABS(FC-RESKH) - DO 20 J=1,25 - RESASC = RESASC+WGK(J)*(ABS(FV1(J)-RESKH)+ABS(FV2(J)-RESKH)) - 20 CONTINUE - RESULT = RESK*HLGTH - RESABS = RESABS*DHLGTH - RESASC = RESASC*DHLGTH - ABSERR = ABS((RESK-RESG)*HLGTH) - IF(RESASC.NE.0.0E+00.AND.ABSERR.NE.0.0E+00) - 1 ABSERR = RESASC*MIN(0.1E+01, - 2 (0.2E+03*ABSERR/RESASC)**1.5E+00) - IF(RESABS.GT.UFLOW/(0.5E+02*EPMACH)) ABSERR = MAX - 1 ((EPMACH*0.5E+02)*RESABS,ABSERR) - RETURN - END diff --git a/slatec/qk61.f b/slatec/qk61.f deleted file mode 100644 index e5ace35..0000000 --- a/slatec/qk61.f +++ /dev/null @@ -1,212 +0,0 @@ -*DECK QK61 - SUBROUTINE QK61 (F, A, B, RESULT, ABSERR, RESABS, RESASC) -C***BEGIN PROLOGUE QK61 -C***PURPOSE To compute I = Integral of F over (A,B) with error -C estimate -C J = Integral of ABS(F) over (A,B) -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A1A2 -C***TYPE SINGLE PRECISION (QK61-S, DQK61-D) -C***KEYWORDS 61-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C Integration rule -C Standard fortran subroutine -C Real version -C -C -C PARAMETERS -C ON ENTRY -C F - Real -C Function subprogram defining the integrand -C function F(X). The actual name for F needs to be -C declared E X T E R N A L in the calling program. -C -C A - Real -C Lower limit of integration -C -C B - Real -C Upper limit of integration -C -C ON RETURN -C RESULT - Real -C Approximation to the integral I -C RESULT is computed by applying the 61-point -C Kronrod rule (RESK) obtained by optimal addition of -C abscissae to the 30-point Gauss rule (RESG). -C -C ABSERR - Real -C Estimate of the modulus of the absolute error, -C which should equal or exceed ABS(I-RESULT) -C -C RESABS - Real -C Approximation to the integral J -C -C RESASC - Real -C Approximation to the integral of ABS(F-I/(B-A)) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH -C***REVISION HISTORY (YYMMDD) -C 800101 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***END PROLOGUE QK61 -C - REAL A,ABSC,ABSERR,B,CENTR,DHLGTH,EPMACH,F,FC,FSUM,FVAL1,FVAL2, - 1 FV1,FV2,HLGTH,RESABS,RESASC,RESG,RESK,RESKH,RESULT,R1MACH,UFLOW, - 2 WG,WGK,XGK - INTEGER J,JTW,JTWM1 - EXTERNAL F -C - DIMENSION FV1(30),FV2(30),XGK(31),WGK(31),WG(15) -C -C THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE -C INTERVAL (-1,1). BECAUSE OF SYMMETRY ONLY THE POSITIVE -C ABSCISSAE AND THEIR CORRESPONDING WEIGHTS ARE GIVEN. -C -C XGK - ABSCISSAE OF THE 61-POINT KRONROD RULE -C XGK(2), XGK(4) ... ABSCISSAE OF THE 30-POINT -C GAUSS RULE -C XGK(1), XGK(3) ... OPTIMALLY ADDED ABSCISSAE -C TO THE 30-POINT GAUSS RULE -C -C WGK - WEIGHTS OF THE 61-POINT KRONROD RULE -C -C WG - WEIGHTS OF THE 30-POINT GAUSS RULE -C - SAVE XGK, WGK, WG - DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7),XGK(8), - 1 XGK(9),XGK(10)/ - 2 0.9994844100504906E+00, 0.9968934840746495E+00, - 3 0.9916309968704046E+00, 0.9836681232797472E+00, - 4 0.9731163225011263E+00, 0.9600218649683075E+00, - 5 0.9443744447485600E+00, 0.9262000474292743E+00, - 6 0.9055733076999078E+00, 0.8825605357920527E+00/ - DATA XGK(11),XGK(12),XGK(13),XGK(14),XGK(15),XGK(16), - 1 XGK(17),XGK(18),XGK(19),XGK(20)/ - 2 0.8572052335460611E+00, 0.8295657623827684E+00, - 3 0.7997278358218391E+00, 0.7677774321048262E+00, - 4 0.7337900624532268E+00, 0.6978504947933158E+00, - 5 0.6600610641266270E+00, 0.6205261829892429E+00, - 6 0.5793452358263617E+00, 0.5366241481420199E+00/ - DATA XGK(21),XGK(22),XGK(23),XGK(24), - 1 XGK(25),XGK(26),XGK(27),XGK(28),XGK(29),XGK(30),XGK(31)/ - 2 0.4924804678617786E+00, 0.4470337695380892E+00, - 3 0.4004012548303944E+00, 0.3527047255308781E+00, - 4 0.3040732022736251E+00, 0.2546369261678898E+00, - 5 0.2045251166823099E+00, 0.1538699136085835E+00, - 6 0.1028069379667370E+00, 0.5147184255531770E-01, - 7 0.0E+00 / - DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7),WGK(8), - 1 WGK(9),WGK(10)/ - 2 0.1389013698677008E-02, 0.3890461127099884E-02, - 3 0.6630703915931292E-02, 0.9273279659517763E-02, - 4 0.1182301525349634E-01, 0.1436972950704580E-01, - 5 0.1692088918905327E-01, 0.1941414119394238E-01, - 6 0.2182803582160919E-01, 0.2419116207808060E-01/ - DATA WGK(11),WGK(12),WGK(13),WGK(14),WGK(15),WGK(16), - 1 WGK(17),WGK(18),WGK(19),WGK(20)/ - 2 0.2650995488233310E-01, 0.2875404876504129E-01, - 3 0.3090725756238776E-01, 0.3298144705748373E-01, - 4 0.3497933802806002E-01, 0.3688236465182123E-01, - 5 0.3867894562472759E-01, 0.4037453895153596E-01, - 6 0.4196981021516425E-01, 0.4345253970135607E-01/ - DATA WGK(21),WGK(22),WGK(23),WGK(24), - 1 WGK(25),WGK(26),WGK(27),WGK(28),WGK(29),WGK(30),WGK(31)/ - 2 0.4481480013316266E-01, 0.4605923827100699E-01, - 3 0.4718554656929915E-01, 0.4818586175708713E-01, - 4 0.4905543455502978E-01, 0.4979568342707421E-01, - 5 0.5040592140278235E-01, 0.5088179589874961E-01, - 6 0.5122154784925877E-01, 0.5142612853745903E-01, - 7 0.5149472942945157E-01/ - DATA WG(1),WG(2),WG(3),WG(4),WG(5),WG(6),WG(7),WG(8)/ - 1 0.7968192496166606E-02, 0.1846646831109096E-01, - 2 0.2878470788332337E-01, 0.3879919256962705E-01, - 3 0.4840267283059405E-01, 0.5749315621761907E-01, - 4 0.6597422988218050E-01, 0.7375597473770521E-01/ - DATA WG(9),WG(10),WG(11),WG(12),WG(13),WG(14),WG(15)/ - 1 0.8075589522942022E-01, 0.8689978720108298E-01, - 2 0.9212252223778613E-01, 0.9636873717464426E-01, - 3 0.9959342058679527E-01, 0.1017623897484055E+00, - 4 0.1028526528935588E+00/ -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C CENTR - MID POINT OF THE INTERVAL -C HLGTH - HALF-LENGTH OF THE INTERVAL -C ABSC - ABSCISSA -C FVAL* - FUNCTION VALUE -C RESG - RESULT OF THE 30-POINT GAUSS RULE -C RESK - RESULT OF THE 61-POINT KRONROD RULE -C RESKH - APPROXIMATION TO THE MEAN VALUE OF F -C OVER (A,B), I.E. TO I/(B-A) -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT QK61 - EPMACH = R1MACH(4) - UFLOW = R1MACH(1) -C - CENTR = 0.5E+00*(B+A) - HLGTH = 0.5E+00*(B-A) - DHLGTH = ABS(HLGTH) -C -C COMPUTE THE 61-POINT KRONROD APPROXIMATION TO THE -C INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. -C - RESG = 0.0E+00 - FC = F(CENTR) - RESK = WGK(31)*FC - RESABS = ABS(RESK) - DO 10 J=1,15 - JTW = J*2 - ABSC = HLGTH*XGK(JTW) - FVAL1 = F(CENTR-ABSC) - FVAL2 = F(CENTR+ABSC) - FV1(JTW) = FVAL1 - FV2(JTW) = FVAL2 - FSUM = FVAL1+FVAL2 - RESG = RESG+WG(J)*FSUM - RESK = RESK+WGK(JTW)*FSUM - RESABS = RESABS+WGK(JTW)*(ABS(FVAL1)+ABS(FVAL2)) - 10 CONTINUE - DO 15 J=1,15 - JTWM1 = J*2-1 - ABSC = HLGTH*XGK(JTWM1) - FVAL1 = F(CENTR-ABSC) - FVAL2 = F(CENTR+ABSC) - FV1(JTWM1) = FVAL1 - FV2(JTWM1) = FVAL2 - FSUM = FVAL1+FVAL2 - RESK = RESK+WGK(JTWM1)*FSUM - RESABS = RESABS+WGK(JTWM1)*(ABS(FVAL1)+ABS(FVAL2)) - 15 CONTINUE - RESKH = RESK*0.5E+00 - RESASC = WGK(31)*ABS(FC-RESKH) - DO 20 J=1,30 - RESASC = RESASC+WGK(J)*(ABS(FV1(J)-RESKH)+ABS(FV2(J)-RESKH)) - 20 CONTINUE - RESULT = RESK*HLGTH - RESABS = RESABS*DHLGTH - RESASC = RESASC*DHLGTH - ABSERR = ABS((RESK-RESG)*HLGTH) - IF(RESASC.NE.0.0E+00.AND.ABSERR.NE.0.0E+00) - 1 ABSERR = RESASC*MIN(0.1E+01, - 2 (0.2E+03*ABSERR/RESASC)**1.5E+00) - IF(RESABS.GT.UFLOW/(0.5E+02*EPMACH)) ABSERR = MAX - 1 ((EPMACH*0.5E+02)*RESABS,ABSERR) - RETURN - END diff --git a/slatec/qmomo.f b/slatec/qmomo.f deleted file mode 100644 index 626c11d..0000000 --- a/slatec/qmomo.f +++ /dev/null @@ -1,139 +0,0 @@ -*DECK QMOMO - SUBROUTINE QMOMO (ALFA, BETA, RI, RJ, RG, RH, INTEGR) -C***BEGIN PROLOGUE QMOMO -C***PURPOSE This routine computes modified Chebyshev moments. The K-th -C modified Chebyshev moment is defined as the integral over -C (-1,1) of W(X)*T(K,X), where T(K,X) is the Chebyshev -C polynomial of degree K. -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A2A1, C3A2 -C***TYPE SINGLE PRECISION (QMOMO-S, DQMOMO-D) -C***KEYWORDS MODIFIED CHEBYSHEV MOMENTS, QUADPACK, QUADRATURE -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C MODIFIED CHEBYSHEV MOMENTS -C STANDARD FORTRAN SUBROUTINE -C REAL VERSION -C -C PARAMETERS -C ALFA - Real -C Parameter in the weight function W(X), ALFA.GT.(-1) -C -C BETA - Real -C Parameter in the weight function W(X), BETA.GT.(-1) -C -C RI - Real -C Vector of dimension 25 -C RI(K) is the integral over (-1,1) of -C (1+X)**ALFA*T(K-1,X), K = 1, ..., 25. -C -C RJ - Real -C Vector of dimension 25 -C RJ(K) is the integral over (-1,1) of -C (1-X)**BETA*T(K-1,X), K = 1, ..., 25. -C -C RG - Real -C Vector of dimension 25 -C RG(K) is the integral over (-1,1) of -C (1+X)**ALFA*LOG((1+X)/2)*T(K-1,X), K = 1, ..., 25. -C -C RH - Real -C Vector of dimension 25 -C RH(K) is the integral over (-1,1) of -C (1-X)**BETA*LOG((1-X)/2)*T(K-1,X), K = 1, ..., 25. -C -C INTEGR - Integer -C Input parameter indicating the modified -C Moments to be computed -C INTEGR = 1 compute RI, RJ -C = 2 compute RI, RJ, RG -C = 3 compute RI, RJ, RH -C = 4 compute RI, RJ, RG, RH -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 810101 DATE WRITTEN -C 891009 Removed unreferenced statement label. (WRB) -C 891009 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE QMOMO -C - REAL ALFA,ALFP1,ALFP2,AN,ANM1,BETA,BETP1, - 1 BETP2,RALF,RBET,RG,RH,RI,RJ - INTEGER I,IM1,INTEGR -C - DIMENSION RG(25),RH(25),RI(25),RJ(25) -C -C -C***FIRST EXECUTABLE STATEMENT QMOMO - ALFP1 = ALFA+0.1E+01 - BETP1 = BETA+0.1E+01 - ALFP2 = ALFA+0.2E+01 - BETP2 = BETA+0.2E+01 - RALF = 0.2E+01**ALFP1 - RBET = 0.2E+01**BETP1 -C -C COMPUTE RI, RJ USING A FORWARD RECURRENCE RELATION. -C - RI(1) = RALF/ALFP1 - RJ(1) = RBET/BETP1 - RI(2) = RI(1)*ALFA/ALFP2 - RJ(2) = RJ(1)*BETA/BETP2 - AN = 0.2E+01 - ANM1 = 0.1E+01 - DO 20 I=3,25 - RI(I) = -(RALF+AN*(AN-ALFP2)*RI(I-1))/ - 1 (ANM1*(AN+ALFP1)) - RJ(I) = -(RBET+AN*(AN-BETP2)*RJ(I-1))/ - 1 (ANM1*(AN+BETP1)) - ANM1 = AN - AN = AN+0.1E+01 - 20 CONTINUE - IF(INTEGR.EQ.1) GO TO 70 - IF(INTEGR.EQ.3) GO TO 40 -C -C COMPUTE RG USING A FORWARD RECURRENCE RELATION. -C - RG(1) = -RI(1)/ALFP1 - RG(2) = -(RALF+RALF)/(ALFP2*ALFP2)-RG(1) - AN = 0.2E+01 - ANM1 = 0.1E+01 - IM1 = 2 - DO 30 I=3,25 - RG(I) = -(AN*(AN-ALFP2)*RG(IM1)-AN*RI(IM1)+ANM1*RI(I))/ - 1 (ANM1*(AN+ALFP1)) - ANM1 = AN - AN = AN+0.1E+01 - IM1 = I - 30 CONTINUE - IF(INTEGR.EQ.2) GO TO 70 -C -C COMPUTE RH USING A FORWARD RECURRENCE RELATION. -C - 40 RH(1) = -RJ(1)/BETP1 - RH(2) = -(RBET+RBET)/(BETP2*BETP2)-RH(1) - AN = 0.2E+01 - ANM1 = 0.1E+01 - IM1 = 2 - DO 50 I=3,25 - RH(I) = -(AN*(AN-BETP2)*RH(IM1)-AN*RJ(IM1)+ - 1 ANM1*RJ(I))/(ANM1*(AN+BETP1)) - ANM1 = AN - AN = AN+0.1E+01 - IM1 = I - 50 CONTINUE - DO 60 I=2,25,2 - RH(I) = -RH(I) - 60 CONTINUE - 70 DO 80 I=2,25,2 - RJ(I) = -RJ(I) - 80 CONTINUE - RETURN - END diff --git a/slatec/qnc79.f b/slatec/qnc79.f deleted file mode 100644 index c434ef0..0000000 --- a/slatec/qnc79.f +++ /dev/null @@ -1,272 +0,0 @@ -*DECK QNC79 - SUBROUTINE QNC79 (FUN, A, B, ERR, ANS, IERR, K) -C***BEGIN PROLOGUE QNC79 -C***PURPOSE Integrate a function using a 7-point adaptive Newton-Cotes -C quadrature rule. -C***LIBRARY SLATEC -C***CATEGORY H2A1A1 -C***TYPE SINGLE PRECISION (QNC79-S, DQNC79-D) -C***KEYWORDS ADAPTIVE QUADRATURE, INTEGRATION, NEWTON-COTES -C***AUTHOR Kahaner, D. K., (NBS) -C Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C QNC79 is a general purpose program for evaluation of -C one dimensional integrals of user defined functions. -C QNC79 will pick its own points for evaluation of the -C integrand and these will vary from problem to problem. -C Thus, QNC79 is not designed to integrate over data sets. -C Moderately smooth integrands will be integrated efficiently -C and reliably. For problems with strong singularities, -C oscillations etc., the user may wish to use more sophis- -C ticated routines such as those in QUADPACK. One measure -C of the reliability of QNC79 is the output parameter K, -C giving the number of integrand evaluations that were needed. -C -C Description of Arguments -C -C --Input-- -C FUN - name of external function to be integrated. This name -C must be in an EXTERNAL statement in your calling -C program. You must write a Fortran function to evaluate -C FUN. This should be of the form -C REAL FUNCTION FUN (X) -C C -C C X can vary from A to B -C C FUN(X) should be finite for all X on interval. -C C -C FUN = ... -C RETURN -C END -C A - lower limit of integration -C B - upper limit of integration (may be less than A) -C ERR - is a requested error tolerance. Normally, pick a value -C 0 .LT. ERR .LT. 1.0E-3. -C -C --Output-- -C ANS - computed value of the integral. Hopefully, ANS is -C accurate to within ERR * integral of ABS(FUN(X)). -C IERR - a status code -C - Normal codes -C 1 ANS most likely meets requested error tolerance. -C -1 A equals B, or A and B are too nearly equal to -C allow normal integration. ANS is set to zero. -C - Abnormal code -C 2 ANS probably does not meet requested error tolerance. -C K - the number of function evaluations actually used to do -C the integration. A value of K .GT. 1000 indicates a -C difficult problem; other programs may be more efficient. -C QNC79 will gracefully give up if K exceeds 2000. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED I1MACH, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790601 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 920218 Code and prologue polished. (WRB) -C***END PROLOGUE QNC79 -C .. Scalar Arguments .. - REAL A, ANS, B, ERR - INTEGER IERR, K -C .. Function Arguments .. - REAL FUN - EXTERNAL FUN -C .. Local Scalars .. - REAL AE, AREA, BANK, BLOCAL, C, CE, EE, EF, EPS, Q13, Q7, Q7L, - + SQ2, TEST, TOL, VR, W1, W2, W3, W4 - INTEGER I, KML, KMX, L, LMN, LMX, NBITS, NIB, NLMN, NLMX - LOGICAL FIRST -C .. Local Arrays .. - REAL AA(40), F(13), F1(40), F2(40), F3(40), F4(40), F5(40), - + F6(40), F7(40), HH(40), Q7R(40), VL(40) - INTEGER LR(40) -C .. External Functions .. - REAL R1MACH - INTEGER I1MACH - EXTERNAL R1MACH, I1MACH -C .. External Subroutines .. - EXTERNAL XERMSG -C .. Intrinsic Functions .. - INTRINSIC ABS, LOG, MAX, MIN, SIGN, SQRT -C .. Save statement .. - SAVE NBITS, NLMX, FIRST, SQ2, W1, W2, W3, W4 -C .. Data statements .. - DATA KML /7/, KMX /2000/, NLMN /2/ - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT QNC79 - IF (FIRST) THEN - W1 = 41.0E0/140.0E0 - W2 = 216.0E0/140.0E0 - W3 = 27.0E0/140.0E0 - W4 = 272.0E0/140.0E0 - NBITS = R1MACH(5)*I1MACH(11)/0.30102000E0 - NLMX = MIN(40,(NBITS*4)/5) - SQ2 = SQRT(2.0E0) - ENDIF - FIRST = .FALSE. - ANS = 0.0E0 - IERR = 1 - CE = 0.0E0 - IF (A .EQ. B) GO TO 260 - LMX = NLMX - LMN = NLMN - IF (B .EQ. 0.0E0) GO TO 100 - IF (SIGN(1.0E0,B)*A .LE. 0.0E0) GO TO 100 - C = ABS(1.0E0-A/B) - IF (C .GT. 0.1E0) GO TO 100 - IF (C .LE. 0.0E0) GO TO 260 - NIB = 0.5E0 - LOG(C)/LOG(2.0E0) - LMX = MIN(NLMX,NBITS-NIB-4) - IF (LMX .LT. 2) GO TO 260 - LMN = MIN(LMN,LMX) - 100 TOL = MAX(ABS(ERR),2.0E0**(5-NBITS)) - IF (ERR .EQ. 0.0E0) TOL = SQRT(R1MACH(4)) - EPS = TOL - HH(1) = (B-A)/12.0E0 - AA(1) = A - LR(1) = 1 - DO 110 I = 1,11,2 - F(I) = FUN(A+(I-1)*HH(1)) - 110 CONTINUE - BLOCAL = B - F(13) = FUN(BLOCAL) - K = 7 - L = 1 - AREA = 0.0E0 - Q7 = 0.0E0 - EF = 256.0E0/255.0E0 - BANK = 0.0E0 -C -C Compute refined estimates, estimate the error, etc. -C - 120 DO 130 I = 2,12,2 - F(I) = FUN(AA(L)+(I-1)*HH(L)) - 130 CONTINUE - K = K + 6 -C -C Compute left and right half estimates -C - Q7L = HH(L)*((W1*(F(1)+F(7))+W2*(F(2)+F(6)))+ - + (W3*(F(3)+F(5))+W4*F(4))) - Q7R(L) = HH(L)*((W1*(F(7)+F(13))+W2*(F(8)+F(12)))+ - + (W3*(F(9)+F(11))+W4*F(10))) -C -C Update estimate of integral of absolute value -C - AREA = AREA + (ABS(Q7L)+ABS(Q7R(L))-ABS(Q7)) -C -C Do not bother to test convergence before minimum refinement level -C - IF (L .LT. LMN) GO TO 180 -C -C Estimate the error in new value for whole interval, Q13 -C - Q13 = Q7L + Q7R(L) - EE = ABS(Q7-Q13)*EF -C -C Compute nominal allowed error -C - AE = EPS*AREA -C -C Borrow from bank account, but not too much -C - TEST = MIN(AE+0.8E0*BANK,10.0E0*AE) -C -C Don't ask for excessive accuracy -C - TEST = MAX(TEST,TOL*ABS(Q13),0.00003E0*TOL*AREA) -C -C Now, did this interval pass or not? -C - IF (EE-TEST) 150,150,170 -C -C Have hit maximum refinement level -- penalize the cumulative error -C - 140 CE = CE + (Q7-Q13) - GO TO 160 -C -C On good intervals accumulate the theoretical estimate -C - 150 CE = CE + (Q7-Q13)/255.0 -C -C Update the bank account. Don't go into debt. -C - 160 BANK = BANK + (AE-EE) - IF (BANK .LT. 0.0E0) BANK = 0.0E0 -C -C Did we just finish a left half or a right half? -C - IF (LR(L)) 190,190,210 -C -C Consider the left half of next deeper level -C - 170 IF (K .GT. KMX) LMX = MIN(KML,LMX) - IF (L .GE. LMX) GO TO 140 - 180 L = L + 1 - EPS = EPS*0.5E0 - IF (L .LE. 17) EF = EF/SQ2 - HH(L) = HH(L-1)*0.5E0 - LR(L) = -1 - AA(L) = AA(L-1) - Q7 = Q7L - F1(L) = F(7) - F2(L) = F(8) - F3(L) = F(9) - F4(L) = F(10) - F5(L) = F(11) - F6(L) = F(12) - F7(L) = F(13) - F(13) = F(7) - F(11) = F(6) - F(9) = F(5) - F(7) = F(4) - F(5) = F(3) - F(3) = F(2) - GO TO 120 -C -C Proceed to right half at this level -C - 190 VL(L) = Q13 - 200 Q7 = Q7R(L-1) - LR(L) = 1 - AA(L) = AA(L) + 12.0E0*HH(L) - F(1) = F1(L) - F(3) = F2(L) - F(5) = F3(L) - F(7) = F4(L) - F(9) = F5(L) - F(11) = F6(L) - F(13) = F7(L) - GO TO 120 -C -C Left and right halves are done, so go back up a level -C - 210 VR = Q13 - 220 IF (L .LE. 1) GO TO 250 - IF (L .LE. 17) EF = EF*SQ2 - EPS = EPS*2.0E0 - L = L - 1 - IF (LR(L)) 230,230,240 - 230 VL(L) = VL(L+1) + VR - GO TO 200 - 240 VR = VL(L+1) + VR - GO TO 220 -C -C Exit -C - 250 ANS = VR - IF (ABS(CE) .LE. 2.0E0*TOL*AREA) GO TO 270 - IERR = 2 - CALL XERMSG ('SLATEC', 'QNC79', - + 'ANS is probably insufficiently accurate.', 2, 1) - GO TO 270 - 260 IERR = -1 - CALL XERMSG ('SLATEC', 'QNC79', - + 'A and B are too nearly equal to allow normal integration. $$' - + // 'ANS is set to zero and IERR to -1.', -1, -1) - 270 RETURN - END diff --git a/slatec/qng.f b/slatec/qng.f deleted file mode 100644 index 525ecb5..0000000 --- a/slatec/qng.f +++ /dev/null @@ -1,348 +0,0 @@ -*DECK QNG - SUBROUTINE QNG (F, A, B, EPSABS, EPSREL, RESULT, ABSERR, NEVAL, - + IER) -C***BEGIN PROLOGUE QNG -C***PURPOSE The routine calculates an approximation result to a -C given definite integral I = integral of F over (A,B), -C hopefully satisfying following claim for accuracy -C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2A1A1 -C***TYPE SINGLE PRECISION (QNG-S, DQNG-D) -C***KEYWORDS AUTOMATIC INTEGRATOR, GAUSS-KRONROD(PATTERSON) RULES, -C NONADAPTIVE, QUADPACK, QUADRATURE, SMOOTH INTEGRAND -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***DESCRIPTION -C -C NON-ADAPTIVE INTEGRATION -C STANDARD FORTRAN SUBROUTINE -C REAL VERSION -C -C F - Real version -C Function subprogram defining the integrand function -C F(X). The actual name for F needs to be declared -C E X T E R N A L in the driver program. -C -C A - Real version -C Lower limit of integration -C -C B - Real version -C Upper limit of integration -C -C EPSABS - Real -C Absolute accuracy requested -C EPSREL - Real -C Relative accuracy requested -C If EPSABS.LE.0 -C And EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C The routine will end with IER = 6. -C -C ON RETURN -C RESULT - Real -C Approximation to the integral I -C Result is obtained by applying the 21-POINT -C GAUSS-KRONROD RULE (RES21) obtained by optimal -C addition of abscissae to the 10-POINT GAUSS RULE -C (RES10), or by applying the 43-POINT RULE (RES43) -C obtained by optimal addition of abscissae to the -C 21-POINT GAUSS-KRONROD RULE, or by applying the -C 87-POINT RULE (RES87) obtained by optimal addition -C of abscissae to the 43-POINT RULE. -C -C ABSERR - Real -C Estimate of the modulus of the absolute error, -C which should EQUAL or EXCEED ABS(I-RESULT) -C -C NEVAL - Integer -C Number of integrand evaluations -C -C IER - IER = 0 normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C IER.GT.0 Abnormal termination of the routine. It is -C assumed that the requested accuracy has -C not been achieved. -C ERROR MESSAGES -C IER = 1 The maximum number of steps has been -C executed. The integral is probably too -C difficult to be calculated by DQNG. -C = 6 The input is invalid, because -C EPSABS.LE.0 AND -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28). -C RESULT, ABSERR and NEVAL are set to zero. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800101 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***END PROLOGUE QNG -C - REAL A,ABSC,ABSERR,B,CENTR,DHLGTH,EPMACH,EPSABS,EPSREL,F,FCENTR, - 1 FVAL,FVAL1,FVAL2,FV1,FV2,FV3,FV4,HLGTH,RESULT,RES10,RES21,RES43, - 2 RES87,RESABS,RESASC,RESKH,R1MACH,SAVFUN,UFLOW,W10,W21A,W43A, - 3 W43B,W87A,W87B,X1,X2,X3,X4 - INTEGER IER,IPX,K,L,NEVAL - EXTERNAL F -C - DIMENSION FV1(5),FV2(5),FV3(5),FV4(5),X1(5),X2(5),X3(11),X4(22), - 1 W10(5),W21A(5),W21B(6),W43A(10),W43B(12),W87A(21),W87B(23), - 2 SAVFUN(21) -C -C THE FOLLOWING DATA STATEMENTS CONTAIN THE -C ABSCISSAE AND WEIGHTS OF THE INTEGRATION RULES USED. -C -C X1 ABSCISSAE COMMON TO THE 10-, 21-, 43- -C AND 87-POINT RULE -C X2 ABSCISSAE COMMON TO THE 21-, 43- AND -C 87-POINT RULE -C X3 ABSCISSAE COMMON TO THE 43- AND 87-POINT -C RULE -C X4 ABSCISSAE OF THE 87-POINT RULE -C W10 WEIGHTS OF THE 10-POINT FORMULA -C W21A WEIGHTS OF THE 21-POINT FORMULA FOR -C ABSCISSAE X1 -C W21B WEIGHTS OF THE 21-POINT FORMULA FOR -C ABSCISSAE X2 -C W43A WEIGHTS OF THE 43-POINT FORMULA FOR -C ABSCISSAE X1, X3 -C W43B WEIGHTS OF THE 43-POINT FORMULA FOR -C ABSCISSAE X3 -C W87A WEIGHTS OF THE 87-POINT FORMULA FOR -C ABSCISSAE X1, X2, X3 -C W87B WEIGHTS OF THE 87-POINT FORMULA FOR -C ABSCISSAE X4 -C - SAVE X1, X2, X3, X4, W10, W21A, W21B, W43A, W43B, W87A, W87B - DATA X1(1),X1(2),X1(3),X1(4),X1(5)/ - 1 0.9739065285171717E+00, 0.8650633666889845E+00, - 2 0.6794095682990244E+00, 0.4333953941292472E+00, - 3 0.1488743389816312E+00/ - DATA X2(1),X2(2),X2(3),X2(4),X2(5)/ - 1 0.9956571630258081E+00, 0.9301574913557082E+00, - 2 0.7808177265864169E+00, 0.5627571346686047E+00, - 3 0.2943928627014602E+00/ - DATA X3(1),X3(2),X3(3),X3(4),X3(5),X3(6),X3(7),X3(8), - 1 X3(9),X3(10),X3(11)/ - 2 0.9993333609019321E+00, 0.9874334029080889E+00, - 3 0.9548079348142663E+00, 0.9001486957483283E+00, - 4 0.8251983149831142E+00, 0.7321483889893050E+00, - 5 0.6228479705377252E+00, 0.4994795740710565E+00, - 6 0.3649016613465808E+00, 0.2222549197766013E+00, - 7 0.7465061746138332E-01/ - DATA X4(1),X4(2),X4(3),X4(4),X4(5),X4(6),X4(7),X4(8),X4(9), - 1 X4(10),X4(11),X4(12),X4(13),X4(14),X4(15),X4(16),X4(17),X4(18), - 2 X4(19),X4(20),X4(21),X4(22)/ 0.9999029772627292E+00, - 3 0.9979898959866787E+00, 0.9921754978606872E+00, - 4 0.9813581635727128E+00, 0.9650576238583846E+00, - 5 0.9431676131336706E+00, 0.9158064146855072E+00, - 6 0.8832216577713165E+00, 0.8457107484624157E+00, - 7 0.8035576580352310E+00, 0.7570057306854956E+00, - 8 0.7062732097873218E+00, 0.6515894665011779E+00, - 9 0.5932233740579611E+00, 0.5314936059708319E+00, - 1 0.4667636230420228E+00, 0.3994248478592188E+00, - 2 0.3298748771061883E+00, 0.2585035592021616E+00, - 3 0.1856953965683467E+00, 0.1118422131799075E+00, - 4 0.3735212339461987E-01/ - DATA W10(1),W10(2),W10(3),W10(4),W10(5)/ - 1 0.6667134430868814E-01, 0.1494513491505806E+00, - 2 0.2190863625159820E+00, 0.2692667193099964E+00, - 3 0.2955242247147529E+00/ - DATA W21A(1),W21A(2),W21A(3),W21A(4),W21A(5)/ - 1 0.3255816230796473E-01, 0.7503967481091995E-01, - 2 0.1093871588022976E+00, 0.1347092173114733E+00, - 3 0.1477391049013385E+00/ - DATA W21B(1),W21B(2),W21B(3),W21B(4),W21B(5),W21B(6)/ - 1 0.1169463886737187E-01, 0.5475589657435200E-01, - 2 0.9312545458369761E-01, 0.1234919762620659E+00, - 3 0.1427759385770601E+00, 0.1494455540029169E+00/ - DATA W43A(1),W43A(2),W43A(3),W43A(4),W43A(5),W43A(6),W43A(7), - 1 W43A(8),W43A(9),W43A(10)/ 0.1629673428966656E-01, - 2 0.3752287612086950E-01, 0.5469490205825544E-01, - 3 0.6735541460947809E-01, 0.7387019963239395E-01, - 4 0.5768556059769796E-02, 0.2737189059324884E-01, - 5 0.4656082691042883E-01, 0.6174499520144256E-01, - 6 0.7138726726869340E-01/ - DATA W43B(1),W43B(2),W43B(3),W43B(4),W43B(5),W43B(6), - 1 W43B(7),W43B(8),W43B(9),W43B(10),W43B(11),W43B(12)/ - 2 0.1844477640212414E-02, 0.1079868958589165E-01, - 3 0.2189536386779543E-01, 0.3259746397534569E-01, - 4 0.4216313793519181E-01, 0.5074193960018458E-01, - 5 0.5837939554261925E-01, 0.6474640495144589E-01, - 6 0.6956619791235648E-01, 0.7282444147183321E-01, - 7 0.7450775101417512E-01, 0.7472214751740301E-01/ - DATA W87A(1),W87A(2),W87A(3),W87A(4),W87A(5),W87A(6), - 1 W87A(7),W87A(8),W87A(9),W87A(10),W87A(11),W87A(12), - 2 W87A(13),W87A(14),W87A(15),W87A(16),W87A(17),W87A(18), - 3 W87A(19),W87A(20),W87A(21)/ - 4 0.8148377384149173E-02, 0.1876143820156282E-01, - 5 0.2734745105005229E-01, 0.3367770731163793E-01, - 6 0.3693509982042791E-01, 0.2884872430211531E-02, - 7 0.1368594602271270E-01, 0.2328041350288831E-01, - 8 0.3087249761171336E-01, 0.3569363363941877E-01, - 9 0.9152833452022414E-03, 0.5399280219300471E-02, - 1 0.1094767960111893E-01, 0.1629873169678734E-01, - 2 0.2108156888920384E-01, 0.2537096976925383E-01, - 3 0.2918969775647575E-01, 0.3237320246720279E-01, - 4 0.3478309895036514E-01, 0.3641222073135179E-01, - 5 0.3725387550304771E-01/ - DATA W87B(1),W87B(2),W87B(3),W87B(4),W87B(5),W87B(6),W87B(7), - 1 W87B(8),W87B(9),W87B(10),W87B(11),W87B(12),W87B(13),W87B(14), - 2 W87B(15),W87B(16),W87B(17),W87B(18),W87B(19),W87B(20), - 3 W87B(21),W87B(22),W87B(23)/ 0.2741455637620724E-03, - 4 0.1807124155057943E-02, 0.4096869282759165E-02, - 5 0.6758290051847379E-02, 0.9549957672201647E-02, - 6 0.1232944765224485E-01, 0.1501044734638895E-01, - 7 0.1754896798624319E-01, 0.1993803778644089E-01, - 8 0.2219493596101229E-01, 0.2433914712600081E-01, - 9 0.2637450541483921E-01, 0.2828691078877120E-01, - 1 0.3005258112809270E-01, 0.3164675137143993E-01, - 2 0.3305041341997850E-01, 0.3425509970422606E-01, - 3 0.3526241266015668E-01, 0.3607698962288870E-01, - 4 0.3669860449845609E-01, 0.3712054926983258E-01, - 5 0.3733422875193504E-01, 0.3736107376267902E-01/ -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C CENTR - MID POINT OF THE INTEGRATION INTERVAL -C HLGTH - HALF-LENGTH OF THE INTEGRATION INTERVAL -C FCENTR - FUNCTION VALUE AT MID POINT -C ABSC - ABSCISSA -C FVAL - FUNCTION VALUE -C SAVFUN - ARRAY OF FUNCTION VALUES WHICH -C HAVE ALREADY BEEN COMPUTED -C RES10 - 10-POINT GAUSS RESULT -C RES21 - 21-POINT KRONROD RESULT -C RES43 - 43-POINT RESULT -C RES87 - 87-POINT RESULT -C RESABS - APPROXIMATION TO THE INTEGRAL OF ABS(F) -C RESASC - APPROXIMATION TO THE INTEGRAL OF ABS(F-I/(B-A)) -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT QNG - EPMACH = R1MACH(4) - UFLOW = R1MACH(1) -C -C TEST ON VALIDITY OF PARAMETERS -C ------------------------------ -C - RESULT = 0.0E+00 - ABSERR = 0.0E+00 - NEVAL = 0 - IER = 6 - IF(EPSABS.LE.0.0E+00.AND.EPSREL.LT.MAX(0.5E-14,0.5E+02*EPMACH)) - 1 GO TO 80 - HLGTH = 0.5E+00*(B-A) - DHLGTH = ABS(HLGTH) - CENTR = 0.5E+00*(B+A) - FCENTR = F(CENTR) - NEVAL = 21 - IER = 1 -C -C COMPUTE THE INTEGRAL USING THE 10- AND 21-POINT FORMULA. -C - DO 70 L = 1,3 - GO TO (5,25,45),L - 5 RES10 = 0.0E+00 - RES21 = W21B(6)*FCENTR - RESABS = W21B(6)*ABS(FCENTR) - DO 10 K=1,5 - ABSC = HLGTH*X1(K) - FVAL1 = F(CENTR+ABSC) - FVAL2 = F(CENTR-ABSC) - FVAL = FVAL1+FVAL2 - RES10 = RES10+W10(K)*FVAL - RES21 = RES21+W21A(K)*FVAL - RESABS = RESABS+W21A(K)*(ABS(FVAL1)+ABS(FVAL2)) - SAVFUN(K) = FVAL - FV1(K) = FVAL1 - FV2(K) = FVAL2 - 10 CONTINUE - IPX = 5 - DO 15 K=1,5 - IPX = IPX+1 - ABSC = HLGTH*X2(K) - FVAL1 = F(CENTR+ABSC) - FVAL2 = F(CENTR-ABSC) - FVAL = FVAL1+FVAL2 - RES21 = RES21+W21B(K)*FVAL - RESABS = RESABS+W21B(K)*(ABS(FVAL1)+ABS(FVAL2)) - SAVFUN(IPX) = FVAL - FV3(K) = FVAL1 - FV4(K) = FVAL2 - 15 CONTINUE -C -C TEST FOR CONVERGENCE. -C - RESULT = RES21*HLGTH - RESABS = RESABS*DHLGTH - RESKH = 0.5E+00*RES21 - RESASC = W21B(6)*ABS(FCENTR-RESKH) - DO 20 K = 1,5 - RESASC = RESASC+W21A(K)*(ABS(FV1(K)-RESKH)+ABS(FV2(K)-RESKH)) - 1 +W21B(K)*(ABS(FV3(K)-RESKH)+ABS(FV4(K)-RESKH)) - 20 CONTINUE - ABSERR = ABS((RES21-RES10)*HLGTH) - RESASC = RESASC*DHLGTH - GO TO 65 -C -C COMPUTE THE INTEGRAL USING THE 43-POINT FORMULA. -C - 25 RES43 = W43B(12)*FCENTR - NEVAL = 43 - DO 30 K=1,10 - RES43 = RES43+SAVFUN(K)*W43A(K) - 30 CONTINUE - DO 40 K=1,11 - IPX = IPX+1 - ABSC = HLGTH*X3(K) - FVAL = F(ABSC+CENTR)+F(CENTR-ABSC) - RES43 = RES43+FVAL*W43B(K) - SAVFUN(IPX) = FVAL - 40 CONTINUE -C -C TEST FOR CONVERGENCE. -C - RESULT = RES43*HLGTH - ABSERR = ABS((RES43-RES21)*HLGTH) - GO TO 65 -C -C COMPUTE THE INTEGRAL USING THE 87-POINT FORMULA. -C - 45 RES87 = W87B(23)*FCENTR - NEVAL = 87 - DO 50 K=1,21 - RES87 = RES87+SAVFUN(K)*W87A(K) - 50 CONTINUE - DO 60 K=1,22 - ABSC = HLGTH*X4(K) - RES87 = RES87+W87B(K)*(F(ABSC+CENTR)+F(CENTR-ABSC)) - 60 CONTINUE - RESULT = RES87*HLGTH - ABSERR = ABS((RES87-RES43)*HLGTH) - 65 IF(RESASC.NE.0.0E+00.AND.ABSERR.NE.0.0E+00) - 1 ABSERR = RESASC*MIN(0.1E+01, - 2 (0.2E+03*ABSERR/RESASC)**1.5E+00) - IF (RESABS.GT.UFLOW/(0.5E+02*EPMACH)) ABSERR = MAX - 1 ((EPMACH*0.5E+02)*RESABS,ABSERR) - IF (ABSERR.LE.MAX(EPSABS,EPSREL*ABS(RESULT))) IER = 0 -C ***JUMP OUT OF DO-LOOP - IF (IER.EQ.0) GO TO 999 - 70 CONTINUE - 80 CALL XERMSG ('SLATEC', 'QNG', 'ABNORMAL RETURN', IER, 0) - 999 RETURN - END diff --git a/slatec/qpdoc.f b/slatec/qpdoc.f deleted file mode 100644 index 604aa79..0000000 --- a/slatec/qpdoc.f +++ /dev/null @@ -1,491 +0,0 @@ -*DECK QPDOC - SUBROUTINE QPDOC -C***BEGIN PROLOGUE QPDOC -C***PURPOSE Documentation for QUADPACK, a package of subprograms for -C automatic evaluation of one-dimensional definite integrals. -C***LIBRARY SLATEC (QUADPACK) -C***CATEGORY H2, Z -C***TYPE ALL (QPDOC-A) -C***KEYWORDS DOCUMENTATION, GUIDELINES FOR SELECTION, QUADPACK, -C QUADRATURE, SURVEY OF INTEGRATORS -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C Kahaner, D. K., (NBS) -C***DESCRIPTION -C -C 1. Introduction -C ------------ -C QUADPACK is a FORTRAN subroutine package for the numerical -C computation of definite one-dimensional integrals. It originated -C from a joint project of R. Piessens and E. de Doncker (Appl. -C Math. and Progr. Div.- K.U.Leuven, Belgium), C. Ueberhuber (Inst. -C Fuer Math.- Techn. U. Wien, Austria), and D. Kahaner (National -C Bureau of Standards- Washington D.C., U.S.A.). -C -C Documentation routine QPDOC describes the package in the form it -C was released from A.M.P.D.- Leuven, for adherence to the SLATEC -C library in May 1981. Apart from a survey of the integrators, some -C guidelines will be given in order to help the QUADPACK user with -C selecting an appropriate routine or a combination of several -C routines for handling his problem. -C -C In the Long Description of QPDOC it is demonstrated how to call -C the integrators, by means of small example calling programs. -C -C For precise guidelines involving the use of each routine in -C particular, we refer to the extensive introductory comments -C within each routine. -C -C 2. Survey -C ------ -C The following list gives an overview of the QUADPACK integrators. -C The routine names for the DOUBLE PRECISION versions are preceded -C by the letter D. -C -C - QNG : Is a simple non-adaptive automatic integrator, based on -C a sequence of rules with increasing degree of algebraic -C precision (Patterson, 1968). -C -C - QAG : Is a simple globally adaptive integrator using the -C strategy of Aind (Piessens, 1973). It is possible to -C choose between 6 pairs of Gauss-Kronrod quadrature -C formulae for the rule evaluation component. The pairs -C of high degree of precision are suitable for handling -C integration difficulties due to a strongly oscillating -C integrand. -C -C - QAGS : Is an integrator based on globally adaptive interval -C subdivision in connection with extrapolation (de Doncker, -C 1978) by the Epsilon algorithm (Wynn, 1956). -C -C - QAGP : Serves the same purposes as QAGS, but also allows -C for eventual user-supplied information, i.e. the -C abscissae of internal singularities, discontinuities -C and other difficulties of the integrand function. -C The algorithm is a modification of that in QAGS. -C -C - QAGI : Handles integration over infinite intervals. The -C infinite range is mapped onto a finite interval and -C then the same strategy as in QAGS is applied. -C -C - QAWO : Is a routine for the integration of COS(OMEGA*X)*F(X) -C or SIN(OMEGA*X)*F(X) over a finite interval (A,B). -C OMEGA is is specified by the user -C The rule evaluation component is based on the -C modified Clenshaw-Curtis technique. -C An adaptive subdivision scheme is used connected with -C an extrapolation procedure, which is a modification -C of that in QAGS and provides the possibility to deal -C even with singularities in F. -C -C - QAWF : Calculates the Fourier cosine or Fourier sine -C transform of F(X), for user-supplied interval (A, -C INFINITY), OMEGA, and F. The procedure of QAWO is -C used on successive finite intervals, and convergence -C acceleration by means of the Epsilon algorithm (Wynn, -C 1956) is applied to the series of the integral -C contributions. -C -C - QAWS : Integrates W(X)*F(X) over (A,B) with A.LT.B finite, -C and W(X) = ((X-A)**ALFA)*((B-X)**BETA)*V(X) -C where V(X) = 1 or LOG(X-A) or LOG(B-X) -C or LOG(X-A)*LOG(B-X) -C and ALFA.GT.(-1), BETA.GT.(-1). -C The user specifies A, B, ALFA, BETA and the type of -C the function V. -C A globally adaptive subdivision strategy is applied, -C with modified Clenshaw-Curtis integration on the -C subintervals which contain A or B. -C -C - QAWC : Computes the Cauchy Principal Value of F(X)/(X-C) -C over a finite interval (A,B) and for -C user-determined C. -C The strategy is globally adaptive, and modified -C Clenshaw-Curtis integration is used on the subranges -C which contain the point X = C. -C -C Each of the routines above also has a "more detailed" version -C with a name ending in E, as QAGE. These provide more -C information and control than the easier versions. -C -C -C The preceding routines are all automatic. That is, the user -C inputs his problem and an error tolerance. The routine -C attempts to perform the integration to within the requested -C absolute or relative error. -C There are, in addition, a number of non-automatic integrators. -C These are most useful when the problem is such that the -C user knows that a fixed rule will provide the accuracy -C required. Typically they return an error estimate but make -C no attempt to satisfy any particular input error request. -C -C QK15 -C QK21 -C QK31 -C QK41 -C QK51 -C QK61 -C Estimate the integral on [a,b] using 15, 21,..., 61 -C point rule and return an error estimate. -C QK15I 15 point rule for (semi)infinite interval. -C QK15W 15 point rule for special singular weight functions. -C QC25C 25 point rule for Cauchy Principal Values -C QC25F 25 point rule for sin/cos integrand. -C QMOMO Integrates k-th degree Chebyshev polynomial times -C function with various explicit singularities. -C -C 3. Guidelines for the use of QUADPACK -C ---------------------------------- -C Here it is not our purpose to investigate the question when -C automatic quadrature should be used. We shall rather attempt -C to help the user who already made the decision to use QUADPACK, -C with selecting an appropriate routine or a combination of -C several routines for handling his problem. -C -C For both quadrature over finite and over infinite intervals, -C one of the first questions to be answered by the user is -C related to the amount of computer time he wants to spend, -C versus his -own- time which would be needed, for example, for -C manual subdivision of the interval or other analytic -C manipulations. -C -C (1) The user may not care about computer time, or not be -C willing to do any analysis of the problem. especially when -C only one or a few integrals must be calculated, this attitude -C can be perfectly reasonable. In this case it is clear that -C either the most sophisticated of the routines for finite -C intervals, QAGS, must be used, or its analogue for infinite -C intervals, GAGI. These routines are able to cope with -C rather difficult, even with improper integrals. -C This way of proceeding may be expensive. But the integrator -C is supposed to give you an answer in return, with additional -C information in the case of a failure, through its error -C estimate and flag. Yet it must be stressed that the programs -C cannot be totally reliable. -C ------ -C -C (2) The user may want to examine the integrand function. -C If bad local difficulties occur, such as a discontinuity, a -C singularity, derivative singularity or high peak at one or -C more points within the interval, the first advice is to -C split up the interval at these points. The integrand must -C then be examined over each of the subintervals separately, -C so that a suitable integrator can be selected for each of -C them. If this yields problems involving relative accuracies -C to be imposed on -finite- subintervals, one can make use of -C QAGP, which must be provided with the positions of the local -C difficulties. However, if strong singularities are present -C and a high accuracy is requested, application of QAGS on the -C subintervals may yield a better result. -C -C For quadrature over finite intervals we thus dispose of QAGS -C and -C - QNG for well-behaved integrands, -C - QAG for functions with an oscillating behaviour of a non -C specific type, -C - QAWO for functions, eventually singular, containing a -C factor COS(OMEGA*X) or SIN(OMEGA*X) where OMEGA is known, -C - QAWS for integrands with Algebraico-Logarithmic end point -C singularities of known type, -C - QAWC for Cauchy Principal Values. -C -C Remark -C ------ -C On return, the work arrays in the argument lists of the -C adaptive integrators contain information about the interval -C subdivision process and hence about the integrand behaviour: -C the end points of the subintervals, the local integral -C contributions and error estimates, and eventually other -C characteristics. For this reason, and because of its simple -C globally adaptive nature, the routine QAG in particular is -C well-suited for integrand examination. Difficult spots can -C be located by investigating the error estimates on the -C subintervals. -C -C For infinite intervals we provide only one general-purpose -C routine, QAGI. It is based on the QAGS algorithm applied -C after a transformation of the original interval into (0,1). -C Yet it may eventuate that another type of transformation is -C more appropriate, or one might prefer to break up the -C original interval and use QAGI only on the infinite part -C and so on. These kinds of actions suggest a combined use of -C different QUADPACK integrators. Note that, when the only -C difficulty is an integrand singularity at the finite -C integration limit, it will in general not be necessary to -C break up the interval, as QAGI deals with several types of -C singularity at the boundary point of the integration range. -C It also handles slowly convergent improper integrals, on -C the condition that the integrand does not oscillate over -C the entire infinite interval. If it does we would advise -C to sum succeeding positive and negative contributions to -C the integral -e.g. integrate between the zeros- with one -C or more of the finite-range integrators, and apply -C convergence acceleration eventually by means of QUADPACK -C subroutine QELG which implements the Epsilon algorithm. -C Such quadrature problems include the Fourier transform as -C a special case. Yet for the latter we have an automatic -C integrator available, QAWF. -C -C *Long Description: -C -C 4. Example Programs -C ---------------- -C 4.1. Calling Program for QNG -C ----------------------- -C -C REAL A,ABSERR,B,F,EPSABS,EPSREL,RESULT -C INTEGER IER,NEVAL -C EXTERNAL F -C A = 0.0E0 -C B = 1.0E0 -C EPSABS = 0.0E0 -C EPSREL = 1.0E-3 -C CALL QNG(F,A,B,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER) -C C INCLUDE WRITE STATEMENTS -C STOP -C END -C C -C REAL FUNCTION F(X) -C REAL X -C F = EXP(X)/(X*X+0.1E+01) -C RETURN -C END -C -C 4.2. Calling Program for QAG -C ----------------------- -C -C REAL A,ABSERR,B,EPSABS,EPSREL,F,RESULT,WORK -C INTEGER IER,IWORK,KEY,LAST,LENW,LIMIT,NEVAL -C DIMENSION IWORK(100),WORK(400) -C EXTERNAL F -C A = 0.0E0 -C B = 1.0E0 -C EPSABS = 0.0E0 -C EPSREL = 1.0E-3 -C KEY = 6 -C LIMIT = 100 -C LENW = LIMIT*4 -C CALL QAG(F,A,B,EPSABS,EPSREL,KEY,RESULT,ABSERR,NEVAL, -C * IER,LIMIT,LENW,LAST,IWORK,WORK) -C C INCLUDE WRITE STATEMENTS -C STOP -C END -C C -C REAL FUNCTION F(X) -C REAL X -C F = 2.0E0/(2.0E0+SIN(31.41592653589793E0*X)) -C RETURN -C END -C -C 4.3. Calling Program for QAGS -C ------------------------ -C -C REAL A,ABSERR,B,EPSABS,EPSREL,F,RESULT,WORK -C INTEGER IER,IWORK,LAST,LENW,LIMIT,NEVAL -C DIMENSION IWORK(100),WORK(400) -C EXTERNAL F -C A = 0.0E0 -C B = 1.0E0 -C EPSABS = 0.0E0 -C EPSREL = 1.0E-3 -C LIMIT = 100 -C LENW = LIMIT*4 -C CALL QAGS(F,A,B,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, -C * LIMIT,LENW,LAST,IWORK,WORK) -C C INCLUDE WRITE STATEMENTS -C STOP -C END -C C -C REAL FUNCTION F(X) -C REAL X -C F = 0.0E0 -C IF(X.GT.0.0E0) F = 1.0E0/SQRT(X) -C RETURN -C END -C -C 4.4. Calling Program for QAGP -C ------------------------ -C -C REAL A,ABSERR,B,EPSABS,EPSREL,F,POINTS,RESULT,WORK -C INTEGER IER,IWORK,LAST,LENIW,LENW,LIMIT,NEVAL,NPTS2 -C DIMENSION IWORK(204),POINTS(4),WORK(404) -C EXTERNAL F -C A = 0.0E0 -C B = 1.0E0 -C NPTS2 = 4 -C POINTS(1) = 1.0E0/7.0E0 -C POINTS(2) = 2.0E0/3.0E0 -C LIMIT = 100 -C LENIW = LIMIT*2+NPTS2 -C LENW = LIMIT*4+NPTS2 -C CALL QAGP(F,A,B,NPTS2,POINTS,EPSABS,EPSREL,RESULT,ABSERR, -C * NEVAL,IER,LENIW,LENW,LAST,IWORK,WORK) -C C INCLUDE WRITE STATEMENTS -C STOP -C END -C C -C REAL FUNCTION F(X) -C REAL X -C F = 0.0E+00 -C IF(X.NE.1.0E0/7.0E0.AND.X.NE.2.0E0/3.0E0) F = -C * ABS(X-1.0E0/7.0E0)**(-0.25E0)* -C * ABS(X-2.0E0/3.0E0)**(-0.55E0) -C RETURN -C END -C -C 4.5. Calling Program for QAGI -C ------------------------ -C -C REAL ABSERR,BOUN,EPSABS,EPSREL,F,RESULT,WORK -C INTEGER IER,INF,IWORK,LAST,LENW,LIMIT,NEVAL -C DIMENSION IWORK(100),WORK(400) -C EXTERNAL F -C BOUN = 0.0E0 -C INF = 1 -C EPSABS = 0.0E0 -C EPSREL = 1.0E-3 -C LIMIT = 100 -C LENW = LIMIT*4 -C CALL QAGI(F,BOUN,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL, -C * IER,LIMIT,LENW,LAST,IWORK,WORK) -C C INCLUDE WRITE STATEMENTS -C STOP -C END -C C -C REAL FUNCTION F(X) -C REAL X -C F = 0.0E0 -C IF(X.GT.0.0E0) F = SQRT(X)*LOG(X)/ -C * ((X+1.0E0)*(X+2.0E0)) -C RETURN -C END -C -C 4.6. Calling Program for QAWO -C ------------------------ -C -C REAL A,ABSERR,B,EPSABS,EPSREL,F,RESULT,OMEGA,WORK -C INTEGER IER,INTEGR,IWORK,LAST,LENIW,LENW,LIMIT,MAXP1,NEVAL -C DIMENSION IWORK(200),WORK(925) -C EXTERNAL F -C A = 0.0E0 -C B = 1.0E0 -C OMEGA = 10.0E0 -C INTEGR = 1 -C EPSABS = 0.0E0 -C EPSREL = 1.0E-3 -C LIMIT = 100 -C LENIW = LIMIT*2 -C MAXP1 = 21 -C LENW = LIMIT*4+MAXP1*25 -C CALL QAWO(F,A,B,OMEGA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, -C * NEVAL,IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) -C C INCLUDE WRITE STATEMENTS -C STOP -C END -C C -C REAL FUNCTION F(X) -C REAL X -C F = 0.0E0 -C IF(X.GT.0.0E0) F = EXP(-X)*LOG(X) -C RETURN -C END -C -C 4.7. Calling Program for QAWF -C ------------------------ -C -C REAL A,ABSERR,EPSABS,F,RESULT,OMEGA,WORK -C INTEGER IER,INTEGR,IWORK,LAST,LENIW,LENW,LIMIT,LIMLST, -C * LST,MAXP1,NEVAL -C DIMENSION IWORK(250),WORK(1025) -C EXTERNAL F -C A = 0.0E0 -C OMEGA = 8.0E0 -C INTEGR = 2 -C EPSABS = 1.0E-3 -C LIMLST = 50 -C LIMIT = 100 -C LENIW = LIMIT*2+LIMLST -C MAXP1 = 21 -C LENW = LENIW*2+MAXP1*25 -C CALL QAWF(F,A,OMEGA,INTEGR,EPSABS,RESULT,ABSERR,NEVAL, -C * IER,LIMLST,LST,LENIW,MAXP1,LENW,IWORK,WORK) -C C INCLUDE WRITE STATEMENTS -C STOP -C END -C C -C REAL FUNCTION F(X) -C REAL X -C IF(X.GT.0.0E0) F = SIN(50.0E0*X)/(X*SQRT(X)) -C RETURN -C END -C -C 4.8. Calling Program for QAWS -C ------------------------ -C -C REAL A,ABSERR,ALFA,B,BETA,EPSABS,EPSREL,F,RESULT,WORK -C INTEGER IER,INTEGR,IWORK,LAST,LENW,LIMIT,NEVAL -C DIMENSION IWORK(100),WORK(400) -C EXTERNAL F -C A = 0.0E0 -C B = 1.0E0 -C ALFA = -0.5E0 -C BETA = -0.5E0 -C INTEGR = 1 -C EPSABS = 0.0E0 -C EPSREL = 1.0E-3 -C LIMIT = 100 -C LENW = LIMIT*4 -C CALL QAWS(F,A,B,ALFA,BETA,INTEGR,EPSABS,EPSREL,RESULT, -C * ABSERR,NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) -C C INCLUDE WRITE STATEMENTS -C STOP -C END -C C -C REAL FUNCTION F(X) -C REAL X -C F = SIN(10.0E0*X) -C RETURN -C END -C -C 4.9. Calling Program for QAWC -C ------------------------ -C -C REAL A,ABSERR,B,C,EPSABS,EPSREL,F,RESULT,WORK -C INTEGER IER,IWORK,LAST,LENW,LIMIT,NEVAL -C DIMENSION IWORK(100),WORK(400) -C EXTERNAL F -C A = -1.0E0 -C B = 1.0E0 -C C = 0.5E0 -C EPSABS = 0.0E0 -C EPSREL = 1.0E-3 -C LIMIT = 100 -C LENW = LIMIT*4 -C CALL QAWC(F,A,B,C,EPSABS,EPSREL,RESULT,ABSERR,NEVAL, -C * IER,LIMIT,LENW,LAST,IWORK,WORK) -C C INCLUDE WRITE STATEMENTS -C STOP -C END -C C -C REAL FUNCTION F(X) -C REAL X -C F = 1.0E0/(X*X+1.0E-4) -C RETURN -C END -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 810401 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 900723 PURPOSE section revised. (WRB) -C***END PROLOGUE QPDOC -C***FIRST EXECUTABLE STATEMENT QPDOC - RETURN - END diff --git a/slatec/qpsrt.f b/slatec/qpsrt.f deleted file mode 100644 index 13cadef..0000000 --- a/slatec/qpsrt.f +++ /dev/null @@ -1,147 +0,0 @@ -*DECK QPSRT - SUBROUTINE QPSRT (LIMIT, LAST, MAXERR, ERMAX, ELIST, IORD, NRMAX) -C***BEGIN PROLOGUE QPSRT -C***SUBSIDIARY -C***PURPOSE Subsidiary to QAGE, QAGIE, QAGPE, QAGSE, QAWCE, QAWOE and -C QAWSE -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (QPSRT-S, DQPSRT-D) -C***KEYWORDS SEQUENTIAL SORTING -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C 1. QPSRT -C Ordering Routine -C Standard FORTRAN Subroutine -C REAL Version -C -C 2. PURPOSE -C This routine maintains the descending ordering -C in the list of the local error estimates resulting from -C the interval subdivision process. At each call two error -C estimates are inserted using the sequential search -C method, top-down for the largest error estimate -C and bottom-up for the smallest error estimate. -C -C 3. CALLING SEQUENCE -C CALL QPSRT(LIMIT,LAST,MAXERR,ERMAX,ELIST,IORD,NRMAX) -C -C PARAMETERS (MEANING AT OUTPUT) -C LIMIT - INTEGER -C Maximum number of error estimates the list -C can contain -C -C LAST - INTEGER -C Number of error estimates currently -C in the list -C -C MAXERR - INTEGER -C MAXERR points to the NRMAX-th largest error -C estimate currently in the list -C -C ERMAX - REAL -C NRMAX-th largest error estimate -C ERMAX = ELIST(MAXERR) -C -C ELIST - REAL -C Vector of dimension LAST containing -C the error estimates -C -C IORD - INTEGER -C Vector of dimension LAST, the first K -C elements of which contain pointers -C to the error estimates, such that -C ELIST(IORD(1)),... , ELIST(IORD(K)) -C form a decreasing sequence, with -C K = LAST if LAST.LE.(LIMIT/2+2), and -C K = LIMIT+1-LAST otherwise -C -C NRMAX - INTEGER -C MAXERR = IORD(NRMAX) -C -C***SEE ALSO QAGE, QAGIE, QAGPE, QAGSE, QAWCE, QAWOE, QAWSE -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 800101 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE QPSRT -C - REAL ELIST,ERMAX,ERRMAX,ERRMIN - INTEGER I,IBEG,IDO,IORD,ISUCC,J,JBND,JUPBN,K,LAST,LIMIT,MAXERR, - 1 NRMAX - DIMENSION ELIST(*),IORD(*) -C -C CHECK WHETHER THE LIST CONTAINS MORE THAN -C TWO ERROR ESTIMATES. -C -C***FIRST EXECUTABLE STATEMENT QPSRT - IF(LAST.GT.2) GO TO 10 - IORD(1) = 1 - IORD(2) = 2 - GO TO 90 -C -C THIS PART OF THE ROUTINE IS ONLY EXECUTED -C IF, DUE TO A DIFFICULT INTEGRAND, SUBDIVISION -C INCREASED THE ERROR ESTIMATE. IN THE NORMAL CASE -C THE INSERT PROCEDURE SHOULD START AFTER THE -C NRMAX-TH LARGEST ERROR ESTIMATE. -C - 10 ERRMAX = ELIST(MAXERR) - IF(NRMAX.EQ.1) GO TO 30 - IDO = NRMAX-1 - DO 20 I = 1,IDO - ISUCC = IORD(NRMAX-1) -C ***JUMP OUT OF DO-LOOP - IF(ERRMAX.LE.ELIST(ISUCC)) GO TO 30 - IORD(NRMAX) = ISUCC - NRMAX = NRMAX-1 - 20 CONTINUE -C -C COMPUTE THE NUMBER OF ELEMENTS IN THE LIST TO -C BE MAINTAINED IN DESCENDING ORDER. THIS NUMBER -C DEPENDS ON THE NUMBER OF SUBDIVISIONS STILL -C ALLOWED. -C - 30 JUPBN = LAST - IF(LAST.GT.(LIMIT/2+2)) JUPBN = LIMIT+3-LAST - ERRMIN = ELIST(LAST) -C -C INSERT ERRMAX BY TRAVERSING THE LIST TOP-DOWN, -C STARTING COMPARISON FROM THE ELEMENT ELIST(IORD(NRMAX+1)). -C - JBND = JUPBN-1 - IBEG = NRMAX+1 - IF(IBEG.GT.JBND) GO TO 50 - DO 40 I=IBEG,JBND - ISUCC = IORD(I) -C ***JUMP OUT OF DO-LOOP - IF(ERRMAX.GE.ELIST(ISUCC)) GO TO 60 - IORD(I-1) = ISUCC - 40 CONTINUE - 50 IORD(JBND) = MAXERR - IORD(JUPBN) = LAST - GO TO 90 -C -C INSERT ERRMIN BY TRAVERSING THE LIST BOTTOM-UP. -C - 60 IORD(I-1) = MAXERR - K = JBND - DO 70 J=I,JBND - ISUCC = IORD(K) -C ***JUMP OUT OF DO-LOOP - IF(ERRMIN.LT.ELIST(ISUCC)) GO TO 80 - IORD(K+1) = ISUCC - K = K-1 - 70 CONTINUE - IORD(I) = LAST - GO TO 90 - 80 IORD(K+1) = LAST -C -C SET MAXERR AND ERMAX. -C - 90 MAXERR = IORD(NRMAX) - ERMAX = ELIST(MAXERR) - RETURN - END diff --git a/slatec/qrfac.f b/slatec/qrfac.f deleted file mode 100644 index 296d538..0000000 --- a/slatec/qrfac.f +++ /dev/null @@ -1,170 +0,0 @@ -*DECK QRFAC - SUBROUTINE QRFAC (M, N, A, LDA, PIVOT, IPVT, LIPVT, SIGMA, ACNORM, - + WA) -C***BEGIN PROLOGUE QRFAC -C***SUBSIDIARY -C***PURPOSE Subsidiary to SNLS1, SNLS1E, SNSQ and SNSQE -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (QRFAC-S, DQRFAC-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This subroutine uses Householder transformations with column -C pivoting (optional) to compute a QR factorization of the -C M by N matrix A. That is, QRFAC determines an orthogonal -C matrix Q, a permutation matrix P, and an upper trapezoidal -C matrix R with diagonal elements of nonincreasing magnitude, -C such that A*P = Q*R. The Householder transformation for -C column K, K = 1,2,...,MIN(M,N), is of the form -C -C T -C I - (1/U(K))*U*U -C -C where U has zeros in the first K-1 positions. The form of -C this transformation and the method of pivoting first -C appeared in the corresponding LINPACK subroutine. -C -C The subroutine statement is -C -C SUBROUTINE QRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,SIGMA,ACNORM,WA) -C -C where -C -C M is a positive integer input variable set to the number -C of rows of A. -C -C N is a positive integer input variable set to the number -C of columns of A. -C -C A is an M by N array. On input A contains the matrix for -C which the QR factorization is to be computed. On output -C the strict upper trapezoidal part of A contains the strict -C upper trapezoidal part of R, and the lower trapezoidal -C part of A contains a factored form of Q (the non-trivial -C elements of the U vectors described above). -C -C LDA is a positive integer input variable not less than M -C which specifies the leading dimension of the array A. -C -C PIVOT is a logical input variable. If pivot is set .TRUE., -C then column pivoting is enforced. If pivot is set .FALSE., -C then no column pivoting is done. -C -C IPVT is an integer output array of length LIPVT. IPVT -C defines the permutation matrix P such that A*P = Q*R. -C Column J of P is column IPVT(J) of the identity matrix. -C If pivot is .FALSE., IPVT is not referenced. -C -C LIPVT is a positive integer input variable. If PIVOT is -C .FALSE., then LIPVT may be as small as 1. If PIVOT is -C .TRUE., then LIPVT must be at least N. -C -C SIGMA is an output array of length N which contains the -C diagonal elements of R. -C -C ACNORM is an output array of length N which contains the -C norms of the corresponding columns of the input matrix A. -C If this information is not needed, then ACNORM can coincide -C with SIGMA. -C -C WA is a work array of length N. If pivot is .FALSE., then WA -C can coincide with SIGMA. -C -C***SEE ALSO SNLS1, SNLS1E, SNSQ, SNSQE -C***ROUTINES CALLED ENORM, R1MACH -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE QRFAC - INTEGER M,N,LDA,LIPVT - INTEGER IPVT(*) - LOGICAL PIVOT - REAL A(LDA,*),SIGMA(*),ACNORM(*),WA(*) - INTEGER I,J,JP1,K,KMAX,MINMN - REAL AJNORM,EPSMCH,ONE,P05,SUM,TEMP,ZERO - REAL R1MACH,ENORM - SAVE ONE, P05, ZERO - DATA ONE,P05,ZERO /1.0E0,5.0E-2,0.0E0/ -C***FIRST EXECUTABLE STATEMENT QRFAC - EPSMCH = R1MACH(4) -C -C COMPUTE THE INITIAL COLUMN NORMS AND INITIALIZE SEVERAL ARRAYS. -C - DO 10 J = 1, N - ACNORM(J) = ENORM(M,A(1,J)) - SIGMA(J) = ACNORM(J) - WA(J) = SIGMA(J) - IF (PIVOT) IPVT(J) = J - 10 CONTINUE -C -C REDUCE A TO R WITH HOUSEHOLDER TRANSFORMATIONS. -C - MINMN = MIN(M,N) - DO 110 J = 1, MINMN - IF (.NOT.PIVOT) GO TO 40 -C -C BRING THE COLUMN OF LARGEST NORM INTO THE PIVOT POSITION. -C - KMAX = J - DO 20 K = J, N - IF (SIGMA(K) .GT. SIGMA(KMAX)) KMAX = K - 20 CONTINUE - IF (KMAX .EQ. J) GO TO 40 - DO 30 I = 1, M - TEMP = A(I,J) - A(I,J) = A(I,KMAX) - A(I,KMAX) = TEMP - 30 CONTINUE - SIGMA(KMAX) = SIGMA(J) - WA(KMAX) = WA(J) - K = IPVT(J) - IPVT(J) = IPVT(KMAX) - IPVT(KMAX) = K - 40 CONTINUE -C -C COMPUTE THE HOUSEHOLDER TRANSFORMATION TO REDUCE THE -C J-TH COLUMN OF A TO A MULTIPLE OF THE J-TH UNIT VECTOR. -C - AJNORM = ENORM(M-J+1,A(J,J)) - IF (AJNORM .EQ. ZERO) GO TO 100 - IF (A(J,J) .LT. ZERO) AJNORM = -AJNORM - DO 50 I = J, M - A(I,J) = A(I,J)/AJNORM - 50 CONTINUE - A(J,J) = A(J,J) + ONE -C -C APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS -C AND UPDATE THE NORMS. -C - JP1 = J + 1 - IF (N .LT. JP1) GO TO 100 - DO 90 K = JP1, N - SUM = ZERO - DO 60 I = J, M - SUM = SUM + A(I,J)*A(I,K) - 60 CONTINUE - TEMP = SUM/A(J,J) - DO 70 I = J, M - A(I,K) = A(I,K) - TEMP*A(I,J) - 70 CONTINUE - IF (.NOT.PIVOT .OR. SIGMA(K) .EQ. ZERO) GO TO 80 - TEMP = A(J,K)/SIGMA(K) - SIGMA(K) = SIGMA(K)*SQRT(MAX(ZERO,ONE-TEMP**2)) - IF (P05*(SIGMA(K)/WA(K))**2 .GT. EPSMCH) GO TO 80 - SIGMA(K) = ENORM(M-J,A(JP1,K)) - WA(K) = SIGMA(K) - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - SIGMA(J) = -AJNORM - 110 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE QRFAC. -C - END diff --git a/slatec/qrsolv.f b/slatec/qrsolv.f deleted file mode 100644 index 813c247..0000000 --- a/slatec/qrsolv.f +++ /dev/null @@ -1,198 +0,0 @@ -*DECK QRSOLV - SUBROUTINE QRSOLV (N, R, LDR, IPVT, DIAG, QTB, X, SIGMA, WA) -C***BEGIN PROLOGUE QRSOLV -C***SUBSIDIARY -C***PURPOSE Subsidiary to SNLS1 and SNLS1E -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (QRSOLV-S, DQRSLV-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Given an M by N matrix A, an N by N diagonal matrix D, -C and an M-vector B, the problem is to determine an X which -C solves the system -C -C A*X = B , D*X = 0 , -C -C in the least squares sense. -C -C This subroutine completes the solution of the problem -C if it is provided with the necessary information from the -C QR factorization, with column pivoting, of A. That is, if -C A*P = Q*R, where P is a permutation matrix, Q has orthogonal -C columns, and R is an upper triangular matrix with diagonal -C elements of nonincreasing magnitude, then QRSOLV expects -C the full upper triangle of R, the permutation matrix P, -C and the first N components of (Q TRANSPOSE)*B. The system -C A*X = B, D*X = 0, is then equivalent to -C -C T T -C R*Z = Q *B , P *D*P*Z = 0 , -C -C where X = P*Z. If this system does not have full rank, -C then a least squares solution is obtained. On output QRSOLV -C also provides an upper triangular matrix S such that -C -C T T T -C P *(A *A + D*D)*P = S *S . -C -C S is computed within QRSOLV and may be of separate interest. -C -C The subroutine statement is -C -C SUBROUTINE QRSOLV(N,R,LDR,IPVT,DIAG,QTB,X,SIGMA,WA) -C -C where -C -C N is a positive integer input variable set to the order of R. -C -C R is an N by N array. On input the full upper triangle -C must contain the full upper triangle of the matrix R. -C On output the full upper triangle is unaltered, and the -C strict lower triangle contains the strict upper triangle -C (transposed) of the upper triangular matrix S. -C -C LDR is a positive integer input variable not less than N -C which specifies the leading dimension of the array R. -C -C IPVT is an integer input array of length N which defines the -C permutation matrix P such that A*P = Q*R. Column J of P -C is column IPVT(J) of the identity matrix. -C -C DIAG is an input array of length N which must contain the -C diagonal elements of the matrix D. -C -C QTB is an input array of length N which must contain the first -C N elements of the vector (Q TRANSPOSE)*B. -C -C X is an output array of length N which contains the least -C squares solution of the system A*X = B, D*X = 0. -C -C SIGMA is an output array of length N which contains the -C diagonal elements of the upper triangular matrix S. -C -C WA is a work array of length N. -C -C***SEE ALSO SNLS1, SNLS1E -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE QRSOLV - INTEGER N,LDR - INTEGER IPVT(*) - REAL R(LDR,*),DIAG(*),QTB(*),X(*),SIGMA(*),WA(*) - INTEGER I,J,JP1,K,KP1,L,NSING - REAL COS,COTAN,P5,P25,QTBPJ,SIN,SUM,TAN,TEMP,ZERO - SAVE P5, P25, ZERO - DATA P5,P25,ZERO /5.0E-1,2.5E-1,0.0E0/ -C***FIRST EXECUTABLE STATEMENT QRSOLV - DO 20 J = 1, N - DO 10 I = J, N - R(I,J) = R(J,I) - 10 CONTINUE - X(J) = R(J,J) - WA(J) = QTB(J) - 20 CONTINUE -C -C ELIMINATE THE DIAGONAL MATRIX D USING A GIVENS ROTATION. -C - DO 100 J = 1, N -C -C PREPARE THE ROW OF D TO BE ELIMINATED, LOCATING THE -C DIAGONAL ELEMENT USING P FROM THE QR FACTORIZATION. -C - L = IPVT(J) - IF (DIAG(L) .EQ. ZERO) GO TO 90 - DO 30 K = J, N - SIGMA(K) = ZERO - 30 CONTINUE - SIGMA(J) = DIAG(L) -C -C THE TRANSFORMATIONS TO ELIMINATE THE ROW OF D -C MODIFY ONLY A SINGLE ELEMENT OF (Q TRANSPOSE)*B -C BEYOND THE FIRST N, WHICH IS INITIALLY ZERO. -C - QTBPJ = ZERO - DO 80 K = J, N -C -C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE -C APPROPRIATE ELEMENT IN THE CURRENT ROW OF D. -C - IF (SIGMA(K) .EQ. ZERO) GO TO 70 - IF (ABS(R(K,K)) .GE. ABS(SIGMA(K))) GO TO 40 - COTAN = R(K,K)/SIGMA(K) - SIN = P5/SQRT(P25+P25*COTAN**2) - COS = SIN*COTAN - GO TO 50 - 40 CONTINUE - TAN = SIGMA(K)/R(K,K) - COS = P5/SQRT(P25+P25*TAN**2) - SIN = COS*TAN - 50 CONTINUE -C -C COMPUTE THE MODIFIED DIAGONAL ELEMENT OF R AND -C THE MODIFIED ELEMENT OF ((Q TRANSPOSE)*B,0). -C - R(K,K) = COS*R(K,K) + SIN*SIGMA(K) - TEMP = COS*WA(K) + SIN*QTBPJ - QTBPJ = -SIN*WA(K) + COS*QTBPJ - WA(K) = TEMP -C -C ACCUMULATE THE TRANSFORMATION IN THE ROW OF S. -C - KP1 = K + 1 - IF (N .LT. KP1) GO TO 70 - DO 60 I = KP1, N - TEMP = COS*R(I,K) + SIN*SIGMA(I) - SIGMA(I) = -SIN*R(I,K) + COS*SIGMA(I) - R(I,K) = TEMP - 60 CONTINUE - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE -C -C STORE THE DIAGONAL ELEMENT OF S AND RESTORE -C THE CORRESPONDING DIAGONAL ELEMENT OF R. -C - SIGMA(J) = R(J,J) - R(J,J) = X(J) - 100 CONTINUE -C -C SOLVE THE TRIANGULAR SYSTEM FOR Z. IF THE SYSTEM IS -C SINGULAR, THEN OBTAIN A LEAST SQUARES SOLUTION. -C - NSING = N - DO 110 J = 1, N - IF (SIGMA(J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1 - IF (NSING .LT. N) WA(J) = ZERO - 110 CONTINUE - IF (NSING .LT. 1) GO TO 150 - DO 140 K = 1, NSING - J = NSING - K + 1 - SUM = ZERO - JP1 = J + 1 - IF (NSING .LT. JP1) GO TO 130 - DO 120 I = JP1, NSING - SUM = SUM + R(I,J)*WA(I) - 120 CONTINUE - 130 CONTINUE - WA(J) = (WA(J) - SUM)/SIGMA(J) - 140 CONTINUE - 150 CONTINUE -C -C PERMUTE THE COMPONENTS OF Z BACK TO COMPONENTS OF X. -C - DO 160 J = 1, N - L = IPVT(J) - X(L) = WA(J) - 160 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE QRSOLV. -C - END diff --git a/slatec/qs2i1d.f b/slatec/qs2i1d.f deleted file mode 100644 index 7153e33..0000000 --- a/slatec/qs2i1d.f +++ /dev/null @@ -1,253 +0,0 @@ -*DECK QS2I1D - SUBROUTINE QS2I1D (IA, JA, A, N, KFLAG) -C***BEGIN PROLOGUE QS2I1D -C***SUBSIDIARY -C***PURPOSE Sort an integer array, moving an integer and DP array. -C This routine sorts the integer array IA and makes the same -C interchanges in the integer array JA and the double pre- -C cision array A. The array IA may be sorted in increasing -C order or decreasing order. A slightly modified QUICKSORT -C algorithm is used. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY N6A2A -C***TYPE DOUBLE PRECISION (QS2I1R-S, QS2I1D-D) -C***KEYWORDS SINGLETON QUICKSORT, SLAP, SORT, SORTING -C***AUTHOR Jones, R. E., (SNLA) -C Kahaner, D. K., (NBS) -C Seager, M. K., (LLNL) seager@llnl.gov -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C Written by Rondall E Jones -C Modified by John A. Wisniewski to use the Singleton QUICKSORT -C algorithm. date 18 November 1976. -C -C Further modified by David K. Kahaner -C National Bureau of Standards -C August, 1981 -C -C Even further modification made to bring the code up to the -C Fortran 77 level and make it more readable and to carry -C along one integer array and one double precision array during -C the sort by -C Mark K. Seager -C Lawrence Livermore National Laboratory -C November, 1987 -C This routine was adapted from the ISORT routine. -C -C ABSTRACT -C This routine sorts an integer array IA and makes the same -C interchanges in the integer array JA and the double precision -C array A. -C The array IA may be sorted in increasing order or decreasing -C order. A slightly modified quicksort algorithm is used. -C -C DESCRIPTION OF PARAMETERS -C IA - Integer array of values to be sorted. -C JA - Integer array to be carried along. -C A - Double Precision array to be carried along. -C N - Number of values in integer array IA to be sorted. -C KFLAG - Control parameter -C = 1 means sort IA in INCREASING order. -C =-1 means sort IA in DECREASING order. -C -C***SEE ALSO DS2Y -C***REFERENCES R. C. Singleton, Algorithm 347, An Efficient Algorithm -C for Sorting With Minimal Storage, Communications ACM -C 12:3 (1969), pp.185-7. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 761118 DATE WRITTEN -C 890125 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 900805 Changed XERROR calls to calls to XERMSG. (RWC) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910506 Made subsidiary to DS2Y and corrected reference. (FNF) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of reference. (FNF) -C 921012 Corrected all f.p. constants to double precision. (FNF) -C***END PROLOGUE QS2I1D -CVD$R NOVECTOR -CVD$R NOCONCUR -C .. Scalar Arguments .. - INTEGER KFLAG, N -C .. Array Arguments .. - DOUBLE PRECISION A(N) - INTEGER IA(N), JA(N) -C .. Local Scalars .. - DOUBLE PRECISION R, TA, TTA - INTEGER I, IIT, IJ, IT, J, JJT, JT, K, KK, L, M, NN -C .. Local Arrays .. - INTEGER IL(21), IU(21) -C .. External Subroutines .. - EXTERNAL XERMSG -C .. Intrinsic Functions .. - INTRINSIC ABS, INT -C***FIRST EXECUTABLE STATEMENT QS2I1D - NN = N - IF (NN.LT.1) THEN - CALL XERMSG ('SLATEC', 'QS2I1D', - $ 'The number of values to be sorted was not positive.', 1, 1) - RETURN - ENDIF - IF( N.EQ.1 ) RETURN - KK = ABS(KFLAG) - IF ( KK.NE.1 ) THEN - CALL XERMSG ('SLATEC', 'QS2I1D', - $ 'The sort control parameter, K, was not 1 or -1.', 2, 1) - RETURN - ENDIF -C -C Alter array IA to get decreasing order if needed. -C - IF( KFLAG.LT.1 ) THEN - DO 20 I=1,NN - IA(I) = -IA(I) - 20 CONTINUE - ENDIF -C -C Sort IA and carry JA and A along. -C And now...Just a little black magic... - M = 1 - I = 1 - J = NN - R = .375D0 - 210 IF( R.LE.0.5898437D0 ) THEN - R = R + 3.90625D-2 - ELSE - R = R-.21875D0 - ENDIF - 225 K = I -C -C Select a central element of the array and save it in location -C it, jt, at. -C - IJ = I + INT ((J-I)*R) - IT = IA(IJ) - JT = JA(IJ) - TA = A(IJ) -C -C If first element of array is greater than it, interchange with it. -C - IF( IA(I).GT.IT ) THEN - IA(IJ) = IA(I) - IA(I) = IT - IT = IA(IJ) - JA(IJ) = JA(I) - JA(I) = JT - JT = JA(IJ) - A(IJ) = A(I) - A(I) = TA - TA = A(IJ) - ENDIF - L=J -C -C If last element of array is less than it, swap with it. -C - IF( IA(J).LT.IT ) THEN - IA(IJ) = IA(J) - IA(J) = IT - IT = IA(IJ) - JA(IJ) = JA(J) - JA(J) = JT - JT = JA(IJ) - A(IJ) = A(J) - A(J) = TA - TA = A(IJ) -C -C If first element of array is greater than it, swap with it. -C - IF ( IA(I).GT.IT ) THEN - IA(IJ) = IA(I) - IA(I) = IT - IT = IA(IJ) - JA(IJ) = JA(I) - JA(I) = JT - JT = JA(IJ) - A(IJ) = A(I) - A(I) = TA - TA = A(IJ) - ENDIF - ENDIF -C -C Find an element in the second half of the array which is -C smaller than it. -C - 240 L=L-1 - IF( IA(L).GT.IT ) GO TO 240 -C -C Find an element in the first half of the array which is -C greater than it. -C - 245 K=K+1 - IF( IA(K).LT.IT ) GO TO 245 -C -C Interchange these elements. -C - IF( K.LE.L ) THEN - IIT = IA(L) - IA(L) = IA(K) - IA(K) = IIT - JJT = JA(L) - JA(L) = JA(K) - JA(K) = JJT - TTA = A(L) - A(L) = A(K) - A(K) = TTA - GOTO 240 - ENDIF -C -C Save upper and lower subscripts of the array yet to be sorted. -C - IF( L-I.GT.J-K ) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 260 -C -C Begin again on another portion of the unsorted array. -C - 255 M = M-1 - IF( M.EQ.0 ) GO TO 300 - I = IL(M) - J = IU(M) - 260 IF( J-I.GE.1 ) GO TO 225 - IF( I.EQ.J ) GO TO 255 - IF( I.EQ.1 ) GO TO 210 - I = I-1 - 265 I = I+1 - IF( I.EQ.J ) GO TO 255 - IT = IA(I+1) - JT = JA(I+1) - TA = A(I+1) - IF( IA(I).LE.IT ) GO TO 265 - K=I - 270 IA(K+1) = IA(K) - JA(K+1) = JA(K) - A(K+1) = A(K) - K = K-1 - IF( IT.LT.IA(K) ) GO TO 270 - IA(K+1) = IT - JA(K+1) = JT - A(K+1) = TA - GO TO 265 -C -C Clean up, if necessary. -C - 300 IF( KFLAG.LT.1 ) THEN - DO 310 I=1,NN - IA(I) = -IA(I) - 310 CONTINUE - ENDIF - RETURN -C------------- LAST LINE OF QS2I1D FOLLOWS ---------------------------- - END diff --git a/slatec/qs2i1r.f b/slatec/qs2i1r.f deleted file mode 100644 index f956223..0000000 --- a/slatec/qs2i1r.f +++ /dev/null @@ -1,251 +0,0 @@ -*DECK QS2I1R - SUBROUTINE QS2I1R (IA, JA, A, N, KFLAG) -C***BEGIN PROLOGUE QS2I1R -C***SUBSIDIARY -C***PURPOSE Sort an integer array, moving an integer and real array. -C This routine sorts the integer array IA and makes the same -C interchanges in the integer array JA and the real array A. -C The array IA may be sorted in increasing order or decreas- -C ing order. A slightly modified QUICKSORT algorithm is -C used. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY N6A2A -C***TYPE SINGLE PRECISION (QS2I1R-S, QS2I1D-D) -C***KEYWORDS SINGLETON QUICKSORT, SLAP, SORT, SORTING -C***AUTHOR Jones, R. E., (SNLA) -C Kahaner, D. K., (NBS) -C Seager, M. K., (LLNL) seager@llnl.gov -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C Written by Rondall E Jones -C Modified by John A. Wisniewski to use the Singleton QUICKSORT -C algorithm. date 18 November 1976. -C -C Further modified by David K. Kahaner -C National Bureau of Standards -C August, 1981 -C -C Even further modification made to bring the code up to the -C Fortran 77 level and make it more readable and to carry -C along one integer array and one real array during the sort by -C Mark K. Seager -C Lawrence Livermore National Laboratory -C November, 1987 -C This routine was adapted from the ISORT routine. -C -C ABSTRACT -C This routine sorts an integer array IA and makes the same -C interchanges in the integer array JA and the real array A. -C The array IA may be sorted in increasing order or decreasing -C order. A slightly modified quicksort algorithm is used. -C -C DESCRIPTION OF PARAMETERS -C IA - Integer array of values to be sorted. -C JA - Integer array to be carried along. -C A - Real array to be carried along. -C N - Number of values in integer array IA to be sorted. -C KFLAG - Control parameter -C = 1 means sort IA in INCREASING order. -C =-1 means sort IA in DECREASING order. -C -C***SEE ALSO SS2Y -C***REFERENCES R. C. Singleton, Algorithm 347, An Efficient Algorithm -C for Sorting With Minimal Storage, Communications ACM -C 12:3 (1969), pp.185-7. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 761118 DATE WRITTEN -C 890125 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 900805 Changed XERROR calls to calls to XERMSG. (RWC) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910506 Made subsidiary to SS2Y and corrected reference. (FNF) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of reference. (FNF) -C 921012 Added E0's to f.p. constants. (FNF) -C***END PROLOGUE QS2I1R -CVD$R NOVECTOR -CVD$R NOCONCUR -C .. Scalar Arguments .. - INTEGER KFLAG, N -C .. Array Arguments .. - REAL A(N) - INTEGER IA(N), JA(N) -C .. Local Scalars .. - REAL R, TA, TTA - INTEGER I, IIT, IJ, IT, J, JJT, JT, K, KK, L, M, NN -C .. Local Arrays .. - INTEGER IL(21), IU(21) -C .. External Subroutines .. - EXTERNAL XERMSG -C .. Intrinsic Functions .. - INTRINSIC ABS, INT -C***FIRST EXECUTABLE STATEMENT QS2I1R - NN = N - IF (NN.LT.1) THEN - CALL XERMSG ('SLATEC', 'QS2I1R', - $ 'The number of values to be sorted was not positive.', 1, 1) - RETURN - ENDIF - IF( N.EQ.1 ) RETURN - KK = ABS(KFLAG) - IF ( KK.NE.1 ) THEN - CALL XERMSG ('SLATEC', 'QS2I1R', - $ 'The sort control parameter, K, was not 1 or -1.', 2, 1) - RETURN - ENDIF -C -C Alter array IA to get decreasing order if needed. -C - IF( KFLAG.LT.1 ) THEN - DO 20 I=1,NN - IA(I) = -IA(I) - 20 CONTINUE - ENDIF -C -C Sort IA and carry JA and A along. -C And now...Just a little black magic... - M = 1 - I = 1 - J = NN - R = .375E0 - 210 IF( R.LE.0.5898437E0 ) THEN - R = R + 3.90625E-2 - ELSE - R = R-.21875E0 - ENDIF - 225 K = I -C -C Select a central element of the array and save it in location -C it, jt, at. -C - IJ = I + INT ((J-I)*R) - IT = IA(IJ) - JT = JA(IJ) - TA = A(IJ) -C -C If first element of array is greater than it, interchange with it. -C - IF( IA(I).GT.IT ) THEN - IA(IJ) = IA(I) - IA(I) = IT - IT = IA(IJ) - JA(IJ) = JA(I) - JA(I) = JT - JT = JA(IJ) - A(IJ) = A(I) - A(I) = TA - TA = A(IJ) - ENDIF - L=J -C -C If last element of array is less than it, swap with it. -C - IF( IA(J).LT.IT ) THEN - IA(IJ) = IA(J) - IA(J) = IT - IT = IA(IJ) - JA(IJ) = JA(J) - JA(J) = JT - JT = JA(IJ) - A(IJ) = A(J) - A(J) = TA - TA = A(IJ) -C -C If first element of array is greater than it, swap with it. -C - IF ( IA(I).GT.IT ) THEN - IA(IJ) = IA(I) - IA(I) = IT - IT = IA(IJ) - JA(IJ) = JA(I) - JA(I) = JT - JT = JA(IJ) - A(IJ) = A(I) - A(I) = TA - TA = A(IJ) - ENDIF - ENDIF -C -C Find an element in the second half of the array which is -C smaller than it. -C - 240 L=L-1 - IF( IA(L).GT.IT ) GO TO 240 -C -C Find an element in the first half of the array which is -C greater than it. -C - 245 K=K+1 - IF( IA(K).LT.IT ) GO TO 245 -C -C Interchange these elements. -C - IF( K.LE.L ) THEN - IIT = IA(L) - IA(L) = IA(K) - IA(K) = IIT - JJT = JA(L) - JA(L) = JA(K) - JA(K) = JJT - TTA = A(L) - A(L) = A(K) - A(K) = TTA - GOTO 240 - ENDIF -C -C Save upper and lower subscripts of the array yet to be sorted. -C - IF( L-I.GT.J-K ) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 260 -C -C Begin again on another portion of the unsorted array. -C - 255 M = M-1 - IF( M.EQ.0 ) GO TO 300 - I = IL(M) - J = IU(M) - 260 IF( J-I.GE.1 ) GO TO 225 - IF( I.EQ.J ) GO TO 255 - IF( I.EQ.1 ) GO TO 210 - I = I-1 - 265 I = I+1 - IF( I.EQ.J ) GO TO 255 - IT = IA(I+1) - JT = JA(I+1) - TA = A(I+1) - IF( IA(I).LE.IT ) GO TO 265 - K=I - 270 IA(K+1) = IA(K) - JA(K+1) = JA(K) - A(K+1) = A(K) - K = K-1 - IF( IT.LT.IA(K) ) GO TO 270 - IA(K+1) = IT - JA(K+1) = JT - A(K+1) = TA - GO TO 265 -C -C Clean up, if necessary. -C - 300 IF( KFLAG.LT.1 ) THEN - DO 310 I=1,NN - IA(I) = -IA(I) - 310 CONTINUE - ENDIF - RETURN -C------------- LAST LINE OF QS2I1R FOLLOWS ---------------------------- - END diff --git a/slatec/qwgtc.f b/slatec/qwgtc.f deleted file mode 100644 index ad42501..0000000 --- a/slatec/qwgtc.f +++ /dev/null @@ -1,30 +0,0 @@ -*DECK QWGTC - REAL FUNCTION QWGTC (X, C, P2, P3, P4, KP) -C***BEGIN PROLOGUE QWGTC -C***SUBSIDIARY -C***PURPOSE This function subprogram is used together with the -C routine QAWC and defines the WEIGHT function. -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (QWGTC-S, DQWGTC-D) -C***KEYWORDS CAUCHY PRINCIPAL VALUE, WEIGHT FUNCTION -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***SEE ALSO QK15W -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 810101 DATE WRITTEN -C 830518 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE QWGTC -C - REAL C,P2,P3,P4,X - INTEGER KP -C***FIRST EXECUTABLE STATEMENT QWGTC - QWGTC = 0.1E+01/(X-C) - RETURN - END diff --git a/slatec/qwgtf.f b/slatec/qwgtf.f deleted file mode 100644 index 6b13e9e..0000000 --- a/slatec/qwgtf.f +++ /dev/null @@ -1,34 +0,0 @@ -*DECK QWGTF - REAL FUNCTION QWGTF (X, OMEGA, P2, P3, P4, INTEGR) -C***BEGIN PROLOGUE QWGTF -C***SUBSIDIARY -C***PURPOSE This function subprogram is used together with the -C routine QAWF and defines the WEIGHT function. -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (QWGTF-S, DQWGTF-D) -C***KEYWORDS COS OR SIN IN WEIGHT FUNCTION -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***SEE ALSO QK15W -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 810101 DATE WRITTEN -C 830518 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE QWGTF -C - REAL OMEGA,OMX,P2,P3,P4,X - INTEGER INTEGR -C***FIRST EXECUTABLE STATEMENT QWGTF - OMX = OMEGA*X - GO TO(10,20),INTEGR - 10 QWGTF = COS(OMX) - GO TO 30 - 20 QWGTF = SIN(OMX) - 30 RETURN - END diff --git a/slatec/qwgts.f b/slatec/qwgts.f deleted file mode 100644 index c9dc7ab..0000000 --- a/slatec/qwgts.f +++ /dev/null @@ -1,40 +0,0 @@ -*DECK QWGTS - REAL FUNCTION QWGTS (X, A, B, ALFA, BETA, INTEGR) -C***BEGIN PROLOGUE QWGTS -C***SUBSIDIARY -C***PURPOSE This function subprogram is used together with the -C routine QAWS and defines the WEIGHT function. -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (QWGTS-S, DQWGTS-D) -C***KEYWORDS ALGEBRAICO-LOGARITHMIC, END POINT SINGULARITIES, -C WEIGHT FUNCTION -C***AUTHOR Piessens, Robert -C Applied Mathematics and Programming Division -C K. U. Leuven -C de Doncker, Elise -C Applied Mathematics and Programming Division -C K. U. Leuven -C***SEE ALSO QK15W -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 810101 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 900328 Added TYPE section. (WRB) -C***END PROLOGUE QWGTS -C - REAL A,ALFA,B,BETA,BMX,X,XMA - INTEGER INTEGR -C***FIRST EXECUTABLE STATEMENT QWGTS - XMA = X-A - BMX = B-X - QWGTS = XMA**ALFA*BMX**BETA - GO TO (40,10,20,30),INTEGR - 10 QWGTS = QWGTS*LOG(XMA) - GO TO 40 - 20 QWGTS = QWGTS*LOG(BMX) - GO TO 40 - 30 QWGTS = QWGTS*LOG(XMA)*LOG(BMX) - 40 RETURN - END diff --git a/slatec/qzhes.f b/slatec/qzhes.f deleted file mode 100644 index 3c19826..0000000 --- a/slatec/qzhes.f +++ /dev/null @@ -1,224 +0,0 @@ -*DECK QZHES - SUBROUTINE QZHES (NM, N, A, B, MATZ, Z) -C***BEGIN PROLOGUE QZHES -C***PURPOSE The first step of the QZ algorithm for solving generalized -C matrix eigenproblems. Accepts a pair of real general -C matrices and reduces one of them to upper Hessenberg -C and the other to upper triangular form using orthogonal -C transformations. Usually followed by QZIT, QZVAL, QZVEC. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C1B3 -C***TYPE SINGLE PRECISION (QZHES-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is the first step of the QZ algorithm -C for solving generalized matrix eigenvalue problems, -C SIAM J. NUMER. ANAL. 10, 241-256(1973) by MOLER and STEWART. -C -C This subroutine accepts a pair of REAL GENERAL matrices and -C reduces one of them to upper Hessenberg form and the other -C to upper triangular form using orthogonal transformations. -C It is usually followed by QZIT, QZVAL and, possibly, QZVEC. -C -C On Input -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, A, B, and Z, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrices A and B. N is an INTEGER -C variable. N must be less than or equal to NM. -C -C A contains a real general matrix. A is a two-dimensional -C REAL array, dimensioned A(NM,N). -C -C B contains a real general matrix. B is a two-dimensional -C REAL array, dimensioned B(NM,N). -C -C MATZ should be set to .TRUE. if the right hand transformations -C are to be accumulated for later use in computing -C eigenvectors, and to .FALSE. otherwise. MATZ is a LOGICAL -C variable. -C -C On Output -C -C A has been reduced to upper Hessenberg form. The elements -C below the first subdiagonal have been set to zero. -C -C B has been reduced to upper triangular form. The elements -C below the main diagonal have been set to zero. -C -C Z contains the product of the right hand transformations if -C MATZ has been set to .TRUE. Otherwise, Z is not referenced. -C Z is a two-dimensional REAL array, dimensioned Z(NM,N). -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE QZHES -C - INTEGER I,J,K,L,N,LB,L1,NM,NK1,NM1,NM2 - REAL A(NM,*),B(NM,*),Z(NM,*) - REAL R,S,T,U1,U2,V1,V2,RHO - LOGICAL MATZ -C -C .......... INITIALIZE Z .......... -C***FIRST EXECUTABLE STATEMENT QZHES - IF (.NOT. MATZ) GO TO 10 -C - DO 3 I = 1, N -C - DO 2 J = 1, N - Z(I,J) = 0.0E0 - 2 CONTINUE -C - Z(I,I) = 1.0E0 - 3 CONTINUE -C .......... REDUCE B TO UPPER TRIANGULAR FORM .......... - 10 IF (N .LE. 1) GO TO 170 - NM1 = N - 1 -C - DO 100 L = 1, NM1 - L1 = L + 1 - S = 0.0E0 -C - DO 20 I = L1, N - S = S + ABS(B(I,L)) - 20 CONTINUE -C - IF (S .EQ. 0.0E0) GO TO 100 - S = S + ABS(B(L,L)) - R = 0.0E0 -C - DO 25 I = L, N - B(I,L) = B(I,L) / S - R = R + B(I,L)**2 - 25 CONTINUE -C - R = SIGN(SQRT(R),B(L,L)) - B(L,L) = B(L,L) + R - RHO = R * B(L,L) -C - DO 50 J = L1, N - T = 0.0E0 -C - DO 30 I = L, N - T = T + B(I,L) * B(I,J) - 30 CONTINUE -C - T = -T / RHO -C - DO 40 I = L, N - B(I,J) = B(I,J) + T * B(I,L) - 40 CONTINUE -C - 50 CONTINUE -C - DO 80 J = 1, N - T = 0.0E0 -C - DO 60 I = L, N - T = T + B(I,L) * A(I,J) - 60 CONTINUE -C - T = -T / RHO -C - DO 70 I = L, N - A(I,J) = A(I,J) + T * B(I,L) - 70 CONTINUE -C - 80 CONTINUE -C - B(L,L) = -S * R -C - DO 90 I = L1, N - B(I,L) = 0.0E0 - 90 CONTINUE -C - 100 CONTINUE -C .......... REDUCE A TO UPPER HESSENBERG FORM, WHILE -C KEEPING B TRIANGULAR .......... - IF (N .EQ. 2) GO TO 170 - NM2 = N - 2 -C - DO 160 K = 1, NM2 - NK1 = NM1 - K -C .......... FOR L=N-1 STEP -1 UNTIL K+1 DO -- .......... - DO 150 LB = 1, NK1 - L = N - LB - L1 = L + 1 -C .......... ZERO A(L+1,K) .......... - S = ABS(A(L,K)) + ABS(A(L1,K)) - IF (S .EQ. 0.0E0) GO TO 150 - U1 = A(L,K) / S - U2 = A(L1,K) / S - R = SIGN(SQRT(U1*U1+U2*U2),U1) - V1 = -(U1 + R) / R - V2 = -U2 / R - U2 = V2 / V1 -C - DO 110 J = K, N - T = A(L,J) + U2 * A(L1,J) - A(L,J) = A(L,J) + T * V1 - A(L1,J) = A(L1,J) + T * V2 - 110 CONTINUE -C - A(L1,K) = 0.0E0 -C - DO 120 J = L, N - T = B(L,J) + U2 * B(L1,J) - B(L,J) = B(L,J) + T * V1 - B(L1,J) = B(L1,J) + T * V2 - 120 CONTINUE -C .......... ZERO B(L+1,L) .......... - S = ABS(B(L1,L1)) + ABS(B(L1,L)) - IF (S .EQ. 0.0E0) GO TO 150 - U1 = B(L1,L1) / S - U2 = B(L1,L) / S - R = SIGN(SQRT(U1*U1+U2*U2),U1) - V1 = -(U1 + R) / R - V2 = -U2 / R - U2 = V2 / V1 -C - DO 130 I = 1, L1 - T = B(I,L1) + U2 * B(I,L) - B(I,L1) = B(I,L1) + T * V1 - B(I,L) = B(I,L) + T * V2 - 130 CONTINUE -C - B(L1,L) = 0.0E0 -C - DO 140 I = 1, N - T = A(I,L1) + U2 * A(I,L) - A(I,L1) = A(I,L1) + T * V1 - A(I,L) = A(I,L) + T * V2 - 140 CONTINUE -C - IF (.NOT. MATZ) GO TO 150 -C - DO 145 I = 1, N - T = Z(I,L1) + U2 * Z(I,L) - Z(I,L1) = Z(I,L1) + T * V1 - Z(I,L) = Z(I,L) + T * V2 - 145 CONTINUE -C - 150 CONTINUE -C - 160 CONTINUE -C - 170 RETURN - END diff --git a/slatec/qzit.f b/slatec/qzit.f deleted file mode 100644 index 667ade1..0000000 --- a/slatec/qzit.f +++ /dev/null @@ -1,387 +0,0 @@ -*DECK QZIT - SUBROUTINE QZIT (NM, N, A, B, EPS1, MATZ, Z, IERR) -C***BEGIN PROLOGUE QZIT -C***PURPOSE The second step of the QZ algorithm for generalized -C eigenproblems. Accepts an upper Hessenberg and an upper -C triangular matrix and reduces the former to -C quasi-triangular form while preserving the form of the -C latter. Usually preceded by QZHES and followed by QZVAL -C and QZVEC. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C1B3 -C***TYPE SINGLE PRECISION (QZIT-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is the second step of the QZ algorithm -C for solving generalized matrix eigenvalue problems, -C SIAM J. NUMER. ANAL. 10, 241-256(1973) by MOLER and STEWART, -C as modified in technical note NASA TN D-7305(1973) by WARD. -C -C This subroutine accepts a pair of REAL matrices, one of them -C in upper Hessenberg form and the other in upper triangular form. -C It reduces the Hessenberg matrix to quasi-triangular form using -C orthogonal transformations while maintaining the triangular form -C of the other matrix. It is usually preceded by QZHES and -C followed by QZVAL and, possibly, QZVEC. -C -C On Input -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, A, B, and Z, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrices A and B. N is an INTEGER -C variable. N must be less than or equal to NM. -C -C A contains a real upper Hessenberg matrix. A is a two- -C dimensional REAL array, dimensioned A(NM,N). -C -C B contains a real upper triangular matrix. B is a two- -C dimensional REAL array, dimensioned B(NM,N). -C -C EPS1 is a tolerance used to determine negligible elements. -C EPS1 = 0.0 (or negative) may be input, in which case an -C element will be neglected only if it is less than roundoff -C error times the norm of its matrix. If the input EPS1 is -C positive, then an element will be considered negligible -C if it is less than EPS1 times the norm of its matrix. A -C positive value of EPS1 may result in faster execution, -C but less accurate results. EPS1 is a REAL variable. -C -C MATZ should be set to .TRUE. if the right hand transformations -C are to be accumulated for later use in computing -C eigenvectors, and to .FALSE. otherwise. MATZ is a LOGICAL -C variable. -C -C Z contains, if MATZ has been set to .TRUE., the transformation -C matrix produced in the reduction by QZHES, if performed, or -C else the identity matrix. If MATZ has been set to .FALSE., -C Z is not referenced. Z is a two-dimensional REAL array, -C dimensioned Z(NM,N). -C -C On Output -C -C A has been reduced to quasi-triangular form. The elements -C below the first subdiagonal are still zero, and no two -C consecutive subdiagonal elements are nonzero. -C -C B is still in upper triangular form, although its elements -C have been altered. The location B(N,1) is used to store -C EPS1 times the norm of B for later use by QZVAL and QZVEC. -C -C Z contains the product of the right hand transformations -C (for both steps) if MATZ has been set to .TRUE. -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C J if neither A(J,J-1) nor A(J-1,J-2) has become -C zero after a total of 30*N iterations. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE QZIT -C - INTEGER I,J,K,L,N,EN,K1,K2,LD,LL,L1,NA,NM,ISH,ITN,ITS,KM1,LM1 - INTEGER ENM2,IERR,LOR1,ENORN - REAL A(NM,*),B(NM,*),Z(NM,*) - REAL R,S,T,A1,A2,A3,EP,SH,U1,U2,U3,V1,V2,V3,ANI - REAL A11,A12,A21,A22,A33,A34,A43,A44,BNI,B11 - REAL B12,B22,B33,B34,B44,EPSA,EPSB,EPS1,ANORM,BNORM - LOGICAL MATZ,NOTLAS -C -C***FIRST EXECUTABLE STATEMENT QZIT - IERR = 0 -C .......... COMPUTE EPSA,EPSB .......... - ANORM = 0.0E0 - BNORM = 0.0E0 -C - DO 30 I = 1, N - ANI = 0.0E0 - IF (I .NE. 1) ANI = ABS(A(I,I-1)) - BNI = 0.0E0 -C - DO 20 J = I, N - ANI = ANI + ABS(A(I,J)) - BNI = BNI + ABS(B(I,J)) - 20 CONTINUE -C - IF (ANI .GT. ANORM) ANORM = ANI - IF (BNI .GT. BNORM) BNORM = BNI - 30 CONTINUE -C - IF (ANORM .EQ. 0.0E0) ANORM = 1.0E0 - IF (BNORM .EQ. 0.0E0) BNORM = 1.0E0 - EP = EPS1 - IF (EP .GT. 0.0E0) GO TO 50 -C .......... COMPUTE ROUNDOFF LEVEL IF EPS1 IS ZERO .......... - EP = 1.0E0 - 40 EP = EP / 2.0E0 - IF (1.0E0 + EP .GT. 1.0E0) GO TO 40 - 50 EPSA = EP * ANORM - EPSB = EP * BNORM -C .......... REDUCE A TO QUASI-TRIANGULAR FORM, WHILE -C KEEPING B TRIANGULAR .......... - LOR1 = 1 - ENORN = N - EN = N - ITN = 30*N -C .......... BEGIN QZ STEP .......... - 60 IF (EN .LE. 2) GO TO 1001 - IF (.NOT. MATZ) ENORN = EN - ITS = 0 - NA = EN - 1 - ENM2 = NA - 1 - 70 ISH = 2 -C .......... CHECK FOR CONVERGENCE OR REDUCIBILITY. -C FOR L=EN STEP -1 UNTIL 1 DO -- .......... - DO 80 LL = 1, EN - LM1 = EN - LL - L = LM1 + 1 - IF (L .EQ. 1) GO TO 95 - IF (ABS(A(L,LM1)) .LE. EPSA) GO TO 90 - 80 CONTINUE -C - 90 A(L,LM1) = 0.0E0 - IF (L .LT. NA) GO TO 95 -C .......... 1-BY-1 OR 2-BY-2 BLOCK ISOLATED .......... - EN = LM1 - GO TO 60 -C .......... CHECK FOR SMALL TOP OF B .......... - 95 LD = L - 100 L1 = L + 1 - B11 = B(L,L) - IF (ABS(B11) .GT. EPSB) GO TO 120 - B(L,L) = 0.0E0 - S = ABS(A(L,L)) + ABS(A(L1,L)) - U1 = A(L,L) / S - U2 = A(L1,L) / S - R = SIGN(SQRT(U1*U1+U2*U2),U1) - V1 = -(U1 + R) / R - V2 = -U2 / R - U2 = V2 / V1 -C - DO 110 J = L, ENORN - T = A(L,J) + U2 * A(L1,J) - A(L,J) = A(L,J) + T * V1 - A(L1,J) = A(L1,J) + T * V2 - T = B(L,J) + U2 * B(L1,J) - B(L,J) = B(L,J) + T * V1 - B(L1,J) = B(L1,J) + T * V2 - 110 CONTINUE -C - IF (L .NE. 1) A(L,LM1) = -A(L,LM1) - LM1 = L - L = L1 - GO TO 90 - 120 A11 = A(L,L) / B11 - A21 = A(L1,L) / B11 - IF (ISH .EQ. 1) GO TO 140 -C .......... ITERATION STRATEGY .......... - IF (ITN .EQ. 0) GO TO 1000 - IF (ITS .EQ. 10) GO TO 155 -C .......... DETERMINE TYPE OF SHIFT .......... - B22 = B(L1,L1) - IF (ABS(B22) .LT. EPSB) B22 = EPSB - B33 = B(NA,NA) - IF (ABS(B33) .LT. EPSB) B33 = EPSB - B44 = B(EN,EN) - IF (ABS(B44) .LT. EPSB) B44 = EPSB - A33 = A(NA,NA) / B33 - A34 = A(NA,EN) / B44 - A43 = A(EN,NA) / B33 - A44 = A(EN,EN) / B44 - B34 = B(NA,EN) / B44 - T = 0.5E0 * (A43 * B34 - A33 - A44) - R = T * T + A34 * A43 - A33 * A44 - IF (R .LT. 0.0E0) GO TO 150 -C .......... DETERMINE SINGLE SHIFT ZEROTH COLUMN OF A .......... - ISH = 1 - R = SQRT(R) - SH = -T + R - S = -T - R - IF (ABS(S-A44) .LT. ABS(SH-A44)) SH = S -C .......... LOOK FOR TWO CONSECUTIVE SMALL -C SUB-DIAGONAL ELEMENTS OF A. -C FOR L=EN-2 STEP -1 UNTIL LD DO -- .......... - DO 130 LL = LD, ENM2 - L = ENM2 + LD - LL - IF (L .EQ. LD) GO TO 140 - LM1 = L - 1 - L1 = L + 1 - T = A(L,L) - IF (ABS(B(L,L)) .GT. EPSB) T = T - SH * B(L,L) - IF (ABS(A(L,LM1)) .LE. ABS(T/A(L1,L)) * EPSA) GO TO 100 - 130 CONTINUE -C - 140 A1 = A11 - SH - A2 = A21 - IF (L .NE. LD) A(L,LM1) = -A(L,LM1) - GO TO 160 -C .......... DETERMINE DOUBLE SHIFT ZEROTH COLUMN OF A .......... - 150 A12 = A(L,L1) / B22 - A22 = A(L1,L1) / B22 - B12 = B(L,L1) / B22 - A1 = ((A33 - A11) * (A44 - A11) - A34 * A43 + A43 * B34 * A11) - 1 / A21 + A12 - A11 * B12 - A2 = (A22 - A11) - A21 * B12 - (A33 - A11) - (A44 - A11) - 1 + A43 * B34 - A3 = A(L1+1,L1) / B22 - GO TO 160 -C .......... AD HOC SHIFT .......... - 155 A1 = 0.0E0 - A2 = 1.0E0 - A3 = 1.1605E0 - 160 ITS = ITS + 1 - ITN = ITN - 1 - IF (.NOT. MATZ) LOR1 = LD -C .......... MAIN LOOP .......... - DO 260 K = L, NA - NOTLAS = K .NE. NA .AND. ISH .EQ. 2 - K1 = K + 1 - K2 = K + 2 - KM1 = MAX(K-1,L) - LL = MIN(EN,K1+ISH) - IF (NOTLAS) GO TO 190 -C .......... ZERO A(K+1,K-1) .......... - IF (K .EQ. L) GO TO 170 - A1 = A(K,KM1) - A2 = A(K1,KM1) - 170 S = ABS(A1) + ABS(A2) - IF (S .EQ. 0.0E0) GO TO 70 - U1 = A1 / S - U2 = A2 / S - R = SIGN(SQRT(U1*U1+U2*U2),U1) - V1 = -(U1 + R) / R - V2 = -U2 / R - U2 = V2 / V1 -C - DO 180 J = KM1, ENORN - T = A(K,J) + U2 * A(K1,J) - A(K,J) = A(K,J) + T * V1 - A(K1,J) = A(K1,J) + T * V2 - T = B(K,J) + U2 * B(K1,J) - B(K,J) = B(K,J) + T * V1 - B(K1,J) = B(K1,J) + T * V2 - 180 CONTINUE -C - IF (K .NE. L) A(K1,KM1) = 0.0E0 - GO TO 240 -C .......... ZERO A(K+1,K-1) AND A(K+2,K-1) .......... - 190 IF (K .EQ. L) GO TO 200 - A1 = A(K,KM1) - A2 = A(K1,KM1) - A3 = A(K2,KM1) - 200 S = ABS(A1) + ABS(A2) + ABS(A3) - IF (S .EQ. 0.0E0) GO TO 260 - U1 = A1 / S - U2 = A2 / S - U3 = A3 / S - R = SIGN(SQRT(U1*U1+U2*U2+U3*U3),U1) - V1 = -(U1 + R) / R - V2 = -U2 / R - V3 = -U3 / R - U2 = V2 / V1 - U3 = V3 / V1 -C - DO 210 J = KM1, ENORN - T = A(K,J) + U2 * A(K1,J) + U3 * A(K2,J) - A(K,J) = A(K,J) + T * V1 - A(K1,J) = A(K1,J) + T * V2 - A(K2,J) = A(K2,J) + T * V3 - T = B(K,J) + U2 * B(K1,J) + U3 * B(K2,J) - B(K,J) = B(K,J) + T * V1 - B(K1,J) = B(K1,J) + T * V2 - B(K2,J) = B(K2,J) + T * V3 - 210 CONTINUE -C - IF (K .EQ. L) GO TO 220 - A(K1,KM1) = 0.0E0 - A(K2,KM1) = 0.0E0 -C .......... ZERO B(K+2,K+1) AND B(K+2,K) .......... - 220 S = ABS(B(K2,K2)) + ABS(B(K2,K1)) + ABS(B(K2,K)) - IF (S .EQ. 0.0E0) GO TO 240 - U1 = B(K2,K2) / S - U2 = B(K2,K1) / S - U3 = B(K2,K) / S - R = SIGN(SQRT(U1*U1+U2*U2+U3*U3),U1) - V1 = -(U1 + R) / R - V2 = -U2 / R - V3 = -U3 / R - U2 = V2 / V1 - U3 = V3 / V1 -C - DO 230 I = LOR1, LL - T = A(I,K2) + U2 * A(I,K1) + U3 * A(I,K) - A(I,K2) = A(I,K2) + T * V1 - A(I,K1) = A(I,K1) + T * V2 - A(I,K) = A(I,K) + T * V3 - T = B(I,K2) + U2 * B(I,K1) + U3 * B(I,K) - B(I,K2) = B(I,K2) + T * V1 - B(I,K1) = B(I,K1) + T * V2 - B(I,K) = B(I,K) + T * V3 - 230 CONTINUE -C - B(K2,K) = 0.0E0 - B(K2,K1) = 0.0E0 - IF (.NOT. MATZ) GO TO 240 -C - DO 235 I = 1, N - T = Z(I,K2) + U2 * Z(I,K1) + U3 * Z(I,K) - Z(I,K2) = Z(I,K2) + T * V1 - Z(I,K1) = Z(I,K1) + T * V2 - Z(I,K) = Z(I,K) + T * V3 - 235 CONTINUE -C .......... ZERO B(K+1,K) .......... - 240 S = ABS(B(K1,K1)) + ABS(B(K1,K)) - IF (S .EQ. 0.0E0) GO TO 260 - U1 = B(K1,K1) / S - U2 = B(K1,K) / S - R = SIGN(SQRT(U1*U1+U2*U2),U1) - V1 = -(U1 + R) / R - V2 = -U2 / R - U2 = V2 / V1 -C - DO 250 I = LOR1, LL - T = A(I,K1) + U2 * A(I,K) - A(I,K1) = A(I,K1) + T * V1 - A(I,K) = A(I,K) + T * V2 - T = B(I,K1) + U2 * B(I,K) - B(I,K1) = B(I,K1) + T * V1 - B(I,K) = B(I,K) + T * V2 - 250 CONTINUE -C - B(K1,K) = 0.0E0 - IF (.NOT. MATZ) GO TO 260 -C - DO 255 I = 1, N - T = Z(I,K1) + U2 * Z(I,K) - Z(I,K1) = Z(I,K1) + T * V1 - Z(I,K) = Z(I,K) + T * V2 - 255 CONTINUE -C - 260 CONTINUE -C .......... END QZ STEP .......... - GO TO 70 -C .......... SET ERROR -- NEITHER BOTTOM SUBDIAGONAL ELEMENT -C HAS BECOME NEGLIGIBLE AFTER 30*N ITERATIONS .......... - 1000 IERR = EN -C .......... SAVE EPSB FOR USE BY QZVAL AND QZVEC .......... - 1001 IF (N .GT. 1) B(N,1) = EPSB - RETURN - END diff --git a/slatec/qzval.f b/slatec/qzval.f deleted file mode 100644 index cee28ec..0000000 --- a/slatec/qzval.f +++ /dev/null @@ -1,310 +0,0 @@ -*DECK QZVAL - SUBROUTINE QZVAL (NM, N, A, B, ALFR, ALFI, BETA, MATZ, Z) -C***BEGIN PROLOGUE QZVAL -C***PURPOSE The third step of the QZ algorithm for generalized -C eigenproblems. Accepts a pair of real matrices, one in -C quasi-triangular form and the other in upper triangular -C form and computes the eigenvalues of the associated -C eigenproblem. Usually preceded by QZHES, QZIT, and -C followed by QZVEC. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C2C -C***TYPE SINGLE PRECISION (QZVAL-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is the third step of the QZ algorithm -C for solving generalized matrix eigenvalue problems, -C SIAM J. NUMER. ANAL. 10, 241-256(1973) by MOLER and STEWART. -C -C This subroutine accepts a pair of REAL matrices, one of them -C in quasi-triangular form and the other in upper triangular form. -C It reduces the quasi-triangular matrix further, so that any -C remaining 2-by-2 blocks correspond to pairs of complex -C eigenvalues, and returns quantities whose ratios give the -C generalized eigenvalues. It is usually preceded by QZHES -C and QZIT and may be followed by QZVEC. -C -C On Input -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, A, B, and Z, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrices A and B. N is an INTEGER -C variable. N must be less than or equal to NM. -C -C A contains a real upper quasi-triangular matrix. A is a two- -C dimensional REAL array, dimensioned A(NM,N). -C -C B contains a real upper triangular matrix. In addition, -C location B(N,1) contains the tolerance quantity (EPSB) -C computed and saved in QZIT. B is a two-dimensional REAL -C array, dimensioned B(NM,N). -C -C MATZ should be set to .TRUE. if the right hand transformations -C are to be accumulated for later use in computing -C eigenvectors, and to .FALSE. otherwise. MATZ is a LOGICAL -C variable. -C -C Z contains, if MATZ has been set to .TRUE., the transformation -C matrix produced in the reductions by QZHES and QZIT, if -C performed, or else the identity matrix. If MATZ has been set -C to .FALSE., Z is not referenced. Z is a two-dimensional REAL -C array, dimensioned Z(NM,N). -C -C On Output -C -C A has been reduced further to a quasi-triangular matrix in -C which all nonzero subdiagonal elements correspond to pairs -C of complex eigenvalues. -C -C B is still in upper triangular form, although its elements -C have been altered. B(N,1) is unaltered. -C -C ALFR and ALFI contain the real and imaginary parts of the -C diagonal elements of the triangular matrix that would be -C obtained if A were reduced completely to triangular form -C by unitary transformations. Non-zero values of ALFI occur -C in pairs, the first member positive and the second negative. -C ALFR and ALFI are one-dimensional REAL arrays, dimensioned -C ALFR(N) and ALFI(N). -C -C BETA contains the diagonal elements of the corresponding B, -C normalized to be real and non-negative. The generalized -C eigenvalues are then the ratios ((ALFR+I*ALFI)/BETA). -C BETA is a one-dimensional REAL array, dimensioned BETA(N). -C -C Z contains the product of the right hand transformations -C (for all three steps) if MATZ has been set to .TRUE. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE QZVAL -C - INTEGER I,J,N,EN,NA,NM,NN,ISW - REAL A(NM,*),B(NM,*),ALFR(*),ALFI(*),BETA(*),Z(NM,*) - REAL C,D,E,R,S,T,AN,A1,A2,BN,CQ,CZ,DI,DR,EI,TI,TR - REAL U1,U2,V1,V2,A1I,A11,A12,A2I,A21,A22,B11,B12,B22 - REAL SQI,SQR,SSI,SSR,SZI,SZR,A11I,A11R,A12I,A12R - REAL A22I,A22R,EPSB - LOGICAL MATZ -C -C***FIRST EXECUTABLE STATEMENT QZVAL - EPSB = B(N,1) - ISW = 1 -C .......... FIND EIGENVALUES OF QUASI-TRIANGULAR MATRICES. -C FOR EN=N STEP -1 UNTIL 1 DO -- .......... - DO 510 NN = 1, N - EN = N + 1 - NN - NA = EN - 1 - IF (ISW .EQ. 2) GO TO 505 - IF (EN .EQ. 1) GO TO 410 - IF (A(EN,NA) .NE. 0.0E0) GO TO 420 -C .......... 1-BY-1 BLOCK, ONE REAL ROOT .......... - 410 ALFR(EN) = A(EN,EN) - IF (B(EN,EN) .LT. 0.0E0) ALFR(EN) = -ALFR(EN) - BETA(EN) = ABS(B(EN,EN)) - ALFI(EN) = 0.0E0 - GO TO 510 -C .......... 2-BY-2 BLOCK .......... - 420 IF (ABS(B(NA,NA)) .LE. EPSB) GO TO 455 - IF (ABS(B(EN,EN)) .GT. EPSB) GO TO 430 - A1 = A(EN,EN) - A2 = A(EN,NA) - BN = 0.0E0 - GO TO 435 - 430 AN = ABS(A(NA,NA)) + ABS(A(NA,EN)) + ABS(A(EN,NA)) - 1 + ABS(A(EN,EN)) - BN = ABS(B(NA,NA)) + ABS(B(NA,EN)) + ABS(B(EN,EN)) - A11 = A(NA,NA) / AN - A12 = A(NA,EN) / AN - A21 = A(EN,NA) / AN - A22 = A(EN,EN) / AN - B11 = B(NA,NA) / BN - B12 = B(NA,EN) / BN - B22 = B(EN,EN) / BN - E = A11 / B11 - EI = A22 / B22 - S = A21 / (B11 * B22) - T = (A22 - E * B22) / B22 - IF (ABS(E) .LE. ABS(EI)) GO TO 431 - E = EI - T = (A11 - E * B11) / B11 - 431 C = 0.5E0 * (T - S * B12) - D = C * C + S * (A12 - E * B12) - IF (D .LT. 0.0E0) GO TO 480 -C .......... TWO REAL ROOTS. -C ZERO BOTH A(EN,NA) AND B(EN,NA) .......... - E = E + (C + SIGN(SQRT(D),C)) - A11 = A11 - E * B11 - A12 = A12 - E * B12 - A22 = A22 - E * B22 - IF (ABS(A11) + ABS(A12) .LT. - 1 ABS(A21) + ABS(A22)) GO TO 432 - A1 = A12 - A2 = A11 - GO TO 435 - 432 A1 = A22 - A2 = A21 -C .......... CHOOSE AND APPLY REAL Z .......... - 435 S = ABS(A1) + ABS(A2) - U1 = A1 / S - U2 = A2 / S - R = SIGN(SQRT(U1*U1+U2*U2),U1) - V1 = -(U1 + R) / R - V2 = -U2 / R - U2 = V2 / V1 -C - DO 440 I = 1, EN - T = A(I,EN) + U2 * A(I,NA) - A(I,EN) = A(I,EN) + T * V1 - A(I,NA) = A(I,NA) + T * V2 - T = B(I,EN) + U2 * B(I,NA) - B(I,EN) = B(I,EN) + T * V1 - B(I,NA) = B(I,NA) + T * V2 - 440 CONTINUE -C - IF (.NOT. MATZ) GO TO 450 -C - DO 445 I = 1, N - T = Z(I,EN) + U2 * Z(I,NA) - Z(I,EN) = Z(I,EN) + T * V1 - Z(I,NA) = Z(I,NA) + T * V2 - 445 CONTINUE -C - 450 IF (BN .EQ. 0.0E0) GO TO 475 - IF (AN .LT. ABS(E) * BN) GO TO 455 - A1 = B(NA,NA) - A2 = B(EN,NA) - GO TO 460 - 455 A1 = A(NA,NA) - A2 = A(EN,NA) -C .......... CHOOSE AND APPLY REAL Q .......... - 460 S = ABS(A1) + ABS(A2) - IF (S .EQ. 0.0E0) GO TO 475 - U1 = A1 / S - U2 = A2 / S - R = SIGN(SQRT(U1*U1+U2*U2),U1) - V1 = -(U1 + R) / R - V2 = -U2 / R - U2 = V2 / V1 -C - DO 470 J = NA, N - T = A(NA,J) + U2 * A(EN,J) - A(NA,J) = A(NA,J) + T * V1 - A(EN,J) = A(EN,J) + T * V2 - T = B(NA,J) + U2 * B(EN,J) - B(NA,J) = B(NA,J) + T * V1 - B(EN,J) = B(EN,J) + T * V2 - 470 CONTINUE -C - 475 A(EN,NA) = 0.0E0 - B(EN,NA) = 0.0E0 - ALFR(NA) = A(NA,NA) - ALFR(EN) = A(EN,EN) - IF (B(NA,NA) .LT. 0.0E0) ALFR(NA) = -ALFR(NA) - IF (B(EN,EN) .LT. 0.0E0) ALFR(EN) = -ALFR(EN) - BETA(NA) = ABS(B(NA,NA)) - BETA(EN) = ABS(B(EN,EN)) - ALFI(EN) = 0.0E0 - ALFI(NA) = 0.0E0 - GO TO 505 -C .......... TWO COMPLEX ROOTS .......... - 480 E = E + C - EI = SQRT(-D) - A11R = A11 - E * B11 - A11I = EI * B11 - A12R = A12 - E * B12 - A12I = EI * B12 - A22R = A22 - E * B22 - A22I = EI * B22 - IF (ABS(A11R) + ABS(A11I) + ABS(A12R) + ABS(A12I) .LT. - 1 ABS(A21) + ABS(A22R) + ABS(A22I)) GO TO 482 - A1 = A12R - A1I = A12I - A2 = -A11R - A2I = -A11I - GO TO 485 - 482 A1 = A22R - A1I = A22I - A2 = -A21 - A2I = 0.0E0 -C .......... CHOOSE COMPLEX Z .......... - 485 CZ = SQRT(A1*A1+A1I*A1I) - IF (CZ .EQ. 0.0E0) GO TO 487 - SZR = (A1 * A2 + A1I * A2I) / CZ - SZI = (A1 * A2I - A1I * A2) / CZ - R = SQRT(CZ*CZ+SZR*SZR+SZI*SZI) - CZ = CZ / R - SZR = SZR / R - SZI = SZI / R - GO TO 490 - 487 SZR = 1.0E0 - SZI = 0.0E0 - 490 IF (AN .LT. (ABS(E) + EI) * BN) GO TO 492 - A1 = CZ * B11 + SZR * B12 - A1I = SZI * B12 - A2 = SZR * B22 - A2I = SZI * B22 - GO TO 495 - 492 A1 = CZ * A11 + SZR * A12 - A1I = SZI * A12 - A2 = CZ * A21 + SZR * A22 - A2I = SZI * A22 -C .......... CHOOSE COMPLEX Q .......... - 495 CQ = SQRT(A1*A1+A1I*A1I) - IF (CQ .EQ. 0.0E0) GO TO 497 - SQR = (A1 * A2 + A1I * A2I) / CQ - SQI = (A1 * A2I - A1I * A2) / CQ - R = SQRT(CQ*CQ+SQR*SQR+SQI*SQI) - CQ = CQ / R - SQR = SQR / R - SQI = SQI / R - GO TO 500 - 497 SQR = 1.0E0 - SQI = 0.0E0 -C .......... COMPUTE DIAGONAL ELEMENTS THAT WOULD RESULT -C IF TRANSFORMATIONS WERE APPLIED .......... - 500 SSR = SQR * SZR + SQI * SZI - SSI = SQR * SZI - SQI * SZR - I = 1 - TR = CQ * CZ * A11 + CQ * SZR * A12 + SQR * CZ * A21 - 1 + SSR * A22 - TI = CQ * SZI * A12 - SQI * CZ * A21 + SSI * A22 - DR = CQ * CZ * B11 + CQ * SZR * B12 + SSR * B22 - DI = CQ * SZI * B12 + SSI * B22 - GO TO 503 - 502 I = 2 - TR = SSR * A11 - SQR * CZ * A12 - CQ * SZR * A21 - 1 + CQ * CZ * A22 - TI = -SSI * A11 - SQI * CZ * A12 + CQ * SZI * A21 - DR = SSR * B11 - SQR * CZ * B12 + CQ * CZ * B22 - DI = -SSI * B11 - SQI * CZ * B12 - 503 T = TI * DR - TR * DI - J = NA - IF (T .LT. 0.0E0) J = EN - R = SQRT(DR*DR+DI*DI) - BETA(J) = BN * R - ALFR(J) = AN * (TR * DR + TI * DI) / R - ALFI(J) = AN * T / R - IF (I .EQ. 1) GO TO 502 - 505 ISW = 3 - ISW - 510 CONTINUE -C - RETURN - END diff --git a/slatec/qzvec.f b/slatec/qzvec.f deleted file mode 100644 index 998623c..0000000 --- a/slatec/qzvec.f +++ /dev/null @@ -1,278 +0,0 @@ -*DECK QZVEC - SUBROUTINE QZVEC (NM, N, A, B, ALFR, ALFI, BETA, Z) -C***BEGIN PROLOGUE QZVEC -C***PURPOSE The optional fourth step of the QZ algorithm for -C generalized eigenproblems. Accepts a matrix in -C quasi-triangular form and another in upper triangular -C and computes the eigenvectors of the triangular problem -C and transforms them back to the original coordinates -C Usually preceded by QZHES, QZIT, and QZVAL. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C3 -C***TYPE SINGLE PRECISION (QZVEC-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is the optional fourth step of the QZ algorithm -C for solving generalized matrix eigenvalue problems, -C SIAM J. NUMER. ANAL. 10, 241-256(1973) by MOLER and STEWART. -C -C This subroutine accepts a pair of REAL matrices, one of them in -C quasi-triangular form (in which each 2-by-2 block corresponds to -C a pair of complex eigenvalues) and the other in upper triangular -C form. It computes the eigenvectors of the triangular problem and -C transforms the results back to the original coordinate system. -C It is usually preceded by QZHES, QZIT, and QZVAL. -C -C On Input -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, A, B, and Z, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrices A and B. N is an INTEGER -C variable. N must be less than or equal to NM. -C -C A contains a real upper quasi-triangular matrix. A is a two- -C dimensional REAL array, dimensioned A(NM,N). -C -C B contains a real upper triangular matrix. In addition, -C location B(N,1) contains the tolerance quantity (EPSB) -C computed and saved in QZIT. B is a two-dimensional REAL -C array, dimensioned B(NM,N). -C -C ALFR, ALFI, and BETA are one-dimensional REAL arrays with -C components whose ratios ((ALFR+I*ALFI)/BETA) are the -C generalized eigenvalues. They are usually obtained from -C QZVAL. They are dimensioned ALFR(N), ALFI(N), and BETA(N). -C -C Z contains the transformation matrix produced in the reductions -C by QZHES, QZIT, and QZVAL, if performed. If the -C eigenvectors of the triangular problem are desired, Z must -C contain the identity matrix. Z is a two-dimensional REAL -C array, dimensioned Z(NM,N). -C -C On Output -C -C A is unaltered. Its subdiagonal elements provide information -C about the storage of the complex eigenvectors. -C -C B has been destroyed. -C -C ALFR, ALFI, and BETA are unaltered. -C -C Z contains the real and imaginary parts of the eigenvectors. -C If ALFI(J) .EQ. 0.0, the J-th eigenvalue is real and -C the J-th column of Z contains its eigenvector. -C If ALFI(J) .NE. 0.0, the J-th eigenvalue is complex. -C If ALFI(J) .GT. 0.0, the eigenvalue is the first of -C a complex pair and the J-th and (J+1)-th columns -C of Z contain its eigenvector. -C If ALFI(J) .LT. 0.0, the eigenvalue is the second of -C a complex pair and the (J-1)-th and J-th columns -C of Z contain the conjugate of its eigenvector. -C Each eigenvector is normalized so that the modulus -C of its largest component is 1.0 . -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE QZVEC -C - INTEGER I,J,K,M,N,EN,II,JJ,NA,NM,NN,ISW,ENM2 - REAL A(NM,*),B(NM,*),ALFR(*),ALFI(*),BETA(*),Z(NM,*) - REAL D,Q,R,S,T,W,X,Y,DI,DR,RA,RR,SA,TI,TR,T1,T2 - REAL W1,X1,ZZ,Z1,ALFM,ALMI,ALMR,BETM,EPSB -C -C***FIRST EXECUTABLE STATEMENT QZVEC - EPSB = B(N,1) - ISW = 1 -C .......... FOR EN=N STEP -1 UNTIL 1 DO -- .......... - DO 800 NN = 1, N - EN = N + 1 - NN - NA = EN - 1 - IF (ISW .EQ. 2) GO TO 795 - IF (ALFI(EN) .NE. 0.0E0) GO TO 710 -C .......... REAL VECTOR .......... - M = EN - B(EN,EN) = 1.0E0 - IF (NA .EQ. 0) GO TO 800 - ALFM = ALFR(M) - BETM = BETA(M) -C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... - DO 700 II = 1, NA - I = EN - II - W = BETM * A(I,I) - ALFM * B(I,I) - R = 0.0E0 -C - DO 610 J = M, EN - 610 R = R + (BETM * A(I,J) - ALFM * B(I,J)) * B(J,EN) -C - IF (I .EQ. 1 .OR. ISW .EQ. 2) GO TO 630 - IF (BETM * A(I,I-1) .EQ. 0.0E0) GO TO 630 - ZZ = W - S = R - GO TO 690 - 630 M = I - IF (ISW .EQ. 2) GO TO 640 -C .......... REAL 1-BY-1 BLOCK .......... - T = W - IF (W .EQ. 0.0E0) T = EPSB - B(I,EN) = -R / T - GO TO 700 -C .......... REAL 2-BY-2 BLOCK .......... - 640 X = BETM * A(I,I+1) - ALFM * B(I,I+1) - Y = BETM * A(I+1,I) - Q = W * ZZ - X * Y - T = (X * S - ZZ * R) / Q - B(I,EN) = T - IF (ABS(X) .LE. ABS(ZZ)) GO TO 650 - B(I+1,EN) = (-R - W * T) / X - GO TO 690 - 650 B(I+1,EN) = (-S - Y * T) / ZZ - 690 ISW = 3 - ISW - 700 CONTINUE -C .......... END REAL VECTOR .......... - GO TO 800 -C .......... COMPLEX VECTOR .......... - 710 M = NA - ALMR = ALFR(M) - ALMI = ALFI(M) - BETM = BETA(M) -C .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT -C EIGENVECTOR MATRIX IS TRIANGULAR .......... - Y = BETM * A(EN,NA) - B(NA,NA) = -ALMI * B(EN,EN) / Y - B(NA,EN) = (ALMR * B(EN,EN) - BETM * A(EN,EN)) / Y - B(EN,NA) = 0.0E0 - B(EN,EN) = 1.0E0 - ENM2 = NA - 1 - IF (ENM2 .EQ. 0) GO TO 795 -C .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- .......... - DO 790 II = 1, ENM2 - I = NA - II - W = BETM * A(I,I) - ALMR * B(I,I) - W1 = -ALMI * B(I,I) - RA = 0.0E0 - SA = 0.0E0 -C - DO 760 J = M, EN - X = BETM * A(I,J) - ALMR * B(I,J) - X1 = -ALMI * B(I,J) - RA = RA + X * B(J,NA) - X1 * B(J,EN) - SA = SA + X * B(J,EN) + X1 * B(J,NA) - 760 CONTINUE -C - IF (I .EQ. 1 .OR. ISW .EQ. 2) GO TO 770 - IF (BETM * A(I,I-1) .EQ. 0.0E0) GO TO 770 - ZZ = W - Z1 = W1 - R = RA - S = SA - ISW = 2 - GO TO 790 - 770 M = I - IF (ISW .EQ. 2) GO TO 780 -C .......... COMPLEX 1-BY-1 BLOCK .......... - TR = -RA - TI = -SA - 773 DR = W - DI = W1 -C .......... COMPLEX DIVIDE (T1,T2) = (TR,TI) / (DR,DI) .......... - 775 IF (ABS(DI) .GT. ABS(DR)) GO TO 777 - RR = DI / DR - D = DR + DI * RR - T1 = (TR + TI * RR) / D - T2 = (TI - TR * RR) / D - GO TO (787,782), ISW - 777 RR = DR / DI - D = DR * RR + DI - T1 = (TR * RR + TI) / D - T2 = (TI * RR - TR) / D - GO TO (787,782), ISW -C .......... COMPLEX 2-BY-2 BLOCK .......... - 780 X = BETM * A(I,I+1) - ALMR * B(I,I+1) - X1 = -ALMI * B(I,I+1) - Y = BETM * A(I+1,I) - TR = Y * RA - W * R + W1 * S - TI = Y * SA - W * S - W1 * R - DR = W * ZZ - W1 * Z1 - X * Y - DI = W * Z1 + W1 * ZZ - X1 * Y - IF (DR .EQ. 0.0E0 .AND. DI .EQ. 0.0E0) DR = EPSB - GO TO 775 - 782 B(I+1,NA) = T1 - B(I+1,EN) = T2 - ISW = 1 - IF (ABS(Y) .GT. ABS(W) + ABS(W1)) GO TO 785 - TR = -RA - X * B(I+1,NA) + X1 * B(I+1,EN) - TI = -SA - X * B(I+1,EN) - X1 * B(I+1,NA) - GO TO 773 - 785 T1 = (-R - ZZ * B(I+1,NA) + Z1 * B(I+1,EN)) / Y - T2 = (-S - ZZ * B(I+1,EN) - Z1 * B(I+1,NA)) / Y - 787 B(I,NA) = T1 - B(I,EN) = T2 - 790 CONTINUE -C .......... END COMPLEX VECTOR .......... - 795 ISW = 3 - ISW - 800 CONTINUE -C .......... END BACK SUBSTITUTION. -C TRANSFORM TO ORIGINAL COORDINATE SYSTEM. -C FOR J=N STEP -1 UNTIL 1 DO -- .......... - DO 880 JJ = 1, N - J = N + 1 - JJ -C - DO 880 I = 1, N - ZZ = 0.0E0 -C - DO 860 K = 1, J - 860 ZZ = ZZ + Z(I,K) * B(K,J) -C - Z(I,J) = ZZ - 880 CONTINUE -C .......... NORMALIZE SO THAT MODULUS OF LARGEST -C COMPONENT OF EACH VECTOR IS 1. -C (ISW IS 1 INITIALLY FROM BEFORE) .......... - DO 950 J = 1, N - D = 0.0E0 - IF (ISW .EQ. 2) GO TO 920 - IF (ALFI(J) .NE. 0.0E0) GO TO 945 -C - DO 890 I = 1, N - IF (ABS(Z(I,J)) .GT. D) D = ABS(Z(I,J)) - 890 CONTINUE -C - DO 900 I = 1, N - 900 Z(I,J) = Z(I,J) / D -C - GO TO 950 -C - 920 DO 930 I = 1, N - R = ABS(Z(I,J-1)) + ABS(Z(I,J)) - IF (R .NE. 0.0E0) R = R * SQRT((Z(I,J-1)/R)**2 - 1 +(Z(I,J)/R)**2) - IF (R .GT. D) D = R - 930 CONTINUE -C - DO 940 I = 1, N - Z(I,J-1) = Z(I,J-1) / D - Z(I,J) = Z(I,J) / D - 940 CONTINUE -C - 945 ISW = 3 - ISW - 950 CONTINUE -C - RETURN - END diff --git a/slatec/r1mach.f b/slatec/r1mach.f deleted file mode 100644 index 43bc451..0000000 --- a/slatec/r1mach.f +++ /dev/null @@ -1,419 +0,0 @@ -*DECK R1MACH - REAL FUNCTION R1MACH (I) -C***BEGIN PROLOGUE R1MACH -C***PURPOSE Return floating point machine dependent constants. -C***LIBRARY SLATEC -C***CATEGORY R1 -C***TYPE SINGLE PRECISION (R1MACH-S, D1MACH-D) -C***KEYWORDS MACHINE CONSTANTS -C***AUTHOR Fox, P. A., (Bell Labs) -C Hall, A. D., (Bell Labs) -C Schryer, N. L., (Bell Labs) -C***DESCRIPTION -C -C R1MACH can be used to obtain machine-dependent parameters for the -C local machine environment. It is a function subprogram with one -C (input) argument, and can be referenced as follows: -C -C A = R1MACH(I) -C -C where I=1,...,5. The (output) value of A above is determined by -C the (input) value of I. The results for various values of I are -C discussed below. -C -C R1MACH(1) = B**(EMIN-1), the smallest positive magnitude. -C R1MACH(2) = B**EMAX*(1 - B**(-T)), the largest magnitude. -C R1MACH(3) = B**(-T), the smallest relative spacing. -C R1MACH(4) = B**(1-T), the largest relative spacing. -C R1MACH(5) = LOG10(B) -C -C Assume single precision numbers are represented in the T-digit, -C base-B form -C -C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) -C -C where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and -C EMIN .LE. E .LE. EMAX. -C -C The values of B, T, EMIN and EMAX are provided in I1MACH as -C follows: -C I1MACH(10) = B, the base. -C I1MACH(11) = T, the number of base-B digits. -C I1MACH(12) = EMIN, the smallest exponent E. -C I1MACH(13) = EMAX, the largest exponent E. -C -C To alter this function for a particular environment, the desired -C set of DATA statements should be activated by removing the C from -C column 1. Also, the values of R1MACH(1) - R1MACH(4) should be -C checked for consistency with the local operating system. -C -C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for -C a portable library, ACM Transactions on Mathematical -C Software 4, 2 (June 1978), pp. 177-188. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 790101 DATE WRITTEN -C 890213 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 900618 Added DEC RISC constants. (WRB) -C 900723 Added IBM RS 6000 constants. (WRB) -C 910710 Added HP 730 constants. (SMR) -C 911114 Added Convex IEEE constants. (WRB) -C 920121 Added SUN -r8 compiler option constants. (WRB) -C 920229 Added Touchstone Delta i860 constants. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 920625 Added CONVEX -p8 and -pd8 compiler option constants. -C (BKS, WRB) -C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) -C***END PROLOGUE R1MACH -C - INTEGER SMALL(2) - INTEGER LARGE(2) - INTEGER RIGHT(2) - INTEGER DIVER(2) - INTEGER LOG10(2) -C - REAL RMACH(5) - SAVE RMACH -C - EQUIVALENCE (RMACH(1),SMALL(1)) - EQUIVALENCE (RMACH(2),LARGE(1)) - EQUIVALENCE (RMACH(3),RIGHT(1)) - EQUIVALENCE (RMACH(4),DIVER(1)) - EQUIVALENCE (RMACH(5),LOG10(1)) -C -C MACHINE CONSTANTS FOR THE AMIGA -C ABSOFT FORTRAN COMPILER USING THE 68020/68881 COMPILER OPTION -C -C DATA SMALL(1) / Z'00800000' / -C DATA LARGE(1) / Z'7F7FFFFF' / -C DATA RIGHT(1) / Z'33800000' / -C DATA DIVER(1) / Z'34000000' / -C DATA LOG10(1) / Z'3E9A209B' / -C -C MACHINE CONSTANTS FOR THE AMIGA -C ABSOFT FORTRAN COMPILER USING SOFTWARE FLOATING POINT -C -C DATA SMALL(1) / Z'00800000' / -C DATA LARGE(1) / Z'7EFFFFFF' / -C DATA RIGHT(1) / Z'33800000' / -C DATA DIVER(1) / Z'34000000' / -C DATA LOG10(1) / Z'3E9A209B' / -C -C MACHINE CONSTANTS FOR THE APOLLO -C -C DATA SMALL(1) / 16#00800000 / -C DATA LARGE(1) / 16#7FFFFFFF / -C DATA RIGHT(1) / 16#33800000 / -C DATA DIVER(1) / 16#34000000 / -C DATA LOG10(1) / 16#3E9A209B / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM -C -C DATA RMACH(1) / Z400800000 / -C DATA RMACH(2) / Z5FFFFFFFF / -C DATA RMACH(3) / Z4E9800000 / -C DATA RMACH(4) / Z4EA800000 / -C DATA RMACH(5) / Z500E730E8 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 5700/6700/7700 SYSTEMS -C -C DATA RMACH(1) / O1771000000000000 / -C DATA RMACH(2) / O0777777777777777 / -C DATA RMACH(3) / O1311000000000000 / -C DATA RMACH(4) / O1301000000000000 / -C DATA RMACH(5) / O1157163034761675 / -C -C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE -C -C DATA RMACH(1) / Z"3001800000000000" / -C DATA RMACH(2) / Z"4FFEFFFFFFFFFFFE" / -C DATA RMACH(3) / Z"3FD2800000000000" / -C DATA RMACH(4) / Z"3FD3800000000000" / -C DATA RMACH(5) / Z"3FFF9A209A84FBCF" / -C -C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES -C -C DATA RMACH(1) / 00564000000000000000B / -C DATA RMACH(2) / 37767777777777777776B / -C DATA RMACH(3) / 16414000000000000000B / -C DATA RMACH(4) / 16424000000000000000B / -C DATA RMACH(5) / 17164642023241175720B / -C -C MACHINE CONSTANTS FOR THE CELERITY C1260 -C -C DATA SMALL(1) / Z'00800000' / -C DATA LARGE(1) / Z'7F7FFFFF' / -C DATA RIGHT(1) / Z'33800000' / -C DATA DIVER(1) / Z'34000000' / -C DATA LOG10(1) / Z'3E9A209B' / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fn COMPILER OPTION -C -C DATA RMACH(1) / Z'00800000' / -C DATA RMACH(2) / Z'7FFFFFFF' / -C DATA RMACH(3) / Z'34800000' / -C DATA RMACH(4) / Z'35000000' / -C DATA RMACH(5) / Z'3F9A209B' / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fi COMPILER OPTION -C -C DATA RMACH(1) / Z'00800000' / -C DATA RMACH(2) / Z'7F7FFFFF' / -C DATA RMACH(3) / Z'33800000' / -C DATA RMACH(4) / Z'34000000' / -C DATA RMACH(5) / Z'3E9A209B' / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -p8 OR -pd8 COMPILER OPTION -C -C DATA RMACH(1) / Z'0010000000000000' / -C DATA RMACH(2) / Z'7FFFFFFFFFFFFFFF' / -C DATA RMACH(3) / Z'3CC0000000000000' / -C DATA RMACH(4) / Z'3CD0000000000000' / -C DATA RMACH(5) / Z'3FF34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE CRAY -C -C DATA RMACH(1) / 200034000000000000000B / -C DATA RMACH(2) / 577767777777777777776B / -C DATA RMACH(3) / 377224000000000000000B / -C DATA RMACH(4) / 377234000000000000000B / -C DATA RMACH(5) / 377774642023241175720B / -C -C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 -C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - -C STATIC RMACH(5) -C -C DATA SMALL / 20K, 0 / -C DATA LARGE / 77777K, 177777K / -C DATA RIGHT / 35420K, 0 / -C DATA DIVER / 36020K, 0 / -C DATA LOG10 / 40423K, 42023K / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING G_FLOAT -C -C DATA RMACH(1) / '00000080'X / -C DATA RMACH(2) / 'FFFF7FFF'X / -C DATA RMACH(3) / '00003480'X / -C DATA RMACH(4) / '00003500'X / -C DATA RMACH(5) / '209B3F9A'X / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING IEEE_FLOAT -C -C DATA RMACH(1) / '00800000'X / -C DATA RMACH(2) / '7F7FFFFF'X / -C DATA RMACH(3) / '33800000'X / -C DATA RMACH(4) / '34000000'X / -C DATA RMACH(5) / '3E9A209B'X / -C -C MACHINE CONSTANTS FOR THE DEC RISC -C -C DATA RMACH(1) / Z'00800000' / -C DATA RMACH(2) / Z'7F7FFFFF' / -C DATA RMACH(3) / Z'33800000' / -C DATA RMACH(4) / Z'34000000' / -C DATA RMACH(5) / Z'3E9A209B' / -C -C MACHINE CONSTANTS FOR THE DEC VAX -C (EXPRESSED IN INTEGER AND HEXADECIMAL) -C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS -C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS -C -C DATA SMALL(1) / 128 / -C DATA LARGE(1) / -32769 / -C DATA RIGHT(1) / 13440 / -C DATA DIVER(1) / 13568 / -C DATA LOG10(1) / 547045274 / -C -C DATA SMALL(1) / Z00000080 / -C DATA LARGE(1) / ZFFFF7FFF / -C DATA RIGHT(1) / Z00003480 / -C DATA DIVER(1) / Z00003500 / -C DATA LOG10(1) / Z209B3F9A / -C -C MACHINE CONSTANTS FOR THE ELXSI 6400 -C (ASSUMING REAL*4 IS THE DEFAULT REAL) -C -C DATA SMALL(1) / '00800000'X / -C DATA LARGE(1) / '7F7FFFFF'X / -C DATA RIGHT(1) / '33800000'X / -C DATA DIVER(1) / '34000000'X / -C DATA LOG10(1) / '3E9A209B'X / -C -C MACHINE CONSTANTS FOR THE HARRIS 220 -C -C DATA SMALL(1), SMALL(2) / '20000000, '00000201 / -C DATA LARGE(1), LARGE(2) / '37777777, '00000177 / -C DATA RIGHT(1), RIGHT(2) / '20000000, '00000352 / -C DATA DIVER(1), DIVER(2) / '20000000, '00000353 / -C DATA LOG10(1), LOG10(2) / '23210115, '00000377 / -C -C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES -C -C DATA RMACH(1) / O402400000000 / -C DATA RMACH(2) / O376777777777 / -C DATA RMACH(3) / O714400000000 / -C DATA RMACH(4) / O716400000000 / -C DATA RMACH(5) / O776464202324 / -C -C MACHINE CONSTANTS FOR THE HP 730 -C -C DATA RMACH(1) / Z'00800000' / -C DATA RMACH(2) / Z'7F7FFFFF' / -C DATA RMACH(3) / Z'33800000' / -C DATA RMACH(4) / Z'34000000' / -C DATA RMACH(5) / Z'3E9A209B' / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C 3 WORD DOUBLE PRECISION WITH FTN4 -C -C DATA SMALL(1), SMALL(2) / 40000B, 1 / -C DATA LARGE(1), LARGE(2) / 77777B, 177776B / -C DATA RIGHT(1), RIGHT(2) / 40000B, 325B / -C DATA DIVER(1), DIVER(2) / 40000B, 327B / -C DATA LOG10(1), LOG10(2) / 46420B, 46777B / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C 4 WORD DOUBLE PRECISION WITH FTN4 -C -C DATA SMALL(1), SMALL(2) / 40000B, 1 / -C DATA LARGE(1), LARGE(2) / 77777B, 177776B / -C DATA RIGHT(1), RIGHT(2) / 40000B, 325B / -C DATA DIVER(1), DIVER(2) / 40000B, 327B / -C DATA LOG10(1), LOG10(2) / 46420B, 46777B / -C -C MACHINE CONSTANTS FOR THE HP 9000 -C -C DATA SMALL(1) / 00004000000B / -C DATA LARGE(1) / 17677777777B / -C DATA RIGHT(1) / 06340000000B / -C DATA DIVER(1) / 06400000000B / -C DATA LOG10(1) / 07646420233B / -C -C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, -C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86 AND -C THE PERKIN ELMER (INTERDATA) 7/32. -C -C DATA RMACH(1) / Z00100000 / -C DATA RMACH(2) / Z7FFFFFFF / -C DATA RMACH(3) / Z3B100000 / -C DATA RMACH(4) / Z3C100000 / -C DATA RMACH(5) / Z41134413 / -C -C MACHINE CONSTANTS FOR THE IBM PC -C -C DATA SMALL(1) / 1.18E-38 / -C DATA LARGE(1) / 3.40E+38 / -C DATA RIGHT(1) / 0.595E-07 / -C DATA DIVER(1) / 1.19E-07 / -C DATA LOG10(1) / 0.30102999566 / -C -C MACHINE CONSTANTS FOR THE IBM RS 6000 -C -C DATA RMACH(1) / Z'00800000' / -C DATA RMACH(2) / Z'7F7FFFFF' / -C DATA RMACH(3) / Z'33800000' / -C DATA RMACH(4) / Z'34000000' / -C DATA RMACH(5) / Z'3E9A209B' / -C -C MACHINE CONSTANTS FOR THE INTEL i860 -C -C DATA RMACH(1) / Z'00800000' / -C DATA RMACH(2) / Z'7F7FFFFF' / -C DATA RMACH(3) / Z'33800000' / -C DATA RMACH(4) / Z'34000000' / -C DATA RMACH(5) / Z'3E9A209B' / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KA OR KI PROCESSOR) -C -C DATA RMACH(1) / "000400000000 / -C DATA RMACH(2) / "377777777777 / -C DATA RMACH(3) / "146400000000 / -C DATA RMACH(4) / "147400000000 / -C DATA RMACH(5) / "177464202324 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). -C -C DATA SMALL(1) / 8388608 / -C DATA LARGE(1) / 2147483647 / -C DATA RIGHT(1) / 880803840 / -C DATA DIVER(1) / 889192448 / -C DATA LOG10(1) / 1067065499 / -C -C DATA RMACH(1) / O00040000000 / -C DATA RMACH(2) / O17777777777 / -C DATA RMACH(3) / O06440000000 / -C DATA RMACH(4) / O06500000000 / -C DATA RMACH(5) / O07746420233 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). -C -C DATA SMALL(1), SMALL(2) / 128, 0 / -C DATA LARGE(1), LARGE(2) / 32767, -1 / -C DATA RIGHT(1), RIGHT(2) / 13440, 0 / -C DATA DIVER(1), DIVER(2) / 13568, 0 / -C DATA LOG10(1), LOG10(2) / 16282, 8347 / -C -C DATA SMALL(1), SMALL(2) / O000200, O000000 / -C DATA LARGE(1), LARGE(2) / O077777, O177777 / -C DATA RIGHT(1), RIGHT(2) / O032200, O000000 / -C DATA DIVER(1), DIVER(2) / O032400, O000000 / -C DATA LOG10(1), LOG10(2) / O037632, O020233 / -C -C MACHINE CONSTANTS FOR THE SILICON GRAPHICS -C -C DATA RMACH(1) / Z'00800000' / -C DATA RMACH(2) / Z'7F7FFFFF' / -C DATA RMACH(3) / Z'33800000' / -C DATA RMACH(4) / Z'34000000' / -C DATA RMACH(5) / Z'3E9A209B' / -C -C MACHINE CONSTANTS FOR THE SUN -C -C DATA RMACH(1) / Z'00800000' / -C DATA RMACH(2) / Z'7F7FFFFF' / -C DATA RMACH(3) / Z'33800000' / -C DATA RMACH(4) / Z'34000000' / -C DATA RMACH(5) / Z'3E9A209B' / -C -C MACHINE CONSTANTS FOR THE SUN -C USING THE -r8 COMPILER OPTION -C -C DATA RMACH(1) / Z'0010000000000000' / -C DATA RMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA RMACH(3) / Z'3CA0000000000000' / -C DATA RMACH(4) / Z'3CB0000000000000' / -C DATA RMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES -C -C DATA RMACH(1) / O000400000000 / -C DATA RMACH(2) / O377777777777 / -C DATA RMACH(3) / O146400000000 / -C DATA RMACH(4) / O147400000000 / -C DATA RMACH(5) / O177464202324 / -C -C MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR -C -C DATA SMALL(1), SMALL(2) / 0, 256/ -C DATA LARGE(1), LARGE(2) / -1, -129/ -C DATA RIGHT(1), RIGHT(2) / 0, 26880/ -C DATA DIVER(1), DIVER(2) / 0, 27136/ -C DATA LOG10(1), LOG10(2) / 8347, 32538/ -C -C***FIRST EXECUTABLE STATEMENT R1MACH - IF (I .LT. 1 .OR. I .GT. 5) CALL XERMSG ('SLATEC', 'R1MACH', - + 'I OUT OF BOUNDS', 1, 2) -C - R1MACH = RMACH(I) - RETURN -C - END diff --git a/slatec/r1mpyq.f b/slatec/r1mpyq.f deleted file mode 100644 index 074a2cb..0000000 --- a/slatec/r1mpyq.f +++ /dev/null @@ -1,98 +0,0 @@ -*DECK R1MPYQ - SUBROUTINE R1MPYQ (M, N, A, LDA, V, W) -C***BEGIN PROLOGUE R1MPYQ -C***SUBSIDIARY -C***PURPOSE Subsidiary to SNSQ and SNSQE -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (R1MPYQ-S, D1MPYQ-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Given an M by N matrix A, this subroutine computes A*Q where -C Q is the product of 2*(N - 1) transformations -C -C GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1) -C -C and GV(I), GW(I) are Givens rotations in the (I,N) plane which -C eliminate elements in the I-th and N-th planes, respectively. -C Q itself is not given, rather the information to recover the -C GV, GW rotations is supplied. -C -C The subroutine statement is -C -C SUBROUTINE R1MPYQ(M,N,A,LDA,V,W) -C -C where -C -C M is a positive integer input variable set to the number -C of rows of A. -C -C N is a positive integer input variable set to the number -C of columns of A. -C -C A is an M by N ARRAY. On input A must contain the matrix -C to be postmultiplied by the orthogonal matrix Q -C described above. On output A*Q has replaced A. -C -C LDA is a positive integer input variable not less than M -C which specifies the leading dimension of the array A. -C -C V is an input array of length N. V(I) must contain the -C information necessary to recover the Givens rotation GV(I) -C described above. -C -C W is an input array of length N. W(I) must contain the -C information necessary to recover the Givens rotation GW(I) -C described above. -C -C***SEE ALSO SNSQ, SNSQE -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE R1MPYQ - INTEGER M,N,LDA - REAL A(LDA,*),V(*),W(*) - INTEGER I,J,NMJ,NM1 - REAL COS,ONE,SIN,TEMP - SAVE ONE - DATA ONE /1.0E0/ -C***FIRST EXECUTABLE STATEMENT R1MPYQ - NM1 = N - 1 - IF (NM1 .LT. 1) GO TO 50 - DO 20 NMJ = 1, NM1 - J = N - NMJ - IF (ABS(V(J)) .GT. ONE) COS = ONE/V(J) - IF (ABS(V(J)) .GT. ONE) SIN = SQRT(ONE-COS**2) - IF (ABS(V(J)) .LE. ONE) SIN = V(J) - IF (ABS(V(J)) .LE. ONE) COS = SQRT(ONE-SIN**2) - DO 10 I = 1, M - TEMP = COS*A(I,J) - SIN*A(I,N) - A(I,N) = SIN*A(I,J) + COS*A(I,N) - A(I,J) = TEMP - 10 CONTINUE - 20 CONTINUE -C -C APPLY THE SECOND SET OF GIVENS ROTATIONS TO A. -C - DO 40 J = 1, NM1 - IF (ABS(W(J)) .GT. ONE) COS = ONE/W(J) - IF (ABS(W(J)) .GT. ONE) SIN = SQRT(ONE-COS**2) - IF (ABS(W(J)) .LE. ONE) SIN = W(J) - IF (ABS(W(J)) .LE. ONE) COS = SQRT(ONE-SIN**2) - DO 30 I = 1, M - TEMP = COS*A(I,J) + SIN*A(I,N) - A(I,N) = -SIN*A(I,J) + COS*A(I,N) - A(I,J) = TEMP - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE R1MPYQ. -C - END diff --git a/slatec/r1updt.f b/slatec/r1updt.f deleted file mode 100644 index 5e61bae..0000000 --- a/slatec/r1updt.f +++ /dev/null @@ -1,209 +0,0 @@ -*DECK R1UPDT - SUBROUTINE R1UPDT (M, N, S, LS, U, V, W, SING) -C***BEGIN PROLOGUE R1UPDT -C***SUBSIDIARY -C***PURPOSE Subsidiary to SNSQ and SNSQE -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (R1UPDT-S, D1UPDT-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Given an M by N lower trapezoidal matrix S, an M-vector U, -C and an N-vector V, the problem is to determine an -C orthogonal matrix Q such that -C -C T -C (S + U*V )*Q -C -C is again lower trapezoidal. -C -C This subroutine determines Q as the product of 2*(N - 1) -C transformations -C -C GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1) -C -C where GV(I), GW(I) are Givens rotations in the (I,N) plane -C which eliminate elements in the I-th and N-th planes, -C respectively. Q Itself is not accumulated, rather the -C information to recover the GV, GW rotations is returned. -C -C The subroutine statement is -C -C SUBROUTINE R1UPDT(M,N,S,LS,U,V,W,SING) -C -C where -C -C M is a positive integer input variable set to the number -C of rows of S. -C -C N is a positive integer input variable set to the number -C of columns of S. N must not exceed M. -C -C S is an array of length LS. On input S must contain the lower -C trapezoidal matrix S stored by columns. On output S contains -C the lower trapezoidal matrix produced as described above. -C -C LS is a positive integer input variable not less than -C (N*(2*M-N+1))/2. -C -C U is an input array of length M which must contain the -C vector U. -C -C V is an array of length N. On input V must contain the vector -C V. On output V(I) contains the information necessary to -C recover the Givens rotation GV(I) described above. -C -C W is an output array of length M. W(I) contains information -C necessary to recover the Givens rotation GW(I) described -C above. -C -C SING is a logical output variable. SING is set .TRUE. if any -C of the diagonal elements of the output S are zero. Otherwise -C SING is set .FALSE. -C -C***SEE ALSO SNSQ, SNSQE -C***ROUTINES CALLED R1MACH -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE R1UPDT - INTEGER M,N,LS - LOGICAL SING - REAL S(*),U(*),V(*),W(*) - INTEGER I,J,JJ,L,NMJ,NM1 - REAL COS,COTAN,GIANT,ONE,P5,P25,SIN,TAN,TAU,TEMP,ZERO - REAL R1MACH - SAVE ONE, P5, P25, ZERO - DATA ONE,P5,P25,ZERO /1.0E0,5.0E-1,2.5E-1,0.0E0/ -C***FIRST EXECUTABLE STATEMENT R1UPDT - GIANT = R1MACH(2) -C -C INITIALIZE THE DIAGONAL ELEMENT POINTER. -C - JJ = (N*(2*M - N + 1))/2 - (M - N) -C -C MOVE THE NONTRIVIAL PART OF THE LAST COLUMN OF S INTO W. -C - L = JJ - DO 10 I = N, M - W(I) = S(L) - L = L + 1 - 10 CONTINUE -C -C ROTATE THE VECTOR V INTO A MULTIPLE OF THE N-TH UNIT VECTOR -C IN SUCH A WAY THAT A SPIKE IS INTRODUCED INTO W. -C - NM1 = N - 1 - IF (NM1 .LT. 1) GO TO 70 - DO 60 NMJ = 1, NM1 - J = N - NMJ - JJ = JJ - (M - J + 1) - W(J) = ZERO - IF (V(J) .EQ. ZERO) GO TO 50 -C -C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE -C J-TH ELEMENT OF V. -C - IF (ABS(V(N)) .GE. ABS(V(J))) GO TO 20 - COTAN = V(N)/V(J) - SIN = P5/SQRT(P25+P25*COTAN**2) - COS = SIN*COTAN - TAU = ONE - IF (ABS(COS)*GIANT .GT. ONE) TAU = ONE/COS - GO TO 30 - 20 CONTINUE - TAN = V(J)/V(N) - COS = P5/SQRT(P25+P25*TAN**2) - SIN = COS*TAN - TAU = SIN - 30 CONTINUE -C -C APPLY THE TRANSFORMATION TO V AND STORE THE INFORMATION -C NECESSARY TO RECOVER THE GIVENS ROTATION. -C - V(N) = SIN*V(J) + COS*V(N) - V(J) = TAU -C -C APPLY THE TRANSFORMATION TO S AND EXTEND THE SPIKE IN W. -C - L = JJ - DO 40 I = J, M - TEMP = COS*S(L) - SIN*W(I) - W(I) = SIN*S(L) + COS*W(I) - S(L) = TEMP - L = L + 1 - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE -C -C ADD THE SPIKE FROM THE RANK 1 UPDATE TO W. -C - DO 80 I = 1, M - W(I) = W(I) + V(N)*U(I) - 80 CONTINUE -C -C ELIMINATE THE SPIKE. -C - SING = .FALSE. - IF (NM1 .LT. 1) GO TO 140 - DO 130 J = 1, NM1 - IF (W(J) .EQ. ZERO) GO TO 120 -C -C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE -C J-TH ELEMENT OF THE SPIKE. -C - IF (ABS(S(JJ)) .GE. ABS(W(J))) GO TO 90 - COTAN = S(JJ)/W(J) - SIN = P5/SQRT(P25+P25*COTAN**2) - COS = SIN*COTAN - TAU = ONE - IF (ABS(COS)*GIANT .GT. ONE) TAU = ONE/COS - GO TO 100 - 90 CONTINUE - TAN = W(J)/S(JJ) - COS = P5/SQRT(P25+P25*TAN**2) - SIN = COS*TAN - TAU = SIN - 100 CONTINUE -C -C APPLY THE TRANSFORMATION TO S AND REDUCE THE SPIKE IN W. -C - L = JJ - DO 110 I = J, M - TEMP = COS*S(L) + SIN*W(I) - W(I) = -SIN*S(L) + COS*W(I) - S(L) = TEMP - L = L + 1 - 110 CONTINUE -C -C STORE THE INFORMATION NECESSARY TO RECOVER THE -C GIVENS ROTATION. -C - W(J) = TAU - 120 CONTINUE -C -C TEST FOR ZERO DIAGONAL ELEMENTS IN THE OUTPUT S. -C - IF (S(JJ) .EQ. ZERO) SING = .TRUE. - JJ = JJ + (M - J + 1) - 130 CONTINUE - 140 CONTINUE -C -C MOVE W BACK INTO THE LAST COLUMN OF THE OUTPUT S. -C - L = JJ - DO 150 I = N, M - S(L) = W(I) - L = L + 1 - 150 CONTINUE - IF (S(JJ) .EQ. ZERO) SING = .TRUE. - RETURN -C -C LAST CARD OF SUBROUTINE R1UPDT. -C - END diff --git a/slatec/r9aimp.f b/slatec/r9aimp.f deleted file mode 100644 index 824335a..0000000 --- a/slatec/r9aimp.f +++ /dev/null @@ -1,226 +0,0 @@ -*DECK R9AIMP - SUBROUTINE R9AIMP (X, AMPL, THETA) -C***BEGIN PROLOGUE R9AIMP -C***SUBSIDIARY -C***PURPOSE Evaluate the Airy modulus and phase. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10D -C***TYPE SINGLE PRECISION (R9AIMP-S, D9AIMP-D) -C***KEYWORDS AIRY FUNCTION, FNLIB, MODULUS, PHASE, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate the Airy modulus and phase for X .LE. -1.0 -C -C Series for AM21 on the interval -1.25000D-01 to 0. -C with weighted error 2.89E-17 -C log weighted error 16.54 -C significant figures required 14.15 -C decimal places required 17.34 -C -C Series for ATH1 on the interval -1.25000D-01 to 0. -C with weighted error 2.53E-17 -C log weighted error 16.60 -C significant figures required 15.15 -C decimal places required 17.38 -C -C Series for AM22 on the interval -1.00000D+00 to -1.25000D-01 -C with weighted error 2.99E-17 -C log weighted error 16.52 -C significant figures required 14.57 -C decimal places required 17.28 -C -C Series for ATH2 on the interval -1.00000D+00 to -1.25000D-01 -C with weighted error 2.57E-17 -C log weighted error 16.59 -C significant figures required 15.07 -C decimal places required 17.34 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890206 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 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE R9AIMP - DIMENSION AM21CS(40), ATH1CS(36), AM22CS(33), ATH2CS(32) - LOGICAL FIRST - SAVE AM21CS, ATH1CS, AM22CS, ATH2CS, PI4, NAM21, - 1 NATH1, NAM22, NATH2, XSML, FIRST - DATA AM21CS( 1) / .0065809191 761485E0 / - DATA AM21CS( 2) / .0023675984 685722E0 / - DATA AM21CS( 3) / .0001324741 670371E0 / - DATA AM21CS( 4) / .0000157600 904043E0 / - DATA AM21CS( 5) / .0000027529 702663E0 / - DATA AM21CS( 6) / .0000006102 679017E0 / - DATA AM21CS( 7) / .0000001595 088468E0 / - DATA AM21CS( 8) / .0000000471 033947E0 / - DATA AM21CS( 9) / .0000000152 933871E0 / - DATA AM21CS(10) / .0000000053 590722E0 / - DATA AM21CS(11) / .0000000020 000910E0 / - DATA AM21CS(12) / .0000000007 872292E0 / - DATA AM21CS(13) / .0000000003 243103E0 / - DATA AM21CS(14) / .0000000001 390106E0 / - DATA AM21CS(15) / .0000000000 617011E0 / - DATA AM21CS(16) / .0000000000 282491E0 / - DATA AM21CS(17) / .0000000000 132979E0 / - DATA AM21CS(18) / .0000000000 064188E0 / - DATA AM21CS(19) / .0000000000 031697E0 / - DATA AM21CS(20) / .0000000000 015981E0 / - DATA AM21CS(21) / .0000000000 008213E0 / - DATA AM21CS(22) / .0000000000 004296E0 / - DATA AM21CS(23) / .0000000000 002284E0 / - DATA AM21CS(24) / .0000000000 001232E0 / - DATA AM21CS(25) / .0000000000 000675E0 / - DATA AM21CS(26) / .0000000000 000374E0 / - DATA AM21CS(27) / .0000000000 000210E0 / - DATA AM21CS(28) / .0000000000 000119E0 / - DATA AM21CS(29) / .0000000000 000068E0 / - DATA AM21CS(30) / .0000000000 000039E0 / - DATA AM21CS(31) / .0000000000 000023E0 / - DATA AM21CS(32) / .0000000000 000013E0 / - DATA AM21CS(33) / .0000000000 000008E0 / - DATA AM21CS(34) / .0000000000 000005E0 / - DATA AM21CS(35) / .0000000000 000003E0 / - DATA AM21CS(36) / .0000000000 000001E0 / - DATA AM21CS(37) / .0000000000 000001E0 / - DATA AM21CS(38) / .0000000000 000000E0 / - DATA AM21CS(39) / .0000000000 000000E0 / - DATA AM21CS(40) / .0000000000 000000E0 / - DATA ATH1CS( 1) / -.0712583781 5669365E0 / - DATA ATH1CS( 2) / -.0059047197 9831451E0 / - DATA ATH1CS( 3) / -.0001211454 4069499E0 / - DATA ATH1CS( 4) / -.0000098860 8542270E0 / - DATA ATH1CS( 5) / -.0000013808 4097352E0 / - DATA ATH1CS( 6) / -.0000002614 2640172E0 / - DATA ATH1CS( 7) / -.0000000605 0432589E0 / - DATA ATH1CS( 8) / -.0000000161 8436223E0 / - DATA ATH1CS( 9) / -.0000000048 3464911E0 / - DATA ATH1CS(10) / -.0000000015 7655272E0 / - DATA ATH1CS(11) / -.0000000005 5231518E0 / - DATA ATH1CS(12) / -.0000000002 0545441E0 / - DATA ATH1CS(13) / -.0000000000 8043412E0 / - DATA ATH1CS(14) / -.0000000000 3291252E0 / - DATA ATH1CS(15) / -.0000000000 1399875E0 / - DATA ATH1CS(16) / -.0000000000 0616151E0 / - DATA ATH1CS(17) / -.0000000000 0279614E0 / - DATA ATH1CS(18) / -.0000000000 0130428E0 / - DATA ATH1CS(19) / -.0000000000 0062373E0 / - DATA ATH1CS(20) / -.0000000000 0030512E0 / - DATA ATH1CS(21) / -.0000000000 0015239E0 / - DATA ATH1CS(22) / -.0000000000 0007758E0 / - DATA ATH1CS(23) / -.0000000000 0004020E0 / - DATA ATH1CS(24) / -.0000000000 0002117E0 / - DATA ATH1CS(25) / -.0000000000 0001132E0 / - DATA ATH1CS(26) / -.0000000000 0000614E0 / - DATA ATH1CS(27) / -.0000000000 0000337E0 / - DATA ATH1CS(28) / -.0000000000 0000188E0 / - DATA ATH1CS(29) / -.0000000000 0000105E0 / - DATA ATH1CS(30) / -.0000000000 0000060E0 / - DATA ATH1CS(31) / -.0000000000 0000034E0 / - DATA ATH1CS(32) / -.0000000000 0000020E0 / - DATA ATH1CS(33) / -.0000000000 0000011E0 / - DATA ATH1CS(34) / -.0000000000 0000007E0 / - DATA ATH1CS(35) / -.0000000000 0000004E0 / - DATA ATH1CS(36) / -.0000000000 0000002E0 / - DATA AM22CS( 1) / -.0156284448 0625341E0 / - DATA AM22CS( 2) / .0077833644 5239681E0 / - DATA AM22CS( 3) / .0008670577 7047718E0 / - DATA AM22CS( 4) / .0001569662 7315611E0 / - DATA AM22CS( 5) / .0000356396 2571432E0 / - DATA AM22CS( 6) / .0000092459 8335425E0 / - DATA AM22CS( 7) / .0000026211 0161850E0 / - DATA AM22CS( 8) / .0000007918 8221651E0 / - DATA AM22CS( 9) / .0000002510 4152792E0 / - DATA AM22CS(10) / .0000000826 5223206E0 / - DATA AM22CS(11) / .0000000280 5711662E0 / - DATA AM22CS(12) / .0000000097 6821090E0 / - DATA AM22CS(13) / .0000000034 7407923E0 / - DATA AM22CS(14) / .0000000012 5828132E0 / - DATA AM22CS(15) / .0000000004 6298826E0 / - DATA AM22CS(16) / .0000000001 7272825E0 / - DATA AM22CS(17) / .0000000000 6523192E0 / - DATA AM22CS(18) / .0000000000 2490471E0 / - DATA AM22CS(19) / .0000000000 0960156E0 / - DATA AM22CS(20) / .0000000000 0373448E0 / - DATA AM22CS(21) / .0000000000 0146417E0 / - DATA AM22CS(22) / .0000000000 0057826E0 / - DATA AM22CS(23) / .0000000000 0022991E0 / - DATA AM22CS(24) / .0000000000 0009197E0 / - DATA AM22CS(25) / .0000000000 0003700E0 / - DATA AM22CS(26) / .0000000000 0001496E0 / - DATA AM22CS(27) / .0000000000 0000608E0 / - DATA AM22CS(28) / .0000000000 0000248E0 / - DATA AM22CS(29) / .0000000000 0000101E0 / - DATA AM22CS(30) / .0000000000 0000041E0 / - DATA AM22CS(31) / .0000000000 0000017E0 / - DATA AM22CS(32) / .0000000000 0000007E0 / - DATA AM22CS(33) / .0000000000 0000002E0 / - DATA ATH2CS( 1) / .0044052734 5871877E0 / - DATA ATH2CS( 2) / -.0304291945 2318455E0 / - DATA ATH2CS( 3) / -.0013856532 8377179E0 / - DATA ATH2CS( 4) / -.0001804443 9089549E0 / - DATA ATH2CS( 5) / -.0000338084 7108327E0 / - DATA ATH2CS( 6) / -.0000076781 8353522E0 / - DATA ATH2CS( 7) / -.0000019678 3944371E0 / - DATA ATH2CS( 8) / -.0000005483 7271158E0 / - DATA ATH2CS( 9) / -.0000001625 4615505E0 / - DATA ATH2CS(10) / -.0000000505 3049981E0 / - DATA ATH2CS(11) / -.0000000163 1580701E0 / - DATA ATH2CS(12) / -.0000000054 3420411E0 / - DATA ATH2CS(13) / -.0000000018 5739855E0 / - DATA ATH2CS(14) / -.0000000006 4895120E0 / - DATA ATH2CS(15) / -.0000000002 3105948E0 / - DATA ATH2CS(16) / -.0000000000 8363282E0 / - DATA ATH2CS(17) / -.0000000000 3071196E0 / - DATA ATH2CS(18) / -.0000000000 1142367E0 / - DATA ATH2CS(19) / -.0000000000 0429811E0 / - DATA ATH2CS(20) / -.0000000000 0163389E0 / - DATA ATH2CS(21) / -.0000000000 0062693E0 / - DATA ATH2CS(22) / -.0000000000 0024260E0 / - DATA ATH2CS(23) / -.0000000000 0009461E0 / - DATA ATH2CS(24) / -.0000000000 0003716E0 / - DATA ATH2CS(25) / -.0000000000 0001469E0 / - DATA ATH2CS(26) / -.0000000000 0000584E0 / - DATA ATH2CS(27) / -.0000000000 0000233E0 / - DATA ATH2CS(28) / -.0000000000 0000093E0 / - DATA ATH2CS(29) / -.0000000000 0000037E0 / - DATA ATH2CS(30) / -.0000000000 0000015E0 / - DATA ATH2CS(31) / -.0000000000 0000006E0 / - DATA ATH2CS(32) / -.0000000000 0000002E0 / - DATA PI4 / 0.7853981633 9744831 E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT R9AIMP - IF (FIRST) THEN - ETA = 0.1*R1MACH(3) - NAM21 = INITS (AM21CS, 40, ETA) - NATH1 = INITS (ATH1CS, 36, ETA) - NAM22 = INITS (AM22CS, 33, ETA) - NATH2 = INITS (ATH2CS, 32, ETA) -C - XSML = -1.0/R1MACH(3)**0.3333 - ENDIF - FIRST = .FALSE. -C - IF (X.GE.(-2.0)) GO TO 20 - Z = 1.0 - IF (X.GT.XSML) Z = 16.0/X**3 + 1.0 - AMPL = 0.3125 + CSEVL(Z, AM21CS, NAM21) - THETA = -0.625 + CSEVL (Z, ATH1CS, NATH1) - GO TO 30 -C - 20 IF (X .GT. (-1.0)) CALL XERMSG ('SLATEC', 'R9AIMP', - + 'X MUST BE LE -1.0', 1, 2) -C - Z = (16.0/X**3 + 9.0)/7.0 - AMPL = 0.3125 + CSEVL (Z, AM22CS, NAM22) - THETA = -0.625 + CSEVL (Z, ATH2CS, NATH2) -C - 30 SQRTX = SQRT(-X) - AMPL = SQRT (AMPL/SQRTX) - THETA = PI4 - X*SQRTX * THETA -C - RETURN - END diff --git a/slatec/r9atn1.f b/slatec/r9atn1.f deleted file mode 100644 index 8fe3633..0000000 --- a/slatec/r9atn1.f +++ /dev/null @@ -1,87 +0,0 @@ -*DECK R9ATN1 - FUNCTION R9ATN1 (X) -C***BEGIN PROLOGUE R9ATN1 -C***SUBSIDIARY -C***PURPOSE Evaluate ATAN(X) from first order relative accuracy so that -C ATAN(X) = X + X**3*R9ATN1(X). -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4A -C***TYPE SINGLE PRECISION (R9ATN1-S, D9ATN1-D) -C***KEYWORDS ARC TANGENT, ELEMENTARY FUNCTIONS, FIRST ORDER, FNLIB, -C TRIGONOMETRIC -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate ATAN(X) from first order, that is, evaluate -C (ATAN(X)-X)/X**3 with relative error accuracy so that -C ATAN(X) = X + X**3*R9ATN1(X). -C -C Series for ATN1 on the interval 0. to 1.00000D+00 -C with weighted error 2.21E-17 -C log weighted error 16.66 -C significant figures required 15.44 -C decimal places required 17.32 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 780401 DATE WRITTEN -C 890206 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 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE R9ATN1 - DIMENSION ATN1CS(21) - LOGICAL FIRST - SAVE ATN1CS, NTATN1, XSML, XBIG, XMAX, FIRST - DATA ATN1CS( 1) / -.0328399753 5355202E0 / - DATA ATN1CS( 2) / .0583343234 3172412E0 / - DATA ATN1CS( 3) / -.0074003696 9671964E0 / - DATA ATN1CS( 4) / .0010097841 9933728E0 / - DATA ATN1CS( 5) / -.0001439787 1635652E0 / - DATA ATN1CS( 6) / .0000211451 2648992E0 / - DATA ATN1CS( 7) / -.0000031723 2107425E0 / - DATA ATN1CS( 8) / .0000004836 6203654E0 / - DATA ATN1CS( 9) / -.0000000746 7746546E0 / - DATA ATN1CS(10) / .0000000116 4800896E0 / - DATA ATN1CS(11) / -.0000000018 3208837E0 / - DATA ATN1CS(12) / .0000000002 9019082E0 / - DATA ATN1CS(13) / -.0000000000 4623885E0 / - DATA ATN1CS(14) / .0000000000 0740552E0 / - DATA ATN1CS(15) / -.0000000000 0119135E0 / - DATA ATN1CS(16) / .0000000000 0019240E0 / - DATA ATN1CS(17) / -.0000000000 0003118E0 / - DATA ATN1CS(18) / .0000000000 0000506E0 / - DATA ATN1CS(19) / -.0000000000 0000082E0 / - DATA ATN1CS(20) / .0000000000 0000013E0 / - DATA ATN1CS(21) / -.0000000000 0000002E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT R9ATN1 - IF (FIRST) THEN - EPS = R1MACH(3) - NTATN1 = INITS (ATN1CS, 21, 0.1*EPS) -C - XSML = SQRT (0.1*EPS) - XBIG = 1.571/SQRT(EPS) - XMAX = 1.571/EPS - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.1.0) GO TO 20 -C - IF (Y.LE.XSML) R9ATN1 = -1.0/3.0 - IF (Y.LE.XSML) RETURN -C - R9ATN1 = -0.25 + CSEVL (2.0*Y*Y-1., ATN1CS, NTATN1) - RETURN -C - 20 IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'R9ATN1', - + 'NO PRECISION IN ANSWER BECAUSE X IS TOO BIG', 2, 2) - IF (Y .GT. XBIG) CALL XERMSG ('SLATEC', 'R9ATN1', - + 'ANSWER LT HALF PRECISION BECAUSE X IS TOO BIG', 1, 1) -C - R9ATN1 = (ATAN(X) - X) / X**3 - RETURN -C - END diff --git a/slatec/r9chu.f b/slatec/r9chu.f deleted file mode 100644 index 1954a16..0000000 --- a/slatec/r9chu.f +++ /dev/null @@ -1,95 +0,0 @@ -*DECK R9CHU - FUNCTION R9CHU (A, B, Z) -C***BEGIN PROLOGUE R9CHU -C***SUBSIDIARY -C***PURPOSE Evaluate for large Z Z**A * U(A,B,Z) where U is the -C logarithmic confluent hypergeometric function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C11 -C***TYPE SINGLE PRECISION (R9CHU-S, D9CHU-D) -C***KEYWORDS FNLIB, LOGARITHMIC CONFLUENT HYPERGEOMETRIC FUNCTION, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate for large Z Z**A * U(A,B,Z) where U is the logarithmic -C confluent hypergeometric function. A rational approximation due to Y. -C L. Luke is used. When U is not in the asymptotic region, i.e., when A -C or B is large compared with Z, considerable significance loss occurs. -C A warning is provided when the computed result is less than half -C precision. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770801 DATE WRITTEN -C 890206 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 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE R9CHU - DIMENSION AA(4), BB(4) - LOGICAL FIRST - SAVE EPS, SQEPS, FIRST - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT R9CHU - IF (FIRST) THEN - EPS = 4.0*R1MACH(4) - SQEPS = SQRT (R1MACH(4)) - ENDIF - FIRST = .FALSE. -C - BP = 1.0 + A - B - AB = A*BP - CT2 = 2.0*(Z-AB) - SAB = A + BP -C - BB(1) = 1.0 - AA(1) = 1.0 -C - CT3 = SAB + 1.0 + AB - BB(2) = 1.0 + 2.0*Z/CT3 - AA(2) = 1.0 + CT2/CT3 -C - ANBN = CT3 + SAB + 3.0 - CT1 = 1.0 + 2.0*Z/ANBN - BB(3) = 1.0 + 6.0*CT1*Z/CT3 - AA(3) = 1.0 + 6.0*AB/ANBN + 3.0*CT1*CT2/CT3 -C - DO 30 I=4,300 - X2I1 = 2*I - 3 - CT1 = X2I1/(X2I1-2.0) - ANBN = ANBN + X2I1 + SAB - CT2 = (X2I1 - 1.0) / ANBN - C2 = X2I1*CT2 - 1.0 - D1Z = X2I1*2.0*Z/ANBN -C - CT3 = SAB*CT2 - G1 = D1Z + CT1*(C2+CT3) - G2 = D1Z - C2 - G3 = CT1*(1.0 - CT3 - 2.0*CT2) -C - BB(4) = G1*BB(3) + G2*BB(2) + G3*BB(1) - AA(4) = G1*AA(3) + G2*AA(2) + G3*AA(1) - IF (ABS(AA(4)*BB(1)-AA(1)*BB(4)).LT.EPS*ABS(BB(4)*BB(1))) - 1 GO TO 40 -C -C IF OVERFLOWS OR UNDERFLOWS PROVE TO BE A PROBLEM, THE STATEMENTS -C BELOW COULD BE ALTERED TO INCORPORATE A DYNAMICALLY ADJUSTED SCALE -C FACTOR. -C - DO 20 J=1,3 - BB(J) = BB(J+1) - AA(J) = AA(J+1) - 20 CONTINUE - 30 CONTINUE - CALL XERMSG ('SLATEC', 'R9CHU', 'NO CONVERGENCE IN 300 TERMS', 1, - + 2) -C - 40 R9CHU = AA(4)/BB(4) -C - IF (R9CHU .LT. SQEPS .OR. R9CHU .GT. 1.0/SQEPS) CALL XERMSG - + ('SLATEC', 'R9CHU', 'ANSWER LESS THAN HALF PRECISION', 2, 1) -C - RETURN - END diff --git a/slatec/r9gmic.f b/slatec/r9gmic.f deleted file mode 100644 index b1cbaca..0000000 --- a/slatec/r9gmic.f +++ /dev/null @@ -1,92 +0,0 @@ -*DECK R9GMIC - FUNCTION R9GMIC (A, X, ALX) -C***BEGIN PROLOGUE R9GMIC -C***SUBSIDIARY -C***PURPOSE Compute the complementary incomplete Gamma function for A -C near a negative integer and for small X. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE SINGLE PRECISION (R9GMIC-S, D9GMIC-D) -C***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, SMALL X, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Compute the complementary incomplete gamma function for A near -C a negative integer and for small X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED ALNGAM, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE R9GMIC - SAVE EULER, EPS, BOT - DATA EULER / .5772156649 015329 E0 / - DATA EPS, BOT / 2*0.0 / -C***FIRST EXECUTABLE STATEMENT R9GMIC - IF (EPS.EQ.0.0) EPS = 0.5*R1MACH(3) - IF (BOT.EQ.0.0) BOT = LOG(R1MACH(1)) -C - IF (A .GT. 0.0) CALL XERMSG ('SLATEC', 'R9GMIC', - + 'A MUST BE NEAR A NEGATIVE INTEGER', 2, 2) - IF (X .LE. 0.0) CALL XERMSG ('SLATEC', 'R9GMIC', - + 'X MUST BE GT ZERO', 3, 2) -C - MA = A - 0.5 - FM = -MA - M = -MA -C - TE = 1.0 - T = 1.0 - S = T - DO 20 K=1,200 - FKP1 = K + 1 - TE = -X*TE/(FM+FKP1) - T = TE/FKP1 - S = S + T - IF (ABS(T).LT.EPS*S) GO TO 30 - 20 CONTINUE - CALL XERMSG ('SLATEC', 'R9GMIC', - + 'NO CONVERGENCE IN 200 TERMS OF CONTINUED FRACTION', 4, 2) -C - 30 R9GMIC = -ALX - EULER + X*S/(FM+1.0) - IF (M.EQ.0) RETURN -C - IF (M.EQ.1) R9GMIC = -R9GMIC - 1.0 + 1.0/X - IF (M.EQ.1) RETURN -C - TE = FM - T = 1.0 - S = T - MM1 = M - 1 - DO 40 K=1,MM1 - FK = K - TE = -X*TE/FK - T = TE/(FM-FK) - S = S + T - IF (ABS(T).LT.EPS*ABS(S)) GO TO 50 - 40 CONTINUE -C - 50 DO 60 K=1,M - R9GMIC = R9GMIC + 1.0/K - 60 CONTINUE -C - SGNG = 1.0 - IF (MOD(M,2).EQ.1) SGNG = -1.0 - ALNG = LOG(R9GMIC) - ALNGAM(FM+1.0) -C - R9GMIC = 0.0 - IF (ALNG.GT.BOT) R9GMIC = SGNG*EXP(ALNG) - IF (S.NE.0.0) R9GMIC = R9GMIC + SIGN (EXP(-FM*ALX+LOG(ABS(S)/FM)) - 1 , S) -C - IF (R9GMIC .EQ. 0.0 .AND. S .EQ. 0.0) CALL XERMSG ('SLATEC', - + 'R9GMIC', 'RESULT UNDERFLOWS', 1, 1) - RETURN -C - END diff --git a/slatec/r9gmit.f b/slatec/r9gmit.f deleted file mode 100644 index 3d81492..0000000 --- a/slatec/r9gmit.f +++ /dev/null @@ -1,84 +0,0 @@ -*DECK R9GMIT - FUNCTION R9GMIT (A, X, ALGAP1, SGNGAM, ALX) -C***BEGIN PROLOGUE R9GMIT -C***SUBSIDIARY -C***PURPOSE Compute Tricomi's incomplete Gamma function for small -C arguments. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE SINGLE PRECISION (R9GMIT-S, D9GMIT-D) -C***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, SMALL X, -C SPECIAL FUNCTIONS, TRICOMI -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Compute Tricomi's incomplete gamma function for small X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED ALNGAM, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE R9GMIT - SAVE EPS, BOT - DATA EPS, BOT / 2*0.0 / -C***FIRST EXECUTABLE STATEMENT R9GMIT - IF (EPS.EQ.0.0) EPS = 0.5*R1MACH(3) - IF (BOT.EQ.0.0) BOT = LOG(R1MACH(1)) -C - IF (X .LE. 0.0) CALL XERMSG ('SLATEC', 'R9GMIT', - + 'X SHOULD BE GT 0', 1, 2) -C - MA = A + 0.5 - IF (A.LT.0.0) MA = A - 0.5 - AEPS = A - MA -C - AE = A - IF (A.LT.(-0.5)) AE = AEPS -C - T = 1.0 - TE = AE - S = T - DO 20 K=1,200 - FK = K - TE = -X*TE/FK - T = TE/(AE+FK) - S = S + T - IF (ABS(T).LT.EPS*ABS(S)) GO TO 30 - 20 CONTINUE - CALL XERMSG ('SLATEC', 'R9GMIT', - + 'NO CONVERGENCE IN 200 TERMS OF TAYLOR-S SERIES', 2, 2) -C - 30 IF (A.GE.(-0.5)) ALGS = -ALGAP1 + LOG(S) - IF (A.GE.(-0.5)) GO TO 60 -C - ALGS = -ALNGAM(1.0+AEPS) + LOG(S) - S = 1.0 - M = -MA - 1 - IF (M.EQ.0) GO TO 50 - T = 1.0 - DO 40 K=1,M - T = X*T/(AEPS-M-1+K) - S = S + T - IF (ABS(T).LT.EPS*ABS(S)) GO TO 50 - 40 CONTINUE -C - 50 R9GMIT = 0.0 - ALGS = -MA*LOG(X) + ALGS - IF (S.EQ.0.0 .OR. AEPS.EQ.0.0) GO TO 60 -C - SGNG2 = SGNGAM*SIGN(1.0,S) - ALG2 = -X - ALGAP1 + LOG(ABS(S)) -C - IF (ALG2.GT.BOT) R9GMIT = SGNG2*EXP(ALG2) - IF (ALGS.GT.BOT) R9GMIT = R9GMIT + EXP(ALGS) - RETURN -C - 60 R9GMIT = EXP(ALGS) - RETURN -C - END diff --git a/slatec/r9knus.f b/slatec/r9knus.f deleted file mode 100644 index ebe659d..0000000 --- a/slatec/r9knus.f +++ /dev/null @@ -1,220 +0,0 @@ -*DECK R9KNUS - SUBROUTINE R9KNUS (XNU, X, BKNU, BKNU1, ISWTCH) -C***BEGIN PROLOGUE R9KNUS -C***SUBSIDIARY -C***PURPOSE Compute Bessel functions EXP(X)*K-SUB-XNU(X) and EXP(X)* -C K-SUB-XNU+1(X) for 0.0 .LE. XNU .LT. 1.0. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C10B3 -C***TYPE SINGLE PRECISION (R9KNUS-S, D9KNUS-D) -C***KEYWORDS BESSEL FUNCTION, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Compute Bessel functions EXP(X) * K-sub-XNU (X) and -C EXP(X) * K-sub-XNU+1 (X) for 0.0 .LE. XNU .LT. 1.0 . -C -C Series for C0K on the interval 0. to 2.50000D-01 -C with weighted error 1.60E-17 -C log weighted error 16.79 -C significant figures required 15.99 -C decimal places required 17.40 -C -C Series for ZNU1 on the interval -7.00000D-01 to 0. -C with weighted error 1.43E-17 -C log weighted error 16.85 -C significant figures required 16.08 -C decimal places required 17.38 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, GAMMA, INITS, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 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 900720 Routine changed from user-callable to subsidiary. (WRB) -C 900727 Added EXTERNAL statement. (WRB) -C 920618 Removed space from variable names. (RWC, WRB) -C***END PROLOGUE R9KNUS - DIMENSION ALPHA(15), BETA(15), A(15), C0KCS(16), ZNU1CS(12) - LOGICAL FIRST - EXTERNAL GAMMA - SAVE C0KCS, ZNU1CS, EULER, SQPI2, ALN2, NTC0K, NTZNU1, - 1 XNUSML, XSML, ALNSML, ALNBIG, ALNEPS, FIRST - DATA C0KCS( 1) / .0601830572 42626108E0 / - DATA C0KCS( 2) / -.1536487143 3017286E0 / - DATA C0KCS( 3) / -.0117511760 08210492E0 / - DATA C0KCS( 4) / -.0008524878 88919795E0 / - DATA C0KCS( 5) / -.0000613298 38767496E0 / - DATA C0KCS( 6) / -.0000044052 28124551E0 / - DATA C0KCS( 7) / -.0000003163 12467283E0 / - DATA C0KCS( 8) / -.0000000227 10719382E0 / - DATA C0KCS( 9) / -.0000000016 30564460E0 / - DATA C0KCS(10) / -.0000000001 17069392E0 / - DATA C0KCS(11) / -.0000000000 08405206E0 / - DATA C0KCS(12) / -.0000000000 00603466E0 / - DATA C0KCS(13) / -.0000000000 00043326E0 / - DATA C0KCS(14) / -.0000000000 00003110E0 / - DATA C0KCS(15) / -.0000000000 00000223E0 / - DATA C0KCS(16) / -.0000000000 00000016E0 / - DATA ZNU1CS( 1) / .2033067569 9419173E0 / - DATA ZNU1CS( 2) / .1400779334 1321977E0 / - DATA ZNU1CS( 3) / .0079167969 61001613E0 / - DATA ZNU1CS( 4) / .0003398011 82532104E0 / - DATA ZNU1CS( 5) / .0000117419 75688989E0 / - DATA ZNU1CS( 6) / .0000003393 57570612E0 / - DATA ZNU1CS( 7) / .0000000084 25941769E0 / - DATA ZNU1CS( 8) / .0000000001 83336677E0 / - DATA ZNU1CS( 9) / .0000000000 03549698E0 / - DATA ZNU1CS(10) / .0000000000 00061903E0 / - DATA ZNU1CS(11) / .0000000000 00000981E0 / - DATA ZNU1CS(12) / .0000000000 00000014E0 / - DATA EULER / 0.5772156649 0153286E0 / - DATA SQPI2 / 1.253314137 3155003E0 / - DATA ALN2 / 0.693147180 55994531E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT R9KNUS - IF (FIRST) THEN - NTC0K = INITS (C0KCS, 16, 0.1*R1MACH(3)) - NTZNU1 = INITS (ZNU1CS, 12, 0.1*R1MACH(3)) -C - XNUSML = SQRT (R1MACH(3)/8.0) - XSML = 0.1*R1MACH(3) - ALNSML = LOG (R1MACH(1)) - ALNBIG = LOG (R1MACH(2)) - ALNEPS = LOG (0.1*R1MACH(3)) - ENDIF - FIRST = .FALSE. -C - IF (XNU .LT. 0. .OR. XNU .GE. 1.0) CALL XERMSG ('SLATEC', - + 'R9KNUS', 'XNU MUST BE GE 0 AND LT 1', 1, 2) - IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'R9KNUS', 'X MUST BE GT 0', - + 2, 2) -C - ISWTCH = 0 - IF (X.GT.2.0) GO TO 50 -C -C X IS SMALL. COMPUTE K-SUB-XNU (X) AND THE DERIVATIVE OF K-SUB-XNU (X) -C THEN FIND K-SUB-XNU+1 (X). XNU IS REDUCED TO THE INTERVAL (-.5,+.5) -C THEN TO (0., .5), BECAUSE K OF NEGATIVE ORDER (-NU) = K OF POSITIVE -C ORDER (+NU). -C - V = XNU - IF (XNU.GT.0.5) V = 1.0 - XNU -C -C CAREFULLY FIND (X/2)**XNU AND Z**XNU WHERE Z = X*X/4. - ALNZ = 2.0 * (LOG(X) - ALN2) -C - IF (X.GT.XNU) GO TO 20 - IF (-0.5*XNU*ALNZ-ALN2-LOG(XNU) .GT. ALNBIG) CALL XERMSG - + ('SLATEC', 'R9KNUS', 'X SO SMALL BESSEL K-SUB-XNU OVERFLOWS', - + 3, 2) -C - 20 VLNZ = V*ALNZ - X2TOV = EXP (0.5*VLNZ) - ZTOV = 0.0 - IF (VLNZ.GT.ALNSML) ZTOV = X2TOV**2 -C - A0 = 0.5*GAMMA(1.0+V) - B0 = 0.5*GAMMA(1.0-V) - C0 = -EULER - IF (ZTOV.GT.0.5 .AND. V.GT.XNUSML) C0 = -0.75 + - 1 CSEVL ((8.0*V)*V-1., C0KCS, NTC0K) -C - IF (ZTOV.LE.0.5) ALPHA(1) = (A0-ZTOV*B0)/V - IF (ZTOV.GT.0.5) ALPHA(1) = C0 - ALNZ*(0.75 + - 1 CSEVL (VLNZ/0.35+1.0, ZNU1CS, NTZNU1))*B0 - BETA(1) = -0.5*(A0+ZTOV*B0) -C - Z = 0.0 - IF (X.GT.XSML) Z = 0.25*X*X - NTERMS = MAX (2.0, 11.0+(8.*ALNZ-25.19-ALNEPS)/(4.28-ALNZ)) - DO 30 I=2,NTERMS - XI = I - 1 - A0 = A0/(XI*(XI-V)) - B0 = B0/(XI*(XI+V)) - ALPHA(I) = (ALPHA(I-1)+2.0*XI*A0)/(XI*(XI+V)) - BETA(I) = (XI-0.5*V)*ALPHA(I) - ZTOV*B0 - 30 CONTINUE -C - BKNU = ALPHA(NTERMS) - BKNUD = BETA(NTERMS) - DO 40 II=2,NTERMS - I = NTERMS + 1 - II - BKNU = ALPHA(I) + BKNU*Z - BKNUD = BETA(I) + BKNUD*Z - 40 CONTINUE -C - EXPX = EXP(X) - BKNU = EXPX*BKNU/X2TOV -C - IF (-0.5*(XNU+1.)*ALNZ-2.0*ALN2.GT.ALNBIG) ISWTCH = 1 - IF (ISWTCH.EQ.1) RETURN - BKNUD = EXPX*BKNUD*2.0/(X2TOV*X) -C - IF (XNU.LE.0.5) BKNU1 = V*BKNU/X - BKNUD - IF (XNU.LE.0.5) RETURN -C - BKNU0 = BKNU - BKNU = -V*BKNU/X - BKNUD - BKNU1 = 2.0*XNU*BKNU/X + BKNU0 - RETURN -C -C X IS LARGE. FIND K-SUB-XNU (X) AND K-SUB-XNU+1 (X) WITH Y. L. LUKE-S -C RATIONAL EXPANSION. -C - 50 SQRTX = SQRT(X) - IF (X.GT.1.0/XSML) GO TO 90 - AN = -1.56 + 4.0/X - BN = -0.29 - 0.22/X - NTERMS = MIN (15, MAX1 (3.0, AN+BN*ALNEPS)) -C - DO 80 INU=1,2 - XMU = 0. - IF (INU.EQ.1 .AND. XNU.GT.XNUSML) XMU = (4.0*XNU)*XNU - IF (INU.EQ.2) XMU = 4.0*(ABS(XNU)+1.)**2 -C - A(1) = 1.0 - XMU - A(2) = 9.0 - XMU - A(3) = 25.0 - XMU - IF (A(2).EQ.0.) RESULT = SQPI2*(16.*X+XMU+7.)/(16.*X*SQRTX) - IF (A(2).EQ.0.) GO TO 70 -C - ALPHA(1) = 1.0 - ALPHA(2) = (16.*X+A(2))/A(2) - ALPHA(3) = ((768.*X+48.*A(3))*X + A(2)*A(3))/(A(2)*A(3)) -C - BETA(1) = 1.0 - BETA(2) = (16.*X+(XMU+7.))/A(2) - BETA(3) = ((768.*X+48.*(XMU+23.))*X + ((XMU+62.)*XMU+129.)) - 1 / (A(2)*A(3)) -C - IF (NTERMS.LT.4) GO TO 65 - DO 60 I=4,NTERMS - N = I - 1 - X2N = 2*N - 1 -C - A(I) = (X2N+2.)**2 - XMU - QQ = 16.*X2N/A(I) - P1 = -X2N*(12*N*N-20*N-A(1))/((X2N-2.)*A(I)) - QQ*X - P2 = (12*N*N-28*N+8-A(1))/A(I) - QQ*X - P3 = -X2N*A(I-3)/((X2N-2.)*A(I)) -C - ALPHA(I) = -P1*ALPHA(I-1) - P2*ALPHA(I-2) - P3*ALPHA(I-3) - BETA(I) = -P1*BETA(I-1) - P2*BETA(I-2) - P3*BETA(I-3) - 60 CONTINUE -C - 65 RESULT = SQPI2*BETA(NTERMS)/(SQRTX*ALPHA(NTERMS)) -C - 70 IF (INU.EQ.1) BKNU = RESULT - IF (INU.EQ.2) BKNU1 = RESULT - 80 CONTINUE - RETURN -C - 90 BKNU = SQPI2/SQRTX - BKNU1 = BKNU - RETURN -C - END diff --git a/slatec/r9lgic.f b/slatec/r9lgic.f deleted file mode 100644 index 45b9866..0000000 --- a/slatec/r9lgic.f +++ /dev/null @@ -1,53 +0,0 @@ -*DECK R9LGIC - FUNCTION R9LGIC (A, X, ALX) -C***BEGIN PROLOGUE R9LGIC -C***SUBSIDIARY -C***PURPOSE Compute the log complementary incomplete Gamma function -C for large X and for A .LE. X. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE SINGLE PRECISION (R9LGIC-S, D9LGIC-D) -C***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, LARGE X, -C LOGARITHM, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Compute the log complementary incomplete gamma function for large X -C and for A .LE. X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE R9LGIC - SAVE EPS - DATA EPS / 0.0 / -C***FIRST EXECUTABLE STATEMENT R9LGIC - IF (EPS.EQ.0.0) EPS = 0.5*R1MACH(3) -C - XPA = X + 1.0 - A - XMA = X - 1.0 - A -C - R = 0.0 - P = 1.0 - S = P - DO 10 K=1,200 - FK = K - T = FK*(A-FK)*(1.0+R) - R = -T/((XMA+2.0*FK)*(XPA+2.0*FK)+T) - P = R*P - S = S + P - IF (ABS(P).LT.EPS*S) GO TO 20 - 10 CONTINUE - CALL XERMSG ('SLATEC', 'R9LGIC', - + 'NO CONVERGENCE IN 200 TERMS OF CONTINUED FRACTION', 1, 2) -C - 20 R9LGIC = A*ALX - X + LOG(S/XPA) -C - RETURN - END diff --git a/slatec/r9lgit.f b/slatec/r9lgit.f deleted file mode 100644 index e19f5ec..0000000 --- a/slatec/r9lgit.f +++ /dev/null @@ -1,61 +0,0 @@ -*DECK R9LGIT - FUNCTION R9LGIT (A, X, ALGAP1) -C***BEGIN PROLOGUE R9LGIT -C***SUBSIDIARY -C***PURPOSE Compute the logarithm of Tricomi's incomplete Gamma -C function with Perron's continued fraction for large X and -C A .GE. X. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE SINGLE PRECISION (R9LGIT-S, D9LGIT-D) -C***KEYWORDS FNLIB, INCOMPLETE GAMMA FUNCTION, LOGARITHM, -C PERRON'S CONTINUED FRACTION, SPECIAL FUNCTIONS, TRICOMI -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Compute the log of Tricomi's incomplete gamma function with Perron's -C continued fraction for large X and for A .GE. X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 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 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE R9LGIT - SAVE EPS, SQEPS - DATA EPS, SQEPS / 2*0.0 / -C***FIRST EXECUTABLE STATEMENT R9LGIT - IF (EPS.EQ.0.0) EPS = 0.5*R1MACH(3) - IF (SQEPS.EQ.0.0) SQEPS = SQRT(R1MACH(4)) -C - IF (X .LE. 0.0 .OR. A .LT. X) CALL XERMSG ('SLATEC', 'R9LGIT', - + 'X SHOULD BE GT 0.0 AND LE A', 2, 2) -C - AX = A + X - A1X = AX + 1.0 - R = 0.0 - P = 1.0 - S = P - DO 20 K=1,200 - FK = K - T = (A+FK)*X*(1.0+R) - R = T/((AX+FK)*(A1X+FK)-T) - P = R*P - S = S + P - IF (ABS(P).LT.EPS*S) GO TO 30 - 20 CONTINUE - CALL XERMSG ('SLATEC', 'R9LGIT', - + 'NO CONVERGENCE IN 200 TERMS OF CONTINUED FRACTION', 3, 2) -C - 30 HSTAR = 1.0 - X*S/A1X - IF (HSTAR .LT. SQEPS) CALL XERMSG ('SLATEC', 'R9LGIT', - + 'RESULT LESS THAN HALF PRECISION', 1, 1) -C - R9LGIT = -X - ALGAP1 - LOG(HSTAR) -C - RETURN - END diff --git a/slatec/r9lgmc.f b/slatec/r9lgmc.f deleted file mode 100644 index 044f7f1..0000000 --- a/slatec/r9lgmc.f +++ /dev/null @@ -1,66 +0,0 @@ -*DECK R9LGMC - FUNCTION R9LGMC (X) -C***BEGIN PROLOGUE R9LGMC -C***SUBSIDIARY -C***PURPOSE Compute the log Gamma correction factor so that -C LOG(GAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X -C + R9LGMC(X). -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE SINGLE PRECISION (R9LGMC-S, D9LGMC-D, C9LGMC-C) -C***KEYWORDS COMPLETE GAMMA FUNCTION, CORRECTION TERM, FNLIB, -C LOG GAMMA, LOGARITHM, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Compute the log gamma correction factor for X .GE. 10.0 so that -C LOG (GAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X + R9LGMC(X) -C -C Series for ALGM on the interval 0. to 1.00000D-02 -C with weighted error 3.40E-16 -C log weighted error 15.47 -C significant figures required 14.39 -C decimal places required 15.86 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770801 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 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE R9LGMC - DIMENSION ALGMCS(6) - LOGICAL FIRST - SAVE ALGMCS, NALGM, XBIG, XMAX, FIRST - DATA ALGMCS( 1) / .1666389480 45186E0 / - DATA ALGMCS( 2) / -.0000138494 817606E0 / - DATA ALGMCS( 3) / .0000000098 108256E0 / - DATA ALGMCS( 4) / -.0000000000 180912E0 / - DATA ALGMCS( 5) / .0000000000 000622E0 / - DATA ALGMCS( 6) / -.0000000000 000003E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT R9LGMC - IF (FIRST) THEN - NALGM = INITS (ALGMCS, 6, R1MACH(3)) - XBIG = 1.0/SQRT(R1MACH(3)) - XMAX = EXP (MIN(LOG(R1MACH(2)/12.0), -LOG(12.0*R1MACH(1))) ) - ENDIF - FIRST = .FALSE. -C - IF (X .LT. 10.0) CALL XERMSG ('SLATEC', 'R9LGMC', - + 'X MUST BE GE 10', 1, 2) - IF (X.GE.XMAX) GO TO 20 -C - R9LGMC = 1.0/(12.0*X) - IF (X.LT.XBIG) R9LGMC = CSEVL (2.0*(10./X)**2-1., ALGMCS, NALGM)/X - RETURN -C - 20 R9LGMC = 0.0 - CALL XERMSG ('SLATEC', 'R9LGMC', 'X SO BIG R9LGMC UNDERFLOWS', 2, - + 1) - RETURN -C - END diff --git a/slatec/r9ln2r.f b/slatec/r9ln2r.f deleted file mode 100644 index 9525d98..0000000 --- a/slatec/r9ln2r.f +++ /dev/null @@ -1,124 +0,0 @@ -*DECK R9LN2R - FUNCTION R9LN2R (X) -C***BEGIN PROLOGUE R9LN2R -C***SUBSIDIARY -C***PURPOSE Evaluate LOG(1+X) from second order relative accuracy so -C that LOG(1+X) = X - X**2/2 + X**3*R9LN2R(X). -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4B -C***TYPE SINGLE PRECISION (R9LN2R-S, D9LN2R-D, C9LN2R-C) -C***KEYWORDS ELEMENTARY FUNCTIONS, FNLIB, LOGARITHM, SECOND ORDER -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate LOG(1+X) from 2-nd order with relative error accuracy so -C that LOG(1+X) = X - X**2/2 + X**3*R9LN2R(X) -C -C Series for LN21 on the interval -6.25000D-01 to 0. -C with weighted error 2.49E-17 -C log weighted error 16.60 -C significant figures required 15.87 -C decimal places required 17.31 -C -C Series for LN22 on the interval 0. to 8.12500D-01 -C with weighted error 1.42E-17 -C log weighted error 16.85 -C significant figures required 15.95 -C decimal places required 17.50 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 780401 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 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE R9LN2R - REAL LN21CS(26), LN22CS(20) - LOGICAL FIRST - SAVE LN21CS, LN22CS, NTLN21, NTLN22, XMIN, XBIG, XMAX, FIRST - DATA LN21CS( 1) / .1811196251 3478810E0 / - DATA LN21CS( 2) / -.1562712319 2872463E0 / - DATA LN21CS( 3) / .0286763053 61557275E0 / - DATA LN21CS( 4) / -.0055586996 55948139E0 / - DATA LN21CS( 5) / .0011178976 65229983E0 / - DATA LN21CS( 6) / -.0002308050 89823279E0 / - DATA LN21CS( 7) / .0000485988 53341100E0 / - DATA LN21CS( 8) / -.0000103901 27388903E0 / - DATA LN21CS( 9) / .0000022484 56370739E0 / - DATA LN21CS(10) / -.0000004914 05927392E0 / - DATA LN21CS(11) / .0000001082 82565070E0 / - DATA LN21CS(12) / -.0000000240 25872763E0 / - DATA LN21CS(13) / .0000000053 62460047E0 / - DATA LN21CS(14) / -.0000000012 02995136E0 / - DATA LN21CS(15) / .0000000002 71078892E0 / - DATA LN21CS(16) / -.0000000000 61323562E0 / - DATA LN21CS(17) / .0000000000 13920858E0 / - DATA LN21CS(18) / -.0000000000 03169930E0 / - DATA LN21CS(19) / .0000000000 00723837E0 / - DATA LN21CS(20) / -.0000000000 00165700E0 / - DATA LN21CS(21) / .0000000000 00038018E0 / - DATA LN21CS(22) / -.0000000000 00008741E0 / - DATA LN21CS(23) / .0000000000 00002013E0 / - DATA LN21CS(24) / -.0000000000 00000464E0 / - DATA LN21CS(25) / .0000000000 00000107E0 / - DATA LN21CS(26) / -.0000000000 00000024E0 / - DATA LN22CS( 1) / -.2224253253 5020461E0 / - DATA LN22CS( 2) / -.0610471001 08078624E0 / - DATA LN22CS( 3) / .0074272350 09750394E0 / - DATA LN22CS( 4) / -.0009335018 26163697E0 / - DATA LN22CS( 5) / .0001200499 07687260E0 / - DATA LN22CS( 6) / -.0000157047 22952820E0 / - DATA LN22CS( 7) / .0000020818 74781051E0 / - DATA LN22CS( 8) / -.0000002789 19557764E0 / - DATA LN22CS( 9) / .0000000376 93558237E0 / - DATA LN22CS(10) / -.0000000051 30902896E0 / - DATA LN22CS(11) / .0000000007 02714117E0 / - DATA LN22CS(12) / -.0000000000 96748595E0 / - DATA LN22CS(13) / .0000000000 13381046E0 / - DATA LN22CS(14) / -.0000000000 01858102E0 / - DATA LN22CS(15) / .0000000000 00258929E0 / - DATA LN22CS(16) / -.0000000000 00036195E0 / - DATA LN22CS(17) / .0000000000 00005074E0 / - DATA LN22CS(18) / -.0000000000 00000713E0 / - DATA LN22CS(19) / .0000000000 00000100E0 / - DATA LN22CS(20) / -.0000000000 00000014E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT R9LN2R - IF (FIRST) THEN - EPS = R1MACH(3) - NTLN21 = INITS (LN21CS, 26, 0.1*EPS) - NTLN22 = INITS (LN22CS, 20, 0.1*EPS) -C - XMIN = -1.0 + SQRT(R1MACH(4)) - SQEPS = SQRT(EPS) - TXMAX = 6.0/SQEPS - XMAX = TXMAX - (EPS*TXMAX**2 - 2.0*LOG(TXMAX)) / - 1 (2.0*EPS*TXMAX) - TXBIG = 4.0/SQRT(SQEPS) - XBIG = TXBIG - (SQEPS*TXBIG**2 - 2.0*LOG(TXBIG)) / - 1 (2.*SQEPS*TXBIG) - ENDIF - FIRST = .FALSE. -C - IF (X.LT.(-0.625) .OR. X.GT.0.8125) GO TO 20 -C - IF (X.LT.0.0) R9LN2R = 0.375 + CSEVL (16.*X/5.+1.0, LN21CS, - 1 NTLN21) - IF (X.GE.0.0) R9LN2R = 0.375 + CSEVL (32.*X/13.-1.0, LN22CS, - 1 NTLN22) - RETURN -C - 20 IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'R9LN2R', - + 'ANSWER LT HALF PRECISION BECAUSE X IS TOO NEAR -1', 1, 1) - IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'R9LN2R', - + 'NO PRECISION IN ANSWER BECAUSE X IS TOO BIG', 3, 2) - IF (X .GT. XBIG) CALL XERMSG ('SLATEC', 'R9LN2R', - + 'ANSWER LT HALF PRECISION BECAUSE X IS TOO BIG', 2, 1) -C - R9LN2R = (LOG(1.0+X) - X*(1.0-0.5*X) ) / X**3 - RETURN -C - END diff --git a/slatec/r9pak.f b/slatec/r9pak.f deleted file mode 100644 index 42127ea..0000000 --- a/slatec/r9pak.f +++ /dev/null @@ -1,67 +0,0 @@ -*DECK R9PAK - FUNCTION R9PAK (Y, N) -C***BEGIN PROLOGUE R9PAK -C***PURPOSE Pack a base 2 exponent into a floating point number. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY A6B -C***TYPE SINGLE PRECISION (R9PAK-S, D9PAK-D) -C***KEYWORDS FNLIB, PACK -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Pack a base 2 exponent into floating point number Y. This -C routine is almost the inverse of R9UPAK. It is not exactly -C the inverse, because ABS(X) need not be between 0.5 and -C 1.0. If both R9PAK and 2.0**N were known to be in range, we -C could compute -C R9PAK = Y * 2.0**N . -C -C***REFERENCES (NONE) -C***ROUTINES CALLED I1MACH, R1MACH, R9UPAK, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790801 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 901009 Routine used I1MACH(7) where it should use I1MACH(10), -C Corrected (RWC) -C***END PROLOGUE R9PAK - LOGICAL FIRST - SAVE NMIN, NMAX, A1N210, FIRST - DATA A1N210 / 3.321928094 887362 E0/ - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT R9PAK - IF (FIRST) THEN - A1N2B = 1.0 - IF (I1MACH(10).NE.2) A1N2B = R1MACH(5)*A1N210 - NMIN = A1N2B*I1MACH(12) - NMAX = A1N2B*I1MACH(13) - ENDIF - FIRST = .FALSE. -C - CALL R9UPAK(Y,R9PAK,NY) -C - NSUM = N + NY - IF (NSUM.LT.NMIN) GO TO 40 - IF (NSUM .GT. NMAX) CALL XERMSG ('SLATEC', 'R9PAK', - + 'PACKED NUMBER OVERFLOWS', 2, 2) -C - IF (NSUM.EQ.0) RETURN - IF (NSUM.GT.0) GO TO 30 -C - 20 R9PAK = 0.5*R9PAK - NSUM = NSUM + 1 - IF(NSUM.NE.0) GO TO 20 - RETURN -C -30 R9PAK = 2.0*R9PAK - NSUM = NSUM - 1 - IF(NSUM.NE.0) GO TO 30 - RETURN -C -40 CALL XERMSG ('SLATEC', 'R9PAK', 'PACKED NUMBER UNDERFLOWS', 1, 1) - R9PAK = 0.0 - RETURN -C - END diff --git a/slatec/r9upak.f b/slatec/r9upak.f deleted file mode 100644 index 27f2eff..0000000 --- a/slatec/r9upak.f +++ /dev/null @@ -1,40 +0,0 @@ -*DECK R9UPAK - SUBROUTINE R9UPAK (X, Y, N) -C***BEGIN PROLOGUE R9UPAK -C***PURPOSE Unpack a floating point number X so that X = Y*2**N. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY A6B -C***TYPE SINGLE PRECISION (R9UPAK-S, D9UPAK-D) -C***KEYWORDS FNLIB, UNPACK -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Unpack a floating point number X so that X = Y*2.0**N, where -C 0.5 .LE. ABS(Y) .LT. 1.0. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 780701 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE R9UPAK -C***FIRST EXECUTABLE STATEMENT R9UPAK - ABSX = ABS(X) - N = 0 - IF (X.EQ.0.0E0) GO TO 30 -C - 10 IF (ABSX.GE.0.5E0) GO TO 20 - N = N-1 - ABSX = ABSX*2.0E0 - GO TO 10 -C - 20 IF (ABSX.LT.1.0E0) GO TO 30 - N = N+1 - ABSX = ABSX*0.5E0 - GO TO 20 -C - 30 Y = SIGN(ABSX,X) - RETURN -C - END diff --git a/slatec/radb2.f b/slatec/radb2.f deleted file mode 100644 index 7bff5de..0000000 --- a/slatec/radb2.f +++ /dev/null @@ -1,61 +0,0 @@ -*DECK RADB2 - SUBROUTINE RADB2 (IDO, L1, CC, CH, WA1) -C***BEGIN PROLOGUE RADB2 -C***SUBSIDIARY -C***PURPOSE Calculate the fast Fourier transform of subvectors of -C length two. -C***LIBRARY SLATEC (FFTPACK) -C***TYPE SINGLE PRECISION (RADB2-S) -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C changing dummy array size declarations (1) to (*). -C 881128 Modified by Dick Valent to meet prologue standards. -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE RADB2 - DIMENSION CC(IDO,2,*), CH(IDO,L1,2), WA1(*) -C***FIRST EXECUTABLE STATEMENT RADB2 - DO 101 K=1,L1 - CH(1,K,1) = CC(1,1,K)+CC(IDO,2,K) - CH(1,K,2) = CC(1,1,K)-CC(IDO,2,K) - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 - IF((IDO-1)/2.LT.L1) GO TO 108 - DO 104 K=1,L1 -CDIR$ IVDEP - DO 103 I=3,IDO,2 - IC = IDP2-I - CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K) - TR2 = CC(I-1,1,K)-CC(IC-1,2,K) - CH(I,K,1) = CC(I,1,K)-CC(IC,2,K) - TI2 = CC(I,1,K)+CC(IC,2,K) - CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2 - CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2 - 103 CONTINUE - 104 CONTINUE - GO TO 111 - 108 DO 110 I=3,IDO,2 - IC = IDP2-I -CDIR$ IVDEP - DO 109 K=1,L1 - CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K) - TR2 = CC(I-1,1,K)-CC(IC-1,2,K) - CH(I,K,1) = CC(I,1,K)-CC(IC,2,K) - TI2 = CC(I,1,K)+CC(IC,2,K) - CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2 - CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2 - 109 CONTINUE - 110 CONTINUE - 111 IF (MOD(IDO,2) .EQ. 1) RETURN - 105 DO 106 K=1,L1 - CH(IDO,K,1) = CC(IDO,1,K)+CC(IDO,1,K) - CH(IDO,K,2) = -(CC(1,2,K)+CC(1,2,K)) - 106 CONTINUE - 107 RETURN - END diff --git a/slatec/radb3.f b/slatec/radb3.f deleted file mode 100644 index ae40565..0000000 --- a/slatec/radb3.f +++ /dev/null @@ -1,85 +0,0 @@ -*DECK RADB3 - SUBROUTINE RADB3 (IDO, L1, CC, CH, WA1, WA2) -C***BEGIN PROLOGUE RADB3 -C***SUBSIDIARY -C***PURPOSE Calculate the fast Fourier transform of subvectors of -C length three. -C***LIBRARY SLATEC (FFTPACK) -C***TYPE SINGLE PRECISION (RADB3-S) -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C (a) changing dummy array size declarations (1) to (*), -C (b) changing definition of variable TAUI by using -C FORTRAN intrinsic function SQRT instead of a DATA -C statement. -C 881128 Modified by Dick Valent to meet prologue standards. -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE RADB3 - DIMENSION CC(IDO,3,*), CH(IDO,L1,3), WA1(*), WA2(*) -C***FIRST EXECUTABLE STATEMENT RADB3 - TAUR = -.5 - TAUI = .5*SQRT(3.) - DO 101 K=1,L1 - TR2 = CC(IDO,2,K)+CC(IDO,2,K) - CR2 = CC(1,1,K)+TAUR*TR2 - CH(1,K,1) = CC(1,1,K)+TR2 - CI3 = TAUI*(CC(1,3,K)+CC(1,3,K)) - CH(1,K,2) = CR2-CI3 - CH(1,K,3) = CR2+CI3 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 - IF((IDO-1)/2.LT.L1) GO TO 104 - DO 103 K=1,L1 -CDIR$ IVDEP - DO 102 I=3,IDO,2 - IC = IDP2-I - TR2 = CC(I-1,3,K)+CC(IC-1,2,K) - CR2 = CC(I-1,1,K)+TAUR*TR2 - CH(I-1,K,1) = CC(I-1,1,K)+TR2 - TI2 = CC(I,3,K)-CC(IC,2,K) - CI2 = CC(I,1,K)+TAUR*TI2 - CH(I,K,1) = CC(I,1,K)+TI2 - CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K)) - CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K)) - DR2 = CR2-CI3 - DR3 = CR2+CI3 - DI2 = CI2+CR3 - DI3 = CI2-CR3 - CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 - CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 - CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 - CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 - 102 CONTINUE - 103 CONTINUE - RETURN - 104 DO 106 I=3,IDO,2 - IC = IDP2-I -CDIR$ IVDEP - DO 105 K=1,L1 - TR2 = CC(I-1,3,K)+CC(IC-1,2,K) - CR2 = CC(I-1,1,K)+TAUR*TR2 - CH(I-1,K,1) = CC(I-1,1,K)+TR2 - TI2 = CC(I,3,K)-CC(IC,2,K) - CI2 = CC(I,1,K)+TAUR*TI2 - CH(I,K,1) = CC(I,1,K)+TI2 - CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K)) - CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K)) - DR2 = CR2-CI3 - DR3 = CR2+CI3 - DI2 = CI2+CR3 - DI3 = CI2-CR3 - CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 - CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 - CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 - CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 - 105 CONTINUE - 106 CONTINUE - RETURN - END diff --git a/slatec/radb4.f b/slatec/radb4.f deleted file mode 100644 index 7f88c9c..0000000 --- a/slatec/radb4.f +++ /dev/null @@ -1,109 +0,0 @@ -*DECK RADB4 - SUBROUTINE RADB4 (IDO, L1, CC, CH, WA1, WA2, WA3) -C***BEGIN PROLOGUE RADB4 -C***SUBSIDIARY -C***PURPOSE Calculate the fast Fourier transform of subvectors of -C length four. -C***LIBRARY SLATEC (FFTPACK) -C***TYPE SINGLE PRECISION (RADB4-S) -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C (a) changing dummy array size declarations (1) to (*), -C (b) changing definition of variable SQRT2 by using -C FORTRAN intrinsic function SQRT instead of a DATA -C statement. -C 881128 Modified by Dick Valent to meet prologue standards. -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE RADB4 - DIMENSION CC(IDO,4,*), CH(IDO,L1,4), WA1(*), WA2(*), WA3(*) -C***FIRST EXECUTABLE STATEMENT RADB4 - SQRT2 = SQRT(2.) - DO 101 K=1,L1 - TR1 = CC(1,1,K)-CC(IDO,4,K) - TR2 = CC(1,1,K)+CC(IDO,4,K) - TR3 = CC(IDO,2,K)+CC(IDO,2,K) - TR4 = CC(1,3,K)+CC(1,3,K) - CH(1,K,1) = TR2+TR3 - CH(1,K,2) = TR1-TR4 - CH(1,K,3) = TR2-TR3 - CH(1,K,4) = TR1+TR4 - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 - IF((IDO-1)/2.LT.L1) GO TO 108 - DO 104 K=1,L1 -CDIR$ IVDEP - DO 103 I=3,IDO,2 - IC = IDP2-I - TI1 = CC(I,1,K)+CC(IC,4,K) - TI2 = CC(I,1,K)-CC(IC,4,K) - TI3 = CC(I,3,K)-CC(IC,2,K) - TR4 = CC(I,3,K)+CC(IC,2,K) - TR1 = CC(I-1,1,K)-CC(IC-1,4,K) - TR2 = CC(I-1,1,K)+CC(IC-1,4,K) - TI4 = CC(I-1,3,K)-CC(IC-1,2,K) - TR3 = CC(I-1,3,K)+CC(IC-1,2,K) - CH(I-1,K,1) = TR2+TR3 - CR3 = TR2-TR3 - CH(I,K,1) = TI2+TI3 - CI3 = TI2-TI3 - CR2 = TR1-TR4 - CR4 = TR1+TR4 - CI2 = TI1+TI4 - CI4 = TI1-TI4 - CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2 - CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2 - CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3 - CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3 - CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4 - CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4 - 103 CONTINUE - 104 CONTINUE - GO TO 111 - 108 DO 110 I=3,IDO,2 - IC = IDP2-I -CDIR$ IVDEP - DO 109 K=1,L1 - TI1 = CC(I,1,K)+CC(IC,4,K) - TI2 = CC(I,1,K)-CC(IC,4,K) - TI3 = CC(I,3,K)-CC(IC,2,K) - TR4 = CC(I,3,K)+CC(IC,2,K) - TR1 = CC(I-1,1,K)-CC(IC-1,4,K) - TR2 = CC(I-1,1,K)+CC(IC-1,4,K) - TI4 = CC(I-1,3,K)-CC(IC-1,2,K) - TR3 = CC(I-1,3,K)+CC(IC-1,2,K) - CH(I-1,K,1) = TR2+TR3 - CR3 = TR2-TR3 - CH(I,K,1) = TI2+TI3 - CI3 = TI2-TI3 - CR2 = TR1-TR4 - CR4 = TR1+TR4 - CI2 = TI1+TI4 - CI4 = TI1-TI4 - CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2 - CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2 - CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3 - CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3 - CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4 - CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4 - 109 CONTINUE - 110 CONTINUE - 111 IF (MOD(IDO,2) .EQ. 1) RETURN - 105 DO 106 K=1,L1 - TI1 = CC(1,2,K)+CC(1,4,K) - TI2 = CC(1,4,K)-CC(1,2,K) - TR1 = CC(IDO,1,K)-CC(IDO,3,K) - TR2 = CC(IDO,1,K)+CC(IDO,3,K) - CH(IDO,K,1) = TR2+TR2 - CH(IDO,K,2) = SQRT2*(TR1-TI1) - CH(IDO,K,3) = TI2+TI2 - CH(IDO,K,4) = -SQRT2*(TR1+TI1) - 106 CONTINUE - 107 RETURN - END diff --git a/slatec/radb5.f b/slatec/radb5.f deleted file mode 100644 index bf72475..0000000 --- a/slatec/radb5.f +++ /dev/null @@ -1,132 +0,0 @@ -*DECK RADB5 - SUBROUTINE RADB5 (IDO, L1, CC, CH, WA1, WA2, WA3, WA4) -C***BEGIN PROLOGUE RADB5 -C***SUBSIDIARY -C***PURPOSE Calculate the fast Fourier transform of subvectors of -C length five. -C***LIBRARY SLATEC (FFTPACK) -C***TYPE SINGLE PRECISION (RADB5-S) -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C (a) changing dummy array size declarations (1) to (*), -C (b) changing definition of variables PI, TI11, TI12, -C TR11, TR12 by using FORTRAN intrinsic functions ATAN -C and SIN instead of DATA statements. -C 881128 Modified by Dick Valent to meet prologue standards. -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE RADB5 - DIMENSION CC(IDO,5,*), CH(IDO,L1,5), WA1(*), WA2(*), WA3(*), - + WA4(*) -C***FIRST EXECUTABLE STATEMENT RADB5 - PI = 4.*ATAN(1.) - TR11 = SIN(.1*PI) - TI11 = SIN(.4*PI) - TR12 = -SIN(.3*PI) - TI12 = SIN(.2*PI) - DO 101 K=1,L1 - TI5 = CC(1,3,K)+CC(1,3,K) - TI4 = CC(1,5,K)+CC(1,5,K) - TR2 = CC(IDO,2,K)+CC(IDO,2,K) - TR3 = CC(IDO,4,K)+CC(IDO,4,K) - CH(1,K,1) = CC(1,1,K)+TR2+TR3 - CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 - CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 - CI5 = TI11*TI5+TI12*TI4 - CI4 = TI12*TI5-TI11*TI4 - CH(1,K,2) = CR2-CI5 - CH(1,K,3) = CR3-CI4 - CH(1,K,4) = CR3+CI4 - CH(1,K,5) = CR2+CI5 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 - IF((IDO-1)/2.LT.L1) GO TO 104 - DO 103 K=1,L1 -CDIR$ IVDEP - DO 102 I=3,IDO,2 - IC = IDP2-I - TI5 = CC(I,3,K)+CC(IC,2,K) - TI2 = CC(I,3,K)-CC(IC,2,K) - TI4 = CC(I,5,K)+CC(IC,4,K) - TI3 = CC(I,5,K)-CC(IC,4,K) - TR5 = CC(I-1,3,K)-CC(IC-1,2,K) - TR2 = CC(I-1,3,K)+CC(IC-1,2,K) - TR4 = CC(I-1,5,K)-CC(IC-1,4,K) - TR3 = CC(I-1,5,K)+CC(IC-1,4,K) - CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 - CH(I,K,1) = CC(I,1,K)+TI2+TI3 - CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 - CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 - CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 - CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 - CR5 = TI11*TR5+TI12*TR4 - CI5 = TI11*TI5+TI12*TI4 - CR4 = TI12*TR5-TI11*TR4 - CI4 = TI12*TI5-TI11*TI4 - DR3 = CR3-CI4 - DR4 = CR3+CI4 - DI3 = CI3+CR4 - DI4 = CI3-CR4 - DR5 = CR2+CI5 - DR2 = CR2-CI5 - DI5 = CI2-CR5 - DI2 = CI2+CR5 - CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 - CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 - CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 - CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 - CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4 - CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4 - CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5 - CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5 - 102 CONTINUE - 103 CONTINUE - RETURN - 104 DO 106 I=3,IDO,2 - IC = IDP2-I -CDIR$ IVDEP - DO 105 K=1,L1 - TI5 = CC(I,3,K)+CC(IC,2,K) - TI2 = CC(I,3,K)-CC(IC,2,K) - TI4 = CC(I,5,K)+CC(IC,4,K) - TI3 = CC(I,5,K)-CC(IC,4,K) - TR5 = CC(I-1,3,K)-CC(IC-1,2,K) - TR2 = CC(I-1,3,K)+CC(IC-1,2,K) - TR4 = CC(I-1,5,K)-CC(IC-1,4,K) - TR3 = CC(I-1,5,K)+CC(IC-1,4,K) - CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 - CH(I,K,1) = CC(I,1,K)+TI2+TI3 - CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 - CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 - CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 - CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 - CR5 = TI11*TR5+TI12*TR4 - CI5 = TI11*TI5+TI12*TI4 - CR4 = TI12*TR5-TI11*TR4 - CI4 = TI12*TI5-TI11*TI4 - DR3 = CR3-CI4 - DR4 = CR3+CI4 - DI3 = CI3+CR4 - DI4 = CI3-CR4 - DR5 = CR2+CI5 - DR2 = CR2-CI5 - DI5 = CI2-CR5 - DI2 = CI2+CR5 - CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 - CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 - CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 - CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 - CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4 - CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4 - CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5 - CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5 - 105 CONTINUE - 106 CONTINUE - RETURN - END diff --git a/slatec/radbg.f b/slatec/radbg.f deleted file mode 100644 index e8ccc06..0000000 --- a/slatec/radbg.f +++ /dev/null @@ -1,189 +0,0 @@ -*DECK RADBG - SUBROUTINE RADBG (IDO, IP, L1, IDL1, CC, C1, C2, CH, CH2, WA) -C***BEGIN PROLOGUE RADBG -C***SUBSIDIARY -C***PURPOSE Calculate the fast Fourier transform of subvectors of -C arbitrary length. -C***LIBRARY SLATEC (FFTPACK) -C***TYPE SINGLE PRECISION (RADBG-S) -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C (a) changing dummy array size declarations (1) to (*), -C (b) changing references to intrinsic function FLOAT -C to REAL, and -C (c) changing definition of variable TPI by using -C FORTRAN intrinsic function ATAN instead of a DATA -C statement. -C 881128 Modified by Dick Valent to meet prologue standards. -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE RADBG - DIMENSION CH(IDO,L1,*), CC(IDO,IP,*), C1(IDO,L1,*), - + C2(IDL1,*), CH2(IDL1,*), WA(*) -C***FIRST EXECUTABLE STATEMENT RADBG - TPI = 8.*ATAN(1.) - ARG = TPI/IP - DCP = COS(ARG) - DSP = SIN(ARG) - IDP2 = IDO+2 - NBD = (IDO-1)/2 - IPP2 = IP+2 - IPPH = (IP+1)/2 - IF (IDO .LT. L1) GO TO 103 - DO 102 K=1,L1 - DO 101 I=1,IDO - CH(I,K,1) = CC(I,1,K) - 101 CONTINUE - 102 CONTINUE - GO TO 106 - 103 DO 105 I=1,IDO - DO 104 K=1,L1 - CH(I,K,1) = CC(I,1,K) - 104 CONTINUE - 105 CONTINUE - 106 DO 108 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 107 K=1,L1 - CH(1,K,J) = CC(IDO,J2-2,K)+CC(IDO,J2-2,K) - CH(1,K,JC) = CC(1,J2-1,K)+CC(1,J2-1,K) - 107 CONTINUE - 108 CONTINUE - IF (IDO .EQ. 1) GO TO 116 - IF (NBD .LT. L1) GO TO 112 - DO 111 J=2,IPPH - JC = IPP2-J - DO 110 K=1,L1 -CDIR$ IVDEP - DO 109 I=3,IDO,2 - IC = IDP2-I - CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) - CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) - CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) - CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K) - 109 CONTINUE - 110 CONTINUE - 111 CONTINUE - GO TO 116 - 112 DO 115 J=2,IPPH - JC = IPP2-J -CDIR$ IVDEP - DO 114 I=3,IDO,2 - IC = IDP2-I - DO 113 K=1,L1 - CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) - CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) - CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) - CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K) - 113 CONTINUE - 114 CONTINUE - 115 CONTINUE - 116 AR1 = 1. - AI1 = 0. - DO 120 L=2,IPPH - LC = IPP2-L - AR1H = DCP*AR1-DSP*AI1 - AI1 = DCP*AI1+DSP*AR1 - AR1 = AR1H - DO 117 IK=1,IDL1 - C2(IK,L) = CH2(IK,1)+AR1*CH2(IK,2) - C2(IK,LC) = AI1*CH2(IK,IP) - 117 CONTINUE - DC2 = AR1 - DS2 = AI1 - AR2 = AR1 - AI2 = AI1 - DO 119 J=3,IPPH - JC = IPP2-J - AR2H = DC2*AR2-DS2*AI2 - AI2 = DC2*AI2+DS2*AR2 - AR2 = AR2H - DO 118 IK=1,IDL1 - C2(IK,L) = C2(IK,L)+AR2*CH2(IK,J) - C2(IK,LC) = C2(IK,LC)+AI2*CH2(IK,JC) - 118 CONTINUE - 119 CONTINUE - 120 CONTINUE - DO 122 J=2,IPPH - DO 121 IK=1,IDL1 - CH2(IK,1) = CH2(IK,1)+CH2(IK,J) - 121 CONTINUE - 122 CONTINUE - DO 124 J=2,IPPH - JC = IPP2-J - DO 123 K=1,L1 - CH(1,K,J) = C1(1,K,J)-C1(1,K,JC) - CH(1,K,JC) = C1(1,K,J)+C1(1,K,JC) - 123 CONTINUE - 124 CONTINUE - IF (IDO .EQ. 1) GO TO 132 - IF (NBD .LT. L1) GO TO 128 - DO 127 J=2,IPPH - JC = IPP2-J - DO 126 K=1,L1 -CDIR$ IVDEP - DO 125 I=3,IDO,2 - CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) - CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) - CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) - CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC) - 125 CONTINUE - 126 CONTINUE - 127 CONTINUE - GO TO 132 - 128 DO 131 J=2,IPPH - JC = IPP2-J - DO 130 I=3,IDO,2 - DO 129 K=1,L1 - CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) - CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) - CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) - CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC) - 129 CONTINUE - 130 CONTINUE - 131 CONTINUE - 132 CONTINUE - IF (IDO .EQ. 1) RETURN - DO 133 IK=1,IDL1 - C2(IK,1) = CH2(IK,1) - 133 CONTINUE - DO 135 J=2,IP - DO 134 K=1,L1 - C1(1,K,J) = CH(1,K,J) - 134 CONTINUE - 135 CONTINUE - IF (NBD .GT. L1) GO TO 139 - IS = -IDO - DO 138 J=2,IP - IS = IS+IDO - IDIJ = IS - DO 137 I=3,IDO,2 - IDIJ = IDIJ+2 - DO 136 K=1,L1 - C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) - C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) - 136 CONTINUE - 137 CONTINUE - 138 CONTINUE - GO TO 143 - 139 IS = -IDO - DO 142 J=2,IP - IS = IS+IDO - DO 141 K=1,L1 - IDIJ = IS -CDIR$ IVDEP - DO 140 I=3,IDO,2 - IDIJ = IDIJ+2 - C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) - C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) - 140 CONTINUE - 141 CONTINUE - 142 CONTINUE - 143 RETURN - END diff --git a/slatec/radf2.f b/slatec/radf2.f deleted file mode 100644 index 99a50e5..0000000 --- a/slatec/radf2.f +++ /dev/null @@ -1,61 +0,0 @@ -*DECK RADF2 - SUBROUTINE RADF2 (IDO, L1, CC, CH, WA1) -C***BEGIN PROLOGUE RADF2 -C***SUBSIDIARY -C***PURPOSE Calculate the fast Fourier transform of subvectors of -C length two. -C***LIBRARY SLATEC (FFTPACK) -C***TYPE SINGLE PRECISION (RADF2-S) -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C changing dummy array size declarations (1) to (*). -C 881128 Modified by Dick Valent to meet prologue standards. -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE RADF2 - DIMENSION CH(IDO,2,*), CC(IDO,L1,2), WA1(*) -C***FIRST EXECUTABLE STATEMENT RADF2 - DO 101 K=1,L1 - CH(1,1,K) = CC(1,K,1)+CC(1,K,2) - CH(IDO,2,K) = CC(1,K,1)-CC(1,K,2) - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 - IF((IDO-1)/2.LT.L1) GO TO 108 - DO 104 K=1,L1 -CDIR$ IVDEP - DO 103 I=3,IDO,2 - IC = IDP2-I - TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - CH(I,1,K) = CC(I,K,1)+TI2 - CH(IC,2,K) = TI2-CC(I,K,1) - CH(I-1,1,K) = CC(I-1,K,1)+TR2 - CH(IC-1,2,K) = CC(I-1,K,1)-TR2 - 103 CONTINUE - 104 CONTINUE - GO TO 111 - 108 DO 110 I=3,IDO,2 - IC = IDP2-I -CDIR$ IVDEP - DO 109 K=1,L1 - TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - CH(I,1,K) = CC(I,K,1)+TI2 - CH(IC,2,K) = TI2-CC(I,K,1) - CH(I-1,1,K) = CC(I-1,K,1)+TR2 - CH(IC-1,2,K) = CC(I-1,K,1)-TR2 - 109 CONTINUE - 110 CONTINUE - 111 IF (MOD(IDO,2) .EQ. 1) RETURN - 105 DO 106 K=1,L1 - CH(1,2,K) = -CC(IDO,K,2) - CH(IDO,1,K) = CC(IDO,K,1) - 106 CONTINUE - 107 RETURN - END diff --git a/slatec/radf3.f b/slatec/radf3.f deleted file mode 100644 index 6449e32..0000000 --- a/slatec/radf3.f +++ /dev/null @@ -1,83 +0,0 @@ -*DECK RADF3 - SUBROUTINE RADF3 (IDO, L1, CC, CH, WA1, WA2) -C***BEGIN PROLOGUE RADF3 -C***SUBSIDIARY -C***PURPOSE Calculate the fast Fourier transform of subvectors of -C length three. -C***LIBRARY SLATEC (FFTPACK) -C***TYPE SINGLE PRECISION (RADF3-S) -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C (a) changing dummy array size declarations (1) to (*), -C (b) changing definition of variable TAUI by using -C FORTRAN intrinsic function SQRT instead of a DATA -C statement. -C 881128 Modified by Dick Valent to meet prologue standards. -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE RADF3 - DIMENSION CH(IDO,3,*), CC(IDO,L1,3), WA1(*), WA2(*) -C***FIRST EXECUTABLE STATEMENT RADF3 - TAUR = -.5 - TAUI = .5*SQRT(3.) - DO 101 K=1,L1 - CR2 = CC(1,K,2)+CC(1,K,3) - CH(1,1,K) = CC(1,K,1)+CR2 - CH(1,3,K) = TAUI*(CC(1,K,3)-CC(1,K,2)) - CH(IDO,2,K) = CC(1,K,1)+TAUR*CR2 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 - IF((IDO-1)/2.LT.L1) GO TO 104 - DO 103 K=1,L1 -CDIR$ IVDEP - DO 102 I=3,IDO,2 - IC = IDP2-I - DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) - DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) - CR2 = DR2+DR3 - CI2 = DI2+DI3 - CH(I-1,1,K) = CC(I-1,K,1)+CR2 - CH(I,1,K) = CC(I,K,1)+CI2 - TR2 = CC(I-1,K,1)+TAUR*CR2 - TI2 = CC(I,K,1)+TAUR*CI2 - TR3 = TAUI*(DI2-DI3) - TI3 = TAUI*(DR3-DR2) - CH(I-1,3,K) = TR2+TR3 - CH(IC-1,2,K) = TR2-TR3 - CH(I,3,K) = TI2+TI3 - CH(IC,2,K) = TI3-TI2 - 102 CONTINUE - 103 CONTINUE - RETURN - 104 DO 106 I=3,IDO,2 - IC = IDP2-I -CDIR$ IVDEP - DO 105 K=1,L1 - DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) - DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) - CR2 = DR2+DR3 - CI2 = DI2+DI3 - CH(I-1,1,K) = CC(I-1,K,1)+CR2 - CH(I,1,K) = CC(I,K,1)+CI2 - TR2 = CC(I-1,K,1)+TAUR*CR2 - TI2 = CC(I,K,1)+TAUR*CI2 - TR3 = TAUI*(DI2-DI3) - TI3 = TAUI*(DR3-DR2) - CH(I-1,3,K) = TR2+TR3 - CH(IC-1,2,K) = TR2-TR3 - CH(I,3,K) = TI2+TI3 - CH(IC,2,K) = TI3-TI2 - 105 CONTINUE - 106 CONTINUE - RETURN - END diff --git a/slatec/radf4.f b/slatec/radf4.f deleted file mode 100644 index 1766c93..0000000 --- a/slatec/radf4.f +++ /dev/null @@ -1,105 +0,0 @@ -*DECK RADF4 - SUBROUTINE RADF4 (IDO, L1, CC, CH, WA1, WA2, WA3) -C***BEGIN PROLOGUE RADF4 -C***SUBSIDIARY -C***PURPOSE Calculate the fast Fourier transform of subvectors of -C length four. -C***LIBRARY SLATEC (FFTPACK) -C***TYPE SINGLE PRECISION (RADF4-S) -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C (a) changing dummy array size declarations (1) to (*). -C (b) changing definition of variable HSQT2 by using -C FORTRAN intrinsic function SQRT instead of a DATA -C statement. -C 881128 Modified by Dick Valent to meet prologue standards. -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE RADF4 - DIMENSION CC(IDO,L1,4), CH(IDO,4,*), WA1(*), WA2(*), WA3(*) -C***FIRST EXECUTABLE STATEMENT RADF4 - HSQT2 = .5*SQRT(2.) - DO 101 K=1,L1 - TR1 = CC(1,K,2)+CC(1,K,4) - TR2 = CC(1,K,1)+CC(1,K,3) - CH(1,1,K) = TR1+TR2 - CH(IDO,4,K) = TR2-TR1 - CH(IDO,2,K) = CC(1,K,1)-CC(1,K,3) - CH(1,3,K) = CC(1,K,4)-CC(1,K,2) - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 - IF((IDO-1)/2.LT.L1) GO TO 111 - DO 104 K=1,L1 -CDIR$ IVDEP - DO 103 I=3,IDO,2 - IC = IDP2-I - CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) - CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) - CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) - CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) - TR1 = CR2+CR4 - TR4 = CR4-CR2 - TI1 = CI2+CI4 - TI4 = CI2-CI4 - TI2 = CC(I,K,1)+CI3 - TI3 = CC(I,K,1)-CI3 - TR2 = CC(I-1,K,1)+CR3 - TR3 = CC(I-1,K,1)-CR3 - CH(I-1,1,K) = TR1+TR2 - CH(IC-1,4,K) = TR2-TR1 - CH(I,1,K) = TI1+TI2 - CH(IC,4,K) = TI1-TI2 - CH(I-1,3,K) = TI4+TR3 - CH(IC-1,2,K) = TR3-TI4 - CH(I,3,K) = TR4+TI3 - CH(IC,2,K) = TR4-TI3 - 103 CONTINUE - 104 CONTINUE - GO TO 110 - 111 DO 109 I=3,IDO,2 - IC = IDP2-I -CDIR$ IVDEP - DO 108 K=1,L1 - CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) - CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) - CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) - CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) - TR1 = CR2+CR4 - TR4 = CR4-CR2 - TI1 = CI2+CI4 - TI4 = CI2-CI4 - TI2 = CC(I,K,1)+CI3 - TI3 = CC(I,K,1)-CI3 - TR2 = CC(I-1,K,1)+CR3 - TR3 = CC(I-1,K,1)-CR3 - CH(I-1,1,K) = TR1+TR2 - CH(IC-1,4,K) = TR2-TR1 - CH(I,1,K) = TI1+TI2 - CH(IC,4,K) = TI1-TI2 - CH(I-1,3,K) = TI4+TR3 - CH(IC-1,2,K) = TR3-TI4 - CH(I,3,K) = TR4+TI3 - CH(IC,2,K) = TR4-TI3 - 108 CONTINUE - 109 CONTINUE - 110 IF (MOD(IDO,2) .EQ. 1) RETURN - 105 DO 106 K=1,L1 - TI1 = -HSQT2*(CC(IDO,K,2)+CC(IDO,K,4)) - TR1 = HSQT2*(CC(IDO,K,2)-CC(IDO,K,4)) - CH(IDO,1,K) = TR1+CC(IDO,K,1) - CH(IDO,3,K) = CC(IDO,K,1)-TR1 - CH(1,2,K) = TI1-CC(IDO,K,3) - CH(1,4,K) = TI1+CC(IDO,K,3) - 106 CONTINUE - 107 RETURN - END diff --git a/slatec/radf5.f b/slatec/radf5.f deleted file mode 100644 index 9ffcc1f..0000000 --- a/slatec/radf5.f +++ /dev/null @@ -1,128 +0,0 @@ -*DECK RADF5 - SUBROUTINE RADF5 (IDO, L1, CC, CH, WA1, WA2, WA3, WA4) -C***BEGIN PROLOGUE RADF5 -C***SUBSIDIARY -C***PURPOSE Calculate the fast Fourier transform of subvectors of -C length five. -C***LIBRARY SLATEC (FFTPACK) -C***TYPE SINGLE PRECISION (RADF5-S) -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C (a) changing dummy array size declarations (1) to (*), -C (b) changing definition of variables PI, TI11, TI12, -C TR11, TR12 by using FORTRAN intrinsic functions ATAN -C and SIN instead of DATA statements. -C 881128 Modified by Dick Valent to meet prologue standards. -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE RADF5 - DIMENSION CC(IDO,L1,5), CH(IDO,5,*), WA1(*), WA2(*), WA3(*), - + WA4(*) -C***FIRST EXECUTABLE STATEMENT RADF5 - PI = 4.*ATAN(1.) - TR11 = SIN(.1*PI) - TI11 = SIN(.4*PI) - TR12 = -SIN(.3*PI) - TI12 = SIN(.2*PI) - DO 101 K=1,L1 - CR2 = CC(1,K,5)+CC(1,K,2) - CI5 = CC(1,K,5)-CC(1,K,2) - CR3 = CC(1,K,4)+CC(1,K,3) - CI4 = CC(1,K,4)-CC(1,K,3) - CH(1,1,K) = CC(1,K,1)+CR2+CR3 - CH(IDO,2,K) = CC(1,K,1)+TR11*CR2+TR12*CR3 - CH(1,3,K) = TI11*CI5+TI12*CI4 - CH(IDO,4,K) = CC(1,K,1)+TR12*CR2+TR11*CR3 - CH(1,5,K) = TI12*CI5-TI11*CI4 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 - IF((IDO-1)/2.LT.L1) GO TO 104 - DO 103 K=1,L1 -CDIR$ IVDEP - DO 102 I=3,IDO,2 - IC = IDP2-I - DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) - DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) - DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) - DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) - DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5) - DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5) - CR2 = DR2+DR5 - CI5 = DR5-DR2 - CR5 = DI2-DI5 - CI2 = DI2+DI5 - CR3 = DR3+DR4 - CI4 = DR4-DR3 - CR4 = DI3-DI4 - CI3 = DI3+DI4 - CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3 - CH(I,1,K) = CC(I,K,1)+CI2+CI3 - TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3 - TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3 - TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3 - TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3 - TR5 = TI11*CR5+TI12*CR4 - TI5 = TI11*CI5+TI12*CI4 - TR4 = TI12*CR5-TI11*CR4 - TI4 = TI12*CI5-TI11*CI4 - CH(I-1,3,K) = TR2+TR5 - CH(IC-1,2,K) = TR2-TR5 - CH(I,3,K) = TI2+TI5 - CH(IC,2,K) = TI5-TI2 - CH(I-1,5,K) = TR3+TR4 - CH(IC-1,4,K) = TR3-TR4 - CH(I,5,K) = TI3+TI4 - CH(IC,4,K) = TI4-TI3 - 102 CONTINUE - 103 CONTINUE - RETURN - 104 DO 106 I=3,IDO,2 - IC = IDP2-I -CDIR$ IVDEP - DO 105 K=1,L1 - DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) - DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) - DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) - DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) - DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5) - DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5) - CR2 = DR2+DR5 - CI5 = DR5-DR2 - CR5 = DI2-DI5 - CI2 = DI2+DI5 - CR3 = DR3+DR4 - CI4 = DR4-DR3 - CR4 = DI3-DI4 - CI3 = DI3+DI4 - CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3 - CH(I,1,K) = CC(I,K,1)+CI2+CI3 - TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3 - TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3 - TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3 - TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3 - TR5 = TI11*CR5+TI12*CR4 - TI5 = TI11*CI5+TI12*CI4 - TR4 = TI12*CR5-TI11*CR4 - TI4 = TI12*CI5-TI11*CI4 - CH(I-1,3,K) = TR2+TR5 - CH(IC-1,2,K) = TR2-TR5 - CH(I,3,K) = TI2+TI5 - CH(IC,2,K) = TI5-TI2 - CH(I-1,5,K) = TR3+TR4 - CH(IC-1,4,K) = TR3-TR4 - CH(I,5,K) = TI3+TI4 - CH(IC,4,K) = TI4-TI3 - 105 CONTINUE - 106 CONTINUE - RETURN - END diff --git a/slatec/radfg.f b/slatec/radfg.f deleted file mode 100644 index ccb3d47..0000000 --- a/slatec/radfg.f +++ /dev/null @@ -1,194 +0,0 @@ -*DECK RADFG - SUBROUTINE RADFG (IDO, IP, L1, IDL1, CC, C1, C2, CH, CH2, WA) -C***BEGIN PROLOGUE RADFG -C***SUBSIDIARY -C***PURPOSE Calculate the fast Fourier transform of subvectors of -C arbitrary length. -C***LIBRARY SLATEC (FFTPACK) -C***TYPE SINGLE PRECISION (RADFG-S) -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C (a) changing dummy array size declarations (1) to (*), -C (b) changing references to intrinsic function FLOAT -C to REAL, and -C (c) changing definition of variable TPI by using -C FORTRAN intrinsic function ATAN instead of a DATA -C statement. -C 881128 Modified by Dick Valent to meet prologue standards. -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE RADFG - DIMENSION CH(IDO,L1,*), CC(IDO,IP,*), C1(IDO,L1,*), - + C2(IDL1,*), CH2(IDL1,*), WA(*) -C***FIRST EXECUTABLE STATEMENT RADFG - TPI = 8.*ATAN(1.) - ARG = TPI/IP - DCP = COS(ARG) - DSP = SIN(ARG) - IPPH = (IP+1)/2 - IPP2 = IP+2 - IDP2 = IDO+2 - NBD = (IDO-1)/2 - IF (IDO .EQ. 1) GO TO 119 - DO 101 IK=1,IDL1 - CH2(IK,1) = C2(IK,1) - 101 CONTINUE - DO 103 J=2,IP - DO 102 K=1,L1 - CH(1,K,J) = C1(1,K,J) - 102 CONTINUE - 103 CONTINUE - IF (NBD .GT. L1) GO TO 107 - IS = -IDO - DO 106 J=2,IP - IS = IS+IDO - IDIJ = IS - DO 105 I=3,IDO,2 - IDIJ = IDIJ+2 - DO 104 K=1,L1 - CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) - CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J) - 104 CONTINUE - 105 CONTINUE - 106 CONTINUE - GO TO 111 - 107 IS = -IDO - DO 110 J=2,IP - IS = IS+IDO - DO 109 K=1,L1 - IDIJ = IS -CDIR$ IVDEP - DO 108 I=3,IDO,2 - IDIJ = IDIJ+2 - CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) - CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J) - 108 CONTINUE - 109 CONTINUE - 110 CONTINUE - 111 IF (NBD .LT. L1) GO TO 115 - DO 114 J=2,IPPH - JC = IPP2-J - DO 113 K=1,L1 -CDIR$ IVDEP - DO 112 I=3,IDO,2 - C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) - C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) - C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) - C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J) - 112 CONTINUE - 113 CONTINUE - 114 CONTINUE - GO TO 121 - 115 DO 118 J=2,IPPH - JC = IPP2-J - DO 117 I=3,IDO,2 - DO 116 K=1,L1 - C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) - C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) - C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) - C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J) - 116 CONTINUE - 117 CONTINUE - 118 CONTINUE - GO TO 121 - 119 DO 120 IK=1,IDL1 - C2(IK,1) = CH2(IK,1) - 120 CONTINUE - 121 DO 123 J=2,IPPH - JC = IPP2-J - DO 122 K=1,L1 - C1(1,K,J) = CH(1,K,J)+CH(1,K,JC) - C1(1,K,JC) = CH(1,K,JC)-CH(1,K,J) - 122 CONTINUE - 123 CONTINUE -C - AR1 = 1. - AI1 = 0. - DO 127 L=2,IPPH - LC = IPP2-L - AR1H = DCP*AR1-DSP*AI1 - AI1 = DCP*AI1+DSP*AR1 - AR1 = AR1H - DO 124 IK=1,IDL1 - CH2(IK,L) = C2(IK,1)+AR1*C2(IK,2) - CH2(IK,LC) = AI1*C2(IK,IP) - 124 CONTINUE - DC2 = AR1 - DS2 = AI1 - AR2 = AR1 - AI2 = AI1 - DO 126 J=3,IPPH - JC = IPP2-J - AR2H = DC2*AR2-DS2*AI2 - AI2 = DC2*AI2+DS2*AR2 - AR2 = AR2H - DO 125 IK=1,IDL1 - CH2(IK,L) = CH2(IK,L)+AR2*C2(IK,J) - CH2(IK,LC) = CH2(IK,LC)+AI2*C2(IK,JC) - 125 CONTINUE - 126 CONTINUE - 127 CONTINUE - DO 129 J=2,IPPH - DO 128 IK=1,IDL1 - CH2(IK,1) = CH2(IK,1)+C2(IK,J) - 128 CONTINUE - 129 CONTINUE -C - IF (IDO .LT. L1) GO TO 132 - DO 131 K=1,L1 - DO 130 I=1,IDO - CC(I,1,K) = CH(I,K,1) - 130 CONTINUE - 131 CONTINUE - GO TO 135 - 132 DO 134 I=1,IDO - DO 133 K=1,L1 - CC(I,1,K) = CH(I,K,1) - 133 CONTINUE - 134 CONTINUE - 135 DO 137 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 136 K=1,L1 - CC(IDO,J2-2,K) = CH(1,K,J) - CC(1,J2-1,K) = CH(1,K,JC) - 136 CONTINUE - 137 CONTINUE - IF (IDO .EQ. 1) RETURN - IF (NBD .LT. L1) GO TO 141 - DO 140 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 139 K=1,L1 -CDIR$ IVDEP - DO 138 I=3,IDO,2 - IC = IDP2-I - CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) - CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) - CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) - CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J) - 138 CONTINUE - 139 CONTINUE - 140 CONTINUE - RETURN - 141 DO 144 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 143 I=3,IDO,2 - IC = IDP2-I - DO 142 K=1,L1 - CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) - CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) - CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) - CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J) - 142 CONTINUE - 143 CONTINUE - 144 CONTINUE - RETURN - END diff --git a/slatec/rand.f b/slatec/rand.f deleted file mode 100644 index 22fb974..0000000 --- a/slatec/rand.f +++ /dev/null @@ -1,122 +0,0 @@ -*DECK RAND - FUNCTION RAND (R) -C***BEGIN PROLOGUE RAND -C***PURPOSE Generate a uniformly distributed random number. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY L6A21 -C***TYPE SINGLE PRECISION (RAND-S) -C***KEYWORDS FNLIB, RANDOM NUMBER, SPECIAL FUNCTIONS, UNIFORM -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C This pseudo-random number generator is portable among a wide -C variety of computers. RAND(R) undoubtedly is not as good as many -C readily available installation dependent versions, and so this -C routine is not recommended for widespread usage. Its redeeming -C feature is that the exact same random numbers (to within final round- -C off error) can be generated from machine to machine. Thus, programs -C that make use of random numbers can be easily transported to and -C checked in a new environment. -C -C The random numbers are generated by the linear congruential -C method described, e.g., by Knuth in Seminumerical Methods (p.9), -C Addison-Wesley, 1969. Given the I-th number of a pseudo-random -C sequence, the I+1 -st number is generated from -C X(I+1) = (A*X(I) + C) MOD M, -C where here M = 2**22 = 4194304, C = 1731 and several suitable values -C of the multiplier A are discussed below. Both the multiplier A and -C random number X are represented in double precision as two 11-bit -C words. The constants are chosen so that the period is the maximum -C possible, 4194304. -C -C In order that the same numbers be generated from machine to -C machine, it is necessary that 23-bit integers be reducible modulo -C 2**11 exactly, that 23-bit integers be added exactly, and that 11-bit -C integers be multiplied exactly. Furthermore, if the restart option -C is used (where R is between 0 and 1), then the product R*2**22 = -C R*4194304 must be correct to the nearest integer. -C -C The first four random numbers should be .0004127026, -C .6750836372, .1614754200, and .9086198807. The tenth random number -C is .5527787209, and the hundredth is .3600893021 . The thousandth -C number should be .2176990509 . -C -C In order to generate several effectively independent sequences -C with the same generator, it is necessary to know the random number -C for several widely spaced calls. The I-th random number times 2**22, -C where I=K*P/8 and P is the period of the sequence (P = 2**22), is -C still of the form L*P/8. In particular we find the I-th random -C number multiplied by 2**22 is given by -C I = 0 1*P/8 2*P/8 3*P/8 4*P/8 5*P/8 6*P/8 7*P/8 8*P/8 -C RAND= 0 5*P/8 2*P/8 7*P/8 4*P/8 1*P/8 6*P/8 3*P/8 0 -C Thus the 4*P/8 = 2097152 random number is 2097152/2**22. -C -C Several multipliers have been subjected to the spectral test -C (see Knuth, p. 82). Four suitable multipliers roughly in order of -C goodness according to the spectral test are -C 3146757 = 1536*2048 + 1029 = 2**21 + 2**20 + 2**10 + 5 -C 2098181 = 1024*2048 + 1029 = 2**21 + 2**10 + 5 -C 3146245 = 1536*2048 + 517 = 2**21 + 2**20 + 2**9 + 5 -C 2776669 = 1355*2048 + 1629 = 5**9 + 7**7 + 1 -C -C In the table below LOG10(NU(I)) gives roughly the number of -C random decimal digits in the random numbers considered I at a time. -C C is the primary measure of goodness. In both cases bigger is better. -C -C LOG10 NU(I) C(I) -C A I=2 I=3 I=4 I=5 I=2 I=3 I=4 I=5 -C -C 3146757 3.3 2.0 1.6 1.3 3.1 1.3 4.6 2.6 -C 2098181 3.3 2.0 1.6 1.2 3.2 1.3 4.6 1.7 -C 3146245 3.3 2.2 1.5 1.1 3.2 4.2 1.1 0.4 -C 2776669 3.3 2.1 1.6 1.3 2.5 2.0 1.9 2.6 -C Best -C Possible 3.3 2.3 1.7 1.4 3.6 5.9 9.7 14.9 -C -C Input Argument -- -C R If R=0., the next random number of the sequence is generated. -C If R .LT. 0., the last generated number will be returned for -C possible use in a restart procedure. -C If R .GT. 0., the sequence of random numbers will start with -C the seed R mod 1. This seed is also returned as the value of -C RAND provided the arithmetic is done exactly. -C -C Output Value -- -C RAND a pseudo-random number between 0. and 1. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 770401 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***END PROLOGUE RAND - SAVE IA1, IA0, IA1MA0, IC, IX1, IX0 - DATA IA1, IA0, IA1MA0 /1536, 1029, 507/ - DATA IC /1731/ - DATA IX1, IX0 /0, 0/ -C***FIRST EXECUTABLE STATEMENT RAND - IF (R.LT.0.) GO TO 10 - IF (R.GT.0.) GO TO 20 -C -C A*X = 2**22*IA1*IX1 + 2**11*(IA1*IX1 + (IA1-IA0)*(IX0-IX1) -C + IA0*IX0) + IA0*IX0 -C - IY0 = IA0*IX0 - IY1 = IA1*IX1 + IA1MA0*(IX0-IX1) + IY0 - IY0 = IY0 + IC - IX0 = MOD (IY0, 2048) - IY1 = IY1 + (IY0-IX0)/2048 - IX1 = MOD (IY1, 2048) -C - 10 RAND = IX1*2048 + IX0 - RAND = RAND / 4194304. - RETURN -C - 20 IX1 = MOD(R,1.)*4194304. + 0.5 - IX0 = MOD (IX1, 2048) - IX1 = (IX1-IX0)/2048 - GO TO 10 -C - END diff --git a/slatec/ratqr.f b/slatec/ratqr.f deleted file mode 100644 index 972814a..0000000 --- a/slatec/ratqr.f +++ /dev/null @@ -1,269 +0,0 @@ -*DECK RATQR - SUBROUTINE RATQR (N, EPS1, D, E, E2, M, W, IND, BD, TYPE, IDEF, - + IERR) -C***BEGIN PROLOGUE RATQR -C***PURPOSE Compute the largest or smallest eigenvalues of a symmetric -C tridiagonal matrix using the rational QR method with Newton -C correction. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4A5, D4C2A -C***TYPE SINGLE PRECISION (RATQR-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure RATQR, -C NUM. MATH. 11, 264-272(1968) by REINSCH and BAUER. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 257-265(1971). -C -C This subroutine finds the algebraically smallest or largest -C eigenvalues of a SYMMETRIC TRIDIAGONAL matrix by the -C rational QR method with Newton corrections. -C -C On Input -C -C N is the order of the matrix. N is an INTEGER variable. -C -C EPS1 is a theoretical absolute error tolerance for the -C computed eigenvalues. If the input EPS1 is non-positive, or -C indeed smaller than its default value, it is reset at each -C iteration to the respective default value, namely, the -C product of the relative machine precision and the magnitude -C of the current eigenvalue iterate. The theoretical absolute -C error in the K-th eigenvalue is usually not greater than -C K times EPS1. EPS1 is a REAL variable. -C -C D contains the diagonal elements of the symmetric tridiagonal -C matrix. D is a one-dimensional REAL array, dimensioned D(N). -C -C E contains the subdiagonal elements of the symmetric -C tridiagonal matrix in its last N-1 positions. E(1) is -C arbitrary. E is a one-dimensional REAL array, dimensioned -C E(N). -C -C E2 contains the squares of the corresponding elements of E in -C its last N-1 positions. E2(1) is arbitrary. E2 is a one- -C dimensional REAL array, dimensioned E2(N). -C -C M is the number of eigenvalues to be found. M is an INTEGER -C variable. -C -C IDEF should be set to 1 if the input matrix is known to be -C positive definite, to -1 if the input matrix is known to -C be negative definite, and to 0 otherwise. IDEF is an -C INTEGER variable. -C -C TYPE should be set to .TRUE. if the smallest eigenvalues are -C to be found, and to .FALSE. if the largest eigenvalues are -C to be found. TYPE is a LOGICAL variable. -C -C On Output -C -C EPS1 is unaltered unless it has been reset to its -C (last) default value. -C -C D and E are unaltered (unless W overwrites D). -C -C Elements of E2, corresponding to elements of E regarded as -C negligible, have been replaced by zero causing the matrix -C to split into a direct sum of submatrices. E2(1) is set -C to 0.0e0 if the smallest eigenvalues have been found, and -C to 2.0e0 if the largest eigenvalues have been found. E2 -C is otherwise unaltered (unless overwritten by BD). -C -C W contains the M algebraically smallest eigenvalues in -C ascending order, or the M largest eigenvalues in descending -C order. If an error exit is made because of an incorrect -C specification of IDEF, no eigenvalues are found. If the -C Newton iterates for a particular eigenvalue are not monotone, -C the best estimate obtained is returned and IERR is set. -C W is a one-dimensional REAL array, dimensioned W(N). W need -C not be distinct from D. -C -C IND contains in its first M positions the submatrix indices -C associated with the corresponding eigenvalues in W -- -C 1 for eigenvalues belonging to the first submatrix from -C the top, 2 for those belonging to the second submatrix, etc. -C IND is an one-dimensional INTEGER array, dimensioned IND(N). -C -C BD contains refined bounds for the theoretical errors of the -C corresponding eigenvalues in W. These bounds are usually -C within the tolerance specified by EPS1. BD is a one- -C dimensional REAL array, dimensioned BD(N). BD need not be -C distinct from E2. -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C 6*N+1 if IDEF is set to 1 and TYPE to .TRUE. -C when the matrix is NOT positive definite, or -C if IDEF is set to -1 and TYPE to .FALSE. -C when the matrix is NOT negative definite, -C no eigenvalues are computed, or -C M is greater than N, -C 5*N+K if successive iterates to the K-th eigenvalue -C are NOT monotone increasing, where K refers -C to the last such occurrence. -C -C Note that subroutine TRIDIB is generally faster and more -C accurate than RATQR if the eigenvalues are clustered. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED R1MACH -C***REVISION HISTORY (YYMMDD) -C 760101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE RATQR -C - INTEGER I,J,K,M,N,II,JJ,K1,IDEF,IERR,JDEF - REAL D(*),E(*),E2(*),W(*),BD(*) - REAL F,P,Q,R,S,EP,QP,ERR,TOT,EPS1,DELTA,MACHEP - INTEGER IND(*) - LOGICAL FIRST, TYPE -C - SAVE FIRST, MACHEP - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT RATQR - IF (FIRST) THEN - MACHEP = R1MACH(4) - ENDIF - FIRST = .FALSE. -C - IERR = 0 - JDEF = IDEF -C .......... COPY D ARRAY INTO W .......... - DO 20 I = 1, N - 20 W(I) = D(I) -C - IF (TYPE) GO TO 40 - J = 1 - GO TO 400 - 40 ERR = 0.0E0 - S = 0.0E0 -C .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES AND DEFINE -C INITIAL SHIFT FROM LOWER GERSCHGORIN BOUND. -C COPY E2 ARRAY INTO BD .......... - TOT = W(1) - Q = 0.0E0 - J = 0 -C - DO 100 I = 1, N - P = Q - IF (I .EQ. 1) GO TO 60 - IF (P .GT. MACHEP * (ABS(D(I)) + ABS(D(I-1)))) GO TO 80 - 60 E2(I) = 0.0E0 - 80 BD(I) = E2(I) -C .......... COUNT ALSO IF ELEMENT OF E2 HAS UNDERFLOWED .......... - IF (E2(I) .EQ. 0.0E0) J = J + 1 - IND(I) = J - Q = 0.0E0 - IF (I .NE. N) Q = ABS(E(I+1)) - TOT = MIN(W(I)-P-Q,TOT) - 100 CONTINUE -C - IF (JDEF .EQ. 1 .AND. TOT .LT. 0.0E0) GO TO 140 -C - DO 110 I = 1, N - 110 W(I) = W(I) - TOT -C - GO TO 160 - 140 TOT = 0.0E0 -C - 160 DO 360 K = 1, M -C .......... NEXT QR TRANSFORMATION .......... - 180 TOT = TOT + S - DELTA = W(N) - S - I = N - F = ABS(MACHEP*TOT) - IF (EPS1 .LT. F) EPS1 = F - IF (DELTA .GT. EPS1) GO TO 190 - IF (DELTA .LT. (-EPS1)) GO TO 1000 - GO TO 300 -C .......... REPLACE SMALL SUB-DIAGONAL SQUARES BY ZERO -C TO REDUCE THE INCIDENCE OF UNDERFLOWS .......... - 190 IF (K .EQ. N) GO TO 210 - K1 = K + 1 - DO 200 J = K1, N - IF (BD(J) .LE. (MACHEP*(W(J)+W(J-1))) ** 2) BD(J) = 0.0E0 - 200 CONTINUE -C - 210 F = BD(N) / DELTA - QP = DELTA + F - P = 1.0E0 - IF (K .EQ. N) GO TO 260 - K1 = N - K -C .......... FOR I=N-1 STEP -1 UNTIL K DO -- .......... - DO 240 II = 1, K1 - I = N - II - Q = W(I) - S - F - R = Q / QP - P = P * R + 1.0E0 - EP = F * R - W(I+1) = QP + EP - DELTA = Q - EP - IF (DELTA .GT. EPS1) GO TO 220 - IF (DELTA .LT. (-EPS1)) GO TO 1000 - GO TO 300 - 220 F = BD(I) / Q - QP = DELTA + F - BD(I+1) = QP * EP - 240 CONTINUE -C - 260 W(K) = QP - S = QP / P - IF (TOT + S .GT. TOT) GO TO 180 -C .......... SET ERROR -- IRREGULAR END OF ITERATION. -C DEFLATE MINIMUM DIAGONAL ELEMENT .......... - IERR = 5 * N + K - S = 0.0E0 - DELTA = QP -C - DO 280 J = K, N - IF (W(J) .GT. DELTA) GO TO 280 - I = J - DELTA = W(J) - 280 CONTINUE -C .......... CONVERGENCE .......... - 300 IF (I .LT. N) BD(I+1) = BD(I) * F / QP - II = IND(I) - IF (I .EQ. K) GO TO 340 - K1 = I - K -C .......... FOR J=I-1 STEP -1 UNTIL K DO -- .......... - DO 320 JJ = 1, K1 - J = I - JJ - W(J+1) = W(J) - S - BD(J+1) = BD(J) - IND(J+1) = IND(J) - 320 CONTINUE -C - 340 W(K) = TOT - ERR = ERR + ABS(DELTA) - BD(K) = ERR - IND(K) = II - 360 CONTINUE -C - IF (TYPE) GO TO 1001 - F = BD(1) - E2(1) = 2.0E0 - BD(1) = F - J = 2 -C .......... NEGATE ELEMENTS OF W FOR LARGEST VALUES .......... - 400 DO 500 I = 1, N - 500 W(I) = -W(I) -C - JDEF = -JDEF - GO TO (40,1001), J -C .......... SET ERROR -- IDEF SPECIFIED INCORRECTLY .......... - 1000 IERR = 6 * N + 1 - 1001 RETURN - END diff --git a/slatec/rc.f b/slatec/rc.f deleted file mode 100644 index 702add7..0000000 --- a/slatec/rc.f +++ /dev/null @@ -1,336 +0,0 @@ -*DECK RC - REAL FUNCTION RC (X, Y, IER) -C***BEGIN PROLOGUE RC -C***PURPOSE Calculate an approximation to -C RC(X,Y) = Integral from zero to infinity of -C -1/2 -1 -C (1/2)(t+X) (t+Y) dt, -C where X is nonnegative and Y is positive. -C***LIBRARY SLATEC -C***CATEGORY C14 -C***TYPE SINGLE PRECISION (RC-S, DRC-D) -C***KEYWORDS DUPLICATION THEOREM, ELEMENTARY FUNCTIONS, -C ELLIPTIC INTEGRAL, TAYLOR SERIES -C***AUTHOR Carlson, B. C. -C Ames Laboratory-DOE -C Iowa State University -C Ames, IA 50011 -C Notis, E. M. -C Ames Laboratory-DOE -C Iowa State University -C Ames, IA 50011 -C Pexton, R. L. -C Lawrence Livermore National Laboratory -C Livermore, CA 94550 -C***DESCRIPTION -C -C 1. RC -C Standard FORTRAN function routine -C Single precision version -C The routine calculates an approximation to -C RC(X,Y) = Integral from zero to infinity of -C -C -1/2 -1 -C (1/2)(t+X) (t+Y) dt, -C -C where X is nonnegative and Y is positive. The duplication -C theorem is iterated until the variables are nearly equal, -C and the function is then expanded in Taylor series to fifth -C order. Logarithmic, inverse circular, and inverse hyper- -C bolic functions can be expressed in terms of RC. -C -C -C 2. Calling Sequence -C RC( X, Y, IER ) -C -C Parameters on Entry -C Values assigned by the calling routine -C -C X - Single precision, nonnegative variable -C -C Y - Single precision, positive variable -C -C -C -C On Return (values assigned by the RC routine) -C -C RC - Single precision approximation to the integral -C -C IER - Integer to indicate normal or abnormal termination. -C -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C -C IER > 0 Abnormal termination of the routine -C -C X and Y are unaltered. -C -C -C 3. Error Messages -C -C Value of IER assigned by the RC routine -C -C Value Assigned Error Message Printed -C IER = 1 X.LT.0.0E0.OR.Y.LE.0.0E0 -C = 2 X+Y.LT.LOLIM -C = 3 MAX(X,Y) .GT. UPLIM -C -C -C 4. Control Parameters -C -C Values of LOLIM, UPLIM, and ERRTOL are set by the -C routine. -C -C LOLIM and UPLIM determine the valid range of X and Y -C -C LOLIM - Lower limit of valid arguments -C -C Not less than 5 * (machine minimum) . -C -C UPLIM - Upper limit of valid arguments -C -C Not greater than (machine maximum) / 5 . -C -C -C Acceptable values for: LOLIM UPLIM -C IBM 360/370 SERIES : 3.0E-78 1.0E+75 -C CDC 6000/7000 SERIES : 1.0E-292 1.0E+321 -C UNIVAC 1100 SERIES : 1.0E-37 1.0E+37 -C CRAY : 2.3E-2466 1.09E+2465 -C VAX 11 SERIES : 1.5E-38 3.0E+37 -C -C ERRTOL determines the accuracy of the answer -C -C The value assigned by the routine will result -C in solution precision within 1-2 decimals of -C "machine precision". -C -C -C ERRTOL - Relative error due to truncation is less than -C 16 * ERRTOL ** 6 / (1 - 2 * ERRTOL). -C -C -C The accuracy of the computed approximation to the inte- -C gral can be controlled by choosing the value of ERRTOL. -C Truncation of a Taylor series after terms of fifth order -C introduces an error less than the amount shown in the -C second column of the following table for each value of -C ERRTOL in the first column. In addition to the trunca- -C tion error there will be round-off error, but in prac- -C tice the total error from both sources is usually less -C than the amount given in the table. -C -C -C -C Sample Choices: ERRTOL Relative Truncation -C error less than -C 1.0E-3 2.0E-17 -C 3.0E-3 2.0E-14 -C 1.0E-2 2.0E-11 -C 3.0E-2 2.0E-8 -C 1.0E-1 2.0E-5 -C -C -C Decreasing ERRTOL by a factor of 10 yields six more -C decimal digits of accuracy at the expense of one or -C two more iterations of the duplication theorem. -C -C *Long Description: -C -C RC Special Comments -C -C -C -C -C Check: RC(X,X+Z) + RC(Y,Y+Z) = RC(0,Z) -C -C where X, Y, and Z are positive and X * Y = Z * Z -C -C -C On Input: -C -C X and Y are the variables in the integral RC(X,Y). -C -C On Output: -C -C X and Y are unaltered. -C -C -C -C RC(0,1/4)=RC(1/16,1/8)=PI=3.14159... -C -C RC(9/4,2)=LN(2) -C -C -C -C ******************************************************** -C -C Warning: Changes in the program may improve speed at the -C expense of robustness. -C -C -C -------------------------------------------------------------------- -C -C Special Functions via RC -C -C -C -C LN X X .GT. 0 -C -C 2 -C LN(X) = (X-1) RC(((1+X)/2) , X ) -C -C -C -------------------------------------------------------------------- -C -C ARCSIN X -1 .LE. X .LE. 1 -C -C 2 -C ARCSIN X = X RC (1-X ,1 ) -C -C -------------------------------------------------------------------- -C -C ARCCOS X 0 .LE. X .LE. 1 -C -C -C 2 2 -C ARCCOS X = SQRT(1-X ) RC(X ,1 ) -C -C -------------------------------------------------------------------- -C -C ARCTAN X -INF .LT. X .LT. +INF -C -C 2 -C ARCTAN X = X RC(1,1+X ) -C -C -------------------------------------------------------------------- -C -C ARCCOT X 0 .LE. X .LT. INF -C -C 2 2 -C ARCCOT X = RC(X ,X +1 ) -C -C -------------------------------------------------------------------- -C -C ARCSINH X -INF .LT. X .LT. +INF -C -C 2 -C ARCSINH X = X RC(1+X ,1 ) -C -C -------------------------------------------------------------------- -C -C ARCCOSH X X .GE. 1 -C -C 2 2 -C ARCCOSH X = SQRT(X -1) RC(X ,1 ) -C -C -------------------------------------------------------------------- -C -C ARCTANH X -1 .LT. X .LT. 1 -C -C 2 -C ARCTANH X = X RC(1,1-X ) -C -C -------------------------------------------------------------------- -C -C ARCCOTH X X .GT. 1 -C -C 2 2 -C ARCCOTH X = RC(X ,X -1 ) -C -C -------------------------------------------------------------------- -C -C***REFERENCES B. C. Carlson and E. M. Notis, Algorithms for incomplete -C elliptic integrals, ACM Transactions on Mathematical -C Software 7, 3 (September 1981), pp. 398-403. -C B. C. Carlson, Computing elliptic integrals by -C duplication, Numerische Mathematik 33, (1979), -C pp. 1-16. -C B. C. Carlson, Elliptic integrals of the first kind, -C SIAM Journal of Mathematical Analysis 8, (1977), -C pp. 231-242. -C***ROUTINES CALLED R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891009 Removed unreferenced statement labels. (WRB) -C 891009 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900510 Changed calls to XERMSG to standard form, and some -C editorial changes. (RWC)) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE RC - CHARACTER*16 XERN3, XERN4, XERN5 - INTEGER IER - REAL C1, C2, ERRTOL, LAMDA, LOLIM - REAL MU, S, SN, UPLIM, X, XN, Y, YN - LOGICAL FIRST - SAVE ERRTOL,LOLIM,UPLIM,C1,C2,FIRST - DATA FIRST /.TRUE./ -C -C***FIRST EXECUTABLE STATEMENT RC - IF (FIRST) THEN - ERRTOL = (R1MACH(3)/16.0E0)**(1.0E0/6.0E0) - LOLIM = 5.0E0 * R1MACH(1) - UPLIM = R1MACH(2) / 5.0E0 -C - C1 = 1.0E0/7.0E0 - C2 = 9.0E0/22.0E0 - ENDIF - FIRST = .FALSE. -C -C CALL ERROR HANDLER IF NECESSARY. -C - RC = 0.0E0 - IF (X.LT.0.0E0.OR.Y.LE.0.0E0) THEN - IER = 1 - WRITE (XERN3, '(1PE15.6)') X - WRITE (XERN4, '(1PE15.6)') Y - CALL XERMSG ('SLATEC', 'RC', - * 'X.LT.0 .OR. Y.LE.0 WHERE X = ' // XERN3 // ' AND Y = ' // - * XERN4, 1, 1) - RETURN - ENDIF -C - IF (MAX(X,Y).GT.UPLIM) THEN - IER = 3 - WRITE (XERN3, '(1PE15.6)') X - WRITE (XERN4, '(1PE15.6)') Y - WRITE (XERN5, '(1PE15.6)') UPLIM - CALL XERMSG ('SLATEC', 'RC', - * 'MAX(X,Y).GT.UPLIM WHERE X = ' // XERN3 // ' Y = ' // - * XERN4 // ' AND UPLIM = ' // XERN5, 3, 1) - RETURN - ENDIF -C - IF (X+Y.LT.LOLIM) THEN - IER = 2 - WRITE (XERN3, '(1PE15.6)') X - WRITE (XERN4, '(1PE15.6)') Y - WRITE (XERN5, '(1PE15.6)') LOLIM - CALL XERMSG ('SLATEC', 'RC', - * 'X+Y.LT.LOLIM WHERE X = ' // XERN3 // ' Y = ' // XERN4 // - * ' AND LOLIM = ' // XERN5, 2, 1) - RETURN - ENDIF -C - IER = 0 - XN = X - YN = Y -C - 30 MU = (XN+YN+YN)/3.0E0 - SN = (YN+MU)/MU - 2.0E0 - IF (ABS(SN).LT.ERRTOL) GO TO 40 - LAMDA = 2.0E0*SQRT(XN)*SQRT(YN) + YN - XN = (XN+LAMDA)*0.250E0 - YN = (YN+LAMDA)*0.250E0 - GO TO 30 -C - 40 S = SN*SN*(0.30E0+SN*(C1+SN*(0.3750E0+SN*C2))) - RC = (1.0E0+S)/SQRT(MU) - RETURN - END diff --git a/slatec/rc3jj.f b/slatec/rc3jj.f deleted file mode 100644 index c71b913..0000000 --- a/slatec/rc3jj.f +++ /dev/null @@ -1,427 +0,0 @@ -*DECK RC3JJ - SUBROUTINE RC3JJ (L2, L3, M2, M3, L1MIN, L1MAX, THRCOF, NDIM, IER) -C***BEGIN PROLOGUE RC3JJ -C***PURPOSE Evaluate the 3j symbol f(L1) = ( L1 L2 L3) -C (-M2-M3 M2 M3) -C for all allowed values of L1, the other parameters -C being held fixed. -C***LIBRARY SLATEC -C***CATEGORY C19 -C***TYPE SINGLE PRECISION (RC3JJ-S, DRC3JJ-D) -C***KEYWORDS 3J COEFFICIENTS, 3J SYMBOLS, CLEBSCH-GORDAN COEFFICIENTS, -C RACAH COEFFICIENTS, VECTOR ADDITION COEFFICIENTS, -C WIGNER COEFFICIENTS -C***AUTHOR Gordon, R. G., Harvard University -C Schulten, K., Max Planck Institute -C***DESCRIPTION -C -C *Usage: -C -C REAL L2, L3, M2, M3, L1MIN, L1MAX, THRCOF(NDIM) -C INTEGER NDIM, IER -C -C CALL RC3JJ (L2, L3, M2, M3, L1MIN, L1MAX, THRCOF, NDIM, IER) -C -C *Arguments: -C -C L2 :IN Parameter in 3j symbol. -C -C L3 :IN Parameter in 3j symbol. -C -C M2 :IN Parameter in 3j symbol. -C -C M3 :IN Parameter in 3j symbol. -C -C L1MIN :OUT Smallest allowable L1 in 3j symbol. -C -C L1MAX :OUT Largest allowable L1 in 3j symbol. -C -C THRCOF :OUT Set of 3j coefficients generated by evaluating the -C 3j symbol for all allowed values of L1. THRCOF(I) -C will contain f(L1MIN+I-1), I=1,2,...,L1MAX+L1MIN+1. -C -C NDIM :IN Declared length of THRCOF in calling program. -C -C IER :OUT Error flag. -C IER=0 No errors. -C IER=1 Either L2.LT.ABS(M2) or L3.LT.ABS(M3). -C IER=2 Either L2+ABS(M2) or L3+ABS(M3) non-integer. -C IER=3 L1MAX-L1MIN not an integer. -C IER=4 L1MAX less than L1MIN. -C IER=5 NDIM less than L1MAX-L1MIN+1. -C -C *Description: -C -C Although conventionally the parameters of the vector addition -C coefficients satisfy certain restrictions, such as being integers -C or integers plus 1/2, the restrictions imposed on input to this -C subroutine are somewhat weaker. See, for example, Section 27.9 of -C Abramowitz and Stegun or Appendix C of Volume II of A. Messiah. -C The restrictions imposed by this subroutine are -C 1. L2 .GE. ABS(M2) and L3 .GE. ABS(M3); -C 2. L2+ABS(M2) and L3+ABS(M3) must be integers; -C 3. L1MAX-L1MIN must be a non-negative integer, where -C L1MAX=L2+L3 and L1MIN=MAX(ABS(L2-L3),ABS(M2+M3)). -C If the conventional restrictions are satisfied, then these -C restrictions are met. -C -C The user should be cautious in using input parameters that do -C not satisfy the conventional restrictions. For example, the -C the subroutine produces values of -C f(L1) = ( L1 2.5 5.8) -C (-0.3 1.5 -1.2) -C for L1=3.3,4.3,...,8.3 but none of the symmetry properties of the 3j -C symbol, set forth on page 1056 of Messiah, is satisfied. -C -C The subroutine generates f(L1MIN), f(L1MIN+1), ..., f(L1MAX) -C where L1MIN and L1MAX are defined above. The sequence f(L1) is -C generated by a three-term recurrence algorithm with scaling to -C control overflow. Both backward and forward recurrence are used to -C maintain numerical stability. The two recurrence sequences are -C matched at an interior point and are normalized from the unitary -C property of 3j coefficients and Wigner's phase convention. -C -C The algorithm is suited to applications in which large quantum -C numbers arise, such as in molecular dynamics. -C -C***REFERENCES 1. Abramowitz, M., and Stegun, I. A., Eds., Handbook -C of Mathematical Functions with Formulas, Graphs -C and Mathematical Tables, NBS Applied Mathematics -C Series 55, June 1964 and subsequent printings. -C 2. Messiah, Albert., Quantum Mechanics, Volume II, -C North-Holland Publishing Company, 1963. -C 3. Schulten, Klaus and Gordon, Roy G., Exact recursive -C evaluation of 3j and 6j coefficients for quantum- -C mechanical coupling of angular momenta, J Math -C Phys, v 16, no. 10, October 1975, pp. 1961-1970. -C 4. Schulten, Klaus and Gordon, Roy G., Semiclassical -C approximations to 3j and 6j coefficients for -C quantum-mechanical coupling of angular momenta, -C J Math Phys, v 16, no. 10, October 1975, -C pp. 1971-1988. -C 5. Schulten, Klaus and Gordon, Roy G., Recursive -C evaluation of 3j and 6j coefficients, Computer -C Phys Comm, v 11, 1976, pp. 269-278. -C***ROUTINES CALLED R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 880515 SLATEC prologue added by G. C. Nielson, NBS; parameters -C HUGE and TINY revised to depend on R1MACH. -C 891229 Prologue description rewritten; other prologue sections -C revised; LMATCH (location of match point for recurrences) -C removed from argument list; argument IER changed to serve -C only as an error flag (previously, in cases without error, -C it returned the number of scalings); number of error codes -C increased to provide more precise error information; -C program comments revised; SLATEC error handler calls -C introduced to enable printing of error messages to meet -C SLATEC standards. These changes were done by D. W. Lozier, -C M. A. McClain and J. M. Smith of the National Institute -C of Standards and Technology, formerly NBS. -C 910415 Mixed type expressions eliminated; variable C1 initialized; -C description of THRCOF expanded. These changes were done by -C D. W. Lozier. -C***END PROLOGUE RC3JJ -C - INTEGER NDIM, IER - REAL L2, L3, M2, M3, L1MIN, L1MAX, THRCOF(NDIM) -C - INTEGER I, INDEX, LSTEP, N, NFIN, NFINP1, NFINP2, NFINP3, NLIM, - + NSTEP2 - REAL A1, A1S, A2, A2S, C1, C1OLD, C2, CNORM, R1MACH, - + DENOM, DV, EPS, HUGE, L1, M1, NEWFAC, OLDFAC, - + ONE, RATIO, SIGN1, SIGN2, SRHUGE, SRTINY, SUM1, - + SUM2, SUMBAC, SUMFOR, SUMUNI, THREE, THRESH, - + TINY, TWO, X, X1, X2, X3, Y, Y1, Y2, Y3, ZERO -C - DATA ZERO,EPS,ONE,TWO,THREE /0.0,0.01,1.0,2.0,3.0/ -C -C***FIRST EXECUTABLE STATEMENT RC3JJ - IER=0 -C HUGE is the square root of one twentieth of the largest floating -C point number, approximately. - HUGE = SQRT(R1MACH(2)/20.0) - SRHUGE = SQRT(HUGE) - TINY = 1.0/HUGE - SRTINY = 1.0/SRHUGE -C -C LMATCH = ZERO - M1 = - M2 - M3 -C -C Check error conditions 1 and 2. - IF((L2-ABS(M2)+EPS.LT.ZERO).OR. - + (L3-ABS(M3)+EPS.LT.ZERO))THEN - IER=1 - CALL XERMSG('SLATEC','RC3JJ','L2-ABS(M2) or L3-ABS(M3) '// - + 'less than zero.',IER,1) - RETURN - ELSEIF((MOD(L2+ABS(M2)+EPS,ONE).GE.EPS+EPS).OR. - + (MOD(L3+ABS(M3)+EPS,ONE).GE.EPS+EPS))THEN - IER=2 - CALL XERMSG('SLATEC','RC3JJ','L2+ABS(M2) or L3+ABS(M3) '// - + 'not integer.',IER,1) - RETURN - ENDIF -C -C -C -C Limits for L1 -C - L1MIN = MAX(ABS(L2-L3),ABS(M1)) - L1MAX = L2 + L3 -C -C Check error condition 3. - IF(MOD(L1MAX-L1MIN+EPS,ONE).GE.EPS+EPS)THEN - IER=3 - CALL XERMSG('SLATEC','RC3JJ','L1MAX-L1MIN not integer.',IER,1) - RETURN - ENDIF - IF(L1MIN.LT.L1MAX-EPS) GO TO 20 - IF(L1MIN.LT.L1MAX+EPS) GO TO 10 -C -C Check error condition 4. - IER=4 - CALL XERMSG('SLATEC','RC3JJ','L1MIN greater than L1MAX.',IER,1) - RETURN -C -C This is reached in case that L1 can take only one value, -C i.e. L1MIN = L1MAX -C - 10 CONTINUE -C LSCALE = 0 - THRCOF(1) = (-ONE) ** INT(ABS(L2+M2-L3+M3)+EPS) / - 1 SQRT(L1MIN + L2 + L3 + ONE) - RETURN -C -C This is reached in case that L1 takes more than one value, -C i.e. L1MIN < L1MAX. -C - 20 CONTINUE -C LSCALE = 0 - NFIN = INT(L1MAX-L1MIN+ONE+EPS) - IF(NDIM-NFIN) 21, 23, 23 -C -C Check error condition 5. - 21 IER = 5 - CALL XERMSG('SLATEC','RC3JJ','Dimension of result array for 3j '// - + 'coefficients too small.',IER,1) - RETURN -C -C -C Starting forward recursion from L1MIN taking NSTEP1 steps -C - 23 L1 = L1MIN - NEWFAC = 0.0 - C1 = 0.0 - THRCOF(1) = SRTINY - SUM1 = (L1+L1+ONE) * TINY -C -C - LSTEP = 1 - 30 LSTEP = LSTEP + 1 - L1 = L1 + ONE -C -C - OLDFAC = NEWFAC - A1 = (L1+L2+L3+ONE) * (L1-L2+L3) * (L1+L2-L3) * (-L1+L2+L3+ONE) - A2 = (L1+M1) * (L1-M1) - NEWFAC = SQRT(A1*A2) - IF(L1.LT.ONE+EPS) GO TO 40 -C -C - DV = - L2*(L2+ONE) * M1 + L3*(L3+ONE) * M1 + L1*(L1-ONE) * (M3-M2) - DENOM = (L1-ONE) * NEWFAC -C - IF(LSTEP-2) 32, 32, 31 -C - 31 C1OLD = ABS(C1) - 32 C1 = - (L1+L1-ONE) * DV / DENOM - GO TO 50 -C -C If L1 = 1, (L1-1) has to be factored out of DV, hence -C - 40 C1 = - (L1+L1-ONE) * L1 * (M3-M2) / NEWFAC -C - 50 IF(LSTEP.GT.2) GO TO 60 -C -C -C If L1 = L1MIN + 1, the third term in the recursion equation vanishes, -C hence - X = SRTINY * C1 - THRCOF(2) = X - SUM1 = SUM1 + TINY * (L1+L1+ONE) * C1*C1 - IF(LSTEP.EQ.NFIN) GO TO 220 - GO TO 30 -C -C - 60 C2 = - L1 * OLDFAC / DENOM -C -C Recursion to the next 3j coefficient X -C - X = C1 * THRCOF(LSTEP-1) + C2 * THRCOF(LSTEP-2) - THRCOF(LSTEP) = X - SUMFOR = SUM1 - SUM1 = SUM1 + (L1+L1+ONE) * X*X - IF(LSTEP.EQ.NFIN) GO TO 100 -C -C See if last unnormalized 3j coefficient exceeds SRHUGE -C - IF(ABS(X).LT.SRHUGE) GO TO 80 -C -C This is reached if last 3j coefficient larger than SRHUGE, -C so that the recursion series THRCOF(1), ... , THRCOF(LSTEP) -C has to be rescaled to prevent overflow -C -C LSCALE = LSCALE + 1 - DO 70 I=1,LSTEP - IF(ABS(THRCOF(I)).LT.SRTINY) THRCOF(I) = ZERO - 70 THRCOF(I) = THRCOF(I) / SRHUGE - SUM1 = SUM1 / HUGE - SUMFOR = SUMFOR / HUGE - X = X / SRHUGE -C -C As long as ABS(C1) is decreasing, the recursion proceeds towards -C increasing 3j values and, hence, is numerically stable. Once -C an increase of ABS(C1) is detected, the recursion direction is -C reversed. -C - 80 IF(C1OLD-ABS(C1)) 100, 100, 30 -C -C -C Keep three 3j coefficients around LMATCH for comparison with -C backward recursion. -C - 100 CONTINUE -C LMATCH = L1 - 1 - X1 = X - X2 = THRCOF(LSTEP-1) - X3 = THRCOF(LSTEP-2) - NSTEP2 = NFIN - LSTEP + 3 -C -C -C -C -C Starting backward recursion from L1MAX taking NSTEP2 steps, so -C that forward and backward recursion overlap at three points -C L1 = LMATCH+1, LMATCH, LMATCH-1. -C - NFINP1 = NFIN + 1 - NFINP2 = NFIN + 2 - NFINP3 = NFIN + 3 - L1 = L1MAX - THRCOF(NFIN) = SRTINY - SUM2 = TINY * (L1+L1+ONE) -C - L1 = L1 + TWO - LSTEP = 1 - 110 LSTEP = LSTEP + 1 - L1 = L1 - ONE -C - OLDFAC = NEWFAC - A1S = (L1+L2+L3)*(L1-L2+L3-ONE)*(L1+L2-L3-ONE)*(-L1+L2+L3+TWO) - A2S = (L1+M1-ONE) * (L1-M1-ONE) - NEWFAC = SQRT(A1S*A2S) -C - DV = - L2*(L2+ONE) * M1 + L3*(L3+ONE) * M1 + L1*(L1-ONE) * (M3-M2) -C - DENOM = L1 * NEWFAC - C1 = - (L1+L1-ONE) * DV / DENOM - IF(LSTEP.GT.2) GO TO 120 -C -C If L1 = L1MAX + 1, the third term in the recursion formula vanishes -C - Y = SRTINY * C1 - THRCOF(NFIN-1) = Y - SUMBAC = SUM2 - SUM2 = SUM2 + TINY * (L1+L1-THREE) * C1*C1 -C - GO TO 110 -C -C - 120 C2 = - (L1 - ONE) * OLDFAC / DENOM -C -C Recursion to the next 3j coefficient Y -C - Y = C1 * THRCOF(NFINP2-LSTEP) + C2 * THRCOF(NFINP3-LSTEP) -C - IF(LSTEP.EQ.NSTEP2) GO TO 200 -C - THRCOF(NFINP1-LSTEP) = Y - SUMBAC = SUM2 - SUM2 = SUM2 + (L1+L1-THREE) * Y*Y -C -C See if last unnormalized 3j coefficient exceeds SRHUGE -C - IF(ABS(Y).LT.SRHUGE) GO TO 110 -C -C This is reached if last 3j coefficient larger than SRHUGE, -C so that the recursion series THRCOF(NFIN), ... ,THRCOF(NFIN-LSTEP+1) -C has to be rescaled to prevent overflow -C -C LSCALE = LSCALE + 1 - DO 130 I=1,LSTEP - INDEX = NFIN - I + 1 - IF(ABS(THRCOF(INDEX)).LT.SRTINY) THRCOF(INDEX) = ZERO - 130 THRCOF(INDEX) = THRCOF(INDEX) / SRHUGE - SUM2 = SUM2 / HUGE - SUMBAC = SUMBAC / HUGE -C -C - GO TO 110 -C -C -C The forward recursion 3j coefficients X1, X2, X3 are to be matched -C with the corresponding backward recursion values Y1, Y2, Y3. -C - 200 Y3 = Y - Y2 = THRCOF(NFINP2-LSTEP) - Y1 = THRCOF(NFINP3-LSTEP) -C -C -C Determine now RATIO such that YI = RATIO * XI (I=1,2,3) holds -C with minimal error. -C - RATIO = ( X1*Y1 + X2*Y2 + X3*Y3 ) / ( X1*X1 + X2*X2 + X3*X3 ) - NLIM = NFIN - NSTEP2 + 1 -C - IF(ABS(RATIO).LT.ONE) GO TO 211 -C - DO 210 N=1,NLIM - 210 THRCOF(N) = RATIO * THRCOF(N) - SUMUNI = RATIO * RATIO * SUMFOR + SUMBAC - GO TO 230 -C - 211 NLIM = NLIM + 1 - RATIO = ONE / RATIO - DO 212 N=NLIM,NFIN - 212 THRCOF(N) = RATIO * THRCOF(N) - SUMUNI = SUMFOR + RATIO*RATIO*SUMBAC - GO TO 230 -C - 220 SUMUNI = SUM1 -C -C -C Normalize 3j coefficients -C - 230 CNORM = ONE / SQRT(SUMUNI) -C -C Sign convention for last 3j coefficient determines overall phase -C - SIGN1 = SIGN(ONE,THRCOF(NFIN)) - SIGN2 = (-ONE) ** INT(ABS(L2+M2-L3+M3)+EPS) - IF(SIGN1*SIGN2) 235,235,236 - 235 CNORM = - CNORM -C - 236 IF(ABS(CNORM).LT.ONE) GO TO 250 -C - DO 240 N=1,NFIN - 240 THRCOF(N) = CNORM * THRCOF(N) - RETURN -C - 250 THRESH = TINY / ABS(CNORM) - DO 251 N=1,NFIN - IF(ABS(THRCOF(N)).LT.THRESH) THRCOF(N) = ZERO - 251 THRCOF(N) = CNORM * THRCOF(N) -C - RETURN - END diff --git a/slatec/rc3jm.f b/slatec/rc3jm.f deleted file mode 100644 index ac6b238..0000000 --- a/slatec/rc3jm.f +++ /dev/null @@ -1,422 +0,0 @@ -*DECK RC3JM - SUBROUTINE RC3JM (L1, L2, L3, M1, M2MIN, M2MAX, THRCOF, NDIM, IER) -C***BEGIN PROLOGUE RC3JM -C***PURPOSE Evaluate the 3j symbol g(M2) = (L1 L2 L3 ) -C (M1 M2 -M1-M2) -C for all allowed values of M2, the other parameters -C being held fixed. -C***LIBRARY SLATEC -C***CATEGORY C19 -C***TYPE SINGLE PRECISION (RC3JM-S, DRC3JM-D) -C***KEYWORDS 3J COEFFICIENTS, 3J SYMBOLS, CLEBSCH-GORDAN COEFFICIENTS, -C RACAH COEFFICIENTS, VECTOR ADDITION COEFFICIENTS, -C WIGNER COEFFICIENTS -C***AUTHOR Gordon, R. G., Harvard University -C Schulten, K., Max Planck Institute -C***DESCRIPTION -C -C *Usage: -C -C REAL L1, L2, L3, M1, M2MIN, M2MAX, THRCOF(NDIM) -C INTEGER NDIM, IER -C -C CALL RC3JM (L1, L2, L3, M1, M2MIN, M2MAX, THRCOF, NDIM, IER) -C -C *Arguments: -C -C L1 :IN Parameter in 3j symbol. -C -C L2 :IN Parameter in 3j symbol. -C -C L3 :IN Parameter in 3j symbol. -C -C M1 :IN Parameter in 3j symbol. -C -C M2MIN :OUT Smallest allowable M2 in 3j symbol. -C -C M2MAX :OUT Largest allowable M2 in 3j symbol. -C -C THRCOF :OUT Set of 3j coefficients generated by evaluating the -C 3j symbol for all allowed values of M2. THRCOF(I) -C will contain g(M2MIN+I-1), I=1,2,...,M2MAX-M2MIN+1. -C -C NDIM :IN Declared length of THRCOF in calling program. -C -C IER :OUT Error flag. -C IER=0 No errors. -C IER=1 Either L1.LT.ABS(M1) or L1+ABS(M1) non-integer. -C IER=2 ABS(L1-L2).LE.L3.LE.L1+L2 not satisfied. -C IER=3 L1+L2+L3 not an integer. -C IER=4 M2MAX-M2MIN not an integer. -C IER=5 M2MAX less than M2MIN. -C IER=6 NDIM less than M2MAX-M2MIN+1. -C -C *Description: -C -C Although conventionally the parameters of the vector addition -C coefficients satisfy certain restrictions, such as being integers -C or integers plus 1/2, the restrictions imposed on input to this -C subroutine are somewhat weaker. See, for example, Section 27.9 of -C Abramowitz and Stegun or Appendix C of Volume II of A. Messiah. -C The restrictions imposed by this subroutine are -C 1. L1.GE.ABS(M1) and L1+ABS(M1) must be an integer; -C 2. ABS(L1-L2).LE.L3.LE.L1+L2; -C 3. L1+L2+L3 must be an integer; -C 4. M2MAX-M2MIN must be an integer, where -C M2MAX=MIN(L2,L3-M1) and M2MIN=MAX(-L2,-L3-M1). -C If the conventional restrictions are satisfied, then these -C restrictions are met. -C -C The user should be cautious in using input parameters that do -C not satisfy the conventional restrictions. For example, the -C the subroutine produces values of -C g(M2) = (0.75 1.50 1.75 ) -C (0.25 M2 -0.25-M2) -C for M2=-1.5,-0.5,0.5,1.5 but none of the symmetry properties of the -C 3j symbol, set forth on page 1056 of Messiah, is satisfied. -C -C The subroutine generates g(M2MIN), g(M2MIN+1), ..., g(M2MAX) -C where M2MIN and M2MAX are defined above. The sequence g(M2) is -C generated by a three-term recurrence algorithm with scaling to -C control overflow. Both backward and forward recurrence are used to -C maintain numerical stability. The two recurrence sequences are -C matched at an interior point and are normalized from the unitary -C property of 3j coefficients and Wigner's phase convention. -C -C The algorithm is suited to applications in which large quantum -C numbers arise, such as in molecular dynamics. -C -C***REFERENCES 1. Abramowitz, M., and Stegun, I. A., Eds., Handbook -C of Mathematical Functions with Formulas, Graphs -C and Mathematical Tables, NBS Applied Mathematics -C Series 55, June 1964 and subsequent printings. -C 2. Messiah, Albert., Quantum Mechanics, Volume II, -C North-Holland Publishing Company, 1963. -C 3. Schulten, Klaus and Gordon, Roy G., Exact recursive -C evaluation of 3j and 6j coefficients for quantum- -C mechanical coupling of angular momenta, J Math -C Phys, v 16, no. 10, October 1975, pp. 1961-1970. -C 4. Schulten, Klaus and Gordon, Roy G., Semiclassical -C approximations to 3j and 6j coefficients for -C quantum-mechanical coupling of angular momenta, -C J Math Phys, v 16, no. 10, October 1975, -C pp. 1971-1988. -C 5. Schulten, Klaus and Gordon, Roy G., Recursive -C evaluation of 3j and 6j coefficients, Computer -C Phys Comm, v 11, 1976, pp. 269-278. -C***ROUTINES CALLED R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 880515 SLATEC prologue added by G. C. Nielson, NBS; parameters -C HUGE and TINY revised to depend on R1MACH. -C 891229 Prologue description rewritten; other prologue sections -C revised; MMATCH (location of match point for recurrences) -C removed from argument list; argument IER changed to serve -C only as an error flag (previously, in cases without error, -C it returned the number of scalings); number of error codes -C increased to provide more precise error information; -C program comments revised; SLATEC error handler calls -C introduced to enable printing of error messages to meet -C SLATEC standards. These changes were done by D. W. Lozier, -C M. A. McClain and J. M. Smith of the National Institute -C of Standards and Technology, formerly NBS. -C 910415 Mixed type expressions eliminated; variable C1 initialized; -C description of THRCOF expanded. These changes were done by -C D. W. Lozier. -C***END PROLOGUE RC3JM -C - INTEGER NDIM, IER - REAL L1, L2, L3, M1, M2MIN, M2MAX, THRCOF(NDIM) -C - INTEGER I, INDEX, LSTEP, N, NFIN, NFINP1, NFINP2, NFINP3, NLIM, - + NSTEP2 - REAL A1, A1S, C1, C1OLD, C2, CNORM, R1MACH, DV, EPS, - + HUGE, M2, M3, NEWFAC, OLDFAC, ONE, RATIO, SIGN1, - + SIGN2, SRHUGE, SRTINY, SUM1, SUM2, SUMBAC, - + SUMFOR, SUMUNI, THRESH, TINY, TWO, X, X1, X2, X3, - + Y, Y1, Y2, Y3, ZERO -C - DATA ZERO,EPS,ONE,TWO /0.0,0.01,1.0,2.0/ -C -C***FIRST EXECUTABLE STATEMENT RC3JM - IER=0 -C HUGE is the square root of one twentieth of the largest floating -C point number, approximately. - HUGE = SQRT(R1MACH(2)/20.0) - SRHUGE = SQRT(HUGE) - TINY = 1.0/HUGE - SRTINY = 1.0/SRHUGE -C -C MMATCH = ZERO -C -C -C Check error conditions 1, 2, and 3. - IF((L1-ABS(M1)+EPS.LT.ZERO).OR. - + (MOD(L1+ABS(M1)+EPS,ONE).GE.EPS+EPS))THEN - IER=1 - CALL XERMSG('SLATEC','RC3JM','L1-ABS(M1) less than zero or '// - + 'L1+ABS(M1) not integer.',IER,1) - RETURN - ELSEIF((L1+L2-L3.LT.-EPS).OR.(L1-L2+L3.LT.-EPS).OR. - + (-L1+L2+L3.LT.-EPS))THEN - IER=2 - CALL XERMSG('SLATEC','RC3JM','L1, L2, L3 do not satisfy '// - + 'triangular condition.',IER,1) - RETURN - ELSEIF(MOD(L1+L2+L3+EPS,ONE).GE.EPS+EPS)THEN - IER=3 - CALL XERMSG('SLATEC','RC3JM','L1+L2+L3 not integer.',IER,1) - RETURN - ENDIF -C -C -C Limits for M2 - M2MIN = MAX(-L2,-L3-M1) - M2MAX = MIN(L2,L3-M1) -C -C Check error condition 4. - IF(MOD(M2MAX-M2MIN+EPS,ONE).GE.EPS+EPS)THEN - IER=4 - CALL XERMSG('SLATEC','RC3JM','M2MAX-M2MIN not integer.',IER,1) - RETURN - ENDIF - IF(M2MIN.LT.M2MAX-EPS) GO TO 20 - IF(M2MIN.LT.M2MAX+EPS) GO TO 10 -C -C Check error condition 5. - IER=5 - CALL XERMSG('SLATEC','RC3JM','M2MIN greater than M2MAX.',IER,1) - RETURN -C -C -C This is reached in case that M2 and M3 can take only one value. - 10 CONTINUE -C MSCALE = 0 - THRCOF(1) = (-ONE) ** INT(ABS(L2-L3-M1)+EPS) / - 1 SQRT(L1+L2+L3+ONE) - RETURN -C -C This is reached in case that M1 and M2 take more than one value. - 20 CONTINUE -C MSCALE = 0 - NFIN = INT(M2MAX-M2MIN+ONE+EPS) - IF(NDIM-NFIN) 21, 23, 23 -C -C Check error condition 6. - 21 IER = 6 - CALL XERMSG('SLATEC','RC3JM','Dimension of result array for 3j '// - + 'coefficients too small.',IER,1) - RETURN -C -C -C -C Start of forward recursion from M2 = M2MIN -C - 23 M2 = M2MIN - THRCOF(1) = SRTINY - NEWFAC = 0.0 - C1 = 0.0 - SUM1 = TINY -C -C - LSTEP = 1 - 30 LSTEP = LSTEP + 1 - M2 = M2 + ONE - M3 = - M1 - M2 -C -C - OLDFAC = NEWFAC - A1 = (L2-M2+ONE) * (L2+M2) * (L3+M3+ONE) * (L3-M3) - NEWFAC = SQRT(A1) -C -C - DV = (L1+L2+L3+ONE)*(L2+L3-L1) - (L2-M2+ONE)*(L3+M3+ONE) - 1 - (L2+M2-ONE)*(L3-M3-ONE) -C - IF(LSTEP-2) 32, 32, 31 -C - 31 C1OLD = ABS(C1) - 32 C1 = - DV / NEWFAC -C - IF(LSTEP.GT.2) GO TO 60 -C -C -C If M2 = M2MIN + 1, the third term in the recursion equation vanishes, -C hence -C - X = SRTINY * C1 - THRCOF(2) = X - SUM1 = SUM1 + TINY * C1*C1 - IF(LSTEP.EQ.NFIN) GO TO 220 - GO TO 30 -C -C - 60 C2 = - OLDFAC / NEWFAC -C -C Recursion to the next 3j coefficient - X = C1 * THRCOF(LSTEP-1) + C2 * THRCOF(LSTEP-2) - THRCOF(LSTEP) = X - SUMFOR = SUM1 - SUM1 = SUM1 + X*X - IF(LSTEP.EQ.NFIN) GO TO 100 -C -C See if last unnormalized 3j coefficient exceeds SRHUGE -C - IF(ABS(X).LT.SRHUGE) GO TO 80 -C -C This is reached if last 3j coefficient larger than SRHUGE, -C so that the recursion series THRCOF(1), ... , THRCOF(LSTEP) -C has to be rescaled to prevent overflow -C -C MSCALE = MSCALE + 1 - DO 70 I=1,LSTEP - IF(ABS(THRCOF(I)).LT.SRTINY) THRCOF(I) = ZERO - 70 THRCOF(I) = THRCOF(I) / SRHUGE - SUM1 = SUM1 / HUGE - SUMFOR = SUMFOR / HUGE - X = X / SRHUGE -C -C -C As long as ABS(C1) is decreasing, the recursion proceeds towards -C increasing 3j values and, hence, is numerically stable. Once -C an increase of ABS(C1) is detected, the recursion direction is -C reversed. -C - 80 IF(C1OLD-ABS(C1)) 100, 100, 30 -C -C -C Keep three 3j coefficients around MMATCH for comparison later -C with backward recursion values. -C - 100 CONTINUE -C MMATCH = M2 - 1 - NSTEP2 = NFIN - LSTEP + 3 - X1 = X - X2 = THRCOF(LSTEP-1) - X3 = THRCOF(LSTEP-2) -C -C Starting backward recursion from M2MAX taking NSTEP2 steps, so -C that forwards and backwards recursion overlap at the three points -C M2 = MMATCH+1, MMATCH, MMATCH-1. -C - NFINP1 = NFIN + 1 - NFINP2 = NFIN + 2 - NFINP3 = NFIN + 3 - THRCOF(NFIN) = SRTINY - SUM2 = TINY -C -C -C - M2 = M2MAX + TWO - LSTEP = 1 - 110 LSTEP = LSTEP + 1 - M2 = M2 - ONE - M3 = - M1 - M2 - OLDFAC = NEWFAC - A1S = (L2-M2+TWO) * (L2+M2-ONE) * (L3+M3+TWO) * (L3-M3-ONE) - NEWFAC = SQRT(A1S) - DV = (L1+L2+L3+ONE)*(L2+L3-L1) - (L2-M2+ONE)*(L3+M3+ONE) - 1 - (L2+M2-ONE)*(L3-M3-ONE) - C1 = - DV / NEWFAC - IF(LSTEP.GT.2) GO TO 120 -C -C If M2 = M2MAX + 1 the third term in the recursion equation vanishes -C - Y = SRTINY * C1 - THRCOF(NFIN-1) = Y - IF(LSTEP.EQ.NSTEP2) GO TO 200 - SUMBAC = SUM2 - SUM2 = SUM2 + Y*Y - GO TO 110 -C - 120 C2 = - OLDFAC / NEWFAC -C -C Recursion to the next 3j coefficient -C - Y = C1 * THRCOF(NFINP2-LSTEP) + C2 * THRCOF(NFINP3-LSTEP) -C - IF(LSTEP.EQ.NSTEP2) GO TO 200 -C - THRCOF(NFINP1-LSTEP) = Y - SUMBAC = SUM2 - SUM2 = SUM2 + Y*Y -C -C -C See if last 3j coefficient exceeds SRHUGE -C - IF(ABS(Y).LT.SRHUGE) GO TO 110 -C -C This is reached if last 3j coefficient larger than SRHUGE, -C so that the recursion series THRCOF(NFIN), ... , THRCOF(NFIN-LSTEP+1) -C has to be rescaled to prevent overflow. -C -C MSCALE = MSCALE + 1 - DO 111 I=1,LSTEP - INDEX = NFIN - I + 1 - IF(ABS(THRCOF(INDEX)).LT.SRTINY) - 1 THRCOF(INDEX) = ZERO - 111 THRCOF(INDEX) = THRCOF(INDEX) / SRHUGE - SUM2 = SUM2 / HUGE - SUMBAC = SUMBAC / HUGE -C - GO TO 110 -C -C -C -C The forward recursion 3j coefficients X1, X2, X3 are to be matched -C with the corresponding backward recursion values Y1, Y2, Y3. -C - 200 Y3 = Y - Y2 = THRCOF(NFINP2-LSTEP) - Y1 = THRCOF(NFINP3-LSTEP) -C -C -C Determine now RATIO such that YI = RATIO * XI (I=1,2,3) holds -C with minimal error. -C - RATIO = ( X1*Y1 + X2*Y2 + X3*Y3 ) / ( X1*X1 + X2*X2 + X3*X3 ) - NLIM = NFIN - NSTEP2 + 1 -C - IF(ABS(RATIO).LT.ONE) GO TO 211 -C - DO 210 N=1,NLIM - 210 THRCOF(N) = RATIO * THRCOF(N) - SUMUNI = RATIO * RATIO * SUMFOR + SUMBAC - GO TO 230 -C - 211 NLIM = NLIM + 1 - RATIO = ONE / RATIO - DO 212 N=NLIM,NFIN - 212 THRCOF(N) = RATIO * THRCOF(N) - SUMUNI = SUMFOR + RATIO*RATIO*SUMBAC - GO TO 230 -C - 220 SUMUNI = SUM1 -C -C -C Normalize 3j coefficients -C - 230 CNORM = ONE / SQRT((L1+L1+ONE) * SUMUNI) -C -C Sign convention for last 3j coefficient determines overall phase -C - SIGN1 = SIGN(ONE,THRCOF(NFIN)) - SIGN2 = (-ONE) ** INT(ABS(L2-L3-M1)+EPS) - IF(SIGN1*SIGN2) 235,235,236 - 235 CNORM = - CNORM -C - 236 IF(ABS(CNORM).LT.ONE) GO TO 250 -C - DO 240 N=1,NFIN - 240 THRCOF(N) = CNORM * THRCOF(N) - RETURN -C - 250 THRESH = TINY / ABS(CNORM) - DO 251 N=1,NFIN - IF(ABS(THRCOF(N)).LT.THRESH) THRCOF(N) = ZERO - 251 THRCOF(N) = CNORM * THRCOF(N) -C -C -C - RETURN - END diff --git a/slatec/rc6j.f b/slatec/rc6j.f deleted file mode 100644 index dcb32eb..0000000 --- a/slatec/rc6j.f +++ /dev/null @@ -1,439 +0,0 @@ -*DECK RC6J - SUBROUTINE RC6J (L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF, NDIM, - + IER) -C***BEGIN PROLOGUE RC6J -C***PURPOSE Evaluate the 6j symbol h(L1) = {L1 L2 L3} -C {L4 L5 L6} -C for all allowed values of L1, the other parameters -C being held fixed. -C***LIBRARY SLATEC -C***CATEGORY C19 -C***TYPE SINGLE PRECISION (RC6J-S, DRC6J-D) -C***KEYWORDS 6J COEFFICIENTS, 6J SYMBOLS, CLEBSCH-GORDAN COEFFICIENTS, -C RACAH COEFFICIENTS, VECTOR ADDITION COEFFICIENTS, -C WIGNER COEFFICIENTS -C***AUTHOR Gordon, R. G., Harvard University -C Schulten, K., Max Planck Institute -C***DESCRIPTION -C -C *Usage: -C -C REAL L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF(NDIM) -C INTEGER NDIM, IER -C -C CALL RC6J(L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF, NDIM, IER) -C -C *Arguments: -C -C L2 :IN Parameter in 6j symbol. -C -C L3 :IN Parameter in 6j symbol. -C -C L4 :IN Parameter in 6j symbol. -C -C L5 :IN Parameter in 6j symbol. -C -C L6 :IN Parameter in 6j symbol. -C -C L1MIN :OUT Smallest allowable L1 in 6j symbol. -C -C L1MAX :OUT Largest allowable L1 in 6j symbol. -C -C SIXCOF :OUT Set of 6j coefficients generated by evaluating the -C 6j symbol for all allowed values of L1. SIXCOF(I) -C will contain h(L1MIN+I-1), I=1,2,...,L1MAX-L1MIN+1. -C -C NDIM :IN Declared length of SIXCOF in calling program. -C -C IER :OUT Error flag. -C IER=0 No errors. -C IER=1 L2+L3+L5+L6 or L4+L2+L6 not an integer. -C IER=2 L4, L2, L6 triangular condition not satisfied. -C IER=3 L4, L5, L3 triangular condition not satisfied. -C IER=4 L1MAX-L1MIN not an integer. -C IER=5 L1MAX less than L1MIN. -C IER=6 NDIM less than L1MAX-L1MIN+1. -C -C *Description: -C -C The definition and properties of 6j symbols can be found, for -C example, in Appendix C of Volume II of A. Messiah. Although the -C parameters of the vector addition coefficients satisfy certain -C conventional restrictions, the restriction that they be non-negative -C integers or non-negative integers plus 1/2 is not imposed on input -C to this subroutine. The restrictions imposed are -C 1. L2+L3+L5+L6 and L2+L4+L6 must be integers; -C 2. ABS(L2-L4).LE.L6.LE.L2+L4 must be satisfied; -C 3. ABS(L4-L5).LE.L3.LE.L4+L5 must be satisfied; -C 4. L1MAX-L1MIN must be a non-negative integer, where -C L1MAX=MIN(L2+L3,L5+L6) and L1MIN=MAX(ABS(L2-L3),ABS(L5-L6)). -C If all the conventional restrictions are satisfied, then these -C restrictions are met. Conversely, if input to this subroutine meets -C all of these restrictions and the conventional restriction stated -C above, then all the conventional restrictions are satisfied. -C -C The user should be cautious in using input parameters that do -C not satisfy the conventional restrictions. For example, the -C the subroutine produces values of -C h(L1) = { L1 2/3 1 } -C {2/3 2/3 2/3} -C for L1=1/3 and 4/3 but none of the symmetry properties of the 6j -C symbol, set forth on pages 1063 and 1064 of Messiah, is satisfied. -C -C The subroutine generates h(L1MIN), h(L1MIN+1), ..., h(L1MAX) -C where L1MIN and L1MAX are defined above. The sequence h(L1) is -C generated by a three-term recurrence algorithm with scaling to -C control overflow. Both backward and forward recurrence are used to -C maintain numerical stability. The two recurrence sequences are -C matched at an interior point and are normalized from the unitary -C property of 6j coefficients and Wigner's phase convention. -C -C The algorithm is suited to applications in which large quantum -C numbers arise, such as in molecular dynamics. -C -C***REFERENCES 1. Messiah, Albert., Quantum Mechanics, Volume II, -C North-Holland Publishing Company, 1963. -C 2. Schulten, Klaus and Gordon, Roy G., Exact recursive -C evaluation of 3j and 6j coefficients for quantum- -C mechanical coupling of angular momenta, J Math -C Phys, v 16, no. 10, October 1975, pp. 1961-1970. -C 3. Schulten, Klaus and Gordon, Roy G., Semiclassical -C approximations to 3j and 6j coefficients for -C quantum-mechanical coupling of angular momenta, -C J Math Phys, v 16, no. 10, October 1975, -C pp. 1971-1988. -C 4. Schulten, Klaus and Gordon, Roy G., Recursive -C evaluation of 3j and 6j coefficients, Computer -C Phys Comm, v 11, 1976, pp. 269-278. -C***ROUTINES CALLED R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 880515 SLATEC prologue added by G. C. Nielson, NBS; parameters -C HUGE and TINY revised to depend on R1MACH. -C 891229 Prologue description rewritten; other prologue sections -C revised; LMATCH (location of match point for recurrences) -C removed from argument list; argument IER changed to serve -C only as an error flag (previously, in cases without error, -C it returned the number of scalings); number of error codes -C increased to provide more precise error information; -C program comments revised; SLATEC error handler calls -C introduced to enable printing of error messages to meet -C SLATEC standards. These changes were done by D. W. Lozier, -C M. A. McClain and J. M. Smith of the National Institute -C of Standards and Technology, formerly NBS. -C 910415 Mixed type expressions eliminated; variable C1 initialized; -C description of SIXCOF expanded. These changes were done by -C D. W. Lozier. -C***END PROLOGUE RC6J -C - INTEGER NDIM, IER - REAL L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF(NDIM) -C - INTEGER I, INDEX, LSTEP, N, NFIN, NFINP1, NFINP2, NFINP3, NLIM, - + NSTEP2 - REAL A1, A1S, A2, A2S, C1, C1OLD, C2, CNORM, R1MACH, - + DENOM, DV, EPS, HUGE, L1, NEWFAC, OLDFAC, ONE, - + RATIO, SIGN1, SIGN2, SRHUGE, SRTINY, SUM1, SUM2, - + SUMBAC, SUMFOR, SUMUNI, THREE, THRESH, TINY, TWO, - + X, X1, X2, X3, Y, Y1, Y2, Y3, ZERO -C - DATA ZERO,EPS,ONE,TWO,THREE /0.0,0.01,1.0,2.0,3.0/ -C -C***FIRST EXECUTABLE STATEMENT RC6J - IER=0 -C HUGE is the square root of one twentieth of the largest floating -C point number, approximately. - HUGE = SQRT(R1MACH(2)/20.0) - SRHUGE = SQRT(HUGE) - TINY = 1.0/HUGE - SRTINY = 1.0/SRHUGE -C -C LMATCH = ZERO -C -C Check error conditions 1, 2, and 3. - IF((MOD(L2+L3+L5+L6+EPS,ONE).GE.EPS+EPS).OR. - + (MOD(L4+L2+L6+EPS,ONE).GE.EPS+EPS))THEN - IER=1 - CALL XERMSG('SLATEC','RC6J','L2+L3+L5+L6 or L4+L2+L6 not '// - + 'integer.',IER,1) - RETURN - ELSEIF((L4+L2-L6.LT.ZERO).OR.(L4-L2+L6.LT.ZERO).OR. - + (-L4+L2+L6.LT.ZERO))THEN - IER=2 - CALL XERMSG('SLATEC','RC6J','L4, L2, L6 triangular '// - + 'condition not satisfied.',IER,1) - RETURN - ELSEIF((L4-L5+L3.LT.ZERO).OR.(L4+L5-L3.LT.ZERO).OR. - + (-L4+L5+L3.LT.ZERO))THEN - IER=3 - CALL XERMSG('SLATEC','RC6J','L4, L5, L3 triangular '// - + 'condition not satisfied.',IER,1) - RETURN - ENDIF -C -C Limits for L1 -C - L1MIN = MAX(ABS(L2-L3),ABS(L5-L6)) - L1MAX = MIN(L2+L3,L5+L6) -C -C Check error condition 4. - IF(MOD(L1MAX-L1MIN+EPS,ONE).GE.EPS+EPS)THEN - IER=4 - CALL XERMSG('SLATEC','RC6J','L1MAX-L1MIN not integer.',IER,1) - RETURN - ENDIF - IF(L1MIN.LT.L1MAX-EPS) GO TO 20 - IF(L1MIN.LT.L1MAX+EPS) GO TO 10 -C -C Check error condition 5. - IER=5 - CALL XERMSG('SLATEC','RC6J','L1MIN greater than L1MAX.',IER,1) - RETURN -C -C -C This is reached in case that L1 can take only one value -C - 10 CONTINUE -C LSCALE = 0 - SIXCOF(1) = (-ONE) ** INT(L2+L3+L5+L6+EPS) / - 1 SQRT((L1MIN+L1MIN+ONE)*(L4+L4+ONE)) - RETURN -C -C -C This is reached in case that L1 can take more than one value. -C - 20 CONTINUE -C LSCALE = 0 - NFIN = INT(L1MAX-L1MIN+ONE+EPS) - IF(NDIM-NFIN) 21, 23, 23 -C -C Check error condition 6. - 21 IER = 6 - CALL XERMSG('SLATEC','RC6J','Dimension of result array for 6j '// - + 'coefficients too small.',IER,1) - RETURN -C -C -C Start of forward recursion -C - 23 L1 = L1MIN - NEWFAC = 0.0 - C1 = 0.0 - SIXCOF(1) = SRTINY - SUM1 = (L1+L1+ONE) * TINY -C - LSTEP = 1 - 30 LSTEP = LSTEP + 1 - L1 = L1 + ONE -C - OLDFAC = NEWFAC - A1 = (L1+L2+L3+ONE) * (L1-L2+L3) * (L1+L2-L3) * (-L1+L2+L3+ONE) - A2 = (L1+L5+L6+ONE) * (L1-L5+L6) * (L1+L5-L6) * (-L1+L5+L6+ONE) - NEWFAC = SQRT(A1*A2) -C - IF(L1.LT.ONE+EPS) GO TO 40 -C - DV = TWO * ( L2*(L2+ONE)*L5*(L5+ONE) + L3*(L3+ONE)*L6*(L6+ONE) - 1 - L1*(L1-ONE)*L4*(L4+ONE) ) - 2 - (L2*(L2+ONE) + L3*(L3+ONE) - L1*(L1-ONE)) - 3 * (L5*(L5+ONE) + L6*(L6+ONE) - L1*(L1-ONE)) -C - DENOM = (L1-ONE) * NEWFAC -C - IF(LSTEP-2) 32, 32, 31 -C - 31 C1OLD = ABS(C1) - 32 C1 = - (L1+L1-ONE) * DV / DENOM - GO TO 50 -C -C If L1 = 1, (L1 - 1) has to be factored out of DV, hence -C - 40 C1 = - TWO * ( L2*(L2+ONE) + L5*(L5+ONE) - L4*(L4+ONE) ) - 1 / NEWFAC -C - 50 IF(LSTEP.GT.2) GO TO 60 -C -C If L1 = L1MIN + 1, the third term in recursion equation vanishes -C - X = SRTINY * C1 - SIXCOF(2) = X - SUM1 = SUM1 + TINY * (L1+L1+ONE) * C1 * C1 -C - IF(LSTEP.EQ.NFIN) GO TO 220 - GO TO 30 -C -C - 60 C2 = - L1 * OLDFAC / DENOM -C -C Recursion to the next 6j coefficient X -C - X = C1 * SIXCOF(LSTEP-1) + C2 * SIXCOF(LSTEP-2) - SIXCOF(LSTEP) = X -C - SUMFOR = SUM1 - SUM1 = SUM1 + (L1+L1+ONE) * X * X - IF(LSTEP.EQ.NFIN) GO TO 100 -C -C See if last unnormalized 6j coefficient exceeds SRHUGE -C - IF(ABS(X).LT.SRHUGE) GO TO 80 -C -C This is reached if last 6j coefficient larger than SRHUGE, -C so that the recursion series SIXCOF(1), ... ,SIXCOF(LSTEP) -C has to be rescaled to prevent overflow -C -C LSCALE = LSCALE + 1 - DO 70 I=1,LSTEP - IF(ABS(SIXCOF(I)).LT.SRTINY) SIXCOF(I) = ZERO - 70 SIXCOF(I) = SIXCOF(I) / SRHUGE - SUM1 = SUM1 / HUGE - SUMFOR = SUMFOR / HUGE - X = X / SRHUGE -C -C -C As long as the coefficient ABS(C1) is decreasing, the recursion -C proceeds towards increasing 6j values and, hence, is numerically -C stable. Once an increase of ABS(C1) is detected, the recursion -C direction is reversed. -C - 80 IF(C1OLD-ABS(C1)) 100, 100, 30 -C -C -C Keep three 6j coefficients around LMATCH for comparison later -C with backward recursion. -C - 100 CONTINUE -C LMATCH = L1 - 1 - X1 = X - X2 = SIXCOF(LSTEP-1) - X3 = SIXCOF(LSTEP-2) -C -C -C -C Starting backward recursion from L1MAX taking NSTEP2 steps, so -C that forward and backward recursion overlap at the three points -C L1 = LMATCH+1, LMATCH, LMATCH-1. -C - NFINP1 = NFIN + 1 - NFINP2 = NFIN + 2 - NFINP3 = NFIN + 3 - NSTEP2 = NFIN - LSTEP + 3 - L1 = L1MAX -C - SIXCOF(NFIN) = SRTINY - SUM2 = (L1+L1+ONE) * TINY -C -C - L1 = L1 + TWO - LSTEP = 1 - 110 LSTEP = LSTEP + 1 - L1 = L1 - ONE -C - OLDFAC = NEWFAC - A1S = (L1+L2+L3)*(L1-L2+L3-ONE)*(L1+L2-L3-ONE)*(-L1+L2+L3+TWO) - A2S = (L1+L5+L6)*(L1-L5+L6-ONE)*(L1+L5-L6-ONE)*(-L1+L5+L6+TWO) - NEWFAC = SQRT(A1S*A2S) -C - DV = TWO * ( L2*(L2+ONE)*L5*(L5+ONE) + L3*(L3+ONE)*L6*(L6+ONE) - 1 - L1*(L1-ONE)*L4*(L4+ONE) ) - 2 - (L2*(L2+ONE) + L3*(L3+ONE) - L1*(L1-ONE)) - 3 * (L5*(L5+ONE) + L6*(L6+ONE) - L1*(L1-ONE)) -C - DENOM = L1 * NEWFAC - C1 = - (L1+L1-ONE) * DV / DENOM - IF(LSTEP.GT.2) GO TO 120 -C -C If L1 = L1MAX + 1 the third term in the recursion equation vanishes -C - Y = SRTINY * C1 - SIXCOF(NFIN-1) = Y - IF(LSTEP.EQ.NSTEP2) GO TO 200 - SUMBAC = SUM2 - SUM2 = SUM2 + (L1+L1-THREE) * C1 * C1 * TINY - GO TO 110 -C -C - 120 C2 = - (L1-ONE) * OLDFAC / DENOM -C -C Recursion to the next 6j coefficient Y -C - Y = C1 * SIXCOF(NFINP2-LSTEP) + C2 * SIXCOF(NFINP3-LSTEP) - IF(LSTEP.EQ.NSTEP2) GO TO 200 - SIXCOF(NFINP1-LSTEP) = Y - SUMBAC = SUM2 - SUM2 = SUM2 + (L1+L1-THREE) * Y * Y -C -C See if last unnormalized 6j coefficient exceeds SRHUGE -C - IF(ABS(Y).LT.SRHUGE) GO TO 110 -C -C This is reached if last 6j coefficient larger than SRHUGE, -C so that the recursion series SIXCOF(NFIN), ... ,SIXCOF(NFIN-LSTEP+1) -C has to be rescaled to prevent overflow -C -C LSCALE = LSCALE + 1 - DO 130 I=1,LSTEP - INDEX = NFIN-I+1 - IF(ABS(SIXCOF(INDEX)).LT.SRTINY) SIXCOF(INDEX) = ZERO - 130 SIXCOF(INDEX) = SIXCOF(INDEX) / SRHUGE - SUMBAC = SUMBAC / HUGE - SUM2 = SUM2 / HUGE -C - GO TO 110 -C -C -C The forward recursion 6j coefficients X1, X2, X3 are to be matched -C with the corresponding backward recursion values Y1, Y2, Y3. -C - 200 Y3 = Y - Y2 = SIXCOF(NFINP2-LSTEP) - Y1 = SIXCOF(NFINP3-LSTEP) -C -C -C Determine now RATIO such that YI = RATIO * XI (I=1,2,3) holds -C with minimal error. -C - RATIO = ( X1*Y1 + X2*Y2 + X3*Y3 ) / ( X1*X1 + X2*X2 + X3*X3 ) - NLIM = NFIN - NSTEP2 + 1 -C - IF(ABS(RATIO).LT.ONE) GO TO 211 -C - DO 210 N=1,NLIM - 210 SIXCOF(N) = RATIO * SIXCOF(N) - SUMUNI = RATIO * RATIO * SUMFOR + SUMBAC - GO TO 230 -C - 211 NLIM = NLIM + 1 - RATIO = ONE / RATIO - DO 212 N=NLIM,NFIN - 212 SIXCOF(N) = RATIO * SIXCOF(N) - SUMUNI = SUMFOR + RATIO*RATIO*SUMBAC - GO TO 230 -C - 220 SUMUNI = SUM1 -C -C -C Normalize 6j coefficients -C - 230 CNORM = ONE / SQRT((L4+L4+ONE)*SUMUNI) -C -C Sign convention for last 6j coefficient determines overall phase -C - SIGN1 = SIGN(ONE,SIXCOF(NFIN)) - SIGN2 = (-ONE) ** INT(L2+L3+L5+L6+EPS) - IF(SIGN1*SIGN2) 235,235,236 - 235 CNORM = - CNORM -C - 236 IF(ABS(CNORM).LT.ONE) GO TO 250 -C - DO 240 N=1,NFIN - 240 SIXCOF(N) = CNORM * SIXCOF(N) - RETURN -C - 250 THRESH = TINY / ABS(CNORM) - DO 251 N=1,NFIN - IF(ABS(SIXCOF(N)).LT.THRESH) SIXCOF(N) = ZERO - 251 SIXCOF(N) = CNORM * SIXCOF(N) -C - RETURN - END diff --git a/slatec/rd.f b/slatec/rd.f deleted file mode 100644 index dc94d8c..0000000 --- a/slatec/rd.f +++ /dev/null @@ -1,408 +0,0 @@ -*DECK RD - REAL FUNCTION RD (X, Y, Z, IER) -C***BEGIN PROLOGUE RD -C***PURPOSE Compute the incomplete or complete elliptic integral of the -C 2nd kind. For X and Y nonnegative, X+Y and Z positive, -C RD(X,Y,Z) = Integral from zero to infinity of -C -1/2 -1/2 -3/2 -C (3/2)(t+X) (t+Y) (t+Z) dt. -C If X or Y is zero, the integral is complete. -C***LIBRARY SLATEC -C***CATEGORY C14 -C***TYPE SINGLE PRECISION (RD-S, DRD-D) -C***KEYWORDS COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM, -C INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE SECOND KIND, -C TAYLOR SERIES -C***AUTHOR Carlson, B. C. -C Ames Laboratory-DOE -C Iowa State University -C Ames, IA 50011 -C Notis, E. M. -C Ames Laboratory-DOE -C Iowa State University -C Ames, IA 50011 -C Pexton, R. L. -C Lawrence Livermore National Laboratory -C Livermore, CA 94550 -C***DESCRIPTION -C -C 1. RD -C Evaluate an INCOMPLETE (or COMPLETE) ELLIPTIC INTEGRAL -C of the second kind -C Standard FORTRAN function routine -C Single precision version -C The routine calculates an approximation result to -C RD(X,Y,Z) = Integral from zero to infinity of -C -1/2 -1/2 -3/2 -C (3/2)(t+X) (t+Y) (t+Z) dt, -C where X and Y are nonnegative, X + Y is positive, and Z is -C positive. If X or Y is zero, the integral is COMPLETE. -C The duplication theorem is iterated until the variables are -C nearly equal, and the function is then expanded in Taylor -C series to fifth order. -C -C 2. Calling Sequence -C -C RD( X, Y, Z, IER ) -C -C Parameters on Entry -C Values assigned by the calling routine -C -C X - Single precision, nonnegative variable -C -C Y - Single precision, nonnegative variable -C -C X + Y is positive -C -C Z - Real, positive variable -C -C -C -C On Return (values assigned by the RD routine) -C -C RD - Real approximation to the integral -C -C -C IER - Integer -C -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C -C IER > 0 Abnormal termination of the routine -C -C -C X, Y, Z are unaltered. -C -C 3. Error Messages -C -C Value of IER assigned by the RD routine -C -C Value Assigned Error Message Printed -C IER = 1 MIN(X,Y) .LT. 0.0E0 -C = 2 MIN(X + Y, Z ) .LT. LOLIM -C = 3 MAX(X,Y,Z) .GT. UPLIM -C -C -C 4. Control Parameters -C -C Values of LOLIM, UPLIM, and ERRTOL are set by the -C routine. -C -C LOLIM and UPLIM determine the valid range of X, Y, and Z -C -C LOLIM - Lower limit of valid arguments -C -C Not less than 2 / (machine maximum) ** (2/3). -C -C UPLIM - Upper limit of valid arguments -C -C Not greater than (0.1E0 * ERRTOL / machine -C minimum) ** (2/3), where ERRTOL is described below. -C In the following table it is assumed that ERRTOL -C will never be chosen smaller than 1.0E-5. -C -C -C Acceptable Values For: LOLIM UPLIM -C IBM 360/370 SERIES : 6.0E-51 1.0E+48 -C CDC 6000/7000 SERIES : 5.0E-215 2.0E+191 -C UNIVAC 1100 SERIES : 1.0E-25 2.0E+21 -C CRAY : 3.0E-1644 1.69E+1640 -C VAX 11 SERIES : 1.0E-25 4.5E+21 -C -C -C ERRTOL determines the accuracy of the answer -C -C The value assigned by the routine will result -C in solution precision within 1-2 decimals of -C "machine precision". -C -C ERRTOL Relative error due to truncation is less than -C 3 * ERRTOL ** 6 / (1-ERRTOL) ** 3/2. -C -C -C -C The accuracy of the computed approximation to the inte- -C gral can be controlled by choosing the value of ERRTOL. -C Truncation of a Taylor series after terms of fifth order -C introduces an error less than the amount shown in the -C second column of the following table for each value of -C ERRTOL in the first column. In addition to the trunca- -C tion error there will be round-off error, but in prac- -C tice the total error from both sources is usually less -C than the amount given in the table. -C -C -C -C -C Sample Choices: ERRTOL Relative Truncation -C error less than -C 1.0E-3 4.0E-18 -C 3.0E-3 3.0E-15 -C 1.0E-2 4.0E-12 -C 3.0E-2 3.0E-9 -C 1.0E-1 4.0E-6 -C -C -C Decreasing ERRTOL by a factor of 10 yields six more -C decimal digits of accuracy at the expense of one or -C two more iterations of the duplication theorem. -C -C *Long Description: -C -C RD Special Comments -C -C -C -C Check: RD(X,Y,Z) + RD(Y,Z,X) + RD(Z,X,Y) -C = 3 / SQRT(X * Y * Z), where X, Y, and Z are positive. -C -C -C On Input: -C -C X, Y, and Z are the variables in the integral RD(X,Y,Z). -C -C -C On Output: -C -C -C X, Y, and Z are unaltered. -C -C -C -C ******************************************************** -C -C WARNING: Changes in the program may improve speed at the -C expense of robustness. -C -C -C -C ------------------------------------------------------------------- -C -C -C Special Functions via RD and RF -C -C -C Legendre form of ELLIPTIC INTEGRAL of 2nd kind -C ---------------------------------------------- -C -C -C 2 2 2 -C E(PHI,K) = SIN(PHI) RF(COS (PHI),1-K SIN (PHI),1) - -C -C 2 3 2 2 2 -C -(K/3) SIN (PHI) RD(COS (PHI),1-K SIN (PHI),1) -C -C -C 2 2 2 -C E(K) = RF(0,1-K ,1) - (K/3) RD(0,1-K ,1) -C -C -C PI/2 2 2 1/2 -C = INT (1-K SIN (PHI) ) D PHI -C 0 -C -C -C -C Bulirsch form of ELLIPTIC INTEGRAL of 2nd kind -C ---------------------------------------------- -C -C 2 2 2 -C EL2(X,KC,A,B) = AX RF(1,1+KC X ,1+X ) + -C -C 3 2 2 2 -C +(1/3)(B-A) X RD(1,1+KC X ,1+X ) -C -C -C -C Legendre form of alternative ELLIPTIC INTEGRAL of 2nd -C ----------------------------------------------------- -C kind -C ---- -C -C Q 2 2 2 -1/2 -C D(Q,K) = INT SIN P (1-K SIN P) DP -C 0 -C -C -C -C 3 2 2 2 -C D(Q,K) =(1/3)(SIN Q) RD(COS Q,1-K SIN Q,1) -C -C -C -C -C -C Lemniscate constant B -C --------------------- -C -C -C -C 1 2 4 -1/2 -C B = INT S (1-S ) DS -C 0 -C -C -C B =(1/3)RD (0,2,1) -C -C -C -C -C Heuman's LAMBDA function -C ------------------------ -C -C -C -C (PI/2) LAMBDA0(A,B) = -C -C 2 2 -C = SIN(B) (RF(0,COS (A),1)-(1/3) SIN (A) * -C -C 2 2 2 2 -C *RD(0,COS (A),1)) RF(COS (B),1-COS (A) SIN (B),1) -C -C 2 3 2 -C -(1/3) COS (A) SIN (B) RF(0,COS (A),1) * -C -C 2 2 2 -C *RD(COS (B),1-COS (A) SIN (B),1) -C -C -C -C Jacobi ZETA function -C -------------------- -C -C -C 2 2 2 2 -C Z(B,K) = (K/3) SIN(B) RF(COS (B),1-K SIN (B),1) -C -C -C 2 2 -C *RD(0,1-K ,1)/RF(0,1-K ,1) -C -C 2 3 2 2 2 -C -(K /3) SIN (B) RD(COS (B),1-K SIN (B),1) -C -C -C ------------------------------------------------------------------- -C -C***REFERENCES B. C. Carlson and E. M. Notis, Algorithms for incomplete -C elliptic integrals, ACM Transactions on Mathematical -C Software 7, 3 (September 1981), pp. 398-403. -C B. C. Carlson, Computing elliptic integrals by -C duplication, Numerische Mathematik 33, (1979), -C pp. 1-16. -C B. C. Carlson, Elliptic integrals of the first kind, -C SIAM Journal of Mathematical Analysis 8, (1977), -C pp. 231-242. -C***ROUTINES CALLED R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790801 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900510 Modify calls to XERMSG to put in standard form. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE RD - CHARACTER*16 XERN3, XERN4, XERN5, XERN6 - INTEGER IER - REAL LOLIM, UPLIM, EPSLON, ERRTOL - REAL C1, C2, C3, C4, EA, EB, EC, ED, EF, LAMDA - REAL MU, POWER4, SIGMA, S1, S2, X, XN, XNDEV - REAL XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV, ZNROOT - LOGICAL FIRST - SAVE ERRTOL, LOLIM, UPLIM, C1, C2, C3, C4, FIRST - DATA FIRST /.TRUE./ -C -C***FIRST EXECUTABLE STATEMENT RD - IF (FIRST) THEN - ERRTOL = (R1MACH(3)/3.0E0)**(1.0E0/6.0E0) - LOLIM = 2.0E0/(R1MACH(2))**(2.0E0/3.0E0) - TUPLIM = R1MACH(1)**(1.0E0/3.0E0) - TUPLIM = (0.10E0*ERRTOL)**(1.0E0/3.0E0)/TUPLIM - UPLIM = TUPLIM**2.0E0 -C - C1 = 3.0E0/14.0E0 - C2 = 1.0E0/6.0E0 - C3 = 9.0E0/22.0E0 - C4 = 3.0E0/26.0E0 - ENDIF - FIRST = .FALSE. -C -C CALL ERROR HANDLER IF NECESSARY. -C - RD = 0.0E0 - IF( MIN(X,Y).LT.0.0E0) THEN - IER = 1 - WRITE (XERN3, '(1PE15.6)') X - WRITE (XERN4, '(1PE15.6)') Y - CALL XERMSG ('SLATEC', 'RD', - * 'MIN(X,Y).LT.0 WHERE X = ' // XERN3 // ' AND Y = ' // - * XERN4, 1, 1) - RETURN - ENDIF -C - IF (MAX(X,Y,Z).GT.UPLIM) THEN - IER = 3 - WRITE (XERN3, '(1PE15.6)') X - WRITE (XERN4, '(1PE15.6)') Y - WRITE (XERN5, '(1PE15.6)') Z - WRITE (XERN6, '(1PE15.6)') UPLIM - CALL XERMSG ('SLATEC', 'RD', - * 'MAX(X,Y,Z).GT.UPLIM WHERE X = ' // XERN3 // ' Y = ' // - * XERN4 // ' Z = ' // XERN5 // ' AND UPLIM = ' // XERN6, - * 3, 1) - RETURN - ENDIF -C - IF (MIN(X+Y,Z).LT.LOLIM) THEN - IER = 2 - WRITE (XERN3, '(1PE15.6)') X - WRITE (XERN4, '(1PE15.6)') Y - WRITE (XERN5, '(1PE15.6)') Z - WRITE (XERN6, '(1PE15.6)') LOLIM - CALL XERMSG ('SLATEC', 'RD', - * 'MIN(X+Y,Z).LT.LOLIM WHERE X = ' // XERN3 // ' Y = ' // - * XERN4 // ' Z = ' // XERN5 // ' AND LOLIM = ' // XERN6, - * 2, 1) - RETURN - ENDIF -C - IER = 0 - XN = X - YN = Y - ZN = Z - SIGMA = 0.0E0 - POWER4 = 1.0E0 -C - 30 MU = (XN+YN+3.0E0*ZN)*0.20E0 - XNDEV = (MU-XN)/MU - YNDEV = (MU-YN)/MU - ZNDEV = (MU-ZN)/MU - EPSLON = MAX(ABS(XNDEV), ABS(YNDEV), ABS(ZNDEV)) - IF (EPSLON.LT.ERRTOL) GO TO 40 - XNROOT = SQRT(XN) - YNROOT = SQRT(YN) - ZNROOT = SQRT(ZN) - LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT - SIGMA = SIGMA + POWER4/(ZNROOT*(ZN+LAMDA)) - POWER4 = POWER4*0.250E0 - XN = (XN+LAMDA)*0.250E0 - YN = (YN+LAMDA)*0.250E0 - ZN = (ZN+LAMDA)*0.250E0 - GO TO 30 -C - 40 EA = XNDEV*YNDEV - EB = ZNDEV*ZNDEV - EC = EA - EB - ED = EA - 6.0E0*EB - EF = ED + EC + EC - S1 = ED*(-C1+0.250E0*C3*ED-1.50E0*C4*ZNDEV*EF) - S2 = ZNDEV*(C2*EF+ZNDEV*(-C3*EC+ZNDEV*C4*EA)) - RD = 3.0E0*SIGMA + POWER4*(1.0E0+S1+S2)/(MU* SQRT(MU)) -C - RETURN - END diff --git a/slatec/rebak.f b/slatec/rebak.f deleted file mode 100644 index d9f783e..0000000 --- a/slatec/rebak.f +++ /dev/null @@ -1,90 +0,0 @@ -*DECK REBAK - SUBROUTINE REBAK (NM, N, B, DL, M, Z) -C***BEGIN PROLOGUE REBAK -C***PURPOSE Form the eigenvectors of a generalized symmetric -C eigensystem from the eigenvectors of derived matrix output -C from REDUC or REDUC2. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C4 -C***TYPE SINGLE PRECISION (REBAK-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure REBAKA, -C NUM. MATH. 11, 99-110(1968) by Martin and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971). -C -C This subroutine forms the eigenvectors of a generalized -C SYMMETRIC eigensystem by back transforming those of the -C derived symmetric matrix determined by REDUC or REDUC2. -C -C On Input -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, B and Z, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix system. N is an INTEGER -C variable. N must be less than or equal to NM. -C -C B contains information about the similarity transformation -C (Cholesky decomposition) used in the reduction by REDUC -C or REDUC2 in its strict lower triangle. B is a two- -C dimensional REAL array, dimensioned B(NM,N). -C -C DL contains further information about the transformation. -C DL is a one-dimensional REAL array, dimensioned DL(N). -C -C M is the number of eigenvectors to be back transformed. -C M is an INTEGER variable. -C -C Z contains the eigenvectors to be back transformed in its -C first M columns. Z is a two-dimensional REAL array -C dimensioned Z(NM,M). -C -C On Output -C -C Z contains the transformed eigenvectors in its first -C M columns. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE REBAK -C - INTEGER I,J,K,M,N,I1,II,NM - REAL B(NM,*),DL(*),Z(NM,*) - REAL X -C -C***FIRST EXECUTABLE STATEMENT REBAK - IF (M .EQ. 0) GO TO 200 -C - DO 100 J = 1, M -C .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... - DO 100 II = 1, N - I = N + 1 - II - I1 = I + 1 - X = Z(I,J) - IF (I .EQ. N) GO TO 80 -C - DO 60 K = I1, N - 60 X = X - B(K,I) * Z(K,J) -C - 80 Z(I,J) = X / DL(I) - 100 CONTINUE -C - 200 RETURN - END diff --git a/slatec/rebakb.f b/slatec/rebakb.f deleted file mode 100644 index aca035a..0000000 --- a/slatec/rebakb.f +++ /dev/null @@ -1,90 +0,0 @@ -*DECK REBAKB - SUBROUTINE REBAKB (NM, N, B, DL, M, Z) -C***BEGIN PROLOGUE REBAKB -C***PURPOSE Form the eigenvectors of a generalized symmetric -C eigensystem from the eigenvectors of derived matrix output -C from REDUC2. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C4 -C***TYPE SINGLE PRECISION (REBAKB-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure REBAKB, -C NUM. MATH. 11, 99-110(1968) by Martin and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971). -C -C This subroutine forms the eigenvectors of a generalized -C SYMMETRIC eigensystem by back transforming those of the -C derived symmetric matrix determined by REDUC2. -C -C On Input -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, B and Z, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix system. N is an INTEGER -C variable. N must be less than or equal to NM. -C -C B contains information about the similarity transformation -C (Cholesky decomposition) used in the reduction by REDUC2 -C in its strict lower triangle. B is a two-dimensional -C REAL array, dimensioned B(NM,N). -C -C DL contains further information about the transformation. -C DL is a one-dimensional REAL array, dimensioned DL(N). -C -C M is the number of eigenvectors to be back transformed. -C M is an INTEGER variable. -C -C Z contains the eigenvectors to be back transformed in its -C first M columns. Z is a two-dimensional REAL array -C dimensioned Z(NM,M). -C -C On Output -C -C Z contains the transformed eigenvectors in its first -C M columns. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE REBAKB -C - INTEGER I,J,K,M,N,I1,II,NM - REAL B(NM,*),DL(*),Z(NM,*) - REAL X -C -C***FIRST EXECUTABLE STATEMENT REBAKB - IF (M .EQ. 0) GO TO 200 -C - DO 100 J = 1, M -C .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... - DO 100 II = 1, N - I1 = N - II - I = I1 + 1 - X = DL(I) * Z(I,J) - IF (I .EQ. 1) GO TO 80 -C - DO 60 K = 1, I1 - 60 X = X + B(I,K) * Z(K,J) -C - 80 Z(I,J) = X - 100 CONTINUE -C - 200 RETURN - END diff --git a/slatec/reduc.f b/slatec/reduc.f deleted file mode 100644 index e94a652..0000000 --- a/slatec/reduc.f +++ /dev/null @@ -1,140 +0,0 @@ -*DECK REDUC - SUBROUTINE REDUC (NM, N, A, B, DL, IERR) -C***BEGIN PROLOGUE REDUC -C***PURPOSE Reduce a generalized symmetric eigenproblem to a standard -C symmetric eigenproblem using Cholesky factorization. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C1C -C***TYPE SINGLE PRECISION (REDUC-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure REDUC1, -C NUM. MATH. 11, 99-110(1968) by Martin and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971). -C -C This subroutine reduces the generalized SYMMETRIC eigenproblem -C Ax=(LAMBDA)Bx, where B is POSITIVE DEFINITE, to the standard -C symmetric eigenproblem using the Cholesky factorization of B. -C -C On Input -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, A and B, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrices A and B. If the Cholesky -C factor L of B is already available, N should be prefixed -C with a minus sign. N is an INTEGER variable. -C -C A and B contain the real symmetric input matrices. Only -C the full upper triangles of the matrices need be supplied. -C If N is negative, the strict lower triangle of B contains, -C instead, the strict lower triangle of its Cholesky factor L. -C A and B are two-dimensional REAL arrays, dimensioned A(NM,N) -C and B(NM,N). -C -C DL contains, if N is negative, the diagonal elements of L. -C DL is a one-dimensional REAL array, dimensioned DL(N). -C -C On Output -C -C A contains in its full lower triangle the full lower triangle -C of the symmetric matrix derived from the reduction to the -C standard form. The strict upper triangle of A is unaltered. -C -C B contains in its strict lower triangle the strict lower -C triangle of its Cholesky factor L. The full upper triangle -C of B is unaltered. -C -C DL contains the diagonal elements of L. -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C 7*N+1 if B is not positive definite. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE REDUC -C - INTEGER I,J,K,N,I1,J1,NM,NN,IERR - REAL A(NM,*),B(NM,*),DL(*) - REAL X,Y -C -C***FIRST EXECUTABLE STATEMENT REDUC - IERR = 0 - NN = ABS(N) - IF (N .LT. 0) GO TO 100 -C .......... FORM L IN THE ARRAYS B AND DL .......... - DO 80 I = 1, N - I1 = I - 1 -C - DO 80 J = I, N - X = B(I,J) - IF (I .EQ. 1) GO TO 40 -C - DO 20 K = 1, I1 - 20 X = X - B(I,K) * B(J,K) -C - 40 IF (J .NE. I) GO TO 60 - IF (X .LE. 0.0E0) GO TO 1000 - Y = SQRT(X) - DL(I) = Y - GO TO 80 - 60 B(J,I) = X / Y - 80 CONTINUE -C .......... FORM THE TRANSPOSE OF THE UPPER TRIANGLE OF INV(L)*A -C IN THE LOWER TRIANGLE OF THE ARRAY A .......... - 100 DO 200 I = 1, NN - I1 = I - 1 - Y = DL(I) -C - DO 200 J = I, NN - X = A(I,J) - IF (I .EQ. 1) GO TO 180 -C - DO 160 K = 1, I1 - 160 X = X - B(I,K) * A(J,K) -C - 180 A(J,I) = X / Y - 200 CONTINUE -C .......... PRE-MULTIPLY BY INV(L) AND OVERWRITE .......... - DO 300 J = 1, NN - J1 = J - 1 -C - DO 300 I = J, NN - X = A(I,J) - IF (I .EQ. J) GO TO 240 - I1 = I - 1 -C - DO 220 K = J, I1 - 220 X = X - A(K,J) * B(I,K) -C - 240 IF (J .EQ. 1) GO TO 280 -C - DO 260 K = 1, J1 - 260 X = X - A(J,K) * B(I,K) -C - 280 A(I,J) = X / DL(I) - 300 CONTINUE -C - GO TO 1001 -C .......... SET ERROR -- B IS NOT POSITIVE DEFINITE .......... - 1000 IERR = 7 * N + 1 - 1001 RETURN - END diff --git a/slatec/reduc2.f b/slatec/reduc2.f deleted file mode 100644 index 8a9cec2..0000000 --- a/slatec/reduc2.f +++ /dev/null @@ -1,142 +0,0 @@ -*DECK REDUC2 - SUBROUTINE REDUC2 (NM, N, A, B, DL, IERR) -C***BEGIN PROLOGUE REDUC2 -C***PURPOSE Reduce a certain generalized symmetric eigenproblem to a -C standard symmetric eigenproblem using Cholesky -C factorization. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C1C -C***TYPE SINGLE PRECISION (REDUC2-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure REDUC2, -C NUM. MATH. 11, 99-110(1968) by Martin and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971). -C -C This subroutine reduces the generalized SYMMETRIC eigenproblems -C ABx=(LAMBDA)x OR BAy=(LAMBDA)y, where B is POSITIVE DEFINITE, -C to the standard symmetric eigenproblem using the Cholesky -C factorization of B. -C -C On Input -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, A and B, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrices A and B. If the Cholesky -C factor L of B is already available, N should be prefixed -C with a minus sign. N is an INTEGER variable. -C -C A and B contain the real symmetric input matrices. Only -C the full upper triangles of the matrices need be supplied. -C If N is negative, the strict lower triangle of B contains, -C instead, the strict lower triangle of its Cholesky factor L. -C A and B are two-dimensional REAL arrays, dimensioned A(NM,N) -C and B(NM,N). -C -C DL contains, if N is negative, the diagonal elements of L. -C DL is a one-dimensional REAL array, dimensioned DL(N). -C -C On Output -C -C A contains in its full lower triangle the full lower triangle -C of the symmetric matrix derived from the reduction to the -C standard form. The strict upper triangle of A is unaltered. -C -C B contains in its strict lower triangle the strict lower -C triangle of its Cholesky factor L. The full upper triangle -C of B is unaltered. -C -C DL contains the diagonal elements of L. -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C 7*N+1 if B is not positive definite. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE REDUC2 -C - INTEGER I,J,K,N,I1,J1,NM,NN,IERR - REAL A(NM,*),B(NM,*),DL(*) - REAL X,Y -C -C***FIRST EXECUTABLE STATEMENT REDUC2 - IERR = 0 - NN = ABS(N) - IF (N .LT. 0) GO TO 100 -C .......... FORM L IN THE ARRAYS B AND DL .......... - DO 80 I = 1, N - I1 = I - 1 -C - DO 80 J = I, N - X = B(I,J) - IF (I .EQ. 1) GO TO 40 -C - DO 20 K = 1, I1 - 20 X = X - B(I,K) * B(J,K) -C - 40 IF (J .NE. I) GO TO 60 - IF (X .LE. 0.0E0) GO TO 1000 - Y = SQRT(X) - DL(I) = Y - GO TO 80 - 60 B(J,I) = X / Y - 80 CONTINUE -C .......... FORM THE LOWER TRIANGLE OF A*L -C IN THE LOWER TRIANGLE OF THE ARRAY A .......... - 100 DO 200 I = 1, NN - I1 = I + 1 -C - DO 200 J = 1, I - X = A(J,I) * DL(J) - IF (J .EQ. I) GO TO 140 - J1 = J + 1 -C - DO 120 K = J1, I - 120 X = X + A(K,I) * B(K,J) -C - 140 IF (I .EQ. NN) GO TO 180 -C - DO 160 K = I1, NN - 160 X = X + A(I,K) * B(K,J) -C - 180 A(I,J) = X - 200 CONTINUE -C .......... PRE-MULTIPLY BY TRANSPOSE(L) AND OVERWRITE .......... - DO 300 I = 1, NN - I1 = I + 1 - Y = DL(I) -C - DO 300 J = 1, I - X = Y * A(I,J) - IF (I .EQ. NN) GO TO 280 -C - DO 260 K = I1, NN - 260 X = X + A(K,J) * B(K,I) -C - 280 A(I,J) = X - 300 CONTINUE -C - GO TO 1001 -C .......... SET ERROR -- B IS NOT POSITIVE DEFINITE .......... - 1000 IERR = 7 * N + 1 - 1001 RETURN - END diff --git a/slatec/reort.f b/slatec/reort.f deleted file mode 100644 index 20ee36b..0000000 --- a/slatec/reort.f +++ /dev/null @@ -1,179 +0,0 @@ -*DECK REORT - SUBROUTINE REORT (NCOMP, Y, YP, YHP, NIV, W, S, P, IP, STOWA, - + IFLAG) -C***BEGIN PROLOGUE REORT -C***SUBSIDIARY -C***PURPOSE Subsidiary to BVSUP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (REORT-S, DREORT-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C ********************************************************************** -C INPUT -C ********* -C Y, YP and YHP = homogeneous solution matrix and particular -C solution vector to be orthonormalized. -C IFLAG = 1 -- store YHP into Y and YP, test for -C reorthonormalization, orthonormalize if needed, -C save restart data. -C 2 -- store YHP into Y and YP, reorthonormalization, -C no restarts. -C (preset orthonormalization mode) -C 3 -- store YHP into Y and YP, reorthonormalization -C (when INHOMO=3 and X=XEND). -C ********************************************************************** -C OUTPUT -C ********* -C Y, YP = orthonormalized solutions. -C NIV = number of independent vectors returned from DMGSBV. -C IFLAG = 0 -- reorthonormalization was performed. -C 10 -- solution process must be restarted at the last -C orthonormalization point. -C 30 -- solutions are linearly dependent, problem must -C be restarted from the beginning. -C W, P, IP = orthonormalization information. -C ********************************************************************** -C -C***SEE ALSO BVSUP -C***ROUTINES CALLED MGSBV, SDOT, STOR1, STWAY -C***COMMON BLOCKS ML15TO, ML18JR, ML8SZ -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 890921 Realigned order of variables in certain COMMON blocks. -C (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE REORT -C - DIMENSION Y(NCOMP,*),YP(*),W(*),S(*),P(*),IP(*), - 1 STOWA(*),YHP(NCOMP,*) -C -C ********************************************************************** -C - COMMON /ML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMPD,NFC - COMMON /ML15TO/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP, - 1 KNSWOT,KOP,LOTJP,MNSWOT,NSWOT - COMMON /ML18JR/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ, - 1 INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,NFCC, - 2 ICOCO -C -C ********************************************************************** -C***FIRST EXECUTABLE STATEMENT REORT - NFCP=NFC+1 -C -C CHECK TO SEE IF ORTHONORMALIZATION TEST IS TO BE PERFORMED -C - IF (IFLAG .NE. 1) GO TO 5 - KNSWOT=KNSWOT+1 - IF (KNSWOT .GE. NSWOT) GO TO 5 - IF ((XEND-X)*(X-XOT) .LT. 0.) RETURN - 5 CALL STOR1(Y,YHP,YP,YHP(1,NFCP),1,0,0) -C -C **************************************** -C -C ORTHOGONALIZE THE HOMOGENEOUS SOLUTIONS Y -C AND PARTICULAR SOLUTION YP. -C - NIV=NFC - CALL MGSBV(NCOMP,NFC,Y,NCOMP,NIV,MFLAG,S,P,IP,INHOMO,YP,W,WCND) -C -C **************************************** -C -C CHECK FOR LINEAR DEPENDENCE OF THE SOLUTIONS. -C - IF (MFLAG .EQ. 0) GO TO 25 - IF (IFLAG .EQ. 2) GO TO 15 - IF (NSWOT .GT. 1 .OR. LOTJP .EQ. 0) GO TO 20 - 15 IFLAG=30 - RETURN -C -C RETRIEVE DATA FOR A RESTART AT LAST ORTHONORMALIZATION POINT -C - 20 CALL STWAY(Y,YP,YHP,1,STOWA) - LOTJP=1 - NSWOT=1 - KNSWOT=0 - MNSWOT=MNSWOT/2 - TND=TND+1. - IFLAG=10 - RETURN -C -C **************************************** -C - 25 IF (IFLAG .NE. 1) GO TO 60 -C -C TEST FOR ORTHONORMALIZATION -C - IF (WCND .LT. 50.*TOL) GO TO 60 - DO 30 IJK=1,NFCP - IF (S(IJK) .GT. 1.0E+20) GO TO 60 - 30 CONTINUE -C -C USE LINEAR EXTRAPOLATION ON LOGARITHMIC VALUES OF THE NORM -C DECREMENTS TO DETERMINE NEXT ORTHONORMALIZATION CHECKPOINT. -C OTHER CONTROLS ON THE NUMBER OF STEPS TO THE NEXT CHECKPOINT -C ARE ADDED FOR SAFETY PURPOSES. -C - NSWOT=KNSWOT - KNSWOT=0 - LOTJP=0 - WCND=LOG10(WCND) - IF (WCND .GT. TND+3.) NSWOT=2*NSWOT - IF (WCND .GE. PWCND) GO TO 40 - DX=X-PX - DND=PWCND-WCND - IF (DND .GE. 4) NSWOT=NSWOT/2 - DNDT=WCND-TND - IF (ABS(DX*DNDT) .GT. DND*ABS(XEND-X)) GO TO 40 - XOT=X+DX*DNDT/DND - GO TO 50 - 40 XOT=XEND - 50 NSWOT=MIN(MNSWOT,NSWOT) - PWCND=WCND - PX=X - RETURN -C -C **************************************** -C -C ORTHONORMALIZATION NECESSARY SO WE NORMALIZE THE HOMOGENEOUS -C SOLUTION VECTORS AND CHANGE W ACCORDINGLY. -C - 60 NSWOT=1 - KNSWOT=0 - LOTJP=1 - KK = 1 - L=1 - DO 70 K = 1,NFCC - SRP=SQRT(P(KK)) - IF (INHOMO .EQ. 1) W(K)=SRP*W(K) - VNORM=1./SRP - P(KK)=VNORM - KK = KK + NFCC + 1 - K - IF (NFC .EQ. NFCC) GO TO 63 - IF (L .NE. K/2) GO TO 70 - 63 DO 65 J = 1,NCOMP - 65 Y(J,L) = Y(J,L)*VNORM - L=L+1 - 70 CONTINUE -C - IF (INHOMO .NE. 1 .OR. NPS .EQ. 1) GO TO 100 -C -C NORMALIZE THE PARTICULAR SOLUTION -C - YPNM=SDOT(NCOMP,YP,1,YP,1) - IF (YPNM .EQ. 0.0) YPNM = 1.0 - YPNM = SQRT(YPNM) - S(NFCP) = YPNM - DO 80 J = 1,NCOMP - 80 YP(J) = YP(J) / YPNM - DO 90 J = 1,NFCC - 90 W(J) = C * W(J) -C - 100 IF (IFLAG .EQ. 1) CALL STWAY(Y,YP,YHP,0,STOWA) - IFLAG=0 - RETURN - END diff --git a/slatec/rf.f b/slatec/rf.f deleted file mode 100644 index 1efabfa..0000000 --- a/slatec/rf.f +++ /dev/null @@ -1,335 +0,0 @@ -*DECK RF - REAL FUNCTION RF (X, Y, Z, IER) -C***BEGIN PROLOGUE RF -C***PURPOSE Compute the incomplete or complete elliptic integral of the -C 1st kind. For X, Y, and Z non-negative and at most one of -C them zero, RF(X,Y,Z) = Integral from zero to infinity of -C -1/2 -1/2 -1/2 -C (1/2)(t+X) (t+Y) (t+Z) dt. -C If X, Y or Z is zero, the integral is complete. -C***LIBRARY SLATEC -C***CATEGORY C14 -C***TYPE SINGLE PRECISION (RF-S, DRF-D) -C***KEYWORDS COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM, -C INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE FIRST KIND, -C TAYLOR SERIES -C***AUTHOR Carlson, B. C. -C Ames Laboratory-DOE -C Iowa State University -C Ames, IA 50011 -C Notis, E. M. -C Ames Laboratory-DOE -C Iowa State University -C Ames, IA 50011 -C Pexton, R. L. -C Lawrence Livermore National Laboratory -C Livermore, CA 94550 -C***DESCRIPTION -C -C 1. RF -C Evaluate an INCOMPLETE (or COMPLETE) ELLIPTIC INTEGRAL -C of the first kind -C Standard FORTRAN function routine -C Single precision version -C The routine calculates an approximation result to -C RF(X,Y,Z) = Integral from zero to infinity of -C -C -1/2 -1/2 -1/2 -C (1/2)(t+X) (t+Y) (t+Z) dt, -C -C where X, Y, and Z are nonnegative and at most one of them -C is zero. If one of them is zero, the integral is COMPLETE. -C The duplication theorem is iterated until the variables are -C nearly equal, and the function is then expanded in Taylor -C series to fifth order. -C -C 2. Calling Sequence -C RF( X, Y, Z, IER ) -C -C Parameters on Entry -C Values assigned by the calling routine -C -C X - Single precision, nonnegative variable -C -C Y - Single precision, nonnegative variable -C -C Z - Single precision, nonnegative variable -C -C -C -C On Return (values assigned by the RF routine) -C -C RF - Single precision approximation to the integral -C -C IER - Integer -C -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C -C IER > 0 Abnormal termination of the routine -C -C X, Y, Z are unaltered. -C -C -C 3. Error Messages -C -C Value of IER assigned by the RF routine -C -C Value assigned Error Message Printed -C IER = 1 MIN(X,Y,Z) .LT. 0.0E0 -C = 2 MIN(X+Y,X+Z,Y+Z) .LT. LOLIM -C = 3 MAX(X,Y,Z) .GT. UPLIM -C -C -C -C 4. Control Parameters -C -C Values of LOLIM, UPLIM, and ERRTOL are set by the -C routine. -C -C LOLIM and UPLIM determine the valid range of X, Y and Z -C -C LOLIM - Lower limit of valid arguments -C -C Not less than 5 * (machine minimum). -C -C UPLIM - Upper limit of valid arguments -C -C Not greater than (machine maximum) / 5. -C -C -C Acceptable Values For: LOLIM UPLIM -C IBM 360/370 SERIES : 3.0E-78 1.0E+75 -C CDC 6000/7000 SERIES : 1.0E-292 1.0E+321 -C UNIVAC 1100 SERIES : 1.0E-37 1.0E+37 -C CRAY : 2.3E-2466 1.09E+2465 -C VAX 11 SERIES : 1.5E-38 3.0E+37 -C -C -C -C ERRTOL determines the accuracy of the answer -C -C The value assigned by the routine will result -C in solution precision within 1-2 decimals of -C "machine precision". -C -C -C -C ERRTOL - Relative error due to truncation is less than -C ERRTOL ** 6 / (4 * (1-ERRTOL) . -C -C -C -C The accuracy of the computed approximation to the inte- -C gral can be controlled by choosing the value of ERRTOL. -C Truncation of a Taylor series after terms of fifth order -C introduces an error less than the amount shown in the -C second column of the following table for each value of -C ERRTOL in the first column. In addition to the trunca- -C tion error there will be round-off error, but in prac- -C tice the total error from both sources is usually less -C than the amount given in the table. -C -C -C -C -C -C Sample Choices: ERRTOL Relative Truncation -C error less than -C 1.0E-3 3.0E-19 -C 3.0E-3 2.0E-16 -C 1.0E-2 3.0E-13 -C 3.0E-2 2.0E-10 -C 1.0E-1 3.0E-7 -C -C -C Decreasing ERRTOL by a factor of 10 yields six more -C decimal digits of accuracy at the expense of one or -C two more iterations of the duplication theorem. -C -C *Long Description: -C -C RF Special Comments -C -C -C -C Check by addition theorem: RF(X,X+Z,X+W) + RF(Y,Y+Z,Y+W) -C = RF(0,Z,W), where X,Y,Z,W are positive and X * Y = Z * W. -C -C -C On Input: -C -C X, Y, and Z are the variables in the integral RF(X,Y,Z). -C -C -C On Output: -C -C -C X, Y, and Z are unaltered. -C -C -C -C ******************************************************** -C -C Warning: Changes in the program may improve speed at the -C expense of robustness. -C -C -C -C Special Functions via RF -C -C -C Legendre form of ELLIPTIC INTEGRAL of 1st kind -C ---------------------------------------------- -C -C -C 2 2 2 -C F(PHI,K) = SIN(PHI) RF(COS (PHI),1-K SIN (PHI),1) -C -C -C 2 -C K(K) = RF(0,1-K ,1) -C -C PI/2 2 2 -1/2 -C = INT (1-K SIN (PHI) ) D PHI -C 0 -C -C -C -C -C -C Bulirsch form of ELLIPTIC INTEGRAL of 1st kind -C ---------------------------------------------- -C -C -C 2 2 2 -C EL1(X,KC) = X RF(1,1+KC X ,1+X ) -C -C -C -C -C Lemniscate constant A -C --------------------- -C -C -C 1 4 -1/2 -C A = INT (1-S ) DS = RF(0,1,2) = RF(0,2,1) -C 0 -C -C -C ------------------------------------------------------------------- -C -C***REFERENCES B. C. Carlson and E. M. Notis, Algorithms for incomplete -C elliptic integrals, ACM Transactions on Mathematical -C Software 7, 3 (September 1981), pp. 398-403. -C B. C. Carlson, Computing elliptic integrals by -C duplication, Numerische Mathematik 33, (1979), -C pp. 1-16. -C B. C. Carlson, Elliptic integrals of the first kind, -C SIAM Journal of Mathematical Analysis 8, (1977), -C pp. 231-242. -C***ROUTINES CALLED R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891009 Removed unreferenced statement labels. (WRB) -C 891009 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900510 Changed calls to XERMSG to standard form, and some -C editorial changes. (RWC)) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE RF - CHARACTER*16 XERN3, XERN4, XERN5, XERN6 - INTEGER IER - REAL LOLIM, UPLIM, EPSLON, ERRTOL - REAL C1, C2, C3, E2, E3, LAMDA - REAL MU, S, X, XN, XNDEV - REAL XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV, - * ZNROOT - LOGICAL FIRST - SAVE ERRTOL,LOLIM,UPLIM,C1,C2,C3,FIRST - DATA FIRST /.TRUE./ -C -C***FIRST EXECUTABLE STATEMENT RF -C - IF (FIRST) THEN - ERRTOL = (4.0E0*R1MACH(3))**(1.0E0/6.0E0) - LOLIM = 5.0E0 * R1MACH(1) - UPLIM = R1MACH(2)/5.0E0 -C - C1 = 1.0E0/24.0E0 - C2 = 3.0E0/44.0E0 - C3 = 1.0E0/14.0E0 - ENDIF - FIRST = .FALSE. -C -C CALL ERROR HANDLER IF NECESSARY. -C - RF = 0.0E0 - IF (MIN(X,Y,Z).LT.0.0E0) THEN - IER = 1 - WRITE (XERN3, '(1PE15.6)') X - WRITE (XERN4, '(1PE15.6)') Y - WRITE (XERN5, '(1PE15.6)') Z - CALL XERMSG ('SLATEC', 'RF', - * 'MIN(X,Y,Z).LT.0 WHERE X = ' // XERN3 // ' Y = ' // XERN4 // - * ' AND Z = ' // XERN5, 1, 1) - RETURN - ENDIF -C - IF (MAX(X,Y,Z).GT.UPLIM) THEN - IER = 3 - WRITE (XERN3, '(1PE15.6)') X - WRITE (XERN4, '(1PE15.6)') Y - WRITE (XERN5, '(1PE15.6)') Z - WRITE (XERN6, '(1PE15.6)') UPLIM - CALL XERMSG ('SLATEC', 'RF', - * 'MAX(X,Y,Z).GT.UPLIM WHERE X = ' // XERN3 // ' Y = ' // - * XERN4 // ' Z = ' // XERN5 // ' AND UPLIM = ' // XERN6, 3, 1) - RETURN - ENDIF -C - IF (MIN(X+Y,X+Z,Y+Z).LT.LOLIM) THEN - IER = 2 - WRITE (XERN3, '(1PE15.6)') X - WRITE (XERN4, '(1PE15.6)') Y - WRITE (XERN5, '(1PE15.6)') Z - WRITE (XERN6, '(1PE15.6)') LOLIM - CALL XERMSG ('SLATEC', 'RF', - * 'MIN(X+Y,X+Z,Y+Z).LT.LOLIM WHERE X = ' // XERN3 // - * ' Y = ' // XERN4 // ' Z = ' // XERN5 // ' AND LOLIM = ' // - * XERN6, 2, 1) - RETURN - ENDIF -C - IER = 0 - XN = X - YN = Y - ZN = Z -C - 30 MU = (XN+YN+ZN)/3.0E0 - XNDEV = 2.0E0 - (MU+XN)/MU - YNDEV = 2.0E0 - (MU+YN)/MU - ZNDEV = 2.0E0 - (MU+ZN)/MU - EPSLON = MAX(ABS(XNDEV), ABS(YNDEV), ABS(ZNDEV)) - IF (EPSLON.LT.ERRTOL) GO TO 40 - XNROOT = SQRT(XN) - YNROOT = SQRT(YN) - ZNROOT = SQRT(ZN) - LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT - XN = (XN+LAMDA)*0.250E0 - YN = (YN+LAMDA)*0.250E0 - ZN = (ZN+LAMDA)*0.250E0 - GO TO 30 -C - 40 E2 = XNDEV*YNDEV - ZNDEV*ZNDEV - E3 = XNDEV*YNDEV*ZNDEV - S = 1.0E0 + (C1*E2-0.10E0-C2*E3)*E2 + C3*E3 - RF = S/SQRT(MU) -C - RETURN - END diff --git a/slatec/rfftb.f b/slatec/rfftb.f deleted file mode 100644 index 0a044c5..0000000 --- a/slatec/rfftb.f +++ /dev/null @@ -1,96 +0,0 @@ -*DECK RFFTB - SUBROUTINE RFFTB (N, R, WSAVE) -C***BEGIN PROLOGUE RFFTB -C***SUBSIDIARY -C***PURPOSE Compute the backward fast Fourier transform of a real -C coefficient array. -C***LIBRARY SLATEC (FFTPACK) -C***CATEGORY J1A1 -C***TYPE SINGLE PRECISION (RFFTB-S, CFFTB-C) -C***KEYWORDS FFTPACK, FOURIER TRANSFORM -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C ******************************************************************** -C * NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE * -C ******************************************************************** -C * * -C * This routine uses non-standard Fortran 77 constructs and will * -C * be removed from the library at a future date. You are * -C * requested to use RFFTB1. * -C * * -C ******************************************************************** -C -C Subroutine RFFTB computes the real periodic sequence from its -C Fourier coefficients (Fourier synthesis). The transform is defined -C below at output parameter R. -C -C Input Arguments -C -C N the length of the array R to be transformed. The method -C is most efficient when N is a product of small primes. -C N may change so long as different work arrays are provided. -C -C R a real array of length N which contains the sequence -C to be transformed. -C -C WSAVE a work array which must be dimensioned at least 2*N+15 -C in the program that calls RFFTB. The WSAVE array must be -C initialized by calling subroutine RFFTI, and a different -C WSAVE array must be used for each different value of N. -C This initialization does not have to be repeated so long as -C remains unchanged. Thus subsequent transforms can be -C obtained faster than the first. Moreover, the same WSAVE -C array can be used by RFFTF and RFFTB as long as N remains -C unchanged. -C -C Output Argument -C -C R For N even and for I = 1,...,N -C -C R(I) = R(1)+(-1)**(I-1)*R(N) -C -C plus the sum from K=2 to K=N/2 of -C -C 2.*R(2*K-2)*COS((K-1)*(I-1)*2*PI/N) -C -C -2.*R(2*K-1)*SIN((K-1)*(I-1)*2*PI/N) -C -C For N odd and for I = 1,...,N -C -C R(I) = R(1) plus the sum from K=2 to K=(N+1)/2 of -C -C 2.*R(2*K-2)*COS((K-1)*(I-1)*2*PI/N) -C -C -2.*R(2*K-1)*SIN((K-1)*(I-1)*2*PI/N) -C -C Note: This transform is unnormalized since a call of RFFTF -C followed by a call of RFFTB will multiply the input -C sequence by N. -C -C WSAVE contains results which must not be destroyed between -C calls of RFFTB or RFFTF. -C -C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel -C Computations (G. Rodrigue, ed.), Academic Press, -C 1982, pp. 51-83. -C***ROUTINES CALLED RFFTB1 -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C changing dummy array size declarations (1) to (*). -C 861211 REVISION DATE from Version 3.2 -C 881128 Modified by Dick Valent to meet prologue standards. -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900131 Routine changed from user-callable to subsidiary -C because of non-standard Fortran 77 arguments in the -C call to CFFTB1. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE RFFTB - DIMENSION R(*), WSAVE(*) -C***FIRST EXECUTABLE STATEMENT RFFTB - IF (N .EQ. 1) RETURN - CALL RFFTB1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1)) - RETURN - END diff --git a/slatec/rfftb1.f b/slatec/rfftb1.f deleted file mode 100644 index c91fad7..0000000 --- a/slatec/rfftb1.f +++ /dev/null @@ -1,143 +0,0 @@ -*DECK RFFTB1 - SUBROUTINE RFFTB1 (N, C, CH, WA, IFAC) -C***BEGIN PROLOGUE RFFTB1 -C***PURPOSE Compute the backward fast Fourier transform of a real -C coefficient array. -C***LIBRARY SLATEC (FFTPACK) -C***CATEGORY J1A1 -C***TYPE SINGLE PRECISION (RFFTB1-S, CFFTB1-C) -C***KEYWORDS FFTPACK, FOURIER TRANSFORM -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C Subroutine RFFTB1 computes the real periodic sequence from its -C Fourier coefficients (Fourier synthesis). The transform is defined -C below at output parameter C. -C -C The arrays WA and IFAC which are used by subroutine RFFTB1 must be -C initialized by calling subroutine RFFTI1. -C -C Input Arguments -C -C N the length of the array R to be transformed. The method -C is most efficient when N is a product of small primes. -C N may change so long as different work arrays are provided. -C -C C a real array of length N which contains the sequence -C to be transformed. -C -C CH a real work array of length at least N. -C -C WA a real work array which must be dimensioned at least N. -C -C IFAC an integer work array which must be dimensioned at least 15. -C -C The WA and IFAC arrays must be initialized by calling -C subroutine RFFTI1, and different WA and IFAC arrays must be -C used for each different value of N. This initialization -C does not have to be repeated so long as N remains unchanged. -C Thus subsequent transforms can be obtained faster than the -C first. The same WA and IFAC arrays can be used by RFFTF1 -C and RFFTB1. -C -C Output Argument -C -C C For N even and for I = 1,...,N -C -C C(I) = C(1)+(-1)**(I-1)*C(N) -C -C plus the sum from K=2 to K=N/2 of -C -C 2.*C(2*K-2)*COS((K-1)*(I-1)*2*PI/N) -C -C -2.*C(2*K-1)*SIN((K-1)*(I-1)*2*PI/N) -C -C For N odd and for I = 1,...,N -C -C C(I) = C(1) plus the sum from K=2 to K=(N+1)/2 of -C -C 2.*C(2*K-2)*COS((K-1)*(I-1)*2*PI/N) -C -C -2.*C(2*K-1)*SIN((K-1)*(I-1)*2*PI/N) -C -C Notes: This transform is unnormalized since a call of RFFTF1 -C followed by a call of RFFTB1 will multiply the input -C sequence by N. -C -C WA and IFAC contain initialization calculations which must -C not be destroyed between calls of subroutine RFFTF1 or -C RFFTB1. -C -C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel -C Computations (G. Rodrigue, ed.), Academic Press, -C 1982, pp. 51-83. -C***ROUTINES CALLED RADB2, RADB3, RADB4, RADB5, RADBG -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C changing dummy array size declarations (1) to (*). -C 881128 Modified by Dick Valent to meet prologue standards. -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900131 Routine changed from subsidiary to user-callable. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE RFFTB1 - DIMENSION CH(*), C(*), WA(*), IFAC(*) -C***FIRST EXECUTABLE STATEMENT RFFTB1 - NF = IFAC(2) - NA = 0 - L1 = 1 - IW = 1 - DO 116 K1=1,NF - IP = IFAC(K1+2) - L2 = IP*L1 - IDO = N/L2 - IDL1 = IDO*L1 - IF (IP .NE. 4) GO TO 103 - IX2 = IW+IDO - IX3 = IX2+IDO - IF (NA .NE. 0) GO TO 101 - CALL RADB4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) - GO TO 102 - 101 CALL RADB4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) - 102 NA = 1-NA - GO TO 115 - 103 IF (IP .NE. 2) GO TO 106 - IF (NA .NE. 0) GO TO 104 - CALL RADB2 (IDO,L1,C,CH,WA(IW)) - GO TO 105 - 104 CALL RADB2 (IDO,L1,CH,C,WA(IW)) - 105 NA = 1-NA - GO TO 115 - 106 IF (IP .NE. 3) GO TO 109 - IX2 = IW+IDO - IF (NA .NE. 0) GO TO 107 - CALL RADB3 (IDO,L1,C,CH,WA(IW),WA(IX2)) - GO TO 108 - 107 CALL RADB3 (IDO,L1,CH,C,WA(IW),WA(IX2)) - 108 NA = 1-NA - GO TO 115 - 109 IF (IP .NE. 5) GO TO 112 - IX2 = IW+IDO - IX3 = IX2+IDO - IX4 = IX3+IDO - IF (NA .NE. 0) GO TO 110 - CALL RADB5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - GO TO 111 - 110 CALL RADB5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - 111 NA = 1-NA - GO TO 115 - 112 IF (NA .NE. 0) GO TO 113 - CALL RADBG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) - GO TO 114 - 113 CALL RADBG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) - 114 IF (IDO .EQ. 1) NA = 1-NA - 115 L1 = L2 - IW = IW+(IP-1)*IDO - 116 CONTINUE - IF (NA .EQ. 0) RETURN - DO 117 I=1,N - C(I) = CH(I) - 117 CONTINUE - RETURN - END diff --git a/slatec/rfftf.f b/slatec/rfftf.f deleted file mode 100644 index 454c2b1..0000000 --- a/slatec/rfftf.f +++ /dev/null @@ -1,97 +0,0 @@ -*DECK RFFTF - SUBROUTINE RFFTF (N, R, WSAVE) -C***BEGIN PROLOGUE RFFTF -C***SUBSIDIARY -C***PURPOSE Compute the forward transform of a real, periodic sequence. -C***LIBRARY SLATEC (FFTPACK) -C***CATEGORY J1A1 -C***TYPE SINGLE PRECISION (RFFTF-S, CFFTF-C) -C***KEYWORDS FFTPACK, FOURIER TRANSFORM -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C ******************************************************************** -C * NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE * -C ******************************************************************** -C * * -C * This routine uses non-standard Fortran 77 constructs and will * -C * be removed from the library at a future date. You are * -C * requested to use RFFTF1. * -C * * -C ******************************************************************** -C -C Subroutine RFFTF computes the Fourier coefficients of a real -C periodic sequence (Fourier analysis). The transform is defined -C below at output parameter R. -C -C Input Arguments -C -C N the length of the array R to be transformed. The method -C is most efficient when N is a product of small primes. -C N may change so long as different work arrays are provided. -C -C R a real array of length N which contains the sequence -C to be transformed. -C -C WSAVE a work array which must be dimensioned at least 2*N+15 -C in the program that calls RFFTF. The WSAVE array must be -C initialized by calling subroutine RFFTI, and a different -C WSAVE array must be used for each different value of N. -C This initialization does not have to be repeated so long as -C remains unchanged. Thus subsequent transforms can be -C obtained faster than the first. Moreover, the same WSAVE -C array can be used by RFFTF and RFFTB as long as N remains -C unchanged. -C -C Output Argument -C -C R R(1) = the sum from I=1 to I=N of R(I) -C -C If N is even set L = N/2; if N is odd set L = (N+1)/2 -C -C then for K = 2,...,L -C -C R(2*K-2) = the sum from I = 1 to I = N of -C -C R(I)*COS((K-1)*(I-1)*2*PI/N) -C -C R(2*K-1) = the sum from I = 1 to I = N of -C -C -R(I)*SIN((K-1)*(I-1)*2*PI/N) -C -C If N is even -C -C R(N) = the sum from I = 1 to I = N of -C -C (-1)**(I-1)*R(I) -C -C Note: This transform is unnormalized since a call of RFFTF -C followed by a call of RFFTB will multiply the input -C sequence by N. -C -C WSAVE contains results which must not be destroyed between -C calls of RFFTF or RFFTB. -C -C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel -C Computations (G. Rodrigue, ed.), Academic Press, -C 1982, pp. 51-83. -C***ROUTINES CALLED RFFTF1 -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C changing dummy array size declarations (1) to (*). -C 861211 REVISION DATE from Version 3.2 -C 881128 Modified by Dick Valent to meet prologue standards. -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900131 Routine changed from user-callable to subsidiary -C because of non-standard Fortran 77 arguments in the -C call to CFFTB1. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE RFFTF - DIMENSION R(*), WSAVE(*) -C***FIRST EXECUTABLE STATEMENT RFFTF - IF (N .EQ. 1) RETURN - CALL RFFTF1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1)) - RETURN - END diff --git a/slatec/rfftf1.f b/slatec/rfftf1.f deleted file mode 100644 index e0e1910..0000000 --- a/slatec/rfftf1.f +++ /dev/null @@ -1,144 +0,0 @@ -*DECK RFFTF1 - SUBROUTINE RFFTF1 (N, C, CH, WA, IFAC) -C***BEGIN PROLOGUE RFFTF1 -C***PURPOSE Compute the forward transform of a real, periodic sequence. -C***LIBRARY SLATEC (FFTPACK) -C***CATEGORY J1A1 -C***TYPE SINGLE PRECISION (RFFTF1-S, CFFTF1-C) -C***KEYWORDS FFTPACK, FOURIER TRANSFORM -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C Subroutine RFFTF1 computes the Fourier coefficients of a real -C periodic sequence (Fourier analysis). The transform is defined -C below at output parameter C. -C -C The arrays WA and IFAC which are used by subroutine RFFTB1 must be -C initialized by calling subroutine RFFTI1. -C -C Input Arguments -C -C N the length of the array R to be transformed. The method -C is most efficient when N is a product of small primes. -C N may change so long as different work arrays are provided. -C -C C a real array of length N which contains the sequence -C to be transformed. -C -C CH a real work array of length at least N. -C -C WA a real work array which must be dimensioned at least N. -C -C IFAC an integer work array which must be dimensioned at least 15. -C -C The WA and IFAC arrays must be initialized by calling -C subroutine RFFTI1, and different WA and IFAC arrays must be -C used for each different value of N. This initialization -C does not have to be repeated so long as N remains unchanged. -C Thus subsequent transforms can be obtained faster than the -C first. The same WA and IFAC arrays can be used by RFFTF1 -C and RFFTB1. -C -C Output Argument -C -C C C(1) = the sum from I=1 to I=N of R(I) -C -C If N is even set L = N/2; if N is odd set L = (N+1)/2 -C -C then for K = 2,...,L -C -C C(2*K-2) = the sum from I = 1 to I = N of -C -C C(I)*COS((K-1)*(I-1)*2*PI/N) -C -C C(2*K-1) = the sum from I = 1 to I = N of -C -C -C(I)*SIN((K-1)*(I-1)*2*PI/N) -C -C If N is even -C -C C(N) = the sum from I = 1 to I = N of -C -C (-1)**(I-1)*C(I) -C -C Notes: This transform is unnormalized since a call of RFFTF1 -C followed by a call of RFFTB1 will multiply the input -C sequence by N. -C -C WA and IFAC contain initialization calculations which must -C not be destroyed between calls of subroutine RFFTF1 or -C RFFTB1. -C -C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel -C Computations (G. Rodrigue, ed.), Academic Press, -C 1982, pp. 51-83. -C***ROUTINES CALLED RADF2, RADF3, RADF4, RADF5, RADFG -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C changing dummy array size declarations (1) to (*). -C 881128 Modified by Dick Valent to meet prologue standards. -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900131 Routine changed from subsidiary to user-callable. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE RFFTF1 - DIMENSION CH(*), C(*), WA(*), IFAC(*) -C***FIRST EXECUTABLE STATEMENT RFFTF1 - NF = IFAC(2) - NA = 1 - L2 = N - IW = N - DO 111 K1=1,NF - KH = NF-K1 - IP = IFAC(KH+3) - L1 = L2/IP - IDO = N/L2 - IDL1 = IDO*L1 - IW = IW-(IP-1)*IDO - NA = 1-NA - IF (IP .NE. 4) GO TO 102 - IX2 = IW+IDO - IX3 = IX2+IDO - IF (NA .NE. 0) GO TO 101 - CALL RADF4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) - GO TO 110 - 101 CALL RADF4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) - GO TO 110 - 102 IF (IP .NE. 2) GO TO 104 - IF (NA .NE. 0) GO TO 103 - CALL RADF2 (IDO,L1,C,CH,WA(IW)) - GO TO 110 - 103 CALL RADF2 (IDO,L1,CH,C,WA(IW)) - GO TO 110 - 104 IF (IP .NE. 3) GO TO 106 - IX2 = IW+IDO - IF (NA .NE. 0) GO TO 105 - CALL RADF3 (IDO,L1,C,CH,WA(IW),WA(IX2)) - GO TO 110 - 105 CALL RADF3 (IDO,L1,CH,C,WA(IW),WA(IX2)) - GO TO 110 - 106 IF (IP .NE. 5) GO TO 108 - IX2 = IW+IDO - IX3 = IX2+IDO - IX4 = IX3+IDO - IF (NA .NE. 0) GO TO 107 - CALL RADF5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - GO TO 110 - 107 CALL RADF5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - GO TO 110 - 108 IF (IDO .EQ. 1) NA = 1-NA - IF (NA .NE. 0) GO TO 109 - CALL RADFG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) - NA = 1 - GO TO 110 - 109 CALL RADFG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) - NA = 0 - 110 L2 = L1 - 111 CONTINUE - IF (NA .EQ. 1) RETURN - DO 112 I=1,N - C(I) = CH(I) - 112 CONTINUE - RETURN - END diff --git a/slatec/rffti.f b/slatec/rffti.f deleted file mode 100644 index 01e1e32..0000000 --- a/slatec/rffti.f +++ /dev/null @@ -1,62 +0,0 @@ -*DECK RFFTI - SUBROUTINE RFFTI (N, WSAVE) -C***BEGIN PROLOGUE RFFTI -C***SUBSIDIARY -C***PURPOSE Initialize a work array for RFFTF and RFFTB. -C***LIBRARY SLATEC (FFTPACK) -C***CATEGORY J1A1 -C***TYPE SINGLE PRECISION (RFFTI-S, CFFTI-C) -C***KEYWORDS FFTPACK, FOURIER TRANSFORM -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C ******************************************************************** -C * NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE * -C ******************************************************************** -C * * -C * This routine uses non-standard Fortran 77 constructs and will * -C * be removed from the library at a future date. You are * -C * requested to use RFFTI1. * -C * * -C ******************************************************************** -C -C Subroutine RFFTI initializes the array WSAVE which is used in -C both RFFTF and RFFTB. The prime factorization of N together with -C a tabulation of the trigonometric functions are computed and -C stored in WSAVE. -C -C Input Argument -C -C N the length of the sequence to be transformed. -C -C Output Argument -C -C WSAVE a work array which must be dimensioned at least 2*N+15. -C The same work array can be used for both RFFTF and RFFTB -C as long as N remains unchanged. Different WSAVE arrays -C are required for different values of N. The contents of -C WSAVE must not be changed between calls of RFFTF or RFFTB. -C -C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel -C Computations (G. Rodrigue, ed.), Academic Press, -C 1982, pp. 51-83. -C***ROUTINES CALLED RFFTI1 -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C changing dummy array size declarations (1) to (*). -C 861211 REVISION DATE from Version 3.2 -C 881128 Modified by Dick Valent to meet prologue standards. -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900131 Routine changed from user-callable to subsidiary -C because of non-standard Fortran 77 arguments in the -C call to CFFTB1. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE RFFTI - DIMENSION WSAVE(*) -C***FIRST EXECUTABLE STATEMENT RFFTI - IF (N .EQ. 1) RETURN - CALL RFFTI1 (N,WSAVE(N+1),WSAVE(2*N+1)) - RETURN - END diff --git a/slatec/rffti1.f b/slatec/rffti1.f deleted file mode 100644 index 8b82fba..0000000 --- a/slatec/rffti1.f +++ /dev/null @@ -1,110 +0,0 @@ -*DECK RFFTI1 - SUBROUTINE RFFTI1 (N, WA, IFAC) -C***BEGIN PROLOGUE RFFTI1 -C***PURPOSE Initialize a real and an integer work array for RFFTF1 and -C RFFTB1. -C***LIBRARY SLATEC (FFTPACK) -C***CATEGORY J1A1 -C***TYPE SINGLE PRECISION (RFFTI1-S, CFFTI1-C) -C***KEYWORDS FFTPACK, FOURIER TRANSFORM -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C Subroutine RFFTI1 initializes the work arrays WA and IFAC which are -C used in both RFFTF1 and RFFTB1. The prime factorization of N and a -C tabulation of the trigonometric functions are computed and stored in -C IFAC and WA, respectively. -C -C Input Argument -C -C N the length of the sequence to be transformed. -C -C Output Arguments -C -C WA a real work array which must be dimensioned at least N. -C -C IFAC an integer work array which must be dimensioned at least 15. -C -C The same work arrays can be used for both RFFTF1 and RFFTB1 as long -C as N remains unchanged. Different WA and IFAC arrays are required -C for different values of N. The contents of WA and IFAC must not be -C changed between calls of RFFTF1 or RFFTB1. -C -C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel -C Computations (G. Rodrigue, ed.), Academic Press, -C 1982, pp. 51-83. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C (a) changing dummy array size declarations (1) to (*), -C (b) changing references to intrinsic function FLOAT -C to REAL, and -C (c) changing definition of variable TPI by using -C FORTRAN intrinsic functions instead of DATA -C statements. -C 881128 Modified by Dick Valent to meet prologue standards. -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900131 Routine changed from subsidiary to user-callable. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE RFFTI1 - DIMENSION WA(*), IFAC(*), NTRYH(4) - SAVE NTRYH - DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ -C***FIRST EXECUTABLE STATEMENT RFFTI1 - NL = N - NF = 0 - J = 0 - 101 J = J+1 - IF (J-4) 102,102,103 - 102 NTRY = NTRYH(J) - GO TO 104 - 103 NTRY = NTRY+2 - 104 NQ = NL/NTRY - NR = NL-NTRY*NQ - IF (NR) 101,105,101 - 105 NF = NF+1 - IFAC(NF+2) = NTRY - NL = NQ - IF (NTRY .NE. 2) GO TO 107 - IF (NF .EQ. 1) GO TO 107 - DO 106 I=2,NF - IB = NF-I+2 - IFAC(IB+2) = IFAC(IB+1) - 106 CONTINUE - IFAC(3) = 2 - 107 IF (NL .NE. 1) GO TO 104 - IFAC(1) = N - IFAC(2) = NF - TPI = 8.*ATAN(1.) - ARGH = TPI/N - IS = 0 - NFM1 = NF-1 - L1 = 1 - IF (NFM1 .EQ. 0) RETURN - DO 110 K1=1,NFM1 - IP = IFAC(K1+2) - LD = 0 - L2 = L1*IP - IDO = N/L2 - IPM = IP-1 - DO 109 J=1,IPM - LD = LD+L1 - I = IS - ARGLD = LD*ARGH - FI = 0. - DO 108 II=3,IDO,2 - I = I+2 - FI = FI+1. - ARG = FI*ARGLD - WA(I-1) = COS(ARG) - WA(I) = SIN(ARG) - 108 CONTINUE - IS = IS+IDO - 109 CONTINUE - L1 = L2 - 110 CONTINUE - RETURN - END diff --git a/slatec/rg.f b/slatec/rg.f deleted file mode 100644 index b9cf9a9..0000000 --- a/slatec/rg.f +++ /dev/null @@ -1,106 +0,0 @@ -*DECK RG - SUBROUTINE RG (NM, N, A, WR, WI, MATZ, Z, IV1, FV1, IERR) -C***BEGIN PROLOGUE RG -C***PURPOSE Compute the eigenvalues and, optionally, the eigenvectors -C of a real general matrix. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4A2 -C***TYPE SINGLE PRECISION (RG-S, CG-C) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine calls the recommended sequence of -C subroutines from the eigensystem subroutine package (EISPACK) -C To find the eigenvalues and eigenvectors (if desired) -C of a REAL GENERAL matrix. -C -C On Input -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, A and Z, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix A. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C A contains the real general matrix. A is a two-dimensional -C REAL array, dimensioned A(NM,N). -C -C MATZ is an INTEGER variable set equal to zero if only -C eigenvalues are desired. Otherwise, it is set to any -C non-zero integer for both eigenvalues and eigenvectors. -C -C On Output -C -C A has been destroyed. -C -C WR and WI contain the real and imaginary parts, respectively, -C of the eigenvalues. The eigenvalues are unordered except -C that complex conjugate pairs of eigenvalues appear consecu- -C tively with the eigenvalue having the positive imaginary part -C first. If an error exit is made, the eigenvalues should be -C correct for indices IERR+1, IERR+2, ..., N. WR and WI are -C one-dimensional REAL arrays, dimensioned WR(N) and WI(N). -C -C Z contains the real and imaginary parts of the eigenvectors -C if MATZ is not zero. If the J-th eigenvalue is real, the -C J-th column of Z contains its eigenvector. If the J-th -C eigenvalue is complex with positive imaginary part, the -C J-th and (J+1)-th columns of Z contain the real and -C imaginary parts of its eigenvector. The conjugate of this -C vector is the eigenvector for the conjugate eigenvalue. -C Z is a two-dimensional REAL array, dimensioned Z(NM,N). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C 10*N if N is greater than NM, -C J if the J-th eigenvalue has not been -C determined after a total of 30 iterations. -C The eigenvalues should be correct for indices -C IERR+1, IERR+2, ..., N, but no eigenvectors are -C computed. -C -C IV1 and FV1 are one-dimensional temporary storage arrays of -C dimension N. IV1 is of type INTEGER and FV1 of type REAL. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED BALANC, BALBAK, ELMHES, ELTRAN, HQR, HQR2 -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C 921103 Corrected description of IV1. (DWL, FNF and WRB) -C***END PROLOGUE RG -C - INTEGER N,NM,IS1,IS2,IERR,MATZ - REAL A(NM,*),WR(*),WI(*),Z(NM,*),FV1(*) - INTEGER IV1(*) -C -C***FIRST EXECUTABLE STATEMENT RG - IF (N .LE. NM) GO TO 10 - IERR = 10 * N - GO TO 50 -C - 10 CALL BALANC(NM,N,A,IS1,IS2,FV1) - CALL ELMHES(NM,N,IS1,IS2,A,IV1) - IF (MATZ .NE. 0) GO TO 20 -C .......... FIND EIGENVALUES ONLY .......... - CALL HQR(NM,N,IS1,IS2,A,WR,WI,IERR) - GO TO 50 -C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... - 20 CALL ELTRAN(NM,N,IS1,IS2,A,IV1,Z) - CALL HQR2(NM,N,IS1,IS2,A,WR,WI,Z,IERR) - IF (IERR .NE. 0) GO TO 50 - CALL BALBAK(NM,N,IS1,IS2,FV1,N,Z) - 50 RETURN - END diff --git a/slatec/rgauss.f b/slatec/rgauss.f deleted file mode 100644 index 5da63f5..0000000 --- a/slatec/rgauss.f +++ /dev/null @@ -1,43 +0,0 @@ -*DECK RGAUSS - FUNCTION RGAUSS (XMEAN, SD) -C***BEGIN PROLOGUE RGAUSS -C***PURPOSE Generate a normally distributed (Gaussian) random number. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY L6A14 -C***TYPE SINGLE PRECISION (RGAUSS-S) -C***KEYWORDS FNLIB, GAUSSIAN, NORMAL, RANDOM NUMBER, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Generate a normally distributed random number, i.e., generate random -C numbers with a Gaussian distribution. These random numbers are not -C exceptionally good -- especially in the tails of the distribution, -C but this implementation is simple and suitable for most applications. -C See R. W. Hamming, Numerical Methods for Scientists and Engineers, -C McGraw-Hill, 1962, pages 34 and 389. -C -C Input Arguments -- -C XMEAN the mean of the Guassian distribution. -C SD the standard deviation of the Guassian function -C EXP (-1/2 * (X-XMEAN)**2 / SD**2) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED RAND -C***REVISION HISTORY (YYMMDD) -C 770401 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 910819 Added EXTERNAL statement for RAND due to problem on IBM -C RS 6000. (WRB) -C***END PROLOGUE RGAUSS - EXTERNAL RAND -C***FIRST EXECUTABLE STATEMENT RGAUSS - RGAUSS = -6.0 - DO 10 I=1,12 - RGAUSS = RGAUSS + RAND(0.0) - 10 CONTINUE -C - RGAUSS = XMEAN + SD*RGAUSS -C - RETURN - END diff --git a/slatec/rgg.f b/slatec/rgg.f deleted file mode 100644 index 5e798d2..0000000 --- a/slatec/rgg.f +++ /dev/null @@ -1,111 +0,0 @@ -*DECK RGG - SUBROUTINE RGG (NM, N, A, B, ALFR, ALFI, BETA, MATZ, Z, IERR) -C***BEGIN PROLOGUE RGG -C***PURPOSE Compute the eigenvalues and eigenvectors for a real -C generalized eigenproblem. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4B2 -C***TYPE SINGLE PRECISION (RGG-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine calls the recommended sequence of -C subroutines from the eigensystem subroutine package (EISPACK) -C to find the eigenvalues and eigenvectors (if desired) -C for the REAL GENERAL GENERALIZED eigenproblem Ax = (LAMBDA)Bx. -C -C On Input -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, A, B, and Z, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrices A and B. N is an INTEGER -C variable. N must be less than or equal to NM. -C -C A contains a real general matrix. A is a two-dimensional -C REAL array, dimensioned A(NM,N). -C -C B contains a real general matrix. B is a two-dimensional -C REAL array, dimensioned B(NM,N). -C -C MATZ is an INTEGER variable set equal to zero if only -C eigenvalues are desired. Otherwise, it is set to any -C non-zero integer for both eigenvalues and eigenvectors. -C -C On Output -C -C A and B have been destroyed. -C -C ALFR and ALFI contain the real and imaginary parts, -C respectively, of the numerators of the eigenvalues. -C ALFR and ALFI are one-dimensional REAL arrays, -C dimensioned ALFR(N) and ALFI(N). -C -C BETA contains the denominators of the eigenvalues, -C which are thus given by the ratios (ALFR+I*ALFI)/BETA. -C Complex conjugate pairs of eigenvalues appear consecutively -C with the eigenvalue having the positive imaginary part first. -C BETA is a one-dimensional REAL array, dimensioned BETA(N). -C -C Z contains the real and imaginary parts of the eigenvectors -C if MATZ is not zero. If the J-th eigenvalue is real, the -C J-th column of Z contains its eigenvector. If the J-th -C eigenvalue is complex with positive imaginary part, the -C J-th and (J+1)-th columns of Z contain the real and -C imaginary parts of its eigenvector. The conjugate of this -C vector is the eigenvector for the conjugate eigenvalue. -C Z is a two-dimensional REAL array, dimensioned Z(NM,N). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C 10*N if N is greater than NM, -C J if the J-th eigenvalue has not been -C determined after a total of 30*N iterations. -C The eigenvalues should be correct for indices -C IERR+1, IERR+2, ..., N, but no eigenvectors are -C computed. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED QZHES, QZIT, QZVAL, QZVEC -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE RGG -C - INTEGER N,NM,IERR,MATZ - REAL A(NM,*),B(NM,*),ALFR(*),ALFI(*),BETA(*),Z(NM,*) - LOGICAL TF -C -C***FIRST EXECUTABLE STATEMENT RGG - IF (N .LE. NM) GO TO 10 - IERR = 10 * N - GO TO 50 -C - 10 IF (MATZ .NE. 0) GO TO 20 -C .......... FIND EIGENVALUES ONLY .......... - TF = .FALSE. - CALL QZHES(NM,N,A,B,TF,Z) - CALL QZIT(NM,N,A,B,0.0E0,TF,Z,IERR) - CALL QZVAL(NM,N,A,B,ALFR,ALFI,BETA,TF,Z) - GO TO 50 -C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... - 20 TF = .TRUE. - CALL QZHES(NM,N,A,B,TF,Z) - CALL QZIT(NM,N,A,B,0.0E0,TF,Z,IERR) - CALL QZVAL(NM,N,A,B,ALFR,ALFI,BETA,TF,Z) - IF (IERR .NE. 0) GO TO 50 - CALL QZVEC(NM,N,A,B,ALFR,ALFI,BETA,Z) - 50 RETURN - END diff --git a/slatec/rj.f b/slatec/rj.f deleted file mode 100644 index 9359122..0000000 --- a/slatec/rj.f +++ /dev/null @@ -1,409 +0,0 @@ -*DECK RJ - REAL FUNCTION RJ (X, Y, Z, P, IER) -C***BEGIN PROLOGUE RJ -C***PURPOSE Compute the incomplete or complete (X or Y or Z is zero) -C elliptic integral of the 3rd kind. For X, Y, and Z non- -C negative, at most one of them zero, and P positive, -C RJ(X,Y,Z,P) = Integral from zero to infinity of -C -1/2 -1/2 -1/2 -1 -C (3/2)(t+X) (t+Y) (t+Z) (t+P) dt. -C***LIBRARY SLATEC -C***CATEGORY C14 -C***TYPE SINGLE PRECISION (RJ-S, DRJ-D) -C***KEYWORDS COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM, -C INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE THIRD KIND, -C TAYLOR SERIES -C***AUTHOR Carlson, B. C. -C Ames Laboratory-DOE -C Iowa State University -C Ames, IA 50011 -C Notis, E. M. -C Ames Laboratory-DOE -C Iowa State University -C Ames, IA 50011 -C Pexton, R. L. -C Lawrence Livermore National Laboratory -C Livermore, CA 94550 -C***DESCRIPTION -C -C 1. RJ -C Standard FORTRAN function routine -C Single precision version -C The routine calculates an approximation result to -C RJ(X,Y,Z,P) = Integral from zero to infinity of -C -C -1/2 -1/2 -1/2 -1 -C (3/2)(t+X) (t+Y) (t+Z) (t+P) dt, -C -C where X, Y, and Z are nonnegative, at most one of them is -C zero, and P is positive. If X or Y or Z is zero, the -C integral is COMPLETE. The duplication theorem is iterated -C until the variables are nearly equal, and the function is -C then expanded in Taylor series to fifth order. -C -C -C 2. Calling Sequence -C RJ( X, Y, Z, P, IER ) -C -C Parameters On Entry -C Values assigned by the calling routine -C -C X - Single precision, nonnegative variable -C -C Y - Single precision, nonnegative variable -C -C Z - Single precision, nonnegative variable -C -C P - Single precision, positive variable -C -C -C On Return (values assigned by the RJ routine) -C -C RJ - Single precision approximation to the integral -C -C IER - Integer -C -C IER = 0 Normal and reliable termination of the -C routine. It is assumed that the requested -C accuracy has been achieved. -C -C IER > 0 Abnormal termination of the routine -C -C -C X, Y, Z, P are unaltered. -C -C -C 3. Error Messages -C -C Value of IER assigned by the RJ routine -C -C Value Assigned Error Message Printed -C IER = 1 MIN(X,Y,Z) .LT. 0.0E0 -C = 2 MIN(X+Y,X+Z,Y+Z,P) .LT. LOLIM -C = 3 MAX(X,Y,Z,P) .GT. UPLIM -C -C -C -C 4. Control Parameters -C -C Values of LOLIM, UPLIM, and ERRTOL are set by the -C routine. -C -C -C LOLIM and UPLIM determine the valid range of X Y, Z, and P -C -C LOLIM is not less than the cube root of the value -C of LOLIM used in the routine for RC. -C -C UPLIM is not greater than 0.3 times the cube root of -C the value of UPLIM used in the routine for RC. -C -C -C Acceptable Values For: LOLIM UPLIM -C IBM 360/370 SERIES : 2.0E-26 3.0E+24 -C CDC 6000/7000 SERIES : 5.0E-98 3.0E+106 -C UNIVAC 1100 SERIES : 5.0E-13 6.0E+11 -C CRAY : 1.32E-822 1.4E+821 -C VAX 11 SERIES : 2.5E-13 9.0E+11 -C -C -C -C ERRTOL determines the accuracy of the answer -C -C The value assigned by the routine will result -C in solution precision within 1-2 decimals of -C "machine precision". -C -C -C -C -C Relative error due to truncation of the series for RJ -C is less than 3 * ERRTOL ** 6 / (1 - ERRTOL) ** 3/2. -C -C -C -C The accuracy of the computed approximation to the inte- -C gral can be controlled by choosing the value of ERRTOL. -C Truncation of a Taylor series after terms of fifth order -C Introduces an error less than the amount shown in the -C second column of the following table for each value of -C ERRTOL in the first column. In addition to the trunca- -C tion error there will be round-off error, but in prac- -C tice the total error from both sources is usually less -C than the amount given in the table. -C -C -C -C Sample choices: ERRTOL Relative Truncation -C error less than -C 1.0E-3 4.0E-18 -C 3.0E-3 3.0E-15 -C 1.0E-2 4.0E-12 -C 3.0E-2 3.0E-9 -C 1.0E-1 4.0E-6 -C -C Decreasing ERRTOL by a factor of 10 yields six more -C decimal digits of accuracy at the expense of one or -C two more iterations of the duplication theorem. -C -C *Long Description: -C -C RJ Special Comments -C -C -C Check by addition theorem: RJ(X,X+Z,X+W,X+P) -C + RJ(Y,Y+Z,Y+W,Y+P) + (A-B) * RJ(A,B,B,A) + 3 / SQRT(A) -C = RJ(0,Z,W,P), where X,Y,Z,W,P are positive and X * Y -C = Z * W, A = P * P * (X+Y+Z+W), B = P * (P+X) * (P+Y), -C and B - A = P * (P-Z) * (P-W). The sum of the third and -C fourth terms on the left side is 3 * RC(A,B). -C -C -C On Input: -C -C X, Y, Z, and P are the variables in the integral RJ(X,Y,Z,P). -C -C -C On Output: -C -C -C X, Y, Z, and P are unaltered. -C -C ******************************************************** -C -C Warning: Changes in the program may improve speed at the -C expense of robustness. -C -C ------------------------------------------------------------ -C -C -C Special Functions via RJ and RF -C -C -C Legendre form of ELLIPTIC INTEGRAL of 3rd kind -C ---------------------------------------------- -C -C -C PHI 2 -1 -C P(PHI,K,N) = INT (1+N SIN (THETA) ) * -C 0 -C -C 2 2 -1/2 -C *(1-K SIN (THETA) ) D THETA -C -C -C 2 2 2 -C = SIN (PHI) RF(COS (PHI), 1-K SIN (PHI),1) -C -C 3 2 2 2 -C -(N/3) SIN (PHI) RJ(COS (PHI),1-K SIN (PHI), -C -C 2 -C 1,1+N SIN (PHI)) -C -C -C -C Bulirsch form of ELLIPTIC INTEGRAL of 3rd kind -C ---------------------------------------------- -C -C -C 2 2 2 -C EL3(X,KC,P) = X RF(1,1+KC X ,1+X ) + -C -C 3 2 2 2 2 -C +(1/3)(1-P) X RJ(1,1+KC X ,1+X ,1+PX ) -C -C -C 2 -C CEL(KC,P,A,B) = A RF(0,KC ,1) + -C -C 2 -C +(1/3)(B-PA) RJ(0,KC ,1,P) -C -C -C -C -C Heuman's LAMBDA function -C ------------------------ -C -C -C 2 2 2 1/2 -C L(A,B,P) = (COS(A)SIN(B)COS(B)/(1-COS (A)SIN (B)) ) -C -C 2 2 2 -C *(SIN(P) RF(COS (P),1-SIN (A) SIN (P),1) -C -C 2 3 2 2 -C +(SIN (A) SIN (P)/(3(1-COS (A) SIN (B)))) -C -C 2 2 2 -C *RJ(COS (P),1-SIN (A) SIN (P),1,1- -C -C 2 2 2 2 -C -SIN (A) SIN (P)/(1-COS (A) SIN (B)))) -C -C -C -C -C (PI/2) LAMBDA0(A,B) =L(A,B,PI/2) = -C -C -C 2 2 2 -1/2 -C = COS (A) SIN(B) COS(B) (1-COS (A) SIN (B)) -C -C 2 2 2 -C *RF(0,COS (A),1) + (1/3) SIN (A) COS (A) -C -C 2 2 -3/2 -C *SIN(B) COS(B) (1-COS (A) SIN (B)) -C -C 2 2 2 2 2 -C *RJ(0,COS (A),1,COS (A) COS (B)/(1-COS (A) SIN (B))) -C -C -C -C Jacobi ZETA function -C -------------------- -C -C -C 2 2 2 1/2 -C Z(B,K) = (K/3) SIN(B) COS(B) (1-K SIN (B)) -C -C -C 2 2 2 2 -C *RJ(0,1-K ,1,1-K SIN (B)) / RF (0,1-K ,1) -C -C -C ------------------------------------------------------------------- -C -C***REFERENCES B. C. Carlson and E. M. Notis, Algorithms for incomplete -C elliptic integrals, ACM Transactions on Mathematical -C Software 7, 3 (September 1981), pp. 398-403. -C B. C. Carlson, Computing elliptic integrals by -C duplication, Numerische Mathematik 33, (1979), -C pp. 1-16. -C B. C. Carlson, Elliptic integrals of the first kind, -C SIAM Journal of Mathematical Analysis 8, (1977), -C pp. 231-242. -C***ROUTINES CALLED R1MACH, RC, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891009 Removed unreferenced statement labels. (WRB) -C 891009 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900510 Changed calls to XERMSG to standard form, and some -C editorial changes. (RWC)). -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE RJ - CHARACTER*16 XERN3, XERN4, XERN5, XERN6, XERN7 - INTEGER IER - REAL ALFA, BETA, C1, C2, C3, C4, EA, EB, EC, E2, E3 - REAL LOLIM, UPLIM, EPSLON, ERRTOL - REAL LAMDA, MU, P, PN, PNDEV - REAL POWER4, RC, SIGMA, S1, S2, S3, X, XN, XNDEV - REAL XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV, - * ZNROOT - LOGICAL FIRST - SAVE ERRTOL,LOLIM,UPLIM,C1,C2,C3,C4,FIRST - DATA FIRST /.TRUE./ -C -C***FIRST EXECUTABLE STATEMENT RJ - IF (FIRST) THEN - ERRTOL = (R1MACH(3)/3.0E0)**(1.0E0/6.0E0) - LOLIM = (5.0E0 * R1MACH(1))**(1.0E0/3.0E0) - UPLIM = 0.30E0*( R1MACH(2) / 5.0E0)**(1.0E0/3.0E0) -C - C1 = 3.0E0/14.0E0 - C2 = 1.0E0/3.0E0 - C3 = 3.0E0/22.0E0 - C4 = 3.0E0/26.0E0 - ENDIF - FIRST = .FALSE. -C -C CALL ERROR HANDLER IF NECESSARY. -C - RJ = 0.0E0 - IF (MIN(X,Y,Z).LT.0.0E0) THEN - IER = 1 - WRITE (XERN3, '(1PE15.6)') X - WRITE (XERN4, '(1PE15.6)') Y - WRITE (XERN5, '(1PE15.6)') Z - CALL XERMSG ('SLATEC', 'RJ', - * 'MIN(X,Y,Z).LT.0 WHERE X = ' // XERN3 // ' Y = ' // XERN4 // - * ' AND Z = ' // XERN5, 1, 1) - RETURN - ENDIF -C - IF (MAX(X,Y,Z,P).GT.UPLIM) THEN - IER = 3 - WRITE (XERN3, '(1PE15.6)') X - WRITE (XERN4, '(1PE15.6)') Y - WRITE (XERN5, '(1PE15.6)') Z - WRITE (XERN6, '(1PE15.6)') P - WRITE (XERN7, '(1PE15.6)') UPLIM - CALL XERMSG ('SLATEC', 'RJ', - * 'MAX(X,Y,Z,P).GT.UPLIM WHERE X = ' // XERN3 // ' Y = ' // - * XERN4 // ' Z = ' // XERN5 // ' P = ' // XERN6 // - * ' AND UPLIM = ' // XERN7, 3, 1) - RETURN - ENDIF -C - IF (MIN(X+Y,X+Z,Y+Z,P).LT.LOLIM) THEN - IER = 2 - WRITE (XERN3, '(1PE15.6)') X - WRITE (XERN4, '(1PE15.6)') Y - WRITE (XERN5, '(1PE15.6)') Z - WRITE (XERN6, '(1PE15.6)') P - WRITE (XERN7, '(1PE15.6)') LOLIM - CALL XERMSG ('SLATEC', 'RJ', - * 'MIN(X+Y,X+Z,Y+Z,P).LT.LOLIM WHERE X = ' // XERN3 // - * ' Y = ' // XERN4 // ' Z = ' // XERN5 // ' P = ' // XERN6 // - * ' AND LOLIM = ', 2, 1) - RETURN - ENDIF -C - IER = 0 - XN = X - YN = Y - ZN = Z - PN = P - SIGMA = 0.0E0 - POWER4 = 1.0E0 -C - 30 MU = (XN+YN+ZN+PN+PN)*0.20E0 - XNDEV = (MU-XN)/MU - YNDEV = (MU-YN)/MU - ZNDEV = (MU-ZN)/MU - PNDEV = (MU-PN)/MU - EPSLON = MAX(ABS(XNDEV), ABS(YNDEV), ABS(ZNDEV), ABS(PNDEV)) - IF (EPSLON.LT.ERRTOL) GO TO 40 - XNROOT = SQRT(XN) - YNROOT = SQRT(YN) - ZNROOT = SQRT(ZN) - LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT - ALFA = PN*(XNROOT+YNROOT+ZNROOT) + XNROOT*YNROOT*ZNROOT - ALFA = ALFA*ALFA - BETA = PN*(PN+LAMDA)*(PN+LAMDA) - SIGMA = SIGMA + POWER4*RC(ALFA,BETA,IER) - POWER4 = POWER4*0.250E0 - XN = (XN+LAMDA)*0.250E0 - YN = (YN+LAMDA)*0.250E0 - ZN = (ZN+LAMDA)*0.250E0 - PN = (PN+LAMDA)*0.250E0 - GO TO 30 -C - 40 EA = XNDEV*(YNDEV+ZNDEV) + YNDEV*ZNDEV - EB = XNDEV*YNDEV*ZNDEV - EC = PNDEV*PNDEV - E2 = EA - 3.0E0*EC - E3 = EB + 2.0E0*PNDEV*(EA-EC) - S1 = 1.0E0 + E2*(-C1+0.750E0*C3*E2-1.50E0*C4*E3) - S2 = EB*(0.50E0*C2+PNDEV*(-C3-C3+PNDEV*C4)) - S3 = PNDEV*EA*(C2-PNDEV*C3) - C2*PNDEV*EC - RJ = 3.0E0*SIGMA + POWER4*(S1+S2+S3)/(MU* SQRT(MU)) - RETURN - END diff --git a/slatec/rkfab.f b/slatec/rkfab.f deleted file mode 100644 index 9ace53c..0000000 --- a/slatec/rkfab.f +++ /dev/null @@ -1,168 +0,0 @@ -*DECK RKFAB - SUBROUTINE RKFAB (NCOMP, XPTS, NXPTS, NFC, IFLAG, Z, MXNON, P, - + NTP, IP, YHP, NIV, U, V, W, S, STOWA, G, WORK, IWORK, NFCC) -C***BEGIN PROLOGUE RKFAB -C***SUBSIDIARY -C***PURPOSE Subsidiary to BVSUP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (RKFAB-S, DRKFAB-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C ********************************************************************** -C -C Subroutine RKFAB integrates the initial value equations using -C the variable-step RUNGE-KUTTA-FEHLBERG integration scheme or -C the variable-order ADAMS method and orthonormalization -C determined by a linear dependence test. -C -C ********************************************************************** -C -C***SEE ALSO BVSUP -C***ROUTINES CALLED BVDER, DEABM, DERKF, REORT, STOR1 -C***COMMON BLOCKS ML15TO, ML17BW, ML18JR, ML8SZ -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 890921 Realigned order of variables in certain COMMON blocks. -C (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE RKFAB -C - DIMENSION P(NTP,*),IP(NFCC,*),U(NCOMP,NFC,*), - 1 V(NCOMP,*),W(NFCC,*),Z(*),YHP(NCOMP,*), - 2 XPTS(*),S(*),STOWA(*),WORK(*),IWORK(*), - 3 G(*) -C -C ********************************************************************** -C - COMMON /ML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMPD,NFCD - COMMON /ML15TO/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP, - 1 KNSWOT,KOP,LOTJP,MNSWOT,NSWOT - COMMON /ML18JR/ AE,RE,TOL,NXPTSD,NIC,NOPG,MXNOND,NDISK,NTAPE,NEQ, - 1 INDPVT,INTEG,NPS,NTPD,NEQIVP,NUMORT,NFCCD, - 2 ICOCO - COMMON /ML17BW/ KKKZPW,NEEDW,NEEDIW,K1,K2,K3,K4,K5,K6,K7,K8,K9, - 1 K10,K11,L1,L2,KKKINT,LLLINT -C - EXTERNAL BVDER -C -C ********************************************************************** -C INITIALIZATION OF COUNTERS AND VARIABLES. -C -C***FIRST EXECUTABLE STATEMENT RKFAB - KOD = 1 - NON = 1 - X = XBEG - JON = 1 - INFO(1) = 0 - INFO(2) = 0 - INFO(3) = 1 - INFO(4) = 1 - WORK(1) = XEND - IF (NOPG .EQ. 0) GO TO 1 - INFO(3) = 0 - IF (X .EQ. Z(1)) JON = 2 - 1 NFCP1 = NFC + 1 -C -C ********************************************************************** -C *****BEGINNING OF INTEGRATION LOOP AT OUTPUT POINTS.****************** -C ********************************************************************** -C - DO 110 KOPP = 2,NXPTS - KOP=KOPP -C - 5 XOP = XPTS(KOP) - IF (NDISK .EQ. 0) KOD = KOP -C -C STEP BY STEP INTEGRATION LOOP BETWEEN OUTPUT POINTS. -C - 10 XXOP = XOP - IF (NOPG .EQ. 0) GO TO 15 - IF (XEND.GT.XBEG.AND.XOP.GT.Z(JON)) XXOP=Z(JON) - IF (XEND.LT.XBEG.AND.XOP.LT.Z(JON)) XXOP=Z(JON) -C -C ********************************************************************** - 15 GO TO (20,25),INTEG -C DERKF INTEGRATOR -C - 20 CALL DERKF(BVDER,NEQ,X,YHP,XXOP,INFO,RE,AE,IDID,WORK,KKKINT, - 1 IWORK,LLLINT,G,IPAR) - GO TO 28 -C DEABM INTEGRATOR -C - 25 CALL DEABM(BVDER,NEQ,X,YHP,XXOP,INFO,RE,AE,IDID,WORK,KKKINT, - 1 IWORK,LLLINT,G,IPAR) - 28 IF(IDID .GE. 1) GO TO 30 - INFO(1) = 1 - IF(IDID .EQ. -1) GO TO 15 - IFLAG = 20 - IDID - RETURN -C -C ********************************************************************** -C GRAM-SCHMIDT ORTHOGONALIZATION TEST FOR ORTHONORMALIZATION -C (TEMPORARILY USING U AND V IN THE TEST) -C - 30 IF (NOPG .EQ. 0) GO TO 35 - IF (XXOP .NE. Z(JON)) GO TO 100 - JFLAG=2 - GO TO 40 - 35 JFLAG=1 - IF (INHOMO .EQ. 3 .AND. X .EQ. XEND) JFLAG=3 -C - 40 IF (NDISK .EQ. 0) NON=NUMORT+1 - CALL REORT(NCOMP,U(1,1,KOD),V(1,KOD),YHP,NIV, - 1 W(1,NON),S,P(1,NON),IP(1,NON),STOWA,JFLAG) -C - IF (JFLAG .NE. 30) GO TO 45 - IFLAG=30 - RETURN -C - 45 IF (JFLAG .EQ. 10) GO TO 5 -C - IF (JFLAG .NE. 0) GO TO 100 -C -C ********************************************************************** -C STORE ORTHONORMALIZED VECTORS INTO SOLUTION VECTORS. -C - IF (NUMORT .LT. MXNON) GO TO 65 - IF (X .EQ. XEND) GO TO 65 - IFLAG = 13 - RETURN -C - 65 NUMORT = NUMORT + 1 - CALL STOR1(YHP,U(1,1,KOD),YHP(1,NFCP1),V(1,KOD),1, - 1 NDISK,NTAPE) -C -C ********************************************************************** -C STORE ORTHONORMALIZATION INFORMATION, INITIALIZE -C INTEGRATION FLAG, AND CONTINUE INTEGRATION TO THE NEXT -C ORTHONORMALIZATION POINT OR OUTPUT POINT. -C - Z(NUMORT) = X - IF (INHOMO .EQ. 1 .AND. NPS .EQ. 0) C = S(NFCP1) * C - IF (NDISK .EQ. 0) GO TO 90 - IF (INHOMO .EQ. 1) WRITE (NTAPE) (W(J,1), J = 1,NFCC) - WRITE(NTAPE) (IP(J,1), J = 1,NFCC),(P(J,1), J = 1,NTP) - 90 INFO(1) = 0 - JON = JON + 1 - IF (NOPG .EQ. 1 .AND. X .NE. XOP) GO TO 10 -C -C ********************************************************************** -C CONTINUE INTEGRATION IF WE ARE NOT AT AN OUTPUT POINT. -C - 100 IF (IDID .EQ. 1) GO TO 15 -C -C STORAGE OF HOMOGENEOUS SOLUTIONS IN U AND THE PARTICULAR -C SOLUTION IN V AT THE OUTPUT POINTS. -C - CALL STOR1(U(1,1,KOD),YHP,V(1,KOD),YHP(1,NFCP1),0,NDISK,NTAPE) - 110 CONTINUE -C ********************************************************************** -C ********************************************************************** -C - IFLAG = 0 - RETURN - END diff --git a/slatec/rpqr79.f b/slatec/rpqr79.f deleted file mode 100644 index aab212c..0000000 --- a/slatec/rpqr79.f +++ /dev/null @@ -1,103 +0,0 @@ -*DECK RPQR79 - SUBROUTINE RPQR79 (NDEG, COEFF, ROOT, IERR, WORK) -C***BEGIN PROLOGUE RPQR79 -C***PURPOSE Find the zeros of a polynomial with real coefficients. -C***LIBRARY SLATEC -C***CATEGORY F1A1A -C***TYPE SINGLE PRECISION (RPQR79-S, CPQR79-C) -C***KEYWORDS COMPLEX POLYNOMIAL, POLYNOMIAL ROOTS, POLYNOMIAL ZEROS -C***AUTHOR Vandevender, W. H., (SNLA) -C***DESCRIPTION -C -C Abstract -C This routine computes all zeros of a polynomial of degree NDEG -C with real coefficients by computing the eigenvalues of the -C companion matrix. -C -C Description of Parameters -C The user must dimension all arrays appearing in the call list -C COEFF(NDEG+1), ROOT(NDEG), WORK(NDEG*(NDEG+2)) -C -C --Input-- -C NDEG degree of polynomial -C -C COEFF REAL coefficients in descending order. i.e., -C P(Z)= COEFF(1)*(Z**NDEG) + COEFF(NDEG)*Z + COEFF(NDEG+1) -C -C WORK REAL work array of dimension at least NDEG*(NDEG+2) -C -C --Output-- -C ROOT COMPLEX vector of roots -C -C IERR Output Error Code -C - Normal Code -C 0 means the roots were computed. -C - Abnormal Codes -C 1 more than 30 QR iterations on some eigenvalue of the -C companion matrix -C 2 COEFF(1)=0.0 -C 3 NDEG is invalid (less than or equal to 0) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED HQR, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800601 DATE WRITTEN -C 890505 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 911010 Code reworked and simplified. (RWC and WRB) -C***END PROLOGUE RPQR79 - REAL COEFF(*), WORK(*), SCALE - COMPLEX ROOT(*) - INTEGER NDEG, IERR, K, KH, KWR, KWI, KCOL -C***FIRST EXECUTABLE STATEMENT RPQR79 - IERR = 0 - IF (ABS(COEFF(1)) .EQ. 0.0) THEN - IERR = 2 - CALL XERMSG ('SLATEC', 'RPQR79', - + 'LEADING COEFFICIENT IS ZERO.', 2, 1) - RETURN - ENDIF -C - IF (NDEG .LE. 0) THEN - IERR = 3 - CALL XERMSG ('SLATEC', 'RPQR79', 'DEGREE INVALID.', 3, 1) - RETURN - ENDIF -C - IF (NDEG .EQ. 1) THEN - ROOT(1) = CMPLX(-COEFF(2)/COEFF(1),0.0) - RETURN - ENDIF -C - SCALE = 1.0E0/COEFF(1) - KH = 1 - KWR = KH+NDEG*NDEG - KWI = KWR+NDEG - KWEND = KWI+NDEG-1 -C - DO 10 K=1,KWEND - WORK(K) = 0.0E0 - 10 CONTINUE -C - DO 20 K=1,NDEG - KCOL = (K-1)*NDEG+1 - WORK(KCOL) = -COEFF(K+1)*SCALE - IF (K .NE. NDEG) WORK(KCOL+K) = 1.0E0 - 20 CONTINUE -C - CALL HQR (NDEG,NDEG,1,NDEG,WORK(KH),WORK(KWR),WORK(KWI),IERR) -C - IF (IERR .NE. 0) THEN - IERR = 1 - CALL XERMSG ('SLATEC', 'CPQR79', - + 'NO CONVERGENCE IN 30 QR ITERATIONS.', 1, 1) - RETURN - ENDIF -C - DO 30 K=1,NDEG - KM1 = K-1 - ROOT(K) = CMPLX(WORK(KWR+KM1),WORK(KWI+KM1)) - 30 CONTINUE - RETURN - END diff --git a/slatec/rpzero.f b/slatec/rpzero.f deleted file mode 100644 index 9db5d47..0000000 --- a/slatec/rpzero.f +++ /dev/null @@ -1,60 +0,0 @@ -*DECK RPZERO - SUBROUTINE RPZERO (N, A, R, T, IFLG, S) -C***BEGIN PROLOGUE RPZERO -C***PURPOSE Find the zeros of a polynomial with real coefficients. -C***LIBRARY SLATEC -C***CATEGORY F1A1A -C***TYPE SINGLE PRECISION (RPZERO-S, CPZERO-C) -C***KEYWORDS POLYNOMIAL ROOTS, POLYNOMIAL ZEROS, REAL ROOTS -C***AUTHOR Kahaner, D. K., (NBS) -C***DESCRIPTION -C -C Find the zeros of the real polynomial -C P(X)= A(1)*X**N + A(2)*X**(N-1) +...+ A(N+1) -C -C Input... -C N = degree of P(X) -C A = real vector containing coefficients of P(X), -C A(I) = coefficient of X**(N+1-I) -C R = N word complex vector containing initial estimates for zeros -C if these are known. -C T = 6(N+1) word array used for temporary storage -C IFLG = flag to indicate if initial estimates of -C zeros are input. -C If IFLG .EQ. 0, no estimates are input. -C If IFLG .NE. 0, the vector R contains estimates of -C the zeros -C ** Warning ****** If estimates are input, they must -C be separated; that is, distinct or -C not repeated. -C S = an N word array -C -C Output... -C R(I) = ith zero, -C S(I) = bound for R(I) . -C IFLG = error diagnostic -C Error Diagnostics... -C If IFLG .EQ. 0 on return, all is well. -C If IFLG .EQ. 1 on return, A(1)=0.0 or N=0 on input. -C If IFLG .EQ. 2 on return, the program failed to converge -C after 25*N iterations. Best current estimates of the -C zeros are in R(I). Error bounds are not calculated. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CPZERO -C***REVISION HISTORY (YYMMDD) -C 810223 DATE WRITTEN -C 890206 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE RPZERO -C - COMPLEX R(*), T(*) - REAL A(*), S(*) -C***FIRST EXECUTABLE STATEMENT RPZERO - N1=N+1 - DO 1 I=1,N1 - T(I)= CMPLX(A(I),0.0) - 1 CONTINUE - CALL CPZERO(N,T,R,T(N+2),IFLG,S) - RETURN - END diff --git a/slatec/rs.f b/slatec/rs.f deleted file mode 100644 index 1c6c56e..0000000 --- a/slatec/rs.f +++ /dev/null @@ -1,90 +0,0 @@ -*DECK RS - SUBROUTINE RS (NM, N, A, W, MATZ, Z, FV1, FV2, IERR) -C***BEGIN PROLOGUE RS -C***PURPOSE Compute the eigenvalues and, optionally, the eigenvectors -C of a real symmetric matrix. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4A1 -C***TYPE SINGLE PRECISION (RS-S, CH-C) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine calls the recommended sequence of -C subroutines from the eigensystem subroutine package (EISPACK) -C to find the eigenvalues and eigenvectors (if desired) -C of a REAL SYMMETRIC matrix. -C -C On Input -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, A and Z, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix A. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C A contains the real symmetric matrix. A is a two-dimensional -C REAL array, dimensioned A(NM,N). -C -C MATZ is an INTEGER variable set equal to zero if only -C eigenvalues are desired. Otherwise, it is set to any -C non-zero integer for both eigenvalues and eigenvectors. -C -C On Output -C -C A is unaltered. -C -C W contains the eigenvalues in ascending order. W is a one- -C dimensional REAL array, dimensioned W(N). -C -C Z contains the eigenvectors if MATZ is not zero. The -C eigenvectors are orthonormal. Z is a two-dimensional -C REAL array, dimensioned Z(NM,N). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C 10*N if N is greater than NM, -C J if the J-th eigenvalue has not been -C determined after 30 iterations. -C The eigenvalues, and eigenvectors if requested, -C should be correct for indices 1, 2, ..., IERR-1. -C -C FV1 and FV2 are one-dimensional REAL arrays used for temporary -C storage, dimensioned FV1(N) and FV2(N). -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED TQL2, TQLRAT, TRED1, TRED2 -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE RS -C - INTEGER N,NM,IERR,MATZ - REAL A(NM,*),W(*),Z(NM,*),FV1(*),FV2(*) -C -C***FIRST EXECUTABLE STATEMENT RS - IF (N .LE. NM) GO TO 10 - IERR = 10 * N - GO TO 50 -C - 10 IF (MATZ .NE. 0) GO TO 20 -C .......... FIND EIGENVALUES ONLY .......... - CALL TRED1(NM,N,A,W,FV1,FV2) - CALL TQLRAT(N,W,FV2,IERR) - GO TO 50 -C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... - 20 CALL TRED2(NM,N,A,W,FV1,Z) - CALL TQL2(NM,N,W,FV1,Z,IERR) - 50 RETURN - END diff --git a/slatec/rsb.f b/slatec/rsb.f deleted file mode 100644 index 80731f7..0000000 --- a/slatec/rsb.f +++ /dev/null @@ -1,112 +0,0 @@ -*DECK RSB - SUBROUTINE RSB (NM, N, MB, A, W, MATZ, Z, FV1, FV2, IERR) -C***BEGIN PROLOGUE RSB -C***PURPOSE Compute the eigenvalues and, optionally, the eigenvectors -C of a symmetric band matrix. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4A6 -C***TYPE SINGLE PRECISION (RSB-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine calls the recommended sequence of -C subroutines from the eigensystem subroutine package (EISPACK) -C to find the eigenvalues and eigenvectors (if desired) -C of a REAL SYMMETRIC BAND matrix. -C -C On Input -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, A and Z, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix A. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C MB is the half band width of the matrix, defined as the -C number of adjacent diagonals, including the principal -C diagonal, required to specify the non-zero portion of the -C lower triangle of the matrix. MB must be less than or -C equal to N. MB is an INTEGER variable. -C -C A contains the lower triangle of the real symmetric band -C matrix. Its lowest subdiagonal is stored in the last -C N+1-MB positions of the first column, its next subdiagonal -C in the last N+2-MB positions of the second column, further -C subdiagonals similarly, and finally its principal diagonal -C in the N positions of the last column. Contents of storage -C locations not part of the matrix are arbitrary. A is a -C two-dimensional REAL array, dimensioned A(NM,MB). -C -C MATZ is an INTEGER variable set equal to zero if only -C eigenvalues are desired. Otherwise, it is set to any -C non-zero integer for both eigenvalues and eigenvectors. -C -C On Output -C -C A has been destroyed. -C -C W contains the eigenvalues in ascending order. W is a one- -C dimensional REAL array, dimensioned W(N). -C -C Z contains the eigenvectors if MATZ is not zero. The -C eigenvectors are orthonormal. Z is a two-dimensional -C REAL array, dimensioned Z(NM,N). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C 10*N if N is greater than NM, -C 12*N if MB is either non-positive or greater than N, -C J if the J-th eigenvalue has not been -C determined after 30 iterations. -C The eigenvalues and eigenvectors, if requested, -C should be correct for indices 1, 2, ..., IERR-1. -C -C FV1 and FV2 are one-dimensional REAL arrays used for temporary -C storage, dimensioned FV1(N) and FV2(N). -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED BANDR, TQL2, TQLRAT -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE RSB -C - INTEGER N,MB,NM,IERR,MATZ - REAL A(NM,*),W(*),Z(NM,*),FV1(*),FV2(*) - LOGICAL TF -C -C***FIRST EXECUTABLE STATEMENT RSB - IF (N .LE. NM) GO TO 5 - IERR = 10 * N - GO TO 50 - 5 IF (MB .GT. 0) GO TO 10 - IERR = 12 * N - GO TO 50 - 10 IF (MB .LE. N) GO TO 15 - IERR = 12 * N - GO TO 50 -C - 15 IF (MATZ .NE. 0) GO TO 20 -C .......... FIND EIGENVALUES ONLY .......... - TF = .FALSE. - CALL BANDR(NM,N,MB,A,W,FV1,FV2,TF,Z) - CALL TQLRAT(N,W,FV2,IERR) - GO TO 50 -C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... - 20 TF = .TRUE. - CALL BANDR(NM,N,MB,A,W,FV1,FV1,TF,Z) - CALL TQL2(NM,N,W,FV1,Z,IERR) - 50 RETURN - END diff --git a/slatec/rsco.f b/slatec/rsco.f deleted file mode 100644 index fceba16..0000000 --- a/slatec/rsco.f +++ /dev/null @@ -1,45 +0,0 @@ -*DECK RSCO - SUBROUTINE RSCO (RSAV, ISAV) -C***BEGIN PROLOGUE RSCO -C***SUBSIDIARY -C***PURPOSE Subsidiary to DEBDF -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (RSCO-S, DRSCO-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C RSCO transfers data from arrays to a common block within the -C integrator package DEBDF. -C -C***SEE ALSO DEBDF -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS DEBDF1 -C***REVISION HISTORY (YYMMDD) -C 800901 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE RSCO -C -C -C----------------------------------------------------------------------- -C THIS ROUTINE RESTORES FROM RSAV AND ISAV THE CONTENTS OF COMMON -C BLOCK DEBDF1 , WHICH IS USED INTERNALLY IN THE DEBDF -C PACKAGE. THIS PRESUMES THAT RSAV AND ISAV WERE LOADED BY MEANS -C OF SUBROUTINE SVCO OR THE EQUIVALENT. -C----------------------------------------------------------------------- - INTEGER ISAV, I, ILS, LENILS, LENRLS - REAL RSAV, RLS - DIMENSION RSAV(*), ISAV(*) - COMMON /DEBDF1/ RLS(218), ILS(33) - SAVE LENRLS, LENILS - DATA LENRLS/218/, LENILS/33/ -C -C***FIRST EXECUTABLE STATEMENT RSCO - DO 10 I = 1,LENRLS - 10 RLS(I) = RSAV(I) - DO 20 I = 1,LENILS - 20 ILS(I) = ISAV(I) - RETURN -C----------------------- END OF SUBROUTINE RSCO ----------------------- - END diff --git a/slatec/rsg.f b/slatec/rsg.f deleted file mode 100644 index 25659e2..0000000 --- a/slatec/rsg.f +++ /dev/null @@ -1,96 +0,0 @@ -*DECK RSG - SUBROUTINE RSG (NM, N, A, B, W, MATZ, Z, FV1, FV2, IERR) -C***BEGIN PROLOGUE RSG -C***PURPOSE Compute the eigenvalues and, optionally, the eigenvectors -C of a symmetric generalized eigenproblem. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4B1 -C***TYPE SINGLE PRECISION (RSG-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine calls the recommended sequence of -C subroutines from the eigensystem subroutine package (EISPACK) -C To find the eigenvalues and eigenvectors (if desired) -C for the REAL SYMMETRIC generalized eigenproblem Ax = (LAMBDA)Bx. -C -C On Input -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, A, B, and Z, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrices A and B. N is an INTEGER -C variable. N must be less than or equal to NM. -C -C A contains a real symmetric matrix. A is a two-dimensional -C REAL array, dimensioned A(NM,N). -C -C B contains a positive definite real symmetric matrix. B is a -C two-dimensional REAL array, dimensioned B(NM,N). -C -C MATZ is an INTEGER variable set equal to zero if only -C eigenvalues are desired. Otherwise, it is set to any -C non-zero integer for both eigenvalues and eigenvectors. -C -C On Output -C -C W contains the eigenvalues in ascending order. W is a -C one-dimensional REAL array, dimensioned W(N). -C -C Z contains the eigenvectors if MATZ is not zero. Z is a -C two-dimensional REAL array, dimensioned Z(NM,N). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C 10*N if N is greater than NM, -C 7*N+1 if B is not positive definite, -C J if the J-th eigenvalue has not been -C determined after 30 iterations. -C The eigenvalues should be correct for indices -C 1, 2, ..., IERR-1, but no eigenvectors are -C computed. -C -C FV1 and FV2 are one-dimensional REAL arrays used for temporary -C storage, dimensioned FV1(N) and FV2(N). -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED REBAK, REDUC, TQL2, TQLRAT, TRED1, TRED2 -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE RSG -C - INTEGER N,NM,IERR,MATZ - REAL A(NM,*),B(NM,*),W(*),Z(NM,*),FV1(*),FV2(*) -C -C***FIRST EXECUTABLE STATEMENT RSG - IF (N .LE. NM) GO TO 10 - IERR = 10 * N - GO TO 50 -C - 10 CALL REDUC(NM,N,A,B,FV2,IERR) - IF (IERR .NE. 0) GO TO 50 - IF (MATZ .NE. 0) GO TO 20 -C .......... FIND EIGENVALUES ONLY .......... - CALL TRED1(NM,N,A,W,FV1,FV2) - CALL TQLRAT(N,W,FV2,IERR) - GO TO 50 -C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... - 20 CALL TRED2(NM,N,A,W,FV1,Z) - CALL TQL2(NM,N,W,FV1,Z,IERR) - IF (IERR .NE. 0) GO TO 50 - CALL REBAK(NM,N,B,FV2,N,Z) - 50 RETURN - END diff --git a/slatec/rsgab.f b/slatec/rsgab.f deleted file mode 100644 index 5b01d58..0000000 --- a/slatec/rsgab.f +++ /dev/null @@ -1,96 +0,0 @@ -*DECK RSGAB - SUBROUTINE RSGAB (NM, N, A, B, W, MATZ, Z, FV1, FV2, IERR) -C***BEGIN PROLOGUE RSGAB -C***PURPOSE Compute the eigenvalues and, optionally, the eigenvectors -C of a symmetric generalized eigenproblem. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4B1 -C***TYPE SINGLE PRECISION (RSGAB-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine calls the recommended sequence of -C subroutines from the eigensystem subroutine package (EISPACK) -C to find the eigenvalues and eigenvectors (if desired) -C for the REAL SYMMETRIC generalized eigenproblem ABx = (LAMBDA)x. -C -C On Input -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, A, B, and Z, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrices A and B. N is an INTEGER -C variable. N must be less than or equal to NM. -C -C A contains a real symmetric matrix. A is a two-dimensional -C REAL array, dimensioned A(NM,N). -C -C B contains a positive definite real symmetric matrix. B is a -C two-dimensional REAL array, dimensioned B(NM,N). -C -C MATZ is an INTEGER variable set equal to zero if only -C eigenvalues are desired. Otherwise, it is set to any -C non-zero integer for both eigenvalues and eigenvectors. -C -C On Output -C -C W contains the eigenvalues in ascending order. W is a -C one-dimensional REAL array, dimensioned W(N). -C -C Z contains the eigenvectors if MATZ is not zero. Z is a -C two-dimensional REAL array, dimensioned Z(NM,N). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C 10*N if N is greater than NM, -C 7*N+1 if B is not positive definite, -C J if the J-th eigenvalue has not been -C determined after 30 iterations. -C The eigenvalues should be correct for indices -C 1, 2, ..., IERR-1, but no eigenvectors are -C computed. -C -C FV1 and FV2 are one-dimensional REAL arrays used for temporary -C storage, dimensioned FV1(N) and FV2(N). -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED REBAK, REDUC2, TQL2, TQLRAT, TRED1, TRED2 -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE RSGAB -C - INTEGER N,NM,IERR,MATZ - REAL A(NM,*),B(NM,*),W(*),Z(NM,*),FV1(*),FV2(*) -C -C***FIRST EXECUTABLE STATEMENT RSGAB - IF (N .LE. NM) GO TO 10 - IERR = 10 * N - GO TO 50 -C - 10 CALL REDUC2(NM,N,A,B,FV2,IERR) - IF (IERR .NE. 0) GO TO 50 - IF (MATZ .NE. 0) GO TO 20 -C .......... FIND EIGENVALUES ONLY .......... - CALL TRED1(NM,N,A,W,FV1,FV2) - CALL TQLRAT(N,W,FV2,IERR) - GO TO 50 -C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... - 20 CALL TRED2(NM,N,A,W,FV1,Z) - CALL TQL2(NM,N,W,FV1,Z,IERR) - IF (IERR .NE. 0) GO TO 50 - CALL REBAK(NM,N,B,FV2,N,Z) - 50 RETURN - END diff --git a/slatec/rsgba.f b/slatec/rsgba.f deleted file mode 100644 index 3263d8b..0000000 --- a/slatec/rsgba.f +++ /dev/null @@ -1,96 +0,0 @@ -*DECK RSGBA - SUBROUTINE RSGBA (NM, N, A, B, W, MATZ, Z, FV1, FV2, IERR) -C***BEGIN PROLOGUE RSGBA -C***PURPOSE Compute the eigenvalues and, optionally, the eigenvectors -C of a symmetric generalized eigenproblem. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4B1 -C***TYPE SINGLE PRECISION (RSGBA-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine calls the recommended sequence of -C subroutines from the eigensystem subroutine package (EISPACK) -C to find the eigenvalues and eigenvectors (if desired) -C for the REAL SYMMETRIC generalized eigenproblem BAx = (LAMBDA)x. -C -C On Input -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, A, B, and Z, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrices A and B. N is an INTEGER -C variable. N must be less than or equal to NM. -C -C A contains a real symmetric matrix. A is a two-dimensional -C REAL array, dimensioned A(NM,N). -C -C B contains a positive definite real symmetric matrix. B is a -C two-dimensional REAL array, dimensioned B(NM,N). -C -C MATZ is an INTEGER variable set equal to zero if only -C eigenvalues are desired. Otherwise, it is set to any -C non-zero integer for both eigenvalues and eigenvectors. -C -C On Output -C -C W contains the eigenvalues in ascending order. W is a -C one-dimensional REAL array, dimensioned W(N). -C -C Z contains the eigenvectors if MATZ is not zero. Z is a -C two-dimensional REAL array, dimensioned Z(NM,N). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C 10*N if N is greater than NM, -C 7*N+1 if B is not positive definite, -C J if the J-th eigenvalue has not been -C determined after 30 iterations. -C The eigenvalues should be correct for indices -C 1, 2, ..., IERR-1, but no eigenvectors are -C computed. -C -C FV1 and FV2 are one-dimensional REAL arrays used for temporary -C storage, dimensioned FV1(N) and FV2(N). -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED REBAKB, REDUC2, TQL2, TQLRAT, TRED1, TRED2 -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE RSGBA -C - INTEGER N,NM,IERR,MATZ - REAL A(NM,*),B(NM,*),W(*),Z(NM,*),FV1(*),FV2(*) -C -C***FIRST EXECUTABLE STATEMENT RSGBA - IF (N .LE. NM) GO TO 10 - IERR = 10 * N - GO TO 50 -C - 10 CALL REDUC2(NM,N,A,B,FV2,IERR) - IF (IERR .NE. 0) GO TO 50 - IF (MATZ .NE. 0) GO TO 20 -C .......... FIND EIGENVALUES ONLY .......... - CALL TRED1(NM,N,A,W,FV1,FV2) - CALL TQLRAT(N,W,FV2,IERR) - GO TO 50 -C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... - 20 CALL TRED2(NM,N,A,W,FV1,Z) - CALL TQL2(NM,N,W,FV1,Z,IERR) - IF (IERR .NE. 0) GO TO 50 - CALL REBAKB(NM,N,B,FV2,N,Z) - 50 RETURN - END diff --git a/slatec/rsp.f b/slatec/rsp.f deleted file mode 100644 index c6f2733..0000000 --- a/slatec/rsp.f +++ /dev/null @@ -1,111 +0,0 @@ -*DECK RSP - SUBROUTINE RSP (NM, N, NV, A, W, MATZ, Z, FV1, FV2, IERR) -C***BEGIN PROLOGUE RSP -C***PURPOSE Compute the eigenvalues and, optionally, the eigenvectors -C of a real symmetric matrix packed into a one dimensional -C array. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4A1 -C***TYPE SINGLE PRECISION (RSP-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine calls the recommended sequence of -C subroutines from the eigensystem subroutine package (EISPACK) -C to find the eigenvalues and eigenvectors (if desired) -C of a REAL SYMMETRIC PACKED matrix. -C -C On Input -C -C NM must be set to the row dimension of the two-dimensional -C array parameter, Z, as declared in the calling program -C dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix A. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C NV is an INTEGER variable set equal to the dimension of the -C array A as specified in the calling program. NV must not -C be less than N*(N+1)/2. -C -C A contains the lower triangle, stored row-wise, of the real -C symmetric packed matrix. A is a one-dimensional REAL -C array, dimensioned A(NV). -C -C MATZ is an INTEGER variable set equal to zero if only -C eigenvalues are desired. Otherwise, it is set to any -C non-zero integer for both eigenvalues and eigenvectors. -C -C On Output -C -C A has been destroyed. -C -C W contains the eigenvalues in ascending order. W is a -C one-dimensional REAL array, dimensioned W(N). -C -C Z contains the eigenvectors if MATZ is not zero. The eigen- -C vectors are orthonormal. Z is a two-dimensional REAL array, -C dimensioned Z(NM,N). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C 10*N if N is greater than NM, -C 20*N if NV is less than N*(N+1)/2, -C J if the J-th eigenvalue has not been -C determined after 30 iterations. -C The eigenvalues and eigenvectors in the W and Z -C arrays should be correct for indices -C 1, 2, ..., IERR-1. -C -C FV1 and FV2 are one-dimensional REAL arrays used for temporary -C storage, dimensioned FV1(N) and FV2(N). -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED TQL2, TQLRAT, TRBAK3, TRED3 -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE RSP -C - INTEGER I,J,N,NM,NV,IERR,MATZ - REAL A(*),W(*),Z(NM,*),FV1(*),FV2(*) -C -C***FIRST EXECUTABLE STATEMENT RSP - IF (N .LE. NM) GO TO 5 - IERR = 10 * N - GO TO 50 - 5 IF (NV .GE. (N * (N + 1)) / 2) GO TO 10 - IERR = 20 * N - GO TO 50 -C - 10 CALL TRED3(N,NV,A,W,FV1,FV2) - IF (MATZ .NE. 0) GO TO 20 -C .......... FIND EIGENVALUES ONLY .......... - CALL TQLRAT(N,W,FV2,IERR) - GO TO 50 -C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... - 20 DO 40 I = 1, N -C - DO 30 J = 1, N - Z(J,I) = 0.0E0 - 30 CONTINUE -C - Z(I,I) = 1.0E0 - 40 CONTINUE -C - CALL TQL2(NM,N,W,FV1,Z,IERR) - IF (IERR .NE. 0) GO TO 50 - CALL TRBAK3(NM,N,NV,A,N,Z) - 50 RETURN - END diff --git a/slatec/rst.f b/slatec/rst.f deleted file mode 100644 index 73390fa..0000000 --- a/slatec/rst.f +++ /dev/null @@ -1,97 +0,0 @@ -*DECK RST - SUBROUTINE RST (NM, N, W, E, MATZ, Z, IERR) -C***BEGIN PROLOGUE RST -C***PURPOSE Compute the eigenvalues and, optionally, the eigenvectors -C of a real symmetric tridiagonal matrix. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4A5 -C***TYPE SINGLE PRECISION (RST-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine calls the recommended sequence of -C subroutines from the eigensystem subroutine package (EISPACK) -C to find the eigenvalues and eigenvectors (if desired) -C of a REAL SYMMETRIC TRIDIAGONAL matrix. -C -C On Input -C -C NM must be set to the row dimension of the two-dimensional -C array parameter, Z, as declared in the calling program -C dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C W contains the diagonal elements of the real symmetric -C tridiagonal matrix. W is a one-dimensional REAL array, -C dimensioned W(N). -C -C E contains the subdiagonal elements of the matrix in its last -C N-1 positions. E(1) is arbitrary. E is a one-dimensional -C REAL array, dimensioned E(N). -C -C MATZ is an INTEGER variable set equal to zero if only -C eigenvalues are desired. Otherwise, it is set to any -C non-zero integer for both eigenvalues and eigenvectors. -C -C On Output -C -C W contains the eigenvalues in ascending order. -C -C Z contains the eigenvectors if MATZ is not zero. The eigen- -C vectors are orthonormal. Z is a two-dimensional REAL array, -C dimensioned Z(NM,N). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C 10*N if N is greater than NM, -C J if the J-th eigenvalue has not been -C determined after 30 iterations. -C The eigenvalues and eigenvectors in the W and Z -C arrays should be correct for indices -C 1, 2, ..., IERR-1. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED IMTQL1, IMTQL2 -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE RST -C - INTEGER I,J,N,NM,IERR,MATZ - REAL W(*),E(*),Z(NM,*) -C -C***FIRST EXECUTABLE STATEMENT RST - IF (N .LE. NM) GO TO 10 - IERR = 10 * N - GO TO 50 -C - 10 IF (MATZ .NE. 0) GO TO 20 -C .......... FIND EIGENVALUES ONLY .......... - CALL IMTQL1(N,W,E,IERR) - GO TO 50 -C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... - 20 DO 40 I = 1, N -C - DO 30 J = 1, N - Z(J,I) = 0.0E0 - 30 CONTINUE -C - Z(I,I) = 1.0E0 - 40 CONTINUE -C - CALL IMTQL2(NM,N,W,E,Z,IERR) - 50 RETURN - END diff --git a/slatec/rt.f b/slatec/rt.f deleted file mode 100644 index fb964bc..0000000 --- a/slatec/rt.f +++ /dev/null @@ -1,102 +0,0 @@ -*DECK RT - SUBROUTINE RT (NM, N, A, W, MATZ, Z, FV1, IERR) -C***BEGIN PROLOGUE RT -C***PURPOSE Compute the eigenvalues and eigenvectors of a special real -C tridiagonal matrix. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4A5 -C***TYPE SINGLE PRECISION (RT-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine calls the recommended sequence of subroutines -C from the eigensystem subroutine package (EISPACK) to find the -C eigenvalues and eigenvectors (if desired) of a special REAL -C TRIDIAGONAL matrix. The property of the matrix required for use -C of this subroutine is that the products of pairs of corresponding -C off-diagonal elements be all non-negative. If eigenvectors are -C desired, no product can be zero unless both factors are zero. -C -C On Input -C -C NM must be set to the row dimension of the two-dimensional -C array parameter, A and Z, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix A. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C A contains the special real tridiagonal matrix in its first -C three columns. The subdiagonal elements are stored in the -C last N-1 positions of the first column, the diagonal elements -C in the second column, and the superdiagonal elements in the -C first N-1 positions of the third column. Elements A(1,1) and -C A(N,3) are arbitrary. A is a two-dimensional REAL array, -C dimensioned A(NM,3). -C -C MATZ is an INTEGER variable set equal to zero if only -C eigenvalues are desired. Otherwise, it is set to any -C non-zero integer for both eigenvalues and eigenvectors. -C -C On Output -C -C W contains the eigenvalues in ascending order. W is a -C one-dimensional REAL array, dimensioned W(N). -C -C Z contains the eigenvectors if MATZ is not zero. The eigen- -C vectors are not normalized. Z is a two-dimensional REAL -C array, dimensioned Z(NM,N). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C 10*N if N is greater than NM, -C N+J if A(J,1)*A(J-1,3) is negative, -C 2*N+J if the product is zero with one factor non-zero, -C and MATZ is non-zero; -C J if the J-th eigenvalue has not been -C determined after 30 iterations. -C The eigenvalues and eigenvectors in the W and Z -C arrays should be correct for indices -C 1, 2, ..., IERR-1. -C -C FV1 is a one-dimensional REAL array used for temporary storage, -C dimensioned FV1(N). -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED FIGI, FIGI2, IMTQL1, IMTQL2 -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE RT -C - INTEGER N,NM,IERR,MATZ - REAL A(NM,3),W(*),Z(NM,*),FV1(*) -C -C***FIRST EXECUTABLE STATEMENT RT - IF (N .LE. NM) GO TO 10 - IERR = 10 * N - GO TO 50 -C - 10 IF (MATZ .NE. 0) GO TO 20 -C .......... FIND EIGENVALUES ONLY .......... - CALL FIGI(NM,N,A,W,FV1,FV1,IERR) - IF (IERR .GT. 0) GO TO 50 - CALL IMTQL1(N,W,FV1,IERR) - GO TO 50 -C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... - 20 CALL FIGI2(NM,N,A,W,FV1,Z,IERR) - IF (IERR .NE. 0) GO TO 50 - CALL IMTQL2(NM,N,W,FV1,Z,IERR) - 50 RETURN - END diff --git a/slatec/runif.f b/slatec/runif.f deleted file mode 100644 index 388256e..0000000 --- a/slatec/runif.f +++ /dev/null @@ -1,79 +0,0 @@ -*DECK RUNIF - FUNCTION RUNIF (T, N) -C***BEGIN PROLOGUE RUNIF -C***PURPOSE Generate a uniformly distributed random number. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY L6A21 -C***TYPE SINGLE PRECISION (RUNIF-S) -C***KEYWORDS FNLIB, RANDOM NUMBER, SPECIAL FUNCTIONS, UNIFORM -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C This random number generator is portable among a wide variety of -C computers. It generates a random number between 0.0 and 1.0 accord- -C ing to the algorithm presented by Bays and Durham (TOMS, 2, 59, -C 1976). The motivation for using this scheme, which resembles the -C Maclaren-Marsaglia method, is to greatly increase the period of the -C random sequence. If the period of the basic generator (RAND) is P, -C then the expected mean period of the sequence generated by RUNIF is -C given by new mean P = SQRT (PI*FACTORIAL(N)/(8*P)), -C where FACTORIAL(N) must be much greater than P in this asymptotic -C formula. Generally, N should be around 32 if P=4.E6 as for RAND. -C -C Input Argument -- -C N ABS(N) is the number of random numbers in an auxiliary table. -C Note though that ABS(N)+1 is the number of items in array T. -C If N is positive and differs from its value in the previous -C invocation, then the table is initialized for the new value of -C N. If N is negative, ABS(N) is the number of items in an -C auxiliary table, but the tables are now assumed already to -C be initialized. This option enables the user to save the -C table T at the end of a long computer run and to restart with -C the same sequence. Normally, RUNIF would be called at most -C once with negative N. Subsequent invocations would have N -C positive and of the correct magnitude. -C -C Input and Output Argument -- -C T an array of ABS(N)+1 random numbers from a previous invocation -C of RUNIF. Whenever N is positive and differs from the old -C N, the table is initialized. The first ABS(N) numbers are the -C table discussed in the reference, and the N+1 -st value is Y. -C This array may be saved in order to restart a sequence. -C -C Output Value -- -C RUNIF a random number between 0.0 and 1.0. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED RAND -C***REVISION HISTORY (YYMMDD) -C 770401 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 910819 Added EXTERNAL statement for RAND due to problem on IBM -C RS 6000. (WRB) -C***END PROLOGUE RUNIF - DIMENSION T(*) - EXTERNAL RAND - SAVE NOLD, FLOATN - DATA NOLD /-1/ -C***FIRST EXECUTABLE STATEMENT RUNIF - IF (N.EQ.NOLD) GO TO 20 -C - NOLD = ABS(N) - FLOATN = NOLD - IF (N.LT.0) DUMMY = RAND (T(NOLD+1)) - IF (N.LT.0) GO TO 20 -C - DO 10 I=1,NOLD - T(I) = RAND (0.) - 10 CONTINUE - T(NOLD+1) = RAND (0.) -C - 20 J = T(NOLD+1)*FLOATN + 1. - T(NOLD+1) = T(J) - RUNIF = T(J) - T(J) = RAND (0.) -C - RETURN - END diff --git a/slatec/rwupdt.f b/slatec/rwupdt.f deleted file mode 100644 index 08164c5..0000000 --- a/slatec/rwupdt.f +++ /dev/null @@ -1,120 +0,0 @@ -*DECK RWUPDT - SUBROUTINE RWUPDT (N, R, LDR, W, B, ALPHA, COS, SIN) -C***BEGIN PROLOGUE RWUPDT -C***SUBSIDIARY -C***PURPOSE Subsidiary to SNLS1 and SNLS1E -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (RWUPDT-S, DWUPDT-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Given an N by N upper triangular matrix R, this subroutine -C computes the QR decomposition of the matrix formed when a row -C is added to R. If the row is specified by the vector W, then -C RWUPDT determines an orthogonal matrix Q such that when the -C N+1 by N matrix composed of R augmented by W is premultiplied -C by (Q TRANSPOSE), the resulting matrix is upper trapezoidal. -C The orthogonal matrix Q is the product of N transformations -C -C G(1)*G(2)* ... *G(N) -C -C where G(I) is a Givens rotation in the (I,N+1) plane which -C eliminates elements in the I-th plane. RWUPDT also -C computes the product (Q TRANSPOSE)*C where C is the -C (N+1)-vector (b,alpha). Q itself is not accumulated, rather -C the information to recover the G rotations is supplied. -C -C The subroutine statement is -C -C SUBROUTINE RWUPDT(N,R,LDR,W,B,ALPHA,COS,SIN) -C -C where -C -C N is a positive integer input variable set to the order of R. -C -C R is an N by N array. On input the upper triangular part of -C R must contain the matrix to be updated. On output R -C contains the updated triangular matrix. -C -C LDR is a positive integer input variable not less than N -C which specifies the leading dimension of the array R. -C -C W is an input array of length N which must contain the row -C vector to be added to R. -C -C B is an array of length N. On input B must contain the -C first N elements of the vector C. On output B contains -C the first N elements of the vector (Q TRANSPOSE)*C. -C -C ALPHA is a variable. On input ALPHA must contain the -C (N+1)-st element of the vector C. On output ALPHA contains -C the (N+1)-st element of the vector (Q TRANSPOSE)*C. -C -C COS is an output array of length N which contains the -C cosines of the transforming Givens rotations. -C -C SIN is an output array of length N which contains the -C sines of the transforming Givens rotations. -C -C***SEE ALSO SNLS1, SNLS1E -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE RWUPDT - INTEGER N,LDR - REAL ALPHA - REAL R(LDR,*),W(*),B(*),COS(*),SIN(*) - INTEGER I,J,JM1 - REAL COTAN,ONE,P5,P25,ROWJ,TAN,TEMP,ZERO - SAVE ONE, P5, P25, ZERO - DATA ONE,P5,P25,ZERO /1.0E0,5.0E-1,2.5E-1,0.0E0/ -C***FIRST EXECUTABLE STATEMENT RWUPDT - DO 60 J = 1, N - ROWJ = W(J) - JM1 = J - 1 -C -C APPLY THE PREVIOUS TRANSFORMATIONS TO -C R(I,J), I=1,2,...,J-1, AND TO W(J). -C - IF (JM1 .LT. 1) GO TO 20 - DO 10 I = 1, JM1 - TEMP = COS(I)*R(I,J) + SIN(I)*ROWJ - ROWJ = -SIN(I)*R(I,J) + COS(I)*ROWJ - R(I,J) = TEMP - 10 CONTINUE - 20 CONTINUE -C -C DETERMINE A GIVENS ROTATION WHICH ELIMINATES W(J). -C - COS(J) = ONE - SIN(J) = ZERO - IF (ROWJ .EQ. ZERO) GO TO 50 - IF (ABS(R(J,J)) .GE. ABS(ROWJ)) GO TO 30 - COTAN = R(J,J)/ROWJ - SIN(J) = P5/SQRT(P25+P25*COTAN**2) - COS(J) = SIN(J)*COTAN - GO TO 40 - 30 CONTINUE - TAN = ROWJ/R(J,J) - COS(J) = P5/SQRT(P25+P25*TAN**2) - SIN(J) = COS(J)*TAN - 40 CONTINUE -C -C APPLY THE CURRENT TRANSFORMATION TO R(J,J), B(J), AND ALPHA. -C - R(J,J) = COS(J)*R(J,J) + SIN(J)*ROWJ - TEMP = COS(J)*B(J) + SIN(J)*ALPHA - ALPHA = -SIN(J)*B(J) + COS(J)*ALPHA - B(J) = TEMP - 50 CONTINUE - 60 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE RWUPDT. -C - END diff --git a/slatec/s1merg.f b/slatec/s1merg.f deleted file mode 100644 index 54c6e94..0000000 --- a/slatec/s1merg.f +++ /dev/null @@ -1,66 +0,0 @@ -*DECK S1MERG - SUBROUTINE S1MERG (TCOS, I1, M1, I2, M2, I3) -C***BEGIN PROLOGUE S1MERG -C***SUBSIDIARY -C***PURPOSE Merge two strings of ascending real numbers. -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (S1MERG-S, D1MERG-D, C1MERG-C, I1MERG-I) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This subroutine merges two ascending strings of numbers in the -C array TCOS. The first string is of length M1 and starts at -C TCOS(I1+1). The second string is of length M2 and starts at -C TCOS(I2+1). The merged string goes into TCOS(I3+1). -C -C***SEE ALSO GENBUN -C***ROUTINES CALLED SCOPY -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 901120 Modified to use IF-THEN-ELSE. Previous spaghetti code did -C not compile correctly with optimization on the IBM RS6000. -C (RWC) -C 920130 Code name changed from MERGE to S1MERG. (WRB) -C***END PROLOGUE S1MERG - INTEGER I1, I2, I3, M1, M2 - REAL TCOS(*) -C - INTEGER J1, J2, J3 -C -C***FIRST EXECUTABLE STATEMENT S1MERG - IF (M1.EQ.0 .AND. M2.EQ.0) RETURN -C - IF (M1.EQ.0 .AND. M2.NE.0) THEN - CALL SCOPY (M2, TCOS(I2+1), 1, TCOS(I3+1), 1) - RETURN - ENDIF -C - IF (M1.NE.0 .AND. M2.EQ.0) THEN - CALL SCOPY (M1, TCOS(I1+1), 1, TCOS(I3+1), 1) - RETURN - ENDIF -C - J1 = 1 - J2 = 1 - J3 = 1 -C - 10 IF (TCOS(I1+J1) .LE. TCOS(I2+J2)) THEN - TCOS(I3+J3) = TCOS(I1+J1) - J1 = J1+1 - IF (J1 .GT. M1) THEN - CALL SCOPY (M2-J2+1, TCOS(I2+J2), 1, TCOS(I3+J3+1), 1) - RETURN - ENDIF - ELSE - TCOS(I3+J3) = TCOS(I2+J2) - J2 = J2+1 - IF (J2 .GT. M2) THEN - CALL SCOPY (M1-J1+1, TCOS(I1+J1), 1, TCOS(I3+J3+1), 1) - RETURN - ENDIF - ENDIF - J3 = J3+1 - GO TO 10 - END diff --git a/slatec/sasum.f b/slatec/sasum.f deleted file mode 100644 index 4699a21..0000000 --- a/slatec/sasum.f +++ /dev/null @@ -1,79 +0,0 @@ -*DECK SASUM - REAL FUNCTION SASUM (N, SX, INCX) -C***BEGIN PROLOGUE SASUM -C***PURPOSE Compute the sum of the magnitudes of the elements of a -C vector. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A3A -C***TYPE SINGLE PRECISION (SASUM-S, DASUM-D, SCASUM-C) -C***KEYWORDS BLAS, LINEAR ALGEBRA, SUM OF MAGNITUDES OF A 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 -C --Output-- -C SASUM single precision result (zero if N .LE. 0) -C -C Returns sum of magnitudes of single precision SX. -C SASUM = sum from 0 to N-1 of ABS(SX(IX+I*INCX)), -C where IX = 1 if INCX .GE. 0, else IX = 1+(1-N)*INCX. -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 900821 Modified to correct problem with a negative increment. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SASUM - REAL SX(*) - INTEGER I, INCX, IX, M, MP1, N -C***FIRST EXECUTABLE STATEMENT SASUM - SASUM = 0.0E0 - IF (N .LE. 0) RETURN -C - IF (INCX .EQ. 1) GOTO 20 -C -C Code for increment not equal to 1. -C - IX = 1 - IF (INCX .LT. 0) IX = (-N+1)*INCX + 1 - DO 10 I = 1,N - SASUM = SASUM + ABS(SX(IX)) - IX = IX + INCX - 10 CONTINUE - RETURN -C -C Code for increment equal to 1. -C -C Clean-up loop so remaining vector length is a multiple of 6. -C - 20 M = MOD(N,6) - IF (M .EQ. 0) GOTO 40 - DO 30 I = 1,M - SASUM = SASUM + ABS(SX(I)) - 30 CONTINUE - IF (N .LT. 6) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,6 - SASUM = SASUM + ABS(SX(I)) + ABS(SX(I+1)) + ABS(SX(I+2)) + - 1 ABS(SX(I+3)) + ABS(SX(I+4)) + ABS(SX(I+5)) - 50 CONTINUE - RETURN - END diff --git a/slatec/saxpy.f b/slatec/saxpy.f deleted file mode 100644 index d7e7d82..0000000 --- a/slatec/saxpy.f +++ /dev/null @@ -1,92 +0,0 @@ -*DECK SAXPY - SUBROUTINE SAXPY (N, SA, SX, INCX, SY, INCY) -C***BEGIN PROLOGUE SAXPY -C***PURPOSE Compute a constant times a vector plus a vector. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A7 -C***TYPE SINGLE PRECISION (SAXPY-S, DAXPY-D, CAXPY-C) -C***KEYWORDS BLAS, LINEAR ALGEBRA, TRIAD, 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 SA single precision scalar multiplier -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 SY single precision result (unchanged if N .LE. 0) -C -C Overwrite single precision SY with single precision SA*SX +SY. -C For I = 0 to N-1, replace SY(LY+I*INCY) with SA*SX(LX+I*INCX) + -C 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 SAXPY - REAL SX(*), SY(*), SA -C***FIRST EXECUTABLE STATEMENT SAXPY - IF (N.LE.0 .OR. SA.EQ.0.0E0) RETURN - IF (INCX .EQ. INCY) IF (INCX-1) 5,20,60 -C -C Code for unequal or nonpositive increments. -C - 5 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 - SY(IY) = SY(IY) + SA*SX(IX) - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -C -C Code for both increments equal to 1. -C -C Clean-up loop so remaining vector length is a multiple of 4. -C - 20 M = MOD(N,4) - IF (M .EQ. 0) GO TO 40 - DO 30 I = 1,M - SY(I) = SY(I) + SA*SX(I) - 30 CONTINUE - IF (N .LT. 4) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,4 - SY(I) = SY(I) + SA*SX(I) - SY(I+1) = SY(I+1) + SA*SX(I+1) - SY(I+2) = SY(I+2) + SA*SX(I+2) - SY(I+3) = SY(I+3) + SA*SX(I+3) - 50 CONTINUE - RETURN -C -C Code for equal, positive, non-unit increments. -C - 60 NS = N*INCX - DO 70 I = 1,NS,INCX - SY(I) = SA*SX(I) + SY(I) - 70 CONTINUE - RETURN - END diff --git a/slatec/sbcg.f b/slatec/sbcg.f deleted file mode 100644 index bad89db..0000000 --- a/slatec/sbcg.f +++ /dev/null @@ -1,375 +0,0 @@ -*DECK SBCG - SUBROUTINE SBCG (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, - + MSOLVE, MTSOLV, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, - + P, RR, ZZ, PP, DZ, RWORK, IWORK) -C***BEGIN PROLOGUE SBCG -C***PURPOSE Preconditioned BiConjugate Gradient Sparse Ax = b Solver. -C Routine to solve a Non-Symmetric linear system Ax = b -C using the Preconditioned BiConjugate Gradient method. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (SBCG-S, DBCG-D) -C***KEYWORDS BICONJUGATE GRADIENT, ITERATIVE PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) -C REAL B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N), P(N) -C REAL RR(N), ZZ(N), PP(N), DZ(N) -C REAL RWORK(USER DEFINED) -C EXTERNAL MATVEC, MTTVEC, MSOLVE, MTSOLV -C -C CALL SBCG(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, -C $ MSOLVE, MTSOLV, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, -C $ R, Z, P, RR, ZZ, PP, DZ, RWORK, IWORK) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Real B(N). -C Right-hand side vector. -C X :INOUT Real X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Real A(NELT). -C These arrays contain the matrix data structure for A. -C It could take any form. See "Description", below, for more -C details. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C MATVEC :EXT External. -C Name of a routine which performs the matrix vector multiply -C operation Y = A*X given A and X. The name of the MATVEC -C routine must be declared external in the calling program. -C The calling sequence of MATVEC is: -C CALL MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) -C Where N is the number of unknowns, Y is the product A*X upon -C return, X is an input vector. NELT, IA, JA, A and ISYM -C define the SLAP matrix data structure: see Description,below. -C MTTVEC :EXT External. -C Name of a routine which performs the matrix transpose vector -C multiply y = A'*X given A and X (where ' denotes transpose). -C The name of the MTTVEC routine must be declared external in -C the calling program. The calling sequence to MTTVEC is the -C same as that for MTTVEC, viz.: -C CALL MTTVEC( N, X, Y, NELT, IA, JA, A, ISYM ) -C Where N is the number of unknowns, Y is the product A'*X -C upon return, X is an input vector. NELT, IA, JA, A and ISYM -C define the SLAP matrix data structure: see Description,below. -C MSOLVE :EXT External. -C Name of a routine which solves a linear system MZ = R for Z -C given R with the preconditioning matrix M (M is supplied via -C RWORK and IWORK arrays). The name of the MSOLVE routine -C must be declared external in the calling program. The -C calling sequence of MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, R is the right-hand side -C vector, and Z is the solution upon return. NELT, IA, JA, A -C and ISYM define the SLAP matrix data structure: see -C Description, below. RWORK is a real array that can be used -C to pass necessary preconditioning information and/or -C workspace to MSOLVE. IWORK is an integer work array for the -C same purpose as RWORK. -C MTSOLV :EXT External. -C Name of a routine which solves a linear system M'ZZ = RR for -C ZZ given RR with the preconditioning matrix M (M is supplied -C via RWORK and IWORK arrays). The name of the MTSOLV routine -C must be declared external in the calling program. The call- -C ing sequence to MTSOLV is: -C CALL MTSOLV(N, RR, ZZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, RR is the right-hand side -C vector, and ZZ is the solution upon return. NELT, IA, JA, A -C and ISYM define the SLAP matrix data structure: see -C Description, below. RWORK is a real array that can be used -C to pass necessary preconditioning information and/or -C workspace to MTSOLV. IWORK is an integer work array for the -C same purpose as RWORK. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /SSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Real. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Real. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*R1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C R :WORK Real R(N). -C Z :WORK Real Z(N). -C P :WORK Real P(N). -C RR :WORK Real RR(N). -C ZZ :WORK Real ZZ(N). -C PP :WORK Real PP(N). -C DZ :WORK Real DZ(N). -C Real arrays used for workspace. -C RWORK :WORK Real RWORK(USER DEFINED). -C Real array that can be used for workspace in MSOLVE -C and MTSOLV. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used for workspace in MSOLVE -C and MTSOLV. -C -C *Description -C This routine does not care what matrix data structure is used -C for A and M. It simply calls MATVEC, MTTVEC, MSOLVE, MTSOLV -C routines, with arguments as above. The user could write any -C type of structure, and appropriate MATVEC, MSOLVE, MTTVEC, -C and MTSOLV routines. It is assumed that A is stored in the -C IA, JA, A arrays in some fashion and that M (or INV(M)) is -C stored in IWORK and RWORK in some fashion. The SLAP -C routines SSDBCG and SSLUBC are examples of this procedure. -C -C Two examples of matrix data structures are the: 1) SLAP -C Triad format and 2) SLAP Column format. -C -C =================== S L A P Triad format =================== -C In this format only the non-zeros are stored. They may -C appear in *ANY* order. The user supplies three arrays of -C length NELT, where NELT is the number of non-zeros in the -C matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero -C the user puts the row and column index of that matrix -C element in the IA and JA arrays. The value of the non-zero -C matrix element is placed in the corresponding location of -C the A array. This is an extremely easy data structure to -C generate. On the other hand it is not too efficient on -C vector computers for the iterative solution of linear -C systems. Hence, SLAP changes this input data structure to -C the SLAP Column format for the iteration (but does not -C change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C In this format the non-zeros are stored counting down -C columns (except for the diagonal entry, which must appear -C first in each "column") and are stored in the real array A. -C In other words, for each column in the matrix put the -C diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have JA(N+1) -C = NELT+1, where N is the number of columns in the matrix and -C NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO SSDBCG, SSLUBC -C***REFERENCES 1. Mark K. Seager, A SLAP for the Masses, in -C G. F. Carey, Ed., Parallel Supercomputing: Methods, -C Algorithms and Applications, Wiley, 1989, pp.135-155. -C***ROUTINES CALLED ISSBCG, R1MACH, SAXPY, SCOPY, SDOT -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 891004 Added new reference. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MATVEC, MTTVEC, MSOLVE, MTSOLV from ROUTINES -C CALLED list. (FNF) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of reference. (FNF) -C 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE SBCG -C .. Scalar Arguments .. - REAL ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT -C .. Array Arguments .. - REAL A(NELT), B(N), DZ(N), P(N), PP(N), R(N), RR(N), RWORK(*), - + X(N), Z(N), ZZ(N) - INTEGER IA(NELT), IWORK(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MATVEC, MSOLVE, MTSOLV, MTTVEC -C .. Local Scalars .. - REAL AK, AKDEN, BK, BKDEN, BKNUM, BNRM, FUZZ, SOLNRM, TOLMIN - INTEGER I, K -C .. External Functions .. - REAL R1MACH, SDOT - INTEGER ISSBCG - EXTERNAL R1MACH, SDOT, ISSBCG -C .. External Subroutines .. - EXTERNAL SAXPY, SCOPY -C .. Intrinsic Functions .. - INTRINSIC ABS -C***FIRST EXECUTABLE STATEMENT SBCG -C -C Check some of the input data. -C - ITER = 0 - IERR = 0 - IF( N.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF - FUZZ = R1MACH(3) - TOLMIN = 500*FUZZ - FUZZ = FUZZ*FUZZ - IF( TOL.LT.TOLMIN ) THEN - TOL = TOLMIN - IERR = 4 - ENDIF -C -C Calculate initial residual and pseudo-residual, and check -C stopping criterion. - CALL MATVEC(N, X, R, NELT, IA, JA, A, ISYM) - DO 10 I = 1, N - R(I) = B(I) - R(I) - RR(I) = R(I) - 10 CONTINUE - CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) - CALL MTSOLV(N, RR, ZZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C - IF( ISSBCG(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, - $ ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, RR, ZZ, PP, - $ DZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) .NE. 0 ) - $ GO TO 200 - IF( IERR.NE.0 ) RETURN -C -C ***** iteration loop ***** -C - DO 100 K=1,ITMAX - ITER = K -C -C Calculate coefficient BK and direction vectors P and PP. - BKNUM = SDOT(N, Z, 1, RR, 1) - IF( ABS(BKNUM).LE.FUZZ ) THEN - IERR = 6 - RETURN - ENDIF - IF(ITER .EQ. 1) THEN - CALL SCOPY(N, Z, 1, P, 1) - CALL SCOPY(N, ZZ, 1, PP, 1) - ELSE - BK = BKNUM/BKDEN - DO 20 I = 1, N - P(I) = Z(I) + BK*P(I) - PP(I) = ZZ(I) + BK*PP(I) - 20 CONTINUE - ENDIF - BKDEN = BKNUM -C -C Calculate coefficient AK, new iterate X, new residuals R and -C RR, and new pseudo-residuals Z and ZZ. - CALL MATVEC(N, P, Z, NELT, IA, JA, A, ISYM) - AKDEN = SDOT(N, PP, 1, Z, 1) - AK = BKNUM/AKDEN - IF( ABS(AKDEN).LE.FUZZ ) THEN - IERR = 6 - RETURN - ENDIF - CALL SAXPY(N, AK, P, 1, X, 1) - CALL SAXPY(N, -AK, Z, 1, R, 1) - CALL MTTVEC(N, PP, ZZ, NELT, IA, JA, A, ISYM) - CALL SAXPY(N, -AK, ZZ, 1, RR, 1) - CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) - CALL MTSOLV(N, RR, ZZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C -C check stopping criterion. - IF( ISSBCG(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, - $ ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, RR, ZZ, - $ PP, DZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) .NE. 0 ) - $ GO TO 200 -C - 100 CONTINUE -C -C ***** end of loop ***** -C -C stopping criterion not satisfied. - ITER = ITMAX + 1 - IERR = 2 -C - 200 RETURN -C------------- LAST LINE OF SBCG FOLLOWS ---------------------------- - END diff --git a/slatec/sbhin.f b/slatec/sbhin.f deleted file mode 100644 index d220c6c..0000000 --- a/slatec/sbhin.f +++ /dev/null @@ -1,286 +0,0 @@ -*DECK SBHIN - SUBROUTINE SBHIN (N, NELT, IA, JA, A, ISYM, SOLN, RHS, IUNIT, JOB) -C***BEGIN PROLOGUE SBHIN -C***PURPOSE Read a Sparse Linear System in the Boeing/Harwell Format. -C The matrix is read in and if the right hand side is also -C present in the input file then it too is read in. The -C matrix is then modified to be in the SLAP Column format. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY N1 -C***TYPE SINGLE PRECISION (SBHIN-S, DBHIN-D) -C***KEYWORDS LINEAR SYSTEM, MATRIX READ, SLAP SPARSE -C***AUTHOR Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, IUNIT, JOB -C REAL A(NELT), SOLN(N), RHS(N) -C -C CALL SBHIN( N, NELT, IA, JA, A, ISYM, SOLN, RHS, IUNIT, JOB ) -C -C *Arguments: -C N :OUT Integer -C Order of the Matrix. -C NELT :INOUT Integer. -C On input NELT is the maximum number of non-zeros that -C can be stored in the IA, JA, A arrays. -C On output NELT is the number of non-zeros stored in A. -C IA :OUT Integer IA(NELT). -C JA :OUT Integer JA(NELT). -C A :OUT Real A(NELT). -C On output these arrays hold the matrix A in the SLAP -C Triad format. See "Description", below. -C ISYM :OUT Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the lower -C triangle of the matrix is stored. -C SOLN :OUT Real SOLN(N). -C The solution to the linear system, if present. This array -C is accessed if and only if JOB is set to read it in, see -C below. If the user requests that SOLN be read in, but it is -C not in the file, then it is simply zeroed out. -C RHS :OUT Real RHS(N). -C The right hand side vector. This array is accessed if and -C only if JOB is set to read it in, see below. -C If the user requests that RHS be read in, but it is not in -C the file, then it is simply zeroed out. -C IUNIT :IN Integer. -C Fortran logical I/O device unit number to read the matrix -C from. This unit must be connected in a system dependent -C fashion to a file, or you will get a nasty message -C from the Fortran I/O libraries. -C JOB :INOUT Integer. -C Flag indicating what I/O operations to perform. -C On input JOB indicates what Input operations to try to -C perform. -C JOB = 0 => Read only the matrix. -C JOB = 1 => Read matrix and RHS (if present). -C JOB = 2 => Read matrix and SOLN (if present). -C JOB = 3 => Read matrix, RHS and SOLN (if present). -C On output JOB indicates what operations were actually -C performed. -C JOB = -3 => Unable to parse matrix "CODE" from input file -C to determine if only the lower triangle of matrix -C is stored. -C JOB = -2 => Number of non-zeros (NELT) too large. -C JOB = -1 => System size (N) too large. -C JOB = 0 => Read in only the matrix. -C JOB = 1 => Read in the matrix and RHS. -C JOB = 2 => Read in the matrix and SOLN. -C JOB = 3 => Read in the matrix, RHS and SOLN. -C JOB = 10 => Read in only the matrix *STRUCTURE*, but no -C non-zero entries. Hence, A(*) is not referenced -C and has the return values the same as the input. -C JOB = 11 => Read in the matrix *STRUCTURE* and RHS. -C JOB = 12 => Read in the matrix *STRUCTURE* and SOLN. -C JOB = 13 => Read in the matrix *STRUCTURE*, RHS and SOLN. -C -C *Description: -C The format for the input is as follows. The first line contains -C a title to identify the data file. On the second line (5I4) are -C counters: NLINE, NPLS, NRILS, NNVLS, NRHSLS. -C NLINE Number of data lines (after the header) in the file. -C NPLS Number of lines for the Column Pointer data in the file. -C NRILS Number of lines for the Row indices in the file. -C NNVLS Number of lines for the Matrix elements in the file. -C NRHSLS Number of lines for the RHS in the file. -C The third line (A3,11X,4I4) contains a symmetry code and some -C additional counters: CODE, NROW, NCOL, NIND, NELE. -C On the fourth line (2A16,2A20) are formats to be used to read -C the following data: PNTFNT, RINFMT, NVLFMT, RHSFMT. -C Following that are the blocks of data in the order indicated. -C -C =================== S L A P Triad format =================== -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Portability: -C You must make sure that IUNIT is a valid Fortran logical -C I/O device unit number and that the unit number has been -C associated with a file or the console. This is a system -C dependent function. -C -C *Implementation note: -C SOLN is not read by this version. It will simply be -C zeroed out if JOB = 2 or 3 and the returned value of -C JOB will indicate SOLN has not been read. -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 881107 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 911122 Added loop to zero out RHS if user wants to read RHS, but -C it's not in the input file. (MKS) -C 911125 Minor improvements to prologue. (FNF) -C 920511 Added complete declaration section. (WRB) -C 921007 Corrected description of input format. (FNF) -C 921208 Added Implementation Note and code to zero out SOLN. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE SBHIN -C .. Scalar Arguments .. - INTEGER ISYM, IUNIT, JOB, N, NELT -C .. Array Arguments .. - REAL A(NELT), RHS(N), SOLN(N) - INTEGER IA(NELT), JA(NELT) -C .. Local Scalars .. - REAL TEMP - INTEGER I, IBGN, ICOL, IEND, ITEMP, J, JOBRET, NCOL, NELE, NIND, - + NLINE, NNVLS, NPLS, NRHSLS, NRILS, NROW - CHARACTER CODE*3, PNTFMT*16, RINFMT*16, NVLFMT*20, RHSFMT*20, - + TITLE*80 -C .. Intrinsic Functions .. - INTRINSIC MOD -C***FIRST EXECUTABLE STATEMENT SBHIN -C -C Read Matrices In BOEING-HARWELL format. -C -C TITLE Header line to identify data file. -C NLINE Number of data lines (after the header) in the file. -C NPLS Number of lines for the Column Pointer data in the file. -C NRILS Number of lines for the Row indices in the data file. -C NNVLS Number of lines for the Matrix elements in the data file. -C NRHSLS Number of lines for the RHS in the data file. -C ---- Only those variables needed by SLAP are referenced. ---- -C - READ(IUNIT,9000) TITLE - READ(IUNIT,9010) NLINE, NPLS, NRILS, NNVLS, NRHSLS - READ(IUNIT,9020) CODE, NROW, NCOL, NIND, NELE - READ(IUNIT,9030) PNTFMT, RINFMT, NVLFMT, RHSFMT -C - IF( NROW.GT.N ) THEN - N = NROW - JOBRET = -1 - GOTO 999 - ENDIF - IF( NIND.GT.NELT ) THEN - NELT = NIND - JOBRET = -2 - GOTO 999 - ENDIF -C -C Set the parameters. -C - N = NROW - NELT = NIND - IF( CODE.EQ.'RUA' ) THEN - ISYM = 0 - ELSE IF( CODE.EQ.'RSA' ) THEN - ISYM = 1 - ELSE - JOBRET = -3 - GOTO 999 - ENDIF - READ(IUNIT,PNTFMT) (JA(I), I = 1, N+1) - READ(IUNIT,RINFMT) (IA(I), I = 1, NELT) - JOBRET = 10 - IF( NNVLS.GT.0 ) THEN - READ(IUNIT,NVLFMT) (A(I), I = 1, NELT) - JOBRET = 0 - ENDIF - IF( MOD(JOB,2).EQ.1 ) THEN -C -C User requests that the RHS be read in. If it is in the input -C file, read it in; otherwise just zero it out. -C - IF( NRHSLS.GT.0 ) THEN - READ(5,RHSFMT) (RHS(I), I = 1, N) - JOBRET = JOBRET + 1 - ELSE - DO 10 I = 1, N - RHS(I) = 0 - 10 CONTINUE - ENDIF - ENDIF - IF ( (JOB.EQ.2).OR.(JOB.EQ.3) ) THEN -C -C User requests that the SOLN be read in. -C Just zero out the array. -C - DO 20 I = 1, N - SOLN(I) = 0 - 20 CONTINUE - ENDIF -C -C Now loop through the IA array making sure that the diagonal -C matrix element appears first in the column. Then sort the -C rest of the column in ascending order. -C -CVD$R NOCONCUR -CVD$R NOVECTOR - DO 70 ICOL = 1, N - IBGN = JA(ICOL) - IEND = JA(ICOL+1)-1 - DO 30 I = IBGN, IEND - IF( IA(I).EQ.ICOL ) THEN -C -C Swap the diagonal element with the first element in the -C column. -C - ITEMP = IA(I) - IA(I) = IA(IBGN) - IA(IBGN) = ITEMP - TEMP = A(I) - A(I) = A(IBGN) - A(IBGN) = TEMP - GOTO 40 - ENDIF - 30 CONTINUE - 40 IBGN = IBGN + 1 - IF( IBGN.LT.IEND ) THEN - DO 60 I = IBGN, IEND - DO 50 J = I+1, IEND - IF( IA(I).GT.IA(J) ) THEN - ITEMP = IA(I) - IA(I) = IA(J) - IA(J) = ITEMP - TEMP = A(I) - A(I) = A(J) - A(J) = TEMP - ENDIF - 50 CONTINUE - 60 CONTINUE - ENDIF - 70 CONTINUE -C -C Set return flag. - 999 JOB = JOBRET - RETURN - 9000 FORMAT( A80 ) - 9010 FORMAT( 5I14 ) - 9020 FORMAT( A3, 11X, 4I14 ) - 9030 FORMAT( 2A16, 2A20 ) -C------------- LAST LINE OF SBHIN FOLLOWS ------------------------------ - END diff --git a/slatec/sbocls.f b/slatec/sbocls.f deleted file mode 100644 index d22da99..0000000 --- a/slatec/sbocls.f +++ /dev/null @@ -1,1146 +0,0 @@ -*DECK SBOCLS - SUBROUTINE SBOCLS (W, MDW, MCON, MROWS, NCOLS, BL, BU, IND, IOPT, - + X, RNORMC, RNORM, MODE, RW, IW) -C***BEGIN PROLOGUE SBOCLS -C***PURPOSE Solve the bounded and constrained least squares -C problem consisting of solving the equation -C E*X = F (in the least squares sense) -C subject to the linear constraints -C C*X = Y. -C***LIBRARY SLATEC -C***CATEGORY K1A2A, G2E, G2H1, G2H2 -C***TYPE SINGLE PRECISION (SBOCLS-S, DBOCLS-D) -C***KEYWORDS BOUNDS, CONSTRAINTS, INEQUALITY, LEAST SQUARES, LINEAR -C***AUTHOR Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C This subprogram solves the bounded and constrained least squares -C problem. The problem statement is: -C -C Solve E*X = F (least squares sense), subject to constraints -C C*X=Y. -C -C In this formulation both X and Y are unknowns, and both may -C have bounds on any of their components. This formulation -C of the problem allows the user to have equality and inequality -C constraints as well as simple bounds on the solution components. -C -C This constrained linear least squares subprogram solves E*X=F -C subject to C*X=Y, where E is MROWS by NCOLS, C is MCON by NCOLS. -C -C The user must have dimension statements of the form -C -C DIMENSION W(MDW,NCOLS+MCON+1), BL(NCOLS+MCON), BU(NCOLS+MCON), -C * X(2*(NCOLS+MCON)+2+NX), RW(6*NCOLS+5*MCON) -C INTEGER IND(NCOLS+MCON), IOPT(17+NI), IW(2*(NCOLS+MCON)) -C -C (here NX=number of extra locations required for the options; NX=0 -C if no options are in use. Also NI=number of extra locations -C for options 1-9.) -C -C INPUT -C ----- -C -C ------------------------- -C W(MDW,*),MCON,MROWS,NCOLS -C ------------------------- -C The array W contains the (possibly null) matrix [C:*] followed by -C [E:F]. This must be placed in W as follows: -C [C : *] -C W = [ ] -C [E : F] -C The (*) after C indicates that this data can be undefined. The -C matrix [E:F] has MROWS rows and NCOLS+1 columns. The matrix C is -C placed in the first MCON rows of W(*,*) while [E:F] -C follows in rows MCON+1 through MCON+MROWS of W(*,*). The vector F -C is placed in rows MCON+1 through MCON+MROWS, column NCOLS+1. The -C values of MDW and NCOLS must be positive; the value of MCON must -C be nonnegative. An exception to this occurs when using option 1 -C for accumulation of blocks of equations. In that case MROWS is an -C OUTPUT variable only, and the matrix data for [E:F] is placed in -C W(*,*), one block of rows at a time. See IOPT(*) contents, option -C number 1, for further details. The row dimension, MDW, of the -C array W(*,*) must satisfy the inequality: -C -C If using option 1, -C MDW .ge. MCON + max(max. number of -C rows accumulated, NCOLS) + 1. -C If using option 8, -C MDW .ge. MCON + MROWS. -C Else -C MDW .ge. MCON + max(MROWS, NCOLS). -C -C Other values are errors, but this is checked only when using -C option=2. The value of MROWS is an output parameter when -C using option number 1 for accumulating large blocks of least -C squares equations before solving the problem. -C See IOPT(*) contents for details about option 1. -C -C ------------------ -C BL(*),BU(*),IND(*) -C ------------------ -C These arrays contain the information about the bounds that the -C solution values are to satisfy. The value of IND(J) tells the -C type of bound and BL(J) and BU(J) give the explicit values for -C the respective upper and lower bounds on the unknowns X and Y. -C The first NVARS entries of IND(*), BL(*) and BU(*) specify -C bounds on X; the next MCON entries specify bounds on Y. -C -C 1. For IND(J)=1, require X(J) .ge. BL(J); -C IF J.gt.NCOLS, Y(J-NCOLS) .ge. BL(J). -C (the value of BU(J) is not used.) -C 2. For IND(J)=2, require X(J) .le. BU(J); -C IF J.gt.NCOLS, Y(J-NCOLS) .le. BU(J). -C (the value of BL(J) is not used.) -C 3. For IND(J)=3, require X(J) .ge. BL(J) and -C X(J) .le. BU(J); -C IF J.gt.NCOLS, Y(J-NCOLS) .ge. BL(J) and -C Y(J-NCOLS) .le. BU(J). -C (to impose equality constraints have BL(J)=BU(J)= -C constraining value.) -C 4. For IND(J)=4, no bounds on X(J) or Y(J-NCOLS) are required. -C (the values of BL(J) and BU(J) are not used.) -C -C Values other than 1,2,3 or 4 for IND(J) are errors. In the case -C IND(J)=3 (upper and lower bounds) the condition BL(J) .gt. BU(J) -C is an error. The values BL(J), BU(J), J .gt. NCOLS, will be -C changed. Significant changes mean that the constraints are -C infeasible. (Users must make this decision themselves.) -C The new values for BL(J), BU(J), J .gt. NCOLS, define a -C region such that the perturbed problem is feasible. If users -C know that their problem is feasible, this step can be skipped -C by using option number 8 described below. -C -C See IOPT(*) description. -C -C -C ------- -C IOPT(*) -C ------- -C This is the array where the user can specify nonstandard options -C for SBOCLS( ). Most of the time this feature can be ignored by -C setting the input value IOPT(1)=99. Occasionally users may have -C needs that require use of the following subprogram options. For -C details about how to use the options see below: IOPT(*) CONTENTS. -C -C Option Number Brief Statement of Purpose -C ------ ------ ----- --------- -- ------- -C 1 Return to user for accumulation of blocks -C of least squares equations. The values -C of IOPT(*) are changed with this option. -C The changes are updates to pointers for -C placing the rows of equations into position -C for processing. -C 2 Check lengths of all arrays used in the -C subprogram. -C 3 Column scaling of the data matrix, [C]. -C [E] -C 4 User provides column scaling for matrix [C]. -C [E] -C 5 Provide option array to the low-level -C subprogram SBOLS( ). -C 6 Provide option array to the low-level -C subprogram SBOLSM( ). -C 7 Move the IOPT(*) processing pointer. -C 8 Do not preprocess the constraints to -C resolve infeasibilities. -C 9 Do not pretriangularize the least squares matrix. -C 99 No more options to change. -C -C ---- -C X(*) -C ---- -C This array is used to pass data associated with options 4,5 and -C 6. Ignore this parameter (on input) if no options are used. -C Otherwise see below: IOPT(*) CONTENTS. -C -C -C OUTPUT -C ------ -C -C ----------------- -C X(*),RNORMC,RNORM -C ----------------- -C The array X(*) contains a solution (if MODE .ge.0 or .eq.-22) for -C the constrained least squares problem. The value RNORMC is the -C minimum residual vector length for the constraints C*X - Y = 0. -C The value RNORM is the minimum residual vector length for the -C least squares equations. Normally RNORMC=0, but in the case of -C inconsistent constraints this value will be nonzero. -C The values of X are returned in the first NVARS entries of X(*). -C The values of Y are returned in the last MCON entries of X(*). -C -C ---- -C MODE -C ---- -C The sign of MODE determines whether the subprogram has completed -C normally, or encountered an error condition or abnormal status. A -C value of MODE .ge. 0 signifies that the subprogram has completed -C normally. The value of mode (.ge. 0) is the number of variables -C in an active status: not at a bound nor at the value zero, for -C the case of free variables. A negative value of MODE will be one -C of the cases (-57)-(-41), (-37)-(-22), (-19)-(-2). Values .lt. -1 -C correspond to an abnormal completion of the subprogram. These -C error messages are in groups for the subprograms SBOCLS(), -C SBOLSM(), and SBOLS(). An approximate solution will be returned -C to the user only when max. iterations is reached, MODE=-22. -C -C ----------- -C RW(*),IW(*) -C ----------- -C These are working arrays. (normally the user can ignore the -C contents of these arrays.) -C -C IOPT(*) CONTENTS -C ------- -------- -C The option array allows a user to modify some internal variables -C in the subprogram without recompiling the source code. A central -C goal of the initial software design was to do a good job for most -C people. Thus the use of options will be restricted to a select -C group of users. The processing of the option array proceeds as -C follows: a pointer, here called LP, is initially set to the value -C 1. At the pointer position the option number is extracted and -C used for locating other information that allows for options to be -C changed. The portion of the array IOPT(*) that is used for each -C option is fixed; the user and the subprogram both know how many -C locations are needed for each option. The value of LP is updated -C for each option based on the amount of storage in IOPT(*) that is -C required. A great deal of error checking is done by the -C subprogram on the contents of the option array. Nevertheless it -C is still possible to give the subprogram optional input that is -C meaningless. For example option 4 uses the locations -C X(NCOLS+IOFF),...,X(NCOLS+IOFF+NCOLS-1) for passing scaling data. -C The user must manage the allocation of these locations. -C -C 1 -C - -C This option allows the user to solve problems with a large number -C of rows compared to the number of variables. The idea is that the -C subprogram returns to the user (perhaps many times) and receives -C new least squares equations from the calling program unit. -C Eventually the user signals "that's all" and a solution is then -C computed. The value of MROWS is an output variable when this -C option is used. Its value is always in the range 0 .le. MROWS -C .le. NCOLS+1. It is the number of rows after the -C triangularization of the entire set of equations. If LP is the -C processing pointer for IOPT(*), the usage for the sequential -C processing of blocks of equations is -C -C -C IOPT(LP)=1 -C Move block of equations to W(*,*) starting at -C the first row of W(*,*). -C IOPT(LP+3)=# of rows in the block; user defined -C -C The user now calls SBOCLS( ) in a loop. The value of IOPT(LP+1) -C directs the user's action. The value of IOPT(LP+2) points to -C where the subsequent rows are to be placed in W(*,*). Both of -C these values are first defined in the subprogram. The user -C changes the value of IOPT(LP+1) (to 2) as a signal that all of -C the rows have been processed. -C -C -C . All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*R1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C R :WORK Real R(N). -C Z :WORK Real Z(N). -C P :WORK Real P(N). -C DZ :WORK Real DZ(N). -C Real arrays used for workspace. -C RWORK :WORK Real RWORK(USER DEFINED). -C Real array that can be used by MSOLVE. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used by MSOLVE. -C -C *Description -C This routine does not care what matrix data structure is -C used for A and M. It simply calls the MATVEC and MSOLVE -C routines, with the arguments as described above. The user -C could write any type of structure and the appropriate MATVEC -C and MSOLVE routines. It is assumed that A is stored in the -C IA, JA, A arrays in some fashion and that M (or INV(M)) is -C stored in IWORK and RWORK in some fashion. The SLAP -C routines SSDCG and SSICCG are examples of this procedure. -C -C Two examples of matrix data structures are the: 1) SLAP -C Triad format and 2) SLAP Column format. -C -C =================== S L A P Triad format =================== -C -C In this format only the non-zeros are stored. They may -C appear in *ANY* order. The user supplies three arrays of -C length NELT, where NELT is the number of non-zeros in the -C matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero -C the user puts the row and column index of that matrix -C element in the IA and JA arrays. The value of the non-zero -C matrix element is placed in the corresponding location of -C the A array. This is an extremely easy data structure to -C generate. On the other hand it is not too efficient on -C vector computers for the iterative solution of linear -C systems. Hence, SLAP changes this input data structure to -C the SLAP Column format for the iteration (but does not -C change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C In this format the non-zeros are stored counting down -C columns (except for the diagonal entry, which must appear -C first in each "column") and are stored in the real array A. -C In other words, for each column in the matrix put the -C diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have JA(N+1) -C = NELT+1, where N is the number of columns in the matrix and -C NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO SSDCG, SSICCG -C***REFERENCES 1. Louis Hageman and David Young, Applied Iterative -C Methods, Academic Press, New York, 1981. -C 2. Concus, Golub and O'Leary, A Generalized Conjugate -C Gradient Method for the Numerical Solution of -C Elliptic Partial Differential Equations, in Sparse -C Matrix Computations, Bunch and Rose, Eds., Academic -C Press, New York, 1979. -C 3. Mark K. Seager, A SLAP for the Masses, in -C G. F. Carey, Ed., Parallel Supercomputing: Methods, -C Algorithms and Applications, Wiley, 1989, pp.135-155. -C***ROUTINES CALLED ISSCG, R1MACH, SAXPY, SCOPY, SDOT -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 891004 Added new reference. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MATVEC and MSOLVE from ROUTINES CALLED list. (FNF) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of references. (FNF) -C 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) -C***END PROLOGUE SCG -C .. Scalar Arguments .. - REAL ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT -C .. Array Arguments .. - REAL A(NELT), B(N), DZ(N), P(N), R(N), RWORK(*), X(N), Z(N) - INTEGER IA(NELT), IWORK(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MATVEC, MSOLVE -C .. Local Scalars .. - REAL AK, AKDEN, BK, BKDEN, BKNUM, BNRM, SOLNRM, TOLMIN - INTEGER I, K -C .. External Functions .. - REAL R1MACH, SDOT - INTEGER ISSCG - EXTERNAL R1MACH, SDOT, ISSCG -C .. External Subroutines .. - EXTERNAL SAXPY, SCOPY -C***FIRST EXECUTABLE STATEMENT SCG -C -C Check some of the input data. -C - ITER = 0 - IERR = 0 - IF( N.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF - TOLMIN = 500*R1MACH(3) - IF( TOL.LT.TOLMIN ) THEN - TOL = TOLMIN - IERR = 4 - ENDIF -C -C Calculate initial residual and pseudo-residual, and check -C stopping criterion. - CALL MATVEC(N, X, R, NELT, IA, JA, A, ISYM) - DO 10 I = 1, N - R(I) = B(I) - R(I) - 10 CONTINUE - CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C - IF( ISSCG(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, - $ ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, DZ, - $ RWORK, IWORK, AK, BK, BNRM, SOLNRM) .NE. 0 ) GO TO 200 - IF( IERR.NE.0 ) RETURN -C -C ***** Iteration loop ***** -C - DO 100 K=1,ITMAX - ITER = K -C -C Calculate coefficient bk and direction vector p. - BKNUM = SDOT(N, Z, 1, R, 1) - IF( BKNUM.LE.0.0E0 ) THEN - IERR = 5 - RETURN - ENDIF - IF(ITER .EQ. 1) THEN - CALL SCOPY(N, Z, 1, P, 1) - ELSE - BK = BKNUM/BKDEN - DO 20 I = 1, N - P(I) = Z(I) + BK*P(I) - 20 CONTINUE - ENDIF - BKDEN = BKNUM -C -C Calculate coefficient ak, new iterate x, new residual r, -C and new pseudo-residual z. - CALL MATVEC(N, P, Z, NELT, IA, JA, A, ISYM) - AKDEN = SDOT(N, P, 1, Z, 1) - IF( AKDEN.LE.0.0E0 ) THEN - IERR = 6 - RETURN - ENDIF - AK = BKNUM/AKDEN - CALL SAXPY(N, AK, P, 1, X, 1) - CALL SAXPY(N, -AK, Z, 1, R, 1) - CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C -C check stopping criterion. - IF( ISSCG(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, - $ ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, DZ, RWORK, - $ IWORK, AK, BK, BNRM, SOLNRM) .NE. 0 ) GO TO 200 -C - 100 CONTINUE -C -C ***** end of loop ***** -C -C stopping criterion not satisfied. - ITER = ITMAX + 1 - IERR = 2 -C - 200 RETURN -C------------- LAST LINE OF SCG FOLLOWS ----------------------------- - END diff --git a/slatec/scgn.f b/slatec/scgn.f deleted file mode 100644 index 81f4656..0000000 --- a/slatec/scgn.f +++ /dev/null @@ -1,371 +0,0 @@ -*DECK SCGN - SUBROUTINE SCGN (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, - + MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, ATP, - + ATZ, DZ, ATDZ, RWORK, IWORK) -C***BEGIN PROLOGUE SCGN -C***PURPOSE Preconditioned CG Sparse Ax=b Solver for Normal Equations. -C Routine to solve a general linear system Ax = b using the -C Preconditioned Conjugate Gradient method applied to the -C normal equations AA'y = b, x=A'y. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (SCGN-S, DCGN-D) -C***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM SOLVE, -C NORMAL EQUATIONS., SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) -C REAL B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N) -C REAL P(N), ATP(N), ATZ(N), DZ(N), ATDZ(N) -C REAL RWORK(USER DEFINED) -C EXTERNAL MATVEC, MTTVEC, MSOLVE -C -C CALL SCGN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, -C $ MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, -C $ Z, P, ATP, ATZ, DZ, ATDZ, RWORK, IWORK) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Real B(N). -C Right-hand side vector. -C X :INOUT Real X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Real A(NELT). -C These arrays contain the matrix data structure for A. -C It could take any form. See "Description", below, -C for more details. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C MATVEC :EXT External. -C Name of a routine which performs the matrix vector multiply -C y = A*X given A and X. The name of the MATVEC routine must -C be declared external in the calling program. The calling -C sequence to MATVEC is: -C CALL MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) -C Where N is the number of unknowns, Y is the product A*X -C upon return X is an input vector, NELT is the number of -C non-zeros in the SLAP-Column IA, JA, A storage for the matrix -C A. ISYM is a flag which, if non-zero, denotes that A is -C symmetric and only the lower or upper triangle is stored. -C MTTVEC :EXT External. -C Name of a routine which performs the matrix transpose vector -C multiply y = A'*X given A and X (where ' denotes transpose). -C The name of the MTTVEC routine must be declared external in -C the calling program. The calling sequence to MTTVEC is the -C same as that for MATVEC, viz.: -C CALL MTTVEC( N, X, Y, NELT, IA, JA, A, ISYM ) -C Where N is the number of unknowns, Y is the product A'*X -C upon return X is an input vector, NELT is the number of -C non-zeros in the SLAP-Column IA, JA, A storage for the matrix -C A. ISYM is a flag which, if non-zero, denotes that A is -C symmetric and only the lower or upper triangle is stored. -C MSOLVE :EXT External. -C Name of a routine which solves a linear system MZ = R for -C Z given R with the preconditioning matrix M (M is supplied via -C RWORK and IWORK arrays). The name of the MSOLVE routine must -C be declared external in the calling program. The calling -C sequence to MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, R is the right-hand side -C vector and Z is the solution upon return. NELT, IA, JA, A and -C ISYM are defined as above. RWORK is a real array that can -C be used to pass necessary preconditioning information and/or -C workspace to MSOLVE. IWORK is an integer work array for -C the same purpose as RWORK. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /SSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Real. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Real. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*R1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C R :WORK Real R(N). -C Z :WORK Real Z(N). -C P :WORK Real P(N). -C ATP :WORK Real ATP(N). -C ATZ :WORK Real ATZ(N). -C DZ :WORK Real DZ(N). -C ATDZ :WORK Real ATDZ(N). -C Real arrays used for workspace. -C RWORK :WORK Real RWORK(USER DEFINED). -C Real array that can be used by MSOLVE. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used by MSOLVE. -C -C *Description: -C This routine applies the preconditioned conjugate gradient -C (PCG) method to a non-symmetric system of equations Ax=b. To -C do this the normal equations are solved: -C AA' y = b, where x = A'y. -C In PCG method the iteration count is determined by condition -C -1 -C number of the matrix (M A). In the situation where the -C normal equations are used to solve a non-symmetric system -C the condition number depends on AA' and should therefore be -C much worse than that of A. This is the conventional wisdom. -C When one has a good preconditioner for AA' this may not hold. -C The latter is the situation when SCGN should be tried. -C -C If one is trying to solve a symmetric system, SCG should be -C used instead. -C -C This routine does not care what matrix data structure is -C used for A and M. It simply calls MATVEC, MTTVEC and MSOLVE -C routines, with arguments as described above. The user could -C write any type of structure, and appropriate MATVEC, MTTVEC -C and MSOLVE routines. It is assumed that A is stored in the -C IA, JA, A arrays in some fashion and that M (or INV(M)) is -C stored in IWORK and RWORK) in some fashion. The SLAP -C routines SSDCGN and SSLUCN are examples of this procedure. -C -C Two examples of matrix data structures are the: 1) SLAP -C Triad format and 2) SLAP Column format. -C -C =================== S L A P Triad format =================== -C -C In this format only the non-zeros are stored. They may -C appear in *ANY* order. The user supplies three arrays of -C length NELT, where NELT is the number of non-zeros in the -C matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero -C the user puts the row and column index of that matrix -C element in the IA and JA arrays. The value of the non-zero -C matrix element is placed in the corresponding location of -C the A array. This is an extremely easy data structure to -C generate. On the other hand it is not too efficient on -C vector computers for the iterative solution of linear -C systems. Hence, SLAP changes this input data structure to -C the SLAP Column format for the iteration (but does not -C change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C In this format the non-zeros are stored counting down -C columns (except for the diagonal entry, which must appear -C first in each "column") and are stored in the real array A. -C In other words, for each column in the matrix put the -C diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have JA(N+1) -C = NELT+1, where N is the number of columns in the matrix and -C NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO SSDCGN, SSLUCN, ISSCGN -C***REFERENCES 1. Mark K. Seager, A SLAP for the Masses, in -C G. F. Carey, Ed., Parallel Supercomputing: Methods, -C Algorithms and Applications, Wiley, 1989, pp.135-155. -C***ROUTINES CALLED ISSCGN, R1MACH, SAXPY, SCOPY, SDOT -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 891004 Added new reference. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MATVEC, MTTVEC and MSOLVE from ROUTINES CALLED -C list. (FNF) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of reference. (FNF) -C 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE SCGN -C .. Scalar Arguments .. - REAL ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT -C .. Array Arguments .. - REAL A(N), ATDZ(N), ATP(N), ATZ(N), B(N), DZ(N), P(N), R(N), - + RWORK(*), X(N), Z(N) - INTEGER IA(NELT), IWORK(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MATVEC, MSOLVE, MTTVEC -C .. Local Scalars .. - REAL AK, AKDEN, BK, BKDEN, BKNUM, BNRM, SOLNRM, TOLMIN - INTEGER I, K -C .. External Functions .. - REAL R1MACH, SDOT - INTEGER ISSCGN - EXTERNAL R1MACH, SDOT, ISSCGN -C .. External Subroutines .. - EXTERNAL SAXPY, SCOPY -C***FIRST EXECUTABLE STATEMENT SCGN -C -C Check user input. -C - ITER = 0 - IERR = 0 - IF( N.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF - TOLMIN = 500*R1MACH(3) - IF( TOL.LT.TOLMIN ) THEN - TOL = TOLMIN - IERR = 4 - ENDIF -C Calculate initial residual and pseudo-residual, and check -C stopping criterion. - CALL MATVEC(N, X, R, NELT, IA, JA, A, ISYM) - DO 10 I = 1, N - R(I) = B(I) - R(I) - 10 CONTINUE - CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) - CALL MTTVEC(N, Z, ATZ, NELT, IA, JA, A, ISYM) -C - IF( ISSCGN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, MSOLVE, - $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, ATP, ATZ, - $ DZ, ATDZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) .NE. 0 ) - $ GO TO 200 - IF( IERR.NE.0 ) RETURN -C -C ***** iteration loop ***** -C - DO 100 K=1,ITMAX - ITER = K -C -C Calculate coefficient BK and direction vector P. - BKNUM = SDOT(N, Z, 1, R, 1) - IF( BKNUM.LE.0.0E0 ) THEN - IERR = 6 - RETURN - ENDIF - IF(ITER .EQ. 1) THEN - CALL SCOPY(N, Z, 1, P, 1) - ELSE - BK = BKNUM/BKDEN - DO 20 I = 1, N - P(I) = Z(I) + BK*P(I) - 20 CONTINUE - ENDIF - BKDEN = BKNUM -C -C Calculate coefficient AK, new iterate X, new residual R, -C and new pseudo-residual ATZ. - IF(ITER .NE. 1) CALL SAXPY(N, BK, ATP, 1, ATZ, 1) - CALL SCOPY(N, ATZ, 1, ATP, 1) - AKDEN = SDOT(N, ATP, 1, ATP, 1) - IF( AKDEN.LE.0.0E0 ) THEN - IERR = 6 - RETURN - ENDIF - AK = BKNUM/AKDEN - CALL SAXPY(N, AK, ATP, 1, X, 1) - CALL MATVEC(N, ATP, Z, NELT, IA, JA, A, ISYM) - CALL SAXPY(N, -AK, Z, 1, R, 1) - CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) - CALL MTTVEC(N, Z, ATZ, NELT, IA, JA, A, ISYM) -C -C check stopping criterion. - IF( ISSCGN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, - $ MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, - $ Z, P, ATP, ATZ, DZ, ATDZ, RWORK, IWORK, AK, BK, BNRM, - $ SOLNRM) .NE. 0) GOTO 200 -C - 100 CONTINUE -C -C ***** end of loop ***** -C -C stopping criterion not satisfied. - ITER = ITMAX + 1 -C - 200 RETURN -C------------- LAST LINE OF SCGN FOLLOWS ---------------------------- - END diff --git a/slatec/scgs.f b/slatec/scgs.f deleted file mode 100644 index a964961..0000000 --- a/slatec/scgs.f +++ /dev/null @@ -1,374 +0,0 @@ -*DECK SCGS - SUBROUTINE SCGS (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, - + ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, R0, P, Q, U, V1, - + V2, RWORK, IWORK) -C***BEGIN PROLOGUE SCGS -C***PURPOSE Preconditioned BiConjugate Gradient Squared Ax=b Solver. -C Routine to solve a Non-Symmetric linear system Ax = b -C using the Preconditioned BiConjugate Gradient Squared -C method. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (SCGS-S, DCGS-D) -C***KEYWORDS BICONJUGATE GRADIENT, ITERATIVE PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) -C REAL B(N), X(N), A(NELT), TOL, ERR, R(N), R0(N), P(N) -C REAL Q(N), U(N), V1(N), V2(N), RWORK(USER DEFINED) -C EXTERNAL MATVEC, MSOLVE -C -C CALL SCGS(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, -C $ MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, -C $ R, R0, P, Q, U, V1, V2, RWORK, IWORK) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Real B(N). -C Right-hand side vector. -C X :INOUT Real X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Real A(NELT). -C These arrays contain the matrix data structure for A. -C It could take any form. See "Description", below, -C for more details. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C MATVEC :EXT External. -C Name of a routine which performs the matrix vector multiply -C operation Y = A*X given A and X. The name of the MATVEC -C routine must be declared external in the calling program. -C The calling sequence of MATVEC is: -C CALL MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) -C Where N is the number of unknowns, Y is the product A*X upon -C return, X is an input vector. NELT, IA, JA, A and ISYM -C define the SLAP matrix data structure: see Description,below. -C MSOLVE :EXT External. -C Name of a routine which solves a linear system MZ = R for Z -C given R with the preconditioning matrix M (M is supplied via -C RWORK and IWORK arrays). The name of the MSOLVE routine -C must be declared external in the calling program. The -C calling sequence of MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, R is the right-hand side -C vector, and Z is the solution upon return. NELT, IA, JA, A -C and ISYM define the SLAP matrix data structure: see -C Description, below. RWORK is a real array that can be used -C to pass necessary preconditioning information and/or -C workspace to MSOLVE. IWORK is an integer work array for the -C same purpose as RWORK. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C This routine must calculate the residual from R = A*X - B. -C This is unnatural and hence expensive for this type of iter- -C ative method. ITOL=2 is *STRONGLY* recommended. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv time a vector is the pre- -C conditioning step. This is the *NATURAL* stopping for this -C iterative method and is *STRONGLY* recommended. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /SSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. -C TOL :INOUT Real. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Real. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*R1MACH(3). Iteration proceeded. -C IERR = 5 => Breakdown of the method detected. -C (r0,r) approximately 0. -C IERR = 6 => Stagnation of the method detected. -C (r0,v) approximately 0. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C R :WORK Real R(N). -C R0 :WORK Real R0(N). -C P :WORK Real P(N). -C Q :WORK Real Q(N). -C U :WORK Real U(N). -C V1 :WORK Real V1(N). -C V2 :WORK Real V2(N). -C Real arrays used for workspace. -C RWORK :WORK Real RWORK(USER DEFINED). -C Real array that can be used for workspace in MSOLVE. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used for workspace in MSOLVE. -C -C *Description -C This routine does not care what matrix data structure is -C used for A and M. It simply calls the MATVEC and MSOLVE -C routines, with the arguments as described above. The user -C could write any type of structure and the appropriate MATVEC -C and MSOLVE routines. It is assumed that A is stored in the -C IA, JA, A arrays in some fashion and that M (or INV(M)) is -C stored in IWORK and RWORK in some fashion. The SLAP -C routines SSDBCG and SSLUCS are examples of this procedure. -C -C Two examples of matrix data structures are the: 1) SLAP -C Triad format and 2) SLAP Column format. -C -C =================== S L A P Triad format =================== -C -C In this format only the non-zeros are stored. They may -C appear in *ANY* order. The user supplies three arrays of -C length NELT, where NELT is the number of non-zeros in the -C matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero -C the user puts the row and column index of that matrix -C element in the IA and JA arrays. The value of the non-zero -C matrix element is placed in the corresponding location of -C the A array. This is an extremely easy data structure to -C generate. On the other hand it is not too efficient on -C vector computers for the iterative solution of linear -C systems. Hence, SLAP changes this input data structure to -C the SLAP Column format for the iteration (but does not -C change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C In this format the non-zeros are stored counting down -C columns (except for the diagonal entry, which must appear -C first in each "column") and are stored in the real array A. -C In other words, for each column in the matrix put the -C diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have JA(N+1) -C = NELT+1, where N is the number of columns in the matrix and -C NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO SSDCGS, SSLUCS -C***REFERENCES 1. P. Sonneveld, CGS, a fast Lanczos-type solver -C for nonsymmetric linear systems, Delft University -C of Technology Report 84-16, Department of Mathe- -C matics and Informatics, Delft, The Netherlands. -C 2. E. F. Kaasschieter, The solution of non-symmetric -C linear systems by biconjugate gradients or conjugate -C gradients squared, Delft University of Technology -C Report 86-21, Department of Mathematics and Informa- -C tics, Delft, The Netherlands. -C 3. Mark K. Seager, A SLAP for the Masses, in -C G. F. Carey, Ed., Parallel Supercomputing: Methods, -C Algorithms and Applications, Wiley, 1989, pp.135-155. -C***ROUTINES CALLED ISSCGS, R1MACH, SAXPY, SDOT -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 891004 Added new reference. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MATVEC and MSOLVE from ROUTINES CALLED list. (FNF) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of references. (FNF) -C 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE SCGS -C .. Scalar Arguments .. - REAL ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT -C .. Array Arguments .. - REAL A(NELT), B(N), P(N), Q(N), R(N), R0(N), RWORK(*), U(N), - + V1(N), V2(N), X(N) - INTEGER IA(NELT), IWORK(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MATVEC, MSOLVE -C .. Local Scalars .. - REAL AK, AKM, BK, BNRM, FUZZ, RHON, RHONM1, SIGMA, SOLNRM, TOLMIN - INTEGER I, K -C .. External Functions .. - REAL R1MACH, SDOT - INTEGER ISSCGS - EXTERNAL R1MACH, SDOT, ISSCGS -C .. External Subroutines .. - EXTERNAL SAXPY -C .. Intrinsic Functions .. - INTRINSIC ABS -C***FIRST EXECUTABLE STATEMENT SCGS -C -C Check some of the input data. -C - ITER = 0 - IERR = 0 - IF( N.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF - TOLMIN = 500*R1MACH(3) - IF( TOL.LT.TOLMIN ) THEN - TOL = TOLMIN - IERR = 4 - ENDIF -C -C Calculate initial residual and pseudo-residual, and check -C stopping criterion. - CALL MATVEC(N, X, R, NELT, IA, JA, A, ISYM) - DO 10 I = 1, N - V1(I) = R(I) - B(I) - 10 CONTINUE - CALL MSOLVE(N, V1, R, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C - IF( ISSCGS(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, - $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, R0, P, Q, - $ U, V1, V2, RWORK, IWORK, AK, BK, BNRM, SOLNRM) .NE. 0 ) - $ GO TO 200 - IF( IERR.NE.0 ) RETURN -C -C Set initial values. -C - FUZZ = R1MACH(3)**2 - DO 20 I = 1, N - R0(I) = R(I) - 20 CONTINUE - RHONM1 = 1 -C -C ***** ITERATION LOOP ***** -C - DO 100 K=1,ITMAX - ITER = K -C -C Calculate coefficient BK and direction vectors U, V and P. - RHON = SDOT(N, R0, 1, R, 1) - IF( ABS(RHONM1).LT.FUZZ ) GOTO 998 - BK = RHON/RHONM1 - IF( ITER.EQ.1 ) THEN - DO 30 I = 1, N - U(I) = R(I) - P(I) = R(I) - 30 CONTINUE - ELSE - DO 40 I = 1, N - U(I) = R(I) + BK*Q(I) - V1(I) = Q(I) + BK*P(I) - 40 CONTINUE - DO 50 I = 1, N - P(I) = U(I) + BK*V1(I) - 50 CONTINUE - ENDIF -C -C Calculate coefficient AK, new iterate X, Q - CALL MATVEC(N, P, V2, NELT, IA, JA, A, ISYM) - CALL MSOLVE(N, V2, V1, NELT, IA, JA, A, ISYM, RWORK, IWORK) - SIGMA = SDOT(N, R0, 1, V1, 1) - IF( ABS(SIGMA).LT.FUZZ ) GOTO 999 - AK = RHON/SIGMA - AKM = -AK - DO 60 I = 1, N - Q(I) = U(I) + AKM*V1(I) - 60 CONTINUE - DO 70 I = 1, N - V1(I) = U(I) + Q(I) - 70 CONTINUE -C X = X - ak*V1. - CALL SAXPY( N, AKM, V1, 1, X, 1 ) -C -1 -C R = R - ak*M *A*V1 - CALL MATVEC(N, V1, V2, NELT, IA, JA, A, ISYM) - CALL MSOLVE(N, V2, V1, NELT, IA, JA, A, ISYM, RWORK, IWORK) - CALL SAXPY( N, AKM, V1, 1, R, 1 ) -C -C check stopping criterion. - IF( ISSCGS(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, - $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, R0, P, Q, - $ U, V1, V2, RWORK, IWORK, AK, BK, BNRM, SOLNRM) .NE. 0 ) - $ GO TO 200 -C -C Update RHO. - RHONM1 = RHON - 100 CONTINUE -C -C ***** end of loop ***** -C Stopping criterion not satisfied. - ITER = ITMAX + 1 - IERR = 2 - 200 RETURN -C -C Breakdown of method detected. - 998 IERR = 5 - RETURN -C -C Stagnation of method detected. - 999 IERR = 6 - RETURN -C------------- LAST LINE OF SCGS FOLLOWS ---------------------------- - END diff --git a/slatec/schdc.f b/slatec/schdc.f deleted file mode 100644 index 2f37925..0000000 --- a/slatec/schdc.f +++ /dev/null @@ -1,249 +0,0 @@ -*DECK SCHDC - SUBROUTINE SCHDC (A, LDA, P, WORK, JPVT, JOB, INFO) -C***BEGIN PROLOGUE SCHDC -C***PURPOSE Compute the Cholesky decomposition of a positive definite -C matrix. A pivoting option allows the user to estimate the -C condition number of a positive definite matrix or determine -C the rank of a positive semidefinite matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1B -C***TYPE SINGLE PRECISION (SCHDC-S, DCHDC-D, CCHDC-C) -C***KEYWORDS CHOLESKY DECOMPOSITION, LINEAR ALGEBRA, LINPACK, MATRIX, -C POSITIVE DEFINITE -C***AUTHOR Dongarra, J., (ANL) -C Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C SCHDC computes the Cholesky decomposition of a positive definite -C matrix. A pivoting option allows the user to estimate the -C condition of a positive definite matrix or determine the rank -C of a positive semidefinite matrix. -C -C On Entry -C -C A REAL(LDA,P). -C A contains the matrix whose decomposition is to -C be computed. Only the upper half of A need be stored. -C The lower part of the array A is not referenced. -C -C LDA INTEGER. -C LDA is the leading dimension of the array A. -C -C P INTEGER. -C P is the order of the matrix. -C -C WORK REAL. -C WORK is a work array. -C -C JPVT INTEGER(P). -C JPVT contains integers that control the selection -C of the pivot elements, if pivoting has been requested. -C Each diagonal element A(K,K) -C is placed in one of three classes according to the -C value of JPVT(K). -C -C If JPVT(K) .GT. 0, then X(K) is an initial -C element. -C -C If JPVT(K) .EQ. 0, then X(K) is a free element. -C -C If JPVT(K) .LT. 0, then X(K) is a final element. -C -C Before the decomposition is computed, initial elements -C are moved by symmetric row and column interchanges to -C the beginning of the array A and final -C elements to the end. Both initial and final elements -C are frozen in place during the computation and only -C free elements are moved. At the K-th stage of the -C reduction, if A(K,K) is occupied by a free element -C it is interchanged with the largest free element -C A(L,L) with L .GE. K. JPVT is not referenced if -C JOB .EQ. 0. -C -C JOB INTEGER. -C JOB is an integer that initiates column pivoting. -C If JOB .EQ. 0, no pivoting is done. -C If JOB .NE. 0, pivoting is done. -C -C On Return -C -C A A contains in its upper half the Cholesky factor -C of the matrix A as it has been permuted by pivoting. -C -C JPVT JPVT(J) contains the index of the diagonal element -C of a that was moved into the J-th position, -C provided pivoting was requested. -C -C INFO contains the index of the last positive diagonal -C element of the Cholesky factor. -C -C For positive definite matrices INFO = P is the normal return. -C For pivoting with positive semidefinite matrices INFO will -C in general be less than P. However, INFO may be greater than -C the rank of A, since rounding error can cause an otherwise zero -C element to be positive. Indefinite systems will always cause -C INFO to be less than P. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SAXPY, SSWAP -C***REVISION HISTORY (YYMMDD) -C 790319 DATE WRITTEN -C 890313 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SCHDC - INTEGER LDA,P,JPVT(*),JOB,INFO - REAL A(LDA,*),WORK(*) -C - INTEGER PU,PL,PLP1,J,JP,JT,K,KB,KM1,KP1,L,MAXL - REAL TEMP - REAL MAXDIA - LOGICAL SWAPK,NEGK -C***FIRST EXECUTABLE STATEMENT SCHDC - PL = 1 - PU = 0 - INFO = P - IF (JOB .EQ. 0) GO TO 160 -C -C PIVOTING HAS BEEN REQUESTED. REARRANGE THE -C THE ELEMENTS ACCORDING TO JPVT. -C - DO 70 K = 1, P - SWAPK = JPVT(K) .GT. 0 - NEGK = JPVT(K) .LT. 0 - JPVT(K) = K - IF (NEGK) JPVT(K) = -JPVT(K) - IF (.NOT.SWAPK) GO TO 60 - IF (K .EQ. PL) GO TO 50 - CALL SSWAP(PL-1,A(1,K),1,A(1,PL),1) - TEMP = A(K,K) - A(K,K) = A(PL,PL) - A(PL,PL) = TEMP - PLP1 = PL + 1 - IF (P .LT. PLP1) GO TO 40 - DO 30 J = PLP1, P - IF (J .GE. K) GO TO 10 - TEMP = A(PL,J) - A(PL,J) = A(J,K) - A(J,K) = TEMP - GO TO 20 - 10 CONTINUE - IF (J .EQ. K) GO TO 20 - TEMP = A(K,J) - A(K,J) = A(PL,J) - A(PL,J) = TEMP - 20 CONTINUE - 30 CONTINUE - 40 CONTINUE - JPVT(K) = JPVT(PL) - JPVT(PL) = K - 50 CONTINUE - PL = PL + 1 - 60 CONTINUE - 70 CONTINUE - PU = P - IF (P .LT. PL) GO TO 150 - DO 140 KB = PL, P - K = P - KB + PL - IF (JPVT(K) .GE. 0) GO TO 130 - JPVT(K) = -JPVT(K) - IF (PU .EQ. K) GO TO 120 - CALL SSWAP(K-1,A(1,K),1,A(1,PU),1) - TEMP = A(K,K) - A(K,K) = A(PU,PU) - A(PU,PU) = TEMP - KP1 = K + 1 - IF (P .LT. KP1) GO TO 110 - DO 100 J = KP1, P - IF (J .GE. PU) GO TO 80 - TEMP = A(K,J) - A(K,J) = A(J,PU) - A(J,PU) = TEMP - GO TO 90 - 80 CONTINUE - IF (J .EQ. PU) GO TO 90 - TEMP = A(K,J) - A(K,J) = A(PU,J) - A(PU,J) = TEMP - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE - JT = JPVT(K) - JPVT(K) = JPVT(PU) - JPVT(PU) = JT - 120 CONTINUE - PU = PU - 1 - 130 CONTINUE - 140 CONTINUE - 150 CONTINUE - 160 CONTINUE - DO 270 K = 1, P -C -C REDUCTION LOOP. -C - MAXDIA = A(K,K) - KP1 = K + 1 - MAXL = K -C -C DETERMINE THE PIVOT ELEMENT. -C - IF (K .LT. PL .OR. K .GE. PU) GO TO 190 - DO 180 L = KP1, PU - IF (A(L,L) .LE. MAXDIA) GO TO 170 - MAXDIA = A(L,L) - MAXL = L - 170 CONTINUE - 180 CONTINUE - 190 CONTINUE -C -C QUIT IF THE PIVOT ELEMENT IS NOT POSITIVE. -C - IF (MAXDIA .GT. 0.0E0) GO TO 200 - INFO = K - 1 - GO TO 280 - 200 CONTINUE - IF (K .EQ. MAXL) GO TO 210 -C -C START THE PIVOTING AND UPDATE JPVT. -C - KM1 = K - 1 - CALL SSWAP(KM1,A(1,K),1,A(1,MAXL),1) - A(MAXL,MAXL) = A(K,K) - A(K,K) = MAXDIA - JP = JPVT(MAXL) - JPVT(MAXL) = JPVT(K) - JPVT(K) = JP - 210 CONTINUE -C -C REDUCTION STEP. PIVOTING IS CONTAINED ACROSS THE ROWS. -C - WORK(K) = SQRT(A(K,K)) - A(K,K) = WORK(K) - IF (P .LT. KP1) GO TO 260 - DO 250 J = KP1, P - IF (K .EQ. MAXL) GO TO 240 - IF (J .GE. MAXL) GO TO 220 - TEMP = A(K,J) - A(K,J) = A(J,MAXL) - A(J,MAXL) = TEMP - GO TO 230 - 220 CONTINUE - IF (J .EQ. MAXL) GO TO 230 - TEMP = A(K,J) - A(K,J) = A(MAXL,J) - A(MAXL,J) = TEMP - 230 CONTINUE - 240 CONTINUE - A(K,J) = A(K,J)/WORK(K) - WORK(J) = A(K,J) - TEMP = -A(K,J) - CALL SAXPY(J-K,TEMP,WORK(KP1),1,A(KP1,J),1) - 250 CONTINUE - 260 CONTINUE - 270 CONTINUE - 280 CONTINUE - RETURN - END diff --git a/slatec/schdd.f b/slatec/schdd.f deleted file mode 100644 index 17d2cee..0000000 --- a/slatec/schdd.f +++ /dev/null @@ -1,201 +0,0 @@ -*DECK SCHDD - SUBROUTINE SCHDD (R, LDR, P, X, Z, LDZ, NZ, Y, RHO, C, S, INFO) -C***BEGIN PROLOGUE SCHDD -C***PURPOSE Downdate an augmented Cholesky decomposition or the -C triangular factor of an augmented QR decomposition. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D7B -C***TYPE SINGLE PRECISION (SCHDD-S, DCHDD-D, CCHDD-C) -C***KEYWORDS CHOLESKY DECOMPOSITION, DOWNDATE, LINEAR ALGEBRA, LINPACK, -C MATRIX -C***AUTHOR Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C SCHDD downdates an augmented Cholesky decomposition or the -C triangular factor of an augmented QR decomposition. -C Specifically, given an upper triangular matrix R of order P, a -C row vector X, a column vector Z, and a scalar Y, SCHDD -C determines an orthogonal matrix U and a scalar ZETA such that -C -C (R Z ) (RR ZZ) -C U * ( ) = ( ) , -C (0 ZETA) ( X Y) -C -C where RR is upper triangular. If R and Z have been obtained -C from the factorization of a least squares problem, then -C RR and ZZ are the factors corresponding to the problem -C with the observation (X,Y) removed. In this case, if RHO -C is the norm of the residual vector, then the norm of -C the residual vector of the downdated problem is -C SQRT(RHO**2 - ZETA**2). SCHDD will simultaneously downdate -C several triplets (Z,Y,RHO) along with R. -C For a less terse description of what SCHDD does and how -C it may be applied, see the LINPACK guide. -C -C The matrix U is determined as the product U(1)*...*U(P) -C where U(I) is a rotation in the (P+1,I)-plane of the -C form -C -C ( C(I) -S(I) ) -C ( ) . -C ( S(I) C(I) ) -C -C The rotations are chosen so that C(I) is real. -C -C The user is warned that a given downdating problem may -C be impossible to accomplish or may produce -C inaccurate results. For example, this can happen -C if X is near a vector whose removal will reduce the -C rank of R. Beware. -C -C On Entry -C -C R REAL(LDR,P), where LDR .GE. P. -C R contains the upper triangular matrix -C that is to be downdated. The part of R -C below the diagonal is not referenced. -C -C LDR INTEGER. -C LDR is the leading dimension of the array R. -C -C P INTEGER. -C P is the order of the matrix R. -C -C X REAL(P). -C X contains the row vector that is to -C be removed from R. X is not altered by SCHDD. -C -C Z REAL(LDZ,NZ), where LDZ .GE. P. -C Z is an array of NZ P-vectors which -C are to be downdated along with R. -C -C LDZ INTEGER. -C LDZ is the leading dimension of the array Z. -C -C NZ INTEGER. -C NZ is the number of vectors to be downdated -C NZ may be zero, in which case Z, Y, and RHO -C are not referenced. -C -C Y REAL(NZ). -C Y contains the scalars for the downdating -C of the vectors Z. Y is not altered by SCHDD. -C -C RHO REAL(NZ). -C RHO contains the norms of the residual -C vectors that are to be downdated. -C -C On Return -C -C R -C Z contain the downdated quantities. -C RHO -C -C C REAL(P). -C C contains the cosines of the transforming -C rotations. -C -C S REAL(P). -C S contains the sines of the transforming -C rotations. -C -C INFO INTEGER. -C INFO is set as follows. -C -C INFO = 0 if the entire downdating -C was successful. -C -C INFO =-1 if R could not be downdated. -C In this case, all quantities -C are left unaltered. -C -C INFO = 1 if some RHO could not be -C downdated. The offending RHOs are -C set to -1. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SDOT, SNRM2 -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SCHDD - INTEGER LDR,P,LDZ,NZ,INFO - REAL R(LDR,*),X(*),Z(LDZ,*),Y(*),S(*) - REAL RHO(*),C(*) -C - INTEGER I,II,J - REAL A,ALPHA,AZETA,NORM,SNRM2 - REAL SDOT,T,ZETA,B,XX -C -C SOLVE THE SYSTEM TRANS(R)*A = X, PLACING THE RESULT -C IN THE ARRAY S. -C -C***FIRST EXECUTABLE STATEMENT SCHDD - INFO = 0 - S(1) = X(1)/R(1,1) - IF (P .LT. 2) GO TO 20 - DO 10 J = 2, P - S(J) = X(J) - SDOT(J-1,R(1,J),1,S,1) - S(J) = S(J)/R(J,J) - 10 CONTINUE - 20 CONTINUE - NORM = SNRM2(P,S,1) - IF (NORM .LT. 1.0E0) GO TO 30 - INFO = -1 - GO TO 120 - 30 CONTINUE - ALPHA = SQRT(1.0E0-NORM**2) -C -C DETERMINE THE TRANSFORMATIONS. -C - DO 40 II = 1, P - I = P - II + 1 - SCALE = ALPHA + ABS(S(I)) - A = ALPHA/SCALE - B = S(I)/SCALE - NORM = SQRT(A**2+B**2) - C(I) = A/NORM - S(I) = B/NORM - ALPHA = SCALE*NORM - 40 CONTINUE -C -C APPLY THE TRANSFORMATIONS TO R. -C - DO 60 J = 1, P - XX = 0.0E0 - DO 50 II = 1, J - I = J - II + 1 - T = C(I)*XX + S(I)*R(I,J) - R(I,J) = C(I)*R(I,J) - S(I)*XX - XX = T - 50 CONTINUE - 60 CONTINUE -C -C IF REQUIRED, DOWNDATE Z AND RHO. -C - IF (NZ .LT. 1) GO TO 110 - DO 100 J = 1, NZ - ZETA = Y(J) - DO 70 I = 1, P - Z(I,J) = (Z(I,J) - S(I)*ZETA)/C(I) - ZETA = C(I)*ZETA - S(I)*Z(I,J) - 70 CONTINUE - AZETA = ABS(ZETA) - IF (AZETA .LE. RHO(J)) GO TO 80 - INFO = 1 - RHO(J) = -1.0E0 - GO TO 90 - 80 CONTINUE - RHO(J) = RHO(J)*SQRT(1.0E0-(AZETA/RHO(J))**2) - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE - RETURN - END diff --git a/slatec/schex.f b/slatec/schex.f deleted file mode 100644 index 5ad7946..0000000 --- a/slatec/schex.f +++ /dev/null @@ -1,266 +0,0 @@ -*DECK SCHEX - SUBROUTINE SCHEX (R, LDR, P, K, L, Z, LDZ, NZ, C, S, JOB) -C***BEGIN PROLOGUE SCHEX -C***PURPOSE Update the Cholesky factorization A=TRANS(R)*R of A -C positive definite matrix A of order P under diagonal -C permutations of the form TRANS(E)*A*E, where E is a -C permutation matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D7B -C***TYPE SINGLE PRECISION (SCHEX-S, DCHEX-D, CCHEX-C) -C***KEYWORDS CHOLESKY DECOMPOSITION, EXCHANGE, LINEAR ALGEBRA, LINPACK, -C MATRIX, POSITIVE DEFINITE -C***AUTHOR Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C SCHEX updates the Cholesky factorization -C -C A = TRANS(R)*R -C -C of a positive definite matrix A of order P under diagonal -C permutations of the form -C -C TRANS(E)*A*E -C -C where E is a permutation matrix. Specifically, given -C an upper triangular matrix R and a permutation matrix -C E (which is specified by K, L, and JOB), SCHEX determines -C an orthogonal matrix U such that -C -C U*R*E = RR, -C -C where RR is upper triangular. At the users option, the -C transformation U will be multiplied into the array Z. -C If A = TRANS(X)*X, so that R is the triangular part of the -C QR factorization of X, then RR is the triangular part of the -C QR factorization of X*E, i.e., X with its columns permuted. -C For a less terse description of what SCHEX does and how -C it may be applied, see the LINPACK guide. -C -C The matrix Q is determined as the product U(L-K)*...*U(1) -C of plane rotations of the form -C -C ( C(I) S(I) ) -C ( ) , -C ( -S(I) C(I) ) -C -C where C(I) is real. The rows these rotations operate on -C are described below. -C -C There are two types of permutations, which are determined -C by the value of JOB. -C -C 1. Right circular shift (JOB = 1). -C -C The columns are rearranged in the following order. -C -C 1,...,K-1,L,K,K+1,...,L-1,L+1,...,P. -C -C U is the product of L-K rotations U(I), where U(I) -C acts in the (L-I,L-I+1)-plane. -C -C 2. Left circular shift (JOB = 2). -C The columns are rearranged in the following order -C -C 1,...,K-1,K+1,K+2,...,L,K,L+1,...,P. -C -C U is the product of L-K rotations U(I), where U(I) -C acts in the (K+I-1,K+I)-plane. -C -C On Entry -C -C R REAL(LDR,P), where LDR .GE. P. -C R contains the upper triangular factor -C that is to be updated. Elements of R -C below the diagonal are not referenced. -C -C LDR INTEGER. -C LDR is the leading dimension of the array R. -C -C P INTEGER. -C P is the order of the matrix R. -C -C K INTEGER. -C K is the first column to be permuted. -C -C L INTEGER. -C L is the last column to be permuted. -C L must be strictly greater than K. -C -C Z REAL(LDZ,NZ), where LDZ.GE.P. -C Z is an array of NZ P-vectors into which the -C transformation U is multiplied. Z is -C not referenced if NZ = 0. -C -C LDZ INTEGER. -C LDZ is the leading dimension of the array Z. -C -C NZ INTEGER. -C NZ is the number of columns of the matrix Z. -C -C JOB INTEGER. -C JOB determines the type of permutation. -C JOB = 1 right circular shift. -C JOB = 2 left circular shift. -C -C On Return -C -C R contains the updated factor. -C -C Z contains the updated matrix Z. -C -C C REAL(P). -C C contains the cosines of the transforming rotations. -C -C S REAL(P). -C S contains the sines of the transforming rotations. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SROTG -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SCHEX - INTEGER LDR,P,K,L,LDZ,NZ,JOB - REAL R(LDR,*),Z(LDZ,*),S(*) - REAL C(*) -C - INTEGER I,II,IL,IU,J,JJ,KM1,KP1,LMK,LM1 - REAL T -C -C INITIALIZE -C -C***FIRST EXECUTABLE STATEMENT SCHEX - KM1 = K - 1 - KP1 = K + 1 - LMK = L - K - LM1 = L - 1 -C -C PERFORM THE APPROPRIATE TASK. -C - GO TO (10,130), JOB -C -C RIGHT CIRCULAR SHIFT. -C - 10 CONTINUE -C -C REORDER THE COLUMNS. -C - DO 20 I = 1, L - II = L - I + 1 - S(I) = R(II,L) - 20 CONTINUE - DO 40 JJ = K, LM1 - J = LM1 - JJ + K - DO 30 I = 1, J - R(I,J+1) = R(I,J) - 30 CONTINUE - R(J+1,J+1) = 0.0E0 - 40 CONTINUE - IF (K .EQ. 1) GO TO 60 - DO 50 I = 1, KM1 - II = L - I + 1 - R(I,K) = S(II) - 50 CONTINUE - 60 CONTINUE -C -C CALCULATE THE ROTATIONS. -C - T = S(1) - DO 70 I = 1, LMK - CALL SROTG(S(I+1),T,C(I),S(I)) - T = S(I+1) - 70 CONTINUE - R(K,K) = T - DO 90 J = KP1, P - IL = MAX(1,L-J+1) - DO 80 II = IL, LMK - I = L - II - T = C(II)*R(I,J) + S(II)*R(I+1,J) - R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J) - R(I,J) = T - 80 CONTINUE - 90 CONTINUE -C -C IF REQUIRED, APPLY THE TRANSFORMATIONS TO Z. -C - IF (NZ .LT. 1) GO TO 120 - DO 110 J = 1, NZ - DO 100 II = 1, LMK - I = L - II - T = C(II)*Z(I,J) + S(II)*Z(I+1,J) - Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J) - Z(I,J) = T - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE - GO TO 260 -C -C LEFT CIRCULAR SHIFT -C - 130 CONTINUE -C -C REORDER THE COLUMNS -C - DO 140 I = 1, K - II = LMK + I - S(II) = R(I,K) - 140 CONTINUE - DO 160 J = K, LM1 - DO 150 I = 1, J - R(I,J) = R(I,J+1) - 150 CONTINUE - JJ = J - KM1 - S(JJ) = R(J+1,J+1) - 160 CONTINUE - DO 170 I = 1, K - II = LMK + I - R(I,L) = S(II) - 170 CONTINUE - DO 180 I = KP1, L - R(I,L) = 0.0E0 - 180 CONTINUE -C -C REDUCTION LOOP. -C - DO 220 J = K, P - IF (J .EQ. K) GO TO 200 -C -C APPLY THE ROTATIONS. -C - IU = MIN(J-1,L-1) - DO 190 I = K, IU - II = I - K + 1 - T = C(II)*R(I,J) + S(II)*R(I+1,J) - R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J) - R(I,J) = T - 190 CONTINUE - 200 CONTINUE - IF (J .GE. L) GO TO 210 - JJ = J - K + 1 - T = S(JJ) - CALL SROTG(R(J,J),T,C(JJ),S(JJ)) - 210 CONTINUE - 220 CONTINUE -C -C APPLY THE ROTATIONS TO Z. -C - IF (NZ .LT. 1) GO TO 250 - DO 240 J = 1, NZ - DO 230 I = K, LM1 - II = I - KM1 - T = C(II)*Z(I,J) + S(II)*Z(I+1,J) - Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J) - Z(I,J) = T - 230 CONTINUE - 240 CONTINUE - 250 CONTINUE - 260 CONTINUE - RETURN - END diff --git a/slatec/schkw.f b/slatec/schkw.f deleted file mode 100644 index b7c2651..0000000 --- a/slatec/schkw.f +++ /dev/null @@ -1,112 +0,0 @@ -*DECK SCHKW - SUBROUTINE SCHKW (NAME, LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR) -C***BEGIN PROLOGUE SCHKW -C***SUBSIDIARY -C***PURPOSE SLAP WORK/IWORK Array Bounds Checker. -C This routine checks the work array lengths and interfaces -C to the SLATEC error handler if a problem is found. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY R2 -C***TYPE SINGLE PRECISION (SCHKW-S, DCHKW-D) -C***KEYWORDS ERROR CHECKING, SLAP, WORKSPACE CHECKING -C***AUTHOR Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C CHARACTER*(*) NAME -C INTEGER LOCIW, LENIW, LOCW, LENW, IERR, ITER -C REAL ERR -C -C CALL SCHKW( NAME, LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) -C -C *Arguments: -C NAME :IN Character*(*). -C Name of the calling routine. This is used in the output -C message, if an error is detected. -C LOCIW :IN Integer. -C Location of the first free element in the integer workspace -C array. -C LENIW :IN Integer. -C Length of the integer workspace array. -C LOCW :IN Integer. -C Location of the first free element in the real workspace -C array. -C LENRW :IN Integer. -C Length of the real workspace array. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient storage allocated for -C WORK or IWORK. -C ITER :OUT Integer. -C Set to zero on return. -C ERR :OUT Real. -C Set to the smallest positive magnitude if all went well. -C Set to a very large number if an error is detected. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 880225 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 900805 Changed XERRWV calls to calls to XERMSG. (RWC) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Corrected XERMSG calls to satisfy Section 6.2.2 of ANSI -C X3.9-1978. (FNF) -C 910506 Made subsidiary. (FNF) -C 920511 Added complete declaration section. (WRB) -C 921015 Added code to initialize ITER and ERR when IERR=0. (FNF) -C***END PROLOGUE SCHKW -C .. Scalar Arguments .. - REAL ERR - INTEGER IERR, ITER, LENIW, LENW, LOCIW, LOCW - CHARACTER NAME*(*) -C .. Local Scalars .. - CHARACTER XERN1*8, XERN2*8, XERNAM*8 -C .. External Functions .. - REAL R1MACH - EXTERNAL R1MACH -C .. External Subroutines .. - EXTERNAL XERMSG -C***FIRST EXECUTABLE STATEMENT SCHKW -C -C Check the Integer workspace situation. -C - IERR = 0 - ITER = 0 - ERR = R1MACH(1) - IF( LOCIW.GT.LENIW ) THEN - IERR = 1 - ERR = R1MACH(2) - XERNAM = NAME - WRITE (XERN1, '(I8)') LOCIW - WRITE (XERN2, '(I8)') LENIW - CALL XERMSG ('SLATEC', 'SCHKW', - $ 'In ' // XERNAM // ', INTEGER work array too short. ' // - $ 'IWORK needs ' // XERN1 // '; have allocated ' // XERN2, - $ 1, 1) - ENDIF -C -C Check the Real workspace situation. - IF( LOCW.GT.LENW ) THEN - IERR = 1 - ERR = R1MACH(2) - XERNAM = NAME - WRITE (XERN1, '(I8)') LOCW - WRITE (XERN2, '(I8)') LENW - CALL XERMSG ('SLATEC', 'SCHKW', - $ 'In ' // XERNAM // ', REAL work array too short. ' // - $ 'RWORK needs ' // XERN1 // '; have allocated ' // XERN2, - $ 1, 1) - ENDIF - RETURN -C------------- LAST LINE OF SCHKW FOLLOWS ---------------------------- - END diff --git a/slatec/schud.f b/slatec/schud.f deleted file mode 100644 index a0b3cbb..0000000 --- a/slatec/schud.f +++ /dev/null @@ -1,158 +0,0 @@ -*DECK SCHUD - SUBROUTINE SCHUD (R, LDR, P, X, Z, LDZ, NZ, Y, RHO, C, S) -C***BEGIN PROLOGUE SCHUD -C***PURPOSE Update an augmented Cholesky decomposition of the -C triangular part of an augmented QR decomposition. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D7B -C***TYPE SINGLE PRECISION (SCHUD-S, DCHUD-D, CCHUD-C) -C***KEYWORDS CHOLESKY DECOMPOSITION, LINEAR ALGEBRA, LINPACK, MATRIX, -C UPDATE -C***AUTHOR Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C SCHUD updates an augmented Cholesky decomposition of the -C triangular part of an augmented QR decomposition. Specifically, -C given an upper triangular matrix R of order P, a row vector -C X, a column vector Z, and a scalar Y, SCHUD determines a -C unitary matrix U and a scalar ZETA such that -C -C -C (R Z) (RR ZZ ) -C U * ( ) = ( ) , -C (X Y) ( 0 ZETA) -C -C where RR is upper triangular. If R and Z have been -C obtained from the factorization of a least squares -C problem, then RR and ZZ are the factors corresponding to -C the problem with the observation (X,Y) appended. In this -C case, if RHO is the norm of the residual vector, then the -C norm of the residual vector of the updated problem is -C SQRT(RHO**2 + ZETA**2). SCHUD will simultaneously update -C several triplets (Z,Y,RHO). -C For a less terse description of what SCHUD does and how -C it may be applied, see the LINPACK guide. -C -C The matrix U is determined as the product U(P)*...*U(1), -C where U(I) is a rotation in the (I,P+1) plane of the -C form -C -C ( C(I) S(I) ) -C ( ) . -C ( -S(I) C(I) ) -C -C The rotations are chosen so that C(I) is real. -C -C On Entry -C -C R REAL(LDR,P), where LDR .GE. P. -C R contains the upper triangular matrix -C that is to be updated. The part of R -C below the diagonal is not referenced. -C -C LDR INTEGER. -C LDR is the leading dimension of the array R. -C -C P INTEGER. -C P is the order of the matrix R. -C -C X REAL(P). -C X contains the row to be added to R. X is -C not altered by SCHUD. -C -C Z REAL(LDZ,NZ), where LDZ .GE. P. -C Z is an array containing NZ P-vectors to -C be updated with R. -C -C LDZ INTEGER. -C LDZ is the leading dimension of the array Z. -C -C NZ INTEGER. -C NZ is the number of vectors to be updated. -C NZ may be zero, in which case Z, Y, and RHO -C are not referenced. -C -C Y REAL(NZ). -C Y contains the scalars for updating the vectors -C Z. Y is not altered by SCHUD. -C -C RHO REAL(NZ). -C RHO contains the norms of the residual -C vectors that are to be updated. If RHO(J) -C is negative, it is left unaltered. -C -C On Return -C -C RC -C RHO contain the updated quantities. -C Z -C -C C REAL(P). -C C contains the cosines of the transforming -C rotations. -C -C S REAL(P). -C S contains the sines of the transforming -C rotations. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SROTG -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SCHUD - INTEGER LDR,P,LDZ,NZ - REAL RHO(*),C(*) - REAL R(LDR,*),X(*),Z(LDZ,*),Y(*),S(*) -C - INTEGER I,J,JM1 - REAL AZETA,SCALE - REAL T,XJ,ZETA -C -C UPDATE R. -C -C***FIRST EXECUTABLE STATEMENT SCHUD - DO 30 J = 1, P - XJ = X(J) -C -C APPLY THE PREVIOUS ROTATIONS. -C - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 20 - DO 10 I = 1, JM1 - T = C(I)*R(I,J) + S(I)*XJ - XJ = C(I)*XJ - S(I)*R(I,J) - R(I,J) = T - 10 CONTINUE - 20 CONTINUE -C -C COMPUTE THE NEXT ROTATION. -C - CALL SROTG(R(J,J),XJ,C(J),S(J)) - 30 CONTINUE -C -C IF REQUIRED, UPDATE Z AND RHO. -C - IF (NZ .LT. 1) GO TO 70 - DO 60 J = 1, NZ - ZETA = Y(J) - DO 40 I = 1, P - T = C(I)*Z(I,J) + S(I)*ZETA - ZETA = C(I)*ZETA - S(I)*Z(I,J) - Z(I,J) = T - 40 CONTINUE - AZETA = ABS(ZETA) - IF (AZETA .EQ. 0.0E0 .OR. RHO(J) .LT. 0.0E0) GO TO 50 - SCALE = AZETA + RHO(J) - RHO(J) = SCALE*SQRT((AZETA/SCALE)**2+(RHO(J)/SCALE)**2) - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE - RETURN - END diff --git a/slatec/sclosm.f b/slatec/sclosm.f deleted file mode 100644 index 5a5d9ae..0000000 --- a/slatec/sclosm.f +++ /dev/null @@ -1,33 +0,0 @@ -*DECK SCLOSM - SUBROUTINE SCLOSM (IPAGE) -C***BEGIN PROLOGUE SCLOSM -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE ALL (SCLOSM-A) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C 1. UNLOAD, RELEASE, OR CLOSE UNIT NUMBER IPAGEF. -C -C***SEE ALSO SPLP -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890605 Corrected references to XERRWV. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C***END PROLOGUE SCLOSM - CHARACTER*8 XERN1 -C -C***FIRST EXECUTABLE STATEMENT SCLOSM - IPAGEF=IPAGE - CLOSE(UNIT=IPAGEF,IOSTAT=IOS,ERR=100,STATUS='KEEP') - RETURN -C - 100 WRITE (XERN1, '(I8)') IOS - CALL XERMSG ('SLATEC', 'SCLOSM', - * 'IN SPLP, CLOSE HAS ERROR FLAG = ' // XERN1, 100, 1) - RETURN - END diff --git a/slatec/scnrm2.f b/slatec/scnrm2.f deleted file mode 100644 index f0a5d00..0000000 --- a/slatec/scnrm2.f +++ /dev/null @@ -1,171 +0,0 @@ -*DECK SCNRM2 - REAL FUNCTION SCNRM2 (N, CX, INCX) -C***BEGIN PROLOGUE SCNRM2 -C***PURPOSE Compute the unitary norm of a complex vector. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A3B -C***TYPE COMPLEX (SNRM2-S, DNRM2-D, SCNRM2-C) -C***KEYWORDS BLAS, EUCLIDEAN LENGTH, EUCLIDEAN NORM, L2, -C LINEAR ALGEBRA, UNITARY, 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 CX complex vector with N elements -C INCX storage spacing between elements of CX -C -C --Output-- -C SCNRM2 single precision result (zero if N .LE. 0) -C -C Unitary norm of the complex N-vector stored in CX with storage -C increment INCX. -C If N .LE. 0, return with result = 0. -C If N .GE. 1, then INCX must be .GE. 1 -C -C Four phase method using two built-in constants that are -C hopefully applicable to all machines. -C CUTLO = maximum of SQRT(U/EPS) over all known machines. -C CUTHI = minimum of SQRT(V) over all known machines. -C where -C EPS = smallest no. such that EPS + 1. .GT. 1. -C U = smallest positive no. (underflow limit) -C V = largest no. (overflow limit) -C -C Brief outline of algorithm. -C -C Phase 1 scans zero components. -C Move to phase 2 when a component is nonzero and .LE. CUTLO -C Move to phase 3 when a component is .GT. CUTLO -C Move to phase 4 when a component is .GE. CUTHI/M -C where M = N for X() real and M = 2*N for complex. -C -C Values for CUTLO and CUTHI. -C From the environmental parameters listed in the IMSL converter -C document the limiting values are as follows: -C CUTLO, S.P. U/EPS = 2**(-102) for Honeywell. Close seconds are -C Univac and DEC at 2**(-103) -C Thus CUTLO = 2**(-51) = 4.44089E-16 -C CUTHI, S.P. V = 2**127 for Univac, Honeywell, and DEC. -C Thus CUTHI = 2**(63.5) = 1.30438E19 -C CUTLO, D.P. U/EPS = 2**(-67) for Honeywell and DEC. -C Thus CUTLO = 2**(-33.5) = 8.23181D-11 -C CUTHI, D.P. same as S.P. CUTHI = 1.30438D19 -C DATA CUTLO, CUTHI /8.232D-11, 1.304D19/ -C DATA CUTLO, CUTHI /4.441E-16, 1.304E19/ -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 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SCNRM2 - LOGICAL IMAG, SCALE - INTEGER NEXT - REAL CUTLO, CUTHI, HITEST, SUM, XMAX, ABSX, ZERO, ONE - COMPLEX CX(*) - SAVE CUTLO, CUTHI, ZERO, ONE - DATA ZERO, ONE /0.0E0, 1.0E0/ -C - DATA CUTLO, CUTHI /4.441E-16, 1.304E19/ -C***FIRST EXECUTABLE STATEMENT SCNRM2 - IF (N .GT. 0) GO TO 10 - SCNRM2 = ZERO - GO TO 300 -C - 10 ASSIGN 30 TO NEXT - SUM = ZERO - NN = N * INCX -C -C BEGIN MAIN LOOP -C - DO 210 I = 1,NN,INCX - ABSX = ABS(REAL(CX(I))) - IMAG = .FALSE. - GO TO NEXT,(30, 50, 70, 90, 110) - 30 IF (ABSX .GT. CUTLO) GO TO 85 - ASSIGN 50 TO NEXT - SCALE = .FALSE. -C -C PHASE 1. SUM IS ZERO -C - 50 IF (ABSX .EQ. ZERO) GO TO 200 - IF (ABSX .GT. CUTLO) GO TO 85 -C -C PREPARE FOR PHASE 2. -C - ASSIGN 70 TO NEXT - GO TO 105 -C -C PREPARE FOR PHASE 4. -C - 100 ASSIGN 110 TO NEXT - SUM = (SUM / ABSX) / ABSX - 105 SCALE = .TRUE. - XMAX = ABSX - GO TO 115 -C -C PHASE 2. SUM IS SMALL. -C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. -C - 70 IF (ABSX .GT. CUTLO) GO TO 75 -C -C COMMON CODE FOR PHASES 2 AND 4. -C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. -C - 110 IF (ABSX .LE. XMAX) GO TO 115 - SUM = ONE + SUM * (XMAX / ABSX)**2 - XMAX = ABSX - GO TO 200 -C - 115 SUM = SUM + (ABSX/XMAX)**2 - GO TO 200 -C -C PREPARE FOR PHASE 3. -C - 75 SUM = (SUM * XMAX) * XMAX -C - 85 ASSIGN 90 TO NEXT - SCALE = .FALSE. -C -C FOR REAL OR D.P. SET HITEST = CUTHI/N -C FOR COMPLEX SET HITEST = CUTHI/(2*N) -C - HITEST = CUTHI / N -C -C PHASE 3. SUM IS MID-RANGE. NO SCALING. -C - 90 IF (ABSX .GE. HITEST) GO TO 100 - SUM = SUM + ABSX**2 - 200 CONTINUE -C -C CONTROL SELECTION OF REAL AND IMAGINARY PARTS. -C - IF (IMAG) GO TO 210 - ABSX = ABS(AIMAG(CX(I))) - IMAG = .TRUE. - GO TO NEXT,( 50, 70, 90, 110 ) -C - 210 CONTINUE -C -C END OF MAIN LOOP. -C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. -C - SCNRM2 = SQRT(SUM) - IF (SCALE) SCNRM2 = SCNRM2 * XMAX - 300 CONTINUE - RETURN - END diff --git a/slatec/scoef.f b/slatec/scoef.f deleted file mode 100644 index c53d812..0000000 --- a/slatec/scoef.f +++ /dev/null @@ -1,166 +0,0 @@ -*DECK SCOEF - SUBROUTINE SCOEF (YH, YP, NCOMP, NROWB, NFC, NIC, B, BETA, COEF, - + INHOMO, RE, AE, BY, CVEC, WORK, IWORK, IFLAG, NFCC) -C***BEGIN PROLOGUE SCOEF -C***SUBSIDIARY -C***PURPOSE Subsidiary to BVSUP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (SCOEF-S, DCOEF-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C ********************************************************************** -C INPUT TO SCOEF -C ********************************************************************** -C -C YH = Matrix of homogeneous solutions. -C YP = Vector containing particular solution. -C NCOMP = Number of components per solution vector. -C NROWB = First dimension of B in calling program. -C NFC = Number of base solution vectors. -C NFCC = 2*NFC for the special treatment of complex valued -C equations. Otherwise, NFCC=NFC. -C NIC = Number of specified initial conditions. -C B = Boundary condition matrix at X = Xfinal. -C BETA = Vector of nonhomogeneous boundary conditions at X = Xfinal. -C 1 - Nonzero particular solution -C INHOMO = 2 - Zero particular solution -C 3 - Eigenvalue problem -C RE = Relative error tolerance -C AE = Absolute error tolerance -C BY = Storage space for the matrix B*YH -C CVEC = Storage space for the vector BETA-B*YP -C WORK = Real array of internal storage. Dimension must be .GE. -C NFCC*(NFCC+4) -C IWORK = Integer array of internal storage. Dimension must be .GE. -C 3+NFCC -C -C ********************************************************************** -C OUTPUT FROM SCOEF -C ********************************************************************** -C -C COEF = Array containing superposition constants. -C IFLAG = Indicator of success from SUDS in solving the -C boundary equations -C = 0 Boundary equations are solved -C = 1 Boundary equations appear to have many solutions -C = 2 Boundary equations appear to be inconsistent -C = 3 For this value of an eigenparameter, the boundary -C equations have only the zero solution. -C -C ********************************************************************** -C -C Subroutine SCOEF solves for the superposition constants from the -C linear equations defined by the boundary conditions at X = Xfinal. -C -C B*YP + B*YH*COEF = BETA -C -C ********************************************************************** -C -C***SEE ALSO BVSUP -C***ROUTINES CALLED SDOT, SUDS, XGETF, XSETF -C***COMMON BLOCKS ML5MCO -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 890921 Realigned order of variables in certain COMMON blocks. -C (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE SCOEF -C - DIMENSION YH(NCOMP,*),YP(*),B(NROWB,*),BETA(*), - 1 COEF(*),BY(NFCC,*),CVEC(*),WORK(*),IWORK(*) -C - COMMON /ML5MCO/ URO,SRU,EPS,SQOVFL,TWOU,FOURU,LPAR -C -C SET UP MATRIX B*YH AND VECTOR BETA - B*YP -C -C***FIRST EXECUTABLE STATEMENT SCOEF - NCOMP2=NCOMP/2 - DO 7 K = 1,NFCC - DO 1 J = 1,NFC - L=J - IF (NFC .NE. NFCC) L=2*J-1 - 1 BY(K,L) = SDOT(NCOMP,B(K,1),NROWB,YH(1,J),1) - IF (NFC .EQ. NFCC) GO TO 3 - DO 2 J=1,NFC - L=2*J - BYKL=SDOT(NCOMP2,B(K,1),NROWB,YH(NCOMP2+1,J),1) - BY(K,L)=SDOT(NCOMP2,B(K,NCOMP2+1),NROWB,YH(1,J),1) - BYKL - 2 CONTINUE - 3 GO TO (4,5,6), INHOMO -C CASE 1 - 4 CVEC(K) = BETA(K) - SDOT(NCOMP,B(K,1),NROWB,YP,1) - GO TO 7 -C CASE 2 - 5 CVEC(K) = BETA(K) - GO TO 7 -C CASE 3 - 6 CVEC(K) = 0. - 7 CONTINUE - CONS=ABS(CVEC(1)) - BYS=ABS(BY(1,1)) -C -C ********************************************************************** -C SOLVE LINEAR SYSTEM -C - IFLAG=0 - MLSO=0 - IF (INHOMO .EQ. 3) MLSO=1 - KFLAG = 0.5 * LOG10(EPS) - CALL XGETF(NF) - CALL XSETF(0) - 10 CALL SUDS(BY,COEF,CVEC,NFCC,NFCC,NFCC,KFLAG,MLSO,WORK,IWORK) - IF (KFLAG .NE. 3) GO TO 13 - KFLAG=1 - IFLAG=1 - GO TO 10 - 13 IF (KFLAG .EQ. 4) IFLAG=2 - CALL XSETF(NF) - IF (NFCC .EQ. 1) GO TO 25 - IF (INHOMO .NE. 3) RETURN - IF (IWORK(1) .LT. NFCC) GO TO 17 - IFLAG=3 - DO 14 K=1,NFCC - 14 COEF(K)=0. - COEF(NFCC)=1. - NFCCM1=NFCC-1 - DO 15 K=1,NFCCM1 - J=NFCC-K - L=NFCC-J+1 - GAM=SDOT(L,BY(J,J),NFCC,COEF(J),1)/(WORK(J)*BY(J,J)) - DO 15 I=J,NFCC - 15 COEF(I)=COEF(I)+GAM*BY(J,I) - RETURN - 17 DO 20 K=1,NFCC - KI=4*NFCC+K - 20 COEF(K)=WORK(KI) - RETURN -C -C ********************************************************************** -C TESTING FOR EXISTENCE AND UNIQUENESS OF BOUNDARY-VALUE PROBLEM -C SOLUTION IN A SCALAR CASE -C - 25 BN = 0. - UN = 0. - YPN=0. - DO 30 K = 1,NCOMP - UN = MAX(UN,ABS(YH(K,1))) - YPN=MAX(YPN,ABS(YP(K))) - 30 BN = MAX(BN,ABS(B(1,K))) - BBN = MAX(BN,ABS(BETA(1))) - IF (BYS .GT. 10.*(RE*UN + AE)*BN) GO TO 35 - BRN = BBN / BN * BYS - IF (CONS .GE. 0.1*BRN .AND. CONS .LE. 10.*BRN) IFLAG=1 - IF (CONS .GT. 10.*BRN) IFLAG=2 - IF (CONS .LE. RE*ABS(BETA(1))+AE + (RE*YPN+AE)*BN) IFLAG=1 - IF (INHOMO .EQ. 3) COEF(1)=1. - RETURN - 35 IF (INHOMO .NE. 3) RETURN - IFLAG=3 - COEF(1)=1. - RETURN - END diff --git a/slatec/scopy.f b/slatec/scopy.f deleted file mode 100644 index 664b089..0000000 --- a/slatec/scopy.f +++ /dev/null @@ -1,93 +0,0 @@ -*DECK SCOPY - SUBROUTINE SCOPY (N, SX, INCX, SY, INCY) -C***BEGIN PROLOGUE SCOPY -C***PURPOSE Copy a vector. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A5 -C***TYPE SINGLE PRECISION (SCOPY-S, DCOPY-D, CCOPY-C, ICOPY-I) -C***KEYWORDS BLAS, COPY, 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 SY copy of vector SX (unchanged if N .LE. 0) -C -C Copy single precision SX to single precision SY. -C For I = 0 to N-1, copy SX(LX+I*INCX) to 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 SCOPY - REAL SX(*), SY(*) -C***FIRST EXECUTABLE STATEMENT SCOPY - IF (N .LE. 0) RETURN - IF (INCX .EQ. INCY) IF (INCX-1) 5,20,60 -C -C Code for unequal or nonpositive increments. -C - 5 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 - SY(IY) = SX(IX) - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -C -C Code for both increments equal to 1. -C -C Clean-up loop so remaining vector length is a multiple of 7. -C - 20 M = MOD(N,7) - IF (M .EQ. 0) GO TO 40 - DO 30 I = 1,M - SY(I) = SX(I) - 30 CONTINUE - IF (N .LT. 7) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,7 - SY(I) = SX(I) - SY(I+1) = SX(I+1) - SY(I+2) = SX(I+2) - SY(I+3) = SX(I+3) - SY(I+4) = SX(I+4) - SY(I+5) = SX(I+5) - SY(I+6) = SX(I+6) - 50 CONTINUE - RETURN -C -C Code for equal, positive, non-unit increments. -C - 60 NS = N*INCX - DO 70 I = 1,NS,INCX - SY(I) = SX(I) - 70 CONTINUE - RETURN - END diff --git a/slatec/scopym.f b/slatec/scopym.f deleted file mode 100644 index 9bae1cc..0000000 --- a/slatec/scopym.f +++ /dev/null @@ -1,84 +0,0 @@ -*DECK SCOPYM - SUBROUTINE SCOPYM (N, SX, INCX, SY, INCY) -C***BEGIN PROLOGUE SCOPYM -C***PURPOSE Copy the negative of a vector to a vector. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A5 -C***TYPE SINGLE PRECISION (SCOPYM-S, DCOPYM-D) -C***KEYWORDS BLAS, COPY, VECTOR -C***AUTHOR Kahaner, D. K., (NBS) -C***DESCRIPTION -C -C Description of Parameters -C The * Flags Output Variables -C -C N Number of elements in vector(s) -C SX Real vector with N elements -C INCX Storage spacing between elements of SX -C SY* Real negative copy of SX -C INCY Storage spacing between elements of SY -C -C *** Note that SY = -SX *** -C -C Copy negative of real SX to real SY. For I=0 to N-1, -C copy -SX(LX+I*INCX) to SY(LY+I*INCY), where LX=1 if -C INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is defined -C in a similar way using INCY. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 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***END PROLOGUE SCOPYM - REAL SX(*),SY(*) -C***FIRST EXECUTABLE STATEMENT SCOPYM - IF (N .LE. 0) RETURN - IF (INCX .EQ. INCY) IF (INCX-1) 5,20,60 -C -C Code for unequal or nonpositive increments. -C - 5 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 - SY(IY) = -SX(IX) - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -C -C Code for both increments equal to 1. -C -C Clean-up loop so remaining vector length is a multiple of 7. -C - 20 M = MOD(N,7) - IF (M .EQ. 0) GO TO 40 - DO 30 I = 1,M - SY(I) = -SX(I) - 30 CONTINUE - IF (N .LT. 7) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,7 - SY(I) = -SX(I) - SY(I+1) = -SX(I+1) - SY(I+2) = -SX(I+2) - SY(I+3) = -SX(I+3) - SY(I+4) = -SX(I+4) - SY(I+5) = -SX(I+5) - SY(I+6) = -SX(I+6) - 50 CONTINUE - RETURN -C -C Code for equal, positive, non-unit increments. -C - 60 NS = N*INCX - DO 70 I = 1,NS,INCX - SY(I) = -SX(I) - 70 CONTINUE - RETURN - END diff --git a/slatec/scov.f b/slatec/scov.f deleted file mode 100644 index 9323b64..0000000 --- a/slatec/scov.f +++ /dev/null @@ -1,264 +0,0 @@ -*DECK SCOV - SUBROUTINE SCOV (FCN, IOPT, M, N, X, FVEC, R, LDR, INFO, WA1, WA2, - + WA3, WA4) -C***BEGIN PROLOGUE SCOV -C***PURPOSE Calculate the covariance matrix for a nonlinear data -C fitting problem. It is intended to be used after a -C successful return from either SNLS1 or SNLS1E. -C***LIBRARY SLATEC -C***CATEGORY K1B1 -C***TYPE SINGLE PRECISION (SCOV-S, DCOV-D) -C***KEYWORDS COVARIANCE MATRIX, NONLINEAR DATA FITTING, -C NONLINEAR LEAST SQUARES -C***AUTHOR Hiebert, K. L., (SNLA) -C***DESCRIPTION -C -C 1. Purpose. -C -C SCOV calculates the covariance matrix for a nonlinear data -C fitting problem. It is intended to be used after a -C successful return from either SNLS1 or SNLS1E. SCOV -C and SNLS1 (and SNLS1E) have compatible parameters. The -C required external subroutine, FCN, is the same -C for all three codes, SCOV, SNLS1, and SNLS1E. -C -C 2. Subroutine and Type Statements. -C -C SUBROUTINE SCOV(FCN,IOPT,M,N,X,FVEC,R,LDR,INFO, -C WA1,WA2,WA3,WA4) -C INTEGER IOPT,M,N,LDR,INFO -C REAL X(N),FVEC(M),R(LDR,N),WA1(N),WA2(N),WA3(N),WA4(M) -C EXTERNAL FCN -C -C 3. Parameters. -C -C FCN is the name of the user-supplied subroutine which calculates -C the functions. If the user wants to supply the Jacobian -C (IOPT=2 or 3), then FCN must be written to calculate the -C Jacobian, as well as the functions. See the explanation -C of the IOPT argument below. FCN must be declared in an -C EXTERNAL statement in the calling program and should be -C written as follows. -C -C SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) -C INTEGER IFLAG,LDFJAC,M,N -C REAL X(N),FVEC(M) -C ---------- -C FJAC and LDFJAC may be ignored , if IOPT=1. -C REAL FJAC(LDFJAC,N) , if IOPT=2. -C REAL FJAC(N) , if IOPT=3. -C ---------- -C IFLAG will never be zero when FCN is called by SCOV. -C RETURN -C ---------- -C If IFLAG=1, calculate the functions at X and return -C this vector in FVEC. -C RETURN -C ---------- -C If IFLAG=2, calculate the full Jacobian at X and return -C this matrix in FJAC. Note that IFLAG will never be 2 unless -C IOPT=2. FVEC contains the function values at X and must -C not be altered. FJAC(I,J) must be set to the derivative -C of FVEC(I) with respect to X(J). -C RETURN -C ---------- -C If IFLAG=3, calculate the LDFJAC-th row of the Jacobian -C and return this vector in FJAC. Note that IFLAG will -C never be 3 unless IOPT=3. FJAC(J) must be set to -C the derivative of FVEC(LDFJAC) with respect to X(J). -C RETURN -C ---------- -C END -C -C -C The value of IFLAG should not be changed by FCN unless the -C user wants to terminate execution of SCOV. In this case, set -C IFLAG to a negative integer. -C -C -C IOPT is an input variable which specifies how the Jacobian will -C be calculated. If IOPT=2 or 3, then the user must supply the -C Jacobian, as well as the function values, through the -C subroutine FCN. If IOPT=2, the user supplies the full -C Jacobian with one call to FCN. If IOPT=3, the user supplies -C one row of the Jacobian with each call. (In this manner, -C storage can be saved because the full Jacobian is not stored.) -C If IOPT=1, the code will approximate the Jacobian by forward -C differencing. -C -C M is a positive integer input variable set to the number of -C functions. -C -C N is a positive integer input variable set to the number of -C variables. N must not exceed M. -C -C X is an array of length N. On input X must contain the value -C at which the covariance matrix is to be evaluated. This is -C usually the value for X returned from a successful run of -C SNLS1 (or SNLS1E). The value of X will not be changed. -C -C FVEC is an output array of length M which contains the functions -C evaluated at X. -C -C R is an output array. For IOPT=1 and 2, R is an M by N array. -C For IOPT=3, R is an N by N array. On output, if INFO=1, -C the upper N by N submatrix of R contains the covariance -C matrix evaluated at X. -C -C LDR is a positive integer input variable which specifies -C the leading dimension of the array R. For IOPT=1 and 2, -C LDR must not be less than M. For IOPT=3, LDR must not -C be less than N. -C -C INFO is an integer output variable. If the user has terminated -C execution, INFO is set to the (negative) value of IFLAG. See -C description of FCN. Otherwise, INFO is set as follows. -C -C INFO = 0 Improper input parameters (M.LE.0 or N.LE.0). -C -C INFO = 1 Successful return. The covariance matrix has been -C calculated and stored in the upper N by N -C submatrix of R. -C -C INFO = 2 The Jacobian matrix is singular for the input value -C of X. The covariance matrix cannot be calculated. -C The upper N by N submatrix of R contains the QR -C factorization of the Jacobian (probably not of -C interest to the user). -C -C WA1 is a work array of length N. -C WA2 is a work array of length N. -C WA3 is a work array of length N. -C WA4 is a work array of length M. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED ENORM, FDJAC3, QRFAC, RWUPDT, XERMSG -C***REVISION HISTORY (YYMMDD) -C 810522 DATE WRITTEN -C 890505 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 Fixed an error message. (RWC) -C***END PROLOGUE SCOV -C -C REVISED 820707-1100 -C REVISED YYMMDD HHMM -C - INTEGER I,IDUM,IFLAG,INFO,IOPT,J,K,KP1,LDR,M,N,NM1,NROW - REAL X(*),R(LDR,*),FVEC(*),WA1(*),WA2(*),WA3(*),WA4(*) - EXTERNAL FCN - REAL ONE,SIGMA,TEMP,ZERO - LOGICAL SING - SAVE ZERO, ONE - DATA ZERO/0.E0/,ONE/1.E0/ -C***FIRST EXECUTABLE STATEMENT SCOV - SING=.FALSE. - IFLAG=0 - IF (M.LE.0 .OR. N.LE.0) GO TO 300 -C -C CALCULATE SIGMA = (SUM OF THE SQUARED RESIDUALS) / (M-N) - IFLAG=1 - CALL FCN(IFLAG,M,N,X,FVEC,R,LDR) - IF (IFLAG.LT.0) GO TO 300 - TEMP=ENORM(M,FVEC) - SIGMA=ONE - IF (M.NE.N) SIGMA=TEMP*TEMP/(M-N) -C -C CALCULATE THE JACOBIAN - IF (IOPT.EQ.3) GO TO 200 -C -C STORE THE FULL JACOBIAN USING M*N STORAGE - IF (IOPT.EQ.1) GO TO 100 -C -C USER SUPPLIES THE JACOBIAN - IFLAG=2 - CALL FCN(IFLAG,M,N,X,FVEC,R,LDR) - GO TO 110 -C -C CODE APPROXIMATES THE JACOBIAN -100 CALL FDJAC3(FCN,M,N,X,FVEC,R,LDR,IFLAG,ZERO,WA4) -110 IF (IFLAG.LT.0) GO TO 300 -C -C COMPUTE THE QR DECOMPOSITION - CALL QRFAC(M,N,R,LDR,.FALSE.,IDUM,1,WA1,WA1,WA1) - DO 120 I=1,N -120 R(I,I)=WA1(I) - GO TO 225 -C -C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN MATRIX CALCULATED ONE -C ROW AT A TIME AND STORED IN THE UPPER TRIANGLE OF R. -C ( (Q TRANSPOSE)*FVEC IS ALSO CALCULATED BUT NOT USED.) -200 CONTINUE - DO 210 J=1,N - WA2(J)=ZERO - DO 205 I=1,N - R(I,J)=ZERO -205 CONTINUE -210 CONTINUE - IFLAG=3 - DO 220 I=1,M - NROW = I - CALL FCN(IFLAG,M,N,X,FVEC,WA1,NROW) - IF (IFLAG.LT.0) GO TO 300 - TEMP=FVEC(I) - CALL RWUPDT(N,R,LDR,WA1,WA2,TEMP,WA3,WA4) -220 CONTINUE -C -C CHECK IF R IS SINGULAR. -225 CONTINUE - DO 230 I=1,N - IF (R(I,I).EQ.ZERO) SING=.TRUE. -230 CONTINUE - IF (SING) GO TO 300 -C -C R IS UPPER TRIANGULAR. CALCULATE (R TRANSPOSE) INVERSE AND STORE -C IN THE UPPER TRIANGLE OF R. - IF (N.EQ.1) GO TO 275 - NM1=N-1 - DO 270 K=1,NM1 -C -C INITIALIZE THE RIGHT-HAND SIDE (WA1(*)) AS THE K-TH COLUMN OF THE -C IDENTITY MATRIX. - DO 240 I=1,N - WA1(I)=ZERO -240 CONTINUE - WA1(K)=ONE -C - R(K,K)=WA1(K)/R(K,K) - KP1=K+1 - DO 260 I=KP1,N -C -C SUBTRACT R(K,I-1)*R(I-1,*) FROM THE RIGHT-HAND SIDE, WA1(*). - DO 250 J=I,N - WA1(J)=WA1(J)-R(K,I-1)*R(I-1,J) -250 CONTINUE - R(K,I)=WA1(I)/R(I,I) -260 CONTINUE -270 CONTINUE -275 R(N,N)=ONE/R(N,N) -C -C CALCULATE R-INVERSE * (R TRANSPOSE) INVERSE AND STORE IN THE UPPER -C TRIANGLE OF R. - DO 290 I=1,N - DO 290 J=I,N - TEMP=ZERO - DO 280 K=J,N - TEMP=TEMP+R(I,K)*R(J,K) -280 CONTINUE - R(I,J)=TEMP*SIGMA -290 CONTINUE - INFO=1 -C -300 CONTINUE - IF (M.LE.0 .OR. N.LE.0) INFO=0 - IF (IFLAG.LT.0) INFO=IFLAG - IF (SING) INFO=2 - IF (INFO .LT. 0) CALL XERMSG ('SLATEC', 'SCOV', - + 'EXECUTION TERMINATED BECAUSE USER SET IFLAG NEGATIVE.', 1, 1) - IF (INFO .EQ. 0) CALL XERMSG ('SLATEC', 'SCOV', - + 'INVALID INPUT PARAMETER.', 2, 1) - IF (INFO .EQ. 2) CALL XERMSG ('SLATEC', 'SCOV', - + 'SINGULAR JACOBIAN MATRIX, COVARIANCE MATRIX CANNOT BE ' // - + 'CALCULATED.', 1, 1) - RETURN - END diff --git a/slatec/scpplt.f b/slatec/scpplt.f deleted file mode 100644 index 93ca6e8..0000000 --- a/slatec/scpplt.f +++ /dev/null @@ -1,196 +0,0 @@ -*DECK SCPPLT - SUBROUTINE SCPPLT (N, NELT, IA, JA, A, ISYM, IUNIT) -C***BEGIN PROLOGUE SCPPLT -C***PURPOSE Printer Plot of SLAP Column Format Matrix. -C Routine to print out a SLAP Column format matrix in a -C "printer plot" graphical representation. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY N1 -C***TYPE SINGLE PRECISION (SCPPLT-S, DCPPLT-D) -C***KEYWORDS DIAGNOSTICS, LINEAR SYSTEM, SLAP SPARSE -C***AUTHOR Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, IUNIT -C REAL A(NELT) -C -C CALL SCPPLT( N, NELT, IA, JA, A, ISYM, IUNIT ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C If N.gt.MAXORD, only the leading MAXORD x MAXORD -C submatrix will be printed. (Currently MAXORD = 225.) -C NELT :IN Integer. -C Number of non-zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Real A(NELT). -C These arrays should hold the matrix A in the SLAP -C Column format. See "Description", below. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the lower -C triangle of the matrix is stored. -C IUNIT :IN Integer. -C Fortran logical I/O device unit number to write the matrix -C to. This unit must be connected in a system dependent fashion -C to a file or the console or you will get a nasty message -C from the Fortran I/O libraries. -C -C *Description: -C This routine prints out a SLAP Column format matrix to the -C Fortran logical I/O unit number IUNIT. The numbers them -C selves are not printed out, but rather a one character -C representation of the numbers. Elements of the matrix that -C are not represented in the (IA,JA,A) arrays are denoted by -C ' ' character (a blank). Elements of A that are *ZERO* (and -C hence should really not be stored) are denoted by a '0' -C character. Elements of A that are *POSITIVE* are denoted by -C 'D' if they are Diagonal elements and '#' if they are off -C Diagonal elements. Elements of A that are *NEGATIVE* are -C denoted by 'N' if they are Diagonal elements and '*' if -C they are off Diagonal elements. -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C *Portability: -C This routine, as distributed, can generate lines up to 229 -C characters long. Some Fortran systems have more restricted -C line lengths. Change parameter MAXORD and the large number -C in FORMAT 1010 to reduce this line length. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 921007 Replaced hard-wired 225 with parameter MAXORD. (FNF) -C 921021 Corrected syntax of CHARACTER declaration. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE SCPPLT -C .. Scalar Arguments .. - INTEGER ISYM, IUNIT, N, NELT -C .. Array Arguments .. - REAL A(NELT) - INTEGER IA(NELT), JA(NELT) -C .. Parameters .. - INTEGER MAXORD - PARAMETER (MAXORD=225) -C .. Local Scalars .. - INTEGER I, ICOL, IROW, J, JBGN, JEND, NMAX -C .. Local Arrays .. - CHARACTER CHMAT(MAXORD)*(MAXORD) -C .. Intrinsic Functions .. - INTRINSIC MIN, MOD, REAL -C***FIRST EXECUTABLE STATEMENT SCPPLT -C -C Set up the character matrix... -C - NMAX = MIN( MAXORD, N ) - DO 10 I = 1, NMAX - CHMAT(I)(1:NMAX) = ' ' - 10 CONTINUE - DO 30 ICOL = 1, NMAX - JBGN = JA(ICOL) - JEND = JA(ICOL+1)-1 - DO 20 J = JBGN, JEND - IROW = IA(J) - IF( IROW.LE.NMAX ) THEN - IF( ISYM.NE.0 ) THEN -C Put in non-sym part as well... - IF( A(J).EQ.0.0E0 ) THEN - CHMAT(IROW)(ICOL:ICOL) = '0' - ELSEIF( A(J).GT.0.0E0 ) THEN - CHMAT(IROW)(ICOL:ICOL) = '#' - ELSE - CHMAT(IROW)(ICOL:ICOL) = '*' - ENDIF - ENDIF - IF( IROW.EQ.ICOL ) THEN -C Diagonal entry. - IF( A(J).EQ.0.0E0 ) THEN - CHMAT(IROW)(ICOL:ICOL) = '0' - ELSEIF( A(J).GT.0.0E0 ) THEN - CHMAT(IROW)(ICOL:ICOL) = 'D' - ELSE - CHMAT(IROW)(ICOL:ICOL) = 'N' - ENDIF - ELSE -C Off-Diagonal entry - IF( A(J).EQ.0.0E0 ) THEN - CHMAT(IROW)(ICOL:ICOL) = '0' - ELSEIF( A(J).GT.0.0E0 ) THEN - CHMAT(IROW)(ICOL:ICOL) = '#' - ELSE - CHMAT(IROW)(ICOL:ICOL) = '*' - ENDIF - ENDIF - ENDIF - 20 CONTINUE - 30 CONTINUE -C -C Write out the heading. - WRITE(IUNIT,1000) N, NELT, REAL(NELT)/(N*N) - WRITE(IUNIT,1010) (MOD(I,10),I=1,NMAX) -C -C Write out the character representations matrix elements. - DO 40 IROW = 1, NMAX - WRITE(IUNIT,1020) IROW, CHMAT(IROW)(1:NMAX) - 40 CONTINUE - RETURN -C - 1000 FORMAT(/'**** Picture of Column SLAP matrix follows ****'/ - $ ' N, NELT and Density = ',2I10,E16.7) -C The following assumes MAXORD.le.225. - 1010 FORMAT(4X,225(I1)) - 1020 FORMAT(1X,I3,A) -C------------- LAST LINE OF SCPPLT FOLLOWS ---------------------------- - END diff --git a/slatec/sdaini.f b/slatec/sdaini.f deleted file mode 100644 index bc58509..0000000 --- a/slatec/sdaini.f +++ /dev/null @@ -1,256 +0,0 @@ -*DECK SDAINI - SUBROUTINE SDAINI (X, Y, YPRIME, NEQ, RES, JAC, H, WT, IDID, RPAR, - * IPAR, PHI, DELTA, E, WM, IWM, HMIN, UROUND, NONNEG, NTEMP) -C***BEGIN PROLOGUE SDAINI -C***SUBSIDIARY -C***PURPOSE Initialization routine for SDASSL. -C***LIBRARY SLATEC (DASSL) -C***TYPE SINGLE PRECISION (SDAINI-S, DDAINI-D) -C***AUTHOR Petzold, Linda R., (LLNL) -C***DESCRIPTION -C----------------------------------------------------------------- -C SDAINI TAKES ONE STEP OF SIZE H OR SMALLER -C WITH THE BACKWARD EULER METHOD, TO -C FIND YPRIME. X AND Y ARE UPDATED TO BE CONSISTENT WITH THE -C NEW STEP. A MODIFIED DAMPED NEWTON ITERATION IS USED TO -C SOLVE THE CORRECTOR ITERATION. -C -C THE INITIAL GUESS FOR YPRIME IS USED IN THE -C PREDICTION, AND IN FORMING THE ITERATION -C MATRIX, BUT IS NOT INVOLVED IN THE -C ERROR TEST. THIS MAY HAVE TROUBLE -C CONVERGING IF THE INITIAL GUESS IS NO -C GOOD, OR IF G(X,Y,YPRIME) DEPENDS -C NONLINEARLY ON YPRIME. -C -C THE PARAMETERS REPRESENT: -C X -- INDEPENDENT VARIABLE -C Y -- SOLUTION VECTOR AT X -C YPRIME -- DERIVATIVE OF SOLUTION VECTOR -C NEQ -- NUMBER OF EQUATIONS -C H -- STEPSIZE. IMDER MAY USE A STEPSIZE -C SMALLER THAN H. -C WT -- VECTOR OF WEIGHTS FOR ERROR -C CRITERION -C IDID -- COMPLETION CODE WITH THE FOLLOWING MEANINGS -C IDID= 1 -- YPRIME WAS FOUND SUCCESSFULLY -C IDID=-12 -- SDAINI FAILED TO FIND YPRIME -C RPAR,IPAR -- REAL AND INTEGER PARAMETER ARRAYS -C THAT ARE NOT ALTERED BY SDAINI -C PHI -- WORK SPACE FOR SDAINI -C DELTA,E -- WORK SPACE FOR SDAINI -C WM,IWM -- REAL AND INTEGER ARRAYS STORING -C MATRIX INFORMATION -C -C----------------------------------------------------------------- -C***ROUTINES CALLED SDAJAC, SDANRM, SDASLV -C***REVISION HISTORY (YYMMDD) -C 830315 DATE WRITTEN -C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) -C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. -C 901026 Added explicit declarations for all variables and minor -C cosmetic changes to prologue. (FNF) -C 901030 Minor corrections to declarations. (FNF) -C***END PROLOGUE SDAINI -C - INTEGER NEQ, IDID, IPAR(*), IWM(*), NONNEG, NTEMP - REAL X, Y(*), YPRIME(*), H, WT(*), RPAR(*), PHI(NEQ,*), DELTA(*), - * E(*), WM(*), HMIN, UROUND - EXTERNAL RES, JAC -C - EXTERNAL SDAJAC, SDANRM, SDASLV - REAL SDANRM -C - INTEGER I, IER, IRES, JCALC, LNJE, LNRE, M, MAXIT, MJAC, NCF, - * NEF, NSF - REAL CJ, DAMP, DELNRM, ERR, OLDNRM, R, RATE, S, XOLD, YNORM - LOGICAL CONVGD -C - PARAMETER (LNRE=12) - PARAMETER (LNJE=13) -C - DATA MAXIT/10/,MJAC/5/ - DATA DAMP/0.75E0/ -C -C -C--------------------------------------------------- -C BLOCK 1. -C INITIALIZATIONS. -C--------------------------------------------------- -C -C***FIRST EXECUTABLE STATEMENT SDAINI - IDID=1 - NEF=0 - NCF=0 - NSF=0 - XOLD=X - YNORM=SDANRM(NEQ,Y,WT,RPAR,IPAR) -C -C SAVE Y AND YPRIME IN PHI - DO 100 I=1,NEQ - PHI(I,1)=Y(I) -100 PHI(I,2)=YPRIME(I) -C -C -C---------------------------------------------------- -C BLOCK 2. -C DO ONE BACKWARD EULER STEP. -C---------------------------------------------------- -C -C SET UP FOR START OF CORRECTOR ITERATION -200 CJ=1.0E0/H - X=X+H -C -C PREDICT SOLUTION AND DERIVATIVE - DO 250 I=1,NEQ -250 Y(I)=Y(I)+H*YPRIME(I) -C - JCALC=-1 - M=0 - CONVGD=.TRUE. -C -C -C CORRECTOR LOOP. -300 IWM(LNRE)=IWM(LNRE)+1 - IRES=0 -C - CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR) - IF (IRES.LT.0) GO TO 430 -C -C -C EVALUATE THE ITERATION MATRIX - IF (JCALC.NE.-1) GO TO 310 - IWM(LNJE)=IWM(LNJE)+1 - JCALC=0 - CALL SDAJAC(NEQ,X,Y,YPRIME,DELTA,CJ,H, - * IER,WT,E,WM,IWM,RES,IRES, - * UROUND,JAC,RPAR,IPAR,NTEMP) -C - S=1000000.E0 - IF (IRES.LT.0) GO TO 430 - IF (IER.NE.0) GO TO 430 - NSF=0 -C -C -C -C MULTIPLY RESIDUAL BY DAMPING FACTOR -310 CONTINUE - DO 320 I=1,NEQ -320 DELTA(I)=DELTA(I)*DAMP -C -C COMPUTE A NEW ITERATE (BACK SUBSTITUTION) -C STORE THE CORRECTION IN DELTA -C - CALL SDASLV(NEQ,DELTA,WM,IWM) -C -C UPDATE Y AND YPRIME - DO 330 I=1,NEQ - Y(I)=Y(I)-DELTA(I) -330 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) -C -C TEST FOR CONVERGENCE OF THE ITERATION. -C - DELNRM=SDANRM(NEQ,DELTA,WT,RPAR,IPAR) - IF (DELNRM.LE.100.E0*UROUND*YNORM) - * GO TO 400 -C - IF (M.GT.0) GO TO 340 - OLDNRM=DELNRM - GO TO 350 -C -340 RATE=(DELNRM/OLDNRM)**(1.0E0/M) - IF (RATE.GT.0.90E0) GO TO 430 - S=RATE/(1.0E0-RATE) -C -350 IF (S*DELNRM .LE. 0.33E0) GO TO 400 -C -C -C THE CORRECTOR HAS NOT YET CONVERGED. UPDATE -C M AND AND TEST WHETHER THE MAXIMUM -C NUMBER OF ITERATIONS HAVE BEEN TRIED. -C EVERY MJAC ITERATIONS, GET A NEW -C ITERATION MATRIX. -C - M=M+1 - IF (M.GE.MAXIT) GO TO 430 -C - IF ((M/MJAC)*MJAC.EQ.M) JCALC=-1 - GO TO 300 -C -C -C THE ITERATION HAS CONVERGED. -C CHECK NONNEGATIVITY CONSTRAINTS -400 IF (NONNEG.EQ.0) GO TO 450 - DO 410 I=1,NEQ -410 DELTA(I)=MIN(Y(I),0.0E0) -C - DELNRM=SDANRM(NEQ,DELTA,WT,RPAR,IPAR) - IF (DELNRM.GT.0.33E0) GO TO 430 -C - DO 420 I=1,NEQ - Y(I)=Y(I)-DELTA(I) -420 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) - GO TO 450 -C -C -C EXITS FROM CORRECTOR LOOP. -430 CONVGD=.FALSE. -450 IF (.NOT.CONVGD) GO TO 600 -C -C -C -C----------------------------------------------------- -C BLOCK 3. -C THE CORRECTOR ITERATION CONVERGED. -C DO ERROR TEST. -C----------------------------------------------------- -C - DO 510 I=1,NEQ -510 E(I)=Y(I)-PHI(I,1) - ERR=SDANRM(NEQ,E,WT,RPAR,IPAR) -C - IF (ERR.LE.1.0E0) RETURN -C -C -C -C-------------------------------------------------------- -C BLOCK 4. -C THE BACKWARD EULER STEP FAILED. RESTORE X, Y -C AND YPRIME TO THEIR ORIGINAL VALUES. -C REDUCE STEPSIZE AND TRY AGAIN, IF -C POSSIBLE. -C--------------------------------------------------------- -C -600 CONTINUE - X = XOLD - DO 610 I=1,NEQ - Y(I)=PHI(I,1) -610 YPRIME(I)=PHI(I,2) -C - IF (CONVGD) GO TO 640 - IF (IER.EQ.0) GO TO 620 - NSF=NSF+1 - H=H*0.25E0 - IF (NSF.LT.3.AND.ABS(H).GE.HMIN) GO TO 690 - IDID=-12 - RETURN -620 IF (IRES.GT.-2) GO TO 630 - IDID=-12 - RETURN -630 NCF=NCF+1 - H=H*0.25E0 - IF (NCF.LT.10.AND.ABS(H).GE.HMIN) GO TO 690 - IDID=-12 - RETURN -C -640 NEF=NEF+1 - R=0.90E0/(2.0E0*ERR+0.0001E0) - R=MAX(0.1E0,MIN(0.5E0,R)) - H=H*R - IF (ABS(H).GE.HMIN.AND.NEF.LT.10) GO TO 690 - IDID=-12 - RETURN -690 GO TO 200 -C -C-------------END OF SUBROUTINE SDAINI---------------------- - END diff --git a/slatec/sdajac.f b/slatec/sdajac.f deleted file mode 100644 index be63b8c..0000000 --- a/slatec/sdajac.f +++ /dev/null @@ -1,176 +0,0 @@ -*DECK SDAJAC - SUBROUTINE SDAJAC (NEQ, X, Y, YPRIME, DELTA, CJ, H, IER, WT, E, - * WM, IWM, RES, IRES, UROUND, JAC, RPAR, IPAR, NTEMP) -C***BEGIN PROLOGUE SDAJAC -C***SUBSIDIARY -C***PURPOSE Compute the iteration matrix for SDASSL and form the -C LU-decomposition. -C***LIBRARY SLATEC (DASSL) -C***TYPE SINGLE PRECISION (SDAJAC-S, DDAJAC-D) -C***AUTHOR Petzold, Linda R., (LLNL) -C***DESCRIPTION -C----------------------------------------------------------------------- -C THIS ROUTINE COMPUTES THE ITERATION MATRIX -C PD=DG/DY+CJ*DG/DYPRIME (WHERE G(X,Y,YPRIME)=0). -C HERE PD IS COMPUTED BY THE USER-SUPPLIED -C ROUTINE JAC IF IWM(MTYPE) IS 1 OR 4, AND -C IT IS COMPUTED BY NUMERICAL FINITE DIFFERENCING -C IF IWM(MTYPE)IS 2 OR 5 -C THE PARAMETERS HAVE THE FOLLOWING MEANINGS. -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 -C IF ITERATION MATRIX IS SINGULAR, -C AND 0 OTHERWISE. -C WT = VECTOR OF WEIGHTS FOR COMPUTING NORMS -C E = WORK SPACE (TEMPORARY) OF LENGTH NEQ -C WM = REAL WORK SPACE FOR MATRICES. ON -C OUTPUT IT CONTAINS THE LU DECOMPOSITION -C OF THE ITERATION MATRIX. -C IWM = INTEGER WORK SPACE CONTAINING -C MATRIX INFORMATION -C RES = NAME OF THE EXTERNAL USER-SUPPLIED ROUTINE -C TO EVALUATE THE RESIDUAL FUNCTION G(X,Y,YPRIME) -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 JAC = 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----------------------------------------------------------------------- -C***ROUTINES CALLED SGBFA, SGEFA -C***REVISION HISTORY (YYMMDD) -C 830315 DATE WRITTEN -C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) -C 901010 Modified three MAX calls to be all on one line. (FNF) -C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. -C 901026 Added explicit declarations for all variables and minor -C cosmetic changes to prologue. (FNF) -C 901101 Corrected PURPOSE. (FNF) -C***END PROLOGUE SDAJAC -C - INTEGER NEQ, IER, IWM(*), IRES, IPAR(*), NTEMP - REAL X, Y(*), YPRIME(*), DELTA(*), CJ, H, WT(*), E(*), WM(*), - * UROUND, RPAR(*) - EXTERNAL RES, JAC -C - EXTERNAL SGBFA, SGEFA -C - INTEGER I, I1, I2, II, IPSAVE, ISAVE, J, K, L, LENPD, LIPVT, - * LML, LMTYPE, LMU, MBA, MBAND, MEB1, MEBAND, MSAVE, MTYPE, N, - * NPD, NPDM1, NROW - REAL DEL, DELINV, SQUR, YPSAVE, YSAVE -C - PARAMETER (NPD=1) - PARAMETER (LML=1) - PARAMETER (LMU=2) - PARAMETER (LMTYPE=4) - PARAMETER (LIPVT=21) -C -C***FIRST EXECUTABLE STATEMENT SDAJAC - IER = 0 - NPDM1=NPD-1 - MTYPE=IWM(LMTYPE) - GO TO (100,200,300,400,500),MTYPE -C -C -C DENSE USER-SUPPLIED MATRIX -100 LENPD=NEQ*NEQ - DO 110 I=1,LENPD -110 WM(NPDM1+I)=0.0E0 - CALL JAC(X,Y,YPRIME,WM(NPD),CJ,RPAR,IPAR) - GO TO 230 -C -C -C DENSE FINITE-DIFFERENCE-GENERATED MATRIX -200 IRES=0 - NROW=NPDM1 - SQUR = SQRT(UROUND) - DO 210 I=1,NEQ - DEL=SQUR*MAX(ABS(Y(I)),ABS(H*YPRIME(I)),ABS(WT(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 - CALL RES(X,Y,YPRIME,E,IRES,RPAR,IPAR) - IF (IRES .LT. 0) RETURN - DELINV=1.0E0/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 PD -230 CALL SGEFA(WM(NPD),NEQ,NEQ,IWM(LIPVT),IER) - RETURN -C -C -C DUMMY SECTION FOR IWM(MTYPE)=3 -300 RETURN -C -C -C BANDED USER-SUPPLIED MATRIX -400 LENPD=(2*IWM(LML)+IWM(LMU)+1)*NEQ - DO 410 I=1,LENPD -410 WM(NPDM1+I)=0.0E0 - CALL JAC(X,Y,YPRIME,WM(NPD),CJ,RPAR,IPAR) - MEBAND=2*IWM(LML)+IWM(LMU)+1 - GO TO 550 -C -C -C BANDED FINITE-DIFFERENCE-GENERATED MATRIX -500 MBAND=IWM(LML)+IWM(LMU)+1 - MBA=MIN(MBAND,NEQ) - MEBAND=MBAND+IWM(LML) - MEB1=MEBAND-1 - MSAVE=(NEQ/MBAND)+1 - ISAVE=NTEMP-1 - 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(WT(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 - CALL RES(X,Y,YPRIME,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(WT(N))) - DEL=SIGN(DEL,H*YPRIME(N)) - DEL=(Y(N)+DEL)-Y(N) - DELINV=1.0E0/DEL - I1=MAX(1,(N-IWM(LMU))) - I2=MIN(NEQ,(N+IWM(LML))) - II=N*MEB1-IWM(LML)+NPDM1 - 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 PD -550 CALL SGBFA(WM(NPD),MEBAND,NEQ, - * IWM(LML),IWM(LMU),IWM(LIPVT),IER) - RETURN -C------END OF SUBROUTINE SDAJAC------ - END diff --git a/slatec/sdanrm.f b/slatec/sdanrm.f deleted file mode 100644 index cfe7cbd..0000000 --- a/slatec/sdanrm.f +++ /dev/null @@ -1,46 +0,0 @@ -*DECK SDANRM - REAL FUNCTION SDANRM (NEQ, V, WT, RPAR, IPAR) -C***BEGIN PROLOGUE SDANRM -C***SUBSIDIARY -C***PURPOSE Compute vector norm for SDASSL. -C***LIBRARY SLATEC (DASSL) -C***TYPE SINGLE PRECISION (SDANRM-S, DDANRM-D) -C***AUTHOR Petzold, Linda R., (LLNL) -C***DESCRIPTION -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 WEIGHTS -C CONTAINED IN THE ARRAY WT OF LENGTH NEQ. -C SDANRM=SQRT((1/NEQ)*SUM(V(I)/WT(I))**2) -C----------------------------------------------------------------------- -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 830315 DATE WRITTEN -C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) -C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. -C 901026 Added explicit declarations for all variables and minor -C cosmetic changes to prologue. (FNF) -C***END PROLOGUE SDANRM -C - INTEGER NEQ, IPAR(*) - REAL V(NEQ), WT(NEQ), RPAR(*) -C - INTEGER I - REAL SUM, VMAX -C -C***FIRST EXECUTABLE STATEMENT SDANRM - SDANRM = 0.0E0 - VMAX = 0.0E0 - DO 10 I = 1,NEQ - IF(ABS(V(I)/WT(I)) .GT. VMAX) VMAX = ABS(V(I)/WT(I)) -10 CONTINUE - IF(VMAX .LE. 0.0E0) GO TO 30 - SUM = 0.0E0 - DO 20 I = 1,NEQ -20 SUM = SUM + ((V(I)/WT(I))/VMAX)**2 - SDANRM = VMAX*SQRT(SUM/NEQ) -30 CONTINUE - RETURN -C------END OF FUNCTION SDANRM------ - END diff --git a/slatec/sdaslv.f b/slatec/sdaslv.f deleted file mode 100644 index ded2cea..0000000 --- a/slatec/sdaslv.f +++ /dev/null @@ -1,61 +0,0 @@ -*DECK SDASLV - SUBROUTINE SDASLV (NEQ, DELTA, WM, IWM) -C***BEGIN PROLOGUE SDASLV -C***SUBSIDIARY -C***PURPOSE Linear system solver for SDASSL. -C***LIBRARY SLATEC (DASSL) -C***TYPE SINGLE PRECISION (SDASLV-S, DDASLV-D) -C***AUTHOR Petzold, Linda R., (LLNL) -C***DESCRIPTION -C----------------------------------------------------------------------- -C THIS ROUTINE MANAGES THE SOLUTION OF THE LINEAR -C SYSTEM ARISING IN THE NEWTON ITERATION. -C MATRICES AND REAL TEMPORARY STORAGE AND -C REAL INFORMATION ARE STORED IN THE ARRAY WM. -C INTEGER MATRIX INFORMATION IS STORED IN -C THE ARRAY IWM. -C FOR A DENSE MATRIX, THE LINPACK ROUTINE -C SGESL IS CALLED. -C FOR A BANDED MATRIX,THE LINPACK ROUTINE -C SGBSL IS CALLED. -C----------------------------------------------------------------------- -C***ROUTINES CALLED SGBSL, SGESL -C***REVISION HISTORY (YYMMDD) -C 830315 DATE WRITTEN -C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) -C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. -C 901026 Added explicit declarations for all variables and minor -C cosmetic changes to prologue. (FNF) -C***END PROLOGUE SDASLV -C - INTEGER NEQ, IWM(*) - REAL DELTA(*), WM(*) -C - EXTERNAL SGBSL, SGESL -C - INTEGER LIPVT, LML, LMU, LMTYPE, MEBAND, MTYPE, NPD - PARAMETER (NPD=1) - PARAMETER (LML=1) - PARAMETER (LMU=2) - PARAMETER (LMTYPE=4) - PARAMETER (LIPVT=21) -C -C***FIRST EXECUTABLE STATEMENT SDASLV - MTYPE=IWM(LMTYPE) - GO TO(100,100,300,400,400),MTYPE -C -C DENSE MATRIX -100 CALL SGESL(WM(NPD),NEQ,NEQ,IWM(LIPVT),DELTA,0) - RETURN -C -C DUMMY SECTION FOR MTYPE=3 -300 CONTINUE - RETURN -C -C BANDED MATRIX -400 MEBAND=2*IWM(LML)+IWM(LMU)+1 - CALL SGBSL(WM(NPD),MEBAND,NEQ,IWM(LML), - * IWM(LMU),IWM(LIPVT),DELTA,0) - RETURN -C------END OF SUBROUTINE SDASLV------ - END diff --git a/slatec/sdassl.f b/slatec/sdassl.f deleted file mode 100644 index 728fae2..0000000 --- a/slatec/sdassl.f +++ /dev/null @@ -1,1598 +0,0 @@ -*DECK SDASSL - SUBROUTINE SDASSL (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, - * IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC) -C***BEGIN PROLOGUE SDASSL -C***PURPOSE This code solves a system of differential/algebraic -C equations of the form G(T,Y,YPRIME) = 0. -C***LIBRARY SLATEC (DASSL) -C***CATEGORY I1A2 -C***TYPE SINGLE PRECISION (SDASSL-S, DDASSL-D) -C***KEYWORDS BACKWARD DIFFERENTIATION FORMULAS, DASSL, -C DIFFERENTIAL/ALGEBRAIC, IMPLICIT DIFFERENTIAL SYSTEMS -C***AUTHOR Petzold, Linda R., (LLNL) -C Computing and Mathematics Research Division -C Lawrence Livermore National Laboratory -C L - 316, P.O. Box 808, -C Livermore, CA. 94550 -C***DESCRIPTION -C -C *Usage: -C -C EXTERNAL RES, JAC -C INTEGER NEQ, INFO(N), IDID, LRW, LIW, IWORK(LIW), IPAR -C REAL T, Y(NEQ), YPRIME(NEQ), TOUT, RTOL, ATOL, -C * RWORK(LRW), RPAR -C -C CALL SDASSL (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, -C * IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC) -C -C -C *Arguments: -C -C RES:EXT This is a subroutine which you provide to define the -C differential/algebraic system. -C -C NEQ:IN This is the number of equations to be solved. -C -C T:INOUT This is the current value of the independent 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 The basic task of the code is to solve the system from T -C to TOUT and return an answer at TOUT. INFO is an integer -C array which is used to communicate exactly how you want -C this task to be carried out. (See below for details.) -C N must be greater than or equal to 15. -C -C RTOL,ATOL:INOUT These quantities represent relative and absolute -C error tolerances which you provide to indicate how -C accurately you wish the solution to be computed. You -C may choose them to be both scalars or else both vectors. -C Caution: In Fortran 77, a scalar is not the same as an -C array of length 1. Some compilers may object -C to using scalars for RTOL,ATOL. -C -C IDID:OUT This scalar quantity is an indicator reporting what the -C code did. You must monitor this integer 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. (See below for required length.) -C -C IWORK:WORK An integer work array of length LIW which provides the -C code with needed storage space. -C -C LIW:IN The length of IWORK. (See below for required length.) -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 subroutine (and the JAC subroutine) -C -C JAC:EXT This is the name of a subroutine which you may choose -C to provide for defining a matrix of partial derivatives -C described below. -C -C Quantities which may be altered by SDASSL are: -C T, Y(*), YPRIME(*), INFO(1), RTOL, ATOL, -C IDID, RWORK(*) AND IWORK(*) -C -C *Description -C -C Subroutine SDASSL uses the backward differentiation formulas of -C orders one through five to solve a system of the above form for Y and -C YPRIME. Values for Y and YPRIME at the initial time must be given as -C input. These values must be consistent, (that is, if T,Y,YPRIME are -C the given initial values, they must satisfy G(T,Y,YPRIME) = 0.). The -C subroutine solves the system from T to TOUT. It is easy to continue -C the solution to get results at additional TOUT. This is the interval -C mode of operation. Intermediate results can also be obtained easily -C by using the intermediate-output capability. -C -C The following detailed description is divided into subsections: -C 1. Input required for the first call to SDASSL. -C 2. Output after any return from SDASSL. -C 3. What to do to continue the integration. -C 4. Error messages. -C -C -C -------- INPUT -- WHAT TO DO ON THE FIRST CALL TO SDASSL ------------ -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 SUBROUTINE RES(T,Y,YPRIME,DELTA,IRES,RPAR,IPAR) -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 -C return the residual of the differential/algebraic -C system -C DELTA = G(T,Y,YPRIME) -C (DELTA(*) is a vector of length NEQ which is -C output for RES.) -C -C Subroutine RES must not alter T,Y or YPRIME. -C You must declare the name RES in an external -C statement in your program that calls SDASSL. -C You must dimension Y,YPRIME and DELTA in RES. -C -C IRES is an integer flag which is always equal to -C zero on input. Subroutine RES should alter IRES -C only if it encounters an illegal value of Y or -C a stop condition. Set IRES = -1 if an input value -C is illegal, and SDASSL will try to solve the problem -C without getting IRES = -1. If IRES = -2, SDASSL -C will return control to the calling program -C 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 SDASSL. 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 differential equations. -C (NEQ .GE. 1) -C -C T -- Set it to the initial point of the integration. -C T must be defined as a variable. -C -C Y(*) -- Set this vector 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 vector to the initial values of the NEQ -C first derivatives of the solution components at the initial -C point. You must dimension YPRIME at least NEQ in your -C calling program. If you do not know initial values of some -C of the solution components, see the explanation of INFO(11). -C -C TOUT -- Set it to the first point at which a solution -C is desired. You can not take TOUT = T. -C integration either forward in T (TOUT .GT. T) or -C backward in T (TOUT .LT. T) is permitted. -C -C The code advances the solution from T to TOUT using -C step sizes which are automatically selected so as to -C achieve the desired accuracy. If you wish, the code will -C return with the solution and its derivative at -C intermediate steps (intermediate-output mode) so that -C you can monitor them, but you still must provide TOUT in -C accord with the basic aim of the code. -C -C The first step taken by the code is a critical one -C because it must reflect how fast the solution changes near -C the initial point. The code automatically selects an -C initial step size which is practically always suitable for -C the problem. By using the fact that the code will not step -C past TOUT in the first step, you could, if necessary, -C restrict the length of the initial step size. -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 -C past TSTOP. In this case any TOUT beyond TSTOP is invalid -C 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 15, though SDASSL uses only the first -C eleven entries. You must respond to all of the following -C items, which are arranged as questions. The simplest use -C of the code corresponds to answering all questions as yes, -C i.e. setting all entries of INFO to 0. -C -C INFO(1) - This parameter enables the code to initialize -C itself. You must set it to indicate the start of every -C new 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 vectors. -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 -C of TOUT by steps. If you wish, it will return the -C computed solution and derivative at the next -C intermediate step (the intermediate-output mode) or -C TOUT, whichever comes first. This is a good way to -C proceed if you want to see the behavior of the solution. -C If you must have solutions at a great many specific -C TOUT points, this 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 not to go past. -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) - To solve differential/algebraic problems it is -C necessary 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. Sometimes numerical differencing -C is cheaper than evaluating derivatives in JAC and -C sometimes it is not - this depends on your problem. -C -C **** Do you want the code to evaluate the partial -C derivatives 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) - SDASSL will perform much better if the matrix of -C partial derivatives, DG/DY + CJ*DG/DYPRIME, -C (here CJ is a scalar determined by SDASSL) -C is banded and the code is told this. In this -C case, the storage needed will be greatly reduced, -C numerical differencing will be performed much cheaper, -C and a number of important algorithms will execute much -C faster. The differential equation is said to have -C half-bandwidths ML (lower) and MU (upper) if equation i -C 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 -C (dense) matrix (and not a special banded -C 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 -C INFO(7) -- You can specify a maximum (absolute value of) -C stepsize, so that the code -C will avoid passing over very -C large regions. -C -C **** Do you want the code to decide -C on its own maximum 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 -C may occasionally suffer from -C severe scaling difficulties on the -C first step. If you know a great deal -C about the scaling of your problem, you can -C help to alleviate this problem by -C specifying an initial stepsize HO. -C -C **** Do you want the code to define -C its own initial stepsize? -C Yes - Set INFO(8)=0 -C No - Set INFO(8)=1 -C and define HO by setting -C RWORK(3)=HO **** -C -C INFO(9) -- If storage is a severe problem, -C you can save some locations by -C restricting the maximum order MAXORD. -C the default value is 5. for each -C order decrease below 5, the code -C requires NEQ fewer locations, however -C it is likely to be slower. In any -C case, you must have 1 .LE. MAXORD .LE. 5 -C **** Do you want the maximum order to -C 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 the solutions to your equations -C will always be nonnegative, it may help to set this -C parameter. However, it is probably best to -C try the code without using this option first, -C and only to use this option if that doesn't -C work very well. -C **** Do you want the code to solve the problem without -C invoking any special nonnegativity constraints? -C Yes - Set INFO(10)=0 -C No - Set INFO(10)=1 -C -C INFO(11) --SDASSL normally requires the initial T, -C Y, and YPRIME to be consistent. That is, -C you must have G(T,Y,YPRIME) = 0 at the initial -C time. If you do not know the initial -C derivative precisely, you can let SDASSL try -C to compute it. -C **** Are the initial T, Y, YPRIME consistent? -C Yes - Set INFO(11) = 0 -C No - Set INFO(11) = 1, -C and set YPRIME to an initial approximation -C to YPRIME. (If you have no idea what -C YPRIME should be, set it to zero. Note -C that the initial Y should be such -C that there must exist a YPRIME so that -C G(T,Y,YPRIME) = 0.) -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. You -C have two choices -- -C Both RTOL and ATOL are scalars. (INFO(2)=0) -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) .LE. RTOL*ABS(Y)+ATOL -C 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 Usually, but not always, the true accuracy of the -C computed Y is comparable to the error tolerances. This -C 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 bigger tolerances. -C -C Setting ATOL=0. results in a pure relative error test on -C 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 much -C bigger than ATOL and to an absolute error test when the -C solution component is smaller than the threshhold ATOL. -C -C The code will not attempt to compute a solution at an -C accuracy unreasonable for the machine being used. It will -C advise you if you ask for too much accuracy and inform -C you as to the maximum accuracy it believes possible. -C -C RWORK(*) -- Dimension this real work array of length LRW in your -C calling program. -C -C LRW -- Set it to the declared length of the RWORK array. -C You must have -C LRW .GE. 40+(MAXORD+4)*NEQ+NEQ**2 -C for the full (dense) JACOBIAN case (when INFO(6)=0), or -C LRW .GE. 40+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ -C for the banded user-defined JACOBIAN case -C (when INFO(5)=1 and INFO(6)=1), or -C LRW .GE. 40+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ -C +2*(NEQ/(ML+MU+1)+1) -C for the banded finite-difference-generated JACOBIAN case -C (when INFO(5)=0 and INFO(6)=1) -C -C IWORK(*) -- Dimension this integer work array of length LIW in -C your calling program. -C -C LIW -- Set it to the declared length of the IWORK array. -C You must have LIW .GE. 20+NEQ -C -C RPAR, IPAR -- These are parameter arrays, of real and integer -C type, respectively. You can use them for communication -C between your program that calls SDASSL and the -C RES subroutine (and the JAC subroutine). They are not -C altered by SDASSL. If you do not need RPAR or IPAR, -C ignore these parameters by treating them as dummy -C arguments. If you do choose to use them, dimension -C them in your calling program and in RES (and in JAC) -C as arrays of appropriate length. -C -C JAC -- If you have set INFO(5)=0, you can ignore this parameter -C by treating it as a dummy argument. Otherwise, you must -C provide a subroutine of the form -C SUBROUTINE JAC(T,Y,YPRIME,PD,CJ,RPAR,IPAR) -C to define the matrix of partial derivatives -C PD=DG/DY+CJ*DG/DYPRIME -C CJ is a scalar which is input to JAC. -C For the given values of T,Y,YPRIME, the -C subroutine must evaluate the non-zero partial -C derivatives for each equation and each solution -C component, and store these values in the -C matrix PD. The elements of PD are set to zero -C before each call to JAC so only non-zero elements -C need to be defined. -C -C Subroutine JAC must not alter T,Y,(*),YPRIME(*), or CJ. -C You must declare the name JAC in an EXTERNAL statement in -C your program that calls SDASSL. You must dimension Y, -C YPRIME and PD in JAC. -C -C The way you must store the elements into the PD matrix -C depends on the structure of the matrix which you -C indicated by INFO(6). -C *** INFO(6)=0 -- Full (dense) matrix *** -C Give PD a first dimension of NEQ. -C When you evaluate the (non-zero) partial derivative -C of equation I with respect to variable J, you must -C store it in PD according to -C PD(I,J) = "DG(I)/DY(J)+CJ*DG(I)/DYPRIME(J)" -C *** INFO(6)=1 -- Banded JACOBIAN with ML lower and MU -C upper diagonal bands (refer to INFO(6) description -C of ML and MU) *** -C Give PD a first dimension of 2*ML+MU+1. -C when you evaluate the (non-zero) partial derivative -C of equation I with respect to variable J, you must -C store it 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 RPAR and IPAR are real and integer parameter arrays -C which you can use for communication between your calling -C program and your JACOBIAN subroutine JAC. They are not -C altered by SDASSL. If you do not need RPAR or IPAR, -C ignore these parameters by treating them as dummy -C arguments. If you do choose to use them, dimension -C them in your calling program and in JAC as arrays of -C appropriate length. -C -C -C OPTIONALLY REPLACEABLE NORM ROUTINE: -C -C SDASSL uses a weighted norm SDANRM to measure the size -C of vectors such as the estimated error in each step. -C A FUNCTION subprogram -C REAL FUNCTION SDANRM(NEQ,V,WT,RPAR,IPAR) -C DIMENSION V(NEQ),WT(NEQ) -C is used to define this norm. Here, V is the vector -C whose norm is to be computed, and WT is a vector of -C weights. A SDANRM routine has been included with SDASSL -C which computes the weighted root-mean-square norm -C given by -C SDANRM=SQRT((1/NEQ)*SUM(V(I)/WT(I))**2) -C this norm is suitable for most problems. In some -C special cases, it may be more convenient and/or -C efficient to define your own norm by writing a function -C subprogram to be called instead of SDANRM. This should, -C however, be attempted only after careful thought and -C consideration. -C -C -C -------- OUTPUT -- AFTER ANY RETURN FROM SDASSL --------------------- -C -C The principal aim of the code is to return a computed solution at -C TOUT, although it is also possible to obtain intermediate results -C along the way. To find out whether the code achieved its goal -C or if the integration process was interrupted before the task was -C completed, you must check the IDID parameter. -C -C -C T -- The solution was successfully advanced to the -C output value of T. -C -C Y(*) -- Contains the computed solution approximation at T. -C -C YPRIME(*) -- Contains the computed derivative -C approximation at T. -C -C IDID -- Reports what the code did. -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(*) is obtained by interpolation. -C YPRIME(*) is obtained by interpolation. -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 -C component is zero. Thus, a pure relative error -C test is impossible for this component. -C -C IDID = -6 -- SDASSL had repeated error test -C failures on the last attempted step. -C -C IDID = -7 -- The corrector could not converge. -C -C IDID = -8 -- The matrix of partial derivatives -C is singular. -C -C IDID = -9 -- The corrector could not converge. -C there were repeated error test failures -C in this step. -C -C IDID =-10 -- The corrector could not converge -C because IRES was equal to minus one. -C -C IDID =-11 -- IRES equal to -2 was encountered -C and control is being returned to the -C calling program. -C -C IDID =-12 -- SDASSL failed to compute the initial -C YPRIME. -C -C -C -C IDID = -13,..,-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 -C interest to the user but necessary for subsequent calls. -C However, you may find use for -C -C RWORK(3)--Which contains the step size H to be -C attempted on the next step. -C -C RWORK(4)--Which contains the current value of the -C independent variable, i.e., the farthest point -C integration has reached. This will be different -C from T only when interpolation has been -C performed (IDID=3). -C -C RWORK(7)--Which contains the stepsize used -C on the last successful step. -C -C IWORK(7)--Which contains the order of the method to -C be attempted on the next step. -C -C IWORK(8)--Which contains the order of the method used -C on the last step. -C -C IWORK(11)--Which contains the number of steps taken so -C far. -C -C IWORK(12)--Which contains the number of calls to RES -C so far. -C -C IWORK(13)--Which contains the number of evaluations of -C the matrix of partial derivatives needed so -C far. -C -C IWORK(14)--Which contains the total number -C of error test failures so far. -C -C IWORK(15)--Which contains the total number -C of convergence test failures so far. -C (includes singular iteration matrix -C failures.) -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, -C in particular do not alter NEQ,T,Y(*),YPRIME(*),RWORK(*),IWORK(*) -C or the differential equation in subroutine RES. Any such -C alteration constitutes a new problem and must be treated as such, -C i.e., you must start afresh. -C -C You cannot change from vector to scalar error control or vice -C versa (INFO(2)), but you can change the size of the entries of -C RTOL, 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), IWORK(1), or IWORK(2) -C unless you are going to restart the code. -C -C *** Following a completed task *** -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 *** Following an interrupted task *** -C To show the code that you realize the task was -C interrupted and that you want to continue, you -C must take appropriate action and set INFO(1) = 1 -C If -C IDID = -1, The code has taken about 500 steps. -C If you want to continue, set INFO(1) = 1 and -C call the code again. An additional 500 steps -C will be allowed. -C -C IDID = -2, The error tolerances RTOL, ATOL have been -C increased to values the code estimates appropriate -C for continuing. You may want to change them -C yourself. If you are sure you want to continue -C with relaxed error tolerances, set INFO(1)=1 and -C call the code 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 -C alter the error criterion to use positive values -C for those components of ATOL corresponding to zero -C solution components, then set INFO(1)=1 and call -C the code again. -C -C IDID = -4,-5 --- Cannot occur with this code. -C -C IDID = -6, Repeated error test failures occurred on the -C last attempted step in SDASSL. 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 -C on the last attempted step in SDASSL. An inaccurate -C or ill-conditioned JACOBIAN may be the problem. If -C you are absolutely certain you want to continue, you -C should restart the integration. -C -C IDID = -8, The matrix of partial derivatives is singular. -C Some of your equations may be redundant. -C SDASSL cannot solve the problem as stated. -C It is possible that the redundant equations -C could be removed, and then SDASSL could -C solve the problem. It is also possible -C that a solution to your problem either -C does not exist or is not unique. -C -C IDID = -9, SDASSL had multiple convergence test -C failures, preceded by multiple error -C test failures, on the last attempted step. -C It is possible that your problem -C is ill-posed, and cannot be solved -C using this code. Or, there may be a -C discontinuity or a singularity in the -C solution. If you are absolutely certain -C you want to continue, you should restart -C the integration. -C -C IDID =-10, SDASSL had multiple convergence test failures -C because IRES was equal to minus one. -C If you are absolutely certain you want -C to continue, you should restart the -C integration. -C -C IDID =-11, IRES=-2 was encountered, and control is being -C returned to the calling program. -C -C IDID =-12, SDASSL failed to compute the initial YPRIME. -C This could happen because the initial -C approximation to YPRIME was not very good, or -C if a YPRIME consistent with the initial Y -C does not exist. The problem could also be caused -C by an inaccurate or singular iteration matrix. -C -C IDID = -13,..,-32 --- Cannot occur with this code. -C -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 -C run being terminated. -C -C -C -------- ERROR MESSAGES --------------------------------------------- -C -C The SLATEC error print routine XERMSG is called in the event of -C unsuccessful completion of a task. Most of these are treated as -C "recoverable errors", which means that (unless the user has directed -C otherwise) control will be returned to the calling program for -C possible action after the message has been printed. -C -C In the event of a negative value of IDID other than -33, an appro- -C priate message is printed and the "error number" printed by XERMSG -C is the value of IDID. There are quite a number of illegal input -C errors that can lead to a returned value IDID=-33. The conditions -C and their printed "error numbers" are as follows: -C -C Error number Condition -C -C 1 Some element of INFO vector is not zero or one. -C 2 NEQ .le. 0 -C 3 MAXORD not in range. -C 4 LRW is less than the required length for RWORK. -C 5 LIW is less than the required length for IWORK. -C 6 Some element of RTOL is .lt. 0 -C 7 Some element of ATOL is .lt. 0 -C 8 All elements of RTOL and ATOL are zero. -C 9 INFO(4)=1 and TSTOP is behind TOUT. -C 10 HMAX .lt. 0.0 -C 11 TOUT is behind T. -C 12 INFO(8)=1 and H0=0.0 -C 13 Some element of WT is .le. 0.0 -C 14 TOUT is too close to T to start integration. -C 15 INFO(4)=1 and TSTOP is behind T. -C 16 --( Not used in this version )-- -C 17 ML illegal. Either .lt. 0 or .gt. NEQ -C 18 MU illegal. Either .lt. 0 or .gt. NEQ -C 19 TOUT = T. -C -C If SDASSL is called again without any action taken to remove the -C cause of an unsuccessful return, XERMSG will be called with a fatal -C error flag, which will cause unconditional termination of the -C program. There are two such fatal errors: -C -C Error number -998: The last step was terminated with a negative -C value of IDID other than -33, and no appropriate action was -C taken. -C -C Error number -999: The previous call was terminated because of -C illegal input (IDID=-33) and there is illegal input in the -C present call, as well. (Suspect infinite loop.) -C -C --------------------------------------------------------------------- -C -C***REFERENCES A DESCRIPTION OF DASSL: A DIFFERENTIAL/ALGEBRAIC -C SYSTEM SOLVER, L. R. PETZOLD, SAND82-8637, -C SANDIA NATIONAL LABORATORIES, SEPTEMBER 1982. -C***ROUTINES CALLED R1MACH, SDAINI, SDANRM, SDASTP, SDATRP, SDAWTS, -C XERMSG -C***REVISION HISTORY (YYMMDD) -C 830315 DATE WRITTEN -C 880387 Code changes made. All common statements have been -C replaced by a DATA statement, which defines pointers into -C RWORK, and PARAMETER statements which define pointers -C into IWORK. As well the documentation has gone through -C grammatical changes. -C 881005 The prologue has been changed to mixed case. -C The subordinate routines had revision dates changed to -C this date, although the documentation for these routines -C is all upper case. No code changes. -C 890511 Code changes made. The DATA statement in the declaration -C section of SDASSL was replaced with a PARAMETER -C statement. Also the statement S = 100.E0 was removed -C from the top of the Newton iteration in SDASTP. -C The subordinate routines had revision dates changed to -C this date. -C 890517 The revision date syntax was replaced with the revision -C history syntax. Also the "DECK" comment was added to -C the top of all subroutines. These changes are consistent -C with new SLATEC guidelines. -C The subordinate routines had revision dates changed to -C this date. No code changes. -C 891013 Code changes made. -C Removed all occurrences of FLOAT. All operations -C are now performed with "mixed-mode" arithmetic. -C Also, specific function names were replaced with generic -C function names to be consistent with new SLATEC guidelines. -C In particular: -C Replaced AMIN1 with MIN everywhere. -C Replaced MIN0 with MIN everywhere. -C Replaced AMAX1 with MAX everywhere. -C Replaced MAX0 with MAX everywhere. -C Also replaced REVISION DATE with REVISION HISTORY in all -C subordinate routines. -C 901004 Miscellaneous changes to prologue to complete conversion -C to SLATEC 4.0 format. No code changes. (F.N.Fritsch) -C 901009 Corrected GAMS classification code and converted subsidiary -C routines to 4.0 format. No code changes. (F.N.Fritsch) -C 901010 Converted XERRWV calls to XERMSG calls. (R.Clemens, AFWL) -C 901019 Code changes made. -C Merged SLATEC 4.0 changes with previous changes made -C by C. Ulrich. Below is a history of the changes made by -C C. Ulrich. (Changes in subsidiary routines are implied -C by this history) -C 891228 Bug was found and repaired inside the SDASSL -C and SDAINI routines. SDAINI was incorrectly -C returning the initial T with Y and YPRIME -C computed at T+H. The routine now returns T+H -C rather than the initial T. -C Cosmetic changes made to SDASTP. -C 900904 Three modifications were made to fix a bug (inside -C SDASSL) re interpolation for continuation calls and -C cases where TN is very close to TSTOP: -C -C 1) In testing for whether H is too large, just -C compare H to (TSTOP - TN), rather than -C (TSTOP - TN) * (1-4*UROUND), and set H to -C TSTOP - TN. This will force SDASTP to step -C exactly to TSTOP under certain situations -C (i.e. when H returned from SDASTP would otherwise -C take TN beyond TSTOP). -C -C 2) Inside the SDASTP loop, interpolate exactly to -C TSTOP if TN is very close to TSTOP (rather than -C interpolating to within roundoff of TSTOP). -C -C 3) Modified IDID description for IDID = 2 to say -C that the solution is returned by stepping exactly -C to TSTOP, rather than TOUT. (In some cases the -C solution is actually obtained by extrapolating -C over a distance near unit roundoff to TSTOP, -C but this small distance is deemed acceptable in -C these circumstances.) -C 901026 Added explicit declarations for all variables and minor -C cosmetic changes to prologue, removed unreferenced labels, -C and improved XERMSG calls. (FNF) -C 901030 Added ERROR MESSAGES section and reworked other sections to -C be of more uniform format. (FNF) -C 910624 Fixed minor bug related to HMAX (six lines after label -C 525). (LRP) -C***END PROLOGUE SDASSL -C -C**End -C -C Declare arguments. -C - INTEGER NEQ, INFO(15), IDID, LRW, IWORK(*), LIW, IPAR(*) - REAL T, Y(*), YPRIME(*), TOUT, RTOL(*), ATOL(*), RWORK(*), - * RPAR(*) - EXTERNAL RES, JAC -C -C Declare externals. -C - EXTERNAL R1MACH, SDAINI, SDANRM, SDASTP, SDATRP, SDAWTS, XERMSG - REAL R1MACH, SDANRM -C -C Declare local variables. -C - INTEGER I, ITEMP, LALPHA, LBETA, LCJ, LCJOLD, LCTF, LDELTA, - * LENIW, LENPD, LENRW, LE, LETF, LGAMMA, LH, LHMAX, LHOLD, LIPVT, - * LJCALC, LK, LKOLD, LIWM, LML, LMTYPE, LMU, LMXORD, LNJE, LNPD, - * LNRE, LNS, LNST, LNSTL, LPD, LPHASE, LPHI, LPSI, LROUND, LS, - * LSIGMA, LTN, LTSTOP, LWM, LWT, MBAND, MSAVE, MXORD, NPD, NTEMP, - * NZFLG - REAL ATOLI, H, HMAX, HMIN, HO, R, RH, RTOLI, TDIST, TN, TNEXT, - * TSTOP, UROUND, YPNORM - LOGICAL DONE -C Auxiliary variables for conversion of values to be included in -C error messages. - CHARACTER*8 XERN1, XERN2 - CHARACTER*16 XERN3, XERN4 -C -C SET POINTERS INTO IWORK - PARAMETER (LML=1, LMU=2, LMXORD=3, LMTYPE=4, LNST=11, - * LNRE=12, LNJE=13, LETF=14, LCTF=15, LNPD=16, - * LIPVT=21, LJCALC=5, LPHASE=6, LK=7, LKOLD=8, - * LNS=9, LNSTL=10, LIWM=1) -C -C SET RELATIVE OFFSET INTO RWORK - PARAMETER (NPD=1) -C -C SET POINTERS INTO RWORK - PARAMETER (LTSTOP=1, LHMAX=2, LH=3, LTN=4, - * LCJ=5, LCJOLD=6, LHOLD=7, LS=8, LROUND=9, - * LALPHA=11, LBETA=17, LGAMMA=23, - * LPSI=29, LSIGMA=35, LDELTA=41) -C -C***FIRST EXECUTABLE STATEMENT SDASSL - 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 EITHER ZERO OR ONE. - DO 10 I=2,11 - IF(INFO(I).NE.0.AND.INFO(I).NE.1)GO TO 701 -10 CONTINUE -C - IF(NEQ.LE.0)GO TO 702 -C -C CHECK AND COMPUTE MAXIMUM ORDER - MXORD=5 - IF(INFO(9).EQ.0)GO TO 20 - MXORD=IWORK(LMXORD) - IF(MXORD.LT.1.OR.MXORD.GT.5)GO TO 703 -20 IWORK(LMXORD)=MXORD -C -C COMPUTE MTYPE,LENPD,LENRW.CHECK ML AND MU. - IF(INFO(6).NE.0)GO TO 40 - LENPD=NEQ**2 - LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD - IF(INFO(5).NE.0)GO TO 30 - IWORK(LMTYPE)=2 - GO TO 60 -30 IWORK(LMTYPE)=1 - GO TO 60 -40 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).NE.0)GO TO 50 - IWORK(LMTYPE)=5 - MBAND=IWORK(LML)+IWORK(LMU)+1 - MSAVE=(NEQ/MBAND)+1 - LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD+2*MSAVE - GO TO 60 -50 IWORK(LMTYPE)=4 - LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD -C -C CHECK LENGTHS OF RWORK AND IWORK -60 LENIW=20+NEQ - IWORK(LNPD)=LENPD - IF(LRW.LT.LENRW)GO TO 704 - IF(LIW.LT.LENIW)GO TO 705 -C -C CHECK TO SEE THAT TOUT IS DIFFERENT FROM T - IF(TOUT .EQ. T)GO TO 719 -C -C CHECK HMAX - IF(INFO(7).EQ.0)GO TO 70 - HMAX=RWORK(LHMAX) - IF(HMAX.LE.0.0E0)GO TO 710 -70 CONTINUE -C -C INITIALIZE COUNTERS - IWORK(LNST)=0 - IWORK(LNRE)=0 - IWORK(LNJE)=0 -C - IWORK(LNSTL)=0 - IDID=1 - GO TO 200 -C -C----------------------------------------------------------------------- -C THIS BLOCK IS FOR CONTINUATION CALLS -C ONLY. HERE WE CHECK INFO(1), AND IF THE -C LAST STEP WAS INTERRUPTED WE CHECK WHETHER -C APPROPRIATE ACTION WAS TAKEN. -C----------------------------------------------------------------------- -C -100 CONTINUE - IF(INFO(1).EQ.1)GO TO 110 - IF(INFO(1).NE.-1)GO TO 701 -C -C IF WE ARE HERE, THE LAST STEP WAS INTERRUPTED -C BY AN ERROR CONDITION FROM SDASTP, AND -C APPROPRIATE ACTION WAS NOT TAKEN. THIS -C IS A FATAL ERROR. - WRITE (XERN1, '(I8)') IDID - CALL XERMSG ('SLATEC', 'SDASSL', - * 'THE LAST STEP TERMINATED WITH A NEGATIVE VALUE OF IDID = ' // - * XERN1 // ' AND NO APPROPRIATE ACTION WAS TAKEN. ' // - * 'RUN TERMINATED', -998, 2) - RETURN -110 CONTINUE - IWORK(LNSTL)=IWORK(LNST) -C -C----------------------------------------------------------------------- -C THIS BLOCK IS EXECUTED ON ALL CALLS. -C THE ERROR TOLERANCE PARAMETERS ARE -C CHECKED, AND THE WORK ARRAY POINTERS -C ARE SET. -C----------------------------------------------------------------------- -C -200 CONTINUE -C CHECK RTOL,ATOL - 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.0E0.OR.ATOLI.GT.0.0E0)NZFLG=1 - IF(RTOLI.LT.0.0E0)GO TO 706 - IF(ATOLI.LT.0.0E0)GO TO 707 -210 CONTINUE - IF(NZFLG.EQ.0)GO TO 708 -C -C SET UP RWORK STORAGE.IWORK STORAGE IS FIXED -C IN DATA STATEMENT. - LE=LDELTA+NEQ - LWT=LE+NEQ - LPHI=LWT+NEQ - LPD=LPHI+(IWORK(LMXORD)+1)*NEQ - LWM=LPD - NTEMP=NPD+IWORK(LNPD) - IF(INFO(1).EQ.1)GO TO 400 -C -C----------------------------------------------------------------------- -C THIS BLOCK IS EXECUTED ON THE INITIAL CALL -C ONLY. SET THE INITIAL STEP SIZE, AND -C THE ERROR WEIGHT VECTOR, AND PHI. -C COMPUTE INITIAL YPRIME, IF NECESSARY. -C----------------------------------------------------------------------- -C - TN=T - IDID=1 -C -C SET ERROR WEIGHT VECTOR WT - CALL SDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) - DO 305 I = 1,NEQ - IF(RWORK(LWT+I-1).LE.0.0E0) GO TO 713 -305 CONTINUE -C -C COMPUTE UNIT ROUNDOFF AND HMIN - UROUND = R1MACH(4) - RWORK(LROUND) = UROUND - HMIN = 4.0E0*UROUND*MAX(ABS(T),ABS(TOUT)) -C -C CHECK INITIAL INTERVAL TO SEE THAT IT IS LONG ENOUGH - TDIST = ABS(TOUT - T) - IF(TDIST .LT. HMIN) GO TO 714 -C -C CHECK HO, IF THIS WAS INPUT - IF (INFO(8) .EQ. 0) GO TO 310 - HO = RWORK(LH) - IF ((TOUT - T)*HO .LT. 0.0E0) GO TO 711 - IF (HO .EQ. 0.0E0) GO TO 712 - GO TO 320 -310 CONTINUE -C -C COMPUTE INITIAL STEPSIZE, TO BE USED BY EITHER -C SDASTP OR SDAINI, DEPENDING ON INFO(11) - HO = 0.001E0*TDIST - YPNORM = SDANRM(NEQ,YPRIME,RWORK(LWT),RPAR,IPAR) - IF (YPNORM .GT. 0.5E0/HO) HO = 0.5E0/YPNORM - HO = SIGN(HO,TOUT-T) -C ADJUST HO IF NECESSARY TO MEET HMAX BOUND -320 IF (INFO(7) .EQ. 0) GO TO 330 - RH = ABS(HO)/RWORK(LHMAX) - IF (RH .GT. 1.0E0) HO = HO/RH -C COMPUTE TSTOP, IF APPLICABLE -330 IF (INFO(4) .EQ. 0) GO TO 340 - TSTOP = RWORK(LTSTOP) - IF ((TSTOP - T)*HO .LT. 0.0E0) GO TO 715 - IF ((T + HO - TSTOP)*HO .GT. 0.0E0) HO = TSTOP - T - IF ((TSTOP - TOUT)*HO .LT. 0.0E0) GO TO 709 -C -C COMPUTE INITIAL DERIVATIVE, UPDATING TN AND Y, IF APPLICABLE -340 IF (INFO(11) .EQ. 0) GO TO 350 - CALL SDAINI(TN,Y,YPRIME,NEQ, - * RES,JAC,HO,RWORK(LWT),IDID,RPAR,IPAR, - * RWORK(LPHI),RWORK(LDELTA),RWORK(LE), - * RWORK(LWM),IWORK(LIWM),HMIN,RWORK(LROUND), - * INFO(10),NTEMP) - IF (IDID .LT. 0) GO TO 390 -C -C LOAD H WITH HO. STORE H IN RWORK(LH) -350 H = HO - RWORK(LH) = H -C -C LOAD Y AND H*YPRIME INTO PHI(*,1) AND PHI(*,2) - ITEMP = LPHI + NEQ - DO 370 I = 1,NEQ - RWORK(LPHI + I - 1) = Y(I) -370 RWORK(ITEMP + I - 1) = H*YPRIME(I) -C -390 GO TO 500 -C -C------------------------------------------------------- -C THIS BLOCK IS FOR CONTINUATION CALLS ONLY. ITS -C PURPOSE IS TO CHECK STOP CONDITIONS BEFORE -C 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.0E0) H = H/RH -410 CONTINUE - IF(T .EQ. TOUT) GO TO 719 - IF((T - TOUT)*H .GT. 0.0E0) 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.0E0)GO TO 490 - CALL SDATRP(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.0E0) GO TO 490 - IF((TN - TOUT)*H .GT. 0.0E0) GO TO 425 - CALL SDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T = TN - IDID = 1 - DONE = .TRUE. - GO TO 490 -425 CONTINUE - CALL SDATRP(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) - IF((TN-TSTOP)*H.GT.0.0E0) GO TO 715 - IF((TSTOP-TOUT)*H.LT.0.0E0)GO TO 709 - IF((TN-TOUT)*H.LT.0.0E0)GO TO 450 - CALL SDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T=TOUT - IDID = 3 - DONE = .TRUE. - GO TO 490 -440 TSTOP = RWORK(LTSTOP) - IF((TN-TSTOP)*H .GT. 0.0E0) GO TO 715 - IF((TSTOP-TOUT)*H .LT. 0.0E0) GO TO 709 - IF((TN-T)*H .LE. 0.0E0) GO TO 450 - IF((TN - TOUT)*H .GT. 0.0E0) GO TO 445 - CALL SDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T = TN - IDID = 1 - DONE = .TRUE. - GO TO 490 -445 CONTINUE - CALL SDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T = TOUT - IDID = 3 - DONE = .TRUE. - GO TO 490 -450 CONTINUE -C CHECK WHETHER WE ARE WITHIN ROUNDOFF OF TSTOP - IF(ABS(TN-TSTOP).GT.100.0E0*UROUND* - * (ABS(TN)+ABS(H)))GO TO 460 - CALL SDATRP(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.0E0)GO TO 490 - H=TSTOP-TN - RWORK(LH)=H -C -490 IF (DONE) GO TO 580 -C -C------------------------------------------------------- -C THE NEXT BLOCK CONTAINS THE CALL TO THE -C ONE-STEP INTEGRATOR SDASTP. -C THIS IS A LOOPING POINT FOR THE INTEGRATION STEPS. -C CHECK FOR TOO MANY STEPS. -C UPDATE WT. -C CHECK FOR TOO MUCH ACCURACY REQUESTED. -C COMPUTE MINIMUM STEPSIZE. -C------------------------------------------------------- -C -500 CONTINUE -C CHECK FOR FAILURE TO COMPUTE INITIAL YPRIME - IF (IDID .EQ. -12) GO TO 527 -C -C CHECK FOR TOO MANY STEPS - IF((IWORK(LNST)-IWORK(LNSTL)).LT.500) - * GO TO 510 - IDID=-1 - GO TO 527 -C -C UPDATE WT -510 CALL SDAWTS(NEQ,INFO(2),RTOL,ATOL,RWORK(LPHI), - * RWORK(LWT),RPAR,IPAR) - DO 520 I=1,NEQ - IF(RWORK(I+LWT-1).GT.0.0E0)GO TO 520 - IDID=-3 - GO TO 527 -520 CONTINUE -C -C TEST FOR TOO MUCH ACCURACY REQUESTED. - R=SDANRM(NEQ,RWORK(LPHI),RWORK(LWT),RPAR,IPAR)* - * 100.0E0*UROUND - IF(R.LE.1.0E0)GO TO 525 -C MULTIPLY RTOL AND ATOL BY R AND RETURN - 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 - HMIN=4.0E0*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.0E0) H = H/RH - ENDIF -C - CALL SDASTP(TN,Y,YPRIME,NEQ, - * RES,JAC,H,RWORK(LWT),INFO(1),IDID,RPAR,IPAR, - * RWORK(LPHI),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), - * IWORK(LPHASE),IWORK(LJCALC),IWORK(LK), - * IWORK(LKOLD),IWORK(LNS),INFO(10),NTEMP) -527 IF(IDID.LT.0)GO TO 600 -C -C-------------------------------------------------------- -C THIS BLOCK HANDLES THE CASE OF A SUCCESSFUL RETURN -C FROM SDASTP (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.0E0)GO TO 500 - CALL SDATRP(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.0E0)GO TO 535 - T=TN - IDID=1 - GO TO 580 -535 CALL SDATRP(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.0E0)GO TO 542 - CALL SDATRP(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.0E0*UROUND* - * (ABS(TN)+ABS(H)))GO TO 545 - TNEXT=TN+H - IF((TNEXT-TSTOP)*H.LE.0.0E0)GO TO 500 - H=TSTOP-TN - GO TO 500 -545 CALL SDATRP(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.0E0)GO TO 555 - IF(ABS(TN-TSTOP).LE.100.0E0*UROUND*(ABS(TN)+ABS(H)))GO TO 552 - T=TN - IDID=1 - GO TO 580 -552 CALL SDATRP(TN,TSTOP,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - IDID=2 - T=TSTOP - GO TO 580 -555 CALL SDATRP(TN,TOUT,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - T=TOUT - IDID=3 - GO TO 580 -C -C-------------------------------------------------------- -C ALL SUCCESSFUL RETURNS FROM SDASSL ARE MADE FROM -C THIS BLOCK. -C-------------------------------------------------------- -C -580 CONTINUE - RWORK(LTN)=TN - RWORK(LH)=H - RETURN -C -C----------------------------------------------------------------------- -C THIS BLOCK HANDLES ALL UNSUCCESSFUL -C RETURNS OTHER THAN FOR ILLEGAL INPUT. -C----------------------------------------------------------------------- -C -600 CONTINUE - ITEMP=-IDID - GO TO (610,620,630,690,690,640,650,660,670,675, - * 680,685), ITEMP -C -C THE MAXIMUM NUMBER OF STEPS WAS TAKEN BEFORE -C REACHING TOUT -610 WRITE (XERN3, '(1P,E15.6)') TN - CALL XERMSG ('SLATEC', 'SDASSL', - * 'AT CURRENT T = ' // XERN3 // ' 500 STEPS TAKEN ON THIS ' // - * 'CALL BEFORE REACHING TOUT', IDID, 1) - GO TO 690 -C -C TOO MUCH ACCURACY FOR MACHINE PRECISION -620 WRITE (XERN3, '(1P,E15.6)') TN - CALL XERMSG ('SLATEC', 'SDASSL', - * 'AT T = ' // XERN3 // ' TOO MUCH ACCURACY REQUESTED FOR ' // - * 'PRECISION OF MACHINE. RTOL AND ATOL WERE INCREASED TO ' // - * 'APPROPRIATE VALUES', IDID, 1) - GO TO 690 -C -C WT(I) .LE. 0.0 FOR SOME I (NOT AT START OF PROBLEM) -630 WRITE (XERN3, '(1P,E15.6)') TN - CALL XERMSG ('SLATEC', 'SDASSL', - * 'AT T = ' // XERN3 // ' SOME ELEMENT OF WT HAS BECOME .LE. ' // - * '0.0', IDID, 1) - GO TO 690 -C -C ERROR TEST FAILED REPEATEDLY OR WITH H=HMIN -640 WRITE (XERN3, '(1P,E15.6)') TN - WRITE (XERN4, '(1P,E15.6)') H - CALL XERMSG ('SLATEC', 'SDASSL', - * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // - * ' THE ERROR TEST FAILED REPEATEDLY OR WITH ABS(H)=HMIN', - * IDID, 1) - GO TO 690 -C -C CORRECTOR CONVERGENCE FAILED REPEATEDLY OR WITH H=HMIN -650 WRITE (XERN3, '(1P,E15.6)') TN - WRITE (XERN4, '(1P,E15.6)') H - CALL XERMSG ('SLATEC', 'SDASSL', - * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // - * ' THE CORRECTOR FAILED TO CONVERGE REPEATEDLY OR WITH ' // - * 'ABS(H)=HMIN', IDID, 1) - GO TO 690 -C -C THE ITERATION MATRIX IS SINGULAR -660 WRITE (XERN3, '(1P,E15.6)') TN - WRITE (XERN4, '(1P,E15.6)') H - CALL XERMSG ('SLATEC', 'SDASSL', - * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // - * ' THE ITERATION MATRIX IS SINGULAR', IDID, 1) - GO TO 690 -C -C CORRECTOR FAILURE PRECEDED BY ERROR TEST FAILURES. -670 WRITE (XERN3, '(1P,E15.6)') TN - WRITE (XERN4, '(1P,E15.6)') H - CALL XERMSG ('SLATEC', 'SDASSL', - * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // - * ' THE CORRECTOR COULD NOT CONVERGE. ALSO, THE ERROR TEST ' // - * 'FAILED REPEATEDLY.', IDID, 1) - GO TO 690 -C -C CORRECTOR FAILURE BECAUSE IRES = -1 -675 WRITE (XERN3, '(1P,E15.6)') TN - WRITE (XERN4, '(1P,E15.6)') H - CALL XERMSG ('SLATEC', 'SDASSL', - * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // - * ' THE CORRECTOR COULD NOT CONVERGE BECAUSE IRES WAS EQUAL ' // - * 'TO MINUS ONE', IDID, 1) - GO TO 690 -C -C FAILURE BECAUSE IRES = -2 -680 WRITE (XERN3, '(1P,E15.6)') TN - WRITE (XERN4, '(1P,E15.6)') H - CALL XERMSG ('SLATEC', 'SDASSL', - * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // - * ' IRES WAS EQUAL TO MINUS TWO', IDID, 1) - GO TO 690 -C -C FAILED TO COMPUTE INITIAL YPRIME -685 WRITE (XERN3, '(1P,E15.6)') TN - WRITE (XERN4, '(1P,E15.6)') HO - CALL XERMSG ('SLATEC', 'SDASSL', - * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // - * ' THE INITIAL YPRIME COULD NOT BE COMPUTED', IDID, 1) - GO TO 690 -C -690 CONTINUE - INFO(1)=-1 - T=TN - RWORK(LTN)=TN - RWORK(LH)=H - RETURN -C -C----------------------------------------------------------------------- -C THIS BLOCK HANDLES ALL ERROR RETURNS DUE -C TO ILLEGAL INPUT, AS DETECTED BEFORE CALLING -C SDASTP. FIRST THE ERROR MESSAGE ROUTINE IS -C CALLED. IF THIS HAPPENS TWICE IN -C SUCCESSION, EXECUTION IS TERMINATED -C -C----------------------------------------------------------------------- -701 CALL XERMSG ('SLATEC', 'SDASSL', - * 'SOME ELEMENT OF INFO VECTOR IS NOT ZERO OR ONE', 1, 1) - GO TO 750 -C -702 WRITE (XERN1, '(I8)') NEQ - CALL XERMSG ('SLATEC', 'SDASSL', - * 'NEQ = ' // XERN1 // ' .LE. 0', 2, 1) - GO TO 750 -C -703 WRITE (XERN1, '(I8)') MXORD - CALL XERMSG ('SLATEC', 'SDASSL', - * 'MAXORD = ' // XERN1 // ' NOT IN RANGE', 3, 1) - GO TO 750 -C -704 WRITE (XERN1, '(I8)') LENRW - WRITE (XERN2, '(I8)') LRW - CALL XERMSG ('SLATEC', 'SDASSL', - * 'RWORK LENGTH NEEDED, LENRW = ' // XERN1 // - * ', EXCEEDS LRW = ' // XERN2, 4, 1) - GO TO 750 -C -705 WRITE (XERN1, '(I8)') LENIW - WRITE (XERN2, '(I8)') LIW - CALL XERMSG ('SLATEC', 'SDASSL', - * 'IWORK LENGTH NEEDED, LENIW = ' // XERN1 // - * ', EXCEEDS LIW = ' // XERN2, 5, 1) - GO TO 750 -C -706 CALL XERMSG ('SLATEC', 'SDASSL', - * 'SOME ELEMENT OF RTOL IS .LT. 0', 6, 1) - GO TO 750 -C -707 CALL XERMSG ('SLATEC', 'SDASSL', - * 'SOME ELEMENT OF ATOL IS .LT. 0', 7, 1) - GO TO 750 -C -708 CALL XERMSG ('SLATEC', 'SDASSL', - * 'ALL ELEMENTS OF RTOL AND ATOL ARE ZERO', 8, 1) - GO TO 750 -C -709 WRITE (XERN3, '(1P,E15.6)') TSTOP - WRITE (XERN4, '(1P,E15.6)') TOUT - CALL XERMSG ('SLATEC', 'SDASSL', - * 'INFO(4) = 1 AND TSTOP = ' // XERN3 // ' BEHIND TOUT = ' // - * XERN4, 9, 1) - GO TO 750 -C -710 WRITE (XERN3, '(1P,E15.6)') HMAX - CALL XERMSG ('SLATEC', 'SDASSL', - * 'HMAX = ' // XERN3 // ' .LT. 0.0', 10, 1) - GO TO 750 -C -711 WRITE (XERN3, '(1P,E15.6)') TOUT - WRITE (XERN4, '(1P,E15.6)') T - CALL XERMSG ('SLATEC', 'SDASSL', - * 'TOUT = ' // XERN3 // ' BEHIND T = ' // XERN4, 11, 1) - GO TO 750 -C -712 CALL XERMSG ('SLATEC', 'SDASSL', - * 'INFO(8)=1 AND H0=0.0', 12, 1) - GO TO 750 -C -713 CALL XERMSG ('SLATEC', 'SDASSL', - * 'SOME ELEMENT OF WT IS .LE. 0.0', 13, 1) - GO TO 750 -C -714 WRITE (XERN3, '(1P,E15.6)') TOUT - WRITE (XERN4, '(1P,E15.6)') T - CALL XERMSG ('SLATEC', 'SDASSL', - * 'TOUT = ' // XERN3 // ' TOO CLOSE TO T = ' // XERN4 // - * ' TO START INTEGRATION', 14, 1) - GO TO 750 -C -715 WRITE (XERN3, '(1P,E15.6)') TSTOP - WRITE (XERN4, '(1P,E15.6)') T - CALL XERMSG ('SLATEC', 'SDASSL', - * 'INFO(4)=1 AND TSTOP = ' // XERN3 // ' BEHIND T = ' // XERN4, - * 15, 1) - GO TO 750 -C -717 WRITE (XERN1, '(I8)') IWORK(LML) - CALL XERMSG ('SLATEC', 'SDASSL', - * 'ML = ' // XERN1 // ' ILLEGAL. EITHER .LT. 0 OR .GT. NEQ', - * 17, 1) - GO TO 750 -C -718 WRITE (XERN1, '(I8)') IWORK(LMU) - CALL XERMSG ('SLATEC', 'SDASSL', - * 'MU = ' // XERN1 // ' ILLEGAL. EITHER .LT. 0 OR .GT. NEQ', - * 18, 1) - GO TO 750 -C -719 WRITE (XERN3, '(1P,E15.6)') TOUT - CALL XERMSG ('SLATEC', 'SDASSL', - * 'TOUT = T = ' // XERN3, 19, 1) - GO TO 750 -C -750 IDID=-33 - IF(INFO(1).EQ.-1) THEN - CALL XERMSG ('SLATEC', 'SDASSL', - * 'REPEATED OCCURRENCES OF ILLEGAL INPUT$$' // - * 'RUN TERMINATED. APPARENT INFINITE LOOP', -999, 2) - ENDIF -C - INFO(1)=-1 - RETURN -C-----------END OF SUBROUTINE SDASSL------------------------------------ - END diff --git a/slatec/sdastp.f b/slatec/sdastp.f deleted file mode 100644 index dedc551..0000000 --- a/slatec/sdastp.f +++ /dev/null @@ -1,611 +0,0 @@ -*DECK SDASTP - SUBROUTINE SDASTP (X, Y, YPRIME, NEQ, RES, JAC, H, WT, JSTART, - * IDID, RPAR, IPAR, PHI, DELTA, E, WM, IWM, ALPHA, BETA, GAMMA, - * PSI, SIGMA, CJ, CJOLD, HOLD, S, HMIN, UROUND, IPHASE, JCALC, K, - * KOLD, NS, NONNEG, NTEMP) -C***BEGIN PROLOGUE SDASTP -C***SUBSIDIARY -C***PURPOSE Perform one step of the SDASSL integration. -C***LIBRARY SLATEC (DASSL) -C***TYPE SINGLE PRECISION (SDASTP-S, DDASTP-D) -C***AUTHOR Petzold, Linda R., (LLNL) -C***DESCRIPTION -C----------------------------------------------------------------------- -C SDASTP SOLVES A SYSTEM OF DIFFERENTIAL/ -C ALGEBRAIC EQUATIONS OF THE FORM -C G(X,Y,YPRIME) = 0, FOR ONE STEP (NORMALLY -C FROM X TO X+H). -C -C THE METHODS USED ARE MODIFIED DIVIDED -C DIFFERENCE,FIXED LEADING COEFFICIENT -C FORMS OF BACKWARD DIFFERENTIATION -C FORMULAS. THE CODE ADJUSTS THE STEPSIZE -C AND ORDER TO CONTROL THE LOCAL ERROR PER -C 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. THE CALL IS -C CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR) -C X,Y,YPRIME ARE INPUT. DELTA IS OUTPUT. -C ON INPUT, IRES=0. RES SHOULD ALTER IRES ONLY -C IF IT ENCOUNTERS AN ILLEGAL VALUE OF Y OR A -C STOP CONDITION. SET IRES=-1 IF AN INPUT VALUE -C OF Y IS ILLEGAL, AND SDASTP WILL TRY TO SOLVE -C THE PROBLEM WITHOUT GETTING IRES = -1. IF -C IRES=-2, SDASTP RETURNS CONTROL TO THE CALLING -C PROGRAM WITH IDID = -11. -C JAC -- EXTERNAL USER-SUPPLIED ROUTINE TO EVALUATE -C THE ITERATION MATRIX (THIS IS OPTIONAL) -C THE CALL IS OF THE FORM -C CALL JAC(X,Y,YPRIME,PD,CJ,RPAR,IPAR) -C PD IS THE MATRIX OF PARTIAL DERIVATIVES, -C PD=DG/DY+CJ*DG/DYPRIME -C H -- APPROPRIATE STEP SIZE FOR NEXT STEP. -C NORMALLY DETERMINED BY THE CODE -C WT -- VECTOR OF WEIGHTS FOR ERROR CRITERION. -C JSTART -- INTEGER VARIABLE SET 0 FOR -C FIRST STEP, 1 OTHERWISE. -C IDID -- COMPLETION CODE WITH THE FOLLOWING MEANINGS: -C IDID= 1 -- THE STEP WAS COMPLETED SUCCESSFULLY -C IDID=-6 -- THE ERROR TEST FAILED REPEATEDLY -C IDID=-7 -- THE CORRECTOR COULD NOT CONVERGE -C IDID=-8 -- THE ITERATION MATRIX IS SINGULAR -C IDID=-9 -- THE CORRECTOR COULD NOT CONVERGE. -C THERE WERE REPEATED ERROR TEST -C FAILURES ON THIS STEP. -C IDID=-10-- THE CORRECTOR COULD NOT CONVERGE -C BECAUSE IRES WAS EQUAL TO MINUS ONE -C IDID=-11-- IRES EQUAL TO -2 WAS ENCOUNTERED, -C AND CONTROL IS BEING RETURNED TO -C THE CALLING PROGRAM -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 SDASTP -C PHI -- ARRAY OF DIVIDED DIFFERENCES USED BY -C SDASTP. THE LENGTH IS NEQ*(K+1),WHERE -C K IS THE MAXIMUM ORDER -C DELTA,E -- WORK VECTORS FOR SDASTP 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 -C THE OTHER PARAMETERS ARE INFORMATION -C WHICH IS NEEDED INTERNALLY BY SDASTP TO -C CONTINUE FROM STEP TO STEP. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED SDAJAC, SDANRM, SDASLV, SDATRP -C***REVISION HISTORY (YYMMDD) -C 830315 DATE WRITTEN -C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) -C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. -C 901026 Added explicit declarations for all variables and minor -C cosmetic changes to prologue. (FNF) -C***END PROLOGUE SDASTP -C - INTEGER NEQ, JSTART, IDID, IPAR(*), IWM(*), IPHASE, JCALC, K, - * KOLD, NS, NONNEG, NTEMP - REAL X, Y(*), YPRIME(*), H, WT(*), RPAR(*), PHI(NEQ,*), DELTA(*), - * E(*), WM(*), ALPHA(*), BETA(*), GAMMA(*), PSI(*), SIGMA(*), CJ, - * CJOLD, HOLD, S, HMIN, UROUND - EXTERNAL RES, JAC -C - EXTERNAL SDAJAC, SDANRM, SDASLV, SDATRP - REAL SDANRM -C - INTEGER I, IER, IRES, J, J1, KDIFF, KM1, KNEW, KP1, KP2, LCTF, - * LETF, LMXORD, LNJE, LNRE, LNST, M, MAXIT, NCF, NEF, NSF, NSP1 - REAL ALPHA0, ALPHAS, CJLAST, CK, DELNRM, ENORM, ERK, ERKM1, - * ERKM2, ERKP1, ERR, EST, HNEW, OLDNRM, PNORM, R, RATE, TEMP1, - * TEMP2, TERK, TERKM1, TERKM2, TERKP1, XOLD, XRATE - LOGICAL CONVGD -C - PARAMETER (LMXORD=3) - PARAMETER (LNST=11) - PARAMETER (LNRE=12) - PARAMETER (LNJE=13) - PARAMETER (LETF=14) - PARAMETER (LCTF=15) -C - DATA MAXIT/4/ - DATA XRATE/0.25E0/ -C -C -C -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***FIRST EXECUTABLE STATEMENT SDASTP - IDID=1 - XOLD=X - NCF=0 - NSF=0 - NEF=0 - IF(JSTART .NE. 0) GO TO 120 -C -C IF THIS IS THE FIRST STEP,PERFORM -C OTHER INITIALIZATIONS - IWM(LETF) = 0 - IWM(LCTF) = 0 - K=1 - KOLD=0 - HOLD=0.0E0 - JSTART=1 - PSI(1)=H - CJOLD = 1.0E0/H - CJ = CJOLD - S = 100.E0 - JCALC = -1 - DELNRM=1.0E0 - 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 - XOLD=X - IF(H.NE.HOLD.OR.K .NE. KOLD) NS = 0 - NS=MIN(NS+1,KOLD+2) - NSP1=NS+1 - IF(KP1 .LT. NS)GO TO 230 -C - BETA(1)=1.0E0 - ALPHA(1)=1.0E0 - TEMP1=H - GAMMA(1)=0.0E0 - SIGMA(1)=1.0E0 - 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 - ALPHAS = 0.0E0 - ALPHA0 = 0.0E0 - DO 240 I = 1,K - ALPHAS = ALPHAS - 1.0E0/I - ALPHA0 = ALPHA0 - ALPHA(I) -240 CONTINUE -C -C COMPUTE LEADING COEFFICIENT CJ - CJLAST = CJ - CJ = -ALPHAS/H -C -C COMPUTE VARIABLE STEPSIZE ERROR COEFFICIENT CK - CK = ABS(ALPHA(KP1) + ALPHAS - ALPHA0) - CK = MAX(CK,ALPHA(KP1)) -C -C DECIDE WHETHER NEW JACOBIAN IS NEEDED - TEMP1 = (1.0E0 - XRATE)/(1.0E0 + XRATE) - TEMP2 = 1.0E0/TEMP1 - IF (CJ/CJOLD .LT. TEMP1 .OR. CJ/CJOLD .GT. TEMP2) JCALC = -1 - IF (CJ .NE. CJLAST) S = 100.E0 -C -C CHANGE PHI TO PHI STAR - 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 - X=X+H -C -C -C -C -C -C----------------------------------------------------------------------- -C BLOCK 3 -C PREDICT THE SOLUTION AND DERIVATIVE, -C AND SOLVE THE CORRECTOR EQUATION -C----------------------------------------------------------------------- -C -C FIRST,PREDICT THE SOLUTION AND DERIVATIVE -300 CONTINUE - DO 310 I=1,NEQ - Y(I)=PHI(I,1) -310 YPRIME(I)=0.0E0 - 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 = SDANRM (NEQ,Y,WT,RPAR,IPAR) -C -C -C -C SOLVE THE CORRECTOR EQUATION USING A -C MODIFIED NEWTON SCHEME. - CONVGD= .TRUE. - M=0 - IWM(LNRE)=IWM(LNRE)+1 - IRES = 0 - CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR) - IF (IRES .LT. 0) GO TO 380 -C -C -C IF INDICATED,REEVALUATE THE -C ITERATION MATRIX PD = DG/DY + CJ*DG/DYPRIME -C (WHERE G(X,Y,YPRIME)=0). SET -C JCALC TO 0 AS AN INDICATOR THAT -C THIS HAS BEEN DONE. - IF(JCALC .NE. -1)GO TO 340 - IWM(LNJE)=IWM(LNJE)+1 - JCALC=0 - CALL SDAJAC(NEQ,X,Y,YPRIME,DELTA,CJ,H, - * IER,WT,E,WM,IWM,RES,IRES,UROUND,JAC,RPAR, - * IPAR,NTEMP) - CJOLD=CJ - S = 100.E0 - IF (IRES .LT. 0) GO TO 380 - IF(IER .NE. 0)GO TO 380 - NSF=0 -C -C -C INITIALIZE THE ERROR ACCUMULATION VECTOR E. -340 CONTINUE - DO 345 I=1,NEQ -345 E(I)=0.0E0 -C -C -C CORRECTOR LOOP. -350 CONTINUE -C -C MULTIPLY RESIDUAL BY TEMP1 TO ACCELERATE CONVERGENCE - TEMP1 = 2.0E0/(1.0E0 + CJ/CJOLD) - DO 355 I = 1,NEQ -355 DELTA(I) = DELTA(I) * TEMP1 -C -C COMPUTE A NEW ITERATE (BACK-SUBSTITUTION). -C STORE THE CORRECTION IN DELTA. - CALL SDASLV(NEQ,DELTA,WM,IWM) -C -C UPDATE Y, E, AND YPRIME - 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 - DELNRM=SDANRM(NEQ,DELTA,WT,RPAR,IPAR) - IF (DELNRM .LE. 100.E0*UROUND*PNORM) GO TO 375 - IF (M .GT. 0) GO TO 365 - OLDNRM = DELNRM - GO TO 367 -365 RATE = (DELNRM/OLDNRM)**(1.0E0/M) - IF (RATE .GT. 0.90E0) GO TO 370 - S = RATE/(1.0E0 - RATE) -367 IF (S*DELNRM .LE. 0.33E0) GO TO 375 -C -C THE CORRECTOR HAS NOT YET CONVERGED. -C UPDATE M AND TEST WHETHER THE -C MAXIMUM NUMBER OF ITERATIONS HAVE -C BEEN TRIED. - M=M+1 - IF(M.GE.MAXIT)GO TO 370 -C -C EVALUATE THE RESIDUAL -C AND GO BACK TO DO ANOTHER ITERATION - IWM(LNRE)=IWM(LNRE)+1 - IRES = 0 - CALL RES(X,Y,YPRIME,DELTA,IRES, - * RPAR,IPAR) - IF (IRES .LT. 0) GO TO 380 - GO TO 350 -C -C -C THE CORRECTOR FAILED TO CONVERGE IN MAXIT -C ITERATIONS. IF THE ITERATION MATRIX -C IS NOT CURRENT,RE-DO THE STEP WITH -C A NEW ITERATION MATRIX. -370 CONTINUE - IF(JCALC.EQ.0)GO TO 380 - JCALC=-1 - GO TO 300 -C -C -C THE ITERATION HAS CONVERGED. IF NONNEGATIVITY OF SOLUTION IS -C REQUIRED, SET THE SOLUTION NONNEGATIVE, IF THE PERTURBATION -C TO DO IT IS SMALL ENOUGH. IF THE CHANGE IS TOO LARGE, THEN -C CONSIDER THE CORRECTOR ITERATION TO HAVE FAILED. -375 IF(NONNEG .EQ. 0) GO TO 390 - DO 377 I = 1,NEQ -377 DELTA(I) = MIN(Y(I),0.0E0) - DELNRM = SDANRM(NEQ,DELTA,WT,RPAR,IPAR) - IF(DELNRM .GT. 0.33E0) GO TO 380 - DO 378 I = 1,NEQ -378 E(I) = E(I) - DELTA(I) - GO TO 390 -C -C -C EXITS FROM BLOCK 3 -C NO CONVERGENCE WITH CURRENT ITERATION -C MATRIX,OR SINGULAR ITERATION MATRIX -380 CONVGD= .FALSE. -390 JCALC = 1 - IF(.NOT.CONVGD)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 - ENORM = SDANRM(NEQ,E,WT,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)*SDANRM(NEQ,DELTA,WT,RPAR,IPAR) - TERKM1 = K*ERKM1 - IF(K .GT. 2)GO TO 410 - IF(TERKM1 .LE. 0.5E0*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)*SDANRM(NEQ,DELTA,WT,RPAR,IPAR) - TERKM2 = (K-1)*ERKM2 - IF(MAX(TERKM1,TERKM2).GT.TERK)GO TO 430 -C LOWER THE ORDER -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 -430 CONTINUE - ERR = CK * ENORM - IF(ERR .GT. 1.0E0)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 - 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.0E0/(K+2))*SDANRM(NEQ,DELTA,WT,RPAR,IPAR) - TERKP1 = (K+2)*ERKP1 - IF(K.GT.1)GO TO 520 - IF(TERKP1.GE.0.5E0*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 -530 K=KP1 - EST = ERKP1 - GO TO 550 -C -C LOWER ORDER -540 K=KM1 - EST = ERKM1 - GO TO 550 -C -C IF IPHASE = 0, INCREASE ORDER BY ONE AND MULTIPLY STEPSIZE BY -C FACTOR TWO -545 K = KP1 - HNEW = H*2.0E0 - H = HNEW - GO TO 575 -C -C -C DETERMINE THE APPROPRIATE STEPSIZE FOR -C THE NEXT STEP. -550 HNEW=H - TEMP2=K+1 - R=(2.0E0*EST+0.0001E0)**(-1.0E0/TEMP2) - IF(R .LT. 2.0E0) GO TO 555 - HNEW = 2.0E0*H - GO TO 560 -555 IF(R .GT. 1.0E0) GO TO 560 - R = MAX(0.5E0,MIN(0.9E0,R)) - HNEW = H*R -560 H=HNEW -C -C -C UPDATE DIFFERENCES FOR NEXT STEP -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) - 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 - X=XOLD - IF(KP1.LT.NSP1)GO TO 630 - DO 620 J=NSP1,KP1 - TEMP1=1.0E0/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 CORRECTOR ITERATION -C OR ERROR TEST - IF(CONVGD)GO TO 660 - IWM(LCTF)=IWM(LCTF)+1 -C -C -C THE NEWTON ITERATION FAILED TO CONVERGE WITH -C A CURRENT ITERATION MATRIX. DETERMINE THE CAUSE -C OF THE FAILURE AND TAKE APPROPRIATE ACTION. - IF(IER.EQ.0)GO TO 650 -C -C THE ITERATION MATRIX IS SINGULAR. REDUCE -C THE STEPSIZE BY A FACTOR OF 4. IF -C THIS HAPPENS THREE TIMES IN A ROW ON -C THE SAME STEP, RETURN WITH AN ERROR FLAG - NSF=NSF+1 - R = 0.25E0 - H=H*R - IF (NSF .LT. 3 .AND. ABS(H) .GE. HMIN) GO TO 690 - IDID=-8 - GO TO 675 -C -C -C THE NEWTON ITERATION FAILED TO CONVERGE FOR A REASON -C OTHER THAN A SINGULAR ITERATION MATRIX. IF IRES = -2, THEN -C RETURN. OTHERWISE, REDUCE THE STEPSIZE AND TRY AGAIN, UNLESS -C TOO MANY FAILURES HAVE OCCURRED. -650 CONTINUE - IF (IRES .GT. -2) GO TO 655 - IDID = -11 - GO TO 675 -655 NCF = NCF + 1 - R = 0.25E0 - H = H*R - IF (NCF .LT. 10 .AND. ABS(H) .GE. HMIN) GO TO 690 - IDID = -7 - IF (IRES .LT. 0) IDID = -10 - IF (NEF .GE. 3) IDID = -9 - GO TO 675 -C -C -C THE NEWTON SCHEME CONVERGED, AND THE CAUSE -C OF THE FAILURE WAS THE ERROR ESTIMATE -C EXCEEDING THE TOLERANCE. -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. - K = KNEW - TEMP2 = K + 1 - R = 0.90E0*(2.0E0*EST+0.0001E0)**(-1.0E0/TEMP2) - R = MAX(0.25E0,MIN(0.9E0,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 FOUR. -665 IF (NEF .GT. 2) GO TO 670 - K = KNEW - H = 0.25E0*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 FOUR. -670 K = 1 - H = 0.25E0*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 -675 CONTINUE - CALL SDATRP(X,X,Y,YPRIME,NEQ,K,PHI,PSI) - RETURN -C -C -C GO BACK AND TRY THIS STEP AGAIN -690 GO TO 200 -C -C------END OF SUBROUTINE SDASTP------ - END diff --git a/slatec/sdatrp.f b/slatec/sdatrp.f deleted file mode 100644 index b7a8148..0000000 --- a/slatec/sdatrp.f +++ /dev/null @@ -1,65 +0,0 @@ -*DECK SDATRP - SUBROUTINE SDATRP (X, XOUT, YOUT, YPOUT, NEQ, KOLD, PHI, PSI) -C***BEGIN PROLOGUE SDATRP -C***SUBSIDIARY -C***PURPOSE Interpolation routine for SDASSL. -C***LIBRARY SLATEC (DASSL) -C***TYPE SINGLE PRECISION (SDATRP-S, DDATRP-D) -C***AUTHOR Petzold, Linda R., (LLNL) -C***DESCRIPTION -C----------------------------------------------------------------------- -C THE METHODS IN SUBROUTINE SDASTP USE POLYNOMIALS -C TO APPROXIMATE THE SOLUTION. SDATRP 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 SDASTP, SO SDATRP CANNOT BE USED ALONE. -C -C THE PARAMETERS ARE: -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***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 830315 DATE WRITTEN -C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) -C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. -C 901026 Added explicit declarations for all variables and minor -C cosmetic changes to prologue. (FNF) -C***END PROLOGUE SDATRP -C - INTEGER NEQ, KOLD - REAL X, XOUT, YOUT(*), YPOUT(*), PHI(NEQ,*), PSI(*) -C - INTEGER I, J, KOLDP1 - REAL C, D, GAMMA, TEMP1 -C -C***FIRST EXECUTABLE STATEMENT SDATRP - KOLDP1=KOLD+1 - TEMP1=XOUT-X - DO 10 I=1,NEQ - YOUT(I)=PHI(I,1) -10 YPOUT(I)=0.0E0 - C=1.0E0 - D=0.0E0 - 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 SDATRP------ - END diff --git a/slatec/sdawts.f b/slatec/sdawts.f deleted file mode 100644 index 237c4c5..0000000 --- a/slatec/sdawts.f +++ /dev/null @@ -1,43 +0,0 @@ -*DECK SDAWTS - SUBROUTINE SDAWTS (NEQ, IWT, RTOL, ATOL, Y, WT, RPAR, IPAR) -C***BEGIN PROLOGUE SDAWTS -C***SUBSIDIARY -C***PURPOSE Set error weight vector for SDASSL. -C***LIBRARY SLATEC (DASSL) -C***TYPE SINGLE PRECISION (SDAWTS-S, DDAWTS-D) -C***AUTHOR Petzold, Linda R., (LLNL) -C***DESCRIPTION -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,-,N. -C RTOL AND ATOL ARE SCALARS IF IWT = 0, -C AND VECTORS IF IWT = 1. -C----------------------------------------------------------------------- -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 830315 DATE WRITTEN -C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) -C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. -C 901026 Added explicit declarations for all variables and minor -C cosmetic changes to prologue. (FNF) -C***END PROLOGUE SDAWTS -C - INTEGER NEQ, IWT, IPAR(*) - REAL RTOL(*), ATOL(*), Y(*), WT(*), RPAR(*) -C - INTEGER I - REAL ATOLI, RTOLI -C -C***FIRST EXECUTABLE STATEMENT SDAWTS - 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-----------END OF SUBROUTINE SDAWTS------------------------------------ - END diff --git a/slatec/sdcor.f b/slatec/sdcor.f deleted file mode 100644 index 6692a2d..0000000 --- a/slatec/sdcor.f +++ /dev/null @@ -1,192 +0,0 @@ -*DECK SDCOR - SUBROUTINE SDCOR (DFDY, EL, FA, H, IERROR, IMPL, IPVT, MATDIM, - 8 MITER, ML, MU, N, NDE, NQ, T, USERS, Y, YH, YWT, EVALFA, SAVE1, - 8 SAVE2, A, D, JSTATE) -C***BEGIN PROLOGUE SDCOR -C***SUBSIDIARY -C***PURPOSE Subroutine SDCOR computes corrections to the Y array. -C***LIBRARY SLATEC (SDRIVE) -C***TYPE SINGLE PRECISION (SDCOR-S, DDCOR-D, CDCOR-C) -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***DESCRIPTION -C -C In the case of functional iteration, update Y directly from the -C result of the last call to F. -C In the case of the chord method, compute the corrector error and -C solve the linear system with that as right hand side and DFDY as -C coefficient matrix, using the LU decomposition if MITER is 1, 2, 4, -C or 5. -C***ROUTINES CALLED SGBSL, SGESL, SNRM2 -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE SDCOR - INTEGER I, IERROR, IFLAG, IMPL, J, JSTATE, MATDIM, MITER, ML, MU, - 8 MW, N, NDE, NQ - REAL A(MATDIM,*), D, DFDY(MATDIM,*), EL(13,12), H, - 8 SAVE1(*), SAVE2(*), SNRM2, T, Y(*), YH(N,*), YWT(*) - INTEGER IPVT(*) - LOGICAL EVALFA -C***FIRST EXECUTABLE STATEMENT SDCOR - IF (MITER .EQ. 0) THEN - IF (IERROR .EQ. 1 .OR. IERROR .EQ. 5) THEN - DO 100 I = 1,N - 100 SAVE1(I) = (H*SAVE2(I) - YH(I,2) - SAVE1(I))/YWT(I) - ELSE - DO 102 I = 1,N - SAVE1(I) = (H*SAVE2(I) - YH(I,2) - SAVE1(I))/ - 8 MAX(ABS(Y(I)), YWT(I)) - 102 CONTINUE - END IF - D = SNRM2(N, SAVE1, 1)/SQRT(REAL(N)) - DO 105 I = 1,N - 105 SAVE1(I) = H*SAVE2(I) - YH(I,2) - ELSE IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN - IF (IMPL .EQ. 0) THEN - DO 130 I = 1,N - 130 SAVE2(I) = H*SAVE2(I) - YH(I,2) - SAVE1(I) - ELSE IF (IMPL .EQ. 1) THEN - IF (EVALFA) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - ELSE - EVALFA = .TRUE. - END IF - DO 150 I = 1,N - 150 SAVE2(I) = H*SAVE2(I) - DO 160 J = 1,N - DO 160 I = 1,N - 160 SAVE2(I) = SAVE2(I) - A(I,J)*(YH(J,2) + SAVE1(J)) - ELSE IF (IMPL .EQ. 2) THEN - IF (EVALFA) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - ELSE - EVALFA = .TRUE. - END IF - DO 180 I = 1,N - 180 SAVE2(I) = H*SAVE2(I) - A(I,1)*(YH(I,2) + SAVE1(I)) - ELSE IF (IMPL .EQ. 3) THEN - IF (EVALFA) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - ELSE - EVALFA = .TRUE. - END IF - DO 140 I = 1,N - 140 SAVE2(I) = H*SAVE2(I) - DO 170 J = 1,NDE - DO 170 I = 1,NDE - 170 SAVE2(I) = SAVE2(I) - A(I,J)*(YH(J,2) + SAVE1(J)) - END IF - CALL SGESL (DFDY, MATDIM, N, IPVT, SAVE2, 0) - IF (IERROR .EQ. 1 .OR. IERROR .EQ. 5) THEN - DO 200 I = 1,N - SAVE1(I) = SAVE1(I) + SAVE2(I) - 200 SAVE2(I) = SAVE2(I)/YWT(I) - ELSE - DO 205 I = 1,N - SAVE1(I) = SAVE1(I) + SAVE2(I) - 205 SAVE2(I) = SAVE2(I)/MAX(ABS(Y(I)), YWT(I)) - END IF - D = SNRM2(N, SAVE2, 1)/SQRT(REAL(N)) - ELSE IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN - IF (IMPL .EQ. 0) THEN - DO 230 I = 1,N - 230 SAVE2(I) = H*SAVE2(I) - YH(I,2) - SAVE1(I) - ELSE IF (IMPL .EQ. 1) THEN - IF (EVALFA) THEN - CALL FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - ELSE - EVALFA = .TRUE. - END IF - DO 250 I = 1,N - 250 SAVE2(I) = H*SAVE2(I) - MW = ML + 1 + MU - DO 260 J = 1,N - DO 260 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) - SAVE2(I+J-MW) = SAVE2(I+J-MW) - 8 - A(I,J)*(YH(J,2) + SAVE1(J)) - 260 CONTINUE - ELSE IF (IMPL .EQ. 2) THEN - IF (EVALFA) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - ELSE - EVALFA = .TRUE. - END IF - DO 280 I = 1,N - 280 SAVE2(I) = H*SAVE2(I) - A(I,1)*(YH(I,2) + SAVE1(I)) - ELSE IF (IMPL .EQ. 3) THEN - IF (EVALFA) THEN - CALL FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - ELSE - EVALFA = .TRUE. - END IF - DO 270 I = 1,N - 270 SAVE2(I) = H*SAVE2(I) - MW = ML + 1 + MU - DO 290 J = 1,NDE - DO 290 I = MAX(ML+1, MW+1-J), MIN(MW+NDE-J, MW+ML) - SAVE2(I+J-MW) = SAVE2(I+J-MW) - 8 - A(I,J)*(YH(J,2) + SAVE1(J)) - 290 CONTINUE - END IF - CALL SGBSL (DFDY, MATDIM, N, ML, MU, IPVT, SAVE2, 0) - IF (IERROR .EQ. 1 .OR. IERROR .EQ. 5) THEN - DO 300 I = 1,N - SAVE1(I) = SAVE1(I) + SAVE2(I) - 300 SAVE2(I) = SAVE2(I)/YWT(I) - ELSE - DO 305 I = 1,N - SAVE1(I) = SAVE1(I) + SAVE2(I) - 305 SAVE2(I) = SAVE2(I)/MAX(ABS(Y(I)), YWT(I)) - END IF - D = SNRM2(N, SAVE2, 1)/SQRT(REAL(N)) - ELSE IF (MITER .EQ. 3) THEN - IFLAG = 2 - CALL USERS (Y, YH(1,2), YWT, SAVE1, SAVE2, T, H, EL(1,NQ), IMPL, - 8 N, NDE, IFLAG) - IF (N .EQ. 0) THEN - JSTATE = 10 - RETURN - END IF - IF (IERROR .EQ. 1 .OR. IERROR .EQ. 5) THEN - DO 320 I = 1,N - SAVE1(I) = SAVE1(I) + SAVE2(I) - 320 SAVE2(I) = SAVE2(I)/YWT(I) - ELSE - DO 325 I = 1,N - SAVE1(I) = SAVE1(I) + SAVE2(I) - 325 SAVE2(I) = SAVE2(I)/MAX(ABS(Y(I)), YWT(I)) - END IF - D = SNRM2(N, SAVE2, 1)/SQRT(REAL(N)) - END IF - RETURN - END diff --git a/slatec/sdcst.f b/slatec/sdcst.f deleted file mode 100644 index 2f1f543..0000000 --- a/slatec/sdcst.f +++ /dev/null @@ -1,105 +0,0 @@ -*DECK SDCST - SUBROUTINE SDCST (MAXORD, MINT, ISWFLG, EL, TQ) -C***BEGIN PROLOGUE SDCST -C***SUBSIDIARY -C***PURPOSE SDCST sets coefficients used by the core integrator SDSTP. -C***LIBRARY SLATEC (SDRIVE) -C***TYPE SINGLE PRECISION (SDCST-S, DDCST-D, CDCST-C) -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***DESCRIPTION -C -C SDCST is called by SDNTL. The array EL determines the basic method. -C The array TQ is involved in adjusting the step size in relation -C to truncation error. EL and TQ depend upon MINT, and are calculated -C for orders 1 to MAXORD(.LE. 12). For each order NQ, the coefficients -C EL are calculated from the generating polynomial: -C L(T) = EL(1,NQ) + EL(2,NQ)*T + ... + EL(NQ+1,NQ)*T**NQ. -C For the implicit Adams methods, L(T) is given by -C dL/dT = (1+T)*(2+T)* ... *(NQ-1+T)/K, L(-1) = 0, -C where K = factorial(NQ-1). -C For the Gear methods, -C L(T) = (1+T)*(2+T)* ... *(NQ+T)/K, -C where K = factorial(NQ)*(1 + 1/2 + ... + 1/NQ). -C For each order NQ, there are three components of TQ. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE SDCST - REAL EL(13,12), FACTRL(12), GAMMA(14), SUM, TQ(3,12) - INTEGER I, ISWFLG, J, MAXORD, MINT, MXRD -C***FIRST EXECUTABLE STATEMENT SDCST - FACTRL(1) = 1.E0 - DO 10 I = 2,MAXORD - 10 FACTRL(I) = I*FACTRL(I-1) -C Compute Adams coefficients - IF (MINT .EQ. 1) THEN - GAMMA(1) = 1.E0 - DO 40 I = 1,MAXORD+1 - SUM = 0.E0 - DO 30 J = 1,I - 30 SUM = SUM - GAMMA(J)/(I-J+2) - 40 GAMMA(I+1) = SUM - EL(1,1) = 1.E0 - EL(2,1) = 1.E0 - EL(2,2) = 1.E0 - EL(3,2) = 1.E0 - DO 60 J = 3,MAXORD - EL(2,J) = FACTRL(J-1) - DO 50 I = 3,J - 50 EL(I,J) = (J-1)*EL(I,J-1) + EL(I-1,J-1) - 60 EL(J+1,J) = 1.E0 - DO 80 J = 2,MAXORD - EL(1,J) = EL(1,J-1) + GAMMA(J) - EL(2,J) = 1.E0 - DO 80 I = 3,J+1 - 80 EL(I,J) = EL(I,J)/((I-1)*FACTRL(J-1)) - DO 100 J = 1,MAXORD - TQ(1,J) = -1.E0/(FACTRL(J)*GAMMA(J)) - TQ(2,J) = -1.E0/GAMMA(J+1) - 100 TQ(3,J) = -1.E0/GAMMA(J+2) -C Compute Gear coefficients - ELSE IF (MINT .EQ. 2) THEN - EL(1,1) = 1.E0 - EL(2,1) = 1.E0 - DO 130 J = 2,MAXORD - EL(1,J) = FACTRL(J) - DO 120 I = 2,J - 120 EL(I,J) = J*EL(I,J-1) + EL(I-1,J-1) - 130 EL(J+1,J) = 1.E0 - SUM = 1.E0 - DO 150 J = 2,MAXORD - SUM = SUM + 1.E0/J - DO 150 I = 1,J+1 - 150 EL(I,J) = EL(I,J)/(FACTRL(J)*SUM) - DO 170 J = 1,MAXORD - IF (J .GT. 1) TQ(1,J) = 1.E0/FACTRL(J-1) - TQ(2,J) = (J+1)/EL(1,J) - 170 TQ(3,J) = (J+2)/EL(1,J) - END IF -C Compute constants used in the stiffness test. -C These are the ratio of TQ(2,NQ) for the Gear -C methods to those for the Adams methods. - IF (ISWFLG .EQ. 3) THEN - MXRD = MIN(MAXORD, 5) - IF (MINT .EQ. 2) THEN - GAMMA(1) = 1.E0 - DO 190 I = 1,MXRD - SUM = 0.E0 - DO 180 J = 1,I - 180 SUM = SUM - GAMMA(J)/(I-J+2) - 190 GAMMA(I+1) = SUM - END IF - SUM = 1.E0 - DO 200 I = 2,MXRD - SUM = SUM + 1.E0/I - 200 EL(1+I,1) = -(I+1)*SUM*GAMMA(I+1) - END IF - RETURN - END diff --git a/slatec/sdntl.f b/slatec/sdntl.f deleted file mode 100644 index 0452326..0000000 --- a/slatec/sdntl.f +++ /dev/null @@ -1,181 +0,0 @@ -*DECK SDNTL - SUBROUTINE SDNTL (EPS, F, FA, HMAX, HOLD, IMPL, JTASK, MATDIM, - 8 MAXORD, MINT, MITER, ML, MU, N, NDE, SAVE1, T, UROUND, USERS, - 8 Y, YWT, H, MNTOLD, MTROLD, NFE, RC, YH, A, CONVRG, EL, FAC, - 8 IER, IPVT, NQ, NWAIT, RH, RMAX, SAVE2, TQ, TREND, ISWFLG, - 8 JSTATE) -C***BEGIN PROLOGUE SDNTL -C***SUBSIDIARY -C***PURPOSE Subroutine SDNTL is called to set parameters on the first -C call to SDSTP, on an internal restart, or when the user has -C altered MINT, MITER, and/or H. -C***LIBRARY SLATEC (SDRIVE) -C***TYPE SINGLE PRECISION (SDNTL-S, DDNTL-D, CDNTL-C) -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***DESCRIPTION -C -C On the first call, the order is set to 1 and the initial derivatives -C are calculated. RMAX is the maximum ratio by which H can be -C increased in one step. It is initially RMINIT to compensate -C for the small initial H, but then is normally equal to RMNORM. -C If a failure occurs (in corrector convergence or error test), RMAX -C is set at RMFAIL for the next increase. -C If the caller has changed MINT, or if JTASK = 0, SDCST is called -C to set the coefficients of the method. If the caller has changed H, -C YH must be rescaled. If H or MINT has been changed, NWAIT is -C reset to NQ + 2 to prevent further increases in H for that many -C steps. Also, RC is reset. RC is the ratio of new to old values of -C the coefficient L(0)*H. If the caller has changed MITER, RC is -C set to 0 to force the partials to be updated, if partials are used. -C***ROUTINES CALLED SDCST, SDSCL, SGBFA, SGBSL, SGEFA, SGESL, SNRM2 -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE SDNTL - INTEGER I, IFLAG, IMPL, INFO, ISWFLG, JSTATE, JTASK, MATDIM, - 8 MAXORD, MINT, MITER, ML, MNTOLD, MTROLD, MU, N, NDE, NFE, - 8 NQ, NWAIT - REAL A(MATDIM,*), EL(13,12), EPS, FAC(*), H, HMAX, - 8 HOLD, OLDL0, RC, RH, RMAX, RMINIT, SAVE1(*), SAVE2(*), SNRM2, - 8 SUM, T, TQ(3,12), TREND, UROUND, Y(*), YH(N,*), YWT(*) - INTEGER IPVT(*) - LOGICAL CONVRG, IER - PARAMETER(RMINIT = 10000.E0) -C***FIRST EXECUTABLE STATEMENT SDNTL - IER = .FALSE. - IF (JTASK .GE. 0) THEN - IF (JTASK .EQ. 0) THEN - CALL SDCST (MAXORD, MINT, ISWFLG, EL, TQ) - RMAX = RMINIT - END IF - RC = 0.E0 - CONVRG = .FALSE. - TREND = 1.E0 - NQ = 1 - NWAIT = 3 - CALL F (N, T, Y, SAVE2) - IF (N .EQ. 0) THEN - JSTATE = 6 - RETURN - END IF - NFE = NFE + 1 - IF (IMPL .NE. 0) THEN - IF (MITER .EQ. 3) THEN - IFLAG = 0 - CALL USERS (Y, YH, YWT, SAVE1, SAVE2, T, H, EL, IMPL, N, - 8 NDE, IFLAG) - IF (IFLAG .EQ. -1) THEN - IER = .TRUE. - RETURN - END IF - IF (N .EQ. 0) THEN - JSTATE = 10 - RETURN - END IF - ELSE IF (IMPL .EQ. 1) THEN - IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - CALL SGEFA (A, MATDIM, N, IPVT, INFO) - IF (INFO .NE. 0) THEN - IER = .TRUE. - RETURN - END IF - CALL SGESL (A, MATDIM, N, IPVT, SAVE2, 0) - ELSE IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN - CALL FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - CALL SGBFA (A, MATDIM, N, ML, MU, IPVT, INFO) - IF (INFO .NE. 0) THEN - IER = .TRUE. - RETURN - END IF - CALL SGBSL (A, MATDIM, N, ML, MU, IPVT, SAVE2, 0) - END IF - ELSE IF (IMPL .EQ. 2) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - DO 150 I = 1,NDE - IF (A(I,1) .EQ. 0.E0) THEN - IER = .TRUE. - RETURN - ELSE - SAVE2(I) = SAVE2(I)/A(I,1) - END IF - 150 CONTINUE - DO 155 I = NDE+1,N - 155 A(I,1) = 0.E0 - ELSE IF (IMPL .EQ. 3) THEN - IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - CALL SGEFA (A, MATDIM, NDE, IPVT, INFO) - IF (INFO .NE. 0) THEN - IER = .TRUE. - RETURN - END IF - CALL SGESL (A, MATDIM, NDE, IPVT, SAVE2, 0) - ELSE IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN - CALL FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - CALL SGBFA (A, MATDIM, NDE, ML, MU, IPVT, INFO) - IF (INFO .NE. 0) THEN - IER = .TRUE. - RETURN - END IF - CALL SGBSL (A, MATDIM, NDE, ML, MU, IPVT, SAVE2, 0) - END IF - END IF - END IF - DO 170 I = 1,NDE - 170 SAVE1(I) = SAVE2(I)/MAX(1.E0, YWT(I)) - SUM = SNRM2(NDE, SAVE1, 1)/SQRT(REAL(NDE)) - IF (SUM .GT. EPS/ABS(H)) H = SIGN(EPS/SUM, H) - DO 180 I = 1,N - 180 YH(I,2) = H*SAVE2(I) - IF (MITER .EQ. 2 .OR. MITER .EQ. 5 .OR. ISWFLG .EQ. 3) THEN - DO 20 I = 1,N - 20 FAC(I) = SQRT(UROUND) - END IF - ELSE - IF (MITER .NE. MTROLD) THEN - MTROLD = MITER - RC = 0.E0 - CONVRG = .FALSE. - END IF - IF (MINT .NE. MNTOLD) THEN - MNTOLD = MINT - OLDL0 = EL(1,NQ) - CALL SDCST (MAXORD, MINT, ISWFLG, EL, TQ) - RC = RC*EL(1,NQ)/OLDL0 - NWAIT = NQ + 2 - END IF - IF (H .NE. HOLD) THEN - NWAIT = NQ + 2 - RH = H/HOLD - CALL SDSCL (HMAX, N, NQ, RMAX, HOLD, RC, RH, YH) - END IF - END IF - RETURN - END diff --git a/slatec/sdntp.f b/slatec/sdntp.f deleted file mode 100644 index 90ff392..0000000 --- a/slatec/sdntp.f +++ /dev/null @@ -1,53 +0,0 @@ -*DECK SDNTP - SUBROUTINE SDNTP (H, K, N, NQ, T, TOUT, YH, Y) -C***BEGIN PROLOGUE SDNTP -C***SUBSIDIARY -C***PURPOSE Subroutine SDNTP interpolates the K-th derivative of Y at -C TOUT, using the data in the YH array. If K has a value -C greater than NQ, the NQ-th derivative is calculated. -C***LIBRARY SLATEC (SDRIVE) -C***TYPE SINGLE PRECISION (SDNTP-S, DDNTP-D, CDNTP-C) -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE SDNTP - INTEGER I, J, JJ, K, KK, KUSED, N, NQ - REAL FACTOR, H, R, T, TOUT, Y(*), YH(N,*) -C***FIRST EXECUTABLE STATEMENT SDNTP - IF (K .EQ. 0) THEN - DO 10 I = 1,N - 10 Y(I) = YH(I,NQ+1) - R = ((TOUT - T)/H) - DO 20 JJ = 1,NQ - J = NQ + 1 - JJ - DO 20 I = 1,N - 20 Y(I) = YH(I,J) + R*Y(I) - ELSE - KUSED = MIN(K, NQ) - FACTOR = 1.E0 - DO 40 KK = 1,KUSED - 40 FACTOR = FACTOR*(NQ+1-KK) - DO 50 I = 1,N - 50 Y(I) = FACTOR*YH(I,NQ+1) - R = ((TOUT - T)/H) - DO 80 JJ = KUSED+1,NQ - J = KUSED + 1 + NQ - JJ - FACTOR = 1.E0 - DO 60 KK = 1,KUSED - 60 FACTOR = FACTOR*(J-KK) - DO 70 I = 1,N - 70 Y(I) = FACTOR*YH(I,J) + R*Y(I) - 80 CONTINUE - DO 100 I = 1,N - 100 Y(I) = Y(I)*H**(-KUSED) - END IF - RETURN - END diff --git a/slatec/sdot.f b/slatec/sdot.f deleted file mode 100644 index 8c7cde2..0000000 --- a/slatec/sdot.f +++ /dev/null @@ -1,89 +0,0 @@ -*DECK SDOT - REAL FUNCTION SDOT (N, SX, INCX, SY, INCY) -C***BEGIN PROLOGUE SDOT -C***PURPOSE Compute the inner product of two vectors. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A4 -C***TYPE SINGLE PRECISION (SDOT-S, DDOT-D, CDOTU-C) -C***KEYWORDS BLAS, INNER PRODUCT, 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 SDOT single precision dot product (zero if N .LE. 0) -C -C Returns the dot product of single precision SX and SY. -C SDOT = 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 SDOT - REAL SX(*), SY(*) -C***FIRST EXECUTABLE STATEMENT SDOT - SDOT = 0.0E0 - IF (N .LE. 0) RETURN - IF (INCX .EQ. INCY) IF (INCX-1) 5,20,60 -C -C Code for unequal or nonpositive increments. -C - 5 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 - SDOT = SDOT + SX(IX)*SY(IY) - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -C -C Code for both increments equal to 1. -C -C Clean-up loop so remaining vector length is a multiple of 5. -C - 20 M = MOD(N,5) - IF (M .EQ. 0) GO TO 40 - DO 30 I = 1,M - SDOT = SDOT + SX(I)*SY(I) - 30 CONTINUE - IF (N .LT. 5) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,5 - SDOT = SDOT + SX(I)*SY(I) + SX(I+1)*SY(I+1) + SX(I+2)*SY(I+2) + - 1 SX(I+3)*SY(I+3) + SX(I+4)*SY(I+4) - 50 CONTINUE - RETURN -C -C Code for equal, positive, non-unit increments. -C - 60 NS = N*INCX - DO 70 I = 1,NS,INCX - SDOT = SDOT + SX(I)*SY(I) - 70 CONTINUE - RETURN - END diff --git a/slatec/sdpsc.f b/slatec/sdpsc.f deleted file mode 100644 index 58d907e..0000000 --- a/slatec/sdpsc.f +++ /dev/null @@ -1,40 +0,0 @@ -*DECK SDPSC - SUBROUTINE SDPSC (KSGN, N, NQ, YH) -C***BEGIN PROLOGUE SDPSC -C***SUBSIDIARY -C***PURPOSE Subroutine SDPSC computes the predicted YH values by -C effectively multiplying the YH array by the Pascal triangle -C matrix when KSGN is +1, and performs the inverse function -C when KSGN is -1. -C***LIBRARY SLATEC (SDRIVE) -C***TYPE SINGLE PRECISION (SDPSC-S, DDPSC-D, CDPSC-C) -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE SDPSC - INTEGER I, J, J1, J2, KSGN, N, NQ - REAL YH(N,*) -C***FIRST EXECUTABLE STATEMENT SDPSC - IF (KSGN .GT. 0) THEN - DO 10 J1 = 1,NQ - DO 10 J2 = J1,NQ - J = NQ - J2 + J1 - DO 10 I = 1,N - 10 YH(I,J) = YH(I,J) + YH(I,J+1) - ELSE - DO 30 J1 = 1,NQ - DO 30 J2 = J1,NQ - J = NQ - J2 + J1 - DO 30 I = 1,N - 30 YH(I,J) = YH(I,J) - YH(I,J+1) - END IF - RETURN - END diff --git a/slatec/sdpst.f b/slatec/sdpst.f deleted file mode 100644 index cdbb406..0000000 --- a/slatec/sdpst.f +++ /dev/null @@ -1,286 +0,0 @@ -*DECK SDPST - SUBROUTINE SDPST (EL, F, FA, H, IMPL, JACOBN, MATDIM, MITER, ML, - 8 MU, N, NDE, NQ, SAVE2, T, USERS, Y, YH, YWT, UROUND, NFE, NJE, - 8 A, DFDY, FAC, IER, IPVT, SAVE1, ISWFLG, BND, JSTATE) -C***BEGIN PROLOGUE SDPST -C***SUBSIDIARY -C***PURPOSE Subroutine SDPST evaluates the Jacobian matrix of the right -C hand side of the differential equations. -C***LIBRARY SLATEC (SDRIVE) -C***TYPE SINGLE PRECISION (SDPST-S, DDPST-D, CDPST-C) -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***DESCRIPTION -C -C If MITER is 1, 2, 4, or 5, the matrix -C P = I - L(0)*H*Jacobian is stored in DFDY and subjected to LU -C decomposition, with the results also stored in DFDY. -C***ROUTINES CALLED SGBFA, SGEFA, SNRM2 -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE SDPST - INTEGER I, IFLAG, IMAX, IMPL, INFO, ISWFLG, J, J2, JSTATE, K, - 8 MATDIM, MITER, ML, MU, MW, N, NDE, NFE, NJE, NQ - REAL A(MATDIM,*), BL, BND, BP, BR, BU, DFDY(MATDIM,*), - 8 DFDYMX, DIFF, DY, EL(13,12), FAC(*), FACMAX, FACMIN, FACTOR, - 8 H, SAVE1(*), SAVE2(*), SCALE, SNRM2, T, UROUND, Y(*), - 8 YH(N,*), YJ, YS, YWT(*) - INTEGER IPVT(*) - LOGICAL IER - PARAMETER(FACMAX = .5E0, BU = 0.5E0) -C***FIRST EXECUTABLE STATEMENT SDPST - NJE = NJE + 1 - IER = .FALSE. - IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN - IF (MITER .EQ. 1) THEN - CALL JACOBN (N, T, Y, DFDY, MATDIM, ML, MU) - IF (N .EQ. 0) THEN - JSTATE = 8 - RETURN - END IF - IF (ISWFLG .EQ. 3) BND = SNRM2(N*N, DFDY, 1) - FACTOR = -EL(1,NQ)*H - DO 110 J = 1,N - DO 110 I = 1,N - 110 DFDY(I,J) = FACTOR*DFDY(I,J) - ELSE IF (MITER .EQ. 2) THEN - BR = UROUND**(.875E0) - BL = UROUND**(.75E0) - BP = UROUND**(-.15E0) - FACMIN = UROUND**(.78E0) - DO 170 J = 1,N - YS = MAX(ABS(YWT(J)), ABS(Y(J))) - 120 DY = FAC(J)*YS - IF (DY .EQ. 0.E0) THEN - IF (FAC(J) .LT. FACMAX) THEN - FAC(J) = MIN(100.E0*FAC(J), FACMAX) - GO TO 120 - ELSE - DY = YS - END IF - END IF - IF (NQ .EQ. 1) THEN - DY = SIGN(DY, SAVE2(J)) - ELSE - DY = SIGN(DY, YH(J,3)) - END IF - DY = (Y(J) + DY) - Y(J) - YJ = Y(J) - Y(J) = Y(J) + DY - CALL F (N, T, Y, SAVE1) - IF (N .EQ. 0) THEN - JSTATE = 6 - RETURN - END IF - Y(J) = YJ - FACTOR = -EL(1,NQ)*H/DY - DO 140 I = 1,N - 140 DFDY(I,J) = (SAVE1(I) - SAVE2(I))*FACTOR -C Step 1 - DIFF = ABS(SAVE2(1) - SAVE1(1)) - IMAX = 1 - DO 150 I = 2,N - IF (ABS(SAVE2(I) - SAVE1(I)) .GT. DIFF) THEN - IMAX = I - DIFF = ABS(SAVE2(I) - SAVE1(I)) - END IF - 150 CONTINUE -C Step 2 - IF (MIN(ABS(SAVE2(IMAX)), ABS(SAVE1(IMAX))) .GT. 0.E0) THEN - SCALE = MAX(ABS(SAVE2(IMAX)), ABS(SAVE1(IMAX))) -C Step 3 - IF (DIFF .GT. BU*SCALE) THEN - FAC(J) = MAX(FACMIN, FAC(J)*.5E0) - ELSE IF (BR*SCALE .LE. DIFF .AND. DIFF .LE. BL*SCALE) THEN - FAC(J) = MIN(FAC(J)*2.E0, FACMAX) -C Step 4 - ELSE IF (DIFF .LT. BR*SCALE) THEN - FAC(J) = MIN(BP*FAC(J), FACMAX) - END IF - END IF - 170 CONTINUE - IF (ISWFLG .EQ. 3) BND = SNRM2(N*N, DFDY, 1)/(-EL(1,NQ)*H) - NFE = NFE + N - END IF - IF (IMPL .EQ. 0) THEN - DO 190 I = 1,N - 190 DFDY(I,I) = DFDY(I,I) + 1.E0 - ELSE IF (IMPL .EQ. 1) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - DO 210 J = 1,N - DO 210 I = 1,N - 210 DFDY(I,J) = DFDY(I,J) + A(I,J) - ELSE IF (IMPL .EQ. 2) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - DO 230 I = 1,NDE - 230 DFDY(I,I) = DFDY(I,I) + A(I,1) - ELSE IF (IMPL .EQ. 3) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - DO 220 J = 1,NDE - DO 220 I = 1,NDE - 220 DFDY(I,J) = DFDY(I,J) + A(I,J) - END IF - CALL SGEFA (DFDY, MATDIM, N, IPVT, INFO) - IF (INFO .NE. 0) IER = .TRUE. - ELSE IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN - IF (MITER .EQ. 4) THEN - CALL JACOBN (N, T, Y, DFDY(ML+1,1), MATDIM, ML, MU) - IF (N .EQ. 0) THEN - JSTATE = 8 - RETURN - END IF - FACTOR = -EL(1,NQ)*H - MW = ML + MU + 1 - DO 260 J = 1,N - DO 260 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) - 260 DFDY(I,J) = FACTOR*DFDY(I,J) - ELSE IF (MITER .EQ. 5) THEN - BR = UROUND**(.875E0) - BL = UROUND**(.75E0) - BP = UROUND**(-.15E0) - FACMIN = UROUND**(.78E0) - MW = ML + MU + 1 - J2 = MIN(MW, N) - DO 340 J = 1,J2 - DO 290 K = J,N,MW - YS = MAX(ABS(YWT(K)), ABS(Y(K))) - 280 DY = FAC(K)*YS - IF (DY .EQ. 0.E0) THEN - IF (FAC(K) .LT. FACMAX) THEN - FAC(K) = MIN(100.E0*FAC(K), FACMAX) - GO TO 280 - ELSE - DY = YS - END IF - END IF - IF (NQ .EQ. 1) THEN - DY = SIGN(DY, SAVE2(K)) - ELSE - DY = SIGN(DY, YH(K,3)) - END IF - DY = (Y(K) + DY) - Y(K) - DFDY(MW,K) = Y(K) - 290 Y(K) = Y(K) + DY - CALL F (N, T, Y, SAVE1) - IF (N .EQ. 0) THEN - JSTATE = 6 - RETURN - END IF - DO 330 K = J,N,MW - Y(K) = DFDY(MW,K) - YS = MAX(ABS(YWT(K)), ABS(Y(K))) - DY = FAC(K)*YS - IF (DY .EQ. 0.E0) DY = YS - IF (NQ .EQ. 1) THEN - DY = SIGN(DY, SAVE2(K)) - ELSE - DY = SIGN(DY, YH(K,3)) - END IF - DY = (Y(K) + DY) - Y(K) - FACTOR = -EL(1,NQ)*H/DY - DO 300 I = MAX(ML+1, MW+1-K), MIN(MW+N-K, MW+ML) - 300 DFDY(I,K) = FACTOR*(SAVE1(I+K-MW) - SAVE2(I+K-MW)) -C Step 1 - IMAX = MAX(1, K - MU) - DIFF = ABS(SAVE2(IMAX) - SAVE1(IMAX)) - DO 310 I = MAX(1, K - MU)+1, MIN(K + ML, N) - IF (ABS(SAVE2(I) - SAVE1(I)) .GT. DIFF) THEN - IMAX = I - DIFF = ABS(SAVE2(I) - SAVE1(I)) - END IF - 310 CONTINUE -C Step 2 - IF (MIN(ABS(SAVE2(IMAX)), ABS(SAVE1(IMAX))) .GT.0.E0) THEN - SCALE = MAX(ABS(SAVE2(IMAX)), ABS(SAVE1(IMAX))) -C Step 3 - IF (DIFF .GT. BU*SCALE) THEN - FAC(J) = MAX(FACMIN, FAC(J)*.5E0) - ELSE IF (BR*SCALE .LE.DIFF .AND. DIFF .LE.BL*SCALE) THEN - FAC(J) = MIN(FAC(J)*2.E0, FACMAX) -C Step 4 - ELSE IF (DIFF .LT. BR*SCALE) THEN - FAC(K) = MIN(BP*FAC(K), FACMAX) - END IF - END IF - 330 CONTINUE - 340 CONTINUE - NFE = NFE + J2 - END IF - IF (ISWFLG .EQ. 3) THEN - DFDYMX = 0.E0 - DO 345 J = 1,N - DO 345 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) - 345 DFDYMX = MAX(DFDYMX, ABS(DFDY(I,J))) - BND = 0.E0 - IF (DFDYMX .NE. 0.E0) THEN - DO 350 J = 1,N - DO 350 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) - 350 BND = BND + (DFDY(I,J)/DFDYMX)**2 - BND = DFDYMX*SQRT(BND)/(-EL(1,NQ)*H) - END IF - END IF - IF (IMPL .EQ. 0) THEN - DO 360 J = 1,N - 360 DFDY(MW,J) = DFDY(MW,J) + 1.E0 - ELSE IF (IMPL .EQ. 1) THEN - CALL FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - DO 380 J = 1,N - DO 380 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) - 380 DFDY(I,J) = DFDY(I,J) + A(I,J) - ELSE IF (IMPL .EQ. 2) THEN - CALL FA (N, T, Y, A, MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - DO 400 J = 1,NDE - 400 DFDY(MW,J) = DFDY(MW,J) + A(J,1) - ELSE IF (IMPL .EQ. 3) THEN - CALL FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) - IF (N .EQ. 0) THEN - JSTATE = 9 - RETURN - END IF - DO 390 J = 1,NDE - DO 390 I = MAX(ML+1, MW+1-J), MIN(MW+NDE-J, MW+ML) - 390 DFDY(I,J) = DFDY(I,J) + A(I,J) - END IF - CALL SGBFA (DFDY, MATDIM, N, ML, MU, IPVT, INFO) - IF (INFO .NE. 0) IER = .TRUE. - ELSE IF (MITER .EQ. 3) THEN - IFLAG = 1 - CALL USERS (Y, YH(1,2), YWT, SAVE1, SAVE2, T, H, EL(1,NQ), IMPL, - 8 N, NDE, IFLAG) - IF (IFLAG .EQ. -1) THEN - IER = .TRUE. - RETURN - END IF - IF (N .EQ. 0) THEN - JSTATE = 10 - RETURN - END IF - END IF - RETURN - END diff --git a/slatec/sdriv1.f b/slatec/sdriv1.f deleted file mode 100644 index 8c49e47..0000000 --- a/slatec/sdriv1.f +++ /dev/null @@ -1,362 +0,0 @@ -*DECK SDRIV1 - SUBROUTINE SDRIV1 (N, T, Y, F, TOUT, MSTATE, EPS, WORK, LENW, - 8 IERFLG) -C***BEGIN PROLOGUE SDRIV1 -C***PURPOSE The function of SDRIV1 is to solve N (200 or fewer) -C ordinary differential equations of the form -C dY(I)/dT = F(Y(I),T), given the initial conditions -C Y(I) = YI. SDRIV1 uses single precision arithmetic. -C***LIBRARY SLATEC (SDRIVE) -C***CATEGORY I1A2, I1A1B -C***TYPE SINGLE PRECISION (SDRIV1-S, DDRIV1-D, CDRIV1-C) -C***KEYWORDS GEAR'S METHOD, INITIAL VALUE PROBLEMS, ODE, -C ORDINARY DIFFERENTIAL EQUATIONS, SDRIVE, SINGLE PRECISION, -C STIFF -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***DESCRIPTION -C -C Version 92.1 -C -C I. CHOOSING THE CORRECT ROUTINE ................................... -C -C SDRIV -C DDRIV -C CDRIV -C These are the generic names for three packages for solving -C initial value problems for ordinary differential equations. -C SDRIV uses single precision arithmetic. DDRIV uses double -C precision arithmetic. CDRIV allows complex-valued -C differential equations, integrated with respect to a single, -C real, independent variable. -C -C As an aid in selecting the proper program, the following is a -C discussion of the important options or restrictions associated with -C each program: -C -C A. SDRIV1 should be tried first for those routine problems with -C no more than 200 differential equations (SDRIV2 and SDRIV3 -C have no such restriction.) Internally this routine has two -C important technical defaults: -C 1. Numerical approximation of the Jacobian matrix of the -C right hand side is used. -C 2. The stiff solver option is used. -C Most users of SDRIV1 should not have to concern themselves -C with these details. -C -C B. SDRIV2 should be considered for those problems for which -C SDRIV1 is inadequate. For example, SDRIV1 may have difficulty -C with problems having zero initial conditions and zero -C derivatives. In this case SDRIV2, with an appropriate value -C of the parameter EWT, should perform more efficiently. SDRIV2 -C provides three important additional options: -C 1. The nonstiff equation solver (as well as the stiff -C solver) is available. -C 2. The root-finding option is available. -C 3. The program can dynamically select either the non-stiff -C or the stiff methods. -C Internally this routine also defaults to the numerical -C approximation of the Jacobian matrix of the right hand side. -C -C C. SDRIV3 is the most flexible, and hence the most complex, of -C the programs. Its important additional features include: -C 1. The ability to exploit band structure in the Jacobian -C matrix. -C 2. The ability to solve some implicit differential -C equations, i.e., those having the form: -C A(Y,T)*dY/dT = F(Y,T). -C 3. The option of integrating in the one step mode. -C 4. The option of allowing the user to provide a routine -C which computes the analytic Jacobian matrix of the right -C hand side. -C 5. The option of allowing the user to provide a routine -C which does all the matrix algebra associated with -C corrections to the solution components. -C -C II. PARAMETERS .................................................... -C -C The user should use parameter names in the call sequence of SDRIV1 -C for those quantities whose value may be altered by SDRIV1. The -C parameters in the call sequence are: -C -C N = (Input) The number of differential equations, N .LE. 200 -C -C T = The independent variable. On input for the first call, T -C is the initial point. On output, T is the point at which -C the solution is given. -C -C Y = The vector of dependent variables. Y is used as input on -C the first call, to set the initial values. On output, Y -C is the computed solution vector. This array Y is passed -C in the call sequence of the user-provided routine F. Thus -C parameters required by F can be stored in this array in -C components N+1 and above. (Note: Changes by the user to -C the first N components of this array will take effect only -C after a restart, i.e., after setting MSTATE to +1(-1).) -C -C F = A subroutine supplied by the user. The name must be -C declared EXTERNAL in the user's calling program. This -C subroutine is of the form: -C SUBROUTINE F (N, T, Y, YDOT) -C REAL Y(*), YDOT(*) -C . -C . -C YDOT(1) = ... -C . -C . -C YDOT(N) = ... -C END (Sample) -C This computes YDOT = F(Y,T), the right hand side of the -C differential equations. Here Y is a vector of length at -C least N. The actual length of Y is determined by the -C user's declaration in the program which calls SDRIV1. -C Thus the dimensioning of Y in F, while required by FORTRAN -C convention, does not actually allocate any storage. When -C this subroutine is called, the first N components of Y are -C intermediate approximations to the solution components. -C The user should not alter these values. Here YDOT is a -C vector of length N. The user should only compute YDOT(I) -C for I from 1 to N. Normally a return from F passes -C control back to SDRIV1. However, if the user would like -C to abort the calculation, i.e., return control to the -C program which calls SDRIV1, he should set N to zero. -C SDRIV1 will signal this by returning a value of MSTATE -C equal to +5(-5). Altering the value of N in F has no -C effect on the value of N in the call sequence of SDRIV1. -C -C TOUT = (Input) The point at which the solution is desired. -C -C MSTATE = An integer describing the status of integration. The user -C must initialize MSTATE to +1 or -1. If MSTATE is -C positive, the routine will integrate past TOUT and -C interpolate the solution. This is the most efficient -C mode. If MSTATE is negative, the routine will adjust its -C internal step to reach TOUT exactly (useful if a -C singularity exists beyond TOUT.) The meaning of the -C magnitude of MSTATE: -C 1 (Input) Means the first call to the routine. This -C value must be set by the user. On all subsequent -C calls the value of MSTATE should be tested by the -C user. Unless SDRIV1 is to be reinitialized, only the -C sign of MSTATE may be changed by the user. (As a -C convenience to the user who may wish to put out the -C initial conditions, SDRIV1 can be called with -C MSTATE=+1(-1), and TOUT=T. In this case the program -C will return with MSTATE unchanged, i.e., -C MSTATE=+1(-1).) -C 2 (Output) Means a successful integration. If a normal -C continuation is desired (i.e., a further integration -C in the same direction), simply advance TOUT and call -C again. All other parameters are automatically set. -C 3 (Output)(Unsuccessful) Means the integrator has taken -C 1000 steps without reaching TOUT. The user can -C continue the integration by simply calling SDRIV1 -C again. -C 4 (Output)(Unsuccessful) Means too much accuracy has -C been requested. EPS has been increased to a value -C the program estimates is appropriate. The user can -C continue the integration by simply calling SDRIV1 -C again. -C 5 (Output)(Unsuccessful) N has been set to zero in -C SUBROUTINE F. -C 6 (Output)(Successful) For MSTATE negative, T is beyond -C TOUT. The solution was obtained by interpolation. -C The user can continue the integration by simply -C advancing TOUT and calling SDRIV1 again. -C 7 (Output)(Unsuccessful) The solution could not be -C obtained. The value of IERFLG (see description -C below) for a "Recoverable" situation indicates the -C type of difficulty encountered: either an illegal -C value for a parameter or an inability to continue the -C solution. For this condition the user should take -C corrective action and reset MSTATE to +1(-1) before -C calling SDRIV1 again. Otherwise the program will -C terminate the run. -C -C EPS = On input, the requested relative accuracy in all solution -C components. On output, the adjusted relative accuracy if -C the input value was too small. The value of EPS should be -C set as large as is reasonable, because the amount of work -C done by SDRIV1 increases as EPS decreases. -C -C WORK -C LENW = (Input) -C WORK is an array of LENW real words used -C internally for temporary storage. The user must allocate -C space for this array in the calling program by a statement -C such as -C REAL WORK(...) -C The length of WORK should be at least N*N + 11*N + 300 -C and LENW should be set to the value used. The contents of -C WORK should not be disturbed between calls to SDRIV1. -C -C IERFLG = An error flag. The error number associated with a -C diagnostic message (see Section IV-A below) is the same as -C the corresponding value of IERFLG. The meaning of IERFLG: -C 0 The routine completed successfully. (No message is -C issued.) -C 3 (Warning) The number of steps required to reach TOUT -C exceeds 1000 . -C 4 (Warning) The value of EPS is too small. -C 11 (Warning) For MSTATE negative, T is beyond TOUT. -C The solution was obtained by interpolation. -C 15 (Warning) The integration step size is below the -C roundoff level of T. (The program issues this -C message as a warning but does not return control to -C the user.) -C 21 (Recoverable) N is greater than 200 . -C 22 (Recoverable) N is not positive. -C 26 (Recoverable) The magnitude of MSTATE is either 0 or -C greater than 7 . -C 27 (Recoverable) EPS is less than zero. -C 32 (Recoverable) Insufficient storage has been allocated -C for the WORK array. -C 41 (Recoverable) The integration step size has gone -C to zero. -C 42 (Recoverable) The integration step size has been -C reduced about 50 times without advancing the -C solution. The problem setup may not be correct. -C 999 (Fatal) The magnitude of MSTATE is 7 . -C -C III. USAGE ........................................................ -C -C PROGRAM SAMPLE -C EXTERNAL F -C REAL ALFA, EPS, T, TOUT -C C N is the number of equations -C PARAMETER(ALFA = 1.E0, N = 3, LENW = N*N + 11*N + 300) -C REAL WORK(LENW), Y(N+1) -C C Initial point -C T = 0.00001E0 -C C Set initial conditions -C Y(1) = 10.E0 -C Y(2) = 0.E0 -C Y(3) = 10.E0 -C C Pass parameter -C Y(4) = ALFA -C TOUT = T -C MSTATE = 1 -C EPS = .001E0 -C 10 CALL SDRIV1 (N, T, Y, F, TOUT, MSTATE, EPS, WORK, LENW, -C 8 IERFLG) -C IF (MSTATE .GT. 2) STOP -C WRITE(*, '(4E12.3)') TOUT, (Y(I), I=1,3) -C TOUT = 10.E0*TOUT -C IF (TOUT .LT. 50.E0) GO TO 10 -C END -C -C SUBROUTINE F (N, T, Y, YDOT) -C REAL ALFA, T, Y(*), YDOT(*) -C ALFA = Y(N+1) -C YDOT(1) = 1.E0 + ALFA*(Y(2) - Y(1)) - Y(1)*Y(3) -C YDOT(2) = ALFA*(Y(1) - Y(2)) - Y(2)*Y(3) -C YDOT(3) = 1.E0 - Y(3)*(Y(1) + Y(2)) -C END -C -C IV. OTHER COMMUNICATION TO THE USER ............................... -C -C A. The solver communicates to the user through the parameters -C above. In addition it writes diagnostic messages through the -C standard error handling program XERMSG. A complete description -C of XERMSG is given in "Guide to the SLATEC Common Mathematical -C Library" by Kirby W. Fong et al.. At installations which do not -C have this error handling package the short but serviceable -C routine, XERMSG, available with this package, can be used. That -C program uses the file named OUTPUT to transmit messages. -C -C B. The number of evaluations of the right hand side can be found -C in the WORK array in the location determined by: -C LENW - (N + 50) + 4 -C -C V. REMARKS ........................................................ -C -C For other information, see Section IV of the writeup for SDRIV3. -C -C***REFERENCES C. W. Gear, Numerical Initial Value Problems in -C Ordinary Differential Equations, Prentice-Hall, 1971. -C***ROUTINES CALLED SDRIV3, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE SDRIV1 - EXTERNAL F - REAL EPS, EWTCOM(1), HMAX, T, TOUT, WORK(*), Y(*) - INTEGER I, IDLIW, IERFLG, IERROR, IMPL, LENIW, LENW, LENWCM, - 8 LNWCHK, MINT, MITER, ML, MSTATE, MU, MXN, MXORD, MXSTEP, - 8 N, NDE, NROOT, NSTATE, NTASK - PARAMETER(MXN = 200, IDLIW = 50) - INTEGER IWORK(IDLIW+MXN) - CHARACTER INTGR1*8 - PARAMETER(NROOT = 0, IERROR = 2, MINT = 2, MITER = 2, IMPL = 0, - 8 MXORD = 5, MXSTEP = 1000) - DATA EWTCOM(1) /1.E0/ -C***FIRST EXECUTABLE STATEMENT SDRIV1 - IF (ABS(MSTATE) .EQ. 0 .OR. ABS(MSTATE) .GT. 7) THEN - WRITE(INTGR1, '(I8)') MSTATE - IERFLG = 26 - CALL XERMSG('SLATEC', 'SDRIV1', - 8 'Illegal input. The magnitude of MSTATE, '//INTGR1// - 8 ', is not in the range 1 to 6 .', IERFLG, 1) - MSTATE = SIGN(7, MSTATE) - RETURN - ELSE IF (ABS(MSTATE) .EQ. 7) THEN - IERFLG = 999 - CALL XERMSG('SLATEC', 'SDRIV1', - 8 'Illegal input. The magnitude of MSTATE is 7 .', IERFLG, 2) - RETURN - END IF - IF (N .GT. MXN) THEN - WRITE(INTGR1, '(I8)') N - IERFLG = 21 - CALL XERMSG('SLATEC', 'SDRIV1', - 8 'Illegal input. The number of equations, '//INTGR1// - 8 ', is greater than the maximum allowed: 200 .', IERFLG, 1) - MSTATE = SIGN(7, MSTATE) - RETURN - END IF - IF (MSTATE .GT. 0) THEN - NSTATE = MSTATE - NTASK = 1 - ELSE - NSTATE = - MSTATE - NTASK = 3 - END IF - HMAX = 2.E0*ABS(TOUT - T) - LENIW = N + IDLIW - LENWCM = LENW - LENIW - IF (LENWCM .LT. (N*N + 10*N + 250)) THEN - LNWCHK = N*N + 10*N + 250 + LENIW - WRITE(INTGR1, '(I8)') LNWCHK - IERFLG = 32 - CALL XERMSG('SLATEC', 'SDRIV1', - 8 'Insufficient storage allocated for the work array. '// - 8 'The required storage is at least '//INTGR1//' .', IERFLG, 1) - MSTATE = SIGN(7, MSTATE) - RETURN - END IF - IF (NSTATE .NE. 1) THEN - DO 20 I = 1,LENIW - 20 IWORK(I) = WORK(I+LENWCM) - END IF - CALL SDRIV3 (N, T, Y, F, NSTATE, TOUT, NTASK, NROOT, EPS, EWTCOM, - 8 IERROR, MINT, MITER, IMPL, ML, MU, MXORD, HMAX, WORK, - 8 LENWCM, IWORK, LENIW, F, F, NDE, MXSTEP, F, F, - 8 IERFLG) - DO 40 I = 1,LENIW - 40 WORK(I+LENWCM) = IWORK(I) - IF (NSTATE .LE. 4) THEN - MSTATE = SIGN(NSTATE, MSTATE) - ELSE IF (NSTATE .EQ. 6) THEN - MSTATE = SIGN(5, MSTATE) - ELSE IF (IERFLG .EQ. 11) THEN - MSTATE = SIGN(6, MSTATE) - ELSE IF (IERFLG .GT. 11) THEN - MSTATE = SIGN(7, MSTATE) - END IF - RETURN - END diff --git a/slatec/sdriv2.f b/slatec/sdriv2.f deleted file mode 100644 index 5d87cff..0000000 --- a/slatec/sdriv2.f +++ /dev/null @@ -1,408 +0,0 @@ -*DECK SDRIV2 - SUBROUTINE SDRIV2 (N, T, Y, F, TOUT, MSTATE, NROOT, EPS, EWT, - 8 MINT, WORK, LENW, IWORK, LENIW, G, IERFLG) -C***BEGIN PROLOGUE SDRIV2 -C***PURPOSE The function of SDRIV2 is to solve N ordinary differential -C equations of the form dY(I)/dT = F(Y(I),T), given the -C initial conditions Y(I) = YI. The program has options to -C allow the solution of both stiff and non-stiff differential -C equations. SDRIV2 uses single precision arithmetic. -C***LIBRARY SLATEC (SDRIVE) -C***CATEGORY I1A2, I1A1B -C***TYPE SINGLE PRECISION (SDRIV2-S, DDRIV2-D, CDRIV2-C) -C***KEYWORDS GEAR'S METHOD, INITIAL VALUE PROBLEMS, ODE, -C ORDINARY DIFFERENTIAL EQUATIONS, SDRIVE, SINGLE PRECISION, -C STIFF -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***DESCRIPTION -C -C I. PARAMETERS ..................................................... -C -C The user should use parameter names in the call sequence of SDRIV2 -C for those quantities whose value may be altered by SDRIV2. The -C parameters in the call sequence are: -C -C N = (Input) The number of differential equations. -C -C T = The independent variable. On input for the first call, T -C is the initial point. On output, T is the point at which -C the solution is given. -C -C Y = The vector of dependent variables. Y is used as input on -C the first call, to set the initial values. On output, Y -C is the computed solution vector. This array Y is passed -C in the call sequence of the user-provided routines F and -C G. Thus parameters required by F and G can be stored in -C this array in components N+1 and above. (Note: Changes -C by the user to the first N components of this array will -C take effect only after a restart, i.e., after setting -C MSTATE to +1(-1).) -C -C F = A subroutine supplied by the user. The name must be -C declared EXTERNAL in the user's calling program. This -C subroutine is of the form: -C SUBROUTINE F (N, T, Y, YDOT) -C REAL Y(*), YDOT(*) -C . -C . -C YDOT(1) = ... -C . -C . -C YDOT(N) = ... -C END (Sample) -C This computes YDOT = F(Y,T), the right hand side of the -C differential equations. Here Y is a vector of length at -C least N. The actual length of Y is determined by the -C user's declaration in the program which calls SDRIV2. -C Thus the dimensioning of Y in F, while required by FORTRAN -C convention, does not actually allocate any storage. When -C this subroutine is called, the first N components of Y are -C intermediate approximations to the solution components. -C The user should not alter these values. Here YDOT is a -C vector of length N. The user should only compute YDOT(I) -C for I from 1 to N. Normally a return from F passes -C control back to SDRIV2. However, if the user would like -C to abort the calculation, i.e., return control to the -C program which calls SDRIV2, he should set N to zero. -C SDRIV2 will signal this by returning a value of MSTATE -C equal to +6(-6). Altering the value of N in F has no -C effect on the value of N in the call sequence of SDRIV2. -C -C TOUT = (Input) The point at which the solution is desired. -C -C MSTATE = An integer describing the status of integration. The user -C must initialize MSTATE to +1 or -1. If MSTATE is -C positive, the routine will integrate past TOUT and -C interpolate the solution. This is the most efficient -C mode. If MSTATE is negative, the routine will adjust its -C internal step to reach TOUT exactly (useful if a -C singularity exists beyond TOUT.) The meaning of the -C magnitude of MSTATE: -C 1 (Input) Means the first call to the routine. This -C value must be set by the user. On all subsequent -C calls the value of MSTATE should be tested by the -C user. Unless SDRIV2 is to be reinitialized, only the -C sign of MSTATE may be changed by the user. (As a -C convenience to the user who may wish to put out the -C initial conditions, SDRIV2 can be called with -C MSTATE=+1(-1), and TOUT=T. In this case the program -C will return with MSTATE unchanged, i.e., -C MSTATE=+1(-1).) -C 2 (Output) Means a successful integration. If a normal -C continuation is desired (i.e., a further integration -C in the same direction), simply advance TOUT and call -C again. All other parameters are automatically set. -C 3 (Output)(Unsuccessful) Means the integrator has taken -C 1000 steps without reaching TOUT. The user can -C continue the integration by simply calling SDRIV2 -C again. Other than an error in problem setup, the -C most likely cause for this condition is trying to -C integrate a stiff set of equations with the non-stiff -C integrator option. (See description of MINT below.) -C 4 (Output)(Unsuccessful) Means too much accuracy has -C been requested. EPS has been increased to a value -C the program estimates is appropriate. The user can -C continue the integration by simply calling SDRIV2 -C again. -C 5 (Output) A root was found at a point less than TOUT. -C The user can continue the integration toward TOUT by -C simply calling SDRIV2 again. -C 6 (Output)(Unsuccessful) N has been set to zero in -C SUBROUTINE F. -C 7 (Output)(Unsuccessful) N has been set to zero in -C FUNCTION G. See description of G below. -C 8 (Output)(Successful) For MSTATE negative, T is beyond -C TOUT. The solution was obtained by interpolation. -C The user can continue the integration by simply -C advancing TOUT and calling SDRIV2 again. -C 9 (Output)(Unsuccessful) The solution could not be -C obtained. The value of IERFLG (see description -C below) for a "Recoverable" situation indicates the -C type of difficulty encountered: either an illegal -C value for a parameter or an inability to continue the -C solution. For this condition the user should take -C corrective action and reset MSTATE to +1(-1) before -C calling SDRIV2 again. Otherwise the program will -C terminate the run. -C -C NROOT = (Input) The number of equations whose roots are desired. -C If NROOT is zero, the root search is not active. This -C option is useful for obtaining output at points which are -C not known in advance, but depend upon the solution, e.g., -C when some solution component takes on a specified value. -C The root search is carried out using the user-written -C function G (see description of G below.) SDRIV2 attempts -C to find the value of T at which one of the equations -C changes sign. SDRIV2 can find at most one root per -C equation per internal integration step, and will then -C return the solution either at TOUT or at a root, whichever -C occurs first in the direction of integration. The initial -C point is never reported as a root. The index of the -C equation whose root is being reported is stored in the -C sixth element of IWORK. -C NOTE: NROOT is never altered by this program. -C -C EPS = On input, the requested relative accuracy in all solution -C components. EPS = 0 is allowed. On output, the adjusted -C relative accuracy if the input value was too small. The -C value of EPS should be set as large as is reasonable, -C because the amount of work done by SDRIV2 increases as -C EPS decreases. -C -C EWT = (Input) Problem zero, i.e., the smallest physically -C meaningful value for the solution. This is used inter- -C nally to compute an array YWT(I) = MAX(ABS(Y(I)), EWT). -C One step error estimates divided by YWT(I) are kept less -C than EPS. Setting EWT to zero provides pure relative -C error control. However, setting EWT smaller than -C necessary can adversely affect the running time. -C -C MINT = (Input) The integration method flag. -C MINT = 1 Means the Adams methods, and is used for -C non-stiff problems. -C MINT = 2 Means the stiff methods of Gear (i.e., the -C backward differentiation formulas), and is -C used for stiff problems. -C MINT = 3 Means the program dynamically selects the -C Adams methods when the problem is non-stiff -C and the Gear methods when the problem is -C stiff. -C MINT may not be changed without restarting, i.e., setting -C the magnitude of MSTATE to 1. -C -C WORK -C LENW = (Input) -C WORK is an array of LENW real words used -C internally for temporary storage. The user must allocate -C space for this array in the calling program by a statement -C such as -C REAL WORK(...) -C The length of WORK should be at least -C 16*N + 2*NROOT + 250 if MINT is 1, or -C N*N + 10*N + 2*NROOT + 250 if MINT is 2, or -C N*N + 17*N + 2*NROOT + 250 if MINT is 3, -C and LENW should be set to the value used. The contents of -C WORK should not be disturbed between calls to SDRIV2. -C -C IWORK -C LENIW = (Input) -C IWORK is an integer array of length LENIW used internally -C for temporary storage. The user must allocate space for -C this array in the calling program by a statement such as -C INTEGER IWORK(...) -C The length of IWORK should be at least -C 50 if MINT is 1, or -C N+50 if MINT is 2 or 3, -C and LENIW should be set to the value used. The contents -C of IWORK should not be disturbed between calls to SDRIV2. -C -C G = A real FORTRAN function supplied by the user -C if NROOT is not 0. In this case, the name must be -C declared EXTERNAL in the user's calling program. G is -C repeatedly called with different values of IROOT to -C obtain the value of each of the NROOT equations for which -C a root is desired. G is of the form: -C REAL FUNCTION G (N, T, Y, IROOT) -C REAL Y(*) -C GO TO (10, ...), IROOT -C 10 G = ... -C . -C . -C END (Sample) -C Here, Y is a vector of length at least N, whose first N -C components are the solution components at the point T. -C The user should not alter these values. The actual length -C of Y is determined by the user's declaration in the -C program which calls SDRIV2. Thus the dimensioning of Y in -C G, while required by FORTRAN convention, does not actually -C allocate any storage. Normally a return from G passes -C control back to SDRIV2. However, if the user would like -C to abort the calculation, i.e., return control to the -C program which calls SDRIV2, he should set N to zero. -C SDRIV2 will signal this by returning a value of MSTATE -C equal to +7(-7). In this case, the index of the equation -C being evaluated is stored in the sixth element of IWORK. -C Altering the value of N in G has no effect on the value of -C N in the call sequence of SDRIV2. -C -C IERFLG = An error flag. The error number associated with a -C diagnostic message (see Section II-A below) is the same as -C the corresponding value of IERFLG. The meaning of IERFLG: -C 0 The routine completed successfully. (No message is -C issued.) -C 3 (Warning) The number of steps required to reach TOUT -C exceeds MXSTEP. -C 4 (Warning) The value of EPS is too small. -C 11 (Warning) For MSTATE negative, T is beyond TOUT. -C The solution was obtained by interpolation. -C 15 (Warning) The integration step size is below the -C roundoff level of T. (The program issues this -C message as a warning but does not return control to -C the user.) -C 22 (Recoverable) N is not positive. -C 23 (Recoverable) MINT is less than 1 or greater than 3 . -C 26 (Recoverable) The magnitude of MSTATE is either 0 or -C greater than 9 . -C 27 (Recoverable) EPS is less than zero. -C 32 (Recoverable) Insufficient storage has been allocated -C for the WORK array. -C 33 (Recoverable) Insufficient storage has been allocated -C for the IWORK array. -C 41 (Recoverable) The integration step size has gone -C to zero. -C 42 (Recoverable) The integration step size has been -C reduced about 50 times without advancing the -C solution. The problem setup may not be correct. -C 999 (Fatal) The magnitude of MSTATE is 9 . -C -C II. OTHER COMMUNICATION TO THE USER ............................... -C -C A. The solver communicates to the user through the parameters -C above. In addition it writes diagnostic messages through the -C standard error handling program XERMSG. A complete description -C of XERMSG is given in "Guide to the SLATEC Common Mathematical -C Library" by Kirby W. Fong et al.. At installations which do not -C have this error handling package the short but serviceable -C routine, XERMSG, available with this package, can be used. That -C program uses the file named OUTPUT to transmit messages. -C -C B. The first three elements of WORK and the first five elements of -C IWORK will contain the following statistical data: -C AVGH The average step size used. -C HUSED The step size last used (successfully). -C AVGORD The average order used. -C IMXERR The index of the element of the solution vector that -C contributed most to the last error test. -C NQUSED The order last used (successfully). -C NSTEP The number of steps taken since last initialization. -C NFE The number of evaluations of the right hand side. -C NJE The number of evaluations of the Jacobian matrix. -C -C III. REMARKS ...................................................... -C -C A. On any return from SDRIV2 all information necessary to continue -C the calculation is contained in the call sequence parameters, -C including the work arrays. Thus it is possible to suspend one -C problem, integrate another, and then return to the first. -C -C B. If this package is to be used in an overlay situation, the user -C must declare in the primary overlay the variables in the call -C sequence to SDRIV2. -C -C C. When the routine G is not required, difficulties associated with -C an unsatisfied external can be avoided by using the name of the -C routine which calculates the right hand side of the differential -C equations in place of G in the call sequence of SDRIV2. -C -C IV. USAGE ......................................................... -C -C PROGRAM SAMPLE -C EXTERNAL F -C PARAMETER(MINT = 1, NROOT = 0, N = ..., -C 8 LENW = 16*N + 2*NROOT + 250, LENIW = 50) -C C N is the number of equations -C REAL EPS, EWT, T, TOUT, WORK(LENW), Y(N) -C INTEGER IWORK(LENIW) -C OPEN(FILE='TAPE6', UNIT=6, STATUS='NEW') -C C Initial point -C T = 0. -C C Set initial conditions -C DO 10 I = 1,N -C 10 Y(I) = ... -C TOUT = T -C EWT = ... -C MSTATE = 1 -C EPS = ... -C 20 CALL SDRIV2 (N, T, Y, F, TOUT, MSTATE, NROOT, EPS, EWT, -C 8 MINT, WORK, LENW, IWORK, LENIW, F, IERFLG) -C C Next to last argument is not -C C F if rootfinding is used. -C IF (MSTATE .GT. 2) STOP -C WRITE(6, 100) TOUT, (Y(I), I=1,N) -C TOUT = TOUT + 1. -C IF (TOUT .LE. 10.) GO TO 20 -C 100 FORMAT(...) -C END (Sample) -C -C***REFERENCES C. W. Gear, Numerical Initial Value Problems in -C Ordinary Differential Equations, Prentice-Hall, 1971. -C***ROUTINES CALLED SDRIV3, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE SDRIV2 - EXTERNAL F, G - REAL EPS, EWT, EWTCOM(1), G, HMAX, T, TOUT, - 8 WORK(*), Y(*) - INTEGER IWORK(*) - INTEGER IERFLG, IERROR, IMPL, LENIW, LENW, MINT, MITER, ML, - 8 MSTATE, MU, MXORD, MXSTEP, N, NDE, NROOT, NSTATE, NTASK - CHARACTER INTGR1*8 - PARAMETER(IMPL = 0, MXSTEP = 1000) -C***FIRST EXECUTABLE STATEMENT SDRIV2 - IF (ABS(MSTATE) .EQ. 9) THEN - IERFLG = 999 - CALL XERMSG('SLATEC', 'SDRIV2', - 8 'Illegal input. The magnitude of MSTATE IS 9 .', - 8 IERFLG, 2) - RETURN - ELSE IF (ABS(MSTATE) .EQ. 0 .OR. ABS(MSTATE) .GT. 9) THEN - WRITE(INTGR1, '(I8)') MSTATE - IERFLG = 26 - CALL XERMSG('SLATEC', 'SDRIV2', - 8 'Illegal input. The magnitude of MSTATE, '//INTGR1// - 8 ' is not in the range 1 to 8 .', IERFLG, 1) - MSTATE = SIGN(9, MSTATE) - RETURN - END IF - IF (MINT .LT. 1 .OR. MINT .GT. 3) THEN - WRITE(INTGR1, '(I8)') MINT - IERFLG = 23 - CALL XERMSG('SLATEC', 'SDRIV2', - 8 'Illegal input. Improper value for the integration method '// - 8 'flag, '//INTGR1//' .', IERFLG, 1) - MSTATE = SIGN(9, MSTATE) - RETURN - END IF - IF (MSTATE .GE. 0) THEN - NSTATE = MSTATE - NTASK = 1 - ELSE - NSTATE = - MSTATE - NTASK = 3 - END IF - EWTCOM(1) = EWT - IF (EWT .NE. 0.E0) THEN - IERROR = 3 - ELSE - IERROR = 2 - END IF - IF (MINT .EQ. 1) THEN - MITER = 0 - MXORD = 12 - ELSE IF (MINT .EQ. 2) THEN - MITER = 2 - MXORD = 5 - ELSE IF (MINT .EQ. 3) THEN - MITER = 2 - MXORD = 12 - END IF - HMAX = 2.E0*ABS(TOUT - T) - CALL SDRIV3 (N, T, Y, F, NSTATE, TOUT, NTASK, NROOT, EPS, EWTCOM, - 8 IERROR, MINT, MITER, IMPL, ML, MU, MXORD, HMAX, WORK, - 8 LENW, IWORK, LENIW, F, F, NDE, MXSTEP, G, F, IERFLG) - IF (NSTATE .LE. 7) THEN - MSTATE = SIGN(NSTATE, MSTATE) - ELSE IF (NSTATE .EQ. 11) THEN - MSTATE = SIGN(8, MSTATE) - ELSE IF (NSTATE .GT. 11) THEN - MSTATE = SIGN(9, MSTATE) - END IF - RETURN - END diff --git a/slatec/sdriv3.f b/slatec/sdriv3.f deleted file mode 100644 index 91baa79..0000000 --- a/slatec/sdriv3.f +++ /dev/null @@ -1,1526 +0,0 @@ -*DECK SDRIV3 - SUBROUTINE SDRIV3 (N, T, Y, F, NSTATE, TOUT, NTASK, NROOT, EPS, - 8 EWT, IERROR, MINT, MITER, IMPL, ML, MU, MXORD, HMAX, WORK, - 8 LENW, IWORK, LENIW, JACOBN, FA, NDE, MXSTEP, G, USERS, IERFLG) -C***BEGIN PROLOGUE SDRIV3 -C***PURPOSE The function of SDRIV3 is to solve N ordinary differential -C equations of the form dY(I)/dT = F(Y(I),T), given the -C initial conditions Y(I) = YI. The program has options to -C allow the solution of both stiff and non-stiff differential -C equations. Other important options are available. SDRIV3 -C uses single precision arithmetic. -C***LIBRARY SLATEC (SDRIVE) -C***CATEGORY I1A2, I1A1B -C***TYPE SINGLE PRECISION (SDRIV3-S, DDRIV3-D, CDRIV3-C) -C***KEYWORDS GEAR'S METHOD, INITIAL VALUE PROBLEMS, ODE, -C ORDINARY DIFFERENTIAL EQUATIONS, SDRIVE, SINGLE PRECISION, -C STIFF -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***DESCRIPTION -C -C I. ABSTRACT ....................................................... -C -C The primary function of SDRIV3 is to solve N ordinary differential -C equations of the form dY(I)/dT = F(Y(I),T), given the initial -C conditions Y(I) = YI. The program has options to allow the -C solution of both stiff and non-stiff differential equations. In -C addition, SDRIV3 may be used to solve: -C 1. The initial value problem, A*dY(I)/dT = F(Y(I),T), where A is -C a non-singular matrix depending on Y and T. -C 2. The hybrid differential/algebraic initial value problem, -C A*dY(I)/dT = F(Y(I),T), where A is a vector (whose values may -C depend upon Y and T) some of whose components will be zero -C corresponding to those equations which are algebraic rather -C than differential. -C SDRIV3 is to be called once for each output point of T. -C -C II. PARAMETERS .................................................... -C -C The user should use parameter names in the call sequence of SDRIV3 -C for those quantities whose value may be altered by SDRIV3. The -C parameters in the call sequence are: -C -C N = (Input) The number of dependent functions whose solution -C is desired. N must not be altered during a problem. -C -C T = The independent variable. On input for the first call, T -C is the initial point. On output, T is the point at which -C the solution is given. -C -C Y = The vector of dependent variables. Y is used as input on -C the first call, to set the initial values. On output, Y -C is the computed solution vector. This array Y is passed -C in the call sequence of the user-provided routines F, -C JACOBN, FA, USERS, and G. Thus parameters required by -C those routines can be stored in this array in components -C N+1 and above. (Note: Changes by the user to the first -C N components of this array will take effect only after a -C restart, i.e., after setting NSTATE to 1 .) -C -C F = A subroutine supplied by the user. The name must be -C declared EXTERNAL in the user's calling program. This -C subroutine is of the form: -C SUBROUTINE F (N, T, Y, YDOT) -C REAL Y(*), YDOT(*) -C . -C . -C YDOT(1) = ... -C . -C . -C YDOT(N) = ... -C END (Sample) -C This computes YDOT = F(Y,T), the right hand side of the -C differential equations. Here Y is a vector of length at -C least N. The actual length of Y is determined by the -C user's declaration in the program which calls SDRIV3. -C Thus the dimensioning of Y in F, while required by FORTRAN -C convention, does not actually allocate any storage. When -C this subroutine is called, the first N components of Y are -C intermediate approximations to the solution components. -C The user should not alter these values. Here YDOT is a -C vector of length N. The user should only compute YDOT(I) -C for I from 1 to N. Normally a return from F passes -C control back to SDRIV3. However, if the user would like -C to abort the calculation, i.e., return control to the -C program which calls SDRIV3, he should set N to zero. -C SDRIV3 will signal this by returning a value of NSTATE -C equal to 6 . Altering the value of N in F has no effect -C on the value of N in the call sequence of SDRIV3. -C -C NSTATE = An integer describing the status of integration. The -C meaning of NSTATE is as follows: -C 1 (Input) Means the first call to the routine. This -C value must be set by the user. On all subsequent -C calls the value of NSTATE should be tested by the -C user, but must not be altered. (As a convenience to -C the user who may wish to put out the initial -C conditions, SDRIV3 can be called with NSTATE=1, and -C TOUT=T. In this case the program will return with -C NSTATE unchanged, i.e., NSTATE=1.) -C 2 (Output) Means a successful integration. If a normal -C continuation is desired (i.e., a further integration -C in the same direction), simply advance TOUT and call -C again. All other parameters are automatically set. -C 3 (Output)(Unsuccessful) Means the integrator has taken -C MXSTEP steps without reaching TOUT. The user can -C continue the integration by simply calling SDRIV3 -C again. -C 4 (Output)(Unsuccessful) Means too much accuracy has -C been requested. EPS has been increased to a value -C the program estimates is appropriate. The user can -C continue the integration by simply calling SDRIV3 -C again. -C 5 (Output) A root was found at a point less than TOUT. -C The user can continue the integration toward TOUT by -C simply calling SDRIV3 again. -C 6 (Output)(Unsuccessful) N has been set to zero in -C SUBROUTINE F. -C 7 (Output)(Unsuccessful) N has been set to zero in -C FUNCTION G. See description of G below. -C 8 (Output)(Unsuccessful) N has been set to zero in -C SUBROUTINE JACOBN. See description of JACOBN below. -C 9 (Output)(Unsuccessful) N has been set to zero in -C SUBROUTINE FA. See description of FA below. -C 10 (Output)(Unsuccessful) N has been set to zero in -C SUBROUTINE USERS. See description of USERS below. -C 11 (Output)(Successful) For NTASK = 2 or 3, T is beyond -C TOUT. The solution was obtained by interpolation. -C The user can continue the integration by simply -C advancing TOUT and calling SDRIV3 again. -C 12 (Output)(Unsuccessful) The solution could not be -C obtained. The value of IERFLG (see description -C below) for a "Recoverable" situation indicates the -C type of difficulty encountered: either an illegal -C value for a parameter or an inability to continue the -C solution. For this condition the user should take -C corrective action and reset NSTATE to 1 before -C calling SDRIV3 again. Otherwise the program will -C terminate the run. -C -C TOUT = (Input) The point at which the solution is desired. The -C position of TOUT relative to T on the first call -C determines the direction of integration. -C -C NTASK = (Input) An index specifying the manner of returning the -C solution, according to the following: -C NTASK = 1 Means SDRIV3 will integrate past TOUT and -C interpolate the solution. This is the most -C efficient mode. -C NTASK = 2 Means SDRIV3 will return the solution after -C each internal integration step, or at TOUT, -C whichever comes first. In the latter case, -C the program integrates exactly to TOUT. -C NTASK = 3 Means SDRIV3 will adjust its internal step to -C reach TOUT exactly (useful if a singularity -C exists beyond TOUT.) -C -C NROOT = (Input) The number of equations whose roots are desired. -C If NROOT is zero, the root search is not active. This -C option is useful for obtaining output at points which are -C not known in advance, but depend upon the solution, e.g., -C when some solution component takes on a specified value. -C The root search is carried out using the user-written -C function G (see description of G below.) SDRIV3 attempts -C to find the value of T at which one of the equations -C changes sign. SDRIV3 can find at most one root per -C equation per internal integration step, and will then -C return the solution either at TOUT or at a root, whichever -C occurs first in the direction of integration. The initial -C point is never reported as a root. The index of the -C equation whose root is being reported is stored in the -C sixth element of IWORK. -C NOTE: NROOT is never altered by this program. -C -C EPS = On input, the requested relative accuracy in all solution -C components. EPS = 0 is allowed. On output, the adjusted -C relative accuracy if the input value was too small. The -C value of EPS should be set as large as is reasonable, -C because the amount of work done by SDRIV3 increases as EPS -C decreases. -C -C EWT = (Input) Problem zero, i.e., the smallest, nonzero, -C physically meaningful value for the solution. (Array, -C possibly of length one. See following description of -C IERROR.) Setting EWT smaller than necessary can adversely -C affect the running time. -C -C IERROR = (Input) Error control indicator. A value of 3 is -C suggested for most problems. Other choices and detailed -C explanations of EWT and IERROR are given below for those -C who may need extra flexibility. -C -C These last three input quantities EPS, EWT and IERROR -C control the accuracy of the computed solution. EWT and -C IERROR are used internally to compute an array YWT. One -C step error estimates divided by YWT(I) are kept less than -C EPS in root mean square norm. -C IERROR (Set by the user) = -C 1 Means YWT(I) = 1. (Absolute error control) -C EWT is ignored. -C 2 Means YWT(I) = ABS(Y(I)), (Relative error control) -C EWT is ignored. -C 3 Means YWT(I) = MAX(ABS(Y(I)), EWT(1)). -C 4 Means YWT(I) = MAX(ABS(Y(I)), EWT(I)). -C This choice is useful when the solution components -C have differing scales. -C 5 Means YWT(I) = EWT(I). -C If IERROR is 3, EWT need only be dimensioned one. -C If IERROR is 4 or 5, the user must dimension EWT at least -C N, and set its values. -C -C MINT = (Input) The integration method indicator. -C MINT = 1 Means the Adams methods, and is used for -C non-stiff problems. -C MINT = 2 Means the stiff methods of Gear (i.e., the -C backward differentiation formulas), and is -C used for stiff problems. -C MINT = 3 Means the program dynamically selects the -C Adams methods when the problem is non-stiff -C and the Gear methods when the problem is -C stiff. When using the Adams methods, the -C program uses a value of MITER=0; when using -C the Gear methods, the program uses the value -C of MITER provided by the user. Only a value -C of IMPL = 0 and a value of MITER = 1, 2, 4, or -C 5 is allowed for this option. The user may -C not alter the value of MINT or MITER without -C restarting, i.e., setting NSTATE to 1. -C -C MITER = (Input) The iteration method indicator. -C MITER = 0 Means functional iteration. This value is -C suggested for non-stiff problems. -C MITER = 1 Means chord method with analytic Jacobian. -C In this case, the user supplies subroutine -C JACOBN (see description below). -C MITER = 2 Means chord method with Jacobian calculated -C internally by finite differences. -C MITER = 3 Means chord method with corrections computed -C by the user-written routine USERS (see -C description of USERS below.) This option -C allows all matrix algebra and storage -C decisions to be made by the user. When using -C a value of MITER = 3, the subroutine FA is -C not required, even if IMPL is not 0. For -C further information on using this option, see -C Section IV-E below. -C MITER = 4 Means the same as MITER = 1 but the A and -C Jacobian matrices are assumed to be banded. -C MITER = 5 Means the same as MITER = 2 but the A and -C Jacobian matrices are assumed to be banded. -C -C IMPL = (Input) The implicit method indicator. -C IMPL = 0 Means solving dY(I)/dT = F(Y(I),T). -C IMPL = 1 Means solving A*dY(I)/dT = F(Y(I),T), non- -C singular A (see description of FA below.) -C Only MINT = 1 or 2, and MITER = 1, 2, 3, 4, -C or 5 are allowed for this option. -C IMPL = 2,3 Means solving certain systems of hybrid -C differential/algebraic equations (see -C description of FA below.) Only MINT = 2 and -C MITER = 1, 2, 3, 4, or 5, are allowed for -C this option. -C The value of IMPL must not be changed during a problem. -C -C ML = (Input) The lower half-bandwidth in the case of a banded -C A or Jacobian matrix. (I.e., maximum(R-C) for nonzero -C A(R,C).) -C -C MU = (Input) The upper half-bandwidth in the case of a banded -C A or Jacobian matrix. (I.e., maximum(C-R).) -C -C MXORD = (Input) The maximum order desired. This is .LE. 12 for -C the Adams methods and .LE. 5 for the Gear methods. Normal -C value is 12 and 5, respectively. If MINT is 3, the -C maximum order used will be MIN(MXORD, 12) when using the -C Adams methods, and MIN(MXORD, 5) when using the Gear -C methods. MXORD must not be altered during a problem. -C -C HMAX = (Input) The maximum magnitude of the step size that will -C be used for the problem. This is useful for ensuring that -C important details are not missed. If this is not the -C case, a large value, such as the interval length, is -C suggested. -C -C WORK -C LENW = (Input) -C WORK is an array of LENW real words used -C internally for temporary storage. The user must allocate -C space for this array in the calling program by a statement -C such as -C REAL WORK(...) -C The following table gives the required minimum value for -C the length of WORK, depending on the value of IMPL and -C MITER. LENW should be set to the value used. The -C contents of WORK should not be disturbed between calls to -C SDRIV3. -C -C IMPL = 0 1 2 3 -C --------------------------------------------------------- -C MITER = 0 (MXORD+4)*N Not allowed Not allowed Not allowed -C + 2*NROOT -C + 250 -C -C 1,2 N*N + 2*N*N + N*N + N*(N + NDE) -C (MXORD+5)*N (MXORD+5)*N (MXORD+6)*N + (MXORD+5)*N -C + 2*NROOT + 2*NROOT + 2*NROOT + 2*NROOT -C + 250 + 250 + 250 + 250 -C -C 3 (MXORD+4)*N (MXORD+4)*N (MXORD+4)*N (MXORD+4)*N -C + 2*NROOT + 2*NROOT + 2*NROOT + 2*NROOT -C + 250 + 250 + 250 + 250 -C -C 4,5 (2*ML+MU+1) 2*(2*ML+MU+1) (2*ML+MU+1) (2*ML+MU+1)* -C *N + *N + *N + (N+NDE) + -C (MXORD+5)*N (MXORD+5)*N (MXORD+6)*N + (MXORD+5)*N -C + 2*NROOT + 2*NROOT + 2*NROOT + 2*NROOT -C + 250 + 250 + 250 + 250 -C --------------------------------------------------------- -C -C IWORK -C LENIW = (Input) -C IWORK is an integer array of length LENIW used internally -C for temporary storage. The user must allocate space for -C this array in the calling program by a statement such as -C INTEGER IWORK(...) -C The length of IWORK should be at least -C 50 if MITER is 0 or 3, or -C N+50 if MITER is 1, 2, 4, or 5, or MINT is 3, -C and LENIW should be set to the value used. The contents -C of IWORK should not be disturbed between calls to SDRIV3. -C -C JACOBN = A subroutine supplied by the user, if MITER is 1 or 4. -C If this is the case, the name must be declared EXTERNAL in -C the user's calling program. Given a system of N -C differential equations, it is meaningful to speak about -C the partial derivative of the I-th right hand side with -C respect to the J-th dependent variable. In general there -C are N*N such quantities. Often however the equations can -C be ordered so that the I-th differential equation only -C involves dependent variables with index near I, e.g., I+1, -C I-2. Such a system is called banded. If, for all I, the -C I-th equation depends on at most the variables -C Y(I-ML), Y(I-ML+1), ... , Y(I), Y(I+1), ... , Y(I+MU) -C then we call ML+MU+1 the bandwidth of the system. In a -C banded system many of the partial derivatives above are -C automatically zero. For the cases MITER = 1, 2, 4, and 5, -C some of these partials are needed. For the cases -C MITER = 2 and 5 the necessary derivatives are -C approximated numerically by SDRIV3, and we only ask the -C user to tell SDRIV3 the value of ML and MU if the system -C is banded. For the cases MITER = 1 and 4 the user must -C derive these partials algebraically and encode them in -C subroutine JACOBN. By computing these derivatives the -C user can often save 20-30 per cent of the computing time. -C Usually, however, the accuracy is not much affected and -C most users will probably forego this option. The optional -C user-written subroutine JACOBN has the form: -C SUBROUTINE JACOBN (N, T, Y, DFDY, MATDIM, ML, MU) -C REAL Y(*), DFDY(MATDIM,*) -C . -C . -C Calculate values of DFDY -C . -C . -C END (Sample) -C Here Y is a vector of length at least N. The actual -C length of Y is determined by the user's declaration in the -C program which calls SDRIV3. Thus the dimensioning of Y in -C JACOBN, while required by FORTRAN convention, does not -C actually allocate any storage. When this subroutine is -C called, the first N components of Y are intermediate -C approximations to the solution components. The user -C should not alter these values. If the system is not -C banded (MITER=1), the partials of the I-th equation with -C respect to the J-th dependent function are to be stored in -C DFDY(I,J). Thus partials of the I-th equation are stored -C in the I-th row of DFDY. If the system is banded -C (MITER=4), then the partials of the I-th equation with -C respect to Y(J) are to be stored in DFDY(K,J), where -C K=I-J+MU+1 . Normally a return from JACOBN passes control -C back to SDRIV3. However, if the user would like to abort -C the calculation, i.e., return control to the program which -C calls SDRIV3, he should set N to zero. SDRIV3 will signal -C this by returning a value of NSTATE equal to +8(-8). -C Altering the value of N in JACOBN has no effect on the -C value of N in the call sequence of SDRIV3. -C -C FA = A subroutine supplied by the user if IMPL is not zero, and -C MITER is not 3. If so, the name must be declared EXTERNAL -C in the user's calling program. This subroutine computes -C the array A, where A*dY(I)/dT = F(Y(I),T). -C There are three cases: -C -C IMPL=1. -C Subroutine FA is of the form: -C SUBROUTINE FA (N, T, Y, A, MATDIM, ML, MU, NDE) -C REAL Y(*), A(MATDIM,*) -C . -C . -C Calculate ALL values of A -C . -C . -C END (Sample) -C In this case A is assumed to be a nonsingular matrix, -C with the same structure as DFDY (see JACOBN description -C above). Programming considerations prevent complete -C generality. If MITER is 1 or 2, A is assumed to be full -C and the user must compute and store all values of -C A(I,J), I,J=1, ... ,N. If MITER is 4 or 5, A is assumed -C to be banded with lower and upper half bandwidth ML and -C MU. The left hand side of the I-th equation is a linear -C combination of dY(I-ML)/dT, dY(I-ML+1)/dT, ... , -C dY(I)/dT, ... , dY(I+MU-1)/dT, dY(I+MU)/dT. Thus in the -C I-th equation, the coefficient of dY(J)/dT is to be -C stored in A(K,J), where K=I-J+MU+1. -C NOTE: The array A will be altered between calls to FA. -C -C IMPL=2. -C Subroutine FA is of the form: -C SUBROUTINE FA (N, T, Y, A, MATDIM, ML, MU, NDE) -C REAL Y(*), A(*) -C . -C . -C Calculate non-zero values of A(1),...,A(NDE) -C . -C . -C END (Sample) -C In this case it is assumed that the system is ordered by -C the user so that the differential equations appear -C first, and the algebraic equations appear last. The -C algebraic equations must be written in the form: -C 0 = F(Y(I),T). When using this option it is up to the -C user to provide initial values for the Y(I) that satisfy -C the algebraic equations as well as possible. It is -C further assumed that A is a vector of length NDE. All -C of the components of A, which may depend on T, Y(I), -C etc., must be set by the user to non-zero values. -C -C IMPL=3. -C Subroutine FA is of the form: -C SUBROUTINE FA (N, T, Y, A, MATDIM, ML, MU, NDE) -C REAL Y(*), A(MATDIM,*) -C . -C . -C Calculate ALL values of A -C . -C . -C END (Sample) -C In this case A is assumed to be a nonsingular NDE by NDE -C matrix with the same structure as DFDY (see JACOBN -C description above). Programming considerations prevent -C complete generality. If MITER is 1 or 2, A is assumed -C to be full and the user must compute and store all -C values of A(I,J), I,J=1, ... ,NDE. If MITER is 4 or 5, -C A is assumed to be banded with lower and upper half -C bandwidths ML and MU. The left hand side of the I-th -C equation is a linear combination of dY(I-ML)/dT, -C dY(I-ML+1)/dT, ... , dY(I)/dT, ... , dY(I+MU-1)/dT, -C dY(I+MU)/dT. Thus in the I-th equation, the coefficient -C of dY(J)/dT is to be stored in A(K,J), where K=I-J+MU+1. -C It is assumed that the system is ordered by the user so -C that the differential equations appear first, and the -C algebraic equations appear last. The algebraic -C equations must be written in the form 0 = F(Y(I),T). -C When using this option it is up to the user to provide -C initial values for the Y(I) that satisfy the algebraic -C equations as well as possible. -C NOTE: For IMPL = 3, the array A will be altered between -C calls to FA. -C Here Y is a vector of length at least N. The actual -C length of Y is determined by the user's declaration in the -C program which calls SDRIV3. Thus the dimensioning of Y in -C FA, while required by FORTRAN convention, does not -C actually allocate any storage. When this subroutine is -C called, the first N components of Y are intermediate -C approximations to the solution components. The user -C should not alter these values. FA is always called -C immediately after calling F, with the same values of T -C and Y. Normally a return from FA passes control back to -C SDRIV3. However, if the user would like to abort the -C calculation, i.e., return control to the program which -C calls SDRIV3, he should set N to zero. SDRIV3 will signal -C this by returning a value of NSTATE equal to +9(-9). -C Altering the value of N in FA has no effect on the value -C of N in the call sequence of SDRIV3. -C -C NDE = (Input) The number of differential equations. This is -C required only for IMPL = 2 or 3, with NDE .LT. N. -C -C MXSTEP = (Input) The maximum number of internal steps allowed on -C one call to SDRIV3. -C -C G = A real FORTRAN function supplied by the user -C if NROOT is not 0. In this case, the name must be -C declared EXTERNAL in the user's calling program. G is -C repeatedly called with different values of IROOT to obtain -C the value of each of the NROOT equations for which a root -C is desired. G is of the form: -C REAL FUNCTION G (N, T, Y, IROOT) -C REAL Y(*) -C GO TO (10, ...), IROOT -C 10 G = ... -C . -C . -C END (Sample) -C Here, Y is a vector of length at least N, whose first N -C components are the solution components at the point T. -C The user should not alter these values. The actual length -C of Y is determined by the user's declaration in the -C program which calls SDRIV3. Thus the dimensioning of Y in -C G, while required by FORTRAN convention, does not actually -C allocate any storage. Normally a return from G passes -C control back to SDRIV3. However, if the user would like -C to abort the calculation, i.e., return control to the -C program which calls SDRIV3, he should set N to zero. -C SDRIV3 will signal this by returning a value of NSTATE -C equal to +7(-7). In this case, the index of the equation -C being evaluated is stored in the sixth element of IWORK. -C Altering the value of N in G has no effect on the value of -C N in the call sequence of SDRIV3. -C -C USERS = A subroutine supplied by the user, if MITER is 3. -C If this is the case, the name must be declared EXTERNAL in -C the user's calling program. The routine USERS is called -C by SDRIV3 when certain linear systems must be solved. The -C user may choose any method to form, store and solve these -C systems in order to obtain the solution result that is -C returned to SDRIV3. In particular, this allows sparse -C matrix methods to be used. The call sequence for this -C routine is: -C -C SUBROUTINE USERS (Y, YH, YWT, SAVE1, SAVE2, T, H, EL, -C 8 IMPL, N, NDE, IFLAG) -C REAL Y(*), YH(*), YWT(*), SAVE1(*), -C 8 SAVE2(*), T, H, EL -C -C The input variable IFLAG indicates what action is to be -C taken. Subroutine USERS should perform the following -C operations, depending on the value of IFLAG and IMPL. -C -C IFLAG = 0 -C IMPL = 0. USERS is not called. -C IMPL = 1, 2 or 3. Solve the system A*X = SAVE2, -C returning the result in SAVE2. The array SAVE1 can -C be used as a work array. For IMPL = 1, there are N -C components to the system, and for IMPL = 2 or 3, -C there are NDE components to the system. -C -C IFLAG = 1 -C IMPL = 0. Compute, decompose and store the matrix -C (I - H*EL*J), where I is the identity matrix and J -C is the Jacobian matrix of the right hand side. The -C array SAVE1 can be used as a work array. -C IMPL = 1, 2 or 3. Compute, decompose and store the -C matrix (A - H*EL*J). The array SAVE1 can be used as -C a work array. -C -C IFLAG = 2 -C IMPL = 0. Solve the system -C (I - H*EL*J)*X = H*SAVE2 - YH - SAVE1, -C returning the result in SAVE2. -C IMPL = 1, 2 or 3. Solve the system -C (A - H*EL*J)*X = H*SAVE2 - A*(YH + SAVE1) -C returning the result in SAVE2. -C The array SAVE1 should not be altered. -C If IFLAG is 0 and IMPL is 1 or 2 and the matrix A is -C singular, or if IFLAG is 1 and one of the matrices -C (I - H*EL*J), (A - H*EL*J) is singular, the INTEGER -C variable IFLAG is to be set to -1 before RETURNing. -C Normally a return from USERS passes control back to -C SDRIV3. However, if the user would like to abort the -C calculation, i.e., return control to the program which -C calls SDRIV3, he should set N to zero. SDRIV3 will signal -C this by returning a value of NSTATE equal to +10(-10). -C Altering the value of N in USERS has no effect on the -C value of N in the call sequence of SDRIV3. -C -C IERFLG = An error flag. The error number associated with a -C diagnostic message (see Section III-A below) is the same -C as the corresponding value of IERFLG. The meaning of -C IERFLG: -C 0 The routine completed successfully. (No message is -C issued.) -C 3 (Warning) The number of steps required to reach TOUT -C exceeds MXSTEP. -C 4 (Warning) The value of EPS is too small. -C 11 (Warning) For NTASK = 2 or 3, T is beyond TOUT. -C The solution was obtained by interpolation. -C 15 (Warning) The integration step size is below the -C roundoff level of T. (The program issues this -C message as a warning but does not return control to -C the user.) -C 22 (Recoverable) N is not positive. -C 23 (Recoverable) MINT is less than 1 or greater than 3 . -C 24 (Recoverable) MITER is less than 0 or greater than -C 5 . -C 25 (Recoverable) IMPL is less than 0 or greater than 3 . -C 26 (Recoverable) The value of NSTATE is less than 1 or -C greater than 12 . -C 27 (Recoverable) EPS is less than zero. -C 28 (Recoverable) MXORD is not positive. -C 29 (Recoverable) For MINT = 3, either MITER = 0 or 3, or -C IMPL = 0 . -C 30 (Recoverable) For MITER = 0, IMPL is not 0 . -C 31 (Recoverable) For MINT = 1, IMPL is 2 or 3 . -C 32 (Recoverable) Insufficient storage has been allocated -C for the WORK array. -C 33 (Recoverable) Insufficient storage has been allocated -C for the IWORK array. -C 41 (Recoverable) The integration step size has gone -C to zero. -C 42 (Recoverable) The integration step size has been -C reduced about 50 times without advancing the -C solution. The problem setup may not be correct. -C 43 (Recoverable) For IMPL greater than 0, the matrix A -C is singular. -C 999 (Fatal) The value of NSTATE is 12 . -C -C III. OTHER COMMUNICATION TO THE USER .............................. -C -C A. The solver communicates to the user through the parameters -C above. In addition it writes diagnostic messages through the -C standard error handling program XERMSG. A complete description -C of XERMSG is given in "Guide to the SLATEC Common Mathematical -C Library" by Kirby W. Fong et al.. At installations which do not -C have this error handling package the short but serviceable -C routine, XERMSG, available with this package, can be used. That -C program uses the file named OUTPUT to transmit messages. -C -C B. The first three elements of WORK and the first five elements of -C IWORK will contain the following statistical data: -C AVGH The average step size used. -C HUSED The step size last used (successfully). -C AVGORD The average order used. -C IMXERR The index of the element of the solution vector that -C contributed most to the last error test. -C NQUSED The order last used (successfully). -C NSTEP The number of steps taken since last initialization. -C NFE The number of evaluations of the right hand side. -C NJE The number of evaluations of the Jacobian matrix. -C -C IV. REMARKS ....................................................... -C -C A. Other routines used: -C SDNTP, SDZRO, SDSTP, SDNTL, SDPST, SDCOR, SDCST, -C SDPSC, and SDSCL; -C SGEFA, SGESL, SGBFA, SGBSL, and SNRM2 (from LINPACK) -C R1MACH (from the Bell Laboratories Machine Constants Package) -C XERMSG (from the SLATEC Common Math Library) -C The last seven routines above, not having been written by the -C present authors, are not explicitly part of this package. -C -C B. On any return from SDRIV3 all information necessary to continue -C the calculation is contained in the call sequence parameters, -C including the work arrays. Thus it is possible to suspend one -C problem, integrate another, and then return to the first. -C -C C. If this package is to be used in an overlay situation, the user -C must declare in the primary overlay the variables in the call -C sequence to SDRIV3. -C -C D. Changing parameters during an integration. -C The value of NROOT, EPS, EWT, IERROR, MINT, MITER, or HMAX may -C be altered by the user between calls to SDRIV3. For example, if -C too much accuracy has been requested (the program returns with -C NSTATE = 4 and an increased value of EPS) the user may wish to -C increase EPS further. In general, prudence is necessary when -C making changes in parameters since such changes are not -C implemented until the next integration step, which is not -C necessarily the next call to SDRIV3. This can happen if the -C program has already integrated to a point which is beyond the -C new point TOUT. -C -C E. As the price for complete control of matrix algebra, the SDRIV3 -C USERS option puts all responsibility for Jacobian matrix -C evaluation on the user. It is often useful to approximate -C numerically all or part of the Jacobian matrix. However this -C must be done carefully. The FORTRAN sequence below illustrates -C the method we recommend. It can be inserted directly into -C subroutine USERS to approximate Jacobian elements in rows I1 -C to I2 and columns J1 to J2. -C REAL DFDY(N,N), EPSJ, H, R, R1MACH, -C 8 SAVE1(N), SAVE2(N), T, UROUND, Y(N), YJ, YWT(N) -C UROUND = R1MACH(4) -C EPSJ = SQRT(UROUND) -C DO 30 J = J1,J2 -C R = EPSJ*MAX(ABS(YWT(J)), ABS(Y(J))) -C IF (R .EQ. 0.E0) R = YWT(J) -C YJ = Y(J) -C Y(J) = Y(J) + R -C CALL F (N, T, Y, SAVE1) -C IF (N .EQ. 0) RETURN -C Y(J) = YJ -C DO 20 I = I1,I2 -C 20 DFDY(I,J) = (SAVE1(I) - SAVE2(I))/R -C 30 CONTINUE -C Many problems give rise to structured sparse Jacobians, e.g., -C block banded. It is possible to approximate them with fewer -C function evaluations than the above procedure uses; see Curtis, -C Powell and Reid, J. Inst. Maths Applics, (1974), Vol. 13, -C pp. 117-119. -C -C F. When any of the routines JACOBN, FA, G, or USERS, is not -C required, difficulties associated with unsatisfied externals can -C be avoided by using the name of the routine which calculates the -C right hand side of the differential equations in place of the -C corresponding name in the call sequence of SDRIV3. -C -C***REFERENCES C. W. Gear, Numerical Initial Value Problems in -C Ordinary Differential Equations, Prentice-Hall, 1971. -C***ROUTINES CALLED R1MACH, SDNTP, SDSTP, SDZRO, SGBFA, SGBSL, SGEFA, -C SGESL, SNRM2, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE SDRIV3 - EXTERNAL F, JACOBN, FA, G, USERS - REAL AE, BIG, EPS, EWT(*), G, GLAST, GNOW, H, HMAX, - 8 HSIGN, HUSED, NROUND, RE, R1MACH, SIZE, SNRM2, SUM, T, TLAST, - 8 TOUT, TROOT, UROUND, WORK(*), Y(*) - INTEGER I, IA, IAVGH, IAVGRD, ICNVRG, IDFDY, IEL, IERFLG, IERROR, - 8 IFAC, IFLAG, IGNOW, IH, IHMAX, IHOLD, IHSIGN, IHUSED, - 8 IJROOT, IJSTPL, IJTASK, IMNT, IMNTLD, IMPL, IMTR, IMTRLD, - 8 IMTRSV, IMXERR, IMXORD, IMXRDS, INDMXR, INDPRT, INDPVT, - 8 INDTRT, INFE, INFO, INJE, INQ, INQUSE, INROOT, INRTLD, - 8 INSTEP, INWAIT, IRC, IRMAX, IROOT, IMACH1, IMACH4, ISAVE1, - 8 ISAVE2, IT, ITOUT, ITQ, ITREND, ITROOT, IWORK(*), IYH, - 8 IYWT, J, JSTATE, JTROOT, LENCHK, LENIW, LENW, LIWCHK, - 8 MATDIM, MAXORD, MINT, MITER, ML, MU, MXORD, MXSTEP, N, - 8 NDE, NDECOM, NPAR, NROOT, NSTATE, NSTEPL, NTASK - LOGICAL CONVRG - CHARACTER INTGR1*8, INTGR2*8, RL1*16, RL2*16 - PARAMETER(NROUND = 20.E0) - PARAMETER(IAVGH = 1, IHUSED = 2, IAVGRD = 3, - 8 IEL = 4, IH = 160, IHMAX = 161, IHOLD = 162, - 8 IHSIGN = 163, IRC = 164, IRMAX = 165, IT = 166, - 8 ITOUT = 167, ITQ = 168, ITREND = 204, IMACH1 = 205, - 8 IMACH4 = 206, IYH = 251, - 8 INDMXR = 1, INQUSE = 2, INSTEP = 3, INFE = 4, INJE = 5, - 8 INROOT = 6, ICNVRG = 7, IJROOT = 8, IJTASK = 9, - 8 IMNTLD = 10, IMTRLD = 11, INQ = 12, INRTLD = 13, - 8 INDTRT = 14, INWAIT = 15, IMNT = 16, IMTRSV = 17, - 8 IMTR = 18, IMXRDS = 19, IMXORD = 20, INDPRT = 21, - 8 IJSTPL = 22, INDPVT = 51) -C***FIRST EXECUTABLE STATEMENT SDRIV3 - IF (NSTATE .EQ. 12) THEN - IERFLG = 999 - CALL XERMSG('SLATEC', 'SDRIV3', - 8 'Illegal input. The value of NSTATE is 12 .', IERFLG, 2) - RETURN - ELSE IF (NSTATE .LT. 1 .OR. NSTATE .GT. 12) THEN - WRITE(INTGR1, '(I8)') NSTATE - IERFLG = 26 - CALL XERMSG('SLATEC', 'SDRIV3', - 8 'Illegal input. Improper value for NSTATE(= '//INTGR1//').', - 8 IERFLG, 1) - NSTATE = 12 - RETURN - END IF - NPAR = N - IF (EPS .LT. 0.E0) THEN - WRITE(RL1, '(E16.8)') EPS - IERFLG = 27 - CALL XERMSG('SLATEC', 'SDRIV3', - 8 'Illegal input. EPS, '//RL1//', is negative.', IERFLG, 1) - NSTATE = 12 - RETURN - END IF - IF (N .LE. 0) THEN - WRITE(INTGR1, '(I8)') N - IERFLG = 22 - CALL XERMSG('SLATEC', 'SDRIV3', - 8 'Illegal input. Number of equations, '//INTGR1// - 8 ', is not positive.', IERFLG, 1) - NSTATE = 12 - RETURN - END IF - IF (MXORD .LE. 0) THEN - WRITE(INTGR1, '(I8)') MXORD - IERFLG = 28 - CALL XERMSG('SLATEC', 'SDRIV3', - 8 'Illegal input. Maximum order, '//INTGR1// - 8 ', is not positive.', IERFLG, 1) - NSTATE = 12 - RETURN - END IF - IF (MINT .LT. 1 .OR. MINT .GT. 3) THEN - WRITE(INTGR1, '(I8)') MINT - IERFLG = 23 - CALL XERMSG('SLATEC', 'SDRIV3', - 8 'Illegal input. Improper value for the integration method '// - 8 'flag, '//INTGR1//' .', IERFLG, 1) - NSTATE = 12 - RETURN - ELSE IF (MITER .LT. 0 .OR. MITER .GT. 5) THEN - WRITE(INTGR1, '(I8)') MITER - IERFLG = 24 - CALL XERMSG('SLATEC', 'SDRIV3', - 8 'Illegal input. Improper value for MITER(= '//INTGR1//').', - 8 IERFLG, 1) - NSTATE = 12 - RETURN - ELSE IF (IMPL .LT. 0 .OR. IMPL .GT. 3) THEN - WRITE(INTGR1, '(I8)') IMPL - IERFLG = 25 - CALL XERMSG('SLATEC', 'SDRIV3', - 8 'Illegal input. Improper value for IMPL(= '//INTGR1//').', - 8 IERFLG, 1) - NSTATE = 12 - RETURN - ELSE IF (MINT .EQ. 3 .AND. - 8 (MITER .EQ. 0 .OR. MITER .EQ. 3 .OR. IMPL .NE. 0)) THEN - WRITE(INTGR1, '(I8)') MITER - WRITE(INTGR2, '(I8)') IMPL - IERFLG = 29 - CALL XERMSG('SLATEC', 'SDRIV3', - 8 'Illegal input. For MINT = 3, the value of MITER, '//INTGR1// - 8 ', and/or IMPL, '//INTGR2//', is not allowed.', IERFLG, 1) - NSTATE = 12 - RETURN - ELSE IF ((IMPL .GE. 1 .AND. IMPL .LE. 3) .AND. MITER .EQ. 0) THEN - WRITE(INTGR1, '(I8)') IMPL - IERFLG = 30 - CALL XERMSG('SLATEC', 'SDRIV3', - 8 'Illegal input. For MITER = 0, the value of IMPL, '//INTGR1// - 8 ', is not allowed.', IERFLG, 1) - NSTATE = 12 - RETURN - ELSE IF ((IMPL .EQ. 2 .OR. IMPL .EQ. 3) .AND. MINT .EQ. 1) THEN - WRITE(INTGR1, '(I8)') IMPL - IERFLG = 31 - CALL XERMSG('SLATEC', 'SDRIV3', - 8 'Illegal input. For MINT = 1, the value of IMPL, '//INTGR1// - 8 ', is not allowed.', IERFLG, 1) - NSTATE = 12 - RETURN - END IF - IF (MITER .EQ. 0 .OR. MITER .EQ. 3) THEN - LIWCHK = INDPVT - 1 - ELSE IF (MITER .EQ. 1 .OR. MITER .EQ. 2 .OR. MITER .EQ. 4 .OR. - 8 MITER .EQ. 5) THEN - LIWCHK = INDPVT + N - 1 - END IF - IF (LENIW .LT. LIWCHK) THEN - WRITE(INTGR1, '(I8)') LIWCHK - IERFLG = 33 - CALL XERMSG('SLATEC', 'SDRIV3', - 8 'Illegal input. Insufficient storage allocated for the '// - 8 'IWORK array. Based on the value of the input parameters '// - 8 'involved, the required storage is '//INTGR1//' .', IERFLG, 1) - NSTATE = 12 - RETURN - END IF -C Allocate the WORK array -C IYH is the index of YH in WORK - IF (MINT .EQ. 1 .OR. MINT .EQ. 3) THEN - MAXORD = MIN(MXORD, 12) - ELSE IF (MINT .EQ. 2) THEN - MAXORD = MIN(MXORD, 5) - END IF - IDFDY = IYH + (MAXORD + 1)*N -C IDFDY is the index of DFDY -C - IF (MITER .EQ. 0 .OR. MITER .EQ. 3) THEN - IYWT = IDFDY - ELSE IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN - IYWT = IDFDY + N*N - ELSE IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN - IYWT = IDFDY + (2*ML + MU + 1)*N - END IF -C IYWT is the index of YWT - ISAVE1 = IYWT + N -C ISAVE1 is the index of SAVE1 - ISAVE2 = ISAVE1 + N -C ISAVE2 is the index of SAVE2 - IGNOW = ISAVE2 + N -C IGNOW is the index of GNOW - ITROOT = IGNOW + NROOT -C ITROOT is the index of TROOT - IFAC = ITROOT + NROOT -C IFAC is the index of FAC - IF (MITER .EQ. 2 .OR. MITER .EQ. 5 .OR. MINT .EQ. 3) THEN - IA = IFAC + N - ELSE - IA = IFAC - END IF -C IA is the index of A - IF (IMPL .EQ. 0 .OR. MITER .EQ. 3) THEN - LENCHK = IA - 1 - ELSE IF (IMPL .EQ. 1 .AND. (MITER .EQ. 1 .OR. MITER .EQ. 2)) THEN - LENCHK = IA - 1 + N*N - ELSE IF (IMPL .EQ. 1 .AND. (MITER .EQ. 4 .OR. MITER .EQ. 5)) THEN - LENCHK = IA - 1 + (2*ML + MU + 1)*N - ELSE IF (IMPL .EQ. 2 .AND. MITER .NE. 3) THEN - LENCHK = IA - 1 + N - ELSE IF (IMPL .EQ. 3 .AND. (MITER .EQ. 1 .OR. MITER .EQ. 2)) THEN - LENCHK = IA - 1 + N*NDE - ELSE IF (IMPL .EQ. 3 .AND. (MITER .EQ. 4 .OR. MITER .EQ. 5)) THEN - LENCHK = IA - 1 + (2*ML + MU + 1)*NDE - END IF - IF (LENW .LT. LENCHK) THEN - WRITE(INTGR1, '(I8)') LENCHK - IERFLG = 32 - CALL XERMSG('SLATEC', 'SDRIV3', - 8 'Illegal input. Insufficient storage allocated for the '// - 8 'WORK array. Based on the value of the input parameters '// - 8 'involved, the required storage is '//INTGR1//' .', IERFLG, 1) - NSTATE = 12 - RETURN - END IF - IF (MITER .EQ. 0 .OR. MITER .EQ. 3) THEN - MATDIM = 1 - ELSE IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN - MATDIM = N - ELSE IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN - MATDIM = 2*ML + MU + 1 - END IF - IF (IMPL .EQ. 0 .OR. IMPL .EQ. 1) THEN - NDECOM = N - ELSE IF (IMPL .EQ. 2 .OR. IMPL .EQ. 3) THEN - NDECOM = NDE - END IF - IF (NSTATE .EQ. 1) THEN -C Initialize parameters - IF (MINT .EQ. 1 .OR. MINT .EQ. 3) THEN - IWORK(IMXORD) = MIN(MXORD, 12) - ELSE IF (MINT .EQ. 2) THEN - IWORK(IMXORD) = MIN(MXORD, 5) - END IF - IWORK(IMXRDS) = MXORD - IF (MINT .EQ. 1 .OR. MINT .EQ. 2) THEN - IWORK(IMNT) = MINT - IWORK(IMTR) = MITER - IWORK(IMNTLD) = MINT - IWORK(IMTRLD) = MITER - ELSE IF (MINT .EQ. 3) THEN - IWORK(IMNT) = 1 - IWORK(IMTR) = 0 - IWORK(IMNTLD) = IWORK(IMNT) - IWORK(IMTRLD) = IWORK(IMTR) - IWORK(IMTRSV) = MITER - END IF - WORK(IHMAX) = HMAX - UROUND = R1MACH (4) - WORK(IMACH4) = UROUND - WORK(IMACH1) = R1MACH (1) - IF (NROOT .NE. 0) THEN - RE = UROUND - AE = WORK(IMACH1) - END IF - H = (TOUT - T)*(1.E0 - 4.E0*UROUND) - H = SIGN(MIN(ABS(H), HMAX), H) - WORK(IH) = H - HSIGN = SIGN(1.E0, H) - WORK(IHSIGN) = HSIGN - IWORK(IJTASK) = 0 - WORK(IAVGH) = 0.E0 - WORK(IHUSED) = 0.E0 - WORK(IAVGRD) = 0.E0 - IWORK(INDMXR) = 0 - IWORK(INQUSE) = 0 - IWORK(INSTEP) = 0 - IWORK(IJSTPL) = 0 - IWORK(INFE) = 0 - IWORK(INJE) = 0 - IWORK(INROOT) = 0 - WORK(IT) = T - IWORK(ICNVRG) = 0 - IWORK(INDPRT) = 0 -C Set initial conditions - DO 30 I = 1,N - 30 WORK(I+IYH-1) = Y(I) - IF (T .EQ. TOUT) RETURN - GO TO 180 - ELSE - UROUND = WORK(IMACH4) - IF (NROOT .NE. 0) THEN - RE = UROUND - AE = WORK(IMACH1) - END IF - END IF -C On a continuation, check -C that output points have -C been or will be overtaken. - IF (IWORK(ICNVRG) .EQ. 1) THEN - CONVRG = .TRUE. - ELSE - CONVRG = .FALSE. - END IF - T = WORK(IT) - H = WORK(IH) - HSIGN = WORK(IHSIGN) - IF (IWORK(IJTASK) .EQ. 0) GO TO 180 -C -C IWORK(IJROOT) flags unreported -C roots, and is set to the value of -C NTASK when a root was last selected. -C It is set to zero when all roots -C have been reported. IWORK(INROOT) -C contains the index and WORK(ITOUT) -C contains the value of the root last -C selected to be reported. -C IWORK(INRTLD) contains the value of -C NROOT and IWORK(INDTRT) contains -C the value of ITROOT when the array -C of roots was last calculated. - IF (NROOT .NE. 0) THEN - IF (IWORK(IJROOT) .GT. 0) THEN -C TOUT has just been reported. -C If TROOT .LE. TOUT, report TROOT. - IF (NSTATE .NE. 5) THEN - IF (TOUT*HSIGN .GE. WORK(ITOUT)*HSIGN) THEN - TROOT = WORK(ITOUT) - CALL SDNTP (H, 0, N, IWORK(INQ), T, TROOT, WORK(IYH), Y) - T = TROOT - NSTATE = 5 - IERFLG = 0 - GO TO 580 - END IF -C A root has just been reported. -C Select the next root. - ELSE - TROOT = T - IROOT = 0 - DO 50 I = 1,IWORK(INRTLD) - JTROOT = I + IWORK(INDTRT) - 1 - IF (WORK(JTROOT)*HSIGN .LE. TROOT*HSIGN) THEN -C -C Check for multiple roots. -C - IF (WORK(JTROOT) .EQ. WORK(ITOUT) .AND. - 8 I .GT. IWORK(INROOT)) THEN - IROOT = I - TROOT = WORK(JTROOT) - GO TO 60 - END IF - IF (WORK(JTROOT)*HSIGN .GT. WORK(ITOUT)*HSIGN) THEN - IROOT = I - TROOT = WORK(JTROOT) - END IF - END IF - 50 CONTINUE - 60 IWORK(INROOT) = IROOT - WORK(ITOUT) = TROOT - IWORK(IJROOT) = NTASK - IF (NTASK .EQ. 1) THEN - IF (IROOT .EQ. 0) THEN - IWORK(IJROOT) = 0 - ELSE - IF (TOUT*HSIGN .GE. TROOT*HSIGN) THEN - CALL SDNTP (H, 0, N, IWORK(INQ), T, TROOT, WORK(IYH), - 8 Y) - NSTATE = 5 - T = TROOT - IERFLG = 0 - GO TO 580 - END IF - END IF - ELSE IF (NTASK .EQ. 2 .OR. NTASK .EQ. 3) THEN -C -C If there are no more roots, or the -C user has altered TOUT to be less -C than a root, set IJROOT to zero. -C - IF (IROOT .EQ. 0 .OR. (TOUT*HSIGN .LT. TROOT*HSIGN)) THEN - IWORK(IJROOT) = 0 - ELSE - CALL SDNTP (H, 0, N, IWORK(INQ), T, TROOT, WORK(IYH), - 8 Y) - NSTATE = 5 - IERFLG = 0 - T = TROOT - GO TO 580 - END IF - END IF - END IF - END IF - END IF -C - IF (NTASK .EQ. 1) THEN - NSTATE = 2 - IF (T*HSIGN .GE. TOUT*HSIGN) THEN - CALL SDNTP (H, 0, N, IWORK(INQ), T, TOUT, WORK(IYH), Y) - T = TOUT - IERFLG = 0 - GO TO 580 - END IF - ELSE IF (NTASK .EQ. 2) THEN -C Check if TOUT has -C been reset .LT. T - IF (T*HSIGN .GT. TOUT*HSIGN) THEN - WRITE(RL1, '(E16.8)') T - WRITE(RL2, '(E16.8)') TOUT - IERFLG = 11 - CALL XERMSG('SLATEC', 'SDRIV3', - 8 'While integrating exactly to TOUT, T, '//RL1// - 8 ', was beyond TOUT, '//RL2//' . Solution obtained by '// - 8 'interpolation.', IERFLG, 0) - NSTATE = 11 - CALL SDNTP (H, 0, N, IWORK(INQ), T, TOUT, WORK(IYH), Y) - T = TOUT - GO TO 580 - END IF -C Determine if TOUT has been overtaken -C - IF (ABS(TOUT - T).LE.NROUND*UROUND*MAX(ABS(T), ABS(TOUT))) THEN - T = TOUT - NSTATE = 2 - IERFLG = 0 - GO TO 560 - END IF -C If there are no more roots -C to report, report T. - IF (NSTATE .EQ. 5) THEN - NSTATE = 2 - IERFLG = 0 - GO TO 560 - END IF - NSTATE = 2 -C See if TOUT will -C be overtaken. - IF ((T + H)*HSIGN .GT. TOUT*HSIGN) THEN - H = TOUT - T - IF ((T + H)*HSIGN .GT. TOUT*HSIGN) H = H*(1.E0 - 4.E0*UROUND) - WORK(IH) = H - IF (H .EQ. 0.E0) GO TO 670 - IWORK(IJTASK) = -1 - END IF - ELSE IF (NTASK .EQ. 3) THEN - NSTATE = 2 - IF (T*HSIGN .GT. TOUT*HSIGN) THEN - WRITE(RL1, '(E16.8)') T - WRITE(RL2, '(E16.8)') TOUT - IERFLG = 11 - CALL XERMSG('SLATEC', 'SDRIV3', - 8 'While integrating exactly to TOUT, T, '//RL1// - 8 ', was beyond TOUT, '//RL2//' . Solution obtained by '// - 8 'interpolation.', IERFLG, 0) - NSTATE = 11 - CALL SDNTP (H, 0, N, IWORK(INQ), T, TOUT, WORK(IYH), Y) - T = TOUT - GO TO 580 - END IF - IF (ABS(TOUT - T).LE.NROUND*UROUND*MAX(ABS(T), ABS(TOUT))) THEN - T = TOUT - IERFLG = 0 - GO TO 560 - END IF - IF ((T + H)*HSIGN .GT. TOUT*HSIGN) THEN - H = TOUT - T - IF ((T + H)*HSIGN .GT. TOUT*HSIGN) H = H*(1.E0 - 4.E0*UROUND) - WORK(IH) = H - IF (H .EQ. 0.E0) GO TO 670 - IWORK(IJTASK) = -1 - END IF - END IF -C Implement changes in MINT, MITER, and/or HMAX. -C - IF ((MINT .NE. IWORK(IMNTLD) .OR. MITER .NE. IWORK(IMTRLD)) .AND. - 8 MINT .NE. 3 .AND. IWORK(IMNTLD) .NE. 3) IWORK(IJTASK) = -1 - IF (HMAX .NE. WORK(IHMAX)) THEN - H = SIGN(MIN(ABS(H), HMAX), H) - IF (H .NE. WORK(IH)) THEN - IWORK(IJTASK) = -1 - WORK(IH) = H - END IF - WORK(IHMAX) = HMAX - END IF -C - 180 NSTEPL = IWORK(INSTEP) - DO 190 I = 1,N - 190 Y(I) = WORK(I+IYH-1) - IF (NROOT .NE. 0) THEN - DO 200 I = 1,NROOT - WORK(I+IGNOW-1) = G (NPAR, T, Y, I) - IF (NPAR .EQ. 0) THEN - IWORK(INROOT) = I - NSTATE = 7 - RETURN - END IF - 200 CONTINUE - END IF - IF (IERROR .EQ. 1) THEN - DO 230 I = 1,N - 230 WORK(I+IYWT-1) = 1.E0 - GO TO 410 - ELSE IF (IERROR .EQ. 5) THEN - DO 250 I = 1,N - 250 WORK(I+IYWT-1) = EWT(I) - GO TO 410 - END IF -C Reset YWT array. Looping point. - 260 IF (IERROR .EQ. 2) THEN - DO 280 I = 1,N - IF (Y(I) .EQ. 0.E0) GO TO 290 - 280 WORK(I+IYWT-1) = ABS(Y(I)) - GO TO 410 - 290 IF (IWORK(IJTASK) .EQ. 0) THEN - CALL F (NPAR, T, Y, WORK(ISAVE2)) - IF (NPAR .EQ. 0) THEN - NSTATE = 6 - RETURN - END IF - IWORK(INFE) = IWORK(INFE) + 1 - IF (MITER .EQ. 3 .AND. IMPL .NE. 0) THEN - IFLAG = 0 - CALL USERS (Y, WORK(IYH), WORK(IYWT), WORK(ISAVE1), - 8 WORK(ISAVE2), T, H, WORK(IEL), IMPL, NPAR, - 8 NDECOM, IFLAG) - IF (IFLAG .EQ. -1) GO TO 690 - IF (NPAR .EQ. 0) THEN - NSTATE = 10 - RETURN - END IF - ELSE IF (IMPL .EQ. 1) THEN - IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN - CALL FA (NPAR, T, Y, WORK(IA), MATDIM, ML, MU, NDECOM) - IF (NPAR .EQ. 0) THEN - NSTATE = 9 - RETURN - END IF - CALL SGEFA (WORK(IA), MATDIM, N, IWORK(INDPVT), INFO) - IF (INFO .NE. 0) GO TO 690 - CALL SGESL (WORK(IA), MATDIM, N, IWORK(INDPVT), - 8 WORK(ISAVE2), 0) - ELSE IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN - CALL FA (NPAR, T, Y, WORK(IA+ML), MATDIM, ML, MU, NDECOM) - IF (NPAR .EQ. 0) THEN - NSTATE = 9 - RETURN - END IF - CALL SGBFA (WORK(IA), MATDIM, N, ML, MU, IWORK(INDPVT), - 8 INFO) - IF (INFO .NE. 0) GO TO 690 - CALL SGBSL (WORK(IA), MATDIM, N, ML, MU, IWORK(INDPVT), - 8 WORK(ISAVE2), 0) - END IF - ELSE IF (IMPL .EQ. 2) THEN - CALL FA (NPAR, T, Y, WORK(IA), MATDIM, ML, MU, NDECOM) - IF (NPAR .EQ. 0) THEN - NSTATE = 9 - RETURN - END IF - DO 340 I = 1,NDECOM - IF (WORK(I+IA-1) .EQ. 0.E0) GO TO 690 - 340 WORK(I+ISAVE2-1) = WORK(I+ISAVE2-1)/WORK(I+IA-1) - ELSE IF (IMPL .EQ. 3) THEN - IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN - CALL FA (NPAR, T, Y, WORK(IA), MATDIM, ML, MU, NDECOM) - IF (NPAR .EQ. 0) THEN - NSTATE = 9 - RETURN - END IF - CALL SGEFA (WORK(IA), MATDIM, NDE, IWORK(INDPVT), INFO) - IF (INFO .NE. 0) GO TO 690 - CALL SGESL (WORK(IA), MATDIM, NDE, IWORK(INDPVT), - 8 WORK(ISAVE2), 0) - ELSE IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN - CALL FA (NPAR, T, Y, WORK(IA+ML), MATDIM, ML, MU, NDECOM) - IF (NPAR .EQ. 0) THEN - NSTATE = 9 - RETURN - END IF - CALL SGBFA (WORK(IA), MATDIM, NDE, ML, MU, IWORK(INDPVT), - 8 INFO) - IF (INFO .NE. 0) GO TO 690 - CALL SGBSL (WORK(IA), MATDIM, NDE, ML, MU, IWORK(INDPVT), - 8 WORK(ISAVE2), 0) - END IF - END IF - END IF - DO 360 J = I,N - IF (Y(J) .NE. 0.E0) THEN - WORK(J+IYWT-1) = ABS(Y(J)) - ELSE - IF (IWORK(IJTASK) .EQ. 0) THEN - WORK(J+IYWT-1) = ABS(H*WORK(J+ISAVE2-1)) - ELSE - WORK(J+IYWT-1) = ABS(WORK(J+IYH+N-1)) - END IF - END IF - IF (WORK(J+IYWT-1) .EQ. 0.E0) WORK(J+IYWT-1) = UROUND - 360 CONTINUE - ELSE IF (IERROR .EQ. 3) THEN - DO 380 I = 1,N - 380 WORK(I+IYWT-1) = MAX(EWT(1), ABS(Y(I))) - ELSE IF (IERROR .EQ. 4) THEN - DO 400 I = 1,N - 400 WORK(I+IYWT-1) = MAX(EWT(I), ABS(Y(I))) - END IF -C - 410 DO 420 I = 1,N - 420 WORK(I+ISAVE2-1) = Y(I)/WORK(I+IYWT-1) - SUM = SNRM2(N, WORK(ISAVE2), 1)/SQRT(REAL(N)) - SUM = MAX(1.E0, SUM) - IF (EPS .LT. SUM*UROUND) THEN - EPS = SUM*UROUND*(1.E0 + 10.E0*UROUND) - WRITE(RL1, '(E16.8)') T - WRITE(RL2, '(E16.8)') EPS - IERFLG = 4 - CALL XERMSG('SLATEC', 'SDRIV3', - 8 'At T, '//RL1//', the requested accuracy, EPS, was not '// - 8 'obtainable with the machine precision. EPS has been '// - 8 'increased to '//RL2//' .', IERFLG, 0) - NSTATE = 4 - GO TO 560 - END IF - IF (ABS(H) .GE. UROUND*ABS(T)) THEN - IWORK(INDPRT) = 0 - ELSE IF (IWORK(INDPRT) .EQ. 0) THEN - WRITE(RL1, '(E16.8)') T - WRITE(RL2, '(E16.8)') H - IERFLG = 15 - CALL XERMSG('SLATEC', 'SDRIV3', - 8 'At T, '//RL1//', the step size, '//RL2//', is smaller '// - 8 'than the roundoff level of T. This may occur if there is '// - 8 'an abrupt change in the right hand side of the '// - 8 'differential equations.', IERFLG, 0) - IWORK(INDPRT) = 1 - END IF - IF (NTASK.NE.2) THEN - IF ((IWORK(INSTEP)-NSTEPL) .EQ. MXSTEP) THEN - WRITE(RL1, '(E16.8)') T - WRITE(INTGR1, '(I8)') MXSTEP - WRITE(RL2, '(E16.8)') TOUT - IERFLG = 3 - CALL XERMSG('SLATEC', 'SDRIV3', - 8 'At T, '//RL1//', '//INTGR1//' steps have been taken '// - 8 'without reaching TOUT, '//RL2//' .', IERFLG, 0) - NSTATE = 3 - GO TO 560 - END IF - END IF -C -C CALL SDSTP (EPS, F, FA, HMAX, IMPL, IERROR, JACOBN, MATDIM, -C 8 MAXORD, MINT, MITER, ML, MU, N, NDE, YWT, UROUND, -C 8 USERS, AVGH, AVGORD, H, HUSED, JTASK, MNTOLD, MTROLD, -C 8 NFE, NJE, NQUSED, NSTEP, T, Y, YH, A, CONVRG, -C 8 DFDY, EL, FAC, HOLD, IPVT, JSTATE, JSTEPL, NQ, NWAIT, -C 8 RC, RMAX, SAVE1, SAVE2, TQ, TREND, ISWFLG, MTRSV, -C 8 MXRDSV) -C - CALL SDSTP (EPS, F, FA, WORK(IHMAX), IMPL, IERROR, JACOBN, - 8 MATDIM, IWORK(IMXORD), IWORK(IMNT), IWORK(IMTR), ML, - 8 MU, NPAR, NDECOM, WORK(IYWT), UROUND, USERS, - 8 WORK(IAVGH), WORK(IAVGRD), WORK(IH), HUSED, - 8 IWORK(IJTASK), IWORK(IMNTLD), IWORK(IMTRLD), - 8 IWORK(INFE), IWORK(INJE), IWORK(INQUSE), - 8 IWORK(INSTEP), WORK(IT), Y, WORK(IYH), WORK(IA), - 8 CONVRG, WORK(IDFDY), WORK(IEL), WORK(IFAC), - 8 WORK(IHOLD), IWORK(INDPVT), JSTATE, IWORK(IJSTPL), - 8 IWORK(INQ), IWORK(INWAIT), WORK(IRC), WORK(IRMAX), - 8 WORK(ISAVE1), WORK(ISAVE2), WORK(ITQ), WORK(ITREND), - 8 MINT, IWORK(IMTRSV), IWORK(IMXRDS)) - T = WORK(IT) - H = WORK(IH) - IF (CONVRG) THEN - IWORK(ICNVRG) = 1 - ELSE - IWORK(ICNVRG) = 0 - END IF - GO TO (470, 670, 680, 690, 690, 660, 660, 660, 660, 660), JSTATE - 470 IWORK(IJTASK) = 1 -C Determine if a root has been overtaken - IF (NROOT .NE. 0) THEN - IROOT = 0 - DO 500 I = 1,NROOT - GLAST = WORK(I+IGNOW-1) - GNOW = G (NPAR, T, Y, I) - IF (NPAR .EQ. 0) THEN - IWORK(INROOT) = I - NSTATE = 7 - RETURN - END IF - WORK(I+IGNOW-1) = GNOW - IF (GLAST*GNOW .GT. 0.E0) THEN - WORK(I+ITROOT-1) = T + H - ELSE - IF (GNOW .EQ. 0.E0) THEN - WORK(I+ITROOT-1) = T - IROOT = I - ELSE - IF (GLAST .EQ. 0.E0) THEN - WORK(I+ITROOT-1) = T + H - ELSE - IF (ABS(HUSED) .GE. UROUND*ABS(T)) THEN - TLAST = T - HUSED - IROOT = I - TROOT = T - CALL SDZRO (AE, G, H, NPAR, IWORK(INQ), IROOT, RE, T, - 8 WORK(IYH), UROUND, TROOT, TLAST, - 8 GNOW, GLAST, Y) - DO 480 J = 1,N - 480 Y(J) = WORK(IYH+J-1) - IF (NPAR .EQ. 0) THEN - IWORK(INROOT) = I - NSTATE = 7 - RETURN - END IF - WORK(I+ITROOT-1) = TROOT - ELSE - WORK(I+ITROOT-1) = T - IROOT = I - END IF - END IF - END IF - END IF - 500 CONTINUE - IF (IROOT .EQ. 0) THEN - IWORK(IJROOT) = 0 -C Select the first root - ELSE - IWORK(IJROOT) = NTASK - IWORK(INRTLD) = NROOT - IWORK(INDTRT) = ITROOT - TROOT = T + H - DO 510 I = 1,NROOT - IF (WORK(I+ITROOT-1)*HSIGN .LT. TROOT*HSIGN) THEN - TROOT = WORK(I+ITROOT-1) - IROOT = I - END IF - 510 CONTINUE - IWORK(INROOT) = IROOT - WORK(ITOUT) = TROOT - IF (TROOT*HSIGN .LE. TOUT*HSIGN) THEN - CALL SDNTP (H, 0, N, IWORK(INQ), T, TROOT, WORK(IYH), Y) - NSTATE = 5 - T = TROOT - IERFLG = 0 - GO TO 580 - END IF - END IF - END IF -C Test for NTASK condition to be satisfied - NSTATE = 2 - IF (NTASK .EQ. 1) THEN - IF (T*HSIGN .LT. TOUT*HSIGN) GO TO 260 - CALL SDNTP (H, 0, N, IWORK(INQ), T, TOUT, WORK(IYH), Y) - T = TOUT - IERFLG = 0 - GO TO 580 -C TOUT is assumed to have been attained -C exactly if T is within twenty roundoff -C units of TOUT, relative to MAX(TOUT, T). -C - ELSE IF (NTASK .EQ. 2) THEN - IF (ABS(TOUT - T).LE.NROUND*UROUND*MAX(ABS(T), ABS(TOUT))) THEN - T = TOUT - ELSE - IF ((T + H)*HSIGN .GT. TOUT*HSIGN) THEN - H = TOUT - T - IF ((T + H)*HSIGN.GT.TOUT*HSIGN) H = H*(1.E0 - 4.E0*UROUND) - WORK(IH) = H - IF (H .EQ. 0.E0) GO TO 670 - IWORK(IJTASK) = -1 - END IF - END IF - ELSE IF (NTASK .EQ. 3) THEN - IF (ABS(TOUT - T).LE.NROUND*UROUND*MAX(ABS(T), ABS(TOUT))) THEN - T = TOUT - ELSE - IF ((T + H)*HSIGN .GT. TOUT*HSIGN) THEN - H = TOUT - T - IF ((T + H)*HSIGN.GT.TOUT*HSIGN) H = H*(1.E0 - 4.E0*UROUND) - WORK(IH) = H - IF (H .EQ. 0.E0) GO TO 670 - IWORK(IJTASK) = -1 - END IF - GO TO 260 - END IF - END IF - IERFLG = 0 -C All returns are made through this -C section. IMXERR is determined. - 560 DO 570 I = 1,N - 570 Y(I) = WORK(I+IYH-1) - 580 IF (IWORK(IJTASK) .EQ. 0) RETURN - BIG = 0.E0 - IMXERR = 1 - DO 590 I = 1,N -C SIZE = ABS(ERROR(I)/YWT(I)) - SIZE = ABS(WORK(I+ISAVE1-1)/WORK(I+IYWT-1)) - IF (BIG .LT. SIZE) THEN - BIG = SIZE - IMXERR = I - END IF - 590 CONTINUE - IWORK(INDMXR) = IMXERR - WORK(IHUSED) = HUSED - RETURN -C - 660 NSTATE = JSTATE - RETURN -C Fatal errors are processed here -C - 670 WRITE(RL1, '(E16.8)') T - IERFLG = 41 - CALL XERMSG('SLATEC', 'SDRIV3', - 8 'At T, '//RL1//', the attempted step size has gone to '// - 8 'zero. Often this occurs if the problem setup is incorrect.', - 8 IERFLG, 1) - NSTATE = 12 - RETURN -C - 680 WRITE(RL1, '(E16.8)') T - IERFLG = 42 - CALL XERMSG('SLATEC', 'SDRIV3', - 8 'At T, '//RL1//', the step size has been reduced about 50 '// - 8 'times without advancing the solution. Often this occurs '// - 8 'if the problem setup is incorrect.', IERFLG, 1) - NSTATE = 12 - RETURN -C - 690 WRITE(RL1, '(E16.8)') T - IERFLG = 43 - CALL XERMSG('SLATEC', 'SDRIV3', - 8 'At T, '//RL1//', while solving A*YDOT = F, A is singular.', - 8 IERFLG, 1) - NSTATE = 12 - RETURN - END diff --git a/slatec/sdscl.f b/slatec/sdscl.f deleted file mode 100644 index de6b9bd..0000000 --- a/slatec/sdscl.f +++ /dev/null @@ -1,37 +0,0 @@ -*DECK SDSCL - SUBROUTINE SDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) -C***BEGIN PROLOGUE SDSCL -C***SUBSIDIARY -C***PURPOSE Subroutine SDSCL rescales the YH array whenever the step -C size is changed. -C***LIBRARY SLATEC (SDRIVE) -C***TYPE SINGLE PRECISION (SDSCL-S, DDSCL-D, CDSCL-C) -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE SDSCL - INTEGER I, J, N, NQ - REAL H, HMAX, RC, RH, RMAX, R1, YH(N,*) -C***FIRST EXECUTABLE STATEMENT SDSCL - IF (H .LT. 1.E0) THEN - RH = MIN(ABS(H)*RH, ABS(H)*RMAX, HMAX)/ABS(H) - ELSE - RH = MIN(RH, RMAX, HMAX/ABS(H)) - END IF - R1 = 1.E0 - DO 10 J = 1,NQ - R1 = R1*RH - DO 10 I = 1,N - 10 YH(I,J+1) = YH(I,J+1)*R1 - H = H*RH - RC = RC*RH - RETURN - END diff --git a/slatec/sdsdot.f b/slatec/sdsdot.f deleted file mode 100644 index 488027a..0000000 --- a/slatec/sdsdot.f +++ /dev/null @@ -1,78 +0,0 @@ -*DECK SDSDOT - REAL FUNCTION SDSDOT (N, SB, SX, INCX, SY, INCY) -C***BEGIN PROLOGUE SDSDOT -C***PURPOSE Compute the inner product of two vectors with extended -C precision accumulation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A4 -C***TYPE SINGLE PRECISION (SDSDOT-S, CDCDOT-C) -C***KEYWORDS BLAS, DOT PRODUCT, INNER PRODUCT, 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 SB single precision scalar to be added to inner product -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 SDSDOT single precision dot product (SB if N .LE. 0) -C -C Returns S.P. result with dot product accumulated in D.P. -C SDSDOT = SB + 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 890531 Changed all specific intrinsics to generic. (WRB) -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 SDSDOT - REAL SX(*), SY(*), SB - DOUBLE PRECISION DSDOT -C***FIRST EXECUTABLE STATEMENT SDSDOT - DSDOT = SB - IF (N .LE. 0) GO TO 30 - IF (INCX.EQ.INCY .AND. INCX.GT.0) GO TO 40 -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 - 30 SDSDOT = DSDOT - RETURN -C -C Code for equal and positive increments. -C - 40 NS = N*INCX - DO 50 I = 1,NS,INCX - DSDOT = DSDOT + DBLE(SX(I))*DBLE(SY(I)) - 50 CONTINUE - SDSDOT = DSDOT - RETURN - END diff --git a/slatec/sdstp.f b/slatec/sdstp.f deleted file mode 100644 index 2d2e3a9..0000000 --- a/slatec/sdstp.f +++ /dev/null @@ -1,458 +0,0 @@ -*DECK SDSTP - SUBROUTINE SDSTP (EPS, F, FA, HMAX, IMPL, IERROR, JACOBN, MATDIM, - 8 MAXORD, MINT, MITER, ML, MU, N, NDE, YWT, UROUND, USERS, AVGH, - 8 AVGORD, H, HUSED, JTASK, MNTOLD, MTROLD, NFE, NJE, NQUSED, - 8 NSTEP, T, Y, YH, A, CONVRG, DFDY, EL, FAC, HOLD, IPVT, JSTATE, - 8 JSTEPL, NQ, NWAIT, RC, RMAX, SAVE1, SAVE2, TQ, TREND, ISWFLG, - 8 MTRSV, MXRDSV) -C***BEGIN PROLOGUE SDSTP -C***SUBSIDIARY -C***PURPOSE SDSTP performs one step of the integration of an initial -C value problem for a system of ordinary differential -C equations. -C***LIBRARY SLATEC (SDRIVE) -C***TYPE SINGLE PRECISION (SDSTP-S, DDSTP-D, CDSTP-C) -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***DESCRIPTION -C -C Communication with SDSTP is done with the following variables: -C -C YH An N by MAXORD+1 array containing the dependent variables -C and their scaled derivatives. MAXORD, the maximum order -C used, is currently 12 for the Adams methods and 5 for the -C Gear methods. YH(I,J+1) contains the J-th derivative of -C Y(I), scaled by H**J/factorial(J). Only Y(I), -C 1 .LE. I .LE. N, need be set by the calling program on -C the first entry. The YH array should not be altered by -C the calling program. When referencing YH as a -C 2-dimensional array, use a column length of N, as this is -C the value used in SDSTP. -C DFDY A block of locations used for partial derivatives if MITER -C is not 0. If MITER is 1 or 2 its length must be at least -C N*N. If MITER is 4 or 5 its length must be at least -C (2*ML+MU+1)*N. -C YWT An array of N locations used in convergence and error tests -C SAVE1 -C SAVE2 Arrays of length N used for temporary storage. -C IPVT An integer array of length N used by the linear system -C solvers for the storage of row interchange information. -C A A block of locations used to store the matrix A, when using -C the implicit method. If IMPL is 1, A is a MATDIM by N -C array. If MITER is 1 or 2 MATDIM is N, and if MITER is 4 -C or 5 MATDIM is 2*ML+MU+1. If IMPL is 2 its length is N. -C If IMPL is 3, A is a MATDIM by NDE array. -C JTASK An integer used on input. -C It has the following values and meanings: -C .EQ. 0 Perform the first step. This value enables -C the subroutine to initialize itself. -C .GT. 0 Take a new step continuing from the last. -C Assumes the last step was successful and -C user has not changed any parameters. -C .LT. 0 Take a new step with a new value of H and/or -C MINT and/or MITER. -C JSTATE A completion code with the following meanings: -C 1 The step was successful. -C 2 A solution could not be obtained with H .NE. 0. -C 3 A solution was not obtained in MXTRY attempts. -C 4 For IMPL .NE. 0, the matrix A is singular. -C On a return with JSTATE .GT. 1, the values of T and -C the YH array are as of the beginning of the last -C step, and H is the last step size attempted. -C***ROUTINES CALLED SDCOR, SDCST, SDNTL, SDPSC, SDPST, SDSCL, SNRM2 -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE SDSTP - EXTERNAL F, JACOBN, FA, USERS - INTEGER I, IERROR, IMPL, IPVT(*), ISWFLG, ITER, J, JSTATE, JSTEPL, - 8 JTASK, MATDIM, MAXORD, MINT, MITER, ML, MNTOLD, MTROLD, - 8 MTRSV, MU, MXFAIL, MXITER, MXRDSV, MXTRY, N, NDE, NDJSTP, - 8 NFAIL, NFE, NJE, NQ, NQUSED, NSTEP, NSV, NTRY, NWAIT - REAL A(MATDIM,*), AVGH, AVGORD, BIAS1, BIAS2, BIAS3, - 8 BND, CTEST, D, DENOM, DFDY(MATDIM,*), D1, EL(13,12), EPS, - 8 ERDN, ERUP, ETEST, FAC(*), H, HMAX, HN, HOLD, HS, HUSED, - 8 NUMER, RC, RCTEST, RH, RH1, RH2, RH3, RMAX, RMFAIL, RMNORM, - 8 SAVE1(*), SAVE2(*), SNRM2, T, TOLD, TQ(3,12), TREND, TRSHLD, - 8 UROUND, Y(*), YH(N,*), YWT(*), Y0NRM - LOGICAL CONVRG, EVALFA, EVALJC, IER, SWITCH - PARAMETER(BIAS1 = 1.3E0, BIAS2 = 1.2E0, BIAS3 = 1.4E0, MXFAIL = 3, - 8 MXITER = 3, MXTRY = 50, RCTEST = .3E0, RMFAIL = 2.E0, - 8 RMNORM = 10.E0, TRSHLD = 1.E0) - PARAMETER (NDJSTP = 10) - DATA IER /.FALSE./ -C***FIRST EXECUTABLE STATEMENT SDSTP - NSV = N - BND = 0.E0 - SWITCH = .FALSE. - NTRY = 0 - TOLD = T - NFAIL = 0 - IF (JTASK .LE. 0) THEN - CALL SDNTL (EPS, F, FA, HMAX, HOLD, IMPL, JTASK, MATDIM, - 8 MAXORD, MINT, MITER, ML, MU, N, NDE, SAVE1, T, - 8 UROUND, USERS, Y, YWT, H, MNTOLD, MTROLD, NFE, RC, - 8 YH, A, CONVRG, EL, FAC, IER, IPVT, NQ, NWAIT, RH, - 8 RMAX, SAVE2, TQ, TREND, ISWFLG, JSTATE) - IF (N .EQ. 0) GO TO 440 - IF (H .EQ. 0.E0) GO TO 400 - IF (IER) GO TO 420 - END IF - 100 NTRY = NTRY + 1 - IF (NTRY .GT. MXTRY) GO TO 410 - T = T + H - CALL SDPSC (1, N, NQ, YH) - EVALJC = (((ABS(RC - 1.E0) .GT. RCTEST) .OR. - 8 (NSTEP .GE. JSTEPL + NDJSTP)) .AND. (MITER .NE. 0)) - EVALFA = .NOT. EVALJC -C - 110 ITER = 0 - DO 115 I = 1,N - 115 Y(I) = YH(I,1) - CALL F (N, T, Y, SAVE2) - IF (N .EQ. 0) THEN - JSTATE = 6 - GO TO 430 - END IF - NFE = NFE + 1 - IF (EVALJC .OR. IER) THEN - CALL SDPST (EL, F, FA, H, IMPL, JACOBN, MATDIM, MITER, ML, - 8 MU, N, NDE, NQ, SAVE2, T, USERS, Y, YH, YWT, UROUND, - 8 NFE, NJE, A, DFDY, FAC, IER, IPVT, SAVE1, ISWFLG, - 8 BND, JSTATE) - IF (N .EQ. 0) GO TO 430 - IF (IER) GO TO 160 - CONVRG = .FALSE. - RC = 1.E0 - JSTEPL = NSTEP - END IF - DO 125 I = 1,N - 125 SAVE1(I) = 0.E0 -C Up to MXITER corrector iterations are taken. -C Convergence is tested by requiring the r.m.s. -C norm of changes to be less than EPS. The sum of -C the corrections is accumulated in the vector -C SAVE1(I). It is approximately equal to the L-th -C derivative of Y multiplied by -C H**L/(factorial(L-1)*EL(L,NQ)), and is thus -C proportional to the actual errors to the lowest -C power of H present (H**L). The YH array is not -C altered in the correction loop. The norm of the -C iterate difference is stored in D. If -C ITER .GT. 0, an estimate of the convergence rate -C constant is stored in TREND, and this is used in -C the convergence test. -C - 130 CALL SDCOR (DFDY, EL, FA, H, IERROR, IMPL, IPVT, MATDIM, MITER, - 8 ML, MU, N, NDE, NQ, T, USERS, Y, YH, YWT, EVALFA, - 8 SAVE1, SAVE2, A, D, JSTATE) - IF (N .EQ. 0) GO TO 430 - IF (ISWFLG .EQ. 3 .AND. MINT .EQ. 1) THEN - IF (ITER .EQ. 0) THEN - NUMER = SNRM2(N, SAVE1, 1) - DO 132 I = 1,N - 132 DFDY(1,I) = SAVE1(I) - Y0NRM = SNRM2(N, YH, 1) - ELSE - DENOM = NUMER - DO 134 I = 1,N - 134 DFDY(1,I) = SAVE1(I) - DFDY(1,I) - NUMER = SNRM2(N, DFDY, MATDIM) - IF (EL(1,NQ)*NUMER .LE. 100.E0*UROUND*Y0NRM) THEN - IF (RMAX .EQ. RMFAIL) THEN - SWITCH = .TRUE. - GO TO 170 - END IF - END IF - DO 136 I = 1,N - 136 DFDY(1,I) = SAVE1(I) - IF (DENOM .NE. 0.E0) - 8 BND = MAX(BND, NUMER/(DENOM*ABS(H)*EL(1,NQ))) - END IF - END IF - IF (ITER .GT. 0) TREND = MAX(.9E0*TREND, D/D1) - D1 = D - CTEST = MIN(2.E0*TREND, 1.E0)*D - IF (CTEST .LE. EPS) GO TO 170 - ITER = ITER + 1 - IF (ITER .LT. MXITER) THEN - DO 140 I = 1,N - 140 Y(I) = YH(I,1) + EL(1,NQ)*SAVE1(I) - CALL F (N, T, Y, SAVE2) - IF (N .EQ. 0) THEN - JSTATE = 6 - GO TO 430 - END IF - NFE = NFE + 1 - GO TO 130 - END IF -C The corrector iteration failed to converge in -C MXITER tries. If partials are involved but are -C not up to date, they are reevaluated for the next -C try. Otherwise the YH array is retracted to its -C values before prediction, and H is reduced, if -C possible. If not, a no-convergence exit is taken. - IF (CONVRG) THEN - EVALJC = .TRUE. - EVALFA = .FALSE. - GO TO 110 - END IF - 160 T = TOLD - CALL SDPSC (-1, N, NQ, YH) - NWAIT = NQ + 2 - IF (JTASK .NE. 0 .AND. JTASK .NE. 2) RMAX = RMFAIL - IF (ITER .EQ. 0) THEN - RH = .3E0 - ELSE - RH = .9E0*(EPS/CTEST)**(.2E0) - END IF - IF (RH*H .EQ. 0.E0) GO TO 400 - CALL SDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) - GO TO 100 -C The corrector has converged. CONVRG is set -C to .TRUE. if partial derivatives were used, -C to indicate that they may need updating on -C subsequent steps. The error test is made. - 170 CONVRG = (MITER .NE. 0) - IF (IERROR .EQ. 1 .OR. IERROR .EQ. 5) THEN - DO 180 I = 1,NDE - 180 SAVE2(I) = SAVE1(I)/YWT(I) - ELSE - DO 185 I = 1,NDE - 185 SAVE2(I) = SAVE1(I)/MAX(ABS(Y(I)), YWT(I)) - END IF - ETEST = SNRM2(NDE, SAVE2, 1)/(TQ(2,NQ)*SQRT(REAL(NDE))) -C -C The error test failed. NFAIL keeps track of -C multiple failures. Restore T and the YH -C array to their previous values, and prepare -C to try the step again. Compute the optimum -C step size for this or one lower order. - IF (ETEST .GT. EPS) THEN - T = TOLD - CALL SDPSC (-1, N, NQ, YH) - NFAIL = NFAIL + 1 - IF (NFAIL .LT. MXFAIL .OR. NQ .EQ. 1) THEN - IF (JTASK .NE. 0 .AND. JTASK .NE. 2) RMAX = RMFAIL - RH2 = 1.E0/(BIAS2*(ETEST/EPS)**(1.E0/(NQ+1))) - IF (NQ .GT. 1) THEN - IF (IERROR .EQ. 1 .OR. IERROR .EQ. 5) THEN - DO 190 I = 1,NDE - 190 SAVE2(I) = YH(I,NQ+1)/YWT(I) - ELSE - DO 195 I = 1,NDE - 195 SAVE2(I) = YH(I,NQ+1)/MAX(ABS(Y(I)), YWT(I)) - END IF - ERDN = SNRM2(NDE, SAVE2, 1)/(TQ(1,NQ)*SQRT(REAL(NDE))) - RH1 = 1.E0/MAX(1.E0, BIAS1*(ERDN/EPS)**(1.E0/NQ)) - IF (RH2 .LT. RH1) THEN - NQ = NQ - 1 - RC = RC*EL(1,NQ)/EL(1,NQ+1) - RH = RH1 - ELSE - RH = RH2 - END IF - ELSE - RH = RH2 - END IF - NWAIT = NQ + 2 - IF (RH*H .EQ. 0.E0) GO TO 400 - CALL SDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) - GO TO 100 - END IF -C Control reaches this section if the error test has -C failed MXFAIL or more times. It is assumed that the -C derivatives that have accumulated in the YH array have -C errors of the wrong order. Hence the first derivative -C is recomputed, the order is set to 1, and the step is -C retried. - NFAIL = 0 - JTASK = 2 - DO 215 I = 1,N - 215 Y(I) = YH(I,1) - CALL SDNTL (EPS, F, FA, HMAX, HOLD, IMPL, JTASK, MATDIM, - 8 MAXORD, MINT, MITER, ML, MU, N, NDE, SAVE1, T, - 8 UROUND, USERS, Y, YWT, H, MNTOLD, MTROLD, NFE, RC, - 8 YH, A, CONVRG, EL, FAC, IER, IPVT, NQ, NWAIT, RH, - 8 RMAX, SAVE2, TQ, TREND, ISWFLG, JSTATE) - RMAX = RMNORM - IF (N .EQ. 0) GO TO 440 - IF (H .EQ. 0.E0) GO TO 400 - IF (IER) GO TO 420 - GO TO 100 - END IF -C After a successful step, update the YH array. - NSTEP = NSTEP + 1 - HUSED = H - NQUSED = NQ - AVGH = ((NSTEP-1)*AVGH + H)/NSTEP - AVGORD = ((NSTEP-1)*AVGORD + NQ)/NSTEP - DO 230 J = 1,NQ+1 - DO 230 I = 1,N - 230 YH(I,J) = YH(I,J) + EL(J,NQ)*SAVE1(I) - DO 235 I = 1,N - 235 Y(I) = YH(I,1) -C If ISWFLG is 3, consider -C changing integration methods. - IF (ISWFLG .EQ. 3) THEN - IF (BND .NE. 0.E0) THEN - IF (MINT .EQ. 1 .AND. NQ .LE. 5) THEN - HN = ABS(H)/MAX(UROUND, (ETEST/EPS)**(1.E0/(NQ+1))) - HN = MIN(HN, 1.E0/(2.E0*EL(1,NQ)*BND)) - HS = ABS(H)/MAX(UROUND, - 8 (ETEST/(EPS*EL(NQ+1,1)))**(1.E0/(NQ+1))) - IF (HS .GT. 1.2E0*HN) THEN - MINT = 2 - MNTOLD = MINT - MITER = MTRSV - MTROLD = MITER - MAXORD = MIN(MXRDSV, 5) - RC = 0.E0 - RMAX = RMNORM - TREND = 1.E0 - CALL SDCST (MAXORD, MINT, ISWFLG, EL, TQ) - NWAIT = NQ + 2 - END IF - ELSE IF (MINT .EQ. 2) THEN - HS = ABS(H)/MAX(UROUND, (ETEST/EPS)**(1.E0/(NQ+1))) - HN = ABS(H)/MAX(UROUND, - 8 (ETEST*EL(NQ+1,1)/EPS)**(1.E0/(NQ+1))) - HN = MIN(HN, 1.E0/(2.E0*EL(1,NQ)*BND)) - IF (HN .GE. HS) THEN - MINT = 1 - MNTOLD = MINT - MITER = 0 - MTROLD = MITER - MAXORD = MIN(MXRDSV, 12) - RMAX = RMNORM - TREND = 1.E0 - CONVRG = .FALSE. - CALL SDCST (MAXORD, MINT, ISWFLG, EL, TQ) - NWAIT = NQ + 2 - END IF - END IF - END IF - END IF - IF (SWITCH) THEN - MINT = 2 - MNTOLD = MINT - MITER = MTRSV - MTROLD = MITER - MAXORD = MIN(MXRDSV, 5) - NQ = MIN(NQ, MAXORD) - RC = 0.E0 - RMAX = RMNORM - TREND = 1.E0 - CALL SDCST (MAXORD, MINT, ISWFLG, EL, TQ) - NWAIT = NQ + 2 - END IF -C Consider changing H if NWAIT = 1. Otherwise -C decrease NWAIT by 1. If NWAIT is then 1 and -C NQ.LT.MAXORD, then SAVE1 is saved for use in -C a possible order increase on the next step. -C - IF (JTASK .EQ. 0 .OR. JTASK .EQ. 2) THEN - RH = 1.E0/MAX(UROUND, BIAS2*(ETEST/EPS)**(1.E0/(NQ+1))) - IF (RH.GT.TRSHLD) CALL SDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) - ELSE IF (NWAIT .GT. 1) THEN - NWAIT = NWAIT - 1 - IF (NWAIT .EQ. 1 .AND. NQ .LT. MAXORD) THEN - DO 250 I = 1,NDE - 250 YH(I,MAXORD+1) = SAVE1(I) - END IF -C If a change in H is considered, an increase or decrease in -C order by one is considered also. A change in H is made -C only if it is by a factor of at least TRSHLD. Factors -C RH1, RH2, and RH3 are computed, by which H could be -C multiplied at order NQ - 1, order NQ, or order NQ + 1, -C respectively. The largest of these is determined and the -C new order chosen accordingly. If the order is to be -C increased, we compute one additional scaled derivative. -C If there is a change of order, reset NQ and the -C coefficients. In any case H is reset according to RH and -C the YH array is rescaled. - ELSE - IF (NQ .EQ. 1) THEN - RH1 = 0.E0 - ELSE - IF (IERROR .EQ. 1 .OR. IERROR .EQ. 5) THEN - DO 270 I = 1,NDE - 270 SAVE2(I) = YH(I,NQ+1)/YWT(I) - ELSE - DO 275 I = 1,NDE - 275 SAVE2(I) = YH(I,NQ+1)/MAX(ABS(Y(I)), YWT(I)) - END IF - ERDN = SNRM2(NDE, SAVE2, 1)/(TQ(1,NQ)*SQRT(REAL(NDE))) - RH1 = 1.E0/MAX(UROUND, BIAS1*(ERDN/EPS)**(1.E0/NQ)) - END IF - RH2 = 1.E0/MAX(UROUND, BIAS2*(ETEST/EPS)**(1.E0/(NQ+1))) - IF (NQ .EQ. MAXORD) THEN - RH3 = 0.E0 - ELSE - IF (IERROR .EQ. 1 .OR. IERROR .EQ. 5) THEN - DO 290 I = 1,NDE - 290 SAVE2(I) = (SAVE1(I) - YH(I,MAXORD+1))/YWT(I) - ELSE - DO 295 I = 1,NDE - SAVE2(I) = (SAVE1(I) - YH(I,MAXORD+1))/ - 8 MAX(ABS(Y(I)), YWT(I)) - 295 CONTINUE - END IF - ERUP = SNRM2(NDE, SAVE2, 1)/(TQ(3,NQ)*SQRT(REAL(NDE))) - RH3 = 1.E0/MAX(UROUND, BIAS3*(ERUP/EPS)**(1.E0/(NQ+2))) - END IF - IF (RH1 .GT. RH2 .AND. RH1 .GE. RH3) THEN - RH = RH1 - IF (RH .LE. TRSHLD) GO TO 380 - NQ = NQ - 1 - RC = RC*EL(1,NQ)/EL(1,NQ+1) - ELSE IF (RH2 .GE. RH1 .AND. RH2 .GE. RH3) THEN - RH = RH2 - IF (RH .LE. TRSHLD) GO TO 380 - ELSE - RH = RH3 - IF (RH .LE. TRSHLD) GO TO 380 - DO 360 I = 1,N - 360 YH(I,NQ+2) = SAVE1(I)*EL(NQ+1,NQ)/(NQ+1) - NQ = NQ + 1 - RC = RC*EL(1,NQ)/EL(1,NQ-1) - END IF - IF (ISWFLG .EQ. 3 .AND. MINT .EQ. 1) THEN - IF (BND.NE.0.E0) RH = MIN(RH, 1.E0/(2.E0*EL(1,NQ)*BND*ABS(H))) - END IF - CALL SDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) - RMAX = RMNORM - 380 NWAIT = NQ + 2 - END IF -C All returns are made through this section. H is saved -C in HOLD to allow the caller to change H on the next step - JSTATE = 1 - HOLD = H - RETURN -C - 400 JSTATE = 2 - HOLD = H - DO 405 I = 1,N - 405 Y(I) = YH(I,1) - RETURN -C - 410 JSTATE = 3 - HOLD = H - RETURN -C - 420 JSTATE = 4 - HOLD = H - RETURN -C - 430 T = TOLD - CALL SDPSC (-1, NSV, NQ, YH) - DO 435 I = 1,NSV - 435 Y(I) = YH(I,1) - 440 HOLD = H - RETURN - END diff --git a/slatec/sdzro.f b/slatec/sdzro.f deleted file mode 100644 index ece13be..0000000 --- a/slatec/sdzro.f +++ /dev/null @@ -1,134 +0,0 @@ -*DECK SDZRO - SUBROUTINE SDZRO (AE, F, H, N, NQ, IROOT, RE, T, YH, UROUND, B, C, - 8 FB, FC, Y) -C***BEGIN PROLOGUE SDZRO -C***SUBSIDIARY -C***PURPOSE SDZRO searches for a zero of a function F(N, T, Y, IROOT) -C between the given values B and C until the width of the -C interval (B, C) has collapsed to within a tolerance -C specified by the stopping criterion, -C ABS(B - C) .LE. 2.*(RW*ABS(B) + AE). -C***LIBRARY SLATEC (SDRIVE) -C***TYPE SINGLE PRECISION (SDZRO-S, DDZRO-D, CDZRO-C) -C***AUTHOR Kahaner, D. K., (NIST) -C National Institute of Standards and Technology -C Gaithersburg, MD 20899 -C Sutherland, C. D., (LANL) -C Mail Stop D466 -C Los Alamos National Laboratory -C Los Alamos, NM 87545 -C***DESCRIPTION -C -C This is a special purpose version of ZEROIN, modified for use with -C the SDRIV package. -C -C Sandia Mathematical Program Library -C Mathematical Computing Services Division 5422 -C Sandia Laboratories -C P. O. Box 5800 -C Albuquerque, New Mexico 87115 -C Control Data 6600 Version 4.5, 1 November 1971 -C -C PARAMETERS -C F - Name of the external function, which returns a -C real result. This name must be in an -C EXTERNAL statement in the calling program. -C B - One end of the interval (B, C). The value returned for -C B usually is the better approximation to a zero of F. -C C - The other end of the interval (B, C). -C RE - Relative error used for RW in the stopping criterion. -C If the requested RE is less than machine precision, -C then RW is set to approximately machine precision. -C AE - Absolute error used in the stopping criterion. If the -C given interval (B, C) contains the origin, then a -C nonzero value should be chosen for AE. -C -C***REFERENCES L. F. Shampine and H. A. Watts, ZEROIN, a root-solving -C routine, SC-TM-70-631, Sept 1970. -C T. J. Dekker, Finding a zero by means of successive -C linear interpolation, Constructive Aspects of the -C Fundamental Theorem of Algebra, edited by B. Dejon -C and P. Henrici, 1969. -C***ROUTINES CALLED SDNTP -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 900329 Initial submission to SLATEC. -C***END PROLOGUE SDZRO - INTEGER IC, IROOT, KOUNT, N, NQ - REAL A, ACBS, ACMB, AE, B, C, CMB, ER, F, FA, FB, FC, - 8 H, P, Q, RE, RW, T, TOL, UROUND, Y(*), YH(N,*) -C***FIRST EXECUTABLE STATEMENT SDZRO - ER = 4.E0*UROUND - RW = MAX(RE, ER) - IC = 0 - ACBS = ABS(B - C) - A = C - FA = FC - KOUNT = 0 -C Perform interchange - 10 IF (ABS(FC) .LT. ABS(FB)) THEN - A = B - FA = FB - B = C - FB = FC - C = A - FC = FA - END IF - CMB = 0.5E0*(C - B) - ACMB = ABS(CMB) - TOL = RW*ABS(B) + AE -C Test stopping criterion - IF (ACMB .LE. TOL) RETURN - IF (KOUNT .GT. 50) RETURN -C Calculate new iterate implicitly as -C B + P/Q, where we arrange P .GE. 0. -C The implicit form is used to prevent overflow. - P = (B - A)*FB - Q = FA - FB - IF (P .LT. 0.E0) THEN - P = -P - Q = -Q - END IF -C Update A and check for satisfactory reduction -C in the size of our bounding interval. - A = B - FA = FB - IC = IC + 1 - IF (IC .GE. 4) THEN - IF (8.E0*ACMB .GE. ACBS) THEN -C Bisect - B = 0.5E0*(C + B) - GO TO 20 - END IF - IC = 0 - END IF - ACBS = ACMB -C Test for too small a change - IF (P .LE. ABS(Q)*TOL) THEN -C Increment by tolerance - B = B + SIGN(TOL, CMB) -C Root ought to be between -C B and (C + B)/2. - ELSE IF (P .LT. CMB*Q) THEN -C Interpolate - B = B + P/Q - ELSE -C Bisect - B = 0.5E0*(C + B) - END IF -C Have completed computation -C for new iterate B. - 20 CALL SDNTP (H, 0, N, NQ, T, B, YH, Y) - FB = F(N, B, Y, IROOT) - IF (N .EQ. 0) RETURN - IF (FB .EQ. 0.E0) RETURN - KOUNT = KOUNT + 1 -C -C Decide whether next step is interpolation or extrapolation -C - IF (SIGN(1.0E0, FB) .EQ. SIGN(1.0E0, FC)) THEN - C = A - FC = FA - END IF - GO TO 10 - END diff --git a/slatec/sepeli.f b/slatec/sepeli.f deleted file mode 100644 index c778fd9..0000000 --- a/slatec/sepeli.f +++ /dev/null @@ -1,516 +0,0 @@ -*DECK SEPELI - SUBROUTINE SEPELI (INTL, IORDER, A, B, M, MBDCND, BDA, ALPHA, BDB, - + BETA, C, D, N, NBDCND, BDC, GAMA, BDD, XNU, COFX, COFY, GRHS, - + USOL, IDMN, W, PERTRB, IERROR) -C***BEGIN PROLOGUE SEPELI -C***PURPOSE Discretize and solve a second and, optionally, a fourth -C order finite difference approximation on a uniform grid to -C the general separable elliptic partial differential -C equation on a rectangle with any combination of periodic or -C mixed boundary conditions. -C***LIBRARY SLATEC (FISHPACK) -C***CATEGORY I2B1A2 -C***TYPE SINGLE PRECISION (SEPELI-S) -C***KEYWORDS ELLIPTIC, FISHPACK, HELMHOLTZ, PDE, SEPARABLE -C***AUTHOR Adams, J., (NCAR) -C Swarztrauber, P. N., (NCAR) -C Sweet, R., (NCAR) -C***DESCRIPTION -C -C Dimension of BDA(N+1), BDB(N+1), BDC(M+1), BDD(M+1), -C Arguments USOL(IDMN,N+1), GRHS(IDMN,N+1), -C W (see argument list) -C -C Latest Revision March 1977 -C -C Purpose SEPELI solves for either the second-order -C finite difference approximation or a -C fourth-order approximation to a separable -C elliptic equation. -C -C 2 2 -C AF(X)*d U/dX + BF(X)*dU/dX + CF(X)*U + -C 2 2 -C DF(Y)*d U/dY + EF(Y)*dU/dY + FF(Y)*U -C -C = G(X,Y) -C -C on a rectangle (X greater than or equal to A -C and less than or equal to B; Y greater than -C or equal to C and less than or equal to D). -C Any combination of periodic or mixed boundary -C conditions is allowed. -C -C Purpose The possible boundary conditions are: -C in the X-direction: -C (0) Periodic, U(X+B-A,Y)=U(X,Y) for all Y,X -C (1) U(A,Y), U(B,Y) are specified for all Y -C (2) U(A,Y), dU(B,Y)/dX+BETA*U(B,Y) are -C specified for all Y -C (3) dU(A,Y)/dX+ALPHA*U(A,Y),dU(B,Y)/dX+ -C BETA*U(B,Y) are specified for all Y -C (4) dU(A,Y)/dX+ALPHA*U(A,Y),U(B,Y) are -C specified for all Y -C -C in the Y-direction: -C (0) Periodic, U(X,Y+D-C)=U(X,Y) for all X,Y -C (1) U(X,C),U(X,D) are specified for all X -C (2) U(X,C),dU(X,D)/dY+XNU*U(X,D) are specified -C for all X -C (3) dU(X,C)/dY+GAMA*U(X,C),dU(X,D)/dY+ -C XNU*U(X,D) are specified for all X -C (4) dU(X,C)/dY+GAMA*U(X,C),U(X,D) are -C specified for all X -C -C Arguments -C -C On Input INTL -C = 0 On initial entry to SEPELI or if any of -C the arguments C, D, N, NBDCND, COFY are -C changed from a previous call -C = 1 If C, D, N, NBDCND, COFY are unchanged -C from the previous call. -C -C IORDER -C = 2 If a second-order approximation is sought -C = 4 If a fourth-order approximation is sought -C -C A,B -C The range of the X-independent variable; -C i.e., X is greater than or equal to A and -C less than or equal to B. A must be less than -C B. -C -C M -C The number of panels into which the interval -C [A,B] is subdivided. Hence, there will be -C M+1 grid points in the X-direction given by -C XI=A+(I-1)*DLX for I=1,2,...,M+1 where -C DLX=(B-A)/M is the panel width. M must be -C less than IDMN and greater than 5. -C -C MBDCND -C Indicates the type of boundary condition at -C X=A and X=B -C = 0 If the solution is periodic in X; i.e., -C U(X+B-A,Y)=U(X,Y) for all Y,X -C = 1 If the solution is specified at X=A and -C X=B; i.e., U(A,Y) and U(B,Y) are -C specified for all Y -C = 2 If the solution is specified at X=A and -C the boundary condition is mixed at X=B; -C i.e., U(A,Y) and dU(B,Y)/dX+BETA*U(B,Y) -C are specified for all Y -C = 3 If the boundary conditions at X=A and X=B -C are mixed; i.e., dU(A,Y)/dX+ALPHA*U(A,Y) -C and dU(B,Y)/dX+BETA*U(B,Y) are specified -C for all Y -C = 4 If the boundary condition at X=A is mixed -C and the solution is specified at X=B; -C i.e., dU(A,Y)/dX+ALPHA*U(A,Y) and U(B,Y) -C are specified for all Y -C -C BDA -C A one-dimensional array of length N+1 that -C specifies the values of dU(A,Y)/dX+ -C ALPHA*U(A,Y) at X=A, when MBDCND=3 or 4. -C BDA(J) = dU(A,YJ)/dX+ALPHA*U(A,YJ); -C J=1,2,...,N+1 -C when MBDCND has any other value, BDA is a -C dummy parameter. -C -C On Input ALPHA -C The scalar multiplying the solution in case -C of a mixed boundary condition at X=A (see -C argument BDA). If MBDCND = 3,4 then ALPHA is -C a dummy parameter. -C -C BDB -C A one-dimensional array of length N+1 that -C specifies the values of dU(B,Y)/dX+ -C BETA*U(B,Y) at X=B. When MBDCND=2 or 3 -C BDB(J) = dU(B,YJ)/dX+BETA*U(B,YJ); -C J=1,2,...,N+1 -C When MBDCND has any other value, BDB is a -C dummy parameter. -C -C BETA -C The scalar multiplying the solution in case -C of a mixed boundary condition at X=B (see -C argument BDB). If MBDCND=2,3 then BETA is a -C dummy parameter. -C -C C,D -C The range of the Y-independent variable; -C i.e., Y is greater than or equal to C and -C less than or equal to D. C must be less than -C D. -C -C N -C The number of panels into which the interval -C [C,D] is subdivided. Hence, there will be -C N+1 grid points in the Y-direction given by -C YJ=C+(J-1)*DLY for J=1,2,...,N+1 where -C DLY=(D-C)/N is the panel width. In addition, -C N must be greater than 4. -C -C NBDCND -C Indicates the types of boundary conditions at -C Y=C and Y=D -C = 0 If the solution is periodic in Y; i.e., -C U(X,Y+D-C)=U(X,Y) for all X,Y -C = 1 If the solution is specified at Y=C and -C Y = D, i.e., U(X,C) and U(X,D) are -C specified for all X -C = 2 If the solution is specified at Y=C and -C the boundary condition is mixed at Y=D; -C i.e., U(X,C) and dU(X,D)/dY+XNU*U(X,D) -C are specified for all X -C = 3 If the boundary conditions are mixed at -C Y=C and Y=D; i.e., dU(X,D)/dY+GAMA*U(X,C) -C and dU(X,D)/dY+XNU*U(X,D) are specified -C for all X -C = 4 If the boundary condition is mixed at Y=C -C and the solution is specified at Y=D; -C i.e. dU(X,C)/dY+GAMA*U(X,C) and U(X,D) -C are specified for all X -C -C BDC -C A one-dimensional array of length M+1 that -C specifies the value of dU(X,C)/dY+GAMA*U(X,C) -C at Y=C. When NBDCND=3 or 4 -C BDC(I) = dU(XI,C)/dY + GAMA*U(XI,C); -C I=1,2,...,M+1. -C When NBDCND has any other value, BDC is a -C dummy parameter. -C -C GAMA -C The scalar multiplying the solution in case -C of a mixed boundary condition at Y=C (see -C argument BDC). If NBDCND=3,4 then GAMA is a -C dummy parameter. -C -C BDD -C A one-dimensional array of length M+1 that -C specifies the value of dU(X,D)/dY + -C XNU*U(X,D) at Y=C. When NBDCND=2 or 3 -C BDD(I) = dU(XI,D)/dY + XNU*U(XI,D); -C I=1,2,...,M+1. -C When NBDCND has any other value, BDD is a -C dummy parameter. -C -C XNU -C The scalar multiplying the solution in case -C of a mixed boundary condition at Y=D (see -C argument BDD). If NBDCND=2 or 3 then XNU is -C a dummy parameter. -C -C COFX -C A user-supplied subprogram with -C parameters X, AFUN, BFUN, CFUN which -C returns the values of the X-dependent -C coefficients AF(X), BF(X), CF(X) in -C the elliptic equation at X. -C -C COFY -C A user-supplied subprogram with -C parameters Y, DFUN, EFUN, FFUN which -C returns the values of the Y-dependent -C coefficients DF(Y), EF(Y), FF(Y) in -C the elliptic equation at Y. -C -C NOTE: COFX and COFY must be declared external -C in the calling routine. The values returned in -C AFUN and DFUN must satisfy AFUN*DFUN greater -C than 0 for A less than X less than B, -C C less than Y less than D (see IERROR=10). -C The coefficients provided may lead to a matrix -C equation which is not diagonally dominant in -C which case solution may fail (see IERROR=4). -C -C GRHS -C A two-dimensional array that specifies the -C values of the right-hand side of the elliptic -C equation; i.e., GRHS(I,J)=G(XI,YI), for -C I=2,...,M; J=2,...,N. At the boundaries, -C GRHS is defined by -C -C MBDCND GRHS(1,J) GRHS(M+1,J) -C ------ --------- ----------- -C 0 G(A,YJ) G(B,YJ) -C 1 * * -C 2 * G(B,YJ) J=1,2,...,N+1 -C 3 G(A,YJ) G(B,YJ) -C 4 G(A,YJ) * -C -C NBDCND GRHS(I,1) GRHS(I,N+1) -C ------ --------- ----------- -C 0 G(XI,C) G(XI,D) -C 1 * * -C 2 * G(XI,D) I=1,2,...,M+1 -C 3 G(XI,C) G(XI,D) -C 4 G(XI,C) * -C -C where * means these quantities are not used. -C GRHS should be dimensioned IDMN by at least -C N+1 in the calling routine. -C -C USOL -C A two-dimensional array that specifies the -C values of the solution along the boundaries. -C At the boundaries, USOL is defined by -C -C MBDCND USOL(1,J) USOL(M+1,J) -C ------ --------- ----------- -C 0 * * -C 1 U(A,YJ) U(B,YJ) -C 2 U(A,YJ) * J=1,2,...,N+1 -C 3 * * -C 4 * U(B,YJ) -C -C NBDCND USOL(I,1) USOL(I,N+1) -C ------ --------- ----------- -C 0 * * -C 1 U(XI,C) U(XI,D) -C 2 U(XI,C) * I=1,2,...,M+1 -C 3 * * -C 4 * U(XI,D) -C -C where * means the quantities are not used in -C the solution. -C -C If IORDER=2, the user may equivalence GRHS -C and USOL to save space. Note that in this -C case the tables specifying the boundaries of -C the GRHS and USOL arrays determine the -C boundaries uniquely except at the corners. -C If the tables call for both G(X,Y) and -C U(X,Y) at a corner then the solution must be -C chosen. For example, if MBDCND=2 and -C NBDCND=4, then U(A,C), U(A,D), U(B,D) must be -C chosen at the corners in addition to G(B,C). -C -C If IORDER=4, then the two arrays, USOL and -C GRHS, must be distinct. -C -C USOL should be dimensioned IDMN by at least -C N+1 in the calling routine. -C -C IDMN -C The row (or first) dimension of the arrays -C GRHS and USOL as it appears in the program -C calling SEPELI. This parameter is used to -C specify the variable dimension of GRHS and -C USOL. IDMN must be at least 7 and greater -C than or equal to M+1. -C -C W -C A one-dimensional array that must be provided -C by the user for work space. Let -C K=INT(log2(N+1))+1 and set L=2**(K+1). -C then (K-2)*L+K+10*N+12*M+27 will suffice -C as a length of W. THE actual length of W in -C the calling routine must be set in W(1) (see -C IERROR=11). -C -C On Output USOL -C Contains the approximate solution to the -C elliptic equation. USOL(I,J) is the -C approximation to U(XI,YJ) for I=1,2...,M+1 -C and J=1,2,...,N+1. The approximation has -C error O(DLX**2+DLY**2) if called with -C IORDER=2 and O(DLX**4+DLY**4) if called with -C IORDER=4. -C -C W -C Contains intermediate values that must not be -C destroyed if SEPELI is called again with -C INTL=1. In addition W(1) contains the exact -C minimal length (in floating point) required -C for the work space (see IERROR=11). -C -C PERTRB -C If a combination of periodic or derivative -C boundary conditions (i.e., ALPHA=BETA=0 if -C MBDCND=3; GAMA=XNU=0 if NBDCND=3) is -C specified and if the coefficients of U(X,Y) -C in the separable elliptic equation are zero -C (i.e., CF(X)=0 for X greater than or equal to -C A and less than or equal to B; FF(Y)=0 for -C Y greater than or equal to C and less than -C or equal to D) then a solution may not exist. -C PERTRB is a constant calculated and -C subtracted from the right-hand side of the -C matrix equations generated by SEPELI which -C insures that a solution exists. SEPELI then -C computes this solution which is a weighted -C minimal least squares solution to the -C original problem. -C -C IERROR -C An error flag that indicates invalid input -C parameters or failure to find a solution -C = 0 No error -C = 1 If A greater than B or C greater than D -C = 2 If MBDCND less than 0 or MBDCND greater -C than 4 -C = 3 If NBDCND less than 0 or NBDCND greater -C than 4 -C = 4 If attempt to find a solution fails. -C (the linear system generated is not -C diagonally dominant.) -C = 5 If IDMN is too small (see discussion of -C IDMN) -C = 6 If M is too small or too large (see -C discussion of M) -C = 7 If N is too small (see discussion of N) -C = 8 If IORDER is not 2 or 4 -C = 9 If INTL is not 0 or 1 -C = 10 If AFUN*DFUN less than or equal to 0 for -C some interior mesh point (XI,YJ) -C = 11 If the work space length input in W(1) -C is less than the exact minimal work -C space length required output in W(1). -C -C NOTE (concerning IERROR=4): for the -C coefficients input through COFX, COFY, the -C discretization may lead to a block -C tridiagonal linear system which is not -C diagonally dominant (for example, this -C happens if CFUN=0 and BFUN/(2.*DLX) greater -C than AFUN/DLX**2). In this case solution may -C fail. This cannot happen in the limit as -C DLX, DLY approach zero. Hence, the condition -C may be remedied by taking larger values for M -C or N. -C -C Entry Points SEPELI, SPELIP, CHKPRM, CHKSNG, ORTHOG, MINSOL, -C TRISP, DEFER, DX, DY, BLKTRI, BLKTR1, INDXB, -C INDXA, INDXC, PROD, PRODP, CPROD, CPRODP, -C PPADD, PSGF, BSRH, PPSGF, PPSPF, COMPB, -C TRUN1, STOR1, TQLRAT -C -C Special Conditions NONE -C -C Common Blocks SPLP, CBLKT -C -C I/O NONE -C -C Precision Single -C -C Specialist John C. Adams, NCAR, Boulder, Colorado 80307 -C -C Language FORTRAN -C -C History Developed at NCAR during 1975-76. -C -C Algorithm SEPELI automatically discretizes the separable -C elliptic equation which is then solved by a -C generalized cyclic reduction algorithm in the -C subroutine, BLKTRI. The fourth-order solution -C is obtained using 'Deferred Corrections' which -C is described and referenced in sections, -C references and method. -C -C Space Required 14654 (octal) = 6572 (decimal) -C -C Accuracy and Timing The following computational results were -C obtained by solving the sample problem at the -C end of this write-up on the Control Data 7600. -C The op count is proportional to M*N*log2(N). -C In contrast to the other routines in this -C chapter, accuracy is tested by computing and -C tabulating second- and fourth-order -C discretization errors. Below is a table -C containing computational results. The times -C given do not include initialization (i.e., -C times are for INTL=1). Note that the -C fourth-order accuracy is not realized until the -C mesh is sufficiently refined. -C -C Second-order Fourth-order Second-order Fourth-order -C M N Execution Time Execution Time Error Error -C (M SEC) (M SEC) -C 6 6 6 14 6.8E-1 1.2E0 -C 14 14 23 58 1.4E-1 1.8E-1 -C 30 30 100 247 3.2E-2 9.7E-3 -C 62 62 445 1,091 7.5E-3 3.0E-4 -C 126 126 2,002 4,772 1.8E-3 3.5E-6 -C -C Portability There are no machine-dependent constants. -C -C Required Resident SQRT, ABS, LOG -C Routines -C -C References Keller, H.B., 'Numerical Methods for Two-point -C Boundary-value Problems', Blaisdel (1968), -C Waltham, Mass. -C -C Swarztrauber, P., and R. Sweet (1975): -C 'Efficient FORTRAN Subprograms for The -C Solution of Elliptic Partial Differential -C Equations'. NCAR Technical Note -C NCAR-TN/IA-109, pp. 135-137. -C -C***REFERENCES H. B. Keller, Numerical Methods for Two-point -C Boundary-value Problems, Blaisdel, Waltham, Mass., -C 1968. -C P. N. Swarztrauber and R. Sweet, Efficient Fortran -C subprograms for the solution of elliptic equations, -C NCAR TN/IA-109, July 1975, 138 pp. -C***ROUTINES CALLED CHKPRM, SPELIP -C***REVISION HISTORY (YYMMDD) -C 801001 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 SEPELI -C - DIMENSION GRHS(IDMN,*) ,USOL(IDMN,*) - DIMENSION BDA(*) ,BDB(*) ,BDC(*) ,BDD(*) , - 1 W(*) - EXTERNAL COFX ,COFY -C***FIRST EXECUTABLE STATEMENT SEPELI - CALL CHKPRM (INTL,IORDER,A,B,M,MBDCND,C,D,N,NBDCND,COFX,COFY, - 1 IDMN,IERROR) - IF (IERROR .NE. 0) RETURN -C -C COMPUTE MINIMUM WORK SPACE AND CHECK WORK SPACE LENGTH INPUT -C - L = N+1 - IF (NBDCND .EQ. 0) L = N - LOGB2N = INT(LOG(L+0.5)/LOG(2.0))+1 - LL = 2**(LOGB2N+1) - K = M+1 - L = N+1 - LENGTH = (LOGB2N-2)*LL+LOGB2N+MAX(2*L,6*K)+5 - IF (NBDCND .EQ. 0) LENGTH = LENGTH+2*L - IERROR = 11 - LINPUT = INT(W(1)+0.5) - LOUTPT = LENGTH+6*(K+L)+1 - W(1) = LOUTPT - IF (LOUTPT .GT. LINPUT) RETURN - IERROR = 0 -C -C SET WORK SPACE INDICES -C - I1 = LENGTH+2 - I2 = I1+L - I3 = I2+L - I4 = I3+L - I5 = I4+L - I6 = I5+L - I7 = I6+L - I8 = I7+K - I9 = I8+K - I10 = I9+K - I11 = I10+K - I12 = I11+K - I13 = 2 - CALL SPELIP (INTL,IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,BETA,C,D,N, - 1 NBDCND,BDC,GAMA,BDD,XNU,COFX,COFY,W(I1),W(I2),W(I3), - 2 W(I4),W(I5),W(I6),W(I7),W(I8),W(I9),W(I10),W(I11), - 3 W(I12),GRHS,USOL,IDMN,W(I13),PERTRB,IERROR) - RETURN - END diff --git a/slatec/sepx4.f b/slatec/sepx4.f deleted file mode 100644 index b8ab368..0000000 --- a/slatec/sepx4.f +++ /dev/null @@ -1,451 +0,0 @@ -*DECK SEPX4 - SUBROUTINE SEPX4 (IORDER, A, B, M, MBDCND, BDA, ALPHA, BDB, BETA, - + C, D, N, NBDCND, BDC, BDD, COFX, GRHS, USOL, IDMN, W, PERTRB, - + IERROR) -C***BEGIN PROLOGUE SEPX4 -C***PURPOSE Solve for either the second or fourth order finite -C difference approximation to the solution of a separable -C elliptic partial differential equation on a rectangle. -C Any combination of periodic or mixed boundary conditions is -C allowed. -C***LIBRARY SLATEC (FISHPACK) -C***CATEGORY I2B1A2 -C***TYPE SINGLE PRECISION (SEPX4-S) -C***KEYWORDS ELLIPTIC, FISHPACK, HELMHOLTZ, PDE, SEPARABLE -C***AUTHOR Adams, J., (NCAR) -C Swarztrauber, P. N., (NCAR) -C Sweet, R., (NCAR) -C***DESCRIPTION -C -C Purpose SEPX4 solves for either the second-order -C finite difference approximation or a -C fourth-order approximation to the -C solution of a separable elliptic equation -C AF(X)*UXX+BF(X)*UX+CF(X)*U+UYY = G(X,Y) -C -C on a rectangle (X greater than or equal to A -C and less than or equal to B; Y greater than -C or equal to C and less than or equal to D). -C Any combination of periodic or mixed boundary -C conditions is allowed. -C If boundary conditions in the X direction -C are periodic (see MBDCND=0 below) then the -C coefficients must satisfy -C AF(X)=C1,BF(X)=0,CF(X)=C2 for all X. -C Here C1,C2 are constants, C1.GT.0. -C -C The possible boundary conditions are -C in the X-direction: -C (0) Periodic, U(X+B-A,Y)=U(X,Y) for all Y,X -C (1) U(A,Y), U(B,Y) are specified for all Y -C (2) U(A,Y), dU(B,Y)/dX+BETA*U(B,Y) are -C specified for all Y -C (3) dU(A,Y)/dX+ALPHA*U(A,Y),dU(B,Y)/dX+ -C BETA*U(B,Y) are specified for all Y -C (4) dU(A,Y)/dX+ALPHA*U(A,Y),U(B,Y) are -C specified for all Y -C -C In the Y-direction: -C (0) Periodic, U(X,Y+D-C)=U(X,Y) for all X,Y -C (1) U(X,C),U(X,D) are specified for all X -C (2) U(X,C),dU(X,D)/dY are specified for all X -C (3) dU(X,C)/DY,dU(X,D)/dY are specified for -C all X -C (4) dU(X,C)/DY,U(X,D) are specified for all X -C -C Usage Call SEPX4(IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB, -C BETA,C,D,N,NBDCND,BDC,BDD,COFX, -C GRHS,USOL,IDMN,W,PERTRB,IERROR) -C -C Arguments -C -C IORDER -C = 2 If a second-order approximation is sought -C = 4 If a fourth-order approximation is sought -C -C A,B -C The range of the X-independent variable; -C i.e., X is greater than or equal to A and -C less than or equal to B. A must be less than -C B. -C -C M -C The number of panels into which the interval -C [A,B] is subdivided. Hence, there will be -C M+1 grid points in the X-direction given by -C XI=A+(I-1)*DLX for I=1,2,...,M+1 where -C DLX=(B-A)/M is the panel width. M must be -C less than IDMN and greater than 5. -C -C MBDCND -C Indicates the type of boundary condition at -C X=A and X=B -C = 0 If the solution is periodic in X; i.e., -C U(X+B-A,Y)=U(X,Y) for all Y,X -C = 1 If the solution is specified at X=A and -C X=B; i.e., U(A,Y) and U(B,Y) are -C specified for all Y -C = 2 If the solution is specified at X=A and -C the boundary condition is mixed at X=B; -C i.e., U(A,Y) and dU(B,Y)/dX+BETA*U(B,Y) -C are specified for all Y -C = 3 If the boundary conditions at X=A and X=B -C are mixed; i.e., dU(A,Y)/dX+ALPHA*U(A,Y) -C and dU(B,Y)/dX+BETA*U(B,Y) are specified -C for all Y -C = 4 If the boundary condition at X=A is mixed -C and the solution is specified at X=B; -C i.e., dU(A,Y)/dX+ALPHA*U(A,Y) and U(B,Y) -C are specified for all Y -C -C BDA -C A one-dimensional array of length N+1 that -C specifies the values of dU(A,Y)/dX+ -C ALPHA*U(A,Y) at X=A, when MBDCND=3 or 4. -C BDA(J) = dU(A,YJ)/dX+ALPHA*U(A,YJ); -C J=1,2,...,N+1 -C When MBDCND has any other value, BDA is a -C dummy parameter. -C -C On Input ALPHA -C The scalar multiplying the solution in case -C of a mixed boundary condition AT X=A (see -C argument BDA). If MBDCND = 3,4 then ALPHA is -C a dummy parameter. -C -C BDB -C A one-dimensional array of length N+1 that -C specifies the values of dU(B,Y)/dX+ -C BETA*U(B,Y) at X=B. when MBDCND=2 or 3 -C BDB(J) = dU(B,YJ)/dX+BETA*U(B,YJ); -C J=1,2,...,N+1 -C When MBDCND has any other value, BDB is a -C dummy parameter. -C -C BETA -C The scalar multiplying the solution in case -C of a mixed boundary condition at X=B (see -C argument BDB). If MBDCND=2,3 then BETA is a -C dummy parameter. -C -C C,D -C The range of the Y-independent variable; -C i.e., Y is greater than or equal to C and -C less than or equal to D. C must be less than -C D. -C -C N -C The number of panels into which the interval -C [C,D] is subdivided. Hence, there will be -C N+1 grid points in the Y-direction given by -C YJ=C+(J-1)*DLY for J=1,2,...,N+1 where -C DLY=(D-C)/N is the panel width. In addition, -C N must be greater than 4. -C -C NBDCND -C Indicates the types of boundary conditions at -C Y=C and Y=D -C = 0 If the solution is periodic in Y; i.e., -C U(X,Y+D-C)=U(X,Y) for all X,Y -C = 1 If the solution is specified at Y=C and -C Y = D, i.e., U(X,C) and U(X,D) are -C specified for all X -C = 2 If the solution is specified at Y=C and -C the boundary condition is mixed at Y=D; -C i.e., dU(X,C)/dY and U(X,D) -C are specified for all X -C = 3 If the boundary conditions are mixed at -C Y= C and Y=D i.e., dU(X,D)/DY -C and dU(X,D)/dY are specified -C for all X -C = 4 If the boundary condition is mixed at Y=C -C and the solution is specified at Y=D; -C i.e. dU(X,C)/dY+GAMA*U(X,C) and U(X,D) -C are specified for all X -C -C BDC -C A one-dimensional array of length M+1 that -C specifies the value dU(X,C)/DY -C at Y=C. When NBDCND=3 or 4 -C BDC(I) = dU(XI,C)/DY -C I=1,2,...,M+1. -C When NBDCND has any other value, BDC is a -C dummy parameter. -C -C -C BDD -C A one-dimensional array of length M+1 that -C specifies the value of dU(X,D)/DY -C at Y=D. When NBDCND=2 or 3 -C BDD(I)=dU(XI,D)/DY -C I=1,2,...,M+1. -C When NBDCND has any other value, BDD is a -C dummy parameter. -C -C -C COFX -C A user-supplied subprogram with -C parameters X, AFUN, BFUN, CFUN which -C returns the values of the X-dependent -C coefficients AF(X), BF(X), CF(X) in -C the elliptic equation at X. -C If boundary conditions in the X direction -C are periodic then the coefficients -C must satisfy AF(X)=C1,BF(X)=0,CF(X)=C2 for -C all X. Here C1.GT.0 and C2 are constants. -C -C Note that COFX must be declared external -C in the calling routine. -C -C GRHS -C A two-dimensional array that specifies the -C values of the right-hand side of the elliptic -C equation; i.e., GRHS(I,J)=G(XI,YI), for -C I=2,...,M; J=2,...,N. At the boundaries, -C GRHS is defined by -C -C MBDCND GRHS(1,J) GRHS(M+1,J) -C ------ --------- ----------- -C 0 G(A,YJ) G(B,YJ) -C 1 * * -C 2 * G(B,YJ) J=1,2,...,N+1 -C 3 G(A,YJ) G(B,YJ) -C 4 G(A,YJ) * -C -C NBDCND GRHS(I,1) GRHS(I,N+1) -C ------ --------- ----------- -C 0 G(XI,C) G(XI,D) -C 1 * * -C 2 * G(XI,D) I=1,2,...,M+1 -C 3 G(XI,C) G(XI,D) -C 4 G(XI,C) * -C -C where * means these quantities are not used. -C GRHS should be dimensioned IDMN by at least -C N+1 in the calling routine. -C -C USOL -C A two-dimensional array that specifies the -C values of the solution along the boundaries. -C At the boundaries, USOL is defined by -C -C MBDCND USOL(1,J) USOL(M+1,J) -C ------ --------- ----------- -C 0 * * -C 1 U(A,YJ) U(B,YJ) -C 2 U(A,YJ) * J=1,2,...,N+1 -C 3 * * -C 4 * U(B,YJ) -C -C NBDCND USOL(I,1) USOL(I,N+1) -C ------ --------- ----------- -C 0 * * -C 1 U(XI,C) U(XI,D) -C 2 U(XI,C) * I=1,2,...,M+1 -C 3 * * -C 4 * U(XI,D) -C -C where * means the quantities are not used in -C the solution. -C -C If IORDER=2, the user may equivalence GRHS -C and USOL to save space. Note that in this -C case the tables specifying the boundaries of -C the GRHS and USOL arrays determine the -C boundaries uniquely except at the corners. -C If the tables call for both G(X,Y) and -C U(X,Y) at a corner then the solution must be -C chosen. For example, if MBDCND=2 and -C NBDCND=4, then U(A,C), U(A,D), U(B,D) must be -C chosen at the corners in addition to G(B,C). -C -C If IORDER=4, then the two arrays, USOL and -C GRHS, must be distinct. -C -C USOL should be dimensioned IDMN by at least -C N+1 in the calling routine. -C -C IDMN -C The row (or first) dimension of the arrays -C GRHS and USOL as it appears in the program -C calling SEPX4. This parameter is used to -C specify the variable dimension of GRHS and -C USOL. IDMN must be at least 7 and greater -C than or equal to M+1. -C -C W -C A one-dimensional array that must be provided -C by the user for work space. -C 10*N+(16+INT(log2(N)))*(M+1)+23 will suffice -C as a length for W. The actual length of -C W in the calling routine must be set in W(1) -C (see IERROR=11). -C -C On Output USOL -C Contains the approximate solution to the -C elliptic equation. USOL(I,J) is the -C approximation to U(XI,YJ) for I=1,2...,M+1 -C and J=1,2,...,N+1. The approximation has -C error O(DLX**2+DLY**2) if called with -C IORDER=2 and O(DLX**4+DLY**4) if called with -C IORDER=4. -C -C W -C W(1) contains the exact minimal length (in -C floating point) required for the work space -C (see IERROR=11). -C -C PERTRB -C If a combination of periodic or derivative -C boundary conditions (i.e., ALPHA=BETA=0 if -C MBDCND=3) is specified and if CF(X)=0 for all -C X, then a solution to the discretized matrix -C equation may not exist (reflecting the non- -C uniqueness of solutions to the PDE). PERTRB -C is a constant calculated and subtracted from -C the right hand side of the matrix equation -C insuring the existence of a solution. -C SEPX4 computes this solution which is a -C weighted minimal least squares solution to -C the original problem. If singularity is -C not detected PERTRB=0.0 is returned by -C SEPX4. -C -C IERROR -C An error flag that indicates invalid input -C parameters or failure to find a solution -C = 0 No error -C = 1 If A greater than B or C greater than D -C = 2 If MBDCND less than 0 or MBDCND greater -C than 4 -C = 3 If NBDCND less than 0 or NBDCND greater -C than 4 -C = 4 If attempt to find a solution fails. -C (the linear system generated is not -C diagonally dominant.) -C = 5 If IDMN is too small (see discussion of -C IDMN) -C = 6 If M is too small or too large (see -C discussion of M) -C = 7 If N is too small (see discussion of N) -C = 8 If IORDER is not 2 or 4 -C = 10 If AFUN is less than or equal to zero -C for some interior mesh point XI -C = 11 If the work space length input in W(1) -C is less than the exact minimal work -C space length required output in W(1). -C = 12 If MBDCND=0 and AF(X)=CF(X)=constant -C or BF(X)=0 for all X is not true. -C -C *Long Description: -C -C Dimension of BDA(N+1), BDB(N+1), BDC(M+1), BDD(M+1), -C Arguments USOL(IDMN,N+1), GRHS(IDMN,N+1), -C W (see argument list) -C -C Latest Revision October 1980 -C -C Special Conditions NONE -C -C Common Blocks SPL4 -C -C I/O NONE -C -C Precision Single -C -C Required Library NONE -C Files -C -C Specialist John C. Adams, NCAR, Boulder, Colorado 80307 -C -C Language FORTRAN -C -C -C Entry Points SEPX4,SPELI4,CHKPR4,CHKSN4,ORTHO4,MINSO4,TRIS4, -C DEFE4,DX4,DY4 -C -C History SEPX4 was developed by modifying the ULIB -C routine SEPELI during October 1978. -C It should be used instead of SEPELI whenever -C possible. The increase in speed is at least -C a factor of three. -C -C Algorithm SEPX4 automatically discretizes the separable -C elliptic equation which is then solved by a -C generalized cyclic reduction algorithm in the -C subroutine POIS. The fourth order solution -C is obtained using the technique of -C deferred corrections referenced below. -C -C -C References Keller, H.B., 'Numerical Methods for Two-point -C Boundary-value Problems', Blaisdel (1968), -C Waltham, Mass. -C -C Swarztrauber, P., and R. Sweet (1975): -C 'Efficient FORTRAN Subprograms For The -C Solution of Elliptic Partial Differential -C Equations'. NCAR Technical Note -C NCAR-TN/IA-109, pp. 135-137. -C -C***REFERENCES H. B. Keller, Numerical Methods for Two-point -C Boundary-value Problems, Blaisdel, Waltham, Mass., -C 1968. -C P. N. Swarztrauber and R. Sweet, Efficient Fortran -C subprograms for the solution of elliptic equations, -C NCAR TN/IA-109, July 1975, 138 pp. -C***ROUTINES CALLED CHKPR4, SPELI4 -C***REVISION HISTORY (YYMMDD) -C 801001 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 920122 Minor corrections and modifications to prologue. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SEPX4 -C - DIMENSION GRHS(IDMN,*) ,USOL(IDMN,*) - DIMENSION BDA(*) ,BDB(*) ,BDC(*) ,BDD(*) , - 1 W(*) - EXTERNAL COFX -C***FIRST EXECUTABLE STATEMENT SEPX4 - CALL CHKPR4(IORDER,A,B,M,MBDCND,C,D,N,NBDCND,COFX,IDMN,IERROR) - IF (IERROR .NE. 0) RETURN -C -C COMPUTE MINIMUM WORK SPACE AND CHECK WORK SPACE LENGTH INPUT -C - L = N+1 - IF (NBDCND .EQ. 0) L = N - K = M+1 - L = N+1 -C ESTIMATE LOG BASE 2 OF N - LOG2N=INT(LOG(REAL(N+1))/LOG(2.0)+0.5) - LENGTH=4*(N+1)+(10+LOG2N)*(M+1) - IERROR = 11 - LINPUT = INT(W(1)+0.5) - LOUTPT = LENGTH+6*(K+L)+1 - W(1) = LOUTPT - IF (LOUTPT .GT. LINPUT) RETURN - IERROR = 0 -C -C SET WORK SPACE INDICES -C - I1 = LENGTH+2 - I2 = I1+L - I3 = I2+L - I4 = I3+L - I5 = I4+L - I6 = I5+L - I7 = I6+L - I8 = I7+K - I9 = I8+K - I10 = I9+K - I11 = I10+K - I12 = I11+K - I13 = 2 - CALL SPELI4(IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,BETA,C,D,N, - 1NBDCND,BDC,BDD,COFX,W(I1),W(I2),W(I3), - 2 W(I4),W(I5),W(I6),W(I7),W(I8),W(I9),W(I10),W(I11), - 3 W(I12),GRHS,USOL,IDMN,W(I13),PERTRB,IERROR) - RETURN - END diff --git a/slatec/sgbco.f b/slatec/sgbco.f deleted file mode 100644 index 49e02e5..0000000 --- a/slatec/sgbco.f +++ /dev/null @@ -1,278 +0,0 @@ -*DECK SGBCO - SUBROUTINE SGBCO (ABD, LDA, N, ML, MU, IPVT, RCOND, Z) -C***BEGIN PROLOGUE SGBCO -C***PURPOSE Factor a band matrix by Gaussian elimination and -C estimate the condition number of the matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2A2 -C***TYPE SINGLE PRECISION (SGBCO-S, DGBCO-D, CGBCO-C) -C***KEYWORDS BANDED, CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, -C MATRIX FACTORIZATION -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C SBGCO factors a real band matrix by Gaussian -C elimination and estimates the condition of the matrix. -C -C If RCOND is not needed, SGBFA is slightly faster. -C To solve A*X = B , follow SBGCO by SGBSL. -C To compute INVERSE(A)*C , follow SBGCO by SGBSL. -C To compute DETERMINANT(A) , follow SBGCO by SGBDI. -C -C On Entry -C -C ABD REAL(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 REAL -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 REAL(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 = MAX(1, J-MU) -C I2 = MIN(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***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SASUM, SAXPY, SDOT, SGBFA, SSCAL -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SGBCO - INTEGER LDA,N,ML,MU,IPVT(*) - REAL ABD(LDA,*),Z(*) - REAL RCOND -C - REAL SDOT,EK,T,WK,WKM - REAL ANORM,S,SASUM,SM,YNORM - INTEGER IS,INFO,J,JU,K,KB,KP1,L,LA,LM,LZ,M,MM -C -C COMPUTE 1-NORM OF A -C -C***FIRST EXECUTABLE STATEMENT SGBCO - ANORM = 0.0E0 - L = ML + 1 - IS = L + MU - DO 10 J = 1, N - ANORM = MAX(ANORM,SASUM(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 SGBFA(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.0E0 - DO 20 J = 1, N - Z(J) = 0.0E0 - 20 CONTINUE - M = ML + MU + 1 - JU = 0 - DO 100 K = 1, N - IF (Z(K) .NE. 0.0E0) EK = SIGN(EK,-Z(K)) - IF (ABS(EK-Z(K)) .LE. ABS(ABD(M,K))) GO TO 30 - S = ABS(ABD(M,K))/ABS(EK-Z(K)) - CALL SSCAL(N,S,Z,1) - EK = S*EK - 30 CONTINUE - WK = EK - Z(K) - WKM = -EK - Z(K) - S = ABS(WK) - SM = ABS(WKM) - IF (ABD(M,K) .EQ. 0.0E0) GO TO 40 - WK = WK/ABD(M,K) - WKM = WKM/ABD(M,K) - GO TO 50 - 40 CONTINUE - WK = 1.0E0 - WKM = 1.0E0 - 50 CONTINUE - KP1 = K + 1 - JU = MIN(MAX(JU,MU+IPVT(K)),N) - MM = M - IF (KP1 .GT. JU) GO TO 90 - DO 60 J = KP1, JU - MM = MM - 1 - SM = SM + ABS(Z(J)+WKM*ABD(MM,J)) - Z(J) = Z(J) + WK*ABD(MM,J) - S = S + ABS(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.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) -C -C SOLVE TRANS(L)*Y = W -C - DO 120 KB = 1, N - K = N + 1 - KB - LM = MIN(ML,N-K) - IF (K .LT. N) Z(K) = Z(K) + SDOT(LM,ABD(M+1,K),1,Z(K+1),1) - IF (ABS(Z(K)) .LE. 1.0E0) GO TO 110 - S = 1.0E0/ABS(Z(K)) - CALL SSCAL(N,S,Z,1) - 110 CONTINUE - L = IPVT(K) - T = Z(L) - Z(L) = Z(K) - Z(K) = T - 120 CONTINUE - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) -C - YNORM = 1.0E0 -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 = MIN(ML,N-K) - IF (K .LT. N) CALL SAXPY(LM,T,ABD(M+1,K),1,Z(K+1),1) - IF (ABS(Z(K)) .LE. 1.0E0) GO TO 130 - S = 1.0E0/ABS(Z(K)) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM - 130 CONTINUE - 140 CONTINUE - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE U*Z = W -C - DO 160 KB = 1, N - K = N + 1 - KB - IF (ABS(Z(K)) .LE. ABS(ABD(M,K))) GO TO 150 - S = ABS(ABD(M,K))/ABS(Z(K)) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM - 150 CONTINUE - IF (ABD(M,K) .NE. 0.0E0) Z(K) = Z(K)/ABD(M,K) - IF (ABD(M,K) .EQ. 0.0E0) Z(K) = 1.0E0 - LM = MIN(K,M) - 1 - LA = M - LM - LZ = K - LM - T = -Z(K) - CALL SAXPY(LM,T,ABD(LA,K),1,Z(LZ),1) - 160 CONTINUE -C MAKE ZNORM = 1.0 - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM -C - IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM - IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0 - RETURN - END diff --git a/slatec/sgbdi.f b/slatec/sgbdi.f deleted file mode 100644 index 8bbae92..0000000 --- a/slatec/sgbdi.f +++ /dev/null @@ -1,85 +0,0 @@ -*DECK SGBDI - SUBROUTINE SGBDI (ABD, LDA, N, ML, MU, IPVT, DET) -C***BEGIN PROLOGUE SGBDI -C***PURPOSE Compute the determinant of a band matrix using the factors -C computed by SGBCO or SGBFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D3A2 -C***TYPE SINGLE PRECISION (SGBDI-S, DGBDI-D, CGBDI-C) -C***KEYWORDS BANDED, DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, -C MATRIX -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C SGBDI computes the determinant of a band matrix -C using the factors computed by SBGCO or SGBFA. -C If the inverse is needed, use SGBSL N times. -C -C On Entry -C -C ABD REAL(LDA, N) -C the output from SBGCO or SGBFA. -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 SBGCO or SGBFA. -C -C On Return -C -C DET REAL(2) -C determinant of original matrix. -C Determinant = DET(1) * 10.0**DET(2) -C with 1.0 .LE. ABS(DET(1)) .LT. 10.0 -C or DET(1) = 0.0 . -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SGBDI - INTEGER LDA,N,ML,MU,IPVT(*) - REAL ABD(LDA,*),DET(2) -C - REAL TEN - INTEGER I,M -C***FIRST EXECUTABLE STATEMENT SGBDI - M = ML + MU + 1 - DET(1) = 1.0E0 - DET(2) = 0.0E0 - TEN = 10.0E0 - DO 50 I = 1, N - IF (IPVT(I) .NE. I) DET(1) = -DET(1) - DET(1) = ABD(M,I)*DET(1) - IF (DET(1) .EQ. 0.0E0) GO TO 60 - 10 IF (ABS(DET(1)) .GE. 1.0E0) GO TO 20 - DET(1) = TEN*DET(1) - DET(2) = DET(2) - 1.0E0 - GO TO 10 - 20 CONTINUE - 30 IF (ABS(DET(1)) .LT. TEN) GO TO 40 - DET(1) = DET(1)/TEN - DET(2) = DET(2) + 1.0E0 - GO TO 30 - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE - RETURN - END diff --git a/slatec/sgbfa.f b/slatec/sgbfa.f deleted file mode 100644 index 38e5859..0000000 --- a/slatec/sgbfa.f +++ /dev/null @@ -1,187 +0,0 @@ -*DECK SGBFA - SUBROUTINE SGBFA (ABD, LDA, N, ML, MU, IPVT, INFO) -C***BEGIN PROLOGUE SGBFA -C***PURPOSE Factor a band matrix using Gaussian elimination. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2A2 -C***TYPE SINGLE PRECISION (SGBFA-S, DGBFA-D, CGBFA-C) -C***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C SGBFA factors a real band matrix by elimination. -C -C SGBFA is usually called by SBGCO, but it can be called -C directly with a saving in time if RCOND is not needed. -C -C On Entry -C -C ABD REAL(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 SGBSL will divide by zero if -C called. Use RCOND in SBGCO 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 = MAX(1, J-MU) -C I2 = MIN(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***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED ISAMAX, SAXPY, SSCAL -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SGBFA - INTEGER LDA,N,ML,MU,IPVT(*),INFO - REAL ABD(LDA,*) -C - REAL T - INTEGER I,ISAMAX,I0,J,JU,JZ,J0,J1,K,KP1,L,LM,M,MM,NM1 -C -C***FIRST EXECUTABLE STATEMENT SGBFA - M = ML + MU + 1 - INFO = 0 -C -C ZERO INITIAL FILL-IN COLUMNS -C - J0 = MU + 2 - J1 = MIN(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.0E0 - 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.0E0 - 40 CONTINUE - 50 CONTINUE -C -C FIND L = PIVOT INDEX -C - LM = MIN(ML,N-K) - L = ISAMAX(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.0E0) 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.0E0/ABD(M,K) - CALL SSCAL(LM,T,ABD(M+1,K),1) -C -C ROW ELIMINATION WITH COLUMN INDEXING -C - JU = MIN(MAX(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 SAXPY(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.0E0) INFO = N - RETURN - END diff --git a/slatec/sgbmv.f b/slatec/sgbmv.f deleted file mode 100644 index 30bad65..0000000 --- a/slatec/sgbmv.f +++ /dev/null @@ -1,307 +0,0 @@ -*DECK SGBMV - SUBROUTINE SGBMV (TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY) -C***BEGIN PROLOGUE SGBMV -C***PURPOSE Multiply a real vector by a real general band matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE SINGLE PRECISION (SGBMV-S, DGBMV-D, CGBMV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C SGBMV performs one of the matrix-vector operations -C -C y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, -C -C where alpha and beta are scalars, x and y are vectors and A is an -C m by n band matrix, with kl sub-diagonals and ku super-diagonals. -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the operation to be performed as -C follows: -C -C TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -C -C TRANS = 'T' or 't' y := alpha*A'*x + beta*y. -C -C TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. -C -C Unchanged on exit. -C -C M - INTEGER. -C On entry, M specifies the number of rows of the matrix A. -C M must be at least zero. -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the number of columns of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C KL - INTEGER. -C On entry, KL specifies the number of sub-diagonals of the -C matrix A. KL must satisfy 0 .le. KL. -C Unchanged on exit. -C -C KU - INTEGER. -C On entry, KU specifies the number of super-diagonals of the -C matrix A. KU must satisfy 0 .le. KU. -C Unchanged on exit. -C -C ALPHA - REAL . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C A - REAL array of DIMENSION ( LDA, n ). -C Before entry, the leading ( kl + ku + 1 ) by n part of the -C array A must contain the matrix of coefficients, supplied -C column by column, with the leading diagonal of the matrix in -C row ( ku + 1 ) of the array, the first super-diagonal -C starting at position 2 in row ku, the first sub-diagonal -C starting at position 1 in row ( ku + 2 ), and so on. -C Elements in the array A that do not correspond to elements -C in the band matrix (such as the top left ku by ku triangle) -C are not referenced. -C The following program segment will transfer a band matrix -C from conventional full matrix storage to band storage: -C -C DO 20, J = 1, N -C K = KU + 1 - J -C DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) -C A( K + I, J ) = matrix( I, J ) -C 10 CONTINUE -C 20 CONTINUE -C -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C ( kl + ku + 1 ). -C Unchanged on exit. -C -C X - REAL array of DIMENSION at least -C ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -C and at least -C ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -C Before entry, the incremented array X must contain the -C vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C BETA - REAL . -C On entry, BETA specifies the scalar beta. When BETA is -C supplied as zero then Y need not be set on input. -C Unchanged on exit. -C -C Y - REAL array of DIMENSION at least -C ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -C and at least -C ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -C Before entry, the incremented array Y must contain the -C vector y. On exit, Y is overwritten by the updated vector y. -C -C INCY - INTEGER. -C On entry, INCY specifies the increment for the elements of -C Y. INCY must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE SGBMV -C .. Scalar Arguments .. - REAL ALPHA, BETA - INTEGER INCX, INCY, KL, KU, LDA, M, N - CHARACTER*1 TRANS -C .. Array Arguments .. - REAL A( LDA, * ), X( * ), Y( * ) - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -C .. Local Scalars .. - REAL TEMP - INTEGER I, INFO, IX, IY, J, JX, JY, K, KUP1, KX, KY, - $ LENX, LENY -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C***FIRST EXECUTABLE STATEMENT SGBMV -C -C Test the input parameters. -C - 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( 'SGBMV ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C Set LENX and LENY, the lengths of the vectors x and y, and set -C up the start points in X and Y. -C - 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 -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through the band part of A. -C -C First form y := beta*y. -C - 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 -C -C Form y := alpha*A*x + y. -C - 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 -C -C Form y := alpha*A'*x + y. -C - 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 -C - RETURN -C -C End of SGBMV . -C - END diff --git a/slatec/sgbsl.f b/slatec/sgbsl.f deleted file mode 100644 index a20f9f7..0000000 --- a/slatec/sgbsl.f +++ /dev/null @@ -1,149 +0,0 @@ -*DECK SGBSL - SUBROUTINE SGBSL (ABD, LDA, N, ML, MU, IPVT, B, JOB) -C***BEGIN PROLOGUE SGBSL -C***PURPOSE Solve the real band system A*X=B or TRANS(A)*X=B using -C the factors computed by SGBCO or SGBFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2A2 -C***TYPE SINGLE PRECISION (SGBSL-S, DGBSL-D, CGBSL-C) -C***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C SGBSL solves the real band system -C A * X = B or TRANS(A) * X = B -C using the factors computed by SBGCO or SGBFA. -C -C On Entry -C -C ABD REAL(LDA, N) -C the output from SBGCO or SGBFA. -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 SBGCO or SGBFA. -C -C B REAL(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 SBGCO has set RCOND .GT. 0.0 -C or SGBFA has set INFO .EQ. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL SBGCO(ABD,LDA,N,ML,MU,IPVT,RCOND,Z) -C If (RCOND is too small) GO TO ... -C DO 10 J = 1, P -C CALL SGBSL(ABD,LDA,N,ML,MU,IPVT,C(1,J),0) -C 10 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SAXPY, SDOT -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SGBSL - INTEGER LDA,N,ML,MU,IPVT(*),JOB - REAL ABD(LDA,*),B(*) -C - REAL SDOT,T - INTEGER K,KB,L,LA,LB,LM,M,NM1 -C***FIRST EXECUTABLE STATEMENT SGBSL - 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 = MIN(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 SAXPY(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 = MIN(K,M) - 1 - LA = M - LM - LB = K - LM - T = -B(K) - CALL SAXPY(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 = MIN(K,M) - 1 - LA = M - LM - LB = K - LM - T = SDOT(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 = MIN(ML,N-K) - B(K) = B(K) + SDOT(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/slatec/sgeco.f b/slatec/sgeco.f deleted file mode 100644 index ded72fe..0000000 --- a/slatec/sgeco.f +++ /dev/null @@ -1,207 +0,0 @@ -*DECK SGECO - SUBROUTINE SGECO (A, LDA, N, IPVT, RCOND, Z) -C***BEGIN PROLOGUE SGECO -C***PURPOSE Factor a matrix using Gaussian elimination and estimate -C the condition number of the matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2A1 -C***TYPE SINGLE PRECISION (SGECO-S, DGECO-D, CGECO-C) -C***KEYWORDS CONDITION NUMBER, GENERAL MATRIX, LINEAR ALGEBRA, LINPACK, -C MATRIX FACTORIZATION -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C SGECO factors a real matrix by Gaussian elimination -C and estimates the condition of the matrix. -C -C If RCOND is not needed, SGEFA is slightly faster. -C To solve A*X = B , follow SGECO by SGESL. -C To compute INVERSE(A)*C , follow SGECO by SGESL. -C To compute DETERMINANT(A) , follow SGECO by SGEDI. -C To compute INVERSE(A) , follow SGECO by SGEDI. -C -C On Entry -C -C A REAL(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 REAL -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 REAL(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***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SASUM, SAXPY, SDOT, SGEFA, SSCAL -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SGECO - INTEGER LDA,N,IPVT(*) - REAL A(LDA,*),Z(*) - REAL RCOND -C - REAL SDOT,EK,T,WK,WKM - REAL ANORM,S,SASUM,SM,YNORM - INTEGER INFO,J,K,KB,KP1,L -C -C COMPUTE 1-NORM OF A -C -C***FIRST EXECUTABLE STATEMENT SGECO - ANORM = 0.0E0 - DO 10 J = 1, N - ANORM = MAX(ANORM,SASUM(N,A(1,J),1)) - 10 CONTINUE -C -C FACTOR -C - CALL SGEFA(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.0E0 - DO 20 J = 1, N - Z(J) = 0.0E0 - 20 CONTINUE - DO 100 K = 1, N - IF (Z(K) .NE. 0.0E0) EK = SIGN(EK,-Z(K)) - IF (ABS(EK-Z(K)) .LE. ABS(A(K,K))) GO TO 30 - S = ABS(A(K,K))/ABS(EK-Z(K)) - CALL SSCAL(N,S,Z,1) - EK = S*EK - 30 CONTINUE - WK = EK - Z(K) - WKM = -EK - Z(K) - S = ABS(WK) - SM = ABS(WKM) - IF (A(K,K) .EQ. 0.0E0) GO TO 40 - WK = WK/A(K,K) - WKM = WKM/A(K,K) - GO TO 50 - 40 CONTINUE - WK = 1.0E0 - WKM = 1.0E0 - 50 CONTINUE - KP1 = K + 1 - IF (KP1 .GT. N) GO TO 90 - DO 60 J = KP1, N - SM = SM + ABS(Z(J)+WKM*A(K,J)) - Z(J) = Z(J) + WK*A(K,J) - S = S + ABS(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.0E0/SASUM(N,Z,1) - CALL SSCAL(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) + SDOT(N-K,A(K+1,K),1,Z(K+1),1) - IF (ABS(Z(K)) .LE. 1.0E0) GO TO 110 - S = 1.0E0/ABS(Z(K)) - CALL SSCAL(N,S,Z,1) - 110 CONTINUE - L = IPVT(K) - T = Z(L) - Z(L) = Z(K) - Z(K) = T - 120 CONTINUE - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) -C - YNORM = 1.0E0 -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 SAXPY(N-K,T,A(K+1,K),1,Z(K+1),1) - IF (ABS(Z(K)) .LE. 1.0E0) GO TO 130 - S = 1.0E0/ABS(Z(K)) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM - 130 CONTINUE - 140 CONTINUE - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE U*Z = V -C - DO 160 KB = 1, N - K = N + 1 - KB - IF (ABS(Z(K)) .LE. ABS(A(K,K))) GO TO 150 - S = ABS(A(K,K))/ABS(Z(K)) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM - 150 CONTINUE - IF (A(K,K) .NE. 0.0E0) Z(K) = Z(K)/A(K,K) - IF (A(K,K) .EQ. 0.0E0) Z(K) = 1.0E0 - T = -Z(K) - CALL SAXPY(K-1,T,A(1,K),1,Z(1),1) - 160 CONTINUE -C MAKE ZNORM = 1.0 - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM -C - IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM - IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0 - RETURN - END diff --git a/slatec/sgedi.f b/slatec/sgedi.f deleted file mode 100644 index 13fd504..0000000 --- a/slatec/sgedi.f +++ /dev/null @@ -1,140 +0,0 @@ -*DECK SGEDI - SUBROUTINE SGEDI (A, LDA, N, IPVT, DET, WORK, JOB) -C***BEGIN PROLOGUE SGEDI -C***PURPOSE Compute the determinant and inverse of a matrix using the -C factors computed by SGECO or SGEFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2A1, D3A1 -C***TYPE SINGLE PRECISION (SGEDI-S, DGEDI-D, CGEDI-C) -C***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C SGEDI computes the determinant and inverse of a matrix -C using the factors computed by SGECO or SGEFA. -C -C On Entry -C -C A REAL(LDA, N) -C the output from SGECO or SGEFA. -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 SGECO or SGEFA. -C -C WORK REAL(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 REAL(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. ABS(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 SGECO has set RCOND .GT. 0.0 or SGEFA has set -C INFO .EQ. 0 . -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SAXPY, SSCAL, SSWAP -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SGEDI - INTEGER LDA,N,IPVT(*),JOB - REAL A(LDA,*),DET(2),WORK(*) -C - REAL T - REAL TEN - INTEGER I,J,K,KB,KP1,L,NM1 -C***FIRST EXECUTABLE STATEMENT SGEDI -C -C COMPUTE DETERMINANT -C - IF (JOB/10 .EQ. 0) GO TO 70 - DET(1) = 1.0E0 - DET(2) = 0.0E0 - TEN = 10.0E0 - DO 50 I = 1, N - IF (IPVT(I) .NE. I) DET(1) = -DET(1) - DET(1) = A(I,I)*DET(1) - IF (DET(1) .EQ. 0.0E0) GO TO 60 - 10 IF (ABS(DET(1)) .GE. 1.0E0) GO TO 20 - DET(1) = TEN*DET(1) - DET(2) = DET(2) - 1.0E0 - GO TO 10 - 20 CONTINUE - 30 IF (ABS(DET(1)) .LT. TEN) GO TO 40 - DET(1) = DET(1)/TEN - DET(2) = DET(2) + 1.0E0 - 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.0E0/A(K,K) - T = -A(K,K) - CALL SSCAL(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.0E0 - CALL SAXPY(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.0E0 - 110 CONTINUE - DO 120 J = KP1, N - T = WORK(J) - CALL SAXPY(N,T,A(1,J),1,A(1,K),1) - 120 CONTINUE - L = IPVT(K) - IF (L .NE. K) CALL SSWAP(N,A(1,K),1,A(1,L),1) - 130 CONTINUE - 140 CONTINUE - 150 CONTINUE - RETURN - END diff --git a/slatec/sgeev.f b/slatec/sgeev.f deleted file mode 100644 index 9604b48..0000000 --- a/slatec/sgeev.f +++ /dev/null @@ -1,184 +0,0 @@ -*DECK SGEEV - SUBROUTINE SGEEV (A, LDA, N, E, V, LDV, WORK, JOB, INFO) -C***BEGIN PROLOGUE SGEEV -C***PURPOSE Compute the eigenvalues and, optionally, the eigenvectors -C of a real general matrix. -C***LIBRARY SLATEC -C***CATEGORY D4A2 -C***TYPE SINGLE PRECISION (SGEEV-S, CGEEV-C) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, GENERAL MATRIX -C***AUTHOR Kahaner, D. K., (NBS) -C Moler, C. B., (U. of New Mexico) -C Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C Abstract -C SGEEV computes the eigenvalues and, optionally, -C the eigenvectors of a general real matrix. -C -C Call Sequence Parameters- -C (The values of parameters marked with * (star) will be changed -C by SGEEV.) -C -C A* REAL(LDA,N) -C real nonsymmetric input matrix. -C -C LDA INTEGER -C set by the user to -C the leading dimension of the real array A. -C -C N INTEGER -C set by the user to -C the order of the matrices A and V, and -C the number of elements in E. -C -C E* COMPLEX(N) -C on return from SGEEV, E contains the eigenvalues of A. -C See also INFO below. -C -C V* COMPLEX(LDV,N) -C on return from SGEEV, if the user has set JOB -C = 0 V is not referenced. -C = nonzero the N eigenvectors of A are stored in the -C first N columns of V. See also INFO below. -C (Note that if the input matrix A is nearly degenerate, -C V may be badly conditioned, i.e., may have nearly -C dependent columns.) -C -C LDV INTEGER -C set by the user to -C the leading dimension of the array V if JOB is also -C set nonzero. In that case, N must be .LE. LDV. -C If JOB is set to zero, LDV is not referenced. -C -C WORK* REAL(2N) -C temporary storage vector. Contents changed by SGEEV. -C -C JOB INTEGER -C set by the user to -C = 0 eigenvalues only to be calculated by SGEEV. -C Neither V nor LDV is referenced. -C = nonzero eigenvalues and vectors to be calculated. -C In this case, A & V must be distinct arrays. -C Also, if LDA .GT. LDV, SGEEV changes all the -C elements of A thru column N. If LDA < LDV, -C SGEEV changes all the elements of V through -C column N. If LDA = LDV, only A(I,J) and V(I, -C J) for I,J = 1,...,N are changed by SGEEV. -C -C INFO* INTEGER -C on return from SGEEV the value of INFO is -C = 0 normal return, calculation successful. -C = K if the eigenvalue iteration fails to converge, -C eigenvalues K+1 through N are correct, but -C no eigenvectors were computed even if they were -C requested (JOB nonzero). -C -C Error Messages -C No. 1 recoverable N is greater than LDA -C No. 2 recoverable N is less than one. -C No. 3 recoverable JOB is nonzero and N is greater than LDV -C No. 4 warning LDA > LDV, elements of A other than the -C N by N input elements have been changed. -C No. 5 warning LDA < LDV, elements of V other than the -C N x N output elements have been changed. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED BALANC, BALBAK, HQR, HQR2, ORTHES, ORTRAN, SCOPY, -C SCOPYM, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800808 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE SGEEV - INTEGER I,IHI,ILO,INFO,J,JB,JOB,K,KM,KP,L,LDA,LDV, - 1 MDIM,N - REAL A(*),E(*),WORK(*),V(*) -C***FIRST EXECUTABLE STATEMENT SGEEV - IF (N .GT. LDA) CALL XERMSG ('SLATEC', 'SGEEV', 'N .GT. LDA.', 1, - + 1) - IF (N .GT. LDA) RETURN - IF (N .LT. 1) CALL XERMSG ('SLATEC', 'SGEEV', 'N .LT. 1', 2, 1) - IF(N .LT. 1) RETURN - IF(N .EQ. 1 .AND. JOB .EQ. 0) GO TO 35 - MDIM = LDA - IF(JOB .EQ. 0) GO TO 5 - IF (N .GT. LDV) CALL XERMSG ('SLATEC', 'SGEEV', - + 'JOB .NE. 0 AND N .GT. LDV.', 3, 1) - IF(N .GT. LDV) RETURN - IF(N .EQ. 1) GO TO 35 -C -C REARRANGE A IF NECESSARY WHEN LDA.GT.LDV AND JOB .NE.0 -C - MDIM = MIN(LDA,LDV) - IF (LDA .LT. LDV) CALL XERMSG ('SLATEC', 'SGEEV', - + 'LDA.LT.LDV, ELEMENTS OF V OTHER THAN THE N BY N OUTPUT ' // - + 'ELEMENTS HAVE BEEN CHANGED.', 5, 0) - IF(LDA.LE.LDV) GO TO 5 - CALL XERMSG ('SLATEC', 'SGEEV', - + 'LDA.GT.LDV, ELEMENTS OF A OTHER THAN THE N BY N INPUT ' // - + 'ELEMENTS HAVE BEEN CHANGED.', 4, 0) - L = N - 1 - DO 4 J=1,L - M = 1+J*LDV - K = 1+J*LDA - CALL SCOPY(N,A(K),1,A(M),1) - 4 CONTINUE - 5 CONTINUE -C -C SCALE AND ORTHOGONAL REDUCTION TO HESSENBERG. -C - CALL BALANC(MDIM,N,A,ILO,IHI,WORK(1)) - CALL ORTHES(MDIM,N,ILO,IHI,A,WORK(N+1)) - IF(JOB .NE. 0) GO TO 10 -C -C EIGENVALUES ONLY -C - CALL HQR(LDA,N,ILO,IHI,A,E(1),E(N+1),INFO) - GO TO 30 -C -C EIGENVALUES AND EIGENVECTORS. -C - 10 CALL ORTRAN(MDIM,N,ILO,IHI,A,WORK(N+1),V) - CALL HQR2(MDIM,N,ILO,IHI,A,E(1),E(N+1),V,INFO) - IF (INFO .NE. 0) GO TO 30 - CALL BALBAK(MDIM,N,ILO,IHI,WORK(1),N,V) -C -C CONVERT EIGENVECTORS TO COMPLEX STORAGE. -C - DO 20 JB = 1,N - J=N+1-JB - I=N+J - K=(J-1)*MDIM+1 - KP=K+MDIM - KM=K-MDIM - IF(E(I).GE.0.0E0) CALL SCOPY(N,V(K),1,WORK(1),2) - IF(E(I).LT.0.0E0) CALL SCOPY(N,V(KM),1,WORK(1),2) - IF(E(I).EQ.0.0E0) CALL SCOPY(N,0.0E0,0,WORK(2),2) - IF(E(I).GT.0.0E0) CALL SCOPY(N,V(KP),1,WORK(2),2) - IF(E(I).LT.0.0E0) CALL SCOPYM(N,V(K),1,WORK(2),2) - L=2*(J-1)*LDV+1 - CALL SCOPY(2*N,WORK(1),1,V(L),1) - 20 CONTINUE -C -C CONVERT EIGENVALUES TO COMPLEX STORAGE. -C - 30 CALL SCOPY(N,E(1),1,WORK(1),1) - CALL SCOPY(N,E(N+1),1,E(2),2) - CALL SCOPY(N,WORK(1),1,E(1),2) - RETURN -C -C TAKE CARE OF N=1 CASE -C - 35 E(1) = A(1) - E(2) = 0.E0 - INFO = 0 - IF(JOB .EQ. 0) RETURN - V(1) = A(1) - V(2) = 0.E0 - RETURN - END diff --git a/slatec/sgefa.f b/slatec/sgefa.f deleted file mode 100644 index c4d3a0f..0000000 --- a/slatec/sgefa.f +++ /dev/null @@ -1,117 +0,0 @@ -*DECK SGEFA - SUBROUTINE SGEFA (A, LDA, N, IPVT, INFO) -C***BEGIN PROLOGUE SGEFA -C***PURPOSE Factor a matrix using Gaussian elimination. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2A1 -C***TYPE SINGLE PRECISION (SGEFA-S, DGEFA-D, CGEFA-C) -C***KEYWORDS GENERAL MATRIX, LINEAR ALGEBRA, LINPACK, -C MATRIX FACTORIZATION -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C SGEFA factors a real matrix by Gaussian elimination. -C -C SGEFA is usually called by SGECO, but it can be called -C directly with a saving in time if RCOND is not needed. -C (Time for SGECO) = (1 + 9/N)*(Time for SGEFA) . -C -C On Entry -C -C A REAL(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 SGESL or SGEDI will divide by zero -C if called. Use RCOND in SGECO for a reliable -C indication of singularity. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED ISAMAX, SAXPY, SSCAL -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SGEFA - INTEGER LDA,N,IPVT(*),INFO - REAL A(LDA,*) -C - REAL T - INTEGER ISAMAX,J,K,KP1,L,NM1 -C -C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING -C -C***FIRST EXECUTABLE STATEMENT SGEFA - 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 = ISAMAX(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.0E0) 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.0E0/A(K,K) - CALL SSCAL(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 SAXPY(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.0E0) INFO = N - RETURN - END diff --git a/slatec/sgefs.f b/slatec/sgefs.f deleted file mode 100644 index 7f8b6be..0000000 --- a/slatec/sgefs.f +++ /dev/null @@ -1,164 +0,0 @@ -*DECK SGEFS - SUBROUTINE SGEFS (A, LDA, N, V, ITASK, IND, WORK, IWORK) -C***BEGIN PROLOGUE SGEFS -C***PURPOSE Solve a general system of linear equations. -C***LIBRARY SLATEC -C***CATEGORY D2A1 -C***TYPE SINGLE PRECISION (SGEFS-S, DGEFS-D, CGEFS-C) -C***KEYWORDS COMPLEX LINEAR EQUATIONS, GENERAL MATRIX, -C GENERAL SYSTEM OF LINEAR EQUATIONS -C***AUTHOR Voorhees, E. A., (LANL) -C***DESCRIPTION -C -C Subroutine SGEFS solves a general NxN system of single -C precision linear equations using LINPACK subroutines SGECO -C and SGESL. That is, if A is an NxN real matrix and if X -C and B are real N-vectors, then SGEFS solves the equation -C -C A*X=B. -C -C The matrix A is first factored into upper and lower tri- -C angular matrices U and L using partial pivoting. These -C factors and the pivoting information are used to find the -C solution vector X. An approximate condition number is -C calculated to provide a rough estimate of the number of -C digits of accuracy in the computed solution. -C -C If the equation A*X=B is to be solved for more than one vector -C B, the factoring of A does not need to be performed again and -C the option to only solve (ITASK .GT. 1) will be faster for -C the succeeding solutions. In this case, the contents of A, -C LDA, N and IWORK must not have been altered by the user follow- -C ing factorization (ITASK=1). IND will not be changed by SGEFS -C in this case. -C -C Argument Description *** -C -C A REAL(LDA,N) -C on entry, the doubly subscripted array with dimension -C (LDA,N) which contains the coefficient matrix. -C on return, an upper triangular matrix U and the -C multipliers necessary to construct a matrix L -C so that A=L*U. -C LDA INTEGER -C the leading dimension of the array A. LDA must be great- -C er than or equal to N. (terminal error message IND=-1) -C N INTEGER -C the order of the matrix A. The first N elements of -C the array A are the elements of the first column of -C the matrix A. N must be greater than or equal to 1. -C (terminal error message IND=-2) -C V REAL(N) -C on entry, the singly subscripted array(vector) of di- -C mension N which contains the right hand side B of a -C system of simultaneous linear equations A*X=B. -C on return, V contains the solution vector, X . -C ITASK INTEGER -C If ITASK=1, the matrix A is factored and then the -C linear equation is solved. -C If ITASK .GT. 1, the equation is solved using the existing -C factored matrix A and IWORK. -C If ITASK .LT. 1, then terminal error message IND=-3 is -C printed. -C IND INTEGER -C GT. 0 IND is a rough estimate of the number of digits -C of accuracy in the solution, X. -C LT. 0 see error message corresponding to IND below. -C WORK REAL(N) -C a singly subscripted array of dimension at least N. -C IWORK INTEGER(N) -C a singly subscripted array of dimension at least N. -C -C Error Messages Printed *** -C -C IND=-1 terminal N is greater than LDA. -C IND=-2 terminal N is less than 1. -C IND=-3 terminal ITASK is less than 1. -C IND=-4 terminal The matrix A is computationally singular. -C A solution has not been computed. -C IND=-10 warning The solution has no apparent significance. -C The solution may be inaccurate or the matrix -C A may be poorly scaled. -C -C Note- The above terminal(*fatal*) error messages are -C designed to be handled by XERMSG in which -C LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 -C for warning error messages from XERMSG. Unless -C the user provides otherwise, an error message -C will be printed followed by an abort. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED R1MACH, SGECO, SGESL, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800317 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 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 SGEFS -C - INTEGER LDA,N,ITASK,IND,IWORK(*) - REAL A(LDA,*),V(*),WORK(*),R1MACH - REAL RCOND - CHARACTER*8 XERN1, XERN2 -C***FIRST EXECUTABLE STATEMENT SGEFS - IF (LDA.LT.N) THEN - IND = -1 - WRITE (XERN1, '(I8)') LDA - WRITE (XERN2, '(I8)') N - CALL XERMSG ('SLATEC', 'SGEFS', 'LDA = ' // XERN1 // - * ' IS LESS THAN N = ' // XERN2, -1, 1) - RETURN - ENDIF -C - IF (N.LE.0) THEN - IND = -2 - WRITE (XERN1, '(I8)') N - CALL XERMSG ('SLATEC', 'SGEFS', 'N = ' // XERN1 // - * ' IS LESS THAN 1', -2, 1) - RETURN - ENDIF -C - IF (ITASK.LT.1) THEN - IND = -3 - WRITE (XERN1, '(I8)') ITASK - CALL XERMSG ('SLATEC', 'SGEFS', 'ITASK = ' // XERN1 // - * ' IS LESS THAN 1', -3, 1) - RETURN - ENDIF -C - IF (ITASK.EQ.1) THEN -C -C FACTOR MATRIX A INTO LU -C - CALL SGECO(A,LDA,N,IWORK,RCOND,WORK) -C -C CHECK FOR COMPUTATIONALLY SINGULAR MATRIX -C - IF (RCOND.EQ.0.0) THEN - IND = -4 - CALL XERMSG ('SLATEC', 'SGEFS', - * 'SINGULAR MATRIX A - NO SOLUTION', -4, 1) - RETURN - ENDIF -C -C COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) -C AND CHECK FOR IND GREATER THAN ZERO -C - IND = -LOG10(R1MACH(4)/RCOND) - IF (IND.LE.0) THEN - IND=-10 - CALL XERMSG ('SLATEC', 'SGEFS', - * 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) - ENDIF - ENDIF -C -C SOLVE AFTER FACTORING -C - CALL SGESL(A,LDA,N,IWORK,V,0) - RETURN - END diff --git a/slatec/sgeir.f b/slatec/sgeir.f deleted file mode 100644 index 78646c0..0000000 --- a/slatec/sgeir.f +++ /dev/null @@ -1,198 +0,0 @@ -*DECK SGEIR - SUBROUTINE SGEIR (A, LDA, N, V, ITASK, IND, WORK, IWORK) -C***BEGIN PROLOGUE SGEIR -C***PURPOSE Solve a general system of linear equations. Iterative -C refinement is used to obtain an error estimate. -C***LIBRARY SLATEC -C***CATEGORY D2A1 -C***TYPE SINGLE PRECISION (SGEIR-S, CGEIR-C) -C***KEYWORDS COMPLEX LINEAR EQUATIONS, GENERAL MATRIX, -C GENERAL SYSTEM OF LINEAR EQUATIONS -C***AUTHOR Voorhees, E. A., (LANL) -C***DESCRIPTION -C -C Subroutine SGEIR solves a general NxN system of single -C precision linear equations using LINPACK subroutines SGEFA and -C SGESL. One pass of iterative refinement is used only to obtain -C an estimate of the accuracy. That is, if A is an NxN real -C matrix and if X and B are real N-vectors, then SGEIR solves -C the equation -C -C A*X=B. -C -C The matrix A is first factored into upper and lower tri- -C angular matrices U and L using partial pivoting. These -C factors and the pivoting information are used to calculate -C the solution, X. Then the residual vector is found and -C used to calculate an estimate of the relative error, IND. -C IND estimates the accuracy of the solution only when the -C input matrix and the right hand side are represented -C exactly in the computer and does not take into account -C any errors in the input data. -C -C If the equation A*X=B is to be solved for more than one vector -C B, the factoring of A does not need to be performed again and -C the option to solve only (ITASK .GT. 1) will be faster for -C the succeeding solutions. In this case, the contents of A, -C LDA, N, WORK, and IWORK must not have been altered by the -C user following factorization (ITASK=1). IND will not be -C changed by SGEIR in this case. -C -C Argument Description *** -C -C A REAL(LDA,N) -C the doubly subscripted array with dimension (LDA,N) -C which contains the coefficient matrix. A is not -C altered by the routine. -C LDA INTEGER -C the leading dimension of the array A. LDA must be great- -C er than or equal to N. (terminal error message IND=-1) -C N INTEGER -C the order of the matrix A. The first N elements of -C the array A are the elements of the first column of -C matrix A. N must be greater than or equal to 1. -C (terminal error message IND=-2) -C V REAL(N) -C on entry, the singly subscripted array(vector) of di- -C mension N which contains the right hand side B of a -C system of simultaneous linear equations A*X=B. -C on return, V contains the solution vector, X . -C ITASK INTEGER -C If ITASK=1, the matrix A is factored and then the -C linear equation is solved. -C If ITASK .GT. 1, the equation is solved using the existing -C factored matrix A (stored in WORK). -C If ITASK .LT. 1, then terminal error message IND=-3 is -C printed. -C IND INTEGER -C GT. 0 IND is a rough estimate of the number of digits -C of accuracy in the solution, X. IND=75 means -C that the solution vector X is zero. -C LT. 0 see error message corresponding to IND below. -C WORK REAL(N*(N+1)) -C a singly subscripted array of dimension at least N*(N+1). -C IWORK INTEGER(N) -C a singly subscripted array of dimension at least N. -C -C Error Messages Printed *** -C -C IND=-1 terminal N is greater than LDA. -C IND=-2 terminal N is less than one. -C IND=-3 terminal ITASK is less than one. -C IND=-4 terminal The matrix A is computationally singular. -C A solution has not been computed. -C IND=-10 warning The solution has no apparent significance. -C The solution may be inaccurate or the matrix -C A may be poorly scaled. -C -C Note- The above terminal(*fatal*) error messages are -C designed to be handled by XERMSG in which -C LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 -C for warning error messages from XERMSG. Unless -C the user provides otherwise, an error message -C will be printed followed by an abort. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED R1MACH, SASUM, SCOPY, SDSDOT, SGEFA, SGESL, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800430 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 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 SGEIR -C - INTEGER LDA,N,ITASK,IND,IWORK(*),INFO,J - REAL A(LDA,*),V(*),WORK(N,*),XNORM,DNORM,SDSDOT,SASUM,R1MACH - CHARACTER*8 XERN1, XERN2 -C***FIRST EXECUTABLE STATEMENT SGEIR - IF (LDA.LT.N) THEN - IND = -1 - WRITE (XERN1, '(I8)') LDA - WRITE (XERN2, '(I8)') N - CALL XERMSG ('SLATEC', 'SGEIR', 'LDA = ' // XERN1 // - * ' IS LESS THAN N = ' // XERN2, -1, 1) - RETURN - ENDIF -C - IF (N.LE.0) THEN - IND = -2 - WRITE (XERN1, '(I8)') N - CALL XERMSG ('SLATEC', 'SGEIR', 'N = ' // XERN1 // - * ' IS LESS THAN 1', -2, 1) - RETURN - ENDIF -C - IF (ITASK.LT.1) THEN - IND = -3 - WRITE (XERN1, '(I8)') ITASK - CALL XERMSG ('SLATEC', 'SGEIR', 'ITASK = ' // XERN1 // - * ' IS LESS THAN 1', -3, 1) - RETURN - ENDIF -C - IF (ITASK.EQ.1) THEN -C -C MOVE MATRIX A TO WORK -C - DO 10 J=1,N - CALL SCOPY(N,A(1,J),1,WORK(1,J),1) - 10 CONTINUE -C -C FACTOR MATRIX A INTO LU -C - CALL SGEFA(WORK,N,N,IWORK,INFO) -C -C CHECK FOR COMPUTATIONALLY SINGULAR MATRIX -C - IF (INFO.NE.0) THEN - IND = -4 - CALL XERMSG ('SLATEC', 'SGEIR', - * 'SINGULAR MATRIX A - NO SOLUTION', -4, 1) - RETURN - ENDIF - ENDIF -C -C SOLVE WHEN FACTORING COMPLETE -C MOVE VECTOR B TO WORK -C - CALL SCOPY(N,V(1),1,WORK(1,N+1),1) - CALL SGESL(WORK,N,N,IWORK,V,0) -C -C FORM NORM OF X0 -C - XNORM=SASUM(N,V(1),1) - IF (XNORM.EQ.0.0) THEN - IND = 75 - RETURN - ENDIF -C -C COMPUTE RESIDUAL -C - DO 40 J=1,N - WORK(J,N+1) = SDSDOT(N,-WORK(J,N+1),A(J,1),LDA,V,1) - 40 CONTINUE -C -C SOLVE A*DELTA=R -C - CALL SGESL(WORK,N,N,IWORK,WORK(1,N+1),0) -C -C FORM NORM OF DELTA -C - DNORM = SASUM(N,WORK(1,N+1),1) -C -C COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) -C AND CHECK FOR IND GREATER THAN ZERO -C - IND = -LOG10(MAX(R1MACH(4),DNORM/XNORM)) - IF (IND.LE.0) THEN - IND = -10 - CALL XERMSG ('SLATEC', 'SGEIR', - * 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) - ENDIF - RETURN - END diff --git a/slatec/sgemm.f b/slatec/sgemm.f deleted file mode 100644 index 2baf21c..0000000 --- a/slatec/sgemm.f +++ /dev/null @@ -1,319 +0,0 @@ -*DECK SGEMM - SUBROUTINE SGEMM (TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC) -C***BEGIN PROLOGUE SGEMM -C***PURPOSE Multiply a real general matrix by a real general matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B6 -C***TYPE SINGLE PRECISION (SGEMM-S, DGEMM-D, CGEMM-C) -C***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J., (ANL) -C Duff, I., (AERE) -C Du Croz, J., (NAG) -C Hammarling, S. (NAG) -C***DESCRIPTION -C -C SGEMM performs one of the matrix-matrix operations -C -C C := alpha*op( A )*op( B ) + beta*C, -C -C where op( X ) is one of -C -C op( X ) = X or op( X ) = X', -C -C alpha and beta are scalars, and A, B and C are matrices, with op( A ) -C an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. -C -C Parameters -C ========== -C -C TRANSA - CHARACTER*1. -C On entry, TRANSA specifies the form of op( A ) to be used in -C the matrix multiplication as follows: -C -C TRANSA = 'N' or 'n', op( A ) = A. -C -C TRANSA = 'T' or 't', op( A ) = A'. -C -C TRANSA = 'C' or 'c', op( A ) = A'. -C -C Unchanged on exit. -C -C TRANSB - CHARACTER*1. -C On entry, TRANSB specifies the form of op( B ) to be used in -C the matrix multiplication as follows: -C -C TRANSB = 'N' or 'n', op( B ) = B. -C -C TRANSB = 'T' or 't', op( B ) = B'. -C -C TRANSB = 'C' or 'c', op( B ) = B'. -C -C Unchanged on exit. -C -C M - INTEGER. -C On entry, M specifies the number of rows of the matrix -C op( A ) and of the matrix C. M must be at least zero. -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the number of columns of the matrix -C op( B ) and the number of columns of the matrix C. N must be -C at least zero. -C Unchanged on exit. -C -C K - INTEGER. -C On entry, K specifies the number of columns of the matrix -C op( A ) and the number of rows of the matrix op( B ). K must -C be at least zero. -C Unchanged on exit. -C -C ALPHA - REAL . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C A - REAL array of DIMENSION ( LDA, ka ), where ka is -C k when TRANSA = 'N' or 'n', and is m otherwise. -C Before entry with TRANSA = 'N' or 'n', the leading m by k -C part of the array A must contain the matrix A, otherwise -C the leading k by m part of the array A must contain the -C matrix A. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. When TRANSA = 'N' or 'n' then -C LDA must be at least max( 1, m ), otherwise LDA must be at -C least max( 1, k ). -C Unchanged on exit. -C -C B - REAL array of DIMENSION ( LDB, kb ), where kb is -C n when TRANSB = 'N' or 'n', and is k otherwise. -C Before entry with TRANSB = 'N' or 'n', the leading k by n -C part of the array B must contain the matrix B, otherwise -C the leading n by k part of the array B must contain the -C matrix B. -C Unchanged on exit. -C -C LDB - INTEGER. -C On entry, LDB specifies the first dimension of B as declared -C in the calling (sub) program. When TRANSB = 'N' or 'n' then -C LDB must be at least max( 1, k ), otherwise LDB must be at -C least max( 1, n ). -C Unchanged on exit. -C -C BETA - REAL . -C On entry, BETA specifies the scalar beta. When BETA is -C supplied as zero then C need not be set on input. -C Unchanged on exit. -C -C C - REAL array of DIMENSION ( LDC, n ). -C Before entry, the leading m by n part of the array C must -C contain the matrix C, except when beta is zero, in which -C case C need not be set on entry. -C On exit, the array C is overwritten by the m by n matrix -C ( alpha*op( A )*op( B ) + beta*C ). -C -C LDC - INTEGER. -C On entry, LDC specifies the first dimension of C as declared -C in the calling (sub) program. LDC must be at least -C max( 1, m ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. -C A set of level 3 basic linear algebra subprograms. -C ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 890208 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE SGEMM -C .. Scalar Arguments .. - CHARACTER*1 TRANSA, TRANSB - INTEGER M, N, K, LDA, LDB, LDC - REAL ALPHA, BETA -C .. Array Arguments .. - REAL A( LDA, * ), B( LDB, * ), C( LDC, * ) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Local Scalars .. - LOGICAL NOTA, NOTB - INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB - REAL TEMP -C .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -C***FIRST EXECUTABLE STATEMENT SGEMM -C -C Set NOTA and NOTB as true if A and B respectively are not -C transposed and set NROWA, NCOLA and NROWB as the number of rows -C and columns of A and the number of rows of B respectively. -C - 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 -C -C Test the input parameters. -C - 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( 'SGEMM ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C And if alpha.eq.zero. -C - 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 -C -C Start the operations. -C - IF( NOTB )THEN - IF( NOTA )THEN -C -C Form C := alpha*A*B + beta*C. -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 -C -C Form C := alpha*A'*B + beta*C -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 -C -C Form C := alpha*A*B' + beta*C -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 -C -C Form C := alpha*A'*B' + beta*C -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 -C - RETURN -C -C End of SGEMM . -C - END diff --git a/slatec/sgemv.f b/slatec/sgemv.f deleted file mode 100644 index 5d1ba4a..0000000 --- a/slatec/sgemv.f +++ /dev/null @@ -1,268 +0,0 @@ -*DECK SGEMV - SUBROUTINE SGEMV (TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, - $ INCY) -C***BEGIN PROLOGUE SGEMV -C***PURPOSE Multiply a real vector by a real general matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE SINGLE PRECISION (SGEMV-S, DGEMV-D, CGEMV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C SGEMV performs one of the matrix-vector operations -C -C y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, -C -C where alpha and beta are scalars, x and y are vectors and A is an -C m by n matrix. -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the operation to be performed as -C follows: -C -C TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -C -C TRANS = 'T' or 't' y := alpha*A'*x + beta*y. -C -C TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. -C -C Unchanged on exit. -C -C M - INTEGER. -C On entry, M specifies the number of rows of the matrix A. -C M must be at least zero. -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the number of columns of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - REAL . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C A - REAL array of DIMENSION ( LDA, n ). -C Before entry, the leading m by n part of the array A must -C contain the matrix of coefficients. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C max( 1, m ). -C Unchanged on exit. -C -C X - REAL array of DIMENSION at least -C ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -C and at least -C ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -C Before entry, the incremented array X must contain the -C vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C BETA - REAL . -C On entry, BETA specifies the scalar beta. When BETA is -C supplied as zero then Y need not be set on input. -C Unchanged on exit. -C -C Y - REAL array of DIMENSION at least -C ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -C and at least -C ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -C Before entry with BETA non-zero, the incremented array Y -C must contain the vector y. On exit, Y is overwritten by the -C updated vector y. -C -C INCY - INTEGER. -C On entry, INCY specifies the increment for the elements of -C Y. INCY must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE SGEMV -C .. Scalar Arguments .. - REAL ALPHA, BETA - INTEGER INCX, INCY, LDA, M, N - CHARACTER*1 TRANS -C .. Array Arguments .. - REAL A( LDA, * ), X( * ), Y( * ) -C .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -C .. Local Scalars .. - REAL TEMP - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C***FIRST EXECUTABLE STATEMENT SGEMV -C -C Test the input parameters. -C - 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( 'SGEMV ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C Set LENX and LENY, the lengths of the vectors x and y, and set -C up the start points in X and Y. -C - 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 -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through A. -C -C First form y := beta*y. -C - 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 -C -C Form y := alpha*A*x + y. -C - 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 -C -C Form y := alpha*A'*x + y. -C - 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 -C - RETURN -C -C End of SGEMV . -C - END diff --git a/slatec/sger.f b/slatec/sger.f deleted file mode 100644 index 8287ce8..0000000 --- a/slatec/sger.f +++ /dev/null @@ -1,164 +0,0 @@ -*DECK SGER - SUBROUTINE SGER (M, N, ALPHA, X, INCX, Y, INCY, A, LDA) -C***BEGIN PROLOGUE SGER -C***PURPOSE Perform rank 1 update of a real general matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE SINGLE PRECISION (SGER-S) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C SGER performs the rank 1 operation -C -C A := alpha*x*y' + A, -C -C where alpha is a scalar, x is an m element vector, y is an n element -C vector and A is an m by n matrix. -C -C Parameters -C ========== -C -C M - INTEGER. -C On entry, M specifies the number of rows of the matrix A. -C M must be at least zero. -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the number of columns of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - REAL . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C X - REAL array of dimension at least -C ( 1 + ( m - 1)*abs( INCX)). -C Before entry, the incremented array X must contain the m -C element vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C Y - REAL array of dimension at least -C ( 1 + ( n - 1 )*abs( INCY ) ). -C Before entry, the incremented array Y must contain the n -C element vector y. -C Unchanged on exit. -C -C INCY - INTEGER. -C On entry, INCY specifies the increment for the elements of -C Y. INCY must not be zero. -C Unchanged on exit. -C -C A - REAL array of DIMENSION ( LDA, n ). -C Before entry, the leading m by n part of the array A must -C contain the matrix of coefficients. On exit, A is -C overwritten by the updated matrix. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C max( 1, m ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE SGER -C .. Scalar Arguments .. - REAL ALPHA - INTEGER INCX, INCY, LDA, M, N -C .. Array Arguments .. - REAL A( LDA, * ), X( * ), Y( * ) -C .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0E+0 ) -C .. Local Scalars .. - REAL TEMP - INTEGER I, INFO, IX, J, JY, KX -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C***FIRST EXECUTABLE STATEMENT SGER -C -C Test the input parameters. -C - 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( 'SGER ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through A. -C - 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 -C - RETURN -C -C End of SGER . -C - END diff --git a/slatec/sgesl.f b/slatec/sgesl.f deleted file mode 100644 index 7f5d8e9..0000000 --- a/slatec/sgesl.f +++ /dev/null @@ -1,131 +0,0 @@ -*DECK SGESL - SUBROUTINE SGESL (A, LDA, N, IPVT, B, JOB) -C***BEGIN PROLOGUE SGESL -C***PURPOSE Solve the real system A*X=B or TRANS(A)*X=B using the -C factors of SGECO or SGEFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2A1 -C***TYPE SINGLE PRECISION (SGESL-S, DGESL-D, CGESL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C SGESL solves the real system -C A * X = B or TRANS(A) * X = B -C using the factors computed by SGECO or SGEFA. -C -C On Entry -C -C A REAL(LDA, N) -C the output from SGECO or SGEFA. -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 SGECO or SGEFA. -C -C B REAL(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 SGECO has set RCOND .GT. 0.0 -C or SGEFA has set INFO .EQ. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL SGECO(A,LDA,N,IPVT,RCOND,Z) -C IF (RCOND is too small) GO TO ... -C DO 10 J = 1, P -C CALL SGESL(A,LDA,N,IPVT,C(1,J),0) -C 10 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SAXPY, SDOT -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SGESL - INTEGER LDA,N,IPVT(*),JOB - REAL A(LDA,*),B(*) -C - REAL SDOT,T - INTEGER K,KB,L,NM1 -C***FIRST EXECUTABLE STATEMENT SGESL - 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 SAXPY(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 SAXPY(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 = SDOT(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) + SDOT(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/slatec/sglss.f b/slatec/sglss.f deleted file mode 100644 index 6217d0d..0000000 --- a/slatec/sglss.f +++ /dev/null @@ -1,144 +0,0 @@ -*DECK SGLSS - SUBROUTINE SGLSS (A, MDA, M, N, B, MDB, NB, RNORM, WORK, LW, - + IWORK, LIW, INFO) -C***BEGIN PROLOGUE SGLSS -C***PURPOSE Solve a linear least squares problems by performing a QR -C factorization of the matrix using Householder -C transformations. Emphasis is put on detecting possible -C rank deficiency. -C***LIBRARY SLATEC -C***CATEGORY D9, D5 -C***TYPE SINGLE PRECISION (SGLSS-S, DGLSS-D) -C***KEYWORDS LINEAR LEAST SQUARES, LQ FACTORIZATION, QR FACTORIZATION, -C UNDERDETERMINED LINEAR SYSTEMS -C***AUTHOR Manteuffel, T. A., (LANL) -C***DESCRIPTION -C -C SGLSS solves both underdetermined and overdetermined -C LINEAR systems AX = B, where A is an M by N matrix -C and B is an M by NB matrix of right hand sides. If -C M.GE.N, the least squares solution is computed by -C decomposing the matrix A into the product of an -C orthogonal matrix Q and an upper triangular matrix -C R (QR factorization). If M.LT.N, the minimal -C length solution is computed by factoring the -C matrix A into the product of a lower triangular -C matrix L and an orthogonal matrix Q (LQ factor- -C ization). If the matrix A is determined to be rank -C deficient, that is the rank of A is less than -C MIN(M,N), then the minimal length least squares -C solution is computed. -C -C SGLSS assumes full machine precision in the data. -C If more control over the uncertainty in the data -C is desired, the codes LLSIA and ULSIA are -C recommended. -C -C SGLSS requires MDA*N + (MDB + 1)*NB + 5*MIN(M,N) dimensioned -C real space and M+N dimensioned integer space. -C -C -C ****************************************************************** -C * * -C * WARNING - All input arrays are changed on exit. * -C * * -C ****************************************************************** -C SUBROUTINE SGLSS(A,MDA,M,N,B,MDB,NB,RNORM,WORK,LW,IWORK,LIW,INFO) -C -C Input.. -C -C A(,) Linear coefficient matrix of AX=B, with MDA the -C MDA,M,N actual first dimension of A in the calling program. -C M is the row dimension (no. of EQUATIONS of the -C problem) and N the col dimension (no. of UNKNOWNS). -C -C B(,) Right hand side(s), with MDB the actual first -C MDB,NB dimension of B in the calling program. NB is the -C number of M by 1 right hand sides. Must have -C MDB.GE.MAX(M,N). If NB = 0, B is never accessed. -C -C -C RNORM() Vector of length at least NB. On input the contents -C of RNORM are unused. -C -C WORK() A real work array dimensioned 5*MIN(M,N). -C -C LW Actual dimension of WORK. -C -C IWORK() Integer work array dimensioned at least N+M. -C -C LIW Actual dimension of IWORK. -C -C -C INFO A flag which provides for the efficient -C solution of subsequent problems involving the -C same A but different B. -C If INFO = 0 original call -C INFO = 1 subsequent calls -C On subsequent calls, the user must supply A, INFO, -C LW, IWORK, LIW, and the first 2*MIN(M,N) locations -C of WORK as output by the original call to SGLSS. -C -C -C Output.. -C -C A(,) Contains the triangular part of the reduced matrix -C and the transformation information. It together with -C the first 2*MIN(M,N) elements of WORK (see below) -C completely specify the factorization of A. -C -C B(,) Contains the N by NB solution matrix X. -C -C -C RNORM() Contains the Euclidean length of the NB residual -C vectors B(I)-AX(I), I=1,NB. -C -C WORK() The first 2*MIN(M,N) locations of WORK contain value -C necessary to reproduce the factorization of A. -C -C IWORK() The first M+N locations contain the order in -C which the rows and columns of A were used. -C If M.GE.N columns then rows. If M.LT.N rows -C then columns. -C -C INFO Flag to indicate status of computation on completion -C -1 Parameter error(s) -C 0 - Full rank -C N.GT.0 - Reduced rank rank=MIN(M,N)-INFO -C -C***REFERENCES T. Manteuffel, An interval analysis approach to rank -C determination in linear least squares problems, -C Report SAND80-0655, Sandia Laboratories, June 1980. -C***ROUTINES CALLED LLSIA, ULSIA -C***REVISION HISTORY (YYMMDD) -C 810801 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SGLSS - DIMENSION A(MDA,*),B(MDB,*),RNORM(*),WORK(*) - INTEGER IWORK(*) -C -C***FIRST EXECUTABLE STATEMENT SGLSS - RE=0. - AE=0. - KEY=0 - MODE=2 - NP=0 -C -C IF M.GE.N CALL LLSIA -C IF M.LT.N CALL ULSIA -C - IF(M.LT.N) GO TO 10 - CALL LLSIA(A,MDA,M,N,B,MDB,NB,RE,AE,KEY,MODE,NP, - 1 KRANK,KSURE,RNORM,WORK,LW,IWORK,LIW,INFO) - IF(INFO.EQ.-1) RETURN - INFO=N-KRANK - RETURN - 10 CALL ULSIA(A,MDA,M,N,B,MDB,NB,RE,AE,KEY,MODE,NP, - 1 KRANK,KSURE,RNORM,WORK,LW,IWORK,LIW,INFO) - IF(INFO.EQ.-1) RETURN - INFO=M-KRANK - RETURN - END diff --git a/slatec/sgmres.f b/slatec/sgmres.f deleted file mode 100644 index 94d7ee3..0000000 --- a/slatec/sgmres.f +++ /dev/null @@ -1,550 +0,0 @@ -*DECK SGMRES - SUBROUTINE SGMRES (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, - + ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, SB, SX, RGWK, LRGW, - + IGWK, LIGW, RWORK, IWORK) -C***BEGIN PROLOGUE SGMRES -C***PURPOSE Preconditioned GMRES Iterative Sparse Ax=b Solver. -C This routine uses the generalized minimum residual -C (GMRES) method with preconditioning to solve -C non-symmetric linear systems of the form: Ax = b. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (SGMRES-S, DGMRES-D) -C***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov -C Hindmarsh, Alan, (LLNL), alanh@llnl.gov -C Seager, Mark K., (LLNL), seager@llnl.gov -C Lawrence Livermore National Laboratory -C PO Box 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LRGW, IGWK(LIGW), LIGW -C INTEGER IWORK(USER DEFINED) -C REAL B(N), X(N), A(NELT), TOL, ERR, SB(N), SX(N) -C REAL RGWK(LRGW), RWORK(USER DEFINED) -C EXTERNAL MATVEC, MSOLVE -C -C CALL SGMRES(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, -C $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, SB, SX, -C $ RGWK, LRGW, IGWK, LIGW, RWORK, IWORK) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Real B(N). -C Right-hand side vector. -C X :INOUT Real X(N). -C On input X is your initial guess for the solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Real A(NELT). -C These arrays contain the matrix data structure for A. -C It could take any form. See "Description", below, -C for more details. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C MATVEC :EXT External. -C Name of a routine which performs the matrix vector multiply -C Y = A*X given A and X. The name of the MATVEC routine must -C be declared external in the calling program. The calling -C sequence to MATVEC is: -C CALL MATVEC(N, X, Y, NELT, IA, JA, A, ISYM) -C where N is the number of unknowns, Y is the product A*X -C upon return, X is an input vector, and NELT is the number of -C non-zeros in the SLAP IA, JA, A storage for the matrix A. -C ISYM is a flag which, if non-zero, denotes that A is -C symmetric and only the lower or upper triangle is stored. -C MSOLVE :EXT External. -C Name of the routine which solves a linear system Mz = r for -C z given r with the preconditioning matrix M (M is supplied via -C RWORK and IWORK arrays. The name of the MSOLVE routine must -C be declared external in the calling program. The calling -C sequence to MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, R is the right-hand side -C vector and Z is the solution upon return. NELT, IA, JA, A and -C ISYM are defined as above. RWORK is a real array that can -C be used to pass necessary preconditioning information and/or -C workspace to MSOLVE. IWORK is an integer work array for -C the same purpose as RWORK. -C ITOL :IN Integer. -C Flag to indicate the type of convergence criterion used. -C ITOL=0 Means the iteration stops when the test described -C below on the residual RL is satisfied. This is -C the "Natural Stopping Criteria" for this routine. -C Other values of ITOL cause extra, otherwise -C unnecessary, computation per iteration and are -C therefore much less efficient. See ISSGMR (the -C stop test routine) for more information. -C ITOL=1 Means the iteration stops when the first test -C described below on the residual RL is satisfied, -C and there is either right or no preconditioning -C being used. -C ITOL=2 Implies that the user is using left -C preconditioning, and the second stopping criterion -C below is used. -C ITOL=3 Means the iteration stops when the third test -C described below on Minv*Residual is satisfied, and -C there is either left or no preconditioning being -C used. -C ITOL=11 is often useful for checking and comparing -C different routines. For this case, the user must -C supply the "exact" solution or a very accurate -C approximation (one with an error much less than -C TOL) through a common block, -C COMMON /SSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the -C difference between the iterative approximation and -C the user-supplied solution divided by the 2-norm -C of the user-supplied solution is less than TOL. -C Note that this requires the user to set up the -C "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling -C routine. The routine with this declaration should -C be loaded before the stop test so that the correct -C length is used by the loader. This procedure is -C not standard Fortran and may not work correctly on -C your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 -C then this common block is indeed standard Fortran. -C TOL :INOUT Real. -C Convergence criterion, as described below. If TOL is set -C to zero on input, then a default value of 500*(the smallest -C positive magnitude, machine epsilon) is used. -C ITMAX :DUMMY Integer. -C Maximum number of iterations in most SLAP routines. In -C this routine this does not make sense. The maximum number -C of iterations here is given by ITMAX = MAXL*(NRMAX+1). -C See IGWK for definitions of MAXL and NRMAX. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Real. -C Error estimate of error in final approximate solution, as -C defined by ITOL. Letting norm() denote the Euclidean -C norm, ERR is defined as follows.. -C -C If ITOL=0, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), -C for right or no preconditioning, and -C ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ -C norm(SB*(M-inverse)*B), -C for left preconditioning. -C If ITOL=1, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), -C since right or no preconditioning -C being used. -C If ITOL=2, then ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ -C norm(SB*(M-inverse)*B), -C since left preconditioning is being -C used. -C If ITOL=3, then ERR = Max |(Minv*(B-A*X(L)))(i)/x(i)| -C i=1,n -C If ITOL=11, then ERR = norm(SB*(X(L)-SOLN))/norm(SB*SOLN). -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient storage allocated for -C RGWK or IGWK. -C IERR = 2 => Routine SGMRES failed to reduce the norm -C of the current residual on its last call, -C and so the iteration has stalled. In -C this case, X equals the last computed -C approximation. The user must either -C increase MAXL, or choose a different -C initial guess. -C IERR =-1 => Insufficient length for RGWK array. -C IGWK(6) contains the required minimum -C length of the RGWK array. -C IERR =-2 => Illegal value of ITOL, or ITOL and JPRE -C values are inconsistent. -C For IERR <= 2, RGWK(1) = RHOL, which is the norm on the -C left-hand-side of the relevant stopping test defined -C below associated with the residual for the current -C approximation X(L). -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C SB :IN Real SB(N). -C Array of length N containing scale factors for the right -C hand side vector B. If JSCAL.eq.0 (see below), SB need -C not be supplied. -C SX :IN Real SX(N). -C Array of length N containing scale factors for the solution -C vector X. If JSCAL.eq.0 (see below), SX need not be -C supplied. SB and SX can be the same array in the calling -C program if desired. -C RGWK :INOUT Real RGWK(LRGW). -C Real array used for workspace by SGMRES. -C On return, RGWK(1) = RHOL. See IERR for definition of RHOL. -C LRGW :IN Integer. -C Length of the real workspace, RGWK. -C LRGW >= 1 + N*(MAXL+6) + MAXL*(MAXL+3). -C See below for definition of MAXL. -C For the default values, RGWK has size at least 131 + 16*N. -C IGWK :INOUT Integer IGWK(LIGW). -C The following IGWK parameters should be set by the user -C before calling this routine. -C IGWK(1) = MAXL. Maximum dimension of Krylov subspace in -C which X - X0 is to be found (where, X0 is the initial -C guess). The default value of MAXL is 10. -C IGWK(2) = KMP. Maximum number of previous Krylov basis -C vectors to which each new basis vector is made orthogonal. -C The default value of KMP is MAXL. -C IGWK(3) = JSCAL. Flag indicating whether the scaling -C arrays SB and SX are to be used. -C JSCAL = 0 => SB and SX are not used and the algorithm -C will perform as if all SB(I) = 1 and SX(I) = 1. -C JSCAL = 1 => Only SX is used, and the algorithm -C performs as if all SB(I) = 1. -C JSCAL = 2 => Only SB is used, and the algorithm -C performs as if all SX(I) = 1. -C JSCAL = 3 => Both SB and SX are used. -C IGWK(4) = JPRE. Flag indicating whether preconditioning -C is being used. -C JPRE = 0 => There is no preconditioning. -C JPRE > 0 => There is preconditioning on the right -C only, and the solver will call routine MSOLVE. -C JPRE < 0 => There is preconditioning on the left -C only, and the solver will call routine MSOLVE. -C IGWK(5) = NRMAX. Maximum number of restarts of the -C Krylov iteration. The default value of NRMAX = 10. -C if IWORK(5) = -1, then no restarts are performed (in -C this case, NRMAX is set to zero internally). -C The following IWORK parameters are diagnostic information -C made available to the user after this routine completes. -C IGWK(6) = MLWK. Required minimum length of RGWK array. -C IGWK(7) = NMS. The total number of calls to MSOLVE. -C LIGW :IN Integer. -C Length of the integer workspace, IGWK. LIGW >= 20. -C RWORK :WORK Real RWORK(USER DEFINED). -C Real array that can be used for workspace in MSOLVE. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used for workspace in MSOLVE. -C -C *Description: -C SGMRES solves a linear system A*X = B rewritten in the form: -C -C (SB*A*(M-inverse)*(SX-inverse))*(SX*M*X) = SB*B, -C -C with right preconditioning, or -C -C (SB*(M-inverse)*A*(SX-inverse))*(SX*X) = SB*(M-inverse)*B, -C -C with left preconditioning, where A is an N-by-N real matrix, -C X and B are N-vectors, SB and SX are diagonal scaling -C matrices, and M is a preconditioning matrix. It uses -C preconditioned Krylov subpace methods based on the -C generalized minimum residual method (GMRES). This routine -C optionally performs either the full orthogonalization -C version of the GMRES algorithm or an incomplete variant of -C it. Both versions use restarting of the linear iteration by -C default, although the user can disable this feature. -C -C The GMRES algorithm generates a sequence of approximations -C X(L) to the true solution of the above linear system. The -C convergence criteria for stopping the iteration is based on -C the size of the scaled norm of the residual R(L) = B - -C A*X(L). The actual stopping test is either: -C -C norm(SB*(B-A*X(L))) .le. TOL*norm(SB*B), -C -C for right preconditioning, or -C -C norm(SB*(M-inverse)*(B-A*X(L))) .le. -C TOL*norm(SB*(M-inverse)*B), -C -C for left preconditioning, where norm() denotes the Euclidean -C norm, and TOL is a positive scalar less than one input by -C the user. If TOL equals zero when SGMRES is called, then a -C default value of 500*(the smallest positive magnitude, -C machine epsilon) is used. If the scaling arrays SB and SX -C are used, then ideally they should be chosen so that the -C vectors SX*X(or SX*M*X) and SB*B have all their components -C approximately equal to one in magnitude. If one wants to -C use the same scaling in X and B, then SB and SX can be the -C same array in the calling program. -C -C The following is a list of the other routines and their -C functions used by SGMRES: -C SPIGMR Contains the main iteration loop for GMRES. -C SORTH Orthogonalizes a new vector against older basis vectors. -C SHEQR Computes a QR decomposition of a Hessenberg matrix. -C SHELS Solves a Hessenberg least-squares system, using QR -C factors. -C SRLCAL Computes the scaled residual RL. -C SXLCAL Computes the solution XL. -C ISSGMR User-replaceable stopping routine. -C -C This routine does not care what matrix data structure is -C used for A and M. It simply calls the MATVEC and MSOLVE -C routines, with the arguments as described above. The user -C could write any type of structure and the appropriate MATVEC -C and MSOLVE routines. It is assumed that A is stored in the -C IA, JA, A arrays in some fashion and that M (or INV(M)) is -C stored in IWORK and RWORK in some fashion. The SLAP -C routines SSDCG and SSICCG are examples of this procedure. -C -C Two examples of matrix data structures are the: 1) SLAP -C Triad format and 2) SLAP Column format. -C -C =================== S L A P Triad format =================== -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***REFERENCES 1. Peter N. Brown and A. C. Hindmarsh, Reduced Storage -C Matrix Methods in Stiff ODE Systems, Lawrence Liver- -C more National Laboratory Report UCRL-95088, Rev. 1, -C Livermore, California, June 1987. -C 2. Mark K. Seager, A SLAP for the Masses, in -C G. F. Carey, Ed., Parallel Supercomputing: Methods, -C Algorithms and Applications, Wiley, 1989, pp.135-155. -C***ROUTINES CALLED R1MACH, SCOPY, SNRM2, SPIGMR -C***REVISION HISTORY (YYMMDD) -C 871001 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 891004 Added new reference. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910506 Corrected errors in C***ROUTINES CALLED list. (FNF) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of references. (FNF) -C 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) -C 921026 Added check for valid value of ITOL. (FNF) -C***END PROLOGUE SGMRES -C The following is for optimized compilation on LLNL/LTSS Crays. -CLLL. OPTIMIZE -C .. Scalar Arguments .. - REAL ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LIGW, LRGW, N, NELT -C .. Array Arguments .. - REAL A(NELT), B(N), RGWK(LRGW), RWORK(*), SB(N), SX(N), X(N) - INTEGER IA(NELT), IGWK(LIGW), IWORK(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MATVEC, MSOLVE -C .. Local Scalars .. - REAL BNRM, RHOL, SUM - INTEGER I, IFLAG, JPRE, JSCAL, KMP, LDL, LGMR, LHES, LQ, LR, LV, - + LW, LXL, LZ, LZM1, MAXL, MAXLP1, NMS, NMSL, NRMAX, NRSTS -C .. External Functions .. - REAL R1MACH, SNRM2 - EXTERNAL R1MACH, SNRM2 -C .. External Subroutines .. - EXTERNAL SCOPY, SPIGMR -C .. Intrinsic Functions .. - INTRINSIC SQRT -C***FIRST EXECUTABLE STATEMENT SGMRES - IERR = 0 -C ------------------------------------------------------------------ -C Load method parameters with user values or defaults. -C ------------------------------------------------------------------ - MAXL = IGWK(1) - IF (MAXL .EQ. 0) MAXL = 10 - IF (MAXL .GT. N) MAXL = N - KMP = IGWK(2) - IF (KMP .EQ. 0) KMP = MAXL - IF (KMP .GT. MAXL) KMP = MAXL - JSCAL = IGWK(3) - JPRE = IGWK(4) -C Check for valid value of ITOL. - IF( (ITOL.LT.0) .OR. ((ITOL.GT.3).AND.(ITOL.NE.11)) ) GOTO 650 -C Check for consistent values of ITOL and JPRE. - IF( ITOL.EQ.1 .AND. JPRE.LT.0 ) GOTO 650 - IF( ITOL.EQ.2 .AND. JPRE.GE.0 ) GOTO 650 - NRMAX = IGWK(5) - IF( NRMAX.EQ.0 ) NRMAX = 10 -C If NRMAX .eq. -1, then set NRMAX = 0 to turn off restarting. - IF( NRMAX.EQ.-1 ) NRMAX = 0 -C If input value of TOL is zero, set it to its default value. - IF( TOL.EQ.0.0E0 ) TOL = 500*R1MACH(3) -C -C Initialize counters. - ITER = 0 - NMS = 0 - NRSTS = 0 -C ------------------------------------------------------------------ -C Form work array segment pointers. -C ------------------------------------------------------------------ - MAXLP1 = MAXL + 1 - LV = 1 - LR = LV + N*MAXLP1 - LHES = LR + N + 1 - LQ = LHES + MAXL*MAXLP1 - LDL = LQ + 2*MAXL - LW = LDL + N - LXL = LW + N - LZ = LXL + N -C -C Load IGWK(6) with required minimum length of the RGWK array. - IGWK(6) = LZ + N - 1 - IF( LZ+N-1.GT.LRGW ) GOTO 640 -C ------------------------------------------------------------------ -C Calculate scaled-preconditioned norm of RHS vector b. -C ------------------------------------------------------------------ - IF (JPRE .LT. 0) THEN - CALL MSOLVE(N, B, RGWK(LR), NELT, IA, JA, A, ISYM, - $ RWORK, IWORK) - NMS = NMS + 1 - ELSE - CALL SCOPY(N, B, 1, RGWK(LR), 1) - ENDIF - IF( JSCAL.EQ.2 .OR. JSCAL.EQ.3 ) THEN - SUM = 0 - DO 10 I = 1,N - SUM = SUM + (RGWK(LR-1+I)*SB(I))**2 - 10 CONTINUE - BNRM = SQRT(SUM) - ELSE - BNRM = SNRM2(N,RGWK(LR),1) - ENDIF -C ------------------------------------------------------------------ -C Calculate initial residual. -C ------------------------------------------------------------------ - CALL MATVEC(N, X, RGWK(LR), NELT, IA, JA, A, ISYM) - DO 50 I = 1,N - RGWK(LR-1+I) = B(I) - RGWK(LR-1+I) - 50 CONTINUE -C ------------------------------------------------------------------ -C If performing restarting, then load the residual into the -C correct location in the RGWK array. -C ------------------------------------------------------------------ - 100 CONTINUE - IF( NRSTS.GT.NRMAX ) GOTO 610 - IF( NRSTS.GT.0 ) THEN -C Copy the current residual to a different location in the RGWK -C array. - CALL SCOPY(N, RGWK(LDL), 1, RGWK(LR), 1) - ENDIF -C ------------------------------------------------------------------ -C Use the SPIGMR algorithm to solve the linear system A*Z = R. -C ------------------------------------------------------------------ - CALL SPIGMR(N, RGWK(LR), SB, SX, JSCAL, MAXL, MAXLP1, KMP, - $ NRSTS, JPRE, MATVEC, MSOLVE, NMSL, RGWK(LZ), RGWK(LV), - $ RGWK(LHES), RGWK(LQ), LGMR, RWORK, IWORK, RGWK(LW), - $ RGWK(LDL), RHOL, NRMAX, B, BNRM, X, RGWK(LXL), ITOL, - $ TOL, NELT, IA, JA, A, ISYM, IUNIT, IFLAG, ERR) - ITER = ITER + LGMR - NMS = NMS + NMSL -C -C Increment X by the current approximate solution Z of A*Z = R. -C - LZM1 = LZ - 1 - DO 110 I = 1,N - X(I) = X(I) + RGWK(LZM1+I) - 110 CONTINUE - IF( IFLAG.EQ.0 ) GOTO 600 - IF( IFLAG.EQ.1 ) THEN - NRSTS = NRSTS + 1 - GOTO 100 - ENDIF - IF( IFLAG.EQ.2 ) GOTO 620 -C ------------------------------------------------------------------ -C All returns are made through this section. -C ------------------------------------------------------------------ -C The iteration has converged. -C - 600 CONTINUE - IGWK(7) = NMS - RGWK(1) = RHOL - IERR = 0 - RETURN -C -C Max number((NRMAX+1)*MAXL) of linear iterations performed. - 610 CONTINUE - IGWK(7) = NMS - RGWK(1) = RHOL - IERR = 1 - RETURN -C -C GMRES failed to reduce last residual in MAXL iterations. -C The iteration has stalled. - 620 CONTINUE - IGWK(7) = NMS - RGWK(1) = RHOL - IERR = 2 - RETURN -C Error return. Insufficient length for RGWK array. - 640 CONTINUE - ERR = TOL - IERR = -1 - RETURN -C Error return. Inconsistent ITOL and JPRE values. - 650 CONTINUE - ERR = TOL - IERR = -2 - RETURN -C------------- LAST LINE OF SGMRES FOLLOWS ---------------------------- - END diff --git a/slatec/sgtsl.f b/slatec/sgtsl.f deleted file mode 100644 index 628043d..0000000 --- a/slatec/sgtsl.f +++ /dev/null @@ -1,131 +0,0 @@ -*DECK SGTSL - SUBROUTINE SGTSL (N, C, D, E, B, INFO) -C***BEGIN PROLOGUE SGTSL -C***PURPOSE Solve a tridiagonal linear system. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2A2A -C***TYPE SINGLE PRECISION (SGTSL-S, DGTSL-D, CGTSL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE, TRIDIAGONAL -C***AUTHOR Dongarra, J., (ANL) -C***DESCRIPTION -C -C SGTSL given a general tridiagonal matrix and a right hand -C side will find the solution. -C -C On Entry -C -C N INTEGER -C is the order of the tridiagonal matrix. -C -C C REAL(N) -C is the subdiagonal of the tridiagonal matrix. -C C(2) through C(N) should contain the subdiagonal. -C On output, C is destroyed. -C -C D REAL(N) -C is the diagonal of the tridiagonal matrix. -C On output, D is destroyed. -C -C E REAL(N) -C is the superdiagonal of the tridiagonal matrix. -C E(1) through E(N-1) should contain the superdiagonal. -C On output, E is destroyed. -C -C B REAL(N) -C is the right hand side vector. -C -C On Return -C -C B is the solution vector. -C -C INFO INTEGER -C = 0 normal value. -C = K if the K-th element of the diagonal becomes -C exactly zero. The subroutine returns when -C this is detected. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SGTSL - INTEGER N,INFO - REAL C(*),D(*),E(*),B(*) -C - INTEGER K,KB,KP1,NM1,NM2 - REAL T -C***FIRST EXECUTABLE STATEMENT SGTSL - INFO = 0 - C(1) = D(1) - NM1 = N - 1 - IF (NM1 .LT. 1) GO TO 40 - D(1) = E(1) - E(1) = 0.0E0 - E(N) = 0.0E0 -C - DO 30 K = 1, NM1 - KP1 = K + 1 -C -C FIND THE LARGEST OF THE TWO ROWS -C - IF (ABS(C(KP1)) .LT. ABS(C(K))) GO TO 10 -C -C INTERCHANGE ROW -C - T = C(KP1) - C(KP1) = C(K) - C(K) = T - T = D(KP1) - D(KP1) = D(K) - D(K) = T - T = E(KP1) - E(KP1) = E(K) - E(K) = T - T = B(KP1) - B(KP1) = B(K) - B(K) = T - 10 CONTINUE -C -C ZERO ELEMENTS -C - IF (C(K) .NE. 0.0E0) GO TO 20 - INFO = K - GO TO 100 - 20 CONTINUE - T = -C(KP1)/C(K) - C(KP1) = D(KP1) + T*D(K) - D(KP1) = E(KP1) + T*E(K) - E(KP1) = 0.0E0 - B(KP1) = B(KP1) + T*B(K) - 30 CONTINUE - 40 CONTINUE - IF (C(N) .NE. 0.0E0) GO TO 50 - INFO = N - GO TO 90 - 50 CONTINUE -C -C BACK SOLVE -C - NM2 = N - 2 - B(N) = B(N)/C(N) - IF (N .EQ. 1) GO TO 80 - B(NM1) = (B(NM1) - D(NM1)*B(N))/C(NM1) - IF (NM2 .LT. 1) GO TO 70 - DO 60 KB = 1, NM2 - K = NM2 - KB + 1 - B(K) = (B(K) - D(K)*B(K+1) - E(K)*B(K+2))/C(K) - 60 CONTINUE - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE -C - RETURN - END diff --git a/slatec/shels.f b/slatec/shels.f deleted file mode 100644 index d7c44c4..0000000 --- a/slatec/shels.f +++ /dev/null @@ -1,98 +0,0 @@ -*DECK SHELS - SUBROUTINE SHELS (A, LDA, N, Q, B) -C***BEGIN PROLOGUE SHELS -C***SUBSIDIARY -C***PURPOSE Internal routine for SGMRES. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (SHELS-S, DHELS-D) -C***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov -C Hindmarsh, Alan, (LLNL), alanh@llnl.gov -C Seager, Mark K., (LLNL), seager@llnl.gov -C Lawrence Livermore National Laboratory -C PO Box 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C***DESCRIPTION -C This routine is extracted from the LINPACK routine SGESL with -C changes due to the fact that A is an upper Hessenberg matrix. -C -C SHELS solves the least squares problem: -C -C MIN(B-A*X,B-A*X) -C -C using the factors computed by SHEQR. -C -C *Usage: -C INTEGER LDA, N -C REAL A(LDA,N), Q(2*N), B(N+1) -C -C CALL SHELS(A, LDA, N, Q, B) -C -C *Arguments: -C A :IN Real A(LDA,N) -C The output from SHEQR which contains the upper -C triangular factor R in the QR decomposition of A. -C LDA :IN Integer -C The leading dimension of the array A. -C N :IN Integer -C A is originally an (N+1) by N matrix. -C Q :IN Real Q(2*N) -C The coefficients of the N Givens rotations -C used in the QR factorization of A. -C B :INOUT Real B(N+1) -C On input, B is the right hand side vector. -C On output, B is the solution vector X. -C -C***SEE ALSO SGMRES -C***ROUTINES CALLED SAXPY -C***REVISION HISTORY (YYMMDD) -C 871001 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Added C***FIRST EXECUTABLE STATEMENT line. (FNF) -C 910506 Made subsidiary to SGMRES. (FNF) -C 920511 Added complete declaration section. (WRB) -C***END PROLOGUE SHELS -C The following is for optimized compilation on LLNL/LTSS Crays. -CLLL. OPTIMIZE -C .. Scalar Arguments .. - INTEGER LDA, N -C .. Array Arguments .. - REAL A(LDA,*), B(*), Q(*) -C .. Local Scalars .. - REAL C, S, T, T1, T2 - INTEGER IQ, K, KB, KP1 -C .. External Subroutines .. - EXTERNAL SAXPY -C***FIRST EXECUTABLE STATEMENT SHELS -C -C Minimize(B-A*X,B-A*X). 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 SAXPY(K-1, T, A(1,K), 1, B(1), 1) - 40 CONTINUE - RETURN -C------------- LAST LINE OF SHELS FOLLOWS ---------------------------- - END diff --git a/slatec/sheqr.f b/slatec/sheqr.f deleted file mode 100644 index 23682fd..0000000 --- a/slatec/sheqr.f +++ /dev/null @@ -1,178 +0,0 @@ -*DECK SHEQR - SUBROUTINE SHEQR (A, LDA, N, Q, INFO, IJOB) -C***BEGIN PROLOGUE SHEQR -C***SUBSIDIARY -C***PURPOSE Internal routine for SGMRES. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (SHEQR-S, DHEQR-D) -C***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov -C Hindmarsh, Alan, (LLNL), alanh@llnl.gov -C Seager, Mark K., (LLNL), seager@llnl.gov -C Lawrence Livermore National Laboratory -C PO Box 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C***DESCRIPTION -C This routine performs a QR decomposition of an upper -C Hessenberg matrix A using Givens rotations. There are two -C options available: 1) Performing a fresh decomposition 2) -C updating the QR factors by adding a row and a column to the -C matrix A. -C -C *Usage: -C INTEGER LDA, N, INFO, IJOB -C REAL A(LDA,N), Q(2*N) -C -C CALL SHEQR(A, LDA, N, Q, INFO, IJOB) -C -C *Arguments: -C A :INOUT Real A(LDA,N) -C On input, the matrix to be decomposed. -C On output, 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 LDA :IN Integer -C The leading dimension of the array A. -C N :IN Integer -C A is an (N+1) by N Hessenberg matrix. -C Q :OUT Real Q(2*N) -C The factors c and s of each Givens rotation used -C in decomposing A. -C INFO :OUT 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 SHELS will divide by zero -C if called. -C IJOB :IN 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 -C***SEE ALSO SGMRES -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 871001 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910506 Made subsidiary to SGMRES. (FNF) -C 920511 Added complete declaration section. (WRB) -C***END PROLOGUE SHEQR -C The following is for optimized compilation on LLNL/LTSS Crays. -CLLL. OPTIMIZE -C .. Scalar Arguments .. - INTEGER IJOB, INFO, LDA, N -C .. Array Arguments .. - REAL A(LDA,*), Q(*) -C .. Local Scalars .. - REAL C, S, T, T1, T2 - INTEGER I, IQ, J, K, KM1, KP1, NM1 -C .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -C***FIRST EXECUTABLE STATEMENT SHEQR - IF (IJOB .GT. 1) GO TO 70 -C ------------------------------------------------------------------- -C A new factorization is desired. -C ------------------------------------------------------------------- -C QR decomposition without pivoting. -C - INFO = 0 - DO 60 K = 1, N - KM1 = K - 1 - KP1 = K + 1 -C -C Compute K-th column of R. -C First, multiply the K-th 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.EQ.0.0E0 ) THEN - C = 1 - S = 0 - ELSEIF( ABS(T2).GE.ABS(T1) ) THEN - T = T1/T2 - S = -1.0E0/SQRT(1.0E0+T*T) - C = -S*T - ELSE - T = T2/T1 - C = 1.0E0/SQRT(1.0E0+T*T) - S = -C*T - ENDIF - Q(IQ) = C - Q(IQ+1) = S - A(K,K) = C*T1 - S*T2 - IF( A(K,K).EQ.0.0E0 ) INFO = K - 60 CONTINUE - RETURN -C ------------------------------------------------------------------- -C The old factorization of a will be updated. A row and a -C column has been added to the matrix A. N by N-1 is now -C 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 -C rotation, and multiplying it times the column -C vector(A(N,N),A(NP1,N)). -C ------------------------------------------------------------------- - INFO = 0 - T1 = A(N,N) - T2 = A(N+1,N) - IF ( T2.EQ.0.0E0 ) THEN - C = 1 - S = 0 - ELSEIF( ABS(T2).GE.ABS(T1) ) THEN - T = T1/T2 - S = -1.0E0/SQRT(1.0E0+T*T) - C = -S*T - ELSE - T = T2/T1 - C = 1.0E0/SQRT(1.0E0+T*T) - S = -C*T - ENDIF - IQ = 2*N - 1 - Q(IQ) = C - Q(IQ+1) = S - A(N,N) = C*T1 - S*T2 - IF (A(N,N) .EQ. 0.0E0) INFO = N - RETURN -C------------- LAST LINE OF SHEQR FOLLOWS ---------------------------- - END diff --git a/slatec/sindg.f b/slatec/sindg.f deleted file mode 100644 index 97b7906..0000000 --- a/slatec/sindg.f +++ /dev/null @@ -1,37 +0,0 @@ -*DECK SINDG - FUNCTION SINDG (X) -C***BEGIN PROLOGUE SINDG -C***PURPOSE Compute the sine of an argument in degrees. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4A -C***TYPE SINGLE PRECISION (SINDG-S, DSINDG-D) -C***KEYWORDS DEGREES, ELEMENTARY FUNCTIONS, FNLIB, SINE, TRIGONOMETRIC -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C SINDG(X) evaluates the single precision sine of X where -C X is in degrees. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 770601 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***END PROLOGUE SINDG -C JUNE 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. - SAVE RADDEG - DATA RADDEG / .017453292519943296E0 / -C -C***FIRST EXECUTABLE STATEMENT SINDG - SINDG = SIN (RADDEG*X) -C - IF (MOD(X,90.).NE.0.) RETURN - N = ABS(X)/90.0 + 0.5 - N = MOD (N, 2) - IF (N.EQ.0) SINDG = 0. - IF (N.EQ.1) SINDG = SIGN (1.0, SINDG) -C - RETURN - END diff --git a/slatec/sinqb.f b/slatec/sinqb.f deleted file mode 100644 index 4e9a416..0000000 --- a/slatec/sinqb.f +++ /dev/null @@ -1,86 +0,0 @@ -*DECK SINQB - SUBROUTINE SINQB (N, X, WSAVE) -C***BEGIN PROLOGUE SINQB -C***PURPOSE Compute the unnormalized inverse of SINQF. -C***LIBRARY SLATEC (FFTPACK) -C***CATEGORY J1A3 -C***TYPE SINGLE PRECISION (SINQB-S) -C***KEYWORDS FFTPACK, FOURIER TRANSFORM -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C Subroutine SINQB computes the fast Fourier transform of quarter -C wave data. That is, SINQB computes a sequence from its -C representation in terms of a sine series with odd wave numbers. -C the transform is defined below at output parameter X. -C -C SINQF is the unnormalized inverse of SINQB since a call of SINQB -C followed by a call of SINQF will multiply the input sequence X -C by 4*N. -C -C The array WSAVE which is used by subroutine SINQB must be -C initialized by calling subroutine SINQI(N,WSAVE). -C -C Input Parameters -C -C N the length of the array X to be transformed. The method -C is most efficient when N is a product of small primes. -C -C X an array which contains the sequence to be transformed -C -C WSAVE a work array which must be dimensioned at least 3*N+15 -C in the program that calls SINQB. The WSAVE array must be -C initialized by calling subroutine SINQI(N,WSAVE), and a -C different WSAVE array must be used for each different -C value of N. This initialization does not have to be -C repeated so long as N remains unchanged. Thus subsequent -C transforms can be obtained faster than the first. -C -C Output Parameters -C -C X For I=1,...,N -C -C X(I)= the sum from K=1 to K=N of -C -C 4*X(K)*SIN((2*K-1)*I*PI/(2*N)) -C -C a call of SINQB followed by a call of -C SINQF will multiply the sequence X by 4*N. -C Therefore SINQF is the unnormalized inverse -C of SINQB. -C -C WSAVE contains initialization calculations which must not -C be destroyed between calls of SINQB or SINQF. -C -C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel -C Computations (G. Rodrigue, ed.), Academic Press, -C 1982, pp. 51-83. -C***ROUTINES CALLED COSQB -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C changing dummy array size declarations (1) to (*). -C 861211 REVISION DATE from Version 3.2 -C 881128 Modified by Dick Valent to meet prologue standards. -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SINQB - DIMENSION X(*), WSAVE(*) -C***FIRST EXECUTABLE STATEMENT SINQB - IF (N .GT. 1) GO TO 101 - X(1) = 4.*X(1) - RETURN - 101 NS2 = N/2 - DO 102 K=2,N,2 - X(K) = -X(K) - 102 CONTINUE - CALL COSQB (N,X,WSAVE) - DO 103 K=1,NS2 - KC = N-K - XHOLD = X(K) - X(K) = X(KC+1) - X(KC+1) = XHOLD - 103 CONTINUE - RETURN - END diff --git a/slatec/sinqf.f b/slatec/sinqf.f deleted file mode 100644 index 8905cf9..0000000 --- a/slatec/sinqf.f +++ /dev/null @@ -1,86 +0,0 @@ -*DECK SINQF - SUBROUTINE SINQF (N, X, WSAVE) -C***BEGIN PROLOGUE SINQF -C***PURPOSE Compute the forward sine transform with odd wave numbers. -C***LIBRARY SLATEC (FFTPACK) -C***CATEGORY J1A3 -C***TYPE SINGLE PRECISION (SINQF-S) -C***KEYWORDS FFTPACK, FOURIER TRANSFORM -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C Subroutine SINQF computes the fast Fourier transform of quarter -C wave data. That is, SINQF computes the coefficients in a sine -C series representation with only odd wave numbers. The transform -C is defined below at output parameter X. -C -C SINQB is the unnormalized inverse of SINQF since a call of SINQF -C followed by a call of SINQB will multiply the input sequence X -C by 4*N. -C -C The array WSAVE which is used by subroutine SINQF must be -C initialized by calling subroutine SINQI(N,WSAVE). -C -C Input Parameters -C -C N the length of the array X to be transformed. The method -C is most efficient when N is a product of small primes. -C -C X an array which contains the sequence to be transformed -C -C WSAVE a work array which must be dimensioned at least 3*N+15 -C in the program that calls SINQF. The WSAVE array must be -C initialized by calling subroutine SINQI(N,WSAVE), and a -C different WSAVE array must be used for each different -C value of N. This initialization does not have to be -C repeated so long as N remains unchanged. Thus subsequent -C transforms can be obtained faster than the first. -C -C Output Parameters -C -C X For I=1,...,N -C -C X(I) = (-1)**(I-1)*X(N) -C -C + the sum from K=1 to K=N-1 of -C -C 2*X(K)*SIN((2*I-1)*K*PI/(2*N)) -C -C A call of SINQF followed by a call of -C SINQB will multiply the sequence X by 4*N. -C Therefore SINQB is the unnormalized inverse -C of SINQF. -C -C WSAVE contains initialization calculations which must not -C be destroyed between calls of SINQF or SINQB. -C -C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel -C Computations (G. Rodrigue, ed.), Academic Press, -C 1982, pp. 51-83. -C***ROUTINES CALLED COSQF -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C changing dummy array size declarations (1) to (*) -C 861211 REVISION DATE from Version 3.2 -C 881128 Modified by Dick Valent to meet prologue standards. -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SINQF - DIMENSION X(*), WSAVE(*) -C***FIRST EXECUTABLE STATEMENT SINQF - IF (N .EQ. 1) RETURN - NS2 = N/2 - DO 101 K=1,NS2 - KC = N-K - XHOLD = X(K) - X(K) = X(KC+1) - X(KC+1) = XHOLD - 101 CONTINUE - CALL COSQF (N,X,WSAVE) - DO 102 K=2,N,2 - X(K) = -X(K) - 102 CONTINUE - RETURN - END diff --git a/slatec/sinqi.f b/slatec/sinqi.f deleted file mode 100644 index 72b84b5..0000000 --- a/slatec/sinqi.f +++ /dev/null @@ -1,48 +0,0 @@ -*DECK SINQI - SUBROUTINE SINQI (N, WSAVE) -C***BEGIN PROLOGUE SINQI -C***PURPOSE Initialize a work array for SINQF and SINQB. -C***LIBRARY SLATEC (FFTPACK) -C***CATEGORY J1A3 -C***TYPE SINGLE PRECISION (SINQI-S) -C***KEYWORDS FFTPACK, FOURIER TRANSFORM -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C Subroutine SINQI initializes the array WSAVE which is used in -C both SINQF and SINQB. The prime factorization of N together with -C a tabulation of the trigonometric functions are computed and -C stored in WSAVE. -C -C Input Parameter -C -C N the length of the sequence to be transformed. The method -C is most efficient when N is a product of small primes. -C -C Output Parameter -C -C WSAVE a work array which must be dimensioned at least 3*N+15. -C The same work array can be used for both SINQF and SINQB -C as long as N remains unchanged. Different WSAVE arrays -C are required for different values of N. The contents of -C WSAVE must not be changed between calls of SINQF or SINQB. -C -C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel -C Computations (G. Rodrigue, ed.), Academic Press, -C 1982, pp. 51-83. -C***ROUTINES CALLED COSQI -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C changing dummy array size declarations (1) to (*) -C 861211 REVISION DATE from Version 3.2 -C 881128 Modified by Dick Valent to meet prologue standards. -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SINQI - DIMENSION WSAVE(*) -C***FIRST EXECUTABLE STATEMENT SINQI - CALL COSQI (N,WSAVE) - RETURN - END diff --git a/slatec/sint.f b/slatec/sint.f deleted file mode 100644 index d00f674..0000000 --- a/slatec/sint.f +++ /dev/null @@ -1,107 +0,0 @@ -*DECK SINT - SUBROUTINE SINT (N, X, WSAVE) -C***BEGIN PROLOGUE SINT -C***PURPOSE Compute the sine transform of a real, odd sequence. -C***LIBRARY SLATEC (FFTPACK) -C***CATEGORY J1A3 -C***TYPE SINGLE PRECISION (SINT-S) -C***KEYWORDS FFTPACK, FOURIER TRANSFORM -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C Subroutine SINT computes the discrete Fourier sine transform -C of an odd sequence X(I). The transform is defined below at -C output parameter X. -C -C SINT is the unnormalized inverse of itself since a call of SINT -C followed by another call of SINT will multiply the input sequence -C X by 2*(N+1). -C -C The array WSAVE which is used by subroutine SINT must be -C initialized by calling subroutine SINTI(N,WSAVE). -C -C Input Parameters -C -C N the length of the sequence to be transformed. The method -C is most efficient when N+1 is the product of small primes. -C -C X an array which contains the sequence to be transformed -C -C -C WSAVE a work array with dimension at least INT(3.5*N+16) -C in the program that calls SINT. The WSAVE array must be -C initialized by calling subroutine SINTI(N,WSAVE), and a -C different WSAVE array must be used for each different -C value of N. This initialization does not have to be -C repeated so long as N remains unchanged. Thus subsequent -C transforms can be obtained faster than the first. -C -C Output Parameters -C -C X For I=1,...,N -C -C X(I)= the sum from K=1 to K=N -C -C 2*X(K)*SIN(K*I*PI/(N+1)) -C -C A call of SINT followed by another call of -C SINT will multiply the sequence X by 2*(N+1). -C Hence SINT is the unnormalized inverse -C of itself. -C -C WSAVE contains initialization calculations which must not be -C destroyed between calls of SINT. -C -C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel -C Computations (G. Rodrigue, ed.), Academic Press, -C 1982, pp. 51-83. -C***ROUTINES CALLED RFFTF -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C (a) changing dummy array size declarations (1) to (*), -C (b) changing definition of variable SQRT3 by using -C FORTRAN intrinsic function SQRT instead of a DATA -C statement. -C 881128 Modified by Dick Valent to meet prologue standards. -C 891009 Removed unreferenced statement label. (WRB) -C 891009 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 SINT - DIMENSION X(*), WSAVE(*) -C***FIRST EXECUTABLE STATEMENT SINT - SQRT3 = SQRT(3.) - IF (N-2) 101,102,103 - 101 X(1) = X(1)+X(1) - RETURN - 102 XH = SQRT3*(X(1)+X(2)) - X(2) = SQRT3*(X(1)-X(2)) - X(1) = XH - RETURN - 103 NP1 = N+1 - NS2 = N/2 - WSAVE(1) = 0. - KW = NP1 - DO 104 K=1,NS2 - KW = KW+1 - KC = NP1-K - T1 = X(K)-X(KC) - T2 = WSAVE(KW)*(X(K)+X(KC)) - WSAVE(K+1) = T1+T2 - WSAVE(KC+1) = T2-T1 - 104 CONTINUE - MODN = MOD(N,2) - IF (MODN .NE. 0) WSAVE(NS2+2) = 4.*X(NS2+1) - NF = NP1+NS2+1 - CALL RFFTF (NP1,WSAVE,WSAVE(NF)) - X(1) = .5*WSAVE(1) - DO 105 I=3,N,2 - X(I-1) = -WSAVE(I) - X(I) = X(I-2)+WSAVE(I-1) - 105 CONTINUE - IF (MODN .NE. 0) RETURN - X(N) = -WSAVE(N+1) - RETURN - END diff --git a/slatec/sinti.f b/slatec/sinti.f deleted file mode 100644 index d6703bf..0000000 --- a/slatec/sinti.f +++ /dev/null @@ -1,65 +0,0 @@ -*DECK SINTI - SUBROUTINE SINTI (N, WSAVE) -C***BEGIN PROLOGUE SINTI -C***PURPOSE Initialize a work array for SINT. -C***LIBRARY SLATEC (FFTPACK) -C***CATEGORY J1A3 -C***TYPE SINGLE PRECISION (SINTI-S) -C***KEYWORDS FFTPACK, FOURIER TRANSFORM -C***AUTHOR Swarztrauber, P. N., (NCAR) -C***DESCRIPTION -C -C Subroutine SINTI initializes the array WSAVE which is used in -C subroutine SINT. The prime factorization of N together with -C a tabulation of the trigonometric functions are computed and -C stored in WSAVE. -C -C Input Parameter -C -C N the length of the sequence to be transformed. The method -C is most efficient when N+1 is a product of small primes. -C -C Output Parameter -C -C WSAVE a work array with at least INT(3.5*N+16) locations. -C Different WSAVE arrays are required for different values -C of N. The contents of WSAVE must not be changed between -C calls of SINT. -C -C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel -C Computations (G. Rodrigue, ed.), Academic Press, -C 1982, pp. 51-83. -C***ROUTINES CALLED RFFTI -C***REVISION HISTORY (YYMMDD) -C 790601 DATE WRITTEN -C 830401 Modified to use SLATEC library source file format. -C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by -C (a) changing dummy array size declarations (1) to (*), -C (b) changing references to intrinsic function FLOAT -C to REAL, and -C (c) changing definition of variable PI by using -C FORTRAN intrinsic function ATAN instead of a DATA -C statement. -C 881128 Modified by Dick Valent to meet prologue standards. -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 SINTI - DIMENSION WSAVE(*) -C***FIRST EXECUTABLE STATEMENT SINTI - IF (N .LE. 1) RETURN - PI = 4.*ATAN(1.) - NP1 = N+1 - NS2 = N/2 - DT = PI/NP1 - KS = N+2 - KF = KS+NS2-1 - FK = 0. - DO 101 K=KS,KF - FK = FK+1. - WSAVE(K) = 2.*SIN(FK*DT) - 101 CONTINUE - CALL RFFTI (NP1,WSAVE(KF+1)) - RETURN - END diff --git a/slatec/sintrp.f b/slatec/sintrp.f deleted file mode 100644 index 6eba4f3..0000000 --- a/slatec/sintrp.f +++ /dev/null @@ -1,135 +0,0 @@ -*DECK SINTRP - SUBROUTINE SINTRP (X, Y, XOUT, YOUT, YPOUT, NEQN, KOLD, PHI, IVC, - + IV, KGI, GI, ALPHA, OG, OW, OX, OY) -C***BEGIN PROLOGUE SINTRP -C***PURPOSE Approximate the solution at XOUT by evaluating the -C polynomial computed in STEPS at XOUT. Must be used in -C conjunction with STEPS. -C***LIBRARY SLATEC (DEPAC) -C***CATEGORY I1A1B -C***TYPE SINGLE PRECISION (SINTRP-S, DINTP-D) -C***KEYWORDS ADAMS METHOD, DEPAC, INITIAL VALUE PROBLEMS, ODE, -C ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR, -C SMOOTH INTERPOLANT -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C The methods in subroutine STEPS approximate the solution near X -C by a polynomial. Subroutine SINTRP approximates the solution at -C XOUT by evaluating the polynomial there. Information defining this -C polynomial is passed from STEPS so SINTRP cannot be used alone. -C -C Subroutine STEPS is completely explained and documented in the text, -C "Computer Solution of Ordinary Differential Equations, the Initial -C Value Problem" by L. F. Shampine and M. K. Gordon. -C -C Input to SINTRP -- -C -C The user provides storage in the calling program for the arrays in -C the call list -C DIMENSION Y(NEQN),YOUT(NEQN),YPOUT(NEQN),PHI(NEQN,16),OY(NEQN) -C AND ALPHA(12),OG(13),OW(12),GI(11),IV(10) -C and defines -C XOUT -- point at which solution is desired. -C The remaining parameters are defined in STEPS and passed to -C SINTRP from that subroutine -C -C Output from SINTRP -- -C -C YOUT(*) -- solution at XOUT -C YPOUT(*) -- derivative of solution at XOUT -C The remaining parameters are returned unaltered from their input -C values. Integration with STEPS may be continued. -C -C***REFERENCES H. A. Watts, A smoother interpolant for DE/STEP, INTRP -C II, Report SAND84-0293, Sandia Laboratories, 1984. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 840201 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SINTRP -C - DIMENSION Y(*),YOUT(*),YPOUT(*),PHI(NEQN,16),OY(*) - DIMENSION G(13),C(13),W(13),OG(13),OW(12),ALPHA(12),GI(11),IV(10) -C -C***FIRST EXECUTABLE STATEMENT SINTRP - KP1 = KOLD + 1 - KP2 = KOLD + 2 -C - HI = XOUT - OX - H = X - OX - XI = HI/H - XIM1 = XI - 1. -C -C INITIALIZE W(*) FOR COMPUTING G(*) -C - XIQ = XI - DO 10 IQ = 1,KP1 - XIQ = XI*XIQ - TEMP1 = IQ*(IQ+1) - 10 W(IQ) = XIQ/TEMP1 -C -C COMPUTE THE DOUBLE INTEGRAL TERM GDI -C - IF (KOLD .LE. KGI) GO TO 50 - IF (IVC .GT. 0) GO TO 20 - GDI = 1.0/TEMP1 - M = 2 - GO TO 30 - 20 IW = IV(IVC) - GDI = OW(IW) - M = KOLD - IW + 3 - 30 IF (M .GT. KOLD) GO TO 60 - DO 40 I = M,KOLD - 40 GDI = OW(KP2-I) - ALPHA(I)*GDI - GO TO 60 - 50 GDI = GI(KOLD) -C -C COMPUTE G(*) AND C(*) -C - 60 G(1) = XI - G(2) = 0.5*XI*XI - C(1) = 1.0 - C(2) = XI - IF (KOLD .LT. 2) GO TO 90 - DO 80 I = 2,KOLD - ALP = ALPHA(I) - GAMMA = 1.0 + XIM1*ALP - L = KP2 - I - DO 70 JQ = 1,L - 70 W(JQ) = GAMMA*W(JQ) - ALP*W(JQ+1) - G(I+1) = W(1) - 80 C(I+1) = GAMMA*C(I) -C -C DEFINE INTERPOLATION PARAMETERS -C - 90 SIGMA = (W(2) - XIM1*W(1))/GDI - RMU = XIM1*C(KP1)/GDI - HMU = RMU/H -C -C INTERPOLATE FOR THE SOLUTION -- YOUT -C AND FOR THE DERIVATIVE OF THE SOLUTION -- YPOUT -C - DO 100 L = 1,NEQN - YOUT(L) = 0.0 - 100 YPOUT(L) = 0.0 - DO 120 J = 1,KOLD - I = KP2 - J - GDIF = OG(I) - OG(I-1) - TEMP2 = (G(I) - G(I-1)) - SIGMA*GDIF - TEMP3 = (C(I) - C(I-1)) + RMU*GDIF - DO 110 L = 1,NEQN - YOUT(L) = YOUT(L) + TEMP2*PHI(L,I) - 110 YPOUT(L) = YPOUT(L) + TEMP3*PHI(L,I) - 120 CONTINUE - DO 130 L = 1,NEQN - YOUT(L) = ((1.0 - SIGMA)*OY(L) + SIGMA*Y(L)) + - 1 H*(YOUT(L) + (G(1) - SIGMA*OG(1))*PHI(L,1)) - 130 YPOUT(L) = HMU*(OY(L) - Y(L)) + - 1 (YPOUT(L) + (C(1) + RMU*OG(1))*PHI(L,1)) -C - RETURN - END diff --git a/slatec/sir.f b/slatec/sir.f deleted file mode 100644 index 184374a..0000000 --- a/slatec/sir.f +++ /dev/null @@ -1,332 +0,0 @@ -*DECK SIR - SUBROUTINE SIR (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, - + ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, - + IWORK) -C***BEGIN PROLOGUE SIR -C***PURPOSE Preconditioned Iterative Refinement Sparse Ax = b Solver. -C Routine to solve a general linear system Ax = b using -C iterative refinement with a matrix splitting. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (SIR-S, DIR-D) -C***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) -C REAL B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N), DZ(N), -C REAL RWORK(USER DEFINED) -C EXTERNAL MATVEC, MSOLVE -C -C CALL SIR(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, ITOL, -C $ TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, IWORK) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Real B(N). -C Right-hand side vector. -C X :INOUT Real X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Real A(NELT). -C These arrays contain the matrix data structure for A. -C It could take any form. See "Description", below, -C for more details. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C MATVEC :EXT External. -C Name of a routine which performs the matrix vector multiply -C Y = A*X given A and X. The name of the MATVEC routine must -C be declared external in the calling program. The calling -C sequence to MATVEC is: -C CALL MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) -C Where N is the number of unknowns, Y is the product A*X -C upon return, X is an input vector, NELT is the number of -C non-zeros in the SLAP IA, JA, A storage for the matrix A. -C ISYM is a flag which, if non-zero, denotes that A is -C symmetric and only the lower or upper triangle is stored. -C MSOLVE :EXT External. -C Name of a routine which solves a linear system MZ = R for -C Z given R with the preconditioning matrix M (M is supplied via -C RWORK and IWORK arrays). The name of the MSOLVE routine must -C be declared external in the calling program. The calling -C sequence to MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, R is the right-hand side -C vector and Z is the solution upon return. NELT, IA, JA, A and -C ISYM are defined as above. RWORK is a real array that can -C be used to pass necessary preconditioning information and/or -C workspace to MSOLVE. IWORK is an integer work array for -C the same purpose as RWORK. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /SSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Real. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Real. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*R1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C R :WORK Real R(N). -C Z :WORK Real Z(N). -C DZ :WORK Real DZ(N). -C Real arrays used for workspace. -C RWORK :WORK Real RWORK(USER DEFINED). -C Real array that can be used by MSOLVE. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used by MSOLVE. -C -C *Description: -C The basic algorithm for iterative refinement (also known as -C iterative improvement) is: -C -C n+1 n -1 n -C X = X + M (B - AX ). -C -C -1 -1 -C If M = A then this is the standard iterative refinement -C algorithm and the "subtraction" in the residual calculation -C should be done in double precision (which it is not in this -C routine). -C If M = DIAG(A), the diagonal of A, then iterative refinement -C is known as Jacobi's method. The SLAP routine SSJAC -C implements this iterative strategy. -C If M = L, the lower triangle of A, then iterative refinement -C is known as Gauss-Seidel. The SLAP routine SSGS implements -C this iterative strategy. -C -C This routine does not care what matrix data structure is -C used for A and M. It simply calls the MATVEC and MSOLVE -C routines, with the arguments as described above. The user -C could write any type of structure and the appropriate MATVEC -C and MSOLVE routines. It is assumed that A is stored in the -C IA, JA, A arrays in some fashion and that M (or INV(M)) is -C stored in IWORK and RWORK) in some fashion. The SLAP -C routines SSJAC and SSGS are examples of this procedure. -C -C Two examples of matrix data structures are the: 1) SLAP -C Triad format and 2) SLAP Column format. -C -C =================== S L A P Triad format =================== -C -C In this format only the non-zeros are stored. They may -C appear in *ANY* order. The user supplies three arrays of -C length NELT, where NELT is the number of non-zeros in the -C matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero -C the user puts the row and column index of that matrix -C element in the IA and JA arrays. The value of the non-zero -C matrix element is placed in the corresponding location of -C the A array. This is an extremely easy data structure to -C generate. On the other hand it is not too efficient on -C vector computers for the iterative solution of linear -C systems. Hence, SLAP changes this input data structure to -C the SLAP Column format for the iteration (but does not -C change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C In this format the non-zeros are stored counting down -C columns (except for the diagonal entry, which must appear -C first in each "column") and are stored in the real array A. -C In other words, for each column in the matrix put the -C diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have JA(N+1) -C = NELT+1, where N is the number of columns in the matrix and -C NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Examples: -C See the SLAP routines SSJAC, SSGS -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO SSJAC, SSGS -C***REFERENCES 1. Gene Golub and Charles Van Loan, Matrix Computations, -C Johns Hopkins University Press, Baltimore, Maryland, -C 1983. -C 2. Mark K. Seager, A SLAP for the Masses, in -C G. F. Carey, Ed., Parallel Supercomputing: Methods, -C Algorithms and Applications, Wiley, 1989, pp.135-155. -C***ROUTINES CALLED ISSIR, R1MACH -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 891004 Added new reference. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MATVEC and MSOLVE from ROUTINES CALLED list. (FNF) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of references. (FNF) -C 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) -C***END PROLOGUE SIR -C .. Scalar Arguments .. - REAL ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT -C .. Array Arguments .. - REAL A(NELT), B(N), DZ(N), R(N), RWORK(*), X(N), Z(N) - INTEGER IA(NELT), IWORK(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MATVEC, MSOLVE -C .. Local Scalars .. - REAL BNRM, SOLNRM, TOLMIN - INTEGER I, K -C .. External Functions .. - REAL R1MACH - INTEGER ISSIR - EXTERNAL R1MACH, ISSIR -C***FIRST EXECUTABLE STATEMENT SIR -C -C Check some of the input data. -C - ITER = 0 - IERR = 0 - IF( N.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF - TOLMIN = 500*R1MACH(3) - IF( TOL.LT.TOLMIN ) THEN - TOL = TOLMIN - IERR = 4 - ENDIF -C -C Calculate initial residual and pseudo-residual, and check -C stopping criterion. - CALL MATVEC(N, X, R, NELT, IA, JA, A, ISYM) - DO 10 I = 1, N - R(I) = B(I) - R(I) - 10 CONTINUE - CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C - IF( ISSIR(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, - $ ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, - $ IWORK, BNRM, SOLNRM) .NE. 0 ) GO TO 200 - IF( IERR.NE.0 ) RETURN -C -C ***** iteration loop ***** -C - DO 100 K=1,ITMAX - ITER = K -C -C Calculate new iterate x, new residual r, and new -C pseudo-residual z. - DO 20 I = 1, N - X(I) = X(I) + Z(I) - 20 CONTINUE - CALL MATVEC(N, X, R, NELT, IA, JA, A, ISYM) - DO 30 I = 1, N - R(I) = B(I) - R(I) - 30 CONTINUE - CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C -C check stopping criterion. - IF( ISSIR(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, - $ ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, - $ IWORK, BNRM, SOLNRM) .NE. 0 ) GO TO 200 -C - 100 CONTINUE -C -C ***** end of loop ***** -C Stopping criterion not satisfied. - ITER = ITMAX + 1 - IERR = 2 -C - 200 RETURN -C------------- LAST LINE OF SIR FOLLOWS ------------------------------- - END diff --git a/slatec/sllti2.f b/slatec/sllti2.f deleted file mode 100644 index c4104f2..0000000 --- a/slatec/sllti2.f +++ /dev/null @@ -1,168 +0,0 @@ -*DECK SLLTI2 - SUBROUTINE SLLTI2 (N, B, X, NEL, IEL, JEL, EL, DINV) -C***BEGIN PROLOGUE SLLTI2 -C***PURPOSE SLAP Backsolve routine for LDL' Factorization. -C Routine to solve a system of the form L*D*L' X = B, -C where L is a unit lower triangular matrix and D is a -C diagonal matrix and ' means transpose. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE SINGLE PRECISION (SLLTI2-S, DLLTI2-D) -C***KEYWORDS INCOMPLETE FACTORIZATION, ITERATIVE PRECONDITION, SLAP, -C SPARSE, SYMMETRIC LINEAR SYSTEM SOLVE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NEL, IEL(NEL), JEL(NEL) -C REAL B(N), X(N), EL(NEL), DINV(N) -C -C CALL SLLTI2( N, B, X, NEL, IEL, JEL, EL, DINV ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Real B(N). -C Right hand side vector. -C X :OUT Real X(N). -C Solution to L*D*L' x = b. -C NEL :IN Integer. -C Number of non-zeros in the EL array. -C IEL :IN Integer IEL(NEL). -C JEL :IN Integer JEL(NEL). -C EL :IN Real EL(NEL). -C IEL, JEL, EL contain the unit lower triangular factor of -C the incomplete decomposition of the A matrix stored in -C SLAP Row format. The diagonal of ones *IS* stored. This -C structure can be set up by the SS2LT routine. See the -C "Description", below for more details about the SLAP Row -C format. -C DINV :IN Real DINV(N). -C Inverse of the diagonal matrix D. -C -C *Description: -C This routine is supplied with the SLAP package as a routine -C to perform the MSOLVE operation in the SCG iteration routine -C for the driver routine SSICCG. It must be called via the -C SLAP MSOLVE calling sequence convention interface routine -C SSLLI. -C **** THIS ROUTINE ITSELF DOES NOT CONFORM TO THE **** -C **** SLAP MSOLVE CALLING CONVENTION **** -C -C IEL, JEL, EL should contain the unit lower triangular factor -C of the incomplete decomposition of the A matrix stored in -C SLAP Row format. This IC factorization can be computed by -C the SSICS routine. The diagonal (which is all one's) is -C stored. -C -C ==================== S L A P Row format ==================== -C -C This routine requires that the matrix A be stored in the -C SLAP Row format. In this format the non-zeros are stored -C counting across rows (except for the diagonal entry, which -C must appear first in each "row") and are stored in the real -C array A. In other words, for each row in the matrix put the -C diagonal entry in A. Then put in the other non-zero -C elements going across the row (except the diagonal) in -C order. The JA array holds the column index for each -C non-zero. The IA array holds the offsets into the JA, A -C arrays for the beginning of each row. That is, -C JA(IA(IROW)), A(IA(IROW)) points to the beginning of the -C IROW-th row in JA and A. JA(IA(IROW+1)-1), A(IA(IROW+1)-1) -C points to the end of the IROW-th row. Note that we always -C have IA(N+1) = NELT+1, where N is the number of rows in -C the matrix and NELT is the number of non-zeros in the -C matrix. -C -C Here is an example of the SLAP Row storage format for a 5x5 -C Matrix (in the A and JA arrays '|' denotes the end of a row): -C -C 5x5 Matrix SLAP Row format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 12 15 | 22 21 | 33 35 | 44 | 55 51 53 -C |21 22 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| IA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C With the SLAP Row format the "inner loop" of this routine -C should vectorize on machines with hardware support for -C vector gather/scatter operations. Your compiler may require -C a compiler directive to convince it that there are no -C implicit vector dependencies. Compiler directives for the -C Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied -C with the standard SLAP distribution. -C -C***SEE ALSO SSICCG, SSICS -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE SLLTI2 -C .. Scalar Arguments .. - INTEGER N, NEL -C .. Array Arguments .. - REAL B(N), DINV(N), EL(NEL), X(N) - INTEGER IEL(NEL), JEL(NEL) -C .. Local Scalars .. - INTEGER I, IBGN, IEND, IROW -C***FIRST EXECUTABLE STATEMENT SLLTI2 -C -C Solve L*y = b, storing result in x. -C - DO 10 I=1,N - X(I) = B(I) - 10 CONTINUE - DO 30 IROW = 1, N - IBGN = IEL(IROW) + 1 - IEND = IEL(IROW+1) - 1 - IF( IBGN.LE.IEND ) THEN -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ NOCONCUR -CVD$ NODEPCHK - DO 20 I = IBGN, IEND - X(IROW) = X(IROW) - EL(I)*X(JEL(I)) - 20 CONTINUE - ENDIF - 30 CONTINUE -C -C Solve D*Z = Y, storing result in X. -C - DO 40 I=1,N - X(I) = X(I)*DINV(I) - 40 CONTINUE -C -C Solve L-trans*X = Z. -C - DO 60 IROW = N, 2, -1 - IBGN = IEL(IROW) + 1 - IEND = IEL(IROW+1) - 1 - IF( IBGN.LE.IEND ) THEN -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ NOCONCUR -CVD$ NODEPCHK - DO 50 I = IBGN, IEND - X(JEL(I)) = X(JEL(I)) - EL(I)*X(IROW) - 50 CONTINUE - ENDIF - 60 CONTINUE -C - RETURN -C------------- LAST LINE OF SLLTI2 FOLLOWS ---------------------------- - END diff --git a/slatec/slpdoc.f b/slatec/slpdoc.f deleted file mode 100644 index 62f043c..0000000 --- a/slatec/slpdoc.f +++ /dev/null @@ -1,459 +0,0 @@ -*DECK SLPDOC - SUBROUTINE SLPDOC -C***BEGIN PROLOGUE SLPDOC -C***PURPOSE Sparse Linear Algebra Package Version 2.0.2 Documentation. -C Routines to solve large sparse symmetric and nonsymmetric -C positive definite linear systems, Ax = b, using precondi- -C tioned iterative methods. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4, Z -C***TYPE SINGLE PRECISION (SLPDOC-S, DLPDOC-D) -C***KEYWORDS BICONJUGATE GRADIENT SQUARED, DOCUMENTATION, -C GENERALIZED MINIMUM RESIDUAL, ITERATIVE IMPROVEMENT, -C NORMAL EQUATIONS, ORTHOMIN, -C PRECONDITIONED CONJUGATE GRADIENT, SLAP, -C SPARSE ITERATIVE METHODS -C***AUTHOR Seager, Mark. K., (LLNL) -C User Systems Division -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 -C (FTS) 543-3141, (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C The -C Sparse Linear Algebra Package -C -C @@@@@@@ @ @@@ @@@@@@@@ -C @ @ @ @ @ @ @ -C @ @ @ @ @ @ -C @@@@@@@ @ @ @ @@@@@@@@ -C @ @ @@@@@@@@@ @ -C @ @ @ @ @ @ -C @@@@@@@ @@@@@@@@@ @ @ @ -C -C @ @ @@@@@@@ @@@@@ -C @ @ @ @ @ @@ -C @ @ @@@@@@@ @ @@ @ @ @ @ -C @ @ @ @ @@ @ @@@@@@ @ @ @ -C @ @ @@@@@@@@@ @ @ @ @ @ -C @ @ @ @ @ @@@ @@ @ -C @@@ @@@@@@@ @ @@@@@@@@@ @@@ @@@@@ -C -C -C ================================================================= -C ========================== Introduction ========================= -C ================================================================= -C This package was originally derived from a set of iterative -C routines written by Anne Greenbaum, as announced in "Routines -C for Solving Large Sparse Linear Systems", Tentacle, Lawrence -C Livermore National Laboratory, Livermore Computing Center -C (January 1986), pp 15-21. -C -C This document contains the specifications for the SLAP Version -C 2.0 package, a Fortran 77 package for the solution of large -C sparse linear systems, Ax = b, via preconditioned iterative -C methods. Included in this package are "core" routines to do -C Iterative Refinement (Jacobi's method), Conjugate Gradient, -C Conjugate Gradient on the normal equations, AA'y = b, (where x = -C A'y and A' denotes the transpose of A), BiConjugate Gradient, -C BiConjugate Gradient Squared, Orthomin and Generalized Minimum -C Residual Iteration. These "core" routines do not require a -C "fixed" data structure for storing the matrix A and the -C preconditioning matrix M. The user is free to choose any -C structure that facilitates efficient solution of the problem at -C hand. The drawback to this approach is that the user must also -C supply at least two routines (MATVEC and MSOLVE, say). MATVEC -C must calculate, y = Ax, given x and the user's data structure for -C A. MSOLVE must solve, r = Mz, for z (*NOT* r) given r and the -C user's data structure for M (or its inverse). The user should -C choose M so that inv(M)*A is approximately the identity and the -C solution step r = Mz is "easy" to solve. For some of the "core" -C routines (Orthomin, BiConjugate Gradient and Conjugate Gradient -C on the normal equations) the user must also supply a matrix -C transpose times vector routine (MTTVEC, say) and (possibly, -C depending on the "core" method) a routine that solves the -C transpose of the preconditioning step (MTSOLV, say). -C Specifically, MTTVEC is a routine which calculates y = A'x, given -C x and the user's data structure for A (A' is the transpose of A). -C MTSOLV is a routine which solves the system r = M'z for z given r -C and the user's data structure for M. -C -C This process of writing the matrix vector operations can be time -C consuming and error prone. To alleviate these problems we have -C written drivers for the "core" methods that assume the user -C supplies one of two specific data structures (SLAP Triad and SLAP -C Column format), see below. Utilizing these data structures we -C have augmented each "core" method with two preconditioners: -C Diagonal Scaling and Incomplete Factorization. Diagonal scaling -C is easy to implement, vectorizes very well and for problems that -C are not too ill-conditioned reduces the number of iterations -C enough to warrant its use. On the other hand, an Incomplete -C factorization (Incomplete Cholesky for symmetric systems and -C Incomplete LU for nonsymmetric systems) may take much longer to -C calculate, but it reduces the iteration count (for most problems) -C significantly. Our implementations of IC and ILU vectorize for -C machines with hardware gather scatter, but the vector lengths can -C be quite short if the number of non-zeros in a column is not -C large. -C -C ================================================================= -C ==================== Supplied Data Structures =================== -C ================================================================= -C The following describes the data structures supplied with the -C package: SLAP Triad and Column formats. -C -C ====================== S L A P Triad format ===================== -C -C In the SLAP Triad format only the non-zeros are stored. They may -C appear in *ANY* order. The user supplies three arrays of length -C NELT, where NELT is the number of non-zeros in the matrix: -C (IA(NELT), JA(NELT), A(NELT)). If the matrix is symmetric then -C one need only store the lower triangle (including the diagonal) -C and NELT would be the corresponding number of non-zeros stored. -C For each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding location -C of the A array. This is an extremely easy data structure to -C generate. On the other hand, it is not very efficient on vector -C computers for the iterative solution of linear systems. Hence, -C SLAP changes this input data structure to the SLAP Column format -C for the iteration (but does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C nonsymmetric 5x5 Matrix. NELT=11. Recall that the entries may -C appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C ====================== S L A P Column format ==================== -C -C In the SLAP Column format the non-zeros are stored counting down -C columns (except for the diagonal entry, which must appear first -C in each "column") and are stored in the real array A. In other -C words, for each column in the matrix first put the diagonal entry -C in A. Then put in the other non-zero elements going down the -C column (except the diagonal) in order. The IA array holds the -C row index for each non-zero. The JA array holds the offsets into -C the IA, A arrays for the beginning of each column. That is, -C IA(JA(ICOL)), A(JA(ICOL)) are the first elements of the ICOL-th -C column in IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) are the -C last elements of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the matrix -C and NELT is the number of non-zeros in the matrix. If the matrix -C is symmetric one need only store the lower triangle (including -C the diagonal) and NELT would be the corresponding number of -C non-zeros stored. -C -C Here is an example of the SLAP Column storage format for a -C nonsymmetric 5x5 Matrix (in the A and IA arrays '|' denotes the -C end of a column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C ================================================================= -C ====================== Which Method To Use ====================== -C ================================================================= -C -C BACKGROUND -C In solving a large sparse linear system Ax = b using an iterative -C method, it is not necessary to actually store the matrix A. -C Rather, what is needed is a procedure for multiplying the matrix -C A times a given vector y to obtain the matrix-vector product, Ay. -C SLAP has been written to take advantage of this fact. The higher -C level routines in the package require storage only of the non-zero -C elements of A (and their positions), and even this can be -C avoided, if the user writes his own subroutine for multiplying -C the matrix times a vector and calls the lower-level iterative -C routines in the package. -C -C If the matrix A is ill-conditioned, then most iterative methods -C will be slow to converge (if they converge at all!). To improve -C the convergence rate, one may use a "matrix splitting," or, -C "preconditioning matrix," say, M. It is then necessary to solve, -C at each iteration, a linear system with coefficient matrix M. A -C good preconditioner M should have two properties: (1) M should -C "approximate" A, in the sense that the matrix inv(M)*A (or some -C variant thereof) is better conditioned than the original matrix -C A; and (2) linear systems with coefficient matrix M should be -C much easier to solve than the original system with coefficient -C matrix A. Preconditioning routines in the SLAP package are -C separate from the iterative routines, so that any of the -C preconditioners provided in the package, or one that the user -C codes himself, can be used with any of the iterative routines. -C -C CHOICE OF PRECONDITIONER -C If you willing to live with either the SLAP Triad or Column -C matrix data structure you can then choose one of two types of -C preconditioners to use: diagonal scaling or incomplete -C factorization. To choose between these two methods requires -C knowing something about the computer you're going to run these -C codes on and how well incomplete factorization approximates the -C inverse of your matrix. -C -C Let us suppose you have a scalar machine. Then, unless the -C incomplete factorization is very, very poor this is *GENERALLY* -C the method to choose. It will reduce the number of iterations -C significantly and is not all that expensive to compute. So if -C you have just one linear system to solve and "just want to get -C the job done" then try incomplete factorization first. If you -C are thinking of integrating some SLAP iterative method into your -C favorite "production code" then try incomplete factorization -C first, but also check to see that diagonal scaling is indeed -C slower for a large sample of test problems. -C -C Let us now suppose you have a vector computer with hardware -C gather/scatter support (Cray X-MP, Y-MP, SCS-40 or Cyber 205, ETA -C 10, ETA Piper, Convex C-1, etc.). Then it is much harder to -C choose between the two methods. The versions of incomplete -C factorization in SLAP do in fact vectorize, but have short vector -C lengths and the factorization step is relatively more expensive. -C Hence, for most problems (i.e., unless your problem is ill -C conditioned, sic!) diagonal scaling is faster, with its very -C fast set up time and vectorized (with long vectors) -C preconditioning step (even though it may take more iterations). -C If you have several systems (or right hand sides) to solve that -C can utilize the same preconditioner then the cost of the -C incomplete factorization can be amortized over these several -C solutions. This situation gives more advantage to the incomplete -C factorization methods. If you have a vector machine without -C hardware gather/scatter (Cray 1, Cray 2 & Cray 3) then the -C advantages for incomplete factorization are even less. -C -C If you're trying to shoehorn SLAP into your favorite "production -C code" and can not easily generate either the SLAP Triad or Column -C format then you are left to your own devices in terms of -C preconditioning. Also, you may find that the preconditioners -C supplied with SLAP are not sufficient for your problem. In this -C situation we would recommend that you talk with a numerical -C analyst versed in iterative methods about writing other -C preconditioning subroutines (e.g., polynomial preconditioning, -C shifted incomplete factorization, SOR or SSOR iteration). You -C can always "roll your own" by using the "core" iterative methods -C and supplying your own MSOLVE and MATVEC (and possibly MTSOLV and -C MTTVEC) routines. -C -C SYMMETRIC SYSTEMS -C If your matrix is symmetric then you would want to use one of the -C symmetric system solvers. If your system is also positive -C definite, (Ax,x) (Ax dot product with x) is positive for all -C non-zero vectors x, then use Conjugate Gradient (SCG, SSDCG, -C SSICSG). If you're not sure it's SPD (symmetric and Positive -C Definite) then try SCG anyway and if it works, fine. If you're -C sure your matrix is not positive definite then you may want to -C try the iterative refinement methods (SIR) or the GMRES code -C (SGMRES) if SIR converges too slowly. -C -C NONSYMMETRIC SYSTEMS -C This is currently an area of active research in numerical -C analysis and there are new strategies being developed. -C Consequently take the following advice with a grain of salt. If -C you matrix is positive definite, (Ax,x) (Ax dot product with x -C is positive for all non-zero vectors x), then you can use any of -C the methods for nonsymmetric systems (Orthomin, GMRES, -C BiConjugate Gradient, BiConjugate Gradient Squared and Conjugate -C Gradient applied to the normal equations). If your system is not -C too ill conditioned then try BiConjugate Gradient Squared (BCGS) -C or GMRES (SGMRES). Both of these methods converge very quickly -C and do not require A' or M' (' denotes transpose) information. -C SGMRES does require some additional storage, though. If the -C system is very ill conditioned or nearly positive indefinite -C ((Ax,x) is positive, but may be very small), then GMRES should -C be the first choice, but try the other methods if you have to -C fine tune the solution process for a "production code". If you -C have a great preconditioner for the normal equations (i.e., M is -C an approximation to the inverse of AA' rather than just A) then -C this is not a bad route to travel. Old wisdom would say that the -C normal equations are a disaster (since it squares the condition -C number of the system and SCG convergence is linked to this number -C of infamy), but some preconditioners (like incomplete -C factorization) can reduce the condition number back below that of -C the original system. -C -C ================================================================= -C ======================= Naming Conventions ====================== -C ================================================================= -C SLAP iterative methods, matrix vector and preconditioner -C calculation routines follow a naming convention which, when -C understood, allows one to determine the iterative method and data -C structure(s) used. The subroutine naming convention takes the -C following form: -C P[S][M]DESC -C where -C P stands for the precision (or data type) of the routine and -C is required in all names, -C S denotes whether or not the routine requires the SLAP Triad -C or Column format (it does if the second letter of the name -C is S and does not otherwise), -C M stands for the type of preconditioner used (only appears -C in drivers for "core" routines), and -C DESC is some number of letters describing the method or purpose -C of the routine. The following is a list of the "DESC" -C fields for iterative methods and their meaning: -C BCG,BC: BiConjugate Gradient -C CG: Conjugate Gradient -C CGN,CN: Conjugate Gradient on the Normal equations -C CGS,CS: biConjugate Gradient Squared -C GMRES,GMR,GM: Generalized Minimum RESidual -C IR,R: Iterative Refinement -C JAC: JACobi's method -C GS: Gauss-Seidel -C OMN,OM: OrthoMiN -C -C In the single precision version of SLAP, all routine names start -C with an S. The brackets around the S and M designate that these -C fields are optional. -C -C Here are some examples of the routines: -C 1) SBCG: Single precision BiConjugate Gradient "core" routine. -C One can deduce that this is a "core" routine, because the S and -C M fields are missing and BiConjugate Gradient is an iterative -C method. -C 2) SSDBCG: Single precision, SLAP data structure BCG with Diagonal -C scaling. -C 3) SSLUBC: Single precision, SLAP data structure BCG with incom- -C plete LU factorization as the preconditioning. -C 4) SCG: Single precision Conjugate Gradient "core" routine. -C 5) SSDCG: Single precision, SLAP data structure Conjugate Gradient -C with Diagonal scaling. -C 6) SSICCG: Single precision, SLAP data structure Conjugate Gra- -C dient with Incomplete Cholesky factorization preconditioning. -C -C -C ================================================================= -C ===================== USER CALLABLE ROUTINES ==================== -C ================================================================= -C The following is a list of the "user callable" SLAP routines and -C their one line descriptions. The headers denote the file names -C where the routines can be found, as distributed for UNIX systems. -C -C Note: Each core routine, SXXX, has a corresponding stop routine, -C ISSXXX. If the stop routine does not have the specific stop -C test the user requires (e.g., weighted infinity norm), then -C the user should modify the source for ISSXXX accordingly. -C -C ============================= sir.f ============================= -C SIR: Preconditioned Iterative Refinement Sparse Ax = b Solver. -C SSJAC: Jacobi's Method Iterative Sparse Ax = b Solver. -C SSGS: Gauss-Seidel Method Iterative Sparse Ax = b Solver. -C SSILUR: Incomplete LU Iterative Refinement Sparse Ax = b Solver. -C -C ============================= scg.f ============================= -C SCG: Preconditioned Conjugate Gradient Sparse Ax=b Solver. -C SSDCG: Diagonally Scaled Conjugate Gradient Sparse Ax=b Solver. -C SSICCG: Incomplete Cholesky Conjugate Gradient Sparse Ax=b Solver. -C -C ============================= scgn.f ============================ -C SCGN: Preconditioned CG Sparse Ax=b Solver for Normal Equations. -C SSDCGN: Diagonally Scaled CG Sparse Ax=b Solver for Normal Eqn's. -C SSLUCN: Incomplete LU CG Sparse Ax=b Solver for Normal Equations. -C -C ============================= sbcg.f ============================ -C SBCG: Preconditioned BiConjugate Gradient Sparse Ax = b Solver. -C SSDBCG: Diagonally Scaled BiConjugate Gradient Sparse Ax=b Solver. -C SSLUBC: Incomplete LU BiConjugate Gradient Sparse Ax=b Solver. -C -C ============================= scgs.f ============================ -C SCGS: Preconditioned BiConjugate Gradient Squared Ax=b Solver. -C SSDCGS: Diagonally Scaled CGS Sparse Ax=b Solver. -C SSLUCS: Incomplete LU BiConjugate Gradient Squared Ax=b Solver. -C -C ============================= somn.f ============================ -C SOMN: Preconditioned Orthomin Sparse Iterative Ax=b Solver. -C SSDOMN: Diagonally Scaled Orthomin Sparse Iterative Ax=b Solver. -C SSLUOM: Incomplete LU Orthomin Sparse Iterative Ax=b Solver. -C -C ============================ sgmres.f =========================== -C SGMRES: Preconditioned GMRES Iterative Sparse Ax=b Solver. -C SSDGMR: Diagonally Scaled GMRES Iterative Sparse Ax=b Solver. -C SSLUGM: Incomplete LU GMRES Iterative Sparse Ax=b Solver. -C -C ============================ smset.f ============================ -C The following routines are used to set up preconditioners. -C -C SSDS: Diagonal Scaling Preconditioner SLAP Set Up. -C SSDSCL: Diagonally Scales/Unscales a SLAP Column Matrix. -C SSD2S: Diagonal Scaling Preconditioner SLAP Normal Eqns Set Up. -C SS2LT: Lower Triangle Preconditioner SLAP Set Up. -C SSICS: Incomplete Cholesky Decomp. Preconditioner SLAP Set Up. -C SSILUS: Incomplete LU Decomposition Preconditioner SLAP Set Up. -C -C ============================ smvops.f =========================== -C Most of the incomplete factorization (LL' and LDU) solvers -C in this file require an intermediate routine to translate -C from the SLAP MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, -C IWORK) calling convention to the calling sequence required -C by the solve routine. This generally is accomplished by -C fishing out pointers to the preconditioner (stored in RWORK) -C from the IWORK array and then making a call to the routine -C that actually does the backsolve. -C -C SSMV: SLAP Column Format Sparse Matrix Vector Product. -C SSMTV: SLAP Column Format Sparse Matrix (transpose) Vector Prod. -C SSDI: Diagonal Matrix Vector Multiply. -C SSLI: SLAP MSOLVE for Lower Triangle Matrix (set up for SSLI2). -C SSLI2: Lower Triangle Matrix Backsolve. -C SSLLTI: SLAP MSOLVE for LDL' (IC) Fact. (set up for SLLTI2). -C SLLTI2: Backsolve routine for LDL' Factorization. -C SSLUI: SLAP MSOLVE for LDU Factorization (set up for SSLUI2). -C SSLUI2: SLAP Backsolve for LDU Factorization. -C SSLUTI: SLAP MTSOLV for LDU Factorization (set up for SSLUI4). -C SSLUI4: SLAP Backsolve for LDU Factorization. -C SSMMTI: SLAP MSOLVE for LDU Fact of Normal Eq (set up for SSMMI2). -C SSMMI2: SLAP Backsolve for LDU Factorization of Normal Equations. -C -C =========================== slaputil.f ========================== -C The following utility routines are useful additions to SLAP. -C -C SBHIN: Read Sparse Linear System in the Boeing/Harwell Format. -C SCHKW: SLAP WORK/IWORK Array Bounds Checker. -C SCPPLT: Printer Plot of SLAP Column Format Matrix. -C SS2Y: SLAP Triad to SLAP Column Format Converter. -C QS2I1R: Quick Sort Integer array, moving integer and real arrays. -C (Used by SS2Y.) -C STIN: Read in SLAP Triad Format Linear System. -C STOUT: Write out SLAP Triad Format Linear System. -C -C -C***REFERENCES 1. Mark K. Seager, A SLAP for the Masses, in -C G. F. Carey, Ed., Parallel Supercomputing: Methods, -C Algorithms and Applications, Wiley, 1989, pp.135-155. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 880715 DATE WRITTEN -C 890404 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C -----( This produced Version 2.0.1. )----- -C 891003 Rearranged list of user callable routines to agree with -C order in source deck. (FNF) -C 891004 Updated reference. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C -----( This produced Version 2.0.2. )----- -C 910506 Minor improvements to prologue. (FNF) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of reference. (FNF) -C 921019 Improved one-line descriptions, reordering some. (FNF) -C***END PROLOGUE SLPDOC -C***FIRST EXECUTABLE STATEMENT SLPDOC -C -C This is a *DUMMY* subroutine and should never be called. -C - RETURN -C------------- LAST LINE OF SLPDOC FOLLOWS ----------------------------- - END diff --git a/slatec/slvs.f b/slatec/slvs.f deleted file mode 100644 index 44bb9f3..0000000 --- a/slatec/slvs.f +++ /dev/null @@ -1,87 +0,0 @@ -*DECK SLVS - SUBROUTINE SLVS (WM, IWM, X, TEM) -C***BEGIN PROLOGUE SLVS -C***SUBSIDIARY -C***PURPOSE Subsidiary to DEBDF -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (SLVS-S, DSLVS-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C SLVS solves the linear system in the iteration scheme for the -C integrator package DEBDF. -C -C***SEE ALSO DEBDF -C***ROUTINES CALLED SGBSL, SGESL -C***COMMON BLOCKS DEBDF1 -C***REVISION HISTORY (YYMMDD) -C 800901 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C 920422 Changed DIMENSION statement. (WRB) -C***END PROLOGUE SLVS -C -CLLL. OPTIMIZE - INTEGER IWM, I, IER, IOWND, IOWNS, JSTART, KFLAG, L, MAXORD, - 1 MEBAND, METH, MITER, ML, MU, N, NFE, NJE, NQ, NQU, NST - REAL WM, X, TEM, - 1 ROWND, ROWNS, EL0, H, HMIN, HMXI, HU, TN, UROUND, - 2 DI, HL0, PHL0, R - DIMENSION WM(*), IWM(*), X(*), TEM(*) - COMMON /DEBDF1/ ROWND, ROWNS(210), - 1 EL0, H, HMIN, HMXI, HU, TN, UROUND, IOWND(14), IOWNS(6), - 2 IER, JSTART, KFLAG, L, METH, MITER, MAXORD, N, NQ, NST, NFE, - 3 NJE, NQU -C----------------------------------------------------------------------- -C THIS ROUTINE MANAGES THE SOLUTION OF THE LINEAR SYSTEM ARISING FROM -C A CHORD ITERATION. IT IS CALLED BY STOD IF MITER .NE. 0. -C IF MITER IS 1 OR 2, IT CALLS SGESL TO ACCOMPLISH THIS. -C IF MITER = 3 IT UPDATES THE COEFFICIENT H*EL0 IN THE DIAGONAL -C MATRIX, AND THEN COMPUTES THE SOLUTION. -C IF MITER IS 4 OR 5, IT CALLS SGBSL. -C COMMUNICATION WITH SLVS USES THE FOLLOWING VARIABLES.. -C WM = REAL WORK SPACE CONTAINING THE INVERSE DIAGONAL MATRIX IF MITER -C IS 3 AND THE LU DECOMPOSITION OF THE MATRIX OTHERWISE. -C STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). -C WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA.. -C WM(1) = SQRT(UROUND) (NOT USED HERE), -C WM(2) = HL0, THE PREVIOUS VALUE OF H*EL0, USED IF MITER = 3. -C IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING AT -C IWM(21), IF MITER IS 1, 2, 4, OR 5. IWM ALSO CONTAINS THE -C BAND PARAMETERS ML = IWM(1) AND MU = IWM(2) IF MITER IS 4 OR 5. -C X = THE RIGHT-HAND SIDE VECTOR ON INPUT, AND THE SOLUTION VECTOR -C ON OUTPUT, OF LENGTH N. -C TEM = VECTOR OF WORK SPACE OF LENGTH N, NOT USED IN THIS VERSION. -C IER = OUTPUT FLAG (IN COMMON). IER = 0 IF NO TROUBLE OCCURRED. -C IER = -1 IF A SINGULAR MATRIX AROSE WITH MITER = 3. -C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, MITER, AND N. -C----------------------------------------------------------------------- -C***FIRST EXECUTABLE STATEMENT SLVS - IER = 0 - GO TO (100, 100, 300, 400, 400), MITER - 100 CALL SGESL (WM(3), N, N, IWM(21), X, 0) - RETURN -C - 300 PHL0 = WM(2) - HL0 = H*EL0 - WM(2) = HL0 - IF (HL0 .EQ. PHL0) GO TO 330 - R = HL0/PHL0 - DO 320 I = 1,N - DI = 1.0E0 - R*(1.0E0 - 1.0E0/WM(I+2)) - IF (ABS(DI) .EQ. 0.0E0) GO TO 390 - 320 WM(I+2) = 1.0E0/DI - 330 DO 340 I = 1,N - 340 X(I) = WM(I+2)*X(I) - RETURN - 390 IER = -1 - RETURN -C - 400 ML = IWM(1) - MU = IWM(2) - MEBAND = 2*ML + MU + 1 - CALL SGBSL (WM(3), MEBAND, N, ML, MU, IWM(21), X, 0) - RETURN -C----------------------- END OF SUBROUTINE SLVS ----------------------- - END diff --git a/slatec/smout.f b/slatec/smout.f deleted file mode 100644 index 104112a..0000000 --- a/slatec/smout.f +++ /dev/null @@ -1,161 +0,0 @@ -*DECK SMOUT - SUBROUTINE SMOUT (M, N, LDA, A, IFMT, IDIGIT) -C***BEGIN PROLOGUE SMOUT -C***SUBSIDIARY -C***PURPOSE Subsidiary to FC and SBOCLS -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (SMOUT-S, DMOUT-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C SINGLE PRECISION MATRIX OUTPUT ROUTINE. -C -C INPUT.. -C -C M,N,LDA,A(*,*) PRINT THE SINGLE PRECISION ARRAY A(I,J),I = 1,...,M, -C J=1,...,N, ON OUTPUT UNIT LOUT=6. LDA IS THE DECLARED -C FIRST DIMENSION OF A(*,*) AS SPECIFIED IN THE CALLING -C PROGRAM. THE HEADING IN THE FORTRAN FORMAT STATEMENT -C IFMT(*), DESCRIBED BELOW, IS PRINTED AS A FIRST STEP. -C THE COMPONENTS A(I,J) ARE INDEXED, ON OUTPUT, IN A -C PLEASANT FORMAT. -C IFMT(*) A FORTRAN FORMAT STATEMENT. THIS IS PRINTED ON -C OUTPUT UNIT LOUT=6 WITH THE VARIABLE FORMAT FORTRAN -C STATEMENT -C WRITE(LOUT,IFMT). -C IDIGIT PRINT AT LEAST ABS(IDIGIT) DECIMAL DIGITS PER NUMBER. -C THE SUBPROGRAM WILL CHOOSE THAT INTEGER 4,6,10, OR 14 -C WHICH WILL PRINT AT LEAST ABS(IDIGIT) NUMBER OF -C PLACES. IF IDIGIT.LT.0, 72 PRINTING COLUMNS ARE -C UTILIZED TO WRITE EACH LINE OF OUTPUT OF THE ARRAY -C A(*,*). (THIS CAN BE USED ON MOST TIME-SHARING -C TERMINALS). IF IDIGIT.GE.0, 133 PRINTING COLUMNS ARE -C UTILIZED. (THIS CAN BE USED ON MOST LINE PRINTERS). -C -C EXAMPLE.. -C -C PRINT AN ARRAY CALLED (SIMPLEX TABLEAU ) OF SIZE 10 BY 20 SHOWING -C 6 DECIMAL DIGITS PER NUMBER. THE USER IS RUNNING ON A TIME-SHARING -C SYSTEM WITH A 72 COLUMN OUTPUT DEVICE. -C -C DIMENSION TABLEU(20,20) -C M = 10 -C N = 20 -C LDTABL = 20 -C IDIGIT = -6 -C CALL SMOUT(M,N,LDTABL,TABLEU,21H(16H1SIMPLEX TABLEAU),IDIGIT) -C -C***SEE ALSO FC, SBOCLS -C***ROUTINES CALLED I1MACH -C***REVISION HISTORY (YYMMDD) -C 780801 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891107 Added comma after 1P edit descriptor in FORMAT -C statements. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE SMOUT - DIMENSION A(LDA,*) - CHARACTER IFMT*(*),ICOL*3 - SAVE ICOL - DATA ICOL /'COL'/ -C***FIRST EXECUTABLE STATEMENT SMOUT - LOUT=I1MACH(2) - WRITE(LOUT,IFMT) - IF(M.LE.0.OR.N.LE.0.OR.LDA.LE.0) RETURN - NDIGIT = IDIGIT - IF(IDIGIT.EQ.0) NDIGIT = 4 - IF(IDIGIT.GE.0) GO TO 80 -C - NDIGIT = -IDIGIT - IF(NDIGIT.GT.4) GO TO 20 -C - DO 10 K1=1,N,5 - K2 = MIN(N,K1+4) - WRITE(LOUT,1000) (ICOL,I,I = K1, K2) - DO 10 I = 1, M - WRITE(LOUT,1004) I,(A(I,J),J = K1, K2) - 10 CONTINUE - RETURN -C - 20 CONTINUE - IF(NDIGIT.GT.6) GO TO 40 -C - DO 30 K1=1,N,4 - K2 = MIN(N,K1+3) - WRITE(LOUT,1001) (ICOL,I,I = K1, K2) - DO 30 I = 1, M - WRITE(LOUT,1005) I,(A(I,J),J = K1, K2) - 30 CONTINUE - RETURN -C - 40 CONTINUE - IF(NDIGIT.GT.10) GO TO 60 -C - DO 50 K1=1,N,3 - K2=MIN(N,K1+2) - WRITE(LOUT,1002) (ICOL,I,I = K1, K2) - DO 50 I = 1, M - WRITE(LOUT,1006) I,(A(I,J),J = K1, K2) - 50 CONTINUE - RETURN -C - 60 CONTINUE - DO 70 K1=1,N,2 - K2 = MIN(N,K1+1) - WRITE(LOUT,1003) (ICOL,I,I = K1, K2) - DO 70 I = 1, M - WRITE(LOUT,1007) I,(A(I,J),J = K1, K2) - 70 CONTINUE - RETURN -C - 80 CONTINUE - IF(NDIGIT.GT.4) GO TO 100 -C - DO 90 K1=1,N,10 - K2 = MIN(N,K1+9) - WRITE(LOUT,1000) (ICOL,I,I = K1, K2) - DO 90 I = 1, M - WRITE(LOUT,1004) I,(A(I,J),J = K1, K2) - 90 CONTINUE - RETURN -C - 100 CONTINUE - IF(NDIGIT.GT.6) GO TO 120 -C - DO 110 K1=1,N,8 - K2 = MIN(N,K1+7) - WRITE(LOUT,1001) (ICOL,I,I = K1, K2) - DO 110 I = 1, M - WRITE(LOUT,1005) I,(A(I,J),J = K1, K2) - 110 CONTINUE - RETURN -C - 120 CONTINUE - IF(NDIGIT.GT.10) GO TO 140 -C - DO 130 K1=1,N,6 - K2 = MIN(N,K1+5) - WRITE(LOUT,1002) (ICOL,I,I = K1, K2) - DO 130 I = 1, M - WRITE(LOUT,1006) I,(A(I,J),J = K1, K2) - 130 CONTINUE - RETURN -C - 140 CONTINUE - DO 150 K1=1,N,5 - K2 = MIN(N,K1+4) - WRITE(LOUT,1003) (ICOL,I,I = K1, K2) - DO 150 I = 1, M - WRITE(LOUT,1007) I,(A(I,J),J = K1, K2) - 150 CONTINUE - RETURN - 1000 FORMAT(10X,10(4X,A,I4,1X)) - 1001 FORMAT(10X,8(5X,A,I4,2X)) - 1002 FORMAT(10X,6(7X,A,I4,4X)) - 1003 FORMAT(10X,5(9X,A,I4,6X)) - 1004 FORMAT(1X,3HROW,I4,2X,1P,10E12.3) - 1005 FORMAT(1X,3HROW,I4,2X,1P,8E14.5) - 1006 FORMAT(1X,3HROW,I4,2X,1P,6E18.9) - 1007 FORMAT(1X,3HROW,I4,2X,1P,5E22.13) - END diff --git a/slatec/snbco.f b/slatec/snbco.f deleted file mode 100644 index 7539063..0000000 --- a/slatec/snbco.f +++ /dev/null @@ -1,273 +0,0 @@ -*DECK SNBCO - SUBROUTINE SNBCO (ABE, LDA, N, ML, MU, IPVT, RCOND, Z) -C***BEGIN PROLOGUE SNBCO -C***PURPOSE Factor a band matrix using Gaussian elimination and -C estimate the condition number. -C***LIBRARY SLATEC -C***CATEGORY D2A2 -C***TYPE SINGLE PRECISION (SNBCO-S, DNBCO-D, CNBCO-C) -C***KEYWORDS BANDED, LINEAR EQUATIONS, MATRIX FACTORIZATION, -C NONSYMMETRIC -C***AUTHOR Voorhees, E. A., (LANL) -C***DESCRIPTION -C -C SNBCO factors a real band matrix by Gaussian -C elimination and estimates the condition of the matrix. -C -C If RCOND is not needed, SNBFA is slightly faster. -C To solve A*X = B , follow SNBCO by SNBSL. -C To compute INVERSE(A)*C , follow SNBCO by SNBSL. -C To compute DETERMINANT(A) , follow SNBCO by SNBDI. -C -C On Entry -C -C ABE REAL(LDA, NC) -C contains the matrix in band storage. The rows -C of the original matrix are stored in the rows -C of ABE and the diagonals of the original matrix -C are stored in columns 1 through ML+MU+1 of ABE. -C NC must be .GE. 2*ML+MU+1 . -C See the comments below for details. -C -C LDA INTEGER -C the leading dimension of the array ABE. -C LDA must be .GE. N . -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 ABE an upper triangular matrix in band storage -C and 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 REAL -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 REAL(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 DO 20 I = 1, N -C J1 = MAX(1, I-ML) -C J2 = MIN(N, I+MU) -C DO 10 J = J1, J2 -C K = J - I + ML + 1 -C ABE(I,K) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C This uses columns 1 through ML+MU+1 of ABE . -C Furthermore, ML additional columns are needed in -C ABE starting with column ML+MU+2 for elements -C generated during the triangularization. The total -C number of columns needed in ABE is 2*ML+MU+1 . -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 ABE should contain -C -C * 11 12 13 + , * = not used -C 21 22 23 24 + , + = used for pivoting -C 32 33 34 35 + -C 43 44 45 46 + -C 54 55 56 * + -C 65 66 * * + -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SASUM, SAXPY, SDOT, SNBFA, SSCAL -C***REVISION HISTORY (YYMMDD) -C 800723 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SNBCO - INTEGER LDA,N,ML,MU,IPVT(*) - REAL ABE(LDA,*),Z(*) - REAL RCOND -C - REAL SDOT,EK,T,WK,WKM - REAL ANORM,S,SASUM,SM,YNORM - INTEGER I,INFO,J,JU,K,KB,KP1,L,LDB,LM,LZ,M,ML1,MM,NL,NU -C***FIRST EXECUTABLE STATEMENT SNBCO - ML1=ML+1 - LDB = LDA - 1 - ANORM = 0.0E0 - DO 10 J = 1, N - NU = MIN(MU,J-1) - NL = MIN(ML,N-J) - L = 1 + NU + NL - ANORM = MAX(ANORM,SASUM(L,ABE(J+NL,ML1-NL),LDB)) - 10 CONTINUE -C -C FACTOR -C - CALL SNBFA(ABE,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.0E0 - DO 20 J = 1, N - Z(J) = 0.0E0 - 20 CONTINUE - M = ML + MU + 1 - JU = 0 - DO 100 K = 1, N - IF (Z(K) .NE. 0.0E0) EK = SIGN(EK,-Z(K)) - IF (ABS(EK-Z(K)) .LE. ABS(ABE(K,ML1))) GO TO 30 - S = ABS(ABE(K,ML1))/ABS(EK-Z(K)) - CALL SSCAL(N,S,Z,1) - EK = S*EK - 30 CONTINUE - WK = EK - Z(K) - WKM = -EK - Z(K) - S = ABS(WK) - SM = ABS(WKM) - IF (ABE(K,ML1) .EQ. 0.0E0) GO TO 40 - WK = WK/ABE(K,ML1) - WKM = WKM/ABE(K,ML1) - GO TO 50 - 40 CONTINUE - WK = 1.0E0 - WKM = 1.0E0 - 50 CONTINUE - KP1 = K + 1 - JU = MIN(MAX(JU,MU+IPVT(K)),N) - MM = ML1 - IF (KP1 .GT. JU) GO TO 90 - DO 60 I = KP1, JU - MM = MM + 1 - SM = SM + ABS(Z(I)+WKM*ABE(K,MM)) - Z(I) = Z(I) + WK*ABE(K,MM) - S = S + ABS(Z(I)) - 60 CONTINUE - IF (S .GE. SM) GO TO 80 - T = WKM -WK - WK = WKM - MM = ML1 - DO 70 I = KP1, JU - MM = MM + 1 - Z(I) = Z(I) + T*ABE(K,MM) - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - Z(K) = WK - 100 CONTINUE - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) -C -C SOLVE TRANS(L)*Y = W -C - DO 120 KB = 1, N - K = N + 1 - KB - NL = MIN(ML,N-K) - IF (K .LT. N) Z(K) = Z(K) + SDOT(NL,ABE(K+NL,ML1-NL),-LDB,Z(K+1) - 1 ,1) - IF (ABS(Z(K)) .LE. 1.0E0) GO TO 110 - S = 1.0E0/ABS(Z(K)) - CALL SSCAL(N,S,Z,1) - 110 CONTINUE - L = IPVT(K) - T = Z(L) - Z(L) = Z(K) - Z(K) = T - 120 CONTINUE - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) -C - YNORM = 1.0E0 -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 - NL = MIN(ML,N-K) - IF (K .LT. N) CALL SAXPY(NL,T,ABE(K+NL,ML1-NL),-LDB,Z(K+1),1) - IF (ABS(Z(K)) .LE. 1.0E0) GO TO 130 - S = 1.0E0/ABS(Z(K)) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM - 130 CONTINUE - 140 CONTINUE - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE U*Z = V -C - DO 160 KB = 1, N - K = N + 1 - KB - IF (ABS(Z(K)) .LE. ABS(ABE(K,ML1))) GO TO 150 - S = ABS(ABE(K,ML1))/ABS(Z(K)) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM - 150 CONTINUE - IF (ABE(K,ML1) .NE. 0.0E0) Z(K) = Z(K)/ABE(K,ML1) - IF (ABE(K,ML1) .EQ. 0.0E0) Z(K) = 1.0E0 - LM = MIN(K,M) - 1 - LZ = K - LM - T = -Z(K) - CALL SAXPY(LM,T,ABE(K-1,ML+2),-LDB,Z(LZ),1) - 160 CONTINUE -C MAKE ZNORM = 1.0E0 - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM -C - IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM - IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0 - RETURN - END diff --git a/slatec/snbdi.f b/slatec/snbdi.f deleted file mode 100644 index fc2f66a..0000000 --- a/slatec/snbdi.f +++ /dev/null @@ -1,82 +0,0 @@ -*DECK SNBDI - SUBROUTINE SNBDI (ABE, LDA, N, ML, MU, IPVT, DET) -C***BEGIN PROLOGUE SNBDI -C***PURPOSE Compute the determinant of a band matrix using the factors -C computed by SNBCO or SNBFA. -C***LIBRARY SLATEC -C***CATEGORY D3A2 -C***TYPE SINGLE PRECISION (SNBDI-S, DNBDI-D, CNBDI-C) -C***KEYWORDS BANDED, DETERMINANT, LINEAR EQUATIONS, NONSYMMETRIC -C***AUTHOR Voorhees, E. A., (LANL) -C***DESCRIPTION -C -C SNBDI computes the determinant of a band matrix -C using the factors computed by SNBCO or SNBFA. -C If the inverse is needed, use SNBSL N times. -C -C On Entry -C -C ABE REAL(LDA, NC) -C the output from SNBCO or SNBFA. -C NC must be .GE. 2*ML+MU+1 . -C -C LDA INTEGER -C the leading dimension of the array ABE . -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 SNBCO or SNBFA. -C -C On Return -C -C DET REAL(2) -C determinant of original matrix. -C Determinant = DET(1) * 10.0**DET(2) -C with 1.0 .LE. ABS(DET(1)) .LT. 10.0 -C or DET(1) = 0.0 . -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 800725 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SNBDI - INTEGER LDA,N,ML,MU,IPVT(*) - REAL ABE(LDA,*),DET(2) -C - REAL TEN - INTEGER I -C***FIRST EXECUTABLE STATEMENT SNBDI - DET(1) = 1.0E0 - DET(2) = 0.0E0 - TEN = 10.0E0 - DO 50 I = 1, N - IF (IPVT(I) .NE. I) DET(1) = -DET(1) - DET(1) = ABE(I,ML+1)*DET(1) - IF (DET(1) .EQ. 0.0E0) GO TO 60 - 10 IF (ABS(DET(1)) .GE. 1.0E0) GO TO 20 - DET(1) = TEN*DET(1) - DET(2) = DET(2) - 1.0E0 - GO TO 10 - 20 CONTINUE - 30 IF (ABS(DET(1)) .LT. TEN) GO TO 40 - DET(1) = DET(1)/TEN - DET(2) = DET(2) + 1.0E0 - GO TO 30 - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE - RETURN - END diff --git a/slatec/snbfa.f b/slatec/snbfa.f deleted file mode 100644 index 38ccf44..0000000 --- a/slatec/snbfa.f +++ /dev/null @@ -1,179 +0,0 @@ -*DECK SNBFA - SUBROUTINE SNBFA (ABE, LDA, N, ML, MU, IPVT, INFO) -C***BEGIN PROLOGUE SNBFA -C***PURPOSE Factor a real band matrix by elimination. -C***LIBRARY SLATEC -C***CATEGORY D2A2 -C***TYPE SINGLE PRECISION (SNBFA-S, DNBFA-D, CNBFA-C) -C***KEYWORDS BANDED, LINEAR EQUATIONS, MATRIX FACTORIZATION, -C NONSYMMETRIC -C***AUTHOR Voorhees, E. A., (LANL) -C***DESCRIPTION -C -C SNBFA factors a real band matrix by elimination. -C -C SNBFA is usually called by SNBCO, but it can be called -C directly with a saving in time if RCOND is not needed. -C -C On Entry -C -C ABE REAL(LDA, NC) -C contains the matrix in band storage. The rows -C of the original matrix are stored in the rows -C of ABE and the diagonals of the original matrix -C are stored in columns 1 through ML+MU+1 of ABE. -C NC must be .GE. 2*ML+MU+1 . -C See the comments below for details. -C -C LDA INTEGER -C the leading dimension of the array ABE. -C LDA must be .GE. N . -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 ABE an upper triangular matrix in band storage -C and 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 SNBSL will divide by zero if -C called. Use RCOND in SNBCO 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 DO 20 I = 1, N -C J1 = MAX(1, I-ML) -C J2 = MIN(N, I+MU) -C DO 10 J = J1, J2 -C K = J - I + ML + 1 -C ABE(I,K) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C This uses columns 1 through ML+MU+1 of ABE . -C Furthermore, ML additional columns are needed in -C ABE starting with column ML+MU+2 for elements -C generated during the triangularization. The total -C number of columns needed in ABE is 2*ML+MU+1 . -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 ABE should contain -C -C * 11 12 13 + , * = not used -C 21 22 23 24 + , + = used for pivoting -C 32 33 34 35 + -C 43 44 45 46 + -C 54 55 56 * + -C 65 66 * * + -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED ISAMAX, SAXPY, SSCAL, SSWAP -C***REVISION HISTORY (YYMMDD) -C 800606 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SNBFA - INTEGER LDA,N,ML,MU,IPVT(*),INFO - REAL ABE(LDA,*) -C - INTEGER ML1,MB,M,N1,LDB,I,J,K,L,LM,LM1,LM2,MP,ISAMAX - REAL T -C***FIRST EXECUTABLE STATEMENT SNBFA - ML1=ML+1 - MB=ML+MU - M=ML+MU+1 - N1=N-1 - LDB=LDA-1 - INFO=0 -C -C SET FILL-IN COLUMNS TO ZERO -C - IF(N.LE.1)GO TO 50 - IF(ML.LE.0)GO TO 7 - DO 6 J=1,ML - DO 5 I=1,N - ABE(I,M+J)=0.0E0 - 5 CONTINUE - 6 CONTINUE - 7 CONTINUE -C -C GAUSSIAN ELIMINATION WITH PARTIAL ELIMINATION -C - DO 40 K=1,N1 - LM=MIN(N-K,ML) - LM1=LM+1 - LM2=ML1-LM -C -C SEARCH FOR PIVOT INDEX -C - L=-ISAMAX(LM1,ABE(LM+K,LM2),LDB)+LM1+K - IPVT(K)=L - MP=MIN(MB,N-K) -C -C SWAP ROWS IF NECESSARY -C - IF(L.NE.K)CALL SSWAP(MP+1,ABE(K,ML1),LDA,ABE(L,ML1+K-L),LDA) -C -C SKIP COLUMN REDUCTION IF PIVOT IS ZERO -C - IF(ABE(K,ML1).EQ.0.0E0) GO TO 20 -C -C COMPUTE MULTIPLIERS -C - T=-1.0/ABE(K,ML1) - CALL SSCAL(LM,T,ABE(LM+K,LM2),LDB) -C -C ROW ELIMINATION WITH COLUMN INDEXING -C - DO 10 J=1,MP - CALL SAXPY (LM,ABE(K,ML1+J),ABE(LM+K,LM2),LDB,ABE(LM+K,LM2+J), - 1 LDB) - 10 CONTINUE - GO TO 30 - 20 CONTINUE - INFO=K - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - IPVT(N)=N - IF(ABE(N,ML1).EQ.0.0E0) INFO=N - RETURN - END diff --git a/slatec/snbfs.f b/slatec/snbfs.f deleted file mode 100644 index 7610930..0000000 --- a/slatec/snbfs.f +++ /dev/null @@ -1,249 +0,0 @@ -*DECK SNBFS - SUBROUTINE SNBFS (ABE, LDA, N, ML, MU, V, ITASK, IND, WORK, IWORK) -C***BEGIN PROLOGUE SNBFS -C***PURPOSE Solve a general nonsymmetric banded system of linear -C equations. -C***LIBRARY SLATEC -C***CATEGORY D2A2 -C***TYPE SINGLE PRECISION (SNBFS-S, DNBFS-D, CNBFS-C) -C***KEYWORDS BANDED, LINEAR EQUATIONS, NONSYMMETRIC -C***AUTHOR Voorhees, E. A., (LANL) -C***DESCRIPTION -C -C Subroutine SNBFS solves a general nonsymmetric banded NxN -C system of single precision real linear equations using -C SLATEC subroutines SNBCO and SNBSL. These are adaptations -C of the LINPACK subroutines SBGCO and SGBSL, which require -C a different format for storing the matrix elements. If -C A is an NxN real matrix and if X and B are real -C N-vectors, then SNBFS solves the equation -C -C A*X=B. -C -C A band matrix is a matrix whose nonzero elements are all -C fairly near the main diagonal, specifically A(I,J) = 0 -C if I-J is greater than ML or J-I is greater than -C MU . The integers ML and MU are called the lower and upper -C band widths and M = ML+MU+1 is the total band width. -C SNBFS uses less time and storage than the corresponding -C program for general matrices (SGEFS) if 2*ML+MU .LT. N . -C -C The matrix A is first factored into upper and lower tri- -C angular matrices U and L using partial pivoting. These -C factors and the pivoting information are used to find the -C solution vector X. An approximate condition number is -C calculated to provide a rough estimate of the number of -C digits of accuracy in the computed solution. -C -C If the equation A*X=B is to be solved for more than one vector -C B, the factoring of A does not need to be performed again and -C the option to only solve (ITASK .GT. 1) will be faster for -C the succeeding solutions. In this case, the contents of A, -C LDA, N and IWORK must not have been altered by the user follow- -C ing factorization (ITASK=1). IND will not be changed by SNBFS -C in this case. -C -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 DO 20 I = 1, N -C J1 = MAX(1, I-ML) -C J2 = MIN(N, I+MU) -C DO 10 J = J1, J2 -C K = J - I + ML + 1 -C ABE(I,K) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C This uses columns 1 through ML+MU+1 of ABE . -C Furthermore, ML additional columns are needed in -C ABE starting with column ML+MU+2 for elements -C generated during the triangularization. The total -C number of columns needed in ABE is 2*ML+MU+1 . -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 ABE should contain -C -C * 11 12 13 + , * = not used -C 21 22 23 24 + , + = used for pivoting -C 32 33 34 35 + -C 43 44 45 46 + -C 54 55 56 * + -C 65 66 * * + -C -C -C Argument Description *** -C -C ABE REAL(LDA,NC) -C on entry, contains the matrix in band storage as -C described above. NC must not be less than -C 2*ML+MU+1 . The user is cautioned to specify NC -C with care since it is not an argument and cannot -C be checked by SNBFS. The rows of the original -C matrix are stored in the rows of ABE and the -C diagonals of the original matrix are stored in -C columns 1 through ML+MU+1 of ABE . -C on return, contains an upper triangular matrix U and -C the multipliers necessary to construct a matrix L -C so that A=L*U. -C LDA INTEGER -C the leading dimension of array ABE. LDA must be great- -C er than or equal to N. (terminal error message IND=-1) -C N INTEGER -C the order of the matrix A. N must be greater -C than or equal to 1 . (terminal error message IND=-2) -C ML INTEGER -C the number of diagonals below the main diagonal. -C ML must not be less than zero nor greater than or -C equal to N . (terminal error message IND=-5) -C MU INTEGER -C the number of diagonals above the main diagonal. -C MU must not be less than zero nor greater than or -C equal to N . (terminal error message IND=-6) -C V REAL(N) -C on entry, the singly subscripted array(vector) of di- -C mension N which contains the right hand side B of a -C system of simultaneous linear equations A*X=B. -C on return, V contains the solution vector, X . -C ITASK INTEGER -C If ITASK=1, the matrix A is factored and then the -C linear equation is solved. -C If ITASK .GT. 1, the equation is solved using the existing -C factored matrix A and IWORK. -C If ITASK .LT. 1, then terminal error message IND=-3 is -C printed. -C IND INTEGER -C GT. 0 IND is a rough estimate of the number of digits -C of accuracy in the solution, X. -C LT. 0 See error message corresponding to IND below. -C WORK REAL(N) -C a singly subscripted array of dimension at least N. -C IWORK INTEGER(N) -C a singly subscripted array of dimension at least N. -C -C Error Messages Printed *** -C -C IND=-1 terminal N is greater than LDA. -C IND=-2 terminal N is less than 1. -C IND=-3 terminal ITASK is less than 1. -C IND=-4 terminal the matrix A is computationally singular. -C A solution has not been computed. -C IND=-5 terminal ML is less than zero or is greater than -C or equal to N . -C IND=-6 terminal MU is less than zero or is greater than -C or equal to N . -C IND=-10 warning the solution has no apparent significance. -C The solution may be inaccurate or the matrix -C A may be poorly scaled. -C -C Note- The above terminal(*fatal*) error messages are -C designed to be handled by XERMSG in which -C LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 -C for warning error messages from XERMSG. Unless -C the user provides otherwise, an error message -C will be printed followed by an abort. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED R1MACH, SNBCO, SNBSL, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800808 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 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 SNBFS -C - INTEGER LDA,N,ITASK,IND,IWORK(*),ML,MU - REAL ABE(LDA,*),V(*),WORK(*),R1MACH - REAL RCOND - CHARACTER*8 XERN1, XERN2 -C***FIRST EXECUTABLE STATEMENT SNBFS - IF (LDA.LT.N) THEN - IND = -1 - WRITE (XERN1, '(I8)') LDA - WRITE (XERN2, '(I8)') N - CALL XERMSG ('SLATEC', 'SNBFS', 'LDA = ' // XERN1 // - * ' IS LESS THAN N = ' // XERN2, -1, 1) - RETURN - ENDIF -C - IF (N.LE.0) THEN - IND = -2 - WRITE (XERN1, '(I8)') N - CALL XERMSG ('SLATEC', 'SNBFS', 'N = ' // XERN1 // - * ' IS LESS THAN 1', -2, 1) - RETURN - ENDIF -C - IF (ITASK.LT.1) THEN - IND = -3 - WRITE (XERN1, '(I8)') ITASK - CALL XERMSG ('SLATEC', 'SNBFS', 'ITASK = ' // XERN1 // - * ' IS LESS THAN 1', -3, 1) - RETURN - ENDIF -C - IF (ML.LT.0 .OR. ML.GE.N) THEN - IND = -5 - WRITE (XERN1, '(I8)') ML - CALL XERMSG ('SLATEC', 'SNBFS', - * 'ML = ' // XERN1 // ' IS OUT OF RANGE', -5, 1) - RETURN - ENDIF -C - IF (MU.LT.0 .OR. MU.GE.N) THEN - IND = -6 - WRITE (XERN1, '(I8)') MU - CALL XERMSG ('SLATEC', 'SNBFS', - * 'MU = ' // XERN1 // ' IS OUT OF RANGE', -6, 1) - RETURN - ENDIF -C - IF (ITASK.EQ.1) THEN -C -C FACTOR MATRIX A INTO LU -C - CALL SNBCO(ABE,LDA,N,ML,MU,IWORK,RCOND,WORK) -C -C CHECK FOR COMPUTATIONALLY SINGULAR MATRIX -C - IF (RCOND.EQ.0.0) THEN - IND = -4 - CALL XERMSG ('SLATEC', 'SNBFS', - * 'SINGULAR MATRIX A - NO SOLUTION', -4, 1) - RETURN - ENDIF -C -C COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) -C AND CHECK FOR IND GREATER THAN ZERO -C - IND = -LOG10(R1MACH(4)/RCOND) - IF (IND.LE.0) THEN - IND = -10 - CALL XERMSG ('SLATEC', 'SNBFS', - * 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) - ENDIF - ENDIF -C -C SOLVE AFTER FACTORING -C - CALL SNBSL(ABE,LDA,N,ML,MU,IWORK,V,0) - RETURN - END diff --git a/slatec/snbir.f b/slatec/snbir.f deleted file mode 100644 index 5bb56a6..0000000 --- a/slatec/snbir.f +++ /dev/null @@ -1,284 +0,0 @@ -*DECK SNBIR - SUBROUTINE SNBIR (ABE, LDA, N, ML, MU, V, ITASK, IND, WORK, IWORK) -C***BEGIN PROLOGUE SNBIR -C***PURPOSE Solve a general nonsymmetric banded system of linear -C equations. Iterative refinement is used to obtain an error -C estimate. -C***LIBRARY SLATEC -C***CATEGORY D2A2 -C***TYPE SINGLE PRECISION (SNBIR-S, CNBIR-C) -C***KEYWORDS BANDED, LINEAR EQUATIONS, NONSYMMETRIC -C***AUTHOR Voorhees, E. A., (LANL) -C***DESCRIPTION -C -C Subroutine SNBIR solves a general nonsymmetric banded NxN -C system of single precision real linear equations using -C SLATEC subroutines SNBFA and SNBSL. These are adaptations -C of the LINPACK subroutines SGBFA and SGBSL, which require -C a different format for storing the matrix elements. -C One pass of iterative refinement is used only to obtain an -C estimate of the accuracy. If A is an NxN real banded -C matrix and if X and B are real N-vectors, then SNBIR -C solves the equation -C -C A*X=B. -C -C A band matrix is a matrix whose nonzero elements are all -C fairly near the main diagonal, specifically A(I,J) = 0 -C if I-J is greater than ML or J-I is greater than -C MU . The integers ML and MU are called the lower and upper -C band widths and M = ML+MU+1 is the total band width. -C SNBIR uses less time and storage than the corresponding -C program for general matrices (SGEIR) if 2*ML+MU .LT. N . -C -C The matrix A is first factored into upper and lower tri- -C angular matrices U and L using partial pivoting. These -C factors and the pivoting information are used to find the -C solution vector X . Then the residual vector is found and used -C to calculate an estimate of the relative error, IND . IND esti- -C mates the accuracy of the solution only when the input matrix -C and the right hand side are represented exactly in the computer -C and does not take into account any errors in the input data. -C -C If the equation A*X=B is to be solved for more than one vector -C B, the factoring of A does not need to be performed again and -C the option to only solve (ITASK .GT. 1) will be faster for -C the succeeding solutions. In this case, the contents of A, LDA, -C N, work and IWORK must not have been altered by the user follow- -C ing factorization (ITASK=1). IND will not be changed by SNBIR -C in this case. -C -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 DO 20 I = 1, N -C J1 = MAX(1, I-ML) -C J2 = MIN(N, I+MU) -C DO 10 J = J1, J2 -C K = J - I + ML + 1 -C ABE(I,K) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C This uses columns 1 Through ML+MU+1 of ABE . -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 ABE should contain -C -C * 11 12 13 , * = not used -C 21 22 23 24 -C 32 33 34 35 -C 43 44 45 46 -C 54 55 56 * -C 65 66 * * -C -C -C Argument Description *** -C -C ABE REAL(LDA,MM) -C on entry, contains the matrix in band storage as -C described above. MM must not be less than M = -C ML+MU+1 . The user is cautioned to dimension ABE -C with care since MM is not an argument and cannot -C be checked by SNBIR. The rows of the original -C matrix are stored in the rows of ABE and the -C diagonals of the original matrix are stored in -C columns 1 through ML+MU+1 of ABE . ABE is -C not altered by the program. -C LDA INTEGER -C the leading dimension of array ABE. LDA must be great- -C er than or equal to N. (terminal error message IND=-1) -C N INTEGER -C the order of the matrix A. N must be greater -C than or equal to 1 . (terminal error message IND=-2) -C ML INTEGER -C the number of diagonals below the main diagonal. -C ML must not be less than zero nor greater than or -C equal to N . (terminal error message IND=-5) -C MU INTEGER -C the number of diagonals above the main diagonal. -C MU must not be less than zero nor greater than or -C equal to N . (terminal error message IND=-6) -C V REAL(N) -C on entry, the singly subscripted array(vector) of di- -C mension N which contains the right hand side B of a -C system of simultaneous linear equations A*X=B. -C on return, V contains the solution vector, X . -C ITASK INTEGER -C If ITASK=1, the matrix A is factored and then the -C linear equation is solved. -C If ITASK .GT. 1, the equation is solved using the existing -C factored matrix A and IWORK. -C If ITASK .LT. 1, then terminal error message IND=-3 is -C printed. -C IND INTEGER -C GT. 0 IND is a rough estimate of the number of digits -C of accuracy in the solution, X . IND=75 means -C that the solution vector X is zero. -C LT. 0 See error message corresponding to IND below. -C WORK REAL(N*(NC+1)) -C a singly subscripted array of dimension at least -C N*(NC+1) where NC = 2*ML+MU+1 . -C IWORK INTEGER(N) -C a singly subscripted array of dimension at least N. -C -C Error Messages Printed *** -C -C IND=-1 terminal N is greater than LDA. -C IND=-2 terminal N is less than 1. -C IND=-3 terminal ITASK is less than 1. -C IND=-4 terminal the matrix A is computationally singular. -C A solution has not been computed. -C IND=-5 terminal ML is less than zero or is greater than -C or equal to N . -C IND=-6 terminal MU is less than zero or is greater than -C or equal to N . -C IND=-10 warning the solution has no apparent significance. -C The solution may be inaccurate or the matrix -C A may be poorly scaled. -C -C Note- The above terminal(*fatal*) error messages are -C designed to be handled by XERMSG in which -C LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 -C for warning error messages from XERMSG. Unless -C the user provides otherwise, an error message -C will be printed followed by an abort. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED R1MACH, SASUM, SCOPY, SDSDOT, SNBFA, SNBSL, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800815 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 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 SNBIR -C - INTEGER LDA,N,ITASK,IND,IWORK(*),INFO,J,K,KK,L,M,ML,MU,NC - REAL ABE(LDA,*),V(*),WORK(N,*),XNORM,DNORM,SDSDOT,SASUM,R1MACH - CHARACTER*8 XERN1, XERN2 -C***FIRST EXECUTABLE STATEMENT SNBIR - IF (LDA.LT.N) THEN - IND = -1 - WRITE (XERN1, '(I8)') LDA - WRITE (XERN2, '(I8)') N - CALL XERMSG ('SLATEC', 'SNBIR', 'LDA = ' // XERN1 // - * ' IS LESS THAN N = ' // XERN2, -1, 1) - RETURN - ENDIF -C - IF (N.LE.0) THEN - IND = -2 - WRITE (XERN1, '(I8)') N - CALL XERMSG ('SLATEC', 'SNBIR', 'N = ' // XERN1 // - * ' IS LESS THAN 1', -2, 1) - RETURN - ENDIF -C - IF (ITASK.LT.1) THEN - IND = -3 - WRITE (XERN1, '(I8)') ITASK - CALL XERMSG ('SLATEC', 'SNBIR', 'ITASK = ' // XERN1 // - * ' IS LESS THAN 1', -3, 1) - RETURN - ENDIF -C - IF (ML.LT.0 .OR. ML.GE.N) THEN - IND = -5 - WRITE (XERN1, '(I8)') ML - CALL XERMSG ('SLATEC', 'SNBIR', - * 'ML = ' // XERN1 // ' IS OUT OF RANGE', -5, 1) - RETURN - ENDIF -C - IF (MU.LT.0 .OR. MU.GE.N) THEN - IND = -6 - WRITE (XERN1, '(I8)') MU - CALL XERMSG ('SLATEC', 'SNBIR', - * 'MU = ' // XERN1 // ' IS OUT OF RANGE', -6, 1) - RETURN - ENDIF -C - NC = 2*ML+MU+1 - IF (ITASK.EQ.1) THEN -C -C MOVE MATRIX ABE TO WORK -C - M=ML+MU+1 - DO 10 J=1,M - CALL SCOPY(N,ABE(1,J),1,WORK(1,J),1) - 10 CONTINUE -C -C FACTOR MATRIX A INTO LU -C - CALL SNBFA(WORK,N,N,ML,MU,IWORK,INFO) -C -C CHECK FOR COMPUTATIONALLY SINGULAR MATRIX -C - IF (INFO.NE.0) THEN - IND = -4 - CALL XERMSG ('SLATEC', 'SNBIR', - * 'SINGULAR MATRIX A - NO SOLUTION', -4, 1) - RETURN - ENDIF - ENDIF -C -C SOLVE WHEN FACTORING COMPLETE -C MOVE VECTOR B TO WORK -C - CALL SCOPY(N,V(1),1,WORK(1,NC+1),1) - CALL SNBSL(WORK,N,N,ML,MU,IWORK,V,0) -C -C FORM NORM OF X0 -C - XNORM = SASUM(N,V(1),1) - IF (XNORM.EQ.0.0) THEN - IND = 75 - RETURN - ENDIF -C -C COMPUTE RESIDUAL -C - DO 40 J=1,N - K = MAX(1,ML+2-J) - KK = MAX(1,J-ML) - L = MIN(J-1,ML)+MIN(N-J,MU)+1 - WORK(J,NC+1) = SDSDOT(L,-WORK(J,NC+1),ABE(J,K),LDA,V(KK),1) - 40 CONTINUE -C -C SOLVE A*DELTA=R -C - CALL SNBSL(WORK,N,N,ML,MU,IWORK,WORK(1,NC+1),0) -C -C FORM NORM OF DELTA -C - DNORM = SASUM(N,WORK(1,NC+1),1) -C -C COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) -C AND CHECK FOR IND GREATER THAN ZERO -C - IND = -LOG10(MAX(R1MACH(4),DNORM/XNORM)) - IF (IND.LE.0) THEN - IND = -10 - CALL XERMSG ('SLATEC', 'SNBIR', - * 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) - ENDIF - RETURN - END diff --git a/slatec/snbsl.f b/slatec/snbsl.f deleted file mode 100644 index aba27e7..0000000 --- a/slatec/snbsl.f +++ /dev/null @@ -1,149 +0,0 @@ -*DECK SNBSL - SUBROUTINE SNBSL (ABE, LDA, N, ML, MU, IPVT, B, JOB) -C***BEGIN PROLOGUE SNBSL -C***PURPOSE Solve a real band system using the factors computed by -C SNBCO or SNBFA. -C***LIBRARY SLATEC -C***CATEGORY D2A2 -C***TYPE SINGLE PRECISION (SNBSL-S, DNBSL-D, CNBSL-C) -C***KEYWORDS BANDED, LINEAR EQUATIONS, NONSYMMETRIC, SOLVE -C***AUTHOR Voorhees, E. A., (LANL) -C***DESCRIPTION -C -C SNBSL solves the real band system -C A * X = B or TRANS(A) * X = B -C using the factors computed by SNBCO or SNBFA. -C -C On Entry -C -C ABE REAL(LDA, NC) -C the output from SNBCO or SNBFA. -C NC must be .GE. 2*ML+MU+1 . -C -C LDA INTEGER -C the leading dimension of the array ABE . -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 SNBCO or SNBFA. -C -C B REAL(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 SNBCO has set RCOND .GT. 0.0 -C or SNBFA has set INFO .EQ. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL SNBCO(ABE,LDA,N,ML,MU,IPVT,RCOND,Z) -C IF (RCOND is too small) GO TO ... -C DO 10 J = 1, P -C CALL SNBSL(ABE,LDA,N,ML,MU,IPVT,C(1,J),0) -C 10 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SAXPY, SDOT -C***REVISION HISTORY (YYMMDD) -C 800717 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SNBSL - INTEGER LDA,N,ML,MU,IPVT(*),JOB - REAL ABE(LDA,*),B(*) -C - REAL SDOT,T - INTEGER K,KB,L,LB,LDB,LM,M,MLM,NM1 -C***FIRST EXECUTABLE STATEMENT SNBSL - M=MU+ML+1 - NM1=N-1 - LDB=1-LDA - 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=MIN(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 - MLM=ML-(LM-1) - CALL SAXPY(LM,T,ABE(K+LM,MLM),LDB,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)/ABE(K,ML+1) - LM=MIN(K,M)-1 - LB=K-LM - T=-B(K) - CALL SAXPY(LM,T,ABE(K-1,ML+2),LDB,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 = MIN(K,M) - 1 - LB = K - LM - T = SDOT(LM,ABE(K-1,ML+2),LDB,B(LB),1) - B(K) = (B(K) - T)/ABE(K,ML+1) - 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 = MIN(ML,N-K) - MLM = ML - (LM - 1) - B(K) = B(K) + SDOT(LM,ABE(K+LM,MLM),LDB,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/slatec/snls1.f b/slatec/snls1.f deleted file mode 100644 index 122822d..0000000 --- a/slatec/snls1.f +++ /dev/null @@ -1,1023 +0,0 @@ -*DECK SNLS1 - SUBROUTINE SNLS1 (FCN, IOPT, M, N, X, FVEC, FJAC, LDFJAC, FTOL, - + XTOL, GTOL, MAXFEV, EPSFCN, DIAG, MODE, FACTOR, NPRINT, INFO, - + NFEV, NJEV, IPVT, QTF, WA1, WA2, WA3, WA4) -C***BEGIN PROLOGUE SNLS1 -C***PURPOSE Minimize the sum of the squares of M nonlinear functions -C in N variables by a modification of the Levenberg-Marquardt -C algorithm. -C***LIBRARY SLATEC -C***CATEGORY K1B1A1, K1B1A2 -C***TYPE SINGLE PRECISION (SNLS1-S, DNLS1-D) -C***KEYWORDS LEVENBERG-MARQUARDT, NONLINEAR DATA FITTING, -C NONLINEAR LEAST SQUARES -C***AUTHOR Hiebert, K. L., (SNLA) -C***DESCRIPTION -C -C 1. Purpose. -C -C The purpose of SNLS1 is to minimize the sum of the squares of M -C nonlinear functions in N variables by a modification of the -C Levenberg-Marquardt algorithm. The user must provide a subrou- -C tine which calculates the functions. The user has the option -C of how the Jacobian will be supplied. The user can supply the -C full Jacobian, or the rows of the Jacobian (to avoid storing -C the full Jacobian), or let the code approximate the Jacobian by -C forward-differencing. This code is the combination of the -C MINPACK codes (Argonne) LMDER, LMDIF, and LMSTR. -C -C -C 2. Subroutine and Type Statements. -C -C SUBROUTINE SNLS1(FCN,IOPT,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL, -C * GTOL,MAXFEV,EPSFCN,DIAG,MODE,FACTOR,NPRINT,INFO -C * ,NFEV,NJEV,IPVT,QTF,WA1,WA2,WA3,WA4) -C INTEGER IOPT,M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV -C INTEGER IPVT(N) -C REAL FTOL,XTOL,GTOL,EPSFCN,FACTOR -C REAL X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N), -C * WA1(N),WA2(N),WA3(N),WA4(M) -C -C -C 3. Parameters. -C -C Parameters designated as input parameters must be specified on -C entry to SNLS1 and are not changed on exit, while parameters -C designated as output parameters need not be specified on entry -C and are set to appropriate values on exit from SNLS1. -C -C FCN is the name of the user-supplied subroutine which calculates -C the functions. If the user wants to supply the Jacobian -C (IOPT=2 or 3), then FCN must be written to calculate the -C Jacobian, as well as the functions. See the explanation -C of the IOPT argument below. -C If the user wants the iterates printed (NPRINT positive), then -C FCN must do the printing. See the explanation of NPRINT -C below. FCN must be declared in an EXTERNAL statement in the -C calling program and should be written as follows. -C -C -C SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) -C INTEGER IFLAG,LDFJAC,M,N -C REAL X(N),FVEC(M) -C ---------- -C FJAC and LDFJAC may be ignored , if IOPT=1. -C REAL FJAC(LDFJAC,N) , if IOPT=2. -C REAL FJAC(N) , if IOPT=3. -C ---------- -C If IFLAG=0, the values in X and FVEC are available -C for printing. See the explanation of NPRINT below. -C IFLAG will never be zero unless NPRINT is positive. -C The values of X and FVEC must not be changed. -C RETURN -C ---------- -C If IFLAG=1, calculate the functions at X and return -C this vector in FVEC. -C RETURN -C ---------- -C If IFLAG=2, calculate the full Jacobian at X and return -C this matrix in FJAC. Note that IFLAG will never be 2 unless -C IOPT=2. FVEC contains the function values at X and must -C not be altered. FJAC(I,J) must be set to the derivative -C of FVEC(I) with respect to X(J). -C RETURN -C ---------- -C If IFLAG=3, calculate the LDFJAC-th row of the Jacobian -C and return this vector in FJAC. Note that IFLAG will -C never be 3 unless IOPT=3. FVEC contains the function -C values at X and must not be altered. FJAC(J) must be -C set to the derivative of FVEC(LDFJAC) with respect to X(J). -C RETURN -C ---------- -C END -C -C -C The value of IFLAG should not be changed by FCN unless the -C user wants to terminate execution of SNLS1. In this case, set -C IFLAG to a negative integer. -C -C -C IOPT is an input variable which specifies how the Jacobian will -C be calculated. If IOPT=2 or 3, then the user must supply the -C Jacobian, as well as the function values, through the -C subroutine FCN. If IOPT=2, the user supplies the full -C Jacobian with one call to FCN. If IOPT=3, the user supplies -C one row of the Jacobian with each call. (In this manner, -C storage can be saved because the full Jacobian is not stored.) -C If IOPT=1, the code will approximate the Jacobian by forward -C differencing. -C -C M is a positive integer input variable set to the number of -C functions. -C -C N is a positive integer input variable set to the number of -C variables. N must not exceed M. -C -C X is an array of length N. On input, X must contain an initial -C estimate of the solution vector. On output, X contains the -C final estimate of the solution vector. -C -C FVEC is an output array of length M which contains the functions -C evaluated at the output X. -C -C FJAC is an output array. For IOPT=1 and 2, FJAC is an M by N -C array. For IOPT=3, FJAC is an N by N array. The upper N by N -C submatrix of FJAC contains an upper triangular matrix R with -C diagonal elements of nonincreasing magnitude such that -C -C T T T -C P *(JAC *JAC)*P = R *R, -C -C where P is a permutation matrix and JAC is the final calcu- -C lated Jacobian. Column J of P is column IPVT(J) (see below) -C of the identity matrix. The lower part of FJAC contains -C information generated during the computation of R. -C -C LDFJAC is a positive integer input variable which specifies -C the leading dimension of the array FJAC. For IOPT=1 and 2, -C LDFJAC must not be less than M. For IOPT=3, LDFJAC must not -C be less than N. -C -C FTOL is a non-negative input variable. Termination occurs when -C both the actual and predicted relative reductions in the sum -C of squares are at most FTOL. Therefore, FTOL measures the -C relative error desired in the sum of squares. Section 4 con- -C tains more details about FTOL. -C -C XTOL is a non-negative input variable. Termination occurs when -C the relative error between two consecutive iterates is at most -C XTOL. Therefore, XTOL measures the relative error desired in -C the approximate solution. Section 4 contains more details -C about XTOL. -C -C GTOL is a non-negative input variable. Termination occurs when -C the cosine of the angle between FVEC and any column of the -C Jacobian is at most GTOL in absolute value. Therefore, GTOL -C measures the orthogonality desired between the function vector -C and the columns of the Jacobian. Section 4 contains more -C details about GTOL. -C -C MAXFEV is a positive integer input variable. Termination occurs -C when the number of calls to FCN to evaluate the functions -C has reached MAXFEV. -C -C EPSFCN is an input variable used in determining a suitable step -C for the forward-difference approximation. This approximation -C assumes that the relative errors in the functions are of the -C order of EPSFCN. If EPSFCN is less than the machine preci- -C sion, it is assumed that the relative errors in the functions -C are of the order of the machine precision. If IOPT=2 or 3, -C then EPSFCN can be ignored (treat it as a dummy argument). -C -C DIAG is an array of length N. If MODE = 1 (see below), DIAG is -C internally set. If MODE = 2, DIAG must contain positive -C entries that serve as implicit (multiplicative) scale factors -C for the variables. -C -C MODE is an integer input variable. If MODE = 1, the variables -C will be scaled internally. If MODE = 2, the scaling is speci- -C fied by the input DIAG. Other values of MODE are equivalent -C to MODE = 1. -C -C FACTOR is a positive input variable used in determining the ini- -C tial step bound. This bound is set to the product of FACTOR -C and the Euclidean norm of DIAG*X if nonzero, or else to FACTOR -C itself. In most cases FACTOR should lie in the interval -C (.1,100.). 100. is a generally recommended value. -C -C NPRINT is an integer input variable that enables controlled -C printing of iterates if it is positive. In this case, FCN is -C called with IFLAG = 0 at the beginning of the first iteration -C and every NPRINT iterations thereafter and immediately prior -C to return, with X and FVEC available for printing. Appropriate -C print statements must be added to FCN (see example) and -C FVEC should not be altered. If NPRINT is not positive, no -C special calls to FCN with IFLAG = 0 are made. -C -C INFO is an integer output variable. If the user has terminated -C execution, INFO is set to the (negative) value of IFLAG. See -C description of FCN and JAC. Otherwise, INFO is set as follows. -C -C INFO = 0 improper input parameters. -C -C INFO = 1 both actual and predicted relative reductions in the -C sum of squares are at most FTOL. -C -C INFO = 2 relative error between two consecutive iterates is -C at most XTOL. -C -C INFO = 3 conditions for INFO = 1 and INFO = 2 both hold. -C -C INFO = 4 the cosine of the angle between FVEC and any column -C of the Jacobian is at most GTOL in absolute value. -C -C INFO = 5 number of calls to FCN for function evaluation -C has reached MAXFEV. -C -C INFO = 6 FTOL is too small. No further reduction in the sum -C of squares is possible. -C -C INFO = 7 XTOL is too small. No further improvement in the -C approximate solution X is possible. -C -C INFO = 8 GTOL is too small. FVEC is orthogonal to the -C columns of the Jacobian to machine precision. -C -C Sections 4 and 5 contain more details about INFO. -C -C NFEV is an integer output variable set to the number of calls to -C FCN for function evaluation. -C -C NJEV is an integer output variable set to the number of -C evaluations of the full Jacobian. If IOPT=2, only one call to -C FCN is required for each evaluation of the full Jacobian. -C If IOPT=3, the M calls to FCN are required. -C If IOPT=1, then NJEV is set to zero. -C -C IPVT is an integer output array of length N. IPVT defines a -C permutation matrix P such that JAC*P = Q*R, where JAC is the -C final calculated Jacobian, Q is orthogonal (not stored), and R -C is upper triangular with diagonal elements of nonincreasing -C magnitude. Column J of P is column IPVT(J) of the identity -C matrix. -C -C QTF is an output array of length N which contains the first N -C elements of the vector (Q transpose)*FVEC. -C -C WA1, WA2, and WA3 are work arrays of length N. -C -C WA4 is a work array of length M. -C -C -C 4. Successful Completion. -C -C The accuracy of SNLS1 is controlled by the convergence parame- -C ters FTOL, XTOL, and GTOL. These parameters are used in tests -C which make three types of comparisons between the approximation -C X and a solution XSOL. SNLS1 terminates when any of the tests -C is satisfied. If any of the convergence parameters is less than -C the machine precision (as defined by the function R1MACH(4)), -C then SNLS1 only attempts to satisfy the test defined by the -C machine precision. Further progress is not usually possible. -C -C The tests assume that the functions are reasonably well behaved, -C and, if the Jacobian is supplied by the user, that the functions -C and the Jacobian are coded consistently. If these conditions -C are not satisfied, then SNLS1 may incorrectly indicate conver- -C gence. If the Jacobian is coded correctly or IOPT=1, -C then the validity of the answer can be checked, for example, by -C rerunning SNLS1 with tighter tolerances. -C -C First Convergence Test. If ENORM(Z) denotes the Euclidean norm -C of a vector Z, then this test attempts to guarantee that -C -C ENORM(FVEC) .LE. (1+FTOL)*ENORM(FVECS), -C -C where FVECS denotes the functions evaluated at XSOL. If this -C condition is satisfied with FTOL = 10**(-K), then the final -C residual norm ENORM(FVEC) has K significant decimal digits and -C INFO is set to 1 (or to 3 if the second test is also satis- -C fied). Unless high precision solutions are required, the -C recommended value for FTOL is the square root of the machine -C precision. -C -C Second Convergence Test. If D is the diagonal matrix whose -C entries are defined by the array DIAG, then this test attempts -C to guarantee that -C -C ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL). -C -C If this condition is satisfied with XTOL = 10**(-K), then the -C larger components of D*X have K significant decimal digits and -C INFO is set to 2 (or to 3 if the first test is also satis- -C fied). There is a danger that the smaller components of D*X -C may have large relative errors, but if MODE = 1, then the -C accuracy of the components of X is usually related to their -C sensitivity. Unless high precision solutions are required, -C the recommended value for XTOL is the square root of the -C machine precision. -C -C Third Convergence Test. This test is satisfied when the cosine -C of the angle between FVEC and any column of the Jacobian at X -C is at most GTOL in absolute value. There is no clear rela- -C tionship between this test and the accuracy of SNLS1, and -C furthermore, the test is equally well satisfied at other crit- -C ical points, namely maximizers and saddle points. Therefore, -C termination caused by this test (INFO = 4) should be examined -C carefully. The recommended value for GTOL is zero. -C -C -C 5. Unsuccessful Completion. -C -C Unsuccessful termination of SNLS1 can be due to improper input -C parameters, arithmetic interrupts, or an excessive number of -C function evaluations. -C -C Improper Input Parameters. INFO is set to 0 if IOPT .LT. 1 -C or IOPT .GT. 3, or N .LE. 0, or M .LT. N, or for IOPT=1 or 2 -C LDFJAC .LT. M, or for IOPT=3 LDFJAC .LT. N, or FTOL .LT. 0.E0, -C or XTOL .LT. 0.E0, or GTOL .LT. 0.E0, or MAXFEV .LE. 0, or -C FACTOR .LE. 0.E0. -C -C Arithmetic Interrupts. If these interrupts occur in the FCN -C subroutine during an early stage of the computation, they may -C be caused by an unacceptable choice of X by SNLS1. In this -C case, it may be possible to remedy the situation by rerunning -C SNLS1 with a smaller value of FACTOR. -C -C Excessive Number of Function Evaluations. A reasonable value -C for MAXFEV is 100*(N+1) for IOPT=2 or 3 and 200*(N+1) for -C IOPT=1. If the number of calls to FCN reaches MAXFEV, then -C this indicates that the routine is converging very slowly -C as measured by the progress of FVEC, and INFO is set to 5. -C In this case, it may be helpful to restart SNLS1 with MODE -C set to 1. -C -C -C 6. Characteristics of the Algorithm. -C -C SNLS1 is a modification of the Levenberg-Marquardt algorithm. -C Two of its main characteristics involve the proper use of -C implicitly scaled variables (if MODE = 1) and an optimal choice -C for the correction. The use of implicitly scaled variables -C achieves scale invariance of SNLS1 and limits the size of the -C correction in any direction where the functions are changing -C rapidly. The optimal choice of the correction guarantees (under -C reasonable conditions) global convergence from starting points -C far from the solution and a fast rate of convergence for -C problems with small residuals. -C -C Timing. The time required by SNLS1 to solve a given problem -C depends on M and N, the behavior of the functions, the accu- -C racy requested, and the starting point. The number of arith- -C metic operations needed by SNLS1 is about N**3 to process each -C evaluation of the functions (call to FCN) and to process each -C evaluation of the Jacobian it takes M*N**2 for IOPT=2 (one -C call to FCN), M*N**2 for IOPT=1 (N calls to FCN) and -C 1.5*M*N**2 for IOPT=3 (M calls to FCN). Unless FCN -C can be evaluated quickly, the timing of SNLS1 will be -C strongly influenced by the time spent in FCN. -C -C Storage. SNLS1 requires (M*N + 2*M + 6*N) for IOPT=1 or 2 and -C (N**2 + 2*M + 6*N) for IOPT=3 single precision storage -C locations and N integer storage locations, in addition to -C the storage required by the program. There are no internally -C declared storage arrays. -C -C *Long Description: -C -C 7. Example. -C -C The problem is to determine the values of X(1), X(2), and X(3) -C which provide the best fit (in the least squares sense) of -C -C X(1) + U(I)/(V(I)*X(2) + W(I)*X(3)), I = 1, 15 -C -C to the data -C -C Y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, -C 0.37,0.58,0.73,0.96,1.34,2.10,4.39), -C -C where U(I) = I, V(I) = 16 - I, and W(I) = MIN(U(I),V(I)). The -C I-th component of FVEC is thus defined by -C -C Y(I) - (X(1) + U(I)/(V(I)*X(2) + W(I)*X(3))). -C -C ********** -C -C PROGRAM TEST -C C -C C Driver for SNLS1 example. -C C -C INTEGER J,IOPT,M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV, -C * NWRITE -C INTEGER IPVT(3) -C REAL FTOL,XTOL,GTOL,FACTOR,FNORM,EPSFCN -C REAL X(3),FVEC(15),FJAC(15,3),DIAG(3),QTF(3), -C * WA1(3),WA2(3),WA3(3),WA4(15) -C REAL ENORM,R1MACH -C EXTERNAL FCN -C DATA NWRITE /6/ -C C -C IOPT = 1 -C M = 15 -C N = 3 -C C -C C The following starting values provide a rough fit. -C C -C X(1) = 1.E0 -C X(2) = 1.E0 -C X(3) = 1.E0 -C C -C LDFJAC = 15 -C C -C C Set FTOL and XTOL to the square root of the machine precision -C C and GTOL to zero. Unless high precision solutions are -C C required, these are the recommended settings. -C C -C FTOL = SQRT(R1MACH(4)) -C XTOL = SQRT(R1MACH(4)) -C GTOL = 0.E0 -C C -C MAXFEV = 400 -C EPSFCN = 0.0 -C MODE = 1 -C FACTOR = 1.E2 -C NPRINT = 0 -C C -C CALL SNLS1(FCN,IOPT,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL, -C * GTOL,MAXFEV,EPSFCN,DIAG,MODE,FACTOR,NPRINT, -C * INFO,NFEV,NJEV,IPVT,QTF,WA1,WA2,WA3,WA4) -C FNORM = ENORM(M,FVEC) -C WRITE (NWRITE,1000) FNORM,NFEV,NJEV,INFO,(X(J),J=1,N) -C STOP -C 1000 FORMAT (5X,' FINAL L2 NORM OF THE RESIDUALS',E15.7 // -C * 5X,' NUMBER OF FUNCTION EVALUATIONS',I10 // -C * 5X,' NUMBER OF JACOBIAN EVALUATIONS',I10 // -C * 5X,' EXIT PARAMETER',16X,I10 // -C * 5X,' FINAL APPROXIMATE SOLUTION' // 5X,3E15.7) -C END -C SUBROUTINE FCN(IFLAG,M,N,X,FVEC,DUM,IDUM) -C C This is the form of the FCN routine if IOPT=1, -C C that is, if the user does not calculate the Jacobian. -C INTEGER M,N,IFLAG -C REAL X(N),FVEC(M) -C INTEGER I -C REAL TMP1,TMP2,TMP3,TMP4 -C REAL Y(15) -C DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), -C * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) -C * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, -C * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ -C C -C IF (IFLAG .NE. 0) GO TO 5 -C C -C C Insert print statements here when NPRINT is positive. -C C -C RETURN -C 5 CONTINUE -C DO 10 I = 1, M -C TMP1 = I -C TMP2 = 16 - I -C TMP3 = TMP1 -C IF (I .GT. 8) TMP3 = TMP2 -C FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) -C 10 CONTINUE -C RETURN -C END -C -C -C Results obtained with different compilers or machines -C may be slightly different. -C -C FINAL L2 NORM OF THE RESIDUALS 0.9063596E-01 -C -C NUMBER OF FUNCTION EVALUATIONS 25 -C -C NUMBER OF JACOBIAN EVALUATIONS 0 -C -C EXIT PARAMETER 1 -C -C FINAL APPROXIMATE SOLUTION -C -C 0.8241058E-01 0.1133037E+01 0.2343695E+01 -C -C -C For IOPT=2, FCN would be modified as follows to also -C calculate the full Jacobian when IFLAG=2. -C -C SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) -C C -C C This is the form of the FCN routine if IOPT=2, -C C that is, if the user calculates the full Jacobian. -C C -C INTEGER LDFJAC,M,N,IFLAG -C REAL X(N),FVEC(M) -C REAL FJAC(LDFJAC,N) -C INTEGER I -C REAL TMP1,TMP2,TMP3,TMP4 -C REAL Y(15) -C DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), -C * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) -C * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, -C * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ -C C -C IF (IFLAG .NE. 0) GO TO 5 -C C -C C Insert print statements here when NPRINT is positive. -C C -C RETURN -C 5 CONTINUE -C IF(IFLAG.NE.1) GO TO 20 -C DO 10 I = 1, M -C TMP1 = I -C TMP2 = 16 - I -C TMP3 = TMP1 -C IF (I .GT. 8) TMP3 = TMP2 -C FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) -C 10 CONTINUE -C RETURN -C C -C C Below, calculate the full Jacobian. -C C -C 20 CONTINUE -C C -C DO 30 I = 1, M -C TMP1 = I -C TMP2 = 16 - I -C TMP3 = TMP1 -C IF (I .GT. 8) TMP3 = TMP2 -C TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 -C FJAC(I,1) = -1.E0 -C FJAC(I,2) = TMP1*TMP2/TMP4 -C FJAC(I,3) = TMP1*TMP3/TMP4 -C 30 CONTINUE -C RETURN -C END -C -C -C For IOPT = 3, FJAC would be dimensioned as FJAC(3,3), -C LDFJAC would be set to 3, and FCN would be written as -C follows to calculate a row of the Jacobian when IFLAG=3. -C -C SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) -C C This is the form of the FCN routine if IOPT=3, -C C that is, if the user calculates the Jacobian row by row. -C INTEGER M,N,IFLAG -C REAL X(N),FVEC(M) -C REAL FJAC(N) -C INTEGER I -C REAL TMP1,TMP2,TMP3,TMP4 -C REAL Y(15) -C DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), -C * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) -C * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, -C * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ -C C -C IF (IFLAG .NE. 0) GO TO 5 -C C -C C Insert print statements here when NPRINT is positive. -C C -C RETURN -C 5 CONTINUE -C IF( IFLAG.NE.1) GO TO 20 -C DO 10 I = 1, M -C TMP1 = I -C TMP2 = 16 - I -C TMP3 = TMP1 -C IF (I .GT. 8) TMP3 = TMP2 -C FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) -C 10 CONTINUE -C RETURN -C C -C C Below, calculate the LDFJAC-th row of the Jacobian. -C C -C 20 CONTINUE -C -C I = LDFJAC -C TMP1 = I -C TMP2 = 16 - I -C TMP3 = TMP1 -C IF (I .GT. 8) TMP3 = TMP2 -C TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 -C FJAC(1) = -1.E0 -C FJAC(2) = TMP1*TMP2/TMP4 -C FJAC(3) = TMP1*TMP3/TMP4 -C RETURN -C END -C -C***REFERENCES Jorge J. More, The Levenberg-Marquardt algorithm: -C implementation and theory. In Numerical Analysis -C Proceedings (Dundee, June 28 - July 1, 1977, G. A. -C Watson, Editor), Lecture Notes in Mathematics 630, -C Springer-Verlag, 1978. -C***ROUTINES CALLED CHKDER, ENORM, FDJAC3, LMPAR, QRFAC, R1MACH, -C RWUPDT, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800301 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 SNLS1 - INTEGER IOPT,M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV - INTEGER IJUNK,NROW,IPVT(*) - REAL FTOL,XTOL,GTOL,FACTOR,EPSFCN - REAL X(*),FVEC(*),FJAC(LDFJAC,*),DIAG(*),QTF(*),WA1(*),WA2(*), - 1 WA3(*),WA4(*) - LOGICAL SING - EXTERNAL FCN - INTEGER I,IFLAG,ITER,J,L,MODECH - REAL ACTRED,DELTA,DIRDER,EPSMCH,FNORM,FNORM1,GNORM,ONE,PAR, - 1 PNORM,PRERED,P1,P5,P25,P75,P0001,RATIO,SUM,TEMP,TEMP1, - 2 TEMP2,XNORM,ZERO - REAL R1MACH,ENORM,ERR,CHKLIM - CHARACTER*8 XERN1 - CHARACTER*16 XERN3 -C - SAVE CHKLIM, ONE, P1, P5, P25, P75, P0001, ZERO - DATA CHKLIM/.1E0/ - DATA ONE,P1,P5,P25,P75,P0001,ZERO - 1 /1.0E0,1.0E-1,5.0E-1,2.5E-1,7.5E-1,1.0E-4,0.0E0/ -C -C***FIRST EXECUTABLE STATEMENT SNLS1 - EPSMCH = R1MACH(4) -C - INFO = 0 - IFLAG = 0 - NFEV = 0 - NJEV = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C - IF (IOPT .LT. 1 .OR. IOPT .GT. 3 .OR. N .LE. 0 .OR. - 1 M .LT. N .OR. LDFJAC .LT. N .OR. FTOL .LT. ZERO - 2 .OR. XTOL .LT. ZERO .OR. GTOL .LT. ZERO - 3 .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO) GO TO 300 - IF (IOPT .LT. 3 .AND. LDFJAC .LT. M) GO TO 300 - IF (MODE .NE. 2) GO TO 20 - DO 10 J = 1, N - IF (DIAG(J) .LE. ZERO) GO TO 300 - 10 CONTINUE - 20 CONTINUE -C -C EVALUATE THE FUNCTION AT THE STARTING POINT -C AND CALCULATE ITS NORM. -C - IFLAG = 1 - IJUNK = 1 - CALL FCN(IFLAG,M,N,X,FVEC,FJAC,IJUNK) - NFEV = 1 - IF (IFLAG .LT. 0) GO TO 300 - FNORM = ENORM(M,FVEC) -C -C INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER. -C - PAR = ZERO - ITER = 1 -C -C BEGINNING OF THE OUTER LOOP. -C - 30 CONTINUE -C -C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. -C - IF (NPRINT .LE. 0) GO TO 40 - IFLAG = 0 - IF (MOD(ITER-1,NPRINT) .EQ. 0) - 1 CALL FCN(IFLAG,M,N,X,FVEC,FJAC,IJUNK) - IF (IFLAG .LT. 0) GO TO 300 - 40 CONTINUE -C -C CALCULATE THE JACOBIAN MATRIX. -C - IF (IOPT .EQ. 3) GO TO 475 -C -C STORE THE FULL JACOBIAN USING M*N STORAGE -C - IF (IOPT .EQ. 1) GO TO 410 -C -C THE USER SUPPLIES THE JACOBIAN -C - IFLAG = 2 - CALL FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) - NJEV = NJEV + 1 -C -C ON THE FIRST ITERATION, CHECK THE USER SUPPLIED JACOBIAN -C - IF (ITER .LE. 1) THEN - IF (IFLAG .LT. 0) GO TO 300 -C -C GET THE INCREMENTED X-VALUES INTO WA1(*). -C - MODECH = 1 - CALL CHKDER(M,N,X,FVEC,FJAC,LDFJAC,WA1,WA4,MODECH,ERR) -C -C EVALUATE FUNCTION AT INCREMENTED VALUE AND PUT IN WA4(*). -C - IFLAG = 1 - CALL FCN(IFLAG,M,N,WA1,WA4,FJAC,LDFJAC) - NFEV = NFEV + 1 - IF(IFLAG .LT. 0) GO TO 300 - DO 350 I = 1, M - MODECH = 2 - CALL CHKDER(1,N,X,FVEC(I),FJAC(I,1),LDFJAC,WA1, - 1 WA4(I),MODECH,ERR) - IF (ERR .LT. CHKLIM) THEN - WRITE (XERN1, '(I8)') I - WRITE (XERN3, '(1PE15.6)') ERR - CALL XERMSG ('SLATEC', 'SNLS1', 'DERIVATIVE OF ' // - * 'FUNCTION ' // XERN1 // ' MAY BE WRONG, ERR = ' // - * XERN3 // ' TOO CLOSE TO 0.', 7, 0) - ENDIF - 350 CONTINUE - ENDIF -C - GO TO 420 -C -C THE CODE APPROXIMATES THE JACOBIAN -C -410 IFLAG = 1 - CALL FDJAC3(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA4) - NFEV = NFEV + N - 420 IF (IFLAG .LT. 0) GO TO 300 -C -C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. -C - CALL QRFAC(M,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3) -C -C FORM (Q TRANSPOSE)*FVEC AND STORE THE FIRST N COMPONENTS IN -C QTF. -C - DO 430 I = 1, M - WA4(I) = FVEC(I) - 430 CONTINUE - DO 470 J = 1, N - IF (FJAC(J,J) .EQ. ZERO) GO TO 460 - SUM = ZERO - DO 440 I = J, M - SUM = SUM + FJAC(I,J)*WA4(I) - 440 CONTINUE - TEMP = -SUM/FJAC(J,J) - DO 450 I = J, M - WA4(I) = WA4(I) + FJAC(I,J)*TEMP - 450 CONTINUE - 460 CONTINUE - FJAC(J,J) = WA1(J) - QTF(J) = WA4(J) - 470 CONTINUE - GO TO 560 -C -C ACCUMULATE THE JACOBIAN BY ROWS IN ORDER TO SAVE STORAGE. -C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN MATRIX -C CALCULATED ONE ROW AT A TIME, WHILE SIMULTANEOUSLY -C FORMING (Q TRANSPOSE)*FVEC AND STORING THE FIRST -C N COMPONENTS IN QTF. -C - 475 DO 490 J = 1, N - QTF(J) = ZERO - DO 480 I = 1, N - FJAC(I,J) = ZERO - 480 CONTINUE - 490 CONTINUE - DO 500 I = 1, M - NROW = I - IFLAG = 3 - CALL FCN(IFLAG,M,N,X,FVEC,WA3,NROW) - IF (IFLAG .LT. 0) GO TO 300 -C -C ON THE FIRST ITERATION, CHECK THE USER SUPPLIED JACOBIAN. -C - IF(ITER .GT. 1) GO TO 498 -C -C GET THE INCREMENTED X-VALUES INTO WA1(*). -C - MODECH = 1 - CALL CHKDER(M,N,X,FVEC,FJAC,LDFJAC,WA1,WA4,MODECH,ERR) -C -C EVALUATE AT INCREMENTED VALUES, IF NOT ALREADY EVALUATED. -C - IF(I .NE. 1) GO TO 495 -C -C EVALUATE FUNCTION AT INCREMENTED VALUE AND PUT INTO WA4(*). -C - IFLAG = 1 - CALL FCN(IFLAG,M,N,WA1,WA4,FJAC,NROW) - NFEV = NFEV + 1 - IF(IFLAG .LT. 0) GO TO 300 -495 CONTINUE - MODECH = 2 - CALL CHKDER(1,N,X,FVEC(I),WA3,1,WA1,WA4(I),MODECH,ERR) - IF (ERR .LT. CHKLIM) THEN - WRITE (XERN1, '(I8)') I - WRITE (XERN3, '(1PE15.6)') ERR - CALL XERMSG ('SLATEC', 'SNLS1', 'DERIVATIVE OF FUNCTION ' - * // XERN1 // ' MAY BE WRONG, ERR = ' // XERN3 // - * ' TOO CLOSE TO 0.', 7, 0) - ENDIF -498 CONTINUE -C - TEMP = FVEC(I) - CALL RWUPDT(N,FJAC,LDFJAC,WA3,QTF,TEMP,WA1,WA2) - 500 CONTINUE - NJEV = NJEV + 1 -C -C IF THE JACOBIAN IS RANK DEFICIENT, CALL QRFAC TO -C REORDER ITS COLUMNS AND UPDATE THE COMPONENTS OF QTF. -C - SING = .FALSE. - DO 510 J = 1, N - IF (FJAC(J,J) .EQ. ZERO) SING = .TRUE. - IPVT(J) = J - WA2(J) = ENORM(J,FJAC(1,J)) - 510 CONTINUE - IF (.NOT.SING) GO TO 560 - CALL QRFAC(N,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3) - DO 550 J = 1, N - IF (FJAC(J,J) .EQ. ZERO) GO TO 540 - SUM = ZERO - DO 520 I = J, N - SUM = SUM + FJAC(I,J)*QTF(I) - 520 CONTINUE - TEMP = -SUM/FJAC(J,J) - DO 530 I = J, N - QTF(I) = QTF(I) + FJAC(I,J)*TEMP - 530 CONTINUE - 540 CONTINUE - FJAC(J,J) = WA1(J) - 550 CONTINUE - 560 CONTINUE -C -C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING -C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. -C - IF (ITER .NE. 1) GO TO 80 - IF (MODE .EQ. 2) GO TO 60 - DO 50 J = 1, N - DIAG(J) = WA2(J) - IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE - 50 CONTINUE - 60 CONTINUE -C -C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X -C AND INITIALIZE THE STEP BOUND DELTA. -C - DO 70 J = 1, N - WA3(J) = DIAG(J)*X(J) - 70 CONTINUE - XNORM = ENORM(N,WA3) - DELTA = FACTOR*XNORM - IF (DELTA .EQ. ZERO) DELTA = FACTOR - 80 CONTINUE -C -C COMPUTE THE NORM OF THE SCALED GRADIENT. -C - GNORM = ZERO - IF (FNORM .EQ. ZERO) GO TO 170 - DO 160 J = 1, N - L = IPVT(J) - IF (WA2(L) .EQ. ZERO) GO TO 150 - SUM = ZERO - DO 140 I = 1, J - SUM = SUM + FJAC(I,J)*(QTF(I)/FNORM) - 140 CONTINUE - GNORM = MAX(GNORM,ABS(SUM/WA2(L))) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE -C -C TEST FOR CONVERGENCE OF THE GRADIENT NORM. -C - IF (GNORM .LE. GTOL) INFO = 4 - IF (INFO .NE. 0) GO TO 300 -C -C RESCALE IF NECESSARY. -C - IF (MODE .EQ. 2) GO TO 190 - DO 180 J = 1, N - DIAG(J) = MAX(DIAG(J),WA2(J)) - 180 CONTINUE - 190 CONTINUE -C -C BEGINNING OF THE INNER LOOP. -C - 200 CONTINUE -C -C DETERMINE THE LEVENBERG-MARQUARDT PARAMETER. -C - CALL LMPAR(N,FJAC,LDFJAC,IPVT,DIAG,QTF,DELTA,PAR,WA1,WA2, - 1 WA3,WA4) -C -C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. -C - DO 210 J = 1, N - WA1(J) = -WA1(J) - WA2(J) = X(J) + WA1(J) - WA3(J) = DIAG(J)*WA1(J) - 210 CONTINUE - PNORM = ENORM(N,WA3) -C -C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. -C - IF (ITER .EQ. 1) DELTA = MIN(DELTA,PNORM) -C -C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. -C - IFLAG = 1 - CALL FCN(IFLAG,M,N,WA2,WA4,FJAC,IJUNK) - NFEV = NFEV + 1 - IF (IFLAG .LT. 0) GO TO 300 - FNORM1 = ENORM(M,WA4) -C -C COMPUTE THE SCALED ACTUAL REDUCTION. -C - ACTRED = -ONE - IF (P1*FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 -C -C COMPUTE THE SCALED PREDICTED REDUCTION AND -C THE SCALED DIRECTIONAL DERIVATIVE. -C - DO 230 J = 1, N - WA3(J) = ZERO - L = IPVT(J) - TEMP = WA1(L) - DO 220 I = 1, J - WA3(I) = WA3(I) + FJAC(I,J)*TEMP - 220 CONTINUE - 230 CONTINUE - TEMP1 = ENORM(N,WA3)/FNORM - TEMP2 = (SQRT(PAR)*PNORM)/FNORM - PRERED = TEMP1**2 + TEMP2**2/P5 - DIRDER = -(TEMP1**2 + TEMP2**2) -C -C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED -C REDUCTION. -C - RATIO = ZERO - IF (PRERED .NE. ZERO) RATIO = ACTRED/PRERED -C -C UPDATE THE STEP BOUND. -C - IF (RATIO .GT. P25) GO TO 240 - IF (ACTRED .GE. ZERO) TEMP = P5 - IF (ACTRED .LT. ZERO) - 1 TEMP = P5*DIRDER/(DIRDER + P5*ACTRED) - IF (P1*FNORM1 .GE. FNORM .OR. TEMP .LT. P1) TEMP = P1 - DELTA = TEMP*MIN(DELTA,PNORM/P1) - PAR = PAR/TEMP - GO TO 260 - 240 CONTINUE - IF (PAR .NE. ZERO .AND. RATIO .LT. P75) GO TO 250 - DELTA = PNORM/P5 - PAR = P5*PAR - 250 CONTINUE - 260 CONTINUE -C -C TEST FOR SUCCESSFUL ITERATION. -C - IF (RATIO .LT. P0001) GO TO 290 -C -C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. -C - DO 270 J = 1, N - X(J) = WA2(J) - WA2(J) = DIAG(J)*X(J) - 270 CONTINUE - DO 280 I = 1, M - FVEC(I) = WA4(I) - 280 CONTINUE - XNORM = ENORM(N,WA2) - FNORM = FNORM1 - ITER = ITER + 1 - 290 CONTINUE -C -C TESTS FOR CONVERGENCE. -C - IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL - 1 .AND. P5*RATIO .LE. ONE) INFO = 1 - IF (DELTA .LE. XTOL*XNORM) INFO = 2 - IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL - 1 .AND. P5*RATIO .LE. ONE .AND. INFO .EQ. 2) INFO = 3 - IF (INFO .NE. 0) GO TO 300 -C -C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. -C - IF (NFEV .GE. MAXFEV) INFO = 5 - IF (ABS(ACTRED) .LE. EPSMCH .AND. PRERED .LE. EPSMCH - 1 .AND. P5*RATIO .LE. ONE) INFO = 6 - IF (DELTA .LE. EPSMCH*XNORM) INFO = 7 - IF (GNORM .LE. EPSMCH) INFO = 8 - IF (INFO .NE. 0) GO TO 300 -C -C END OF THE INNER LOOP. REPEAT IF ITERATION UNSUCCESSFUL. -C - IF (RATIO .LT. P0001) GO TO 200 -C -C END OF THE OUTER LOOP. -C - GO TO 30 - 300 CONTINUE -C -C TERMINATION, EITHER NORMAL OR USER IMPOSED. -C - IF (IFLAG .LT. 0) INFO = IFLAG - IFLAG = 0 - IF (NPRINT .GT. 0) CALL FCN(IFLAG,M,N,X,FVEC,FJAC,IJUNK) - IF (INFO .LT. 0) CALL XERMSG ('SLATEC', 'SNLS1', - + 'EXECUTION TERMINATED BECAUSE USER SET IFLAG NEGATIVE.', 1, 1) - IF (INFO .EQ. 0) CALL XERMSG ('SLATEC', 'SNLS1', - + 'INVALID INPUT PARAMETER.', 2, 1) - IF (INFO .EQ. 4) CALL XERMSG ('SLATEC', 'SNLS1', - + 'THIRD CONVERGENCE CONDITION, CHECK RESULTS BEFORE ACCEPTING.', - + 1, 1) - IF (INFO .EQ. 5) CALL XERMSG ('SLATEC', 'SNLS1', - + 'TOO MANY FUNCTION EVALUATIONS.', 9, 1) - IF (INFO .GE. 6) CALL XERMSG ('SLATEC', 'SNLS1', - + 'TOLERANCES TOO SMALL, NO FURTHER IMPROVEMENT POSSIBLE.', 3, 1) - RETURN -C -C LAST CARD OF SUBROUTINE SNLS1. -C - END diff --git a/slatec/snls1e.f b/slatec/snls1e.f deleted file mode 100644 index 49dca65..0000000 --- a/slatec/snls1e.f +++ /dev/null @@ -1,544 +0,0 @@ -*DECK SNLS1E - SUBROUTINE SNLS1E (FCN, IOPT, M, N, X, FVEC, TOL, NPRINT, INFO, - + IW, WA, LWA) -C***BEGIN PROLOGUE SNLS1E -C***PURPOSE An easy-to-use code which minimizes the sum of the squares -C of M nonlinear functions in N variables by a modification -C of the Levenberg-Marquardt algorithm. -C***LIBRARY SLATEC -C***CATEGORY K1B1A1, K1B1A2 -C***TYPE SINGLE PRECISION (SNLS1E-S, DNLS1E-D) -C***KEYWORDS EASY-TO-USE, LEVENBERG-MARQUARDT, NONLINEAR DATA FITTING, -C NONLINEAR LEAST SQUARES -C***AUTHOR Hiebert, K. L., (SNLA) -C***DESCRIPTION -C -C 1. Purpose. -C -C The purpose of SNLS1E is to minimize the sum of the squares of M -C nonlinear functions in N variables by a modification of the -C Levenberg-Marquardt algorithm. This is done by using the more -C general least-squares solver SNLS1. The user must provide a -C subroutine which calculates the functions. The user has the -C option of how the Jacobian will be supplied. The user can -C supply the full Jacobian, or the rows of the Jacobian (to avoid -C storing the full Jacobian), or let the code approximate the -C Jacobian by forward-differencing. This code is the combination -C of the MINPACK codes (Argonne) LMDER1, LMDIF1, and LMSTR1. -C -C -C 2. Subroutine and Type Statements. -C -C SUBROUTINE SNLS1E(FCN,IOPT,M,N,X,FVEC,TOL,NPRINT, -C * INFO,IW,WA,LWA) -C INTEGER IOPT,M,N,NPRINT,INFO,LWA -C INTEGER IW(N) -C REAL TOL -C REAL X(N),FVEC(M),WA(LWA) -C EXTERNAL FCN -C -C -C 3. Parameters. -C -C Parameters designated as input parameters must be specified on -C entry to SNLS1E and are not changed on exit, while parameters -C designated as output parameters need not be specified on entry -C and are set to appropriate values on exit from SNLS1E. -C -C FCN is the name of the user-supplied subroutine which calculates -C the functions. If the user wants to supply the Jacobian -C (IOPT=2 or 3), then FCN must be written to calculate the -C Jacobian, as well as the functions. See the explanation -C of the IOPT argument below. -C If the user wants the iterates printed (NPRINT positive), then -C FCN must do the printing. See the explanation of NPRINT -C below. FCN must be declared in an EXTERNAL statement in the -C calling program and should be written as follows. -C -C -C SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) -C INTEGER IFLAG,LDFJAC,M,N -C REAL X(N),FVEC(M) -C ---------- -C FJAC and LDFJAC may be ignored , if IOPT=1. -C REAL FJAC(LDFJAC,N) , if IOPT=2. -C REAL FJAC(N) , if IOPT=3. -C ---------- -C If IFLAG=0, the values in X and FVEC are available -C for printing. See the explanation of NPRINT below. -C IFLAG will never be zero unless NPRINT is positive. -C The values of X and FVEC must not be changed. -C RETURN -C ---------- -C If IFLAG=1, calculate the functions at X and return -C this vector in FVEC. -C RETURN -C ---------- -C If IFLAG=2, calculate the full Jacobian at X and return -C this matrix in FJAC. Note that IFLAG will never be 2 unless -C IOPT=2. FVEC contains the function values at X and must -C not be altered. FJAC(I,J) must be set to the derivative -C of FVEC(I) with respect to X(J). -C RETURN -C ---------- -C If IFLAG=3, calculate the LDFJAC-th row of the Jacobian -C and return this vector in FJAC. Note that IFLAG will -C never be 3 unless IOPT=3. FVEC contains the function -C values at X and must not be altered. FJAC(J) must be -C set to the derivative of FVEC(LDFJAC) with respect to X(J). -C RETURN -C ---------- -C END -C -C -C The value of IFLAG should not be changed by FCN unless the -C user wants to terminate execution of SNLS1E. In this case, -C set IFLAG to a negative integer. -C -C -C IOPT is an input variable which specifies how the Jacobian will -C be calculated. If IOPT=2 or 3, then the user must supply the -C Jacobian, as well as the function values, through the -C subroutine FCN. If IOPT=2, the user supplies the full -C Jacobian with one call to FCN. If IOPT=3, the user supplies -C one row of the Jacobian with each call. (In this manner, -C storage can be saved because the full Jacobian is not stored.) -C If IOPT=1, the code will approximate the Jacobian by forward -C differencing. -C -C M is a positive integer input variable set to the number of -C functions. -C -C N is a positive integer input variable set to the number of -C variables. N must not exceed M. -C -C X is an array of length N. On input, X must contain an initial -C estimate of the solution vector. On output, X contains the -C final estimate of the solution vector. -C -C FVEC is an output array of length M which contains the functions -C evaluated at the output X. -C -C TOL is a non-negative input variable. Termination occurs when -C the algorithm estimates either that the relative error in the -C sum of squares is at most TOL or that the relative error -C between X and the solution is at most TOL. Section 4 contains -C more details about TOL. -C -C NPRINT is an integer input variable that enables controlled -C printing of iterates if it is positive. In this case, FCN is -C called with IFLAG = 0 at the beginning of the first iteration -C and every NPRINT iterations thereafter and immediately prior -C to return, with X and FVEC available for printing. Appropriate -C print statements must be added to FCN (see example) and -C FVEC should not be altered. If NPRINT is not positive, no -C special calls of FCN with IFLAG = 0 are made. -C -C INFO is an integer output variable. If the user has terminated -C execution, INFO is set to the (negative) value of IFLAG. See -C description of FCN and JAC. Otherwise, INFO is set as follows. -C -C INFO = 0 improper input parameters. -C -C INFO = 1 algorithm estimates that the relative error in the -C sum of squares is at most TOL. -C -C INFO = 2 algorithm estimates that the relative error between -C X and the solution is at most TOL. -C -C INFO = 3 conditions for INFO = 1 and INFO = 2 both hold. -C -C INFO = 4 FVEC is orthogonal to the columns of the Jacobian to -C machine precision. -C -C INFO = 5 number of calls to FCN has reached 100*(N+1) -C for IOPT=2 or 3 or 200*(N+1) for IOPT=1. -C -C INFO = 6 TOL is too small. No further reduction in the sum -C of squares is possible. -C -C INFO = 7 TOL is too small. No further improvement in the -C approximate solution X is possible. -C -C Sections 4 and 5 contain more details about INFO. -C -C IW is an INTEGER work array of length N. -C -C WA is a work array of length LWA. -C -C LWA is a positive integer input variable not less than -C N*(M+5)+M for IOPT=1 and 2 or N*(N+5)+M for IOPT=3. -C -C -C 4. Successful Completion. -C -C The accuracy of SNLS1E is controlled by the convergence parame- -C ter TOL. This parameter is used in tests which make three types -C of comparisons between the approximation X and a solution XSOL. -C SNLS1E terminates when any of the tests is satisfied. If TOL is -C less than the machine precision (as defined by the function -C R1MACH(4)), then SNLS1E only attempts to satisfy the test -C defined by the machine precision. Further progress is not usu- -C ally possible. Unless high precision solutions are required, -C the recommended value for TOL is the square root of the machine -C precision. -C -C The tests assume that the functions are reasonably well behaved, -C and, if the Jacobian is supplied by the user, that the functions -C and the Jacobian are coded consistently. If these conditions -C are not satisfied, then SNLS1E may incorrectly indicate conver- -C gence. If the Jacobian is coded correctly or IOPT=1, -C then the validity of the answer can be checked, for example, by -C rerunning SNLS1E with tighter tolerances. -C -C First Convergence Test. If ENORM(Z) denotes the Euclidean norm -C of a vector Z, then this test attempts to guarantee that -C -C ENORM(FVEC) .LE. (1+TOL)*ENORM(FVECS), -C -C where FVECS denotes the functions evaluated at XSOL. If this -C condition is satisfied with TOL = 10**(-K), then the final -C residual norm ENORM(FVEC) has K significant decimal digits and -C INFO is set to 1 (or to 3 if the second test is also satis- -C fied). -C -C Second Convergence Test. If D is a diagonal matrix (implicitly -C generated by SNLS1E) whose entries contain scale factors for -C the variables, then this test attempts to guarantee that -C -C ENORM(D*(X-XSOL)) .LE. TOL*ENORM(D*XSOL). -C -C If this condition is satisfied with TOL = 10**(-K), then the -C larger components of D*X have K significant decimal digits and -C INFO is set to 2 (or to 3 if the first test is also satis- -C fied). There is a danger that the smaller components of D*X -C may have large relative errors, but the choice of D is such -C that the accuracy of the components of X is usually related to -C their sensitivity. -C -C Third Convergence Test. This test is satisfied when FVEC is -C orthogonal to the columns of the Jacobian to machine preci- -C sion. There is no clear relationship between this test and -C the accuracy of SNLS1E, and furthermore, the test is equally -C well satisfied at other critical points, namely maximizers and -C saddle points. Therefore, termination caused by this test -C (INFO = 4) should be examined carefully. -C -C -C 5. Unsuccessful Completion. -C -C Unsuccessful termination of SNLS1E can be due to improper input -C parameters, arithmetic interrupts, or an excessive number of -C function evaluations. -C -C Improper Input Parameters. INFO is set to 0 if IOPT .LT. 1 -C or IOPT .GT. 3, or N .LE. 0, or M .LT. N, or TOL .LT. 0.E0, -C or for IOPT=1 or 2 LWA .LT. N*(M+5)+M, or for IOPT=3 -C LWA .LT. N*(N+5)+M. -C -C Arithmetic Interrupts. If these interrupts occur in the FCN -C subroutine during an early stage of the computation, they may -C be caused by an unacceptable choice of X by SNLS1E. In this -C case, it may be possible to remedy the situation by not evalu- -C ating the functions here, but instead setting the components -C of FVEC to numbers that exceed those in the initial FVEC. -C -C Excessive Number of Function Evaluations. If the number of -C calls to FCN reaches 100*(N+1) for IOPT=2 or 3 or 200*(N+1) -C for IOPT=1, then this indicates that the routine is converging -C very slowly as measured by the progress of FVEC, and INFO is -C set to 5. In this case, it may be helpful to restart SNLS1E, -C thereby forcing it to disregard old (and possibly harmful) -C information. -C -C -C 6. Characteristics of the Algorithm. -C -C SNLS1E is a modification of the Levenberg-Marquardt algorithm. -C Two of its main characteristics involve the proper use of -C implicitly scaled variables and an optimal choice for the cor- -C rection. The use of implicitly scaled variables achieves scale -C invariance of SNLS1E and limits the size of the correction in -C any direction where the functions are changing rapidly. The -C optimal choice of the correction guarantees (under reasonable -C conditions) global convergence from starting points far from the -C solution and a fast rate of convergence for problems with small -C residuals. -C -C Timing. The time required by SNLS1E to solve a given problem -C depends on M and N, the behavior of the functions, the accu- -C racy requested, and the starting point. The number of arith- -C metic operations needed by SNLS1E is about N**3 to process -C each evaluation of the functions (call to FCN) and to process -C each evaluation of the Jacobian SNLS1E takes M*N**2 for IOPT=2 -C (one call to JAC), M*N**2 for IOPT=1 (N calls to FCN) and -C 1.5*M*N**2 for IOPT=3 (M calls to FCN). Unless FCN -C can be evaluated quickly, the timing of SNLS1E will be -C strongly influenced by the time spent in FCN. -C -C Storage. SNLS1E requires (M*N + 2*M + 6*N) for IOPT=1 or 2 and -C (N**2 + 2*M + 6*N) for IOPT=3 single precision storage -C locations and N integer storage locations, in addition to -C the storage required by the program. There are no internally -C declared storage arrays. -C -C *Long Description: -C -C 7. Example. -C -C The problem is to determine the values of X(1), X(2), and X(3) -C which provide the best fit (in the least squares sense) of -C -C X(1) + U(I)/(V(I)*X(2) + W(I)*X(3)), I = 1, 15 -C -C to the data -C -C Y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, -C 0.37,0.58,0.73,0.96,1.34,2.10,4.39), -C -C where U(I) = I, V(I) = 16 - I, and W(I) = MIN(U(I),V(I)). The -C I-th component of FVEC is thus defined by -C -C Y(I) - (X(1) + U(I)/(V(I)*X(2) + W(I)*X(3))). -C -C ********** -C -C PROGRAM TEST -C C -C C Driver for SNLS1E example. -C C -C INTEGER I,IOPT,M,N,NPRINT,JNFO,LWA,NWRITE -C INTEGER IW(3) -C REAL TOL,FNORM -C REAL X(3),FVEC(15),WA(75) -C REAL ENORM,R1MACH -C EXTERNAL FCN -C DATA NWRITE /6/ -C C -C IOPT = 1 -C M = 15 -C N = 3 -C C -C C The following starting values provide a rough fit. -C C -C X(1) = 1.E0 -C X(2) = 1.E0 -C X(3) = 1.E0 -C C -C LWA = 75 -C NPRINT = 0 -C C -C C Set TOL to the square root of the machine precision. -C C Unless high precision solutions are required, -C C this is the recommended setting. -C C -C TOL = SQRT(R1MACH(4)) -C C -C CALL SNLS1E(FCN,IOPT,M,N,X,FVEC,TOL,NPRINT, -C * INFO,IW,WA,LWA) -C FNORM = ENORM(M,FVEC) -C WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) -C STOP -C 1000 FORMAT (5X,' FINAL L2 NORM OF THE RESIDUALS',E15.7 // -C * 5X,' EXIT PARAMETER',16X,I10 // -C * 5X,' FINAL APPROXIMATE SOLUTION' // 5X,3E15.7) -C END -C SUBROUTINE FCN(IFLAG,M,N,X,FVEC,DUM,IDUM) -C C This is the form of the FCN routine if IOPT=1, -C C that is, if the user does not calculate the Jacobian. -C INTEGER M,N,IFLAG -C REAL X(N),FVEC(M) -C INTEGER I -C REAL TMP1,TMP2,TMP3,TMP4 -C REAL Y(15) -C DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), -C * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) -C * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, -C * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ -C C -C IF (IFLAG .NE. 0) GO TO 5 -C C -C C Insert print statements here when NPRINT is positive. -C C -C RETURN -C 5 CONTINUE -C DO 10 I = 1, M -C TMP1 = I -C TMP2 = 16 - I -C TMP3 = TMP1 -C IF (I .GT. 8) TMP3 = TMP2 -C FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) -C 10 CONTINUE -C RETURN -C END -C -C -C Results obtained with different compilers or machines -C may be slightly different. -C -C FINAL L2 NORM OF THE RESIDUALS 0.9063596E-01 -C -C EXIT PARAMETER 1 -C -C FINAL APPROXIMATE SOLUTION -C -C 0.8241058E-01 0.1133037E+01 0.2343695E+01 -C -C -C For IOPT=2, FCN would be modified as follows to also -C calculate the full Jacobian when IFLAG=2. -C -C SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) -C C -C C This is the form of the FCN routine if IOPT=2, -C C that is, if the user calculates the full Jacobian. -C C -C INTEGER LDFJAC,M,N,IFLAG -C REAL X(N),FVEC(M) -C REAL FJAC(LDFJAC,N) -C INTEGER I -C REAL TMP1,TMP2,TMP3,TMP4 -C REAL Y(15) -C DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), -C * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) -C * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, -C * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ -C C -C IF (IFLAG .NE. 0) GO TO 5 -C C -C C Insert print statements here when NPRINT is positive. -C C -C RETURN -C 5 CONTINUE -C IF(IFLAG.NE.1) GO TO 20 -C DO 10 I = 1, M -C TMP1 = I -C TMP2 = 16 - I -C TMP3 = TMP1 -C IF (I .GT. 8) TMP3 = TMP2 -C FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) -C 10 CONTINUE -C RETURN -C C -C C Below, calculate the full Jacobian. -C C -C 20 CONTINUE -C C -C DO 30 I = 1, M -C TMP1 = I -C TMP2 = 16 - I -C TMP3 = TMP1 -C IF (I .GT. 8) TMP3 = TMP2 -C TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 -C FJAC(I,1) = -1.E0 -C FJAC(I,2) = TMP1*TMP2/TMP4 -C FJAC(I,3) = TMP1*TMP3/TMP4 -C 30 CONTINUE -C RETURN -C END -C -C -C For IOPT = 3, FJAC would be dimensioned as FJAC(3,3), -C LDFJAC would be set to 3, and FCN would be written as -C follows to calculate a row of the Jacobian when IFLAG=3. -C -C SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) -C C This is the form of the FCN routine if IOPT=3, -C C that is, if the user calculates the Jacobian row by row. -C INTEGER M,N,IFLAG -C REAL X(N),FVEC(M) -C REAL FJAC(N) -C INTEGER I -C REAL TMP1,TMP2,TMP3,TMP4 -C REAL Y(15) -C DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), -C * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) -C * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, -C * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ -C C -C IF (IFLAG .NE. 0) GO TO 5 -C C -C C Insert print statements here when NPRINT is positive. -C C -C RETURN -C 5 CONTINUE -C IF( IFLAG.NE.1) GO TO 20 -C DO 10 I = 1, M -C TMP1 = I -C TMP2 = 16 - I -C TMP3 = TMP1 -C IF (I .GT. 8) TMP3 = TMP2 -C FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) -C 10 CONTINUE -C RETURN -C C -C C Below, calculate the LDFJAC-th row of the Jacobian. -C C -C 20 CONTINUE -C -C I = LDFJAC -C TMP1 = I -C TMP2 = 16 - I -C TMP3 = TMP1 -C IF (I .GT. 8) TMP3 = TMP2 -C TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 -C FJAC(1) = -1.E0 -C FJAC(2) = TMP1*TMP2/TMP4 -C FJAC(3) = TMP1*TMP3/TMP4 -C RETURN -C END -C -C***REFERENCES Jorge J. More, The Levenberg-Marquardt algorithm: -C implementation and theory. In Numerical Analysis -C Proceedings (Dundee, June 28 - July 1, 1977, G. A. -C Watson, Editor), Lecture Notes in Mathematics 630, -C Springer-Verlag, 1978. -C***ROUTINES CALLED SNLS1, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890206 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***END PROLOGUE SNLS1E - INTEGER M,N,NPRINT,INFO,LWA,IOPT - INTEGER INDEX,IW(*) - REAL TOL - REAL X(*),FVEC(*),WA(*) - EXTERNAL FCN - INTEGER MAXFEV,MODE,NFEV,NJEV - REAL FACTOR,FTOL,GTOL,XTOL,ZERO,EPSFCN - SAVE FACTOR, ZERO - DATA FACTOR,ZERO /1.0E2,0.0E0/ -C***FIRST EXECUTABLE STATEMENT SNLS1E - INFO = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C - IF (IOPT .LT. 1 .OR. IOPT .GT. 3 .OR. - 1 N .LE. 0 .OR. M .LT. N .OR. TOL .LT. ZERO - 2 .OR. LWA .LT. N*(N+5) + M) GO TO 10 - IF (IOPT .LT. 3 .AND. LWA .LT. N*(M+5) + M) GO TO 10 -C -C CALL SNLS1. -C - MAXFEV = 100*(N + 1) - IF (IOPT .EQ. 1) MAXFEV = 2*MAXFEV - FTOL = TOL - XTOL = TOL - GTOL = ZERO - EPSFCN = ZERO - MODE = 1 - INDEX = 5*N+M - CALL SNLS1(FCN,IOPT,M,N,X,FVEC,WA(INDEX+1),M,FTOL,XTOL,GTOL, - 1 MAXFEV,EPSFCN,WA(1),MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, - 2 IW,WA(N+1),WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) - IF (INFO .EQ. 8) INFO = 4 - 10 CONTINUE - IF (INFO .EQ. 0) CALL XERMSG ('SLATEC', 'SNLS1E', - + 'INVALID INPUT PARAMETER.', 2, 1) - RETURN -C -C LAST CARD OF SUBROUTINE SNLS1E. -C - END diff --git a/slatec/snrm2.f b/slatec/snrm2.f deleted file mode 100644 index c8b0b0a..0000000 --- a/slatec/snrm2.f +++ /dev/null @@ -1,161 +0,0 @@ -*DECK SNRM2 - REAL FUNCTION SNRM2 (N, SX, INCX) -C***BEGIN PROLOGUE SNRM2 -C***PURPOSE Compute the Euclidean length (L2 norm) of a vector. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A3B -C***TYPE SINGLE PRECISION (SNRM2-S, DNRM2-D, SCNRM2-C) -C***KEYWORDS BLAS, EUCLIDEAN LENGTH, EUCLIDEAN NORM, L2, -C LINEAR ALGEBRA, UNITARY, 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 -C --Output-- -C SNRM2 single precision result (zero if N .LE. 0) -C -C Euclidean norm of the N-vector stored in SX with storage -C increment INCX . -C If N .LE. 0, return with result = 0. -C If N .GE. 1, then INCX must be .GE. 1 -C -C Four Phase Method using two built-in constants that are -C hopefully applicable to all machines. -C CUTLO = maximum of SQRT(U/EPS) over all known machines. -C CUTHI = minimum of SQRT(V) over all known machines. -C where -C EPS = smallest no. such that EPS + 1. .GT. 1. -C U = smallest positive no. (underflow limit) -C V = largest no. (overflow limit) -C -C Brief Outline of Algorithm. -C -C Phase 1 scans zero components. -C Move to phase 2 when a component is nonzero and .LE. CUTLO -C Move to phase 3 when a component is .GT. CUTLO -C Move to phase 4 when a component is .GE. CUTHI/M -C where M = N for X() real and M = 2*N for complex. -C -C Values for CUTLO and CUTHI. -C From the environmental parameters listed in the IMSL converter -C document the limiting values are as follows: -C CUTLO, S.P. U/EPS = 2**(-102) for Honeywell. Close seconds are -C Univac and DEC at 2**(-103) -C Thus CUTLO = 2**(-51) = 4.44089E-16 -C CUTHI, S.P. V = 2**127 for Univac, Honeywell, and DEC. -C Thus CUTHI = 2**(63.5) = 1.30438E19 -C CUTLO, D.P. U/EPS = 2**(-67) for Honeywell and DEC. -C Thus CUTLO = 2**(-33.5) = 8.23181D-11 -C CUTHI, D.P. same as S.P. CUTHI = 1.30438D19 -C DATA CUTLO, CUTHI /8.232D-11, 1.304D19/ -C DATA CUTLO, CUTHI /4.441E-16, 1.304E19/ -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 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SNRM2 - INTEGER NEXT - REAL SX(*), CUTLO, CUTHI, HITEST, SUM, XMAX, ZERO, ONE - SAVE CUTLO, CUTHI, ZERO, ONE - DATA ZERO, ONE /0.0E0, 1.0E0/ -C - DATA CUTLO, CUTHI /4.441E-16, 1.304E19/ -C***FIRST EXECUTABLE STATEMENT SNRM2 - IF (N .GT. 0) GO TO 10 - SNRM2 = ZERO - GO TO 300 -C - 10 ASSIGN 30 TO NEXT - SUM = ZERO - NN = N * INCX -C -C BEGIN MAIN LOOP -C - I = 1 - 20 GO TO NEXT,(30, 50, 70, 110) - 30 IF (ABS(SX(I)) .GT. CUTLO) GO TO 85 - ASSIGN 50 TO NEXT - XMAX = ZERO -C -C PHASE 1. SUM IS ZERO -C - 50 IF (SX(I) .EQ. ZERO) GO TO 200 - IF (ABS(SX(I)) .GT. CUTLO) GO TO 85 -C -C PREPARE FOR PHASE 2. -C - ASSIGN 70 TO NEXT - GO TO 105 -C -C PREPARE FOR PHASE 4. -C - 100 I = J - ASSIGN 110 TO NEXT - SUM = (SUM / SX(I)) / SX(I) - 105 XMAX = ABS(SX(I)) - GO TO 115 -C -C PHASE 2. SUM IS SMALL. -C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. -C - 70 IF (ABS(SX(I)) .GT. CUTLO) GO TO 75 -C -C COMMON CODE FOR PHASES 2 AND 4. -C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. -C - 110 IF (ABS(SX(I)) .LE. XMAX) GO TO 115 - SUM = ONE + SUM * (XMAX / SX(I))**2 - XMAX = ABS(SX(I)) - GO TO 200 -C - 115 SUM = SUM + (SX(I)/XMAX)**2 - GO TO 200 -C -C PREPARE FOR PHASE 3. -C - 75 SUM = (SUM * XMAX) * XMAX -C -C FOR REAL OR D.P. SET HITEST = CUTHI/N -C FOR COMPLEX SET HITEST = CUTHI/(2*N) -C - 85 HITEST = CUTHI / N -C -C PHASE 3. SUM IS MID-RANGE. NO SCALING. -C - DO 95 J = I,NN,INCX - IF (ABS(SX(J)) .GE. HITEST) GO TO 100 - 95 SUM = SUM + SX(J)**2 - SNRM2 = SQRT( SUM ) - GO TO 300 -C - 200 CONTINUE - I = I + INCX - IF (I .LE. NN) GO TO 20 -C -C END OF MAIN LOOP. -C -C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. -C - SNRM2 = XMAX * SQRT(SUM) - 300 CONTINUE - RETURN - END diff --git a/slatec/snsq.f b/slatec/snsq.f deleted file mode 100644 index b86fbe6..0000000 --- a/slatec/snsq.f +++ /dev/null @@ -1,737 +0,0 @@ -*DECK SNSQ - SUBROUTINE SNSQ (FCN, JAC, IOPT, N, X, FVEC, FJAC, LDFJAC, XTOL, - + MAXFEV, ML, MU, EPSFCN, DIAG, MODE, FACTOR, NPRINT, INFO, NFEV, - + NJEV, R, LR, QTF, WA1, WA2, WA3, WA4) -C***BEGIN PROLOGUE SNSQ -C***PURPOSE Find a zero of a system of a N nonlinear functions in N -C variables by a modification of the Powell hybrid method. -C***LIBRARY SLATEC -C***CATEGORY F2A -C***TYPE SINGLE PRECISION (SNSQ-S, DNSQ-D) -C***KEYWORDS NONLINEAR SQUARE SYSTEM, POWELL HYBRID METHOD, ZEROS -C***AUTHOR Hiebert, K. L., (SNLA) -C***DESCRIPTION -C -C 1. Purpose. -C -C The purpose of SNSQ is to find a zero of a system of N non- -C linear functions in N variables by a modification of the Powell -C hybrid method. The user must provide a subroutine which calcu- -C lates the functions. The user has the option of either to -C provide a subroutine which calculates the Jacobian or to let the -C code calculate it by a forward-difference approximation. -C This code is the combination of the MINPACK codes (Argonne) -C HYBRD and HYBRDJ. -C -C -C 2. Subroutine and Type Statements. -C -C SUBROUTINE SNSQ(FCN,JAC,IOPT,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV, -C * ML,MU,EPSFCN,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV, -C * NJEV,R,LR,QTF,WA1,WA2,WA3,WA4) -C INTEGER IOPT,N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,NJEV,LR -C REAL XTOL,EPSFCN,FACTOR -C REAL X(N),FVEC(N),DIAG(N),FJAC(LDFJAC,N),R(LR),QTF(N), -C * WA1(N),WA2(N),WA3(N),WA4(N) -C EXTERNAL FCN,JAC -C -C -C 3. Parameters. -C -C Parameters designated as input parameters must be specified on -C entry to SNSQ and are not changed on exit, while parameters -C designated as output parameters need not be specified on entry -C and are set to appropriate values on exit from SNSQ. -C -C FCN is the name of the user-supplied subroutine which calculates -C the functions. FCN must be declared in an EXTERNAL statement -C in the user calling program, and should be written as follows. -C -C SUBROUTINE FCN(N,X,FVEC,IFLAG) -C INTEGER N,IFLAG -C REAL X(N),FVEC(N) -C ---------- -C Calculate the functions at X and -C return this vector in FVEC. -C ---------- -C RETURN -C END -C -C The value of IFLAG should not be changed by FCN unless the -C user wants to terminate execution of SNSQ. In this case, set -C IFLAG to a negative integer. -C -C JAC is the name of the user-supplied subroutine which calculates -C the Jacobian. If IOPT=1, then JAC must be declared in an -C EXTERNAL statement in the user calling program, and should be -C written as follows. -C -C SUBROUTINE JAC(N,X,FVEC,FJAC,LDFJAC,IFLAG) -C INTEGER N,LDFJAC,IFLAG -C REAL X(N),FVEC(N),FJAC(LDFJAC,N) -C ---------- -C Calculate the Jacobian at X and return this -C matrix in FJAC. FVEC contains the function -C values at X and should not be altered. -C ---------- -C RETURN -C END -C -C The value of IFLAG should not be changed by JAC unless the -C user wants to terminate execution of SNSQ. In this case, set -C IFLAG to a negative integer. -C -C If IOPT=2, JAC can be ignored (treat it as a dummy argument). -C -C IOPT is an input variable which specifies how the Jacobian will -C be calculated. If IOPT=1, then the user must supply the -C Jacobian through the subroutine JAC. If IOPT=2, then the -C code will approximate the Jacobian by forward-differencing. -C -C N is a positive integer input variable set to the number of -C functions and variables. -C -C X is an array of length N. On input, X must contain an initial -C estimate of the solution vector. On output, X contains the -C final estimate of the solution vector. -C -C FVEC is an output array of length N which contains the functions -C evaluated at the output X. -C -C FJAC is an output N by N array which contains the orthogonal -C matrix Q produced by the QR factorization of the final approx- -C imate Jacobian. -C -C LDFJAC is a positive integer input variable not less than N -C which specifies the leading dimension of the array FJAC. -C -C XTOL is a non-negative input variable. Termination occurs when -C the relative error between two consecutive iterates is at most -C XTOL. Therefore, XTOL measures the relative error desired in -C the approximate solution. Section 4 contains more details -C about XTOL. -C -C MAXFEV is a positive integer input variable. Termination occurs -C when the number of calls to FCN is at least MAXFEV by the end -C of an iteration. -C -C ML is a non-negative integer input variable which specifies the -C number of subdiagonals within the band of the Jacobian matrix. -C If the Jacobian is not banded or IOPT=1, set ML to at -C least N - 1. -C -C MU is a non-negative integer input variable which specifies the -C number of superdiagonals within the band of the Jacobian -C matrix. If the Jacobian is not banded or IOPT=1, set MU to at -C least N - 1. -C -C EPSFCN is an input variable used in determining a suitable step -C for the forward-difference approximation. This approximation -C assumes that the relative errors in the functions are of the -C order of EPSFCN. If EPSFCN is less than the machine preci- -C sion, it is assumed that the relative errors in the functions -C are of the order of the machine precision. If IOPT=1, then -C EPSFCN can be ignored (treat it as a dummy argument). -C -C DIAG is an array of length N. If MODE = 1 (see below), DIAG is -C internally set. If MODE = 2, DIAG must contain positive -C entries that serve as implicit (multiplicative) scale factors -C for the variables. -C -C MODE is an integer input variable. If MODE = 1, the variables -C will be scaled internally. If MODE = 2, the scaling is speci- -C fied by the input DIAG. Other values of MODE are equivalent -C to MODE = 1. -C -C FACTOR is a positive input variable used in determining the ini- -C tial step bound. This bound is set to the product of FACTOR -C and the Euclidean norm of DIAG*X if nonzero, or else to FACTOR -C itself. In most cases FACTOR should lie in the interval -C (.1,100.). 100. is a generally recommended value. -C -C NPRINT is an integer input variable that enables controlled -C printing of iterates if it is positive. In this case, FCN is -C called with IFLAG = 0 at the beginning of the first iteration -C and every NPRINT iteration thereafter and immediately prior -C to return, with X and FVEC available for printing. Appropriate -C print statements must be added to FCN(see example). If NPRINT -C is not positive, no special calls of FCN with IFLAG = 0 are -C made. -C -C INFO is an integer output variable. If the user has terminated -C execution, INFO is set to the (negative) value of IFLAG. See -C description of FCN and JAC. Otherwise, INFO is set as follows. -C -C INFO = 0 improper input parameters. -C -C INFO = 1 relative error between two consecutive iterates is -C at most XTOL. -C -C INFO = 2 number of calls to FCN has reached or exceeded -C MAXFEV. -C -C INFO = 3 XTOL is too small. No further improvement in the -C approximate solution X is possible. -C -C INFO = 4 iteration is not making good progress, as measured -C by the improvement from the last five Jacobian eval- -C uations. -C -C INFO = 5 iteration is not making good progress, as measured -C by the improvement from the last ten iterations. -C -C Sections 4 and 5 contain more details about INFO. -C -C NFEV is an integer output variable set to the number of calls to -C FCN. -C -C NJEV is an integer output variable set to the number of calls to -C JAC. (If IOPT=2, then NJEV is set to zero.) -C -C R is an output array of length LR which contains the upper -C triangular matrix produced by the QR factorization of the -C final approximate Jacobian, stored rowwise. -C -C LR is a positive integer input variable not less than -C (N*(N+1))/2. -C -C QTF is an output array of length N which contains the vector -C (Q TRANSPOSE)*FVEC. -C -C WA1, WA2, WA3, and WA4 are work arrays of length N. -C -C -C 4. Successful Completion. -C -C The accuracy of SNSQ is controlled by the convergence parameter -C XTOL. This parameter is used in a test which makes a comparison -C between the approximation X and a solution XSOL. SNSQ termi- -C nates when the test is satisfied. If the convergence parameter -C is less than the machine precision (as defined by the function -C R1MACH(4)), then SNSQ only attempts to satisfy the test -C defined by the machine precision. Further progress is not -C usually possible. -C -C The test assumes that the functions are reasonably well behaved, -C and, if the Jacobian is supplied by the user, that the functions -C and the Jacobian are coded consistently. If these conditions -C are not satisfied, then SNSQ may incorrectly indicate conver- -C gence. The coding of the Jacobian can be checked by the -C subroutine CHKDER. If the Jacobian is coded correctly or IOPT=2, -C then the validity of the answer can be checked, for example, by -C rerunning SNSQ with a tighter tolerance. -C -C Convergence Test. If ENORM(Z) denotes the Euclidean norm of a -C vector Z and D is the diagonal matrix whose entries are -C defined by the array DIAG, then this test attempts to guaran- -C tee that -C -C ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL). -C -C If this condition is satisfied with XTOL = 10**(-K), then the -C larger components of D*X have K significant decimal digits and -C INFO is set to 1. There is a danger that the smaller compo- -C nents of D*X may have large relative errors, but the fast rate -C of convergence of SNSQ usually avoids this possibility. -C Unless high precision solutions are required, the recommended -C value for XTOL is the square root of the machine precision. -C -C -C 5. Unsuccessful Completion. -C -C Unsuccessful termination of SNSQ can be due to improper input -C parameters, arithmetic interrupts, an excessive number of func- -C tion evaluations, or lack of good progress. -C -C Improper Input Parameters. INFO is set to 0 if IOPT .LT. 1, -C or IOPT .GT. 2, or N .LE. 0, or LDFJAC .LT. N, or -C XTOL .LT. 0.E0, or MAXFEV .LE. 0, or ML .LT. 0, or MU .LT. 0, -C or FACTOR .LE. 0.E0, or LR .LT. (N*(N+1))/2. -C -C Arithmetic Interrupts. If these interrupts occur in the FCN -C subroutine during an early stage of the computation, they may -C be caused by an unacceptable choice of X by SNSQ. In this -C case, it may be possible to remedy the situation by rerunning -C SNSQ with a smaller value of FACTOR. -C -C Excessive Number of Function Evaluations. A reasonable value -C for MAXFEV is 100*(N+1) for IOPT=1 and 200*(N+1) for IOPT=2. -C If the number of calls to FCN reaches MAXFEV, then this -C indicates that the routine is converging very slowly as -C measured by the progress of FVEC, and INFO is set to 2. This -C situation should be unusual because, as indicated below, lack -C of good progress is usually diagnosed earlier by SNSQ, -C causing termination with INFO = 4 or INFO = 5. -C -C Lack of Good Progress. SNSQ searches for a zero of the system -C by minimizing the sum of the squares of the functions. In so -C doing, it can become trapped in a region where the minimum -C does not correspond to a zero of the system and, in this situ- -C ation, the iteration eventually fails to make good progress. -C In particular, this will happen if the system does not have a -C zero. If the system has a zero, rerunning SNSQ from a dif- -C ferent starting point may be helpful. -C -C -C 6. Characteristics of the Algorithm. -C -C SNSQ is a modification of the Powell hybrid method. Two of its -C main characteristics involve the choice of the correction as a -C convex combination of the Newton and scaled gradient directions, -C and the updating of the Jacobian by the rank-1 method of Broy- -C den. The choice of the correction guarantees (under reasonable -C conditions) global convergence for starting points far from the -C solution and a fast rate of convergence. The Jacobian is -C calculated at the starting point by either the user-supplied -C subroutine or a forward-difference approximation, but it is not -C recalculated until the rank-1 method fails to produce satis- -C factory progress. -C -C Timing. The time required by SNSQ to solve a given problem -C depends on N, the behavior of the functions, the accuracy -C requested, and the starting point. The number of arithmetic -C operations needed by SNSQ is about 11.5*(N**2) to process -C each evaluation of the functions (call to FCN) and 1.3*(N**3) -C to process each evaluation of the Jacobian (call to JAC, -C if IOPT = 1). Unless FCN and JAC can be evaluated quickly, -C the timing of SNSQ will be strongly influenced by the time -C spent in FCN and JAC. -C -C Storage. SNSQ requires (3*N**2 + 17*N)/2 single precision -C storage locations, in addition to the storage required by the -C program. There are no internally declared storage arrays. -C -C -C 7. Example. -C -C The problem is to determine the values of X(1), X(2), ..., X(9), -C which solve the system of tridiagonal equations -C -C (3-2*X(1))*X(1) -2*X(2) = -1 -C -X(I-1) + (3-2*X(I))*X(I) -2*X(I+1) = -1, I=2-8 -C -X(8) + (3-2*X(9))*X(9) = -1 -C C ********** -C -C PROGRAM TEST -C C -C C Driver for SNSQ example. -C C -C INTEGER J,IOPT,N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,LR, -C * NWRITE -C REAL XTOL,EPSFCN,FACTOR,FNORM -C REAL X(9),FVEC(9),DIAG(9),FJAC(9,9),R(45),QTF(9), -C * WA1(9),WA2(9),WA3(9),WA4(9) -C REAL ENORM,R1MACH -C EXTERNAL FCN -C DATA NWRITE /6/ -C C -C IOPT = 2 -C N = 9 -C C -C C The following starting values provide a rough solution. -C C -C DO 10 J = 1, 9 -C X(J) = -1.E0 -C 10 CONTINUE -C C -C LDFJAC = 9 -C LR = 45 -C C -C C Set XTOL to the square root of the machine precision. -C C Unless high precision solutions are required, -C C this is the recommended setting. -C C -C XTOL = SQRT(R1MACH(4)) -C C -C MAXFEV = 2000 -C ML = 1 -C MU = 1 -C EPSFCN = 0.E0 -C MODE = 2 -C DO 20 J = 1, 9 -C DIAG(J) = 1.E0 -C 20 CONTINUE -C FACTOR = 1.E2 -C NPRINT = 0 -C C -C CALL SNSQ(FCN,JAC,IOPT,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,ML,MU, -C * EPSFCN,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, -C * R,LR,QTF,WA1,WA2,WA3,WA4) -C FNORM = ENORM(N,FVEC) -C WRITE (NWRITE,1000) FNORM,NFEV,INFO,(X(J),J=1,N) -C STOP -C 1000 FORMAT (5X,' FINAL L2 NORM OF THE RESIDUALS',E15.7 // -C * 5X,' NUMBER OF FUNCTION EVALUATIONS',I10 // -C * 5X,' EXIT PARAMETER',16X,I10 // -C * 5X,' FINAL APPROXIMATE SOLUTION' // (5X,3E15.7)) -C END -C SUBROUTINE FCN(N,X,FVEC,IFLAG) -C INTEGER N,IFLAG -C REAL X(N),FVEC(N) -C INTEGER K -C REAL ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO -C DATA ZERO,ONE,TWO,THREE /0.E0,1.E0,2.E0,3.E0/ -C C -C IF (IFLAG .NE. 0) GO TO 5 -C C -C C Insert print statements here when NPRINT is positive. -C C -C RETURN -C 5 CONTINUE -C DO 10 K = 1, N -C TEMP = (THREE - TWO*X(K))*X(K) -C TEMP1 = ZERO -C IF (K .NE. 1) TEMP1 = X(K-1) -C TEMP2 = ZERO -C IF (K .NE. N) TEMP2 = X(K+1) -C FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE -C 10 CONTINUE -C RETURN -C END -C -C Results obtained with different compilers or machines -C may be slightly different. -C -C FINAL L2 NORM OF THE RESIDUALS 0.1192636E-07 -C -C NUMBER OF FUNCTION EVALUATIONS 14 -C -C EXIT PARAMETER 1 -C -C FINAL APPROXIMATE SOLUTION -C -C -0.5706545E+00 -0.6816283E+00 -0.7017325E+00 -C -0.7042129E+00 -0.7013690E+00 -0.6918656E+00 -C -0.6657920E+00 -0.5960342E+00 -0.4164121E+00 -C -C***REFERENCES M. J. D. Powell, A hybrid method for nonlinear equa- -C tions. In Numerical Methods for Nonlinear Algebraic -C Equations, P. Rabinowitz, Editor. Gordon and Breach, -C 1988. -C***ROUTINES CALLED DOGLEG, ENORM, FDJAC1, QFORM, QRFAC, R1MACH, -C R1MPYQ, R1UPDT, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SNSQ - INTEGER IOPT,N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,LR,NJEV - REAL XTOL,EPSFCN,FACTOR - REAL X(*),FVEC(*),DIAG(*),FJAC(LDFJAC,*),R(LR),QTF(*),WA1(*), - 1 WA2(*),WA3(*),WA4(*) - EXTERNAL FCN - INTEGER I,IFLAG,ITER,J,JM1,L,NCFAIL,NCSUC,NSLOW1,NSLOW2 - INTEGER IWA(1) - LOGICAL JEVAL,SING - REAL ACTRED,DELTA,EPSMCH,FNORM,FNORM1,ONE,PNORM,PRERED,P1,P5, - 1 P001,P0001,RATIO,SUM,TEMP,XNORM,ZERO - REAL R1MACH,ENORM - SAVE ONE, P1, P5, P001, P0001, ZERO - DATA ONE,P1,P5,P001,P0001,ZERO - 1 /1.0E0,1.0E-1,5.0E-1,1.0E-3,1.0E-4,0.0E0/ -C -C***FIRST EXECUTABLE STATEMENT SNSQ - EPSMCH = R1MACH(4) -C - INFO = 0 - IFLAG = 0 - NFEV = 0 - NJEV = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C - IF (IOPT .LT. 1 .OR. IOPT .GT. 2 .OR. - 1 N .LE. 0 .OR. XTOL .LT. ZERO .OR. MAXFEV .LE. 0 - 2 .OR. ML .LT. 0 .OR. MU .LT. 0 .OR. FACTOR .LE. ZERO - 3 .OR. LDFJAC .LT. N .OR. LR .LT. (N*(N + 1))/2) GO TO 300 - IF (MODE .NE. 2) GO TO 20 - DO 10 J = 1, N - IF (DIAG(J) .LE. ZERO) GO TO 300 - 10 CONTINUE - 20 CONTINUE -C -C EVALUATE THE FUNCTION AT THE STARTING POINT -C AND CALCULATE ITS NORM. -C - IFLAG = 1 - CALL FCN(N,X,FVEC,IFLAG) - NFEV = 1 - IF (IFLAG .LT. 0) GO TO 300 - FNORM = ENORM(N,FVEC) -C -C INITIALIZE ITERATION COUNTER AND MONITORS. -C - ITER = 1 - NCSUC = 0 - NCFAIL = 0 - NSLOW1 = 0 - NSLOW2 = 0 -C -C BEGINNING OF THE OUTER LOOP. -C - 30 CONTINUE - JEVAL = .TRUE. -C -C CALCULATE THE JACOBIAN MATRIX. -C - IF (IOPT .EQ. 2) GO TO 31 -C -C USER SUPPLIES JACOBIAN -C - CALL JAC(N,X,FVEC,FJAC,LDFJAC,IFLAG) - NJEV = NJEV+1 - GO TO 32 -C -C CODE APPROXIMATES THE JACOBIAN -C - 31 IFLAG = 2 - CALL FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN,WA1, - 1 WA2) - NFEV = NFEV + MIN(ML+MU+1,N) -C - 32 IF (IFLAG .LT. 0) GO TO 300 -C -C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. -C - CALL QRFAC(N,N,FJAC,LDFJAC,.FALSE.,IWA,1,WA1,WA2,WA3) -C -C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING -C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. -C - IF (ITER .NE. 1) GO TO 70 - IF (MODE .EQ. 2) GO TO 50 - DO 40 J = 1, N - DIAG(J) = WA2(J) - IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE - 40 CONTINUE - 50 CONTINUE -C -C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X -C AND INITIALIZE THE STEP BOUND DELTA. -C - DO 60 J = 1, N - WA3(J) = DIAG(J)*X(J) - 60 CONTINUE - XNORM = ENORM(N,WA3) - DELTA = FACTOR*XNORM - IF (DELTA .EQ. ZERO) DELTA = FACTOR - 70 CONTINUE -C -C FORM (Q TRANSPOSE)*FVEC AND STORE IN QTF. -C - DO 80 I = 1, N - QTF(I) = FVEC(I) - 80 CONTINUE - DO 120 J = 1, N - IF (FJAC(J,J) .EQ. ZERO) GO TO 110 - SUM = ZERO - DO 90 I = J, N - SUM = SUM + FJAC(I,J)*QTF(I) - 90 CONTINUE - TEMP = -SUM/FJAC(J,J) - DO 100 I = J, N - QTF(I) = QTF(I) + FJAC(I,J)*TEMP - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE -C -C COPY THE TRIANGULAR FACTOR OF THE QR FACTORIZATION INTO R. -C - SING = .FALSE. - DO 150 J = 1, N - L = J - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 140 - DO 130 I = 1, JM1 - R(L) = FJAC(I,J) - L = L + N - I - 130 CONTINUE - 140 CONTINUE - R(L) = WA1(J) - IF (WA1(J) .EQ. ZERO) SING = .TRUE. - 150 CONTINUE -C -C ACCUMULATE THE ORTHOGONAL FACTOR IN FJAC. -C - CALL QFORM(N,N,FJAC,LDFJAC,WA1) -C -C RESCALE IF NECESSARY. -C - IF (MODE .EQ. 2) GO TO 170 - DO 160 J = 1, N - DIAG(J) = MAX(DIAG(J),WA2(J)) - 160 CONTINUE - 170 CONTINUE -C -C BEGINNING OF THE INNER LOOP. -C - 180 CONTINUE -C -C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. -C - IF (NPRINT .LE. 0) GO TO 190 - IFLAG = 0 - IF (MOD(ITER-1,NPRINT) .EQ. 0) CALL FCN(N,X,FVEC,IFLAG) - IF (IFLAG .LT. 0) GO TO 300 - 190 CONTINUE -C -C DETERMINE THE DIRECTION P. -C - CALL DOGLEG(N,R,LR,DIAG,QTF,DELTA,WA1,WA2,WA3) -C -C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. -C - DO 200 J = 1, N - WA1(J) = -WA1(J) - WA2(J) = X(J) + WA1(J) - WA3(J) = DIAG(J)*WA1(J) - 200 CONTINUE - PNORM = ENORM(N,WA3) -C -C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. -C - IF (ITER .EQ. 1) DELTA = MIN(DELTA,PNORM) -C -C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. -C - IFLAG = 1 - CALL FCN(N,WA2,WA4,IFLAG) - NFEV = NFEV + 1 - IF (IFLAG .LT. 0) GO TO 300 - FNORM1 = ENORM(N,WA4) -C -C COMPUTE THE SCALED ACTUAL REDUCTION. -C - ACTRED = -ONE - IF (FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 -C -C COMPUTE THE SCALED PREDICTED REDUCTION. -C - L = 1 - DO 220 I = 1, N - SUM = ZERO - DO 210 J = I, N - SUM = SUM + R(L)*WA1(J) - L = L + 1 - 210 CONTINUE - WA3(I) = QTF(I) + SUM - 220 CONTINUE - TEMP = ENORM(N,WA3) - PRERED = ZERO - IF (TEMP .LT. FNORM) PRERED = ONE - (TEMP/FNORM)**2 -C -C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED -C REDUCTION. -C - RATIO = ZERO - IF (PRERED .GT. ZERO) RATIO = ACTRED/PRERED -C -C UPDATE THE STEP BOUND. -C - IF (RATIO .GE. P1) GO TO 230 - NCSUC = 0 - NCFAIL = NCFAIL + 1 - DELTA = P5*DELTA - GO TO 240 - 230 CONTINUE - NCFAIL = 0 - NCSUC = NCSUC + 1 - IF (RATIO .GE. P5 .OR. NCSUC .GT. 1) - 1 DELTA = MAX(DELTA,PNORM/P5) - IF (ABS(RATIO-ONE) .LE. P1) DELTA = PNORM/P5 - 240 CONTINUE -C -C TEST FOR SUCCESSFUL ITERATION. -C - IF (RATIO .LT. P0001) GO TO 260 -C -C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. -C - DO 250 J = 1, N - X(J) = WA2(J) - WA2(J) = DIAG(J)*X(J) - FVEC(J) = WA4(J) - 250 CONTINUE - XNORM = ENORM(N,WA2) - FNORM = FNORM1 - ITER = ITER + 1 - 260 CONTINUE -C -C DETERMINE THE PROGRESS OF THE ITERATION. -C - NSLOW1 = NSLOW1 + 1 - IF (ACTRED .GE. P001) NSLOW1 = 0 - IF (JEVAL) NSLOW2 = NSLOW2 + 1 - IF (ACTRED .GE. P1) NSLOW2 = 0 -C -C TEST FOR CONVERGENCE. -C - IF (DELTA .LE. XTOL*XNORM .OR. FNORM .EQ. ZERO) INFO = 1 - IF (INFO .NE. 0) GO TO 300 -C -C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. -C - IF (NFEV .GE. MAXFEV) INFO = 2 - IF (P1*MAX(P1*DELTA,PNORM) .LE. EPSMCH*XNORM) INFO = 3 - IF (NSLOW2 .EQ. 5) INFO = 4 - IF (NSLOW1 .EQ. 10) INFO = 5 - IF (INFO .NE. 0) GO TO 300 -C -C CRITERION FOR RECALCULATING JACOBIAN -C - IF (NCFAIL .EQ. 2) GO TO 290 -C -C CALCULATE THE RANK ONE MODIFICATION TO THE JACOBIAN -C AND UPDATE QTF IF NECESSARY. -C - DO 280 J = 1, N - SUM = ZERO - DO 270 I = 1, N - SUM = SUM + FJAC(I,J)*WA4(I) - 270 CONTINUE - WA2(J) = (SUM - WA3(J))/PNORM - WA1(J) = DIAG(J)*((DIAG(J)*WA1(J))/PNORM) - IF (RATIO .GE. P0001) QTF(J) = SUM - 280 CONTINUE -C -C COMPUTE THE QR FACTORIZATION OF THE UPDATED JACOBIAN. -C - CALL R1UPDT(N,N,R,LR,WA1,WA2,WA3,SING) - CALL R1MPYQ(N,N,FJAC,LDFJAC,WA2,WA3) - CALL R1MPYQ(1,N,QTF,1,WA2,WA3) -C -C END OF THE INNER LOOP. -C - JEVAL = .FALSE. - GO TO 180 - 290 CONTINUE -C -C END OF THE OUTER LOOP. -C - GO TO 30 - 300 CONTINUE -C -C TERMINATION, EITHER NORMAL OR USER IMPOSED. -C - IF (IFLAG .LT. 0) INFO = IFLAG - IFLAG = 0 - IF (NPRINT .GT. 0) CALL FCN(N,X,FVEC,IFLAG) - IF (INFO .LT. 0) CALL XERMSG ('SLATEC', 'SNSQ', - + 'EXECUTION TERMINATED BECAUSE USER SET IFLAG NEGATIVE.', 1, 1) - IF (INFO .EQ. 0) CALL XERMSG ('SLATEC', 'SNSQ', - + 'INVALID INPUT PARAMETER.', 2, 1) - IF (INFO .EQ. 2) CALL XERMSG ('SLATEC', 'SNSQ', - + 'TOO MANY FUNCTION EVALUATIONS.', 9, 1) - IF (INFO .EQ. 3) CALL XERMSG ('SLATEC', 'SNSQ', - + 'XTOL TOO SMALL. NO FURTHER IMPROVEMENT POSSIBLE.', 3, 1) - IF (INFO .GT. 4) CALL XERMSG ('SLATEC', 'SNSQ', - + 'ITERATION NOT MAKING GOOD PROGRESS.', 1, 1) - RETURN -C -C LAST CARD OF SUBROUTINE SNSQ. -C - END diff --git a/slatec/snsqe.f b/slatec/snsqe.f deleted file mode 100644 index 6b19063..0000000 --- a/slatec/snsqe.f +++ /dev/null @@ -1,382 +0,0 @@ -*DECK SNSQE - SUBROUTINE SNSQE (FCN, JAC, IOPT, N, X, FVEC, TOL, NPRINT, INFO, - + WA, LWA) -C***BEGIN PROLOGUE SNSQE -C***PURPOSE An easy-to-use code to find a zero of a system of N -C nonlinear functions in N variables by a modification of -C the Powell hybrid method. -C***LIBRARY SLATEC -C***CATEGORY F2A -C***TYPE SINGLE PRECISION (SNSQE-S, DNSQE-D) -C***KEYWORDS EASY-TO-USE, NONLINEAR SQUARE SYSTEM, -C POWELL HYBRID METHOD, ZEROS -C***AUTHOR Hiebert, K. L., (SNLA) -C***DESCRIPTION -C -C 1. Purpose. -C -C -C The purpose of SNSQE is to find a zero of a system of N non- -C linear functions in N variables by a modification of the Powell -C hybrid method. This is done by using the more general nonlinear -C equation solver SNSQ. The user must provide a subroutine which -C calculates the functions. The user has the option of either to -C provide a subroutine which calculates the Jacobian or to let the -C code calculate it by a forward-difference approximation. This -C code is the combination of the MINPACK codes (Argonne) HYBRD1 -C and HYBRJ1. -C -C -C 2. Subroutine and Type Statements. -C -C SUBROUTINE SNSQE(FCN,JAC,IOPT,N,X,FVEC,TOL,NPRINT,INFO, -C * WA,LWA) -C INTEGER IOPT,N,NPRINT,INFO,LWA -C REAL TOL -C REAL X(N),FVEC(N),WA(LWA) -C EXTERNAL FCN,JAC -C -C -C 3. Parameters. -C -C Parameters designated as input parameters must be specified on -C entry to SNSQE and are not changed on exit, while parameters -C designated as output parameters need not be specified on entry -C and are set to appropriate values on exit from SNSQE. -C -C FCN is the name of the user-supplied subroutine which calculates -C the functions. FCN must be declared in an EXTERNAL statement -C in the user calling program, and should be written as follows. -C -C SUBROUTINE FCN(N,X,FVEC,IFLAG) -C INTEGER N,IFLAG -C REAL X(N),FVEC(N) -C ---------- -C Calculate the functions at X and -C return this vector in FVEC. -C ---------- -C RETURN -C END -C -C The value of IFLAG should not be changed by FCN unless the -C user wants to terminate execution of SNSQE. In this case, set -C IFLAG to a negative integer. -C -C JAC is the name of the user-supplied subroutine which calculates -C the Jacobian. If IOPT=1, then JAC must be declared in an -C EXTERNAL statement in the user calling program, and should be -C written as follows. -C -C SUBROUTINE JAC(N,X,FVEC,FJAC,LDFJAC,IFLAG) -C INTEGER N,LDFJAC,IFLAG -C REAL X(N),FVEC(N),FJAC(LDFJAC,N) -C ---------- -C Calculate the Jacobian at X and return this -C matrix in FJAC. FVEC contains the function -C values at X and should not be altered. -C ---------- -C RETURN -C END -C -C The value of IFLAG should not be changed by JAC unless the -C user wants to terminate execution of SNSQE. In this case, set -C IFLAG to a negative integer. -C -C If IOPT=2, JAC can be ignored (treat it as a dummy argument). -C -C IOPT is an input variable which specifies how the Jacobian will -C be calculated. If IOPT=1, then the user must supply the -C Jacobian through the subroutine JAC. If IOPT=2, then the -C code will approximate the Jacobian by forward-differencing. -C -C N is a positive integer input variable set to the number of -C functions and variables. -C -C X is an array of length N. On input, X must contain an initial -C estimate of the solution vector. On output, X contains the -C final estimate of the solution vector. -C -C FVEC is an output array of length N which contains the functions -C evaluated at the output X. -C -C TOL is a non-negative input variable. Termination occurs when -C the algorithm estimates that the relative error between X and -C the solution is at most TOL. Section 4 contains more details -C about TOL. -C -C NPRINT is an integer input variable that enables controlled -C printing of iterates if it is positive. In this case, FCN is -C called with IFLAG = 0 at the beginning of the first iteration -C and every NPRINT iteration thereafter and immediately prior -C to return, with X and FVEC available for printing. Appropriate -C print statements must be added to FCN (see example). If NPRINT -C is not positive, no special calls of FCN with IFLAG = 0 are -C made. -C -C INFO is an integer output variable. If the user has terminated -C execution, INFO is set to the (negative) value of IFLAG. See -C description of FCN and JAC. Otherwise, INFO is set as follows. -C -C INFO = 0 improper input parameters. -C -C INFO = 1 algorithm estimates that the relative error between -C X and the solution is at most TOL. -C -C INFO = 2 number of calls to FCN has reached or exceeded -C 100*(N+1) for IOPT=1 or 200*(N+1) for IOPT=2. -C -C INFO = 3 TOL is too small. No further improvement in the -C approximate solution X is possible. -C -C INFO = 4 iteration is not making good progress. -C -C Sections 4 and 5 contain more details about INFO. -C -C WA is a work array of length LWA. -C -C LWA is a positive integer input variable not less than -C (3*N**2+13*N))/2. -C -C -C 4. Successful Completion. -C -C The accuracy of SNSQE is controlled by the convergence parame- -C ter TOL. This parameter is used in a test which makes a compar- -C ison between the approximation X and a solution XSOL. SNSQE -C terminates when the test is satisfied. If TOL is less than the -C machine precision (as defined by the function R1MACH(4)), then -C SNSQE attempts only to satisfy the test defined by the machine -C precision. Further progress is not usually possible. Unless -C high precision solutions are required, the recommended value -C for TOL is the square root of the machine precision. -C -C The test assumes that the functions are reasonably well behaved, -C and, if the Jacobian is supplied by the user, that the functions -C and the Jacobian coded consistently. If these conditions -C are not satisfied, SNSQE may incorrectly indicate convergence. -C The coding of the Jacobian can be checked by the subroutine -C CHKDER. If the Jacobian is coded correctly or IOPT=2, then -C the validity of the answer can be checked, for example, by -C rerunning SNSQE with a tighter tolerance. -C -C Convergence Test. If ENORM(Z) denotes the Euclidean norm of a -C vector Z, then this test attempts to guarantee that -C -C ENORM(X-XSOL) .LE. TOL*ENORM(XSOL). -C -C If this condition is satisfied with TOL = 10**(-K), then the -C larger components of X have K significant decimal digits and -C INFO is set to 1. There is a danger that the smaller compo- -C nents of X may have large relative errors, but the fast rate -C of convergence of SNSQE usually avoids this possibility. -C -C -C 5. Unsuccessful Completion. -C -C Unsuccessful termination of SNSQE can be due to improper input -C parameters, arithmetic interrupts, an excessive number of func- -C tion evaluations, errors in the functions, or lack of good prog- -C ress. -C -C Improper Input Parameters. INFO is set to 0 if IOPT .LT. 1, or -C IOPT .GT. 2, or N .LE. 0, or TOL .LT. 0.E0, or -C LWA .LT. (3*N**2+13*N)/2. -C -C Arithmetic Interrupts. If these interrupts occur in the FCN -C subroutine during an early stage of the computation, they may -C be caused by an unacceptable choice of X by SNSQE. In this -C case, it may be possible to remedy the situation by not evalu- -C ating the functions here, but instead setting the components -C of FVEC to numbers that exceed those in the initial FVEC. -C -C Excessive Number of Function Evaluations. If the number of -C calls to FCN reaches 100*(N+1) for IOPT=1 or 200*(N+1) for -C IOPT=2, then this indicates that the routine is converging -C very slowly as measured by the progress of FVEC, and INFO is -C set to 2. This situation should be unusual because, as -C indicated below, lack of good progress is usually diagnosed -C earlier by SNSQE, causing termination with INFO = 4. -C -C Errors in the Functions. When IOPT=2, the choice of step length -C in the forward-difference approximation to the Jacobian -C assumes that the relative errors in the functions are of the -C order of the machine precision. If this is not the case, -C SNSQE may fail (usually with INFO = 4). The user should -C then either use SNSQ and set the step length or use IOPT=1 -C and supply the Jacobian. -C -C Lack of Good Progress. SNSQE searches for a zero of the system -C by minimizing the sum of the squares of the functions. In so -C doing, it can become trapped in a region where the minimum -C does not correspond to a zero of the system and, in this situ- -C ation, the iteration eventually fails to make good progress. -C In particular, this will happen if the system does not have a -C zero. If the system has a zero, rerunning SNSQE from a dif- -C ferent starting point may be helpful. -C -C -C 6. Characteristics of the Algorithm. -C -C SNSQE is a modification of the Powell hybrid method. Two of -C its main characteristics involve the choice of the correction as -C a convex combination of the Newton and scaled gradient direc- -C tions, and the updating of the Jacobian by the rank-1 method of -C Broyden. The choice of the correction guarantees (under reason- -C able conditions) global convergence for starting points far from -C the solution and a fast rate of convergence. The Jacobian is -C calculated at the starting point by either the user-supplied -C subroutine or a forward-difference approximation, but it is not -C recalculated until the rank-1 method fails to produce satis- -C factory progress. -C -C Timing. The time required by SNSQE to solve a given problem -C depends on N, the behavior of the functions, the accuracy -C requested, and the starting point. The number of arithmetic -C operations needed by SNSQE is about 11.5*(N**2) to process -C each evaluation of the functions (call to FCN) and 1.3*(N**3) -C to process each evaluation of the Jacobian (call to JAC, -C if IOPT = 1). Unless FCN and JAC can be evaluated quickly, -C the timing of SNSQE will be strongly influenced by the time -C spent in FCN and JAC. -C -C Storage. SNSQE requires (3*N**2 + 17*N)/2 single precision -C storage locations, in addition to the storage required by the -C program. There are no internally declared storage arrays. -C -C -C 7. Example. -C -C The problem is to determine the values of X(1), X(2), ..., X(9), -C which solve the system of tridiagonal equations -C -C (3-2*X(1))*X(1) -2*X(2) = -1 -C -X(I-1) + (3-2*X(I))*X(I) -2*X(I+1) = -1, I=2-8 -C -X(8) + (3-2*X(9))*X(9) = -1 -C -C ********** -C -C PROGRAM TEST -C C -C C Driver for SNSQE example. -C C -C INTEGER J,N,IOPT,NPRINT,INFO,LWA,NWRITE -C REAL TOL,FNORM -C REAL X(9),FVEC(9),WA(180) -C REAL ENORM,R1MACH -C EXTERNAL FCN -C DATA NWRITE /6/ -C C -C IOPT = 2 -C N = 9 -C C -C C The following starting values provide a rough solution. -C C -C DO 10 J = 1, 9 -C X(J) = -1.E0 -C 10 CONTINUE -C -C LWA = 180 -C NPRINT = 0 -C C -C C Set TOL to the square root of the machine precision. -C C Unless high precision solutions are required, -C C this is the recommended setting. -C C -C TOL = SQRT(R1MACH(4)) -C C -C CALL SNSQE(FCN,JAC,IOPT,N,X,FVEC,TOL,NPRINT,INFO,WA,LWA) -C FNORM = ENORM(N,FVEC) -C WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) -C STOP -C 1000 FORMAT (5X,' FINAL L2 NORM OF THE RESIDUALS',E15.7 // -C * 5X,' EXIT PARAMETER',16X,I10 // -C * 5X,' FINAL APPROXIMATE SOLUTION' // (5X,3E15.7)) -C END -C SUBROUTINE FCN(N,X,FVEC,IFLAG) -C INTEGER N,IFLAG -C REAL X(N),FVEC(N) -C INTEGER K -C REAL ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO -C DATA ZERO,ONE,TWO,THREE /0.E0,1.E0,2.E0,3.E0/ -C C -C DO 10 K = 1, N -C TEMP = (THREE - TWO*X(K))*X(K) -C TEMP1 = ZERO -C IF (K .NE. 1) TEMP1 = X(K-1) -C TEMP2 = ZERO -C IF (K .NE. N) TEMP2 = X(K+1) -C FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE -C 10 CONTINUE -C RETURN -C END -C -C Results obtained with different compilers or machines -C may be slightly different. -C -C FINAL L2 NORM OF THE RESIDUALS 0.1192636E-07 -C -C EXIT PARAMETER 1 -C -C FINAL APPROXIMATE SOLUTION -C -C -0.5706545E+00 -0.6816283E+00 -0.7017325E+00 -C -0.7042129E+00 -0.7013690E+00 -0.6918656E+00 -C -0.6657920E+00 -0.5960342E+00 -0.4164121E+00 -C -C***REFERENCES M. J. D. Powell, A hybrid method for nonlinear equa- -C tions. In Numerical Methods for Nonlinear Algebraic -C Equations, P. Rabinowitz, Editor. Gordon and Breach, -C 1988. -C***ROUTINES CALLED SNSQ, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800301 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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SNSQE - INTEGER IOPT,N,NPRINT,INFO,LWA - REAL TOL - REAL X(*),FVEC(*),WA(LWA) - EXTERNAL FCN, JAC - INTEGER INDEX,J,LR,MAXFEV,ML,MODE,MU,NFEV,NJEV - REAL EPSFCN,FACTOR,ONE,XTOL,ZERO - SAVE FACTOR, ONE, ZERO - DATA FACTOR,ONE,ZERO /1.0E2,1.0E0,0.0E0/ -C***FIRST EXECUTABLE STATEMENT SNSQE - INFO = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C - IF (IOPT .LT. 1 .OR. IOPT .GT. 2 .OR. N .LE. 0 - 1 .OR. TOL .LT. ZERO .OR. LWA .LT. (3*N**2 +13*N)/2) - 2 GO TO 20 -C -C CALL SNSQ. -C - MAXFEV = 100*(N + 1) - IF (IOPT .EQ. 2) MAXFEV = 2*MAXFEV - XTOL = TOL - ML = N - 1 - MU = N - 1 - EPSFCN = ZERO - MODE = 2 - DO 10 J = 1, N - WA(J) = ONE - 10 CONTINUE - LR = (N*(N + 1))/2 - INDEX=6*N+LR - CALL SNSQ(FCN,JAC,IOPT,N,X,FVEC,WA(INDEX+1),N,XTOL,MAXFEV,ML,MU, - 1 EPSFCN,WA(1),MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, - 2 WA(6*N+1),LR,WA(N+1),WA(2*N+1),WA(3*N+1),WA(4*N+1), - 3 WA(5*N+1)) - IF (INFO .EQ. 5) INFO = 4 - 20 CONTINUE - IF (INFO .EQ. 0) CALL XERMSG ('SLATEC', 'SNSQE', - + 'INVALID INPUT PARAMETER.', 2, 1) - RETURN -C -C LAST CARD OF SUBROUTINE SNSQE. -C - END diff --git a/slatec/sods.f b/slatec/sods.f deleted file mode 100644 index 272f79c..0000000 --- a/slatec/sods.f +++ /dev/null @@ -1,117 +0,0 @@ -*DECK SODS - SUBROUTINE SODS (A, X, B, NEQ, NUK, NRDA, IFLAG, WORK, IWORK) -C***BEGIN PROLOGUE SODS -C***SUBSIDIARY -C***PURPOSE Subsidiary to BVSUP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (SODS-S) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C SODS solves the overdetermined system of linear equations A X = B, -C where A is NEQ by NUK and NEQ .GE. NUK. If rank A = NUK, -C X is the UNIQUE least squares solution vector. That is, -C R(1)**2 + ..... + R(NEQ)**2 = minimum -C where R is the residual vector R = B - A X. -C If rank A .LT. NUK , the least squares solution of minimal -C length can be provided. -C SODS is an interfacing routine which calls subroutine LSSODS -C for the solution. LSSODS in turn calls subroutine ORTHOL and -C possibly subroutine OHTROR for the decomposition of A by -C orthogonal transformations. In the process, ORTHOL calls upon -C subroutine CSCALE for scaling. -C -C ********************************************************************** -C Input -C ********************************************************************** -C -C A -- Contains the matrix of NEQ equations in NUK unknowns and must -C be dimensioned NRDA by NUK. The original A is destroyed -C X -- Solution array of length at least NUK -C B -- Given constant vector of length NEQ, B is destroyed -C NEQ -- Number of equations, NEQ greater or equal to 1 -C NUK -- Number of columns in the matrix (which is also the number -C of unknowns), NUK not larger than NEQ -C NRDA -- Row dimension of A, NRDA greater or equal to NEQ -C IFLAG -- Status indicator -C =0 For the first call (and for each new problem defined by -C a new matrix A) when the matrix data is treated as exact -C =-K For the first call (and for each new problem defined by -C a new matrix A) when the matrix data is assumed to be -C accurate to about K digits -C =1 For subsequent calls whenever the matrix A has already -C been decomposed (problems with new vectors B but -C same matrix a can be handled efficiently) -C WORK(*),IWORK(*) -- Arrays for storage of internal information, -C WORK must be dimensioned at least 2 + 5*NUK -C IWORK must be dimensioned at least NUK+2 -C IWORK(2) -- Scaling indicator -C =-1 If the matrix A is to be pre-scaled by -C columns when appropriate -C If the scaling indicator is not equal to -1 -C no scaling will be attempted -C For most problems scaling will probably not be necessary -C -C ********************************************************************** -C OUTPUT -C ********************************************************************** -C -C IFLAG -- Status indicator -C =1 If solution was obtained -C =2 If improper input is detected -C =3 If rank of matrix is less than NUK -C If the minimal length least squares solution is -C desired, simply reset IFLAG=1 and call the code again -C X -- Least squares solution of A X = B -C A -- Contains the strictly upper triangular part of the reduced -C matrix and the transformation information -C WORK(*),IWORK(*) -- Contains information needed on subsequent -C Calls (IFLAG=1 case on input) which must not -C be altered -C WORK(1) contains the Euclidean norm of -C the residual vector -C WORK(2) contains the Euclidean norm of -C the solution vector -C IWORK(1) contains the numerically determined -C rank of the matrix A -C -C ********************************************************************** -C -C***SEE ALSO BVSUP -C***REFERENCES G. Golub, Numerical methods for solving linear least -C squares problems, Numerische Mathematik 7, (1965), -C pp. 206-216. -C P. Businger and G. Golub, Linear least squares -C solutions by Householder transformations, Numerische -C Mathematik 7, (1965), pp. 269-276. -C H. A. Watts, Solving linear least squares problems -C using SODS/SUDS/CODS, Sandia Report SAND77-0683, -C Sandia Laboratories, 1977. -C***ROUTINES CALLED LSSODS -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 910408 Updated the AUTHOR and REFERENCES sections. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SODS - DIMENSION A(NRDA,*),X(*),B(*),WORK(*),IWORK(*) -C -C***FIRST EXECUTABLE STATEMENT SODS - ITER=0 - IS=2 - IP=3 - KS=2 - KD=3 - KZ=KD+NUK - KV=KZ+NUK - KT=KV+NUK - KC=KT+NUK -C - CALL LSSODS(A,X,B,NEQ,NUK,NRDA,IFLAG,IWORK(1),IWORK(IS),A, - 1 WORK(KD),IWORK(IP),ITER,WORK(1),WORK(KS), - 2 WORK(KZ),B,WORK(KV),WORK(KT),WORK(KC)) -C - RETURN - END diff --git a/slatec/somn.f b/slatec/somn.f deleted file mode 100644 index 8745303..0000000 --- a/slatec/somn.f +++ /dev/null @@ -1,362 +0,0 @@ -*DECK SOMN - SUBROUTINE SOMN (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, - + NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, AP, - + EMAP, DZ, CSAV, RWORK, IWORK) -C***BEGIN PROLOGUE SOMN -C***PURPOSE Preconditioned Orthomin Sparse Iterative Ax=b Solver. -C Routine to solve a general linear system Ax = b using -C the Preconditioned Orthomin method. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (SOMN-S, DOMN-D) -C***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, -C ORTHOMIN, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NSAVE, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) -C REAL B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N) -C REAL P(N,0:NSAVE), AP(N,0:NSAVE), EMAP(N,0:NSAVE) -C REAL DZ(N), CSAV(NSAVE), RWORK(USER DEFINED) -C EXTERNAL MATVEC, MSOLVE -C -C CALL SOMN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, -C $ NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, -C $ Z, P, AP, EMAP, DZ, CSAV, RWORK, IWORK) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Real B(N). -C Right-hand side vector. -C X :INOUT Real X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Real A(NELT). -C These arrays contain the matrix data structure for A. -C It could take any form. See "Description", below, for more -C details. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C MATVEC :EXT External. -C Name of a routine which performs the matrix vector multiply -C Y = A*X given A and X. The name of the MATVEC routine must -C be declared external in the calling program. The calling -C sequence to MATVEC is: -C CALL MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) -C Where N is the number of unknowns, Y is the product A*X -C upon return X is an input vector, NELT is the number of -C non-zeros in the SLAP IA, JA, A storage for the matrix A. -C ISYM is a flag which, if non-zero, denotest that A is -C symmetric and only the lower or upper triangle is stored. -C MSOLVE :EXT External. -C Name of a routine which solves a linear system MZ = R for -C Z given R with the preconditioning matrix M (M is supplied via -C RWORK and IWORK arrays). The name of the MSOLVE routine must -C be declared external in the calling program. The calling -C sequence to MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C Where N is the number of unknowns, R is the right-hand side -C vector and Z is the solution upon return. NELT, IA, JA, A and -C ISYM are defined as above. RWORK is a real array that can -C be used to pass necessary preconditioning information and/or -C workspace to MSOLVE. IWORK is an integer work array for -C the same purpose as RWORK. -C NSAVE :IN Integer. -C Number of direction vectors to save and orthogonalize -C against. NSAVE >= 0. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /SSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Real. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Real. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*R1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Breakdown of method detected. -C (p,Ap) < epsilon**2. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C R :WORK Real R(N). -C Z :WORK Real Z(N). -C P :WORK Real P(N,0:NSAVE). -C AP :WORK Real AP(N,0:NSAVE). -C EMAP :WORK Real EMAP(N,0:NSAVE). -C DZ :WORK Real DZ(N). -C CSAV :WORK Real CSAV(NSAVE) -C Real arrays used for workspace. -C RWORK :WORK Real RWORK(USER DEFINED). -C Real array that can be used for workspace in MSOLVE. -C IWORK :WORK Integer IWORK(USER DEFINED). -C Integer array that can be used for workspace in MSOLVE. -C -C *Description -C This routine does not care what matrix data structure is -C used for A and M. It simply calls the MATVEC and MSOLVE -C routines, with the arguments as described above. The user -C could write any type of structure and the appropriate MATVEC -C and MSOLVE routines. It is assumed that A is stored in the -C IA, JA, A arrays in some fashion and that M (or INV(M)) is -C stored in IWORK and RWORK) in some fashion. The SLAP -C routines SSDOMN and SSLUOM are examples of this procedure. -C -C Two examples of matrix data structures are the: 1) SLAP -C Triad format and 2) SLAP Column format. -C -C =================== S L A P Triad format =================== -C In this format only the non-zeros are stored. They may -C appear in *ANY* order. The user supplies three arrays of -C length NELT, where NELT is the number of non-zeros in the -C matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero -C the user puts the row and column index of that matrix -C element in the IA and JA arrays. The value of the non-zero -C matrix element is placed in the corresponding location of -C the A array. This is an extremely easy data structure to -C generate. On the other hand it is not too efficient on -C vector computers for the iterative solution of linear -C systems. Hence, SLAP changes this input data structure to -C the SLAP Column format for the iteration (but does not -C change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C In this format the non-zeros are stored counting down -C columns (except for the diagonal entry, which must appear -C first in each "column") and are stored in the real array A. -C In other words, for each column in the matrix put the -C diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have JA(N+1) -C = NELT+1, where N is the number of columns in the matrix and -C NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO SSDOMN, SSLUOM, ISSOMN -C***REFERENCES 1. Mark K. Seager, A SLAP for the Masses, in -C G. F. Carey, Ed., Parallel Supercomputing: Methods, -C Algorithms and Applications, Wiley, 1989, pp.135-155. -C***ROUTINES CALLED ISSOMN, R1MACH, SAXPY, SCOPY, SDOT -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 891004 Added new reference. -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MATVEC and MSOLVE from ROUTINES CALLED list. (FNF) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of reference. (FNF) -C 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) -C 921113 Corrected C***CATEGORY line. (FNF) -C 930326 Removed unused variable. (FNF) -C***END PROLOGUE SOMN -C .. Scalar Arguments .. - REAL ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT, NSAVE -C .. Array Arguments .. - REAL A(NELT), AP(N,0:NSAVE), B(N), CSAV(NSAVE), DZ(N), - + EMAP(N,0:NSAVE), P(N,0:NSAVE), R(N), RWORK(*), X(N), Z(N) - INTEGER IA(NELT), IWORK(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MATVEC, MSOLVE -C .. Local Scalars .. - REAL AK, AKDEN, AKNUM, BKL, BNRM, FUZZ, SOLNRM - INTEGER I, IP, IPO, K, L, LMAX -C .. External Functions .. - REAL R1MACH, SDOT - INTEGER ISSOMN - EXTERNAL R1MACH, SDOT, ISSOMN -C .. External Subroutines .. - EXTERNAL SAXPY, SCOPY -C .. Intrinsic Functions .. - INTRINSIC ABS, MIN, MOD -C***FIRST EXECUTABLE STATEMENT SOMN -C -C Check some of the input data. -C - ITER = 0 - IERR = 0 - IF( N.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF - FUZZ = R1MACH(3) - IF( TOL.LT.500*FUZZ ) THEN - TOL = 500*FUZZ - IERR = 4 - ENDIF - FUZZ = FUZZ*FUZZ -C -C Calculate initial residual and pseudo-residual, and check -C stopping criterion. - CALL MATVEC(N, X, R, NELT, IA, JA, A, ISYM) - DO 10 I = 1, N - R(I) = B(I) - R(I) - 10 CONTINUE - CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C - IF( ISSOMN(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, NSAVE, - $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, - $ R, Z, P, AP, EMAP, DZ, CSAV, - $ RWORK, IWORK, AK, BNRM, SOLNRM) .NE. 0 ) GO TO 200 - IF( IERR.NE.0 ) RETURN -C -C -C ***** iteration loop ***** -C -CVD$R NOVECTOR -CVD$R NOCONCUR - DO 100 K = 1, ITMAX - ITER = K - IP = MOD( ITER-1, NSAVE+1 ) -C -C calculate direction vector p, a*p, and (m-inv)*a*p, -C and save if desired. - CALL SCOPY(N, Z, 1, P(1,IP), 1) - CALL MATVEC(N, P(1,IP), AP(1,IP), NELT, IA, JA, A, ISYM) - CALL MSOLVE(N, AP(1,IP), EMAP(1,IP), NELT, IA, JA, A, ISYM, - $ RWORK, IWORK) - IF( NSAVE.EQ.0 ) THEN - AKDEN = SDOT(N, EMAP, 1, EMAP, 1) - ELSE - IF( ITER.GT.1 ) THEN - LMAX = MIN( NSAVE, ITER-1 ) - DO 20 L = 1, LMAX - IPO = MOD(IP+(NSAVE+1-L),NSAVE+1) - BKL = SDOT(N, EMAP(1,IP), 1, EMAP(1,IPO), 1) - BKL = BKL*CSAV(L) - CALL SAXPY(N, -BKL, P(1,IPO), 1, P(1,IP), 1) - CALL SAXPY(N, -BKL, AP(1,IPO), 1, AP(1,IP), 1) - CALL SAXPY(N, -BKL, EMAP(1,IPO), 1, EMAP(1,IP), 1) - 20 CONTINUE - IF( NSAVE.GT.1 ) THEN - DO 30 L = NSAVE-1, 1, -1 - CSAV(L+1) = CSAV(L) - 30 CONTINUE - ENDIF - ENDIF - AKDEN = SDOT(N, EMAP(1,IP), 1, EMAP(1,IP), 1) - IF( ABS(AKDEN).LT.FUZZ ) THEN - IERR = 6 - RETURN - ENDIF - CSAV(1) = 1.0E0/AKDEN -C -C calculate coefficient ak, new iterate x, new residual r, and -C new pseudo-residual z. - ENDIF - AKNUM = SDOT(N, Z, 1, EMAP(1,IP), 1) - AK = AKNUM/AKDEN - CALL SAXPY(N, AK, P(1,IP), 1, X, 1) - CALL SAXPY(N, -AK, AP(1,IP), 1, R, 1) - CALL SAXPY(N, -AK, EMAP(1,IP), 1, Z, 1) -C -C check stopping criterion. - IF( ISSOMN(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, NSAVE, - $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, - $ R, Z, P, AP, EMAP, DZ, CSAV, - $ RWORK, IWORK, AK, BNRM, SOLNRM) .NE. 0 ) GO TO 200 -C - 100 CONTINUE -C -C ***** end of loop ***** -C -C Stopping criterion not satisfied. - ITER = ITMAX + 1 - IERR = 2 -C - 200 RETURN -C------------- LAST LINE OF SOMN FOLLOWS ---------------------------- - END diff --git a/slatec/sopenm.f b/slatec/sopenm.f deleted file mode 100644 index 0ac02ab..0000000 --- a/slatec/sopenm.f +++ /dev/null @@ -1,37 +0,0 @@ -*DECK SOPENM - SUBROUTINE SOPENM (IPAGE, LPAGE) -C***BEGIN PROLOGUE SOPENM -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE ALL (SOPENM-A) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C 1. OPEN UNIT NUMBER IPAGEF AS A RANDOM ACCESS FILE. -C -C 2. THE RECORD LENGTH IS CONSTANT=LPG. -C -C***SEE ALSO SPLP -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890605 Corrected references to XERRWV. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C***END PROLOGUE SOPENM - CHARACTER*8 XERN1 -C -C***FIRST EXECUTABLE STATEMENT SOPENM - IPAGEF=IPAGE - LPG =LPAGE - OPEN(UNIT=IPAGEF,IOSTAT=IOS,ERR=100,STATUS='UNKNOWN', - *ACCESS='DIRECT',FORM='UNFORMATTED',RECL=LPG) - RETURN -C - 100 WRITE (XERN1, '(I8)') IOS - CALL XERMSG ('SLATEC', 'SOPENM', - * 'IN SPLP, OPEN HAS ERROR FLAG = ' // XERN1, 100, 1) - RETURN - END diff --git a/slatec/sorth.f b/slatec/sorth.f deleted file mode 100644 index 9f63a61..0000000 --- a/slatec/sorth.f +++ /dev/null @@ -1,125 +0,0 @@ -*DECK SORTH - SUBROUTINE SORTH (VNEW, V, HES, N, LL, LDHES, KMP, SNORMW) -C***BEGIN PROLOGUE SORTH -C***SUBSIDIARY -C***PURPOSE Internal routine for SGMRES. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (SORTH-S, DORTH-D) -C***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov -C Hindmarsh, Alan, (LLNL), alanh@llnl.gov -C Seager, Mark K., (LLNL), seager@llnl.gov -C Lawrence Livermore National Laboratory -C PO Box 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C***DESCRIPTION -C This routine orthogonalizes the vector VNEW against the -C previous KMP vectors in the V array. It uses a modified -C Gram-Schmidt orthogonalization procedure with conditional -C reorthogonalization. -C -C *Usage: -C INTEGER N, LL, LDHES, KMP -C REAL VNEW(N), V(N,LL), HES(LDHES,LL), SNORMW -C -C CALL SORTH(VNEW, V, HES, N, LL, LDHES, KMP, SNORMW) -C -C *Arguments: -C VNEW :INOUT Real VNEW(N) -C On input, the vector of length N containing a scaled -C product of the Jacobian and the vector V(*,LL). -C On output, the new vector orthogonal to V(*,i0) to V(*,LL), -C where i0 = max(1, LL-KMP+1). -C V :IN Real V(N,LL) -C The N x LL array containing the previous LL -C orthogonal vectors V(*,1) to V(*,LL). -C HES :INOUT Real HES(LDHES,LL) -C On input, an LL x LL upper Hessenberg matrix containing, -C in HES(I,K), K.lt.LL, the scaled inner products of -C A*V(*,K) and V(*,i). -C On return, column LL of HES is filled in with -C the scaled inner products of A*V(*,LL) and V(*,i). -C N :IN Integer -C The order of the matrix A, and the length of VNEW. -C LL :IN Integer -C The current order of the matrix HES. -C LDHES :IN Integer -C The leading dimension of the HES array. -C KMP :IN Integer -C The number of previous vectors the new vector VNEW -C must be made orthogonal to (KMP .le. MAXL). -C SNORMW :OUT REAL -C Scalar containing the l-2 norm of VNEW. -C -C***SEE ALSO SGMRES -C***ROUTINES CALLED SAXPY, SDOT, SNRM2 -C***REVISION HISTORY (YYMMDD) -C 871001 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910506 Made subsidiary to SGMRES. (FNF) -C 920511 Added complete declaration section. (WRB) -C***END PROLOGUE SORTH -C The following is for optimized compilation on LLNL/LTSS Crays. -CLLL. OPTIMIZE -C .. Scalar Arguments .. - REAL SNORMW - INTEGER KMP, LDHES, LL, N -C .. Array Arguments .. - REAL HES(LDHES,*), V(N,*), VNEW(*) -C .. Local Scalars .. - REAL ARG, SUMDSQ, TEM, VNRM - INTEGER I, I0 -C .. External Functions .. - REAL SDOT, SNRM2 - EXTERNAL SDOT, SNRM2 -C .. External Subroutines .. - EXTERNAL SAXPY -C .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -C***FIRST EXECUTABLE STATEMENT SORTH -C -C Get norm of unaltered VNEW for later use. -C - VNRM = SNRM2(N, VNEW, 1) -C ------------------------------------------------------------------- -C Perform the modified Gram-Schmidt procedure 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 = MAX(1,LL-KMP+1) - DO 10 I = I0,LL - HES(I,LL) = SDOT(N, V(1,I), 1, VNEW, 1) - TEM = -HES(I,LL) - CALL SAXPY(N, TEM, V(1,I), 1, VNEW, 1) - 10 CONTINUE -C ------------------------------------------------------------------- -C Compute SNORMW = norm of VNEW. If VNEW is small compared -C to its input value (in norm), then reorthogonalize VNEW to -C V(*,1) through V(*,LL). Correct if relative correction -C exceeds 1000*(unit roundoff). Finally, correct SNORMW using -C the dot products involved. -C ------------------------------------------------------------------- - SNORMW = SNRM2(N, VNEW, 1) - IF (VNRM + 0.001E0*SNORMW .NE. VNRM) RETURN - SUMDSQ = 0 - DO 30 I = I0,LL - TEM = -SDOT(N, V(1,I), 1, VNEW, 1) - IF (HES(I,LL) + 0.001E0*TEM .EQ. HES(I,LL)) GO TO 30 - HES(I,LL) = HES(I,LL) - TEM - CALL SAXPY(N, TEM, V(1,I), 1, VNEW, 1) - SUMDSQ = SUMDSQ + TEM**2 - 30 CONTINUE - IF (SUMDSQ .EQ. 0.0E0) RETURN - ARG = MAX(0.0E0,SNORMW**2 - SUMDSQ) - SNORMW = SQRT(ARG) -C - RETURN -C------------- LAST LINE OF SORTH FOLLOWS ---------------------------- - END diff --git a/slatec/sos.f b/slatec/sos.f deleted file mode 100644 index 07451ec..0000000 --- a/slatec/sos.f +++ /dev/null @@ -1,270 +0,0 @@ -*DECK SOS - SUBROUTINE SOS (FNC, NEQ, X, RTOLX, ATOLX, TOLF, IFLAG, RW, LRW, - + IW, LIW) -C***BEGIN PROLOGUE SOS -C***PURPOSE Solve a square system of nonlinear equations. -C***LIBRARY SLATEC -C***CATEGORY F2A -C***TYPE SINGLE PRECISION (SOS-S, DSOS-D) -C***KEYWORDS BROWN'S METHOD, NEWTON'S METHOD, NONLINEAR EQUATIONS, -C ROOTS, SOLUTIONS -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C SOS solves a system of NEQ simultaneous nonlinear equations in -C NEQ unknowns. That is, it solves the problem F(X)=0 -C where X is a vector with components X(1),...,X(NEQ) and F -C is a vector of nonlinear functions. Each equation is of the form -C -C F (X(1),...,X(NEQ))=0 for K=1,...,NEQ. -C K -C -C The algorithm is based on an iterative method which is a -C variation of Newton's method using Gaussian elimination -C in a manner similar to the Gauss-Seidel process. Convergence -C is roughly quadratic. All partial derivatives required by -C the algorithm are approximated by first difference quotients. -C The convergence behavior of this code is affected by the -C ordering of the equations, and it is advantageous to place linear -C and mildly nonlinear equations first in the ordering. -C -C Actually, SOS is merely an interfacing routine for -C calling subroutine SOSEQS which embodies the solution -C algorithm. The purpose of this is to add greater -C flexibility and ease of use for the prospective user. -C -C SOSEQS calls the accompanying routine SOSSOL, which solves special -C triangular linear systems by back-substitution. -C -C The user must supply a function subprogram which evaluates the -C K-th equation only (K specified by SOSEQS) for each call -C to the subprogram. -C -C SOS represents an implementation of the mathematical algorithm -C described in the references below. It is a modification of the -C code SOSNLE written by H. A. Watts in 1973. -C -C ********************************************************************** -C -Input- -C -C FNC -Name of the function program which evaluates the equations. -C This name must be in an EXTERNAL statement in the calling -C program. The user must supply FNC in the form FNC(X,K), -C where X is the solution vector (which must be dimensioned -C in FNC) and FNC returns the value of the K-th function. -C -C NEQ -Number of equations to be solved. -C -C X -Solution vector. Initial guesses must be supplied. -C -C RTOLX -Relative error tolerance used in the convergence criteria. -C Each solution component X(I) is checked by an accuracy test -C of the form ABS(X(I)-XOLD(I)) .LE. RTOLX*ABS(X(I))+ATOLX, -C where XOLD(I) represents the previous iteration value. -C RTOLX must be non-negative. -C -C ATOLX -Absolute error tolerance used in the convergence criteria. -C ATOLX must be non-negative. If the user suspects some -C solution component may be zero, he should set ATOLX to an -C appropriate (depends on the scale of the remaining variables) -C positive value for better efficiency. -C -C TOLF -Residual error tolerance used in the convergence criteria. -C Convergence will be indicated if all residuals (values of the -C functions or equations) are not bigger than TOLF in -C magnitude. Note that extreme care must be given in assigning -C an appropriate value for TOLF because this convergence test -C is dependent on the scaling of the equations. An -C inappropriate value can cause premature termination of the -C iteration process. -C -C IFLAG -Optional input indicator. You must set IFLAG=-1 if you -C want to use any of the optional input items listed below. -C Otherwise set it to zero. -C -C RW -A REAL work array which is split apart by SOS and used -C internally by SOSEQS. -C -C LRW -Dimension of the RW array. LRW must be at least -C 1 + 6*NEQ + NEQ*(NEQ+1)/2 -C -C IW -An INTEGER work array which is split apart by SOS and used -C internally by SOSEQS. -C -C LIW -Dimension of the IW array. LIW must be at least 3 + NEQ. -C -C -Optional Input- -C -C IW(1) -Internal printing parameter. You must set IW(1)=-1 if -C you want the intermediate solution iterates to be printed. -C -C IW(2) -Iteration limit. The maximum number of allowable -C iterations can be specified, if desired. To override the -C default value of 50, set IW(2) to the number wanted. -C -C Remember, if you tell the code that you are using one of the -C options (by setting IFLAG=-1), you must supply values -C for both IW(1) and IW(2). -C -C ********************************************************************** -C -Output- -C -C X -Solution vector. -C -C IFLAG -Status indicator -C -C *** Convergence to a Solution *** -C -C 1 Means satisfactory convergence to a solution was achieved. -C Each solution component X(I) satisfies the error tolerance -C test ABS(X(I)-XOLD(I)) .LE. RTOLX*ABS(X(I))+ATOLX. -C -C 2 Means procedure converged to a solution such that all -C residuals are at most TOLF in magnitude, -C ABS(FNC(X,I)) .LE. TOLF. -C -C 3 Means that conditions for both IFLAG=1 and IFLAG=2 hold. -C -C 4 Means possible numerical convergence. Behavior indicates -C limiting precision calculations as a result of user asking -C for too much accuracy or else convergence is very slow. -C Residual norms and solution increment norms have -C remained roughly constant over several consecutive -C iterations. -C -C *** Task Interrupted *** -C -C 5 Means the allowable number of iterations has been met -C without obtaining a solution to the specified accuracy. -C Very slow convergence may be indicated. Examine the -C approximate solution returned and see if the error -C tolerances seem appropriate. -C -C 6 Means the allowable number of iterations has been met and -C the iterative process does not appear to be converging. -C A local minimum may have been encountered or there may be -C limiting precision difficulties. -C -C 7 Means that the iterative scheme appears to be diverging. -C Residual norms and solution increment norms have -C increased over several consecutive iterations. -C -C *** Task Cannot Be Continued *** -C -C 8 Means that a Jacobian-related matrix was singular. -C -C 9 Means improper input parameters. -C -C *** IFLAG should be examined after each call to *** -C *** SOS with the appropriate action being taken. *** -C -C -C RW(1) -Contains a norm of the residual. -C -C IW(3) -Contains the number of iterations used by the process. -C -C ********************************************************************** -C***REFERENCES K. M. Brown, Solution of simultaneous nonlinear -C equations, Algorithm 316, Communications of the -C A.C.M. 10, (1967), pp. 728-729. -C K. M. Brown, A quadratically convergent Newton-like -C method based upon Gaussian elimination, SIAM Journal -C on Numerical Analysis 6, (1969), pp. 560-569. -C***ROUTINES CALLED SOSEQS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 801001 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 900510 Convert XERRWV calls to XERMSG calls, changed Prologue -C comments to agree with DSOS. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SOS - DIMENSION X(*), RW(*), IW(*) - CHARACTER*8 XERN1 - CHARACTER*16 XERN3, XERN4 - EXTERNAL FNC -C***FIRST EXECUTABLE STATEMENT SOS - INPFLG = IFLAG -C -C CHECK FOR VALID INPUT -C - IF (NEQ .LE. 0) THEN - WRITE (XERN1, '(I8)') NEQ - CALL XERMSG ('SLATEC', 'SOS', 'THE NUMBER OF EQUATIONS ' // - * 'MUST BE A POSITIVE INTEGER. YOU HAVE CALLED THE ' // - * 'CODE WITH NEQ = ' // XERN1, 1, 1) - IFLAG = 9 - ENDIF -C - IF (RTOLX .LT. 0.0D0 .OR. ATOLX .LT. 0.0D0) THEN - WRITE (XERN3, '(1PE15.6)') ATOLX - WRITE (XERN4, '(1PE15.6)') RTOLX - CALL XERMSG ('SLATEC', 'SOS', 'THE ERROR TOLERANCES FOR ' // - * 'THE SOLUTION ITERATES CANNOT BE NEGATIVE. YOU HAVE ' // - * 'CALLED THE CODE WITH RTOLX = ' // XERN3 // - * ' AND ATOLX = ' // XERN4,2, 1) - IFLAG = 9 - ENDIF -C - IF (TOLF .LT. 0.0D0) THEN - WRITE (XERN3, '(1PE15.6)') TOLF - CALL XERMSG ('SLATEC', 'SOS', 'THE RESIDUAL ERROR ' // - * 'TOLERANCE MUST BE NON-NEGATIVE. YOU HAVE CALLED THE ' // - * 'CODE WITH TOLF = ' // XERN3, 3, 1) - IFLAG = 9 - ENDIF -C - IPRINT = 0 - MXIT = 50 - IF (INPFLG .EQ. (-1)) THEN - IF (IW(1) .EQ. (-1)) IPRINT = -1 - MXIT = IW(2) - IF (MXIT .LE. 0) THEN - WRITE (XERN1, '(I8)') MXIT - CALL XERMSG ('SLATEC', 'SOS', 'YOU HAVE TOLD THE CODE ' // - * 'TO USE OPTIONAL IN PUT ITEMS BY SETTING IFLAG=-1. ' // - * 'HOWEVER YOU HAVE CALLED THE CODE WITH THE MAXIMUM ' // - * 'ALLOWABLE NUMBER OF ITERATIONS SET TO IW(2) = ' // - * XERN1, 4, 1) - IFLAG = 9 - ENDIF - ENDIF -C - NC = (NEQ*(NEQ+1))/2 - IF (LRW .LT. 1 + 6*NEQ + NC) THEN - WRITE (XERN1, '(I8)') LRW - CALL XERMSG ('SLATEC', 'SOS', 'DIMENSION OF THE RW ARRAY ' // - * 'MUST BE AT LEAST 1 + 6*NEQ + NEQ*(NEQ+1)/2 . YOU HAVE ' // - * 'CALLED THE CODE WITH LRW = ' // XERN1, 5, 1) - IFLAG = 9 - ENDIF -C - IF (LIW .LT. 3 + NEQ) THEN - WRITE (XERN1, '(I8)') LIW - CALL XERMSG ('SLATEC', 'SOS', 'DIMENSION OF THE IW ARRAY ' // - * 'MUST BE AT LEAST 3 + NEQ. YOU HAVE CALLED THE CODE ' // - * 'WITH LIW = ' // XERN1, 6, 1) - IFLAG = 9 - ENDIF -C - IF (IFLAG .NE. 9) THEN - NCJS = 6 - NSRRC = 4 - NSRI = 5 -C - K1 = NC + 2 - K2 = K1 + NEQ - K3 = K2 + NEQ - K4 = K3 + NEQ - K5 = K4 + NEQ - K6 = K5 + NEQ -C - CALL SOSEQS(FNC, NEQ, X, RTOLX, ATOLX, TOLF, IFLAG, MXIT, NCJS, - 1 NSRRC, NSRI, IPRINT, RW(1), RW(2), NC, RW(K1), - 2 RW(K2), RW(K3), RW(K4), RW(K5), RW(K6), IW(4)) -C - IW(3) = MXIT - ENDIF - RETURN - END diff --git a/slatec/soseqs.f b/slatec/soseqs.f deleted file mode 100644 index 828a17c..0000000 --- a/slatec/soseqs.f +++ /dev/null @@ -1,412 +0,0 @@ -*DECK SOSEQS - SUBROUTINE SOSEQS (FNC, N, S, RTOLX, ATOLX, TOLF, IFLAG, MXIT, - + NCJS, NSRRC, NSRI, IPRINT, FMAX, C, NC, B, P, TEMP, X, Y, FAC, - + IS) -C***BEGIN PROLOGUE SOSEQS -C***SUBSIDIARY -C***PURPOSE Subsidiary to SOS -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (SOSEQS-S, DSOSEQ-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C SOSEQS solves a system of N simultaneous nonlinear equations. -C See the comments in the interfacing routine SOS for a more -C detailed description of some of the items in the calling list. -C -C ******************************************************************** -C -C -INPUT- -C FNC -Function subprogram which evaluates the equations -C N -Number of equations -C S -Solution vector of initial guesses -C RTOLX-Relative error tolerance on solution components -C ATOLX-Absolute error tolerance on solution components -C TOLF-Residual error tolerance -C MXIT-Maximum number of allowable iterations. -C NCJS-Maximum number of consecutive iterative steps to perform -C using the same triangular Jacobian matrix approximation. -C NSRRC-Number of consecutive iterative steps for which the -C limiting precision accuracy test must be satisfied -C before the routine exits with IFLAG=4. -C NSRI-Number of consecutive iterative steps for which the -C diverging condition test must be satisfied before -C the routine exits with IFLAG=7. -C IPRINT-Internal printing parameter. You must set IPRINT=-1 if you -C want the intermediate solution iterates and a residual norm -C to be printed. -C C -Internal work array, dimensioned at least N*(N+1)/2. -C NC -Dimension of C array. NC .GE. N*(N+1)/2. -C B -Internal work array, dimensioned N. -C P -Internal work array, dimensioned N. -C TEMP-Internal work array, dimensioned N. -C X -Internal work array, dimensioned N. -C Y -Internal work array, dimensioned N. -C FAC -Internal work array, dimensioned N. -C IS -Internal work array, dimensioned N. -C -C -OUTPUT- -C S -Solution vector -C IFLAG-Status indicator flag -C MXIT-The actual number of iterations performed -C FMAX-Residual norm -C C -Upper unit triangular matrix which approximates the -C forward triangularization of the full Jacobian matrix. -C stored in a vector with dimension at least N*(N+1)/2. -C B -Contains the residuals (function values) divided -C by the corresponding components of the P vector -C P -Array used to store the partial derivatives. After -C each iteration P(K) contains the maximal derivative -C occurring in the K-th reduced equation. -C TEMP-Array used to store the previous solution iterate. -C X -Solution vector. Contains the values achieved on the -C last iteration loop upon exit from SOS. -C Y -Array containing the solution increments. -C FAC -Array containing factors used in computing numerical -C derivatives. -C IS -Records the pivotal information (column interchanges) -C -C ********************************************************************** -C *** Three machine dependent parameters appear in this subroutine. -C -C *** The smallest positive magnitude, zero, is defined by the function -C *** routine R1MACH(1). -C -C *** URO, The computer unit roundoff value, is defined by R1MACH(3) for -C *** machines that round or R1MACH(4) for machines that truncate. -C *** URO is the smallest positive number such that 1.+URO .GT. 1. -C -C *** The output tape unit number, LOUN, is defined by the function -C *** I1MACH(2). -C ********************************************************************** -C -C***SEE ALSO SOS -C***ROUTINES CALLED I1MACH, R1MACH, SOSSOL -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE SOSEQS -C -C - DIMENSION S(*), C(NC), B(*), IS(*), P(*), TEMP(*), X(*), Y(*), - 1 FAC(*) -C -C***FIRST EXECUTABLE STATEMENT SOSEQS - URO = R1MACH(4) - LOUN = I1MACH(2) - ZERO = R1MACH(1) - RE = MAX(RTOLX,URO) - SRURO = SQRT(URO) -C - IFLAG = 0 - NP1 = N + 1 - ICR = 0 - IC = 0 - ITRY = NCJS - YN1 = 0. - YN2 = 0. - YN3 = 0. - YNS = 0. - MIT = 0 - FN1 = 0. - FN2 = 0. - FMXS = 0. -C -C INITIALIZE THE INTERCHANGE (PIVOTING) VECTOR AND -C SAVE THE CURRENT SOLUTION APPROXIMATION FOR FUTURE USE. -C - DO 10 K=1,N - IS(K) = K - X(K) = S(K) - TEMP(K) = X(K) - 10 CONTINUE -C -C -C ***************************************** -C **** BEGIN PRINCIPAL ITERATION LOOP **** -C ***************************************** -C - DO 330 M=1,MXIT -C - DO 20 K=1,N - FAC(K) = SRURO - 20 CONTINUE -C - 30 KN = 1 - FMAX = 0. -C -C -C ******** BEGIN SUBITERATION LOOP DEFINING THE LINEARIZATION OF EACH -C ******** EQUATION WHICH RESULTS IN THE CONSTRUCTION OF AN UPPER -C ******** TRIANGULAR MATRIX APPROXIMATING THE FORWARD -C ******** TRIANGULARIZATION OF THE FULL JACOBIAN MATRIX -C - DO 170 K=1,N - KM1 = K - 1 -C -C BACK-SOLVE A TRIANGULAR LINEAR SYSTEM OBTAINING -C IMPROVED SOLUTION VALUES FOR K-1 OF THE VARIABLES -C FROM THE FIRST K-1 EQUATIONS. THESE VARIABLES ARE THEN -C ELIMINATED FROM THE K-TH EQUATION. -C - IF (KM1 .EQ. 0) GO TO 50 - CALL SOSSOL(K, N, KM1, Y, C, B, KN) - DO 40 J=1,KM1 - JS = IS(J) - X(JS) = TEMP(JS) + Y(J) - 40 CONTINUE -C -C -C EVALUATE THE K-TH EQUATION AND THE INTERMEDIATE COMPUTATION -C FOR THE MAX NORM OF THE RESIDUAL VECTOR. -C - 50 F = FNC(X,K) - FMAX = MAX(FMAX,ABS(F)) -C -C IF WE WISH TO PERFORM SEVERAL ITERATIONS USING A FIXED -C FACTORIZATION OF AN APPROXIMATE JACOBIAN,WE NEED ONLY -C UPDATE THE CONSTANT VECTOR. -C - IF (ITRY .LT. NCJS) GO TO 160 -C -C - IT = 0 -C -C COMPUTE PARTIAL DERIVATIVES THAT ARE REQUIRED IN THE LINEARIZATION -C OF THE K-TH REDUCED EQUATION -C - DO 90 J=K,N - ITEM = IS(J) - HX = X(ITEM) - H = FAC(ITEM)*HX - IF (ABS(H) .LE. ZERO) H = FAC(ITEM) - X(ITEM) = HX + H - IF (KM1 .EQ. 0) GO TO 70 - Y(J) = H - CALL SOSSOL(K, N, J, Y, C, B, KN) - DO 60 L=1,KM1 - LS = IS(L) - X(LS) = TEMP(LS) + Y(L) - 60 CONTINUE - 70 FP = FNC(X,K) - X(ITEM) = HX - FDIF = FP - F - IF (ABS(FDIF) .GT. URO*ABS(F)) GO TO 80 - FDIF = 0. - IT = IT + 1 - 80 P(J) = FDIF/H - 90 CONTINUE -C - IF (IT .LE. (N-K)) GO TO 110 -C -C ALL COMPUTED PARTIAL DERIVATIVES OF THE K-TH EQUATION -C ARE EFFECTIVELY ZERO.TRY LARGER PERTURBATIONS OF THE -C INDEPENDENT VARIABLES. -C - DO 100 J=K,N - ISJ = IS(J) - FACT = 100.*FAC(ISJ) - IF (FACT .GT. 1.E+10) GO TO 340 - FAC(ISJ) = FACT - 100 CONTINUE - GO TO 30 -C - 110 IF (K .EQ. N) GO TO 160 -C -C ACHIEVE A PIVOTING EFFECT BY CHOOSING THE MAXIMAL DERIVATIVE -C ELEMENT -C - PMAX = 0. - DO 120 J=K,N - TEST = ABS(P(J)) - IF (TEST .LE. PMAX) GO TO 120 - PMAX = TEST - ISV = J - 120 CONTINUE - IF (PMAX .EQ. 0.) GO TO 340 -C -C SET UP THE COEFFICIENTS FOR THE K-TH ROW OF THE TRIANGULAR -C LINEAR SYSTEM AND SAVE THE PARTIAL DERIVATIVE OF -C LARGEST MAGNITUDE -C - PMAX = P(ISV) - KK = KN - DO 140 J=K,N - IF (J .EQ. ISV) GO TO 130 - C(KK) = -P(J)/PMAX - 130 KK = KK + 1 - 140 CONTINUE - P(K) = PMAX -C -C - IF (ISV .EQ. K) GO TO 160 -C -C INTERCHANGE THE TWO COLUMNS OF C DETERMINED BY THE -C PIVOTAL STRATEGY -C - KSV = IS(K) - IS(K) = IS(ISV) - IS(ISV) = KSV -C - KD = ISV - K - KJ = K - DO 150 J=1,K - CSV = C(KJ) - JK = KJ + KD - C(KJ) = C(JK) - C(JK) = CSV - KJ = KJ + N - J - 150 CONTINUE -C - 160 KN = KN + NP1 - K -C -C STORE THE COMPONENTS FOR THE CONSTANT VECTOR -C - B(K) = -F/P(K) -C - 170 CONTINUE -C -C ******** -C ******** END OF LOOP CREATING THE TRIANGULAR LINEARIZATION MATRIX -C ******** -C -C -C SOLVE THE RESULTING TRIANGULAR SYSTEM FOR A NEW SOLUTION -C APPROXIMATION AND OBTAIN THE SOLUTION INCREMENT NORM. -C - KN = KN - 1 - Y(N) = B(N) - IF (N .GT. 1) CALL SOSSOL(N, N, N, Y, C, B, KN) - XNORM = 0. - YNORM = 0. - DO 180 J=1,N - YJ = Y(J) - YNORM = MAX(YNORM,ABS(YJ)) - JS = IS(J) - X(JS) = TEMP(JS) + YJ - XNORM = MAX(XNORM,ABS(X(JS))) - 180 CONTINUE -C -C -C PRINT INTERMEDIATE SOLUTION ITERATES AND RESIDUAL NORM IF DESIRED -C - IF (IPRINT.NE.(-1)) GO TO 190 - MM = M - 1 - WRITE (LOUN,1234) FMAX, MM, (X(J),J=1,N) - 1234 FORMAT ('0RESIDUAL NORM =', E9.2, /1X, 'SOLUTION ITERATE', - 1 ' (', I3, ')', /(1X, 5E26.14)) - 190 CONTINUE -C -C TEST FOR CONVERGENCE TO A SOLUTION (RELATIVE AND/OR ABSOLUTE ERROR -C COMPARISON ON SUCCESSIVE APPROXIMATIONS OF EACH SOLUTION VARIABLE) -C - DO 200 J=1,N - JS = IS(J) - IF (ABS(Y(J)) .GT. RE*ABS(X(JS))+ATOLX) GO TO 210 - 200 CONTINUE - IF (FMAX .LE. FMXS) IFLAG = 1 -C -C TEST FOR CONVERGENCE TO A SOLUTION BASED ON RESIDUALS -C - 210 IF (FMAX .GT. TOLF) GO TO 220 - IFLAG = IFLAG + 2 - 220 IF (IFLAG .GT. 0) GO TO 360 -C -C - IF (M .GT. 1) GO TO 230 - FMIN = FMAX - GO TO 280 -C -C SAVE SOLUTION HAVING MINIMUM RESIDUAL NORM. -C - 230 IF (FMAX .GE. FMIN) GO TO 250 - MIT = M + 1 - YN1 = YNORM - YN2 = YNS - FN1 = FMXS - FMIN = FMAX - DO 240 J=1,N - S(J) = X(J) - 240 CONTINUE - IC = 0 -C -C TEST FOR LIMITING PRECISION CONVERGENCE. VERY SLOWLY CONVERGENT -C PROBLEMS MAY ALSO BE DETECTED. -C - 250 IF (YNORM .GT. SRURO*XNORM) GO TO 260 - IF ((FMAX .LT. 0.2*FMXS) .OR. (FMAX .GT. 5.*FMXS)) GO TO 260 - IF ((YNORM .LT. 0.2*YNS) .OR. (YNORM .GT. 5.*YNS)) GO TO 260 - ICR = ICR + 1 - IF (ICR .LT. NSRRC) GO TO 270 - IFLAG = 4 - FMAX = FMIN - GO TO 380 - 260 ICR = 0 -C -C TEST FOR DIVERGENCE OF THE ITERATIVE SCHEME. -C - IF ((YNORM .LE. 2.*YNS) .AND. (FMAX .LE. 2.*FMXS)) GO TO 270 - IC = IC + 1 - IF (IC .LT. NSRI) GO TO 280 - IFLAG = 7 - GO TO 360 - 270 IC = 0 -C -C CHECK TO SEE IF NEXT ITERATION CAN USE THE OLD JACOBIAN -C FACTORIZATION -C - 280 ITRY = ITRY - 1 - IF (ITRY .EQ. 0) GO TO 290 - IF (20.*YNORM .GT. XNORM) GO TO 290 - IF (YNORM .GT. 2.*YNS) GO TO 290 - IF (FMAX .LT. 2.*FMXS) GO TO 300 - 290 ITRY = NCJS -C -C SAVE THE CURRENT SOLUTION APPROXIMATION AND THE RESIDUAL AND -C SOLUTION INCREMENT NORMS FOR USE IN THE NEXT ITERATION. -C - 300 DO 310 J=1,N - TEMP(J) = X(J) - 310 CONTINUE - IF (M.NE.MIT) GO TO 320 - FN2 = FMAX - YN3 = YNORM - 320 FMXS = FMAX - YNS = YNORM -C -C - 330 CONTINUE -C -C ***************************************** -C **** END OF PRINCIPAL ITERATION LOOP **** -C ***************************************** -C -C -C TOO MANY ITERATIONS, CONVERGENCE WAS NOT ACHIEVED. - M = MXIT - IFLAG = 5 - IF (YN1 .GT. 10.0*YN2 .OR. YN3 .GT. 10.0*YN1) IFLAG = 6 - IF (FN1 .GT. 5.0*FMIN .OR. FN2 .GT. 5.0*FMIN) IFLAG = 6 - IF (FMAX .GT. 5.0*FMIN) IFLAG = 6 - GO TO 360 -C -C -C A JACOBIAN-RELATED MATRIX IS EFFECTIVELY SINGULAR. - 340 IFLAG = 8 - DO 350 J=1,N - S(J) = TEMP(J) - 350 CONTINUE - GO TO 380 -C -C - 360 DO 370 J=1,N - S(J) = X(J) - 370 CONTINUE -C -C - 380 MXIT = M - RETURN - END diff --git a/slatec/sossol.f b/slatec/sossol.f deleted file mode 100644 index 145fd71..0000000 --- a/slatec/sossol.f +++ /dev/null @@ -1,64 +0,0 @@ -*DECK SOSSOL - SUBROUTINE SOSSOL (K, N, L, X, C, B, M) -C***BEGIN PROLOGUE SOSSOL -C***SUBSIDIARY -C***PURPOSE Subsidiary to SOS -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (SOSSOL-S, DSOSSL-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C SOSSOL solves an upper triangular type of linear system by back -C substitution. -C -C The matrix C is upper trapezoidal and stored as a linear array by -C rows. The equations have been normalized so that the diagonal -C entries of C are understood to be unity. The off diagonal entries -C and the elements of the constant right hand side vector B have -C already been stored as the negatives of the corresponding equation -C values. -C with each call to SOSSOL a (K-1) by (K-1) triangular system is -C resolved. For L greater than K, column L of C is included in the -C right hand side vector. -C -C***SEE ALSO SOS -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE SOSSOL -C -C - DIMENSION X(*), C(*), B(*) -C -C***FIRST EXECUTABLE STATEMENT SOSSOL - NP1 = N + 1 - KM1 = K - 1 - LK = KM1 - IF (L .EQ. K) LK = K - KN = M -C -C - DO 40 KJ=1,KM1 - KMM1 = K - KJ - KM = KMM1 + 1 - XMAX = 0. - KN = KN - NP1 + KMM1 - IF (KM .GT. LK) GO TO 20 - JKM = KN -C - DO 10 J=KM,LK - JKM = JKM + 1 - XMAX = XMAX + C(JKM)*X(J) - 10 CONTINUE -C - 20 IF (L .LE. K) GO TO 30 - JKM = KN + L - KMM1 - XMAX = XMAX + C(JKM)*X(L) - 30 X(KMM1) = XMAX + B(KMM1) - 40 CONTINUE -C - RETURN - END diff --git a/slatec/spbco.f b/slatec/spbco.f deleted file mode 100644 index 3c9ab6a..0000000 --- a/slatec/spbco.f +++ /dev/null @@ -1,262 +0,0 @@ -*DECK SPBCO - SUBROUTINE SPBCO (ABD, LDA, N, M, RCOND, Z, INFO) -C***BEGIN PROLOGUE SPBCO -C***PURPOSE Factor a real symmetric positive definite matrix stored in -C band form and estimate the condition number of the matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B2 -C***TYPE SINGLE PRECISION (SPBCO-S, DPBCO-D, CPBCO-C) -C***KEYWORDS BANDED, CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, -C MATRIX FACTORIZATION, POSITIVE DEFINITE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C SPBCO factors a real symmetric positive definite matrix -C stored in band form and estimates the condition of the matrix. -C -C If RCOND is not needed, SPBFA is slightly faster. -C To solve A*X = B , follow SPBCO by SPBSL. -C To compute INVERSE(A)*C , follow SPBCO by SPBSL. -C To compute DETERMINANT(A) , follow SPBCO by SPBDI. -C -C On Entry -C -C ABD REAL(LDA, N) -C the matrix to be factored. The columns of the upper -C triangle are stored in the columns of ABD and the -C diagonals of the upper triangle are stored in the -C rows of ABD . See the comments below for details. -C -C LDA INTEGER -C the leading dimension of the array ABD . -C LDA must be .GE. M + 1 . -C -C N INTEGER -C the order of the matrix A . -C -C M INTEGER -C the number of diagonals above the main diagonal. -C 0 .LE. M .LT. N . -C -C On Return -C -C ABD an upper triangular matrix R , stored in band -C form, so that A = TRANS(R)*R . -C If INFO .NE. 0 , the factorization is not complete. -C -C RCOND REAL -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. If INFO .NE. 0 , RCOND is unchanged. -C -C Z REAL(N) -C a work vector whose contents are usually unimportant. -C If A is singular to working precision, then Z is -C an approximate null vector in the sense that -C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . -C If INFO .NE. 0 , Z is unchanged. -C -C INFO INTEGER -C = 0 for normal return. -C = K signals an error condition. The leading minor -C of order K is not positive definite. -C -C Band Storage -C -C If A is a symmetric positive definite band matrix, -C the following program segment will set up the input. -C -C M = (band width above diagonal) -C DO 20 J = 1, N -C I1 = MAX(1, J-M) -C DO 10 I = I1, J -C K = I-J+M+1 -C ABD(K,J) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C This uses M + 1 rows of A , except for the M by M -C upper left triangle, which is ignored. -C -C Example: If the original matrix is -C -C 11 12 13 0 0 0 -C 12 22 23 24 0 0 -C 13 23 33 34 35 0 -C 0 24 34 44 45 46 -C 0 0 35 45 55 56 -C 0 0 0 46 56 66 -C -C then N = 6 , M = 2 and ABD should contain -C -C * * 13 24 35 46 -C * 12 23 34 45 56 -C 11 22 33 44 55 66 -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SASUM, SAXPY, SDOT, SPBFA, SSCAL -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SPBCO - INTEGER LDA,N,M,INFO - REAL ABD(LDA,*),Z(*) - REAL RCOND -C - REAL SDOT,EK,T,WK,WKM - REAL ANORM,S,SASUM,SM,YNORM - INTEGER I,J,J2,K,KB,KP1,L,LA,LB,LM,MU -C -C FIND NORM OF A -C -C***FIRST EXECUTABLE STATEMENT SPBCO - DO 30 J = 1, N - L = MIN(J,M+1) - MU = MAX(M+2-J,1) - Z(J) = SASUM(L,ABD(MU,J),1) - K = J - L - IF (M .LT. MU) GO TO 20 - DO 10 I = MU, M - K = K + 1 - Z(K) = Z(K) + ABS(ABD(I,J)) - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - ANORM = 0.0E0 - DO 40 J = 1, N - ANORM = MAX(ANORM,Z(J)) - 40 CONTINUE -C -C FACTOR -C - CALL SPBFA(ABD,LDA,N,M,INFO) - IF (INFO .NE. 0) GO TO 180 -C -C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . -C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . -C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL -C GROWTH IN THE ELEMENTS OF W WHERE TRANS(R)*W = E . -C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. -C -C SOLVE TRANS(R)*W = E -C - EK = 1.0E0 - DO 50 J = 1, N - Z(J) = 0.0E0 - 50 CONTINUE - DO 110 K = 1, N - IF (Z(K) .NE. 0.0E0) EK = SIGN(EK,-Z(K)) - IF (ABS(EK-Z(K)) .LE. ABD(M+1,K)) GO TO 60 - S = ABD(M+1,K)/ABS(EK-Z(K)) - CALL SSCAL(N,S,Z,1) - EK = S*EK - 60 CONTINUE - WK = EK - Z(K) - WKM = -EK - Z(K) - S = ABS(WK) - SM = ABS(WKM) - WK = WK/ABD(M+1,K) - WKM = WKM/ABD(M+1,K) - KP1 = K + 1 - J2 = MIN(K+M,N) - I = M + 1 - IF (KP1 .GT. J2) GO TO 100 - DO 70 J = KP1, J2 - I = I - 1 - SM = SM + ABS(Z(J)+WKM*ABD(I,J)) - Z(J) = Z(J) + WK*ABD(I,J) - S = S + ABS(Z(J)) - 70 CONTINUE - IF (S .GE. SM) GO TO 90 - T = WKM - WK - WK = WKM - I = M + 1 - DO 80 J = KP1, J2 - I = I - 1 - Z(J) = Z(J) + T*ABD(I,J) - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - Z(K) = WK - 110 CONTINUE - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) -C -C SOLVE R*Y = W -C - DO 130 KB = 1, N - K = N + 1 - KB - IF (ABS(Z(K)) .LE. ABD(M+1,K)) GO TO 120 - S = ABD(M+1,K)/ABS(Z(K)) - CALL SSCAL(N,S,Z,1) - 120 CONTINUE - Z(K) = Z(K)/ABD(M+1,K) - LM = MIN(K-1,M) - LA = M + 1 - LM - LB = K - LM - T = -Z(K) - CALL SAXPY(LM,T,ABD(LA,K),1,Z(LB),1) - 130 CONTINUE - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) -C - YNORM = 1.0E0 -C -C SOLVE TRANS(R)*V = Y -C - DO 150 K = 1, N - LM = MIN(K-1,M) - LA = M + 1 - LM - LB = K - LM - Z(K) = Z(K) - SDOT(LM,ABD(LA,K),1,Z(LB),1) - IF (ABS(Z(K)) .LE. ABD(M+1,K)) GO TO 140 - S = ABD(M+1,K)/ABS(Z(K)) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM - 140 CONTINUE - Z(K) = Z(K)/ABD(M+1,K) - 150 CONTINUE - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE R*Z = W -C - DO 170 KB = 1, N - K = N + 1 - KB - IF (ABS(Z(K)) .LE. ABD(M+1,K)) GO TO 160 - S = ABD(M+1,K)/ABS(Z(K)) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM - 160 CONTINUE - Z(K) = Z(K)/ABD(M+1,K) - LM = MIN(K-1,M) - LA = M + 1 - LM - LB = K - LM - T = -Z(K) - CALL SAXPY(LM,T,ABD(LA,K),1,Z(LB),1) - 170 CONTINUE -C MAKE ZNORM = 1.0 - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM -C - IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM - IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0 - 180 CONTINUE - RETURN - END diff --git a/slatec/spbdi.f b/slatec/spbdi.f deleted file mode 100644 index b9ceb7f..0000000 --- a/slatec/spbdi.f +++ /dev/null @@ -1,82 +0,0 @@ -*DECK SPBDI - SUBROUTINE SPBDI (ABD, LDA, N, M, DET) -C***BEGIN PROLOGUE SPBDI -C***PURPOSE Compute the determinant of a symmetric positive definite -C band matrix using the factors computed by SPBCO or SPBFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D3B2 -C***TYPE SINGLE PRECISION (SPBDI-S, DPBDI-D, CPBDI-C) -C***KEYWORDS BANDED, DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, -C MATRIX, POSITIVE DEFINITE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C SPBDI computes the determinant -C of a real symmetric positive definite band matrix -C using the factors computed by SPBCO or SPBFA. -C If the inverse is needed, use SPBSL N times. -C -C On Entry -C -C ABD REAL(LDA, N) -C the output from SPBCO or SPBFA. -C -C LDA INTEGER -C the leading dimension of the array ABD . -C -C N INTEGER -C the order of the matrix A . -C -C M INTEGER -C the number of diagonals above the main diagonal. -C -C On Return -C -C DET REAL(2) -C determinant of original matrix in the form -C Determinant = DET(1) * 10.0**DET(2) -C with 1.0 .LE. DET(1) .LT. 10.0 -C or DET(1) .EQ. 0.0 . -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SPBDI - INTEGER LDA,N,M - REAL ABD(LDA,*) - REAL DET(2) -C - REAL S - INTEGER I -C***FIRST EXECUTABLE STATEMENT SPBDI -C -C COMPUTE DETERMINANT -C - DET(1) = 1.0E0 - DET(2) = 0.0E0 - S = 10.0E0 - DO 50 I = 1, N - DET(1) = ABD(M+1,I)**2*DET(1) - IF (DET(1) .EQ. 0.0E0) GO TO 60 - 10 IF (DET(1) .GE. 1.0E0) GO TO 20 - DET(1) = S*DET(1) - DET(2) = DET(2) - 1.0E0 - GO TO 10 - 20 CONTINUE - 30 IF (DET(1) .LT. S) GO TO 40 - DET(1) = DET(1)/S - DET(2) = DET(2) + 1.0E0 - GO TO 30 - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE - RETURN - END diff --git a/slatec/spbfa.f b/slatec/spbfa.f deleted file mode 100644 index c9a1324..0000000 --- a/slatec/spbfa.f +++ /dev/null @@ -1,106 +0,0 @@ -*DECK SPBFA - SUBROUTINE SPBFA (ABD, LDA, N, M, INFO) -C***BEGIN PROLOGUE SPBFA -C***PURPOSE Factor a real symmetric positive definite matrix stored in -C band form. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B2 -C***TYPE SINGLE PRECISION (SPBFA-S, DPBFA-D, CPBFA-C) -C***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, -C POSITIVE DEFINITE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C SPBFA factors a real symmetric positive definite matrix -C stored in band form. -C -C SPBFA is usually called by SPBCO, but it can be called -C directly with a saving in time if RCOND is not needed. -C -C On Entry -C -C ABD REAL(LDA, N) -C the matrix to be factored. The columns of the upper -C triangle are stored in the columns of ABD and the -C diagonals of the upper triangle are stored in the -C rows of ABD . See the comments below for details. -C -C LDA INTEGER -C the leading dimension of the array ABD . -C LDA must be .GE. M + 1 . -C -C N INTEGER -C the order of the matrix A . -C -C M INTEGER -C the number of diagonals above the main diagonal. -C 0 .LE. M .LT. N . -C -C On Return -C -C ABD an upper triangular matrix R , stored in band -C form, so that A = TRANS(R)*R . -C -C INFO INTEGER -C = 0 for normal return. -C = K if the leading minor of order K is not -C positive definite. -C -C Band Storage -C -C If A is a symmetric positive definite band matrix, -C the following program segment will set up the input. -C -C M = (band width above diagonal) -C DO 20 J = 1, N -C I1 = MAX(1, J-M) -C DO 10 I = I1, J -C K = I-J+M+1 -C ABD(K,J) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SDOT -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SPBFA - INTEGER LDA,N,M,INFO - REAL ABD(LDA,*) -C - REAL SDOT,T - REAL S - INTEGER IK,J,JK,K,MU -C***FIRST EXECUTABLE STATEMENT SPBFA - DO 30 J = 1, N - INFO = J - S = 0.0E0 - IK = M + 1 - JK = MAX(J-M,1) - MU = MAX(M+2-J,1) - IF (M .LT. MU) GO TO 20 - DO 10 K = MU, M - T = ABD(K,J) - SDOT(K-MU,ABD(IK,JK),1,ABD(MU,J),1) - T = T/ABD(M+1,JK) - ABD(K,J) = T - S = S + T*T - IK = IK - 1 - JK = JK + 1 - 10 CONTINUE - 20 CONTINUE - S = ABD(M+1,J) - S - IF (S .LE. 0.0E0) GO TO 40 - ABD(M+1,J) = SQRT(S) - 30 CONTINUE - INFO = 0 - 40 CONTINUE - RETURN - END diff --git a/slatec/spbsl.f b/slatec/spbsl.f deleted file mode 100644 index 894f8aa..0000000 --- a/slatec/spbsl.f +++ /dev/null @@ -1,97 +0,0 @@ -*DECK SPBSL - SUBROUTINE SPBSL (ABD, LDA, N, M, B) -C***BEGIN PROLOGUE SPBSL -C***PURPOSE Solve a real symmetric positive definite band system -C using the factors computed by SPBCO or SPBFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B2 -C***TYPE SINGLE PRECISION (SPBSL-S, DPBSL-D, CPBSL-C) -C***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX, -C POSITIVE DEFINITE, SOLVE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C SPBSL solves the real symmetric positive definite band -C system A*X = B -C using the factors computed by SPBCO or SPBFA. -C -C On Entry -C -C ABD REAL(LDA, N) -C the output from SPBCO or SPBFA. -C -C LDA INTEGER -C the leading dimension of the array ABD . -C -C N INTEGER -C the order of the matrix A . -C -C M INTEGER -C the number of diagonals above the main diagonal. -C -C B REAL(N) -C the right hand side vector. -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 -C a zero on the diagonal. Technically, this indicates -C singularity, but it is usually caused by improper subroutine -C arguments. It will not occur if the subroutines are called -C correctly and INFO .EQ. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL SPBCO(ABD,LDA,N,RCOND,Z,INFO) -C IF (RCOND is too small .OR. INFO .NE. 0) GO TO ... -C DO 10 J = 1, P -C CALL SPBSL(ABD,LDA,N,C(1,J)) -C 10 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SAXPY, SDOT -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SPBSL - INTEGER LDA,N,M - REAL ABD(LDA,*),B(*) -C - REAL SDOT,T - INTEGER K,KB,LA,LB,LM -C -C SOLVE TRANS(R)*Y = B -C -C***FIRST EXECUTABLE STATEMENT SPBSL - DO 10 K = 1, N - LM = MIN(K-1,M) - LA = M + 1 - LM - LB = K - LM - T = SDOT(LM,ABD(LA,K),1,B(LB),1) - B(K) = (B(K) - T)/ABD(M+1,K) - 10 CONTINUE -C -C SOLVE R*X = Y -C - DO 20 KB = 1, N - K = N + 1 - KB - LM = MIN(K-1,M) - LA = M + 1 - LM - LB = K - LM - B(K) = B(K)/ABD(M+1,K) - T = -B(K) - CALL SAXPY(LM,T,ABD(LA,K),1,B(LB),1) - 20 CONTINUE - RETURN - END diff --git a/slatec/speli4.f b/slatec/speli4.f deleted file mode 100644 index 6700744..0000000 --- a/slatec/speli4.f +++ /dev/null @@ -1,330 +0,0 @@ -*DECK SPELI4 - SUBROUTINE SPELI4 (IORDER, A, B, M, MBDCND, BDA, ALPHA, BDB, BETA, - + C, D, N, NBDCND, BDC, BDD, COFX, AN, BN, CN, DN, UN, ZN, AM, - + BM, CM, DM, UM, ZM, GRHS, USOL, IDMN, W, PERTRB, IERROR) -C***BEGIN PROLOGUE SPELI4 -C***SUBSIDIARY -C***PURPOSE Subsidiary to SEPX4 -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (SPELI4-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C SPELI4 sets up vectors and arrays for input to BLKTRI -C and computes a second order solution in USOL. A return jump to -C SEPX4 occurs if IORDER=2. If IORDER=4 a fourth order -C solution is generated in USOL. -C -C***SEE ALSO SEPX4 -C***ROUTINES CALLED CHKSN4, DEFE4, GENBUN, MINSO4, ORTHO4, TRIS4 -C***COMMON BLOCKS SPL4 -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891009 Removed unreferenced variable. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE SPELI4 -C - DIMENSION BDA(*) ,BDB(*) ,BDC(*) ,BDD(*) , - 1 W(*) - DIMENSION GRHS(IDMN,*) ,USOL(IDMN,*) - DIMENSION AN(*) ,BN(*) ,CN(*) ,DN(*) , - 1 UN(*) ,ZN(*) - DIMENSION AM(*) ,BM(*) ,CM(*) ,DM(*) , - 1 UM(*) ,ZM(*) - COMMON /SPL4/ KSWX ,KSWY ,K ,L , - 1 AIT ,BIT ,CIT ,DIT , - 2 MIT ,NIT ,IS ,MS , - 3 JS ,NS ,DLX ,DLY , - 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 - LOGICAL SINGLR - EXTERNAL COFX -C***FIRST EXECUTABLE STATEMENT SPELI4 - KSWX = MBDCND+1 - KSWY = NBDCND+1 - K = M+1 - L = N+1 - AIT = A - BIT = B - CIT = C - DIT = D - DLY=(DIT-CIT)/N -C -C SET RIGHT HAND SIDE VALUES FROM GRHS IN USOL ON THE INTERIOR -C AND NON-SPECIFIED BOUNDARIES. -C - DO 20 I=2,M - DO 10 J=2,N - USOL(I,J)=DLY**2*GRHS(I,J) - 10 CONTINUE - 20 CONTINUE - IF (KSWX.EQ.2 .OR. KSWX.EQ.3) GO TO 40 - DO 30 J=2,N - USOL(1,J)=DLY**2*GRHS(1,J) - 30 CONTINUE - 40 CONTINUE - IF (KSWX.EQ.2 .OR. KSWX.EQ.5) GO TO 60 - DO 50 J=2,N - USOL(K,J)=DLY**2*GRHS(K,J) - 50 CONTINUE - 60 CONTINUE - IF (KSWY.EQ.2 .OR. KSWY.EQ.3) GO TO 80 - DO 70 I=2,M - USOL(I,1)=DLY**2*GRHS(I,1) - 70 CONTINUE - 80 CONTINUE - IF (KSWY.EQ.2 .OR. KSWY.EQ.5) GO TO 100 - DO 90 I=2,M - USOL(I,L)=DLY**2*GRHS(I,L) - 90 CONTINUE - 100 CONTINUE - IF (KSWX.NE.2 .AND. KSWX.NE.3 .AND. KSWY.NE.2 .AND. KSWY.NE.3) - 1USOL(1,1)=DLY**2*GRHS(1,1) - IF (KSWX.NE.2 .AND. KSWX.NE.5 .AND. KSWY.NE.2 .AND. KSWY.NE.3) - 1USOL(K,1)=DLY**2*GRHS(K,1) - IF (KSWX.NE.2 .AND. KSWX.NE.3 .AND. KSWY.NE.2 .AND. KSWY.NE.5) - 1USOL(1,L)=DLY**2*GRHS(1,L) - IF (KSWX.NE.2 .AND. KSWX.NE.5 .AND. KSWY.NE.2 .AND. KSWY.NE.5) - 1USOL(K,L)=DLY**2*GRHS(K,L) -C -C SET SWITCHES FOR PERIODIC OR NON-PERIODIC BOUNDARIES -C - MP=1 - IF(KSWX.EQ.1) MP=0 - NP=NBDCND -C -C SET DLX,DLY AND SIZE OF BLOCK TRI-DIAGONAL SYSTEM GENERATED -C IN NINT,MINT -C - DLX = (BIT-AIT)/M - MIT = K-1 - IF (KSWX .EQ. 2) MIT = K-2 - IF (KSWX .EQ. 4) MIT = K - DLY = (DIT-CIT)/N - NIT = L-1 - IF (KSWY .EQ. 2) NIT = L-2 - IF (KSWY .EQ. 4) NIT = L - TDLX3 = 2.0*DLX**3 - DLX4 = DLX**4 - TDLY3 = 2.0*DLY**3 - DLY4 = DLY**4 -C -C SET SUBSCRIPT LIMITS FOR PORTION OF ARRAY TO INPUT TO BLKTRI -C - IS = 1 - JS = 1 - IF (KSWX.EQ.2 .OR. KSWX.EQ.3) IS = 2 - IF (KSWY.EQ.2 .OR. KSWY.EQ.3) JS = 2 - NS = NIT+JS-1 - MS = MIT+IS-1 -C -C SET X - DIRECTION -C - DO 110 I=1,MIT - XI = AIT+(IS+I-2)*DLX - CALL COFX (XI,AI,BI,CI) - AXI = (AI/DLX-0.5*BI)/DLX - BXI = -2.*AI/DLX**2+CI - CXI = (AI/DLX+0.5*BI)/DLX - AM(I)=DLY**2*AXI - BM(I)=DLY**2*BXI - CM(I)=DLY**2*CXI - 110 CONTINUE -C -C SET Y DIRECTION -C - DO 120 J=1,NIT - DYJ=1.0 - EYJ=-2.0 - FYJ=1.0 - AN(J) = DYJ - BN(J) = EYJ - CN(J) = FYJ - 120 CONTINUE -C -C ADJUST EDGES IN X DIRECTION UNLESS PERIODIC -C - AX1 = AM(1) - CXM = CM(MIT) - GO TO (170,130,150,160,140),KSWX -C -C DIRICHLET-DIRICHLET IN X DIRECTION -C - 130 AM(1) = 0.0 - CM(MIT) = 0.0 - GO TO 170 -C -C MIXED-DIRICHLET IN X DIRECTION -C - 140 AM(1) = 0.0 - BM(1) = BM(1)+2.*ALPHA*DLX*AX1 - CM(1) = CM(1)+AX1 - CM(MIT) = 0.0 - GO TO 170 -C -C DIRICHLET-MIXED IN X DIRECTION -C - 150 AM(1) = 0.0 - AM(MIT) = AM(MIT)+CXM - BM(MIT) = BM(MIT)-2.*BETA*DLX*CXM - CM(MIT) = 0.0 - GO TO 170 -C -C MIXED - MIXED IN X DIRECTION -C - 160 CONTINUE - AM(1) = 0.0 - BM(1) = BM(1)+2.*DLX*ALPHA*AX1 - CM(1) = CM(1)+AX1 - AM(MIT) = AM(MIT)+CXM - BM(MIT) = BM(MIT)-2.*DLX*BETA*CXM - CM(MIT) = 0.0 - 170 CONTINUE -C -C ADJUST IN Y DIRECTION UNLESS PERIODIC -C - DY1 = AN(1) - FYN = CN(NIT) - GAMA=0.0 - XNU=0.0 - GO TO (220,180,200,210,190),KSWY -C -C DIRICHLET-DIRICHLET IN Y DIRECTION -C - 180 CONTINUE - AN(1) = 0.0 - CN(NIT) = 0.0 - GO TO 220 -C -C MIXED-DIRICHLET IN Y DIRECTION -C - 190 CONTINUE - AN(1) = 0.0 - BN(1) = BN(1)+2.*DLY*GAMA*DY1 - CN(1) = CN(1)+DY1 - CN(NIT) = 0.0 - GO TO 220 -C -C DIRICHLET-MIXED IN Y DIRECTION -C - 200 AN(1) = 0.0 - AN(NIT) = AN(NIT)+FYN - BN(NIT) = BN(NIT)-2.*DLY*XNU*FYN - CN(NIT) = 0.0 - GO TO 220 -C -C MIXED - MIXED DIRECTION IN Y DIRECTION -C - 210 CONTINUE - AN(1) = 0.0 - BN(1) = BN(1)+2.*DLY*GAMA*DY1 - CN(1) = CN(1)+DY1 - AN(NIT) = AN(NIT)+FYN - BN(NIT) = BN(NIT)-2.0*DLY*XNU*FYN - CN(NIT) = 0.0 - 220 IF (KSWX .EQ. 1) GO TO 270 -C -C ADJUST USOL ALONG X EDGE -C - DO 260 J=JS,NS - IF (KSWX.NE.2 .AND. KSWX.NE.3) GO TO 230 - USOL(IS,J) = USOL(IS,J)-AX1*USOL(1,J) - GO TO 240 - 230 USOL(IS,J) = USOL(IS,J)+2.0*DLX*AX1*BDA(J) - 240 IF (KSWX.NE.2 .AND. KSWX.NE.5) GO TO 250 - USOL(MS,J) = USOL(MS,J)-CXM*USOL(K,J) - GO TO 260 - 250 USOL(MS,J) = USOL(MS,J)-2.0*DLX*CXM*BDB(J) - 260 CONTINUE - 270 IF (KSWY .EQ. 1) GO TO 320 -C -C ADJUST USOL ALONG Y EDGE -C - DO 310 I=IS,MS - IF (KSWY.NE.2 .AND. KSWY.NE.3) GO TO 280 - USOL(I,JS) = USOL(I,JS)-DY1*USOL(I,1) - GO TO 290 - 280 USOL(I,JS) = USOL(I,JS)+2.0*DLY*DY1*BDC(I) - 290 IF (KSWY.NE.2 .AND. KSWY.NE.5) GO TO 300 - USOL(I,NS) = USOL(I,NS)-FYN*USOL(I,L) - GO TO 310 - 300 USOL(I,NS) = USOL(I,NS)-2.0*DLY*FYN*BDD(I) - 310 CONTINUE - 320 CONTINUE -C -C SAVE ADJUSTED EDGES IN GRHS IF IORDER=4 -C - IF (IORDER .NE. 4) GO TO 350 - DO 330 J=JS,NS - GRHS(IS,J) = USOL(IS,J) - GRHS(MS,J) = USOL(MS,J) - 330 CONTINUE - DO 340 I=IS,MS - GRHS(I,JS) = USOL(I,JS) - GRHS(I,NS) = USOL(I,NS) - 340 CONTINUE - 350 CONTINUE - IORD = IORDER - PERTRB = 0.0 -C -C CHECK IF OPERATOR IS SINGULAR -C - CALL CHKSN4(MBDCND,NBDCND,ALPHA,BETA,COFX,SINGLR) -C -C COMPUTE NON-ZERO EIGENVECTOR IN NULL SPACE OF TRANSPOSE -C IF SINGULAR -C - IF (SINGLR) CALL TRIS4 (MIT,AM,BM,CM,DM,UM,ZM) - IF (SINGLR) CALL TRIS4 (NIT,AN,BN,CN,DN,UN,ZN) -C -C ADJUST RIGHT HAND SIDE IF NECESSARY -C - 360 CONTINUE - IF (SINGLR) CALL ORTHO4 (USOL,IDMN,ZN,ZM,PERTRB) -C -C COMPUTE SOLUTION -C -C SAVE ADJUSTED RIGHT HAND SIDE IN GRHS - DO 444 J=JS,NS - DO 444 I=IS,MS - GRHS(I,J)=USOL(I,J) - 444 CONTINUE - CALL GENBUN(NP,NIT,MP,MIT,AM,BM,CM,IDMN,USOL(IS,JS),IEROR,W) -C CHECK IF ERROR DETECTED IN POIS -C THIS CAN ONLY CORRESPOND TO IERROR=12 - IF(IEROR.EQ.0) GO TO 224 -C SET ERROR FLAG IF IMPROPER COEFFICIENTS INPUT TO POIS - IERROR=12 - RETURN - 224 CONTINUE - IF (IERROR .NE. 0) RETURN -C -C SET PERIODIC BOUNDARIES IF NECESSARY -C - IF (KSWX .NE. 1) GO TO 380 - DO 370 J=1,L - USOL(K,J) = USOL(1,J) - 370 CONTINUE - 380 IF (KSWY .NE. 1) GO TO 400 - DO 390 I=1,K - USOL(I,L) = USOL(I,1) - 390 CONTINUE - 400 CONTINUE -C -C MINIMIZE SOLUTION WITH RESPECT TO WEIGHTED LEAST SQUARES -C NORM IF OPERATOR IS SINGULAR -C - IF (SINGLR) CALL MINSO4 (USOL,IDMN,ZN,ZM,PRTRB) -C -C RETURN IF DEFERRED CORRECTIONS AND A FOURTH ORDER SOLUTION ARE -C NOT FLAGGED -C - IF (IORD .EQ. 2) RETURN - IORD = 2 -C -C COMPUTE NEW RIGHT HAND SIDE FOR FOURTH ORDER SOLUTION -C - CALL DEFE4(COFX,IDMN,USOL,GRHS) - GO TO 360 - END diff --git a/slatec/spelip.f b/slatec/spelip.f deleted file mode 100644 index f68a67a..0000000 --- a/slatec/spelip.f +++ /dev/null @@ -1,327 +0,0 @@ -*DECK SPELIP - SUBROUTINE SPELIP (INTL, IORDER, A, B, M, MBDCND, BDA, ALPHA, BDB, - + BETA, C, D, N, NBDCND, BDC, GAMA, BDD, XNU, COFX, COFY, AN, BN, - + CN, DN, UN, ZN, AM, BM, CM, DM, UM, ZM, GRHS, USOL, IDMN, W, - + PERTRB, IERROR) -C***BEGIN PROLOGUE SPELIP -C***SUBSIDIARY -C***PURPOSE Subsidiary to SEPELI -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (SPELIP-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C SPELIP sets up vectors and arrays for input to BLKTRI -C and computes a second order solution in USOL. A return jump to -C SEPELI occurs if IORDER=2. If IORDER=4 a fourth order -C solution is generated in USOL. -C -C***SEE ALSO SEPELI -C***ROUTINES CALLED BLKTRI, CHKSNG, DEFER, MINSOL, ORTHOG, TRISP -C***COMMON BLOCKS SPLPCM -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE SPELIP -C - DIMENSION BDA(*) ,BDB(*) ,BDC(*) ,BDD(*) , - 1 W(*) - DIMENSION GRHS(IDMN,*) ,USOL(IDMN,*) - DIMENSION AN(*) ,BN(*) ,CN(*) ,DN(*) , - 1 UN(*) ,ZN(*) - DIMENSION AM(*) ,BM(*) ,CM(*) ,DM(*) , - 1 UM(*) ,ZM(*) - COMMON /SPLPCM/ KSWX ,KSWY ,K ,L , - 1 AIT ,BIT ,CIT ,DIT , - 2 MIT ,NIT ,IS ,MS , - 3 JS ,NS ,DLX ,DLY , - 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 - LOGICAL SINGLR - EXTERNAL COFX ,COFY -C***FIRST EXECUTABLE STATEMENT SPELIP - KSWX = MBDCND+1 - KSWY = NBDCND+1 - K = M+1 - L = N+1 - AIT = A - BIT = B - CIT = C - DIT = D -C -C SET RIGHT HAND SIDE VALUES FROM GRHS IN USOL ON THE INTERIOR -C AND NON-SPECIFIED BOUNDARIES. -C - DO 20 I=2,M - DO 10 J=2,N - USOL(I,J) = GRHS(I,J) - 10 CONTINUE - 20 CONTINUE - IF (KSWX.EQ.2 .OR. KSWX.EQ.3) GO TO 40 - DO 30 J=2,N - USOL(1,J) = GRHS(1,J) - 30 CONTINUE - 40 CONTINUE - IF (KSWX.EQ.2 .OR. KSWX.EQ.5) GO TO 60 - DO 50 J=2,N - USOL(K,J) = GRHS(K,J) - 50 CONTINUE - 60 CONTINUE - IF (KSWY.EQ.2 .OR. KSWY.EQ.3) GO TO 80 - DO 70 I=2,M - USOL(I,1) = GRHS(I,1) - 70 CONTINUE - 80 CONTINUE - IF (KSWY.EQ.2 .OR. KSWY.EQ.5) GO TO 100 - DO 90 I=2,M - USOL(I,L) = GRHS(I,L) - 90 CONTINUE - 100 CONTINUE - IF (KSWX.NE.2 .AND. KSWX.NE.3 .AND. KSWY.NE.2 .AND. KSWY.NE.3) - 1 USOL(1,1) = GRHS(1,1) - IF (KSWX.NE.2 .AND. KSWX.NE.5 .AND. KSWY.NE.2 .AND. KSWY.NE.3) - 1 USOL(K,1) = GRHS(K,1) - IF (KSWX.NE.2 .AND. KSWX.NE.3 .AND. KSWY.NE.2 .AND. KSWY.NE.5) - 1 USOL(1,L) = GRHS(1,L) - IF (KSWX.NE.2 .AND. KSWX.NE.5 .AND. KSWY.NE.2 .AND. KSWY.NE.5) - 1 USOL(K,L) = GRHS(K,L) - I1 = 1 -C -C SET SWITCHES FOR PERIODIC OR NON-PERIODIC BOUNDARIES -C - MP = 1 - NP = 1 - IF (KSWX .EQ. 1) MP = 0 - IF (KSWY .EQ. 1) NP = 0 -C -C SET DLX,DLY AND SIZE OF BLOCK TRI-DIAGONAL SYSTEM GENERATED -C IN NINT,MINT -C - DLX = (BIT-AIT)/M - MIT = K-1 - IF (KSWX .EQ. 2) MIT = K-2 - IF (KSWX .EQ. 4) MIT = K - DLY = (DIT-CIT)/N - NIT = L-1 - IF (KSWY .EQ. 2) NIT = L-2 - IF (KSWY .EQ. 4) NIT = L - TDLX3 = 2.0*DLX**3 - DLX4 = DLX**4 - TDLY3 = 2.0*DLY**3 - DLY4 = DLY**4 -C -C SET SUBSCRIPT LIMITS FOR PORTION OF ARRAY TO INPUT TO BLKTRI -C - IS = 1 - JS = 1 - IF (KSWX.EQ.2 .OR. KSWX.EQ.3) IS = 2 - IF (KSWY.EQ.2 .OR. KSWY.EQ.3) JS = 2 - NS = NIT+JS-1 - MS = MIT+IS-1 -C -C SET X - DIRECTION -C - DO 110 I=1,MIT - XI = AIT+(IS+I-2)*DLX - CALL COFX (XI,AI,BI,CI) - AXI = (AI/DLX-0.5*BI)/DLX - BXI = -2.*AI/DLX**2+CI - CXI = (AI/DLX+0.5*BI)/DLX - AM(I) = AXI - BM(I) = BXI - CM(I) = CXI - 110 CONTINUE -C -C SET Y DIRECTION -C - DO 120 J=1,NIT - YJ = CIT+(JS+J-2)*DLY - CALL COFY (YJ,DJ,EJ,FJ) - DYJ = (DJ/DLY-0.5*EJ)/DLY - EYJ = (-2.*DJ/DLY**2+FJ) - FYJ = (DJ/DLY+0.5*EJ)/DLY - AN(J) = DYJ - BN(J) = EYJ - CN(J) = FYJ - 120 CONTINUE -C -C ADJUST EDGES IN X DIRECTION UNLESS PERIODIC -C - AX1 = AM(1) - CXM = CM(MIT) - GO TO (170,130,150,160,140),KSWX -C -C DIRICHLET-DIRICHLET IN X DIRECTION -C - 130 AM(1) = 0.0 - CM(MIT) = 0.0 - GO TO 170 -C -C MIXED-DIRICHLET IN X DIRECTION -C - 140 AM(1) = 0.0 - BM(1) = BM(1)+2.*ALPHA*DLX*AX1 - CM(1) = CM(1)+AX1 - CM(MIT) = 0.0 - GO TO 170 -C -C DIRICHLET-MIXED IN X DIRECTION -C - 150 AM(1) = 0.0 - AM(MIT) = AM(MIT)+CXM - BM(MIT) = BM(MIT)-2.*BETA*DLX*CXM - CM(MIT) = 0.0 - GO TO 170 -C -C MIXED - MIXED IN X DIRECTION -C - 160 CONTINUE - AM(1) = 0.0 - BM(1) = BM(1)+2.*DLX*ALPHA*AX1 - CM(1) = CM(1)+AX1 - AM(MIT) = AM(MIT)+CXM - BM(MIT) = BM(MIT)-2.*DLX*BETA*CXM - CM(MIT) = 0.0 - 170 CONTINUE -C -C ADJUST IN Y DIRECTION UNLESS PERIODIC -C - DY1 = AN(1) - FYN = CN(NIT) - GO TO (220,180,200,210,190),KSWY -C -C DIRICHLET-DIRICHLET IN Y DIRECTION -C - 180 CONTINUE - AN(1) = 0.0 - CN(NIT) = 0.0 - GO TO 220 -C -C MIXED-DIRICHLET IN Y DIRECTION -C - 190 CONTINUE - AN(1) = 0.0 - BN(1) = BN(1)+2.*DLY*GAMA*DY1 - CN(1) = CN(1)+DY1 - CN(NIT) = 0.0 - GO TO 220 -C -C DIRICHLET-MIXED IN Y DIRECTION -C - 200 AN(1) = 0.0 - AN(NIT) = AN(NIT)+FYN - BN(NIT) = BN(NIT)-2.*DLY*XNU*FYN - CN(NIT) = 0.0 - GO TO 220 -C -C MIXED - MIXED DIRECTION IN Y DIRECTION -C - 210 CONTINUE - AN(1) = 0.0 - BN(1) = BN(1)+2.*DLY*GAMA*DY1 - CN(1) = CN(1)+DY1 - AN(NIT) = AN(NIT)+FYN - BN(NIT) = BN(NIT)-2.0*DLY*XNU*FYN - CN(NIT) = 0.0 - 220 IF (KSWX .EQ. 1) GO TO 270 -C -C ADJUST USOL ALONG X EDGE -C - DO 260 J=JS,NS - IF (KSWX.NE.2 .AND. KSWX.NE.3) GO TO 230 - USOL(IS,J) = USOL(IS,J)-AX1*USOL(1,J) - GO TO 240 - 230 USOL(IS,J) = USOL(IS,J)+2.0*DLX*AX1*BDA(J) - 240 IF (KSWX.NE.2 .AND. KSWX.NE.5) GO TO 250 - USOL(MS,J) = USOL(MS,J)-CXM*USOL(K,J) - GO TO 260 - 250 USOL(MS,J) = USOL(MS,J)-2.0*DLX*CXM*BDB(J) - 260 CONTINUE - 270 IF (KSWY .EQ. 1) GO TO 320 -C -C ADJUST USOL ALONG Y EDGE -C - DO 310 I=IS,MS - IF (KSWY.NE.2 .AND. KSWY.NE.3) GO TO 280 - USOL(I,JS) = USOL(I,JS)-DY1*USOL(I,1) - GO TO 290 - 280 USOL(I,JS) = USOL(I,JS)+2.0*DLY*DY1*BDC(I) - 290 IF (KSWY.NE.2 .AND. KSWY.NE.5) GO TO 300 - USOL(I,NS) = USOL(I,NS)-FYN*USOL(I,L) - GO TO 310 - 300 USOL(I,NS) = USOL(I,NS)-2.0*DLY*FYN*BDD(I) - 310 CONTINUE - 320 CONTINUE -C -C SAVE ADJUSTED EDGES IN GRHS IF IORDER=4 -C - IF (IORDER .NE. 4) GO TO 350 - DO 330 J=JS,NS - GRHS(IS,J) = USOL(IS,J) - GRHS(MS,J) = USOL(MS,J) - 330 CONTINUE - DO 340 I=IS,MS - GRHS(I,JS) = USOL(I,JS) - GRHS(I,NS) = USOL(I,NS) - 340 CONTINUE - 350 CONTINUE - IORD = IORDER - PERTRB = 0.0 -C -C CHECK IF OPERATOR IS SINGULAR -C - CALL CHKSNG (MBDCND,NBDCND,ALPHA,BETA,GAMA,XNU,COFX,COFY,SINGLR) -C -C COMPUTE NON-ZERO EIGENVECTOR IN NULL SPACE OF TRANSPOSE -C IF SINGULAR -C - IF (SINGLR) CALL TRISP (MIT,AM,BM,CM,DM,UM,ZM) - IF (SINGLR) CALL TRISP (NIT,AN,BN,CN,DN,UN,ZN) -C -C MAKE INITIALIZATION CALL TO BLKTRI -C - IF (INTL .EQ. 0) - 1 CALL BLKTRI (INTL,NP,NIT,AN,BN,CN,MP,MIT,AM,BM,CM,IDMN, - 2 USOL(IS,JS),IERROR,W) - IF (IERROR .NE. 0) RETURN -C -C ADJUST RIGHT HAND SIDE IF NECESSARY -C - 360 CONTINUE - IF (SINGLR) CALL ORTHOG (USOL,IDMN,ZN,ZM,PERTRB) -C -C COMPUTE SOLUTION -C - CALL BLKTRI (I1,NP,NIT,AN,BN,CN,MP,MIT,AM,BM,CM,IDMN,USOL(IS,JS), - 1 IERROR,W) - IF (IERROR .NE. 0) RETURN -C -C SET PERIODIC BOUNDARIES IF NECESSARY -C - IF (KSWX .NE. 1) GO TO 380 - DO 370 J=1,L - USOL(K,J) = USOL(1,J) - 370 CONTINUE - 380 IF (KSWY .NE. 1) GO TO 400 - DO 390 I=1,K - USOL(I,L) = USOL(I,1) - 390 CONTINUE - 400 CONTINUE -C -C MINIMIZE SOLUTION WITH RESPECT TO WEIGHTED LEAST SQUARES -C NORM IF OPERATOR IS SINGULAR -C - IF (SINGLR) CALL MINSOL (USOL,IDMN,ZN,ZM,PRTRB) -C -C RETURN IF DEFERRED CORRECTIONS AND A FOURTH ORDER SOLUTION ARE -C NOT FLAGGED -C - IF (IORD .EQ. 2) RETURN - IORD = 2 -C -C COMPUTE NEW RIGHT HAND SIDE FOR FOURTH ORDER SOLUTION -C - CALL DEFER (COFX,COFY,IDMN,USOL,GRHS) - GO TO 360 - END diff --git a/slatec/spenc.f b/slatec/spenc.f deleted file mode 100644 index 5fc086c..0000000 --- a/slatec/spenc.f +++ /dev/null @@ -1,117 +0,0 @@ -*DECK SPENC - FUNCTION SPENC (X) -C***BEGIN PROLOGUE SPENC -C***PURPOSE Compute a form of Spence's integral due to K. Mitchell. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C5 -C***TYPE SINGLE PRECISION (SPENC-S, DSPENC-D) -C***KEYWORDS FNLIB, SPECIAL FUNCTIONS, SPENCE'S INTEGRAL -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate a form of Spence's function defined by -C integral from 0 to X of -LOG(1-Y)/Y DY. -C For ABS(X) .LE. 1, the uniformly convergent expansion -C SPENC = sum K=1,infinity X**K / K**2 is valid. -C -C Spence's function can be used to evaluate much more general integral -C forms. For example, -C integral from 0 to Z of LOG(A*X+B)/(C*X+D) DX = -C LOG(ABS(B-A*D/C))*LOG(ABS(A*(C*X+D)/(A*D-B*C)))/C -C - SPENC (A*(C*Z+D)/(A*D-B*C)) / C. -C -C Ref -- K. Mitchell, Philosophical Magazine, 40, p. 351 (1949). -C Stegun and Abromowitz, AMS 55, p. 1004. -C -C -C Series for SPEN on the interval 0. to 5.00000D-01 -C with weighted error 6.82E-17 -C log weighted error 16.17 -C significant figures required 15.22 -C decimal places required 16.81 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, INITS, R1MACH -C***REVISION HISTORY (YYMMDD) -C 780201 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***END PROLOGUE SPENC - DIMENSION SPENCS(19) - LOGICAL FIRST - SAVE SPENCS, PI26, NSPENC, XBIG, FIRST - DATA SPENCS( 1) / .1527365598 892406E0 / - DATA SPENCS( 2) / .0816965805 8051014E0 / - DATA SPENCS( 3) / .0058141571 4077873E0 / - DATA SPENCS( 4) / .0005371619 8145415E0 / - DATA SPENCS( 5) / .0000572470 4675185E0 / - DATA SPENCS( 6) / .0000066745 4612164E0 / - DATA SPENCS( 7) / .0000008276 4673397E0 / - DATA SPENCS( 8) / .0000001073 3156730E0 / - DATA SPENCS( 9) / .0000000144 0077294E0 / - DATA SPENCS(10) / .0000000019 8444202E0 / - DATA SPENCS(11) / .0000000002 7940058E0 / - DATA SPENCS(12) / .0000000000 4003991E0 / - DATA SPENCS(13) / .0000000000 0582346E0 / - DATA SPENCS(14) / .0000000000 0085767E0 / - DATA SPENCS(15) / .0000000000 0012768E0 / - DATA SPENCS(16) / .0000000000 0001918E0 / - DATA SPENCS(17) / .0000000000 0000290E0 / - DATA SPENCS(18) / .0000000000 0000044E0 / - DATA SPENCS(19) / .0000000000 0000006E0 / - DATA PI26 / 1.644934066 848226E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT SPENC - IF (FIRST) THEN - NSPENC = INITS (SPENCS, 19, 0.1*R1MACH(3)) - XBIG = 1.0/R1MACH(3) - ENDIF - FIRST = .FALSE. -C - IF (X.GT.2.0) GO TO 60 - IF (X.GT.1.0) GO TO 50 - IF (X.GT.0.5) GO TO 40 - IF (X.GE.0.0) GO TO 30 - IF (X.GT.(-1.)) GO TO 20 -C -C HERE IF X .LE. -1.0 -C - ALN = LOG(1.0-X) - SPENC = -PI26 - 0.5*ALN*(2.0*LOG(-X)-ALN) - IF (X.GT.(-XBIG)) SPENC = SPENC - 1 + (1.0 + CSEVL (4.0/(1.0-X)-1.0, SPENCS, NSPENC)) / (1.0-X) - RETURN -C -C -1.0 .LT. X .LT. 0.0 -C - 20 SPENC = -0.5*LOG(1.0-X)**2 - 1 - X*(1.0 + CSEVL (4.0*X/(X-1.0)-1.0, SPENCS, NSPENC)) / (X-1.0) - RETURN -C -C 0.0 .LE. X .LE. 0.5 -C - 30 SPENC = X*(1.0 + CSEVL (4.0*X-1.0, SPENCS, NSPENC)) - RETURN -C -C 0.5 .LT. X .LE. 1.0 -C - 40 SPENC = PI26 - IF (X.NE.1.0) SPENC = PI26 - LOG(X)*LOG(1.0-X) - 1 - (1.0-X)*(1.0 + CSEVL (4.0*(1.0-X)-1.0, SPENCS, NSPENC)) - RETURN -C -C 1.0 .LT. X .LE. 2.0 -C - 50 SPENC = PI26 - 0.5*LOG(X)*LOG((X-1.0)**2/X) - 1 + (X-1.)*(1.0 + CSEVL (4.0*(X-1.)/X-1.0, SPENCS, NSPENC))/X - RETURN -C -C X .GT. 2.0 -C - 60 SPENC = 2.0*PI26 - 0.5*LOG(X)**2 - IF (X.LT.XBIG) SPENC = SPENC - 1 - (1.0 + CSEVL (4.0/X-1.0, SPENCS, NSPENC))/X - RETURN -C - END diff --git a/slatec/spigmr.f b/slatec/spigmr.f deleted file mode 100644 index e00062a..0000000 --- a/slatec/spigmr.f +++ /dev/null @@ -1,434 +0,0 @@ -*DECK SPIGMR - SUBROUTINE SPIGMR (N, R0, SR, SZ, JSCAL, MAXL, MAXLP1, KMP, NRSTS, - + JPRE, MATVEC, MSOLVE, NMSL, Z, V, HES, Q, LGMR, RPAR, IPAR, WK, - + DL, RHOL, NRMAX, B, BNRM, X, XL, ITOL, TOL, NELT, IA, JA, A, - + ISYM, IUNIT, IFLAG, ERR) -C***BEGIN PROLOGUE SPIGMR -C***SUBSIDIARY -C***PURPOSE Internal routine for SGMRES. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (SPIGMR-S, DPIGMR-D) -C***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov -C Hindmarsh, Alan, (LLNL), alanh@llnl.gov -C Seager, Mark K., (LLNL), seager@llnl.gov -C Lawrence Livermore National Laboratory -C PO Box 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C***DESCRIPTION -C This routine solves the linear system A * Z = R0 using a -C scaled preconditioned version of the generalized minimum -C residual method. An initial guess of Z = 0 is assumed. -C -C *Usage: -C INTEGER N, JSCAL, MAXL, MAXLP1, KMP, NRSTS, JPRE, NMSL, LGMR -C INTEGER IPAR(USER DEFINED), NRMAX, ITOL, NELT, IA(NELT), JA(NELT) -C INTEGER ISYM, IUNIT, IFLAG -C REAL R0(N), SR(N), SZ(N), Z(N), V(N,MAXLP1), HES(MAXLP1,MAXL), -C $ Q(2*MAXL), RPAR(USER DEFINED), WK(N), DL(N), RHOL, B(N), -C $ BNRM, X(N), XL(N), TOL, A(NELT), ERR -C EXTERNAL MATVEC, MSOLVE -C -C CALL SPIGMR(N, R0, SR, SZ, JSCAL, MAXL, MAXLP1, KMP, -C $ NRSTS, JPRE, MATVEC, MSOLVE, NMSL, Z, V, HES, Q, LGMR, -C $ RPAR, IPAR, WK, DL, RHOL, NRMAX, B, BNRM, X, XL, -C $ ITOL, TOL, NELT, IA, JA, A, ISYM, IUNIT, IFLAG, ERR) -C -C *Arguments: -C N :IN Integer -C The order of the matrix A, and the lengths -C of the vectors SR, SZ, R0 and Z. -C R0 :IN Real R0(N) -C R0 = the right hand side of the system A*Z = R0. -C R0 is also used as workspace when computing -C the final approximation. -C (R0 is the same as V(*,MAXL+1) in the call to SPIGMR.) -C SR :IN Real SR(N) -C SR is a vector of length N containing the non-zero -C elements of the diagonal scaling matrix for R0. -C SZ :IN Real SZ(N) -C SZ is a vector of length N containing the non-zero -C elements of the diagonal scaling matrix for Z. -C JSCAL :IN Integer -C A flag indicating whether arrays SR and SZ are used. -C JSCAL=0 means SR and SZ are not used and the -C algorithm will perform as if all -C SR(i) = 1 and SZ(i) = 1. -C JSCAL=1 means only SZ is used, and the algorithm -C performs as if all SR(i) = 1. -C JSCAL=2 means only SR is used, and the algorithm -C performs as if all SZ(i) = 1. -C JSCAL=3 means both SR and SZ are used. -C MAXL :IN Integer -C The maximum allowable order of the matrix H. -C MAXLP1 :IN Integer -C MAXPL1 = MAXL + 1, used for dynamic dimensioning of HES. -C KMP :IN Integer -C The number of previous vectors the new vector VNEW -C must be made orthogonal to. (KMP .le. MAXL) -C NRSTS :IN Integer -C Counter for the number of restarts on the current -C call to SGMRES. If NRSTS .gt. 0, then the residual -C R0 is already scaled, and so scaling of it is -C not necessary. -C JPRE :IN Integer -C Preconditioner type flag. -C MATVEC :EXT External. -C Name of a routine which performs the matrix vector multiply -C Y = A*X given A and X. The name of the MATVEC routine must -C be declared external in the calling program. The calling -C sequence to MATVEC is: -C CALL MATVEC(N, X, Y, NELT, IA, JA, A, ISYM) -C where N is the number of unknowns, Y is the product A*X -C upon return, X is an input vector, and NELT is the number of -C non-zeros in the SLAP IA, JA, A storage for the matrix A. -C ISYM is a flag which, if non-zero, denotes that A is -C symmetric and only the lower or upper triangle is stored. -C MSOLVE :EXT External. -C Name of the routine which solves a linear system Mz = r for -C z given r with the preconditioning matrix M (M is supplied via -C RPAR and IPAR arrays. The name of the MSOLVE routine must -C be declared external in the calling program. The calling -C sequence to MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RPAR, IPAR) -C Where N is the number of unknowns, R is the right-hand side -C vector and Z is the solution upon return. NELT, IA, JA, A and -C ISYM are defined as below. RPAR is a real array that can be -C used to pass necessary preconditioning information and/or -C workspace to MSOLVE. IPAR is an integer work array for the -C same purpose as RPAR. -C NMSL :OUT Integer -C The number of calls to MSOLVE. -C Z :OUT Real Z(N) -C The final computed approximation to the solution -C of the system A*Z = R0. -C V :OUT Real V(N,MAXLP1) -C The N by (LGMR+1) array containing the LGMR -C orthogonal vectors V(*,1) to V(*,LGMR). -C HES :OUT Real HES(MAXLP1,MAXL) -C 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 Q :OUT Real Q(2*MAXL) -C A 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 SHEQR and used in SHELS. -C LGMR :OUT Integer -C The number of iterations performed and -C the current order of the upper Hessenberg -C matrix HES. -C RPAR :IN Real RPAR(USER DEFINED) -C Real workspace passed directly to the MSOLVE routine. -C IPAR :IN Integer IPAR(USER DEFINED) -C Integer workspace passed directly to the MSOLVE routine. -C WK :IN Real WK(N) -C A real work array of length N used by routines MATVEC -C and MSOLVE. -C DL :INOUT Real DL(N) -C On input, a real work array of length N used for calculation -C of the residual norm RHO when the method is incomplete -C (KMP.lt.MAXL), and/or when using restarting. -C On output, the scaled residual vector RL. It is only loaded -C when performing restarts of the Krylov iteration. -C RHOL :OUT Real -C A real scalar containing the norm of the final residual. -C NRMAX :IN Integer -C The maximum number of restarts of the Krylov iteration. -C NRMAX .gt. 0 means restarting is active, while -C NRMAX = 0 means restarting is not being used. -C B :IN Real B(N) -C The right hand side of the linear system A*X = b. -C BNRM :IN Real -C The scaled norm of b. -C X :IN Real X(N) -C The current approximate solution as of the last -C restart. -C XL :IN Real XL(N) -C An array of length N used to hold the approximate -C solution X(L) when ITOL=11. -C ITOL :IN Integer -C A flag to indicate the type of convergence criterion -C used. See the driver for its description. -C TOL :IN Real -C The tolerance on residuals R0-A*Z in scaled norm. -C NELT :IN Integer -C The length of arrays IA, JA and A. -C IA :IN Integer IA(NELT) -C An integer array of length NELT containing matrix data. -C It is passed directly to the MATVEC and MSOLVE routines. -C JA :IN Integer JA(NELT) -C An integer array of length NELT containing matrix data. -C It is passed directly to the MATVEC and MSOLVE routines. -C A :IN Real A(NELT) -C A real array of length NELT containing matrix data. -C It is passed directly to the MATVEC and MSOLVE routines. -C ISYM :IN Integer -C A flag to indicate symmetric matrix storage. -C If ISYM=0, all non-zero entries of the matrix are -C stored. If ISYM=1, the matrix is symmetric and -C only the upper or lower triangular part is stored. -C IUNIT :IN Integer -C The i/o unit number for writing intermediate residual -C norm values. -C IFLAG :OUT Integer -C An 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 residual norm is .lt. norm(R0), -C and so Z is computed. -C 2 means the convergence test did not pass in MAXL -C iterations, residual .ge. norm(R0), and Z = 0. -C ERR :OUT Real. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO SGMRES -C***ROUTINES CALLED ISSGMR, SAXPY, SCOPY, SHELS, SHEQR, SNRM2, SORTH, -C SRLCAL, SSCAL -C***REVISION HISTORY (YYMMDD) -C 871001 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MATVEC and MSOLVE from ROUTINES CALLED list. (FNF) -C 910506 Made subsidiary to SGMRES. (FNF) -C 920511 Added complete declaration section. (WRB) -C***END PROLOGUE SPIGMR -C The following is for optimized compilation on LLNL/LTSS Crays. -CLLL. OPTIMIZE -C .. Scalar Arguments .. - REAL BNRM, ERR, RHOL, TOL - INTEGER IFLAG, ISYM, ITOL, IUNIT, JPRE, JSCAL, KMP, LGMR, MAXL, - + MAXLP1, N, NELT, NMSL, NRMAX, NRSTS -C .. Array Arguments .. - REAL A(NELT), B(*), DL(*), HES(MAXLP1,*), Q(*), R0(*), RPAR(*), - + SR(*), SZ(*), V(N,*), WK(*), X(*), XL(*), Z(*) - INTEGER IA(NELT), IPAR(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MATVEC, MSOLVE -C .. Local Scalars .. - REAL C, DLNRM, PROD, R0NRM, RHO, S, SNORMW, TEM - INTEGER I, I2, INFO, IP1, ITER, ITMAX, J, K, LL, LLP1 -C .. External Functions .. - REAL SNRM2 - INTEGER ISSGMR - EXTERNAL SNRM2, ISSGMR -C .. External Subroutines .. - EXTERNAL SAXPY, SCOPY, SHELS, SHEQR, SORTH, SRLCAL, SSCAL -C .. Intrinsic Functions .. - INTRINSIC ABS -C***FIRST EXECUTABLE STATEMENT SPIGMR -C -C Zero out the Z array. -C - DO 5 I = 1,N - Z(I) = 0 - 5 CONTINUE -C - IFLAG = 0 - LGMR = 0 - NMSL = 0 -C Load ITMAX, the maximum number of iterations. - ITMAX =(NRMAX+1)*MAXL -C ------------------------------------------------------------------- -C The initial residual is the vector R0. -C Apply left precon. if JPRE < 0 and this is not a restart. -C Apply scaling to R0 if JSCAL = 2 or 3. -C ------------------------------------------------------------------- - IF ((JPRE .LT. 0) .AND.(NRSTS .EQ. 0)) THEN - CALL SCOPY(N, R0, 1, WK, 1) - CALL MSOLVE(N, WK, R0, NELT, IA, JA, A, ISYM, RPAR, IPAR) - NMSL = NMSL + 1 - ENDIF - IF (((JSCAL.EQ.2) .OR.(JSCAL.EQ.3)) .AND.(NRSTS.EQ.0)) THEN - DO 10 I = 1,N - V(I,1) = R0(I)*SR(I) - 10 CONTINUE - ELSE - DO 20 I = 1,N - V(I,1) = R0(I) - 20 CONTINUE - ENDIF - R0NRM = SNRM2(N, V, 1) - ITER = NRSTS*MAXL -C -C Call stopping routine ISSGMR. -C - IF (ISSGMR(N, B, X, XL, NELT, IA, JA, A, ISYM, MSOLVE, - $ NMSL, ITOL, TOL, ITMAX, ITER, ERR, IUNIT, V(1,1), Z, WK, - $ RPAR, IPAR, R0NRM, BNRM, SR, SZ, JSCAL, - $ KMP, LGMR, MAXL, MAXLP1, V, Q, SNORMW, PROD, R0NRM, - $ HES, JPRE) .NE. 0) RETURN - TEM = 1.0E0/R0NRM - CALL SSCAL(N, TEM, V(1,1), 1) -C -C Zero out the HES array. -C - DO 50 J = 1,MAXL - DO 40 I = 1,MAXLP1 - HES(I,J) = 0 - 40 CONTINUE - 50 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 - DO 90 LL = 1,MAXL - LGMR = LL -C ------------------------------------------------------------------- -C Unscale the current V(LL) and store in WK. Call routine -C MSOLVE to compute(M-inverse)*WK, where M is the -C preconditioner matrix. Save the answer in Z. Call routine -C MATVEC to compute VNEW = A*Z, where A is the the system -C matrix. save the answer in V(LL+1). Scale V(LL+1). Call -C routine SORTH to orthogonalize the new vector VNEW = -C V(*,LL+1). Call routine SHEQR to update the factors of HES. -C ------------------------------------------------------------------- - IF ((JSCAL .EQ. 1) .OR.(JSCAL .EQ. 3)) THEN - DO 60 I = 1,N - WK(I) = V(I,LL)/SZ(I) - 60 CONTINUE - ELSE - CALL SCOPY(N, V(1,LL), 1, WK, 1) - ENDIF - IF (JPRE .GT. 0) THEN - CALL MSOLVE(N, WK, Z, NELT, IA, JA, A, ISYM, RPAR, IPAR) - NMSL = NMSL + 1 - CALL MATVEC(N, Z, V(1,LL+1), NELT, IA, JA, A, ISYM) - ELSE - CALL MATVEC(N, WK, V(1,LL+1), NELT, IA, JA, A, ISYM) - ENDIF - IF (JPRE .LT. 0) THEN - CALL SCOPY(N, V(1,LL+1), 1, WK, 1) - CALL MSOLVE(N,WK,V(1,LL+1),NELT,IA,JA,A,ISYM,RPAR,IPAR) - NMSL = NMSL + 1 - ENDIF - IF ((JSCAL .EQ. 2) .OR.(JSCAL .EQ. 3)) THEN - DO 65 I = 1,N - V(I,LL+1) = V(I,LL+1)*SR(I) - 65 CONTINUE - ENDIF - CALL SORTH(V(1,LL+1), V, HES, N, LL, MAXLP1, KMP, SNORMW) - HES(LL+1,LL) = SNORMW - CALL SHEQR(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 R0-A*ZL. -C If KMP < MAXL, then the vectors V(*,1),...,V(*,LL+1) are not -C necessarily orthogonal for LL > 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*R0NRM) - IF ((LL.GT.KMP) .AND.(KMP.LT.MAXL)) THEN - IF (LL .EQ. KMP+1) THEN - CALL SCOPY(N, 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,N - DL(K) = S*DL(K) + C*V(K,IP1) - 70 CONTINUE - 75 CONTINUE - ENDIF - S = Q(2*LL) - C = Q(2*LL-1)/SNORMW - LLP1 = LL + 1 - DO 80 K = 1,N - DL(K) = S*DL(K) + C*V(K,LLP1) - 80 CONTINUE - DLNRM = SNRM2(N, DL, 1) - RHO = RHO*DLNRM - ENDIF - RHOL = RHO -C ------------------------------------------------------------------- -C Test for convergence. If passed, compute approximation ZL. -C If failed and LL < MAXL, then continue iterating. -C ------------------------------------------------------------------- - ITER = NRSTS*MAXL + LGMR - IF (ISSGMR(N, B, X, XL, NELT, IA, JA, A, ISYM, MSOLVE, - $ NMSL, ITOL, TOL, ITMAX, ITER, ERR, IUNIT, DL, Z, WK, - $ RPAR, IPAR, RHOL, BNRM, SR, SZ, JSCAL, - $ KMP, LGMR, MAXL, MAXLP1, V, Q, SNORMW, PROD, R0NRM, - $ HES, JPRE) .NE. 0) 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.0E0/SNORMW - CALL SSCAL(N, TEM, V(1,LL+1), 1) - 90 CONTINUE - 100 CONTINUE - IF (RHO .LT. R0NRM) GO TO 150 - 120 CONTINUE - IFLAG = 2 -C -C Load approximate solution with zero. -C - DO 130 I = 1,N - Z(I) = 0 - 130 CONTINUE - RETURN - 150 IFLAG = 1 -C -C Tolerance not met, but residual norm reduced. -C - IF (NRMAX .GT. 0) THEN -C -C If performing restarting (NRMAX > 0) calculate the residual -C vector RL and store it in the DL array. If the incomplete -C version is being used (KMP < MAXL) then DL has already been -C calculated up to a scaling factor. Use SRLCAL to calculate -C the scaled residual vector. -C - CALL SRLCAL(N, KMP, MAXL, MAXL, V, Q, DL, SNORMW, PROD, - $ R0NRM) - ENDIF -C ------------------------------------------------------------------- -C Compute the approximation ZL to the solution. Since the -C vector Z was used as workspace, and the initial guess -C of the linear iteration is zero, Z must be reset to zero. -C ------------------------------------------------------------------- - 200 CONTINUE - LL = LGMR - LLP1 = LL + 1 - DO 210 K = 1,LLP1 - R0(K) = 0 - 210 CONTINUE - R0(1) = R0NRM - CALL SHELS(HES, MAXLP1, LL, Q, R0) - DO 220 K = 1,N - Z(K) = 0 - 220 CONTINUE - DO 230 I = 1,LL - CALL SAXPY(N, R0(I), V(1,I), 1, Z, 1) - 230 CONTINUE - IF ((JSCAL .EQ. 1) .OR.(JSCAL .EQ. 3)) THEN - DO 240 I = 1,N - Z(I) = Z(I)/SZ(I) - 240 CONTINUE - ENDIF - IF (JPRE .GT. 0) THEN - CALL SCOPY(N, Z, 1, WK, 1) - CALL MSOLVE(N, WK, Z, NELT, IA, JA, A, ISYM, RPAR, IPAR) - NMSL = NMSL + 1 - ENDIF - RETURN -C------------- LAST LINE OF SPIGMR FOLLOWS ---------------------------- - END diff --git a/slatec/spincw.f b/slatec/spincw.f deleted file mode 100644 index 75afbb4..0000000 --- a/slatec/spincw.f +++ /dev/null @@ -1,133 +0,0 @@ -*DECK SPINCW - SUBROUTINE SPINCW (MRELAS, NVARS, LMX, LBM, NPP, JSTRT, IBASIS, - + IMAT, IBRC, IPR, IWR, IND, IBB, COSTSC, GG, ERDNRM, DULNRM, - + AMAT, BASMAT, CSC, WR, WW, RZ, RG, COSTS, COLNRM, DUALS, - + STPEDG) -C***BEGIN PROLOGUE SPINCW -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (SPINCW-S, DPINCW-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO -C DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. -C -C USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/, -C REAL (12 BLANKS)/DOUBLE PRECISION/,/SCOPY/DCOPY/,/SDOT/DDOT/. -C -C THIS SUBPROGRAM IS PART OF THE SPLP( ) PACKAGE. -C IT IMPLEMENTS THE PROCEDURE (INITIALIZE REDUCED COSTS AND -C STEEPEST EDGE WEIGHTS). -C -C***SEE ALSO SPLP -C***ROUTINES CALLED IPLOC, LA05BS, PRWPGE, SCOPY, SDOT -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890605 Removed unreferenced labels. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE SPINCW - INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*) - REAL AMAT(*),BASMAT(*),CSC(*),WR(*),WW(*),RZ(*),RG(*), - * COSTS(*),COLNRM(*),DUALS(*),COSTSC,ERDNRM,DULNRM,GG,ONE,RZJ, - * SCALR,ZERO,RCOST - LOGICAL STPEDG,PAGEPL,TRANS -C***FIRST EXECUTABLE STATEMENT SPINCW - LPG=LMX-(NVARS+4) - ZERO=0. - ONE=1. -C -C FORM REDUCED COSTS, RZ(*), AND STEEPEST EDGE WEIGHTS, RG(*). - PAGEPL=.TRUE. - RZ(1)=ZERO - CALL SCOPY(NVARS+MRELAS,RZ,0,RZ,1) - RG(1)=ONE - CALL SCOPY(NVARS+MRELAS,RG,0,RG,1) - NNEGRC=0 - J=JSTRT -20002 IF (.NOT.(IBB(J).LE.0)) GO TO 20004 - PAGEPL=.TRUE. - GO TO 20005 -C -C THESE ARE NONBASIC INDEPENDENT VARIABLES. THE COLS. ARE IN SPARSE -C MATRIX FORMAT. -20004 IF (.NOT.(J.LE.NVARS)) GO TO 20007 - RZJ=COSTSC*COSTS(J) - WW(1)=ZERO - CALL SCOPY(MRELAS,WW,0,WW,1) - IF (.NOT.(J.EQ.1)) GO TO 20010 - ILOW=NVARS+5 - GO TO 20011 -20010 ILOW=IMAT(J+3)+1 -20011 CONTINUE - IF (.NOT.(PAGEPL)) GO TO 20013 - IL1=IPLOC(ILOW,AMAT,IMAT) - IF (.NOT.(IL1.GE.LMX-1)) GO TO 20016 - ILOW=ILOW+2 - IL1=IPLOC(ILOW,AMAT,IMAT) -20016 CONTINUE - IPAGE=ABS(IMAT(LMX-1)) - GO TO 20014 -20013 IL1=IHI+1 -20014 CONTINUE - IHI=IMAT(J+4)-(ILOW-IL1) -20019 IU1=MIN(LMX-2,IHI) - IF (.NOT.(IL1.GT.IU1)) GO TO 20021 - GO TO 20020 -20021 CONTINUE - DO 60 I=IL1,IU1 - RZJ=RZJ-AMAT(I)*DUALS(IMAT(I)) - WW(IMAT(I))=AMAT(I)*CSC(J) -60 CONTINUE - IF (.NOT.(IHI.LE.LMX-2)) GO TO 20024 - GO TO 20020 -20024 CONTINUE - IPAGE=IPAGE+1 - KEY=1 - CALL PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT) - IL1=NVARS+5 - IHI=IHI-LPG - GO TO 20019 -20020 PAGEPL=IHI.EQ.(LMX-2) - RZ(J)=RZJ*CSC(J) - IF (.NOT.(STPEDG)) GO TO 20027 - TRANS=.FALSE. - CALL LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) - RG(J)=SDOT(MRELAS,WW,1,WW,1)+ONE -20027 CONTINUE -C -C THESE ARE NONBASIC DEPENDENT VARIABLES. THE COLS. ARE IMPLICITLY -C DEFINED. - GO TO 20008 -20007 PAGEPL=.TRUE. - WW(1)=ZERO - CALL SCOPY(MRELAS,WW,0,WW,1) - SCALR=-ONE - IF (IND(J).EQ.2) SCALR=ONE - I=J-NVARS - RZ(J)=-SCALR*DUALS(I) - WW(I)=SCALR - IF (.NOT.(STPEDG)) GO TO 20030 - TRANS=.FALSE. - CALL LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) - RG(J)=SDOT(MRELAS,WW,1,WW,1)+ONE -20030 CONTINUE - CONTINUE -20008 CONTINUE -C -20005 RCOST=RZ(J) - IF (MOD(IBB(J),2).EQ.0) RCOST=-RCOST - IF (IND(J).EQ.4) RCOST=-ABS(RCOST) - CNORM=ONE - IF (J.LE.NVARS) CNORM=COLNRM(J) - IF (RCOST+ERDNRM*DULNRM*CNORM.LT.ZERO) NNEGRC=NNEGRC+1 - J=MOD(J,MRELAS+NVARS)+1 - IF (.NOT.(NNEGRC.GE.NPP .OR. J.EQ.JSTRT)) GO TO 20033 - GO TO 20003 -20033 GO TO 20002 -20003 JSTRT=J - RETURN - END diff --git a/slatec/spinit.f b/slatec/spinit.f deleted file mode 100644 index 6e05098..0000000 --- a/slatec/spinit.f +++ /dev/null @@ -1,229 +0,0 @@ -*DECK SPINIT - SUBROUTINE SPINIT (MRELAS, NVARS, COSTS, BL, BU, IND, PRIMAL, - + INFO, AMAT, CSC, COSTSC, COLNRM, XLAMDA, ANORM, RHS, RHSNRM, - + IBASIS, IBB, IMAT, LOPT) -C***BEGIN PROLOGUE SPINIT -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (SPINIT-S, DPINIT-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO -C DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. -C -C USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. -C /REAL (12 BLANKS)/DOUBLE PRECISION/,/SCOPY/DCOPY/ -C REVISED 810519-0900 -C REVISED YYMMDD-HHMM -C -C INITIALIZATION SUBROUTINE FOR SPLP(*) PACKAGE. -C -C***SEE ALSO SPLP -C***ROUTINES CALLED PNNZRS, SASUM, SCOPY -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890605 Removed unreferenced labels. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE SPINIT - REAL AIJ,AMAT(*),ANORM,BL(*),BU(*),CMAX, - * COLNRM(*),COSTS(*),COSTSC,CSC(*),CSUM,ONE,PRIMAL(*), - * RHS(*),RHSNRM,SCALR,TESTSC,XLAMDA,ZERO - INTEGER IBASIS(*),IBB(*),IMAT(*),IND(*) - LOGICAL CONTIN,USRBAS,COLSCP,CSTSCP,MINPRB,LOPT(8) -C -C***FIRST EXECUTABLE STATEMENT SPINIT - ZERO=0. - ONE=1. - CONTIN=LOPT(1) - USRBAS=LOPT(2) - COLSCP=LOPT(5) - CSTSCP=LOPT(6) - MINPRB=LOPT(7) -C -C SCALE DATA. NORMALIZE BOUNDS. FORM COLUMN CHECK SUMS. - GO TO 30001 -C -C INITIALIZE ACTIVE BASIS MATRIX. -20002 CONTINUE - GO TO 30002 -20003 RETURN -C -C PROCEDURE (SCALE DATA. NORMALIZE BOUNDS. FORM COLUMN CHECK SUMS) -C -C DO COLUMN SCALING IF NOT PROVIDED BY THE USER. -30001 IF (.NOT.(.NOT. COLSCP)) GO TO 20004 - J=1 - N20007=NVARS - GO TO 20008 -20007 J=J+1 -20008 IF ((N20007-J).LT.0) GO TO 20009 - CMAX=ZERO - I=0 -20011 CALL PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,J) - IF (.NOT.(I.EQ.0)) GO TO 20013 - GO TO 20012 -20013 CONTINUE - CMAX=MAX(CMAX,ABS(AIJ)) - GO TO 20011 -20012 IF (.NOT.(CMAX.EQ.ZERO)) GO TO 20016 - CSC(J)=ONE - GO TO 20017 -20016 CSC(J)=ONE/CMAX -20017 CONTINUE - GO TO 20007 -20009 CONTINUE -C -C FORM CHECK SUMS OF COLUMNS. COMPUTE MATRIX NORM OF SCALED MATRIX. -20004 ANORM = ZERO - J=1 - N20019=NVARS - GO TO 20020 -20019 J=J+1 -20020 IF ((N20019-J).LT.0) GO TO 20021 - PRIMAL(J)=ZERO - CSUM = ZERO - I=0 -20023 CALL PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,J) - IF (.NOT.(I.LE.0)) GO TO 20025 - GO TO 20024 -20025 CONTINUE - PRIMAL(J)=PRIMAL(J)+AIJ - CSUM = CSUM+ABS(AIJ) - GO TO 20023 -20024 IF (IND(J).EQ.2) CSC(J)=-CSC(J) - PRIMAL(J)=PRIMAL(J)*CSC(J) - COLNRM(J)=ABS(CSC(J)*CSUM) - ANORM = MAX(ANORM,COLNRM(J)) - GO TO 20019 -C -C IF THE USER HAS NOT PROVIDED COST VECTOR SCALING THEN SCALE IT -C USING THE MAX. NORM OF THE TRANSFORMED COST VECTOR, IF NONZERO. -20021 TESTSC=ZERO - J=1 - N20028=NVARS - GO TO 20029 -20028 J=J+1 -20029 IF ((N20028-J).LT.0) GO TO 20030 - TESTSC=MAX(TESTSC,ABS(CSC(J)*COSTS(J))) - GO TO 20028 -20030 IF (.NOT.(.NOT.CSTSCP)) GO TO 20032 - IF (.NOT.(TESTSC.GT.ZERO)) GO TO 20035 - COSTSC=ONE/TESTSC - GO TO 20036 -20035 COSTSC=ONE -20036 CONTINUE - CONTINUE -20032 XLAMDA=(COSTSC+COSTSC)*TESTSC - IF (XLAMDA.EQ.ZERO) XLAMDA=ONE -C -C IF MAXIMIZATION PROBLEM, THEN CHANGE SIGN OF COSTSC AND LAMDA -C =WEIGHT FOR PENALTY-FEASIBILITY METHOD. - IF (.NOT.(.NOT.MINPRB)) GO TO 20038 - COSTSC=-COSTSC -20038 GO TO 20002 -C:CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (INITIALIZE RHS(*),IBASIS(*), AND IBB(*)) -C -C INITIALLY SET RIGHT-HAND SIDE VECTOR TO ZERO. -30002 CALL SCOPY(MRELAS,ZERO,0,RHS,1) -C -C TRANSLATE RHS ACCORDING TO CLASSIFICATION OF INDEPENDENT VARIABLES - J=1 - N20041=NVARS - GO TO 20042 -20041 J=J+1 -20042 IF ((N20041-J).LT.0) GO TO 20043 - IF (.NOT.(IND(J).EQ.1)) GO TO 20045 - SCALR=-BL(J) - GO TO 20046 -20045 IF (.NOT.(IND(J).EQ.2)) GO TO 10001 - SCALR=-BU(J) - GO TO 20046 -10001 IF (.NOT.(IND(J).EQ.3)) GO TO 10002 - SCALR=-BL(J) - GO TO 20046 -10002 IF (.NOT.(IND(J).EQ.4)) GO TO 10003 - SCALR=ZERO -10003 CONTINUE -20046 CONTINUE - IF (.NOT.(SCALR.NE.ZERO)) GO TO 20048 - I=0 -20051 CALL PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,J) - IF (.NOT.(I.LE.0)) GO TO 20053 - GO TO 20052 -20053 CONTINUE - RHS(I)=SCALR*AIJ+RHS(I) - GO TO 20051 -20052 CONTINUE -20048 CONTINUE - GO TO 20041 -C -C TRANSLATE RHS ACCORDING TO CLASSIFICATION OF DEPENDENT VARIABLES. -20043 I=NVARS+1 - N20056=NVARS+MRELAS - GO TO 20057 -20056 I=I+1 -20057 IF ((N20056-I).LT.0) GO TO 20058 - IF (.NOT.(IND(I).EQ.1)) GO TO 20060 - SCALR=BL(I) - GO TO 20061 -20060 IF (.NOT.(IND(I).EQ.2)) GO TO 10004 - SCALR=BU(I) - GO TO 20061 -10004 IF (.NOT.(IND(I).EQ.3)) GO TO 10005 - SCALR=BL(I) - GO TO 20061 -10005 IF (.NOT.(IND(I).EQ.4)) GO TO 10006 - SCALR=ZERO -10006 CONTINUE -20061 CONTINUE - RHS(I-NVARS)=RHS(I-NVARS)+SCALR - GO TO 20056 -20058 RHSNRM=SASUM(MRELAS,RHS,1) -C -C IF THIS IS NOT A CONTINUATION OR THE USER HAS NOT PROVIDED THE -C INITIAL BASIS, THEN THE INITIAL BASIS IS COMPRISED OF THE -C DEPENDENT VARIABLES. - IF (.NOT.(.NOT.(CONTIN .OR. USRBAS))) GO TO 20063 - J=1 - N20066=MRELAS - GO TO 20067 -20066 J=J+1 -20067 IF ((N20066-J).LT.0) GO TO 20068 - IBASIS(J)=NVARS+J - GO TO 20066 -20068 CONTINUE -C -C DEFINE THE ARRAY IBB(*) -20063 J=1 - N20070=NVARS+MRELAS - GO TO 20071 -20070 J=J+1 -20071 IF ((N20070-J).LT.0) GO TO 20072 - IBB(J)=1 - GO TO 20070 -20072 J=1 - N20074=MRELAS - GO TO 20075 -20074 J=J+1 -20075 IF ((N20074-J).LT.0) GO TO 20076 - IBB(IBASIS(J))=-1 - GO TO 20074 -C -C DEFINE THE REST OF IBASIS(*) -20076 IP=MRELAS - J=1 - N20078=NVARS+MRELAS - GO TO 20079 -20078 J=J+1 -20079 IF ((N20078-J).LT.0) GO TO 20080 - IF (.NOT.(IBB(J).GT.0)) GO TO 20082 - IP=IP+1 - IBASIS(IP)=J -20082 GO TO 20078 -20080 GO TO 20003 - END diff --git a/slatec/splp.f b/slatec/splp.f deleted file mode 100644 index e59880b..0000000 --- a/slatec/splp.f +++ /dev/null @@ -1,1680 +0,0 @@ -*DECK SPLP - SUBROUTINE SPLP (USRMAT, MRELAS, NVARS, COSTS, PRGOPT, DATTRV, BL, - + BU, IND, INFO, PRIMAL, DUALS, IBASIS, WORK, LW, IWORK, LIW) -C***BEGIN PROLOGUE SPLP -C***PURPOSE Solve linear programming problems involving at -C most a few thousand constraints and variables. -C Takes advantage of sparsity in the constraint matrix. -C***LIBRARY SLATEC -C***CATEGORY G2A2 -C***TYPE SINGLE PRECISION (SPLP-S, DSPLP-D) -C***KEYWORDS LINEAR CONSTRAINTS, LINEAR OPTIMIZATION, -C LINEAR PROGRAMMING, LP, SPARSE CONSTRAINTS -C***AUTHOR Hanson, R. J., (SNLA) -C Hiebert, K. L., (SNLA) -C***DESCRIPTION -C -C These are the short usage instructions; for details about -C other features, options and methods for defining the matrix -C A, see the extended usage instructions which are contained in -C the Long Description section below. -C -C |------------| -C |Introduction| -C |------------| -C The subprogram SPLP( ) solves a linear optimization problem. -C The problem statement is as follows -C -C minimize (transpose of costs)*x -C subject to A*x=w. -C -C The entries of the unknowns x and w may have simple lower or -C upper bounds (or both), or be free to take on any value. By -C setting the bounds for x and w, the user is imposing the con- -C straints of the problem. The matrix A has MRELAS rows and -C NVARS columns. The vectors costs, x, and w respectively -C have NVARS, NVARS, and MRELAS number of entries. -C -C The input for the problem includes the problem dimensions, -C MRELAS and NVARS, the array COSTS(*), data for the matrix -C A, and the bound information for the unknowns x and w, BL(*), -C BU(*), and IND(*). Only the nonzero entries of the matrix A -C are passed to SPLP( ). -C -C The output from the problem (when output flag INFO=1) includes -C optimal values for x and w in PRIMAL(*), optimal values for -C dual variables of the equations A*x=w and the simple bounds -C on x in DUALS(*), and the indices of the basic columns, -C IBASIS(*). -C -C |------------------------------| -C |Fortran Declarations Required:| -C |------------------------------| -C -C DIMENSION COSTS(NVARS),PRGOPT(*),DATTRV(*), -C *BL(NVARS+MRELAS),BU(NVARS+MRELAS),IND(NVARS+MRELAS), -C *PRIMAL(NVARS+MRELAS),DUALS(MRELAS+NVARS),IBASIS(NVARS+MRELAS), -C *WORK(LW),IWORK(LIW) -C -C EXTERNAL USRMAT -C -C The dimensions of PRGOPT(*) and DATTRV(*) must be at least 1. -C The exact lengths will be determined by user-required options and -C data transferred to the subprogram USRMAT( ). -C -C The values of LW and LIW, the lengths of the arrays WORK(*) -C and IWORK(*), must satisfy the inequalities -C -C LW .GE. 4*NVARS+ 8*MRELAS+LAMAT+ LBM -C LIW.GE. NVARS+11*MRELAS+LAMAT+2*LBM -C -C It is an error if they do not both satisfy these inequalities. -C (The subprogram will inform the user of the required lengths -C if either LW or LIW is wrong.) The values of LAMAT and LBM -C nominally are -C -C LAMAT=4*NVARS+7 -C and LBM =8*MRELAS -C -C LAMAT determines the length of the sparse matrix storage area. -C The value of LBM determines the amount of storage available -C to decompose and update the active basis matrix. -C -C |------| -C |Input:| -C |------| -C -C MRELAS,NVARS -C ------------ -C These parameters are respectively the number of constraints (the -C linear relations A*x=w that the unknowns x and w are to satisfy) -C and the number of entries in the vector x. Both must be .GE. 1. -C Other values are errors. -C -C COSTS(*) -C -------- -C The NVARS entries of this array are the coefficients of the -C linear objective function. The value COSTS(J) is the -C multiplier for variable J of the unknown vector x. Each -C entry of this array must be defined. -C -C USRMAT -C ------ -C This is the name of a specific subprogram in the SPLP( ) package -C used to define the matrix A. In this usage mode of SPLP( ) -C the user places the nonzero entries of A in the -C array DATTRV(*) as given in the description of that parameter. -C The name USRMAT must appear in a Fortran EXTERNAL statement. -C -C DATTRV(*) -C --------- -C The array DATTRV(*) contains data for the matrix A as follows: -C Each column (numbered J) requires (floating point) data con- -C sisting of the value (-J) followed by pairs of values. Each pair -C consists of the row index immediately followed by the value -C of the matrix at that entry. A value of J=0 signals that there -C are no more columns. The required length of -C DATTRV(*) is 2*no. of nonzeros + NVARS + 1. -C -C BL(*),BU(*),IND(*) -C ------------------ -C The values of IND(*) are input parameters that define -C the form of the bounds for the unknowns x and w. The values for -C the bounds are found in the arrays BL(*) and BU(*) as follows. -C -C For values of J between 1 and NVARS, -C if IND(J)=1, then X(J) .GE. BL(J); BU(J) is not used. -C if IND(J)=2, then X(J) .LE. BU(J); BL(J) is not used. -C if IND(J)=3, then BL(J) .LE. X(J) .LE. BU(J),(BL(J)=BU(J) ok) -C if IND(J)=4, then X(J) is free to have any value, -C and BL(J), BU(J) are not used. -C -C For values of I between NVARS+1 and NVARS+MRELAS, -C if IND(I)=1, then W(I-NVARS) .GE. BL(I); BU(I) is not used. -C if IND(I)=2, then W(I-NVARS) .LE. BU(I); BL(I) is not used. -C if IND(I)=3, then BL(I) .LE. W(I-NVARS) .LE. BU(I), -C (BL(I)=BU(I) is ok). -C if IND(I)=4, then W(I-NVARS) is free to have any value, -C and BL(I), BU(I) are not used. -C -C A value of IND(*) not equal to 1,2,3 or 4 is an error. When -C IND(I)=3, BL(I) must be .LE. BU(I). The condition BL(I).GT. -C BU(I) indicates infeasibility and is an error. -C -C PRGOPT(*) -C --------- -C This array is used to redefine various parameters within SPLP( ). -C Frequently, perhaps most of the time, a user will be satisfied -C and obtain the solutions with no changes to any of these -C parameters. To try this, simply set PRGOPT(1)=1.E0. -C -C For users with more sophisticated needs, SPLP( ) provides several -C options that may be used to take advantage of more detailed -C knowledge of the problem or satisfy other utilitarian needs. -C The complete description of how to use this option array to -C utilize additional subprogram features is found under the -C heading of SPLP( ) Subprogram Options in the Extended -C Usage Instructions. -C -C Briefly, the user should note the following value of the parameter -C KEY and the corresponding task or feature desired before turning -C to that document. -C -C Value Brief Statement of Purpose for Option -C of KEY -C ------ ------------------------------------- -C 50 Change from a minimization problem to a -C maximization problem. -C 51 Change the amount of printed output. -C Normally, no printed output is obtained. -C 52 Redefine the line length and precision used -C for the printed output. -C 53 Redefine the values of LAMAT and LBM that -C were discussed above under the heading -C Fortran Declarations Required. -C 54 Redefine the unit number where pages of the sparse -C data matrix A are stored. Normally, the unit -C number is 1. -C 55 A computation, partially completed, is -C being continued. Read the up-to-date -C partial results from unit number 2. -C 56 Redefine the unit number where the partial results -C are stored. Normally, the unit number is 2. -C 57 Save partial results on unit 2 either after -C maximum iterations or at the optimum. -C 58 Redefine the value for the maximum number of -C iterations. Normally, the maximum number of -C iterations is 3*(NVARS+MRELAS). -C 59 Provide SPLP( ) with a starting (feasible) -C nonsingular basis. Normally, SPLP( ) starts -C with the identity matrix columns corresponding -C to the vector w. -C 60 The user has provided scale factors for the -C columns of A. Normally, SPLP( ) computes scale -C factors that are the reciprocals of the max. norm -C of each column. -C 61 The user has provided a scale factor -C for the vector costs. Normally, SPLP( ) computes -C a scale factor equal to the reciprocal of the -C max. norm of the vector costs after the column -C scaling for the data matrix has been applied. -C 62 Size parameters, namely the smallest and -C largest magnitudes of nonzero entries in -C the matrix A, are provided. Values noted -C outside this range are to be considered errors. -C 63 Redefine the tolerance required in -C evaluating residuals for feasibility. -C Normally, this value is set to RELPR, -C where RELPR = relative precision of the arithmetic. -C 64 Change the criterion for bringing new variables -C into the basis from the steepest edge (best -C local move) to the minimum reduced cost. -C 65 Redefine the value for the number of iterations -C between recalculating the error in the primal -C solution. Normally, this value is equal to ten. -C 66 Perform "partial pricing" on variable selection. -C Redefine the value for the number of negative -C reduced costs to compute (at most) when finding -C a variable to enter the basis. Normally this -C value is set to NVARS. This implies that no -C "partial pricing" is used. -C 67 Adjust the tuning factor (normally one) to apply -C to the primal and dual error estimates. -C 68 Pass information to the subprogram FULMAT(), -C provided with the SPLP() package, so that a Fortran -C two-dimensional array can be used as the argument -C DATTRV(*). -C 69 Pass an absolute tolerance to use for the feasibility -C test when the usual relative error test indicates -C infeasibility. The nominal value of this tolerance, -C TOLABS, is zero. -C -C -C |---------------| -C |Working Arrays:| -C |---------------| -C -C WORK(*),LW, -C IWORK(*),LIW -C ------------ -C The arrays WORK(*) and IWORK(*) are respectively floating point -C and type INTEGER working arrays for SPLP( ) and its -C subprograms. The lengths of these arrays are respectively -C LW and LIW. These parameters must satisfy the inequalities -C noted above under the heading "Fortran Declarations Required:" -C It is an error if either value is too small. -C -C |----------------------------| -C |Input/Output files required:| -C |----------------------------| -C -C Fortran unit 1 is used by SPLP( ) to store the sparse matrix A -C out of high-speed memory. A crude -C upper bound for the amount of information written on unit 1 -C is 6*nz, where nz is the number of nonzero entries in A. -C -C |-------| -C |Output:| -C |-------| -C -C INFO,PRIMAL(*),DUALS(*) -C ----------------------- -C The integer flag INFO indicates why SPLP( ) has returned to the -C user. If INFO=1 the solution has been computed. In this case -C X(J)=PRIMAL(J) and W(I)=PRIMAL(I+NVARS). The dual variables -C for the equations A*x=w are in the array DUALS(I)=dual for -C equation number I. The dual value for the component X(J) that -C has an upper or lower bound (or both) is returned in -C DUALS(J+MRELAS). The only other values for INFO are .LT. 0. -C The meaning of these values can be found by reading -C the diagnostic message in the output file, or by looking for -C error number = (-INFO) in the Extended Usage Instructions -C under the heading: -C -C List of SPLP( ) Error and Diagnostic Messages. -C -C BL(*),BU(*),IND(*) -C ------------------ -C These arrays are output parameters only under the (unusual) -C circumstances where the stated problem is infeasible, has an -C unbounded optimum value, or both. These respective conditions -C correspond to INFO=-1,-2 or -3. See the Extended -C Usage Instructions for further details. -C -C IBASIS(I),I=1,...,MRELAS -C ------------------------ -C This array contains the indices of the variables that are -C in the active basis set at the solution (INFO=1). A value -C of IBASIS(I) between 1 and NVARS corresponds to the variable -C X(IBASIS(I)). A value of IBASIS(I) between NVARS+1 and NVARS+ -C MRELAS corresponds to the variable W(IBASIS(I)-NVARS). -C -C *Long Description: -C -C SUBROUTINE SPLP(USRMAT,MRELAS,NVARS,COSTS,PRGOPT,DATTRV, -C * BL,BU,IND,INFO,PRIMAL,DUALS,IBASIS,WORK,LW,IWORK,LIW) -C -C |------------| -C |Introduction| -C |------------| -C The subprogram SPLP( ) solves a linear optimization problem. -C The problem statement is as follows -C -C minimize (transpose of costs)*x -C subject to A*x=w. -C -C The entries of the unknowns x and w may have simple lower or -C upper bounds (or both), or be free to take on any value. By -C setting the bounds for x and w, the user is imposing the con- -C straints of the problem. -C -C (The problem may also be stated as a maximization -C problem. This is done by means of input in the option array -C PRGOPT(*).) The matrix A has MRELAS rows and NVARS columns. The -C vectors costs, x, and w respectively have NVARS, NVARS, and -C MRELAS number of entries. -C -C The input for the problem includes the problem dimensions, -C MRELAS and NVARS, the array COSTS(*), data for the matrix -C A, and the bound information for the unknowns x and w, BL(*), -C BU(*), and IND(*). -C -C The output from the problem (when output flag INFO=1) includes -C optimal values for x and w in PRIMAL(*), optimal values for -C dual variables of the equations A*x=w and the simple bounds -C on x in DUALS(*), and the indices of the basic columns in -C IBASIS(*). -C -C |------------------------------| -C |Fortran Declarations Required:| -C |------------------------------| -C -C DIMENSION COSTS(NVARS),PRGOPT(*),DATTRV(*), -C *BL(NVARS+MRELAS),BU(NVARS+MRELAS),IND(NVARS+MRELAS), -C *PRIMAL(NVARS+MRELAS),DUALS(MRELAS+NVARS),IBASIS(NVARS+MRELAS), -C *WORK(LW),IWORK(LIW) -C -C EXTERNAL USRMAT (or 'NAME', if user provides the subprogram) -C -C The dimensions of PRGOPT(*) and DATTRV(*) must be at least 1. -C The exact lengths will be determined by user-required options and -C data transferred to the subprogram USRMAT( ) ( or 'NAME'). -C -C The values of LW and LIW, the lengths of the arrays WORK(*) -C and IWORK(*), must satisfy the inequalities -C -C LW .GE. 4*NVARS+ 8*MRELAS+LAMAT+ LBM -C LIW.GE. NVARS+11*MRELAS+LAMAT+2*LBM -C -C It is an error if they do not both satisfy these inequalities. -C (The subprogram will inform the user of the required lengths -C if either LW or LIW is wrong.) The values of LAMAT and LBM -C nominally are -C -C LAMAT=4*NVARS+7 -C and LBM =8*MRELAS -C -C These values will be as shown unless the user changes them by -C means of input in the option array PRGOPT(*). The value of LAMAT -C determines the length of the sparse matrix "staging" area. -C For reasons of efficiency the user may want to increase the value -C of LAMAT. The value of LBM determines the amount of storage -C available to decompose and update the active basis matrix. -C Due to exhausting the working space because of fill-in, -C it may be necessary for the user to increase the value of LBM. -C (If this situation occurs an informative diagnostic is printed -C and a value of INFO=-28 is obtained as an output parameter.) -C -C |------| -C |Input:| -C |------| -C -C MRELAS,NVARS -C ------------ -C These parameters are respectively the number of constraints (the -C linear relations A*x=w that the unknowns x and w are to satisfy) -C and the number of entries in the vector x. Both must be .GE. 1. -C Other values are errors. -C -C COSTS(*) -C -------- -C The NVARS entries of this array are the coefficients of the -C linear objective function. The value COSTS(J) is the -C multiplier for variable J of the unknown vector x. Each -C entry of this array must be defined. This array can be changed -C by the user between restarts. See options with KEY=55,57 for -C details of checkpointing and restarting. -C -C USRMAT -C ------ -C This is the name of a specific subprogram in the SPLP( ) package -C that is used to define the matrix entries when this data is passed -C to SPLP( ) as a linear array. In this usage mode of SPLP( ) -C the user gives information about the nonzero entries of A -C in DATTRV(*) as given under the description of that parameter. -C The name USRMAT must appear in a Fortran EXTERNAL statement. -C Users who are passing the matrix data with USRMAT( ) can skip -C directly to the description of the input parameter DATTRV(*). -C Also see option 68 for passing the constraint matrix data using -C a standard Fortran two-dimensional array. -C -C If the user chooses to provide a subprogram 'NAME'( ) to -C define the matrix A, then DATTRV(*) may be used to pass floating -C point data from the user's program unit to the subprogram -C 'NAME'( ). The content of DATTRV(*) is not changed in any way. -C -C The subprogram 'NAME'( ) can be of the user's choice -C but it must meet Fortran standards and it must appear in a -C Fortran EXTERNAL statement. The first statement of the subprogram -C has the form -C -C SUBROUTINE 'NAME'(I,J,AIJ, INDCAT, PRGOPT, DATTRV, IFLAG) -C -C The variables I,J, INDCAT, IFLAG(10) are type INTEGER, -C while AIJ, PRGOPT(*),DATTRV(*) are type REAL. -C -C The user interacts with the contents of IFLAG(*) to -C direct the appropriate action. The algorithmic steps are -C as follows. -C -C Test IFLAG(1). -C -C IF(IFLAG(1).EQ.1) THEN -C -C Initialize the necessary pointers and data -C for defining the matrix A. The contents -C of IFLAG(K), K=2,...,10, may be used for -C storage of the pointers. This array remains intact -C between calls to 'NAME'( ) by SPLP( ). -C RETURN -C -C END IF -C -C IF(IFLAG(1).EQ.2) THEN -C -C Define one set of values for I,J,AIJ, and INDCAT. -C Each nonzero entry of A must be defined this way. -C These values can be defined in any convenient order. -C (It is most efficient to define the data by -C columns in the order 1,...,NVARS; within each -C column define the entries in the order 1,...,MRELAS.) -C If this is the last matrix value to be -C defined or updated, then set IFLAG(1)=3. -C (When I and J are positive and respectively no larger -C than MRELAS and NVARS, the value of AIJ is used to -C define (or update) row I and column J of A.) -C RETURN -C -C END IF -C -C END -C -C Remarks: The values of I and J are the row and column -C indices for the nonzero entries of the matrix A. -C The value of this entry is AIJ. -C Set INDCAT=0 if this value defines that entry. -C Set INDCAT=1 if this entry is to be updated, -C new entry=old entry+AIJ. -C A value of I not between 1 and MRELAS, a value of J -C not between 1 and NVARS, or a value of INDCAT -C not equal to 0 or 1 are each errors. -C -C The contents of IFLAG(K), K=2,...,10, can be used to -C remember the status (of the process of defining the -C matrix entries) between calls to 'NAME'( ) by SPLP( ). -C On entry to 'NAME'( ), only the values 1 or 2 will be -C in IFLAG(1). More than 2*NVARS*MRELAS definitions of -C the matrix elements is considered an error because -C it suggests an infinite loop in the user-written -C subprogram 'NAME'( ). Any matrix element not -C provided by 'NAME'( ) is defined to be zero. -C -C The REAL arrays PRGOPT(*) and DATTRV(*) are passed as -C arguments directly from SPLP( ) to 'NAME'( ). -C The array PRGOPT(*) contains any user-defined program -C options. In this usage mode the array DATTRV(*) may -C now contain any (type REAL) data that the user needs -C to define the matrix A. Both arrays PRGOPT(*) and -C DATTRV(*) remain intact between calls to 'NAME'( ) -C by SPLP( ). -C Here is a subprogram that communicates the matrix values for A, -C as represented in DATTRV(*), to SPLP( ). This subprogram, -C called USRMAT( ), is included as part of the SPLP( ) package. -C This subprogram 'decodes' the array DATTRV(*) and defines the -C nonzero entries of the matrix A for SPLP( ) to store. This -C listing is presented here as a guide and example -C for the users who find it necessary to write their own subroutine -C for this purpose. The contents of DATTRV(*) are given below in -C the description of that parameter. -C -C SUBROUTINE USRMAT(I,J,AIJ, INDCAT,PRGOPT,DATTRV,IFLAG) -C DIMENSION PRGOPT(*),DATTRV(*),IFLAG(10) -C -C IF(IFLAG(1).EQ.1) THEN -C -C THIS IS THE INITIALIZATION STEP. THE VALUES OF IFLAG(K),K=2,3,4, -C ARE RESPECTIVELY THE COLUMN INDEX, THE ROW INDEX (OR THE NEXT COL. -C INDEX), AND THE POINTER TO THE MATRIX ENTRY'S VALUE WITHIN -C DATTRV(*). ALSO CHECK (DATTRV(1)=0.) SIGNIFYING NO DATA. -C IF(DATTRV(1).EQ.0.) THEN -C I = 0 -C J = 0 -C IFLAG(1) = 3 -C ELSE -C IFLAG(2)=-DATTRV(1) -C IFLAG(3)= DATTRV(2) -C IFLAG(4)= 3 -C END IF -C -C RETURN -C ELSE -C J=IFLAG(2) -C I=IFLAG(3) -C L=IFLAG(4) -C IF(I.EQ.0) THEN -C -C SIGNAL THAT ALL OF THE NONZERO ENTRIES HAVE BEEN DEFINED. -C IFLAG(1)=3 -C RETURN -C ELSE IF(I.LT.0) THEN -C -C SIGNAL THAT A SWITCH IS MADE TO A NEW COLUMN. -C J=-I -C I=DATTRV(L) -C L=L+1 -C END IF -C -C AIJ=DATTRV(L) -C -C UPDATE THE INDICES AND POINTERS FOR THE NEXT ENTRY. -C IFLAG(2)=J -C IFLAG(3)=DATTRV(L+1) -C IFLAG(4)=L+2 -C -C INDCAT=0 DENOTES THAT ENTRIES OF THE MATRIX ARE ASSIGNED THE -C VALUES FROM DATTRV(*). NO ACCUMULATION IS PERFORMED. -C INDCAT=0 -C RETURN -C END IF -C END -C -C DATTRV(*) -C --------- -C If the user chooses to use the provided subprogram USRMAT( ) then -C the array DATTRV(*) contains data for the matrix A as follows: -C Each column (numbered J) requires (floating point) data con- -C sisting of the value (-J) followed by pairs of values. Each pair -C consists of the row index immediately followed by the value -C of the matrix at that entry. A value of J=0 signals that there -C are no more columns. (See "Example of SPLP( ) Usage," below.) -C The dimension of DATTRV(*) must be 2*no. of nonzeros -C + NVARS + 1 in this usage. No checking of the array -C length is done by the subprogram package. -C -C If the Save/Restore feature is in use (see options with -C KEY=55,57 for details of checkpointing and restarting) -C USRMAT( ) can be used to redefine entries of the matrix. -C The matrix entries are redefined or overwritten. No accum- -C ulation is performed. -C Any other nonzero entry of A, defined in a previous call to -C SPLP( ), remain intact. -C -C BL(*),BU(*),IND(*) -C ------------------ -C The values of IND(*) are input parameters that define -C the form of the bounds for the unknowns x and w. The values for -C the bounds are found in the arrays BL(*) and BU(*) as follows. -C -C For values of J between 1 and NVARS, -C if IND(J)=1, then X(J) .GE. BL(J); BU(J) is not used. -C if IND(J)=2, then X(J) .LE. BU(J); BL(J) is not used. -C if IND(J)=3, then BL(J) .LE. X(J) .LE. BU(J),(BL(J)=BU(J) ok) -C if IND(J)=4, then X(J) is free to have any value, -C and BL(J), BU(J) are not used. -C -C For values of I between NVARS+1 and NVARS+MRELAS, -C if IND(I)=1, then W(I-NVARS) .GE. BL(I); BU(I) is not used. -C if IND(I)=2, then W(I-NVARS) .LE. BU(I); BL(I) is not used. -C if IND(I)=3, then BL(I) .LE. W(I-NVARS) .LE. BU(I), -C (BL(I)=BU(I) is ok). -C if IND(I)=4, then W(I-NVARS) is free to have any value, -C and BL(I), BU(I) are not used. -C -C A value of IND(*) not equal to 1,2,3 or 4 is an error. When -C IND(I)=3, BL(I) must be .LE. BU(I). The condition BL(I).GT. -C BU(I) indicates infeasibility and is an error. These -C arrays can be changed by the user between restarts. See -C options with KEY=55,57 for details of checkpointing and -C restarting. -C -C PRGOPT(*) -C --------- -C This array is used to redefine various parameters within SPLP( ). -C Frequently, perhaps most of the time, a user will be satisfied -C and obtain the solutions with no changes to any of these -C parameters. To try this, simply set PRGOPT(1)=1.E0. -C -C For users with more sophisticated needs, SPLP( ) provides several -C options that may be used to take advantage of more detailed -C knowledge of the problem or satisfy other utilitarian needs. -C The complete description of how to use this option array to -C utilize additional subprogram features is found under the -C heading "Usage of SPLP( ) Subprogram Options." -C -C Briefly, the user should note the following value of the parameter -C KEY and the corresponding task or feature desired before turning -C to that section. -C -C Value Brief Statement of Purpose for Option -C of KEY -C ------ ------------------------------------- -C 50 Change from a minimization problem to a -C maximization problem. -C 51 Change the amount of printed output. -C Normally, no printed output is obtained. -C 52 Redefine the line length and precision used -C for the printed output. -C 53 Redefine the values of LAMAT and LBM that -C were discussed above under the heading -C Fortran Declarations Required. -C 54 Redefine the unit number where pages of the sparse -C data matrix A are stored. Normally, the unit -C number is 1. -C 55 A computation, partially completed, is -C being continued. Read the up-to-date -C partial results from unit number 2. -C 56 Redefine the unit number where the partial results -C are stored. Normally, the unit number is 2. -C 57 Save partial results on unit 2 either after -C maximum iterations or at the optimum. -C 58 Redefine the value for the maximum number of -C iterations. Normally, the maximum number of -C iterations is 3*(NVARS+MRELAS). -C 59 Provide SPLP( ) with a starting (feasible) -C nonsingular basis. Normally, SPLP( ) starts -C with the identity matrix columns corresponding -C to the vector w. -C 60 The user has provided scale factors for the -C columns of A. Normally, SPLP( ) computes scale -C factors that are the reciprocals of the max. norm -C of each column. -C 61 The user has provided a scale factor -C for the vector costs. Normally, SPLP( ) computes -C a scale factor equal to the reciprocal of the -C max. norm of the vector costs after the column -C scaling for the data matrix has been applied. -C 62 Size parameters, namely the smallest and -C largest magnitudes of nonzero entries in -C the matrix A, are provided. Values noted -C outside this range are to be considered errors. -C 63 Redefine the tolerance required in -C evaluating residuals for feasibility. -C Normally, this value is set to the value RELPR, -C where RELPR = relative precision of the arithmetic. -C 64 Change the criterion for bringing new variables -C into the basis from the steepest edge (best -C local move) to the minimum reduced cost. -C 65 Redefine the value for the number of iterations -C between recalculating the error in the primal -C solution. Normally, this value is equal to ten. -C 66 Perform "partial pricing" on variable selection. -C Redefine the value for the number of negative -C reduced costs to compute (at most) when finding -C a variable to enter the basis. Normally this -C value is set to NVARS. This implies that no -C "partial pricing" is used. -C 67 Adjust the tuning factor (normally one) to apply -C to the primal and dual error estimates. -C 68 Pass information to the subprogram FULMAT(), -C provided with the SPLP() package, so that a Fortran -C two-dimensional array can be used as the argument -C DATTRV(*). -C 69 Pass an absolute tolerance to use for the feasibility -C test when the usual relative error test indicates -C infeasibility. The nominal value of this tolerance, -C TOLABS, is zero. -C -C -C |---------------| -C |Working Arrays:| -C |---------------| -C -C WORK(*),LW, -C IWORK(*),LIW -C ------------ -C The arrays WORK(*) and IWORK(*) are respectively floating point -C and type INTEGER working arrays for SPLP( ) and its -C subprograms. The lengths of these arrays are respectively -C LW and LIW. These parameters must satisfy the inequalities -C noted above under the heading "Fortran Declarations Required." -C It is an error if either value is too small. -C -C |----------------------------| -C |Input/Output files required:| -C |----------------------------| -C -C Fortran unit 1 is used by SPLP( ) to store the sparse matrix A -C out of high-speed memory. This direct access file is opened -C within the package under the following two conditions. -C 1. When the Save/Restore feature is used. 2. When the -C constraint matrix is so large that storage out of high-speed -C memory is required. The user may need to close unit 1 -C (with deletion from the job step) in the main program unit -C when several calls are made to SPLP( ). A crude -C upper bound for the amount of information written on unit 1 -C is 6*nz, where nz is the number of nonzero entries in A. -C The unit number may be redefined to any other positive value -C by means of input in the option array PRGOPT(*). -C -C Fortran unit 2 is used by SPLP( ) only when the Save/Restore -C feature is desired. Normally this feature is not used. It is -C activated by means of input in the option array PRGOPT(*). -C On some computer systems the user may need to open unit -C 2 before executing a call to SPLP( ). This file is type -C sequential and is unformatted. -C -C Fortran unit=I1MACH(2) (check local setting) is used by SPLP( ) -C when the printed output feature (KEY=51) is used. Normally -C this feature is not used. It is activated by input in the -C options array PRGOPT(*). For many computer systems I1MACH(2)=6. -C -C |-------| -C |Output:| -C |-------| -C -C INFO,PRIMAL(*),DUALS(*) -C ----------------------- -C The integer flag INFO indicates why SPLP( ) has returned to the -C user. If INFO=1 the solution has been computed. In this case -C X(J)=PRIMAL(J) and W(I)=PRIMAL(I+NVARS). The dual variables -C for the equations A*x=w are in the array DUALS(I)=dual for -C equation number I. The dual value for the component X(J) that -C has an upper or lower bound (or both) is returned in -C DUALS(J+MRELAS). The only other values for INFO are .LT. 0. -C The meaning of these values can be found by reading -C the diagnostic message in the output file, or by looking for -C error number = (-INFO) under the heading "List of SPLP( ) Error -C and Diagnostic Messages." -C The diagnostic messages are printed using the error processing -C subprogram XERMSG( ) with error category LEVEL=1. -C See the document "Brief Instr. for Using the Sandia Math. -C Subroutine Library," SAND79-2382, Nov., 1980, for further inform- -C ation about resetting the usual response to a diagnostic message. -C -C BL(*),BU(*),IND(*) -C ------------------ -C These arrays are output parameters only under the (unusual) -C circumstances where the stated problem is infeasible, has an -C unbounded optimum value, or both. These respective conditions -C correspond to INFO=-1,-2 or -3. For INFO=-1 or -3 certain comp- -C onents of the vectors x or w will not satisfy the input bounds. -C If component J of X or component I of W does not satisfy its input -C bound because of infeasibility, then IND(J)=-4 or IND(I+NVARS)=-4, -C respectively. For INFO=-2 or -3 certain -C components of the vector x could not be used as basic variables -C because the objective function would have become unbounded. -C In particular if component J of x corresponds to such a variable, -C then IND(J)=-3. Further, if the input value of IND(J) -C =1, then BU(J)=BL(J); -C =2, then BL(J)=BU(J); -C =4, then BL(J)=0.,BU(J)=0. -C -C (The J-th variable in x has been restricted to an appropriate -C feasible value.) -C The negative output value for IND(*) allows the user to identify -C those constraints that are not satisfied or those variables that -C would cause unbounded values of the objective function. Note -C that the absolute value of IND(*), together with BL(*) and BU(*), -C are valid input to SPLP( ). In the case of infeasibility the -C sum of magnitudes of the infeasible values is minimized. Thus -C one could reenter SPLP( ) with these components of x or w now -C fixed at their present values. This involves setting -C the appropriate components of IND(*) = 3, and BL(*) = BU(*). -C -C IBASIS(I),I=1,...,MRELAS -C ------------------------ -C This array contains the indices of the variables that are -C in the active basis set at the solution (INFO=1). A value -C of IBASIS(I) between 1 and NVARS corresponds to the variable -C X(IBASIS(I)). A value of IBASIS(I) between NVARS+1 and NVARS+ -C MRELAS corresponds to the variable W(IBASIS(I)-NVARS). -C -C Computing with the Matrix A after Calling SPLP( ) -C ------------------------------------------------- -C Following the return from SPLP( ), nonzero entries of the MRELAS -C by NVARS matrix A are available for usage by the user. The method -C for obtaining the next nonzero in column J with a row index -C strictly greater than I in value, is completed by executing -C -C CALL PNNZRS(I,AIJ,IPLACE,WORK,IWORK,J) -C -C The value of I is also an output parameter. If I.LE.0 on output, -C then there are no more nonzeroes in column J. If I.GT.0, the -C output value for component number I of column J is in AIJ. The -C parameters WORK(*) and IWORK(*) are the same arguments as in the -C call to SPLP( ). The parameter IPLACE is a single INTEGER -C working variable. -C -C The data structure used for storage of the matrix A within SPLP( ) -C corresponds to sequential storage by columns as defined in -C SAND78-0785. Note that the names of the subprograms LNNZRS(), -C LCHNGS(),LINITM(),LLOC(),LRWPGE(), and LRWVIR() have been -C changed to PNNZRS(),PCHNGS(),PINITM(),IPLOC(),PRWPGE(), and -C PRWVIR() respectively. The error processing subprogram LERROR() -C is no longer used; XERMSG() is used instead. -C -C |-------------------------------| -C |Subprograms Required by SPLP( )| -C |-------------------------------| -C Called by SPLP() are SPLPMN(),SPLPUP(),SPINIT(),SPOPT(), -C SPLPDM(),SPLPCE(),SPINCW(),SPLPFL(), -C SPLPFE(),SPLPMU(). -C -C Error Processing Subprograms XERMSG(),I1MACH(),R1MACH() -C -C Sparse Matrix Subprograms PNNZRS(),PCHNGS(),PRWPGE(),PRWVIR(), -C PINITM(),IPLOC() -C -C Mass Storage File Subprograms SOPENM(),SCLOSM(),SREADP(),SWRITP() -C -C Basic Linear Algebra Subprograms SCOPY(),SASUM(),SDOT() -C -C Sparse Matrix Basis Handling Subprograms LA05AS(),LA05BS(), -C LA05CS(),LA05ED(),MC20AS() -C -C Vector Output Subprograms SVOUT(),IVOUT() -C -C Machine-sensitive Subprograms I1MACH( ),R1MACH( ), -C SOPENM(),SCLOSM(),SREADP(),SWRITP(). -C COMMON Block Used -C ----------------- -C /LA05DS/ SMALL,LP,LENL,LENU,NCP,LROW,LCOL -C See the document AERE-R8269 for further details. -C |------------------------| -C |Example of SPLP( ) Usage| -C |------------------------| -C PROGRAM LPEX -C THE OPTIMIZATION PROBLEM IS TO FIND X1, X2, X3 THAT -C MINIMIZE X1 + X2 + X3, X1.GE.0, X2.GE.0, X3 UNCONSTRAINED. -C -C THE UNKNOWNS X1,X2,X3 ARE TO SATISFY CONSTRAINTS -C -C X1 -3*X2 +4*X3 = 5 -C X1 -2*X2 .LE.3 -C 2*X2 - X3.GE.4 -C -C WE FIRST DEFINE THE DEPENDENT VARIABLES -C W1=X1 -3*X2 +4*X3 -C W2=X1- 2*X2 -C W3= 2*X2 -X3 -C -C WE NOW SHOW HOW TO USE SPLP( ) TO SOLVE THIS LINEAR OPTIMIZATION -C PROBLEM. EACH REQUIRED STEP WILL BE SHOWN IN THIS EXAMPLE. -C DIMENSION COSTS(03),PRGOPT(01),DATTRV(18),BL(06),BU(06),IND(06), -C *PRIMAL(06),DUALS(06),IBASIS(06),WORK(079),IWORK(103) -C -C EXTERNAL USRMAT -C MRELAS=3 -C NVARS=3 -C -C DEFINE THE ARRAY COSTS(*) FOR THE OBJECTIVE FUNCTION. -C COSTS(01)=1. -C COSTS(02)=1. -C COSTS(03)=1. -C -C PLACE THE NONZERO INFORMATION ABOUT THE MATRIX IN DATTRV(*). -C DEFINE COL. 1: -C DATTRV(01)=-1 -C DATTRV(02)=1 -C DATTRV(03)=1. -C DATTRV(04)=2 -C DATTRV(05)=1. -C -C DEFINE COL. 2: -C DATTRV(06)=-2 -C DATTRV(07)=1 -C DATTRV(08)=-3. -C DATTRV(09)=2 -C DATTRV(10)=-2. -C DATTRV(11)=3 -C DATTRV(12)=2. -C -C DEFINE COL. 3: -C DATTRV(13)=-3 -C DATTRV(14)=1 -C DATTRV(15)=4. -C DATTRV(16)=3 -C DATTRV(17)=-1. -C -C DATTRV(18)=0 -C -C CONSTRAIN X1,X2 TO BE NONNEGATIVE. LET X3 HAVE NO BOUNDS. -C BL(1)=0. -C IND(1)=1 -C BL(2)=0. -C IND(2)=1 -C IND(3)=4 -C -C CONSTRAIN W1=5,W2.LE.3, AND W3.GE.4. -C BL(4)=5. -C BU(4)=5. -C IND(4)=3 -C BU(5)=3. -C IND(5)=2 -C BL(6)=4. -C IND(6)=1 -C -C INDICATE THAT NO MODIFICATIONS TO OPTIONS ARE IN USE. -C PRGOPT(01)=1 -C -C DEFINE THE WORKING ARRAY LENGTHS. -C LW=079 -C LIW=103 -C CALL SPLP(USRMAT,MRELAS,NVARS,COSTS,PRGOPT,DATTRV, -C *BL,BU,IND,INFO,PRIMAL,DUALS,IBASIS,WORK,LW,IWORK,LIW) -C -C CALCULATE VAL, THE MINIMAL VALUE OF THE OBJECTIVE FUNCTION. -C VAL=SDOT(NVARS,COSTS,1,PRIMAL,1) -C -C STOP -C END -C |------------------------| -C |End of Example of Usage | -C |------------------------| -C -C |------------------------------------| -C |Usage of SPLP( ) Subprogram Options.| -C |------------------------------------| -C -C Users frequently have a large variety of requirements for linear -C optimization software. Allowing for these varied requirements -C is at cross purposes with the desire to keep the usage of SPLP( ) -C as simple as possible. One solution to this dilemma is as follows. -C (1) Provide a version of SPLP( ) that solves a wide class of -C problems and is easy to use. (2) Identify parameters within SPLP() -C that certain users may want to change. (3) Provide a means -C of changing any selected number of these parameters that does -C not require changing all of them. -C -C Changing selected parameters is done by requiring -C that the user provide an option array, PRGOPT(*), to SPLP( ). -C The contents of PRGOPT(*) inform SPLP( ) of just those options -C that are going to be modified within the total set of possible -C parameters that can be modified. The array PRGOPT(*) is a linked -C list consisting of groups of data of the following form -C -C LINK -C KEY -C SWITCH -C data set -C -C that describe the desired options. The parameters LINK, KEY and -C switch are each one word and are always required. The data set -C can be comprised of several words or can be empty. The number of -C words in the data set for each option depends on the value of -C the parameter KEY. -C -C The value of LINK points to the first entry of the next group -C of data within PRGOPT(*). The exception is when there are no more -C options to change. In that case, LINK=1 and the values for KEY, -C SWITCH and data set are not referenced. The general layout of -C PRGOPT(*) is as follows: -C ...PRGOPT(1)=LINK1 (link to first entry of next group) -C . PRGOPT(2)=KEY1 (KEY to the option change) -C . PRGOPT(3)=SWITCH1 (on/off switch for the option) -C . PRGOPT(4)=data value -C . . -C . . -C . . -C ...PRGOPT(LINK1)=LINK2 (link to first entry of next group) -C . PRGOPT(LINK1+1)=KEY2 (KEY to option change) -C . PRGOPT(LINK1+2)=SWITCH2 (on/off switch for the option) -C . PRGOPT(LINK1+3)=data value -C ... . -C . . -C . . -C ...PRGOPT(LINK)=1 (no more options to change) -C -C A value of LINK that is .LE.0 or .GT. 10000 is an error. -C In this case SPLP( ) returns with an error message, INFO=-14. -C This helps prevent using invalid but positive values of LINK that -C will probably extend beyond the program limits of PRGOPT(*). -C Unrecognized values of KEY are ignored. If the value of SWITCH is -C zero then the option is turned off. For any other value of SWITCH -C the option is turned on. This is used to allow easy changing of -C options without rewriting PRGOPT(*). The order of the options is -C arbitrary and any number of options can be changed with the -C following restriction. To prevent cycling in processing of the -C option array PRGOPT(*), a count of the number of options changed -C is maintained. Whenever this count exceeds 1000 an error message -C (INFO=-15) is printed and the subprogram returns. -C -C In the following description of the options, the value of -C LATP indicates the amount of additional storage that a particular -C option requires. The sum of all of these values (plus one) is -C the minimum dimension for the array PRGOPT(*). -C -C If a user is satisfied with the nominal form of SPLP( ), -C set PRGOPT(1)=1 (or PRGOPT(1)=1.E0). -C -C Options: -C -C -----KEY = 50. Change from a minimization problem to a maximization -C problem. -C If SWITCH=0 option is off; solve minimization problem. -C =1 option is on; solve maximization problem. -C data set =empty -C LATP=3 -C -C -----KEY = 51. Change the amount of printed output. The nominal form -C of SPLP( ) has no printed output. -C The first level of output (SWITCH=1) includes -C -C (1) Minimum dimensions for the arrays COSTS(*),BL(*),BU(*),IND(*), -C PRIMAL(*),DUALS(*),IBASIS(*), and PRGOPT(*). -C (2) Problem dimensions MRELAS,NVARS. -C (3) The types of and values for the bounds on x and w, -C and the values of the components of the vector costs. -C (4) Whether optimization problem is minimization or -C maximization. -C (5) Whether steepest edge or smallest reduced cost criteria used -C for exchanging variables in the revised simplex method. -C -C Whenever a solution has been found, (INFO=1), -C -C (6) the value of the objective function, -C (7) the values of the vectors x and w, -C (8) the dual variables for the constraints A*x=w and the -C bounded components of x, -C (9) the indices of the basic variables, -C (10) the number of revised simplex method iterations, -C (11) the number of full decompositions of the basis matrix. -C -C The second level of output (SWITCH=2) includes all for SWITCH=1 -C plus -C -C (12) the iteration number, -C (13) the column number to enter the basis, -C (14) the column number to leave the basis, -C (15) the length of the step taken. -C -C The third level of output (SWITCH=3) includes all for SWITCH=2 -C plus -C (16) critical quantities required in the revised simplex method. -C This output is rather voluminous. It is intended to be used -C as a diagnostic tool in case of a failure in SPLP( ). -C -C If SWITCH=0 option is off; no printed output. -C =1 summary output. -C =2 lots of output. -C =3 even more output. -C data set =empty -C LATP=3 -C -C -----KEY = 52. Redefine the parameter, IDIGIT, which determines the -C format and precision used for the printed output. In the printed -C output, at least ABS(IDIGIT) decimal digits per number is printed. -C If IDIGIT.LT.0, 72 printing columns are used. IF IDIGIT.GT.0, 133 -C printing columns are used. -C If SWITCH=0 option is off; IDIGIT=-4. -C =1 option is on. -C data set =IDIGIT -C LATP=4 -C -C -----KEY = 53. Redefine LAMAT and LBM, the lengths of the portions of -C WORK(*) and IWORK(*) that are allocated to the sparse matrix -C storage and the sparse linear equation solver, respectively. -C LAMAT must be .GE. NVARS+7 and LBM must be positive. -C If SWITCH=0 option is off; LAMAT=4*NVARS+7 -C LBM =8*MRELAS. -C =1 option is on. -C data set =LAMAT -C LBM -C LATP=5 -C -C -----KEY = 54. Redefine IPAGEF, the file number where the pages of the -C sparse data matrix are stored. IPAGEF must be positive and -C different from ISAVE (see option 56). -C If SWITCH=0 option is off; IPAGEF=1. -C =1 option is on. -C data set =IPAGEF -C LATP=4 -C -C -----KEY = 55. Partial results have been computed and stored on unit -C number ISAVE (see option 56), during a previous run of -C SPLP( ). This is a continuation from these partial results. -C The arrays COSTS(*),BL(*),BU(*),IND(*) do not have to have -C the same values as they did when the checkpointing occurred. -C This feature makes it possible for the user to do certain -C types of parameter studies such as changing costs and varying -C the constraints of the problem. This file is rewound both be- -C fore and after reading the partial results. -C If SWITCH=0 option is off; start a new problem. -C =1 option is on; continue from partial results -C that are stored in file ISAVE. -C data set = empty -C LATP=3 -C -C -----KEY = 56. Redefine ISAVE, the file number where the partial -C results are stored (see option 57). ISAVE must be positive and -C different from IPAGEF (see option 54). -C If SWITCH=0 option is off; ISAVE=2. -C =1 option is on. -C data set =ISAVE -C LATP=4 -C -C -----KEY = 57. Save the partial results after maximum number of -C iterations, MAXITR, or at the optimum. When this option is on, -C data essential to continuing the calculation is saved on a file -C using a Fortran binary write operation. The data saved includes -C all the information about the sparse data matrix A. Also saved -C is information about the current basis. Nominally the partial -C results are saved on Fortran unit 2. This unit number can be -C redefined (see option 56). If the save option is on, -C this file must be opened (or declared) by the user prior to the -C call to SPLP( ). A crude upper bound for the number of words -C written to this file is 6*nz. Here nz= number of nonzeros in A. -C If SWITCH=0 option is off; do not save partial results. -C =1 option is on; save partial results. -C data set = empty -C LATP=3 -C -C -----KEY = 58. Redefine the maximum number of iterations, MAXITR, to -C be taken before returning to the user. -C If SWITCH=0 option is off; MAXITR=3*(NVARS+MRELAS). -C =1 option is on. -C data set =MAXITR -C LATP=4 -C -C -----KEY = 59. Provide SPLP( ) with exactly MRELAS indices which -C comprise a feasible, nonsingular basis. The basis must define a -C feasible point: values for x and w such that A*x=w and all the -C stated bounds on x and w are satisfied. The basis must also be -C nonsingular. The failure of either condition will cause an error -C message (INFO=-23 or =-24, respectively). Normally, SPLP( ) uses -C identity matrix columns which correspond to the components of w. -C This option would normally not be used when restarting from -C a previously saved run (KEY=57). -C In numbering the unknowns, -C the components of x are numbered (1-NVARS) and the components -C of w are numbered (NVARS+1)-(NVARS+MRELAS). A value for an -C index .LE. 0 or .GT. (NVARS+MRELAS) is an error (INFO=-16). -C If SWITCH=0 option is off; SPLP( ) chooses the initial basis. -C =1 option is on; user provides the initial basis. -C data set =MRELAS indices of basis; order is arbitrary. -C LATP=MRELAS+3 -C -C -----KEY = 60. Provide the scale factors for the columns of the data -C matrix A. Normally, SPLP( ) computes the scale factors as the -C reciprocals of the max. norm of each column. -C If SWITCH=0 option is off; SPLP( ) computes the scale factors. -C =1 option is on; user provides the scale factors. -C data set =scaling for column J, J=1,NVARS; order is sequential. -C LATP=NVARS+3 -C -C -----KEY = 61. Provide a scale factor, COSTSC, for the vector of -C costs. Normally, SPLP( ) computes this scale factor to be the -C reciprocal of the max. norm of the vector costs after the column -C scaling has been applied. -C If SWITCH=0 option is off; SPLP( ) computes COSTSC. -C =1 option is on; user provides COSTSC. -C data set =COSTSC -C LATP=4 -C -C -----KEY = 62. Provide size parameters, ASMALL and ABIG, the smallest -C and largest magnitudes of nonzero entries in the data matrix A, -C respectively. When this option is on, SPLP( ) will check the -C nonzero entries of A to see if they are in the range of ASMALL and -C ABIG. If an entry of A is not within this range, SPLP( ) returns -C an error message, INFO=-22. Both ASMALL and ABIG must be positive -C with ASMALL .LE. ABIG. Otherwise, an error message is returned, -C INFO=-17. -C If SWITCH=0 option is off; no checking of the data matrix is done -C =1 option is on; checking is done. -C data set =ASMALL -C ABIG -C LATP=5 -C -C -----KEY = 63. Redefine the relative tolerance, TOLLS, used in -C checking if the residuals are feasible. Normally, -C TOLLS=RELPR, where RELPR is the machine precision. -C If SWITCH=0 option is off; TOLLS=RELPR. -C =1 option is on. -C data set =TOLLS -C LATP=4 -C -C -----KEY = 64. Use the minimum reduced cost pricing strategy to choose -C columns to enter the basis. Normally, SPLP( ) uses the steepest -C edge pricing strategy which is the best local move. The steepest -C edge pricing strategy generally uses fewer iterations than the -C minimum reduced cost pricing, but each iteration costs more in the -C number of calculations done. The steepest edge pricing is -C considered to be more efficient. However, this is very problem -C dependent. That is why SPLP( ) provides the option of either -C pricing strategy. -C If SWITCH=0 option is off; steepest option edge pricing is used. -C =1 option is on; minimum reduced cost pricing is used. -C data set =empty -C LATP=3 -C -C -----KEY = 65. Redefine MXITBR, the number of iterations between -C recalculating the error in the primal solution. Normally, MXITBR -C is set to 10. The error in the primal solution is used to monitor -C the error in solving the linear system. This is an expensive -C calculation and every tenth iteration is generally often enough. -C If SWITCH=0 option is off; MXITBR=10. -C =1 option is on. -C data set =MXITBR -C LATP=4 -C -C -----KEY = 66. Redefine NPP, the number of negative reduced costs -C (at most) to be found at each iteration of choosing -C a variable to enter the basis. Normally NPP is set -C to NVARS which implies that all of the reduced costs -C are computed at each such step. This "partial -C pricing" may very well increase the total number -C of iterations required. However it decreases the -C number of calculations at each iteration. -C therefore the effect on overall efficiency is quite -C problem-dependent. -C -C if SWITCH=0 option is off; NPP=NVARS -C =1 option is on. -C data set =NPP -C LATP=4 -C -C -----KEY = 67. Redefine the tuning factor (PHI) used to scale the -C error estimates for the primal and dual linear algebraic systems -C of equations. Normally, PHI = 1.E0, but in some environments it -C may be necessary to reset PHI to the range 0.001-0.01. This is -C particularly important for machines with short word lengths. -C -C if SWITCH = 0 option is off; PHI=1.E0. -C = 1 option is on. -C Data Set = PHI -C LATP=4 -C -C -----KEY = 68. Used together with the subprogram FULMAT(), provided -C with the SPLP() package, for passing a standard Fortran two- -C dimensional array containing the constraint matrix. Thus the sub- -C program FULMAT must be declared in a Fortran EXTERNAL statement. -C The two-dimensional array is passed as the argument DATTRV. -C The information about the array and problem dimensions are passed -C in the option array PRGOPT(*). It is an error if FULMAT() is -C used and this information is not passed in PRGOPT(*). -C -C if SWITCH = 0 option is off; this is an error is FULMAT() is -C used. -C = 1 option is on. -C Data Set = IA = row dimension of two-dimensional array. -C MRELAS = number of constraint equations. -C NVARS = number of dependent variables. -C LATP = 6 -C -----KEY = 69. Normally a relative tolerance (TOLLS, see option 63) -C is used to decide if the problem is feasible. If this test fails -C an absolute test will be applied using the value TOLABS. -C Nominally TOLABS = zero. -C If SWITCH = 0 option is off; TOLABS = zero. -C = 1 option is on. -C Data set = TOLABS -C LATP = 4 -C -C |-----------------------------| -C |Example of Option array Usage| -C |-----------------------------| -C To illustrate the usage of the option array, let us suppose that -C the user has the following nonstandard requirements: -C -C a) Wants to change from minimization to maximization problem. -C b) Wants to limit the number of simplex steps to 100. -C c) Wants to save the partial results after 100 steps on -C Fortran unit 2. -C -C After these 100 steps are completed the user wants to continue the -C problem (until completed) using the partial results saved on -C Fortran unit 2. Here are the entries of the array PRGOPT(*) -C that accomplish these tasks. (The definitions of the other -C required input parameters are not shown.) -C -C CHANGE TO A MAXIMIZATION PROBLEM; KEY=50. -C PRGOPT(01)=4 -C PRGOPT(02)=50 -C PRGOPT(03)=1 -C -C LIMIT THE NUMBER OF SIMPLEX STEPS TO 100; KEY=58. -C PRGOPT(04)=8 -C PRGOPT(05)=58 -C PRGOPT(06)=1 -C PRGOPT(07)=100 -C -C SAVE THE PARTIAL RESULTS, AFTER 100 STEPS, ON FORTRAN -C UNIT 2; KEY=57. -C PRGOPT(08)=11 -C PRGOPT(09)=57 -C PRGOPT(10)=1 -C -C NO MORE OPTIONS TO CHANGE. -C PRGOPT(11)=1 -C The user makes the CALL statement for SPLP( ) at this point. -C Now to restart, using the partial results after 100 steps, define -C new values for the array PRGOPT(*): -C -C AGAIN INFORM SPLP( ) THAT THIS IS A MAXIMIZATION PROBLEM. -C PRGOPT(01)=4 -C PRGOPT(02)=50 -C PRGOPT(03)=1 -C -C RESTART, USING SAVED PARTIAL RESULTS; KEY=55. -C PRGOPT(04)=7 -C PRGOPT(05)=55 -C PRGOPT(06)=1 -C -C NO MORE OPTIONS TO CHANGE. THE SUBPROGRAM SPLP( ) IS NO LONGER -C LIMITED TO 100 SIMPLEX STEPS BUT WILL RUN UNTIL COMPLETION OR -C MAX.=3*(MRELAS+NVARS) ITERATIONS. -C PRGOPT(07)=1 -C The user now makes a CALL to subprogram SPLP( ) to compute the -C solution. -C |-------------------------------------------| -C |End of Usage of SPLP( ) Subprogram Options.| -C |-------------------------------------------| -C -C |----------------------------------------------| -C |List of SPLP( ) Error and Diagnostic Messages.| -C |----------------------------------------------| -C This section may be required to understand the meanings of the -C error flag =-INFO that may be returned from SPLP( ). -C -C -----1. There is no set of values for x and w that satisfy A*x=w and -C the stated bounds. The problem can be made feasible by ident- -C ifying components of w that are now infeasible and then rede- -C signating them as free variables. Subprogram SPLP( ) only -C identifies an infeasible problem; it takes no other action to -C change this condition. Message: -C SPLP( ). THE PROBLEM APPEARS TO BE INFEASIBLE. -C ERROR NUMBER = 1 -C -C 2. One of the variables in either the vector x or w was con- -C strained at a bound. Otherwise the objective function value, -C (transpose of costs)*x, would not have a finite optimum. -C Message: -C SPLP( ). THE PROBLEM APPEARS TO HAVE NO FINITE SOLN. -C ERROR NUMBER = 2 -C -C 3. Both of the conditions of 1. and 2. above have occurred. -C Message: -C SPLP( ). THE PROBLEM APPEARS TO BE INFEASIBLE AND TO -C HAVE NO FINITE SOLN. -C ERROR NUMBER = 3 -C -C -----4. The REAL and INTEGER working arrays, WORK(*) and IWORK(*), -C are not long enough. The values (I1) and (I2) in the message -C below will give you the minimum length required. Also redefine -C LW and LIW, the lengths of these arrays. Message: -C SPLP( ). WORK OR IWORK IS NOT LONG ENOUGH. LW MUST BE (I1) -C AND LIW MUST BE (I2). -C IN ABOVE MESSAGE, I1= 0 -C IN ABOVE MESSAGE, I2= 0 -C ERROR NUMBER = 4 -C -C -----5. and 6. These error messages often mean that one or more -C arguments were left out of the call statement to SPLP( ) or -C that the values of MRELAS and NVARS have been over-written -C by garbage. Messages: -C SPLP( ). VALUE OF MRELAS MUST BE .GT.0. NOW=(I1). -C IN ABOVE MESSAGE, I1= 0 -C ERROR NUMBER = 5 -C -C SPLP( ). VALUE OF NVARS MUST BE .GT.0. NOW=(I1). -C IN ABOVE MESSAGE, I1= 0 -C ERROR NUMBER = 6 -C -C -----7.,8., and 9. These error messages can occur as the data matrix -C is being defined by either USRMAT( ) or the user-supplied sub- -C program, 'NAME'( ). They would indicate a mistake in the contents -C of DATTRV(*), the user-written subprogram or that data has been -C over-written. -C Messages: -C SPLP( ). MORE THAN 2*NVARS*MRELAS ITERS. DEFINING OR UPDATING -C MATRIX DATA. -C ERROR NUMBER = 7 -C -C SPLP( ). ROW INDEX (I1) OR COLUMN INDEX (I2) IS OUT OF RANGE. -C IN ABOVE MESSAGE, I1= 1 -C IN ABOVE MESSAGE, I2= 12 -C ERROR NUMBER = 8 -C -C SPLP( ). INDICATION FLAG (I1) FOR MATRIX DATA MUST BE -C EITHER 0 OR 1. -C IN ABOVE MESSAGE, I1= 12 -C ERROR NUMBER = 9 -C -C -----10. and 11. The type of bound (even no bound) and the bounds -C must be specified for each independent variable. If an independent -C variable has both an upper and lower bound, the bounds must be -C consistent. The lower bound must be .LE. the upper bound. -C Messages: -C SPLP( ). INDEPENDENT VARIABLE (I1) IS NOT DEFINED. -C IN ABOVE MESSAGE, I1= 1 -C ERROR NUMBER = 10 -C -C SPLP( ). LOWER BOUND (R1) AND UPPER BOUND (R2) FOR INDEP. -C VARIABLE (I1) ARE NOT CONSISTENT. -C IN ABOVE MESSAGE, I1= 1 -C IN ABOVE MESSAGE, R1= 0. -C IN ABOVE MESSAGE, R2= -.1000000000E+01 -C ERROR NUMBER = 11 -C -C -----12. and 13. The type of bound (even no bound) and the bounds -C must be specified for each dependent variable. If a dependent -C variable has both an upper and lower bound, the bounds must be -C consistent. The lower bound must be .LE. the upper bound. -C Messages: -C SPLP( ). DEPENDENT VARIABLE (I1) IS NOT DEFINED. -C IN ABOVE MESSAGE, I1= 1 -C ERROR NUMBER = 12 -C -C SPLP( ). LOWER BOUND (R1) AND UPPER BOUND (R2) FOR DEP. -C VARIABLE (I1) ARE NOT CONSISTENT. -C IN ABOVE MESSAGE, I1= 1 -C IN ABOVE MESSAGE, R1= 0. -C IN ABOVE MESSAGE, R2= -.1000000000E+01 -C ERROR NUMBER = 13 -C -C -----14. - 21. These error messages can occur when processing the -C option array, PRGOPT(*), supplied by the user. They would -C indicate a mistake in defining PRGOPT(*) or that data has been -C over-written. See heading Usage of SPLP( ) -C Subprogram Options, for details on how to define PRGOPT(*). -C Messages: -C SPLP( ). THE USER OPTION ARRAY HAS UNDEFINED DATA. -C ERROR NUMBER = 14 -C -C SPLP( ). OPTION ARRAY PROCESSING IS CYCLING. -C ERROR NUMBER = 15 -C -C SPLP( ). AN INDEX OF USER-SUPPLIED BASIS IS OUT OF RANGE. -C ERROR NUMBER = 16 -C -C SPLP( ). SIZE PARAMETERS FOR MATRIX MUST BE SMALLEST AND LARGEST -C MAGNITUDES OF NONZERO ENTRIES. -C ERROR NUMBER = 17 -C -C SPLP( ). THE NUMBER OF REVISED SIMPLEX STEPS BETWEEN CHECK-POINTS -C MUST BE POSITIVE. -C ERROR NUMBER = 18 -C -C SPLP( ). FILE NUMBERS FOR SAVED DATA AND MATRIX PAGES MUST BE -C POSITIVE AND NOT EQUAL. -C ERROR NUMBER = 19 -C -C SPLP( ). USER-DEFINED VALUE OF LAMAT (I1) -C MUST BE .GE. NVARS+7. -C IN ABOVE MESSAGE, I1= 1 -C ERROR NUMBER = 20 -C -C SPLP( ). USER-DEFINED VALUE OF LBM MUST BE .GE. 0. -C ERROR NUMBER = 21 -C -C -----22. The user-option, number 62, to check the size of the matrix -C data has been used. An element of the matrix does not lie within -C the range of ASMALL and ABIG, parameters provided by the user. -C (See the heading: Usage of SPLP( ) Subprogram Options, -C for details about this feature.) Message: -C SPLP( ). A MATRIX ELEMENT'S SIZE IS OUT OF THE SPECIFIED RANGE. -C ERROR NUMBER = 22 -C -C -----23. The user has provided an initial basis that is singular. -C In this case, the user can remedy this problem by letting -C subprogram SPLP( ) choose its own initial basis. Message: -C SPLP( ). A SINGULAR INITIAL BASIS WAS ENCOUNTERED. -C ERROR NUMBER = 23 -C -C -----24. The user has provided an initial basis which is infeasible. -C The x and w values it defines do not satisfy A*x=w and the stated -C bounds. In this case, the user can let subprogram SPLP( ) -C choose its own initial basis. Message: -C SPLP( ). AN INFEASIBLE INITIAL BASIS WAS ENCOUNTERED. -C ERROR NUMBER = 24 -C -C -----25. Subprogram SPLP( ) has completed the maximum specified number -C of iterations. (The nominal maximum number is 3*(MRELAS+NVARS).) -C The results, necessary to continue on from -C this point, can be saved on Fortran unit 2 by activating option -C KEY=57. If the user anticipates continuing the calculation, then -C the contents of Fortran unit 2 must be retained intact. This -C is not done by subprogram SPLP( ), so the user needs to save unit -C 2 by using the appropriate system commands. Message: -C SPLP( ). MAX. ITERS. (I1) TAKEN. UP-TO-DATE RESULTS -C SAVED ON FILE (I2). IF(I2)=0, NO SAVE. -C IN ABOVE MESSAGE, I1= 500 -C IN ABOVE MESSAGE, I2= 2 -C ERROR NUMBER = 25 -C -C -----26. This error should never happen. Message: -C SPLP( ). MOVED TO A SINGULAR POINT. THIS SHOULD NOT HAPPEN. -C ERROR NUMBER = 26 -C -C -----27. The subprogram LA05A( ), which decomposes the basis matrix, -C has returned with an error flag (R1). (See the document, -C "Fortran subprograms for handling sparse linear programming -C bases", AERE-R8269, J.K. Reid, Jan., 1976, H.M. Stationery Office, -C for an explanation of this error.) Message: -C SPLP( ). LA05A( ) RETURNED ERROR FLAG (R1) BELOW. -C IN ABOVE MESSAGE, R1= -.5000000000E+01 -C ERROR NUMBER = 27 -C -C -----28. The sparse linear solver package, LA05*( ), requires more -C space. The value of LBM must be increased. See the companion -C document, Usage of SPLP( ) Subprogram Options, for details on how -C to increase the value of LBM. Message: -C SPLP( ). SHORT ON STORAGE FOR LA05*( ) PACKAGE. USE PRGOPT(*) -C TO GIVE MORE. -C ERROR NUMBER = 28 -C -C -----29. The row dimension of the two-dimensional Fortran array, -C the number of constraint equations (MRELAS), and the number -C of variables (NVARS), were not passed to the subprogram -C FULMAT(). See KEY = 68 for details. Message: -C FULMAT() OF SPLP() PACKAGE. ROW DIM., MRELAS, NVARS ARE -C MISSING FROM PRGOPT(*). -C ERROR NUMBER = 29 -C -C |------------------------------------------------------| -C |End of List of SPLP( ) Error and Diagnostic Messages. | -C |------------------------------------------------------| -C***REFERENCES R. J. Hanson and K. L. Hiebert, A sparse linear -C programming subprogram, Report SAND81-0297, Sandia -C National Laboratories, 1981. -C***ROUTINES CALLED SPLPMN, XERMSG -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890605 Corrected references to XERRWV. (WRB) -C 890605 Removed unreferenced labels. (WRB) -C 890605 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 SPLP - REAL BL(*),BU(*),COSTS(*),DATTRV(*),DUALS(*), - * PRGOPT(*),PRIMAL(*),WORK(*),ZERO -C - INTEGER IBASIS(*),IND(*),IWORK(*) - CHARACTER*8 XERN1, XERN2 -C - EXTERNAL USRMAT -C -C***FIRST EXECUTABLE STATEMENT SPLP - ZERO=0.E0 - IOPT=1 -C -C VERIFY THAT MRELAS, NVARS .GT. 0. -C - IF (MRELAS.LE.0) THEN - WRITE (XERN1, '(I8)') MRELAS - CALL XERMSG ('SLATEC', 'SPLP', 'VALUE OF MRELAS MUST BE ' // - * '.GT. 0. NOW = ' // XERN1, 5, 1) - INFO = -5 - RETURN - ENDIF -C - IF (NVARS.LE.0) THEN - WRITE (XERN1, '(I8)') NVARS - CALL XERMSG ('SLATEC', 'SPLP', 'VALUE OF NVARS MUST BE ' // - * '.GT. 0. NOW = ' // XERN1, 6, 1) - INFO = -6 - RETURN - ENDIF -C - LMX=4*NVARS+7 - LBM=8*MRELAS - LAST = 1 - IADBIG=10000 - ICTMAX=1000 - ICTOPT= 0 -C -C LOOK IN OPTION ARRAY FOR CHANGES TO WORK ARRAY LENGTHS. -20008 NEXT=PRGOPT(LAST) - IF (.NOT.(NEXT.LE.0 .OR. NEXT.GT.IADBIG)) GO TO 20010 -C -C THE CHECKS FOR SMALL OR LARGE VALUES OF NEXT ARE TO PREVENT -C WORKING WITH UNDEFINED DATA. - NERR=14 - CALL XERMSG ('SLATEC', 'SPLP', - + 'THE USER OPTION ARRAY HAS UNDEFINED DATA.', NERR, IOPT) - INFO=-NERR - RETURN -20010 IF (.NOT.(NEXT.EQ.1)) GO TO 10001 - GO TO 20009 -10001 IF (.NOT.(ICTOPT.GT.ICTMAX)) GO TO 10002 - NERR=15 - CALL XERMSG ('SLATEC', 'SPLP', - + 'OPTION ARRAY PROCESSING IS CYCLING.', NERR, IOPT) - INFO=-NERR - RETURN -10002 CONTINUE - KEY = PRGOPT(LAST+1) -C -C IF KEY = 53, USER MAY SPECIFY LENGTHS OF PORTIONS -C OF WORK(*) AND IWORK(*) THAT ARE ALLOCATED TO THE -C SPARSE MATRIX STORAGE AND SPARSE LINEAR EQUATION -C SOLVING. - IF (.NOT.(KEY.EQ.53)) GO TO 20013 - IF (.NOT.(PRGOPT(LAST+2).NE.ZERO)) GO TO 20016 - LMX=PRGOPT(LAST+3) - LBM=PRGOPT(LAST+4) -20016 CONTINUE -20013 ICTOPT = ICTOPT+1 - LAST = NEXT - GO TO 20008 -C -C CHECK LENGTH VALIDITY OF SPARSE MATRIX STAGING AREA. -C -20009 IF (LMX.LT.NVARS+7) THEN - WRITE (XERN1, '(I8)') LMX - CALL XERMSG ('SLATEC', 'SPLP', 'USER-DEFINED VALUE OF ' // - * 'LAMAT = ' // XERN1 // ' MUST BE .GE. NVARS+7.', 20, 1) - INFO = -20 - RETURN - ENDIF -C -C TRIVIAL CHECK ON LENGTH OF LA05*() MATRIX AREA. - IF (.NOT.(LBM.LT.0)) GO TO 20022 - NERR=21 - CALL XERMSG ('SLATEC', 'SPLP', - + 'USER-DEFINED VALUE OF LBM MUST BE .GE. 0.', NERR, IOPT) - INFO=-NERR - RETURN -20022 CONTINUE -C -C DEFINE POINTERS FOR STARTS OF SUBARRAYS USED IN WORK(*) -C AND IWORK(*) IN OTHER SUBPROGRAMS OF THE PACKAGE. - LAMAT=1 - LCSC=LAMAT+LMX - LCOLNR=LCSC+NVARS - LERD=LCOLNR+NVARS - LERP=LERD+MRELAS - LBASMA=LERP+MRELAS - LWR=LBASMA+LBM - LRZ=LWR+MRELAS - LRG=LRZ+NVARS+MRELAS - LRPRIM=LRG+NVARS+MRELAS - LRHS=LRPRIM+MRELAS - LWW=LRHS+MRELAS - LWORK=LWW+MRELAS-1 - LIMAT=1 - LIBB=LIMAT+LMX - LIBRC=LIBB+NVARS+MRELAS - LIPR=LIBRC+2*LBM - LIWR=LIPR+2*MRELAS - LIWORK=LIWR+8*MRELAS-1 -C -C CHECK ARRAY LENGTH VALIDITY OF WORK(*), IWORK(*). -C - IF (LW.LT.LWORK .OR. LIW.LT.LIWORK) THEN - WRITE (XERN1, '(I8)') LWORK - WRITE (XERN2, '(I8)') LIWORK - CALL XERMSG ('SLATEC', 'SPLP', 'WORK OR IWORK IS NOT LONG ' // - * 'ENOUGH. LW MUST BE = ' // XERN1 // ' AND LIW MUST BE = ' // - * XERN2, 4, 1) - INFO = -4 - RETURN - ENDIF -C - CALL SPLPMN(USRMAT,MRELAS,NVARS,COSTS,PRGOPT,DATTRV, - * BL,BU,IND,INFO,PRIMAL,DUALS,WORK(LAMAT), - * WORK(LCSC),WORK(LCOLNR),WORK(LERD),WORK(LERP),WORK(LBASMA), - * WORK(LWR),WORK(LRZ),WORK(LRG),WORK(LRPRIM),WORK(LRHS), - * WORK(LWW),LMX,LBM,IBASIS,IWORK(LIBB),IWORK(LIMAT), - * IWORK(LIBRC),IWORK(LIPR),IWORK(LIWR)) -C -C CALL SPLPMN(USRMAT,MRELAS,NVARS,COSTS,PRGOPT,DATTRV, -C 1 BL,BU,IND,INFO,PRIMAL,DUALS,AMAT, -C 2 CSC,COLNRM,ERD,ERP,BASMAT, -C 3 WR,RZ,RG,RPRIM,RHS, -C 4 WW,LMX,LBM,IBASIS,IBB,IMAT, -C 5 IBRC,IPR,IWR) -C - RETURN - END diff --git a/slatec/splpce.f b/slatec/splpce.f deleted file mode 100644 index d76b701..0000000 --- a/slatec/splpce.f +++ /dev/null @@ -1,181 +0,0 @@ -*DECK SPLPCE - SUBROUTINE SPLPCE (MRELAS, NVARS, LMX, LBM, ITLP, ITBRC, IBASIS, - + IMAT, IBRC, IPR, IWR, IND, IBB, ERDNRM, EPS, TUNE, GG, AMAT, - + BASMAT, CSC, WR, WW, PRIMAL, ERD, ERP, SINGLR, REDBAS) -C***BEGIN PROLOGUE SPLPCE -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (SPLPCE-S, DPLPCE-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO -C DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. -C -C USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. -C /REAL (12 BLANKS)/DOUBLE PRECISION/, -C /SASUM/DASUM/,/SCOPY/,DCOPY/. -C -C REVISED 811219-1630 -C REVISED YYMMDD-HHMM -C -C THIS SUBPROGRAM IS FROM THE SPLP( ) PACKAGE. IT CALCULATES -C THE APPROXIMATE ERROR IN THE PRIMAL AND DUAL SYSTEMS. IT IS -C THE MAIN PART OF THE PROCEDURE (COMPUTE ERROR IN DUAL AND PRIMAL -C SYSTEMS). -C -C***SEE ALSO SPLP -C***ROUTINES CALLED IPLOC, LA05BS, PRWPGE, SASUM, SCOPY -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890605 Removed unreferenced labels. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE SPLPCE - INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*) - REAL AMAT(*),BASMAT(*),CSC(*),WR(*),WW(*),PRIMAL(*), - * ERD(*),ERP(*),EPS,ERDNRM,FACTOR,GG,ONE,ZERO,TEN,TUNE - LOGICAL SINGLR,REDBAS,TRANS,PAGEPL -C***FIRST EXECUTABLE STATEMENT SPLPCE - ZERO=0.E0 - ONE=1.E0 - TEN=10.E0 - LPG=LMX-(NVARS+4) - SINGLR=.FALSE. - FACTOR=0.01 -C -C COPY COLSUMS IN WW(*), AND SOLVE TRANSPOSED SYSTEM. - I=1 - N20002=MRELAS - GO TO 20003 -20002 I=I+1 -20003 IF ((N20002-I).LT.0) GO TO 20004 - J=IBASIS(I) - IF (.NOT.(J.LE.NVARS)) GO TO 20006 - WW(I) = PRIMAL(J) - GO TO 20007 -20006 IF (.NOT.(IND(J).EQ.2)) GO TO 20009 - WW(I)=ONE - GO TO 20010 -20009 WW(I)=-ONE -20010 CONTINUE -20007 CONTINUE - GO TO 20002 -C -C PERTURB RIGHT-SIDE IN UNITS OF LAST BITS TO BETTER REFLECT -C ERRORS IN THE CHECK SUM SOLNS. -20004 I=1 - N20012=MRELAS - GO TO 20013 -20012 I=I+1 -20013 IF ((N20012-I).LT.0) GO TO 20014 - WW(I)=WW(I)+TEN*EPS*WW(I) - GO TO 20012 -20014 TRANS = .TRUE. - CALL LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) - I=1 - N20016=MRELAS - GO TO 20017 -20016 I=I+1 -20017 IF ((N20016-I).LT.0) GO TO 20018 - ERD(I)=MAX(ABS(WW(I)-ONE),EPS)*TUNE -C -C SYSTEM BECOMES SINGULAR WHEN ACCURACY OF SOLUTION IS .GT. FACTOR. -C THIS VALUE (FACTOR) MIGHT NEED TO BE CHANGED. - SINGLR=SINGLR.OR.(ERD(I).GE.FACTOR) - GO TO 20016 -20018 ERDNRM=SASUM(MRELAS,ERD,1) -C -C RECALCULATE ROW CHECK SUMS EVERY ITBRC ITERATIONS OR WHEN -C A REDECOMPOSITION HAS OCCURRED. - IF (.NOT.(MOD(ITLP,ITBRC).EQ.0 .OR. REDBAS)) GO TO 20020 -C -C COMPUTE ROW SUMS, STORE IN WW(*), SOLVE PRIMAL SYSTEM. - WW(1)=ZERO - CALL SCOPY(MRELAS,WW,0,WW,1) - PAGEPL=.TRUE. - J=1 - N20023=NVARS - GO TO 20024 -20023 J=J+1 -20024 IF ((N20023-J).LT.0) GO TO 20025 - IF (.NOT.(IBB(J).GE.ZERO)) GO TO 20027 -C -C THE VARIABLE IS NON-BASIC. - PAGEPL=.TRUE. - GO TO 20023 -20027 IF (.NOT.(J.EQ.1)) GO TO 20030 - ILOW=NVARS+5 - GO TO 20031 -20030 ILOW=IMAT(J+3)+1 -20031 IF (.NOT.(PAGEPL)) GO TO 20033 - IL1=IPLOC(ILOW,AMAT,IMAT) - IF (.NOT.(IL1.GE.LMX-1)) GO TO 20036 - ILOW=ILOW+2 - IL1=IPLOC(ILOW,AMAT,IMAT) -20036 CONTINUE - IPAGE=ABS(IMAT(LMX-1)) - GO TO 20034 -20033 IL1=IHI+1 -20034 IHI=IMAT(J+4)-(ILOW-IL1) -20039 IU1=MIN(LMX-2,IHI) - IF (.NOT.(IL1.GT.IU1)) GO TO 20041 - GO TO 20040 -20041 CONTINUE - DO 20 I=IL1,IU1 - WW(IMAT(I))=WW(IMAT(I))+AMAT(I)*CSC(J) -20 CONTINUE - IF (.NOT.(IHI.LE.LMX-2)) GO TO 20044 - GO TO 20040 -20044 CONTINUE - IPAGE=IPAGE+1 - KEY=1 - CALL PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT) - IL1=NVARS+5 - IHI=IHI-LPG - GO TO 20039 -20040 PAGEPL=IHI.EQ.(LMX-2) - GO TO 20023 -20025 L=1 - N20047=MRELAS - GO TO 20048 -20047 L=L+1 -20048 IF ((N20047-L).LT.0) GO TO 20049 - J=IBASIS(L) - IF (.NOT.(J.GT.NVARS)) GO TO 20051 - I=J-NVARS - IF (.NOT.(IND(J).EQ.2)) GO TO 20054 - WW(I)=WW(I)+ONE - GO TO 20055 -20054 WW(I)=WW(I)-ONE -20055 CONTINUE -20051 CONTINUE - GO TO 20047 -C -C PERTURB RIGHT-SIDE IN UNITS OF LAST BIT POSITIONS. -20049 I=1 - N20057=MRELAS - GO TO 20058 -20057 I=I+1 -20058 IF ((N20057-I).LT.0) GO TO 20059 - WW(I)=WW(I)+TEN*EPS*WW(I) - GO TO 20057 -20059 TRANS = .FALSE. - CALL LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) - I=1 - N20061=MRELAS - GO TO 20062 -20061 I=I+1 -20062 IF ((N20061-I).LT.0) GO TO 20063 - ERP(I)=MAX(ABS(WW(I)-ONE),EPS)*TUNE -C -C SYSTEM BECOMES SINGULAR WHEN ACCURACY OF SOLUTION IS .GT. FACTOR. -C THIS VALUE (FACTOR) MIGHT NEED TO BE CHANGED. - SINGLR=SINGLR.OR.(ERP(I).GE.FACTOR) - GO TO 20061 -20063 CONTINUE -C -20020 RETURN - END diff --git a/slatec/splpdm.f b/slatec/splpdm.f deleted file mode 100644 index 0915263..0000000 --- a/slatec/splpdm.f +++ /dev/null @@ -1,112 +0,0 @@ -*DECK SPLPDM - SUBROUTINE SPLPDM (MRELAS, NVARS, LMX, LBM, NREDC, INFO, IOPT, - + IBASIS, IMAT, IBRC, IPR, IWR, IND, IBB, ANORM, EPS, UU, GG, - + AMAT, BASMAT, CSC, WR, SINGLR, REDBAS) -C***BEGIN PROLOGUE SPLPDM -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (SPLPDM-S, DPLPDM-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THIS SUBPROGRAM IS FROM THE SPLP( ) PACKAGE. IT PERFORMS THE -C TASK OF DEFINING THE ENTRIES OF THE BASIS MATRIX AND -C DECOMPOSING IT USING THE LA05 PACKAGE. -C IT IS THE MAIN PART OF THE PROCEDURE (DECOMPOSE BASIS MATRIX). -C -C***SEE ALSO SPLP -C***ROUTINES CALLED LA05AS, PNNZRS, SASUM, XERMSG -C***COMMON BLOCKS LA05DS -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890605 Corrected references to XERRWV. (WRB) -C 890605 Removed unreferenced labels. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls, changed do-it-yourself -C DO loops to DO loops. (RWC) -C***END PROLOGUE SPLPDM - INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*) - REAL AMAT(*),BASMAT(*),CSC(*),WR(*),ANORM,EPS,GG, - * ONE,SMALL,UU,ZERO - LOGICAL SINGLR,REDBAS - CHARACTER*16 XERN3 -C -C COMMON BLOCK USED BY LA05 () PACKAGE.. - COMMON /LA05DS/ SMALL,LP,LENL,LENU,NCP,LROW,LCOL -C -C***FIRST EXECUTABLE STATEMENT SPLPDM - ZERO = 0.E0 - ONE = 1.E0 -C -C DEFINE BASIS MATRIX BY COLUMNS FOR SPARSE MATRIX EQUATION SOLVER. -C THE LA05AS() SUBPROGRAM REQUIRES THE NONZERO ENTRIES OF THE MATRIX -C TOGETHER WITH THE ROW AND COLUMN INDICES. -C - NZBM = 0 -C -C DEFINE DEPENDENT VARIABLE COLUMNS. THESE ARE -C COLS. OF THE IDENTITY MATRIX AND IMPLICITLY GENERATED. -C - DO 20 K = 1,MRELAS - J = IBASIS(K) - IF (J.GT.NVARS) THEN - NZBM = NZBM+1 - IF (IND(J).EQ.2) THEN - BASMAT(NZBM) = ONE - ELSE - BASMAT(NZBM) = -ONE - ENDIF - IBRC(NZBM,1) = J-NVARS - IBRC(NZBM,2) = K - ELSE -C -C DEFINE THE INDEP. VARIABLE COLS. THIS REQUIRES RETRIEVING -C THE COLS. FROM THE SPARSE MATRIX DATA STRUCTURE. -C - I = 0 - 10 CALL PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,J) - IF (I.GT.0) THEN - NZBM = NZBM+1 - BASMAT(NZBM) = AIJ*CSC(J) - IBRC(NZBM,1) = I - IBRC(NZBM,2) = K - GO TO 10 - ENDIF - ENDIF - 20 CONTINUE -C - SINGLR = .FALSE. -C -C RECOMPUTE MATRIX NORM USING CRUDE NORM = SUM OF MAGNITUDES. -C - ANORM = SASUM(NZBM,BASMAT,1) - SMALL = EPS*ANORM -C -C GET AN L-U FACTORIZATION OF THE BASIS MATRIX. -C - NREDC = NREDC+1 - REDBAS = .TRUE. - CALL LA05AS(BASMAT,IBRC,NZBM,LBM,MRELAS,IPR,IWR,WR,GG,UU) -C -C CHECK RETURN VALUE OF ERROR FLAG, GG. -C - IF (GG.GE.ZERO) RETURN - IF (GG.EQ.(-7.)) THEN - CALL XERMSG ('SLATEC', 'SPLPDM', - * 'IN SPLP, SHORT ON STORAGE FOR LA05AS. ' // - * 'USE PRGOPT(*) TO GIVE MORE.', 28, IOPT) - INFO = -28 - ELSEIF (GG.EQ.(-5.)) THEN - SINGLR = .TRUE. - ELSE - WRITE (XERN3, '(1PE15.6)') GG - CALL XERMSG ('SLATEC', 'SPLPDM', - * 'IN SPLP, LA05AS RETURNED ERROR FLAG = ' // XERN3, - * 27, IOPT) - INFO = -27 - ENDIF - RETURN - END diff --git a/slatec/splpfe.f b/slatec/splpfe.f deleted file mode 100644 index 01e3368..0000000 --- a/slatec/splpfe.f +++ /dev/null @@ -1,159 +0,0 @@ -*DECK SPLPFE - SUBROUTINE SPLPFE (MRELAS, NVARS, LMX, LBM, IENTER, IBASIS, IMAT, - + IBRC, IPR, IWR, IND, IBB, ERDNRM, EPS, GG, DULNRM, DIRNRM, - + AMAT, BASMAT, CSC, WR, WW, BL, BU, RZ, RG, COLNRM, DUALS, - + FOUND) -C***BEGIN PROLOGUE SPLPFE -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (SPLPFE-S, DPLPFE-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO -C DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. -C -C USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. -C /REAL (12 BLANKS)/DOUBLE PRECISION/,/SASUM/DASUM/, -C /SCOPY/DCOPY/. -C -C THIS SUBPROGRAM IS PART OF THE SPLP( ) PACKAGE. -C IT IMPLEMENTS THE PROCEDURE (FIND VARIABLE TO ENTER BASIS -C AND GET SEARCH DIRECTION). -C REVISED 811130-1100 -C REVISED YYMMDD-HHMM -C -C***SEE ALSO SPLP -C***ROUTINES CALLED IPLOC, LA05BS, PRWPGE, SASUM, SCOPY -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890605 Removed unreferenced labels. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE SPLPFE - INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*) - REAL AMAT(*),BASMAT(*),CSC(*),WR(*),WW(*),BL(*),BU(*), - * RZ(*),RG(*),COLNRM(*),DUALS(*),CNORM,DIRNRM,DULNRM,EPS,ERDNRM,GG, - * ONE,RATIO,RCOST,RMAX,ZERO - LOGICAL FOUND,TRANS -C***FIRST EXECUTABLE STATEMENT SPLPFE - LPG=LMX-(NVARS+4) - ZERO=0.E0 - ONE=1.E0 - RMAX=ZERO - FOUND=.FALSE. - I=MRELAS+1 - N20002=MRELAS+NVARS - GO TO 20003 -20002 I=I+1 -20003 IF ((N20002-I).LT.0) GO TO 20004 - J=IBASIS(I) -C -C IF J=IBASIS(I) .LT. 0 THEN THE VARIABLE LEFT AT A ZERO LEVEL -C AND IS NOT CONSIDERED AS A CANDIDATE TO ENTER. - IF (.NOT.(J.GT.0)) GO TO 20006 -C -C DO NOT CONSIDER VARIABLES CORRESPONDING TO UNBOUNDED STEP LENGTHS. - IF (.NOT.(IBB(J).EQ.0)) GO TO 20009 - GO TO 20002 -20009 CONTINUE -C -C IF A VARIABLE CORRESPONDS TO AN EQUATION(IND=3 AND BL=BU), -C THEN DO NOT CONSIDER IT AS A CANDIDATE TO ENTER. - IF (.NOT.(IND(J).EQ.3)) GO TO 20012 - IF (.NOT.((BU(J)-BL(J)).LE.EPS*(ABS(BL(J))+ABS(BU(J))))) GO TO 200 - *15 - GO TO 20002 -20015 CONTINUE -20012 CONTINUE - RCOST=RZ(J) -C -C IF VARIABLE IS AT UPPER BOUND IT CAN ONLY DECREASE. THIS -C ACCOUNTS FOR THE POSSIBLE CHANGE OF SIGN. - IF(MOD(IBB(J),2).EQ.0) RCOST=-RCOST -C -C IF THE VARIABLE IS FREE, USE THE NEGATIVE MAGNITUDE OF THE -C REDUCED COST FOR THAT VARIABLE. - IF(IND(J).EQ.4) RCOST=-ABS(RCOST) - CNORM=ONE - IF(J.LE.NVARS)CNORM=COLNRM(J) -C -C TEST FOR NEGATIVITY OF REDUCED COSTS. - IF (.NOT.(RCOST+ERDNRM*DULNRM*CNORM.LT.ZERO)) GO TO 20018 - FOUND=.TRUE. - RATIO=RCOST**2/RG(J) - IF (.NOT.(RATIO.GT.RMAX)) GO TO 20021 - RMAX=RATIO - IENTER=I -20021 CONTINUE -20018 CONTINUE -20006 GO TO 20002 -C -C USE COL. CHOSEN TO COMPUTE SEARCH DIRECTION. -20004 IF (.NOT.(FOUND)) GO TO 20024 - J=IBASIS(IENTER) - WW(1)=ZERO - CALL SCOPY(MRELAS,WW,0,WW,1) - IF (.NOT.(J.LE.NVARS)) GO TO 20027 - IF (.NOT.(J.EQ.1)) GO TO 20030 - ILOW=NVARS+5 - GO TO 20031 -20030 ILOW=IMAT(J+3)+1 -20031 CONTINUE - IL1=IPLOC(ILOW,AMAT,IMAT) - IF (.NOT.(IL1.GE.LMX-1)) GO TO 20033 - ILOW=ILOW+2 - IL1=IPLOC(ILOW,AMAT,IMAT) -20033 CONTINUE - IPAGE=ABS(IMAT(LMX-1)) - IHI=IMAT(J+4)-(ILOW-IL1) -20036 IU1=MIN(LMX-2,IHI) - IF (.NOT.(IL1.GT.IU1)) GO TO 20038 - GO TO 20037 -20038 CONTINUE - DO 30 I=IL1,IU1 - WW(IMAT(I))=AMAT(I)*CSC(J) -30 CONTINUE - IF (.NOT.(IHI.LE.LMX-2)) GO TO 20041 - GO TO 20037 -20041 CONTINUE - IPAGE=IPAGE+1 - KEY=1 - CALL PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT) - IL1=NVARS+5 - IHI=IHI-LPG - GO TO 20036 -20037 GO TO 20028 -20027 IF (.NOT.(IND(J).EQ.2)) GO TO 20044 - WW(J-NVARS)=ONE - GO TO 20045 -20044 WW(J-NVARS)=-ONE -20045 CONTINUE - CONTINUE -C -C COMPUTE SEARCH DIRECTION. -20028 TRANS=.FALSE. - CALL LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) -C -C THE SEARCH DIRECTION REQUIRES THE FOLLOWING SIGN CHANGE IF EITHER -C VARIABLE ENTERING IS AT ITS UPPER BOUND OR IS FREE AND HAS -C POSITIVE REDUCED COST. - IF (.NOT.(MOD(IBB(J),2).EQ.0.OR.(IND(J).EQ.4 .AND. RZ(J).GT.ZERO)) - *) GO TO 20047 - I=1 - N20050=MRELAS - GO TO 20051 -20050 I=I+1 -20051 IF ((N20050-I).LT.0) GO TO 20052 - WW(I)=-WW(I) - GO TO 20050 -20052 CONTINUE -20047 DIRNRM=SASUM(MRELAS,WW,1) -C -C COPY CONTENTS OF WR(*) TO DUALS(*) FOR USE IN -C ADD-DROP (EXCHANGE) STEP, LA05CS( ). - CALL SCOPY(MRELAS,WR,1,DUALS,1) -20024 RETURN - END diff --git a/slatec/splpfl.f b/slatec/splpfl.f deleted file mode 100644 index 2ecd11f..0000000 --- a/slatec/splpfl.f +++ /dev/null @@ -1,157 +0,0 @@ -*DECK SPLPFL - SUBROUTINE SPLPFL (MRELAS, NVARS, IENTER, ILEAVE, IBASIS, IND, - + IBB, THETA, DIRNRM, RPRNRM, CSC, WW, BL, BU, ERP, RPRIM, - + PRIMAL, FINITE, ZEROLV) -C***BEGIN PROLOGUE SPLPFL -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (SPLPFL-S, DPLPFL-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO -C DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. -C -C USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. -C /REAL (12 BLANKS)/DOUBLE PRECISION/. -C -C THIS SUBPROGRAM IS PART OF THE SPLP( ) PACKAGE. -C IT IMPLEMENTS THE PROCEDURE (CHOOSE VARIABLE TO LEAVE BASIS). -C REVISED 811130-1045 -C REVISED YYMMDD-HHMM -C -C***SEE ALSO SPLP -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890605 Removed unreferenced labels. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE SPLPFL - INTEGER IBASIS(*),IND(*),IBB(*) - REAL CSC(*),WW(*),BL(*),BU(*),ERP(*),RPRIM(*), - * PRIMAL(*),BOUND,DIRNRM,RATIO,RPRNRM,THETA,ZERO - LOGICAL FINITE,ZEROLV -C***FIRST EXECUTABLE STATEMENT SPLPFL - ZERO=0.E0 -C -C SEE IF THE ENTERING VARIABLE IS RESTRICTING THE STEP LENGTH -C BECAUSE OF AN UPPER BOUND. - FINITE=.FALSE. - J=IBASIS(IENTER) - IF (.NOT.(IND(J).EQ.3)) GO TO 20002 - THETA=BU(J)-BL(J) - IF(J.LE.NVARS)THETA=THETA/CSC(J) - FINITE=.TRUE. - ILEAVE=IENTER -C -C NOW USE THE BASIC VARIABLES TO POSSIBLY RESTRICT THE STEP -C LENGTH EVEN FURTHER. -20002 I=1 - N20005=MRELAS - GO TO 20006 -20005 I=I+1 -20006 IF ((N20005-I).LT.0) GO TO 20007 - J=IBASIS(I) -C -C IF THIS IS A FREE VARIABLE, DO NOT USE IT TO -C RESTRICT THE STEP LENGTH. - IF (.NOT.(IND(J).EQ.4)) GO TO 20009 - GO TO 20005 -C -C IF DIRECTION COMPONENT IS ABOUT ZERO, IGNORE IT FOR COMPUTING -C THE STEP LENGTH. -20009 IF (.NOT.(ABS(WW(I)).LE.DIRNRM*ERP(I))) GO TO 20012 - GO TO 20005 -20012 IF (.NOT.(WW(I).GT.ZERO)) GO TO 20015 -C -C IF RPRIM(I) IS ESSENTIALLY ZERO, SET RATIO TO ZERO AND EXIT LOOP. - IF (.NOT.(ABS(RPRIM(I)).LE.RPRNRM*ERP(I))) GO TO 20018 - THETA=ZERO - ILEAVE=I - FINITE=.TRUE. - GO TO 20008 -C -C THE VALUE OF RPRIM(I) WILL DECREASE ONLY TO ITS LOWER BOUND OR -C ONLY TO ITS UPPER BOUND. IF IT DECREASES TO ITS -C UPPER BOUND, THEN RPRIM(I) HAS ALREADY BEEN TRANSLATED -C TO ITS UPPER BOUND AND NOTHING NEEDS TO BE DONE TO IBB(J). -20018 IF (.NOT.(RPRIM(I).GT.ZERO)) GO TO 10001 - RATIO=RPRIM(I)/WW(I) - IF (.NOT.(.NOT.FINITE)) GO TO 20021 - ILEAVE=I - THETA=RATIO - FINITE=.TRUE. - GO TO 20022 -20021 IF (.NOT.(RATIO.LT.THETA)) GO TO 10002 - ILEAVE=I - THETA=RATIO -10002 CONTINUE -20022 CONTINUE - GO TO 20019 -C -C THE VALUE RPRIM(I).LT.ZERO WILL NOT RESTRICT THE STEP. -10001 CONTINUE -C -C THE DIRECTION COMPONENT IS NEGATIVE, THEREFORE THE VARIABLE WILL -C INCREASE. -20019 GO TO 20016 -C -C IF THE VARIABLE IS LESS THAN ITS LOWER BOUND, IT CAN -C INCREASE ONLY TO ITS LOWER BOUND. -20015 IF (.NOT.(PRIMAL(I+NVARS).LT.ZERO)) GO TO 20024 - RATIO=RPRIM(I)/WW(I) - IF (RATIO.LT.ZERO) RATIO=ZERO - IF (.NOT.(.NOT.FINITE)) GO TO 20027 - ILEAVE=I - THETA=RATIO - FINITE=.TRUE. - GO TO 20028 -20027 IF (.NOT.(RATIO.LT.THETA)) GO TO 10003 - ILEAVE=I - THETA=RATIO -10003 CONTINUE -20028 CONTINUE -C -C IF THE BASIC VARIABLE IS FEASIBLE AND IS NOT AT ITS UPPER BOUND, -C THEN IT CAN INCREASE TO ITS UPPER BOUND. - GO TO 20025 -20024 IF (.NOT.(IND(J).EQ.3 .AND. PRIMAL(I+NVARS).EQ.ZERO)) GO TO 10004 - BOUND=BU(J)-BL(J) - IF(J.LE.NVARS) BOUND=BOUND/CSC(J) - RATIO=(BOUND-RPRIM(I))/(-WW(I)) - IF (.NOT.(.NOT.FINITE)) GO TO 20030 - ILEAVE=-I - THETA=RATIO - FINITE=.TRUE. - GO TO 20031 -20030 IF (.NOT.(RATIO.LT.THETA)) GO TO 10005 - ILEAVE=-I - THETA=RATIO -10005 CONTINUE -20031 CONTINUE - CONTINUE -10004 CONTINUE -20025 CONTINUE -20016 GO TO 20005 -20007 CONTINUE -C -C IF STEP LENGTH IS FINITE, SEE IF STEP LENGTH IS ABOUT ZERO. -20008 IF (.NOT.(FINITE)) GO TO 20033 - ZEROLV=.TRUE. - I=1 - N20036=MRELAS - GO TO 20037 -20036 I=I+1 -20037 IF ((N20036-I).LT.0) GO TO 20038 - ZEROLV=ZEROLV.AND. ABS(THETA*WW(I)).LE.ERP(I)*RPRNRM - IF (.NOT.(.NOT. ZEROLV)) GO TO 20040 - GO TO 20039 -20040 GO TO 20036 -20038 CONTINUE -20039 CONTINUE -20033 CONTINUE - RETURN - END diff --git a/slatec/splpmn.f b/slatec/splpmn.f deleted file mode 100644 index a14a30c..0000000 --- a/slatec/splpmn.f +++ /dev/null @@ -1,988 +0,0 @@ -*DECK SPLPMN - SUBROUTINE SPLPMN (USRMAT, MRELAS, NVARS, COSTS, PRGOPT, DATTRV, - + BL, BU, IND, INFO, PRIMAL, DUALS, AMAT, CSC, COLNRM, ERD, ERP, - + BASMAT, WR, RZ, RG, RPRIM, RHS, WW, LMX, LBM, IBASIS, IBB, - + IMAT, IBRC, IPR, IWR) -C***BEGIN PROLOGUE SPLPMN -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (SPLPMN-S, DPLPMN-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C MARVEL OPTION(S).. OUTPUT=YES/NO TO ELIMINATE PRINTED OUTPUT. -C THIS DOES NOT APPLY TO THE CALLS TO THE ERROR PROCESSOR. -C -C MAIN SUBROUTINE FOR SPLP PACKAGE. -C -C***SEE ALSO SPLP -C***ROUTINES CALLED IVOUT, LA05BS, PINITM, PNNZRS, PRWPGE, SASUM, -C SCLOSM, SCOPY, SDOT, SPINCW, SPINIT, SPLPCE, -C SPLPDM, SPLPFE, SPLPFL, SPLPMU, SPLPUP, SPOPT, -C SVOUT, XERMSG -C***COMMON BLOCKS LA05DS -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890605 Corrected references to XERRWV. (WRB) -C 890605 Removed unreferenced labels. (WRB) -C 891009 Removed unreferenced variable. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C***END PROLOGUE SPLPMN - REAL ABIG,AIJ,AMAT(*),ANORM,ASMALL,BASMAT(*), - * BL(*),BU(*),COLNRM(*),COSTS(*),COSTSC,CSC(*),DATTRV(*), - * DIRNRM,DUALS(*),DULNRM,EPS,TUNE,ERD(*),ERDNRM,ERP(*),FACTOR,GG, - * ONE,PRGOPT(*),PRIMAL(*),RESNRM,RG(*),RHS(*),RHSNRM,ROPT(07), - * RPRIM(*),RPRNRM,RZ(*),RZJ,SCALR,SCOSTS,SIZE,SMALL,THETA, - * TOLLS,UPBND,UU,WR(*),WW(*),XLAMDA,XVAL,ZERO,RDUM(01),TOLABS -C - INTEGER IBASIS(*),IBB(*),IBRC(LBM,2),IMAT(*),IND(*), - * IPR(*),IWR(*),INTOPT(08),IDUM(01) -C -C ARRAY LOCAL VARIABLES -C NAME(LENGTH) DESCRIPTION -C -C COSTS(NVARS) COST COEFFICIENTS -C PRGOPT( ) OPTION VECTOR -C DATTRV( ) DATA TRANSFER VECTOR -C PRIMAL(NVARS+MRELAS) AS OUTPUT IT IS PRIMAL SOLUTION OF LP. -C INTERNALLY, THE FIRST NVARS POSITIONS HOLD -C THE COLUMN CHECK SUMS. THE NEXT MRELAS -C POSITIONS HOLD THE CLASSIFICATION FOR THE -C BASIC VARIABLES -1 VIOLATES LOWER -C BOUND, 0 FEASIBLE, +1 VIOLATES UPPER BOUND -C DUALS(MRELAS+NVARS) DUAL SOLUTION. INTERNALLY HOLDS R.H. SIDE -C AS FIRST MRELAS ENTRIES. -C AMAT(LMX) SPARSE FORM OF DATA MATRIX -C IMAT(LMX) SPARSE FORM OF DATA MATRIX -C BL(NVARS+MRELAS) LOWER BOUNDS FOR VARIABLES -C BU(NVARS+MRELAS) UPPER BOUNDS FOR VARIABLES -C IND(NVARS+MRELAS) INDICATOR FOR VARIABLES -C CSC(NVARS) COLUMN SCALING -C IBASIS(NVARS+MRELAS) COLS. 1-MRELAS ARE BASIC, REST ARE NON-BASIC -C IBB(NVARS+MRELAS) INDICATOR FOR NON-BASIC VARS., POLARITY OF -C VARS., AND POTENTIALLY INFINITE VARS. -C IF IBB(J).LT.0, VARIABLE J IS BASIC -C IF IBB(J).GT.0, VARIABLE J IS NON-BASIC -C IF IBB(J).EQ.0, VARIABLE J HAS TO BE IGNORED -C BECAUSE IT WOULD CAUSE UNBOUNDED SOLN. -C WHEN MOD(IBB(J),2).EQ.0, VARIABLE IS AT ITS -C UPPER BOUND, OTHERWISE IT IS AT ITS LOWER -C BOUND -C COLNRM(NVARS) NORM OF COLUMNS -C ERD(MRELAS) ERRORS IN DUAL VARIABLES -C ERP(MRELAS) ERRORS IN PRIMAL VARIABLES -C BASMAT(LBM) BASIS MATRIX FOR HARWELL SPARSE CODE -C IBRC(LBM,2) ROW AND COLUMN POINTERS FOR BASMAT(*) -C IPR(2*MRELAS) WORK ARRAY FOR HARWELL SPARSE CODE -C IWR(8*MRELAS) WORK ARRAY FOR HARWELL SPARSE CODE -C WR(MRELAS) WORK ARRAY FOR HARWELL SPARSE CODE -C RZ(NVARS+MRELAS) REDUCED COSTS -C RPRIM(MRELAS) INTERNAL PRIMAL SOLUTION -C RG(NVARS+MRELAS) COLUMN WEIGHTS -C WW(MRELAS) WORK ARRAY -C RHS(MRELAS) HOLDS TRANSLATED RIGHT HAND SIDE -C -C SCALAR LOCAL VARIABLES -C NAME TYPE DESCRIPTION -C -C LMX INTEGER LENGTH OF AMAT(*) -C LPG INTEGER LENGTH OF PAGE FOR AMAT(*) -C EPS REAL MACHINE PRECISION -C TUNE REAL PARAMETER TO SCALE ERROR ESTIMATES -C TOLLS REAL RELATIVE TOLERANCE FOR SMALL RESIDUALS -C TOLABS REAL ABSOLUTE TOLERANCE FOR SMALL RESIDUALS. -C USED IF RELATIVE ERROR TEST FAILS. -C IN CONSTRAINT EQUATIONS -C FACTOR REAL .01--DETERMINES IF BASIS IS SINGULAR -C OR COMPONENT IS FEASIBLE. MAY NEED TO -C BE INCREASED TO 1.E0 ON SHORT WORD -C LENGTH MACHINES. -C ASMALL REAL LOWER BOUND FOR NON-ZERO MAGN. IN AMAT(*) -C ABIG REAL UPPER BOUND FOR NON-ZERO MAGN. IN AMAT(*) -C MXITLP INTEGER MAXIMUM NUMBER OF ITERATIONS FOR LP -C ITLP INTEGER ITERATION COUNTER FOR TOTAL LP ITERS -C COSTSC REAL COSTS(*) SCALING -C SCOSTS REAL TEMP LOC. FOR COSTSC. -C XLAMDA REAL WEIGHT PARAMETER FOR PEN. METHOD. -C ANORM REAL NORM OF DATA MATRIX AMAT(*) -C RPRNRM REAL NORM OF THE SOLUTION -C DULNRM REAL NORM OF THE DUALS -C ERDNRM REAL NORM OF ERROR IN DUAL VARIABLES -C DIRNRM REAL NORM OF THE DIRECTION VECTOR -C RHSNRM REAL NORM OF TRANSLATED RIGHT HAND SIDE VECTOR -C RESNRM REAL NORM OF RESIDUAL VECTOR FOR CHECKING -C FEASIBILITY -C NZBM INTEGER NUMBER OF NON-ZEROS IN BASMAT(*) -C LBM INTEGER LENGTH OF BASMAT(*) -C SMALL REAL EPS*ANORM USED IN HARWELL SPARSE CODE -C LP INTEGER USED IN HARWELL LA05*() PACK AS OUTPUT -C FILE NUMBER. SET=I1MACH(4) NOW. -C UU REAL 0.1--USED IN HARWELL SPARSE CODE -C FOR RELATIVE PIVOTING TOLERANCE. -C GG REAL OUTPUT INFO FLAG IN HARWELL SPARSE CODE -C IPLACE INTEGER INTEGER USED BY SPARSE MATRIX CODES -C IENTER INTEGER NEXT COLUMN TO ENTER BASIS -C NREDC INTEGER NO. OF FULL REDECOMPOSITIONS -C KPRINT INTEGER LEVEL OF OUTPUT, =0-3 -C IDG INTEGER FORMAT AND PRECISION OF OUTPUT -C ITBRC INTEGER NO. OF ITERS. BETWEEN RECALCULATING -C THE ERROR IN THE PRIMAL SOLUTION. -C NPP INTEGER NO. OF NEGATIVE REDUCED COSTS REQUIRED -C IN PARTIAL PRICING -C JSTRT INTEGER STARTING PLACE FOR PARTIAL PRICING. -C - LOGICAL COLSCP,SAVEDT,CONTIN,CSTSCP,UNBND, - * FEAS,FINITE,FOUND,MINPRB,REDBAS, - * SINGLR,SIZEUP,STPEDG,TRANS,USRBAS,ZEROLV,LOPT(08) - CHARACTER*8 XERN1, XERN2 - EQUIVALENCE (CONTIN,LOPT(1)),(USRBAS,LOPT(2)), - * (SIZEUP,LOPT(3)),(SAVEDT,LOPT(4)),(COLSCP,LOPT(5)), - * (CSTSCP,LOPT(6)),(MINPRB,LOPT(7)),(STPEDG,LOPT(8)), - * (IDG,INTOPT(1)),(IPAGEF,INTOPT(2)),(ISAVE,INTOPT(3)), - * (MXITLP,INTOPT(4)),(KPRINT,INTOPT(5)),(ITBRC,INTOPT(6)), - * (NPP,INTOPT(7)),(LPRG,INTOPT(8)),(EPS,ROPT(1)),(ASMALL,ROPT(2)), - * (ABIG,ROPT(3)),(COSTSC,ROPT(4)),(TOLLS,ROPT(5)),(TUNE,ROPT(6)), - * (TOLABS,ROPT(7)) -C -C COMMON BLOCK USED BY LA05 () PACKAGE.. - COMMON /LA05DS/ SMALL,LP,LENL,LENU,NCP,LROW,LCOL - EXTERNAL USRMAT -C -C SET LP=0 SO NO ERROR MESSAGES WILL PRINT WITHIN LA05 () PACKAGE. -C***FIRST EXECUTABLE STATEMENT SPLPMN - LP=0 -C -C THE VALUES ZERO AND ONE. - ZERO=0.E0 - ONE=1.E0 - FACTOR=0.01E0 - LPG=LMX-(NVARS+4) - IOPT=1 - INFO=0 - UNBND=.FALSE. - JSTRT=1 -C -C PROCESS USER OPTIONS IN PRGOPT(*). -C CHECK THAT ANY USER-GIVEN CHANGES ARE WELL-DEFINED. - CALL SPOPT(PRGOPT,MRELAS,NVARS,INFO,CSC,IBASIS,ROPT,INTOPT,LOPT) - IF (.NOT.(INFO.LT.0)) GO TO 20002 - GO TO 30001 -20002 IF (.NOT.(CONTIN)) GO TO 20003 - GO TO 30002 -20006 GO TO 20004 -C -C INITIALIZE SPARSE DATA MATRIX, AMAT(*) AND IMAT(*). -20003 CALL PINITM(MRELAS,NVARS,AMAT,IMAT,LMX,IPAGEF) -C -C UPDATE MATRIX DATA AND CHECK BOUNDS FOR CONSISTENCY. -20004 CALL SPLPUP(USRMAT,MRELAS,NVARS,PRGOPT,DATTRV, - * BL,BU,IND,INFO,AMAT,IMAT,SIZEUP,ASMALL,ABIG) - IF (.NOT.(INFO.LT.0)) GO TO 20007 - GO TO 30001 -C -C++ CODE FOR OUTPUT=YES IS ACTIVE -20007 IF (.NOT.(KPRINT.GE.1)) GO TO 20008 - GO TO 30003 -20011 CONTINUE -C++ CODE FOR OUTPUT=NO IS INACTIVE -C++ END -C -C INITIALIZATION. SCALE DATA, NORMALIZE BOUNDS, FORM COLUMN -C CHECK SUMS, AND FORM INITIAL BASIS MATRIX. -20008 CALL SPINIT(MRELAS,NVARS,COSTS,BL,BU,IND,PRIMAL,INFO, - * AMAT,CSC,COSTSC,COLNRM,XLAMDA,ANORM,RHS,RHSNRM, - * IBASIS,IBB,IMAT,LOPT) - IF (.NOT.(INFO.LT.0)) GO TO 20012 - GO TO 30001 -C -20012 NREDC=0 - ASSIGN 20013 TO NPR004 - GO TO 30004 -20013 IF (.NOT.(SINGLR)) GO TO 20014 - NERR=23 - CALL XERMSG ('SLATEC', 'SPLPMN', - + 'IN SPLP, A SINGULAR INITIAL BASIS WAS ENCOUNTERED.', NERR, - + IOPT) - INFO=-NERR - GO TO 30001 -20014 ASSIGN 20018 TO NPR005 - GO TO 30005 -20018 ASSIGN 20019 TO NPR006 - GO TO 30006 -20019 ASSIGN 20020 TO NPR007 - GO TO 30007 -20020 IF (.NOT.(USRBAS)) GO TO 20021 - ASSIGN 20024 TO NPR008 - GO TO 30008 -20024 IF (.NOT.(.NOT.FEAS)) GO TO 20025 - NERR=24 - CALL XERMSG ('SLATEC', 'SPLPMN', - + 'IN SPLP, AN INFEASIBLE INITIAL BASIS WAS ENCOUNTERED.', NERR, - + IOPT) - INFO=-NERR - GO TO 30001 -20025 CONTINUE -20021 ITLP=0 -C -C LAMDA HAS BEEN SET TO A CONSTANT, PERFORM PENALTY METHOD. - ASSIGN 20029 TO NPR009 - GO TO 30009 -20029 ASSIGN 20030 TO NPR010 - GO TO 30010 -20030 ASSIGN 20031 TO NPR006 - GO TO 30006 -20031 ASSIGN 20032 TO NPR008 - GO TO 30008 -20032 IF (.NOT.(.NOT.FEAS)) GO TO 20033 -C -C SET LAMDA TO INFINITY BY SETTING COSTSC TO ZERO (SAVE THE VALUE OF -C COSTSC) AND PERFORM STANDARD PHASE-1. - IF(KPRINT.GE.2)CALL IVOUT(0,IDUM,'('' ENTER STANDARD PHASE-1'')', - *IDG) - SCOSTS=COSTSC - COSTSC=ZERO - ASSIGN 20036 TO NPR007 - GO TO 30007 -20036 ASSIGN 20037 TO NPR009 - GO TO 30009 -20037 ASSIGN 20038 TO NPR010 - GO TO 30010 -20038 ASSIGN 20039 TO NPR006 - GO TO 30006 -20039 ASSIGN 20040 TO NPR008 - GO TO 30008 -20040 IF (.NOT.(FEAS)) GO TO 20041 -C -C SET LAMDA TO ZERO, COSTSC=SCOSTS, PERFORM STANDARD PHASE-2. - IF(KPRINT.GT.1)CALL IVOUT(0,IDUM,'('' ENTER STANDARD PHASE-2'')', - *IDG) - XLAMDA=ZERO - COSTSC=SCOSTS - ASSIGN 20044 TO NPR009 - GO TO 30009 -20044 CONTINUE -20041 GO TO 20034 -C CHECK IF ANY BASIC VARIABLES ARE STILL CLASSIFIED AS -C INFEASIBLE. IF ANY ARE, THEN THIS MAY NOT YET BE AN -C OPTIMAL POINT. THEREFORE SET LAMDA TO ZERO AND TRY -C TO PERFORM MORE SIMPLEX STEPS. -20033 I=1 - N20046=MRELAS - GO TO 20047 -20046 I=I+1 -20047 IF ((N20046-I).LT.0) GO TO 20048 - IF (PRIMAL(I+NVARS).NE.ZERO) GO TO 20045 - GO TO 20046 -20048 GO TO 20035 -20045 XLAMDA=ZERO - ASSIGN 20050 TO NPR009 - GO TO 30009 -20050 CONTINUE -20034 CONTINUE -C -20035 ASSIGN 20051 TO NPR011 - GO TO 30011 -20051 IF (.NOT.(FEAS.AND.(.NOT.UNBND))) GO TO 20052 - INFO=1 - GO TO 20053 -20052 IF (.NOT.((.NOT.FEAS).AND.(.NOT.UNBND))) GO TO 10001 - NERR=1 - CALL XERMSG ('SLATEC', 'SPLPMN', - + 'IN SPLP, THE PROBLEM APPEARS TO BE INFEASIBLE', NERR, IOPT) - INFO=-NERR - GO TO 20053 -10001 IF (.NOT.(FEAS .AND. UNBND)) GO TO 10002 - NERR=2 - CALL XERMSG ('SLATEC', 'SPLPMN', - + 'IN SPLP, THE PROBLEM APPEARS TO HAVE NO FINITE SOLUTION.', - + NERR, IOPT) - INFO=-NERR - GO TO 20053 -10002 IF (.NOT.((.NOT.FEAS).AND.UNBND)) GO TO 10003 - NERR=3 - CALL XERMSG ('SLATEC', 'SPLPMN', - + 'IN SPLP, THE PROBLEM APPEARS TO BE INFEASIBLE AND TO HAVE ' // - + 'NO FINITE SOLUTION.', NERR, IOPT) - INFO=-NERR -10003 CONTINUE -20053 CONTINUE -C - IF (.NOT.(INFO.EQ.(-1) .OR. INFO.EQ.(-3))) GO TO 20055 - SIZE=SASUM(NVARS,PRIMAL,1)*ANORM - SIZE=SIZE/SASUM(NVARS,CSC,1) - SIZE=SIZE+SASUM(MRELAS,PRIMAL(NVARS+1),1) - I=1 - N20058=NVARS+MRELAS - GO TO 20059 -20058 I=I+1 -20059 IF ((N20058-I).LT.0) GO TO 20060 - NX0066=IND(I) - IF (NX0066.LT.1.OR.NX0066.GT.4) GO TO 20066 - GO TO (20062,20063,20064,20065), NX0066 -20062 IF (.NOT.(SIZE+ABS(PRIMAL(I)-BL(I))*FACTOR.EQ.SIZE)) GO TO 20068 - GO TO 20058 -20068 IF (.NOT.(PRIMAL(I).GT.BL(I))) GO TO 10004 - GO TO 20058 -10004 IND(I)=-4 - GO TO 20067 -20063 IF (.NOT.(SIZE+ABS(PRIMAL(I)-BU(I))*FACTOR.EQ.SIZE)) GO TO 20071 - GO TO 20058 -20071 IF (.NOT.(PRIMAL(I).LT.BU(I))) GO TO 10005 - GO TO 20058 -10005 IND(I)=-4 - GO TO 20067 -20064 IF (.NOT.(SIZE+ABS(PRIMAL(I)-BL(I))*FACTOR.EQ.SIZE)) GO TO 20074 - GO TO 20058 -20074 IF (.NOT.(PRIMAL(I).LT.BL(I))) GO TO 10006 - IND(I)=-4 - GO TO 20075 -10006 IF (.NOT.(SIZE+ABS(PRIMAL(I)-BU(I))*FACTOR.EQ.SIZE)) GO TO 10007 - GO TO 20058 -10007 IF (.NOT.(PRIMAL(I).GT.BU(I))) GO TO 10008 - IND(I)=-4 - GO TO 20075 -10008 GO TO 20058 -20075 GO TO 20067 -20065 GO TO 20058 -20066 CONTINUE -20067 GO TO 20058 -20060 CONTINUE -20055 CONTINUE -C - IF (.NOT.(INFO.EQ.(-2) .OR. INFO.EQ.(-3))) GO TO 20077 - J=1 - N20080=NVARS - GO TO 20081 -20080 J=J+1 -20081 IF ((N20080-J).LT.0) GO TO 20082 - IF (.NOT.(IBB(J).EQ.0)) GO TO 20084 - NX0091=IND(J) - IF (NX0091.LT.1.OR.NX0091.GT.4) GO TO 20091 - GO TO (20087,20088,20089,20090), NX0091 -20087 BU(J)=BL(J) - IND(J)=-3 - GO TO 20092 -20088 BL(J)=BU(J) - IND(J)=-3 - GO TO 20092 -20089 GO TO 20080 -20090 BL(J)=ZERO - BU(J)=ZERO - IND(J)=-3 -20091 CONTINUE -20092 CONTINUE -20084 GO TO 20080 -20082 CONTINUE -20077 CONTINUE -C++ CODE FOR OUTPUT=YES IS ACTIVE - IF (.NOT.(KPRINT.GE.1)) GO TO 20093 - ASSIGN 20096 TO NPR012 - GO TO 30012 -20096 CONTINUE -20093 CONTINUE -C++ CODE FOR OUTPUT=NO IS INACTIVE -C++ END - GO TO 30001 -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (COMPUTE RIGHT HAND SIDE) -30010 RHS(1)=ZERO - CALL SCOPY(MRELAS,RHS,0,RHS,1) - J=1 - N20098=NVARS+MRELAS - GO TO 20099 -20098 J=J+1 -20099 IF ((N20098-J).LT.0) GO TO 20100 - NX0106=IND(J) - IF (NX0106.LT.1.OR.NX0106.GT.4) GO TO 20106 - GO TO (20102,20103,20104,20105), NX0106 -20102 SCALR=-BL(J) - GO TO 20107 -20103 SCALR=-BU(J) - GO TO 20107 -20104 SCALR=-BL(J) - GO TO 20107 -20105 SCALR=ZERO -20106 CONTINUE -20107 IF (.NOT.(SCALR.NE.ZERO)) GO TO 20108 - IF (.NOT.(J.LE.NVARS)) GO TO 20111 - I=0 -20114 CALL PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,J) - IF (.NOT.(I.LE.0)) GO TO 20116 - GO TO 20115 -20116 RHS(I)=RHS(I)+AIJ*SCALR - GO TO 20114 -20115 GO TO 20112 -20111 RHS(J-NVARS)=RHS(J-NVARS)-SCALR -20112 CONTINUE -20108 GO TO 20098 -20100 J=1 - N20119=NVARS+MRELAS - GO TO 20120 -20119 J=J+1 -20120 IF ((N20119-J).LT.0) GO TO 20121 - SCALR=ZERO - IF(IND(J).EQ.3.AND.MOD(IBB(J),2).EQ.0) SCALR=BU(J)-BL(J) - IF (.NOT.(SCALR.NE.ZERO)) GO TO 20123 - IF (.NOT.(J.LE.NVARS)) GO TO 20126 - I=0 -20129 CALL PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,J) - IF (.NOT.(I.LE.0)) GO TO 20131 - GO TO 20130 -20131 RHS(I)=RHS(I)-AIJ*SCALR - GO TO 20129 -20130 GO TO 20127 -20126 RHS(J-NVARS)=RHS(J-NVARS)+SCALR -20127 CONTINUE -20123 GO TO 20119 -20121 CONTINUE - GO TO NPR010, (20030,20038) -C PROCEDURE (PERFORM SIMPLEX STEPS) -30009 ASSIGN 20134 TO NPR013 - GO TO 30013 -20134 ASSIGN 20135 TO NPR014 - GO TO 30014 -20135 IF (.NOT.(KPRINT.GT.2)) GO TO 20136 - CALL SVOUT(MRELAS,DUALS,'('' BASIC (INTERNAL) DUAL SOLN.'')',IDG) - CALL SVOUT(NVARS+MRELAS,RZ,'('' REDUCED COSTS'')',IDG) -20136 CONTINUE -20139 ASSIGN 20141 TO NPR015 - GO TO 30015 -20141 IF (.NOT.(.NOT. FOUND)) GO TO 20142 - GO TO 30016 -20145 CONTINUE -20142 IF (.NOT.(FOUND)) GO TO 20146 - IF (KPRINT.GE.3) CALL SVOUT(MRELAS,WW,'('' SEARCH DIRECTION'')', - *IDG) - GO TO 30017 -20149 IF (.NOT.(FINITE)) GO TO 20150 - GO TO 30018 -20153 ASSIGN 20154 TO NPR005 - GO TO 30005 -20154 GO TO 20151 -20150 UNBND=.TRUE. - IBB(IBASIS(IENTER))=0 -20151 GO TO 20147 -20146 GO TO 20140 -20147 ITLP=ITLP+1 - GO TO 30019 -20155 GO TO 20139 -20140 CONTINUE - GO TO NPR009, (20029,20037,20044,20050) -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (RETRIEVE SAVED DATA FROM FILE ISAVE) -30002 LPR=NVARS+4 - REWIND ISAVE - READ(ISAVE) (AMAT(I),I=1,LPR),(IMAT(I),I=1,LPR) - KEY=2 - IPAGE=1 - GO TO 20157 -20156 IF (NP.LT.0) GO TO 20158 -20157 LPR1=LPR+1 - READ(ISAVE) (AMAT(I),I=LPR1,LMX),(IMAT(I),I=LPR1,LMX) - CALL PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT) - NP=IMAT(LMX-1) - IPAGE=IPAGE+1 - GO TO 20156 -20158 NPARM=NVARS+MRELAS - READ(ISAVE) (IBASIS(I),I=1,NPARM) - REWIND ISAVE - GO TO 20006 -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (SAVE DATA ON FILE ISAVE) -C -C SOME PAGES MAY NOT BE WRITTEN YET. -30020 IF (.NOT.(AMAT(LMX).EQ.ONE)) GO TO 20159 - AMAT(LMX)=ZERO - KEY=2 - IPAGE=ABS(IMAT(LMX-1)) - CALL PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT) -C -C FORCE PAGE FILE TO BE OPENED ON RESTARTS. -20159 KEY=AMAT(4) - AMAT(4)=ZERO - LPR=NVARS+4 - WRITE(ISAVE) (AMAT(I),I=1,LPR),(IMAT(I),I=1,LPR) - AMAT(4)=KEY - IPAGE=1 - KEY=1 - GO TO 20163 -20162 IF (NP.LT.0) GO TO 20164 -20163 CALL PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT) - LPR1=LPR+1 - WRITE(ISAVE) (AMAT(I),I=LPR1,LMX),(IMAT(I),I=LPR1,LMX) - NP=IMAT(LMX-1) - IPAGE=IPAGE+1 - GO TO 20162 -20164 NPARM=NVARS+MRELAS - WRITE(ISAVE) (IBASIS(I),I=1,NPARM) - ENDFILE ISAVE -C -C CLOSE FILE, IPAGEF, WHERE PAGES ARE STORED. THIS IS NEEDED SO THAT -C THE PAGES MAY BE RESTORED AT A CONTINUATION OF SPLP(). - GO TO 20317 -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (DECOMPOSE BASIS MATRIX) -C++ CODE FOR OUTPUT=YES IS ACTIVE -30004 IF (.NOT.(KPRINT.GE.2)) GO TO 20165 - CALL IVOUT(MRELAS,IBASIS, - *'('' SUBSCRIPTS OF BASIC VARIABLES DURING REDECOMPOSITION'')', - *IDG) -C++ CODE FOR OUTPUT=NO IS INACTIVE -C++ END -C -C SET RELATIVE PIVOTING FACTOR FOR USE IN LA05 () PACKAGE. -20165 UU=0.1 - CALL SPLPDM( - *MRELAS,NVARS,LMX,LBM,NREDC,INFO,IOPT, - *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB, - *ANORM,EPS,UU,GG, - *AMAT,BASMAT,CSC,WR, - *SINGLR,REDBAS) - IF (.NOT.(INFO.LT.0)) GO TO 20168 - GO TO 30001 -20168 CONTINUE - GO TO NPR004, (20013,20204,20242) -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (CLASSIFY VARIABLES) -C -C DEFINE THE CLASSIFICATION OF THE BASIC VARIABLES -C -1 VIOLATES LOWER BOUND, 0 FEASIBLE, +1 VIOLATES UPPER BOUND. -C (THIS INFO IS STORED IN PRIMAL(NVARS+1)-PRIMAL(NVARS+MRELAS)) -C TRANSLATE VARIABLE TO ITS UPPER BOUND, IF .GT. UPPER BOUND -30007 PRIMAL(NVARS+1)=ZERO - CALL SCOPY(MRELAS,PRIMAL(NVARS+1),0,PRIMAL(NVARS+1),1) - I=1 - N20172=MRELAS - GO TO 20173 -20172 I=I+1 -20173 IF ((N20172-I).LT.0) GO TO 20174 - J=IBASIS(I) - IF (.NOT.(IND(J).NE.4)) GO TO 20176 - IF (.NOT.(RPRIM(I).LT.ZERO)) GO TO 20179 - PRIMAL(I+NVARS)=-ONE - GO TO 20180 -20179 IF (.NOT.(IND(J).EQ.3)) GO TO 10009 - UPBND=BU(J)-BL(J) - IF (J.LE.NVARS) UPBND=UPBND/CSC(J) - IF (.NOT.(RPRIM(I).GT.UPBND)) GO TO 20182 - RPRIM(I)=RPRIM(I)-UPBND - IF (.NOT.(J.LE.NVARS)) GO TO 20185 - K=0 -20188 CALL PNNZRS(K,AIJ,IPLACE,AMAT,IMAT,J) - IF (.NOT.(K.LE.0)) GO TO 20190 - GO TO 20189 -20190 RHS(K)=RHS(K)-UPBND*AIJ*CSC(J) - GO TO 20188 -20189 GO TO 20186 -20185 RHS(J-NVARS)=RHS(J-NVARS)+UPBND -20186 PRIMAL(I+NVARS)=ONE -20182 CONTINUE - CONTINUE -10009 CONTINUE -20180 CONTINUE -20176 GO TO 20172 -20174 CONTINUE - GO TO NPR007, (20020,20036) -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (COMPUTE ERROR IN DUAL AND PRIMAL SYSTEMS) -30005 NTRIES=1 - GO TO 20195 -20194 NTRIES=NTRIES+1 -20195 IF ((2-NTRIES).LT.0) GO TO 20196 - CALL SPLPCE( - *MRELAS,NVARS,LMX,LBM,ITLP,ITBRC, - *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB, - *ERDNRM,EPS,TUNE,GG, - *AMAT,BASMAT,CSC,WR,WW,PRIMAL,ERD,ERP, - *SINGLR,REDBAS) - IF (.NOT.(.NOT. SINGLR)) GO TO 20198 -C++ CODE FOR OUTPUT=YES IS ACTIVE - IF (.NOT.(KPRINT.GE.3)) GO TO 20201 - CALL SVOUT(MRELAS,ERP,'('' EST. ERROR IN PRIMAL COMPS.'')',IDG) - CALL SVOUT(MRELAS,ERD,'('' EST. ERROR IN DUAL COMPS.'')',IDG) -20201 CONTINUE -C++ CODE FOR OUTPUT=NO IS INACTIVE -C++ END - GO TO 20193 -20198 IF (NTRIES.EQ.2) GO TO 20197 - ASSIGN 20204 TO NPR004 - GO TO 30004 -20204 CONTINUE - GO TO 20194 -20196 CONTINUE -20197 NERR=26 - CALL XERMSG ('SLATEC', 'SPLPMN', - + 'IN SPLP, MOVED TO A SINGULAR POINT. THIS SHOULD NOT HAPPEN.', - + NERR, IOPT) - INFO=-NERR - GO TO 30001 -20193 CONTINUE - GO TO NPR005, (20018,20154,20243) -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (CHECK FEASIBILITY) -C -C SEE IF NEARBY FEASIBLE POINT SATISFIES THE CONSTRAINT -C EQUATIONS. -C -C COPY RHS INTO WW(*), THEN UPDATE WW(*). -30008 CALL SCOPY(MRELAS,RHS,1,WW,1) - J=1 - N20206=MRELAS - GO TO 20207 -20206 J=J+1 -20207 IF ((N20206-J).LT.0) GO TO 20208 - IBAS=IBASIS(J) - XVAL=RPRIM(J) -C -C ALL VARIABLES BOUNDED BELOW HAVE ZERO AS THAT BOUND. - IF (IND(IBAS).LE.3) XVAL=MAX(ZERO,XVAL) -C -C IF THE VARIABLE HAS AN UPPER BOUND, COMPUTE THAT BOUND. - IF (.NOT.(IND(IBAS).EQ.3)) GO TO 20210 - UPBND=BU(IBAS)-BL(IBAS) - IF (IBAS.LE.NVARS) UPBND=UPBND/CSC(IBAS) - XVAL=MIN(UPBND,XVAL) -20210 CONTINUE -C -C SUBTRACT XVAL TIMES COLUMN VECTOR FROM RIGHT-HAND SIDE IN WW(*) - IF (.NOT.(XVAL.NE.ZERO)) GO TO 20213 - IF (.NOT.(IBAS.LE.NVARS)) GO TO 20216 - I=0 -20219 CALL PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,IBAS) - IF (.NOT.(I.LE.0)) GO TO 20221 - GO TO 20220 -20221 WW(I)=WW(I)-XVAL*AIJ*CSC(IBAS) - GO TO 20219 -20220 GO TO 20217 -20216 IF (.NOT.(IND(IBAS).EQ.2)) GO TO 20224 - WW(IBAS-NVARS)=WW(IBAS-NVARS)-XVAL - GO TO 20225 -20224 WW(IBAS-NVARS)=WW(IBAS-NVARS)+XVAL -20225 CONTINUE -20217 CONTINUE -20213 CONTINUE - GO TO 20206 -C -C COMPUTE NORM OF DIFFERENCE AND CHECK FOR FEASIBILITY. -20208 RESNRM=SASUM(MRELAS,WW,1) - FEAS=RESNRM.LE.TOLLS*(RPRNRM*ANORM+RHSNRM) -C -C TRY AN ABSOLUTE ERROR TEST IF THE RELATIVE TEST FAILS. - IF(.NOT. FEAS)FEAS=RESNRM.LE.TOLABS - IF (.NOT.(FEAS)) GO TO 20227 - PRIMAL(NVARS+1)=ZERO - CALL SCOPY(MRELAS,PRIMAL(NVARS+1),0,PRIMAL(NVARS+1),1) -20227 CONTINUE - GO TO NPR008, (20024,20032,20040) -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (INITIALIZE REDUCED COSTS AND STEEPEST EDGE WEIGHTS) -30014 CALL SPINCW( - *MRELAS,NVARS,LMX,LBM,NPP,JSTRT, - *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB, - *COSTSC,GG,ERDNRM,DULNRM, - *AMAT,BASMAT,CSC,WR,WW,RZ,RG,COSTS,COLNRM,DUALS, - *STPEDG) -C - GO TO NPR014, (20135,20246) -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (CHECK AND RETURN WITH EXCESS ITERATIONS) -30019 IF (.NOT.(ITLP.GT.MXITLP)) GO TO 20230 - NERR=25 - ASSIGN 20233 TO NPR011 - GO TO 30011 -C++ CODE FOR OUTPUT=YES IS ACTIVE -20233 IF (.NOT.(KPRINT.GE.1)) GO TO 20234 - ASSIGN 20237 TO NPR012 - GO TO 30012 -20237 CONTINUE -20234 CONTINUE -C++ CODE FOR OUTPUT=NO IS INACTIVE -C++ END - IDUM(1)=0 - IF(SAVEDT) IDUM(1)=ISAVE - WRITE (XERN1, '(I8)') MXITLP - WRITE (XERN2, '(I8)') IDUM(1) - CALL XERMSG ('SLATEC', 'SPLPMN', - * 'IN SPLP, MAX ITERATIONS = ' // XERN1 // - * ' TAKEN. UP-TO-DATE RESULTS SAVED ON FILE NO. ' // XERN2 // - * '. IF FILE NO. = 0, NO SAVE.', NERR, IOPT) - INFO=-NERR - GO TO 30001 -20230 CONTINUE - GO TO 20155 -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (REDECOMPOSE BASIS MATRIX AND TRY AGAIN) -30016 IF (.NOT.(.NOT.REDBAS)) GO TO 20239 - ASSIGN 20242 TO NPR004 - GO TO 30004 -20242 ASSIGN 20243 TO NPR005 - GO TO 30005 -20243 ASSIGN 20244 TO NPR006 - GO TO 30006 -20244 ASSIGN 20245 TO NPR013 - GO TO 30013 -20245 ASSIGN 20246 TO NPR014 - GO TO 30014 -20246 CONTINUE -C -C ERASE NON-CYCLING MARKERS NEAR COMPLETION. -20239 I=MRELAS+1 - N20247=MRELAS+NVARS - GO TO 20248 -20247 I=I+1 -20248 IF ((N20247-I).LT.0) GO TO 20249 - IBASIS(I)=ABS(IBASIS(I)) - GO TO 20247 -20249 ASSIGN 20251 TO NPR015 - GO TO 30015 -20251 CONTINUE - GO TO 20145 -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (COMPUTE NEW PRIMAL) -C -C COPY RHS INTO WW(*), SOLVE SYSTEM. -30006 CALL SCOPY(MRELAS,RHS,1,WW,1) - TRANS = .FALSE. - CALL LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) - CALL SCOPY(MRELAS,WW,1,RPRIM,1) - RPRNRM=SASUM(MRELAS,RPRIM,1) - GO TO NPR006, (20019,20031,20039,20244,20275) -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (COMPUTE NEW DUALS) -C -C SOLVE FOR DUAL VARIABLES. FIRST COPY COSTS INTO DUALS(*). -30013 I=1 - N20252=MRELAS - GO TO 20253 -20252 I=I+1 -20253 IF ((N20252-I).LT.0) GO TO 20254 - J=IBASIS(I) - IF (.NOT.(J.LE.NVARS)) GO TO 20256 - DUALS(I)=COSTSC*COSTS(J)*CSC(J) + XLAMDA*PRIMAL(I+NVARS) - GO TO 20257 -20256 DUALS(I)=XLAMDA*PRIMAL(I+NVARS) -20257 CONTINUE - GO TO 20252 -C -20254 TRANS=.TRUE. - CALL LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,DUALS,TRANS) - DULNRM=SASUM(MRELAS,DUALS,1) - GO TO NPR013, (20134,20245,20267) -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (FIND VARIABLE TO ENTER BASIS AND GET SEARCH DIRECTION) -30015 CALL SPLPFE( - *MRELAS,NVARS,LMX,LBM,IENTER, - *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB, - *ERDNRM,EPS,GG,DULNRM,DIRNRM, - *AMAT,BASMAT,CSC,WR,WW,BL,BU,RZ,RG,COLNRM,DUALS, - *FOUND) - GO TO NPR015, (20141,20251) -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (CHOOSE VARIABLE TO LEAVE BASIS) -30017 CALL SPLPFL( - *MRELAS,NVARS,IENTER,ILEAVE, - *IBASIS,IND,IBB, - *THETA,DIRNRM,RPRNRM, - *CSC,WW,BL,BU,ERP,RPRIM,PRIMAL, - *FINITE,ZEROLV) - GO TO 20149 -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (MAKE MOVE AND UPDATE) -30018 CALL SPLPMU( - *MRELAS,NVARS,LMX,LBM,NREDC,INFO,IENTER,ILEAVE,IOPT,NPP,JSTRT, - *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB, - *ANORM,EPS,UU,GG,RPRNRM,ERDNRM,DULNRM,THETA,COSTSC,XLAMDA,RHSNRM, - *AMAT,BASMAT,CSC,WR,RPRIM,WW,BU,BL,RHS,ERD,ERP,RZ,RG,COLNRM,COSTS, - *PRIMAL,DUALS,SINGLR,REDBAS,ZEROLV,STPEDG) - IF (.NOT.(INFO.EQ.(-26))) GO TO 20259 - GO TO 30001 -C++ CODE FOR OUTPUT=YES IS ACTIVE -20259 IF (.NOT.(KPRINT.GE.2)) GO TO 20263 - GO TO 30021 -20266 CONTINUE -C++ CODE FOR OUTPUT=NO IS INACTIVE -C++ END -20263 CONTINUE - GO TO 20153 -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE(RESCALE AND REARRANGE VARIABLES) -C -C RESCALE THE DUAL VARIABLES. -30011 ASSIGN 20267 TO NPR013 - GO TO 30013 -20267 IF (.NOT.(COSTSC.NE.ZERO)) GO TO 20268 - I=1 - N20271=MRELAS - GO TO 20272 -20271 I=I+1 -20272 IF ((N20271-I).LT.0) GO TO 20273 - DUALS(I)=DUALS(I)/COSTSC - GO TO 20271 -20273 CONTINUE -20268 ASSIGN 20275 TO NPR006 - GO TO 30006 -C -C REAPPLY COLUMN SCALING TO PRIMAL. -20275 I=1 - N20276=MRELAS - GO TO 20277 -20276 I=I+1 -20277 IF ((N20276-I).LT.0) GO TO 20278 - J=IBASIS(I) - IF (.NOT.(J.LE.NVARS)) GO TO 20280 - SCALR=CSC(J) - IF(IND(J).EQ.2)SCALR=-SCALR - RPRIM(I)=RPRIM(I)*SCALR -20280 GO TO 20276 -C -C REPLACE TRANSLATED BASIC VARIABLES INTO ARRAY PRIMAL(*) -20278 PRIMAL(1)=ZERO - CALL SCOPY(NVARS+MRELAS,PRIMAL,0,PRIMAL,1) - J=1 - N20283=NVARS+MRELAS - GO TO 20284 -20283 J=J+1 -20284 IF ((N20283-J).LT.0) GO TO 20285 - IBAS=ABS(IBASIS(J)) - XVAL=ZERO - IF (J.LE.MRELAS) XVAL=RPRIM(J) - IF (IND(IBAS).EQ.1) XVAL=XVAL+BL(IBAS) - IF (IND(IBAS).EQ.2) XVAL=BU(IBAS)-XVAL - IF (.NOT.(IND(IBAS).EQ.3)) GO TO 20287 - IF (MOD(IBB(IBAS),2).EQ.0) XVAL=BU(IBAS)-BL(IBAS)-XVAL - XVAL = XVAL+BL(IBAS) -20287 PRIMAL(IBAS)=XVAL - GO TO 20283 -C -C COMPUTE DUALS FOR INDEPENDENT VARIABLES WITH BOUNDS. -C OTHER ENTRIES ARE ZERO. -20285 J=1 - N20290=NVARS - GO TO 20291 -20290 J=J+1 -20291 IF ((N20290-J).LT.0) GO TO 20292 - RZJ=ZERO - IF (.NOT.(IBB(J).GT.ZERO .AND. IND(J).NE.4)) GO TO 20294 - RZJ=COSTS(J) - I=0 -20297 CALL PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,J) - IF (.NOT.(I.LE.0)) GO TO 20299 - GO TO 20298 -20299 CONTINUE - RZJ=RZJ-AIJ*DUALS(I) - GO TO 20297 -20298 CONTINUE -20294 DUALS(MRELAS+J)=RZJ - GO TO 20290 -20292 CONTINUE - GO TO NPR011, (20051,20233) -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C++ CODE FOR OUTPUT=YES IS ACTIVE -C PROCEDURE (PRINT PROLOGUE) -30003 IDUM(1)=MRELAS - CALL IVOUT(1,IDUM,'(''1NUM. OF DEPENDENT VARS., MRELAS'')',IDG) - IDUM(1)=NVARS - CALL IVOUT(1,IDUM,'('' NUM. OF INDEPENDENT VARS., NVARS'')',IDG) - CALL IVOUT(1,IDUM,'('' DIMENSION OF COSTS(*)='')',IDG) - IDUM(1)=NVARS+MRELAS - CALL IVOUT(1,IDUM, '('' DIMENSIONS OF BL(*),BU(*),IND(*)'' - */'' PRIMAL(*),DUALS(*) ='')',IDG) - CALL IVOUT(1,IDUM,'('' DIMENSION OF IBASIS(*)='')',IDG) - IDUM(1)=LPRG+1 - CALL IVOUT(1,IDUM,'('' DIMENSION OF PRGOPT(*)='')',IDG) - CALL IVOUT(0,IDUM, - * '('' 1-NVARS=INDEPENDENT VARIABLE INDICES.''/ - * '' (NVARS+1)-(NVARS+MRELAS)=DEPENDENT VARIABLE INDICES.''/ - * '' CONSTRAINT INDICATORS ARE 1-4 AND MEAN'')',IDG) - CALL IVOUT(0,IDUM, - * '('' 1=VARIABLE HAS ONLY LOWER BOUND.''/ - * '' 2=VARIABLE HAS ONLY UPPER BOUND.''/ - * '' 3=VARIABLE HAS BOTH BOUNDS.''/ - * '' 4=VARIABLE HAS NO BOUNDS, IT IS FREE.'')',IDG) - CALL SVOUT(NVARS,COSTS,'('' ARRAY OF COSTS'')',IDG) - CALL IVOUT(NVARS+MRELAS,IND, - * '('' CONSTRAINT INDICATORS'')',IDG) - CALL SVOUT(NVARS+MRELAS,BL, - *'('' LOWER BOUNDS FOR VARIABLES (IGNORE UNUSED ENTRIES.)'')',IDG) - CALL SVOUT(NVARS+MRELAS,BU, - *'('' UPPER BOUNDS FOR VARIABLES (IGNORE UNUSED ENTRIES.)'')',IDG) - IF (.NOT.(KPRINT.GE.2)) GO TO 20302 - CALL IVOUT(0,IDUM, - * '(''0NON-BASIC INDICES THAT ARE NEGATIVE SHOW VARIABLES'' - * '' EXCHANGED AT A ZERO''/'' STEP LENGTH'')',IDG) - CALL IVOUT(0,IDUM, - * '('' WHEN COL. NO. LEAVING=COL. NO. ENTERING, THE ENTERING '' - * ''VARIABLE MOVED''/'' TO ITS BOUND. IT REMAINS NON-BASIC.''/ - * '' WHEN COL. NO. OF BASIS EXCHANGED IS NEGATIVE, THE LEAVING''/ - * '' VARIABLE IS AT ITS UPPER BOUND.'')',IDG) -20302 CONTINUE - GO TO 20011 -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (PRINT SUMMARY) -30012 IDUM(1)=INFO - CALL IVOUT(1,IDUM,'('' THE OUTPUT VALUE OF INFO IS'')',IDG) - IF (.NOT.(MINPRB)) GO TO 20305 - CALL IVOUT(0,IDUM,'('' THIS IS A MINIMIZATION PROBLEM.'')',IDG) - GO TO 20306 -20305 CALL IVOUT(0,IDUM,'('' THIS IS A MAXIMIZATION PROBLEM.'')',IDG) -20306 IF (.NOT.(STPEDG)) GO TO 20308 - CALL IVOUT(0,IDUM,'('' STEEPEST EDGE PRICING WAS USED.'')',IDG) - GO TO 20309 -20308 CALL IVOUT(0,IDUM,'('' MINIMUM REDUCED COST PRICING WAS USED.'')', - * IDG) -20309 RDUM(1)=SDOT(NVARS,COSTS,1,PRIMAL,1) - CALL SVOUT(1,RDUM, - * '('' OUTPUT VALUE OF THE OBJECTIVE FUNCTION'')',IDG) - CALL SVOUT(NVARS+MRELAS,PRIMAL, - * '('' THE OUTPUT INDEPENDENT AND DEPENDENT VARIABLES'')',IDG) - CALL SVOUT(MRELAS+NVARS,DUALS, - * '('' THE OUTPUT DUAL VARIABLES'')',IDG) - CALL IVOUT(NVARS+MRELAS,IBASIS, - * '('' VARIABLE INDICES IN POSITIONS 1-MRELAS ARE BASIC.'')',IDG) - IDUM(1)=ITLP - CALL IVOUT(1,IDUM,'('' NO. OF ITERATIONS'')',IDG) - IDUM(1)=NREDC - CALL IVOUT(1,IDUM,'('' NO. OF FULL REDECOMPS'')',IDG) - GO TO NPR012, (20096,20237) -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (PRINT ITERATION SUMMARY) -30021 IDUM(1)=ITLP+1 - CALL IVOUT(1,IDUM,'(''0ITERATION NUMBER'')',IDG) - IDUM(1)=IBASIS(ABS(ILEAVE)) - CALL IVOUT(1,IDUM, - * '('' INDEX OF VARIABLE ENTERING THE BASIS'')',IDG) - IDUM(1)=ILEAVE - CALL IVOUT(1,IDUM,'('' COLUMN OF THE BASIS EXCHANGED'')',IDG) - IDUM(1)=IBASIS(IENTER) - CALL IVOUT(1,IDUM, - * '('' INDEX OF VARIABLE LEAVING THE BASIS'')',IDG) - RDUM(1)=THETA - CALL SVOUT(1,RDUM,'('' LENGTH OF THE EXCHANGE STEP'')',IDG) - IF (.NOT.(KPRINT.GE.3)) GO TO 20311 - CALL SVOUT(MRELAS,RPRIM,'('' BASIC (INTERNAL) PRIMAL SOLN.'')', - * IDG) - CALL IVOUT(NVARS+MRELAS,IBASIS, - * '('' VARIABLE INDICES IN POSITIONS 1-MRELAS ARE BASIC.'')',IDG) - CALL IVOUT(NVARS+MRELAS,IBB,'('' IBB ARRAY'')',IDG) - CALL SVOUT(MRELAS,RHS,'('' TRANSLATED RHS'')',IDG) - CALL SVOUT(MRELAS,DUALS,'('' BASIC (INTERNAL) DUAL SOLN.'')',IDG) -20311 CONTINUE - GO TO 20266 -C++ CODE FOR OUTPUT=NO IS INACTIVE -C++ END -C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PROCEDURE (RETURN TO USER) -30001 IF (.NOT.(SAVEDT)) GO TO 20314 - GO TO 30020 -20317 CONTINUE -20314 IF(IMAT(LMX-1).NE.(-1)) CALL SCLOSM(IPAGEF) -C -C THIS TEST IS THERE ONLY TO AVOID DIAGNOSTICS ON SOME FORTRAN -C COMPILERS. - RETURN - END diff --git a/slatec/splpmu.f b/slatec/splpmu.f deleted file mode 100644 index 85d1e80..0000000 --- a/slatec/splpmu.f +++ /dev/null @@ -1,432 +0,0 @@ -*DECK SPLPMU - SUBROUTINE SPLPMU (MRELAS, NVARS, LMX, LBM, NREDC, INFO, IENTER, - + ILEAVE, IOPT, NPP, JSTRT, IBASIS, IMAT, IBRC, IPR, IWR, IND, - + IBB, ANORM, EPS, UU, GG, RPRNRM, ERDNRM, DULNRM, THETA, COSTSC, - + XLAMDA, RHSNRM, AMAT, BASMAT, CSC, WR, RPRIM, WW, BU, BL, RHS, - + ERD, ERP, RZ, RG, COLNRM, COSTS, PRIMAL, DUALS, SINGLR, REDBAS, - + ZEROLV, STPEDG) -C***BEGIN PROLOGUE SPLPMU -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (SPLPMU-S, DPLPMU-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO -C DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. -C -C USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. -C /REAL (12 BLANKS)/DOUBLE PRECISION/, -C /SASUM/DASUM/,/SCOPY/DCOPY/,/SDOT/DDOT/, -C /.E0/.D0/ -C -C THIS SUBPROGRAM IS FROM THE SPLP( ) PACKAGE. IT PERFORMS THE -C TASKS OF UPDATING THE PRIMAL SOLUTION, EDGE WEIGHTS, REDUCED -C COSTS, AND MATRIX DECOMPOSITION. -C IT IS THE MAIN PART OF THE PROCEDURE (MAKE MOVE AND UPDATE). -C -C REVISED 821122-1100 -C REVISED YYMMDD -C -C***SEE ALSO SPLP -C***ROUTINES CALLED IPLOC, LA05BS, LA05CS, PNNZRS, PRWPGE, SASUM, -C SCOPY, SDOT, SPLPDM, XERMSG -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890605 Removed unreferenced labels. (WRB) -C 890606 Removed unused COMMON block LA05DS. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE SPLPMU - INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*) - REAL AIJ,ALPHA,ANORM,COSTSC,ERDNRM,DULNRM,EPS,GAMMA, - * GG,GQ,ONE,RPRNRM,RZJ,SCALR,THETA,TWO,UU,WP,XLAMDA,RHSNRM, - * ZERO,AMAT(*),BASMAT(*),CSC(*),WR(*),RPRIM(*),WW(*),BU(*),BL(*), - * RHS(*),ERD(*),ERP(*),RZ(*),RG(*),COSTS(*),PRIMAL(*),DUALS(*), - * COLNRM(*),RCOST,SASUM,SDOT - LOGICAL SINGLR,REDBAS,PAGEPL,TRANS,ZEROLV,STPEDG -C -C***FIRST EXECUTABLE STATEMENT SPLPMU - ZERO=0.E0 - ONE=1.E0 - TWO=2.E0 - LPG=LMX-(NVARS+4) -C -C UPDATE THE PRIMAL SOLUTION WITH A MULTIPLE OF THE SEARCH -C DIRECTION. - I=1 - N20002=MRELAS - GO TO 20003 -20002 I=I+1 -20003 IF ((N20002-I).LT.0) GO TO 20004 - RPRIM(I)=RPRIM(I)-THETA*WW(I) - GO TO 20002 -C -C IF EJECTED VARIABLE IS LEAVING AT AN UPPER BOUND, THEN -C TRANSLATE RIGHT HAND SIDE. -20004 IF (.NOT.(ILEAVE.LT.0)) GO TO 20006 - IBAS=IBASIS(ABS(ILEAVE)) - SCALR=RPRIM(ABS(ILEAVE)) - ASSIGN 20009 TO NPR001 - GO TO 30001 -20009 IBB(IBAS)=ABS(IBB(IBAS))+1 -C -C IF ENTERING VARIABLE IS RESTRICTED TO ITS UPPER BOUND, TRANSLATE -C RIGHT HAND SIDE. IF THE VARIABLE DECREASED FROM ITS UPPER -C BOUND, A SIGN CHANGE IS REQUIRED IN THE TRANSLATION. -20006 IF (.NOT.(IENTER.EQ.ILEAVE)) GO TO 20010 - IBAS=IBASIS(IENTER) - SCALR=THETA - IF (MOD(IBB(IBAS),2).EQ.0) SCALR=-SCALR - ASSIGN 20013 TO NPR001 - GO TO 30001 -20013 IBB(IBAS)=IBB(IBAS)+1 - GO TO 20011 -20010 IBAS=IBASIS(IENTER) -C -C IF ENTERING VARIABLE IS DECREASING FROM ITS UPPER BOUND, -C COMPLEMENT ITS PRIMAL VALUE. - IF (.NOT.(IND(IBAS).EQ.3.AND.MOD(IBB(IBAS),2).EQ.0)) GO TO 20014 - SCALR=-(BU(IBAS)-BL(IBAS)) - IF (IBAS.LE.NVARS) SCALR=SCALR/CSC(IBAS) - ASSIGN 20017 TO NPR001 - GO TO 30001 -20017 THETA=-SCALR-THETA - IBB(IBAS)=IBB(IBAS)+1 -20014 CONTINUE - RPRIM(ABS(ILEAVE))=THETA - IBB(IBAS)=-ABS(IBB(IBAS)) - I=IBASIS(ABS(ILEAVE)) - IBB(I)=ABS(IBB(I)) - IF(PRIMAL(ABS(ILEAVE)+NVARS).GT.ZERO) IBB(I)=IBB(I)+1 -C -C INTERCHANGE COLUMN POINTERS TO NOTE EXCHANGE OF COLUMNS. -20011 IBAS=IBASIS(IENTER) - IBASIS(IENTER)=IBASIS(ABS(ILEAVE)) - IBASIS(ABS(ILEAVE))=IBAS -C -C IF VARIABLE WAS EXCHANGED AT A ZERO LEVEL, MARK IT SO THAT -C IT CAN'T BE BROUGHT BACK IN. THIS IS TO HELP PREVENT CYCLING. - IF(ZEROLV) IBASIS(IENTER)=-ABS(IBASIS(IENTER)) - RPRNRM=MAX(RPRNRM,SASUM(MRELAS,RPRIM,1)) - K=1 - N20018=MRELAS - GO TO 20019 -20018 K=K+1 -20019 IF ((N20018-K).LT.0) GO TO 20020 -C -C SEE IF VARIABLES THAT WERE CLASSIFIED AS INFEASIBLE HAVE NOW -C BECOME FEASIBLE. THIS MAY REQUIRED TRANSLATING UPPER BOUNDED -C VARIABLES. - IF (.NOT.(PRIMAL(K+NVARS).NE.ZERO .AND. - * ABS(RPRIM(K)).LE.RPRNRM*ERP(K))) GO TO 20022 - IF (.NOT.(PRIMAL(K+NVARS).GT.ZERO)) GO TO 20025 - IBAS=IBASIS(K) - SCALR=-(BU(IBAS)-BL(IBAS)) - IF(IBAS.LE.NVARS)SCALR=SCALR/CSC(IBAS) - ASSIGN 20028 TO NPR001 - GO TO 30001 -20028 RPRIM(K)=-SCALR - RPRNRM=RPRNRM-SCALR -20025 PRIMAL(K+NVARS)=ZERO -20022 CONTINUE - GO TO 20018 -C -C UPDATE REDUCED COSTS, EDGE WEIGHTS, AND MATRIX DECOMPOSITION. -20020 IF (.NOT.(IENTER.NE.ILEAVE)) GO TO 20029 -C -C THE INCOMING VARIABLE IS ALWAYS CLASSIFIED AS FEASIBLE. - PRIMAL(ABS(ILEAVE)+NVARS)=ZERO -C - WP=WW(ABS(ILEAVE)) - GQ=SDOT(MRELAS,WW,1,WW,1)+ONE -C -C COMPUTE INVERSE (TRANSPOSE) TIMES SEARCH DIRECTION. - TRANS=.TRUE. - CALL LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) -C -C UPDATE THE MATRIX DECOMPOSITION. COL. ABS(ILEAVE) IS LEAVING. -C THE ARRAY DUALS(*) CONTAINS INTERMEDIATE RESULTS FOR THE -C INCOMING COLUMN. - CALL LA05CS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,DUALS,GG,UU, - * ABS(ILEAVE)) - REDBAS=.FALSE. - IF (.NOT.(GG.LT.ZERO)) GO TO 20032 -C -C REDECOMPOSE BASIS MATRIX WHEN AN ERROR RETURN FROM -C LA05CS( ) IS NOTED. THIS WILL PROBABLY BE DUE TO -C SPACE BEING EXHAUSTED, GG=-7. - CALL SPLPDM( - *MRELAS,NVARS,LMX,LBM,NREDC,INFO,IOPT, - *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB, - *ANORM,EPS,UU,GG, - *AMAT,BASMAT,CSC,WR, - *SINGLR,REDBAS) - IF (.NOT.(SINGLR)) GO TO 20035 - NERR=26 - CALL XERMSG ('SLATEC', 'SPLPMU', - + 'IN SPLP, MOVED TO A SINGULAR POINT. THIS SHOULD NOT HAPPEN.', - + NERR, IOPT) - INFO=-NERR - RETURN -20035 CONTINUE - GO TO 30002 -20038 CONTINUE -20032 CONTINUE -C -C IF STEEPEST EDGE PRICING IS USED, UPDATE REDUCED COSTS -C AND EDGE WEIGHTS. - IF (.NOT.(STPEDG)) GO TO 20039 -C -C COMPUTE COL. ABS(ILEAVE) OF THE NEW INVERSE (TRANSPOSE) MATRIX -C HERE ABS(ILEAVE) POINTS TO THE EJECTED COLUMN. -C USE ERD(*) FOR TEMP. STORAGE. - CALL SCOPY(MRELAS,ZERO,0,ERD,1) - ERD(ABS(ILEAVE))=ONE - TRANS=.TRUE. - CALL LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,ERD,TRANS) -C -C COMPUTE UPDATED DUAL VARIABLES IN DUALS(*). - ASSIGN 20042 TO NPR003 - GO TO 30003 -C -C COMPUTE THE DOT PRODUCT OF COL. J OF THE NEW INVERSE (TRANSPOSE) -C WITH EACH NON-BASIC COLUMN. ALSO COMPUTE THE DOT PRODUCT OF THE -C INVERSE (TRANSPOSE) OF NON-UPDATED MATRIX (TIMES) THE -C SEARCH DIRECTION WITH EACH NON-BASIC COLUMN. -C RECOMPUTE REDUCED COSTS. -20042 PAGEPL=.TRUE. - CALL SCOPY(NVARS+MRELAS,ZERO,0,RZ,1) - NNEGRC=0 - J=JSTRT -20043 IF (.NOT.(IBB(J).LE.0)) GO TO 20045 - PAGEPL=.TRUE. - RG(J)=ONE - GO TO 20046 -C -C NONBASIC INDEPENDENT VARIABLES (COLUMN IN SPARSE MATRIX STORAGE) -20045 IF (.NOT.(J.LE.NVARS)) GO TO 20048 - RZJ=COSTS(J)*COSTSC - ALPHA=ZERO - GAMMA=ZERO -C -C COMPUTE THE DOT PRODUCT OF THE SPARSE MATRIX NONBASIC COLUMNS -C WITH THREE VECTORS INVOLVED IN THE UPDATING STEP. - IF (.NOT.(J.EQ.1)) GO TO 20051 - ILOW=NVARS+5 - GO TO 20052 -20051 ILOW=IMAT(J+3)+1 -20052 IF (.NOT.(PAGEPL)) GO TO 20054 - IL1=IPLOC(ILOW,AMAT,IMAT) - IF (.NOT.(IL1.GE.LMX-1)) GO TO 20057 - ILOW=ILOW+2 - IL1=IPLOC(ILOW,AMAT,IMAT) -20057 CONTINUE - IPAGE=ABS(IMAT(LMX-1)) - GO TO 20055 -20054 IL1=IHI+1 -20055 IHI=IMAT(J+4)-(ILOW-IL1) -20060 IU1=MIN(LMX-2,IHI) - IF (.NOT.(IL1.GT.IU1)) GO TO 20062 - GO TO 20061 -20062 CONTINUE - DO 10 I=IL1,IU1 - RZJ=RZJ-AMAT(I)*DUALS(IMAT(I)) - ALPHA=ALPHA+AMAT(I)*ERD(IMAT(I)) - GAMMA=GAMMA+AMAT(I)*WW(IMAT(I)) -10 CONTINUE - IF (.NOT.(IHI.LE.LMX-2)) GO TO 20065 - GO TO 20061 -20065 CONTINUE - IPAGE=IPAGE+1 - KEY=1 - CALL PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT) - IL1=NVARS+5 - IHI=IHI-LPG - GO TO 20060 -20061 PAGEPL=IHI.EQ.(LMX-2) - RZ(J)=RZJ*CSC(J) - ALPHA=ALPHA*CSC(J) - GAMMA=GAMMA*CSC(J) - RG(J)=MAX(RG(J)-TWO*ALPHA*GAMMA+ALPHA**2*GQ,ONE+ALPHA**2) -C -C NONBASIC DEPENDENT VARIABLES (COLUMNS DEFINED IMPLICITLY) - GO TO 20049 -20048 PAGEPL=.TRUE. - SCALR=-ONE - IF(IND(J).EQ.2) SCALR=ONE - I=J-NVARS - ALPHA=SCALR*ERD(I) - RZ(J)=-SCALR*DUALS(I) - GAMMA=SCALR*WW(I) - RG(J)=MAX(RG(J)-TWO*ALPHA*GAMMA+ALPHA**2*GQ,ONE+ALPHA**2) -20049 CONTINUE -20046 CONTINUE -C - RCOST=RZ(J) - IF (MOD(IBB(J),2).EQ.0) RCOST=-RCOST - IF (.NOT.(IND(J).EQ.3)) GO TO 20068 - IF(BU(J).EQ.BL(J)) RCOST=ZERO -20068 CONTINUE - IF (IND(J).EQ.4) RCOST=-ABS(RCOST) - CNORM=ONE - IF (J.LE.NVARS) CNORM=COLNRM(J) - IF (RCOST+ERDNRM*DULNRM*CNORM.LT.ZERO) NNEGRC=NNEGRC+1 - J=MOD(J,MRELAS+NVARS)+1 - IF (.NOT.(NNEGRC.GE.NPP .OR. J.EQ.JSTRT)) GO TO 20071 - GO TO 20044 -20071 CONTINUE - GO TO 20043 -20044 JSTRT=J -C -C UPDATE THE EDGE WEIGHT FOR THE EJECTED VARIABLE. - RG(ABS(IBASIS(IENTER)))= GQ/WP**2 -C -C IF MINIMUM REDUCED COST (DANTZIG) PRICING IS USED, -C CALCULATE THE NEW REDUCED COSTS. - GO TO 20040 -C -C COMPUTE THE UPDATED DUALS IN DUALS(*). -20039 ASSIGN 20074 TO NPR003 - GO TO 30003 -20074 CALL SCOPY(NVARS+MRELAS,ZERO,0,RZ,1) - NNEGRC=0 - J=JSTRT - PAGEPL=.TRUE. -C -20075 IF (.NOT.(IBB(J).LE.0)) GO TO 20077 - PAGEPL=.TRUE. - GO TO 20078 -C -C NONBASIC INDEPENDENT VARIABLE (COLUMN IN SPARSE MATRIX STORAGE) -20077 IF (.NOT.(J.LE.NVARS)) GO TO 20080 - RZ(J)=COSTS(J)*COSTSC - IF (.NOT.(J.EQ.1)) GO TO 20083 - ILOW=NVARS+5 - GO TO 20084 -20083 ILOW=IMAT(J+3)+1 -20084 CONTINUE - IF (.NOT.(PAGEPL)) GO TO 20086 - IL1=IPLOC(ILOW,AMAT,IMAT) - IF (.NOT.(IL1.GE.LMX-1)) GO TO 20089 - ILOW=ILOW+2 - IL1=IPLOC(ILOW,AMAT,IMAT) -20089 CONTINUE - IPAGE=ABS(IMAT(LMX-1)) - GO TO 20087 -20086 IL1=IHI+1 -20087 CONTINUE - IHI=IMAT(J+4)-(ILOW-IL1) -20092 IU1=MIN(LMX-2,IHI) - IF (.NOT.(IU1.GE.IL1 .AND.MOD(IU1-IL1,2).EQ.0)) GO TO 20094 - RZ(J)=RZ(J)-AMAT(IL1)*DUALS(IMAT(IL1)) - IL1=IL1+1 -20094 CONTINUE - IF (.NOT.(IL1.GT.IU1)) GO TO 20097 - GO TO 20093 -20097 CONTINUE -C -C UNROLL THE DOT PRODUCT LOOP TO A DEPTH OF TWO. (THIS IS DONE -C FOR INCREASED EFFICIENCY). - DO 40 I=IL1,IU1,2 - RZ(J)=RZ(J)-AMAT(I)*DUALS(IMAT(I))-AMAT(I+1)*DUALS(IMAT(I+1)) -40 CONTINUE - IF (.NOT.(IHI.LE.LMX-2)) GO TO 20100 - GO TO 20093 -20100 CONTINUE - IPAGE=IPAGE+1 - KEY=1 - CALL PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT) - IL1=NVARS+5 - IHI=IHI-LPG - GO TO 20092 -20093 PAGEPL=IHI.EQ.(LMX-2) - RZ(J)=RZ(J)*CSC(J) -C -C NONBASIC DEPENDENT VARIABLES (COLUMNS DEFINED IMPLICITLY) - GO TO 20081 -20080 PAGEPL=.TRUE. - SCALR=-ONE - IF(IND(J).EQ.2) SCALR=ONE - I=J-NVARS - RZ(J)=-SCALR*DUALS(I) -20081 CONTINUE -20078 CONTINUE -C - RCOST=RZ(J) - IF (MOD(IBB(J),2).EQ.0) RCOST=-RCOST - IF (.NOT.(IND(J).EQ.3)) GO TO 20103 - IF(BU(J).EQ.BL(J)) RCOST=ZERO -20103 CONTINUE - IF (IND(J).EQ.4) RCOST=-ABS(RCOST) - CNORM=ONE - IF (J.LE.NVARS) CNORM=COLNRM(J) - IF (RCOST+ERDNRM*DULNRM*CNORM.LT.ZERO) NNEGRC=NNEGRC+1 - J=MOD(J,MRELAS+NVARS)+1 - IF (.NOT.(NNEGRC.GE.NPP .OR. J.EQ.JSTRT)) GO TO 20106 - GO TO 20076 -20106 CONTINUE - GO TO 20075 -20076 JSTRT=J -20040 CONTINUE - GO TO 20030 -C -C THIS IS NECESSARY ONLY FOR PRINTING OF INTERMEDIATE RESULTS. -20029 ASSIGN 20109 TO NPR003 - GO TO 30003 -20109 CONTINUE -20030 RETURN -C PROCEDURE (TRANSLATE RIGHT HAND SIDE) -C -C PERFORM THE TRANSLATION ON THE RIGHT-HAND SIDE. -30001 IF (.NOT.(IBAS.LE.NVARS)) GO TO 20110 - I=0 -20113 CALL PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,IBAS) - IF (.NOT.(I.LE.0)) GO TO 20115 - GO TO 20114 -20115 CONTINUE - RHS(I)=RHS(I)-SCALR*AIJ*CSC(IBAS) - GO TO 20113 -20114 GO TO 20111 -20110 I=IBAS-NVARS - IF (.NOT.(IND(IBAS).EQ.2)) GO TO 20118 - RHS(I)=RHS(I)-SCALR - GO TO 20119 -20118 RHS(I)=RHS(I)+SCALR -20119 CONTINUE -20111 CONTINUE - RHSNRM=MAX(RHSNRM,SASUM(MRELAS,RHS,1)) - GO TO NPR001, (20009,20013,20017,20028) -C PROCEDURE (COMPUTE NEW PRIMAL) -C -C COPY RHS INTO WW(*), SOLVE SYSTEM. -30002 CALL SCOPY(MRELAS,RHS,1,WW,1) - TRANS = .FALSE. - CALL LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) - CALL SCOPY(MRELAS,WW,1,RPRIM,1) - RPRNRM=SASUM(MRELAS,RPRIM,1) - GO TO 20038 -C PROCEDURE (COMPUTE NEW DUALS) -C -C SOLVE FOR DUAL VARIABLES. FIRST COPY COSTS INTO DUALS(*). -30003 I=1 - N20121=MRELAS - GO TO 20122 -20121 I=I+1 -20122 IF ((N20121-I).LT.0) GO TO 20123 - J=IBASIS(I) - IF (.NOT.(J.LE.NVARS)) GO TO 20125 - DUALS(I)=COSTSC*COSTS(J)*CSC(J) + XLAMDA*PRIMAL(I+NVARS) - GO TO 20126 -20125 DUALS(I)=XLAMDA*PRIMAL(I+NVARS) -20126 CONTINUE - GO TO 20121 -C -20123 TRANS=.TRUE. - CALL LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,DUALS,TRANS) - DULNRM=SASUM(MRELAS,DUALS,1) - GO TO NPR003, (20042,20074,20109) - END diff --git a/slatec/splpup.f b/slatec/splpup.f deleted file mode 100644 index 0da4805..0000000 --- a/slatec/splpup.f +++ /dev/null @@ -1,214 +0,0 @@ -*DECK SPLPUP - SUBROUTINE SPLPUP (USRMAT, MRELAS, NVARS, PRGOPT, DATTRV, BL, BU, - + IND, INFO, AMAT, IMAT, SIZEUP, ASMALL, ABIG) -C***BEGIN PROLOGUE SPLPUP -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (SPLPUP-S, DPLPUP-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO -C DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. -C -C USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. -C /REAL (12 BLANKS)/DOUBLE PRECISION/. -C -C REVISED 810613-1130 -C REVISED YYMMDD-HHMM -C -C THIS SUBROUTINE COLLECTS INFORMATION ABOUT THE BOUNDS AND MATRIX -C FROM THE USER. IT IS PART OF THE SPLP( ) PACKAGE. -C -C***SEE ALSO SPLP -C***ROUTINES CALLED PCHNGS, PNNZRS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890605 Corrected references to XERRWV. (WRB) -C 890605 Removed unreferenced labels. (WRB) -C 891009 Removed unreferenced variables. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls, changed do-it-yourself -C DO loops to DO loops. (RWC) -C 900602 Get rid of ASSIGNed GOTOs. (RWC) -C***END PROLOGUE SPLPUP - REAL ABIG,AIJ,AMAT(*),AMN,AMX,ASMALL,BL(*), - * BU(*),DATTRV(*),PRGOPT(*),XVAL,ZERO - INTEGER IFLAG(10),IMAT(*),IND(*) - LOGICAL SIZEUP,FIRST - CHARACTER*8 XERN1, XERN2 - CHARACTER*16 XERN3, XERN4 -C -C***FIRST EXECUTABLE STATEMENT SPLPUP - ZERO = 0.E0 -C -C CHECK USER-SUPPLIED BOUNDS -C -C CHECK THAT IND(*) VALUES ARE 1,2,3 OR 4. -C ALSO CHECK CONSISTENCY OF UPPER AND LOWER BOUNDS. -C - DO 10 J=1,NVARS - IF (IND(J).LT.1 .OR. IND(J).GT.4) THEN - WRITE (XERN1, '(I8)') J - CALL XERMSG ('SLATEC', 'SPLPUP', - * 'IN SPLP, INDEPENDENT VARIABLE = ' // XERN1 // - * ' IS NOT DEFINED.', 10, 1) - INFO = -10 - RETURN - ENDIF -C - IF (IND(J).EQ.3) THEN - IF (BL(J).GT.BU(J)) THEN - WRITE (XERN1, '(I8)') J - WRITE (XERN3, '(1PE15.6)') BL(J) - WRITE (XERN4, '(1PE15.6)') BU(J) - CALL XERMSG ('SLATEC', 'SPLPUP', - * 'IN SPLP, LOWER BOUND = ' // XERN3 // - * ' AND UPPER BOUND = ' // XERN4 // - * ' FOR INDEPENDENT VARIABLE = ' // XERN1 // - * ' ARE NOT CONSISTENT.', 11, 1) - RETURN - ENDIF - ENDIF - 10 CONTINUE -C - DO 20 I=NVARS+1,NVARS+MRELAS - IF (IND(I).LT.1 .OR. IND(I).GT.4) THEN - WRITE (XERN1, '(I8)') I-NVARS - CALL XERMSG ('SLATEC', 'SPLPUP', - * 'IN SPLP, DEPENDENT VARIABLE = ' // XERN1 // - * ' IS NOT DEFINED.', 12, 1) - INFO = -12 - RETURN - ENDIF -C - IF (IND(I).EQ.3) THEN - IF (BL(I).GT.BU(I)) THEN - WRITE (XERN1, '(I8)') I - WRITE (XERN3, '(1PE15.6)') BL(I) - WRITE (XERN4, '(1PE15.6)') BU(I) - CALL XERMSG ('SLATEC', 'SPLPUP', - * 'IN SPLP, LOWER BOUND = ' // XERN3 // - * ' AND UPPER BOUND = ' // XERN4 // - * ' FOR DEPENDANT VARIABLE = ' // XERN1 // - * ' ARE NOT CONSISTENT.',13,1) - INFO = -13 - RETURN - ENDIF - ENDIF - 20 CONTINUE -C -C GET UPDATES OR DATA FOR MATRIX FROM THE USER -C -C GET THE ELEMENTS OF THE MATRIX FROM THE USER. IT WILL BE STORED -C BY COLUMNS USING THE SPARSE STORAGE CODES OF RJ HANSON AND -C JA WISNIEWSKI. -C - IFLAG(1) = 1 -C -C KEEP ACCEPTING ELEMENTS UNTIL THE USER IS FINISHED GIVING THEM. -C LIMIT THIS LOOP TO 2*NVARS*MRELAS ITERATIONS. -C - ITMAX = 2*NVARS*MRELAS+1 - ITCNT = 0 - FIRST = .TRUE. -C -C CHECK ON THE ITERATION COUNT. -C - 30 ITCNT = ITCNT+1 - IF (ITCNT.GT.ITMAX) THEN - CALL XERMSG ('SLATEC', 'SPLPUP', - + 'IN SPLP, MORE THAN 2*NVARS*MRELAS ITERATIONS DEFINING ' // - + 'OR UPDATING MATRIX DATA.', 7, 1) - INFO = -7 - RETURN - ENDIF -C - AIJ = ZERO - CALL USRMAT(I,J,AIJ,INDCAT,PRGOPT,DATTRV,IFLAG) - IF (IFLAG(1).EQ.1) THEN - IFLAG(1) = 2 - GO TO 30 - ENDIF -C -C CHECK TO SEE THAT THE SUBSCRIPTS I AND J ARE VALID. -C - IF (I.LT.1 .OR. I.GT.MRELAS .OR. J.LT.1 .OR. J.GT.NVARS) THEN -C -C CHECK ON SIZE OF MATRIX DATA -C RECORD THE LARGEST AND SMALLEST(IN MAGNITUDE) NONZERO ELEMENTS. -C - IF (IFLAG(1).EQ.3) THEN - IF (SIZEUP .AND. ABS(AIJ).NE.ZERO) THEN - IF (FIRST) THEN - AMX = ABS(AIJ) - AMN = ABS(AIJ) - FIRST = .FALSE. - ELSEIF (ABS(AIJ).GT.AMX) THEN - AMX = ABS(AIJ) - ELSEIF (ABS(AIJ).LT.AMN) THEN - AMN = ABS(AIJ) - ENDIF - ENDIF - GO TO 40 - ENDIF -C - WRITE (XERN1, '(I8)') I - WRITE (XERN2, '(I8)') J - CALL XERMSG ('SLATEC', 'SPLPUP', - * 'IN SPLP, ROW INDEX = ' // XERN1 // ' OR COLUMN INDEX = ' - * // XERN2 // ' IS OUT OF RANGE.', 8, 1) - INFO = -8 - RETURN - ENDIF -C -C IF INDCAT=0 THEN SET A(I,J)=AIJ. -C IF INDCAT=1 THEN ACCUMULATE ELEMENT, A(I,J)=A(I,J)+AIJ. -C - IF (INDCAT.EQ.0) THEN - CALL PCHNGS(I,AIJ,IPLACE,AMAT,IMAT,J) - ELSEIF (INDCAT.EQ.1) THEN - INDEX = -(I-1) - CALL PNNZRS(INDEX,XVAL,IPLACE,AMAT,IMAT,J) - IF (INDEX.EQ.I) AIJ=AIJ+XVAL - CALL PCHNGS(I,AIJ,IPLACE,AMAT,IMAT,J) - ELSE - WRITE (XERN1, '(I8)') INDCAT - CALL XERMSG ('SLATEC', 'SPLPUP', - * 'IN SPLP, INDICATION FLAG = ' // XERN1 // - * ' FOR MATRIX DATA MUST BE EITHER 0 OR 1.', 9, 1) - INFO = -9 - RETURN - ENDIF -C -C CHECK ON SIZE OF MATRIX DATA -C RECORD THE LARGEST AND SMALLEST(IN MAGNITUDE) NONZERO ELEMENTS. -C - IF (SIZEUP .AND. ABS(AIJ).NE.ZERO) THEN - IF (FIRST) THEN - AMX = ABS(AIJ) - AMN = ABS(AIJ) - FIRST = .FALSE. - ELSEIF (ABS(AIJ).GT.AMX) THEN - AMX = ABS(AIJ) - ELSEIF (ABS(AIJ).LT.AMN) THEN - AMN = ABS(AIJ) - ENDIF - ENDIF - IF (IFLAG(1).NE.3) GO TO 30 -C - 40 IF (SIZEUP .AND. .NOT. FIRST) THEN - IF (AMN.LT.ASMALL .OR. AMX.GT.ABIG) THEN - CALL XERMSG ('SLATEC', 'SPLPUP', - + 'IN SPLP, A MATRIX ELEMENT''S SIZE IS OUT OF THE ' // - + 'SPECIFIED RANGE.', 22, 1) - INFO = -22 - RETURN - ENDIF - ENDIF - RETURN - END diff --git a/slatec/spoco.f b/slatec/spoco.f deleted file mode 100644 index 000b076..0000000 --- a/slatec/spoco.f +++ /dev/null @@ -1,208 +0,0 @@ -*DECK SPOCO - SUBROUTINE SPOCO (A, LDA, N, RCOND, Z, INFO) -C***BEGIN PROLOGUE SPOCO -C***PURPOSE Factor a real symmetric positive definite matrix -C and estimate the condition number of the matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1B -C***TYPE SINGLE PRECISION (SPOCO-S, DPOCO-D, CPOCO-C) -C***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, -C MATRIX FACTORIZATION, POSITIVE DEFINITE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C SPOCO factors a real symmetric positive definite matrix -C and estimates the condition of the matrix. -C -C If RCOND is not needed, SPOFA is slightly faster. -C To solve A*X = B , follow SPOCO by SPOSL. -C To compute INVERSE(A)*C , follow SPOCO by SPOSL. -C To compute DETERMINANT(A) , follow SPOCO by SPODI. -C To compute INVERSE(A) , follow SPOCO by SPODI. -C -C On Entry -C -C A REAL(LDA, N) -C the symmetric matrix to be factored. Only the -C diagonal and upper triangle are used. -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 R so that A = TRANS(R)*R -C where TRANS(R) is the transpose. -C The strict lower triangle is unaltered. -C If INFO .NE. 0 , the factorization is not complete. -C -C RCOND REAL -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. If INFO .NE. 0 , RCOND is unchanged. -C -C Z REAL(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 If INFO .NE. 0 , Z is unchanged. -C -C INFO INTEGER -C = 0 for normal return. -C = K signals an error condition. The leading minor -C of order K is not positive definite. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SASUM, SAXPY, SDOT, SPOFA, SSCAL -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SPOCO - INTEGER LDA,N,INFO - REAL A(LDA,*),Z(*) - REAL RCOND -C - REAL SDOT,EK,T,WK,WKM - REAL ANORM,S,SASUM,SM,YNORM - INTEGER I,J,JM1,K,KB,KP1 -C -C FIND NORM OF A USING ONLY UPPER HALF -C -C***FIRST EXECUTABLE STATEMENT SPOCO - DO 30 J = 1, N - Z(J) = SASUM(J,A(1,J),1) - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 20 - DO 10 I = 1, JM1 - Z(I) = Z(I) + ABS(A(I,J)) - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - ANORM = 0.0E0 - DO 40 J = 1, N - ANORM = MAX(ANORM,Z(J)) - 40 CONTINUE -C -C FACTOR -C - CALL SPOFA(A,LDA,N,INFO) - IF (INFO .NE. 0) GO TO 180 -C -C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . -C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . -C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL -C GROWTH IN THE ELEMENTS OF W WHERE TRANS(R)*W = E . -C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. -C -C SOLVE TRANS(R)*W = E -C - EK = 1.0E0 - DO 50 J = 1, N - Z(J) = 0.0E0 - 50 CONTINUE - DO 110 K = 1, N - IF (Z(K) .NE. 0.0E0) EK = SIGN(EK,-Z(K)) - IF (ABS(EK-Z(K)) .LE. A(K,K)) GO TO 60 - S = A(K,K)/ABS(EK-Z(K)) - CALL SSCAL(N,S,Z,1) - EK = S*EK - 60 CONTINUE - WK = EK - Z(K) - WKM = -EK - Z(K) - S = ABS(WK) - SM = ABS(WKM) - WK = WK/A(K,K) - WKM = WKM/A(K,K) - KP1 = K + 1 - IF (KP1 .GT. N) GO TO 100 - DO 70 J = KP1, N - SM = SM + ABS(Z(J)+WKM*A(K,J)) - Z(J) = Z(J) + WK*A(K,J) - S = S + ABS(Z(J)) - 70 CONTINUE - IF (S .GE. SM) GO TO 90 - T = WKM - WK - WK = WKM - DO 80 J = KP1, N - Z(J) = Z(J) + T*A(K,J) - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - Z(K) = WK - 110 CONTINUE - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) -C -C SOLVE R*Y = W -C - DO 130 KB = 1, N - K = N + 1 - KB - IF (ABS(Z(K)) .LE. A(K,K)) GO TO 120 - S = A(K,K)/ABS(Z(K)) - CALL SSCAL(N,S,Z,1) - 120 CONTINUE - Z(K) = Z(K)/A(K,K) - T = -Z(K) - CALL SAXPY(K-1,T,A(1,K),1,Z(1),1) - 130 CONTINUE - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) -C - YNORM = 1.0E0 -C -C SOLVE TRANS(R)*V = Y -C - DO 150 K = 1, N - Z(K) = Z(K) - SDOT(K-1,A(1,K),1,Z(1),1) - IF (ABS(Z(K)) .LE. A(K,K)) GO TO 140 - S = A(K,K)/ABS(Z(K)) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM - 140 CONTINUE - Z(K) = Z(K)/A(K,K) - 150 CONTINUE - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE R*Z = V -C - DO 170 KB = 1, N - K = N + 1 - KB - IF (ABS(Z(K)) .LE. A(K,K)) GO TO 160 - S = A(K,K)/ABS(Z(K)) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM - 160 CONTINUE - Z(K) = Z(K)/A(K,K) - T = -Z(K) - CALL SAXPY(K-1,T,A(1,K),1,Z(1),1) - 170 CONTINUE -C MAKE ZNORM = 1.0 - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM -C - IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM - IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0 - 180 CONTINUE - RETURN - END diff --git a/slatec/spodi.f b/slatec/spodi.f deleted file mode 100644 index 0b5a8e5..0000000 --- a/slatec/spodi.f +++ /dev/null @@ -1,136 +0,0 @@ -*DECK SPODI - SUBROUTINE SPODI (A, LDA, N, DET, JOB) -C***BEGIN PROLOGUE SPODI -C***PURPOSE Compute the determinant and inverse of a certain real -C symmetric positive definite matrix using the factors -C computed by SPOCO, SPOFA or SQRDC. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1B, D3B1B -C***TYPE SINGLE PRECISION (SPODI-S, DPODI-D, CPODI-C) -C***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, -C POSITIVE DEFINITE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C SPODI computes the determinant and inverse of a certain -C real symmetric positive definite matrix (see below) -C using the factors computed by SPOCO, SPOFA or SQRDC. -C -C On Entry -C -C A REAL(LDA, N) -C the output A from SPOCO or SPOFA -C or the output X from SQRDC. -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 JOB INTEGER -C = 11 both determinant and inverse. -C = 01 inverse only. -C = 10 determinant only. -C -C On Return -C -C A If SPOCO or SPOFA was used to factor A , then -C SPODI produces the upper half of INVERSE(A) . -C If SQRDC was used to decompose X , then -C SPODI produces the upper half of INVERSE(TRANS(X)*X), -C where TRANS(X) is the transpose. -C Elements of A below the diagonal are unchanged. -C If the units digit of JOB is zero, A is unchanged. -C -C DET REAL(2) -C determinant of A or of TRANS(X)*X if requested. -C Otherwise not referenced. -C Determinant = DET(1) * 10.0**DET(2) -C with 1.0 .LE. 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 SPOCO or SPOFA has set INFO .EQ. 0 . -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SAXPY, SSCAL -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SPODI - INTEGER LDA,N,JOB - REAL A(LDA,*) - REAL DET(2) -C - REAL T - REAL S - INTEGER I,J,JM1,K,KP1 -C***FIRST EXECUTABLE STATEMENT SPODI -C -C COMPUTE DETERMINANT -C - IF (JOB/10 .EQ. 0) GO TO 70 - DET(1) = 1.0E0 - DET(2) = 0.0E0 - S = 10.0E0 - DO 50 I = 1, N - DET(1) = A(I,I)**2*DET(1) - IF (DET(1) .EQ. 0.0E0) GO TO 60 - 10 IF (DET(1) .GE. 1.0E0) GO TO 20 - DET(1) = S*DET(1) - DET(2) = DET(2) - 1.0E0 - GO TO 10 - 20 CONTINUE - 30 IF (DET(1) .LT. S) GO TO 40 - DET(1) = DET(1)/S - DET(2) = DET(2) + 1.0E0 - GO TO 30 - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE -C -C COMPUTE INVERSE(R) -C - IF (MOD(JOB,10) .EQ. 0) GO TO 140 - DO 100 K = 1, N - A(K,K) = 1.0E0/A(K,K) - T = -A(K,K) - CALL SSCAL(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.0E0 - CALL SAXPY(K,T,A(1,K),1,A(1,J),1) - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE -C -C FORM INVERSE(R) * TRANS(INVERSE(R)) -C - DO 130 J = 1, N - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 120 - DO 110 K = 1, JM1 - T = A(K,J) - CALL SAXPY(K,T,A(1,J),1,A(1,K),1) - 110 CONTINUE - 120 CONTINUE - T = A(J,J) - CALL SSCAL(J,T,A(1,J),1) - 130 CONTINUE - 140 CONTINUE - RETURN - END diff --git a/slatec/spofa.f b/slatec/spofa.f deleted file mode 100644 index aed2313..0000000 --- a/slatec/spofa.f +++ /dev/null @@ -1,81 +0,0 @@ -*DECK SPOFA - SUBROUTINE SPOFA (A, LDA, N, INFO) -C***BEGIN PROLOGUE SPOFA -C***PURPOSE Factor a real symmetric positive definite matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1B -C***TYPE SINGLE PRECISION (SPOFA-S, DPOFA-D, CPOFA-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, -C POSITIVE DEFINITE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C SPOFA factors a real symmetric positive definite matrix. -C -C SPOFA is usually called by SPOCO, but it can be called -C directly with a saving in time if RCOND is not needed. -C (Time for SPOCO) = (1 + 18/N)*(Time for SPOFA) . -C -C On Entry -C -C A REAL(LDA, N) -C the symmetric matrix to be factored. Only the -C diagonal and upper triangle are used. -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 R so that A = TRANS(R)*R -C where TRANS(R) is the transpose. -C The strict lower triangle is unaltered. -C If INFO .NE. 0 , the factorization is not complete. -C -C INFO INTEGER -C = 0 for normal return. -C = K signals an error condition. The leading minor -C of order K is not positive definite. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SDOT -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SPOFA - INTEGER LDA,N,INFO - REAL A(LDA,*) -C - REAL SDOT,T - REAL S - INTEGER J,JM1,K -C***FIRST EXECUTABLE STATEMENT SPOFA - DO 30 J = 1, N - INFO = J - S = 0.0E0 - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 20 - DO 10 K = 1, JM1 - T = A(K,J) - SDOT(K-1,A(1,K),1,A(1,J),1) - T = T/A(K,K) - A(K,J) = T - S = S + T*T - 10 CONTINUE - 20 CONTINUE - S = A(J,J) - S - IF (S .LE. 0.0E0) GO TO 40 - A(J,J) = SQRT(S) - 30 CONTINUE - INFO = 0 - 40 CONTINUE - RETURN - END diff --git a/slatec/spofs.f b/slatec/spofs.f deleted file mode 100644 index 0629aa4..0000000 --- a/slatec/spofs.f +++ /dev/null @@ -1,163 +0,0 @@ -*DECK SPOFS - SUBROUTINE SPOFS (A, LDA, N, V, ITASK, IND, WORK) -C***BEGIN PROLOGUE SPOFS -C***PURPOSE Solve a positive definite symmetric system of linear -C equations. -C***LIBRARY SLATEC -C***CATEGORY D2B1B -C***TYPE SINGLE PRECISION (SPOFS-S, DPOFS-D, CPOFS-C) -C***KEYWORDS HERMITIAN, LINEAR EQUATIONS, POSITIVE DEFINITE, SYMMETRIC -C***AUTHOR Voorhees, E. A., (LANL) -C***DESCRIPTION -C -C Subroutine SPOFS solves a real positive definite symmetric -C NxN system of single precision linear equations using -C LINPACK subroutines SPOCO and SPOSL. That is, if A is an -C NxN real positive definite symmetric matrix and if X and B -C are real N-vectors, then SPOFS solves the equation -C -C A*X=B. -C -C The matrix A is first factored into upper and lower tri- -C angular matrices R and R-TRANSPOSE. These factors are used to -C find the solution vector X. An approximate condition number is -C calculated to provide a rough estimate of the number of -C digits of accuracy in the computed solution. -C -C If the equation A*X=B is to be solved for more than one vector -C B, the factoring of A does not need to be performed again and -C the option to solve only (ITASK .GT. 1) will be faster for -C the succeeding solutions. In this case, the contents of A, -C LDA, and N must not have been altered by the user following -C factorization (ITASK=1). IND will not be changed by SPOFS -C in this case. -C -C Argument Description *** -C -C A REAL(LDA,N) -C on entry, the doubly subscripted array with dimension -C (LDA,N) which contains the coefficient matrix. Only -C the upper triangle, including the diagonal, of the -C coefficient matrix need be entered and will subse- -C quently be referenced and changed by the routine. -C on return, contains in its upper triangle an upper -C triangular matrix R such that A = (R-TRANSPOSE) * R . -C LDA INTEGER -C the leading dimension of the array A. LDA must be great- -C er than or equal to N. (Terminal error message IND=-1) -C N INTEGER -C the order of the matrix A. N must be greater -C than or equal to 1. (Terminal error message IND=-2) -C V REAL(N) -C on entry, the singly subscripted array(vector) of di- -C mension N which contains the right hand side B of a -C system of simultaneous linear equations A*X=B. -C on return, V contains the solution vector, X . -C ITASK INTEGER -C If ITASK = 1, the matrix A is factored and then the -C linear equation is solved. -C If ITASK .GT. 1, the equation is solved using the existing -C factored matrix A. -C If ITASK .LT. 1, then terminal error message IND=-3 is -C printed. -C IND INTEGER -C GT. 0 IND is a rough estimate of the number of digits -C of accuracy in the solution, X. -C LT. 0 see error message corresponding to IND below. -C WORK REAL(N) -C a singly subscripted array of dimension at least N. -C -C Error Messages Printed *** -C -C IND=-1 terminal N is greater than LDA. -C IND=-2 terminal N is less than 1. -C IND=-3 terminal ITASK is less than 1. -C IND=-4 Terminal The matrix A is computationally singular or -C is not positive definite. A solution -C has not been computed. -C IND=-10 warning The solution has no apparent significance. -C The solution may be inaccurate or the -C matrix A may be poorly scaled. -C -C Note- The above terminal(*fatal*) error messages are -C designed to be handled by XERMSG in which -C LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 -C for warning error messages from XERMSG. Unless -C the user provides otherwise, an error message -C will be printed followed by an abort. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED R1MACH, SPOCO, SPOSL, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800509 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 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 SPOFS -C - INTEGER LDA,N,ITASK,IND,INFO - REAL A(LDA,*),V(*),WORK(*),R1MACH - REAL RCOND - CHARACTER*8 XERN1, XERN2 -C***FIRST EXECUTABLE STATEMENT SPOFS - IF (LDA.LT.N) THEN - IND = -1 - WRITE (XERN1, '(I8)') LDA - WRITE (XERN2, '(I8)') N - CALL XERMSG ('SLATEC', 'SPOFS', 'LDA = ' // XERN1 // - * ' IS LESS THAN N = ' // XERN2, -1, 1) - RETURN - ENDIF -C - IF (N.LE.0) THEN - IND = -2 - WRITE (XERN1, '(I8)') N - CALL XERMSG ('SLATEC', 'SPOFS', 'N = ' // XERN1 // - * ' IS LESS THAN 1', -2, 1) - RETURN - ENDIF -C - IF (ITASK.LT.1) THEN - IND = -3 - WRITE (XERN1, '(I8)') ITASK - CALL XERMSG ('SLATEC', 'SPOFS', 'ITASK = ' // XERN1 // - * ' IS LESS THAN 1', -3, 1) - RETURN - ENDIF -C - IF (ITASK.EQ.1) THEN -C -C FACTOR MATRIX A INTO R -C - CALL SPOCO(A,LDA,N,RCOND,WORK,INFO) -C -C CHECK FOR POSITIVE DEFINITE MATRIX -C - IF (INFO.NE.0) THEN - IND = -4 - CALL XERMSG ('SLATEC', 'SPOFS', - * 'SINGULAR OR NOT POSITIVE DEFINITE - NO SOLUTION', -4, 1) - RETURN - ENDIF -C -C COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) -C AND CHECK FOR IND GREATER THAN ZERO -C - IND = -LOG10(R1MACH(4)/RCOND) - IF (IND.LE.0) THEN - IND = -10 - CALL XERMSG ('SLATEC', 'SPOFS', - * 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) - ENDIF - ENDIF -C -C SOLVE AFTER FACTORING -C - CALL SPOSL(A,LDA,N,V) - RETURN - END diff --git a/slatec/spoir.f b/slatec/spoir.f deleted file mode 100644 index 609d7d7..0000000 --- a/slatec/spoir.f +++ /dev/null @@ -1,198 +0,0 @@ -*DECK SPOIR - SUBROUTINE SPOIR (A, LDA, N, V, ITASK, IND, WORK) -C***BEGIN PROLOGUE SPOIR -C***PURPOSE Solve a positive definite symmetric system of linear -C equations. Iterative refinement is used to obtain an error -C estimate. -C***LIBRARY SLATEC -C***CATEGORY D2B1B -C***TYPE SINGLE PRECISION (SPOIR-S, CPOIR-C) -C***KEYWORDS HERMITIAN, LINEAR EQUATIONS, POSITIVE DEFINITE, SYMMETRIC -C***AUTHOR Voorhees, E. A., (LANL) -C***DESCRIPTION -C -C Subroutine SPOIR solves a real positive definite symmetric -C NxN system of single precision linear equations using LINPACK -C subroutines SPOFA and SPOSL. One pass of iterative refine- -C ment is used only to obtain an estimate of the accuracy. That -C is, if A is an NxN real positive definite symmetric matrix -C and if X and B are real N-vectors, then SPOIR solves the -C equation -C -C A*X=B. -C -C The matrix A is first factored into upper and lower -C triangular matrices R and R-TRANSPOSE. These -C factors are used to calculate the solution, X. -C Then the residual vector is found and used -C to calculate an estimate of the relative error, IND. -C IND estimates the accuracy of the solution only when the -C input matrix and the right hand side are represented -C exactly in the computer and does not take into account -C any errors in the input data. -C -C If the equation A*X=B is to be solved for more than one vector -C B, the factoring of A does not need to be performed again and -C the option to only solve (ITASK .GT. 1) will be faster for -C the succeeding solutions. In this case, the contents of A, -C LDA, N, and WORK must not have been altered by the user -C following factorization (ITASK=1). IND will not be changed -C by SPOIR in this case. -C -C Argument Description *** -C A REAL(LDA,N) -C the doubly subscripted array with dimension (LDA,N) -C which contains the coefficient matrix. Only the -C upper triangle, including the diagonal, of the -C coefficient matrix need be entered. A is not -C altered by the routine. -C LDA INTEGER -C the leading dimension of the array A. LDA must be great- -C er than or equal to N. (Terminal error message IND=-1) -C N INTEGER -C the order of the matrix A. N must be greater than -C or equal to one. (Terminal error message IND=-2) -C V REAL(N) -C on entry, the singly subscripted array(vector) of di- -C mension N which contains the right hand side B of a -C system of simultaneous linear equations A*X=B. -C on return, V contains the solution vector, X . -C ITASK INTEGER -C If ITASK = 1, the matrix A is factored and then the -C linear equation is solved. -C If ITASK .GT. 1, the equation is solved using the existing -C factored matrix A (stored in WORK). -C If ITASK .LT. 1, then terminal terminal error IND=-3 is -C printed. -C IND INTEGER -C GT. 0 IND is a rough estimate of the number of digits -C of accuracy in the solution, X. IND=75 means -C that the solution vector X is zero. -C LT. 0 See error message corresponding to IND below. -C WORK REAL(N*(N+1)) -C a singly subscripted array of dimension at least N*(N+1). -C -C Error Messages Printed *** -C -C IND=-1 terminal N is greater than LDA. -C IND=-2 terminal N is less than one. -C IND=-3 terminal ITASK is less than one. -C IND=-4 Terminal The matrix A is computationally singular -C or is not positive definite. -C A solution has not been computed. -C IND=-10 warning The solution has no apparent significance. -C The solution may be inaccurate or the matrix -C A may be poorly scaled. -C -C Note- The above terminal(*fatal*) error messages are -C designed to be handled by XERMSG in which -C LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 -C for warning error messages from XERMSG. Unless -C the user provides otherwise, an error message -C will be printed followed by an abort. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DSDOT, R1MACH, SASUM, SCOPY, SPOFA, SPOSL, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800528 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 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 SPOIR -C - INTEGER LDA,N,ITASK,IND,INFO,J - REAL A(LDA,*),V(*),WORK(N,*),SASUM,XNORM,DNORM,R1MACH - DOUBLE PRECISION DSDOT - CHARACTER*8 XERN1, XERN2 -C***FIRST EXECUTABLE STATEMENT SPOIR - IF (LDA.LT.N) THEN - IND = -1 - WRITE (XERN1, '(I8)') LDA - WRITE (XERN2, '(I8)') N - CALL XERMSG ('SLATEC', 'SPOIR', 'LDA = ' // XERN1 // - * ' IS LESS THAN N = ' // XERN2, -1, 1) - RETURN - ENDIF -C - IF (N.LE.0) THEN - IND = -2 - WRITE (XERN1, '(I8)') N - CALL XERMSG ('SLATEC', 'SPOIR', 'N = ' // XERN1 // - * ' IS LESS THAN 1', -2, 1) - RETURN - ENDIF -C - IF (ITASK.LT.1) THEN - IND = -3 - WRITE (XERN1, '(I8)') ITASK - CALL XERMSG ('SLATEC', 'SPOIR', 'ITASK = ' // XERN1 // - * ' IS LESS THAN 1', -3, 1) - RETURN - ENDIF -C - IF (ITASK.EQ.1) THEN -C -C MOVE MATRIX A TO WORK -C - DO 10 J=1,N - CALL SCOPY(N,A(1,J),1,WORK(1,J),1) - 10 CONTINUE -C -C FACTOR MATRIX A INTO R - CALL SPOFA(WORK,N,N,INFO) -C -C CHECK FOR SINGULAR OR NOT POS.DEF. MATRIX - IF (INFO.NE.0) THEN - IND = -4 - CALL XERMSG ('SLATEC', 'SPOIR', - * 'SINGULAR OR NOT POSITIVE DEFINITE - NO SOLUTION', -4, 1) - RETURN - ENDIF - ENDIF -C -C SOLVE AFTER FACTORING -C MOVE VECTOR B TO WORK -C - CALL SCOPY(N,V(1),1,WORK(1,N+1),1) - CALL SPOSL(WORK,N,N,V) -C -C FORM NORM OF X0 -C - XNORM = SASUM(N,V(1),1) - IF (XNORM.EQ.0.0) THEN - IND = 75 - RETURN - ENDIF -C -C COMPUTE RESIDUAL -C - DO 40 J=1,N - WORK(J,N+1) = -WORK(J,N+1) - 1 +DSDOT(J-1,A(1,J),1,V(1),1) - 2 +DSDOT(N-J+1,A(J,J),LDA,V(J),1) - 40 CONTINUE -C -C SOLVE A*DELTA=R -C - CALL SPOSL(WORK,N,N,WORK(1,N+1)) -C -C FORM NORM OF DELTA -C - DNORM = SASUM(N,WORK(1,N+1),1) -C -C COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) -C AND CHECK FOR IND GREATER THAN ZERO -C - IND = -LOG10(MAX(R1MACH(4),DNORM/XNORM)) - IF (IND.LE.0) THEN - IND = -10 - CALL XERMSG ('SLATEC', 'SPOIR', - * 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) - ENDIF - RETURN - END diff --git a/slatec/spopt.f b/slatec/spopt.f deleted file mode 100644 index bacb2a1..0000000 --- a/slatec/spopt.f +++ /dev/null @@ -1,379 +0,0 @@ -*DECK SPOPT - SUBROUTINE SPOPT (PRGOPT, MRELAS, NVARS, INFO, CSC, IBASIS, ROPT, - + INTOPT, LOPT) -C***BEGIN PROLOGUE SPOPT -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (SPOPT-S, DPOPT-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO -C DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. -C -C USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. -C /REAL (12 BLANKS)/DOUBLE PRECISION/, -C /R1MACH/D1MACH/,/E0/D0/ -C -C REVISED 821122-1045 -C REVISED YYMMDD-HHMM -C -C THIS SUBROUTINE PROCESSES THE OPTION VECTOR, PRGOPT(*), -C AND VALIDATES ANY MODIFIED DATA. -C -C***SEE ALSO SPLP -C***ROUTINES CALLED R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890605 Removed unreferenced labels. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE SPOPT - REAL ABIG,ASMALL,COSTSC,CSC(*),EPS,ONE,PRGOPT(*), - * ROPT(07),TOLLS,TUNE,ZERO,R1MACH,TOLABS - INTEGER IBASIS(*),INTOPT(08) - LOGICAL CONTIN,USRBAS,SIZEUP,SAVEDT,COLSCP,CSTSCP,MINPRB, - * STPEDG,LOPT(8) -C -C***FIRST EXECUTABLE STATEMENT SPOPT - IOPT=1 - ZERO=0.E0 - ONE=1.E0 - GO TO 30001 -20002 CONTINUE - GO TO 30002 -C -20003 LOPT(1)=CONTIN - LOPT(2)=USRBAS - LOPT(3)=SIZEUP - LOPT(4)=SAVEDT - LOPT(5)=COLSCP - LOPT(6)=CSTSCP - LOPT(7)=MINPRB - LOPT(8)=STPEDG -C - INTOPT(1)=IDG - INTOPT(2)=IPAGEF - INTOPT(3)=ISAVE - INTOPT(4)=MXITLP - INTOPT(5)=KPRINT - INTOPT(6)=ITBRC - INTOPT(7)=NPP - INTOPT(8)=LPRG -C - ROPT(1)=EPS - ROPT(2)=ASMALL - ROPT(3)=ABIG - ROPT(4)=COSTSC - ROPT(5)=TOLLS - ROPT(6)=TUNE - ROPT(7)=TOLABS - RETURN -C -C -C PROCEDURE (INITIALIZE PARAMETERS AND PROCESS USER OPTIONS) -30001 CONTIN = .FALSE. - USRBAS = .FALSE. - SIZEUP = .FALSE. - SAVEDT = .FALSE. - COLSCP = .FALSE. - CSTSCP = .FALSE. - MINPRB = .TRUE. - STPEDG = .TRUE. -C -C GET THE MACHINE REL. FLOATING POINT ACCURACY VALUE FROM THE -C LIBRARY SUBPROGRAM, R1MACH( ). - EPS=R1MACH(4) - TOLLS=R1MACH(4) - TUNE=ONE - TOLABS=ZERO -C -C DEFINE NOMINAL FILE NUMBERS FOR MATRIX PAGES AND DATA SAVING. - IPAGEF=1 - ISAVE=2 - ITBRC=10 - MXITLP=3*(NVARS+MRELAS) - KPRINT=0 - IDG=-4 - NPP=NVARS - LPRG=0 -C - LAST = 1 - IADBIG=10000 - ICTMAX=1000 - ICTOPT= 0 -20004 NEXT=PRGOPT(LAST) - IF (.NOT.(NEXT.LE.0 .OR. NEXT.GT.IADBIG)) GO TO 20006 -C -C THE CHECKS FOR SMALL OR LARGE VALUES OF NEXT ARE TO PREVENT -C WORKING WITH UNDEFINED DATA. - NERR=14 - CALL XERMSG ('SLATEC', 'SPOPT', - + 'IN SPLP, THE USER OPTION ARRAY HAS UNDEFINED DATA.', NERR, - + IOPT) - INFO=-NERR - RETURN -20006 IF (.NOT.(NEXT.EQ.1)) GO TO 10001 - GO TO 20005 -10001 IF (.NOT.(ICTOPT.GT.ICTMAX)) GO TO 10002 - NERR=15 - CALL XERMSG ('SLATEC', 'SPOPT', - + 'IN SPLP, OPTION ARRAY PROCESSING IS CYCLING.', NERR, IOPT) - INFO=-NERR - RETURN -10002 CONTINUE - KEY = PRGOPT(LAST+1) -C -C IF KEY = 50, THIS IS TO BE A MAXIMIZATION PROBLEM -C INSTEAD OF A MINIMIZATION PROBLEM. - IF (.NOT.(KEY.EQ.50)) GO TO 20010 - MINPRB = PRGOPT(LAST+2).EQ.ZERO - LDS=3 - GO TO 20009 -20010 CONTINUE -C -C IF KEY = 51, THE LEVEL OF OUTPUT IS BEING MODIFIED. -C KPRINT = 0, NO OUTPUT -C = 1, SUMMARY OUTPUT -C = 2, LOTS OF OUTPUT -C = 3, EVEN MORE OUTPUT - IF (.NOT.(KEY.EQ.51)) GO TO 20013 - KPRINT=PRGOPT(LAST+2) - LDS=3 - GO TO 20009 -20013 CONTINUE -C -C IF KEY = 52, REDEFINE THE FORMAT AND PRECISION USED -C IN THE OUTPUT. - IF (.NOT.(KEY.EQ.52)) GO TO 20016 - IF (PRGOPT(LAST+2).NE.ZERO) IDG=PRGOPT(LAST+3) - LDS=4 - GO TO 20009 -20016 CONTINUE -C -C IF KEY = 53, THE ALLOTTED SPACE FOR THE SPARSE MATRIX -C STORAGE AND/OR SPARSE EQUATION SOLVING HAS BEEN CHANGED. -C (PROCESSED IN SPLP(). THIS IS TO COMPUTE THE LENGTH OF PRGOPT(*).) - IF (.NOT.(KEY.EQ.53)) GO TO 20019 - LDS=5 - GO TO 20009 -20019 CONTINUE -C -C IF KEY = 54, REDEFINE THE FILE NUMBER WHERE THE PAGES -C FOR THE SPARSE MATRIX ARE STORED. - IF (.NOT.(KEY.EQ.54)) GO TO 20022 - IF(PRGOPT(LAST+2).NE.ZERO) IPAGEF = PRGOPT(LAST+3) - LDS=4 - GO TO 20009 -20022 CONTINUE -C -C IF KEY = 55, A CONTINUATION FOR A PROBLEM MAY BE REQUESTED. - IF (.NOT.(KEY .EQ. 55)) GO TO 20025 - CONTIN = PRGOPT(LAST+2).NE.ZERO - LDS=3 - GO TO 20009 -20025 CONTINUE -C -C IF KEY = 56, REDEFINE THE FILE NUMBER WHERE THE SAVED DATA -C WILL BE STORED. - IF (.NOT.(KEY.EQ.56)) GO TO 20028 - IF(PRGOPT(LAST+2).NE.ZERO) ISAVE = PRGOPT(LAST+3) - LDS=4 - GO TO 20009 -20028 CONTINUE -C -C IF KEY = 57, SAVE DATA (ON EXTERNAL FILE) AT MXITLP ITERATIONS OR -C THE OPTIMUM, WHICHEVER COMES FIRST. - IF (.NOT.(KEY.EQ.57)) GO TO 20031 - SAVEDT=PRGOPT(LAST+2).NE.ZERO - LDS=3 - GO TO 20009 -20031 CONTINUE -C -C IF KEY = 58, SEE IF PROBLEM IS TO RUN ONLY A GIVEN -C NUMBER OF ITERATIONS. - IF (.NOT.(KEY.EQ.58)) GO TO 20034 - IF (PRGOPT(LAST+2).NE.ZERO) MXITLP = PRGOPT(LAST+3) - LDS=4 - GO TO 20009 -20034 CONTINUE -C -C IF KEY = 59, SEE IF USER PROVIDES THE BASIS INDICES. - IF (.NOT.(KEY .EQ. 59)) GO TO 20037 - USRBAS = PRGOPT(LAST+2) .NE. ZERO - IF (.NOT.(USRBAS)) GO TO 20040 - I=1 - N20043=MRELAS - GO TO 20044 -20043 I=I+1 -20044 IF ((N20043-I).LT.0) GO TO 20045 - IBASIS(I) = PRGOPT(LAST+2+I) - GO TO 20043 -20045 CONTINUE -20040 CONTINUE - LDS=MRELAS+3 - GO TO 20009 -20037 CONTINUE -C -C IF KEY = 60, SEE IF USER HAS PROVIDED SCALING OF COLUMNS. - IF (.NOT.(KEY .EQ. 60)) GO TO 20047 - COLSCP = PRGOPT(LAST+2).NE.ZERO - IF (.NOT.(COLSCP)) GO TO 20050 - J=1 - N20053=NVARS - GO TO 20054 -20053 J=J+1 -20054 IF ((N20053-J).LT.0) GO TO 20055 - CSC(J)=ABS(PRGOPT(LAST+2+J)) - GO TO 20053 -20055 CONTINUE -20050 CONTINUE - LDS=NVARS+3 - GO TO 20009 -20047 CONTINUE -C -C IF KEY = 61, SEE IF USER HAS PROVIDED SCALING OF COSTS. - IF (.NOT.(KEY .EQ. 61)) GO TO 20057 - CSTSCP = PRGOPT(LAST+2).NE.ZERO - IF (CSTSCP) COSTSC = PRGOPT(LAST+3) - LDS=4 - GO TO 20009 -20057 CONTINUE -C -C IF KEY = 62, SEE IF SIZE PARAMETERS ARE PROVIDED WITH THE DATA. -C THESE WILL BE CHECKED AGAINST THE MATRIX ELEMENT SIZES LATER. - IF (.NOT.(KEY .EQ. 62)) GO TO 20060 - SIZEUP = PRGOPT(LAST+2).NE.ZERO - IF (.NOT.(SIZEUP)) GO TO 20063 - ASMALL = PRGOPT(LAST+3) - ABIG = PRGOPT(LAST+4) -20063 CONTINUE - LDS=5 - GO TO 20009 -20060 CONTINUE -C -C IF KEY = 63, SEE IF TOLERANCE FOR LINEAR SYSTEM RESIDUAL ERROR IS -C PROVIDED. - IF (.NOT.(KEY .EQ. 63)) GO TO 20066 - IF (PRGOPT(LAST+2).NE.ZERO) TOLLS = MAX(EPS,PRGOPT(LAST+3)) - LDS=4 - GO TO 20009 -20066 CONTINUE -C -C IF KEY = 64, SEE IF MINIMUM REDUCED COST OR STEEPEST EDGE -C DESCENT IS TO BE USED FOR SELECTING VARIABLES TO ENTER BASIS. - IF (.NOT.(KEY.EQ.64)) GO TO 20069 - STPEDG = PRGOPT(LAST+2).EQ.ZERO - LDS=3 - GO TO 20009 -20069 CONTINUE -C -C IF KEY = 65, SET THE NUMBER OF ITERATIONS BETWEEN RECALCULATING -C THE ERROR IN THE PRIMAL SOLUTION. - IF (.NOT.(KEY.EQ.65)) GO TO 20072 - IF (PRGOPT(LAST+2).NE.ZERO) ITBRC=MAX(ONE,PRGOPT(LAST+3)) - LDS=4 - GO TO 20009 -20072 CONTINUE -C -C IF KEY = 66, SET THE NUMBER OF NEGATIVE REDUCED COSTS TO BE FOUND -C IN THE PARTIAL PRICING STRATEGY. - IF (.NOT.(KEY.EQ.66)) GO TO 20075 - IF (.NOT.(PRGOPT(LAST+2).NE.ZERO)) GO TO 20078 - NPP=MAX(PRGOPT(LAST+3),ONE) - NPP=MIN(NPP,NVARS) -20078 CONTINUE - LDS=4 - GO TO 20009 -20075 CONTINUE -C IF KEY = 67, CHANGE THE TUNING PARAMETER TO APPLY TO THE ERROR -C ESTIMATES FOR THE PRIMAL AND DUAL SYSTEMS. - IF (.NOT.(KEY.EQ.67)) GO TO 20081 - IF (.NOT.(PRGOPT(LAST+2).NE.ZERO)) GO TO 20084 - TUNE=ABS(PRGOPT(LAST+3)) -20084 CONTINUE - LDS=4 - GO TO 20009 -20081 CONTINUE - IF (.NOT.(KEY.EQ.68)) GO TO 20087 - LDS=6 - GO TO 20009 -20087 CONTINUE -C -C RESET THE ABSOLUTE TOLERANCE TO BE USED ON THE FEASIBILITY -C DECISION PROVIDED THE RELATIVE ERROR TEST FAILED. - IF (.NOT.(KEY.EQ.69)) GO TO 20090 - IF(PRGOPT(LAST+2).NE.ZERO)TOLABS=PRGOPT(LAST+3) - LDS=4 - GO TO 20009 -20090 CONTINUE - CONTINUE -C -20009 ICTOPT = ICTOPT+1 - LAST = NEXT - LPRG=LPRG+LDS - GO TO 20004 -20005 CONTINUE - GO TO 20002 -C -C PROCEDURE (VALIDATE OPTIONALLY MODIFIED DATA) -C -C IF USER HAS DEFINED THE BASIS, CHECK FOR VALIDITY OF INDICES. -30002 IF (.NOT.(USRBAS)) GO TO 20093 - I=1 - N20096=MRELAS - GO TO 20097 -20096 I=I+1 -20097 IF ((N20096-I).LT.0) GO TO 20098 - ITEST=IBASIS(I) - IF (.NOT.(ITEST.LE.0 .OR.ITEST.GT.(NVARS+MRELAS))) GO TO 20100 - NERR=16 - CALL XERMSG ('SLATEC', 'SPOPT', - + 'IN SPLP, AN INDEX OF USER-SUPPLIED BASIS IS OUT OF RANGE.', - + NERR, IOPT) - INFO=-NERR - RETURN -20100 CONTINUE - GO TO 20096 -20098 CONTINUE -20093 CONTINUE -C -C IF USER HAS PROVIDED SIZE PARAMETERS, MAKE SURE THEY ARE ORDERED -C AND POSITIVE. - IF (.NOT.(SIZEUP)) GO TO 20103 - IF (.NOT.(ASMALL.LE.ZERO .OR. ABIG.LT.ASMALL)) GO TO 20106 - NERR=17 - CALL XERMSG ('SLATEC', 'SPOPT', - + 'IN SPLP, SIZE PARAMETERS FOR MATRIX MUST BE SMALLEST AND ' // - + 'LARGEST MAGNITUDES OF NONZERO ENTRIES.', NERR, IOPT) - INFO=-NERR - RETURN -20106 CONTINUE -20103 CONTINUE -C -C THE NUMBER OF ITERATIONS OF REV. SIMPLEX STEPS MUST BE POSITIVE. - IF (.NOT.(MXITLP.LE.0)) GO TO 20109 - NERR=18 - CALL XERMSG ('SLATEC', 'SPOPT', - + 'IN SPLP, THE NUMBER OF REVISED SIMPLEX STEPS BETWEEN ' // - + 'CHECK-POINTS MUST BE POSITIVE.', NERR, IOPT) - INFO=-NERR - RETURN -20109 CONTINUE -C -C CHECK THAT SAVE AND PAGE FILE NUMBERS ARE DEFINED AND NOT EQUAL. - IF (.NOT.(ISAVE.LE.0.OR.IPAGEF.LE.0.OR.(ISAVE.EQ.IPAGEF))) GO TO 2 - *0112 - NERR=19 - CALL XERMSG ('SLATEC', 'SPOPT', - + 'IN SPLP, FILE NUMBERS FOR SAVED DATA AND MATRIX PAGES ' // - + 'MUST BE POSITIVE AND NOT EQUAL.', NERR, IOPT) - INFO=-NERR - RETURN -20112 CONTINUE - CONTINUE - GO TO 20003 - END diff --git a/slatec/sposl.f b/slatec/sposl.f deleted file mode 100644 index 487a638..0000000 --- a/slatec/sposl.f +++ /dev/null @@ -1,86 +0,0 @@ -*DECK SPOSL - SUBROUTINE SPOSL (A, LDA, N, B) -C***BEGIN PROLOGUE SPOSL -C***PURPOSE Solve the real symmetric positive definite linear system -C using the factors computed by SPOCO or SPOFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1B -C***TYPE SINGLE PRECISION (SPOSL-S, DPOSL-D, CPOSL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, POSITIVE DEFINITE, SOLVE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C SPOSL solves the real symmetric positive definite system -C A * X = B -C using the factors computed by SPOCO or SPOFA. -C -C On Entry -C -C A REAL(LDA, N) -C the output from SPOCO or SPOFA. -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 B REAL(N) -C the right hand side vector. -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 -C a zero on the diagonal. Technically, this indicates -C singularity, but it is usually caused by improper subroutine -C arguments. It will not occur if the subroutines are called -C correctly and INFO .EQ. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL SPOCO(A,LDA,N,RCOND,Z,INFO) -C IF (RCOND is too small .OR. INFO .NE. 0) GO TO ... -C DO 10 J = 1, P -C CALL SPOSL(A,LDA,N,C(1,J)) -C 10 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SAXPY, SDOT -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SPOSL - INTEGER LDA,N - REAL A(LDA,*),B(*) -C - REAL SDOT,T - INTEGER K,KB -C -C SOLVE TRANS(R)*Y = B -C -C***FIRST EXECUTABLE STATEMENT SPOSL - DO 10 K = 1, N - T = SDOT(K-1,A(1,K),1,B(1),1) - B(K) = (B(K) - T)/A(K,K) - 10 CONTINUE -C -C SOLVE R*X = Y -C - DO 20 KB = 1, N - K = N + 1 - KB - B(K) = B(K)/A(K,K) - T = -B(K) - CALL SAXPY(K-1,T,A(1,K),1,B(1),1) - 20 CONTINUE - RETURN - END diff --git a/slatec/sppco.f b/slatec/sppco.f deleted file mode 100644 index a7b2704..0000000 --- a/slatec/sppco.f +++ /dev/null @@ -1,234 +0,0 @@ -*DECK SPPCO - SUBROUTINE SPPCO (AP, N, RCOND, Z, INFO) -C***BEGIN PROLOGUE SPPCO -C***PURPOSE Factor a symmetric positive definite matrix stored in -C packed form and estimate the condition number of the -C matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1B -C***TYPE SINGLE PRECISION (SPPCO-S, DPPCO-D, CPPCO-C) -C***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, -C MATRIX FACTORIZATION, PACKED, POSITIVE DEFINITE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C SPPCO factors a real symmetric positive definite matrix -C stored in packed form -C and estimates the condition of the matrix. -C -C If RCOND is not needed, SPPFA is slightly faster. -C To solve A*X = B , follow SPPCO by SPPSL. -C To compute INVERSE(A)*C , follow SPPCO by SPPSL. -C To compute DETERMINANT(A) , follow SPPCO by SPPDI. -C To compute INVERSE(A) , follow SPPCO by SPPDI. -C -C On Entry -C -C AP REAL (N*(N+1)/2) -C the packed form of a symmetric matrix A . The -C columns of the upper triangle are stored sequentially -C in a one-dimensional array of length N*(N+1)/2 . -C See comments below for details. -C -C N INTEGER -C the order of the matrix A . -C -C On Return -C -C AP an upper triangular matrix R , stored in packed -C form, so that A = TRANS(R)*R . -C If INFO .NE. 0 , the factorization is not complete. -C -C RCOND REAL -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. If INFO .NE. 0 , RCOND is unchanged. -C -C Z REAL(N) -C a work vector whose contents are usually unimportant. -C If A is singular to working precision, then Z is -C an approximate null vector in the sense that -C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . -C If INFO .NE. 0 , Z is unchanged. -C -C INFO INTEGER -C = 0 for normal return. -C = K signals an error condition. The leading minor -C of order K is not positive definite. -C -C Packed Storage -C -C The following program segment will pack the upper -C triangle of a symmetric matrix. -C -C K = 0 -C DO 20 J = 1, N -C DO 10 I = 1, J -C K = K + 1 -C AP(K) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SASUM, SAXPY, SDOT, SPPFA, SSCAL -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SPPCO - INTEGER N,INFO - REAL AP(*),Z(*) - REAL RCOND -C - REAL SDOT,EK,T,WK,WKM - REAL ANORM,S,SASUM,SM,YNORM - INTEGER I,IJ,J,JM1,J1,K,KB,KJ,KK,KP1 -C -C FIND NORM OF A -C -C***FIRST EXECUTABLE STATEMENT SPPCO - J1 = 1 - DO 30 J = 1, N - Z(J) = SASUM(J,AP(J1),1) - IJ = J1 - J1 = J1 + J - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 20 - DO 10 I = 1, JM1 - Z(I) = Z(I) + ABS(AP(IJ)) - IJ = IJ + 1 - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - ANORM = 0.0E0 - DO 40 J = 1, N - ANORM = MAX(ANORM,Z(J)) - 40 CONTINUE -C -C FACTOR -C - CALL SPPFA(AP,N,INFO) - IF (INFO .NE. 0) GO TO 180 -C -C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . -C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . -C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL -C GROWTH IN THE ELEMENTS OF W WHERE TRANS(R)*W = E . -C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. -C -C SOLVE TRANS(R)*W = E -C - EK = 1.0E0 - DO 50 J = 1, N - Z(J) = 0.0E0 - 50 CONTINUE - KK = 0 - DO 110 K = 1, N - KK = KK + K - IF (Z(K) .NE. 0.0E0) EK = SIGN(EK,-Z(K)) - IF (ABS(EK-Z(K)) .LE. AP(KK)) GO TO 60 - S = AP(KK)/ABS(EK-Z(K)) - CALL SSCAL(N,S,Z,1) - EK = S*EK - 60 CONTINUE - WK = EK - Z(K) - WKM = -EK - Z(K) - S = ABS(WK) - SM = ABS(WKM) - WK = WK/AP(KK) - WKM = WKM/AP(KK) - KP1 = K + 1 - KJ = KK + K - IF (KP1 .GT. N) GO TO 100 - DO 70 J = KP1, N - SM = SM + ABS(Z(J)+WKM*AP(KJ)) - Z(J) = Z(J) + WK*AP(KJ) - S = S + ABS(Z(J)) - KJ = KJ + J - 70 CONTINUE - IF (S .GE. SM) GO TO 90 - T = WKM - WK - WK = WKM - KJ = KK + K - DO 80 J = KP1, N - Z(J) = Z(J) + T*AP(KJ) - KJ = KJ + J - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - Z(K) = WK - 110 CONTINUE - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) -C -C SOLVE R*Y = W -C - DO 130 KB = 1, N - K = N + 1 - KB - IF (ABS(Z(K)) .LE. AP(KK)) GO TO 120 - S = AP(KK)/ABS(Z(K)) - CALL SSCAL(N,S,Z,1) - 120 CONTINUE - Z(K) = Z(K)/AP(KK) - KK = KK - K - T = -Z(K) - CALL SAXPY(K-1,T,AP(KK+1),1,Z(1),1) - 130 CONTINUE - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) -C - YNORM = 1.0E0 -C -C SOLVE TRANS(R)*V = Y -C - DO 150 K = 1, N - Z(K) = Z(K) - SDOT(K-1,AP(KK+1),1,Z(1),1) - KK = KK + K - IF (ABS(Z(K)) .LE. AP(KK)) GO TO 140 - S = AP(KK)/ABS(Z(K)) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM - 140 CONTINUE - Z(K) = Z(K)/AP(KK) - 150 CONTINUE - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE R*Z = V -C - DO 170 KB = 1, N - K = N + 1 - KB - IF (ABS(Z(K)) .LE. AP(KK)) GO TO 160 - S = AP(KK)/ABS(Z(K)) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM - 160 CONTINUE - Z(K) = Z(K)/AP(KK) - KK = KK - K - T = -Z(K) - CALL SAXPY(K-1,T,AP(KK+1),1,Z(1),1) - 170 CONTINUE -C MAKE ZNORM = 1.0 - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM -C - IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM - IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0 - 180 CONTINUE - RETURN - END diff --git a/slatec/sppdi.f b/slatec/sppdi.f deleted file mode 100644 index cc6f19a..0000000 --- a/slatec/sppdi.f +++ /dev/null @@ -1,142 +0,0 @@ -*DECK SPPDI - SUBROUTINE SPPDI (AP, N, DET, JOB) -C***BEGIN PROLOGUE SPPDI -C***PURPOSE Compute the determinant and inverse of a real symmetric -C positive definite matrix using factors from SPPCO or SPPFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1B, D3B1B -C***TYPE SINGLE PRECISION (SPPDI-S, DPPDI-D, CPPDI-C) -C***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, -C PACKED, POSITIVE DEFINITE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C SPPDI computes the determinant and inverse -C of a real symmetric positive definite matrix -C using the factors computed by SPPCO or SPPFA . -C -C On Entry -C -C AP REAL (N*(N+1)/2) -C the output from SPPCO or SPPFA. -C -C N INTEGER -C the order of the matrix A . -C -C JOB INTEGER -C = 11 both determinant and inverse. -C = 01 inverse only. -C = 10 determinant only. -C -C On Return -C -C AP the upper triangular half of the inverse . -C The strict lower triangle is unaltered. -C -C DET REAL(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. 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 SPOCO or SPOFA has set INFO .EQ. 0 . -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SAXPY, SSCAL -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SPPDI - INTEGER N,JOB - REAL AP(*) - REAL DET(2) -C - REAL T - REAL S - INTEGER I,II,J,JJ,JM1,J1,K,KJ,KK,KP1,K1 -C***FIRST EXECUTABLE STATEMENT SPPDI -C -C COMPUTE DETERMINANT -C - IF (JOB/10 .EQ. 0) GO TO 70 - DET(1) = 1.0E0 - DET(2) = 0.0E0 - S = 10.0E0 - II = 0 - DO 50 I = 1, N - II = II + I - DET(1) = AP(II)**2*DET(1) - IF (DET(1) .EQ. 0.0E0) GO TO 60 - 10 IF (DET(1) .GE. 1.0E0) GO TO 20 - DET(1) = S*DET(1) - DET(2) = DET(2) - 1.0E0 - GO TO 10 - 20 CONTINUE - 30 IF (DET(1) .LT. S) GO TO 40 - DET(1) = DET(1)/S - DET(2) = DET(2) + 1.0E0 - GO TO 30 - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE -C -C COMPUTE INVERSE(R) -C - IF (MOD(JOB,10) .EQ. 0) GO TO 140 - KK = 0 - DO 100 K = 1, N - K1 = KK + 1 - KK = KK + K - AP(KK) = 1.0E0/AP(KK) - T = -AP(KK) - CALL SSCAL(K-1,T,AP(K1),1) - KP1 = K + 1 - J1 = KK + 1 - KJ = KK + K - IF (N .LT. KP1) GO TO 90 - DO 80 J = KP1, N - T = AP(KJ) - AP(KJ) = 0.0E0 - CALL SAXPY(K,T,AP(K1),1,AP(J1),1) - J1 = J1 + J - KJ = KJ + J - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE -C -C FORM INVERSE(R) * TRANS(INVERSE(R)) -C - JJ = 0 - DO 130 J = 1, N - J1 = JJ + 1 - JJ = JJ + J - JM1 = J - 1 - K1 = 1 - KJ = J1 - IF (JM1 .LT. 1) GO TO 120 - DO 110 K = 1, JM1 - T = AP(KJ) - CALL SAXPY(K,T,AP(J1),1,AP(K1),1) - K1 = K1 + K - KJ = KJ + 1 - 110 CONTINUE - 120 CONTINUE - T = AP(JJ) - CALL SSCAL(J,T,AP(J1),1) - 130 CONTINUE - 140 CONTINUE - RETURN - END diff --git a/slatec/spperm.f b/slatec/spperm.f deleted file mode 100644 index b46fd43..0000000 --- a/slatec/spperm.f +++ /dev/null @@ -1,84 +0,0 @@ -*DECK SPPERM - SUBROUTINE SPPERM (X, N, IPERM, IER) -C***BEGIN PROLOGUE SPPERM -C***PURPOSE Rearrange a given array according to a prescribed -C permutation vector. -C***LIBRARY SLATEC -C***CATEGORY N8 -C***TYPE SINGLE PRECISION (SPPERM-S, DPPERM-D, IPPERM-I, HPPERM-H) -C***KEYWORDS APPLICATION OF PERMUTATION TO DATA VECTOR -C***AUTHOR McClain, M. A., (NIST) -C Rhoads, G. S., (NBS) -C***DESCRIPTION -C -C SPPERM rearranges the data vector X according to the -C permutation IPERM: X(I) <--- X(IPERM(I)). IPERM could come -C from one of the sorting routines IPSORT, SPSORT, DPSORT or -C HPSORT. -C -C Description of Parameters -C X - input/output -- real array of values to be rearranged. -C N - input -- number of values in real array X. -C IPERM - input -- permutation vector. -C IER - output -- error indicator: -C = 0 if no error, -C = 1 if N is zero or negative, -C = 2 if IPERM is not a valid permutation. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 901004 DATE WRITTEN -C 920507 Modified by M. McClain to revise prologue text. -C***END PROLOGUE SPPERM - INTEGER N, IPERM(*), I, IER, INDX, INDX0, ISTRT - REAL X(*), TEMP -C***FIRST EXECUTABLE STATEMENT SPPERM - IER=0 - IF(N.LT.1)THEN - IER=1 - CALL XERMSG ('SLATEC', 'SPPERM', - + 'The number of values to be rearranged, N, is not positive.', - + IER, 1) - RETURN - ENDIF -C -C CHECK WHETHER IPERM IS A VALID PERMUTATION -C - DO 100 I=1,N - INDX=ABS(IPERM(I)) - IF((INDX.GE.1).AND.(INDX.LE.N))THEN - IF(IPERM(INDX).GT.0)THEN - IPERM(INDX)=-IPERM(INDX) - GOTO 100 - ENDIF - ENDIF - IER=2 - CALL XERMSG ('SLATEC', 'SPPERM', - + 'The permutation vector, IPERM, is not valid.', IER, 1) - RETURN - 100 CONTINUE -C -C REARRANGE THE VALUES OF X -C -C USE THE IPERM VECTOR AS A FLAG. -C IF IPERM(I) > 0, THEN THE I-TH VALUE IS IN CORRECT LOCATION -C - DO 330 ISTRT = 1 , N - IF (IPERM(ISTRT) .GT. 0) GOTO 330 - INDX = ISTRT - INDX0 = INDX - TEMP = X(ISTRT) - 320 CONTINUE - IF (IPERM(INDX) .GE. 0) GOTO 325 - X(INDX) = X(-IPERM(INDX)) - INDX0 = INDX - IPERM(INDX) = -IPERM(INDX) - INDX = IPERM(INDX) - GOTO 320 - 325 CONTINUE - X(INDX0) = TEMP - 330 CONTINUE -C - RETURN - END diff --git a/slatec/sppfa.f b/slatec/sppfa.f deleted file mode 100644 index 20f120b..0000000 --- a/slatec/sppfa.f +++ /dev/null @@ -1,100 +0,0 @@ -*DECK SPPFA - SUBROUTINE SPPFA (AP, N, INFO) -C***BEGIN PROLOGUE SPPFA -C***PURPOSE Factor a real symmetric positive definite matrix stored in -C packed form. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1B -C***TYPE SINGLE PRECISION (SPPFA-S, DPPFA-D, CPPFA-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, PACKED, -C POSITIVE DEFINITE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C SPPFA factors a real symmetric positive definite matrix -C stored in packed form. -C -C SPPFA is usually called by SPPCO, but it can be called -C directly with a saving in time if RCOND is not needed. -C (Time for SPPCO) = (1 + 18/N)*(Time for SPPFA) . -C -C On Entry -C -C AP REAL (N*(N+1)/2) -C the packed form of a symmetric matrix A . The -C columns of the upper triangle are stored sequentially -C in a one-dimensional array of length N*(N+1)/2 . -C See comments below for details. -C -C N INTEGER -C the order of the matrix A . -C -C On Return -C -C AP an upper triangular matrix R , stored in packed -C form, so that A = TRANS(R)*R . -C -C INFO INTEGER -C = 0 for normal return. -C = K if the leading minor of order K is not -C positive definite. -C -C -C Packed Storage -C -C The following program segment will pack the upper -C triangle of a symmetric matrix. -C -C K = 0 -C DO 20 J = 1, N -C DO 10 I = 1, J -C K = K + 1 -C AP(K) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SDOT -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SPPFA - INTEGER N,INFO - REAL AP(*) -C - REAL SDOT,T - REAL S - INTEGER J,JJ,JM1,K,KJ,KK -C***FIRST EXECUTABLE STATEMENT SPPFA - JJ = 0 - DO 30 J = 1, N - INFO = J - S = 0.0E0 - JM1 = J - 1 - KJ = JJ - KK = 0 - IF (JM1 .LT. 1) GO TO 20 - DO 10 K = 1, JM1 - KJ = KJ + 1 - T = AP(KJ) - SDOT(K-1,AP(KK+1),1,AP(JJ+1),1) - KK = KK + K - T = T/AP(KK) - AP(KJ) = T - S = S + T*T - 10 CONTINUE - 20 CONTINUE - JJ = JJ + J - S = AP(JJ) - S - IF (S .LE. 0.0E0) GO TO 40 - AP(JJ) = SQRT(S) - 30 CONTINUE - INFO = 0 - 40 CONTINUE - RETURN - END diff --git a/slatec/sppsl.f b/slatec/sppsl.f deleted file mode 100644 index d7a1b19..0000000 --- a/slatec/sppsl.f +++ /dev/null @@ -1,81 +0,0 @@ -*DECK SPPSL - SUBROUTINE SPPSL (AP, N, B) -C***BEGIN PROLOGUE SPPSL -C***PURPOSE Solve the real symmetric positive definite system using -C the factors computed by SPPCO or SPPFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1B -C***TYPE SINGLE PRECISION (SPPSL-S, DPPSL-D, CPPSL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, PACKED, -C POSITIVE DEFINITE, SOLVE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C SPPSL solves the real symmetric positive definite system -C A * X = B -C using the factors computed by SPPCO or SPPFA. -C -C On Entry -C -C AP REAL (N*(N+1)/2) -C the output from SPPCO or SPPFA. -C -C N INTEGER -C the order of the matrix A . -C -C B REAL(N) -C the right hand side vector. -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 -C a zero on the diagonal. Technically, this indicates -C singularity, but it is usually caused by improper subroutine -C arguments. It will not occur if the subroutines are called -C correctly and INFO .EQ. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL SPPCO(AP,N,RCOND,Z,INFO) -C IF (RCOND is too small .OR. INFO .NE. 0) GO TO ... -C DO 10 J = 1, P -C CALL SPPSL(AP,N,C(1,J)) -C 10 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SAXPY, SDOT -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SPPSL - INTEGER N - REAL AP(*),B(*) -C - REAL SDOT,T - INTEGER K,KB,KK -C***FIRST EXECUTABLE STATEMENT SPPSL - KK = 0 - DO 10 K = 1, N - T = SDOT(K-1,AP(KK+1),1,B(1),1) - KK = KK + K - B(K) = (B(K) - T)/AP(KK) - 10 CONTINUE - DO 20 KB = 1, N - K = N + 1 - KB - B(K) = B(K)/AP(KK) - KK = KK - K - T = -B(K) - CALL SAXPY(K-1,T,AP(KK+1),1,B(1),1) - 20 CONTINUE - RETURN - END diff --git a/slatec/spsort.f b/slatec/spsort.f deleted file mode 100644 index dcaac87..0000000 --- a/slatec/spsort.f +++ /dev/null @@ -1,268 +0,0 @@ -*DECK SPSORT - SUBROUTINE SPSORT (X, N, IPERM, KFLAG, IER) -C***BEGIN PROLOGUE SPSORT -C***PURPOSE Return the permutation vector generated by sorting a given -C array and, optionally, rearrange the elements of the array. -C The array may be sorted in increasing or decreasing order. -C A slightly modified quicksort algorithm is used. -C***LIBRARY SLATEC -C***CATEGORY N6A1B, N6A2B -C***TYPE SINGLE PRECISION (SPSORT-S, DPSORT-D, IPSORT-I, HPSORT-H) -C***KEYWORDS NUMBER SORTING, PASSIVE SORTING, SINGLETON QUICKSORT, SORT -C***AUTHOR Jones, R. E., (SNLA) -C Rhoads, G. S., (NBS) -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C -C SPSORT returns the permutation vector IPERM generated by sorting -C the array X and, optionally, rearranges the values in X. X may -C be sorted in increasing or decreasing order. A slightly modified -C quicksort algorithm is used. -C -C IPERM is such that X(IPERM(I)) is the Ith value in the rearrangement -C of X. IPERM may be applied to another array by calling IPPERM, -C SPPERM, DPPERM or HPPERM. -C -C The main difference between SPSORT and its active sorting equivalent -C SSORT is that the data are referenced indirectly rather than -C directly. Therefore, SPSORT should require approximately twice as -C long to execute as SSORT. However, SPSORT is more general. -C -C Description of Parameters -C X - input/output -- real array of values to be sorted. -C If ABS(KFLAG) = 2, then the values in X will be -C rearranged on output; otherwise, they are unchanged. -C N - input -- number of values in array X to be sorted. -C IPERM - output -- permutation array such that IPERM(I) is the -C index of the value in the original order of the -C X array that is in the Ith location in the sorted -C order. -C KFLAG - input -- control parameter: -C = 2 means return the permutation vector resulting from -C sorting X in increasing order and sort X also. -C = 1 means return the permutation vector resulting from -C sorting X in increasing order and do not sort X. -C = -1 means return the permutation vector resulting from -C sorting X in decreasing order and do not sort X. -C = -2 means return the permutation vector resulting from -C sorting X in decreasing order and sort X also. -C IER - output -- error indicator: -C = 0 if no error, -C = 1 if N is zero or negative, -C = 2 if KFLAG is not 2, 1, -1, or -2. -C***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm -C for sorting with minimal storage, Communications of -C the ACM, 12, 3 (1969), pp. 185-187. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 761101 DATE WRITTEN -C 761118 Modified by John A. Wisniewski to use the Singleton -C quicksort algorithm. -C 870423 Modified by Gregory S. Rhoads for passive sorting with the -C option for the rearrangement of the original data. -C 890620 Algorithm for rearranging the data vector corrected by R. -C Boisvert. -C 890622 Prologue upgraded to Version 4.0 style by D. Lozier. -C 891128 Error when KFLAG.LT.0 and N=1 corrected by R. Boisvert. -C 920507 Modified by M. McClain to revise prologue text. -C 920818 Declarations section rebuilt and code restructured to use -C IF-THEN-ELSE-ENDIF. (SMR, WRB) -C***END PROLOGUE SPSORT -C .. Scalar Arguments .. - INTEGER IER, KFLAG, N -C .. Array Arguments .. - REAL X(*) - INTEGER IPERM(*) -C .. Local Scalars .. - REAL R, TEMP - INTEGER I, IJ, INDX, INDX0, ISTRT, J, K, KK, L, LM, LMT, M, NN -C .. Local Arrays .. - INTEGER IL(21), IU(21) -C .. External Subroutines .. - EXTERNAL XERMSG -C .. Intrinsic Functions .. - INTRINSIC ABS, INT -C***FIRST EXECUTABLE STATEMENT SPSORT - IER = 0 - NN = N - IF (NN .LT. 1) THEN - IER = 1 - CALL XERMSG ('SLATEC', 'SPSORT', - + 'The number of values to be sorted, N, is not positive.', - + IER, 1) - RETURN - ENDIF - KK = ABS(KFLAG) - IF (KK.NE.1 .AND. KK.NE.2) THEN - IER = 2 - CALL XERMSG ('SLATEC', 'SPSORT', - + 'The sort control parameter, KFLAG, is not 2, 1, -1, or -2.', - + IER, 1) - RETURN - ENDIF -C -C Initialize permutation vector -C - DO 10 I=1,NN - IPERM(I) = I - 10 CONTINUE -C -C Return if only one value is to be sorted -C - IF (NN .EQ. 1) RETURN -C -C Alter array X to get decreasing order if needed -C - IF (KFLAG .LE. -1) THEN - DO 20 I=1,NN - X(I) = -X(I) - 20 CONTINUE - ENDIF -C -C Sort X only -C - M = 1 - I = 1 - J = NN - R = .375E0 -C - 30 IF (I .EQ. J) GO TO 80 - IF (R .LE. 0.5898437E0) THEN - R = R+3.90625E-2 - ELSE - R = R-0.21875E0 - ENDIF -C - 40 K = I -C -C Select a central element of the array and save it in location L -C - IJ = I + INT((J-I)*R) - LM = IPERM(IJ) -C -C If first element of array is greater than LM, interchange with LM -C - IF (X(IPERM(I)) .GT. X(LM)) THEN - IPERM(IJ) = IPERM(I) - IPERM(I) = LM - LM = IPERM(IJ) - ENDIF - L = J -C -C If last element of array is less than LM, interchange with LM -C - IF (X(IPERM(J)) .LT. X(LM)) THEN - IPERM(IJ) = IPERM(J) - IPERM(J) = LM - LM = IPERM(IJ) -C -C If first element of array is greater than LM, interchange -C with LM -C - IF (X(IPERM(I)) .GT. X(LM)) THEN - IPERM(IJ) = IPERM(I) - IPERM(I) = LM - LM = IPERM(IJ) - ENDIF - ENDIF - GO TO 60 - 50 LMT = IPERM(L) - IPERM(L) = IPERM(K) - IPERM(K) = LMT -C -C Find an element in the second half of the array which is smaller -C than LM -C - 60 L = L-1 - IF (X(IPERM(L)) .GT. X(LM)) GO TO 60 -C -C Find an element in the first half of the array which is greater -C than LM -C - 70 K = K+1 - IF (X(IPERM(K)) .LT. X(LM)) GO TO 70 -C -C Interchange these elements -C - IF (K .LE. L) GO TO 50 -C -C Save upper and lower subscripts of the array yet to be sorted -C - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 90 -C -C Begin again on another portion of the unsorted array -C - 80 M = M-1 - IF (M .EQ. 0) GO TO 120 - I = IL(M) - J = IU(M) -C - 90 IF (J-I .GE. 1) GO TO 40 - IF (I .EQ. 1) GO TO 30 - I = I-1 -C - 100 I = I+1 - IF (I .EQ. J) GO TO 80 - LM = IPERM(I+1) - IF (X(IPERM(I)) .LE. X(LM)) GO TO 100 - K = I -C - 110 IPERM(K+1) = IPERM(K) - K = K-1 -C - IF (X(LM) .LT. X(IPERM(K))) GO TO 110 - IPERM(K+1) = LM - GO TO 100 -C -C Clean up -C - 120 IF (KFLAG .LE. -1) THEN - DO 130 I=1,NN - X(I) = -X(I) - 130 CONTINUE - ENDIF -C -C Rearrange the values of X if desired -C - IF (KK .EQ. 2) THEN -C -C Use the IPERM vector as a flag. -C If IPERM(I) < 0, then the I-th value is in correct location -C - DO 150 ISTRT=1,NN - IF (IPERM(ISTRT) .GE. 0) THEN - INDX = ISTRT - INDX0 = INDX - TEMP = X(ISTRT) - 140 IF (IPERM(INDX) .GT. 0) THEN - X(INDX) = X(IPERM(INDX)) - INDX0 = INDX - IPERM(INDX) = -IPERM(INDX) - INDX = ABS(IPERM(INDX)) - GO TO 140 - ENDIF - X(INDX0) = TEMP - ENDIF - 150 CONTINUE -C -C Revert the signs of the IPERM values -C - DO 160 I=1,NN - IPERM(I) = -IPERM(I) - 160 CONTINUE -C - ENDIF -C - RETURN - END diff --git a/slatec/sptsl.f b/slatec/sptsl.f deleted file mode 100644 index d20b896..0000000 --- a/slatec/sptsl.f +++ /dev/null @@ -1,106 +0,0 @@ -*DECK SPTSL - SUBROUTINE SPTSL (N, D, E, B) -C***BEGIN PROLOGUE SPTSL -C***PURPOSE Solve a positive definite tridiagonal linear system. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B2A -C***TYPE SINGLE PRECISION (SPTSL-S, DPTSL-D, CPTSL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, POSITIVE DEFINITE, SOLVE, -C TRIDIAGONAL -C***AUTHOR Dongarra, J., (ANL) -C***DESCRIPTION -C -C SPTSL given a positive definite tridiagonal matrix and a right -C hand side will find the solution. -C -C On Entry -C -C N INTEGER -C is the order of the tridiagonal matrix. -C -C D REAL(N) -C is the diagonal of the tridiagonal matrix. -C On output, D is destroyed. -C -C E REAL(N) -C is the offdiagonal of the tridiagonal matrix. -C E(1) through E(N-1) should contain the -C offdiagonal. -C -C B REAL(N) -C is the right hand side vector. -C -C On Return -C -C B contains the solution. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890505 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SPTSL - INTEGER N - REAL D(*),E(*),B(*) -C - INTEGER K,KBM1,KE,KF,KP1,NM1,NM1D2 - REAL T1,T2 -C -C CHECK FOR 1 X 1 CASE -C -C***FIRST EXECUTABLE STATEMENT SPTSL - IF (N .NE. 1) GO TO 10 - B(1) = B(1)/D(1) - GO TO 70 - 10 CONTINUE - NM1 = N - 1 - NM1D2 = NM1/2 - IF (N .EQ. 2) GO TO 30 - KBM1 = N - 1 -C -C ZERO TOP HALF OF SUBDIAGONAL AND BOTTOM HALF OF -C SUPERDIAGONAL -C - DO 20 K = 1, NM1D2 - T1 = E(K)/D(K) - D(K+1) = D(K+1) - T1*E(K) - B(K+1) = B(K+1) - T1*B(K) - T2 = E(KBM1)/D(KBM1+1) - D(KBM1) = D(KBM1) - T2*E(KBM1) - B(KBM1) = B(KBM1) - T2*B(KBM1+1) - KBM1 = KBM1 - 1 - 20 CONTINUE - 30 CONTINUE - KP1 = NM1D2 + 1 -C -C CLEAN UP FOR POSSIBLE 2 X 2 BLOCK AT CENTER -C - IF (MOD(N,2) .NE. 0) GO TO 40 - T1 = E(KP1)/D(KP1) - D(KP1+1) = D(KP1+1) - T1*E(KP1) - B(KP1+1) = B(KP1+1) - T1*B(KP1) - KP1 = KP1 + 1 - 40 CONTINUE -C -C BACK SOLVE STARTING AT THE CENTER, GOING TOWARDS THE TOP -C AND BOTTOM -C - B(KP1) = B(KP1)/D(KP1) - IF (N .EQ. 2) GO TO 60 - K = KP1 - 1 - KE = KP1 + NM1D2 - 1 - DO 50 KF = KP1, KE - B(K) = (B(K) - E(K)*B(K+1))/D(K) - B(KF+1) = (B(KF+1) - E(KF)*B(KF))/D(KF+1) - K = K - 1 - 50 CONTINUE - 60 CONTINUE - IF (MOD(N,2) .EQ. 0) B(1) = (B(1) - E(1)*B(2))/D(1) - 70 CONTINUE - RETURN - END diff --git a/slatec/sqrdc.f b/slatec/sqrdc.f deleted file mode 100644 index 68ee573..0000000 --- a/slatec/sqrdc.f +++ /dev/null @@ -1,223 +0,0 @@ -*DECK SQRDC - SUBROUTINE SQRDC (X, LDX, N, P, QRAUX, JPVT, WORK, JOB) -C***BEGIN PROLOGUE SQRDC -C***PURPOSE Use Householder transformations to compute the QR -C factorization of an N by P matrix. Column pivoting is a -C users option. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D5 -C***TYPE SINGLE PRECISION (SQRDC-S, DQRDC-D, CQRDC-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, ORTHOGONAL TRIANGULAR, -C QR DECOMPOSITION -C***AUTHOR Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C SQRDC uses Householder transformations to compute the QR -C factorization of an N by P matrix X. Column pivoting -C based on the 2-norms of the reduced columns may be -C performed at the user's option. -C -C On Entry -C -C X REAL(LDX,P), where LDX .GE. N. -C X contains the matrix whose decomposition is to be -C computed. -C -C LDX INTEGER. -C LDX is the leading dimension of the array X. -C -C N INTEGER. -C N is the number of rows of the matrix X. -C -C P INTEGER. -C P is the number of columns of the matrix X. -C -C JPVT INTEGER(P). -C JPVT contains integers that control the selection -C of the pivot columns. The K-th column X(K) of X -C is placed in one of three classes according to the -C value of JPVT(K). -C -C If JPVT(K) .GT. 0, then X(K) is an initial -C column. -C -C If JPVT(K) .EQ. 0, then X(K) is a free column. -C -C If JPVT(K) .LT. 0, then X(K) is a final column. -C -C Before the decomposition is computed, initial columns -C are moved to the beginning of the array X and final -C columns to the end. Both initial and final columns -C are frozen in place during the computation and only -C free columns are moved. At the K-th stage of the -C reduction, if X(K) is occupied by a free column, -C it is interchanged with the free column of largest -C reduced norm. JPVT is not referenced if -C JOB .EQ. 0. -C -C WORK REAL(P). -C WORK is a work array. WORK is not referenced if -C JOB .EQ. 0. -C -C JOB INTEGER. -C JOB is an integer that initiates column pivoting. -C If JOB .EQ. 0, no pivoting is done. -C If JOB .NE. 0, pivoting is done. -C -C On Return -C -C X X contains in its upper triangle the upper -C triangular matrix R of the QR factorization. -C Below its diagonal X contains information from -C which the orthogonal part of the decomposition -C can be recovered. Note that if pivoting has -C been requested, the decomposition is not that -C of the original matrix X but that of X -C with its columns permuted as described by JPVT. -C -C QRAUX REAL(P). -C QRAUX contains further information required to recover -C the orthogonal part of the decomposition. -C -C JPVT JPVT(K) contains the index of the column of the -C original matrix that has been interchanged into -C the K-th column, if pivoting was requested. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SAXPY, SDOT, SNRM2, SSCAL, SSWAP -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SQRDC - INTEGER LDX,N,P,JOB - INTEGER JPVT(*) - REAL X(LDX,*),QRAUX(*),WORK(*) -C - INTEGER J,JP,L,LP1,LUP,MAXJ,PL,PU - REAL MAXNRM,SNRM2,TT - REAL SDOT,NRMXL,T - LOGICAL NEGJ,SWAPJ -C -C***FIRST EXECUTABLE STATEMENT SQRDC - PL = 1 - PU = 0 - IF (JOB .EQ. 0) GO TO 60 -C -C PIVOTING HAS BEEN REQUESTED. REARRANGE THE COLUMNS -C ACCORDING TO JPVT. -C - DO 20 J = 1, P - SWAPJ = JPVT(J) .GT. 0 - NEGJ = JPVT(J) .LT. 0 - JPVT(J) = J - IF (NEGJ) JPVT(J) = -J - IF (.NOT.SWAPJ) GO TO 10 - IF (J .NE. PL) CALL SSWAP(N,X(1,PL),1,X(1,J),1) - JPVT(J) = JPVT(PL) - JPVT(PL) = J - PL = PL + 1 - 10 CONTINUE - 20 CONTINUE - PU = P - DO 50 JJ = 1, P - J = P - JJ + 1 - IF (JPVT(J) .GE. 0) GO TO 40 - JPVT(J) = -JPVT(J) - IF (J .EQ. PU) GO TO 30 - CALL SSWAP(N,X(1,PU),1,X(1,J),1) - JP = JPVT(PU) - JPVT(PU) = JPVT(J) - JPVT(J) = JP - 30 CONTINUE - PU = PU - 1 - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE -C -C COMPUTE THE NORMS OF THE FREE COLUMNS. -C - IF (PU .LT. PL) GO TO 80 - DO 70 J = PL, PU - QRAUX(J) = SNRM2(N,X(1,J),1) - WORK(J) = QRAUX(J) - 70 CONTINUE - 80 CONTINUE -C -C PERFORM THE HOUSEHOLDER REDUCTION OF X. -C - LUP = MIN(N,P) - DO 200 L = 1, LUP - IF (L .LT. PL .OR. L .GE. PU) GO TO 120 -C -C LOCATE THE COLUMN OF LARGEST NORM AND BRING IT -C INTO THE PIVOT POSITION. -C - MAXNRM = 0.0E0 - MAXJ = L - DO 100 J = L, PU - IF (QRAUX(J) .LE. MAXNRM) GO TO 90 - MAXNRM = QRAUX(J) - MAXJ = J - 90 CONTINUE - 100 CONTINUE - IF (MAXJ .EQ. L) GO TO 110 - CALL SSWAP(N,X(1,L),1,X(1,MAXJ),1) - QRAUX(MAXJ) = QRAUX(L) - WORK(MAXJ) = WORK(L) - JP = JPVT(MAXJ) - JPVT(MAXJ) = JPVT(L) - JPVT(L) = JP - 110 CONTINUE - 120 CONTINUE - QRAUX(L) = 0.0E0 - IF (L .EQ. N) GO TO 190 -C -C COMPUTE THE HOUSEHOLDER TRANSFORMATION FOR COLUMN L. -C - NRMXL = SNRM2(N-L+1,X(L,L),1) - IF (NRMXL .EQ. 0.0E0) GO TO 180 - IF (X(L,L) .NE. 0.0E0) NRMXL = SIGN(NRMXL,X(L,L)) - CALL SSCAL(N-L+1,1.0E0/NRMXL,X(L,L),1) - X(L,L) = 1.0E0 + X(L,L) -C -C APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS, -C UPDATING THE NORMS. -C - LP1 = L + 1 - IF (P .LT. LP1) GO TO 170 - DO 160 J = LP1, P - T = -SDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L) - CALL SAXPY(N-L+1,T,X(L,L),1,X(L,J),1) - IF (J .LT. PL .OR. J .GT. PU) GO TO 150 - IF (QRAUX(J) .EQ. 0.0E0) GO TO 150 - TT = 1.0E0 - (ABS(X(L,J))/QRAUX(J))**2 - TT = MAX(TT,0.0E0) - T = TT - TT = 1.0E0 + 0.05E0*TT*(QRAUX(J)/WORK(J))**2 - IF (TT .EQ. 1.0E0) GO TO 130 - QRAUX(J) = QRAUX(J)*SQRT(T) - GO TO 140 - 130 CONTINUE - QRAUX(J) = SNRM2(N-L,X(L+1,J),1) - WORK(J) = QRAUX(J) - 140 CONTINUE - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE -C -C SAVE THE TRANSFORMATION. -C - QRAUX(L) = X(L,L) - X(L,L) = -NRMXL - 180 CONTINUE - 190 CONTINUE - 200 CONTINUE - RETURN - END diff --git a/slatec/sqrsl.f b/slatec/sqrsl.f deleted file mode 100644 index ae1d43e..0000000 --- a/slatec/sqrsl.f +++ /dev/null @@ -1,288 +0,0 @@ -*DECK SQRSL - SUBROUTINE SQRSL (X, LDX, N, K, QRAUX, Y, QY, QTY, B, RSD, XB, - + JOB, INFO) -C***BEGIN PROLOGUE SQRSL -C***PURPOSE Apply the output of SQRDC to compute coordinate transfor- -C mations, projections, and least squares solutions. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D9, D2A1 -C***TYPE SINGLE PRECISION (SQRSL-S, DQRSL-D, CQRSL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, ORTHOGONAL TRIANGULAR, -C SOLVE -C***AUTHOR Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C SQRSL applies the output of SQRDC to compute coordinate -C transformations, projections, and least squares solutions. -C For K .LE. MIN(N,P), let XK be the matrix -C -C XK = (X(JPVT(1)),X(JPVT(2)), ... ,X(JPVT(K))) -C -C formed from columns JPVT(1), ... ,JPVT(K) of the original -C N x P matrix X that was input to SQRDC (if no pivoting was -C done, XK consists of the first K columns of X in their -C original order). SQRDC produces a factored orthogonal matrix Q -C and an upper triangular matrix R such that -C -C XK = Q * (R) -C (0) -C -C This information is contained in coded form in the arrays -C X and QRAUX. -C -C On Entry -C -C X REAL(LDX,P) -C X contains the output of SQRDC. -C -C LDX INTEGER -C LDX is the leading dimension of the array X. -C -C N INTEGER -C N is the number of rows of the matrix XK. It must -C have the same value as N in SQRDC. -C -C K INTEGER -C K is the number of columns of the matrix XK. K -C must not be greater than MIN(N,P), where P is the -C same as in the calling sequence to SQRDC. -C -C QRAUX REAL(P) -C QRAUX contains the auxiliary output from SQRDC. -C -C Y REAL(N) -C Y contains an N-vector that is to be manipulated -C by SQRSL. -C -C JOB INTEGER -C JOB specifies what is to be computed. JOB has -C the decimal expansion ABCDE, with the following -C meaning. -C -C If A .NE. 0, compute QY. -C If B,C,D, or E .NE. 0, compute QTY. -C If C .NE. 0, compute B. -C If D .NE. 0, compute RSD. -C If E .NE. 0, compute XB. -C -C Note that a request to compute B, RSD, or XB -C automatically triggers the computation of QTY, for -C which an array must be provided in the calling -C sequence. -C -C On Return -C -C QY REAL(N). -C QY contains Q*Y, if its computation has been -C requested. -C -C QTY REAL(N). -C QTY contains TRANS(Q)*Y, if its computation has -C been requested. Here TRANS(Q) is the -C transpose of the matrix Q. -C -C B REAL(K) -C B contains the solution of the least squares problem -C -C minimize norm2(Y - XK*B), -C -C if its computation has been requested. (Note that -C if pivoting was requested in SQRDC, the J-th -C component of B will be associated with column JPVT(J) -C of the original matrix X that was input into SQRDC.) -C -C RSD REAL(N). -C RSD contains the least squares residual Y - XK*B, -C if its computation has been requested. RSD is -C also the orthogonal projection of Y onto the -C orthogonal complement of the column space of XK. -C -C XB REAL(N). -C XB contains the least squares approximation XK*B, -C if its computation has been requested. XB is also -C the orthogonal projection of Y onto the column space -C of X. -C -C INFO INTEGER. -C INFO is zero unless the computation of B has -C been requested and R is exactly singular. In -C this case, INFO is the index of the first zero -C diagonal element of R and B is left unaltered. -C -C The parameters QY, QTY, B, RSD, and XB are not referenced -C if their computation is not requested and in this case -C can be replaced by dummy variables in the calling program. -C To save storage, the user may in some cases use the same -C array for different parameters in the calling sequence. A -C frequently occurring example is when one wishes to compute -C any of B, RSD, or XB and does not need Y or QTY. In this -C case one may identify Y, QTY, and one of B, RSD, or XB, while -C providing separate arrays for anything else that is to be -C computed. Thus the calling sequence -C -C CALL SQRSL(X,LDX,N,K,QRAUX,Y,DUM,Y,B,Y,DUM,110,INFO) -C -C will result in the computation of B and RSD, with RSD -C overwriting Y. More generally, each item in the following -C list contains groups of permissible identifications for -C a single calling sequence. -C -C 1. (Y,QTY,B) (RSD) (XB) (QY) -C -C 2. (Y,QTY,RSD) (B) (XB) (QY) -C -C 3. (Y,QTY,XB) (B) (RSD) (QY) -C -C 4. (Y,QY) (QTY,B) (RSD) (XB) -C -C 5. (Y,QY) (QTY,RSD) (B) (XB) -C -C 6. (Y,QY) (QTY,XB) (B) (RSD) -C -C In any group the value returned in the array allocated to -C the group corresponds to the last member of the group. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SAXPY, SCOPY, SDOT -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SQRSL - INTEGER LDX,N,K,JOB,INFO - REAL X(LDX,*),QRAUX(*),Y(*),QY(*),QTY(*),B(*),RSD(*),XB(*) -C - INTEGER I,J,JJ,JU,KP1 - REAL SDOT,T,TEMP - LOGICAL CB,CQY,CQTY,CR,CXB -C***FIRST EXECUTABLE STATEMENT SQRSL -C -C SET INFO FLAG. -C - INFO = 0 -C -C DETERMINE WHAT IS TO BE COMPUTED. -C - CQY = JOB/10000 .NE. 0 - CQTY = MOD(JOB,10000) .NE. 0 - CB = MOD(JOB,1000)/100 .NE. 0 - CR = MOD(JOB,100)/10 .NE. 0 - CXB = MOD(JOB,10) .NE. 0 - JU = MIN(K,N-1) -C -C SPECIAL ACTION WHEN N=1. -C - IF (JU .NE. 0) GO TO 40 - IF (CQY) QY(1) = Y(1) - IF (CQTY) QTY(1) = Y(1) - IF (CXB) XB(1) = Y(1) - IF (.NOT.CB) GO TO 30 - IF (X(1,1) .NE. 0.0E0) GO TO 10 - INFO = 1 - GO TO 20 - 10 CONTINUE - B(1) = Y(1)/X(1,1) - 20 CONTINUE - 30 CONTINUE - IF (CR) RSD(1) = 0.0E0 - GO TO 250 - 40 CONTINUE -C -C SET UP TO COMPUTE QY OR QTY. -C - IF (CQY) CALL SCOPY(N,Y,1,QY,1) - IF (CQTY) CALL SCOPY(N,Y,1,QTY,1) - IF (.NOT.CQY) GO TO 70 -C -C COMPUTE QY. -C - DO 60 JJ = 1, JU - J = JU - JJ + 1 - IF (QRAUX(J) .EQ. 0.0E0) GO TO 50 - TEMP = X(J,J) - X(J,J) = QRAUX(J) - T = -SDOT(N-J+1,X(J,J),1,QY(J),1)/X(J,J) - CALL SAXPY(N-J+1,T,X(J,J),1,QY(J),1) - X(J,J) = TEMP - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE - IF (.NOT.CQTY) GO TO 100 -C -C COMPUTE TRANS(Q)*Y. -C - DO 90 J = 1, JU - IF (QRAUX(J) .EQ. 0.0E0) GO TO 80 - TEMP = X(J,J) - X(J,J) = QRAUX(J) - T = -SDOT(N-J+1,X(J,J),1,QTY(J),1)/X(J,J) - CALL SAXPY(N-J+1,T,X(J,J),1,QTY(J),1) - X(J,J) = TEMP - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE -C -C SET UP TO COMPUTE B, RSD, OR XB. -C - IF (CB) CALL SCOPY(K,QTY,1,B,1) - KP1 = K + 1 - IF (CXB) CALL SCOPY(K,QTY,1,XB,1) - IF (CR .AND. K .LT. N) CALL SCOPY(N-K,QTY(KP1),1,RSD(KP1),1) - IF (.NOT.CXB .OR. KP1 .GT. N) GO TO 120 - DO 110 I = KP1, N - XB(I) = 0.0E0 - 110 CONTINUE - 120 CONTINUE - IF (.NOT.CR) GO TO 140 - DO 130 I = 1, K - RSD(I) = 0.0E0 - 130 CONTINUE - 140 CONTINUE - IF (.NOT.CB) GO TO 190 -C -C COMPUTE B. -C - DO 170 JJ = 1, K - J = K - JJ + 1 - IF (X(J,J) .NE. 0.0E0) GO TO 150 - INFO = J - GO TO 180 - 150 CONTINUE - B(J) = B(J)/X(J,J) - IF (J .EQ. 1) GO TO 160 - T = -B(J) - CALL SAXPY(J-1,T,X(1,J),1,B,1) - 160 CONTINUE - 170 CONTINUE - 180 CONTINUE - 190 CONTINUE - IF (.NOT.CR .AND. .NOT.CXB) GO TO 240 -C -C COMPUTE RSD OR XB AS REQUIRED. -C - DO 230 JJ = 1, JU - J = JU - JJ + 1 - IF (QRAUX(J) .EQ. 0.0E0) GO TO 220 - TEMP = X(J,J) - X(J,J) = QRAUX(J) - IF (.NOT.CR) GO TO 200 - T = -SDOT(N-J+1,X(J,J),1,RSD(J),1)/X(J,J) - CALL SAXPY(N-J+1,T,X(J,J),1,RSD(J),1) - 200 CONTINUE - IF (.NOT.CXB) GO TO 210 - T = -SDOT(N-J+1,X(J,J),1,XB(J),1)/X(J,J) - CALL SAXPY(N-J+1,T,X(J,J),1,XB(J),1) - 210 CONTINUE - X(J,J) = TEMP - 220 CONTINUE - 230 CONTINUE - 240 CONTINUE - 250 CONTINUE - RETURN - END diff --git a/slatec/sreadp.f b/slatec/sreadp.f deleted file mode 100644 index 336036b..0000000 --- a/slatec/sreadp.f +++ /dev/null @@ -1,44 +0,0 @@ -*DECK SREADP - SUBROUTINE SREADP (IPAGE, LIST, RLIST, LPAGE, IREC) -C***BEGIN PROLOGUE SREADP -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (SREADP-S, DREADP-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C READ RECORD NUMBER IRECN, OF LENGTH LPG, FROM UNIT -C NUMBER IPAGEF INTO THE STORAGE ARRAY, LIST(*). -C READ RECORD IRECN+1, OF LENGTH LPG, FROM UNIT NUMBER -C IPAGEF INTO THE STORAGE ARRAY RLIST(*). -C -C TO CONVERT THIS PROGRAM UNIT TO DOUBLE PRECISION CHANGE -C /REAL (12 BLANKS)/ TO /DOUBLE PRECISION/. -C -C***SEE ALSO SPLP -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890605 Corrected references to XERRWV. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C***END PROLOGUE SREADP - INTEGER LIST(*) - REAL RLIST(*) - CHARACTER*8 XERN1, XERN2 -C***FIRST EXECUTABLE STATEMENT SREADP - IPAGEF=IPAGE - LPG =LPAGE - IRECN=IREC - READ(IPAGEF,REC=IRECN,ERR=100)(LIST(I),I=1,LPG) - READ(IPAGEF,REC=IRECN+1,ERR=100)(RLIST(I),I=1,LPG) - RETURN -C - 100 WRITE (XERN1, '(I8)') LPG - WRITE (XERN2, '(I8)') IRECN - CALL XERMSG ('SLATEC', 'SREADP', 'IN SPLP, LPG = ' // XERN1 // - * ' IRECN = ' // XERN2, 100, 1) - RETURN - END diff --git a/slatec/srlcal.f b/slatec/srlcal.f deleted file mode 100644 index f2b5983..0000000 --- a/slatec/srlcal.f +++ /dev/null @@ -1,115 +0,0 @@ -*DECK SRLCAL - SUBROUTINE SRLCAL (N, KMP, LL, MAXL, V, Q, RL, SNORMW, PROD, - + R0NRM) -C***BEGIN PROLOGUE SRLCAL -C***SUBSIDIARY -C***PURPOSE Internal routine for SGMRES. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (SRLCAL-S, DRLCAL-D) -C***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov -C Hindmarsh, Alan, (LLNL), alanh@llnl.gov -C Seager, Mark K., (LLNL), seager@llnl.gov -C Lawrence Livermore National Laboratory -C PO Box 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C***DESCRIPTION -C This routine calculates the scaled residual RL from the -C V(I)'s. -C *Usage: -C INTEGER N, KMP, LL, MAXL -C REAL V(N,LL), Q(2*MAXL), RL(N), SNORMW, PROD, R0NORM -C -C CALL SRLCAL(N, KMP, LL, MAXL, V, Q, RL, SNORMW, PROD, R0NRM) -C -C *Arguments: -C N :IN Integer -C The order of the matrix A, and the lengths -C of the vectors SR, SZ, R0 and Z. -C KMP :IN Integer -C The number of previous V vectors the new vector VNEW -C must be made orthogonal to. (KMP .le. MAXL) -C LL :IN Integer -C The current dimension of the Krylov subspace. -C MAXL :IN Integer -C The maximum dimension of the Krylov subspace. -C V :IN Real V(N,LL) -C The N x LL array containing the orthogonal vectors -C V(*,1) to V(*,LL). -C Q :IN Real Q(2*MAXL) -C A 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 SHEQR and used in SHELS. -C RL :OUT Real RL(N) -C The residual vector RL. This is either SB*(B-A*XL) if -C not preconditioning or preconditioning on the right, -C or SB*(M-inverse)*(B-A*XL) if preconditioning on the -C left. -C SNORMW :IN Real -C Scale factor. -C PROD :IN Real -C The product s1*s2*...*sl = the product of the sines of the -C Givens rotations used in the QR factorization of -C the Hessenberg matrix HES. -C R0NRM :IN Real -C The scaled norm of initial residual R0. -C -C***SEE ALSO SGMRES -C***ROUTINES CALLED SCOPY, SSCAL -C***REVISION HISTORY (YYMMDD) -C 871001 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910506 Made subsidiary to SGMRES. (FNF) -C 920511 Added complete declaration section. (WRB) -C***END PROLOGUE SRLCAL -C The following is for optimized compilation on LLNL/LTSS Crays. -CLLL. OPTIMIZE -C .. Scalar Arguments .. - REAL PROD, R0NRM, SNORMW - INTEGER KMP, LL, MAXL, N -C .. Array Arguments .. - REAL Q(*), RL(N), V(N,*) -C .. Local Scalars .. - REAL C, S, TEM - INTEGER I, I2, IP1, K, LLM1, LLP1 -C .. External Subroutines .. - EXTERNAL SCOPY, SSCAL -C***FIRST EXECUTABLE STATEMENT SRLCAL - IF (KMP .EQ. MAXL) THEN -C -C calculate RL. Start by copying V(*,1) into RL. -C - CALL SCOPY(N, V(1,1), 1, RL, 1) - LLM1 = LL - 1 - DO 20 I = 1,LLM1 - IP1 = I + 1 - I2 = I*2 - S = Q(I2) - C = Q(I2-1) - DO 10 K = 1,N - RL(K) = S*RL(K) + C*V(K,IP1) - 10 CONTINUE - 20 CONTINUE - S = Q(2*LL) - C = Q(2*LL-1)/SNORMW - LLP1 = LL + 1 - DO 30 K = 1,N - RL(K) = S*RL(K) + C*V(K,LLP1) - 30 CONTINUE - ENDIF -C -C When KMP < MAXL, RL vector already partially calculated. -C Scale RL by R0NRM*PROD to obtain the residual RL. -C - TEM = R0NRM*PROD - CALL SSCAL(N, TEM, RL, 1) - RETURN -C------------- LAST LINE OF SRLCAL FOLLOWS ---------------------------- - END diff --git a/slatec/srot.f b/slatec/srot.f deleted file mode 100644 index 184889c..0000000 --- a/slatec/srot.f +++ /dev/null @@ -1,89 +0,0 @@ -*DECK SROT - SUBROUTINE SROT (N, SX, INCX, SY, INCY, SC, SS) -C***BEGIN PROLOGUE SROT -C***PURPOSE Apply a plane Givens rotation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A8 -C***TYPE SINGLE PRECISION (SROT-S, DROT-D, CSROT-C) -C***KEYWORDS BLAS, GIVENS ROTATION, GIVENS TRANSFORMATION, -C LINEAR ALGEBRA, PLANE ROTATION, 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 SC element of rotation matrix -C SS element of rotation matrix -C -C --Output-- -C SX rotated vector SX (unchanged if N .LE. 0) -C SY rotated vector SY (unchanged if N .LE. 0) -C -C Multiply the 2 x 2 matrix ( SC SS) times the 2 x N matrix (SX**T) -C (-SS SC) (SY**T) -C where **T indicates transpose. The elements of SX are in -C SX(LX+I*INCX), I = 0 to N-1, where LX = 1 if INCX .GE. 0, else -C LX = 1+(1-N)*INCX, and similarly for SY using LY and 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 861211 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 SROT - REAL SX, SY, SC, SS, ZERO, ONE, W, Z - DIMENSION SX(*), SY(*) - SAVE ZERO, ONE - DATA ZERO, ONE /0.0E0, 1.0E0/ -C***FIRST EXECUTABLE STATEMENT SROT - IF (N .LE. 0 .OR. (SS .EQ. ZERO .AND. SC .EQ. ONE)) GO TO 40 - IF (.NOT. (INCX .EQ. INCY .AND. INCX .GT. 0)) GO TO 20 -C -C Code for equal and positive increments. -C - NSTEPS=INCX*N - DO 10 I = 1,NSTEPS,INCX - W=SX(I) - Z=SY(I) - SX(I)=SC*W+SS*Z - SY(I)=-SS*W+SC*Z - 10 CONTINUE - GO TO 40 -C -C Code for unequal or nonpositive increments. -C - 20 CONTINUE - KX=1 - KY=1 -C - IF (INCX .LT. 0) KX = 1-(N-1)*INCX - IF (INCY .LT. 0) KY = 1-(N-1)*INCY -C - DO 30 I = 1,N - W=SX(KX) - Z=SY(KY) - SX(KX)=SC*W+SS*Z - SY(KY)=-SS*W+SC*Z - KX=KX+INCX - KY=KY+INCY - 30 CONTINUE - 40 CONTINUE -C - RETURN - END diff --git a/slatec/srotg.f b/slatec/srotg.f deleted file mode 100644 index 3dc4d9d..0000000 --- a/slatec/srotg.f +++ /dev/null @@ -1,106 +0,0 @@ -*DECK SROTG - SUBROUTINE SROTG (SA, SB, SC, SS) -C***BEGIN PROLOGUE SROTG -C***PURPOSE Construct a plane Givens rotation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B10 -C***TYPE SINGLE PRECISION (SROTG-S, DROTG-D, CROTG-C) -C***KEYWORDS BLAS, GIVENS ROTATION, GIVENS TRANSFORMATION, -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 SA single precision scalar -C SB single precision scalar -C -C --Output-- -C SA single precision result R -C SB single precision result Z -C SC single precision result -C SS single precision result -C -C Construct the Givens transformation -C -C ( SC SS ) -C G = ( ) , SC**2 + SS**2 = 1 , -C (-SS SC ) -C -C which zeros the second entry of the 2-vector (SA,SB)**T. -C -C The quantity R = (+/-)SQRT(SA**2 + SB**2) overwrites SA in -C storage. The value of SB is overwritten by a value Z which -C allows SC and SS to be recovered by the following algorithm: -C -C If Z=1 set SC=0.0 and SS=1.0 -C If ABS(Z) .LT. 1 set SC=SQRT(1-Z**2) and SS=Z -C If ABS(Z) .GT. 1 set SC=1/Z and SS=SQRT(1-SC**2) -C -C Normally, the subprogram SROT(N,SX,INCX,SY,INCY,SC,SS) will -C next be called to apply the transformation to a 2 by N matrix. -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 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 SROTG -C***FIRST EXECUTABLE STATEMENT SROTG - IF (ABS(SA) .LE. ABS(SB)) GO TO 10 -C -C *** HERE ABS(SA) .GT. ABS(SB) *** -C - U = SA + SA - V = SB / U -C -C NOTE THAT U AND R HAVE THE SIGN OF SA -C - R = SQRT(0.25E0 + V**2) * U -C -C NOTE THAT SC IS POSITIVE -C - SC = SA / R - SS = V * (SC + SC) - SB = SS - SA = R - RETURN -C -C *** HERE ABS(SA) .LE. ABS(SB) *** -C - 10 IF (SB .EQ. 0.0E0) GO TO 20 - U = SB + SB - V = SA / U -C -C NOTE THAT U AND R HAVE THE SIGN OF SB -C (R IS IMMEDIATELY STORED IN SA) -C - SA = SQRT(0.25E0 + V**2) * U -C -C NOTE THAT SS IS POSITIVE -C - SS = SB / SA - SC = V * (SS + SS) - IF (SC .EQ. 0.0E0) GO TO 15 - SB = 1.0E0 / SC - RETURN - 15 SB = 1.0E0 - RETURN -C -C *** HERE SA = SB = 0.0 *** -C - 20 SC = 1.0E0 - SS = 0.0E0 - RETURN -C - END diff --git a/slatec/srotm.f b/slatec/srotm.f deleted file mode 100644 index 544b4bc..0000000 --- a/slatec/srotm.f +++ /dev/null @@ -1,148 +0,0 @@ -*DECK SROTM - SUBROUTINE SROTM (N, SX, INCX, SY, INCY, SPARAM) -C***BEGIN PROLOGUE SROTM -C***PURPOSE Apply a modified Givens transformation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A8 -C***TYPE SINGLE PRECISION (SROTM-S, DROTM-D) -C***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, 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 SPARAM 5-element vector. SPARAM(1) is SFLAG described below. -C Locations 2-5 of SPARAM contain elements of the -C transformation matrix H described below. -C -C --Output-- -C SX rotated vector (unchanged if N .LE. 0) -C SY rotated vector (unchanged if N .LE. 0) -C -C Apply the modified Givens transformation, H, to the 2 by N matrix -C (SX**T) -C (SY**T) , where **T indicates transpose. The elements of SX are -C in SX(LX+I*INCX), I = 0 to N-1, where LX = 1 if INCX .GE. 0, else -C LX = 1+(1-N)*INCX, and similarly for SY using LY and INCY. -C -C With SPARAM(1)=SFLAG, H has one of the following forms: -C -C SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 -C -C (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) -C H=( ) ( ) ( ) ( ) -C (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). -C -C See SROTMG for a description of data storage in SPARAM. -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 861211 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 SROTM - DIMENSION SX(*), SY(*), SPARAM(5) - SAVE ZERO, TWO - DATA ZERO, TWO /0.0E0, 2.0E0/ -C***FIRST EXECUTABLE STATEMENT SROTM - SFLAG=SPARAM(1) - IF (N.LE.0 .OR. (SFLAG+TWO.EQ.ZERO)) GO TO 140 - IF (.NOT.(INCX.EQ.INCY.AND. INCX .GT.0)) GO TO 70 -C - NSTEPS=N*INCX - IF (SFLAG) 50,10,30 - 10 CONTINUE - SH12=SPARAM(4) - SH21=SPARAM(3) - DO 20 I = 1,NSTEPS,INCX - W=SX(I) - Z=SY(I) - SX(I)=W+Z*SH12 - SY(I)=W*SH21+Z - 20 CONTINUE - GO TO 140 - 30 CONTINUE - SH11=SPARAM(2) - SH22=SPARAM(5) - DO 40 I = 1,NSTEPS,INCX - W=SX(I) - Z=SY(I) - SX(I)=W*SH11+Z - SY(I)=-W+SH22*Z - 40 CONTINUE - GO TO 140 - 50 CONTINUE - SH11=SPARAM(2) - SH12=SPARAM(4) - SH21=SPARAM(3) - SH22=SPARAM(5) - DO 60 I = 1,NSTEPS,INCX - W=SX(I) - Z=SY(I) - SX(I)=W*SH11+Z*SH12 - SY(I)=W*SH21+Z*SH22 - 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 (SFLAG) 120,80,100 - 80 CONTINUE - SH12=SPARAM(4) - SH21=SPARAM(3) - DO 90 I = 1,N - W=SX(KX) - Z=SY(KY) - SX(KX)=W+Z*SH12 - SY(KY)=W*SH21+Z - KX=KX+INCX - KY=KY+INCY - 90 CONTINUE - GO TO 140 - 100 CONTINUE - SH11=SPARAM(2) - SH22=SPARAM(5) - DO 110 I = 1,N - W=SX(KX) - Z=SY(KY) - SX(KX)=W*SH11+Z - SY(KY)=-W+SH22*Z - KX=KX+INCX - KY=KY+INCY - 110 CONTINUE - GO TO 140 - 120 CONTINUE - SH11=SPARAM(2) - SH12=SPARAM(4) - SH21=SPARAM(3) - SH22=SPARAM(5) - DO 130 I = 1,N - W=SX(KX) - Z=SY(KY) - SX(KX)=W*SH11+Z*SH12 - SY(KY)=W*SH21+Z*SH22 - KX=KX+INCX - KY=KY+INCY - 130 CONTINUE - 140 CONTINUE - RETURN - END diff --git a/slatec/srotmg.f b/slatec/srotmg.f deleted file mode 100644 index cc964fe..0000000 --- a/slatec/srotmg.f +++ /dev/null @@ -1,205 +0,0 @@ -*DECK SROTMG - SUBROUTINE SROTMG (SD1, SD2, SX1, SY1, SPARAM) -C***BEGIN PROLOGUE SROTMG -C***PURPOSE Construct a modified Givens transformation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B10 -C***TYPE SINGLE PRECISION (SROTMG-S, DROTMG-D) -C***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, 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 SD1 single precision scalar -C SD2 single precision scalar -C SX1 single precision scalar -C SY2 single precision scalar -C SPARAM S.P. 5-vector. SPARAM(1)=SFLAG defined below. -C Locations 2-5 contain the rotation matrix. -C -C --Output-- -C SD1 changed to represent the effect of the transformation -C SD2 changed to represent the effect of the transformation -C SX1 changed to represent the effect of the transformation -C SY2 unchanged -C -C Construct the modified Givens transformation matrix H which zeros -C the second component of the 2-vector (SQRT(SD1)*SX1,SQRT(SD2)* -C SY2)**T. -C With SPARAM(1)=SFLAG, H has one of the following forms: -C -C SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 -C -C (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) -C H=( ) ( ) ( ) ( ) -C (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). -C -C Locations 2-5 of SPARAM contain SH11, SH21, SH12, and SH22, -C respectively. (Values of 1.E0, -1.E0, or 0.E0 implied by the -C value of SPARAM(1) are not stored in SPARAM.) -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 780301 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920316 Prologue corrected. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SROTMG - DIMENSION SPARAM(5) - SAVE ZERO, ONE, TWO, GAM, GAMSQ, RGAMSQ - DATA ZERO, ONE, TWO /0.0E0, 1.0E0, 2.0E0/ - DATA GAM, GAMSQ, RGAMSQ /4096.0E0, 1.67772E7, 5.96046E-8/ -C***FIRST EXECUTABLE STATEMENT SROTMG - IF (.NOT. SD1 .LT. ZERO) GO TO 10 -C GO ZERO-H-D-AND-SX1.. - GO TO 60 - 10 CONTINUE -C CASE-SD1-NONNEGATIVE - SP2=SD2*SY1 - IF (.NOT. SP2 .EQ. ZERO) GO TO 20 - SFLAG=-TWO - GO TO 260 -C REGULAR-CASE.. - 20 CONTINUE - SP1=SD1*SX1 - SQ2=SP2*SY1 - SQ1=SP1*SX1 -C - IF (.NOT. ABS(SQ1) .GT. ABS(SQ2)) GO TO 40 - SH21=-SY1/SX1 - SH12=SP2/SP1 -C - SU=ONE-SH12*SH21 -C - IF (.NOT. SU .LE. ZERO) GO TO 30 -C GO ZERO-H-D-AND-SX1.. - GO TO 60 - 30 CONTINUE - SFLAG=ZERO - SD1=SD1/SU - SD2=SD2/SU - SX1=SX1*SU -C GO SCALE-CHECK.. - GO TO 100 - 40 CONTINUE - IF (.NOT. SQ2 .LT. ZERO) GO TO 50 -C GO ZERO-H-D-AND-SX1.. - GO TO 60 - 50 CONTINUE - SFLAG=ONE - SH11=SP1/SP2 - SH22=SX1/SY1 - SU=ONE+SH11*SH22 - STEMP=SD2/SU - SD2=SD1/SU - SD1=STEMP - SX1=SY1*SU -C GO SCALE-CHECK - GO TO 100 -C PROCEDURE..ZERO-H-D-AND-SX1.. - 60 CONTINUE - SFLAG=-ONE - SH11=ZERO - SH12=ZERO - SH21=ZERO - SH22=ZERO -C - SD1=ZERO - SD2=ZERO - SX1=ZERO -C RETURN.. - GO TO 220 -C PROCEDURE..FIX-H.. - 70 CONTINUE - IF (.NOT. SFLAG .GE. ZERO) GO TO 90 -C - IF (.NOT. SFLAG .EQ. ZERO) GO TO 80 - SH11=ONE - SH22=ONE - SFLAG=-ONE - GO TO 90 - 80 CONTINUE - SH21=-ONE - SH12=ONE - SFLAG=-ONE - 90 CONTINUE - GO TO IGO,(120,150,180,210) -C PROCEDURE..SCALE-CHECK - 100 CONTINUE - 110 CONTINUE - IF (.NOT. SD1 .LE. RGAMSQ) GO TO 130 - IF (SD1 .EQ. ZERO) GO TO 160 - ASSIGN 120 TO IGO -C FIX-H.. - GO TO 70 - 120 CONTINUE - SD1=SD1*GAM**2 - SX1=SX1/GAM - SH11=SH11/GAM - SH12=SH12/GAM - GO TO 110 - 130 CONTINUE - 140 CONTINUE - IF (.NOT. SD1 .GE. GAMSQ) GO TO 160 - ASSIGN 150 TO IGO -C FIX-H.. - GO TO 70 - 150 CONTINUE - SD1=SD1/GAM**2 - SX1=SX1*GAM - SH11=SH11*GAM - SH12=SH12*GAM - GO TO 140 - 160 CONTINUE - 170 CONTINUE - IF (.NOT. ABS(SD2) .LE. RGAMSQ) GO TO 190 - IF (SD2 .EQ. ZERO) GO TO 220 - ASSIGN 180 TO IGO -C FIX-H.. - GO TO 70 - 180 CONTINUE - SD2=SD2*GAM**2 - SH21=SH21/GAM - SH22=SH22/GAM - GO TO 170 - 190 CONTINUE - 200 CONTINUE - IF (.NOT. ABS(SD2) .GE. GAMSQ) GO TO 220 - ASSIGN 210 TO IGO -C FIX-H.. - GO TO 70 - 210 CONTINUE - SD2=SD2/GAM**2 - SH21=SH21*GAM - SH22=SH22*GAM - GO TO 200 - 220 CONTINUE - IF (SFLAG) 250,230,240 - 230 CONTINUE - SPARAM(3)=SH21 - SPARAM(4)=SH12 - GO TO 260 - 240 CONTINUE - SPARAM(2)=SH11 - SPARAM(5)=SH22 - GO TO 260 - 250 CONTINUE - SPARAM(2)=SH11 - SPARAM(3)=SH21 - SPARAM(4)=SH12 - SPARAM(5)=SH22 - 260 CONTINUE - SPARAM(1)=SFLAG - RETURN - END diff --git a/slatec/ss2lt.f b/slatec/ss2lt.f deleted file mode 100644 index 7f361da..0000000 --- a/slatec/ss2lt.f +++ /dev/null @@ -1,138 +0,0 @@ -*DECK SS2LT - SUBROUTINE SS2LT (N, NELT, IA, JA, A, ISYM, NEL, IEL, JEL, EL) -C***BEGIN PROLOGUE SS2LT -C***PURPOSE Lower Triangle Preconditioner SLAP Set Up. -C Routine to store the lower triangle of a matrix stored -C in the SLAP Column format. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE SINGLE PRECISION (SS2LT-S, DS2LT-D) -C***KEYWORDS LINEAR SYSTEM, LOWER TRIANGLE, SLAP SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM -C INTEGER NEL, IEL(NEL), JEL(NEL) -C REAL A(NELT), EL(NEL) -C -C CALL SS2LT( N, NELT, IA, JA, A, ISYM, NEL, IEL, JEL, EL ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C NELT :IN Integer. -C Number of non-zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Real A(NELT). -C These arrays should hold the matrix A in the SLAP Column -C format. See "Description", below. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the lower -C triangle of the matrix is stored. -C NEL :OUT Integer. -C Number of non-zeros in the lower triangle of A. Also -C corresponds to the length of the IEL, JEL, EL arrays. -C IEL :OUT Integer IEL(NEL). -C JEL :OUT Integer JEL(NEL). -C EL :OUT Real EL(NEL). -C IEL, JEL, EL contain the lower triangle of the A matrix -C stored in SLAP Column format. See "Description", below, -C for more details bout the SLAP Column format. -C -C *Description -C =================== S L A P Column format ================== -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE SS2LT -C .. Scalar Arguments .. - INTEGER ISYM, N, NEL, NELT -C .. Array Arguments .. - REAL A(NELT), EL(NELT) - INTEGER IA(NELT), IEL(NEL), JA(NELT), JEL(NEL) -C .. Local Scalars .. - INTEGER I, ICOL, J, JBGN, JEND -C***FIRST EXECUTABLE STATEMENT SS2LT - IF( ISYM.EQ.0 ) THEN -C -C The matrix is stored non-symmetricly. Pick out the lower -C triangle. -C - NEL = 0 - DO 20 ICOL = 1, N - JEL(ICOL) = NEL+1 - JBGN = JA(ICOL) - JEND = JA(ICOL+1)-1 -CVD$ NOVECTOR - DO 10 J = JBGN, JEND - IF( IA(J).GE.ICOL ) THEN - NEL = NEL + 1 - IEL(NEL) = IA(J) - EL(NEL) = A(J) - ENDIF - 10 CONTINUE - 20 CONTINUE - JEL(N+1) = NEL+1 - ELSE -C -C The matrix is symmetric and only the lower triangle is -C stored. Copy it to IEL, JEL, EL. -C - NEL = NELT - DO 30 I = 1, NELT - IEL(I) = IA(I) - EL(I) = A(I) - 30 CONTINUE - DO 40 I = 1, N+1 - JEL(I) = JA(I) - 40 CONTINUE - ENDIF - RETURN -C------------- LAST LINE OF SS2LT FOLLOWS ---------------------------- - END diff --git a/slatec/ss2y.f b/slatec/ss2y.f deleted file mode 100644 index 654e021..0000000 --- a/slatec/ss2y.f +++ /dev/null @@ -1,208 +0,0 @@ -*DECK SS2Y - SUBROUTINE SS2Y (N, NELT, IA, JA, A, ISYM) -C***BEGIN PROLOGUE SS2Y -C***PURPOSE SLAP Triad to SLAP Column Format Converter. -C Routine to convert from the SLAP Triad to SLAP Column -C format. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D1B9 -C***TYPE SINGLE PRECISION (SS2Y-S, DS2Y-D) -C***KEYWORDS LINEAR SYSTEM, SLAP SPARSE -C***AUTHOR Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM -C REAL A(NELT) -C -C CALL SS2Y( N, NELT, IA, JA, A, ISYM ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C NELT :IN Integer. -C Number of non-zeros stored in A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Real A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is used, this format is -C translated to the SLAP Column format by this routine. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the lower -C triangle of the matrix is stored. -C -C *Description: -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures. If the SLAP Triad format is give -C as input then this routine transforms it into SLAP Column -C format. The way this routine tells which format is given as -C input is to look at JA(N+1). If JA(N+1) = NELT+1 then we -C have the SLAP Column format. If that equality does not hold -C then it is assumed that the IA, JA, A arrays contain the -C SLAP Triad format. -C -C =================== S L A P Triad format =================== -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C***REFERENCES (NONE) -C***ROUTINES CALLED QS2I1R -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Corrected C***FIRST EXECUTABLE STATEMENT line. (FNF) -C 920511 Added complete declaration section. (WRB) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE SS2Y -C .. Scalar Arguments .. - INTEGER ISYM, N, NELT -C .. Array Arguments .. - REAL A(NELT) - INTEGER IA(NELT), JA(NELT) -C .. Local Scalars .. - REAL TEMP - INTEGER I, IBGN, ICOL, IEND, ITEMP, J -C .. External Subroutines .. - EXTERNAL QS2I1R -C***FIRST EXECUTABLE STATEMENT SS2Y -C -C Check to see if the (IA,JA,A) arrays are in SLAP Column -C format. If it's not then transform from SLAP Triad. -C - IF( JA(N+1).EQ.NELT+1 ) RETURN -C -C Sort into ascending order by COLUMN (on the ja array). -C This will line up the columns. -C - CALL QS2I1R( JA, IA, A, NELT, 1 ) -C -C Loop over each column to see where the column indices change -C in the column index array ja. This marks the beginning of the -C next column. -C -CVD$R NOVECTOR - JA(1) = 1 - DO 20 ICOL = 1, N-1 - DO 10 J = JA(ICOL)+1, NELT - IF( JA(J).NE.ICOL ) THEN - JA(ICOL+1) = J - GOTO 20 - ENDIF - 10 CONTINUE - 20 CONTINUE - JA(N+1) = NELT+1 -C -C Mark the n+2 element so that future calls to a SLAP routine -C utilizing the YSMP-Column storage format will be able to tell. -C - JA(N+2) = 0 -C -C Now loop through the IA array making sure that the diagonal -C matrix element appears first in the column. Then sort the -C rest of the column in ascending order. -C - DO 70 ICOL = 1, N - IBGN = JA(ICOL) - IEND = JA(ICOL+1)-1 - DO 30 I = IBGN, IEND - IF( IA(I).EQ.ICOL ) THEN -C -C Swap the diagonal element with the first element in the -C column. -C - ITEMP = IA(I) - IA(I) = IA(IBGN) - IA(IBGN) = ITEMP - TEMP = A(I) - A(I) = A(IBGN) - A(IBGN) = TEMP - GOTO 40 - ENDIF - 30 CONTINUE - 40 IBGN = IBGN + 1 - IF( IBGN.LT.IEND ) THEN - DO 60 I = IBGN, IEND - DO 50 J = I+1, IEND - IF( IA(I).GT.IA(J) ) THEN - ITEMP = IA(I) - IA(I) = IA(J) - IA(J) = ITEMP - TEMP = A(I) - A(I) = A(J) - A(J) = TEMP - ENDIF - 50 CONTINUE - 60 CONTINUE - ENDIF - 70 CONTINUE - RETURN -C------------- LAST LINE OF SS2Y FOLLOWS ---------------------------- - END diff --git a/slatec/ssbmv.f b/slatec/ssbmv.f deleted file mode 100644 index ab7af5a..0000000 --- a/slatec/ssbmv.f +++ /dev/null @@ -1,310 +0,0 @@ -*DECK SSBMV - SUBROUTINE SSBMV (UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, - $ INCY) -C***BEGIN PROLOGUE SSBMV -C***PURPOSE Multiply a real vector by a real symmetric band matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE SINGLE PRECISION (SSBMV-S, DSBMV-D, CSBMV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C SSBMV performs the matrix-vector operation -C -C y := alpha*A*x + beta*y, -C -C where alpha and beta are scalars, x and y are n element vectors and -C A is an n by n symmetric band matrix, with k super-diagonals. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the band matrix A is being supplied as -C follows: -C -C UPLO = 'U' or 'u' The upper triangular part of A is -C being supplied. -C -C UPLO = 'L' or 'l' The lower triangular part of A is -C being supplied. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C K - INTEGER. -C On entry, K specifies the number of super-diagonals of the -C matrix A. K must satisfy 0 .le. K. -C Unchanged on exit. -C -C ALPHA - REAL . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C A - REAL array of DIMENSION ( LDA, n ). -C Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -C by n part of the array A must contain the upper triangular -C band part of the symmetric matrix, supplied column by -C column, with the leading diagonal of the matrix in row -C ( k + 1 ) of the array, the first super-diagonal starting at -C position 2 in row k, and so on. The top left k by k triangle -C of the array A is not referenced. -C The following program segment will transfer the upper -C triangular part of a symmetric band matrix from conventional -C full matrix storage to band storage: -C -C DO 20, J = 1, N -C M = K + 1 - J -C DO 10, I = MAX( 1, J - K ), J -C A( M + I, J ) = matrix( I, J ) -C 10 CONTINUE -C 20 CONTINUE -C -C Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -C by n part of the array A must contain the lower triangular -C band part of the symmetric matrix, supplied column by -C column, with the leading diagonal of the matrix in row 1 of -C the array, the first sub-diagonal starting at position 1 in -C row 2, and so on. The bottom right k by k triangle of the -C array A is not referenced. -C The following program segment will transfer the lower -C triangular part of a symmetric band matrix from conventional -C full matrix storage to band storage: -C -C DO 20, J = 1, N -C M = 1 - J -C DO 10, I = J, MIN( N, J + K ) -C A( M + I, J ) = matrix( I, J ) -C 10 CONTINUE -C 20 CONTINUE -C -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C ( k + 1 ). -C Unchanged on exit. -C -C X - REAL array of DIMENSION at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the -C vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C BETA - REAL . -C On entry, BETA specifies the scalar beta. -C Unchanged on exit. -C -C Y - REAL array of DIMENSION at least -C ( 1 + ( n - 1 )*abs( INCY ) ). -C Before entry, the incremented array Y must contain the -C vector y. On exit, Y is overwritten by the updated vector y. -C -C INCY - INTEGER. -C On entry, INCY specifies the increment for the elements of -C Y. INCY must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE SSBMV -C .. Scalar Arguments .. - REAL ALPHA, BETA - INTEGER INCX, INCY, K, LDA, N - CHARACTER*1 UPLO -C .. Array Arguments .. - REAL A( LDA, * ), X( * ), Y( * ) -C .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -C .. Local Scalars .. - REAL TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C***FIRST EXECUTABLE STATEMENT SSBMV -C -C Test the input parameters. -C - 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( 'SSBMV ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C Set up the start points in X and Y. -C - 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 -C -C Start the operations. In this version the elements of the array A -C are accessed sequentially with one pass through A. -C -C First form y := beta*y. -C - 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 -C -C Form y when upper triangle of A is stored. -C - 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 -C -C Form y when lower triangle of A is stored. -C - 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 -C - RETURN -C -C End of SSBMV . -C - END diff --git a/slatec/sscal.f b/slatec/sscal.f deleted file mode 100644 index 2ad12c0..0000000 --- a/slatec/sscal.f +++ /dev/null @@ -1,80 +0,0 @@ -*DECK SSCAL - SUBROUTINE SSCAL (N, SA, SX, INCX) -C***BEGIN PROLOGUE SSCAL -C***PURPOSE Multiply a vector by a constant. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A6 -C***TYPE SINGLE PRECISION (SSCAL-S, DSCAL-D, CSCAL-C) -C***KEYWORDS BLAS, LINEAR ALGEBRA, SCALE, 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 SA single precision scale factor -C SX single precision vector with N elements -C INCX storage spacing between elements of SX -C -C --Output-- -C SX single precision result (unchanged if N .LE. 0) -C -C Replace single precision SX by single precision SA*SX. -C For I = 0 to N-1, replace SX(IX+I*INCX) with SA * SX(IX+I*INCX), -C where IX = 1 if INCX .GE. 0, else IX = 1+(1-N)*INCX. -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 900821 Modified to correct problem with a negative increment. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SSCAL - REAL SA, SX(*) - INTEGER I, INCX, IX, M, MP1, N -C***FIRST EXECUTABLE STATEMENT SSCAL - IF (N .LE. 0) RETURN - IF (INCX .EQ. 1) GOTO 20 -C -C Code for increment not equal to 1. -C - IX = 1 - IF (INCX .LT. 0) IX = (-N+1)*INCX + 1 - DO 10 I = 1,N - SX(IX) = SA*SX(IX) - IX = IX + INCX - 10 CONTINUE - RETURN -C -C Code for increment equal to 1. -C -C Clean-up loop so remaining vector length is a multiple of 5. -C - 20 M = MOD(N,5) - IF (M .EQ. 0) GOTO 40 - DO 30 I = 1,M - SX(I) = SA*SX(I) - 30 CONTINUE - IF (N .LT. 5) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,5 - SX(I) = SA*SX(I) - SX(I+1) = SA*SX(I+1) - SX(I+2) = SA*SX(I+2) - SX(I+3) = SA*SX(I+3) - SX(I+4) = SA*SX(I+4) - 50 CONTINUE - RETURN - END diff --git a/slatec/ssd2s.f b/slatec/ssd2s.f deleted file mode 100644 index 2f006c1..0000000 --- a/slatec/ssd2s.f +++ /dev/null @@ -1,150 +0,0 @@ -*DECK SSD2S - SUBROUTINE SSD2S (N, NELT, IA, JA, A, ISYM, DINV) -C***BEGIN PROLOGUE SSD2S -C***PURPOSE Diagonal Scaling Preconditioner SLAP Normal Eqns Set Up. -C Routine to compute the inverse of the diagonal of the -C matrix A*A', where A is stored in SLAP-Column format. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE SINGLE PRECISION (SSD2S-S, DSD2S-D) -C***KEYWORDS DIAGONAL, SLAP SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM -C REAL A(NELT), DINV(N) -C -C CALL SSD2S( N, NELT, IA, JA, A, ISYM, DINV ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C NELT :IN Integer. -C Number of elements in arrays IA, JA, and A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Real A(NELT). -C These arrays should hold the matrix A in the SLAP Column -C format. See "Description", below. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C DINV :OUT Real DINV(N). -C Upon return this array holds 1./DIAG(A*A'). -C -C *Description -C =================== S L A P Column format ================== -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C With the SLAP format all of the "inner loops" of this -C routine should vectorize on machines with hardware support -C for vector gather/scatter operations. Your compiler may -C require a compiler directive to convince it that there are -C no implicit vector dependencies. Compiler directives for -C the Alliant FX/Fortran and CRI CFT/CFT77 compilers are -C supplied with the standard SLAP distribution. -C -C -C *Cautions: -C This routine assumes that the diagonal of A is all non-zero -C and that the operation DINV = 1.0/DIAG(A*A') will not under- -C flow or overflow. This is done so that the loop vectorizes. -C Matrices with zero or near zero or very large entries will -C have numerical difficulties and must be fixed before this -C routine is called. -C -C***SEE ALSO SSDCGN -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE SSD2S -C .. Scalar Arguments .. - INTEGER ISYM, N, NELT -C .. Array Arguments .. - REAL A(NELT), DINV(N) - INTEGER IA(NELT), JA(NELT) -C .. Local Scalars .. - INTEGER I, K, KBGN, KEND -C***FIRST EXECUTABLE STATEMENT SSD2S - DO 10 I = 1, N - DINV(I) = 0 - 10 CONTINUE -C -C Loop over each column. -CVD$R NOCONCUR - DO 40 I = 1, N - KBGN = JA(I) - KEND = JA(I+1) - 1 -C -C Add in the contributions for each row that has a non-zero -C in this column. -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ NODEPCHK - DO 20 K = KBGN, KEND - DINV(IA(K)) = DINV(IA(K)) + A(K)**2 - 20 CONTINUE - IF( ISYM.EQ.1 ) THEN -C -C Lower triangle stored by columns => upper triangle stored by -C rows with Diagonal being the first entry. Loop across the -C rest of the row. - KBGN = KBGN + 1 - IF( KBGN.LE.KEND ) THEN - DO 30 K = KBGN, KEND - DINV(I) = DINV(I) + A(K)**2 - 30 CONTINUE - ENDIF - ENDIF - 40 CONTINUE - DO 50 I=1,N - DINV(I) = 1.0E0/DINV(I) - 50 CONTINUE -C - RETURN -C------------- LAST LINE OF SSD2S FOLLOWS ---------------------------- - END diff --git a/slatec/ssdbcg.f b/slatec/ssdbcg.f deleted file mode 100644 index 2fc84d3..0000000 --- a/slatec/ssdbcg.f +++ /dev/null @@ -1,270 +0,0 @@ -*DECK SSDBCG - SUBROUTINE SSDBCG (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, - + ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE SSDBCG -C***PURPOSE Diagonally Scaled BiConjugate Gradient Sparse Ax=b Solver. -C Routine to solve a linear system Ax = b using the -C BiConjugate Gradient method with diagonal scaling. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (SSDBCG-S, DSDBCG-D) -C***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, SLAP, -C SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LENW, IWORK(10), LENIW -C REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(8*N) -C -C CALL SSDBCG(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Real B(N). -C Right-hand side vector. -C X :INOUT Real X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Real A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /SSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Real. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Real. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*R1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Real RWORK(LENW). -C Real array used for workspace. -C LENW :IN Integer. -C Length of the real workspace, RWORK. LENW >= 8*N. -C IWORK :WORK Integer IWORK(LENIW). -C Used to hold pointers into the RWORK array. -C LENIW :IN Integer. -C Length of the integer workspace, IWORK. LENIW >= 10. -C Upon return the following locations of IWORK hold information -C which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Real workspace actually used. -C -C *Description: -C This routine performs preconditioned BiConjugate gradient -C method on the Non-Symmetric positive definite linear system -C Ax=b. The preconditioner is M = DIAG(A), the diagonal of the -C matrix A. This is the simplest of preconditioners and -C vectorizes very well. -C -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to -C be the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO SBCG, SLUBCG -C***REFERENCES (NONE) -C***ROUTINES CALLED SBCG, SCHKW, SS2Y, SSDI, SSDS, SSMTV, SSMV -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE SSDBCG -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - REAL ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT -C .. Array Arguments .. - REAL A(N), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER LOCDIN, LOCDZ, LOCIW, LOCP, LOCPP, LOCR, LOCRR, LOCW, - + LOCZ, LOCZZ -C .. External Subroutines .. - EXTERNAL SBCG, SCHKW, SS2Y, SSDI, SSDS, SSMTV, SSMV -C***FIRST EXECUTABLE STATEMENT SSDBCG -C - IERR = 0 - IF( N.LT.1 .OR. NELT.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Change the SLAP input matrix IA, JA, A to SLAP-Column format. - CALL SS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Set up the workspace. - LOCIW = LOCIB -C - LOCDIN = LOCRB - LOCR = LOCDIN + N - LOCZ = LOCR + N - LOCP = LOCZ + N - LOCRR = LOCP + N - LOCZZ = LOCRR + N - LOCPP = LOCZZ + N - LOCDZ = LOCPP + N - LOCW = LOCDZ + N -C -C Check the workspace allocations. - CALL SCHKW( 'SSDBCG', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(4) = LOCDIN - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Compute the inverse of the diagonal of the matrix. - CALL SSDS(N, NELT, IA, JA, A, ISYM, RWORK(LOCDIN)) -C -C Perform the Diagonally Scaled BiConjugate gradient algorithm. - CALL SBCG(N, B, X, NELT, IA, JA, A, ISYM, SSMV, SSMTV, - $ SSDI, SSDI, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, - $ RWORK(LOCR), RWORK(LOCZ), RWORK(LOCP), - $ RWORK(LOCRR), RWORK(LOCZZ), RWORK(LOCPP), - $ RWORK(LOCDZ), RWORK(1), IWORK(1)) - RETURN -C------------- LAST LINE OF SSDBCG FOLLOWS ---------------------------- - END diff --git a/slatec/ssdcg.f b/slatec/ssdcg.f deleted file mode 100644 index f3ab88e..0000000 --- a/slatec/ssdcg.f +++ /dev/null @@ -1,276 +0,0 @@ -*DECK SSDCG - SUBROUTINE SSDCG (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, - + ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE SSDCG -C***PURPOSE Diagonally Scaled Conjugate Gradient Sparse Ax=b Solver. -C Routine to solve a symmetric positive definite linear -C system Ax = b using the Preconditioned Conjugate -C Gradient method. The preconditioner is diagonal scaling. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2B4 -C***TYPE SINGLE PRECISION (SSDCG-S, DSDCG-D) -C***KEYWORDS ITERATIVE PRECONDITION, SLAP, SPARSE, -C SYMMETRIC LINEAR SYSTEM -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LENW, IWORK(10), LENIW -C REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(5*N) -C -C CALL SSDCG(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Real B(N). -C Right-hand side vector. -C X :INOUT Real X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Real A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /SSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Real. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Real. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*R1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Real RWORK(LENW). -C Real array used for workspace. -C LENW :IN Integer. -C Length of the real workspace, RWORK. LENW >= 5*N. -C IWORK :WORK Integer IWORK(LENIW). -C Used to hold pointers into the real workspace, RWORK. -C Upon return the following locations of IWORK hold information -C which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Real workspace actually used. -C LENIW :IN Integer. -C Length of the integer workspace, IWORK. LENIW >= 10. -C -C *Description: -C This routine performs preconditioned conjugate gradient -C method on the symmetric positive definite linear system -C Ax=b. The preconditioner is M = DIAG(A), the diagonal of -C the matrix A. This is the simplest of preconditioners and -C vectorizes very well. This routine is simply a driver for -C the SCG routine. It calls the SSDS routine to set up the -C preconditioning and then calls SCG with the appropriate -C MATVEC and MSOLVE routines. -C -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to -C be the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO SCG, SSICCG -C***REFERENCES 1. Louis Hageman and David Young, Applied Iterative -C Methods, Academic Press, New York, 1981. -C 2. Concus, Golub and O'Leary, A Generalized Conjugate -C Gradient Method for the Numerical Solution of -C Elliptic Partial Differential Equations, in Sparse -C Matrix Computations, Bunch and Rose, Eds., Academic -C Press, New York, 1979. -C***ROUTINES CALLED SCG, SCHKW, SS2Y, SSDI, SSDS, SSMV -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of references. (FNF) -C***END PROLOGUE SSDCG -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - REAL ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT -C .. Array Arguments .. - REAL A(NELT), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER LOCD, LOCDZ, LOCIW, LOCP, LOCR, LOCW, LOCZ -C .. External Subroutines .. - EXTERNAL SCG, SCHKW, SS2Y, SSDI, SSDS, SSMV -C***FIRST EXECUTABLE STATEMENT SSDCG -C - IERR = 0 - IF( N.LT.1 .OR. NELT.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Modify the SLAP matrix data structure to YSMP-Column. - CALL SS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Set up the work arrays. - LOCIW = LOCIB -C - LOCD = LOCRB - LOCR = LOCD + N - LOCZ = LOCR + N - LOCP = LOCZ + N - LOCDZ = LOCP + N - LOCW = LOCDZ + N -C -C Check the workspace allocations. - CALL SCHKW( 'SSDCG', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(4) = LOCD - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Compute the inverse of the diagonal of the matrix. This -C will be used as the preconditioner. - CALL SSDS(N, NELT, IA, JA, A, ISYM, RWORK(LOCD)) -C -C Do the Preconditioned Conjugate Gradient. - CALL SCG(N, B, X, NELT, IA, JA, A, ISYM, SSMV, SSDI, - $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), - $ RWORK(LOCZ), RWORK(LOCP), RWORK(LOCDZ), RWORK, IWORK) - RETURN -C------------- LAST LINE OF SSDCG FOLLOWS ----------------------------- - END diff --git a/slatec/ssdcgn.f b/slatec/ssdcgn.f deleted file mode 100644 index 31bead9..0000000 --- a/slatec/ssdcgn.f +++ /dev/null @@ -1,273 +0,0 @@ -*DECK SSDCGN - SUBROUTINE SSDCGN (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, - + ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE SSDCGN -C***PURPOSE Diagonally Scaled CG Sparse Ax=b Solver for Normal Eqn's. -C Routine to solve a general linear system Ax = b using -C diagonal scaling with the Conjugate Gradient method -C applied to the the normal equations, viz., AA'y = b, -C where x = A'y. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (SSDCGN-S, DSDCGN-D) -C***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM SOLVE, -C SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LENW, IWORK(10), LENIW -C REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(8*N) -C -C CALL SSDCGN(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Real B(N). -C Right-hand side vector. -C X :INOUT Real X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Real A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /SSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Real. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Real. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*R1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Real RWORK(LENW). -C Real array used for workspace. -C LENW :IN Integer. -C Length of the real workspace, RWORK. LENW >= 8*N. -C IWORK :WORK Integer IWORK(LENIW). -C Used to hold pointers into the RWORK array. -C Upon return the following locations of IWORK hold information -C which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Real workspace actually used. -C LENIW :IN Integer. -C Length of the integer workspace, IWORK. LENIW >= 10. -C -C *Description: -C This routine is simply a driver for the SCGN routine. It -C calls the SSD2S routine to set up the preconditioning and -C then calls SCGN with the appropriate MATVEC and MSOLVE -C routines. -C -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to be -C the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO SCGN, SSD2S, SSMV, SSMTV, SSDI -C***REFERENCES (NONE) -C***ROUTINES CALLED SCGN, SCHKW, SS2Y, SSD2S, SSDI, SSMTV, SSMV -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE SSDCGN -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - REAL ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT -C .. Array Arguments .. - REAL A(NELT), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER LOCATD, LOCATP, LOCATZ, LOCD, LOCDZ, LOCIW, LOCP, LOCR, - + LOCW, LOCZ -C .. External Subroutines .. - EXTERNAL SCGN, SCHKW, SS2Y, SSD2S, SSDI, SSMTV, SSMV -C***FIRST EXECUTABLE STATEMENT SSDCGN -C - IERR = 0 - IF( N.LT.1 .OR. NELT.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Modify the SLAP matrix data structure to YSMP-Column. - CALL SS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Set up the work arrays. - LOCIW = LOCIB -C - LOCD = LOCRB - LOCR = LOCD + N - LOCZ = LOCR + N - LOCP = LOCZ + N - LOCATP = LOCP + N - LOCATZ = LOCATP + N - LOCDZ = LOCATZ + N - LOCATD = LOCDZ + N - LOCW = LOCATD + N -C -C Check the workspace allocations. - CALL SCHKW( 'SSDCGN', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(4) = LOCD - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Compute the inverse of the diagonal of AA'. This will be -C used as the preconditioner. - CALL SSD2S(N, NELT, IA, JA, A, ISYM, RWORK(1)) -C -C Perform Conjugate Gradient algorithm on the normal equations. - CALL SCGN( N, B, X, NELT, IA, JA, A, ISYM, SSMV, SSMTV, SSDI, - $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), - $ RWORK(LOCZ), RWORK(LOCP), RWORK(LOCATP), RWORK(LOCATZ), - $ RWORK(LOCDZ), RWORK(LOCATD), RWORK, IWORK ) -C - IF( ITER.GT.ITMAX ) IERR = 2 - RETURN -C------------- LAST LINE OF SSDCGN FOLLOWS ---------------------------- - END diff --git a/slatec/ssdcgs.f b/slatec/ssdcgs.f deleted file mode 100644 index 21e47f1..0000000 --- a/slatec/ssdcgs.f +++ /dev/null @@ -1,285 +0,0 @@ -*DECK SSDCGS - SUBROUTINE SSDCGS (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, - + ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE SSDCGS -C***PURPOSE Diagonally Scaled CGS Sparse Ax=b Solver. -C Routine to solve a linear system Ax = b using the -C BiConjugate Gradient Squared method with diagonal scaling. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (SSDCGS-S, DSDCGS-D) -C***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, SLAP, -C SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LENW, IWORK(10), LENIW -C REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(8*N) -C -C CALL SSDCGS(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Real B(N). -C Right-hand side vector. -C X :INOUT Real X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Real A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C This routine must calculate the residual from R = A*X - B. -C This is unnatural and hence expensive for this type of iter- -C ative method. ITOL=2 is *STRONGLY* recommended. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv time a vector is the pre- -C conditioning step. This is the *NATURAL* stopping for this -C iterative method and is *STRONGLY* recommended. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /SSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Real. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Real. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*R1MACH(3). Iteration proceeded. -C IERR = 5 => Breakdown of the method detected. -C (r0,r) approximately 0. -C IERR = 6 => Stagnation of the method detected. -C (r0,v) approximately 0. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Real RWORK(LENW). -C Real array used for workspace. -C LENW :IN Integer. -C Length of the real workspace, RWORK. LENW >= 8*N. -C IWORK :WORK Integer IWORK(LENIW). -C Used to hold pointers into the RWORK array. -C Upon return the following locations of IWORK hold information -C which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Real workspace actually used. -C LENIW :IN Integer. -C Length of the integer workspace, IWORK. LENIW >= 10. -C -C *Description: -C This routine performs preconditioned BiConjugate gradient -C method on the Non-Symmetric positive definite linear system -C Ax=b. The preconditioner is M = DIAG(A), the diagonal of the -C matrix A. This is the simplest of preconditioners and -C vectorizes very well. -C -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to -C be the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO SCGS, SLUBCG -C***REFERENCES 1. P. Sonneveld, CGS, a fast Lanczos-type solver -C for nonsymmetric linear systems, Delft University -C of Technology Report 84-16, Department of Mathe- -C matics and Informatics, Delft, The Netherlands. -C 2. E. F. Kaasschieter, The solution of non-symmetric -C linear systems by biconjugate gradients or conjugate -C gradients squared, Delft University of Technology -C Report 86-21, Department of Mathematics and Informa- -C tics, Delft, The Netherlands. -C***ROUTINES CALLED SCGS, SCHKW, SS2Y, SSDI, SSDS, SSMV -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of references. (FNF) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE SSDCGS -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - REAL ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT -C .. Array Arguments .. - REAL A(N), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER LOCDIN, LOCIW, LOCP, LOCQ, LOCR, LOCR0, LOCU, LOCV1, - + LOCV2, LOCW -C .. External Subroutines .. - EXTERNAL SCGS, SCHKW, SS2Y, SSDI, SSDS, SSMV -C***FIRST EXECUTABLE STATEMENT SSDCGS -C - IERR = 0 - IF( N.LT.1 .OR. NELT.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Change the SLAP input matrix IA, JA, A to SLAP-Column format. - CALL SS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Set up the workspace. - LOCIW = LOCIB -C - LOCDIN = LOCRB - LOCR = LOCDIN + N - LOCR0 = LOCR + N - LOCP = LOCR0 + N - LOCQ = LOCP + N - LOCU = LOCQ + N - LOCV1 = LOCU + N - LOCV2 = LOCV1 + N - LOCW = LOCV2 + N -C -C Check the workspace allocations. - CALL SCHKW( 'SSDCGS', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(4) = LOCDIN - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Compute the inverse of the diagonal of the matrix. - CALL SSDS(N, NELT, IA, JA, A, ISYM, RWORK(LOCDIN)) -C -C Perform the Diagonally Scaled -C BiConjugate Gradient Squared algorithm. - CALL SCGS(N, B, X, NELT, IA, JA, A, ISYM, SSMV, - $ SSDI, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, - $ RWORK(LOCR), RWORK(LOCR0), RWORK(LOCP), - $ RWORK(LOCQ), RWORK(LOCU), RWORK(LOCV1), - $ RWORK(LOCV2), RWORK(1), IWORK(1)) - RETURN -C------------- LAST LINE OF SSDCGS FOLLOWS ---------------------------- - END diff --git a/slatec/ssdgmr.f b/slatec/ssdgmr.f deleted file mode 100644 index 02e3a79..0000000 --- a/slatec/ssdgmr.f +++ /dev/null @@ -1,385 +0,0 @@ -*DECK SSDGMR - SUBROUTINE SSDGMR (N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ITOL, - + TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE SSDGMR -C***PURPOSE Diagonally Scaled GMRES Iterative Sparse Ax=b Solver. -C This routine uses the generalized minimum residual -C (GMRES) method with diagonal scaling to solve possibly -C non-symmetric linear systems of the form: Ax = b. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (SSDGMR-S, DSDGMR-D) -C***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov -C Hindmarsh, Alan, (LLNL), alanh@llnl.gov -C Seager, Mark K., (LLNL), seager@llnl.gov -C Lawrence Livermore National Laboratory -C PO Box 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NSAVE, ITOL -C INTEGER ITMAX, ITER, IERR, IUNIT, LENW, IWORK(LENIW), LENIW -C REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(LENW) -C -C CALL SSDGMR(N, B, X, NELT, IA, JA, A, ISYM, NSAVE, -C $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, -C $ RWORK, LENW, IWORK, LENIW) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Real B(N). -C Right-hand side vector. -C X :INOUT Real X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Real A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C NSAVE :IN Integer. -C Number of direction vectors to save and orthogonalize against. -C Must be greater than 1. -C ITOL :IN Integer. -C Flag to indicate the type of convergence criterion used. -C ITOL=0 Means the iteration stops when the test described -C below on the residual RL is satisfied. This is -C the "Natural Stopping Criteria" for this routine. -C Other values of ITOL cause extra, otherwise -C unnecessary, computation per iteration and are -C therefore much less efficient. See ISSGMR (the -C stop test routine) for more information. -C ITOL=1 Means the iteration stops when the first test -C described below on the residual RL is satisfied, -C and there is either right or no preconditioning -C being used. -C ITOL=2 Implies that the user is using left -C preconditioning, and the second stopping criterion -C below is used. -C ITOL=3 Means the iteration stops when the third test -C described below on Minv*Residual is satisfied, and -C there is either left or no preconditioning begin -C used. -C ITOL=11 is often useful for checking and comparing -C different routines. For this case, the user must -C supply the "exact" solution or a very accurate -C approximation (one with an error much less than -C TOL) through a common block, -C COMMON /SSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the -C difference between the iterative approximation and -C the user-supplied solution divided by the 2-norm -C of the user-supplied solution is less than TOL. -C Note that this requires the user to set up the -C "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling -C routine. The routine with this declaration should -C be loaded before the stop test so that the correct -C length is used by the loader. This procedure is -C not standard Fortran and may not work correctly on -C your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 -C then this common block is indeed standard Fortran. -C TOL :INOUT Real. -C Convergence criterion, as described below. If TOL is set -C to zero on input, then a default value of 500*(the smallest -C positive magnitude, machine epsilon) is used. -C ITMAX :IN Integer. -C Maximum number of iterations. This routine uses the default -C of NRMAX = ITMAX/NSAVE to determine when each restart -C should occur. See the description of NRMAX and MAXL in -C SGMRES for a full and frightfully interesting discussion of -C this topic. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Real. -C Error estimate of error in final approximate solution, as -C defined by ITOL. Letting norm() denote the Euclidean -C norm, ERR is defined as follows... -C If ITOL=0, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), -C for right or no preconditioning, and -C ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ -C norm(SB*(M-inverse)*B), -C for left preconditioning. -C If ITOL=1, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), -C since right or no preconditioning -C being used. -C If ITOL=2, then ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ -C norm(SB*(M-inverse)*B), -C since left preconditioning is being -C used. -C If ITOL=3, then ERR = Max |(Minv*(B-A*X(L)))(i)/x(i)| -C i=1,n -C If ITOL=11, then ERR = norm(SB*(X(L)-SOLN))/norm(SB*SOLN). -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient storage allocated for -C RGWK or IGWK. -C IERR = 2 => Routine SPIGMR failed to reduce the norm -C of the current residual on its last call, -C and so the iteration has stalled. In -C this case, X equals the last computed -C approximation. The user must either -C increase MAXL, or choose a different -C initial guess. -C IERR =-1 => Insufficient length for RGWK array. -C IGWK(6) contains the required minimum -C length of the RGWK array. -C IERR =-2 => Inconsistent ITOL and JPRE values. -C For IERR <= 2, RGWK(1) = RHOL, which is the norm on the -C left-hand-side of the relevant stopping test defined -C below associated with the residual for the current -C approximation X(L). -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Real RWORK(LENW). -C Real array of size LENW. -C LENW :IN Integer. -C Length of the real workspace, RWORK. -C LENW >= 1 + N*(NSAVE+7) + NSAVE*(NSAVE+3). -C For the recommended values of NSAVE (10), RWORK has size at -C least 131 + 17*N. -C IWORK :INOUT Integer IWORK(USER DEFINED >= 30). -C Used to hold pointers into the RWORK array. -C Upon return the following locations of IWORK hold information -C which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Real workspace actually used. -C LENIW :IN Integer. -C Length of the integer workspace IWORK. LENIW >= 30. -C -C *Description: -C SSDGMR solves a linear system A*X = B rewritten in the form: -C -C (SB*A*(M-inverse)*(SX-inverse))*(SX*M*X) = SB*B, -C -C with right preconditioning, or -C -C (SB*(M-inverse)*A*(SX-inverse))*(SX*X) = SB*(M-inverse)*B, -C -C with left preconditioning, where A is an n-by-n real matrix, -C X and B are N-vectors, SB and SX are diagonal scaling -C matrices, and M is the diagonal of A. It uses -C preconditioned Krylov subpace methods based on the -C generalized minimum residual method (GMRES). This routine -C is a driver routine which assumes a SLAP matrix data -C structure and sets up the necessary information to do -C diagonal preconditioning and calls the main GMRES routine -C SGMRES for the solution of the linear system. SGMRES -C optionally performs either the full orthogonalization -C version of the GMRES algorithm or an incomplete variant of -C it. Both versions use restarting of the linear iteration by -C default, although the user can disable this feature. -C -C The GMRES algorithm generates a sequence of approximations -C X(L) to the true solution of the above linear system. The -C convergence criteria for stopping the iteration is based on -C the size of the scaled norm of the residual R(L) = B - -C A*X(L). The actual stopping test is either: -C -C norm(SB*(B-A*X(L))) .le. TOL*norm(SB*B), -C -C for right preconditioning, or -C -C norm(SB*(M-inverse)*(B-A*X(L))) .le. -C TOL*norm(SB*(M-inverse)*B), -C -C for left preconditioning, where norm() denotes the Euclidean -C norm, and TOL is a positive scalar less than one input by -C the user. If TOL equals zero when SSDGMR is called, then a -C default value of 500*(the smallest positive magnitude, -C machine epsilon) is used. If the scaling arrays SB and SX -C are used, then ideally they should be chosen so that the -C vectors SX*X(or SX*M*X) and SB*B have all their components -C approximately equal to one in magnitude. If one wants to -C use the same scaling in X and B, then SB and SX can be the -C same array in the calling program. -C -C The following is a list of the other routines and their -C functions used by GMRES: -C SGMRES Contains the matrix structure independent driver -C routine for GMRES. -C SPIGMR Contains the main iteration loop for GMRES. -C SORTH Orthogonalizes a new vector against older basis vectors. -C SHEQR Computes a QR decomposition of a Hessenberg matrix. -C SHELS Solves a Hessenberg least-squares system, using QR -C factors. -C RLCALC Computes the scaled residual RL. -C XLCALC Computes the solution XL. -C ISSGMR User-replaceable stopping routine. -C -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to be -C the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***REFERENCES 1. Peter N. Brown and A. C. Hindmarsh, Reduced Storage -C Matrix Methods in Stiff ODE Systems, Lawrence Liver- -C more National Laboratory Report UCRL-95088, Rev. 1, -C Livermore, California, June 1987. -C***ROUTINES CALLED SCHKW, SGMRES, SS2Y, SSDI, SSDS, SSMV -C***REVISION HISTORY (YYMMDD) -C 880615 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of references. (FNF) -C***END PROLOGUE SSDGMR -C The following is for optimized compilation on LLNL/LTSS Crays. -CLLL. OPTIMIZE -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - REAL ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, - + NELT, NSAVE -C .. Array Arguments .. - REAL A(NELT), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER LOCDIN, LOCIGW, LOCIW, LOCRGW, LOCW, MYITOL -C .. External Subroutines .. - EXTERNAL SCHKW, SGMRES, SS2Y, SSDI, SSDS, SSMV -C***FIRST EXECUTABLE STATEMENT SSDGMR -C - IERR = 0 - ERR = 0 - IF( NSAVE.LE.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Change the SLAP input matrix IA, JA, A to SLAP-Column format. - CALL SS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Set up the workspace. We assume MAXL=KMP=NSAVE. - LOCIGW = LOCIB - LOCIW = LOCIGW + 20 -C - LOCDIN = LOCRB - LOCRGW = LOCDIN + N - LOCW = LOCRGW + 1+N*(NSAVE+6)+NSAVE*(NSAVE+3) -C - IWORK(4) = LOCDIN - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Check the workspace allocations. - CALL SCHKW( 'SSDGMR', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C -C Compute the inverse of the diagonal of the matrix. - CALL SSDS(N, NELT, IA, JA, A, ISYM, RWORK(LOCDIN)) -C -C Perform the Diagonally Scaled Generalized Minimum -C Residual iteration algorithm. The following SGMRES -C defaults are used MAXL = KMP = NSAVE, JSCAL = 0, -C JPRE = -1, NRMAX = ITMAX/NSAVE - IWORK(LOCIGW ) = NSAVE - IWORK(LOCIGW+1) = NSAVE - IWORK(LOCIGW+2) = 0 - IWORK(LOCIGW+3) = -1 - IWORK(LOCIGW+4) = ITMAX/NSAVE - MYITOL = 0 -C - CALL SGMRES( N, B, X, NELT, IA, JA, A, ISYM, SSMV, SSDI, - $ MYITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, RWORK, - $ RWORK(LOCRGW), LENW-LOCRGW, IWORK(LOCIGW), 20, - $ RWORK, IWORK ) -C - IF( ITER.GT.ITMAX ) IERR = 2 - RETURN -C------------- LAST LINE OF SSDGMR FOLLOWS ---------------------------- - END diff --git a/slatec/ssdi.f b/slatec/ssdi.f deleted file mode 100644 index f552b00..0000000 --- a/slatec/ssdi.f +++ /dev/null @@ -1,88 +0,0 @@ -*DECK SSDI - SUBROUTINE SSDI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C***BEGIN PROLOGUE SSDI -C***PURPOSE Diagonal Matrix Vector Multiply. -C Routine to calculate the product X = DIAG*B, where DIAG -C is a diagonal matrix. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D1B4 -C***TYPE SINGLE PRECISION (SSDI-S, DSDI-D) -C***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM SOLVE, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, IWORK(10) -C REAL B(N), X(N), A(NELT), RWORK(USER DEFINED) -C -C CALL SSDI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Real B(N). -C Vector to multiply the diagonal by. -C X :OUT Real X(N). -C Result of DIAG*B. -C NELT :DUMMY Integer. -C IA :DUMMY Integer IA(NELT). -C JA :DUMMY Integer JA(NELT). -C A :DUMMY Real A(NELT). -C ISYM :DUMMY Integer. -C These are for compatibility with SLAP MSOLVE calling sequence. -C RWORK :IN Real RWORK(USER DEFINED). -C Work array holding the diagonal of some matrix to scale -C B by. This array must be set by the user or by a call -C to the SLAP routine SSDS or SSD2S. The length of RWORK -C must be >= IWORK(4)+N. -C IWORK :IN Integer IWORK(10). -C IWORK(4) holds the offset into RWORK for the diagonal matrix -C to scale B by. This is usually set up by the SLAP pre- -C conditioner setup routines SSDS or SSD2S. -C -C *Description: -C This routine is supplied with the SLAP package to perform -C the MSOLVE operation for iterative drivers that require -C diagonal Scaling (e.g., SSDCG, SSDBCG). It conforms -C to the SLAP MSOLVE CALLING CONVENTION and hence does not -C require an interface routine as do some of the other pre- -C conditioners supplied with SLAP. -C -C***SEE ALSO SSDS, SSD2S -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE SSDI -C .. Scalar Arguments .. - INTEGER ISYM, N, NELT -C .. Array Arguments .. - REAL A(NELT), B(N), RWORK(*), X(N) - INTEGER IA(NELT), IWORK(10), JA(NELT) -C .. Local Scalars .. - INTEGER I, LOCD -C***FIRST EXECUTABLE STATEMENT SSDI -C -C Determine where the inverse of the diagonal -C is in the work array and then scale by it. -C - LOCD = IWORK(4) - 1 - DO 10 I = 1, N - X(I) = RWORK(LOCD+I)*B(I) - 10 CONTINUE - RETURN -C------------- LAST LINE OF SSDI FOLLOWS ---------------------------- - END diff --git a/slatec/ssdomn.f b/slatec/ssdomn.f deleted file mode 100644 index 3534aa1..0000000 --- a/slatec/ssdomn.f +++ /dev/null @@ -1,262 +0,0 @@ -*DECK SSDOMN - SUBROUTINE SSDOMN (N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ITOL, - + TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE SSDOMN -C***PURPOSE Diagonally Scaled Orthomin Sparse Iterative Ax=b Solver. -C Routine to solve a general linear system Ax = b using -C the Orthomin method with diagonal scaling. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (SSDOMN-S, DSDOMN-D) -C***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM SOLVE, -C SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NSAVE, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LENW, IWORK(10), LENIW -C REAL B(N), X(N), A(NELT), TOL, ERR -C REAL RWORK(7*N+3*N*NSAVE+NSAVE) -C -C CALL SSDOMN(N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Real B(N). -C Right-hand side vector. -C X :INOUT Real X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Real A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen, it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C NSAVE :IN Integer. -C Number of direction vectors to save and orthogonalize against. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /SSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. -C TOL :INOUT Real. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Real. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*R1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Breakdown of method detected. -C (p,Ap) < epsilon**2. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Real RWORK(LENW). -C Real array used for workspace. -C LENW :IN Integer. -C Length of the real workspace, RWORK. -C LENW >= 7*N+NSAVE*(3*N+1). -C IWORK :WORK Integer IWORK(LENIW). -C Used to hold pointers into the RWORK array. -C LENIW :IN Integer. -C Length of the integer workspace, IWORK. LENIW >= 10. -C -C *Description: -C This routine is simply a driver for the SOMN routine. It -C calls the SSDS routine to set up the preconditioning and -C then calls SOMN with the appropriate MATVEC and MSOLVE -C routines. -C -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C -C In this format only the non-zeros are stored. They may -C appear in *ANY* order. The user supplies three arrays of -C length NELT, where NELT is the number of non-zeros in the -C matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero -C the user puts the row and column index of that matrix -C element in the IA and JA arrays. The value of the non-zero -C matrix element is placed in the corresponding location of -C the A array. This is an extremely easy data structure to -C generate. On the other hand it is not too efficient on -C vector computers for the iterative solution of linear -C systems. Hence, SLAP changes this input data structure to -C the SLAP Column format for the iteration (but does not -C change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C In this format the non-zeros are stored counting down -C columns (except for the diagonal entry, which must appear -C first in each "column") and are stored in the real array A. -C In other words, for each column in the matrix put the -C diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have JA(N+1) -C = NELT+1, where N is the number of columns in the matrix and -C NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to -C be the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO SOMN, SSLUOM -C***REFERENCES (NONE) -C***ROUTINES CALLED SCHKW, SOMN, SS2Y, SSDI, SSDS, SSMV -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE SSDOMN -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - REAL ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, - + NELT, NSAVE -C .. Array Arguments .. - REAL A(N), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER LOCAP, LOCCSA, LOCDIN, LOCDZ, LOCEMA, LOCIW, LOCP, LOCR, - + LOCW, LOCZ -C .. External Subroutines .. - EXTERNAL SCHKW, SOMN, SS2Y, SSDI, SSDS, SSMV -C***FIRST EXECUTABLE STATEMENT SSDOMN -C - IERR = 0 - IF( N.LT.1 .OR. NELT.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Change the SLAP input matrix IA, JA, A to SLAP-Column format. - CALL SS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Set up the workspace. - LOCIW = LOCIB -C - LOCDIN = LOCRB - LOCR = LOCDIN + N - LOCZ = LOCR + N - LOCP = LOCZ + N - LOCAP = LOCP + N*(NSAVE+1) - LOCEMA = LOCAP + N*(NSAVE+1) - LOCDZ = LOCEMA + N*(NSAVE+1) - LOCCSA = LOCDZ + N - LOCW = LOCCSA + NSAVE -C -C Check the workspace allocations. - CALL SCHKW( 'SSDOMN', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(4) = LOCDIN - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Compute the inverse of the diagonal of the matrix. - CALL SSDS(N, NELT, IA, JA, A, ISYM, RWORK(LOCDIN)) -C -C Perform the Diagonally Scaled Orthomin iteration algorithm. - CALL SOMN(N, B, X, NELT, IA, JA, A, ISYM, SSMV, - $ SSDI, NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, - $ RWORK(LOCR), RWORK(LOCZ), RWORK(LOCP), RWORK(LOCAP), - $ RWORK(LOCEMA), RWORK(LOCDZ), RWORK(LOCCSA), - $ RWORK, IWORK ) - RETURN -C------------- LAST LINE OF SSDOMN FOLLOWS ---------------------------- - END diff --git a/slatec/ssds.f b/slatec/ssds.f deleted file mode 100644 index 6d5ba2d..0000000 --- a/slatec/ssds.f +++ /dev/null @@ -1,124 +0,0 @@ -*DECK SSDS - SUBROUTINE SSDS (N, NELT, IA, JA, A, ISYM, DINV) -C***BEGIN PROLOGUE SSDS -C***PURPOSE Diagonal Scaling Preconditioner SLAP Set Up. -C Routine to compute the inverse of the diagonal of a matrix -C stored in the SLAP Column format. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE SINGLE PRECISION (SSDS-S, DSDS-D) -C***KEYWORDS DIAGONAL, SLAP SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM -C REAL A(NELT), DINV(N) -C -C CALL SSDS( N, NELT, IA, JA, A, ISYM, DINV ) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C NELT :IN Integer. -C Number of elements in arrays IA, JA, and A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Real A(NELT). -C These arrays should hold the matrix A in the SLAP Column -C format. See "Description", below. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C DINV :OUT Real DINV(N). -C Upon return this array holds 1./DIAG(A). -C -C *Description -C =================== S L A P Column format ================== -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C With the SLAP format all of the "inner loops" of this -C routine should vectorize on machines with hardware support -C for vector gather/scatter operations. Your compiler may -C require a compiler directive to convince it that there are -C no implicit vector dependencies. Compiler directives for -C the Alliant FX/Fortran and CRI CFT/CFT77 compilers are -C supplied with the standard SLAP distribution. -C -C -C *Cautions: -C This routine assumes that the diagonal of A is all non-zero -C and that the operation DINV = 1.0/DIAG(A) will not underflow -C or overflow. This is done so that the loop vectorizes. -C Matrices with zero or near zero or very large entries will -C have numerical difficulties and must be fixed before this -C routine is called. -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE SSDS -C .. Scalar Arguments .. - INTEGER ISYM, N, NELT -C .. Array Arguments .. - REAL A(NELT), DINV(N) - INTEGER IA(NELT), JA(NELT) -C .. Local Scalars .. - INTEGER ICOL -C***FIRST EXECUTABLE STATEMENT SSDS -C -C Assume the Diagonal elements are the first in each column. -C This loop should *VECTORIZE*. If it does not you may have -C to add a compiler directive. We do not check for a zero -C (or near zero) diagonal element since this would interfere -C with vectorization. If this makes you nervous put a check -C in! It will run much slower. -C - DO 10 ICOL = 1, N - DINV(ICOL) = 1.0E0/A(JA(ICOL)) - 10 CONTINUE -C - RETURN -C------------- LAST LINE OF SSDS FOLLOWS ---------------------------- - END diff --git a/slatec/ssdscl.f b/slatec/ssdscl.f deleted file mode 100644 index 16ca7a7..0000000 --- a/slatec/ssdscl.f +++ /dev/null @@ -1,194 +0,0 @@ -*DECK SSDSCL - SUBROUTINE SSDSCL (N, NELT, IA, JA, A, ISYM, X, B, DINV, JOB, - + ITOL) -C***BEGIN PROLOGUE SSDSCL -C***PURPOSE Diagonal Scaling of system Ax = b. -C This routine scales (and unscales) the system Ax = b -C by symmetric diagonal scaling. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE SINGLE PRECISION (SSDSCL-S, DSDSCL-D) -C***KEYWORDS DIAGONAL, SLAP SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C This routine scales (and unscales) the system Ax = b by symmetric -C diagonal scaling. The new system is: -C -1/2 -1/2 1/2 -1/2 -C D AD (D x) = D b -C when scaling is selected with the JOB parameter. When unscaling -C is selected this process is reversed. The true solution is also -C scaled or unscaled if ITOL is set appropriately, see below. -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, JOB, ITOL -C REAL A(NELT), X(N), B(N), DINV(N) -C -C CALL SSDSCL( N, NELT, IA, JA, A, ISYM, X, B, DINV, JOB, ITOL ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C NELT :IN Integer. -C Number of elements in arrays IA, JA, and A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Real A(NELT). -C These arrays should hold the matrix A in the SLAP Column -C format. See "Description", below. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C X :INOUT Real X(N). -C Initial guess that will be later used in the iterative -C solution. -C of the scaled system. -C B :INOUT Real B(N). -C Right hand side vector. -C DINV :INOUT Real DINV(N). -C Upon return this array holds 1./DIAG(A). -C This is an input if JOB = 0. -C JOB :IN Integer. -C Flag indicating whether to scale or not. -C JOB non-zero means do scaling. -C JOB = 0 means do unscaling. -C ITOL :IN Integer. -C Flag indicating what type of error estimation to do in the -C iterative method. When ITOL = 11 the exact solution from -C common block SSLBLK will be used. When the system is scaled -C then the true solution must also be scaled. If ITOL is not -C 11 then this vector is not referenced. -C -C *Common Blocks: -C SOLN :INOUT Real SOLN(N). COMMON BLOCK /SSLBLK/ -C The true solution, SOLN, is scaled (or unscaled) if ITOL is -C set to 11, see above. -C -C *Description -C =================== S L A P Column format ================== -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C With the SLAP format all of the "inner loops" of this -C routine should vectorize on machines with hardware support -C for vector gather/scatter operations. Your compiler may -C require a compiler directive to convince it that there are -C no implicit vector dependencies. Compiler directives for -C the Alliant FX/Fortran and CRI CFT/CFT77 compilers are -C supplied with the standard SLAP distribution. -C -C -C *Cautions: -C This routine assumes that the diagonal of A is all non-zero -C and that the operation DINV = 1.0/DIAG(A) will not under- -C flow or overflow. This is done so that the loop vectorizes. -C Matrices with zero or near zero or very large entries will -C have numerical difficulties and must be fixed before this -C routine is called. -C -C***SEE ALSO SSDCG -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS SSLBLK -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Added C***FIRST EXECUTABLE STATEMENT line. (FNF) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE SSDSCL -C .. Scalar Arguments .. - INTEGER ISYM, ITOL, JOB, N, NELT -C .. Array Arguments .. - REAL A(NELT), B(N), DINV(N), X(N) - INTEGER IA(NELT), JA(NELT) -C .. Arrays in Common .. - REAL SOLN(1) -C .. Local Scalars .. - REAL DI - INTEGER ICOL, J, JBGN, JEND -C .. Intrinsic Functions .. - INTRINSIC SQRT -C .. Common blocks .. - COMMON /SSLBLK/ SOLN -C***FIRST EXECUTABLE STATEMENT SSDSCL -C -C SCALING... -C - IF( JOB.NE.0 ) THEN - DO 10 ICOL = 1, N - DINV(ICOL) = 1.0E0/SQRT( A(JA(ICOL)) ) - 10 CONTINUE - ELSE -C -C UNSCALING... -C - DO 15 ICOL = 1, N - DINV(ICOL) = 1.0E0/DINV(ICOL) - 15 CONTINUE - ENDIF -C - DO 30 ICOL = 1, N - JBGN = JA(ICOL) - JEND = JA(ICOL+1)-1 - DI = DINV(ICOL) - DO 20 J = JBGN, JEND - A(J) = DINV(IA(J))*A(J)*DI - 20 CONTINUE - 30 CONTINUE -C - DO 40 ICOL = 1, N - B(ICOL) = B(ICOL)*DINV(ICOL) - X(ICOL) = X(ICOL)/DINV(ICOL) - 40 CONTINUE -C -C Check to see if we need to scale the "true solution" as well. -C - IF( ITOL.EQ.11 ) THEN - DO 50 ICOL = 1, N - SOLN(ICOL) = SOLN(ICOL)/DINV(ICOL) - 50 CONTINUE - ENDIF -C - RETURN -C------------- LAST LINE OF SSDSCL FOLLOWS ---------------------------- - END diff --git a/slatec/ssgs.f b/slatec/ssgs.f deleted file mode 100644 index af88100..0000000 --- a/slatec/ssgs.f +++ /dev/null @@ -1,285 +0,0 @@ -*DECK SSGS - SUBROUTINE SSGS (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, ITMAX, - + ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE SSGS -C***PURPOSE Gauss-Seidel Method Iterative Sparse Ax = b Solver. -C Routine to solve a general linear system Ax = b using -C Gauss-Seidel iteration. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (SSGS-S, DSGS-D) -C***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+2*N+1), LENIW -C REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(NL+3*N) -C -C CALL SSGS(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Real B(N). -C Right-hand side vector. -C X :INOUT Real X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Real A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the lower -C lower triangle of the matrix is stored. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /SSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Real. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Real. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*R1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Real RWORK(LENW). -C Real array used for workspace. -C LENW :IN Integer. -C Length of the real workspace, RWORK. LENW >= NL+3*N. -C NL is the number of non-zeros in the lower triangle of the -C matrix (including the diagonal). -C IWORK :WORK Integer IWORK(LENIW). -C Integer array used for workspace. -C Upon return the following locations of IWORK hold information -C which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Real workspace actually used. -C LENIW :IN Integer. -C Length of the integer workspace, IWORK. LENIW >= NL+N+11. -C NL is the number of non-zeros in the lower triangle of the -C matrix (including the diagonal). -C -C *Description -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to be -C the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO SSJAC, SIR -C***REFERENCES (NONE) -C***ROUTINES CALLED SCHKW, SIR, SS2LT, SS2Y, SSLI, SSMV -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 921019 Corrected NEL to NL. (FNF) -C***END PROLOGUE SSGS -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - REAL ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT -C .. Array Arguments .. - REAL A(N), B(N), RWORK(*), X(N) - INTEGER IA(NELT), IWORK(10), JA(NELT) -C .. Local Scalars .. - INTEGER ICOL, J, JBGN, JEND, LOCDZ, LOCEL, LOCIEL, LOCIW, LOCJEL, - + LOCR, LOCW, LOCZ, NL -C .. External Subroutines .. - EXTERNAL SCHKW, SIR, SS2LT, SS2Y, SSLI, SSMV -C***FIRST EXECUTABLE STATEMENT SSGS -C - IF( N.LT.1 .OR. NELT.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Modify the SLAP matrix data structure to YSMP-Column. - CALL SS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Count number of elements in lower triangle of the matrix. - IF( ISYM.EQ.0 ) THEN - NL = 0 - DO 20 ICOL = 1, N - JBGN = JA(ICOL) - JEND = JA(ICOL+1)-1 - DO 10 J = JBGN, JEND - IF( IA(J).GE.ICOL ) NL = NL + 1 - 10 CONTINUE - 20 CONTINUE - ELSE - NL = JA(N+1)-1 - ENDIF -C -C Set up the work arrays. Then store the lower triangle of -C the matrix. -C - LOCJEL = LOCIB - LOCIEL = LOCJEL + N+1 - LOCIW = LOCIEL + NL -C - LOCEL = LOCRB - LOCR = LOCEL + NL - LOCZ = LOCR + N - LOCDZ = LOCZ + N - LOCW = LOCDZ + N -C -C Check the workspace allocations. - CALL SCHKW( 'SSGS', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(1) = NL - IWORK(2) = LOCIEL - IWORK(3) = LOCJEL - IWORK(4) = LOCEL - IWORK(9) = LOCIW - IWORK(10) = LOCW -C - CALL SS2LT( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIEL), - $ IWORK(LOCJEL), RWORK(LOCEL) ) -C -C Call iterative refinement routine. - CALL SIR(N, B, X, NELT, IA, JA, A, ISYM, SSMV, SSLI, - $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), - $ RWORK(LOCZ), RWORK(LOCDZ), RWORK, IWORK ) -C -C Set the amount of Integer and Real Workspace used. - IWORK(9) = LOCIW+N+NELT - IWORK(10) = LOCW+NELT - RETURN -C------------- LAST LINE OF SSGS FOLLOWS ------------------------------ - END diff --git a/slatec/ssiccg.f b/slatec/ssiccg.f deleted file mode 100644 index 19102e6..0000000 --- a/slatec/ssiccg.f +++ /dev/null @@ -1,313 +0,0 @@ -*DECK SSICCG - SUBROUTINE SSICCG (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, - + ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE SSICCG -C***PURPOSE Incomplete Cholesky Conjugate Gradient Sparse Ax=b Solver. -C Routine to solve a symmetric positive definite linear -C system Ax = b using the incomplete Cholesky -C Preconditioned Conjugate Gradient method. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2B4 -C***TYPE SINGLE PRECISION (SSICCG-S, DSICCG-D) -C***KEYWORDS INCOMPLETE CHOLESKY, ITERATIVE PRECONDITION, SLAP, SPARSE, -C SYMMETRIC LINEAR SYSTEM -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+2*N+1), LENIW -C REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(NL+5*N) -C -C CALL SSICCG(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Real B(N). -C Right-hand side vector. -C X :INOUT Real X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Real A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /SSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Real. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Real. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*R1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. -C IERR = 7 => Incomplete factorization broke down and was -C fudged. Resulting preconditioning may be less -C than the best. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Real RWORK(LENW). -C Real array used for workspace. -C LENW :IN Integer. -C Length of the real workspace, RWORK. LENW >= NL+5*N. -C NL is the number of non-zeros in the lower triangle of the -C matrix (including the diagonal). -C IWORK :WORK Integer IWORK(LENIW). -C Integer array used for workspace. -C Upon return the following locations of IWORK hold information -C which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Real workspace actually used. -C LENIW :IN Integer. -C Length of the integer workspace, IWORK. LENIW >= NL+N+11. -C NL is the number of non-zeros in the lower triangle of the -C matrix (including the diagonal). -C -C *Description: -C This routine performs preconditioned conjugate gradient -C method on the symmetric positive definite linear system -C Ax=b. The preconditioner is the incomplete Cholesky (IC) -C factorization of the matrix A. See SSICS for details about -C the incomplete factorization algorithm. One should note -C here however, that the IC factorization is a slow process -C and that one should save factorizations for reuse, if -C possible. The MSOLVE operation (handled in SSLLTI) does -C vectorize on machines with hardware gather/scatter and is -C quite fast. -C -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to be -C the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO SCG, SSLLTI -C***REFERENCES 1. Louis Hageman and David Young, Applied Iterative -C Methods, Academic Press, New York, 1981. -C 2. Concus, Golub and O'Leary, A Generalized Conjugate -C Gradient Method for the Numerical Solution of -C Elliptic Partial Differential Equations, in Sparse -C Matrix Computations, Bunch and Rose, Eds., Academic -C Press, New York, 1979. -C***ROUTINES CALLED SCG, SCHKW, SS2Y, SSICS, SSLLTI, SSMV, XERMSG -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 900805 Changed XERRWV calls to calls to XERMSG. (RWC) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of references. (FNF) -C 921019 Corrected NEL to NL. (FNF) -C***END PROLOGUE SSICCG -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - REAL ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT -C .. Array Arguments .. - REAL A(NELT), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER LOCDIN, LOCDZ, LOCEL, LOCIEL, LOCIW, LOCJEL, LOCP, LOCR, - + LOCW, LOCZ, NL - CHARACTER XERN1*8 -C .. External Subroutines .. - EXTERNAL SCG, SCHKW, SS2Y, SSICS, SSLLTI, SSMV, XERMSG -C***FIRST EXECUTABLE STATEMENT SSICCG -C - IERR = 0 - IF( N.LT.1 .OR. NELT.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Change the SLAP input matrix IA, JA, A to SLAP-Column format. - CALL SS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Count number of elements in lower triangle of the matrix. -C Then set up the work arrays. - IF( ISYM.EQ.0 ) THEN - NL = (NELT + N)/2 - ELSE - NL = NELT - ENDIF -C - LOCJEL = LOCIB - LOCIEL = LOCJEL + NL - LOCIW = LOCIEL + N + 1 -C - LOCEL = LOCRB - LOCDIN = LOCEL + NL - LOCR = LOCDIN + N - LOCZ = LOCR + N - LOCP = LOCZ + N - LOCDZ = LOCP + N - LOCW = LOCDZ + N -C -C Check the workspace allocations. - CALL SCHKW( 'SSICCG', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(1) = NL - IWORK(2) = LOCJEL - IWORK(3) = LOCIEL - IWORK(4) = LOCEL - IWORK(5) = LOCDIN - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Compute the Incomplete Cholesky decomposition. -C - CALL SSICS(N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIEL), - $ IWORK(LOCJEL), RWORK(LOCEL), RWORK(LOCDIN), - $ RWORK(LOCR), IERR ) - IF( IERR.NE.0 ) THEN - WRITE (XERN1, '(I8)') IERR - CALL XERMSG ('SLATEC', 'SSICCG', - $ 'IC factorization broke down on step ' // XERN1 // - $ '. Diagonal was set to unity and factorization proceeded.', - $ 1, 1) - IERR = 7 - ENDIF -C -C Do the Preconditioned Conjugate Gradient. - CALL SCG(N, B, X, NELT, IA, JA, A, ISYM, SSMV, SSLLTI, - $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), - $ RWORK(LOCZ), RWORK(LOCP), RWORK(LOCDZ), RWORK(1), - $ IWORK(1)) - RETURN -C------------- LAST LINE OF SSICCG FOLLOWS ---------------------------- - END diff --git a/slatec/ssico.f b/slatec/ssico.f deleted file mode 100644 index 3702734..0000000 --- a/slatec/ssico.f +++ /dev/null @@ -1,260 +0,0 @@ -*DECK SSICO - SUBROUTINE SSICO (A, LDA, N, KPVT, RCOND, Z) -C***BEGIN PROLOGUE SSICO -C***PURPOSE Factor a symmetric matrix by elimination with symmetric -C pivoting and estimate the condition number of the matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1A -C***TYPE SINGLE PRECISION (SSICO-S, DSICO-D, CHICO-C, CSICO-C) -C***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, -C MATRIX FACTORIZATION, SYMMETRIC -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C SSICO factors a real symmetric matrix by elimination with -C symmetric pivoting and estimates the condition of the matrix. -C -C If RCOND is not needed, SSIFA is slightly faster. -C To solve A*X = B , follow SSICO by SSISL. -C To compute INVERSE(A)*C , follow SSICO by SSISL. -C To compute INVERSE(A) , follow SSICO by SSIDI. -C To compute DETERMINANT(A) , follow SSICO by SSIDI. -C To compute INERTIA(A), follow SSICO by SSIDI. -C -C On Entry -C -C A REAL(LDA, N) -C the symmetric matrix to be factored. -C Only the diagonal and upper triangle are used. -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 Output -C -C A a block diagonal matrix and the multipliers which -C were used to obtain it. -C The factorization can be written A = U*D*TRANS(U) -C where U is a product of permutation and unit -C upper triangular matrices , TRANS(U) is the -C transpose of U , and D is block diagonal -C with 1 by 1 and 2 by 2 blocks. -C -C KPVT INTEGER(N) -C an integer vector of pivot indices. -C -C RCOND REAL -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 REAL(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***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SASUM, SAXPY, SDOT, SSCAL, SSIFA -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Modified routine equivalence list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SSICO - INTEGER LDA,N,KPVT(*) - REAL A(LDA,*),Z(*) - REAL RCOND -C - REAL AK,AKM1,BK,BKM1,SDOT,DENOM,EK,T - REAL ANORM,S,SASUM,YNORM - INTEGER I,INFO,J,JM1,K,KP,KPS,KS -C -C FIND NORM OF A USING ONLY UPPER HALF -C -C***FIRST EXECUTABLE STATEMENT SSICO - DO 30 J = 1, N - Z(J) = SASUM(J,A(1,J),1) - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 20 - DO 10 I = 1, JM1 - Z(I) = Z(I) + ABS(A(I,J)) - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - ANORM = 0.0E0 - DO 40 J = 1, N - ANORM = MAX(ANORM,Z(J)) - 40 CONTINUE -C -C FACTOR -C - CALL SSIFA(A,LDA,N,KPVT,INFO) -C -C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . -C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . -C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL -C GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . -C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. -C -C SOLVE U*D*W = E -C - EK = 1.0E0 - DO 50 J = 1, N - Z(J) = 0.0E0 - 50 CONTINUE - K = N - 60 IF (K .EQ. 0) GO TO 120 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - KP = ABS(KPVT(K)) - KPS = K + 1 - KS - IF (KP .EQ. KPS) GO TO 70 - T = Z(KPS) - Z(KPS) = Z(KP) - Z(KP) = T - 70 CONTINUE - IF (Z(K) .NE. 0.0E0) EK = SIGN(EK,Z(K)) - Z(K) = Z(K) + EK - CALL SAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) - IF (KS .EQ. 1) GO TO 80 - IF (Z(K-1) .NE. 0.0E0) EK = SIGN(EK,Z(K-1)) - Z(K-1) = Z(K-1) + EK - CALL SAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) - 80 CONTINUE - IF (KS .EQ. 2) GO TO 100 - IF (ABS(Z(K)) .LE. ABS(A(K,K))) GO TO 90 - S = ABS(A(K,K))/ABS(Z(K)) - CALL SSCAL(N,S,Z,1) - EK = S*EK - 90 CONTINUE - IF (A(K,K) .NE. 0.0E0) Z(K) = Z(K)/A(K,K) - IF (A(K,K) .EQ. 0.0E0) Z(K) = 1.0E0 - GO TO 110 - 100 CONTINUE - AK = A(K,K)/A(K-1,K) - AKM1 = A(K-1,K-1)/A(K-1,K) - BK = Z(K)/A(K-1,K) - BKM1 = Z(K-1)/A(K-1,K) - DENOM = AK*AKM1 - 1.0E0 - Z(K) = (AKM1*BK - BKM1)/DENOM - Z(K-1) = (AK*BKM1 - BK)/DENOM - 110 CONTINUE - K = K - KS - GO TO 60 - 120 CONTINUE - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) -C -C SOLVE TRANS(U)*Y = W -C - K = 1 - 130 IF (K .GT. N) GO TO 160 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. 1) GO TO 150 - Z(K) = Z(K) + SDOT(K-1,A(1,K),1,Z(1),1) - IF (KS .EQ. 2) - 1 Z(K+1) = Z(K+1) + SDOT(K-1,A(1,K+1),1,Z(1),1) - KP = ABS(KPVT(K)) - IF (KP .EQ. K) GO TO 140 - T = Z(K) - Z(K) = Z(KP) - Z(KP) = T - 140 CONTINUE - 150 CONTINUE - K = K + KS - GO TO 130 - 160 CONTINUE - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) -C - YNORM = 1.0E0 -C -C SOLVE U*D*V = Y -C - K = N - 170 IF (K .EQ. 0) GO TO 230 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. KS) GO TO 190 - KP = ABS(KPVT(K)) - KPS = K + 1 - KS - IF (KP .EQ. KPS) GO TO 180 - T = Z(KPS) - Z(KPS) = Z(KP) - Z(KP) = T - 180 CONTINUE - CALL SAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) - IF (KS .EQ. 2) CALL SAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) - 190 CONTINUE - IF (KS .EQ. 2) GO TO 210 - IF (ABS(Z(K)) .LE. ABS(A(K,K))) GO TO 200 - S = ABS(A(K,K))/ABS(Z(K)) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM - 200 CONTINUE - IF (A(K,K) .NE. 0.0E0) Z(K) = Z(K)/A(K,K) - IF (A(K,K) .EQ. 0.0E0) Z(K) = 1.0E0 - GO TO 220 - 210 CONTINUE - AK = A(K,K)/A(K-1,K) - AKM1 = A(K-1,K-1)/A(K-1,K) - BK = Z(K)/A(K-1,K) - BKM1 = Z(K-1)/A(K-1,K) - DENOM = AK*AKM1 - 1.0E0 - Z(K) = (AKM1*BK - BKM1)/DENOM - Z(K-1) = (AK*BKM1 - BK)/DENOM - 220 CONTINUE - K = K - KS - GO TO 170 - 230 CONTINUE - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE TRANS(U)*Z = V -C - K = 1 - 240 IF (K .GT. N) GO TO 270 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. 1) GO TO 260 - Z(K) = Z(K) + SDOT(K-1,A(1,K),1,Z(1),1) - IF (KS .EQ. 2) - 1 Z(K+1) = Z(K+1) + SDOT(K-1,A(1,K+1),1,Z(1),1) - KP = ABS(KPVT(K)) - IF (KP .EQ. K) GO TO 250 - T = Z(K) - Z(K) = Z(KP) - Z(KP) = T - 250 CONTINUE - 260 CONTINUE - K = K + KS - GO TO 240 - 270 CONTINUE -C MAKE ZNORM = 1.0 - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM -C - IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM - IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0 - RETURN - END diff --git a/slatec/ssics.f b/slatec/ssics.f deleted file mode 100644 index 6974ff9..0000000 --- a/slatec/ssics.f +++ /dev/null @@ -1,340 +0,0 @@ -*DECK SSICS - SUBROUTINE SSICS (N, NELT, IA, JA, A, ISYM, NEL, IEL, JEL, EL, D, - + R, IWARN) -C***BEGIN PROLOGUE SSICS -C***PURPOSE Incompl. Cholesky Decomposition Preconditioner SLAP Set Up. -C Routine to generate the Incomplete Cholesky decomposition, -C L*D*L-trans, of a symmetric positive definite matrix, A, -C which is stored in SLAP Column format. The unit lower -C triangular matrix L is stored by rows, and the inverse of -C the diagonal matrix D is stored. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE SINGLE PRECISION (SSICS-S, DSICS-D) -C***KEYWORDS INCOMPLETE CHOLESKY FACTORIZATION, -C ITERATIVE PRECONDITION, LINEAR SYSTEM, SLAP SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM -C INTEGER NEL, IEL(NEL), JEL(NEL), IWARN -C REAL A(NELT), EL(NEL), D(N), R(N) -C -C CALL SSICS( N, NELT, IA, JA, A, ISYM, NEL, IEL, JEL, EL, D, R, -C $ IWARN ) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C NELT :IN Integer. -C Number of elements in arrays IA, JA, and A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Real A(NELT). -C These arrays should hold the matrix A in the SLAP Column -C format. See "Description", below. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the lower -C triangle of the matrix is stored. -C NEL :OUT Integer. -C Number of non-zeros in the lower triangle of A. Also -C corresponds to the length of the IEL, JEL, EL arrays. -C IEL :OUT Integer IEL(NEL). -C JEL :OUT Integer JEL(NEL). -C EL :OUT Real EL(NEL). -C IEL, JEL, EL contain the unit lower triangular factor of the -C incomplete decomposition of the A matrix stored in SLAP -C Row format. The Diagonal of ones *IS* stored. See -C "Description", below for more details about the SLAP Row fmt. -C D :OUT Real D(N) -C Upon return this array holds D(I) = 1./DIAG(A). -C R :WORK Real R(N). -C Temporary real workspace needed for the factorization. -C IWARN :OUT Integer. -C This is a warning variable and is zero if the IC factoriza- -C tion goes well. It is set to the row index corresponding to -C the last zero pivot found. See "Description", below. -C -C *Description -C =================== S L A P Column format ================== -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C ==================== S L A P Row format ==================== -C -C This routine requires that the matrix A be stored in the -C SLAP Row format. In this format the non-zeros are stored -C counting across rows (except for the diagonal entry, which -C must appear first in each "row") and are stored in the real -C array A. In other words, for each row in the matrix put the -C diagonal entry in A. Then put in the other non-zero -C elements going across the row (except the diagonal) in -C order. The JA array holds the column index for each -C non-zero. The IA array holds the offsets into the JA, A -C arrays for the beginning of each row. That is, -C JA(IA(IROW)), A(IA(IROW)) points to the beginning of the -C IROW-th row in JA and A. JA(IA(IROW+1)-1), A(IA(IROW+1)-1) -C points to the end of the IROW-th row. Note that we always -C have IA(N+1) = NELT+1, where N is the number of rows in -C the matrix and NELT is the number of non-zeros in the -C matrix. -C -C Here is an example of the SLAP Row storage format for a 5x5 -C Matrix (in the A and JA arrays '|' denotes the end of a row): -C -C 5x5 Matrix SLAP Row format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 12 15 | 22 21 | 33 35 | 44 | 55 51 53 -C |21 22 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| IA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C With the SLAP format some of the "inner loops" of this -C routine should vectorize on machines with hardware support -C for vector gather/scatter operations. Your compiler may -C require a compiler directive to convince it that there are -C no implicit vector dependencies. Compiler directives for -C the Alliant FX/Fortran and CRI CFT/CFT77 compilers are -C supplied with the standard SLAP distribution. -C -C The IC factorization does not always exist for SPD matrices. -C In the event that a zero pivot is found it is set to be 1.0 -C and the factorization proceeds. The integer variable IWARN -C is set to the last row where the Diagonal was fudged. This -C eventuality hardly ever occurs in practice. -C -C***SEE ALSO SCG, SSICCG -C***REFERENCES 1. Gene Golub and Charles Van Loan, Matrix Computations, -C Johns Hopkins University Press, Baltimore, Maryland, -C 1983. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 900805 Changed XERRWV calls to calls to XERMSG. (RWC) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of reference. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE SSICS -C .. Scalar Arguments .. - INTEGER ISYM, IWARN, N, NEL, NELT -C .. Array Arguments .. - REAL A(NELT), D(N), EL(NEL), R(N) - INTEGER IA(NELT), IEL(NEL), JA(NELT), JEL(NEL) -C .. Local Scalars .. - REAL ELTMP - INTEGER I, IBGN, IC, ICBGN, ICEND, ICOL, IEND, IR, IRBGN, IREND, - + IROW, IRR, J, JBGN, JELTMP, JEND - CHARACTER XERN1*8 -C .. External Subroutines .. - EXTERNAL XERMSG -C***FIRST EXECUTABLE STATEMENT SSICS -C -C Set the lower triangle in IEL, JEL, EL -C - IWARN = 0 -C -C All matrix elements stored in IA, JA, A. Pick out the lower -C triangle (making sure that the Diagonal of EL is one) and -C store by rows. -C - NEL = 1 - IEL(1) = 1 - JEL(1) = 1 - EL(1) = 1 - D(1) = A(1) -CVD$R NOCONCUR - DO 30 IROW = 2, N -C Put in the Diagonal. - NEL = NEL + 1 - IEL(IROW) = NEL - JEL(NEL) = IROW - EL(NEL) = 1 - D(IROW) = A(JA(IROW)) -C -C Look in all the lower triangle columns for a matching row. -C Since the matrix is symmetric, we can look across the -C ITOW-th row by looking down the IROW-th column (if it is -C stored ISYM=0)... - IF( ISYM.EQ.0 ) THEN - ICBGN = JA(IROW) - ICEND = JA(IROW+1)-1 - ELSE - ICBGN = 1 - ICEND = IROW-1 - ENDIF - DO 20 IC = ICBGN, ICEND - IF( ISYM.EQ.0 ) THEN - ICOL = IA(IC) - IF( ICOL.GE.IROW ) GOTO 20 - ELSE - ICOL = IC - ENDIF - JBGN = JA(ICOL)+1 - JEND = JA(ICOL+1)-1 - IF( JBGN.LE.JEND .AND. IA(JEND).GE.IROW ) THEN -CVD$ NOVECTOR - DO 10 J = JBGN, JEND - IF( IA(J).EQ.IROW ) THEN - NEL = NEL + 1 - JEL(NEL) = ICOL - EL(NEL) = A(J) - GOTO 20 - ENDIF - 10 CONTINUE - ENDIF - 20 CONTINUE - 30 CONTINUE - IEL(N+1) = NEL+1 -C -C Sort ROWS of lower triangle into descending order (count out -C along rows out from Diagonal). -C - DO 60 IROW = 2, N - IBGN = IEL(IROW)+1 - IEND = IEL(IROW+1)-1 - IF( IBGN.LT.IEND ) THEN - DO 50 I = IBGN, IEND-1 -CVD$ NOVECTOR - DO 40 J = I+1, IEND - IF( JEL(I).GT.JEL(J) ) THEN - JELTMP = JEL(J) - JEL(J) = JEL(I) - JEL(I) = JELTMP - ELTMP = EL(J) - EL(J) = EL(I) - EL(I) = ELTMP - ENDIF - 40 CONTINUE - 50 CONTINUE - ENDIF - 60 CONTINUE -C -C Perform the Incomplete Cholesky decomposition by looping -C over the rows. -C Scale the first column. Use the structure of A to pick out -C the rows with something in column 1. -C - IRBGN = JA(1)+1 - IREND = JA(2)-1 - DO 65 IRR = IRBGN, IREND - IR = IA(IRR) -C Find the index into EL for EL(1,IR). -C Hint: it's the second entry. - I = IEL(IR)+1 - EL(I) = EL(I)/D(1) - 65 CONTINUE -C - DO 110 IROW = 2, N -C -C Update the IROW-th diagonal. -C - DO 66 I = 1, IROW-1 - R(I) = 0 - 66 CONTINUE - IBGN = IEL(IROW)+1 - IEND = IEL(IROW+1)-1 - IF( IBGN.LE.IEND ) THEN -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ NODEPCHK - DO 70 I = IBGN, IEND - R(JEL(I)) = EL(I)*D(JEL(I)) - D(IROW) = D(IROW) - EL(I)*R(JEL(I)) - 70 CONTINUE -C -C Check to see if we have a problem with the diagonal. -C - IF( D(IROW).LE.0.0E0 ) THEN - IF( IWARN.EQ.0 ) IWARN = IROW - D(IROW) = 1 - ENDIF - ENDIF -C -C Update each EL(IROW+1:N,IROW), if there are any. -C Use the structure of A to determine the Non-zero elements -C of the IROW-th column of EL. -C - IRBGN = JA(IROW) - IREND = JA(IROW+1)-1 - DO 100 IRR = IRBGN, IREND - IR = IA(IRR) - IF( IR.LE.IROW ) GOTO 100 -C Find the index into EL for EL(IR,IROW) - IBGN = IEL(IR)+1 - IEND = IEL(IR+1)-1 - IF( JEL(IBGN).GT.IROW ) GOTO 100 - DO 90 I = IBGN, IEND - IF( JEL(I).EQ.IROW ) THEN - ICEND = IEND - 91 IF( JEL(ICEND).GE.IROW ) THEN - ICEND = ICEND - 1 - GOTO 91 - ENDIF -C Sum up the EL(IR,1:IROW-1)*R(1:IROW-1) contributions. -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ NODEPCHK - DO 80 IC = IBGN, ICEND - EL(I) = EL(I) - EL(IC)*R(JEL(IC)) - 80 CONTINUE - EL(I) = EL(I)/D(IROW) - GOTO 100 - ENDIF - 90 CONTINUE -C -C If we get here, we have real problems... - WRITE (XERN1, '(I8)') IROW - CALL XERMSG ('SLATEC', 'SSICS', - $ 'A and EL data structure mismatch in row '// XERN1, 1, 2) - 100 CONTINUE - 110 CONTINUE -C -C Replace diagonals by their inverses. -C -CVD$ CONCUR - DO 120 I =1, N - D(I) = 1.0E0/D(I) - 120 CONTINUE - RETURN -C------------- LAST LINE OF SSICS FOLLOWS ---------------------------- - END diff --git a/slatec/ssidi.f b/slatec/ssidi.f deleted file mode 100644 index 1ca4968..0000000 --- a/slatec/ssidi.f +++ /dev/null @@ -1,228 +0,0 @@ -*DECK SSIDI - SUBROUTINE SSIDI (A, LDA, N, KPVT, DET, INERT, WORK, JOB) -C***BEGIN PROLOGUE SSIDI -C***PURPOSE Compute the determinant, inertia and inverse of a real -C symmetric matrix using the factors from SSIFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1A, D3B1A -C***TYPE SINGLE PRECISION (SSIDI-S, DSIDI-D, CHIDI-C, CSIDI-C) -C***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, -C SYMMETRIC -C***AUTHOR Bunch, J., (UCSD) -C***DESCRIPTION -C -C SSIDI computes the determinant, inertia and inverse -C of a real symmetric matrix using the factors from SSIFA. -C -C On Entry -C -C A REAL(LDA,N) -C the output from SSIFA. -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 KPVT INTEGER(N) -C the pivot vector from SSIFA. -C -C WORK REAL(N) -C work vector. Contents destroyed. -C -C JOB INTEGER -C JOB has the decimal expansion ABC where -C If C .NE. 0, the inverse is computed, -C If B .NE. 0, the determinant is computed, -C If A .NE. 0, the inertia is computed. -C -C For example, JOB = 111 gives all three. -C -C On Return -C -C Variables not requested by JOB are not used. -C -C A contains the upper triangle of the inverse of -C the original matrix. The strict lower triangle -C is never referenced. -C -C DET REAL(2) -C determinant of original matrix. -C Determinant = DET(1) * 10.0**DET(2) -C with 1.0 .LE. ABS(DET(1)) .LT. 10.0 -C or DET(1) = 0.0. -C -C INERT INTEGER(3) -C the inertia of the original matrix. -C INERT(1) = number of positive eigenvalues. -C INERT(2) = number of negative eigenvalues. -C INERT(3) = number of zero eigenvalues. -C -C Error Condition -C -C A division by zero may occur if the inverse is requested -C and SSICO has set RCOND .EQ. 0.0 -C or SSIFA has set INFO .NE. 0 . -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SAXPY, SCOPY, SDOT, SSWAP -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Modified routine equivalence list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SSIDI - INTEGER LDA,N,JOB - REAL A(LDA,*),WORK(*) - REAL DET(2) - INTEGER KPVT(*),INERT(3) -C - REAL AKKP1,SDOT,TEMP - REAL TEN,D,T,AK,AKP1 - INTEGER J,JB,K,KM1,KS,KSTEP - LOGICAL NOINV,NODET,NOERT -C***FIRST EXECUTABLE STATEMENT SSIDI - NOINV = MOD(JOB,10) .EQ. 0 - NODET = MOD(JOB,100)/10 .EQ. 0 - NOERT = MOD(JOB,1000)/100 .EQ. 0 -C - IF (NODET .AND. NOERT) GO TO 140 - IF (NOERT) GO TO 10 - INERT(1) = 0 - INERT(2) = 0 - INERT(3) = 0 - 10 CONTINUE - IF (NODET) GO TO 20 - DET(1) = 1.0E0 - DET(2) = 0.0E0 - TEN = 10.0E0 - 20 CONTINUE - T = 0.0E0 - DO 130 K = 1, N - D = A(K,K) -C -C CHECK IF 1 BY 1 -C - IF (KPVT(K) .GT. 0) GO TO 50 -C -C 2 BY 2 BLOCK -C USE DET (D S) = (D/T * C - T) * T , T = ABS(S) -C (S C) -C TO AVOID UNDERFLOW/OVERFLOW TROUBLES. -C TAKE TWO PASSES THROUGH SCALING. USE T FOR FLAG. -C - IF (T .NE. 0.0E0) GO TO 30 - T = ABS(A(K,K+1)) - D = (D/T)*A(K+1,K+1) - T - GO TO 40 - 30 CONTINUE - D = T - T = 0.0E0 - 40 CONTINUE - 50 CONTINUE -C - IF (NOERT) GO TO 60 - IF (D .GT. 0.0E0) INERT(1) = INERT(1) + 1 - IF (D .LT. 0.0E0) INERT(2) = INERT(2) + 1 - IF (D .EQ. 0.0E0) INERT(3) = INERT(3) + 1 - 60 CONTINUE -C - IF (NODET) GO TO 120 - DET(1) = D*DET(1) - IF (DET(1) .EQ. 0.0E0) GO TO 110 - 70 IF (ABS(DET(1)) .GE. 1.0E0) GO TO 80 - DET(1) = TEN*DET(1) - DET(2) = DET(2) - 1.0E0 - GO TO 70 - 80 CONTINUE - 90 IF (ABS(DET(1)) .LT. TEN) GO TO 100 - DET(1) = DET(1)/TEN - DET(2) = DET(2) + 1.0E0 - GO TO 90 - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE - 130 CONTINUE - 140 CONTINUE -C -C COMPUTE INVERSE(A) -C - IF (NOINV) GO TO 270 - K = 1 - 150 IF (K .GT. N) GO TO 260 - KM1 = K - 1 - IF (KPVT(K) .LT. 0) GO TO 180 -C -C 1 BY 1 -C - A(K,K) = 1.0E0/A(K,K) - IF (KM1 .LT. 1) GO TO 170 - CALL SCOPY(KM1,A(1,K),1,WORK,1) - DO 160 J = 1, KM1 - A(J,K) = SDOT(J,A(1,J),1,WORK,1) - CALL SAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1) - 160 CONTINUE - A(K,K) = A(K,K) + SDOT(KM1,WORK,1,A(1,K),1) - 170 CONTINUE - KSTEP = 1 - GO TO 220 - 180 CONTINUE -C -C 2 BY 2 -C - T = ABS(A(K,K+1)) - AK = A(K,K)/T - AKP1 = A(K+1,K+1)/T - AKKP1 = A(K,K+1)/T - D = T*(AK*AKP1 - 1.0E0) - A(K,K) = AKP1/D - A(K+1,K+1) = AK/D - A(K,K+1) = -AKKP1/D - IF (KM1 .LT. 1) GO TO 210 - CALL SCOPY(KM1,A(1,K+1),1,WORK,1) - DO 190 J = 1, KM1 - A(J,K+1) = SDOT(J,A(1,J),1,WORK,1) - CALL SAXPY(J-1,WORK(J),A(1,J),1,A(1,K+1),1) - 190 CONTINUE - A(K+1,K+1) = A(K+1,K+1) + SDOT(KM1,WORK,1,A(1,K+1),1) - A(K,K+1) = A(K,K+1) + SDOT(KM1,A(1,K),1,A(1,K+1),1) - CALL SCOPY(KM1,A(1,K),1,WORK,1) - DO 200 J = 1, KM1 - A(J,K) = SDOT(J,A(1,J),1,WORK,1) - CALL SAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1) - 200 CONTINUE - A(K,K) = A(K,K) + SDOT(KM1,WORK,1,A(1,K),1) - 210 CONTINUE - KSTEP = 2 - 220 CONTINUE -C -C SWAP -C - KS = ABS(KPVT(K)) - IF (KS .EQ. K) GO TO 250 - CALL SSWAP(KS,A(1,KS),1,A(1,K),1) - DO 230 JB = KS, K - J = K + KS - JB - TEMP = A(J,K) - A(J,K) = A(KS,J) - A(KS,J) = TEMP - 230 CONTINUE - IF (KSTEP .EQ. 1) GO TO 240 - TEMP = A(KS,K+1) - A(KS,K+1) = A(K,K+1) - A(K,K+1) = TEMP - 240 CONTINUE - 250 CONTINUE - K = K + KSTEP - GO TO 150 - 260 CONTINUE - 270 CONTINUE - RETURN - END diff --git a/slatec/ssiev.f b/slatec/ssiev.f deleted file mode 100644 index d792465..0000000 --- a/slatec/ssiev.f +++ /dev/null @@ -1,113 +0,0 @@ -*DECK SSIEV - SUBROUTINE SSIEV (A, LDA, N, E, WORK, JOB, INFO) -C***BEGIN PROLOGUE SSIEV -C***PURPOSE Compute the eigenvalues and, optionally, the eigenvectors -C of a real symmetric matrix. -C***LIBRARY SLATEC -C***CATEGORY D4A1 -C***TYPE SINGLE PRECISION (SSIEV-S, CHIEV-C) -C***KEYWORDS COMPLEX HERMITIAN, EIGENVALUES, EIGENVECTORS, MATRIX, -C SYMMETRIC -C***AUTHOR Kahaner, D. K., (NBS) -C Moler, C. B., (U. of New Mexico) -C Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C Abstract -C SSIEV computes the eigenvalues and, optionally, the eigenvectors -C of a real symmetric matrix. -C -C Call Sequence Parameters- -C (The values of parameters marked with * (star) will be changed -C by SSIEV.) -C -C A* REAL (LDA,N) -C real symmetric input matrix. -C Only the diagonal and upper triangle of A must be input, -C as SSIEV copies the upper triangle to the lower. -C That is, the user must define A(I,J), I=1,..N, and J=I,. -C ..,N. -C On return from SSIEV, if the user has set JOB -C = 0 the lower triangle of A has been altered. -C = nonzero the N eigenvectors of A are stored in its -C first N columns. See also INFO below. -C -C LDA INTEGER -C set by the user to -C the leading dimension of the array A. -C -C N INTEGER -C set by the user to -C the order of the matrix A and -C the number of elements in E. -C -C E* REAL (N) -C on return from SSIEV, E contains the N -C eigenvalues of A. See also INFO below. -C -C WORK* REAL (2*N) -C temporary storage vector. Contents changed by SSIEV. -C -C JOB INTEGER -C set by user on input -C = 0 only calculate eigenvalues of A. -C = nonzero calculate eigenvalues and eigenvectors of A. -C -C INFO* INTEGER -C on return from SSIEV, the value of INFO is -C = 0 for normal return. -C = K if the eigenvalue iteration fails to converge. -C eigenvalues and vectors 1 through K-1 are correct. -C -C -C Error Messages- -C No. 1 recoverable N is greater than LDA -C No. 2 recoverable N is less than one -C -C***REFERENCES (NONE) -C***ROUTINES CALLED IMTQL2, TQLRAT, TRED1, TRED2, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800808 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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE SSIEV - INTEGER INFO,JOB,LDA,N - REAL A(LDA,*),E(*),WORK(*) -C***FIRST EXECUTABLE STATEMENT SSIEV - IF (N .GT. LDA) CALL XERMSG ('SLATEC', 'SSIEV', 'N .GT. LDA.', - + 1, 1) - IF(N .GT. LDA) RETURN - IF (N .LT. 1) CALL XERMSG ('SLATEC', 'SSIEV', 'N .LT. 1', 2, 1) - IF(N .LT. 1) RETURN -C -C CHECK N=1 CASE -C - E(1) = A(1,1) - INFO = 0 - IF(N .EQ. 1) RETURN -C -C COPY UPPER TRIANGLE TO LOWER -C - DO 10 J=1,N - DO 10 I=1,J - A(J,I)=A(I,J) - 10 CONTINUE -C - IF(JOB.NE.0) GO TO 20 -C -C EIGENVALUES ONLY -C - CALL TRED1(LDA,N,A,E,WORK(1),WORK(N+1)) - CALL TQLRAT(N,E,WORK(N+1),INFO) - RETURN -C -C EIGENVALUES AND EIGENVECTORS -C - 20 CALL TRED2(LDA,N,A,E,WORK,A) - CALL IMTQL2(LDA,N,E,WORK,A,INFO) - RETURN - END diff --git a/slatec/ssifa.f b/slatec/ssifa.f deleted file mode 100644 index 8711954..0000000 --- a/slatec/ssifa.f +++ /dev/null @@ -1,237 +0,0 @@ -*DECK SSIFA - SUBROUTINE SSIFA (A, LDA, N, KPVT, INFO) -C***BEGIN PROLOGUE SSIFA -C***PURPOSE Factor a real symmetric matrix by elimination with -C symmetric pivoting. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1A -C***TYPE SINGLE PRECISION (SSIFA-S, DSIFA-D, CHIFA-C, CSIFA-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, SYMMETRIC -C***AUTHOR Bunch, J., (UCSD) -C***DESCRIPTION -C -C SSIFA factors a real symmetric matrix by elimination -C with symmetric pivoting. -C -C To solve A*X = B , follow SSIFA by SSISL. -C To compute INVERSE(A)*C , follow SSIFA by SSISL. -C To compute DETERMINANT(A) , follow SSIFA by SSIDI. -C To compute INERTIA(A) , follow SSIFA by SSIDI. -C To compute INVERSE(A) , follow SSIFA by SSIDI. -C -C On Entry -C -C A REAL(LDA,N) -C the symmetric matrix to be factored. -C Only the diagonal and upper triangle are used. -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 a block diagonal matrix and the multipliers which -C were used to obtain it. -C The factorization can be written A = U*D*TRANS(U) -C where U is a product of permutation and unit -C upper triangular matrices , TRANS(U) is the -C transpose of U , and D is block diagonal -C with 1 by 1 and 2 by 2 blocks. -C -C KPVT INTEGER(N) -C an integer vector of pivot indices. -C -C INFO INTEGER -C = 0 normal value. -C = K if the K-th pivot block is singular. This is -C not an error condition for this subroutine, -C but it does indicate that SSISL or SSIDI may -C divide by zero if called. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED ISAMAX, SAXPY, SSWAP -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Modified routine equivalence list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SSIFA - INTEGER LDA,N,KPVT(*),INFO - REAL A(LDA,*) -C - REAL AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T - REAL ABSAKK,ALPHA,COLMAX,ROWMAX - INTEGER IMAX,IMAXP1,J,JJ,JMAX,K,KM1,KM2,KSTEP,ISAMAX - LOGICAL SWAP -C***FIRST EXECUTABLE STATEMENT SSIFA -C -C INITIALIZE -C -C ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE. -C - ALPHA = (1.0E0 + SQRT(17.0E0))/8.0E0 -C - INFO = 0 -C -C MAIN LOOP ON K, WHICH GOES FROM N TO 1. -C - K = N - 10 CONTINUE -C -C LEAVE THE LOOP IF K=0 OR K=1. -C - IF (K .EQ. 0) GO TO 200 - IF (K .GT. 1) GO TO 20 - KPVT(1) = 1 - IF (A(1,1) .EQ. 0.0E0) INFO = 1 - GO TO 200 - 20 CONTINUE -C -C THIS SECTION OF CODE DETERMINES THE KIND OF -C ELIMINATION TO BE PERFORMED. WHEN IT IS COMPLETED, -C KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND -C SWAP WILL BE SET TO .TRUE. IF AN INTERCHANGE IS -C REQUIRED. -C - KM1 = K - 1 - ABSAKK = ABS(A(K,K)) -C -C DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN -C COLUMN K. -C - IMAX = ISAMAX(K-1,A(1,K),1) - COLMAX = ABS(A(IMAX,K)) - IF (ABSAKK .LT. ALPHA*COLMAX) GO TO 30 - KSTEP = 1 - SWAP = .FALSE. - GO TO 90 - 30 CONTINUE -C -C DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN -C ROW IMAX. -C - ROWMAX = 0.0E0 - IMAXP1 = IMAX + 1 - DO 40 J = IMAXP1, K - ROWMAX = MAX(ROWMAX,ABS(A(IMAX,J))) - 40 CONTINUE - IF (IMAX .EQ. 1) GO TO 50 - JMAX = ISAMAX(IMAX-1,A(1,IMAX),1) - ROWMAX = MAX(ROWMAX,ABS(A(JMAX,IMAX))) - 50 CONTINUE - IF (ABS(A(IMAX,IMAX)) .LT. ALPHA*ROWMAX) GO TO 60 - KSTEP = 1 - SWAP = .TRUE. - GO TO 80 - 60 CONTINUE - IF (ABSAKK .LT. ALPHA*COLMAX*(COLMAX/ROWMAX)) GO TO 70 - KSTEP = 1 - SWAP = .FALSE. - GO TO 80 - 70 CONTINUE - KSTEP = 2 - SWAP = IMAX .NE. KM1 - 80 CONTINUE - 90 CONTINUE - IF (MAX(ABSAKK,COLMAX) .NE. 0.0E0) GO TO 100 -C -C COLUMN K IS ZERO. SET INFO AND ITERATE THE LOOP. -C - KPVT(K) = K - INFO = K - GO TO 190 - 100 CONTINUE - IF (KSTEP .EQ. 2) GO TO 140 -C -C 1 X 1 PIVOT BLOCK. -C - IF (.NOT.SWAP) GO TO 120 -C -C PERFORM AN INTERCHANGE. -C - CALL SSWAP(IMAX,A(1,IMAX),1,A(1,K),1) - DO 110 JJ = IMAX, K - J = K + IMAX - JJ - T = A(J,K) - A(J,K) = A(IMAX,J) - A(IMAX,J) = T - 110 CONTINUE - 120 CONTINUE -C -C PERFORM THE ELIMINATION. -C - DO 130 JJ = 1, KM1 - J = K - JJ - MULK = -A(J,K)/A(K,K) - T = MULK - CALL SAXPY(J,T,A(1,K),1,A(1,J),1) - A(J,K) = MULK - 130 CONTINUE -C -C SET THE PIVOT ARRAY. -C - KPVT(K) = K - IF (SWAP) KPVT(K) = IMAX - GO TO 190 - 140 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - IF (.NOT.SWAP) GO TO 160 -C -C PERFORM AN INTERCHANGE. -C - CALL SSWAP(IMAX,A(1,IMAX),1,A(1,K-1),1) - DO 150 JJ = IMAX, KM1 - J = KM1 + IMAX - JJ - T = A(J,K-1) - A(J,K-1) = A(IMAX,J) - A(IMAX,J) = T - 150 CONTINUE - T = A(K-1,K) - A(K-1,K) = A(IMAX,K) - A(IMAX,K) = T - 160 CONTINUE -C -C PERFORM THE ELIMINATION. -C - KM2 = K - 2 - IF (KM2 .EQ. 0) GO TO 180 - AK = A(K,K)/A(K-1,K) - AKM1 = A(K-1,K-1)/A(K-1,K) - DENOM = 1.0E0 - AK*AKM1 - DO 170 JJ = 1, KM2 - J = KM1 - JJ - BK = A(J,K)/A(K-1,K) - BKM1 = A(J,K-1)/A(K-1,K) - MULK = (AKM1*BK - BKM1)/DENOM - MULKM1 = (AK*BKM1 - BK)/DENOM - T = MULK - CALL SAXPY(J,T,A(1,K),1,A(1,J),1) - T = MULKM1 - CALL SAXPY(J,T,A(1,K-1),1,A(1,J),1) - A(J,K) = MULK - A(J,K-1) = MULKM1 - 170 CONTINUE - 180 CONTINUE -C -C SET THE PIVOT ARRAY. -C - KPVT(K) = 1 - K - IF (SWAP) KPVT(K) = -IMAX - KPVT(K-1) = KPVT(K) - 190 CONTINUE - K = K - KSTEP - GO TO 10 - 200 CONTINUE - RETURN - END diff --git a/slatec/ssilur.f b/slatec/ssilur.f deleted file mode 100644 index 38de428..0000000 --- a/slatec/ssilur.f +++ /dev/null @@ -1,305 +0,0 @@ -*DECK SSILUR - SUBROUTINE SSILUR (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, - + ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE SSILUR -C***PURPOSE Incomplete LU Iterative Refinement Sparse Ax = b Solver. -C Routine to solve a general linear system Ax = b using -C the incomplete LU decomposition with iterative refinement. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (SSILUR-S, DSILUR-D) -C***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+NU+4*N+2), LENIW -C REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(NL+NU+4*N) -C -C CALL SSILUR(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Real B(N). -C Right-hand side vector. -C X :INOUT Real X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Real A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /SSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Real. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Real. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*R1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. -C IERR = 7 => Incomplete factorization broke down and was -C fudged. Resulting preconditioning may be less -C than the best. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Real RWORK(LENW). -C Real array used for workspace. -C LENW :IN Integer. -C Length of the real workspace, RWORK. LENW >= NL+NU+4*N. -C NL is the number of non-zeros in the lower triangle of the -C matrix (including the diagonal). -C NU is the number of non-zeros in the upper triangle of the -C matrix (including the diagonal). -C IWORK :WORK Integer IWORK(LENIW). -C Integer array used for workspace. -C Upon return the following locations of IWORK hold information -C which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Real workspace actually used. -C LENIW :IN Integer. -C Length of integer workspace, IWORK. LENIW >= NL+NU+4*N+10. -C NL is the number of non-zeros in the lower triangle of the -C matrix (including the diagonal). -C NU is the number of non-zeros in the upper triangle of the -C matrix (including the diagonal). -C -C *Description -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to be -C the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO SSJAC, SSGS, SIR -C***REFERENCES (NONE) -C***ROUTINES CALLED SCHKW, SIR, SS2Y, SSILUS, SSLUI, SSMV -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 921019 Corrected NEL to NL. (FNF) -C***END PROLOGUE SSILUR -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - REAL ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT -C .. Array Arguments .. - REAL A(NELT), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER ICOL, J, JBGN, JEND, LOCDIN, LOCDZ, LOCIL, LOCIU, LOCIW, - + LOCJL, LOCJU, LOCL, LOCNC, LOCNR, LOCR, LOCU, LOCW, LOCZ, - + NL, NU -C .. External Subroutines .. - EXTERNAL SCHKW, SIR, SS2Y, SSILUS, SSLUI, SSMV -C***FIRST EXECUTABLE STATEMENT SSILUR -C - IERR = 0 - IF( N.LT.1 .OR. NELT.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Change the SLAP input matrix IA, JA, A to SLAP-Column format. - CALL SS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Count number of Non-Zero elements in preconditioner ILU -C matrix. Then set up the work arrays. - NL = 0 - NU = 0 - DO 20 ICOL = 1, N -C Don't count diagonal. - JBGN = JA(ICOL)+1 - JEND = JA(ICOL+1)-1 - IF( JBGN.LE.JEND ) THEN -CVD$ NOVECTOR - DO 10 J = JBGN, JEND - IF( IA(J).GT.ICOL ) THEN - NL = NL + 1 - IF( ISYM.NE.0 ) NU = NU + 1 - ELSE - NU = NU + 1 - ENDIF - 10 CONTINUE - ENDIF - 20 CONTINUE -C - LOCIL = LOCIB - LOCJL = LOCIL + N+1 - LOCIU = LOCJL + NL - LOCJU = LOCIU + NU - LOCNR = LOCJU + N+1 - LOCNC = LOCNR + N - LOCIW = LOCNC + N -C - LOCL = LOCRB - LOCDIN = LOCL + NL - LOCU = LOCDIN + N - LOCR = LOCU + NU - LOCZ = LOCR + N - LOCDZ = LOCZ + N - LOCW = LOCDZ + N -C -C Check the workspace allocations. - CALL SCHKW( 'SSILUR', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(1) = LOCIL - IWORK(2) = LOCJL - IWORK(3) = LOCIU - IWORK(4) = LOCJU - IWORK(5) = LOCL - IWORK(6) = LOCDIN - IWORK(7) = LOCU - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Compute the Incomplete LU decomposition. - CALL SSILUS( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIL), - $ IWORK(LOCJL), RWORK(LOCL), RWORK(LOCDIN), NU, IWORK(LOCIU), - $ IWORK(LOCJU), RWORK(LOCU), IWORK(LOCNR), IWORK(LOCNC) ) -C -C Do the Preconditioned Iterative Refinement iteration. - CALL SIR(N, B, X, NELT, IA, JA, A, ISYM, SSMV, SSLUI, - $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), - $ RWORK(LOCZ), RWORK(LOCDZ), RWORK, IWORK) - RETURN -C------------- LAST LINE OF SSILUR FOLLOWS ---------------------------- - END diff --git a/slatec/ssilus.f b/slatec/ssilus.f deleted file mode 100644 index e45d638..0000000 --- a/slatec/ssilus.f +++ /dev/null @@ -1,360 +0,0 @@ -*DECK SSILUS - SUBROUTINE SSILUS (N, NELT, IA, JA, A, ISYM, NL, IL, JL, L, DINV, - + NU, IU, JU, U, NROW, NCOL) -C***BEGIN PROLOGUE SSILUS -C***PURPOSE Incomplete LU Decomposition Preconditioner SLAP Set Up. -C Routine to generate the incomplete LDU decomposition of a -C matrix. The unit lower triangular factor L is stored by -C rows and the unit upper triangular factor U is stored by -C columns. The inverse of the diagonal matrix D is stored. -C No fill in is allowed. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE SINGLE PRECISION (SSILUS-S, DSILUS-D) -C***KEYWORDS INCOMPLETE LU FACTORIZATION, ITERATIVE PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM -C INTEGER NL, IL(NL), JL(NL), NU, IU(NU), JU(NU) -C INTEGER NROW(N), NCOL(N) -C REAL A(NELT), L(NL), DINV(N), U(NU) -C -C CALL SSILUS( N, NELT, IA, JA, A, ISYM, NL, IL, JL, L, -C $ DINV, NU, IU, JU, U, NROW, NCOL ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C NELT :IN Integer. -C Number of elements in arrays IA, JA, and A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Real A(NELT). -C These arrays should hold the matrix A in the SLAP Column -C format. See "Description", below. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the lower -C triangle of the matrix is stored. -C NL :OUT Integer. -C Number of non-zeros in the L array. -C IL :OUT Integer IL(NL). -C JL :OUT Integer JL(NL). -C L :OUT Real L(NL). -C IL, JL, L contain the unit lower triangular factor of the -C incomplete decomposition of some matrix stored in SLAP -C Row format. The Diagonal of ones *IS* stored. See -C "DESCRIPTION", below for more details about the SLAP format. -C NU :OUT Integer. -C Number of non-zeros in the U array. -C IU :OUT Integer IU(NU). -C JU :OUT Integer JU(NU). -C U :OUT Real U(NU). -C IU, JU, U contain the unit upper triangular factor of the -C incomplete decomposition of some matrix stored in SLAP -C Column format. The Diagonal of ones *IS* stored. See -C "Description", below for more details about the SLAP -C format. -C NROW :WORK Integer NROW(N). -C NROW(I) is the number of non-zero elements in the I-th row -C of L. -C NCOL :WORK Integer NCOL(N). -C NCOL(I) is the number of non-zero elements in the I-th -C column of U. -C -C *Description -C IL, JL, L should contain the unit lower triangular factor of -C the incomplete decomposition of the A matrix stored in SLAP -C Row format. IU, JU, U should contain the unit upper factor -C of the incomplete decomposition of the A matrix stored in -C SLAP Column format This ILU factorization can be computed by -C the SSILUS routine. The diagonals (which are all one's) are -C stored. -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C ==================== S L A P Row format ==================== -C -C This routine requires that the matrix A be stored in the -C SLAP Row format. In this format the non-zeros are stored -C counting across rows (except for the diagonal entry, which -C must appear first in each "row") and are stored in the real -C array A. In other words, for each row in the matrix put the -C diagonal entry in A. Then put in the other non-zero -C elements going across the row (except the diagonal) in -C order. The JA array holds the column index for each -C non-zero. The IA array holds the offsets into the JA, A -C arrays for the beginning of each row. That is, -C JA(IA(IROW)), A(IA(IROW)) points to the beginning of the -C IROW-th row in JA and A. JA(IA(IROW+1)-1), A(IA(IROW+1)-1) -C points to the end of the IROW-th row. Note that we always -C have IA(N+1) = NELT+1, where N is the number of rows in -C the matrix and NELT is the number of non-zeros in the -C matrix. -C -C Here is an example of the SLAP Row storage format for a 5x5 -C Matrix (in the A and JA arrays '|' denotes the end of a row): -C -C 5x5 Matrix SLAP Row format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 12 15 | 22 21 | 33 35 | 44 | 55 51 53 -C |21 22 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| IA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C***SEE ALSO SILUR -C***REFERENCES 1. Gene Golub and Charles Van Loan, Matrix Computations, -C Johns Hopkins University Press, Baltimore, Maryland, -C 1983. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of reference. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE SSILUS -C .. Scalar Arguments .. - INTEGER ISYM, N, NELT, NL, NU -C .. Array Arguments .. - REAL A(NELT), DINV(N), L(NL), U(NU) - INTEGER IA(NELT), IL(NL), IU(NU), JA(NELT), JL(NL), JU(NU), - + NCOL(N), NROW(N) -C .. Local Scalars .. - REAL TEMP - INTEGER I, IBGN, ICOL, IEND, INDX, INDX1, INDX2, INDXC1, INDXC2, - + INDXR1, INDXR2, IROW, ITEMP, J, JBGN, JEND, JTEMP, K, KC, - + KR -C***FIRST EXECUTABLE STATEMENT SSILUS -C -C Count number of elements in each row of the lower triangle. -C - DO 10 I=1,N - NROW(I) = 0 - NCOL(I) = 0 - 10 CONTINUE -CVD$R NOCONCUR -CVD$R NOVECTOR - DO 30 ICOL = 1, N - JBGN = JA(ICOL)+1 - JEND = JA(ICOL+1)-1 - IF( JBGN.LE.JEND ) THEN - DO 20 J = JBGN, JEND - IF( IA(J).LT.ICOL ) THEN - NCOL(ICOL) = NCOL(ICOL) + 1 - ELSE - NROW(IA(J)) = NROW(IA(J)) + 1 - IF( ISYM.NE.0 ) NCOL(IA(J)) = NCOL(IA(J)) + 1 - ENDIF - 20 CONTINUE - ENDIF - 30 CONTINUE - JU(1) = 1 - IL(1) = 1 - DO 40 ICOL = 1, N - IL(ICOL+1) = IL(ICOL) + NROW(ICOL) - JU(ICOL+1) = JU(ICOL) + NCOL(ICOL) - NROW(ICOL) = IL(ICOL) - NCOL(ICOL) = JU(ICOL) - 40 CONTINUE -C -C Copy the matrix A into the L and U structures. - DO 60 ICOL = 1, N - DINV(ICOL) = A(JA(ICOL)) - JBGN = JA(ICOL)+1 - JEND = JA(ICOL+1)-1 - IF( JBGN.LE.JEND ) THEN - DO 50 J = JBGN, JEND - IROW = IA(J) - IF( IROW.LT.ICOL ) THEN -C Part of the upper triangle. - IU(NCOL(ICOL)) = IROW - U(NCOL(ICOL)) = A(J) - NCOL(ICOL) = NCOL(ICOL) + 1 - ELSE -C Part of the lower triangle (stored by row). - JL(NROW(IROW)) = ICOL - L(NROW(IROW)) = A(J) - NROW(IROW) = NROW(IROW) + 1 - IF( ISYM.NE.0 ) THEN -C Symmetric...Copy lower triangle into upper triangle as well. - IU(NCOL(IROW)) = ICOL - U(NCOL(IROW)) = A(J) - NCOL(IROW) = NCOL(IROW) + 1 - ENDIF - ENDIF - 50 CONTINUE - ENDIF - 60 CONTINUE -C -C Sort the rows of L and the columns of U. - DO 110 K = 2, N - JBGN = JU(K) - JEND = JU(K+1)-1 - IF( JBGN.LT.JEND ) THEN - DO 80 J = JBGN, JEND-1 - DO 70 I = J+1, JEND - IF( IU(J).GT.IU(I) ) THEN - ITEMP = IU(J) - IU(J) = IU(I) - IU(I) = ITEMP - TEMP = U(J) - U(J) = U(I) - U(I) = TEMP - ENDIF - 70 CONTINUE - 80 CONTINUE - ENDIF - IBGN = IL(K) - IEND = IL(K+1)-1 - IF( IBGN.LT.IEND ) THEN - DO 100 I = IBGN, IEND-1 - DO 90 J = I+1, IEND - IF( JL(I).GT.JL(J) ) THEN - JTEMP = JU(I) - JU(I) = JU(J) - JU(J) = JTEMP - TEMP = L(I) - L(I) = L(J) - L(J) = TEMP - ENDIF - 90 CONTINUE - 100 CONTINUE - ENDIF - 110 CONTINUE -C -C Perform the incomplete LDU decomposition. - DO 300 I=2,N -C -C I-th row of L - INDX1 = IL(I) - INDX2 = IL(I+1) - 1 - IF(INDX1 .GT. INDX2) GO TO 200 - DO 190 INDX=INDX1,INDX2 - IF(INDX .EQ. INDX1) GO TO 180 - INDXR1 = INDX1 - INDXR2 = INDX - 1 - INDXC1 = JU(JL(INDX)) - INDXC2 = JU(JL(INDX)+1) - 1 - IF(INDXC1 .GT. INDXC2) GO TO 180 - 160 KR = JL(INDXR1) - 170 KC = IU(INDXC1) - IF(KR .GT. KC) THEN - INDXC1 = INDXC1 + 1 - IF(INDXC1 .LE. INDXC2) GO TO 170 - ELSEIF(KR .LT. KC) THEN - INDXR1 = INDXR1 + 1 - IF(INDXR1 .LE. INDXR2) GO TO 160 - ELSEIF(KR .EQ. KC) THEN - L(INDX) = L(INDX) - L(INDXR1)*DINV(KC)*U(INDXC1) - INDXR1 = INDXR1 + 1 - INDXC1 = INDXC1 + 1 - IF(INDXR1 .LE. INDXR2 .AND. INDXC1 .LE. INDXC2) GO TO 160 - ENDIF - 180 L(INDX) = L(INDX)/DINV(JL(INDX)) - 190 CONTINUE -C -C I-th column of U - 200 INDX1 = JU(I) - INDX2 = JU(I+1) - 1 - IF(INDX1 .GT. INDX2) GO TO 260 - DO 250 INDX=INDX1,INDX2 - IF(INDX .EQ. INDX1) GO TO 240 - INDXC1 = INDX1 - INDXC2 = INDX - 1 - INDXR1 = IL(IU(INDX)) - INDXR2 = IL(IU(INDX)+1) - 1 - IF(INDXR1 .GT. INDXR2) GO TO 240 - 210 KR = JL(INDXR1) - 220 KC = IU(INDXC1) - IF(KR .GT. KC) THEN - INDXC1 = INDXC1 + 1 - IF(INDXC1 .LE. INDXC2) GO TO 220 - ELSEIF(KR .LT. KC) THEN - INDXR1 = INDXR1 + 1 - IF(INDXR1 .LE. INDXR2) GO TO 210 - ELSEIF(KR .EQ. KC) THEN - U(INDX) = U(INDX) - L(INDXR1)*DINV(KC)*U(INDXC1) - INDXR1 = INDXR1 + 1 - INDXC1 = INDXC1 + 1 - IF(INDXR1 .LE. INDXR2 .AND. INDXC1 .LE. INDXC2) GO TO 210 - ENDIF - 240 U(INDX) = U(INDX)/DINV(IU(INDX)) - 250 CONTINUE -C -C I-th diagonal element - 260 INDXR1 = IL(I) - INDXR2 = IL(I+1) - 1 - IF(INDXR1 .GT. INDXR2) GO TO 300 - INDXC1 = JU(I) - INDXC2 = JU(I+1) - 1 - IF(INDXC1 .GT. INDXC2) GO TO 300 - 270 KR = JL(INDXR1) - 280 KC = IU(INDXC1) - IF(KR .GT. KC) THEN - INDXC1 = INDXC1 + 1 - IF(INDXC1 .LE. INDXC2) GO TO 280 - ELSEIF(KR .LT. KC) THEN - INDXR1 = INDXR1 + 1 - IF(INDXR1 .LE. INDXR2) GO TO 270 - ELSEIF(KR .EQ. KC) THEN - DINV(I) = DINV(I) - L(INDXR1)*DINV(KC)*U(INDXC1) - INDXR1 = INDXR1 + 1 - INDXC1 = INDXC1 + 1 - IF(INDXR1 .LE. INDXR2 .AND. INDXC1 .LE. INDXC2) GO TO 270 - ENDIF -C - 300 CONTINUE -C -C Replace diagonal elements by their inverses. -CVD$ VECTOR - DO 430 I=1,N - DINV(I) = 1.0E0/DINV(I) - 430 CONTINUE -C - RETURN -C------------- LAST LINE OF SSILUS FOLLOWS ---------------------------- - END diff --git a/slatec/ssisl.f b/slatec/ssisl.f deleted file mode 100644 index 6012e64..0000000 --- a/slatec/ssisl.f +++ /dev/null @@ -1,187 +0,0 @@ -*DECK SSISL - SUBROUTINE SSISL (A, LDA, N, KPVT, B) -C***BEGIN PROLOGUE SSISL -C***PURPOSE Solve a real symmetric system using the factors obtained -C from SSIFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1A -C***TYPE SINGLE PRECISION (SSISL-S, DSISL-D, CHISL-C, CSISL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE, SYMMETRIC -C***AUTHOR Bunch, J., (UCSD) -C***DESCRIPTION -C -C SSISL solves the real symmetric system -C A * X = B -C using the factors computed by SSIFA. -C -C On Entry -C -C A REAL(LDA,N) -C the output from SSIFA. -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 KPVT INTEGER(N) -C the pivot vector from SSIFA. -C -C B REAL(N) -C the right hand side vector. -C -C On Return -C -C B the solution vector X . -C -C Error Condition -C -C A division by zero may occur if SSICO has set RCOND .EQ. 0.0 -C or SSIFA has set INFO .NE. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL SSIFA(A,LDA,N,KPVT,INFO) -C IF (INFO .NE. 0) GO TO ... -C DO 10 J = 1, P -C CALL SSISL(A,LDA,N,KPVT,C(1,J)) -C 10 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SAXPY, SDOT -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Modified routine equivalence list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SSISL - INTEGER LDA,N,KPVT(*) - REAL A(LDA,*),B(*) -C - REAL AK,AKM1,BK,BKM1,SDOT,DENOM,TEMP - INTEGER K,KP -C -C LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND -C D INVERSE TO B. -C -C***FIRST EXECUTABLE STATEMENT SSISL - K = N - 10 IF (K .EQ. 0) GO TO 80 - IF (KPVT(K) .LT. 0) GO TO 40 -C -C 1 X 1 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 30 - KP = KPVT(K) - IF (KP .EQ. K) GO TO 20 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 20 CONTINUE -C -C APPLY THE TRANSFORMATION. -C - CALL SAXPY(K-1,B(K),A(1,K),1,B(1),1) - 30 CONTINUE -C -C APPLY D INVERSE. -C - B(K) = B(K)/A(K,K) - K = K - 1 - GO TO 70 - 40 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - IF (K .EQ. 2) GO TO 60 - KP = ABS(KPVT(K)) - IF (KP .EQ. K - 1) GO TO 50 -C -C INTERCHANGE. -C - TEMP = B(K-1) - B(K-1) = B(KP) - B(KP) = TEMP - 50 CONTINUE -C -C APPLY THE TRANSFORMATION. -C - CALL SAXPY(K-2,B(K),A(1,K),1,B(1),1) - CALL SAXPY(K-2,B(K-1),A(1,K-1),1,B(1),1) - 60 CONTINUE -C -C APPLY D INVERSE. -C - AK = A(K,K)/A(K-1,K) - AKM1 = A(K-1,K-1)/A(K-1,K) - BK = B(K)/A(K-1,K) - BKM1 = B(K-1)/A(K-1,K) - DENOM = AK*AKM1 - 1.0E0 - B(K) = (AKM1*BK - BKM1)/DENOM - B(K-1) = (AK*BKM1 - BK)/DENOM - K = K - 2 - 70 CONTINUE - GO TO 10 - 80 CONTINUE -C -C LOOP FORWARD APPLYING THE TRANSFORMATIONS. -C - K = 1 - 90 IF (K .GT. N) GO TO 160 - IF (KPVT(K) .LT. 0) GO TO 120 -C -C 1 X 1 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 110 -C -C APPLY THE TRANSFORMATION. -C - B(K) = B(K) + SDOT(K-1,A(1,K),1,B(1),1) - KP = KPVT(K) - IF (KP .EQ. K) GO TO 100 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 100 CONTINUE - 110 CONTINUE - K = K + 1 - GO TO 150 - 120 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 140 -C -C APPLY THE TRANSFORMATION. -C - B(K) = B(K) + SDOT(K-1,A(1,K),1,B(1),1) - B(K+1) = B(K+1) + SDOT(K-1,A(1,K+1),1,B(1),1) - KP = ABS(KPVT(K)) - IF (KP .EQ. K) GO TO 130 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 130 CONTINUE - 140 CONTINUE - K = K + 2 - 150 CONTINUE - GO TO 90 - 160 CONTINUE - RETURN - END diff --git a/slatec/ssjac.f b/slatec/ssjac.f deleted file mode 100644 index 1600e88..0000000 --- a/slatec/ssjac.f +++ /dev/null @@ -1,263 +0,0 @@ -*DECK SSJAC - SUBROUTINE SSJAC (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, - + ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE SSJAC -C***PURPOSE Jacobi's Method Iterative Sparse Ax = b Solver. -C Routine to solve a general linear system Ax = b using -C Jacobi iteration. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (SSJAC-S, DSJAC-D) -C***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LENW, IWORK(LENIW), LENIW -C REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(LENW) -C -C CALL SSJAC(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Real B(N). -C Right-hand side vector. -C X :INOUT Real X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Real A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /SSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Real. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Real. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*R1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Real RWORK(LENW). -C Real array used for workspace. -C LENW :IN Integer. -C Length of the real workspace, RWORK. LENW >= 4*N. -C IWORK :WORK Integer IWORK(LENIW). -C Used to hold pointers into the real workspace, RWORK. -C Upon return the following locations of IWORK hold information -C which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Real workspace actually used. -C LENIW :IN Integer. -C Length of the integer workspace, IWORK. LENIW >= 10. -C -C *Description: -C Jacobi's method solves the linear system Ax=b with the -C basic iterative method (where A = L + D + U): -C -C n+1 -1 n n -C X = D (B - LX - UX ) -C -C n -1 n -C = X + D (B - AX ) -C -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which one -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to be -C the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO SSGS, SIR -C***REFERENCES (NONE) -C***ROUTINES CALLED SCHKW, SIR, SS2Y, SSDI, SSDS, SSMV -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910506 Corrected error in C***ROUTINES CALLED list. (FNF) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C***END PROLOGUE SSJAC -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - REAL ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT -C .. Array Arguments .. - REAL A(NELT), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER LOCD, LOCDZ, LOCIW, LOCR, LOCW, LOCZ -C .. External Subroutines .. - EXTERNAL SCHKW, SIR, SS2Y, SSDI, SSDS, SSMV -C***FIRST EXECUTABLE STATEMENT SSJAC -C - IERR = 0 - IF( N.LT.1 .OR. NELT.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF - LOCIW = LOCIB - LOCD = LOCRB - LOCR = LOCD + N - LOCZ = LOCR + N - LOCDZ = LOCZ + N - LOCW = LOCDZ + N -C -C Check the workspace allocations. - CALL SCHKW( 'SSJAC', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(4) = LOCD - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Convert to SLAP column format. - CALL SS2Y(N, NELT, IA, JA, A, ISYM ) -C -C Compute the inverse of the diagonal of the matrix. This -C will be used as the preconditioner. - CALL SSDS(N, NELT, IA, JA, A, ISYM, RWORK(LOCD)) -C -C Set up the work array and perform the iterative refinement. - CALL SIR(N, B, X, NELT, IA, JA, A, ISYM, SSMV, SSDI, ITOL, TOL, - $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), RWORK(LOCZ), - $ RWORK(LOCDZ), RWORK, IWORK ) - RETURN -C------------- LAST LINE OF SSJAC FOLLOWS ----------------------------- - END diff --git a/slatec/ssli.f b/slatec/ssli.f deleted file mode 100644 index 4634a44..0000000 --- a/slatec/ssli.f +++ /dev/null @@ -1,61 +0,0 @@ -*DECK SSLI - SUBROUTINE SSLI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C***BEGIN PROLOGUE SSLI -C***PURPOSE SLAP MSOLVE for Lower Triangle Matrix. -C This routine acts as an interface between the SLAP generic -C MSOLVE calling convention and the routine that actually -C -1 -C computes L B = X. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A3 -C***TYPE SINGLE PRECISION (SSLI-S, DSLI-D) -C***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM SOLVE, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C It is assumed that RWORK and IWORK have initialized with -C the information required for SSLI2: -C IWORK(1) = NEL -C IWORK(2) = Starting location of IEL in IWORK. -C IWORK(3) = Starting location of JEL in IWORK. -C IWORK(4) = Starting location of EL in RWORK. -C See the DESCRIPTION of SSLI2 for details. -C***REFERENCES (NONE) -C***ROUTINES CALLED SSLI2 -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE SSLI -C .. Scalar Arguments .. - INTEGER ISYM, N, NELT -C .. Array Arguments .. - REAL A(NELT), B(N), RWORK(*), X(N) - INTEGER IA(NELT), IWORK(10), JA(NELT) -C .. Local Scalars .. - INTEGER LOCEL, LOCIEL, LOCJEL, NEL -C .. External Subroutines .. - EXTERNAL SSLI2 -C***FIRST EXECUTABLE STATEMENT SSLI -C - NEL = IWORK(1) - LOCIEL = IWORK(2) - LOCJEL = IWORK(3) - LOCEL = IWORK(4) - CALL SSLI2(N, B, X, NEL, IWORK(LOCIEL), IWORK(LOCJEL), - $ RWORK(LOCEL)) -C - RETURN -C------------- LAST LINE OF SSLI FOLLOWS ---------------------------- - END diff --git a/slatec/ssli2.f b/slatec/ssli2.f deleted file mode 100644 index f6d1e54..0000000 --- a/slatec/ssli2.f +++ /dev/null @@ -1,139 +0,0 @@ -*DECK SSLI2 - SUBROUTINE SSLI2 (N, B, X, NEL, IEL, JEL, EL) -C***BEGIN PROLOGUE SSLI2 -C***PURPOSE SLAP Lower Triangle Matrix Backsolve. -C Routine to solve a system of the form Lx = b , where L -C is a lower triangular matrix. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A3 -C***TYPE SINGLE PRECISION (SSLI2-S, DSLI2-D) -C***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM SOLVE, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NEL, IEL(NEL), JEL(NEL) -C REAL B(N), X(N), EL(NEL) -C -C CALL SSLI2( N, B, X, NEL, IEL, JEL, EL ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Real B(N). -C Right hand side vector. -C X :OUT Real X(N). -C Solution to Lx = b. -C NEL :IN Integer. -C Number of non-zeros in the EL array. -C IEL :IN Integer IEL(NEL). -C JEL :IN Integer JEL(NEL). -C EL :IN Real EL(NEL). -C IEL, JEL, EL contain the unit lower triangular factor of -C the incomplete decomposition of the A matrix stored in -C SLAP Row format. The diagonal of ones *IS* stored. This -C structure can be set up by the SS2LT routine. See the -C "Description", below, for more details about the SLAP Row -C format. -C -C *Description: -C This routine is supplied with the SLAP package as a routine -C to perform the MSOLVE operation in the SIR iteration routine -C for the driver routine SSGS. It must be called via the SLAP -C MSOLVE calling sequence convention interface routine SSLI. -C **** THIS ROUTINE ITSELF DOES NOT CONFORM TO THE **** -C **** SLAP MSOLVE CALLING CONVENTION **** -C -C ==================== S L A P Row format ==================== -C -C This routine requires that the matrix A be stored in the -C SLAP Row format. In this format the non-zeros are stored -C counting across rows (except for the diagonal entry, which -C must appear first in each "row") and are stored in the real -C array A. In other words, for each row in the matrix put the -C diagonal entry in A. Then put in the other non-zero -C elements going across the row (except the diagonal) in -C order. The JA array holds the column index for each -C non-zero. The IA array holds the offsets into the JA, A -C arrays for the beginning of each row. That is, -C JA(IA(IROW)), A(IA(IROW)) points to the beginning of the -C IROW-th row in JA and A. JA(IA(IROW+1)-1), A(IA(IROW+1)-1) -C points to the end of the IROW-th row. Note that we always -C have IA(N+1) = NELT+1, where N is the number of rows in -C the matrix and NELT is the number of non-zeros in the -C matrix. -C -C Here is an example of the SLAP Row storage format for a 5x5 -C Matrix (in the A and JA arrays '|' denotes the end of a row): -C -C 5x5 Matrix SLAP Row format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 12 15 | 22 21 | 33 35 | 44 | 55 51 53 -C |21 22 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| IA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C With the SLAP Row format the "inner loop" of this routine -C should vectorize on machines with hardware support for -C vector gather/scatter operations. Your compiler may require -C a compiler directive to convince it that there are no -C implicit vector dependencies. Compiler directives for the -C Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied -C with the standard SLAP distribution. -C -C***SEE ALSO SSLI -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE SSLI2 -C .. Scalar Arguments .. - INTEGER N, NEL -C .. Array Arguments .. - REAL B(N), EL(NEL), X(N) - INTEGER IEL(NEL), JEL(NEL) -C .. Local Scalars .. - INTEGER I, ICOL, J, JBGN, JEND -C***FIRST EXECUTABLE STATEMENT SSLI2 -C -C Initialize the solution by copying the right hands side -C into it. -C - DO 10 I=1,N - X(I) = B(I) - 10 CONTINUE -C -CVD$ NOCONCUR - DO 30 ICOL = 1, N - X(ICOL) = X(ICOL)/EL(JEL(ICOL)) - JBGN = JEL(ICOL) + 1 - JEND = JEL(ICOL+1) - 1 - IF( JBGN.LE.JEND ) THEN -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ NOCONCUR -CVD$ NODEPCHK - DO 20 J = JBGN, JEND - X(IEL(J)) = X(IEL(J)) - EL(J)*X(ICOL) - 20 CONTINUE - ENDIF - 30 CONTINUE -C - RETURN -C------------- LAST LINE OF SSLI2 FOLLOWS ---------------------------- - END diff --git a/slatec/ssllti.f b/slatec/ssllti.f deleted file mode 100644 index a0f2b3a..0000000 --- a/slatec/ssllti.f +++ /dev/null @@ -1,63 +0,0 @@ -*DECK SSLLTI - SUBROUTINE SSLLTI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C***BEGIN PROLOGUE SSLLTI -C***PURPOSE SLAP MSOLVE for LDL' (IC) Factorization. -C This routine acts as an interface between the SLAP generic -C MSOLVE calling convention and the routine that actually -C -1 -C computes (LDL') B = X. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE SINGLE PRECISION (SSLLTI-S, DSLLTI-D) -C***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM SOLVE, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C It is assumed that RWORK and IWORK have initialized with -C the information required for SLLTI2: -C IWORK(1) = NEL -C IWORK(2) = Starting location of IEL in IWORK. -C IWORK(3) = Starting location of JEL in IWORK. -C IWORK(4) = Starting location of EL in RWORK. -C IWORK(5) = Starting location of DINV in RWORK. -C See the DESCRIPTION of SLLTI2 for details. -C***REFERENCES (NONE) -C***ROUTINES CALLED SLLTI2 -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Corrected conversion error. (FNF) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE SSLLTI -C .. Scalar Arguments .. - INTEGER ISYM, N, NELT -C .. Array Arguments .. - REAL A(NELT), B(*), RWORK(*), X(*) - INTEGER IA(NELT), IWORK(*), JA(NELT) -C .. Local Scalars .. - INTEGER LOCDIN, LOCEL, LOCIEL, LOCJEL, NEL -C .. External Subroutines .. - EXTERNAL SLLTI2 -C***FIRST EXECUTABLE STATEMENT SSLLTI - NEL = IWORK(1) - LOCIEL = IWORK(3) - LOCJEL = IWORK(2) - LOCEL = IWORK(4) - LOCDIN = IWORK(5) - CALL SLLTI2(N, B, X, NEL, IWORK(LOCIEL), IWORK(LOCJEL), - $ RWORK(LOCEL), RWORK(LOCDIN)) -C - RETURN -C------------- LAST LINE OF SSLLTI FOLLOWS ---------------------------- - END diff --git a/slatec/sslubc.f b/slatec/sslubc.f deleted file mode 100644 index fbec1e0..0000000 --- a/slatec/sslubc.f +++ /dev/null @@ -1,321 +0,0 @@ -*DECK SSLUBC - SUBROUTINE SSLUBC (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, - + ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE SSLUBC -C***PURPOSE Incomplete LU BiConjugate Gradient Sparse Ax=b Solver. -C Routine to solve a linear system Ax = b using the -C BiConjugate Gradient method with Incomplete LU -C decomposition preconditioning. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (SSLUBC-S, DSLUBC-D) -C***KEYWORDS ITERATIVE INCOMPLETE LU PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+NU+4*N+2), LENIW -C REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(NL+NU+8*N) -C -C CALL SSLUBC(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Real B(N). -C Right-hand side vector. -C X :INOUT Real X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Real A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /SSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Real. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Real. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*R1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. -C IERR = 7 => Incomplete factorization broke down and was -C fudged. Resulting preconditioning may be less -C than the best. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Real RWORK(LENW). -C Real array used for workspace. -C LENW :IN Integer. -C Length of the real workspace, RWORK. LENW >= NL+NU+8*N. -C NL is the number of non-zeros in the lower triangle of the -C matrix (including the diagonal). -C NU is the number of non-zeros in the upper triangle of the -C matrix (including the diagonal). -C IWORK :WORK Integer IWORK(LENIW). -C Integer array used for workspace. -C Upon return the following locations of IWORK hold information -C which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Real workspace actually used. -C LENIW :IN Integer. -C Length of the integer workspace, IWORK. -C LENIW >= NL+NU+4*N+12. -C NL is the number of non-zeros in the lower triangle of the -C matrix (including the diagonal). -C NU is the number of non-zeros in the upper triangle of the -C matrix (including the diagonal). -C -C *Description: -C This routine is simply a driver for the SBCGN routine. It -C calls the SSILUS routine to set up the preconditioning and -C then calls SBCGN with the appropriate MATVEC, MTTVEC and -C MSOLVE, MTSOLV routines. -C -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to -C be the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO SBCG, SSDBCG -C***REFERENCES (NONE) -C***ROUTINES CALLED SBCG, SCHKW, SS2Y, SSILUS, SSLUI, SSLUTI, SSMTV, -C SSMV -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE SSLUBC -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - REAL ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT -C .. Array Arguments .. - REAL A(NELT), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER ICOL, J, JBGN, JEND, LOCDIN, LOCDZ, LOCIL, LOCIU, LOCIW, - + LOCJL, LOCJU, LOCL, LOCNC, LOCNR, LOCP, LOCPP, LOCR, - + LOCRR, LOCU, LOCW, LOCZ, LOCZZ, NL, NU -C .. External Subroutines .. - EXTERNAL SBCG, SCHKW, SS2Y, SSILUS, SSLUI, SSLUTI, SSMTV, SSMV -C***FIRST EXECUTABLE STATEMENT SSLUBC -C - IERR = 0 - IF( N.LT.1 .OR. NELT.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Change the SLAP input matrix IA, JA, A to SLAP-Column format. - CALL SS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Count number of Non-Zero elements preconditioner ILU matrix. -C Then set up the work arrays. - NL = 0 - NU = 0 - DO 20 ICOL = 1, N -C Don't count diagonal. - JBGN = JA(ICOL)+1 - JEND = JA(ICOL+1)-1 - IF( JBGN.LE.JEND ) THEN -CVD$ NOVECTOR - DO 10 J = JBGN, JEND - IF( IA(J).GT.ICOL ) THEN - NL = NL + 1 - IF( ISYM.NE.0 ) NU = NU + 1 - ELSE - NU = NU + 1 - ENDIF - 10 CONTINUE - ENDIF - 20 CONTINUE -C - LOCIL = LOCIB - LOCJL = LOCIL + N+1 - LOCIU = LOCJL + NL - LOCJU = LOCIU + NU - LOCNR = LOCJU + N+1 - LOCNC = LOCNR + N - LOCIW = LOCNC + N -C - LOCL = LOCRB - LOCDIN = LOCL + NL - LOCU = LOCDIN + N - LOCR = LOCU + NU - LOCZ = LOCR + N - LOCP = LOCZ + N - LOCRR = LOCP + N - LOCZZ = LOCRR + N - LOCPP = LOCZZ + N - LOCDZ = LOCPP + N - LOCW = LOCDZ + N -C -C Check the workspace allocations. - CALL SCHKW( 'SSLUBC', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(1) = LOCIL - IWORK(2) = LOCJL - IWORK(3) = LOCIU - IWORK(4) = LOCJU - IWORK(5) = LOCL - IWORK(6) = LOCDIN - IWORK(7) = LOCU - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Compute the Incomplete LU decomposition. - CALL SSILUS( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIL), - $ IWORK(LOCJL), RWORK(LOCL), RWORK(LOCDIN), NU, IWORK(LOCIU), - $ IWORK(LOCJU), RWORK(LOCU), IWORK(LOCNR), IWORK(LOCNC) ) -C -C Perform the incomplete LU preconditioned -C BiConjugate Gradient algorithm. - CALL SBCG(N, B, X, NELT, IA, JA, A, ISYM, SSMV, SSMTV, - $ SSLUI, SSLUTI, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, - $ RWORK(LOCR), RWORK(LOCZ), RWORK(LOCP), - $ RWORK(LOCRR), RWORK(LOCZZ), RWORK(LOCPP), - $ RWORK(LOCDZ), RWORK, IWORK ) - RETURN -C------------- LAST LINE OF SSLUBC FOLLOWS ---------------------------- - END diff --git a/slatec/sslucn.f b/slatec/sslucn.f deleted file mode 100644 index 37216d1..0000000 --- a/slatec/sslucn.f +++ /dev/null @@ -1,320 +0,0 @@ -*DECK SSLUCN - SUBROUTINE SSLUCN (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, - + ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE SSLUCN -C***PURPOSE Incomplete LU CG Sparse Ax=b Solver for Normal Equations. -C Routine to solve a general linear system Ax = b using the -C incomplete LU decomposition with the Conjugate Gradient -C method applied to the normal equations, viz., AA'y = b, -C x = A'y. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (SSLUCN-S, DSLUCN-D) -C***KEYWORDS ITERATIVE INCOMPLETE LU PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+NU+4*N+2), LENIW -C REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(NL+NU+8*N) -C -C CALL SSLUCN(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Real B(N). -C Right-hand side vector. -C X :INOUT Real X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Real A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /SSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Real. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Real. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*R1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. -C IERR = 7 => Incomplete factorization broke down and was -C fudged. Resulting preconditioning may be less -C than the best. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Real RWORK(LENW). -C Real array used for workspace. -C LENW :IN Integer. -C Length of the real workspace, RWORK. LENW >= NL+NU+8*N. -C NL is the number of non-zeros in the lower triangle of the -C matrix (including the diagonal). -C NU is the number of non-zeros in the upper triangle of the -C matrix (including the diagonal). -C IWORK :WORK Integer IWORK(LENIW). -C Integer array used for workspace. -C Upon return the following locations of IWORK hold information -C which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Real workspace actually used. -C LENIW :IN Integer. -C Length of the integer workspace, IWORK. -C LENIW >= NL+NU+4*N+12. -C NL is the number of non-zeros in the lower triangle of the -C matrix (including the diagonal). -C NU is the number of non-zeros in the upper triangle of the -C matrix (including the diagonal). -C -C *Description: -C This routine is simply a driver for the SCGN routine. It -C calls the SSILUS routine to set up the preconditioning and then -C calls SCGN with the appropriate MATVEC and MSOLVE routines. -C -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to be -C the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO SCGN, SDCGN, SSILUS -C***REFERENCES (NONE) -C***ROUTINES CALLED SCGN, SCHKW, SS2Y, SSILUS, SSMMTI, SSMTV, SSMV -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE SSLUCN -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - REAL ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT -C .. Array Arguments .. - REAL A(NELT), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER ICOL, J, JBGN, JEND, LOCATD, LOCATP, LOCATZ, LOCDIN, - + LOCDZ, LOCIL, LOCIU, LOCIW, LOCJL, LOCJU, LOCL, LOCNC, - + LOCNR, LOCP, LOCR, LOCU, LOCW, LOCZ, NL, NU -C .. External Subroutines .. - EXTERNAL SCGN, SCHKW, SS2Y, SSILUS, SSMMTI, SSMTV, SSMV -C***FIRST EXECUTABLE STATEMENT SSLUCN -C - IERR = 0 - IF( N.LT.1 .OR. NELT.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Change the SLAP input matrix IA, JA, A to SLAP-Column format. - CALL SS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Count number of Non-Zero elements preconditioner ILU matrix. -C Then set up the work arrays. - NL = 0 - NU = 0 - DO 20 ICOL = 1, N -C Don't count diagonal. - JBGN = JA(ICOL)+1 - JEND = JA(ICOL+1)-1 - IF( JBGN.LE.JEND ) THEN -CVD$ NOVECTOR - DO 10 J = JBGN, JEND - IF( IA(J).GT.ICOL ) THEN - NL = NL + 1 - IF( ISYM.NE.0 ) NU = NU + 1 - ELSE - NU = NU + 1 - ENDIF - 10 CONTINUE - ENDIF - 20 CONTINUE -C - LOCIL = LOCIB - LOCJL = LOCIL + N+1 - LOCIU = LOCJL + NL - LOCJU = LOCIU + NU - LOCNR = LOCJU + N+1 - LOCNC = LOCNR + N - LOCIW = LOCNC + N -C - LOCL = LOCRB - LOCDIN = LOCL + NL - LOCU = LOCDIN + N - LOCR = LOCU + NU - LOCZ = LOCR + N - LOCP = LOCZ + N - LOCATP = LOCP + N - LOCATZ = LOCATP + N - LOCDZ = LOCATZ + N - LOCATD = LOCDZ + N - LOCW = LOCATD + N -C -C Check the workspace allocations. - CALL SCHKW( 'SSLUCN', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(1) = LOCIL - IWORK(2) = LOCJL - IWORK(3) = LOCIU - IWORK(4) = LOCJU - IWORK(5) = LOCL - IWORK(6) = LOCDIN - IWORK(7) = LOCU - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Compute the Incomplete LU decomposition. - CALL SSILUS( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIL), - $ IWORK(LOCJL), RWORK(LOCL), RWORK(LOCDIN), NU, IWORK(LOCIU), - $ IWORK(LOCJU), RWORK(LOCU), IWORK(LOCNR), IWORK(LOCNC) ) -C -C Perform Conjugate Gradient algorithm on the normal equations. - CALL SCGN(N, B, X, NELT, IA, JA, A, ISYM, SSMV, SSMTV, SSMMTI, - $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), - $ RWORK(LOCZ), RWORK(LOCP), RWORK(LOCATP), RWORK(LOCATZ), - $ RWORK(LOCDZ), RWORK(LOCATD), RWORK, IWORK ) -C - IF( ITER.GT.ITMAX ) IERR = 2 - RETURN -C------------- LAST LINE OF SSLUCN FOLLOWS ---------------------------- - END diff --git a/slatec/sslucs.f b/slatec/sslucs.f deleted file mode 100644 index 5b0820a..0000000 --- a/slatec/sslucs.f +++ /dev/null @@ -1,315 +0,0 @@ -*DECK SSLUCS - SUBROUTINE SSLUCS (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, - + ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE SSLUCS -C***PURPOSE Incomplete LU BiConjugate Gradient Squared Ax=b Solver. -C Routine to solve a linear system Ax = b using the -C BiConjugate Gradient Squared method with Incomplete LU -C decomposition preconditioning. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (SSLUCS-S, DSLUCS-D) -C***KEYWORDS ITERATIVE INCOMPLETE LU PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+NU+4*N+2), LENIW -C REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(NL+NU+8*N) -C -C CALL SSLUCS(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Real B(N). -C Right-hand side vector. -C X :INOUT Real X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Real A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C This routine must calculate the residual from R = A*X - B. -C This is unnatural and hence expensive for this type of iter- -C ative method. ITOL=2 is *STRONGLY* recommended. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv time a vector is the pre- -C conditioning step. This is the *NATURAL* stopping for this -C iterative method and is *STRONGLY* recommended. -C TOL :INOUT Real. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Real. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*R1MACH(3). Iteration proceeded. -C IERR = 5 => Breakdown of the method detected. -C (r0,r) approximately 0. -C IERR = 6 => Stagnation of the method detected. -C (r0,v) approximately 0. -C IERR = 7 => Incomplete factorization broke down and was -C fudged. Resulting preconditioning may be less -C than the best. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Real RWORK(LENW). -C Real array used for workspace. NL is the number of non- -C zeros in the lower triangle of the matrix (including the -C diagonal). NU is the number of non-zeros in the upper -C triangle of the matrix (including the diagonal). -C LENW :IN Integer. -C Length of the real workspace, RWORK. LENW >= NL+NU+8*N. -C IWORK :WORK Integer IWORK(LENIW). -C Integer array used for workspace. NL is the number of non- -C zeros in the lower triangle of the matrix (including the -C diagonal). NU is the number of non-zeros in the upper -C triangle of the matrix (including the diagonal). -C Upon return the following locations of IWORK hold information -C which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Real workspace actually used. -C LENIW :IN Integer. -C Length of the integer workspace, IWORK. -C LENIW >= NL+NU+4*N+12. -C -C *Description: -C This routine is simply a driver for the SCGSN routine. It -C calls the SSILUS routine to set up the preconditioning and -C then calls SCGSN with the appropriate MATVEC, MTTVEC and -C MSOLVE, MTSOLV routines. -C -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to -C be the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO SCGS, SSDCGS -C***REFERENCES 1. P. Sonneveld, CGS, a fast Lanczos-type solver -C for nonsymmetric linear systems, Delft University -C of Technology Report 84-16, Department of Mathe- -C matics and Informatics, Delft, The Netherlands. -C 2. E. F. Kaasschieter, The solution of non-symmetric -C linear systems by biconjugate gradients or conjugate -C gradients squared, Delft University of Technology -C Report 86-21, Department of Mathematics and Informa- -C tics, Delft, The Netherlands. -C***ROUTINES CALLED SCGS, SCHKW, SS2Y, SSILUS, SSLUI, SSMV -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of references. (FNF) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE SSLUCS -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - REAL ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT -C .. Array Arguments .. - REAL A(NELT), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER ICOL, J, JBGN, JEND, LOCDIN, LOCIL, LOCIU, LOCIW, LOCJL, - + LOCJU, LOCL, LOCNC, LOCNR, LOCP, LOCQ, LOCR, LOCR0, LOCU, - + LOCUU, LOCV1, LOCV2, LOCW, NL, NU -C .. External Subroutines .. - EXTERNAL SCGS, SCHKW, SS2Y, SSILUS, SSLUI, SSMV -C***FIRST EXECUTABLE STATEMENT SSLUCS -C - IERR = 0 - IF( N.LT.1 .OR. NELT.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Change the SLAP input matrix IA, JA, A to SLAP-Column format. - CALL SS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Count number of Non-Zero elements preconditioner ILU matrix. -C Then set up the work arrays. - NL = 0 - NU = 0 - DO 20 ICOL = 1, N -C Don't count diagonal. - JBGN = JA(ICOL)+1 - JEND = JA(ICOL+1)-1 - IF( JBGN.LE.JEND ) THEN -CVD$ NOVECTOR - DO 10 J = JBGN, JEND - IF( IA(J).GT.ICOL ) THEN - NL = NL + 1 - IF( ISYM.NE.0 ) NU = NU + 1 - ELSE - NU = NU + 1 - ENDIF - 10 CONTINUE - ENDIF - 20 CONTINUE -C - LOCIL = LOCIB - LOCJL = LOCIL + N+1 - LOCIU = LOCJL + NL - LOCJU = LOCIU + NU - LOCNR = LOCJU + N+1 - LOCNC = LOCNR + N - LOCIW = LOCNC + N -C - LOCL = LOCRB - LOCDIN = LOCL + NL - LOCUU = LOCDIN + N - LOCR = LOCUU + NU - LOCR0 = LOCR + N - LOCP = LOCR0 + N - LOCQ = LOCP + N - LOCU = LOCQ + N - LOCV1 = LOCU + N - LOCV2 = LOCV1 + N - LOCW = LOCV2 + N -C -C Check the workspace allocations. - CALL SCHKW( 'SSLUCS', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(1) = LOCIL - IWORK(2) = LOCJL - IWORK(3) = LOCIU - IWORK(4) = LOCJU - IWORK(5) = LOCL - IWORK(6) = LOCDIN - IWORK(7) = LOCUU - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Compute the Incomplete LU decomposition. - CALL SSILUS( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIL), - $ IWORK(LOCJL), RWORK(LOCL), RWORK(LOCDIN), NU, IWORK(LOCIU), - $ IWORK(LOCJU), RWORK(LOCUU), IWORK(LOCNR), IWORK(LOCNC) ) -C -C Perform the incomplete LU preconditioned -C BiConjugate Gradient Squared algorithm. - CALL SCGS(N, B, X, NELT, IA, JA, A, ISYM, SSMV, - $ SSLUI, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, - $ RWORK(LOCR), RWORK(LOCR0), RWORK(LOCP), - $ RWORK(LOCQ), RWORK(LOCU), RWORK(LOCV1), - $ RWORK(LOCV2), RWORK, IWORK ) - RETURN -C------------- LAST LINE OF SSLUCS FOLLOWS ---------------------------- - END diff --git a/slatec/sslugm.f b/slatec/sslugm.f deleted file mode 100644 index 6832fb7..0000000 --- a/slatec/sslugm.f +++ /dev/null @@ -1,430 +0,0 @@ -*DECK SSLUGM - SUBROUTINE SSLUGM (N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ITOL, - + TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE SSLUGM -C***PURPOSE Incomplete LU GMRES Iterative Sparse Ax=b Solver. -C This routine uses the generalized minimum residual -C (GMRES) method with incomplete LU factorization for -C preconditioning to solve possibly non-symmetric linear -C systems of the form: Ax = b. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (SSLUGM-S, DSLUGM-D) -C***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov -C Hindmarsh, Alan, (LLNL), alanh@llnl.gov -C Seager, Mark K., (LLNL), seager@llnl.gov -C Lawrence Livermore National Laboratory -C PO Box 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NSAVE, ITOL -C INTEGER ITMAX, ITER, IERR, IUNIT, LENW, IWORK(LENIW), LENIW -C REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(LENW) -C -C CALL SSLUGM(N, B, X, NELT, IA, JA, A, ISYM, NSAVE, -C $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, -C $ RWORK, LENW, IWORK, LENIW) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C B :IN Real B(N). -C Right-hand side vector. -C X :INOUT Real X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Real A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C NSAVE :IN Integer. -C Number of direction vectors to save and orthogonalize against. -C Must be greater than 1. -C ITOL :IN Integer. -C Flag to indicate the type of convergence criterion used. -C ITOL=0 Means the iteration stops when the test described -C below on the residual RL is satisfied. This is -C the "Natural Stopping Criteria" for this routine. -C Other values of ITOL cause extra, otherwise -C unnecessary, computation per iteration and are -C therefore much less efficient. See ISSGMR (the -C stop test routine) for more information. -C ITOL=1 Means the iteration stops when the first test -C described below on the residual RL is satisfied, -C and there is either right or no preconditioning -C being used. -C ITOL=2 Implies that the user is using left -C preconditioning, and the second stopping criterion -C below is used. -C ITOL=3 Means the iteration stops when the third test -C described below on Minv*Residual is satisfied, and -C there is either left or no preconditioning begin -C used. -C ITOL=11 is often useful for checking and comparing -C different routines. For this case, the user must -C supply the "exact" solution or a very accurate -C approximation (one with an error much less than -C TOL) through a common block, -C COMMON /SSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the -C difference between the iterative approximation and -C the user-supplied solution divided by the 2-norm -C of the user-supplied solution is less than TOL. -C Note that this requires the user to set up the -C "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling -C routine. The routine with this declaration should -C be loaded before the stop test so that the correct -C length is used by the loader. This procedure is -C not standard Fortran and may not work correctly on -C your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 -C then this common block is indeed standard Fortran. -C TOL :INOUT Real. -C Convergence criterion, as described below. If TOL is set -C to zero on input, then a default value of 500*(the smallest -C positive magnitude, machine epsilon) is used. -C ITMAX :IN Integer. -C Maximum number of iterations. This routine uses the default -C of NRMAX = ITMAX/NSAVE to determine the when each restart -C should occur. See the description of NRMAX and MAXL in -C SGMRES for a full and frightfully interesting discussion of -C this topic. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Real. -C Error estimate of error in final approximate solution, as -C defined by ITOL. Letting norm() denote the Euclidean -C norm, ERR is defined as follows... -C If ITOL=0, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), -C for right or no preconditioning, and -C ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ -C norm(SB*(M-inverse)*B), -C for left preconditioning. -C If ITOL=1, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), -C since right or no preconditioning -C being used. -C If ITOL=2, then ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ -C norm(SB*(M-inverse)*B), -C since left preconditioning is being -C used. -C If ITOL=3, then ERR = Max |(Minv*(B-A*X(L)))(i)/x(i)| -C i=1,n -C If ITOL=11, then ERR = norm(SB*(X(L)-SOLN))/norm(SB*SOLN). -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient storage allocated for -C RGWK or IGWK. -C IERR = 2 => Routine SPIGMR failed to reduce the norm -C of the current residual on its last call, -C and so the iteration has stalled. In -C this case, X equals the last computed -C approximation. The user must either -C increase MAXL, or choose a different -C initial guess. -C IERR =-1 => Insufficient length for RGWK array. -C IGWK(6) contains the required minimum -C length of the RGWK array. -C IERR =-2 => Inconsistent ITOL and JPRE values. -C For IERR <= 2, RGWK(1) = RHOL, which is the norm on the -C left-hand-side of the relevant stopping test defined -C below associated with the residual for the current -C approximation X(L). -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Real RWORK(LENW). -C Real array of size LENW. -C LENW :IN Integer. -C Length of the real workspace, RWORK. -C LENW >= 1 + N*(NSAVE+7) + NSAVE*(NSAVE+3)+NL+NU. -C Here NL is the number of non-zeros in the lower triangle of -C the matrix (including the diagonal) and NU is the number of -C non-zeros in the upper triangle of the matrix (including the -C diagonal). -C For the recommended values, RWORK has size at least -C 131 + 17*N + NL + NU. -C IWORK :INOUT Integer IWORK(LENIW). -C Used to hold pointers into the RWORK array. -C Upon return the following locations of IWORK hold information -C which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Real workspace actually used. -C LENIW :IN Integer. -C Length of the integer workspace, IWORK. -C LENIW >= NL+NU+4*N+32. -C -C *Description: -C SSLUGM solves a linear system A*X = B rewritten in the form: -C -C (SB*A*(M-inverse)*(SX-inverse))*(SX*M*X) = SB*B, -C -C with right preconditioning, or -C -C (SB*(M-inverse)*A*(SX-inverse))*(SX*X) = SB*(M-inverse)*B, -C -C with left preconditioning, where A is an n-by-n real matrix, -C X and B are N-vectors, SB and SX are diagonal scaling -C matrices, and M is the Incomplete LU factorization of A. It -C uses preconditioned Krylov subpace methods based on the -C generalized minimum residual method (GMRES). This routine -C is a driver routine which assumes a SLAP matrix data -C structure and sets up the necessary information to do -C diagonal preconditioning and calls the main GMRES routine -C SGMRES for the solution of the linear system. SGMRES -C optionally performs either the full orthogonalization -C version of the GMRES algorithm or an incomplete variant of -C it. Both versions use restarting of the linear iteration by -C default, although the user can disable this feature. -C -C The GMRES algorithm generates a sequence of approximations -C X(L) to the true solution of the above linear system. The -C convergence criteria for stopping the iteration is based on -C the size of the scaled norm of the residual R(L) = B - -C A*X(L). The actual stopping test is either: -C -C norm(SB*(B-A*X(L))) .le. TOL*norm(SB*B), -C -C for right preconditioning, or -C -C norm(SB*(M-inverse)*(B-A*X(L))) .le. -C TOL*norm(SB*(M-inverse)*B), -C -C for left preconditioning, where norm() denotes the Euclidean -C norm, and TOL is a positive scalar less than one input by -C the user. If TOL equals zero when SSLUGM is called, then a -C default value of 500*(the smallest positive magnitude, -C machine epsilon) is used. If the scaling arrays SB and SX -C are used, then ideally they should be chosen so that the -C vectors SX*X(or SX*M*X) and SB*B have all their components -C approximately equal to one in magnitude. If one wants to -C use the same scaling in X and B, then SB and SX can be the -C same array in the calling program. -C -C The following is a list of the other routines and their -C functions used by GMRES: -C SGMRES Contains the matrix structure independent driver -C routine for GMRES. -C SPIGMR Contains the main iteration loop for GMRES. -C SORTH Orthogonalizes a new vector against older basis vectors. -C SHEQR Computes a QR decomposition of a Hessenberg matrix. -C SHELS Solves a Hessenberg least-squares system, using QR -C factors. -C RLCALC Computes the scaled residual RL. -C XLCALC Computes the solution XL. -C ISSGMR User-replaceable stopping routine. -C -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to be -C the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***REFERENCES 1. Peter N. Brown and A. C. Hindmarsh, Reduced Storage -C Matrix Methods in Stiff ODE Systems, Lawrence Liver- -C more National Laboratory Report UCRL-95088, Rev. 1, -C Livermore, California, June 1987. -C***ROUTINES CALLED SCHKW, SGMRES, SS2Y, SSILUS, SSLUI, SSMV -C***REVISION HISTORY (YYMMDD) -C 880615 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 920929 Corrected format of references. (FNF) -C 921019 Corrected NEL to NL. (FNF) -C***END PROLOGUE SSLUGM -C The following is for optimized compilation on LLNL/LTSS Crays. -CLLL. OPTIMIZE -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - REAL ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, - + NELT, NSAVE -C .. Array Arguments .. - REAL A(NELT), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER ICOL, J, JBGN, JEND, LOCDIN, LOCIGW, LOCIL, LOCIU, LOCIW, - + LOCJL, LOCJU, LOCL, LOCNC, LOCNR, LOCRGW, LOCU, LOCW, - + MYITOL, NL, NU -C .. External Subroutines .. - EXTERNAL SCHKW, SGMRES, SS2Y, SSILUS, SSLUI, SSMV -C***FIRST EXECUTABLE STATEMENT SSLUGM -C - IERR = 0 - ERR = 0 - IF( NSAVE.LE.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Change the SLAP input matrix IA, JA, A to SLAP-Column format. - CALL SS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Count number of Non-Zero elements preconditioner ILU matrix. -C Then set up the work arrays. We assume MAXL=KMP=NSAVE. - NL = 0 - NU = 0 - DO 20 ICOL = 1, N -C Don't count diagonal. - JBGN = JA(ICOL)+1 - JEND = JA(ICOL+1)-1 - IF( JBGN.LE.JEND ) THEN -CVD$ NOVECTOR - DO 10 J = JBGN, JEND - IF( IA(J).GT.ICOL ) THEN - NL = NL + 1 - IF( ISYM.NE.0 ) NU = NU + 1 - ELSE - NU = NU + 1 - ENDIF - 10 CONTINUE - ENDIF - 20 CONTINUE -C - LOCIGW = LOCIB - LOCIL = LOCIGW + 20 - LOCJL = LOCIL + N+1 - LOCIU = LOCJL + NL - LOCJU = LOCIU + NU - LOCNR = LOCJU + N+1 - LOCNC = LOCNR + N - LOCIW = LOCNC + N -C - LOCL = LOCRB - LOCDIN = LOCL + NL - LOCU = LOCDIN + N - LOCRGW = LOCU + NU - LOCW = LOCRGW + 1+N*(NSAVE+6)+NSAVE*(NSAVE+3) -C -C Check the workspace allocations. - CALL SCHKW( 'SSLUGM', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(1) = LOCIL - IWORK(2) = LOCJL - IWORK(3) = LOCIU - IWORK(4) = LOCJU - IWORK(5) = LOCL - IWORK(6) = LOCDIN - IWORK(7) = LOCU - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Compute the Incomplete LU decomposition. - CALL SSILUS( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIL), - $ IWORK(LOCJL), RWORK(LOCL), RWORK(LOCDIN), NU, IWORK(LOCIU), - $ IWORK(LOCJU), RWORK(LOCU), IWORK(LOCNR), IWORK(LOCNC) ) -C -C Perform the Incomplete LU Preconditioned Generalized Minimum -C Residual iteration algorithm. The following SGMRES -C defaults are used MAXL = KMP = NSAVE, JSCAL = 0, -C JPRE = -1, NRMAX = ITMAX/NSAVE - IWORK(LOCIGW ) = NSAVE - IWORK(LOCIGW+1) = NSAVE - IWORK(LOCIGW+2) = 0 - IWORK(LOCIGW+3) = -1 - IWORK(LOCIGW+4) = ITMAX/NSAVE - MYITOL = 0 -C - CALL SGMRES( N, B, X, NELT, IA, JA, A, ISYM, SSMV, SSLUI, - $ MYITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, RWORK, - $ RWORK(LOCRGW), LENW-LOCRGW, IWORK(LOCIGW), 20, - $ RWORK, IWORK ) -C - IF( ITER.GT.ITMAX ) IERR = 2 - RETURN -C------------- LAST LINE OF SSLUGM FOLLOWS ---------------------------- - END diff --git a/slatec/sslui.f b/slatec/sslui.f deleted file mode 100644 index a9ca23b..0000000 --- a/slatec/sslui.f +++ /dev/null @@ -1,73 +0,0 @@ -*DECK SSLUI - SUBROUTINE SSLUI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C***BEGIN PROLOGUE SSLUI -C***PURPOSE SLAP MSOLVE for LDU Factorization. -C This routine acts as an interface between the SLAP generic -C MSOLVE calling convention and the routine that actually -C -1 -C computes (LDU) B = X. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE SINGLE PRECISION (SSLUI-S, DSLUI-D) -C***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM SOLVE, -C SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C It is assumed that RWORK and IWORK have initialized with -C the information required for SSLUI2: -C IWORK(1) = Starting location of IL in IWORK. -C IWORK(2) = Starting location of JL in IWORK. -C IWORK(3) = Starting location of IU in IWORK. -C IWORK(4) = Starting location of JU in IWORK. -C IWORK(5) = Starting location of L in RWORK. -C IWORK(6) = Starting location of DINV in RWORK. -C IWORK(7) = Starting location of U in RWORK. -C See the DESCRIPTION of SSLUI2 for details. -C***REFERENCES (NONE) -C***ROUTINES CALLED SSLUI2 -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE SSLUI -C .. Scalar Arguments .. - INTEGER ISYM, N, NELT -C .. Array Arguments .. - REAL A(NELT), B(N), RWORK(*), X(N) - INTEGER IA(NELT), IWORK(10), JA(NELT) -C .. Local Scalars .. - INTEGER LOCDIN, LOCIL, LOCIU, LOCJL, LOCJU, LOCL, LOCU -C .. External Subroutines .. - EXTERNAL SSLUI2 -C***FIRST EXECUTABLE STATEMENT SSLUI -C -C Pull out the locations of the arrays holding the ILU -C factorization. -C - LOCIL = IWORK(1) - LOCJL = IWORK(2) - LOCIU = IWORK(3) - LOCJU = IWORK(4) - LOCL = IWORK(5) - LOCDIN = IWORK(6) - LOCU = IWORK(7) -C -C Solve the system LUx = b - CALL SSLUI2(N, B, X, IWORK(LOCIL), IWORK(LOCJL), RWORK(LOCL), - $ RWORK(LOCDIN), IWORK(LOCIU), IWORK(LOCJU), RWORK(LOCU) ) -C - RETURN -C------------- LAST LINE OF SSLUI FOLLOWS ---------------------------- - END diff --git a/slatec/sslui2.f b/slatec/sslui2.f deleted file mode 100644 index 66776e6..0000000 --- a/slatec/sslui2.f +++ /dev/null @@ -1,204 +0,0 @@ -*DECK SSLUI2 - SUBROUTINE SSLUI2 (N, B, X, IL, JL, L, DINV, IU, JU, U) -C***BEGIN PROLOGUE SSLUI2 -C***PURPOSE SLAP Backsolve for LDU Factorization. -C Routine to solve a system of the form L*D*U X = B, -C where L is a unit lower triangular matrix, D is a diagonal -C matrix, and U is a unit upper triangular matrix. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE SINGLE PRECISION (SSLUI2-S, DSLUI2-D) -C***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM SOLVE, -C SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, IL(NL), JL(NL), IU(NU), JU(NU) -C REAL B(N), X(N), L(NL), DINV(N), U(NU) -C -C CALL SSLUI2( N, B, X, IL, JL, L, DINV, IU, JU, U ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Real B(N). -C Right hand side. -C X :OUT Real X(N). -C Solution of L*D*U x = b. -C IL :IN Integer IL(NL). -C JL :IN Integer JL(NL). -C L :IN Real L(NL). -C IL, JL, L contain the unit lower triangular factor of the -C incomplete decomposition of some matrix stored in SLAP Row -C format. The diagonal of ones *IS* stored. This structure -C can be set up by the SSILUS routine. See the -C "Description", below for more details about the SLAP -C format. (NL is the number of non-zeros in the L array.) -C DINV :IN Real DINV(N). -C Inverse of the diagonal matrix D. -C IU :IN Integer IU(NU). -C JU :IN Integer JU(NU). -C U :IN Real U(NU). -C IU, JU, U contain the unit upper triangular factor of the -C incomplete decomposition of some matrix stored in SLAP -C Column format. The diagonal of ones *IS* stored. This -C structure can be set up by the SSILUS routine. See the -C "Description", below for more details about the SLAP -C format. (NU is the number of non-zeros in the U array.) -C -C *Description: -C This routine is supplied with the SLAP package as a routine -C to perform the MSOLVE operation in the SIR and SBCG -C iteration routines for the drivers SSILUR and SSLUBC. It -C must be called via the SLAP MSOLVE calling sequence -C convention interface routine SSLUI. -C **** THIS ROUTINE ITSELF DOES NOT CONFORM TO THE **** -C **** SLAP MSOLVE CALLING CONVENTION **** -C -C IL, JL, L should contain the unit lower triangular factor of -C the incomplete decomposition of the A matrix stored in SLAP -C Row format. IU, JU, U should contain the unit upper factor -C of the incomplete decomposition of the A matrix stored in -C SLAP Column format This ILU factorization can be computed by -C the SSILUS routine. The diagonals (which are all one's) are -C stored. -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C ==================== S L A P Row format ==================== -C -C This routine requires that the matrix A be stored in the -C SLAP Row format. In this format the non-zeros are stored -C counting across rows (except for the diagonal entry, which -C must appear first in each "row") and are stored in the real -C array A. In other words, for each row in the matrix put the -C diagonal entry in A. Then put in the other non-zero -C elements going across the row (except the diagonal) in -C order. The JA array holds the column index for each -C non-zero. The IA array holds the offsets into the JA, A -C arrays for the beginning of each row. That is, -C JA(IA(IROW)), A(IA(IROW)) points to the beginning of the -C IROW-th row in JA and A. JA(IA(IROW+1)-1), A(IA(IROW+1)-1) -C points to the end of the IROW-th row. Note that we always -C have IA(N+1) = NELT+1, where N is the number of rows in -C the matrix and NELT is the number of non-zeros in the -C matrix. -C -C Here is an example of the SLAP Row storage format for a 5x5 -C Matrix (in the A and JA arrays '|' denotes the end of a row): -C -C 5x5 Matrix SLAP Row format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 12 15 | 22 21 | 33 35 | 44 | 55 51 53 -C |21 22 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| IA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C With the SLAP format the "inner loops" of this routine -C should vectorize on machines with hardware support for -C vector gather/scatter operations. Your compiler may require -C a compiler directive to convince it that there are no -C implicit vector dependencies. Compiler directives for the -C Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied -C with the standard SLAP distribution. -C -C***SEE ALSO SSILUS -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE SSLUI2 -C .. Scalar Arguments .. - INTEGER N -C .. Array Arguments .. - REAL B(N), DINV(N), L(*), U(*), X(N) - INTEGER IL(*), IU(*), JL(*), JU(*) -C .. Local Scalars .. - INTEGER I, ICOL, IROW, J, JBGN, JEND -C***FIRST EXECUTABLE STATEMENT SSLUI2 -C -C Solve L*Y = B, storing result in X, L stored by rows. -C - DO 10 I = 1, N - X(I) = B(I) - 10 CONTINUE - DO 30 IROW = 2, N - JBGN = IL(IROW) - JEND = IL(IROW+1)-1 - IF( JBGN.LE.JEND ) THEN -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ ASSOC -CVD$ NODEPCHK - DO 20 J = JBGN, JEND - X(IROW) = X(IROW) - L(J)*X(JL(J)) - 20 CONTINUE - ENDIF - 30 CONTINUE -C -C Solve D*Z = Y, storing result in X. - DO 40 I=1,N - X(I) = X(I)*DINV(I) - 40 CONTINUE -C -C Solve U*X = Z, U stored by columns. - DO 60 ICOL = N, 2, -1 - JBGN = JU(ICOL) - JEND = JU(ICOL+1)-1 - IF( JBGN.LE.JEND ) THEN -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ NODEPCHK - DO 50 J = JBGN, JEND - X(IU(J)) = X(IU(J)) - U(J)*X(ICOL) - 50 CONTINUE - ENDIF - 60 CONTINUE -C - RETURN -C------------- LAST LINE OF SSLUI2 FOLLOWS ---------------------------- - END diff --git a/slatec/sslui4.f b/slatec/sslui4.f deleted file mode 100644 index f87353f..0000000 --- a/slatec/sslui4.f +++ /dev/null @@ -1,203 +0,0 @@ -*DECK SSLUI4 - SUBROUTINE SSLUI4 (N, B, X, IL, JL, L, DINV, IU, JU, U) -C***BEGIN PROLOGUE SSLUI4 -C***PURPOSE SLAP Backsolve for LDU Factorization. -C Routine to solve a system of the form (L*D*U)' X = B, -C where L is a unit lower triangular matrix, D is a diagonal -C matrix, and U is a unit upper triangular matrix and ' -C denotes transpose. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE SINGLE PRECISION (SSLUI4-S, DSLUI4-D) -C***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM SOLVE, -C SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, IL(NL), JL(NL), IU(NU), JU(NU) -C REAL B(N), X(N), L(NL), DINV(N), U(NU) -C -C CALL SSLUI4( N, B, X, IL, JL, L, DINV, IU, JU, U ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Real B(N). -C Right hand side. -C X :OUT Real X(N). -C Solution of (L*D*U)trans x = b. -C IL :IN Integer IL(NL). -C JL :IN Integer JL(NL). -C L :IN Real L(NL). -C IL, JL, L contain the unit lower triangular factor of the -C incomplete decomposition of some matrix stored in SLAP Row -C format. The diagonal of ones *IS* stored. This structure -C can be set up by the SSILUS routine. See the -C "Description", below for more details about the SLAP -C format. (NL is the number of non-zeros in the L array.) -C DINV :IN Real DINV(N). -C Inverse of the diagonal matrix D. -C IU :IN Integer IU(NU). -C JU :IN Integer JU(NU). -C U :IN Real U(NU). -C IU, JU, U contain the unit upper triangular factor of the -C incomplete decomposition of some matrix stored in SLAP -C Column format. The diagonal of ones *IS* stored. This -C structure can be set up by the SSILUS routine. See the -C "Description", below for more details about the SLAP -C format. (NU is the number of non-zeros in the U array.) -C -C *Description: -C This routine is supplied with the SLAP package as a routine -C to perform the MTSOLV operation in the SBCG iteration -C routine for the driver SSLUBC. It must be called via the -C SLAP MTSOLV calling sequence convention interface routine -C SSLUTI. -C **** THIS ROUTINE ITSELF DOES NOT CONFORM TO THE **** -C **** SLAP MSOLVE CALLING CONVENTION **** -C -C IL, JL, L should contain the unit lower triangular factor of -C the incomplete decomposition of the A matrix stored in SLAP -C Row format. IU, JU, U should contain the unit upper factor -C of the incomplete decomposition of the A matrix stored in -C SLAP Column format This ILU factorization can be computed by -C the SSILUS routine. The diagonals (which are all one's) are -C stored. -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C ==================== S L A P Row format ==================== -C -C This routine requires that the matrix A be stored in the -C SLAP Row format. In this format the non-zeros are stored -C counting across rows (except for the diagonal entry, which -C must appear first in each "row") and are stored in the real -C array A. In other words, for each row in the matrix put the -C diagonal entry in A. Then put in the other non-zero -C elements going across the row (except the diagonal) in -C order. The JA array holds the column index for each -C non-zero. The IA array holds the offsets into the JA, A -C arrays for the beginning of each row. That is, -C JA(IA(IROW)), A(IA(IROW)) points to the beginning of the -C IROW-th row in JA and A. JA(IA(IROW+1)-1), A(IA(IROW+1)-1) -C points to the end of the IROW-th row. Note that we always -C have IA(N+1) = NELT+1, where N is the number of rows in -C the matrix and NELT is the number of non-zeros in the -C matrix. -C -C Here is an example of the SLAP Row storage format for a 5x5 -C Matrix (in the A and JA arrays '|' denotes the end of a row): -C -C 5x5 Matrix SLAP Row format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 12 15 | 22 21 | 33 35 | 44 | 55 51 53 -C |21 22 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| IA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C With the SLAP format the "inner loops" of this routine -C should vectorize on machines with hardware support for -C vector gather/scatter operations. Your compiler may require -C a compiler directive to convince it that there are no -C implicit vector dependencies. Compiler directives for the -C Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied -C with the standard SLAP distribution. -C -C***SEE ALSO SSILUS -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE SSLUI4 -C .. Scalar Arguments .. - INTEGER N -C .. Array Arguments .. - REAL B(N), DINV(N), L(*), U(*), X(N) - INTEGER IL(*), IU(*), JL(*), JU(*) -C .. Local Scalars .. - INTEGER I, ICOL, IROW, J, JBGN, JEND -C***FIRST EXECUTABLE STATEMENT SSLUI4 - DO 10 I=1,N - X(I) = B(I) - 10 CONTINUE -C -C Solve U'*Y = X, storing result in X, U stored by columns. - DO 80 IROW = 2, N - JBGN = JU(IROW) - JEND = JU(IROW+1) - 1 - IF( JBGN.LE.JEND ) THEN -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ ASSOC -CVD$ NODEPCHK - DO 70 J = JBGN, JEND - X(IROW) = X(IROW) - U(J)*X(IU(J)) - 70 CONTINUE - ENDIF - 80 CONTINUE -C -C Solve D*Z = Y, storing result in X. - DO 90 I = 1, N - X(I) = X(I)*DINV(I) - 90 CONTINUE -C -C Solve L'*X = Z, L stored by rows. - DO 110 ICOL = N, 2, -1 - JBGN = IL(ICOL) - JEND = IL(ICOL+1) - 1 - IF( JBGN.LE.JEND ) THEN -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ NODEPCHK - DO 100 J = JBGN, JEND - X(JL(J)) = X(JL(J)) - L(J)*X(ICOL) - 100 CONTINUE - ENDIF - 110 CONTINUE - RETURN -C------------- LAST LINE OF SSLUI4 FOLLOWS ---------------------------- - END diff --git a/slatec/ssluom.f b/slatec/ssluom.f deleted file mode 100644 index b6fade1..0000000 --- a/slatec/ssluom.f +++ /dev/null @@ -1,322 +0,0 @@ -*DECK SSLUOM - SUBROUTINE SSLUOM (N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ITOL, - + TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) -C***BEGIN PROLOGUE SSLUOM -C***PURPOSE Incomplete LU Orthomin Sparse Iterative Ax=b Solver. -C Routine to solve a general linear system Ax = b using -C the Orthomin method with Incomplete LU decomposition. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (SSLUOM-S, DSLUOM-D) -C***KEYWORDS ITERATIVE INCOMPLETE LU PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NSAVE, ITOL, ITMAX -C INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+NU+4*N+2), LENIW -C REAL B(N), X(N), A(NELT), TOL, ERR -C REAL RWORK(NL+NU+7*N+3*N*NSAVE+NSAVE) -C -C CALL SSLUOM(N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ITOL, TOL, -C $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) -C -C *Arguments: -C N :IN Integer. -C Order of the matrix. -C B :IN Real B(N). -C Right-hand side vector. -C X :INOUT Real X(N). -C On input X is your initial guess for solution vector. -C On output X is the final approximate solution. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :INOUT Integer IA(NELT). -C JA :INOUT Integer JA(NELT). -C A :INOUT Real A(NELT). -C These arrays should hold the matrix A in either the SLAP -C Triad format or the SLAP Column format. See "Description", -C below. If the SLAP Triad format is chosen, it is changed -C internally to the SLAP Column format. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C NSAVE :IN Integer. -C Number of direction vectors to save and orthogonalize against. -C ITOL :IN Integer. -C Flag to indicate type of convergence criterion. -C If ITOL=1, iteration stops when the 2-norm of the residual -C divided by the 2-norm of the right-hand side is less than TOL. -C If ITOL=2, iteration stops when the 2-norm of M-inv times the -C residual divided by the 2-norm of M-inv times the right hand -C side is less than TOL, where M-inv is the inverse of the -C diagonal of A. -C ITOL=11 is often useful for checking and comparing different -C routines. For this case, the user must supply the "exact" -C solution or a very accurate approximation (one with an error -C much less than TOL) through a common block, -C COMMON /SSLBLK/ SOLN( ) -C If ITOL=11, iteration stops when the 2-norm of the difference -C between the iterative approximation and the user-supplied -C solution divided by the 2-norm of the user-supplied solution -C is less than TOL. Note that this requires the user to set up -C the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. -C The routine with this declaration should be loaded before the -C stop test so that the correct length is used by the loader. -C This procedure is not standard Fortran and may not work -C correctly on your system (although it has worked on every -C system the authors have tried). If ITOL is not 11 then this -C common block is indeed standard Fortran. -C TOL :INOUT Real. -C Convergence criterion, as described above. (Reset if IERR=4.) -C ITMAX :IN Integer. -C Maximum number of iterations. -C ITER :OUT Integer. -C Number of iterations required to reach convergence, or -C ITMAX+1 if convergence criterion could not be achieved in -C ITMAX iterations. -C ERR :OUT Real. -C Error estimate of error in final approximate solution, as -C defined by ITOL. -C IERR :OUT Integer. -C Return error flag. -C IERR = 0 => All went well. -C IERR = 1 => Insufficient space allocated for WORK or IWORK. -C IERR = 2 => Method failed to converge in ITMAX steps. -C IERR = 3 => Error in user input. -C Check input values of N, ITOL. -C IERR = 4 => User error tolerance set too tight. -C Reset to 500*R1MACH(3). Iteration proceeded. -C IERR = 5 => Preconditioning matrix, M, is not positive -C definite. (r,z) < 0. -C IERR = 6 => Breakdown of the method detected. -C (p,Ap) < epsilon**2. -C IERR = 7 => Incomplete factorization broke down and was -C fudged. Resulting preconditioning may be less -C than the best. -C IUNIT :IN Integer. -C Unit number on which to write the error at each iteration, -C if this is desired for monitoring convergence. If unit -C number is 0, no writing will occur. -C RWORK :WORK Real RWORK(LENW). -C Real array used for workspace. NL is the number of non- -C zeros in the lower triangle of the matrix (including the -C diagonal). NU is the number of non-zeros in the upper -C triangle of the matrix (including the diagonal). -C LENW :IN Integer. -C Length of the real workspace, RWORK. -C LENW >= NL+NU+4*N+NSAVE*(3*N+1) -C IWORK :WORK Integer IWORK(LENIW) -C Integer array used for workspace. NL is the number of non- -C zeros in the lower triangle of the matrix (including the -C diagonal). NU is the number of non-zeros in the upper -C triangle of the matrix (including the diagonal). -C Upon return the following locations of IWORK hold information -C which may be of use to the user: -C IWORK(9) Amount of Integer workspace actually used. -C IWORK(10) Amount of Real workspace actually used. -C LENIW :IN Integer. -C Length of the integer workspace, IWORK. -C LENIW >= NL+NU+4*N+12. -C -C *Description: -C This routine is simply a driver for the SOMN routine. It -C calls the SSILUS routine to set up the preconditioning and -C then calls SOMN with the appropriate MATVEC and MSOLVE -C routines. -C -C The Sparse Linear Algebra Package (SLAP) utilizes two matrix -C data structures: 1) the SLAP Triad format or 2) the SLAP -C Column format. The user can hand this routine either of the -C of these data structures and SLAP will figure out which on -C is being used and act accordingly. -C -C =================== S L A P Triad format =================== -C -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Side Effects: -C The SLAP Triad format (IA, JA, A) is modified internally to -C be the SLAP Column format. See above. -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C -C***SEE ALSO SOMN, SSDOMN -C***REFERENCES (NONE) -C***ROUTINES CALLED SCHKW, SOMN, SS2Y, SSILUS, SSLUI, SSMV -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890921 Removed TeX from comments. (FNF) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920407 COMMON BLOCK renamed SSLBLK. (WRB) -C 920511 Added complete declaration section. (WRB) -C 921019 Corrected NEL to NL. (FNF) -C 921113 Corrected C***CATEGORY line. (FNF) -C***END PROLOGUE SSLUOM -C .. Parameters .. - INTEGER LOCRB, LOCIB - PARAMETER (LOCRB=1, LOCIB=11) -C .. Scalar Arguments .. - REAL ERR, TOL - INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, - + NELT, NSAVE -C .. Array Arguments .. - REAL A(N), B(N), RWORK(LENW), X(N) - INTEGER IA(NELT), IWORK(LENIW), JA(NELT) -C .. Local Scalars .. - INTEGER ICOL, J, JBGN, JEND, LOCAP, LOCCSA, LOCDIN, LOCDZ, LOCEMA, - + LOCIL, LOCIU, LOCIW, LOCJL, LOCJU, LOCL, LOCNC, LOCNR, - + LOCP, LOCR, LOCU, LOCW, LOCZ, NL, NU -C .. External Subroutines .. - EXTERNAL SCHKW, SOMN, SS2Y, SSILUS, SSLUI, SSMV -C***FIRST EXECUTABLE STATEMENT SSLUOM -C - IERR = 0 - IF( N.LT.1 .OR. NELT.LT.1 ) THEN - IERR = 3 - RETURN - ENDIF -C -C Change the SLAP input matrix IA, JA, A to SLAP-Column format. - CALL SS2Y( N, NELT, IA, JA, A, ISYM ) -C -C Count number of Non-Zero elements preconditioner ILU matrix. -C Then set up the work arrays. - NL = 0 - NU = 0 - DO 20 ICOL = 1, N -C Don't count diagonal. - JBGN = JA(ICOL)+1 - JEND = JA(ICOL+1)-1 - IF( JBGN.LE.JEND ) THEN -CVD$ NOVECTOR - DO 10 J = JBGN, JEND - IF( IA(J).GT.ICOL ) THEN - NL = NL + 1 - IF( ISYM.NE.0 ) NU = NU + 1 - ELSE - NU = NU + 1 - ENDIF - 10 CONTINUE - ENDIF - 20 CONTINUE -C - LOCIL = LOCIB - LOCJL = LOCIL + N+1 - LOCIU = LOCJL + NL - LOCJU = LOCIU + NU - LOCNR = LOCJU + N+1 - LOCNC = LOCNR + N - LOCIW = LOCNC + N -C - LOCL = LOCRB - LOCDIN = LOCL + NL - LOCU = LOCDIN + N - LOCR = LOCU + NU - LOCZ = LOCR + N - LOCP = LOCZ + N - LOCAP = LOCP + N*(NSAVE+1) - LOCEMA = LOCAP + N*(NSAVE+1) - LOCDZ = LOCEMA + N*(NSAVE+1) - LOCCSA = LOCDZ + N - LOCW = LOCCSA + NSAVE -C -C Check the workspace allocations. - CALL SCHKW( 'SSLUOM', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) - IF( IERR.NE.0 ) RETURN -C - IWORK(1) = LOCIL - IWORK(2) = LOCJL - IWORK(3) = LOCIU - IWORK(4) = LOCJU - IWORK(5) = LOCL - IWORK(6) = LOCDIN - IWORK(7) = LOCU - IWORK(9) = LOCIW - IWORK(10) = LOCW -C -C Compute the Incomplete LU decomposition. - CALL SSILUS( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIL), - $ IWORK(LOCJL), RWORK(LOCL), RWORK(LOCDIN), NU, IWORK(LOCIU), - $ IWORK(LOCJU), RWORK(LOCU), IWORK(LOCNR), IWORK(LOCNC) ) -C -C Perform the incomplete LU preconditioned OrthoMin algorithm. - CALL SOMN(N, B, X, NELT, IA, JA, A, ISYM, SSMV, - $ SSLUI, NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, - $ RWORK(LOCR), RWORK(LOCZ), RWORK(LOCP), RWORK(LOCAP), - $ RWORK(LOCEMA), RWORK(LOCDZ), RWORK(LOCCSA), - $ RWORK, IWORK ) - RETURN - END diff --git a/slatec/ssluti.f b/slatec/ssluti.f deleted file mode 100644 index 1f8287f..0000000 --- a/slatec/ssluti.f +++ /dev/null @@ -1,71 +0,0 @@ -*DECK SSLUTI - SUBROUTINE SSLUTI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C***BEGIN PROLOGUE SSLUTI -C***PURPOSE SLAP MTSOLV for LDU Factorization. -C This routine acts as an interface between the SLAP generic -C MTSOLV calling convention and the routine that actually -C -T -C computes (LDU) B = X. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE SINGLE PRECISION (SSLUTI-S, DSLUTI-D) -C***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM SOLVE, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C It is assumed that RWORK and IWORK have initialized with -C the information required for SSLUI4: -C IWORK(1) = Starting location of IL in IWORK. -C IWORK(2) = Starting location of JL in IWORK. -C IWORK(3) = Starting location of IU in IWORK. -C IWORK(4) = Starting location of JU in IWORK. -C IWORK(5) = Starting location of L in RWORK. -C IWORK(6) = Starting location of DINV in RWORK. -C IWORK(7) = Starting location of U in RWORK. -C See the DESCRIPTION of SSLUI4 for details. -C***REFERENCES (NONE) -C***ROUTINES CALLED SSLUI4 -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE SSLUTI -C .. Scalar Arguments .. - INTEGER ISYM, N, NELT -C .. Array Arguments .. - REAL A(N), B(N), RWORK(*), X(N) - INTEGER IA(NELT), IWORK(10), JA(NELT) -C .. Local Scalars .. - INTEGER LOCDIN, LOCIL, LOCIU, LOCJL, LOCJU, LOCL, LOCU -C .. External Subroutines .. - EXTERNAL SSLUI4 -C***FIRST EXECUTABLE STATEMENT SSLUTI -C -C Pull out the pointers to the L, D and U matrices and call -C the workhorse routine. -C - LOCIL = IWORK(1) - LOCJL = IWORK(2) - LOCIU = IWORK(3) - LOCJU = IWORK(4) - LOCL = IWORK(5) - LOCDIN = IWORK(6) - LOCU = IWORK(7) -C - CALL SSLUI4(N, B, X, IWORK(LOCIL), IWORK(LOCJL), RWORK(LOCL), - $ RWORK(LOCDIN), IWORK(LOCIU), IWORK(LOCJU), RWORK(LOCU)) -C - RETURN -C------------- LAST LINE OF SSLUTI FOLLOWS ---------------------------- - END diff --git a/slatec/ssmmi2.f b/slatec/ssmmi2.f deleted file mode 100644 index e4aad1c..0000000 --- a/slatec/ssmmi2.f +++ /dev/null @@ -1,238 +0,0 @@ -*DECK SSMMI2 - SUBROUTINE SSMMI2 (N, B, X, IL, JL, L, DINV, IU, JU, U) -C***BEGIN PROLOGUE SSMMI2 -C***PURPOSE SLAP Backsolve for LDU Factorization of Normal Equations. -C To solve a system of the form (L*D*U)*(L*D*U)' X = B, -C where L is a unit lower triangular matrix, D is a diagonal -C matrix, and U is a unit upper triangular matrix and ' -C denotes transpose. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE SINGLE PRECISION (SSMMI2-S, DSMMI2-D) -C***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, IL(NL), JL(NL), IU(NU), JU(NU) -C REAL B(N), X(N), L(NL), DINV(N), U(NU) -C -C CALL SSMMI2( N, B, X, IL, JL, L, DINV, IU, JU, U ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C B :IN Real B(N). -C Right hand side. -C X :OUT Real X(N). -C Solution of (L*D*U)(L*D*U)trans x = b. -C IL :IN Integer IL(NL). -C JL :IN Integer JL(NL). -C L :IN Real L(NL). -C IL, JL, L contain the unit lower triangular factor of the -C incomplete decomposition of some matrix stored in SLAP Row -C format. The diagonal of ones *IS* stored. This structure -C can be set up by the SSILUS routine. See the -C "Description", below for more details about the SLAP -C format. (NL is the number of non-zeros in the L array.) -C DINV :IN Real DINV(N). -C Inverse of the diagonal matrix D. -C IU :IN Integer IU(NU). -C JU :IN Integer JU(NU). -C U :IN Real U(NU). -C IU, JU, U contain the unit upper triangular factor of the -C incomplete decomposition of some matrix stored in SLAP -C Column format. The diagonal of ones *IS* stored. This -C structure can be set up by the SSILUS routine. See the -C "Description", below for more details about the SLAP -C format. (NU is the number of non-zeros in the U array.) -C -C *Description: -C This routine is supplied with the SLAP package as a routine -C to perform the MSOLVE operation in the SBCGN iteration -C routine for the driver SSLUCN. It must be called via the -C SLAP MSOLVE calling sequence convention interface routine -C SSMMTI. -C **** THIS ROUTINE ITSELF DOES NOT CONFORM TO THE **** -C **** SLAP MSOLVE CALLING CONVENTION **** -C -C IL, JL, L should contain the unit lower triangular factor of -C the incomplete decomposition of the A matrix stored in SLAP -C Row format. IU, JU, U should contain the unit upper factor -C of the incomplete decomposition of the A matrix stored in -C SLAP Column format This ILU factorization can be computed by -C the SSILUS routine. The diagonals (which are all one's) are -C stored. -C -C =================== S L A P Column format ================== -C -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C ==================== S L A P Row format ==================== -C -C This routine requires that the matrix A be stored in the -C SLAP Row format. In this format the non-zeros are stored -C counting across rows (except for the diagonal entry, which -C must appear first in each "row") and are stored in the real -C array A. In other words, for each row in the matrix put the -C diagonal entry in A. Then put in the other non-zero -C elements going across the row (except the diagonal) in -C order. The JA array holds the column index for each -C non-zero. The IA array holds the offsets into the JA, A -C arrays for the beginning of each row. That is, -C JA(IA(IROW)), A(IA(IROW)) points to the beginning of the -C IROW-th row in JA and A. JA(IA(IROW+1)-1), A(IA(IROW+1)-1) -C points to the end of the IROW-th row. Note that we always -C have IA(N+1) = NELT+1, where N is the number of rows in -C the matrix and NELT is the number of non-zeros in the -C matrix. -C -C Here is an example of the SLAP Row storage format for a 5x5 -C Matrix (in the A and JA arrays '|' denotes the end of a row): -C -C 5x5 Matrix SLAP Row format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 12 15 | 22 21 | 33 35 | 44 | 55 51 53 -C |21 22 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| IA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C With the SLAP format the "inner loops" of this routine -C should vectorize on machines with hardware support for -C vector gather/scatter operations. Your compiler may require -C a compiler directive to convince it that there are no -C implicit vector dependencies. Compiler directives for the -C Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied -C with the standard SLAP distribution. -C -C***SEE ALSO SSILUS -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE SSMMI2 -C .. Scalar Arguments .. - INTEGER N -C .. Array Arguments .. - REAL B(N), DINV(N), L(*), U(N), X(N) - INTEGER IL(*), IU(*), JL(*), JU(*) -C .. Local Scalars .. - INTEGER I, ICOL, IROW, J, JBGN, JEND -C***FIRST EXECUTABLE STATEMENT SSMMI2 -C -C Solve L*Y = B, storing result in X, L stored by rows. -C - DO 10 I = 1, N - X(I) = B(I) - 10 CONTINUE - DO 30 IROW = 2, N - JBGN = IL(IROW) - JEND = IL(IROW+1)-1 - IF( JBGN.LE.JEND ) THEN -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ ASSOC -CVD$ NODEPCHK - DO 20 J = JBGN, JEND - X(IROW) = X(IROW) - L(J)*X(JL(J)) - 20 CONTINUE - ENDIF - 30 CONTINUE -C -C Solve D*Z = Y, storing result in X. - DO 40 I=1,N - X(I) = X(I)*DINV(I) - 40 CONTINUE -C -C Solve U*X = Z, U stored by columns. - DO 60 ICOL = N, 2, -1 - JBGN = JU(ICOL) - JEND = JU(ICOL+1)-1 - IF( JBGN.LE.JEND ) THEN -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ NODEPCHK - DO 50 J = JBGN, JEND - X(IU(J)) = X(IU(J)) - U(J)*X(ICOL) - 50 CONTINUE - ENDIF - 60 CONTINUE -C -C Solve U'*Y = X, storing result in X, U stored by columns. - DO 80 IROW = 2, N - JBGN = JU(IROW) - JEND = JU(IROW+1) - 1 - IF( JBGN.LE.JEND ) THEN -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ ASSOC -CVD$ NODEPCHK - DO 70 J = JBGN, JEND - X(IROW) = X(IROW) - U(J)*X(IU(J)) - 70 CONTINUE - ENDIF - 80 CONTINUE -C -C Solve D*Z = Y, storing result in X. - DO 90 I = 1, N - X(I) = X(I)*DINV(I) - 90 CONTINUE -C -C Solve L'*X = Z, L stored by rows. - DO 110 ICOL = N, 2, -1 - JBGN = IL(ICOL) - JEND = IL(ICOL+1) - 1 - IF( JBGN.LE.JEND ) THEN -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ NODEPCHK - DO 100 J = JBGN, JEND - X(JL(J)) = X(JL(J)) - L(J)*X(ICOL) - 100 CONTINUE - ENDIF - 110 CONTINUE -C - RETURN -C------------- LAST LINE OF SSMMI2 FOLLOWS ---------------------------- - END diff --git a/slatec/ssmmti.f b/slatec/ssmmti.f deleted file mode 100644 index 96f01f9..0000000 --- a/slatec/ssmmti.f +++ /dev/null @@ -1,72 +0,0 @@ -*DECK SSMMTI - SUBROUTINE SSMMTI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) -C***BEGIN PROLOGUE SSMMTI -C***PURPOSE SLAP MSOLVE for LDU Factorization of Normal Equations. -C This routine acts as an interface between the SLAP generic -C MMTSLV calling convention and the routine that actually -C -1 -C computes [(LDU)*(LDU)'] B = X. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2E -C***TYPE SINGLE PRECISION (SSMMTI-S, DSMMTI-D) -C***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM SOLVE, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C It is assumed that RWORK and IWORK have initialized with -C the information required for SSMMI2: -C IWORK(1) = Starting location of IL in IWORK. -C IWORK(2) = Starting location of JL in IWORK. -C IWORK(3) = Starting location of IU in IWORK. -C IWORK(4) = Starting location of JU in IWORK. -C IWORK(5) = Starting location of L in RWORK. -C IWORK(6) = Starting location of DINV in RWORK. -C IWORK(7) = Starting location of U in RWORK. -C See the DESCRIPTION of SSMMI2 for details. -C***REFERENCES (NONE) -C***ROUTINES CALLED SSMMI2 -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 921113 Corrected C***CATEGORY line. (FNF) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE SSMMTI -C .. Scalar Arguments .. - INTEGER ISYM, N, NELT -C .. Array Arguments .. - REAL A(NELT), B(N), RWORK(*), X(N) - INTEGER IA(NELT), IWORK(10), JA(NELT) -C .. Local Scalars .. - INTEGER LOCDIN, LOCIL, LOCIU, LOCJL, LOCJU, LOCL, LOCU -C .. External Subroutines .. - EXTERNAL SSMMI2 -C***FIRST EXECUTABLE STATEMENT SSMMTI -C -C Pull out the locations of the arrays holding the ILU -C factorization. -C - LOCIL = IWORK(1) - LOCJL = IWORK(2) - LOCIU = IWORK(3) - LOCJU = IWORK(4) - LOCL = IWORK(5) - LOCDIN = IWORK(6) - LOCU = IWORK(7) -C - CALL SSMMI2(N, B, X, IWORK(LOCIL), IWORK(LOCJL), - $ RWORK(LOCL), RWORK(LOCDIN), IWORK(LOCIU), - $ IWORK(LOCJU), RWORK(LOCU)) -C - RETURN -C------------- LAST LINE OF SSMMTI FOLLOWS ---------------------------- - END diff --git a/slatec/ssmtv.f b/slatec/ssmtv.f deleted file mode 100644 index b325c70..0000000 --- a/slatec/ssmtv.f +++ /dev/null @@ -1,152 +0,0 @@ -*DECK SSMTV - SUBROUTINE SSMTV (N, X, Y, NELT, IA, JA, A, ISYM) -C***BEGIN PROLOGUE SSMTV -C***PURPOSE SLAP Column Format Sparse Matrix Transpose Vector Product. -C Routine to calculate the sparse matrix vector product: -C Y = A'*X, where ' denotes transpose. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D1B4 -C***TYPE SINGLE PRECISION (SSMTV-S, DSMTV-D) -C***KEYWORDS MATRIX TRANSPOSE VECTOR MULTIPLY, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM -C REAL X(N), Y(N), A(NELT) -C -C CALL SSMTV(N, X, Y, NELT, IA, JA, A, ISYM ) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C X :IN Real X(N). -C The vector that should be multiplied by the transpose of -C the matrix. -C Y :OUT Real Y(N). -C The product of the transpose of the matrix and the vector. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Real A(NELT). -C These arrays should hold the matrix A in the SLAP Column -C format. See "Description", below. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C -C *Description -C =================== S L A P Column format ================== -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C With the SLAP format the "inner loops" of this routine -C should vectorize on machines with hardware support for -C vector gather/scatter operations. Your compiler may require -C a compiler directive to convince it that there are no -C implicit vector dependencies. Compiler directives for the -C Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied -C with the standard SLAP distribution. -C -C *Cautions: -C This routine assumes that the matrix A is stored in SLAP -C Column format. It does not check for this (for speed) and -C evil, ugly, ornery and nasty things will happen if the matrix -C data structure is, in fact, not SLAP Column. Beware of the -C wrong data structure!!! -C -C***SEE ALSO SSMV -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE SSMTV -C .. Scalar Arguments .. - INTEGER ISYM, N, NELT -C .. Array Arguments .. - REAL A(NELT), X(N), Y(N) - INTEGER IA(NELT), JA(NELT) -C .. Local Scalars .. - INTEGER I, IBGN, ICOL, IEND, IROW, J, JBGN, JEND -C***FIRST EXECUTABLE STATEMENT SSMTV -C -C Zero out the result vector. -C - DO 10 I = 1, N - Y(I) = 0 - 10 CONTINUE -C -C Multiply by A-Transpose. -C A-Transpose is stored by rows... -CVD$R NOCONCUR - DO 30 IROW = 1, N - IBGN = JA(IROW) - IEND = JA(IROW+1)-1 -CVD$ ASSOC - DO 20 I = IBGN, IEND - Y(IROW) = Y(IROW) + A(I)*X(IA(I)) - 20 CONTINUE - 30 CONTINUE -C - IF( ISYM.EQ.1 ) THEN -C -C The matrix is non-symmetric. Need to get the other half in... -C This loops assumes that the diagonal is the first entry in -C each column. -C - DO 50 ICOL = 1, N - JBGN = JA(ICOL)+1 - JEND = JA(ICOL+1)-1 - IF( JBGN.GT.JEND ) GOTO 50 -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ NODEPCHK - DO 40 J = JBGN, JEND - Y(IA(J)) = Y(IA(J)) + A(J)*X(ICOL) - 40 CONTINUE - 50 CONTINUE - ENDIF - RETURN -C------------- LAST LINE OF SSMTV FOLLOWS ---------------------------- - END diff --git a/slatec/ssmv.f b/slatec/ssmv.f deleted file mode 100644 index 4be7370..0000000 --- a/slatec/ssmv.f +++ /dev/null @@ -1,150 +0,0 @@ -*DECK SSMV - SUBROUTINE SSMV (N, X, Y, NELT, IA, JA, A, ISYM) -C***BEGIN PROLOGUE SSMV -C***PURPOSE SLAP Column Format Sparse Matrix Vector Product. -C Routine to calculate the sparse matrix vector product: -C Y = A*X. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D1B4 -C***TYPE SINGLE PRECISION (SSMV-S, DSMV-D) -C***KEYWORDS MATRIX VECTOR MULTIPLY, SLAP, SPARSE -C***AUTHOR Greenbaum, Anne, (Courant Institute) -C Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM -C REAL X(N), Y(N), A(NELT) -C -C CALL SSMV(N, X, Y, NELT, IA, JA, A, ISYM ) -C -C *Arguments: -C N :IN Integer. -C Order of the Matrix. -C X :IN Real X(N). -C The vector that should be multiplied by the matrix. -C Y :OUT Real Y(N). -C The product of the matrix and the vector. -C NELT :IN Integer. -C Number of Non-Zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Real A(NELT). -C These arrays should hold the matrix A in the SLAP Column -C format. See "Description", below. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the upper -C or lower triangle of the matrix is stored. -C -C *Description -C =================== S L A P Column format ================== -C This routine requires that the matrix A be stored in the -C SLAP Column format. In this format the non-zeros are stored -C counting down columns (except for the diagonal entry, which -C must appear first in each "column") and are stored in the -C real array A. In other words, for each column in the matrix -C put the diagonal entry in A. Then put in the other non-zero -C elements going down the column (except the diagonal) in -C order. The IA array holds the row index for each non-zero. -C The JA array holds the offsets into the IA, A arrays for the -C beginning of each column. That is, IA(JA(ICOL)), -C A(JA(ICOL)) points to the beginning of the ICOL-th column in -C IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the -C end of the ICOL-th column. Note that we always have -C JA(N+1) = NELT+1, where N is the number of columns in the -C matrix and NELT is the number of non-zeros in the matrix. -C -C Here is an example of the SLAP Column storage format for a -C 5x5 Matrix (in the A and IA arrays '|' denotes the end of a -C column): -C -C 5x5 Matrix SLAP Column format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 -C |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 -C | 0 0 33 0 35| JA: 1 4 6 8 9 12 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C With the SLAP format the "inner loops" of this routine -C should vectorize on machines with hardware support for -C vector gather/scatter operations. Your compiler may require -C a compiler directive to convince it that there are no -C implicit vector dependencies. Compiler directives for the -C Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied -C with the standard SLAP distribution. -C -C *Cautions: -C This routine assumes that the matrix A is stored in SLAP -C Column format. It does not check for this (for speed) and -C evil, ugly, ornery and nasty things will happen if the matrix -C data structure is, in fact, not SLAP Column. Beware of the -C wrong data structure!!! -C -C***SEE ALSO SSMTV -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE SSMV -C .. Scalar Arguments .. - INTEGER ISYM, N, NELT -C .. Array Arguments .. - REAL A(NELT), X(N), Y(N) - INTEGER IA(NELT), JA(NELT) -C .. Local Scalars .. - INTEGER I, IBGN, ICOL, IEND, IROW, J, JBGN, JEND -C***FIRST EXECUTABLE STATEMENT SSMV -C -C Zero out the result vector. -C - DO 10 I = 1, N - Y(I) = 0 - 10 CONTINUE -C -C Multiply by A. -C -CVD$R NOCONCUR - DO 30 ICOL = 1, N - IBGN = JA(ICOL) - IEND = JA(ICOL+1)-1 -CLLL. OPTION ASSERT (NOHAZARD) -CDIR$ IVDEP -CVD$ NODEPCHK - DO 20 I = IBGN, IEND - Y(IA(I)) = Y(IA(I)) + A(I)*X(ICOL) - 20 CONTINUE - 30 CONTINUE -C - IF( ISYM.EQ.1 ) THEN -C -C The matrix is non-symmetric. Need to get the other half in... -C This loops assumes that the diagonal is the first entry in -C each column. -C - DO 50 IROW = 1, N - JBGN = JA(IROW)+1 - JEND = JA(IROW+1)-1 - IF( JBGN.GT.JEND ) GOTO 50 - DO 40 J = JBGN, JEND - Y(IROW) = Y(IROW) + A(J)*X(IA(J)) - 40 CONTINUE - 50 CONTINUE - ENDIF - RETURN -C------------- LAST LINE OF SSMV FOLLOWS ---------------------------- - END diff --git a/slatec/ssort.f b/slatec/ssort.f deleted file mode 100644 index ddb1045..0000000 --- a/slatec/ssort.f +++ /dev/null @@ -1,323 +0,0 @@ -*DECK SSORT - SUBROUTINE SSORT (X, Y, N, KFLAG) -C***BEGIN PROLOGUE SSORT -C***PURPOSE Sort an array and optionally make the same interchanges in -C an auxiliary array. The array may be sorted in increasing -C or decreasing order. A slightly modified QUICKSORT -C algorithm is used. -C***LIBRARY SLATEC -C***CATEGORY N6A2B -C***TYPE SINGLE PRECISION (SSORT-S, DSORT-D, ISORT-I) -C***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING -C***AUTHOR Jones, R. E., (SNLA) -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C -C SSORT sorts array X and optionally makes the same interchanges in -C array Y. The array X may be sorted in increasing order or -C decreasing order. A slightly modified quicksort algorithm is used. -C -C Description of Parameters -C X - array of values to be sorted (usually abscissas) -C Y - array to be (optionally) carried along -C N - number of values in array X to be sorted -C KFLAG - control parameter -C = 2 means sort X in increasing order and carry Y along. -C = 1 means sort X in increasing order (ignoring Y) -C = -1 means sort X in decreasing order (ignoring Y) -C = -2 means sort X in decreasing order and carry Y along. -C -C***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm -C for sorting with minimal storage, Communications of -C the ACM, 12, 3 (1969), pp. 185-187. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 761101 DATE WRITTEN -C 761118 Modified to use the Singleton quicksort algorithm. (JAW) -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891009 Removed unreferenced statement labels. (WRB) -C 891024 Changed category. (WRB) -C 891024 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 901012 Declared all variables; changed X,Y to SX,SY. (M. McClain) -C 920501 Reformatted the REFERENCES section. (DWL, WRB) -C 920519 Clarified error messages. (DWL) -C 920801 Declarations section rebuilt and code restructured to use -C IF-THEN-ELSE-ENDIF. (RWC, WRB) -C***END PROLOGUE SSORT -C .. Scalar Arguments .. - INTEGER KFLAG, N -C .. Array Arguments .. - REAL X(*), Y(*) -C .. Local Scalars .. - REAL R, T, TT, TTY, TY - INTEGER I, IJ, J, K, KK, L, M, NN -C .. Local Arrays .. - INTEGER IL(21), IU(21) -C .. External Subroutines .. - EXTERNAL XERMSG -C .. Intrinsic Functions .. - INTRINSIC ABS, INT -C***FIRST EXECUTABLE STATEMENT SSORT - NN = N - IF (NN .LT. 1) THEN - CALL XERMSG ('SLATEC', 'SSORT', - + 'The number of values to be sorted is not positive.', 1, 1) - RETURN - ENDIF -C - KK = ABS(KFLAG) - IF (KK.NE.1 .AND. KK.NE.2) THEN - CALL XERMSG ('SLATEC', 'SSORT', - + 'The sort control parameter, K, is not 2, 1, -1, or -2.', 2, - + 1) - RETURN - ENDIF -C -C Alter array X to get decreasing order if needed -C - IF (KFLAG .LE. -1) THEN - DO 10 I=1,NN - X(I) = -X(I) - 10 CONTINUE - ENDIF -C - IF (KK .EQ. 2) GO TO 100 -C -C Sort X only -C - M = 1 - I = 1 - J = NN - R = 0.375E0 -C - 20 IF (I .EQ. J) GO TO 60 - IF (R .LE. 0.5898437E0) THEN - R = R+3.90625E-2 - ELSE - R = R-0.21875E0 - ENDIF -C - 30 K = I -C -C Select a central element of the array and save it in location T -C - IJ = I + INT((J-I)*R) - T = X(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (X(I) .GT. T) THEN - X(IJ) = X(I) - X(I) = T - T = X(IJ) - ENDIF - L = J -C -C If last element of array is less than than T, interchange with T -C - IF (X(J) .LT. T) THEN - X(IJ) = X(J) - X(J) = T - T = X(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (X(I) .GT. T) THEN - X(IJ) = X(I) - X(I) = T - T = X(IJ) - ENDIF - ENDIF -C -C Find an element in the second half of the array which is smaller -C than T -C - 40 L = L-1 - IF (X(L) .GT. T) GO TO 40 -C -C Find an element in the first half of the array which is greater -C than T -C - 50 K = K+1 - IF (X(K) .LT. T) GO TO 50 -C -C Interchange these elements -C - IF (K .LE. L) THEN - TT = X(L) - X(L) = X(K) - X(K) = TT - GO TO 40 - ENDIF -C -C Save upper and lower subscripts of the array yet to be sorted -C - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 70 -C -C Begin again on another portion of the unsorted array -C - 60 M = M-1 - IF (M .EQ. 0) GO TO 190 - I = IL(M) - J = IU(M) -C - 70 IF (J-I .GE. 1) GO TO 30 - IF (I .EQ. 1) GO TO 20 - I = I-1 -C - 80 I = I+1 - IF (I .EQ. J) GO TO 60 - T = X(I+1) - IF (X(I) .LE. T) GO TO 80 - K = I -C - 90 X(K+1) = X(K) - K = K-1 - IF (T .LT. X(K)) GO TO 90 - X(K+1) = T - GO TO 80 -C -C Sort X and carry Y along -C - 100 M = 1 - I = 1 - J = NN - R = 0.375E0 -C - 110 IF (I .EQ. J) GO TO 150 - IF (R .LE. 0.5898437E0) THEN - R = R+3.90625E-2 - ELSE - R = R-0.21875E0 - ENDIF -C - 120 K = I -C -C Select a central element of the array and save it in location T -C - IJ = I + INT((J-I)*R) - T = X(IJ) - TY = Y(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (X(I) .GT. T) THEN - X(IJ) = X(I) - X(I) = T - T = X(IJ) - Y(IJ) = Y(I) - Y(I) = TY - TY = Y(IJ) - ENDIF - L = J -C -C If last element of array is less than T, interchange with T -C - IF (X(J) .LT. T) THEN - X(IJ) = X(J) - X(J) = T - T = X(IJ) - Y(IJ) = Y(J) - Y(J) = TY - TY = Y(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (X(I) .GT. T) THEN - X(IJ) = X(I) - X(I) = T - T = X(IJ) - Y(IJ) = Y(I) - Y(I) = TY - TY = Y(IJ) - ENDIF - ENDIF -C -C Find an element in the second half of the array which is smaller -C than T -C - 130 L = L-1 - IF (X(L) .GT. T) GO TO 130 -C -C Find an element in the first half of the array which is greater -C than T -C - 140 K = K+1 - IF (X(K) .LT. T) GO TO 140 -C -C Interchange these elements -C - IF (K .LE. L) THEN - TT = X(L) - X(L) = X(K) - X(K) = TT - TTY = Y(L) - Y(L) = Y(K) - Y(K) = TTY - GO TO 130 - ENDIF -C -C Save upper and lower subscripts of the array yet to be sorted -C - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 160 -C -C Begin again on another portion of the unsorted array -C - 150 M = M-1 - IF (M .EQ. 0) GO TO 190 - I = IL(M) - J = IU(M) -C - 160 IF (J-I .GE. 1) GO TO 120 - IF (I .EQ. 1) GO TO 110 - I = I-1 -C - 170 I = I+1 - IF (I .EQ. J) GO TO 150 - T = X(I+1) - TY = Y(I+1) - IF (X(I) .LE. T) GO TO 170 - K = I -C - 180 X(K+1) = X(K) - Y(K+1) = Y(K) - K = K-1 - IF (T .LT. X(K)) GO TO 180 - X(K+1) = T - Y(K+1) = TY - GO TO 170 -C -C Clean up -C - 190 IF (KFLAG .LE. -1) THEN - DO 200 I=1,NN - X(I) = -X(I) - 200 CONTINUE - ENDIF - RETURN - END diff --git a/slatec/sspco.f b/slatec/sspco.f deleted file mode 100644 index cf487ff..0000000 --- a/slatec/sspco.f +++ /dev/null @@ -1,301 +0,0 @@ -*DECK SSPCO - SUBROUTINE SSPCO (AP, N, KPVT, RCOND, Z) -C***BEGIN PROLOGUE SSPCO -C***PURPOSE Factor a real symmetric matrix stored in packed form -C by elimination with symmetric pivoting and estimate the -C condition number of the matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1A -C***TYPE SINGLE PRECISION (SSPCO-S, DSPCO-D, CHPCO-C, CSPCO-C) -C***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, -C MATRIX FACTORIZATION, PACKED, SYMMETRIC -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C SSPCO factors a real symmetric matrix stored in packed -C form by elimination with symmetric pivoting and estimates -C the condition of the matrix. -C -C If RCOND is not needed, SSPFA is slightly faster. -C To solve A*X = B , follow SSPCO by SSPSL. -C To compute INVERSE(A)*C , follow SSPCO by SSPSL. -C To compute INVERSE(A) , follow SSPCO by SSPDI. -C To compute DETERMINANT(A) , follow SSPCO by SSPDI. -C To compute INERTIA(A), follow SSPCO by SSPDI. -C -C On Entry -C -C AP REAL (N*(N+1)/2) -C the packed form of a symmetric matrix A . The -C columns of the upper triangle are stored sequentially -C in a one-dimensional array of length N*(N+1)/2 . -C See comments below for details. -C -C N INTEGER -C the order of the matrix A . -C -C Output -C -C AP a block diagonal matrix and the multipliers which -C were used to obtain it stored in packed form. -C The factorization can be written A = U*D*TRANS(U) -C where U is a product of permutation and unit -C upper triangular matrices , TRANS(U) is the -C transpose of U , and D is block diagonal -C with 1 by 1 and 2 by 2 blocks. -C -C KPVT INTEGER(N) -C an integer vector of pivot indices. -C -C RCOND REAL -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 REAL(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 Packed Storage -C -C The following program segment will pack the upper -C triangle of a symmetric matrix. -C -C K = 0 -C DO 20 J = 1, N -C DO 10 I = 1, J -C K = K + 1 -C AP(K) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SASUM, SAXPY, SDOT, SSCAL, SSPFA -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Modified routine equivalence list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SSPCO - INTEGER N,KPVT(*) - REAL AP(*),Z(*) - REAL RCOND -C - REAL AK,AKM1,BK,BKM1,SDOT,DENOM,EK,T - REAL ANORM,S,SASUM,YNORM - INTEGER I,IJ,IK,IKM1,IKP1,INFO,J,JM1,J1 - INTEGER K,KK,KM1K,KM1KM1,KP,KPS,KS -C -C FIND NORM OF A USING ONLY UPPER HALF -C -C***FIRST EXECUTABLE STATEMENT SSPCO - J1 = 1 - DO 30 J = 1, N - Z(J) = SASUM(J,AP(J1),1) - IJ = J1 - J1 = J1 + J - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 20 - DO 10 I = 1, JM1 - Z(I) = Z(I) + ABS(AP(IJ)) - IJ = IJ + 1 - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - ANORM = 0.0E0 - DO 40 J = 1, N - ANORM = MAX(ANORM,Z(J)) - 40 CONTINUE -C -C FACTOR -C - CALL SSPFA(AP,N,KPVT,INFO) -C -C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . -C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . -C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL -C GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . -C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. -C -C SOLVE U*D*W = E -C - EK = 1.0E0 - DO 50 J = 1, N - Z(J) = 0.0E0 - 50 CONTINUE - K = N - IK = (N*(N - 1))/2 - 60 IF (K .EQ. 0) GO TO 120 - KK = IK + K - IKM1 = IK - (K - 1) - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - KP = ABS(KPVT(K)) - KPS = K + 1 - KS - IF (KP .EQ. KPS) GO TO 70 - T = Z(KPS) - Z(KPS) = Z(KP) - Z(KP) = T - 70 CONTINUE - IF (Z(K) .NE. 0.0E0) EK = SIGN(EK,Z(K)) - Z(K) = Z(K) + EK - CALL SAXPY(K-KS,Z(K),AP(IK+1),1,Z(1),1) - IF (KS .EQ. 1) GO TO 80 - IF (Z(K-1) .NE. 0.0E0) EK = SIGN(EK,Z(K-1)) - Z(K-1) = Z(K-1) + EK - CALL SAXPY(K-KS,Z(K-1),AP(IKM1+1),1,Z(1),1) - 80 CONTINUE - IF (KS .EQ. 2) GO TO 100 - IF (ABS(Z(K)) .LE. ABS(AP(KK))) GO TO 90 - S = ABS(AP(KK))/ABS(Z(K)) - CALL SSCAL(N,S,Z,1) - EK = S*EK - 90 CONTINUE - IF (AP(KK) .NE. 0.0E0) Z(K) = Z(K)/AP(KK) - IF (AP(KK) .EQ. 0.0E0) Z(K) = 1.0E0 - GO TO 110 - 100 CONTINUE - KM1K = IK + K - 1 - KM1KM1 = IKM1 + K - 1 - AK = AP(KK)/AP(KM1K) - AKM1 = AP(KM1KM1)/AP(KM1K) - BK = Z(K)/AP(KM1K) - BKM1 = Z(K-1)/AP(KM1K) - DENOM = AK*AKM1 - 1.0E0 - Z(K) = (AKM1*BK - BKM1)/DENOM - Z(K-1) = (AK*BKM1 - BK)/DENOM - 110 CONTINUE - K = K - KS - IK = IK - K - IF (KS .EQ. 2) IK = IK - (K + 1) - GO TO 60 - 120 CONTINUE - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) -C -C SOLVE TRANS(U)*Y = W -C - K = 1 - IK = 0 - 130 IF (K .GT. N) GO TO 160 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. 1) GO TO 150 - Z(K) = Z(K) + SDOT(K-1,AP(IK+1),1,Z(1),1) - IKP1 = IK + K - IF (KS .EQ. 2) - 1 Z(K+1) = Z(K+1) + SDOT(K-1,AP(IKP1+1),1,Z(1),1) - KP = ABS(KPVT(K)) - IF (KP .EQ. K) GO TO 140 - T = Z(K) - Z(K) = Z(KP) - Z(KP) = T - 140 CONTINUE - 150 CONTINUE - IK = IK + K - IF (KS .EQ. 2) IK = IK + (K + 1) - K = K + KS - GO TO 130 - 160 CONTINUE - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) -C - YNORM = 1.0E0 -C -C SOLVE U*D*V = Y -C - K = N - IK = N*(N - 1)/2 - 170 IF (K .EQ. 0) GO TO 230 - KK = IK + K - IKM1 = IK - (K - 1) - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. KS) GO TO 190 - KP = ABS(KPVT(K)) - KPS = K + 1 - KS - IF (KP .EQ. KPS) GO TO 180 - T = Z(KPS) - Z(KPS) = Z(KP) - Z(KP) = T - 180 CONTINUE - CALL SAXPY(K-KS,Z(K),AP(IK+1),1,Z(1),1) - IF (KS .EQ. 2) CALL SAXPY(K-KS,Z(K-1),AP(IKM1+1),1,Z(1),1) - 190 CONTINUE - IF (KS .EQ. 2) GO TO 210 - IF (ABS(Z(K)) .LE. ABS(AP(KK))) GO TO 200 - S = ABS(AP(KK))/ABS(Z(K)) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM - 200 CONTINUE - IF (AP(KK) .NE. 0.0E0) Z(K) = Z(K)/AP(KK) - IF (AP(KK) .EQ. 0.0E0) Z(K) = 1.0E0 - GO TO 220 - 210 CONTINUE - KM1K = IK + K - 1 - KM1KM1 = IKM1 + K - 1 - AK = AP(KK)/AP(KM1K) - AKM1 = AP(KM1KM1)/AP(KM1K) - BK = Z(K)/AP(KM1K) - BKM1 = Z(K-1)/AP(KM1K) - DENOM = AK*AKM1 - 1.0E0 - Z(K) = (AKM1*BK - BKM1)/DENOM - Z(K-1) = (AK*BKM1 - BK)/DENOM - 220 CONTINUE - K = K - KS - IK = IK - K - IF (KS .EQ. 2) IK = IK - (K + 1) - GO TO 170 - 230 CONTINUE - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE TRANS(U)*Z = V -C - K = 1 - IK = 0 - 240 IF (K .GT. N) GO TO 270 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. 1) GO TO 260 - Z(K) = Z(K) + SDOT(K-1,AP(IK+1),1,Z(1),1) - IKP1 = IK + K - IF (KS .EQ. 2) - 1 Z(K+1) = Z(K+1) + SDOT(K-1,AP(IKP1+1),1,Z(1),1) - KP = ABS(KPVT(K)) - IF (KP .EQ. K) GO TO 250 - T = Z(K) - Z(K) = Z(KP) - Z(KP) = T - 250 CONTINUE - 260 CONTINUE - IK = IK + K - IF (KS .EQ. 2) IK = IK + (K + 1) - K = K + KS - GO TO 240 - 270 CONTINUE -C MAKE ZNORM = 1.0 - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM -C - IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM - IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0 - RETURN - END diff --git a/slatec/sspdi.f b/slatec/sspdi.f deleted file mode 100644 index 8aa5ca6..0000000 --- a/slatec/sspdi.f +++ /dev/null @@ -1,256 +0,0 @@ -*DECK SSPDI - SUBROUTINE SSPDI (AP, N, KPVT, DET, INERT, WORK, JOB) -C***BEGIN PROLOGUE SSPDI -C***PURPOSE Compute the determinant, inertia, inverse of a real -C symmetric matrix stored in packed form using the factors -C from SSPFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1A, D3B1A -C***TYPE SINGLE PRECISION (SSPDI-S, DSPDI-D, CHPDI-C, CSPDI-C) -C***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, -C PACKED, SYMMETRIC -C***AUTHOR Bunch, J., (UCSD) -C***DESCRIPTION -C -C SSPDI computes the determinant, inertia and inverse -C of a real symmetric matrix using the factors from SSPFA, -C where the matrix is stored in packed form. -C -C On Entry -C -C AP REAL (N*(N+1)/2) -C the output from SSPFA. -C -C N INTEGER -C the order of the matrix A. -C -C KPVT INTEGER(N) -C the pivot vector from SSPFA. -C -C WORK REAL(N) -C work vector. Contents ignored. -C -C JOB INTEGER -C JOB has the decimal expansion ABC where -C If C .NE. 0, the inverse is computed, -C If B .NE. 0, the determinant is computed, -C If A .NE. 0, the inertia is computed. -C -C For example, JOB = 111 gives all three. -C -C On Return -C -C Variables not requested by JOB are not used. -C -C AP contains the upper triangle of the inverse of -C the original matrix, stored in packed form. -C The columns of the upper triangle are stored -C sequentially in a one-dimensional array. -C -C DET REAL(2) -C determinant of original matrix. -C Determinant = DET(1) * 10.0**DET(2) -C with 1.0 .LE. ABS(DET(1)) .LT. 10.0 -C or DET(1) = 0.0. -C -C INERT INTEGER(3) -C the inertia of the original matrix. -C INERT(1) = number of positive eigenvalues. -C INERT(2) = number of negative eigenvalues. -C INERT(3) = number of zero eigenvalues. -C -C Error Condition -C -C A division by zero will occur if the inverse is requested -C and SSPCO has set RCOND .EQ. 0.0 -C or SSPFA has set INFO .NE. 0 . -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SAXPY, SCOPY, SDOT, SSWAP -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Modified routine equivalence list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SSPDI - INTEGER N,JOB - REAL AP(*),WORK(*) - REAL DET(2) - INTEGER KPVT(*),INERT(3) -C - REAL AKKP1,SDOT,TEMP - REAL TEN,D,T,AK,AKP1 - INTEGER IJ,IK,IKP1,IKS,J,JB,JK,JKP1 - INTEGER K,KK,KKP1,KM1,KS,KSJ,KSKP1,KSTEP - LOGICAL NOINV,NODET,NOERT -C***FIRST EXECUTABLE STATEMENT SSPDI - NOINV = MOD(JOB,10) .EQ. 0 - NODET = MOD(JOB,100)/10 .EQ. 0 - NOERT = MOD(JOB,1000)/100 .EQ. 0 -C - IF (NODET .AND. NOERT) GO TO 140 - IF (NOERT) GO TO 10 - INERT(1) = 0 - INERT(2) = 0 - INERT(3) = 0 - 10 CONTINUE - IF (NODET) GO TO 20 - DET(1) = 1.0E0 - DET(2) = 0.0E0 - TEN = 10.0E0 - 20 CONTINUE - T = 0.0E0 - IK = 0 - DO 130 K = 1, N - KK = IK + K - D = AP(KK) -C -C CHECK IF 1 BY 1 -C - IF (KPVT(K) .GT. 0) GO TO 50 -C -C 2 BY 2 BLOCK -C USE DET (D S) = (D/T * C - T) * T , T = ABS(S) -C (S C) -C TO AVOID UNDERFLOW/OVERFLOW TROUBLES. -C TAKE TWO PASSES THROUGH SCALING. USE T FOR FLAG. -C - IF (T .NE. 0.0E0) GO TO 30 - IKP1 = IK + K - KKP1 = IKP1 + K - T = ABS(AP(KKP1)) - D = (D/T)*AP(KKP1+1) - T - GO TO 40 - 30 CONTINUE - D = T - T = 0.0E0 - 40 CONTINUE - 50 CONTINUE -C - IF (NOERT) GO TO 60 - IF (D .GT. 0.0E0) INERT(1) = INERT(1) + 1 - IF (D .LT. 0.0E0) INERT(2) = INERT(2) + 1 - IF (D .EQ. 0.0E0) INERT(3) = INERT(3) + 1 - 60 CONTINUE -C - IF (NODET) GO TO 120 - DET(1) = D*DET(1) - IF (DET(1) .EQ. 0.0E0) GO TO 110 - 70 IF (ABS(DET(1)) .GE. 1.0E0) GO TO 80 - DET(1) = TEN*DET(1) - DET(2) = DET(2) - 1.0E0 - GO TO 70 - 80 CONTINUE - 90 IF (ABS(DET(1)) .LT. TEN) GO TO 100 - DET(1) = DET(1)/TEN - DET(2) = DET(2) + 1.0E0 - GO TO 90 - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE - IK = IK + K - 130 CONTINUE - 140 CONTINUE -C -C COMPUTE INVERSE(A) -C - IF (NOINV) GO TO 270 - K = 1 - IK = 0 - 150 IF (K .GT. N) GO TO 260 - KM1 = K - 1 - KK = IK + K - IKP1 = IK + K - KKP1 = IKP1 + K - IF (KPVT(K) .LT. 0) GO TO 180 -C -C 1 BY 1 -C - AP(KK) = 1.0E0/AP(KK) - IF (KM1 .LT. 1) GO TO 170 - CALL SCOPY(KM1,AP(IK+1),1,WORK,1) - IJ = 0 - DO 160 J = 1, KM1 - JK = IK + J - AP(JK) = SDOT(J,AP(IJ+1),1,WORK,1) - CALL SAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IK+1),1) - IJ = IJ + J - 160 CONTINUE - AP(KK) = AP(KK) + SDOT(KM1,WORK,1,AP(IK+1),1) - 170 CONTINUE - KSTEP = 1 - GO TO 220 - 180 CONTINUE -C -C 2 BY 2 -C - T = ABS(AP(KKP1)) - AK = AP(KK)/T - AKP1 = AP(KKP1+1)/T - AKKP1 = AP(KKP1)/T - D = T*(AK*AKP1 - 1.0E0) - AP(KK) = AKP1/D - AP(KKP1+1) = AK/D - AP(KKP1) = -AKKP1/D - IF (KM1 .LT. 1) GO TO 210 - CALL SCOPY(KM1,AP(IKP1+1),1,WORK,1) - IJ = 0 - DO 190 J = 1, KM1 - JKP1 = IKP1 + J - AP(JKP1) = SDOT(J,AP(IJ+1),1,WORK,1) - CALL SAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IKP1+1),1) - IJ = IJ + J - 190 CONTINUE - AP(KKP1+1) = AP(KKP1+1) - 1 + SDOT(KM1,WORK,1,AP(IKP1+1),1) - AP(KKP1) = AP(KKP1) - 1 + SDOT(KM1,AP(IK+1),1,AP(IKP1+1),1) - CALL SCOPY(KM1,AP(IK+1),1,WORK,1) - IJ = 0 - DO 200 J = 1, KM1 - JK = IK + J - AP(JK) = SDOT(J,AP(IJ+1),1,WORK,1) - CALL SAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IK+1),1) - IJ = IJ + J - 200 CONTINUE - AP(KK) = AP(KK) + SDOT(KM1,WORK,1,AP(IK+1),1) - 210 CONTINUE - KSTEP = 2 - 220 CONTINUE -C -C SWAP -C - KS = ABS(KPVT(K)) - IF (KS .EQ. K) GO TO 250 - IKS = (KS*(KS - 1))/2 - CALL SSWAP(KS,AP(IKS+1),1,AP(IK+1),1) - KSJ = IK + KS - DO 230 JB = KS, K - J = K + KS - JB - JK = IK + J - TEMP = AP(JK) - AP(JK) = AP(KSJ) - AP(KSJ) = TEMP - KSJ = KSJ - (J - 1) - 230 CONTINUE - IF (KSTEP .EQ. 1) GO TO 240 - KSKP1 = IKP1 + KS - TEMP = AP(KSKP1) - AP(KSKP1) = AP(KKP1) - AP(KKP1) = TEMP - 240 CONTINUE - 250 CONTINUE - IK = IK + K - IF (KSTEP .EQ. 2) IK = IK + K + 1 - K = K + KSTEP - GO TO 150 - 260 CONTINUE - 270 CONTINUE - RETURN - END diff --git a/slatec/sspev.f b/slatec/sspev.f deleted file mode 100644 index 9452dd8..0000000 --- a/slatec/sspev.f +++ /dev/null @@ -1,120 +0,0 @@ -*DECK SSPEV - SUBROUTINE SSPEV (A, N, E, V, LDV, WORK, JOB, INFO) -C***BEGIN PROLOGUE SSPEV -C***PURPOSE Compute the eigenvalues and, optionally, the eigenvectors -C of a real symmetric matrix stored in packed form. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4A1 -C***TYPE SINGLE PRECISION (SSPEV-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK, PACKED, SYMMETRIC -C***AUTHOR Kahaner, D. K., (NBS) -C Moler, C. B., (U. of New Mexico) -C Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C Abstract -C SSPEV computes the eigenvalues and, optionally, the eigenvectors -C of a real symmetric matrix stored in packed form. -C -C Call Sequence Parameters- -C (The values of parameters marked with * (star) will be changed -C by SSPEV.) -C -C A* REAL(N*(N+1)/2) -C real symmetric packed input matrix. Contains upper -C triangle and diagonal of A, by column (elements -C 11, 12, 22, 13, 23, 33, ...). -C -C N INTEGER -C set by the user to -C the order of the matrix A. -C -C E* REAL(N) -C on return from SSPEV, E contains the eigenvalues of A. -C See also INFO below. -C -C V* REAL(LDV,N) -C on return from SSPEV, if the user has set JOB -C = 0 V is not referenced. -C = nonzero the N eigenvectors of A are stored in the -C first N columns of V. See also INFO below. -C -C LDV INTEGER -C set by the user to -C the leading dimension of the array V if JOB is also -C set nonzero. In that case, N must be .LE. LDV. -C If JOB is set to zero, LDV is not referenced. -C -C WORK* REAL(2N) -C temporary storage vector. Contents changed by SSPEV. -C -C JOB INTEGER -C set by the user to -C = 0 eigenvalues only to be calculated by SSPEV. -C Neither V nor LDV are referenced. -C = nonzero eigenvalues and vectors to be calculated. -C In this case, A & V must be distinct arrays. -C Also, if LDA .GT. LDV, SSPEV changes all the -C elements of A thru column N. If LDA < LDV, -C SSPEV changes all the elements of V through -C column N. If LDA=LDV, only A(I,J) and V(I, -C J) for I,J = 1,...,N are changed by SSPEV. -C -C INFO* INTEGER -C on return from SSPEV, the value of INFO is -C = 0 for normal return. -C = K if the eigenvalue iteration fails to converge. -C Eigenvalues and vectors 1 through K-1 are correct. -C -C -C Error Messages- -C No. 1 recoverable N is greater than LDV and JOB is nonzero -C No. 2 recoverable N is less than one -C -C***REFERENCES (NONE) -C***ROUTINES CALLED IMTQL2, TQLRAT, TRBAK3, TRED3, XERMSG -C***REVISION HISTORY (YYMMDD) -C 800808 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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE SSPEV - INTEGER I,INFO,J,LDV,M,N - REAL A(*),E(*),V(LDV,*),WORK(*) -C***FIRST EXECUTABLE STATEMENT SSPEV - IF (N .GT. LDV) CALL XERMSG ('SLATEC', 'SSPEV', 'N .GT. LDV.', - + 1, 1) - IF(N .GT. LDV) RETURN - IF (N .LT. 1) CALL XERMSG ('SLATEC', 'SSPEV', 'N .LT. 1', 2, 1) - IF(N .LT. 1) RETURN -C -C CHECK N=1 CASE -C - E(1) = A(1) - INFO = 0 - IF(N .EQ. 1) RETURN -C - IF(JOB.NE.0) GO TO 20 -C -C EIGENVALUES ONLY -C - CALL TRED3(N,1,A,E,WORK(1),WORK(N+1)) - CALL TQLRAT(N,E,WORK(N+1),INFO) - RETURN -C -C EIGENVALUES AND EIGENVECTORS -C - 20 CALL TRED3(N,1,A,E,WORK(1),WORK(1)) - DO 30 I = 1, N - DO 25 J = 1, N - 25 V(I,J) = 0. - 30 V(I,I) = 1. - CALL IMTQL2(LDV,N,E,WORK,V,INFO) - M = N - IF(INFO .NE. 0) M = INFO - 1 - CALL TRBAK3(LDV,N,1,A,M,V) - RETURN - END diff --git a/slatec/sspfa.f b/slatec/sspfa.f deleted file mode 100644 index 227b20c..0000000 --- a/slatec/sspfa.f +++ /dev/null @@ -1,277 +0,0 @@ -*DECK SSPFA - SUBROUTINE SSPFA (AP, N, KPVT, INFO) -C***BEGIN PROLOGUE SSPFA -C***PURPOSE Factor a real symmetric matrix stored in packed form by -C elimination with symmetric pivoting. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1A -C***TYPE SINGLE PRECISION (SSPFA-S, DSPFA-D, CHPFA-C, CSPFA-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, PACKED, -C SYMMETRIC -C***AUTHOR Bunch, J., (UCSD) -C***DESCRIPTION -C -C SSPFA factors a real symmetric matrix stored in -C packed form by elimination with symmetric pivoting. -C -C To solve A*X = B , follow SSPFA by SSPSL. -C To compute INVERSE(A)*C , follow SSPFA by SSPSL. -C To compute DETERMINANT(A) , follow SSPFA by SSPDI. -C To compute INERTIA(A) , follow SSPFA by SSPDI. -C To compute INVERSE(A) , follow SSPFA by SSPDI. -C -C On Entry -C -C AP REAL (N*(N+1)/2) -C the packed form of a symmetric matrix A . The -C columns of the upper triangle are stored sequentially -C in a one-dimensional array of length N*(N+1)/2 . -C See comments below for details. -C -C N INTEGER -C the order of the matrix A . -C -C Output -C -C AP a block diagonal matrix and the multipliers which -C were used to obtain it stored in packed form. -C The factorization can be written A = U*D*TRANS(U) -C where U is a product of permutation and unit -C upper triangular matrices , TRANS(U) is the -C transpose of U , and D is block diagonal -C with 1 by 1 and 2 by 2 blocks. -C -C KPVT INTEGER(N) -C an integer vector of pivot indices. -C -C INFO INTEGER -C = 0 normal value. -C = K if the K-th pivot block is singular. This is -C not an error condition for this subroutine, -C but it does indicate that SSPSL or SSPDI may -C divide by zero if called. -C -C Packed Storage -C -C The following program segment will pack the upper -C triangle of a symmetric matrix. -C -C K = 0 -C DO 20 J = 1, N -C DO 10 I = 1, J -C K = K + 1 -C AP(K) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED ISAMAX, SAXPY, SSWAP -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Modified routine equivalence list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SSPFA - INTEGER N,KPVT(*),INFO - REAL AP(*) -C - REAL AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T - REAL ABSAKK,ALPHA,COLMAX,ROWMAX - INTEGER ISAMAX,IJ,IK,IKM1,IM,IMAX,IMAXP1,IMIM,IMJ,IMK - INTEGER J,JJ,JK,JKM1,JMAX,JMIM,K,KK,KM1,KM1K,KM1KM1,KM2,KSTEP - LOGICAL SWAP -C***FIRST EXECUTABLE STATEMENT SSPFA -C -C INITIALIZE -C -C ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE. -C - ALPHA = (1.0E0 + SQRT(17.0E0))/8.0E0 -C - INFO = 0 -C -C MAIN LOOP ON K, WHICH GOES FROM N TO 1. -C - K = N - IK = (N*(N - 1))/2 - 10 CONTINUE -C -C LEAVE THE LOOP IF K=0 OR K=1. -C - IF (K .EQ. 0) GO TO 200 - IF (K .GT. 1) GO TO 20 - KPVT(1) = 1 - IF (AP(1) .EQ. 0.0E0) INFO = 1 - GO TO 200 - 20 CONTINUE -C -C THIS SECTION OF CODE DETERMINES THE KIND OF -C ELIMINATION TO BE PERFORMED. WHEN IT IS COMPLETED, -C KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND -C SWAP WILL BE SET TO .TRUE. IF AN INTERCHANGE IS -C REQUIRED. -C - KM1 = K - 1 - KK = IK + K - ABSAKK = ABS(AP(KK)) -C -C DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN -C COLUMN K. -C - IMAX = ISAMAX(K-1,AP(IK+1),1) - IMK = IK + IMAX - COLMAX = ABS(AP(IMK)) - IF (ABSAKK .LT. ALPHA*COLMAX) GO TO 30 - KSTEP = 1 - SWAP = .FALSE. - GO TO 90 - 30 CONTINUE -C -C DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN -C ROW IMAX. -C - ROWMAX = 0.0E0 - IMAXP1 = IMAX + 1 - IM = IMAX*(IMAX - 1)/2 - IMJ = IM + 2*IMAX - DO 40 J = IMAXP1, K - ROWMAX = MAX(ROWMAX,ABS(AP(IMJ))) - IMJ = IMJ + J - 40 CONTINUE - IF (IMAX .EQ. 1) GO TO 50 - JMAX = ISAMAX(IMAX-1,AP(IM+1),1) - JMIM = JMAX + IM - ROWMAX = MAX(ROWMAX,ABS(AP(JMIM))) - 50 CONTINUE - IMIM = IMAX + IM - IF (ABS(AP(IMIM)) .LT. ALPHA*ROWMAX) GO TO 60 - KSTEP = 1 - SWAP = .TRUE. - GO TO 80 - 60 CONTINUE - IF (ABSAKK .LT. ALPHA*COLMAX*(COLMAX/ROWMAX)) GO TO 70 - KSTEP = 1 - SWAP = .FALSE. - GO TO 80 - 70 CONTINUE - KSTEP = 2 - SWAP = IMAX .NE. KM1 - 80 CONTINUE - 90 CONTINUE - IF (MAX(ABSAKK,COLMAX) .NE. 0.0E0) GO TO 100 -C -C COLUMN K IS ZERO. SET INFO AND ITERATE THE LOOP. -C - KPVT(K) = K - INFO = K - GO TO 190 - 100 CONTINUE - IF (KSTEP .EQ. 2) GO TO 140 -C -C 1 X 1 PIVOT BLOCK. -C - IF (.NOT.SWAP) GO TO 120 -C -C PERFORM AN INTERCHANGE. -C - CALL SSWAP(IMAX,AP(IM+1),1,AP(IK+1),1) - IMJ = IK + IMAX - DO 110 JJ = IMAX, K - J = K + IMAX - JJ - JK = IK + J - T = AP(JK) - AP(JK) = AP(IMJ) - AP(IMJ) = T - IMJ = IMJ - (J - 1) - 110 CONTINUE - 120 CONTINUE -C -C PERFORM THE ELIMINATION. -C - IJ = IK - (K - 1) - DO 130 JJ = 1, KM1 - J = K - JJ - JK = IK + J - MULK = -AP(JK)/AP(KK) - T = MULK - CALL SAXPY(J,T,AP(IK+1),1,AP(IJ+1),1) - AP(JK) = MULK - IJ = IJ - (J - 1) - 130 CONTINUE -C -C SET THE PIVOT ARRAY. -C - KPVT(K) = K - IF (SWAP) KPVT(K) = IMAX - GO TO 190 - 140 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - KM1K = IK + K - 1 - IKM1 = IK - (K - 1) - IF (.NOT.SWAP) GO TO 160 -C -C PERFORM AN INTERCHANGE. -C - CALL SSWAP(IMAX,AP(IM+1),1,AP(IKM1+1),1) - IMJ = IKM1 + IMAX - DO 150 JJ = IMAX, KM1 - J = KM1 + IMAX - JJ - JKM1 = IKM1 + J - T = AP(JKM1) - AP(JKM1) = AP(IMJ) - AP(IMJ) = T - IMJ = IMJ - (J - 1) - 150 CONTINUE - T = AP(KM1K) - AP(KM1K) = AP(IMK) - AP(IMK) = T - 160 CONTINUE -C -C PERFORM THE ELIMINATION. -C - KM2 = K - 2 - IF (KM2 .EQ. 0) GO TO 180 - AK = AP(KK)/AP(KM1K) - KM1KM1 = IKM1 + K - 1 - AKM1 = AP(KM1KM1)/AP(KM1K) - DENOM = 1.0E0 - AK*AKM1 - IJ = IK - (K - 1) - (K - 2) - DO 170 JJ = 1, KM2 - J = KM1 - JJ - JK = IK + J - BK = AP(JK)/AP(KM1K) - JKM1 = IKM1 + J - BKM1 = AP(JKM1)/AP(KM1K) - MULK = (AKM1*BK - BKM1)/DENOM - MULKM1 = (AK*BKM1 - BK)/DENOM - T = MULK - CALL SAXPY(J,T,AP(IK+1),1,AP(IJ+1),1) - T = MULKM1 - CALL SAXPY(J,T,AP(IKM1+1),1,AP(IJ+1),1) - AP(JK) = MULK - AP(JKM1) = MULKM1 - IJ = IJ - (J - 1) - 170 CONTINUE - 180 CONTINUE -C -C SET THE PIVOT ARRAY. -C - KPVT(K) = 1 - K - IF (SWAP) KPVT(K) = -IMAX - KPVT(K-1) = KPVT(K) - 190 CONTINUE - IK = IK - (K - 1) - IF (KSTEP .EQ. 2) IK = IK - (K - 2) - K = K - KSTEP - GO TO 10 - 200 CONTINUE - RETURN - END diff --git a/slatec/sspmv.f b/slatec/sspmv.f deleted file mode 100644 index 16cb216..0000000 --- a/slatec/sspmv.f +++ /dev/null @@ -1,269 +0,0 @@ -*DECK SSPMV - SUBROUTINE SSPMV (UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY) -C***BEGIN PROLOGUE SSPMV -C***PURPOSE Perform the matrix-vector operation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE SINGLE PRECISION (SSPMV-S, DSPMV-D, CSPMV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C SSPMV performs the matrix-vector operation -C -C y := alpha*A*x + beta*y, -C -C where alpha and beta are scalars, x and y are n element vectors and -C A is an n by n symmetric matrix, supplied in packed form. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the matrix A is supplied in the packed -C array AP as follows: -C -C UPLO = 'U' or 'u' The upper triangular part of A is -C supplied in AP. -C -C UPLO = 'L' or 'l' The lower triangular part of A is -C supplied in AP. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - REAL . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C AP - REAL array of DIMENSION at least -C ( ( n*( n + 1))/2). -C Before entry with UPLO = 'U' or 'u', the array AP must -C contain the upper triangular part of the symmetric matrix -C packed sequentially, column by column, so that AP( 1 ) -C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -C and a( 2, 2 ) respectively, and so on. -C Before entry with UPLO = 'L' or 'l', the array AP must -C contain the lower triangular part of the symmetric matrix -C packed sequentially, column by column, so that AP( 1 ) -C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -C and a( 3, 1 ) respectively, and so on. -C Unchanged on exit. -C -C X - REAL array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C BETA - REAL . -C On entry, BETA specifies the scalar beta. When BETA is -C supplied as zero then Y need not be set on input. -C Unchanged on exit. -C -C Y - REAL array of dimension at least -C ( 1 + ( n - 1 )*abs( INCY ) ). -C Before entry, the incremented array Y must contain the n -C element vector y. On exit, Y is overwritten by the updated -C vector y. -C -C INCY - INTEGER. -C On entry, INCY specifies the increment for the elements of -C Y. INCY must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE SSPMV -C .. Scalar Arguments .. - REAL ALPHA, BETA - INTEGER INCX, INCY, N - CHARACTER*1 UPLO -C .. Array Arguments .. - REAL AP( * ), X( * ), Y( * ) -C .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -C .. Local Scalars .. - REAL TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C***FIRST EXECUTABLE STATEMENT SSPMV -C -C Test the input parameters. -C - 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( 'SSPMV ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C Set up the start points in X and Y. -C - 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 -C -C Start the operations. In this version the elements of the array AP -C are accessed sequentially with one pass through AP. -C -C First form y := beta*y. -C - 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 -C -C Form y when AP contains the upper triangle. -C - 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 -C -C Form y when AP contains the lower triangle. -C - 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 -C - RETURN -C -C End of SSPMV . -C - END diff --git a/slatec/sspr.f b/slatec/sspr.f deleted file mode 100644 index fa89c93..0000000 --- a/slatec/sspr.f +++ /dev/null @@ -1,205 +0,0 @@ -*DECK SSPR - SUBROUTINE SSPR (UPLO, N, ALPHA, X, INCX, AP) -C***BEGIN PROLOGUE SSPR -C***PURPOSE Performs the symmetric rank 1 operation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE SINGLE PRECISION (SSPR-S) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C SSPR performs the symmetric rank 1 operation -C -C A := alpha*x*x' + A, -C -C where alpha is a real scalar, x is an n element vector and A is an -C n by n symmetric matrix, supplied in packed form. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the matrix A is supplied in the packed -C array AP as follows: -C -C UPLO = 'U' or 'u' The upper triangular part of A is -C supplied in AP. -C -C UPLO = 'L' or 'l' The lower triangular part of A is -C supplied in AP. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - REAL . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C X - REAL array of dimension at least -C ( 1 + ( n - 1)*abs( INCX)). -C Before entry, the incremented array X must contain the n -C element vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C AP - REAL array of DIMENSION at least -C ( ( n*( n + 1 ) )/2 ). -C Before entry with UPLO = 'U' or 'u', the array AP must -C contain the upper triangular part of the symmetric matrix -C packed sequentially, column by column, so that AP( 1 ) -C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -C and a( 2, 2 ) respectively, and so on. On exit, the array -C AP is overwritten by the upper triangular part of the -C updated matrix. -C Before entry with UPLO = 'L' or 'l', the array AP must -C contain the lower triangular part of the symmetric matrix -C packed sequentially, column by column, so that AP( 1 ) -C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -C and a( 3, 1 ) respectively, and so on. On exit, the array -C AP is overwritten by the lower triangular part of the -C updated matrix. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE SSPR -C .. Scalar Arguments .. - REAL ALPHA - INTEGER INCX, N - CHARACTER*1 UPLO -C .. Array Arguments .. - REAL AP( * ), X( * ) -C .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0E+0 ) -C .. Local Scalars .. - REAL TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C***FIRST EXECUTABLE STATEMENT SSPR -C -C Test the input parameters. -C - 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( 'SSPR ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -C -C Set the start point in X if the increment is not unity. -C - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -C -C Start the operations. In this version the elements of the array AP -C are accessed sequentially with one pass through AP. -C - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -C -C Form A when upper triangle is stored in AP. -C - 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 -C -C Form A when lower triangle is stored in AP. -C - 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 -C - RETURN -C -C End of SSPR . -C - END diff --git a/slatec/sspr2.f b/slatec/sspr2.f deleted file mode 100644 index 20649d3..0000000 --- a/slatec/sspr2.f +++ /dev/null @@ -1,236 +0,0 @@ -*DECK SSPR2 - SUBROUTINE SSPR2 (UPLO, N, ALPHA, X, INCX, Y, INCY, AP) -C***BEGIN PROLOGUE SSPR2 -C***PURPOSE Perform the symmetric rank 2 operation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE SINGLE PRECISION (SSPR2-S, DSPR2-D, CSPR2-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C SSPR2 performs the symmetric rank 2 operation -C -C A := alpha*x*y' + alpha*y*x' + A, -C -C where alpha is a scalar, x and y are n element vectors and A is an -C n by n symmetric matrix, supplied in packed form. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the matrix A is supplied in the packed -C array AP as follows: -C -C UPLO = 'U' or 'u' The upper triangular part of A is -C supplied in AP. -C -C UPLO = 'L' or 'l' The lower triangular part of A is -C supplied in AP. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - REAL . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C X - REAL array of dimension at least -C ( 1 + ( n - 1)*abs( INCX)). -C Before entry, the incremented array X must contain the n -C element vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C Y - REAL array of dimension at least -C ( 1 + ( n - 1 )*abs( INCY ) ). -C Before entry, the incremented array Y must contain the n -C element vector y. -C Unchanged on exit. -C -C INCY - INTEGER. -C On entry, INCY specifies the increment for the elements of -C Y. INCY must not be zero. -C Unchanged on exit. -C -C AP - REAL array of DIMENSION at least -C ( ( n*( n + 1 ) )/2 ). -C Before entry with UPLO = 'U' or 'u', the array AP must -C contain the upper triangular part of the symmetric matrix -C packed sequentially, column by column, so that AP( 1 ) -C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -C and a( 2, 2 ) respectively, and so on. On exit, the array -C AP is overwritten by the upper triangular part of the -C updated matrix. -C Before entry with UPLO = 'L' or 'l', the array AP must -C contain the lower triangular part of the symmetric matrix -C packed sequentially, column by column, so that AP( 1 ) -C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -C and a( 3, 1 ) respectively, and so on. On exit, the array -C AP is overwritten by the lower triangular part of the -C updated matrix. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE SSPR2 -C .. Scalar Arguments .. - REAL ALPHA - INTEGER INCX, INCY, N - CHARACTER*1 UPLO -C .. Array Arguments .. - REAL AP( * ), X( * ), Y( * ) -C .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0E+0 ) -C .. Local Scalars .. - REAL TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C***FIRST EXECUTABLE STATEMENT SSPR2 -C -C Test the input parameters. -C - 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( 'SSPR2 ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -C -C Set up the start points in X and Y if the increments are not both -C unity. -C - 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 -C -C Start the operations. In this version the elements of the array AP -C are accessed sequentially with one pass through AP. -C - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -C -C Form A when upper triangle is stored in AP. -C - 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 -C -C Form A when lower triangle is stored in AP. -C - 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 -C - RETURN -C -C End of SSPR2 . -C - END diff --git a/slatec/sspsl.f b/slatec/sspsl.f deleted file mode 100644 index 9f398a0..0000000 --- a/slatec/sspsl.f +++ /dev/null @@ -1,196 +0,0 @@ -*DECK SSPSL - SUBROUTINE SSPSL (AP, N, KPVT, B) -C***BEGIN PROLOGUE SSPSL -C***PURPOSE Solve a real symmetric system using the factors obtained -C from SSPFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2B1A -C***TYPE SINGLE PRECISION (SSPSL-S, DSPSL-D, CHPSL-C, CSPSL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, PACKED, SOLVE, SYMMETRIC -C***AUTHOR Bunch, J., (UCSD) -C***DESCRIPTION -C -C SSISL solves the real symmetric system -C A * X = B -C using the factors computed by SSPFA. -C -C On Entry -C -C AP REAL(N*(N+1)/2) -C the output from SSPFA. -C -C N INTEGER -C the order of the matrix A . -C -C KPVT INTEGER(N) -C the pivot vector from SSPFA. -C -C B REAL(N) -C the right hand side vector. -C -C On Return -C -C B the solution vector X . -C -C Error Condition -C -C A division by zero may occur if SSPCO has set RCOND .EQ. 0.0 -C or SSPFA has set INFO .NE. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL SSPFA(AP,N,KPVT,INFO) -C IF (INFO .NE. 0) GO TO ... -C DO 10 J = 1, P -C CALL SSPSL(AP,N,KPVT,C(1,J)) -C 10 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SAXPY, SDOT -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891107 Modified routine equivalence list. (WRB) -C 891107 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SSPSL - INTEGER N,KPVT(*) - REAL AP(*),B(*) -C - REAL AK,AKM1,BK,BKM1,SDOT,DENOM,TEMP - INTEGER IK,IKM1,IKP1,K,KK,KM1K,KM1KM1,KP -C -C LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND -C D INVERSE TO B. -C -C***FIRST EXECUTABLE STATEMENT SSPSL - K = N - IK = (N*(N - 1))/2 - 10 IF (K .EQ. 0) GO TO 80 - KK = IK + K - IF (KPVT(K) .LT. 0) GO TO 40 -C -C 1 X 1 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 30 - KP = KPVT(K) - IF (KP .EQ. K) GO TO 20 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 20 CONTINUE -C -C APPLY THE TRANSFORMATION. -C - CALL SAXPY(K-1,B(K),AP(IK+1),1,B(1),1) - 30 CONTINUE -C -C APPLY D INVERSE. -C - B(K) = B(K)/AP(KK) - K = K - 1 - IK = IK - K - GO TO 70 - 40 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - IKM1 = IK - (K - 1) - IF (K .EQ. 2) GO TO 60 - KP = ABS(KPVT(K)) - IF (KP .EQ. K - 1) GO TO 50 -C -C INTERCHANGE. -C - TEMP = B(K-1) - B(K-1) = B(KP) - B(KP) = TEMP - 50 CONTINUE -C -C APPLY THE TRANSFORMATION. -C - CALL SAXPY(K-2,B(K),AP(IK+1),1,B(1),1) - CALL SAXPY(K-2,B(K-1),AP(IKM1+1),1,B(1),1) - 60 CONTINUE -C -C APPLY D INVERSE. -C - KM1K = IK + K - 1 - KK = IK + K - AK = AP(KK)/AP(KM1K) - KM1KM1 = IKM1 + K - 1 - AKM1 = AP(KM1KM1)/AP(KM1K) - BK = B(K)/AP(KM1K) - BKM1 = B(K-1)/AP(KM1K) - DENOM = AK*AKM1 - 1.0E0 - B(K) = (AKM1*BK - BKM1)/DENOM - B(K-1) = (AK*BKM1 - BK)/DENOM - K = K - 2 - IK = IK - (K + 1) - K - 70 CONTINUE - GO TO 10 - 80 CONTINUE -C -C LOOP FORWARD APPLYING THE TRANSFORMATIONS. -C - K = 1 - IK = 0 - 90 IF (K .GT. N) GO TO 160 - IF (KPVT(K) .LT. 0) GO TO 120 -C -C 1 X 1 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 110 -C -C APPLY THE TRANSFORMATION. -C - B(K) = B(K) + SDOT(K-1,AP(IK+1),1,B(1),1) - KP = KPVT(K) - IF (KP .EQ. K) GO TO 100 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 100 CONTINUE - 110 CONTINUE - IK = IK + K - K = K + 1 - GO TO 150 - 120 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 140 -C -C APPLY THE TRANSFORMATION. -C - B(K) = B(K) + SDOT(K-1,AP(IK+1),1,B(1),1) - IKP1 = IK + K - B(K+1) = B(K+1) + SDOT(K-1,AP(IKP1+1),1,B(1),1) - KP = ABS(KPVT(K)) - IF (KP .EQ. K) GO TO 130 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 130 CONTINUE - 140 CONTINUE - IK = IK + K + K + 1 - K = K + 2 - 150 CONTINUE - GO TO 90 - 160 CONTINUE - RETURN - END diff --git a/slatec/ssvdc.f b/slatec/ssvdc.f deleted file mode 100644 index c2893e4..0000000 --- a/slatec/ssvdc.f +++ /dev/null @@ -1,487 +0,0 @@ -*DECK SSVDC - SUBROUTINE SSVDC (X, LDX, N, P, S, E, U, LDU, V, LDV, WORK, JOB, - + INFO) -C***BEGIN PROLOGUE SSVDC -C***PURPOSE Perform the singular value decomposition of a rectangular -C matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D6 -C***TYPE SINGLE PRECISION (SSVDC-S, DSVDC-D, CSVDC-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, -C SINGULAR VALUE DECOMPOSITION -C***AUTHOR Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C SSVDC is a subroutine to reduce a real NxP matrix X by orthogonal -C transformations U and V to diagonal form. The elements S(I) are -C the singular values of X. The columns of U are the corresponding -C left singular vectors, and the columns of V the right singular -C vectors. -C -C On Entry -C -C X REAL(LDX,P), where LDX .GE. N. -C X contains the matrix whose singular value -C decomposition is to be computed. X is -C destroyed by SSVDC. -C -C LDX INTEGER -C LDX is the leading dimension of the array X. -C -C N INTEGER -C N is the number of rows of the matrix X. -C -C P INTEGER -C P is the number of columns of the matrix X. -C -C LDU INTEGER -C LDU is the leading dimension of the array U. -C (See below). -C -C LDV INTEGER -C LDV is the leading dimension of the array V. -C (See below). -C -C WORK REAL(N) -C work is a scratch array. -C -C JOB INTEGER -C JOB controls the computation of the singular -C vectors. It has the decimal expansion AB -C with the following meaning -C -C A .EQ. 0 Do not compute the left singular -C vectors. -C A .EQ. 1 Return the N left singular vectors -C in U. -C A .GE. 2 Return the first MIN(N,P) singular -C vectors in U. -C B .EQ. 0 Do not compute the right singular -C vectors. -C B .EQ. 1 Return the right singular vectors -C in V. -C -C On Return -C -C S REAL(MM), where MM=MIN(N+1,P). -C The first MIN(N,P) entries of S contain the -C singular values of X arranged in descending -C order of magnitude. -C -C E REAL(P). -C E ordinarily contains zeros. However, see the -C discussion of INFO for exceptions. -C -C U REAL(LDU,K), where LDU .GE. N. If JOBA .EQ. 1, then -C K .EQ. N. If JOBA .GE. 2 , then -C K .EQ. MIN(N,P). -C U contains the matrix of right singular vectors. -C U is not referenced if JOBA .EQ. 0. If N .LE. P -C or if JOBA .EQ. 2, then U may be identified with X -C in the subroutine call. -C -C V REAL(LDV,P), where LDV .GE. P. -C V contains the matrix of right singular vectors. -C V is not referenced if JOB .EQ. 0. If P .LE. N, -C then V may be identified with X in the -C subroutine call. -C -C INFO INTEGER. -C the singular values (and their corresponding -C singular vectors) S(INFO+1),S(INFO+2),...,S(M) -C are correct (here M=MIN(N,P)). Thus if -C INFO .EQ. 0, all the singular values and their -C vectors are correct. In any event, the matrix -C B = TRANS(U)*X*V is the bidiagonal matrix -C with the elements of S on its diagonal and the -C elements of E on its super-diagonal (TRANS(U) -C is the transpose of U). Thus the singular -C values of X and B are the same. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SAXPY, SDOT, SNRM2, SROT, SROTG, SSCAL, SSWAP -C***REVISION HISTORY (YYMMDD) -C 790319 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SSVDC - INTEGER LDX,N,P,LDU,LDV,JOB,INFO - REAL X(LDX,*),S(*),E(*),U(LDU,*),V(LDV,*),WORK(*) -C -C - INTEGER I,ITER,J,JOBU,K,KASE,KK,L,LL,LLS,LM1,LP1,LS,LU,M,MAXIT, - 1 MM,MM1,MP1,NCT,NCTP1,NCU,NRT,NRTP1 - REAL SDOT,T - REAL B,C,CS,EL,EMM1,F,G,SNRM2,SCALE,SHIFT,SL,SM,SN,SMM1,T1,TEST, - 1 ZTEST - LOGICAL WANTU,WANTV -C***FIRST EXECUTABLE STATEMENT SSVDC -C -C SET THE MAXIMUM NUMBER OF ITERATIONS. -C - MAXIT = 30 -C -C DETERMINE WHAT IS TO BE COMPUTED. -C - WANTU = .FALSE. - WANTV = .FALSE. - JOBU = MOD(JOB,100)/10 - NCU = N - IF (JOBU .GT. 1) NCU = MIN(N,P) - IF (JOBU .NE. 0) WANTU = .TRUE. - IF (MOD(JOB,10) .NE. 0) WANTV = .TRUE. -C -C REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS -C IN S AND THE SUPER-DIAGONAL ELEMENTS IN E. -C - INFO = 0 - NCT = MIN(N-1,P) - NRT = MAX(0,MIN(P-2,N)) - LU = MAX(NCT,NRT) - IF (LU .LT. 1) GO TO 170 - DO 160 L = 1, LU - LP1 = L + 1 - IF (L .GT. NCT) GO TO 20 -C -C COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND -C PLACE THE L-TH DIAGONAL IN S(L). -C - S(L) = SNRM2(N-L+1,X(L,L),1) - IF (S(L) .EQ. 0.0E0) GO TO 10 - IF (X(L,L) .NE. 0.0E0) S(L) = SIGN(S(L),X(L,L)) - CALL SSCAL(N-L+1,1.0E0/S(L),X(L,L),1) - X(L,L) = 1.0E0 + X(L,L) - 10 CONTINUE - S(L) = -S(L) - 20 CONTINUE - IF (P .LT. LP1) GO TO 50 - DO 40 J = LP1, P - IF (L .GT. NCT) GO TO 30 - IF (S(L) .EQ. 0.0E0) GO TO 30 -C -C APPLY THE TRANSFORMATION. -C - T = -SDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L) - CALL SAXPY(N-L+1,T,X(L,L),1,X(L,J),1) - 30 CONTINUE -C -C PLACE THE L-TH ROW OF X INTO E FOR THE -C SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION. -C - E(J) = X(L,J) - 40 CONTINUE - 50 CONTINUE - IF (.NOT.WANTU .OR. L .GT. NCT) GO TO 70 -C -C PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK -C MULTIPLICATION. -C - DO 60 I = L, N - U(I,L) = X(I,L) - 60 CONTINUE - 70 CONTINUE - IF (L .GT. NRT) GO TO 150 -C -C COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE -C L-TH SUPER-DIAGONAL IN E(L). -C - E(L) = SNRM2(P-L,E(LP1),1) - IF (E(L) .EQ. 0.0E0) GO TO 80 - IF (E(LP1) .NE. 0.0E0) E(L) = SIGN(E(L),E(LP1)) - CALL SSCAL(P-L,1.0E0/E(L),E(LP1),1) - E(LP1) = 1.0E0 + E(LP1) - 80 CONTINUE - E(L) = -E(L) - IF (LP1 .GT. N .OR. E(L) .EQ. 0.0E0) GO TO 120 -C -C APPLY THE TRANSFORMATION. -C - DO 90 I = LP1, N - WORK(I) = 0.0E0 - 90 CONTINUE - DO 100 J = LP1, P - CALL SAXPY(N-L,E(J),X(LP1,J),1,WORK(LP1),1) - 100 CONTINUE - DO 110 J = LP1, P - CALL SAXPY(N-L,-E(J)/E(LP1),WORK(LP1),1,X(LP1,J),1) - 110 CONTINUE - 120 CONTINUE - IF (.NOT.WANTV) GO TO 140 -C -C PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT -C BACK MULTIPLICATION. -C - DO 130 I = LP1, P - V(I,L) = E(I) - 130 CONTINUE - 140 CONTINUE - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE -C -C SET UP THE FINAL BIDIAGONAL MATRIX OR ORDER M. -C - M = MIN(P,N+1) - NCTP1 = NCT + 1 - NRTP1 = NRT + 1 - IF (NCT .LT. P) S(NCTP1) = X(NCTP1,NCTP1) - IF (N .LT. M) S(M) = 0.0E0 - IF (NRTP1 .LT. M) E(NRTP1) = X(NRTP1,M) - E(M) = 0.0E0 -C -C IF REQUIRED, GENERATE U. -C - IF (.NOT.WANTU) GO TO 300 - IF (NCU .LT. NCTP1) GO TO 200 - DO 190 J = NCTP1, NCU - DO 180 I = 1, N - U(I,J) = 0.0E0 - 180 CONTINUE - U(J,J) = 1.0E0 - 190 CONTINUE - 200 CONTINUE - IF (NCT .LT. 1) GO TO 290 - DO 280 LL = 1, NCT - L = NCT - LL + 1 - IF (S(L) .EQ. 0.0E0) GO TO 250 - LP1 = L + 1 - IF (NCU .LT. LP1) GO TO 220 - DO 210 J = LP1, NCU - T = -SDOT(N-L+1,U(L,L),1,U(L,J),1)/U(L,L) - CALL SAXPY(N-L+1,T,U(L,L),1,U(L,J),1) - 210 CONTINUE - 220 CONTINUE - CALL SSCAL(N-L+1,-1.0E0,U(L,L),1) - U(L,L) = 1.0E0 + U(L,L) - LM1 = L - 1 - IF (LM1 .LT. 1) GO TO 240 - DO 230 I = 1, LM1 - U(I,L) = 0.0E0 - 230 CONTINUE - 240 CONTINUE - GO TO 270 - 250 CONTINUE - DO 260 I = 1, N - U(I,L) = 0.0E0 - 260 CONTINUE - U(L,L) = 1.0E0 - 270 CONTINUE - 280 CONTINUE - 290 CONTINUE - 300 CONTINUE -C -C IF IT IS REQUIRED, GENERATE V. -C - IF (.NOT.WANTV) GO TO 350 - DO 340 LL = 1, P - L = P - LL + 1 - LP1 = L + 1 - IF (L .GT. NRT) GO TO 320 - IF (E(L) .EQ. 0.0E0) GO TO 320 - DO 310 J = LP1, P - T = -SDOT(P-L,V(LP1,L),1,V(LP1,J),1)/V(LP1,L) - CALL SAXPY(P-L,T,V(LP1,L),1,V(LP1,J),1) - 310 CONTINUE - 320 CONTINUE - DO 330 I = 1, P - V(I,L) = 0.0E0 - 330 CONTINUE - V(L,L) = 1.0E0 - 340 CONTINUE - 350 CONTINUE -C -C MAIN ITERATION LOOP FOR THE SINGULAR VALUES. -C - MM = M - ITER = 0 - 360 CONTINUE -C -C QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND. -C - IF (M .EQ. 0) GO TO 620 -C -C IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET -C FLAG AND RETURN. -C - IF (ITER .LT. MAXIT) GO TO 370 - INFO = M - GO TO 620 - 370 CONTINUE -C -C THIS SECTION OF THE PROGRAM INSPECTS FOR -C NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS. ON -C COMPLETION THE VARIABLES KASE AND L ARE SET AS FOLLOWS. -C -C KASE = 1 IF S(M) AND E(L-1) ARE NEGLIGIBLE AND L.LT.M -C KASE = 2 IF S(L) IS NEGLIGIBLE AND L.LT.M -C KASE = 3 IF E(L-1) IS NEGLIGIBLE, L.LT.M, AND -C S(L), ..., S(M) ARE NOT NEGLIGIBLE (QR STEP). -C KASE = 4 IF E(M-1) IS NEGLIGIBLE (CONVERGENCE). -C - DO 390 LL = 1, M - L = M - LL - IF (L .EQ. 0) GO TO 400 - TEST = ABS(S(L)) + ABS(S(L+1)) - ZTEST = TEST + ABS(E(L)) - IF (ZTEST .NE. TEST) GO TO 380 - E(L) = 0.0E0 - GO TO 400 - 380 CONTINUE - 390 CONTINUE - 400 CONTINUE - IF (L .NE. M - 1) GO TO 410 - KASE = 4 - GO TO 480 - 410 CONTINUE - LP1 = L + 1 - MP1 = M + 1 - DO 430 LLS = LP1, MP1 - LS = M - LLS + LP1 - IF (LS .EQ. L) GO TO 440 - TEST = 0.0E0 - IF (LS .NE. M) TEST = TEST + ABS(E(LS)) - IF (LS .NE. L + 1) TEST = TEST + ABS(E(LS-1)) - ZTEST = TEST + ABS(S(LS)) - IF (ZTEST .NE. TEST) GO TO 420 - S(LS) = 0.0E0 - GO TO 440 - 420 CONTINUE - 430 CONTINUE - 440 CONTINUE - IF (LS .NE. L) GO TO 450 - KASE = 3 - GO TO 470 - 450 CONTINUE - IF (LS .NE. M) GO TO 460 - KASE = 1 - GO TO 470 - 460 CONTINUE - KASE = 2 - L = LS - 470 CONTINUE - 480 CONTINUE - L = L + 1 -C -C PERFORM THE TASK INDICATED BY KASE. -C - GO TO (490,520,540,570), KASE -C -C DEFLATE NEGLIGIBLE S(M). -C - 490 CONTINUE - MM1 = M - 1 - F = E(M-1) - E(M-1) = 0.0E0 - DO 510 KK = L, MM1 - K = MM1 - KK + L - T1 = S(K) - CALL SROTG(T1,F,CS,SN) - S(K) = T1 - IF (K .EQ. L) GO TO 500 - F = -SN*E(K-1) - E(K-1) = CS*E(K-1) - 500 CONTINUE - IF (WANTV) CALL SROT(P,V(1,K),1,V(1,M),1,CS,SN) - 510 CONTINUE - GO TO 610 -C -C SPLIT AT NEGLIGIBLE S(L). -C - 520 CONTINUE - F = E(L-1) - E(L-1) = 0.0E0 - DO 530 K = L, M - T1 = S(K) - CALL SROTG(T1,F,CS,SN) - S(K) = T1 - F = -SN*E(K) - E(K) = CS*E(K) - IF (WANTU) CALL SROT(N,U(1,K),1,U(1,L-1),1,CS,SN) - 530 CONTINUE - GO TO 610 -C -C PERFORM ONE QR STEP. -C - 540 CONTINUE -C -C CALCULATE THE SHIFT. -C - SCALE = MAX(ABS(S(M)),ABS(S(M-1)),ABS(E(M-1)),ABS(S(L)), - 1 ABS(E(L))) - SM = S(M)/SCALE - SMM1 = S(M-1)/SCALE - EMM1 = E(M-1)/SCALE - SL = S(L)/SCALE - EL = E(L)/SCALE - B = ((SMM1 + SM)*(SMM1 - SM) + EMM1**2)/2.0E0 - C = (SM*EMM1)**2 - SHIFT = 0.0E0 - IF (B .EQ. 0.0E0 .AND. C .EQ. 0.0E0) GO TO 550 - SHIFT = SQRT(B**2+C) - IF (B .LT. 0.0E0) SHIFT = -SHIFT - SHIFT = C/(B + SHIFT) - 550 CONTINUE - F = (SL + SM)*(SL - SM) - SHIFT - G = SL*EL -C -C CHASE ZEROS. -C - MM1 = M - 1 - DO 560 K = L, MM1 - CALL SROTG(F,G,CS,SN) - IF (K .NE. L) E(K-1) = F - F = CS*S(K) + SN*E(K) - E(K) = CS*E(K) - SN*S(K) - G = SN*S(K+1) - S(K+1) = CS*S(K+1) - IF (WANTV) CALL SROT(P,V(1,K),1,V(1,K+1),1,CS,SN) - CALL SROTG(F,G,CS,SN) - S(K) = F - F = CS*E(K) + SN*S(K+1) - S(K+1) = -SN*E(K) + CS*S(K+1) - G = SN*E(K+1) - E(K+1) = CS*E(K+1) - IF (WANTU .AND. K .LT. N) - 1 CALL SROT(N,U(1,K),1,U(1,K+1),1,CS,SN) - 560 CONTINUE - E(M-1) = F - ITER = ITER + 1 - GO TO 610 -C -C CONVERGENCE. -C - 570 CONTINUE -C -C MAKE THE SINGULAR VALUE POSITIVE. -C - IF (S(L) .GE. 0.0E0) GO TO 580 - S(L) = -S(L) - IF (WANTV) CALL SSCAL(P,-1.0E0,V(1,L),1) - 580 CONTINUE -C -C ORDER THE SINGULAR VALUE. -C - 590 IF (L .EQ. MM) GO TO 600 - IF (S(L) .GE. S(L+1)) GO TO 600 - T = S(L) - S(L) = S(L+1) - S(L+1) = T - IF (WANTV .AND. L .LT. P) - 1 CALL SSWAP(P,V(1,L),1,V(1,L+1),1) - IF (WANTU .AND. L .LT. N) - 1 CALL SSWAP(N,U(1,L),1,U(1,L+1),1) - L = L + 1 - GO TO 590 - 600 CONTINUE - ITER = 0 - M = M - 1 - 610 CONTINUE - GO TO 360 - 620 CONTINUE - RETURN - END diff --git a/slatec/sswap.f b/slatec/sswap.f deleted file mode 100644 index 1424ce9..0000000 --- a/slatec/sswap.f +++ /dev/null @@ -1,102 +0,0 @@ -*DECK SSWAP - SUBROUTINE SSWAP (N, SX, INCX, SY, INCY) -C***BEGIN PROLOGUE SSWAP -C***PURPOSE Interchange two vectors. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A5 -C***TYPE SINGLE PRECISION (SSWAP-S, DSWAP-D, CSWAP-C, ISWAP-I) -C***KEYWORDS BLAS, INTERCHANGE, 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 SX input vector SY (unchanged if N .LE. 0) -C SY input vector SX (unchanged if N .LE. 0) -C -C Interchange single precision SX and single precision SY. -C For I = 0 to N-1, interchange SX(LX+I*INCX) and 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 SSWAP - REAL SX(*), SY(*), STEMP1, STEMP2, STEMP3 -C***FIRST EXECUTABLE STATEMENT SSWAP - IF (N .LE. 0) RETURN - IF (INCX .EQ. INCY) IF (INCX-1) 5,20,60 -C -C Code for unequal or nonpositive increments. -C - 5 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 - STEMP1 = SX(IX) - SX(IX) = SY(IY) - SY(IY) = STEMP1 - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -C -C Code for both increments equal to 1. -C -C Clean-up loop so remaining vector length is a multiple of 3. -C - 20 M = MOD(N,3) - IF (M .EQ. 0) GO TO 40 - DO 30 I = 1,M - STEMP1 = SX(I) - SX(I) = SY(I) - SY(I) = STEMP1 - 30 CONTINUE - IF (N .LT. 3) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,3 - STEMP1 = SX(I) - STEMP2 = SX(I+1) - STEMP3 = SX(I+2) - SX(I) = SY(I) - SX(I+1) = SY(I+1) - SX(I+2) = SY(I+2) - SY(I) = STEMP1 - SY(I+1) = STEMP2 - SY(I+2) = STEMP3 - 50 CONTINUE - RETURN -C -C Code for equal, positive, non-unit increments. -C - 60 NS = N*INCX - DO 70 I = 1,NS,INCX - STEMP1 = SX(I) - SX(I) = SY(I) - SY(I) = STEMP1 - 70 CONTINUE - RETURN - END diff --git a/slatec/ssymm.f b/slatec/ssymm.f deleted file mode 100644 index a777991..0000000 --- a/slatec/ssymm.f +++ /dev/null @@ -1,300 +0,0 @@ -*DECK SSYMM - SUBROUTINE SSYMM (SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, - $ C, LDC) -C***BEGIN PROLOGUE SSYMM -C***PURPOSE Multiply a real general matrix by a real symmetric matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B6 -C***TYPE SINGLE PRECISION (SSYMM-S, DSYMM-D, CSYMM-C) -C***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J., (ANL) -C Duff, I., (AERE) -C Du Croz, J., (NAG) -C Hammarling, S. (NAG) -C***DESCRIPTION -C -C SSYMM performs one of the matrix-matrix operations -C -C C := alpha*A*B + beta*C, -C -C or -C -C C := alpha*B*A + beta*C, -C -C where alpha and beta are scalars, A is a symmetric matrix and B and -C C are m by n matrices. -C -C Parameters -C ========== -C -C SIDE - CHARACTER*1. -C On entry, SIDE specifies whether the symmetric matrix A -C appears on the left or right in the operation as follows: -C -C SIDE = 'L' or 'l' C := alpha*A*B + beta*C, -C -C SIDE = 'R' or 'r' C := alpha*B*A + beta*C, -C -C Unchanged on exit. -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the symmetric matrix A is to be -C referenced as follows: -C -C UPLO = 'U' or 'u' Only the upper triangular part of the -C symmetric matrix is to be referenced. -C -C UPLO = 'L' or 'l' Only the lower triangular part of the -C symmetric matrix is to be referenced. -C -C Unchanged on exit. -C -C M - INTEGER. -C On entry, M specifies the number of rows of the matrix C. -C M must be at least zero. -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the number of columns of the matrix C. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - REAL . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C A - REAL array of DIMENSION ( LDA, ka ), where ka is -C m when SIDE = 'L' or 'l' and is n otherwise. -C Before entry with SIDE = 'L' or 'l', the m by m part of -C the array A must contain the symmetric matrix, such that -C when UPLO = 'U' or 'u', the leading m by m upper triangular -C part of the array A must contain the upper triangular part -C of the symmetric matrix and the strictly lower triangular -C part of A is not referenced, and when UPLO = 'L' or 'l', -C the leading m by m lower triangular part of the array A -C must contain the lower triangular part of the symmetric -C matrix and the strictly upper triangular part of A is not -C referenced. -C Before entry with SIDE = 'R' or 'r', the n by n part of -C the array A must contain the symmetric matrix, such that -C when UPLO = 'U' or 'u', the leading n by n upper triangular -C part of the array A must contain the upper triangular part -C of the symmetric matrix and the strictly lower triangular -C part of A is not referenced, and when UPLO = 'L' or 'l', -C the leading n by n lower triangular part of the array A -C must contain the lower triangular part of the symmetric -C matrix and the strictly upper triangular part of A is not -C referenced. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. When SIDE = 'L' or 'l' then -C LDA must be at least max( 1, m ), otherwise LDA must be at -C least max( 1, n ). -C Unchanged on exit. -C -C B - REAL array of DIMENSION ( LDB, n ). -C Before entry, the leading m by n part of the array B must -C contain the matrix B. -C Unchanged on exit. -C -C LDB - INTEGER. -C On entry, LDB specifies the first dimension of B as declared -C in the calling (sub) program. LDB must be at least -C max( 1, m ). -C Unchanged on exit. -C -C BETA - REAL . -C On entry, BETA specifies the scalar beta. When BETA is -C supplied as zero then C need not be set on input. -C Unchanged on exit. -C -C C - REAL array of DIMENSION ( LDC, n ). -C Before entry, the leading m by n part of the array C must -C contain the matrix C, except when beta is zero, in which -C case C need not be set on entry. -C On exit, the array C is overwritten by the m by n updated -C matrix. -C -C LDC - INTEGER. -C On entry, LDC specifies the first dimension of C as declared -C in the calling (sub) program. LDC must be at least -C max( 1, m ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. -C A set of level 3 basic linear algebra subprograms. -C ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 890208 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE SSYMM -C .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO - INTEGER M, N, LDA, LDB, LDC - REAL ALPHA, BETA -C .. Array Arguments .. - REAL A( LDA, * ), B( LDB, * ), C( LDC, * ) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, K, NROWA - REAL TEMP1, TEMP2 -C .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -C***FIRST EXECUTABLE STATEMENT SSYMM -C -C Set NROWA as the number of rows of A. -C - IF( LSAME( SIDE, 'L' ) )THEN - NROWA = M - ELSE - NROWA = N - END IF - UPPER = LSAME( UPLO, 'U' ) -C -C Test the input parameters. -C - 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( 'SSYMM ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C And when alpha.eq.zero. -C - 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 -C -C Start the operations. -C - IF( LSAME( SIDE, 'L' ) )THEN -C -C Form C := alpha*A*B + beta*C. -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 -C -C Form C := alpha*B*A + beta*C. -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 -C - RETURN -C -C End of SSYMM . -C - END diff --git a/slatec/ssymv.f b/slatec/ssymv.f deleted file mode 100644 index df6e25a..0000000 --- a/slatec/ssymv.f +++ /dev/null @@ -1,268 +0,0 @@ -*DECK SSYMV - SUBROUTINE SSYMV (UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) -C***BEGIN PROLOGUE SSYMV -C***PURPOSE Multiply a real vector by a real symmetric matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE SINGLE PRECISION (SSYMV-S, DSYMV-D, CSYMV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C SSYMV performs the matrix-vector operation -C -C y := alpha*A*x + beta*y, -C -C where alpha and beta are scalars, x and y are n element vectors and -C A is an n by n symmetric matrix. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the array A is to be referenced as -C follows: -C -C UPLO = 'U' or 'u' Only the upper triangular part of A -C is to be referenced. -C -C UPLO = 'L' or 'l' Only the lower triangular part of A -C is to be referenced. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - REAL . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C A - REAL array of DIMENSION ( LDA, n ). -C Before entry with UPLO = 'U' or 'u', the leading n by n -C upper triangular part of the array A must contain the upper -C triangular part of the symmetric matrix and the strictly -C lower triangular part of A is not referenced. -C Before entry with UPLO = 'L' or 'l', the leading n by n -C lower triangular part of the array A must contain the lower -C triangular part of the symmetric matrix and the strictly -C upper triangular part of A is not referenced. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C max( 1, n ). -C Unchanged on exit. -C -C X - REAL array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C BETA - REAL . -C On entry, BETA specifies the scalar beta. When BETA is -C supplied as zero then Y need not be set on input. -C Unchanged on exit. -C -C Y - REAL array of dimension at least -C ( 1 + ( n - 1 )*abs( INCY ) ). -C Before entry, the incremented array Y must contain the n -C element vector y. On exit, Y is overwritten by the updated -C vector y. -C -C INCY - INTEGER. -C On entry, INCY specifies the increment for the elements of -C Y. INCY must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE SSYMV -C .. Scalar Arguments .. - REAL ALPHA, BETA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -C .. Array Arguments .. - REAL A( LDA, * ), X( * ), Y( * ) -C .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -C .. Local Scalars .. - REAL TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C***FIRST EXECUTABLE STATEMENT SSYMV -C -C Test the input parameters. -C - 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( 'SSYMV ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C Set up the start points in X and Y. -C - 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 -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through the triangular part -C of A. -C -C First form y := beta*y. -C - 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 -C -C Form y when A is stored in upper triangle. -C - 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 -C -C Form y when A is stored in lower triangle. -C - 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 -C - RETURN -C -C End of SSYMV . -C - END diff --git a/slatec/ssyr.f b/slatec/ssyr.f deleted file mode 100644 index d3677bf..0000000 --- a/slatec/ssyr.f +++ /dev/null @@ -1,204 +0,0 @@ -*DECK SSYR - SUBROUTINE SSYR (UPLO, N, ALPHA, X, INCX, A, LDA) -C***BEGIN PROLOGUE SSYR -C***PURPOSE Perform symmetric rank 1 update of a real symmetric matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE SINGLE PRECISION (SSYR-S) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C SSYR performs the symmetric rank 1 operation -C -C A := alpha*x*x' + A, -C -C where alpha is a real scalar, x is an n element vector and A is an -C n by n symmetric matrix. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the array A is to be referenced as -C follows: -C -C UPLO = 'U' or 'u' Only the upper triangular part of A -C is to be referenced. -C -C UPLO = 'L' or 'l' Only the lower triangular part of A -C is to be referenced. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - REAL . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C X - REAL array of dimension at least -C ( 1 + ( n - 1)*abs( INCX)). -C Before entry, the incremented array X must contain the n -C element vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C A - REAL array of DIMENSION ( LDA, n ). -C Before entry with UPLO = 'U' or 'u', the leading n by n -C upper triangular part of the array A must contain the upper -C triangular part of the symmetric matrix and the strictly -C lower triangular part of A is not referenced. On exit, the -C upper triangular part of the array A is overwritten by the -C upper triangular part of the updated matrix. -C Before entry with UPLO = 'L' or 'l', the leading n by n -C lower triangular part of the array A must contain the lower -C triangular part of the symmetric matrix and the strictly -C upper triangular part of A is not referenced. On exit, the -C lower triangular part of the array A is overwritten by the -C lower triangular part of the updated matrix. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C max( 1, n ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE SSYR -C .. Scalar Arguments .. - REAL ALPHA - INTEGER INCX, LDA, N - CHARACTER*1 UPLO -C .. Array Arguments .. - REAL A( LDA, * ), X( * ) -C .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0E+0 ) -C .. Local Scalars .. - REAL TEMP - INTEGER I, INFO, IX, J, JX, KX -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C***FIRST EXECUTABLE STATEMENT SSYR -C -C Test the input parameters. -C - 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( 'SSYR ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -C -C Set the start point in X if the increment is not unity. -C - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through the triangular part -C of A. -C - IF( LSAME( UPLO, 'U' ) )THEN -C -C Form A when A is stored in upper triangle. -C - 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 -C -C Form A when A is stored in lower triangle. -C - 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 -C - RETURN -C -C End of SSYR . -C - END diff --git a/slatec/ssyr2.f b/slatec/ssyr2.f deleted file mode 100644 index 87e3876..0000000 --- a/slatec/ssyr2.f +++ /dev/null @@ -1,237 +0,0 @@ -*DECK SSYR2 - SUBROUTINE SSYR2 (UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA) -C***BEGIN PROLOGUE SSYR2 -C***PURPOSE Perform symmetric rank 2 update of a real symmetric matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE SINGLE PRECISION (SSYR2-S, DSYR2-D, CSYR2-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C SSYR2 performs the symmetric rank 2 operation -C -C A := alpha*x*y' + alpha*y*x' + A, -C -C where alpha is a scalar, x and y are n element vectors and A is an n -C by n symmetric matrix. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the array A is to be referenced as -C follows: -C -C UPLO = 'U' or 'u' Only the upper triangular part of A -C is to be referenced. -C -C UPLO = 'L' or 'l' Only the lower triangular part of A -C is to be referenced. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C ALPHA - REAL . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C X - REAL array of dimension at least -C ( 1 + ( n - 1)*abs( INCX)). -C Before entry, the incremented array X must contain the n -C element vector x. -C Unchanged on exit. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C Y - REAL array of dimension at least -C ( 1 + ( n - 1 )*abs( INCY ) ). -C Before entry, the incremented array Y must contain the n -C element vector y. -C Unchanged on exit. -C -C INCY - INTEGER. -C On entry, INCY specifies the increment for the elements of -C Y. INCY must not be zero. -C Unchanged on exit. -C -C A - REAL array of DIMENSION ( LDA, n ). -C Before entry with UPLO = 'U' or 'u', the leading n by n -C upper triangular part of the array A must contain the upper -C triangular part of the symmetric matrix and the strictly -C lower triangular part of A is not referenced. On exit, the -C upper triangular part of the array A is overwritten by the -C upper triangular part of the updated matrix. -C Before entry with UPLO = 'L' or 'l', the leading n by n -C lower triangular part of the array A must contain the lower -C triangular part of the symmetric matrix and the strictly -C upper triangular part of A is not referenced. On exit, the -C lower triangular part of the array A is overwritten by the -C lower triangular part of the updated matrix. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C max( 1, n ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE SSYR2 -C .. Scalar Arguments .. - REAL ALPHA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -C .. Array Arguments .. - REAL A( LDA, * ), X( * ), Y( * ) -C .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0E+0 ) -C .. Local Scalars .. - REAL TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C***FIRST EXECUTABLE STATEMENT SSYR2 -C -C Test the input parameters. -C - 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( 'SSYR2 ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -C -C Set up the start points in X and Y if the increments are not both -C unity. -C - 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 -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through the triangular part -C of A. -C - IF( LSAME( UPLO, 'U' ) )THEN -C -C Form A when A is stored in the upper triangle. -C - 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 -C -C Form A when A is stored in the lower triangle. -C - 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 -C - RETURN -C -C End of SSYR2 . -C - END diff --git a/slatec/ssyr2k.f b/slatec/ssyr2k.f deleted file mode 100644 index 08f2293..0000000 --- a/slatec/ssyr2k.f +++ /dev/null @@ -1,333 +0,0 @@ -*DECK SSYR2K - SUBROUTINE SSYR2K (UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, - $ C, LDC) -C***BEGIN PROLOGUE SSYR2K -C***PURPOSE Perform symmetric rank 2k update of a real symmetric matrix -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B6 -C***TYPE SINGLE PRECISION (SSYR2-S, DSYR2-D, CSYR2-C, SSYR2K-S) -C***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J., (ANL) -C Duff, I., (AERE) -C Du Croz, J., (NAG) -C Hammarling, S. (NAG) -C***DESCRIPTION -C -C SSYR2K performs one of the symmetric rank 2k operations -C -C C := alpha*A*B' + alpha*B*A' + beta*C, -C -C or -C -C C := alpha*A'*B + alpha*B'*A + beta*C, -C -C where alpha and beta are scalars, C is an n by n symmetric matrix -C and A and B are n by k matrices in the first case and k by n -C matrices in the second case. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the array C is to be referenced as -C follows: -C -C UPLO = 'U' or 'u' Only the upper triangular part of C -C is to be referenced. -C -C UPLO = 'L' or 'l' Only the lower triangular part of C -C is to be referenced. -C -C Unchanged on exit. -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the operation to be performed as -C follows: -C -C TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + -C beta*C. -C -C TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + -C beta*C. -C -C TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A + -C beta*C. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix C. N must be -C at least zero. -C Unchanged on exit. -C -C K - INTEGER. -C On entry with TRANS = 'N' or 'n', K specifies the number -C of columns of the matrices A and B, and on entry with -C TRANS = 'T' or 't' or 'C' or 'c', K specifies the number -C of rows of the matrices A and B. K must be at least zero. -C Unchanged on exit. -C -C ALPHA - REAL . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C A - REAL array of DIMENSION ( LDA, ka ), where ka is -C k when TRANS = 'N' or 'n', and is n otherwise. -C Before entry with TRANS = 'N' or 'n', the leading n by k -C part of the array A must contain the matrix A, otherwise -C the leading k by n part of the array A must contain the -C matrix A. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. When TRANS = 'N' or 'n' -C then LDA must be at least max( 1, n ), otherwise LDA must -C be at least max( 1, k ). -C Unchanged on exit. -C -C B - REAL array of DIMENSION ( LDB, kb ), where kb is -C k when TRANS = 'N' or 'n', and is n otherwise. -C Before entry with TRANS = 'N' or 'n', the leading n by k -C part of the array B must contain the matrix B, otherwise -C the leading k by n part of the array B must contain the -C matrix B. -C Unchanged on exit. -C -C LDB - INTEGER. -C On entry, LDB specifies the first dimension of B as declared -C in the calling (sub) program. When TRANS = 'N' or 'n' -C then LDB must be at least max( 1, n ), otherwise LDB must -C be at least max( 1, k ). -C Unchanged on exit. -C -C BETA - REAL . -C On entry, BETA specifies the scalar beta. -C Unchanged on exit. -C -C C - REAL array of DIMENSION ( LDC, n ). -C Before entry with UPLO = 'U' or 'u', the leading n by n -C upper triangular part of the array C must contain the upper -C triangular part of the symmetric matrix and the strictly -C lower triangular part of C is not referenced. On exit, the -C upper triangular part of the array C is overwritten by the -C upper triangular part of the updated matrix. -C Before entry with UPLO = 'L' or 'l', the leading n by n -C lower triangular part of the array C must contain the lower -C triangular part of the symmetric matrix and the strictly -C upper triangular part of C is not referenced. On exit, the -C lower triangular part of the array C is overwritten by the -C lower triangular part of the updated matrix. -C -C LDC - INTEGER. -C On entry, LDC specifies the first dimension of C as declared -C in the calling (sub) program. LDC must be at least -C max( 1, n ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. -C A set of level 3 basic linear algebra subprograms. -C ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 890208 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE SSYR2K -C .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDB, LDC - REAL ALPHA, BETA -C .. Array Arguments .. - REAL A( LDA, * ), B( LDB, * ), C( LDC, * ) -C -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - REAL TEMP1, TEMP2 -C .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -C***FIRST EXECUTABLE STATEMENT SSYR2K -C -C Test the input parameters. -C - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -C - 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( 'SSYR2K', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C And when alpha.eq.zero. -C - 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 -C -C Start the operations. -C - IF( LSAME( TRANS, 'N' ) )THEN -C -C Form C := alpha*A*B' + alpha*B*A' + C. -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 -C -C Form C := alpha*A'*B + alpha*B'*A + C. -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 -C - RETURN -C -C End of SSYR2K. -C - END diff --git a/slatec/ssyrk.f b/slatec/ssyrk.f deleted file mode 100644 index e9eafe4..0000000 --- a/slatec/ssyrk.f +++ /dev/null @@ -1,299 +0,0 @@ -*DECK SSYRK - SUBROUTINE SSYRK (UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC) -C***BEGIN PROLOGUE SSYRK -C***PURPOSE Perform symmetric rank k update of a real symmetric matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B6 -C***TYPE SINGLE PRECISION (SSYRK-S, DSYRK-D, CSYRK-C) -C***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J., (ANL) -C Duff, I., (AERE) -C Du Croz, J., (NAG) -C Hammarling, S. (NAG) -C***DESCRIPTION -C -C SSYRK performs one of the symmetric rank k operations -C -C C := alpha*A*A' + beta*C, -C -C or -C -C C := alpha*A'*A + beta*C, -C -C where alpha and beta are scalars, C is an n by n symmetric matrix -C and A is an n by k matrix in the first case and a k by n matrix -C in the second case. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the upper or lower -C triangular part of the array C is to be referenced as -C follows: -C -C UPLO = 'U' or 'u' Only the upper triangular part of C -C is to be referenced. -C -C UPLO = 'L' or 'l' Only the lower triangular part of C -C is to be referenced. -C -C Unchanged on exit. -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the operation to be performed as -C follows: -C -C TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. -C -C TRANS = 'T' or 't' C := alpha*A'*A + beta*C. -C -C TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix C. N must be -C at least zero. -C Unchanged on exit. -C -C K - INTEGER. -C On entry with TRANS = 'N' or 'n', K specifies the number -C of columns of the matrix A, and on entry with -C TRANS = 'T' or 't' or 'C' or 'c', K specifies the number -C of rows of the matrix A. K must be at least zero. -C Unchanged on exit. -C -C ALPHA - REAL . -C On entry, ALPHA specifies the scalar alpha. -C Unchanged on exit. -C -C A - REAL array of DIMENSION ( LDA, ka ), where ka is -C k when TRANS = 'N' or 'n', and is n otherwise. -C Before entry with TRANS = 'N' or 'n', the leading n by k -C part of the array A must contain the matrix A, otherwise -C the leading k by n part of the array A must contain the -C matrix A. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. When TRANS = 'N' or 'n' -C then LDA must be at least max( 1, n ), otherwise LDA must -C be at least max( 1, k ). -C Unchanged on exit. -C -C BETA - REAL . -C On entry, BETA specifies the scalar beta. -C Unchanged on exit. -C -C C - REAL array of DIMENSION ( LDC, n ). -C Before entry with UPLO = 'U' or 'u', the leading n by n -C upper triangular part of the array C must contain the upper -C triangular part of the symmetric matrix and the strictly -C lower triangular part of C is not referenced. On exit, the -C upper triangular part of the array C is overwritten by the -C upper triangular part of the updated matrix. -C Before entry with UPLO = 'L' or 'l', the leading n by n -C lower triangular part of the array C must contain the lower -C triangular part of the symmetric matrix and the strictly -C upper triangular part of C is not referenced. On exit, the -C lower triangular part of the array C is overwritten by the -C lower triangular part of the updated matrix. -C -C LDC - INTEGER. -C On entry, LDC specifies the first dimension of C as declared -C in the calling (sub) program. LDC must be at least -C max( 1, n ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. -C A set of level 3 basic linear algebra subprograms. -C ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 890208 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE SSYRK -C .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDC - REAL ALPHA, BETA -C .. Array Arguments .. - REAL A( LDA, * ), C( LDC, * ) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - REAL TEMP -C .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -C***FIRST EXECUTABLE STATEMENT SSYRK -C -C Test the input parameters. -C - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -C - 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( 'SSYRK ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C And when alpha.eq.zero. -C - 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 -C -C Start the operations. -C - IF( LSAME( TRANS, 'N' ) )THEN -C -C Form C := alpha*A*A' + beta*C. -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 -C -C Form C := alpha*A'*A + beta*C. -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 -C - RETURN -C -C End of SSYRK . -C - END diff --git a/slatec/stbmv.f b/slatec/stbmv.f deleted file mode 100644 index 7afec21..0000000 --- a/slatec/stbmv.f +++ /dev/null @@ -1,349 +0,0 @@ -*DECK STBMV - SUBROUTINE STBMV (UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) -C***BEGIN PROLOGUE STBMV -C***PURPOSE Multiply a real vector by a real triangular band matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE SINGLE PRECISION (STBMV-S, DTBMV-D, CTBMV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C STBMV performs one of the matrix-vector operations -C -C x := A*x, or x := A'*x, -C -C where x is an n element vector and A is an n by n unit, or non-unit, -C upper or lower triangular band matrix, with ( k + 1) diagonals. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the matrix is an upper or -C lower triangular matrix as follows: -C -C UPLO = 'U' or 'u' A is an upper triangular matrix. -C -C UPLO = 'L' or 'l' A is a lower triangular matrix. -C -C Unchanged on exit. -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the operation to be performed as -C follows: -C -C TRANS = 'N' or 'n' x := A*x. -C -C TRANS = 'T' or 't' x := A'*x. -C -C TRANS = 'C' or 'c' x := A'*x. -C -C Unchanged on exit. -C -C DIAG - CHARACTER*1. -C On entry, DIAG specifies whether or not A is unit -C triangular as follows: -C -C DIAG = 'U' or 'u' A is assumed to be unit triangular. -C -C DIAG = 'N' or 'n' A is not assumed to be unit -C triangular. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C K - INTEGER. -C On entry with UPLO = 'U' or 'u', K specifies the number of -C super-diagonals of the matrix A. -C On entry with UPLO = 'L' or 'l', K specifies the number of -C sub-diagonals of the matrix A. -C K must satisfy 0 .le. K. -C Unchanged on exit. -C -C A - REAL array of DIMENSION ( LDA, n ). -C Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -C by n part of the array A must contain the upper triangular -C band part of the matrix of coefficients, supplied column by -C column, with the leading diagonal of the matrix in row -C ( k + 1 ) of the array, the first super-diagonal starting at -C position 2 in row k, and so on. The top left k by k triangle -C of the array A is not referenced. -C The following program segment will transfer an upper -C triangular band matrix from conventional full matrix storage -C to band storage: -C -C DO 20, J = 1, N -C M = K + 1 - J -C DO 10, I = MAX( 1, J - K ), J -C A( M + I, J ) = matrix( I, J ) -C 10 CONTINUE -C 20 CONTINUE -C -C Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -C by n part of the array A must contain the lower triangular -C band part of the matrix of coefficients, supplied column by -C column, with the leading diagonal of the matrix in row 1 of -C the array, the first sub-diagonal starting at position 1 in -C row 2, and so on. The bottom right k by k triangle of the -C array A is not referenced. -C The following program segment will transfer a lower -C triangular band matrix from conventional full matrix storage -C to band storage: -C -C DO 20, J = 1, N -C M = 1 - J -C DO 10, I = J, MIN( N, J + K ) -C A( M + I, J ) = matrix( I, J ) -C 10 CONTINUE -C 20 CONTINUE -C -C Note that when DIAG = 'U' or 'u' the elements of the array A -C corresponding to the diagonal elements of the matrix are not -C referenced, but are assumed to be unity. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C ( k + 1 ). -C Unchanged on exit. -C -C X - REAL array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element vector x. On exit, X is overwritten with the -C transformed vector x. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE STBMV -C .. Scalar Arguments .. - INTEGER INCX, K, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -C .. Array Arguments .. - REAL A( LDA, * ), X( * ) -C .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0E+0 ) -C .. Local Scalars .. - REAL TEMP - INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L - LOGICAL NOUNIT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C***FIRST EXECUTABLE STATEMENT STBMV -C -C Test the input parameters. -C - 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( 'STBMV ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - NOUNIT = LSAME( DIAG, 'N' ) -C -C Set up the start point in X if the increment is not unity. This -C will be ( N - 1 )*INCX too small for descending loops. -C - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through A. -C - IF( LSAME( TRANS, 'N' ) )THEN -C -C Form x := A*x. -C - 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 -C -C Form x := A'*x. -C - 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 -C - RETURN -C -C End of STBMV . -C - END diff --git a/slatec/stbsv.f b/slatec/stbsv.f deleted file mode 100644 index e36414b..0000000 --- a/slatec/stbsv.f +++ /dev/null @@ -1,353 +0,0 @@ -*DECK STBSV - SUBROUTINE STBSV (UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) -C***BEGIN PROLOGUE STBSV -C***PURPOSE Solve a real triangular banded system of linear equations. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE SINGLE PRECISION (STBSV-S, DTBSV-D, CTBSV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C STBSV solves one of the systems of equations -C -C A*x = b, or A'*x = b, -C -C where b and x are n element vectors and A is an n by n unit, or -C non-unit, upper or lower triangular band matrix, with ( k + 1) -C diagonals. -C -C No test for singularity or near-singularity is included in this -C routine. Such tests must be performed before calling this routine. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the matrix is an upper or -C lower triangular matrix as follows: -C -C UPLO = 'U' or 'u' A is an upper triangular matrix. -C -C UPLO = 'L' or 'l' A is a lower triangular matrix. -C -C Unchanged on exit. -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the equations to be solved as -C follows: -C -C TRANS = 'N' or 'n' A*x = b. -C -C TRANS = 'T' or 't' A'*x = b. -C -C TRANS = 'C' or 'c' A'*x = b. -C -C Unchanged on exit. -C -C DIAG - CHARACTER*1. -C On entry, DIAG specifies whether or not A is unit -C triangular as follows: -C -C DIAG = 'U' or 'u' A is assumed to be unit triangular. -C -C DIAG = 'N' or 'n' A is not assumed to be unit -C triangular. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C K - INTEGER. -C On entry with UPLO = 'U' or 'u', K specifies the number of -C super-diagonals of the matrix A. -C On entry with UPLO = 'L' or 'l', K specifies the number of -C sub-diagonals of the matrix A. -C K must satisfy 0 .le. K. -C Unchanged on exit. -C -C A - REAL array of DIMENSION ( LDA, n ). -C Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -C by n part of the array A must contain the upper triangular -C band part of the matrix of coefficients, supplied column by -C column, with the leading diagonal of the matrix in row -C ( k + 1 ) of the array, the first super-diagonal starting at -C position 2 in row k, and so on. The top left k by k triangle -C of the array A is not referenced. -C The following program segment will transfer an upper -C triangular band matrix from conventional full matrix storage -C to band storage: -C -C DO 20, J = 1, N -C M = K + 1 - J -C DO 10, I = MAX( 1, J - K ), J -C A( M + I, J ) = matrix( I, J ) -C 10 CONTINUE -C 20 CONTINUE -C -C Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -C by n part of the array A must contain the lower triangular -C band part of the matrix of coefficients, supplied column by -C column, with the leading diagonal of the matrix in row 1 of -C the array, the first sub-diagonal starting at position 1 in -C row 2, and so on. The bottom right k by k triangle of the -C array A is not referenced. -C The following program segment will transfer a lower -C triangular band matrix from conventional full matrix storage -C to band storage: -C -C DO 20, J = 1, N -C M = 1 - J -C DO 10, I = J, MIN( N, J + K ) -C A( M + I, J ) = matrix( I, J ) -C 10 CONTINUE -C 20 CONTINUE -C -C Note that when DIAG = 'U' or 'u' the elements of the array A -C corresponding to the diagonal elements of the matrix are not -C referenced, but are assumed to be unity. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C ( k + 1 ). -C Unchanged on exit. -C -C X - REAL array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element right-hand side vector b. On exit, X is overwritten -C with the solution vector x. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE STBSV -C .. Scalar Arguments .. - INTEGER INCX, K, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -C .. Array Arguments .. - REAL A( LDA, * ), X( * ) -C .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0E+0 ) -C .. Local Scalars .. - REAL TEMP - INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L - LOGICAL NOUNIT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C***FIRST EXECUTABLE STATEMENT STBSV -C -C Test the input parameters. -C - 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( 'STBSV ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - NOUNIT = LSAME( DIAG, 'N' ) -C -C Set up the start point in X if the increment is not unity. This -C will be ( N - 1 )*INCX too small for descending loops. -C - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -C -C Start the operations. In this version the elements of A are -C accessed by sequentially with one pass through A. -C - IF( LSAME( TRANS, 'N' ) )THEN -C -C Form x := inv( A )*x. -C - 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 -C -C Form x := inv( A')*x. -C - 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 -C - RETURN -C -C End of STBSV . -C - END diff --git a/slatec/steps.f b/slatec/steps.f deleted file mode 100644 index 987ad9e..0000000 --- a/slatec/steps.f +++ /dev/null @@ -1,568 +0,0 @@ -*DECK STEPS - SUBROUTINE STEPS (F, NEQN, Y, X, H, EPS, WT, START, HOLD, K, KOLD, - + CRASH, PHI, P, YP, PSI, ALPHA, BETA, SIG, V, W, G, PHASE1, NS, - + NORND, KSTEPS, TWOU, FOURU, XOLD, KPREV, IVC, IV, KGI, GI, - + RPAR, IPAR) -C***BEGIN PROLOGUE STEPS -C***PURPOSE Integrate a system of first order ordinary differential -C equations one step. -C***LIBRARY SLATEC (DEPAC) -C***CATEGORY I1A1B -C***TYPE SINGLE PRECISION (STEPS-S, DSTEPS-D) -C***KEYWORDS ADAMS METHOD, DEPAC, INITIAL VALUE PROBLEMS, ODE, -C ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR -C***AUTHOR Shampine, L. F., (SNLA) -C Gordon, M. K., (SNLA) -C MODIFIED BY H.A. WATTS -C***DESCRIPTION -C -C Written by L. F. Shampine and M. K. Gordon -C -C Abstract -C -C Subroutine STEPS is normally used indirectly through subroutine -C DEABM . Because DEABM suffices for most problems and is much -C easier to use, using it should be considered before using STEPS -C alone. -C -C Subroutine STEPS integrates a system of NEQN first order ordinary -C differential equations one step, normally from X to X+H, using a -C modified divided difference form of the Adams Pece formulas. Local -C extrapolation is used to improve absolute stability and accuracy. -C The code adjusts its order and step size to control the local error -C per unit step in a generalized sense. Special devices are included -C to control roundoff error and to detect when the user is requesting -C too much accuracy. -C -C This code is completely explained and documented in the text, -C Computer Solution of Ordinary Differential Equations, The Initial -C Value Problem by L. F. Shampine and M. K. Gordon. -C Further details on use of this code are available in "Solving -C Ordinary Differential Equations with ODE, STEP, and INTRP", -C by L. F. Shampine and M. K. Gordon, SLA-73-1060. -C -C -C The parameters represent -- -C F -- subroutine to evaluate derivatives -C NEQN -- number of equations to be integrated -C Y(*) -- solution vector at X -C X -- independent variable -C H -- appropriate step size for next step. Normally determined by -C code -C EPS -- local error tolerance -C WT(*) -- vector of weights for error criterion -C START -- logical variable set .TRUE. for first step, .FALSE. -C otherwise -C HOLD -- step size used for last successful step -C K -- appropriate order for next step (determined by code) -C KOLD -- order used for last successful step -C CRASH -- logical variable set .TRUE. when no step can be taken, -C .FALSE. otherwise. -C YP(*) -- derivative of solution vector at X after successful -C step -C KSTEPS -- counter on attempted steps -C TWOU -- 2.*U where U is machine unit roundoff quantity -C FOURU -- 4.*U where U is machine unit roundoff quantity -C RPAR,IPAR -- parameter arrays which you may choose to use -C for communication between your program and subroutine F. -C They are not altered or used by STEPS. -C The variables X,XOLD,KOLD,KGI and IVC and the arrays Y,PHI,ALPHA,G, -C W,P,IV and GI are required for the interpolation subroutine SINTRP. -C The remaining variables and arrays are included in the call list -C only to eliminate local retention of variables between calls. -C -C Input to STEPS -C -C First call -- -C -C The user must provide storage in his calling program for all arrays -C in the call list, namely -C -C DIMENSION Y(NEQN),WT(NEQN),PHI(NEQN,16),P(NEQN),YP(NEQN),PSI(12), -C 1 ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13),GI(11),IV(10), -C 2 RPAR(*),IPAR(*) -C -C **Note** -C -C The user must also declare START , CRASH , PHASE1 and NORND -C logical variables and F an EXTERNAL subroutine, supply the -C subroutine F(X,Y,YP) to evaluate -C DY(I)/DX = YP(I) = F(X,Y(1),Y(2),...,Y(NEQN)) -C and initialize only the following parameters. -C NEQN -- number of equations to be integrated -C Y(*) -- vector of initial values of dependent variables -C X -- initial value of the independent variable -C H -- nominal step size indicating direction of integration -C and maximum size of step. Must be variable -C EPS -- local error tolerance per step. Must be variable -C WT(*) -- vector of non-zero weights for error criterion -C START -- .TRUE. -C YP(*) -- vector of initial derivative values -C KSTEPS -- set KSTEPS to zero -C TWOU -- 2.*U where U is machine unit roundoff quantity -C FOURU -- 4.*U where U is machine unit roundoff quantity -C Define U to be the machine unit roundoff quantity by calling -C the function routine R1MACH, U = R1MACH(4), or by -C computing U so that U is the smallest positive number such -C that 1.0+U .GT. 1.0. -C -C STEPS requires that the L2 norm of the vector with components -C LOCAL ERROR(L)/WT(L) be less than EPS for a successful step. The -C array WT allows the user to specify an error test appropriate -C for his problem. For example, -C WT(L) = 1.0 specifies absolute error, -C = ABS(Y(L)) error relative to the most recent value of the -C L-th component of the solution, -C = ABS(YP(L)) error relative to the most recent value of -C the L-th component of the derivative, -C = MAX(WT(L),ABS(Y(L))) error relative to the largest -C magnitude of L-th component obtained so far, -C = ABS(Y(L))*RELERR/EPS + ABSERR/EPS specifies a mixed -C relative-absolute test where RELERR is relative -C error, ABSERR is absolute error and EPS = -C MAX(RELERR,ABSERR) . -C -C Subsequent calls -- -C -C Subroutine STEPS is designed so that all information needed to -C continue the integration, including the step size H and the order -C K , is returned with each step. With the exception of the step -C size, the error tolerance, and the weights, none of the parameters -C should be altered. The array WT must be updated after each step -C to maintain relative error tests like those above. Normally the -C integration is continued just beyond the desired endpoint and the -C solution interpolated there with subroutine SINTRP . If it is -C impossible to integrate beyond the endpoint, the step size may be -C reduced to hit the endpoint since the code will not take a step -C larger than the H input. Changing the direction of integration, -C i.e., the sign of H , requires the user set START = .TRUE. before -C calling STEPS again. This is the only situation in which START -C should be altered. -C -C Output from STEPS -C -C Successful Step -- -C -C The subroutine returns after each successful step with START and -C CRASH set .FALSE. . X represents the independent variable -C advanced one step of length HOLD from its value on input and Y -C the solution vector at the new value of X . All other parameters -C represent information corresponding to the new X needed to -C continue the integration. -C -C Unsuccessful Step -- -C -C When the error tolerance is too small for the machine precision, -C the subroutine returns without taking a step and CRASH = .TRUE. . -C An appropriate step size and error tolerance for continuing are -C estimated and all other information is restored as upon input -C before returning. To continue with the larger tolerance, the user -C just calls the code again. A restart is neither required nor -C desirable. -C -C***REFERENCES L. F. Shampine and M. K. Gordon, Solving ordinary -C differential equations with ODE, STEP, and INTRP, -C Report SLA-73-1060, Sandia Laboratories, 1973. -C***ROUTINES CALLED HSTART, R1MACH -C***REVISION HISTORY (YYMMDD) -C 740101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE STEPS -C - LOGICAL START,CRASH,PHASE1,NORND - DIMENSION Y(*),WT(*),PHI(NEQN,16),P(*),YP(*),PSI(12), - 1 ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13),GI(11),IV(10), - 2 RPAR(*),IPAR(*) - DIMENSION TWO(13),GSTR(13) - EXTERNAL F - SAVE TWO, GSTR -C - DATA TWO(1),TWO(2),TWO(3),TWO(4),TWO(5),TWO(6),TWO(7),TWO(8), - 1 TWO(9),TWO(10),TWO(11),TWO(12),TWO(13) /2.0,4.0,8.0,16.0, - 2 32.0,64.0,128.0,256.0,512.0,1024.0,2048.0,4096.0,8192.0/ - DATA GSTR(1),GSTR(2),GSTR(3),GSTR(4),GSTR(5),GSTR(6),GSTR(7), - 1 GSTR(8),GSTR(9),GSTR(10),GSTR(11),GSTR(12),GSTR(13)/0.500, - 2 0.0833,0.0417,0.0264,0.0188,0.0143,0.0114,0.00936,0.00789, - 3 0.00679,0.00592,0.00524,0.00468/ -C -C -C *** BEGIN BLOCK 0 *** -C CHECK IF STEP SIZE OR ERROR TOLERANCE IS TOO SMALL FOR MACHINE -C PRECISION. IF FIRST STEP, INITIALIZE PHI ARRAY AND ESTIMATE A -C STARTING STEP SIZE. -C *** -C -C IF STEP SIZE IS TOO SMALL, DETERMINE AN ACCEPTABLE ONE -C -C***FIRST EXECUTABLE STATEMENT STEPS - CRASH = .TRUE. - IF(ABS(H) .GE. FOURU*ABS(X)) GO TO 5 - H = SIGN(FOURU*ABS(X),H) - RETURN - 5 P5EPS = 0.5*EPS -C -C IF ERROR TOLERANCE IS TOO SMALL, INCREASE IT TO AN ACCEPTABLE VALUE -C - ROUND = 0.0 - DO 10 L = 1,NEQN - 10 ROUND = ROUND + (Y(L)/WT(L))**2 - ROUND = TWOU*SQRT(ROUND) - IF(P5EPS .GE. ROUND) GO TO 15 - EPS = 2.0*ROUND*(1.0 + FOURU) - RETURN - 15 CRASH = .FALSE. - G(1) = 1.0 - G(2) = 0.5 - SIG(1) = 1.0 - IF(.NOT.START) GO TO 99 -C -C INITIALIZE. COMPUTE APPROPRIATE STEP SIZE FOR FIRST STEP -C -C CALL F(X,Y,YP,RPAR,IPAR) -C SUM = 0.0 - DO 20 L = 1,NEQN - PHI(L,1) = YP(L) - 20 PHI(L,2) = 0.0 -C20 SUM = SUM + (YP(L)/WT(L))**2 -C SUM = SQRT(SUM) -C ABSH = ABS(H) -C IF(EPS .LT. 16.0*SUM*H*H) ABSH = 0.25*SQRT(EPS/SUM) -C H = SIGN(MAX(ABSH,FOURU*ABS(X)),H) -C - U = R1MACH(4) - BIG = SQRT(R1MACH(2)) - CALL HSTART (F,NEQN,X,X+H,Y,YP,WT,1,U,BIG, - 1 PHI(1,3),PHI(1,4),PHI(1,5),PHI(1,6),RPAR,IPAR,H) -C - HOLD = 0.0 - K = 1 - KOLD = 0 - KPREV = 0 - START = .FALSE. - PHASE1 = .TRUE. - NORND = .TRUE. - IF(P5EPS .GT. 100.0*ROUND) GO TO 99 - NORND = .FALSE. - DO 25 L = 1,NEQN - 25 PHI(L,15) = 0.0 - 99 IFAIL = 0 -C *** END BLOCK 0 *** -C -C *** BEGIN BLOCK 1 *** -C COMPUTE COEFFICIENTS OF FORMULAS FOR THIS STEP. AVOID COMPUTING -C THOSE QUANTITIES NOT CHANGED WHEN STEP SIZE IS NOT CHANGED. -C *** -C - 100 KP1 = K+1 - KP2 = K+2 - KM1 = K-1 - KM2 = K-2 -C -C NS IS THE NUMBER OF STEPS TAKEN WITH SIZE H, INCLUDING THE CURRENT -C ONE. WHEN K.LT.NS, NO COEFFICIENTS CHANGE -C - IF(H .NE. HOLD) NS = 0 - IF (NS.LE.KOLD) NS = NS+1 - NSP1 = NS+1 - IF (K .LT. NS) GO TO 199 -C -C COMPUTE THOSE COMPONENTS OF ALPHA(*),BETA(*),PSI(*),SIG(*) WHICH -C ARE CHANGED -C - BETA(NS) = 1.0 - REALNS = NS - ALPHA(NS) = 1.0/REALNS - TEMP1 = H*REALNS - SIG(NSP1) = 1.0 - IF(K .LT. NSP1) GO TO 110 - DO 105 I = NSP1,K - IM1 = I-1 - TEMP2 = PSI(IM1) - PSI(IM1) = TEMP1 - BETA(I) = BETA(IM1)*PSI(IM1)/TEMP2 - TEMP1 = TEMP2 + H - ALPHA(I) = H/TEMP1 - REALI = I - 105 SIG(I+1) = REALI*ALPHA(I)*SIG(I) - 110 PSI(K) = TEMP1 -C -C COMPUTE COEFFICIENTS G(*) -C -C INITIALIZE V(*) AND SET W(*). -C - IF(NS .GT. 1) GO TO 120 - DO 115 IQ = 1,K - TEMP3 = IQ*(IQ+1) - V(IQ) = 1.0/TEMP3 - 115 W(IQ) = V(IQ) - IVC = 0 - KGI = 0 - IF (K .EQ. 1) GO TO 140 - KGI = 1 - GI(1) = W(2) - GO TO 140 -C -C IF ORDER WAS RAISED, UPDATE DIAGONAL PART OF V(*) -C - 120 IF(K .LE. KPREV) GO TO 130 - IF (IVC .EQ. 0) GO TO 122 - JV = KP1 - IV(IVC) - IVC = IVC - 1 - GO TO 123 - 122 JV = 1 - TEMP4 = K*KP1 - V(K) = 1.0/TEMP4 - W(K) = V(K) - IF (K .NE. 2) GO TO 123 - KGI = 1 - GI(1) = W(2) - 123 NSM2 = NS-2 - IF(NSM2 .LT. JV) GO TO 130 - DO 125 J = JV,NSM2 - I = K-J - V(I) = V(I) - ALPHA(J+1)*V(I+1) - 125 W(I) = V(I) - IF (I .NE. 2) GO TO 130 - KGI = NS - 1 - GI(KGI) = W(2) -C -C UPDATE V(*) AND SET W(*) -C - 130 LIMIT1 = KP1 - NS - TEMP5 = ALPHA(NS) - DO 135 IQ = 1,LIMIT1 - V(IQ) = V(IQ) - TEMP5*V(IQ+1) - 135 W(IQ) = V(IQ) - G(NSP1) = W(1) - IF (LIMIT1 .EQ. 1) GO TO 137 - KGI = NS - GI(KGI) = W(2) - 137 W(LIMIT1+1) = V(LIMIT1+1) - IF (K .GE. KOLD) GO TO 140 - IVC = IVC + 1 - IV(IVC) = LIMIT1 + 2 -C -C COMPUTE THE G(*) IN THE WORK VECTOR W(*) -C - 140 NSP2 = NS + 2 - KPREV = K - IF(KP1 .LT. NSP2) GO TO 199 - DO 150 I = NSP2,KP1 - LIMIT2 = KP2 - I - TEMP6 = ALPHA(I-1) - DO 145 IQ = 1,LIMIT2 - 145 W(IQ) = W(IQ) - TEMP6*W(IQ+1) - 150 G(I) = W(1) - 199 CONTINUE -C *** END BLOCK 1 *** -C -C *** BEGIN BLOCK 2 *** -C PREDICT A SOLUTION P(*), EVALUATE DERIVATIVES USING PREDICTED -C SOLUTION, ESTIMATE LOCAL ERROR AT ORDER K AND ERRORS AT ORDERS K, -C K-1, K-2 AS IF CONSTANT STEP SIZE WERE USED. -C *** -C -C INCREMENT COUNTER ON ATTEMPTED STEPS -C - KSTEPS = KSTEPS + 1 -C -C CHANGE PHI TO PHI STAR -C - IF(K .LT. NSP1) GO TO 215 - DO 210 I = NSP1,K - TEMP1 = BETA(I) - DO 205 L = 1,NEQN - 205 PHI(L,I) = TEMP1*PHI(L,I) - 210 CONTINUE -C -C PREDICT SOLUTION AND DIFFERENCES -C - 215 DO 220 L = 1,NEQN - PHI(L,KP2) = PHI(L,KP1) - PHI(L,KP1) = 0.0 - 220 P(L) = 0.0 - DO 230 J = 1,K - I = KP1 - J - IP1 = I+1 - TEMP2 = G(I) - DO 225 L = 1,NEQN - P(L) = P(L) + TEMP2*PHI(L,I) - 225 PHI(L,I) = PHI(L,I) + PHI(L,IP1) - 230 CONTINUE - IF(NORND) GO TO 240 - DO 235 L = 1,NEQN - TAU = H*P(L) - PHI(L,15) - P(L) = Y(L) + TAU - 235 PHI(L,16) = (P(L) - Y(L)) - TAU - GO TO 250 - 240 DO 245 L = 1,NEQN - 245 P(L) = Y(L) + H*P(L) - 250 XOLD = X - X = X + H - ABSH = ABS(H) - CALL F(X,P,YP,RPAR,IPAR) -C -C ESTIMATE ERRORS AT ORDERS K,K-1,K-2 -C - ERKM2 = 0.0 - ERKM1 = 0.0 - ERK = 0.0 - DO 265 L = 1,NEQN - TEMP3 = 1.0/WT(L) - TEMP4 = YP(L) - PHI(L,1) - IF(KM2)265,260,255 - 255 ERKM2 = ERKM2 + ((PHI(L,KM1)+TEMP4)*TEMP3)**2 - 260 ERKM1 = ERKM1 + ((PHI(L,K)+TEMP4)*TEMP3)**2 - 265 ERK = ERK + (TEMP4*TEMP3)**2 - IF(KM2)280,275,270 - 270 ERKM2 = ABSH*SIG(KM1)*GSTR(KM2)*SQRT(ERKM2) - 275 ERKM1 = ABSH*SIG(K)*GSTR(KM1)*SQRT(ERKM1) - 280 TEMP5 = ABSH*SQRT(ERK) - ERR = TEMP5*(G(K)-G(KP1)) - ERK = TEMP5*SIG(KP1)*GSTR(K) - KNEW = K -C -C TEST IF ORDER SHOULD BE LOWERED -C - IF(KM2)299,290,285 - 285 IF(MAX(ERKM1,ERKM2) .LE. ERK) KNEW = KM1 - GO TO 299 - 290 IF(ERKM1 .LE. 0.5*ERK) KNEW = KM1 -C -C TEST IF STEP SUCCESSFUL -C - 299 IF(ERR .LE. EPS) GO TO 400 -C *** END BLOCK 2 *** -C -C *** BEGIN BLOCK 3 *** -C THE STEP IS UNSUCCESSFUL. RESTORE X, PHI(*,*), PSI(*) . -C IF THIRD CONSECUTIVE FAILURE, SET ORDER TO ONE. IF STEP FAILS MORE -C THAN THREE TIMES, CONSIDER AN OPTIMAL STEP SIZE. DOUBLE ERROR -C TOLERANCE AND RETURN IF ESTIMATED STEP SIZE IS TOO SMALL FOR MACHINE -C PRECISION. -C *** -C -C RESTORE X, PHI(*,*) AND PSI(*) -C - PHASE1 = .FALSE. - X = XOLD - DO 310 I = 1,K - TEMP1 = 1.0/BETA(I) - IP1 = I+1 - DO 305 L = 1,NEQN - 305 PHI(L,I) = TEMP1*(PHI(L,I) - PHI(L,IP1)) - 310 CONTINUE - IF(K .LT. 2) GO TO 320 - DO 315 I = 2,K - 315 PSI(I-1) = PSI(I) - H -C -C ON THIRD FAILURE, SET ORDER TO ONE. THEREAFTER, USE OPTIMAL STEP -C SIZE -C - 320 IFAIL = IFAIL + 1 - TEMP2 = 0.5 - IF(IFAIL - 3) 335,330,325 - 325 IF(P5EPS .LT. 0.25*ERK) TEMP2 = SQRT(P5EPS/ERK) - 330 KNEW = 1 - 335 H = TEMP2*H - K = KNEW - NS = 0 - IF(ABS(H) .GE. FOURU*ABS(X)) GO TO 340 - CRASH = .TRUE. - H = SIGN(FOURU*ABS(X),H) - EPS = EPS + EPS - RETURN - 340 GO TO 100 -C *** END BLOCK 3 *** -C -C *** BEGIN BLOCK 4 *** -C THE STEP IS SUCCESSFUL. CORRECT THE PREDICTED SOLUTION, EVALUATE -C THE DERIVATIVES USING THE CORRECTED SOLUTION AND UPDATE THE -C DIFFERENCES. DETERMINE BEST ORDER AND STEP SIZE FOR NEXT STEP. -C *** - 400 KOLD = K - HOLD = H -C -C CORRECT AND EVALUATE -C - TEMP1 = H*G(KP1) - IF(NORND) GO TO 410 - DO 405 L = 1,NEQN - TEMP3 = Y(L) - RHO = TEMP1*(YP(L) - PHI(L,1)) - PHI(L,16) - Y(L) = P(L) + RHO - PHI(L,15) = (Y(L) - P(L)) - RHO - 405 P(L) = TEMP3 - GO TO 420 - 410 DO 415 L = 1,NEQN - TEMP3 = Y(L) - Y(L) = P(L) + TEMP1*(YP(L) - PHI(L,1)) - 415 P(L) = TEMP3 - 420 CALL F(X,Y,YP,RPAR,IPAR) -C -C UPDATE DIFFERENCES FOR NEXT STEP -C - DO 425 L = 1,NEQN - PHI(L,KP1) = YP(L) - PHI(L,1) - 425 PHI(L,KP2) = PHI(L,KP1) - PHI(L,KP2) - DO 435 I = 1,K - DO 430 L = 1,NEQN - 430 PHI(L,I) = PHI(L,I) + PHI(L,KP1) - 435 CONTINUE -C -C ESTIMATE ERROR AT ORDER K+1 UNLESS: -C IN FIRST PHASE WHEN ALWAYS RAISE ORDER, -C ALREADY DECIDED TO LOWER ORDER, -C STEP SIZE NOT CONSTANT SO ESTIMATE UNRELIABLE -C - ERKP1 = 0.0 - IF(KNEW .EQ. KM1 .OR. K .EQ. 12) PHASE1 = .FALSE. - IF(PHASE1) GO TO 450 - IF(KNEW .EQ. KM1) GO TO 455 - IF(KP1 .GT. NS) GO TO 460 - DO 440 L = 1,NEQN - 440 ERKP1 = ERKP1 + (PHI(L,KP2)/WT(L))**2 - ERKP1 = ABSH*GSTR(KP1)*SQRT(ERKP1) -C -C USING ESTIMATED ERROR AT ORDER K+1, DETERMINE APPROPRIATE ORDER -C FOR NEXT STEP -C - IF(K .GT. 1) GO TO 445 - IF(ERKP1 .GE. 0.5*ERK) GO TO 460 - GO TO 450 - 445 IF(ERKM1 .LE. MIN(ERK,ERKP1)) GO TO 455 - IF(ERKP1 .GE. ERK .OR. K .EQ. 12) GO TO 460 -C -C HERE ERKP1 .LT. ERK .LT. MAX(ERKM1,ERKM2) ELSE ORDER WOULD HAVE -C BEEN LOWERED IN BLOCK 2. THUS ORDER IS TO BE RAISED -C -C RAISE ORDER -C - 450 K = KP1 - ERK = ERKP1 - GO TO 460 -C -C LOWER ORDER -C - 455 K = KM1 - ERK = ERKM1 -C -C WITH NEW ORDER DETERMINE APPROPRIATE STEP SIZE FOR NEXT STEP -C - 460 HNEW = H + H - IF(PHASE1) GO TO 465 - IF(P5EPS .GE. ERK*TWO(K+1)) GO TO 465 - HNEW = H - IF(P5EPS .GE. ERK) GO TO 465 - TEMP2 = K+1 - R = (P5EPS/ERK)**(1.0/TEMP2) - HNEW = ABSH*MAX(0.5,MIN(0.9,R)) - HNEW = SIGN(MAX(HNEW,FOURU*ABS(X)),H) - 465 H = HNEW - RETURN -C *** END BLOCK 4 *** - END diff --git a/slatec/stin.f b/slatec/stin.f deleted file mode 100644 index c28a65c..0000000 --- a/slatec/stin.f +++ /dev/null @@ -1,186 +0,0 @@ -*DECK STIN - SUBROUTINE STIN (N, NELT, IA, JA, A, ISYM, SOLN, RHS, IUNIT, JOB) -C***BEGIN PROLOGUE STIN -C***PURPOSE Read in SLAP Triad Format Linear System. -C Routine to read in a SLAP Triad format matrix and right -C hand side and solution to the system, if known. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY N1 -C***TYPE SINGLE PRECISION (STIN-S, DTIN-D) -C***KEYWORDS DIAGNOSTICS, LINEAR SYSTEM, SLAP SPARSE -C***AUTHOR Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, IUNIT, JOB -C REAL A(NELT), SOLN(N), RHS(N) -C -C CALL STIN( N, NELT, IA, JA, A, ISYM, SOLN, RHS, IUNIT, JOB ) -C -C *Arguments: -C N :OUT Integer -C Order of the Matrix. -C NELT :INOUT Integer. -C On input NELT is the maximum number of non-zeros that -C can be stored in the IA, JA, A arrays. -C On output NELT is the number of non-zeros stored in A. -C IA :OUT Integer IA(NELT). -C JA :OUT Integer JA(NELT). -C A :OUT Real A(NELT). -C On output these arrays hold the matrix A in the SLAP -C Triad format. See "Description", below. -C ISYM :OUT Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the lower -C triangle of the matrix is stored. -C SOLN :OUT Real SOLN(N). -C The solution to the linear system, if present. This array -C is accessed if and only if JOB to read it in, see below. -C If the user requests that SOLN be read in, but it is not in -C the file, then it is simply zeroed out. -C RHS :OUT Real RHS(N). -C The right hand side vector. This array is accessed if and -C only if JOB is set to read it in, see below. -C If the user requests that RHS be read in, but it is not in -C the file, then it is simply zeroed out. -C IUNIT :IN Integer. -C Fortran logical I/O device unit number to write the matrix -C to. This unit must be connected in a system dependent fashion -C to a file or the console or you will get a nasty message -C from the Fortran I/O libraries. -C JOB :INOUT Integer. -C Flag indicating what I/O operations to perform. -C On input JOB indicates what Input operations to try to -C perform. -C JOB = 0 => Read only the matrix. -C JOB = 1 => Read matrix and RHS (if present). -C JOB = 2 => Read matrix and SOLN (if present). -C JOB = 3 => Read matrix, RHS and SOLN (if present). -C On output JOB indicates what operations were actually -C performed. -C JOB = 0 => Read in only the matrix. -C JOB = 1 => Read in the matrix and RHS. -C JOB = 2 => Read in the matrix and SOLN. -C JOB = 3 => Read in the matrix, RHS and SOLN. -C -C *Description: -C The format for the input is as follows. On the first line -C are counters and flags: N, NELT, ISYM, IRHS, ISOLN. N, NELT -C and ISYM are described above. IRHS is a flag indicating if -C the RHS was written out (1 is yes, 0 is no). ISOLN is a -C flag indicating if the SOLN was written out (1 is yes, 0 is -C no). The format for the fist line is: 5i10. Then comes the -C NELT Triad's IA(I), JA(I) and A(I), I = 1, NELT. The format -C for these lines is : 1X,I5,1X,I5,1X,E16.7. Then comes -C RHS(I), I = 1, N, if IRHS = 1. Then comes SOLN(I), I = 1, -C N, if ISOLN = 1. The format for these lines is: 1X,E16.7. -C -C =================== S L A P Triad format =================== -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE STIN -C .. Scalar Arguments .. - INTEGER ISYM, IUNIT, JOB, N, NELT -C .. Array Arguments .. - REAL A(NELT), RHS(N), SOLN(N) - INTEGER IA(NELT), JA(NELT) -C .. Local Scalars .. - INTEGER I, IRHS, ISOLN, JOBRET, NELTMX -C .. Intrinsic Functions .. - INTRINSIC MIN -C***FIRST EXECUTABLE STATEMENT STIN -C -C Read in the information heading. -C - NELTMX = NELT - READ(IUNIT,1000) N, NELT, ISYM, IRHS, ISOLN - NELT = MIN( NELT, NELTMX ) -C -C Read in the matrix non-zeros in Triad format. - DO 10 I = 1, NELT - READ(IUNIT,1010) IA(I), JA(I), A(I) - 10 CONTINUE -C -C If requested, read in the rhs. - JOBRET = 0 - IF( JOB.EQ.1 .OR. JOB.EQ.3 ) THEN -C -C Check to see if rhs is in the file. - IF( IRHS.EQ.1 ) THEN - JOBRET = 1 - READ(IUNIT,1020) (RHS(I),I=1,N) - ELSE - DO 20 I = 1, N - RHS(I) = 0 - 20 CONTINUE - ENDIF - ENDIF -C -C If requested, read in the solution. - IF( JOB.GT.1 ) THEN -C -C Check to see if solution is in the file. - IF( ISOLN.EQ.1 ) THEN - JOBRET = JOBRET + 2 - READ(IUNIT,1020) (SOLN(I),I=1,N) - ELSE - DO 30 I = 1, N - SOLN(I) = 0 - 30 CONTINUE - ENDIF - ENDIF -C - JOB = JOBRET - RETURN - 1000 FORMAT(5I10) - 1010 FORMAT(1X,I5,1X,I5,1X,E16.7) - 1020 FORMAT(1X,E16.7) -C------------- LAST LINE OF STIN FOLLOWS ---------------------------- - END diff --git a/slatec/stod.f b/slatec/stod.f deleted file mode 100644 index 49d653d..0000000 --- a/slatec/stod.f +++ /dev/null @@ -1,478 +0,0 @@ -*DECK STOD - SUBROUTINE STOD (NEQ, Y, YH, NYH, YH1, EWT, SAVF, ACOR, WM, IWM, - + F, JAC, RPAR, IPAR) -C***BEGIN PROLOGUE STOD -C***SUBSIDIARY -C***PURPOSE Subsidiary to DEBDF -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (STOD-S, DSTOD-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C STOD integrates a system of first order odes over one step in the -C integrator package DEBDF. -C ---------------------------------------------------------------------- -C STOD performs one step of the integration of an initial value -C problem for a system of ordinary differential equations. -C Note.. STOD is independent of the value of the iteration method -C indicator MITER, when this is .NE. 0, and hence is independent -C of the type of chord method used, or the Jacobian structure. -C Communication with STOD is done with the following variables.. -C -C Y = An array of length .GE. n used as the Y argument in -C all calls to F and JAC. -C NEQ = Integer array containing problem size in NEQ(1), and -C passed as the NEQ argument in all calls to F and JAC. -C YH = An NYH by LMAX array containing the dependent variables -C and their approximate scaled derivatives, where -C LMAX = MAXORD + 1. YH(I,J+1) contains the approximate -C J-th derivative of Y(I), scaled by H**J/Factorial(j) -C (J = 0,1,...,NQ). On entry for the first step, the first -C two columns of YH must be set from the initial values. -C NYH = A constant integer .GE. N, the first dimension of YH. -C YH1 = A one-dimensional array occupying the same space as YH. -C EWT = An array of N elements with which the estimated local -C errors in YH are compared. -C SAVF = An array of working storage, of length N. -C ACOR = A work array of length N, used for the accumulated -C corrections. On a successful return, ACOR(I) contains -C the estimated one-step local error in Y(I). -C WM,IWM = Real and integer work arrays associated with matrix -C operations in chord iteration (MITER .NE. 0). -C PJAC = Name of routine to evaluate and preprocess Jacobian matrix -C if a chord method is being used. -C SLVS = Name of routine to solve linear system in chord iteration. -C H = The step size to be attempted on the next step. -C H is altered by the error control algorithm during the -C problem. H can be either positive or negative, but its -C sign must remain constant throughout the problem. -C HMIN = The minimum absolute value of the step size H to be used. -C HMXI = Inverse of the maximum absolute value of H to be used. -C HMXI = 0.0 is allowed and corresponds to an infinite HMAX. -C HMIN and HMXI may be changed at any time, but will not -C take effect until the next change of H is considered. -C TN = The independent variable. TN is updated on each step taken. -C JSTART = An integer used for input only, with the following -C values and meanings.. -C 0 Perform the first step. -C .GT.0 Take a new step continuing from the last. -C -1 Take the next step with a new value of H, MAXORD, -C N, METH, MITER, and/or matrix parameters. -C -2 Take the next step with a new value of H, -C but with other inputs unchanged. -C On return, JSTART is set to 1 to facilitate continuation. -C KFLAG = a completion code with the following meanings.. -C 0 The step was successful. -C -1 The requested error could not be achieved. -C -2 Corrector convergence could not be achieved. -C A return with KFLAG = -1 or -2 means either -C ABS(H) = HMIN or 10 consecutive failures occurred. -C On a return with KFLAG negative, the values of TN and -C the YH array are as of the beginning of the last -C step, and H is the last step size attempted. -C MAXORD = The maximum order of integration method to be allowed. -C METH/MITER = The method flags. See description in driver. -C N = The number of first-order differential equations. -C ---------------------------------------------------------------------- -C -C***SEE ALSO DEBDF -C***ROUTINES CALLED CFOD, PJAC, SLVS, VNWRMS -C***COMMON BLOCKS DEBDF1 -C***REVISION HISTORY (YYMMDD) -C 800901 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C 920422 Changed DIMENSION statement. (WRB) -C***END PROLOGUE STOD - EXTERNAL F, JAC -C -CLLL. OPTIMIZE - INTEGER NEQ, NYH, IWM, I, I1, IALTH, IER, IOWND, IREDO, IRET, - 1 IPUP, J, JB, JSTART, KFLAG, L, LMAX, M, MAXORD, MEO, METH, - 2 MITER, N, NCF, NEWQ, NFE, NJE, NQ, NQNYH, NQU, NST, NSTEPJ - REAL Y, YH, YH1, EWT, SAVF, ACOR, WM, - 1 ROWND, CONIT, CRATE, EL, ELCO, HOLD, RC, RMAX, TESCO, - 2 EL0, H, HMIN, HMXI, HU, TN, UROUND, - 3 DCON, DDN, DEL, DELP, DSM, DUP, EXDN, EXSM, EXUP, - 4 R, RH, RHDN, RHSM, RHUP, TOLD, VNWRMS - DIMENSION Y(*), YH(NYH,*), YH1(*), EWT(*), SAVF(*), - 1 ACOR(*), WM(*), IWM(*), RPAR(*), IPAR(*) - COMMON /DEBDF1/ ROWND, CONIT, CRATE, EL(13), ELCO(13,12), - 1 HOLD, RC, RMAX, TESCO(3,12), - 2 EL0, H, HMIN, HMXI, HU, TN, UROUND, IOWND(7), KSTEPS, IOD(6), - 3 IALTH, IPUP, LMAX, MEO, NQNYH, NSTEPJ, - 4 IER, JSTART, KFLAG, L, METH, MITER, MAXORD, N, NQ, NST, NFE, - 5 NJE, NQU -C -C -C***FIRST EXECUTABLE STATEMENT STOD - KFLAG = 0 - TOLD = TN - NCF = 0 - IF (JSTART .GT. 0) GO TO 200 - IF (JSTART .EQ. -1) GO TO 100 - IF (JSTART .EQ. -2) GO TO 160 -C----------------------------------------------------------------------- -C ON THE FIRST CALL, THE ORDER IS SET TO 1, AND OTHER VARIABLES ARE -C INITIALIZED. RMAX IS THE MAXIMUM RATIO BY WHICH H CAN BE INCREASED -C IN A SINGLE STEP. IT IS INITIALLY 1.E4 TO COMPENSATE FOR THE SMALL -C INITIAL H, BUT THEN IS NORMALLY EQUAL TO 10. IF A FAILURE -C OCCURS (IN CORRECTOR CONVERGENCE OR ERROR TEST), RMAX IS SET AT 2 -C FOR THE NEXT INCREASE. -C----------------------------------------------------------------------- - LMAX = MAXORD + 1 - NQ = 1 - L = 2 - IALTH = 2 - RMAX = 10000.0E0 - RC = 0.0E0 - EL0 = 1.0E0 - CRATE = 0.7E0 - DELP = 0.0E0 - HOLD = H - MEO = METH - NSTEPJ = 0 - IRET = 3 - GO TO 140 -C----------------------------------------------------------------------- -C THE FOLLOWING BLOCK HANDLES PRELIMINARIES NEEDED WHEN JSTART = -1. -C IPUP IS SET TO MITER TO FORCE A MATRIX UPDATE. -C IF AN ORDER INCREASE IS ABOUT TO BE CONSIDERED (IALTH = 1), -C IALTH IS RESET TO 2 TO POSTPONE CONSIDERATION ONE MORE STEP. -C IF THE CALLER HAS CHANGED METH, CFOD IS CALLED TO RESET -C THE COEFFICIENTS OF THE METHOD. -C IF THE CALLER HAS CHANGED MAXORD TO A VALUE LESS THAN THE CURRENT -C ORDER NQ, NQ IS REDUCED TO MAXORD, AND A NEW H CHOSEN ACCORDINGLY. -C IF H IS TO BE CHANGED, YH MUST BE RESCALED. -C IF H OR METH IS BEING CHANGED, IALTH IS RESET TO L = NQ + 1 -C TO PREVENT FURTHER CHANGES IN H FOR THAT MANY STEPS. -C----------------------------------------------------------------------- - 100 IPUP = MITER - LMAX = MAXORD + 1 - IF (IALTH .EQ. 1) IALTH = 2 - IF (METH .EQ. MEO) GO TO 110 - CALL CFOD (METH, ELCO, TESCO) - MEO = METH - IF (NQ .GT. MAXORD) GO TO 120 - IALTH = L - IRET = 1 - GO TO 150 - 110 IF (NQ .LE. MAXORD) GO TO 160 - 120 NQ = MAXORD - L = LMAX - DO 125 I = 1,L - 125 EL(I) = ELCO(I,NQ) - NQNYH = NQ*NYH - RC = RC*EL(1)/EL0 - EL0 = EL(1) - CONIT = 0.5E0/(NQ+2) - DDN = VNWRMS (N, SAVF, EWT)/TESCO(1,L) - EXDN = 1.0E0/L - RHDN = 1.0E0/(1.3E0*DDN**EXDN + 0.0000013E0) - RH = MIN(RHDN,1.0E0) - IREDO = 3 - IF (H .EQ. HOLD) GO TO 170 - RH = MIN(RH,ABS(H/HOLD)) - H = HOLD - GO TO 175 -C----------------------------------------------------------------------- -C CFOD IS CALLED TO GET ALL THE INTEGRATION COEFFICIENTS FOR THE -C CURRENT METH. THEN THE EL VECTOR AND RELATED CONSTANTS ARE RESET -C WHENEVER THE ORDER NQ IS CHANGED, OR AT THE START OF THE PROBLEM. -C----------------------------------------------------------------------- - 140 CALL CFOD (METH, ELCO, TESCO) - 150 DO 155 I = 1,L - 155 EL(I) = ELCO(I,NQ) - NQNYH = NQ*NYH - RC = RC*EL(1)/EL0 - EL0 = EL(1) - CONIT = 0.5E0/(NQ+2) - GO TO (160, 170, 200), IRET -C----------------------------------------------------------------------- -C IF H IS BEING CHANGED, THE H RATIO RH IS CHECKED AGAINST -C RMAX, HMIN, AND HMXI, AND THE YH ARRAY RESCALED. IALTH IS SET TO -C L = NQ + 1 TO PREVENT A CHANGE OF H FOR THAT MANY STEPS, UNLESS -C FORCED BY A CONVERGENCE OR ERROR TEST FAILURE. -C----------------------------------------------------------------------- - 160 IF (H .EQ. HOLD) GO TO 200 - RH = H/HOLD - H = HOLD - IREDO = 3 - GO TO 175 - 170 RH = MAX(RH,HMIN/ABS(H)) - 175 RH = MIN(RH,RMAX) - RH = RH/MAX(1.0E0,ABS(H)*HMXI*RH) - R = 1.0E0 - DO 180 J = 2,L - R = R*RH - DO 180 I = 1,N - 180 YH(I,J) = YH(I,J)*R - H = H*RH - RC = RC*RH - IALTH = L - IF (IREDO .EQ. 0) GO TO 680 -C----------------------------------------------------------------------- -C THIS SECTION COMPUTES THE PREDICTED VALUES BY EFFECTIVELY -C MULTIPLYING THE YH ARRAY BY THE PASCAL TRIANGLE MATRIX. -C RC IS THE RATIO OF NEW TO OLD VALUES OF THE COEFFICIENT H*EL(1). -C WHEN RC DIFFERS FROM 1 BY MORE THAN 30 PERCENT, IPUP IS SET TO MITER -C TO FORCE PJAC TO BE CALLED, IF A JACOBIAN IS INVOLVED. -C IN ANY CASE, PJAC IS CALLED AT LEAST EVERY 20-TH STEP. -C----------------------------------------------------------------------- - 200 IF (ABS(RC-1.0E0) .GT. 0.3E0) IPUP = MITER - IF (NST .GE. NSTEPJ+20) IPUP = MITER - TN = TN + H - I1 = NQNYH + 1 - DO 215 JB = 1,NQ - I1 = I1 - NYH - DO 210 I = I1,NQNYH - 210 YH1(I) = YH1(I) + YH1(I+NYH) - 215 CONTINUE - KSTEPS = KSTEPS + 1 -C----------------------------------------------------------------------- -C UP TO 3 CORRECTOR ITERATIONS ARE TAKEN. A CONVERGENCE TEST IS -C MADE ON THE R.M.S. NORM OF EACH CORRECTION, WEIGHTED BY THE ERROR -C WEIGHT VECTOR EWT. THE SUM OF THE CORRECTIONS IS ACCUMULATED IN THE -C VECTOR ACOR(I). THE YH ARRAY IS NOT ALTERED IN THE CORRECTOR LOOP. -C----------------------------------------------------------------------- - 220 M = 0 - DO 230 I = 1,N - 230 Y(I) = YH(I,1) - CALL F (TN, Y, SAVF, RPAR, IPAR) - NFE = NFE + 1 - IF (IPUP .LE. 0) GO TO 250 -C----------------------------------------------------------------------- -C IF INDICATED, THE MATRIX P = I - H*EL(1)*J IS REEVALUATED AND -C PREPROCESSED BEFORE STARTING THE CORRECTOR ITERATION. IPUP IS SET -C TO 0 AS AN INDICATOR THAT THIS HAS BEEN DONE. -C----------------------------------------------------------------------- - IPUP = 0 - RC = 1.0E0 - NSTEPJ = NST - CRATE = 0.7E0 - CALL PJAC (NEQ, Y, YH, NYH, EWT, ACOR, SAVF, WM, IWM, F, JAC, - 1 RPAR, IPAR) - IF (IER .NE. 0) GO TO 430 - 250 DO 260 I = 1,N - 260 ACOR(I) = 0.0E0 - 270 IF (MITER .NE. 0) GO TO 350 -C----------------------------------------------------------------------- -C IN THE CASE OF FUNCTIONAL ITERATION, UPDATE Y DIRECTLY FROM -C THE RESULT OF THE LAST FUNCTION EVALUATION. -C----------------------------------------------------------------------- - DO 290 I = 1,N - SAVF(I) = H*SAVF(I) - YH(I,2) - 290 Y(I) = SAVF(I) - ACOR(I) - DEL = VNWRMS (N, Y, EWT) - DO 300 I = 1,N - Y(I) = YH(I,1) + EL(1)*SAVF(I) - 300 ACOR(I) = SAVF(I) - GO TO 400 -C----------------------------------------------------------------------- -C IN THE CASE OF THE CHORD METHOD, COMPUTE THE CORRECTOR ERROR, -C AND SOLVE THE LINEAR SYSTEM WITH THAT AS RIGHT-HAND SIDE AND -C P AS COEFFICIENT MATRIX. -C----------------------------------------------------------------------- - 350 DO 360 I = 1,N - 360 Y(I) = H*SAVF(I) - (YH(I,2) + ACOR(I)) - CALL SLVS (WM, IWM, Y, SAVF) - IF (IER .NE. 0) GO TO 410 - DEL = VNWRMS (N, Y, EWT) - DO 380 I = 1,N - ACOR(I) = ACOR(I) + Y(I) - 380 Y(I) = YH(I,1) + EL(1)*ACOR(I) -C----------------------------------------------------------------------- -C TEST FOR CONVERGENCE. IF M.GT.0, AN ESTIMATE OF THE CONVERGENCE -C RATE CONSTANT IS STORED IN CRATE, AND THIS IS USED IN THE TEST. -C----------------------------------------------------------------------- - 400 IF (M .NE. 0) CRATE = MAX(0.2E0*CRATE,DEL/DELP) - DCON = DEL*MIN(1.0E0,1.5E0*CRATE)/(TESCO(2,NQ)*CONIT) - IF (DCON .LE. 1.0E0) GO TO 450 - M = M + 1 - IF (M .EQ. 3) GO TO 410 - IF (M .GE. 2 .AND. DEL .GT. 2.0E0*DELP) GO TO 410 - DELP = DEL - CALL F (TN, Y, SAVF, RPAR, IPAR) - NFE = NFE + 1 - GO TO 270 -C----------------------------------------------------------------------- -C THE CORRECTOR ITERATION FAILED TO CONVERGE IN 3 TRIES. -C IF MITER .NE. 0 AND THE JACOBIAN IS OUT OF DATE, PJAC IS CALLED FOR -C THE NEXT TRY. OTHERWISE THE YH ARRAY IS RETRACTED TO ITS VALUES -C BEFORE PREDICTION, AND H IS REDUCED, IF POSSIBLE. IF H CANNOT BE -C REDUCED OR 10 FAILURES HAVE OCCURRED, EXIT WITH KFLAG = -2. -C----------------------------------------------------------------------- - 410 IF (IPUP .EQ. 0) GO TO 430 - IPUP = MITER - GO TO 220 - 430 TN = TOLD - NCF = NCF + 1 - RMAX = 2.0E0 - I1 = NQNYH + 1 - DO 445 JB = 1,NQ - I1 = I1 - NYH - DO 440 I = I1,NQNYH - 440 YH1(I) = YH1(I) - YH1(I+NYH) - 445 CONTINUE - IF (ABS(H) .LE. HMIN*1.00001E0) GO TO 670 - IF (NCF .EQ. 10) GO TO 670 - RH = 0.25E0 - IPUP = MITER - IREDO = 1 - GO TO 170 -C----------------------------------------------------------------------- -C THE CORRECTOR HAS CONVERGED. IPUP IS SET TO -1 IF MITER .NE. 0, -C TO SIGNAL THAT THE JACOBIAN INVOLVED MAY NEED UPDATING LATER. -C THE LOCAL ERROR TEST IS MADE AND CONTROL PASSES TO STATEMENT 500 -C IF IT FAILS. -C----------------------------------------------------------------------- - 450 IF (MITER .NE. 0) IPUP = -1 - IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ) - IF (M .GT. 0) DSM = VNWRMS (N, ACOR, EWT)/TESCO(2,NQ) - IF (DSM .GT. 1.0E0) GO TO 500 -C----------------------------------------------------------------------- -C AFTER A SUCCESSFUL STEP, UPDATE THE YH ARRAY. -C CONSIDER CHANGING H IF IALTH = 1. OTHERWISE DECREASE IALTH BY 1. -C IF IALTH IS THEN 1 AND NQ .LT. MAXORD, THEN ACOR IS SAVED FOR -C USE IN A POSSIBLE ORDER INCREASE ON THE NEXT STEP. -C IF A CHANGE IN H IS CONSIDERED, AN INCREASE OR DECREASE IN ORDER -C BY ONE IS CONSIDERED ALSO. A CHANGE IN H IS MADE ONLY IF IT IS BY A -C FACTOR OF AT LEAST 1.1. IF NOT, IALTH IS SET TO 3 TO PREVENT -C TESTING FOR THAT MANY STEPS. -C----------------------------------------------------------------------- - KFLAG = 0 - IREDO = 0 - NST = NST + 1 - HU = H - NQU = NQ - DO 470 J = 1,L - DO 470 I = 1,N - 470 YH(I,J) = YH(I,J) + EL(J)*ACOR(I) - IALTH = IALTH - 1 - IF (IALTH .EQ. 0) GO TO 520 - IF (IALTH .GT. 1) GO TO 690 - IF (L .EQ. LMAX) GO TO 690 - DO 490 I = 1,N - 490 YH(I,LMAX) = ACOR(I) - GO TO 690 -C----------------------------------------------------------------------- -C THE ERROR TEST FAILED. KFLAG KEEPS TRACK OF MULTIPLE FAILURES. -C RESTORE TN AND THE YH ARRAY TO THEIR PREVIOUS VALUES, AND PREPARE -C TO TRY THE STEP AGAIN. COMPUTE THE OPTIMUM STEP SIZE FOR THIS OR -C ONE LOWER ORDER. AFTER 2 OR MORE FAILURES, H IS FORCED TO DECREASE -C BY A FACTOR OF 0.2 OR LESS. -C----------------------------------------------------------------------- - 500 KFLAG = KFLAG - 1 - TN = TOLD - I1 = NQNYH + 1 - DO 515 JB = 1,NQ - I1 = I1 - NYH - DO 510 I = I1,NQNYH - 510 YH1(I) = YH1(I) - YH1(I+NYH) - 515 CONTINUE - RMAX = 2.0E0 - IF (ABS(H) .LE. HMIN*1.00001E0) GO TO 660 - IF (KFLAG .LE. -3) GO TO 640 - IREDO = 2 - RHUP = 0.0E0 - GO TO 540 -C----------------------------------------------------------------------- -C REGARDLESS OF THE SUCCESS OR FAILURE OF THE STEP, FACTORS -C RHDN, RHSM, AND RHUP ARE COMPUTED, BY WHICH H COULD BE MULTIPLIED -C AT ORDER NQ - 1, ORDER NQ, OR ORDER NQ + 1, RESPECTIVELY. -C IN THE CASE OF FAILURE, RHUP = 0.0 TO AVOID AN ORDER INCREASE. -C THE LARGEST OF THESE IS DETERMINED AND THE NEW ORDER CHOSEN -C ACCORDINGLY. IF THE ORDER IS TO BE INCREASED, WE COMPUTE ONE -C ADDITIONAL SCALED DERIVATIVE. -C----------------------------------------------------------------------- - 520 RHUP = 0.0E0 - IF (L .EQ. LMAX) GO TO 540 - DO 530 I = 1,N - 530 SAVF(I) = ACOR(I) - YH(I,LMAX) - DUP = VNWRMS (N, SAVF, EWT)/TESCO(3,NQ) - EXUP = 1.0E0/(L+1) - RHUP = 1.0E0/(1.4E0*DUP**EXUP + 0.0000014E0) - 540 EXSM = 1.0E0/L - RHSM = 1.0E0/(1.2E0*DSM**EXSM + 0.0000012E0) - RHDN = 0.0E0 - IF (NQ .EQ. 1) GO TO 560 - DDN = VNWRMS (N, YH(1,L), EWT)/TESCO(1,NQ) - EXDN = 1.0E0/NQ - RHDN = 1.0E0/(1.3E0*DDN**EXDN + 0.0000013E0) - 560 IF (RHSM .GE. RHUP) GO TO 570 - IF (RHUP .GT. RHDN) GO TO 590 - GO TO 580 - 570 IF (RHSM .LT. RHDN) GO TO 580 - NEWQ = NQ - RH = RHSM - GO TO 620 - 580 NEWQ = NQ - 1 - RH = RHDN - IF (KFLAG .LT. 0 .AND. RH .GT. 1.0E0) RH = 1.0E0 - GO TO 620 - 590 NEWQ = L - RH = RHUP - IF (RH .LT. 1.1E0) GO TO 610 - R = EL(L)/L - DO 600 I = 1,N - 600 YH(I,NEWQ+1) = ACOR(I)*R - GO TO 630 - 610 IALTH = 3 - GO TO 690 - 620 IF ((KFLAG .EQ. 0) .AND. (RH .LT. 1.1E0)) GO TO 610 - IF (KFLAG .LE. -2) RH = MIN(RH,0.2E0) -C----------------------------------------------------------------------- -C IF THERE IS A CHANGE OF ORDER, RESET NQ, L, AND THE COEFFICIENTS. -C IN ANY CASE H IS RESET ACCORDING TO RH AND THE YH ARRAY IS RESCALED. -C THEN EXIT FROM 680 IF THE STEP WAS OK, OR REDO THE STEP OTHERWISE. -C----------------------------------------------------------------------- - IF (NEWQ .EQ. NQ) GO TO 170 - 630 NQ = NEWQ - L = NQ + 1 - IRET = 2 - GO TO 150 -C----------------------------------------------------------------------- -C CONTROL REACHES THIS SECTION IF 3 OR MORE FAILURES HAVE OCCURRED. -C IF 10 FAILURES HAVE OCCURRED, EXIT WITH KFLAG = -1. -C IT IS ASSUMED THAT THE DERIVATIVES THAT HAVE ACCUMULATED IN THE -C YH ARRAY HAVE ERRORS OF THE WRONG ORDER. HENCE THE FIRST -C DERIVATIVE IS RECOMPUTED, AND THE ORDER IS SET TO 1. THEN -C H IS REDUCED BY A FACTOR OF 10, AND THE STEP IS RETRIED, -C UNTIL IT SUCCEEDS OR H REACHES HMIN. -C----------------------------------------------------------------------- - 640 IF (KFLAG .EQ. -10) GO TO 660 - RH = 0.1E0 - RH = MAX(HMIN/ABS(H),RH) - H = H*RH - DO 645 I = 1,N - 645 Y(I) = YH(I,1) - CALL F (TN, Y, SAVF, RPAR, IPAR) - NFE = NFE + 1 - DO 650 I = 1,N - 650 YH(I,2) = H*SAVF(I) - IPUP = MITER - IALTH = 5 - IF (NQ .EQ. 1) GO TO 200 - NQ = 1 - L = 2 - IRET = 3 - GO TO 150 -C----------------------------------------------------------------------- -C ALL RETURNS ARE MADE THROUGH THIS SECTION. H IS SAVED IN HOLD -C TO ALLOW THE CALLER TO CHANGE H ON THE NEXT STEP. -C----------------------------------------------------------------------- - 660 KFLAG = -1 - GO TO 700 - 670 KFLAG = -2 - GO TO 700 - 680 RMAX = 10.0E0 - 690 R = 1.0E0/TESCO(2,NQU) - DO 695 I = 1,N - 695 ACOR(I) = ACOR(I)*R - 700 HOLD = H - JSTART = 1 - RETURN -C----------------------- END OF SUBROUTINE STOD ----------------------- - END diff --git a/slatec/stor1.f b/slatec/stor1.f deleted file mode 100644 index a780e61..0000000 --- a/slatec/stor1.f +++ /dev/null @@ -1,65 +0,0 @@ -*DECK STOR1 - SUBROUTINE STOR1 (U, YH, V, YP, NTEMP, NDISK, NTAPE) -C***BEGIN PROLOGUE STOR1 -C***SUBSIDIARY -C***PURPOSE Subsidiary to BVSUP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (STOR1-S, DSTOR1-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C ********************************************************************** -C 0 -- Storage at output points. -C NTEMP = -C 1 -- Temporary storage -C ********************************************************************** -C -C***SEE ALSO BVSUP -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS ML8SZ -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890921 Realigned order of variables in certain COMMON blocks. -C (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE STOR1 - DIMENSION U(*),YH(*),V(*),YP(*) -C -C ********************************************************************** -C - COMMON /ML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMP,NFC -C -C ********************************************************************** -C -C***FIRST EXECUTABLE STATEMENT STOR1 - NCTNF = NCOMP * NFC - DO 10 J = 1,NCTNF - 10 U(J) = YH(J) - IF (INHOMO .EQ. 1) GO TO 30 -C -C ZERO PARTICULAR SOLUTION -C - IF (NTEMP .EQ. 1) RETURN - DO 20 J = 1,NCOMP - 20 V(J) = 0. - GO TO 70 -C -C NONZERO PARTICULAR SOLUTION -C - 30 IF (NTEMP .EQ. 0) GO TO 50 -C - DO 40 J = 1,NCOMP - 40 V(J) = YP(J) - RETURN -C - 50 DO 60 J = 1,NCOMP - 60 V(J) = C * YP(J) -C -C IS OUTPUT INFORMATION TO BE WRITTEN TO DISK -C - 70 IF (NDISK .EQ. 1) WRITE (NTAPE) (V(J),J=1,NCOMP),(U(J),J=1,NCTNF) -C - RETURN - END diff --git a/slatec/stout.f b/slatec/stout.f deleted file mode 100644 index 4471a3d..0000000 --- a/slatec/stout.f +++ /dev/null @@ -1,153 +0,0 @@ -*DECK STOUT - SUBROUTINE STOUT (N, NELT, IA, JA, A, ISYM, SOLN, RHS, IUNIT, JOB) -C***BEGIN PROLOGUE STOUT -C***PURPOSE Write out SLAP Triad Format Linear System. -C Routine to write out a SLAP Triad format matrix and right -C hand side and solution to the system, if known. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY N1 -C***TYPE SINGLE PRECISION (STOUT-S, DTOUT-D) -C***KEYWORDS DIAGNOSTICS, LINEAR SYSTEM, SLAP SPARSE -C***AUTHOR Seager, Mark K., (LLNL) -C Lawrence Livermore National Laboratory -C PO BOX 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C seager@llnl.gov -C***DESCRIPTION -C -C *Usage: -C INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, IUNIT, JOB -C REAL A(NELT), SOLN(N), RHS(N) -C -C CALL STOUT( N, NELT, IA, JA, A, ISYM, SOLN, RHS, IUNIT, JOB ) -C -C *Arguments: -C N :IN Integer -C Order of the Matrix. -C NELT :IN Integer. -C Number of non-zeros stored in A. -C IA :IN Integer IA(NELT). -C JA :IN Integer JA(NELT). -C A :IN Real A(NELT). -C These arrays should hold the matrix A in the SLAP -C Triad format. See "Description", below. -C ISYM :IN Integer. -C Flag to indicate symmetric storage format. -C If ISYM=0, all non-zero entries of the matrix are stored. -C If ISYM=1, the matrix is symmetric, and only the lower -C triangle of the matrix is stored. -C SOLN :IN Real SOLN(N). -C The solution to the linear system, if known. This array -C is accessed if and only if JOB is set to print it out, -C see below. -C RHS :IN Real RHS(N). -C The right hand side vector. This array is accessed if and -C only if JOB is set to print it out, see below. -C IUNIT :IN Integer. -C Fortran logical I/O device unit number to write the matrix -C to. This unit must be connected in a system dependent fashion -C to a file or the console or you will get a nasty message -C from the Fortran I/O libraries. -C JOB :IN Integer. -C Flag indicating what I/O operations to perform. -C JOB = 0 => Print only the matrix. -C = 1 => Print matrix and RHS. -C = 2 => Print matrix and SOLN. -C = 3 => Print matrix, RHS and SOLN. -C -C *Description: -C The format for the output is as follows. On the first line -C are counters and flags: N, NELT, ISYM, IRHS, ISOLN. N, NELT -C and ISYM are described above. IRHS is a flag indicating if -C the RHS was written out (1 is yes, 0 is no). ISOLN is a -C flag indicating if the SOLN was written out (1 is yes, 0 is -C no). The format for the fist line is: 5i10. Then comes the -C NELT Triad's IA(I), JA(I) and A(I), I = 1, NELT. The format -C for these lines is : 1X,I5,1X,I5,1X,E16.7. Then comes -C RHS(I), I = 1, N, if IRHS = 1. Then comes SOLN(I), I = 1, -C N, if ISOLN = 1. The format for these lines is: 1X,E16.7. -C -C =================== S L A P Triad format =================== -C This routine requires that the matrix A be stored in the -C SLAP Triad format. In this format only the non-zeros are -C stored. They may appear in *ANY* order. The user supplies -C three arrays of length NELT, where NELT is the number of -C non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For -C each non-zero the user puts the row and column index of that -C matrix element in the IA and JA arrays. The value of the -C non-zero matrix element is placed in the corresponding -C location of the A array. This is an extremely easy data -C structure to generate. On the other hand it is not too -C efficient on vector computers for the iterative solution of -C linear systems. Hence, SLAP changes this input data -C structure to the SLAP Column format for the iteration (but -C does not change it back). -C -C Here is an example of the SLAP Triad storage format for a -C 5x5 Matrix. Recall that the entries may appear in any order. -C -C 5x5 Matrix SLAP Triad format for 5x5 matrix on left. -C 1 2 3 4 5 6 7 8 9 10 11 -C |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 -C |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 -C | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 -C | 0 0 0 44 0| -C |51 0 53 0 55| -C -C *Cautions: -C This routine will attempt to write to the Fortran logical output -C unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that -C this logical unit is attached to a file or terminal before calling -C this routine with a non-zero value for IUNIT. This routine does -C not check for the validity of a non-zero IUNIT unit number. -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 871119 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 920511 Added complete declaration section. (WRB) -C 930701 Updated CATEGORY section. (FNF, WRB) -C***END PROLOGUE STOUT -C .. Scalar Arguments .. - INTEGER ISYM, IUNIT, JOB, N, NELT -C .. Array Arguments .. - REAL A(NELT), RHS(N), SOLN(N) - INTEGER IA(NELT), JA(NELT) -C .. Local Scalars .. - INTEGER I, IRHS, ISOLN -C***FIRST EXECUTABLE STATEMENT STOUT -C -C If RHS and SOLN are to be printed also. -C Write out the information heading. -C - IRHS = 0 - ISOLN = 0 - IF( JOB.EQ.1 .OR. JOB.EQ.3 ) IRHS = 1 - IF( JOB.GT.1 ) ISOLN = 1 - WRITE(IUNIT,1000) N, NELT, ISYM, IRHS, ISOLN -C -C Write out the matrix non-zeros in Triad format. - DO 10 I = 1, NELT - WRITE(IUNIT,1010) IA(I), JA(I), A(I) - 10 CONTINUE -C -C If requested, write out the rhs. - IF( IRHS.EQ.1 ) THEN - WRITE(IUNIT,1020) (RHS(I),I=1,N) - ENDIF -C -C If requested, write out the solution. - IF( ISOLN.EQ.1 ) THEN - WRITE(IUNIT,1020) (SOLN(I),I=1,N) - ENDIF - RETURN - 1000 FORMAT(5I10) - 1010 FORMAT(1X,I5,1X,I5,1X,E16.7) - 1020 FORMAT(1X,E16.7) -C------------- LAST LINE OF STOUT FOLLOWS ---------------------------- - END diff --git a/slatec/stpmv.f b/slatec/stpmv.f deleted file mode 100644 index 85279e0..0000000 --- a/slatec/stpmv.f +++ /dev/null @@ -1,306 +0,0 @@ -*DECK STPMV - SUBROUTINE STPMV (UPLO, TRANS, DIAG, N, AP, X, INCX) -C***BEGIN PROLOGUE STPMV -C***PURPOSE Perform one of the matrix-vector operations. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE SINGLE PRECISION (STPMV-S, DTPMV-D, CTPMV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C STPMV performs one of the matrix-vector operations -C -C x := A*x, or x := A'*x, -C -C where x is an n element vector and A is an n by n unit, or non-unit, -C upper or lower triangular matrix, supplied in packed form. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the matrix is an upper or -C lower triangular matrix as follows: -C -C UPLO = 'U' or 'u' A is an upper triangular matrix. -C -C UPLO = 'L' or 'l' A is a lower triangular matrix. -C -C Unchanged on exit. -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the operation to be performed as -C follows: -C -C TRANS = 'N' or 'n' x := A*x. -C -C TRANS = 'T' or 't' x := A'*x. -C -C TRANS = 'C' or 'c' x := A'*x. -C -C Unchanged on exit. -C -C DIAG - CHARACTER*1. -C On entry, DIAG specifies whether or not A is unit -C triangular as follows: -C -C DIAG = 'U' or 'u' A is assumed to be unit triangular. -C -C DIAG = 'N' or 'n' A is not assumed to be unit -C triangular. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C AP - REAL array of DIMENSION at least -C ( ( n*( n + 1))/2). -C Before entry with UPLO = 'U' or 'u', the array AP must -C contain the upper triangular matrix packed sequentially, -C column by column, so that AP( 1 ) contains a( 1, 1 ), -C AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) -C respectively, and so on. -C Before entry with UPLO = 'L' or 'l', the array AP must -C contain the lower triangular matrix packed sequentially, -C column by column, so that AP( 1 ) contains a( 1, 1 ), -C AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) -C respectively, and so on. -C Note that when DIAG = 'U' or 'u', the diagonal elements of -C A are not referenced, but are assumed to be unity. -C Unchanged on exit. -C -C X - REAL array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element vector x. On exit, X is overwritten with the -C transformed vector x. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE STPMV -C .. Scalar Arguments .. - INTEGER INCX, N - CHARACTER*1 DIAG, TRANS, UPLO -C .. Array Arguments .. - REAL AP( * ), X( * ) -C .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0E+0 ) -C .. Local Scalars .. - REAL TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX - LOGICAL NOUNIT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C***FIRST EXECUTABLE STATEMENT STPMV -C -C Test the input parameters. -C - 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( 'STPMV ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - NOUNIT = LSAME( DIAG, 'N' ) -C -C Set up the start point in X if the increment is not unity. This -C will be ( N - 1 )*INCX too small for descending loops. -C - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -C -C Start the operations. In this version the elements of AP are -C accessed sequentially with one pass through AP. -C - IF( LSAME( TRANS, 'N' ) )THEN -C -C Form x:= A*x. -C - 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 -C -C Form x := A'*x. -C - 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 -C - RETURN -C -C End of STPMV . -C - END diff --git a/slatec/stpsv.f b/slatec/stpsv.f deleted file mode 100644 index 8fb5fa2..0000000 --- a/slatec/stpsv.f +++ /dev/null @@ -1,309 +0,0 @@ -*DECK STPSV - SUBROUTINE STPSV (UPLO, TRANS, DIAG, N, AP, X, INCX) -C***BEGIN PROLOGUE STPSV -C***PURPOSE Solve one of the systems of equations. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE SINGLE PRECISION (STPSV-S, DTPSV-D, CTPSV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C STPSV solves one of the systems of equations -C -C A*x = b, or A'*x = b, -C -C where b and x are n element vectors and A is an n by n unit, or -C non-unit, upper or lower triangular matrix, supplied in packed form. -C -C No test for singularity or near-singularity is included in this -C routine. Such tests must be performed before calling this routine. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the matrix is an upper or -C lower triangular matrix as follows: -C -C UPLO = 'U' or 'u' A is an upper triangular matrix. -C -C UPLO = 'L' or 'l' A is a lower triangular matrix. -C -C Unchanged on exit. -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the equations to be solved as -C follows: -C -C TRANS = 'N' or 'n' A*x = b. -C -C TRANS = 'T' or 't' A'*x = b. -C -C TRANS = 'C' or 'c' A'*x = b. -C -C Unchanged on exit. -C -C DIAG - CHARACTER*1. -C On entry, DIAG specifies whether or not A is unit -C triangular as follows: -C -C DIAG = 'U' or 'u' A is assumed to be unit triangular. -C -C DIAG = 'N' or 'n' A is not assumed to be unit -C triangular. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C AP - REAL array of DIMENSION at least -C ( ( n*( n + 1))/2). -C Before entry with UPLO = 'U' or 'u', the array AP must -C contain the upper triangular matrix packed sequentially, -C column by column, so that AP( 1 ) contains a( 1, 1 ), -C AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) -C respectively, and so on. -C Before entry with UPLO = 'L' or 'l', the array AP must -C contain the lower triangular matrix packed sequentially, -C column by column, so that AP( 1 ) contains a( 1, 1 ), -C AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) -C respectively, and so on. -C Note that when DIAG = 'U' or 'u', the diagonal elements of -C A are not referenced, but are assumed to be unity. -C Unchanged on exit. -C -C X - REAL array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element right-hand side vector b. On exit, X is overwritten -C with the solution vector x. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE STPSV -C .. Scalar Arguments .. - INTEGER INCX, N - CHARACTER*1 DIAG, TRANS, UPLO -C .. Array Arguments .. - REAL AP( * ), X( * ) -C .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0E+0 ) -C .. Local Scalars .. - REAL TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX - LOGICAL NOUNIT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C***FIRST EXECUTABLE STATEMENT STPSV -C -C Test the input parameters. -C - 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( 'STPSV ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - NOUNIT = LSAME( DIAG, 'N' ) -C -C Set up the start point in X if the increment is not unity. This -C will be ( N - 1 )*INCX too small for descending loops. -C - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -C -C Start the operations. In this version the elements of AP are -C accessed sequentially with one pass through AP. -C - IF( LSAME( TRANS, 'N' ) )THEN -C -C Form x := inv( A )*x. -C - 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 -C -C Form x := inv( A' )*x. -C - 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 -C - RETURN -C -C End of STPSV . -C - END diff --git a/slatec/strco.f b/slatec/strco.f deleted file mode 100644 index 40984dc..0000000 --- a/slatec/strco.f +++ /dev/null @@ -1,174 +0,0 @@ -*DECK STRCO - SUBROUTINE STRCO (T, LDT, N, RCOND, Z, JOB) -C***BEGIN PROLOGUE STRCO -C***PURPOSE Estimate the condition number of a triangular matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2A3 -C***TYPE SINGLE PRECISION (STRCO-S, DTRCO-D, CTRCO-C) -C***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, -C TRIANGULAR MATRIX -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C STRCO estimates the condition of a real triangular matrix. -C -C On Entry -C -C T REAL(LDT,N) -C T contains the triangular matrix. The zero -C elements of the matrix are not referenced, and -C the corresponding elements of the array can be -C used to store other information. -C -C LDT INTEGER -C LDT is the leading dimension of the array T. -C -C N INTEGER -C N is the order of the system. -C -C JOB INTEGER -C = 0 T is lower triangular. -C = nonzero T is upper triangular. -C -C On Return -C -C RCOND REAL -C an estimate of the reciprocal condition of T . -C For the system T*X = B , relative perturbations -C in T 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 T 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 REAL(N) -C a work vector whose contents are usually unimportant. -C If T 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***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SASUM, SAXPY, SSCAL -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE STRCO - INTEGER LDT,N,JOB - REAL T(LDT,*),Z(*) - REAL RCOND -C - REAL W,WK,WKM,EK - REAL TNORM,YNORM,S,SM,SASUM - INTEGER I1,J,J1,J2,K,KK,L - LOGICAL LOWER -C***FIRST EXECUTABLE STATEMENT STRCO - LOWER = JOB .EQ. 0 -C -C COMPUTE 1-NORM OF T -C - TNORM = 0.0E0 - DO 10 J = 1, N - L = J - IF (LOWER) L = N + 1 - J - I1 = 1 - IF (LOWER) I1 = J - TNORM = MAX(TNORM,SASUM(L,T(I1,J),1)) - 10 CONTINUE -C -C RCOND = 1/(NORM(T)*(ESTIMATE OF NORM(INVERSE(T)))) . -C ESTIMATE = NORM(Z)/NORM(Y) WHERE T*Z = Y AND TRANS(T)*Y = E . -C TRANS(T) IS THE TRANSPOSE OF T . -C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL -C GROWTH IN THE ELEMENTS OF Y . -C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. -C -C SOLVE TRANS(T)*Y = E -C - EK = 1.0E0 - DO 20 J = 1, N - Z(J) = 0.0E0 - 20 CONTINUE - DO 100 KK = 1, N - K = KK - IF (LOWER) K = N + 1 - KK - IF (Z(K) .NE. 0.0E0) EK = SIGN(EK,-Z(K)) - IF (ABS(EK-Z(K)) .LE. ABS(T(K,K))) GO TO 30 - S = ABS(T(K,K))/ABS(EK-Z(K)) - CALL SSCAL(N,S,Z,1) - EK = S*EK - 30 CONTINUE - WK = EK - Z(K) - WKM = -EK - Z(K) - S = ABS(WK) - SM = ABS(WKM) - IF (T(K,K) .EQ. 0.0E0) GO TO 40 - WK = WK/T(K,K) - WKM = WKM/T(K,K) - GO TO 50 - 40 CONTINUE - WK = 1.0E0 - WKM = 1.0E0 - 50 CONTINUE - IF (KK .EQ. N) GO TO 90 - J1 = K + 1 - IF (LOWER) J1 = 1 - J2 = N - IF (LOWER) J2 = K - 1 - DO 60 J = J1, J2 - SM = SM + ABS(Z(J)+WKM*T(K,J)) - Z(J) = Z(J) + WK*T(K,J) - S = S + ABS(Z(J)) - 60 CONTINUE - IF (S .GE. SM) GO TO 80 - W = WKM - WK - WK = WKM - DO 70 J = J1, J2 - Z(J) = Z(J) + W*T(K,J) - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - Z(K) = WK - 100 CONTINUE - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) -C - YNORM = 1.0E0 -C -C SOLVE T*Z = Y -C - DO 130 KK = 1, N - K = N + 1 - KK - IF (LOWER) K = KK - IF (ABS(Z(K)) .LE. ABS(T(K,K))) GO TO 110 - S = ABS(T(K,K))/ABS(Z(K)) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM - 110 CONTINUE - IF (T(K,K) .NE. 0.0E0) Z(K) = Z(K)/T(K,K) - IF (T(K,K) .EQ. 0.0E0) Z(K) = 1.0E0 - I1 = 1 - IF (LOWER) I1 = K + 1 - IF (KK .GE. N) GO TO 120 - W = -Z(K) - CALL SAXPY(N-KK,W,T(I1,K),1,Z(I1),1) - 120 CONTINUE - 130 CONTINUE -C MAKE ZNORM = 1.0 - S = 1.0E0/SASUM(N,Z,1) - CALL SSCAL(N,S,Z,1) - YNORM = S*YNORM -C - IF (TNORM .NE. 0.0E0) RCOND = YNORM/TNORM - IF (TNORM .EQ. 0.0E0) RCOND = 0.0E0 - RETURN - END diff --git a/slatec/strdi.f b/slatec/strdi.f deleted file mode 100644 index bc6d006..0000000 --- a/slatec/strdi.f +++ /dev/null @@ -1,145 +0,0 @@ -*DECK STRDI - SUBROUTINE STRDI (T, LDT, N, DET, JOB, INFO) -C***BEGIN PROLOGUE STRDI -C***PURPOSE Compute the determinant and inverse of a triangular matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2A3, D3A3 -C***TYPE SINGLE PRECISION (STRDI-S, DTRDI-D, CTRDI-C) -C***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, -C TRIANGULAR -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C STRDI computes the determinant and inverse of a real -C triangular matrix. -C -C On Entry -C -C T REAL(LDT,N) -C T contains the triangular matrix. The zero -C elements of the matrix are not referenced, and -C the corresponding elements of the array can be -C used to store other information. -C -C LDT INTEGER -C LDT is the leading dimension of the array T. -C -C N INTEGER -C N is the order of the system. -C -C JOB INTEGER -C = 010 no det, inverse of lower triangular. -C = 011 no det, inverse of upper triangular. -C = 100 det, no inverse. -C = 110 det, inverse of lower triangular. -C = 111 det, inverse of upper triangular. -C -C On Return -C -C T inverse of original matrix if requested. -C Otherwise unchanged. -C -C DET REAL(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. ABS(DET(1)) .LT. 10.0 -C or DET(1) .EQ. 0.0 . -C -C INFO INTEGER -C INFO contains zero if the system is nonsingular -C and the inverse is requested. -C Otherwise INFO contains the index of -C a zero diagonal element of T. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SAXPY, SSCAL -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE STRDI - INTEGER LDT,N,JOB,INFO - REAL T(LDT,*),DET(2) -C - REAL TEMP - REAL TEN - INTEGER I,J,K,KB,KM1,KP1 -C***FIRST EXECUTABLE STATEMENT STRDI -C -C COMPUTE DETERMINANT -C - IF (JOB/100 .EQ. 0) GO TO 70 - DET(1) = 1.0E0 - DET(2) = 0.0E0 - TEN = 10.0E0 - DO 50 I = 1, N - DET(1) = T(I,I)*DET(1) - IF (DET(1) .EQ. 0.0E0) GO TO 60 - 10 IF (ABS(DET(1)) .GE. 1.0E0) GO TO 20 - DET(1) = TEN*DET(1) - DET(2) = DET(2) - 1.0E0 - GO TO 10 - 20 CONTINUE - 30 IF (ABS(DET(1)) .LT. TEN) GO TO 40 - DET(1) = DET(1)/TEN - DET(2) = DET(2) + 1.0E0 - GO TO 30 - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE -C -C COMPUTE INVERSE OF UPPER TRIANGULAR -C - IF (MOD(JOB/10,10) .EQ. 0) GO TO 170 - IF (MOD(JOB,10) .EQ. 0) GO TO 120 - DO 100 K = 1, N - INFO = K - IF (T(K,K) .EQ. 0.0E0) GO TO 110 - T(K,K) = 1.0E0/T(K,K) - TEMP = -T(K,K) - CALL SSCAL(K-1,TEMP,T(1,K),1) - KP1 = K + 1 - IF (N .LT. KP1) GO TO 90 - DO 80 J = KP1, N - TEMP = T(K,J) - T(K,J) = 0.0E0 - CALL SAXPY(K,TEMP,T(1,K),1,T(1,J),1) - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - INFO = 0 - 110 CONTINUE - GO TO 160 - 120 CONTINUE -C -C COMPUTE INVERSE OF LOWER TRIANGULAR -C - DO 150 KB = 1, N - K = N + 1 - KB - INFO = K - IF (T(K,K) .EQ. 0.0E0) GO TO 180 - T(K,K) = 1.0E0/T(K,K) - TEMP = -T(K,K) - IF (K .NE. N) CALL SSCAL(N-K,TEMP,T(K+1,K),1) - KM1 = K - 1 - IF (KM1 .LT. 1) GO TO 140 - DO 130 J = 1, KM1 - TEMP = T(K,J) - T(K,J) = 0.0E0 - CALL SAXPY(N-K+1,TEMP,T(K,K),1,T(K,J),1) - 130 CONTINUE - 140 CONTINUE - 150 CONTINUE - INFO = 0 - 160 CONTINUE - 170 CONTINUE - 180 CONTINUE - RETURN - END diff --git a/slatec/strmm.f b/slatec/strmm.f deleted file mode 100644 index 30e44bc..0000000 --- a/slatec/strmm.f +++ /dev/null @@ -1,361 +0,0 @@ -*DECK STRMM - SUBROUTINE STRMM (SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB) -C***BEGIN PROLOGUE STRMM -C***PURPOSE Multiply a real general matrix by a real triangular matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B6 -C***TYPE SINGLE PRECISION (STRMM-S, DTRMM-D, CTRMM-C) -C***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J., (ANL) -C Duff, I., (AERE) -C Du Croz, J., (NAG) -C Hammarling, S. (NAG) -C***DESCRIPTION -C -C STRMM performs one of the matrix-matrix operations -C -C B := alpha*op( A )*B, or B := alpha*B*op( A ), -C -C where alpha is a scalar, B is an m by n matrix, A is a unit, or -C non-unit, upper or lower triangular matrix and op( A ) is one of -C -C op( A ) = A or op( A ) = A'. -C -C Parameters -C ========== -C -C SIDE - CHARACTER*1. -C On entry, SIDE specifies whether op( A ) multiplies B from -C the left or right as follows: -C -C SIDE = 'L' or 'l' B := alpha*op( A )*B. -C -C SIDE = 'R' or 'r' B := alpha*B*op( A ). -C -C Unchanged on exit. -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the matrix A is an upper or -C lower triangular matrix as follows: -C -C UPLO = 'U' or 'u' A is an upper triangular matrix. -C -C UPLO = 'L' or 'l' A is a lower triangular matrix. -C -C Unchanged on exit. -C -C TRANSA - CHARACTER*1. -C On entry, TRANSA specifies the form of op( A ) to be used in -C the matrix multiplication as follows: -C -C TRANSA = 'N' or 'n' op( A ) = A. -C -C TRANSA = 'T' or 't' op( A ) = A'. -C -C TRANSA = 'C' or 'c' op( A ) = A'. -C -C Unchanged on exit. -C -C DIAG - CHARACTER*1. -C On entry, DIAG specifies whether or not A is unit triangular -C as follows: -C -C DIAG = 'U' or 'u' A is assumed to be unit triangular. -C -C DIAG = 'N' or 'n' A is not assumed to be unit -C triangular. -C -C Unchanged on exit. -C -C M - INTEGER. -C On entry, M specifies the number of rows of B. M must be at -C least zero. -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the number of columns of B. N must be -C at least zero. -C Unchanged on exit. -C -C ALPHA - REAL . -C On entry, ALPHA specifies the scalar alpha. When alpha is -C zero then A is not referenced and B need not be set before -C entry. -C Unchanged on exit. -C -C A - REAL array of DIMENSION ( LDA, k ), where k is m -C when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -C Before entry with UPLO = 'U' or 'u', the leading k by k -C upper triangular part of the array A must contain the upper -C triangular matrix and the strictly lower triangular part of -C A is not referenced. -C Before entry with UPLO = 'L' or 'l', the leading k by k -C lower triangular part of the array A must contain the lower -C triangular matrix and the strictly upper triangular part of -C A is not referenced. -C Note that when DIAG = 'U' or 'u', the diagonal elements of -C A are not referenced either, but are assumed to be unity. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. When SIDE = 'L' or 'l' then -C LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -C then LDA must be at least max( 1, n ). -C Unchanged on exit. -C -C B - REAL array of DIMENSION ( LDB, n ). -C Before entry, the leading m by n part of the array B must -C contain the matrix B, and on exit is overwritten by the -C transformed matrix. -C -C LDB - INTEGER. -C On entry, LDB specifies the first dimension of B as declared -C in the calling (sub) program. LDB must be at least -C max( 1, m ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. -C A set of level 3 basic linear algebra subprograms. -C ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 890208 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE STRMM -C .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - REAL ALPHA -C .. Array Arguments .. - REAL A( LDA, * ), B( LDB, * ) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Local Scalars .. - LOGICAL LSIDE, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - REAL TEMP -C .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -C***FIRST EXECUTABLE STATEMENT STRMM -C -C Test the input parameters. -C - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -C - 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( 'STRMM ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C -C And when alpha.eq.zero. -C - 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 -C -C Start the operations. -C - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) )THEN -C -C Form B := alpha*A*B. -C - 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 -C -C Form B := alpha*B*A'. -C - 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 -C -C Form B := alpha*B*A. -C - 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 -C -C Form B := alpha*B*A'. -C - 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 -C - RETURN -C -C End of STRMM . -C - END diff --git a/slatec/strmv.f b/slatec/strmv.f deleted file mode 100644 index 90a803f..0000000 --- a/slatec/strmv.f +++ /dev/null @@ -1,293 +0,0 @@ -*DECK STRMV - SUBROUTINE STRMV (UPLO, TRANS, DIAG, N, A, LDA, X, INCX) -C***BEGIN PROLOGUE STRMV -C***PURPOSE Multiply a real vector by a real triangular matrix. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE SINGLE PRECISION (STRMV-S, DTRMV-D, CTRMV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C STRMV performs one of the matrix-vector operations -C -C x := A*x, or x := A'*x, -C -C where x is an n element vector and A is an n by n unit, or non-unit, -C upper or lower triangular matrix. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the matrix is an upper or -C lower triangular matrix as follows: -C -C UPLO = 'U' or 'u' A is an upper triangular matrix. -C -C UPLO = 'L' or 'l' A is a lower triangular matrix. -C -C Unchanged on exit. -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the operation to be performed as -C follows: -C -C TRANS = 'N' or 'n' x := A*x. -C -C TRANS = 'T' or 't' x := A'*x. -C -C TRANS = 'C' or 'c' x := A'*x. -C -C Unchanged on exit. -C -C DIAG - CHARACTER*1. -C On entry, DIAG specifies whether or not A is unit -C triangular as follows: -C -C DIAG = 'U' or 'u' A is assumed to be unit triangular. -C -C DIAG = 'N' or 'n' A is not assumed to be unit -C triangular. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C A - REAL array of DIMENSION ( LDA, n). -C Before entry with UPLO = 'U' or 'u', the leading n by n -C upper triangular part of the array A must contain the upper -C triangular matrix and the strictly lower triangular part of -C A is not referenced. -C Before entry with UPLO = 'L' or 'l', the leading n by n -C lower triangular part of the array A must contain the lower -C triangular matrix and the strictly upper triangular part of -C A is not referenced. -C Note that when DIAG = 'U' or 'u', the diagonal elements of -C A are not referenced either, but are assumed to be unity. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C max( 1, n ). -C Unchanged on exit. -C -C X - REAL array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element vector x. On exit, X is overwritten with the -C transformed vector x. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE STRMV -C .. Scalar Arguments .. - INTEGER INCX, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -C .. Array Arguments .. - REAL A( LDA, * ), X( * ) -C .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0E+0 ) -C .. Local Scalars .. - REAL TEMP - INTEGER I, INFO, IX, J, JX, KX - LOGICAL NOUNIT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C***FIRST EXECUTABLE STATEMENT STRMV -C -C Test the input parameters. -C - 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( 'STRMV ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - NOUNIT = LSAME( DIAG, 'N' ) -C -C Set up the start point in X if the increment is not unity. This -C will be ( N - 1 )*INCX too small for descending loops. -C - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through A. -C - IF( LSAME( TRANS, 'N' ) )THEN -C -C Form x := A*x. -C - 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 -C -C Form x := A'*x. -C - 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 -C - RETURN -C -C End of STRMV . -C - END diff --git a/slatec/strsl.f b/slatec/strsl.f deleted file mode 100644 index 0fb5058..0000000 --- a/slatec/strsl.f +++ /dev/null @@ -1,146 +0,0 @@ -*DECK STRSL - SUBROUTINE STRSL (T, LDT, N, B, JOB, INFO) -C***BEGIN PROLOGUE STRSL -C***PURPOSE Solve a system of the form T*X=B or TRANS(T)*X=B, where -C T is a triangular matrix. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2A3 -C***TYPE SINGLE PRECISION (STRSL-S, DTRSL-D, CTRSL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, TRIANGULAR LINEAR SYSTEM, -C TRIANGULAR MATRIX -C***AUTHOR Stewart, G. W., (U. of Maryland) -C***DESCRIPTION -C -C STRSL solves systems of the form -C -C T * X = B -C or -C TRANS(T) * X = B -C -C where T is a triangular matrix of order N. Here TRANS(T) -C denotes the transpose of the matrix T. -C -C On Entry -C -C T REAL(LDT,N) -C T contains the matrix of the system. The zero -C elements of the matrix are not referenced, and -C the corresponding elements of the array can be -C used to store other information. -C -C LDT INTEGER -C LDT is the leading dimension of the array T. -C -C N INTEGER -C N is the order of the system. -C -C B REAL(N). -C B contains the right hand side of the system. -C -C JOB INTEGER -C JOB specifies what kind of system is to be solved. -C If JOB is -C -C 00 solve T*X=B, T lower triangular, -C 01 solve T*X=B, T upper triangular, -C 10 solve TRANS(T)*X=B, T lower triangular, -C 11 solve TRANS(T)*X=B, T upper triangular. -C -C On Return -C -C B B contains the solution, if INFO .EQ. 0. -C Otherwise B is unaltered. -C -C INFO INTEGER -C INFO contains zero if the system is nonsingular. -C Otherwise INFO contains the index of -C the first zero diagonal element of T. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED SAXPY, SDOT -C***REVISION HISTORY (YYMMDD) -C 780814 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 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE STRSL - INTEGER LDT,N,JOB,INFO - REAL T(LDT,*),B(*) -C -C - REAL SDOT,TEMP - INTEGER CASE,J,JJ -C***FIRST EXECUTABLE STATEMENT STRSL -C -C CHECK FOR ZERO DIAGONAL ELEMENTS. -C - DO 10 INFO = 1, N - IF (T(INFO,INFO) .EQ. 0.0E0) GO TO 150 - 10 CONTINUE - INFO = 0 -C -C DETERMINE THE TASK AND GO TO IT. -C - CASE = 1 - IF (MOD(JOB,10) .NE. 0) CASE = 2 - IF (MOD(JOB,100)/10 .NE. 0) CASE = CASE + 2 - GO TO (20,50,80,110), CASE -C -C SOLVE T*X=B FOR T LOWER TRIANGULAR -C - 20 CONTINUE - B(1) = B(1)/T(1,1) - IF (N .LT. 2) GO TO 40 - DO 30 J = 2, N - TEMP = -B(J-1) - CALL SAXPY(N-J+1,TEMP,T(J,J-1),1,B(J),1) - B(J) = B(J)/T(J,J) - 30 CONTINUE - 40 CONTINUE - GO TO 140 -C -C SOLVE T*X=B FOR T UPPER TRIANGULAR. -C - 50 CONTINUE - B(N) = B(N)/T(N,N) - IF (N .LT. 2) GO TO 70 - DO 60 JJ = 2, N - J = N - JJ + 1 - TEMP = -B(J+1) - CALL SAXPY(J,TEMP,T(1,J+1),1,B(1),1) - B(J) = B(J)/T(J,J) - 60 CONTINUE - 70 CONTINUE - GO TO 140 -C -C SOLVE TRANS(T)*X=B FOR T LOWER TRIANGULAR. -C - 80 CONTINUE - B(N) = B(N)/T(N,N) - IF (N .LT. 2) GO TO 100 - DO 90 JJ = 2, N - J = N - JJ + 1 - B(J) = B(J) - SDOT(JJ-1,T(J+1,J),1,B(J+1),1) - B(J) = B(J)/T(J,J) - 90 CONTINUE - 100 CONTINUE - GO TO 140 -C -C SOLVE TRANS(T)*X=B FOR T UPPER TRIANGULAR. -C - 110 CONTINUE - B(1) = B(1)/T(1,1) - IF (N .LT. 2) GO TO 130 - DO 120 J = 2, N - B(J) = B(J) - SDOT(J-1,T(1,J),1,B(1),1) - B(J) = B(J)/T(J,J) - 120 CONTINUE - 130 CONTINUE - 140 CONTINUE - 150 CONTINUE - RETURN - END diff --git a/slatec/strsm.f b/slatec/strsm.f deleted file mode 100644 index 8d03fbb..0000000 --- a/slatec/strsm.f +++ /dev/null @@ -1,385 +0,0 @@ -*DECK STRSM - SUBROUTINE STRSM (SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB) -C***BEGIN PROLOGUE STRSM -C***PURPOSE Solve a real triangular system of equations with multiple -C right-hand sides. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B6 -C***TYPE SINGLE PRECISION (STRSM-S, DTRSM-D, CTRSM-C) -C***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J., (ANL) -C Duff, I., (AERE) -C Du Croz, J., (NAG) -C Hammarling, S. (NAG) -C***DESCRIPTION -C -C STRSM solves one of the matrix equations -C -C op( A )*X = alpha*B, or X*op( A ) = alpha*B, -C -C where alpha is a scalar, X and B are m by n matrices, A is a unit, or -C non-unit, upper or lower triangular matrix and op( A ) is one of -C -C op( A ) = A or op( A ) = A'. -C -C The matrix X is overwritten on B. -C -C Parameters -C ========== -C -C SIDE - CHARACTER*1. -C On entry, SIDE specifies whether op( A ) appears on the left -C or right of X as follows: -C -C SIDE = 'L' or 'l' op( A )*X = alpha*B. -C -C SIDE = 'R' or 'r' X*op( A ) = alpha*B. -C -C Unchanged on exit. -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the matrix A is an upper or -C lower triangular matrix as follows: -C -C UPLO = 'U' or 'u' A is an upper triangular matrix. -C -C UPLO = 'L' or 'l' A is a lower triangular matrix. -C -C Unchanged on exit. -C -C TRANSA - CHARACTER*1. -C On entry, TRANSA specifies the form of op( A ) to be used in -C the matrix multiplication as follows: -C -C TRANSA = 'N' or 'n' op( A ) = A. -C -C TRANSA = 'T' or 't' op( A ) = A'. -C -C TRANSA = 'C' or 'c' op( A ) = A'. -C -C Unchanged on exit. -C -C DIAG - CHARACTER*1. -C On entry, DIAG specifies whether or not A is unit triangular -C as follows: -C -C DIAG = 'U' or 'u' A is assumed to be unit triangular. -C -C DIAG = 'N' or 'n' A is not assumed to be unit -C triangular. -C -C Unchanged on exit. -C -C M - INTEGER. -C On entry, M specifies the number of rows of B. M must be at -C least zero. -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the number of columns of B. N must be -C at least zero. -C Unchanged on exit. -C -C ALPHA - REAL . -C On entry, ALPHA specifies the scalar alpha. When alpha is -C zero then A is not referenced and B need not be set before -C entry. -C Unchanged on exit. -C -C A - REAL array of DIMENSION ( LDA, k ), where k is m -C when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -C Before entry with UPLO = 'U' or 'u', the leading k by k -C upper triangular part of the array A must contain the upper -C triangular matrix and the strictly lower triangular part of -C A is not referenced. -C Before entry with UPLO = 'L' or 'l', the leading k by k -C lower triangular part of the array A must contain the lower -C triangular matrix and the strictly upper triangular part of -C A is not referenced. -C Note that when DIAG = 'U' or 'u', the diagonal elements of -C A are not referenced either, but are assumed to be unity. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. When SIDE = 'L' or 'l' then -C LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -C then LDA must be at least max( 1, n ). -C Unchanged on exit. -C -C B - REAL array of DIMENSION ( LDB, n ). -C Before entry, the leading m by n part of the array B must -C contain the right-hand side matrix B, and on exit is -C overwritten by the solution matrix X. -C -C LDB - INTEGER. -C On entry, LDB specifies the first dimension of B as declared -C in the calling (sub) program. LDB must be at least -C max( 1, m ). -C Unchanged on exit. -C -C***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. -C A set of level 3 basic linear algebra subprograms. -C ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 890208 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE STRSM -C .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - REAL ALPHA -C .. Array Arguments .. - REAL A( LDA, * ), B( LDB, * ) -C -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Local Scalars .. - LOGICAL LSIDE, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - REAL TEMP -C .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -C***FIRST EXECUTABLE STATEMENT STRSM -C -C Test the input parameters. -C - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -C - 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( 'STRSM ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C -C And when alpha.eq.zero. -C - 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 -C -C Start the operations. -C - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) )THEN -C -C Form B := alpha*inv( A )*B. -C - 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 -C -C Form B := alpha*inv( A' )*B. -C - 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 -C -C Form B := alpha*B*inv( A ). -C - 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 -C -C Form B := alpha*B*inv( A' ). -C - 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 -C - RETURN -C -C End of STRSM . -C - END diff --git a/slatec/strsv.f b/slatec/strsv.f deleted file mode 100644 index 5e719dd..0000000 --- a/slatec/strsv.f +++ /dev/null @@ -1,296 +0,0 @@ -*DECK STRSV - SUBROUTINE STRSV (UPLO, TRANS, DIAG, N, A, LDA, X, INCX) -C***BEGIN PROLOGUE STRSV -C***PURPOSE Solve a real triangular system of linear equations. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1B4 -C***TYPE SINGLE PRECISION (STRSV-S, DTRSV-D, CTRSV-C) -C***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA -C***AUTHOR Dongarra, J. J., (ANL) -C Du Croz, J., (NAG) -C Hammarling, S., (NAG) -C Hanson, R. J., (SNLA) -C***DESCRIPTION -C -C STRSV solves one of the systems of equations -C -C A*x = b, or A'*x = b, -C -C where b and x are n element vectors and A is an n by n unit, or -C non-unit, upper or lower triangular matrix. -C -C No test for singularity or near-singularity is included in this -C routine. Such tests must be performed before calling this routine. -C -C Parameters -C ========== -C -C UPLO - CHARACTER*1. -C On entry, UPLO specifies whether the matrix is an upper or -C lower triangular matrix as follows: -C -C UPLO = 'U' or 'u' A is an upper triangular matrix. -C -C UPLO = 'L' or 'l' A is a lower triangular matrix. -C -C Unchanged on exit. -C -C TRANS - CHARACTER*1. -C On entry, TRANS specifies the equations to be solved as -C follows: -C -C TRANS = 'N' or 'n' A*x = b. -C -C TRANS = 'T' or 't' A'*x = b. -C -C TRANS = 'C' or 'c' A'*x = b. -C -C Unchanged on exit. -C -C DIAG - CHARACTER*1. -C On entry, DIAG specifies whether or not A is unit -C triangular as follows: -C -C DIAG = 'U' or 'u' A is assumed to be unit triangular. -C -C DIAG = 'N' or 'n' A is not assumed to be unit -C triangular. -C -C Unchanged on exit. -C -C N - INTEGER. -C On entry, N specifies the order of the matrix A. -C N must be at least zero. -C Unchanged on exit. -C -C A - REAL array of DIMENSION ( LDA, n). -C Before entry with UPLO = 'U' or 'u', the leading n by n -C upper triangular part of the array A must contain the upper -C triangular matrix and the strictly lower triangular part of -C A is not referenced. -C Before entry with UPLO = 'L' or 'l', the leading n by n -C lower triangular part of the array A must contain the lower -C triangular matrix and the strictly upper triangular part of -C A is not referenced. -C Note that when DIAG = 'U' or 'u', the diagonal elements of -C A are not referenced either, but are assumed to be unity. -C Unchanged on exit. -C -C LDA - INTEGER. -C On entry, LDA specifies the first dimension of A as declared -C in the calling (sub) program. LDA must be at least -C max( 1, n ). -C Unchanged on exit. -C -C X - REAL array of dimension at least -C ( 1 + ( n - 1 )*abs( INCX ) ). -C Before entry, the incremented array X must contain the n -C element right-hand side vector b. On exit, X is overwritten -C with the solution vector x. -C -C INCX - INTEGER. -C On entry, INCX specifies the increment for the elements of -C X. INCX must not be zero. -C Unchanged on exit. -C -C***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and -C Hanson, R. J. An extended set of Fortran basic linear -C algebra subprograms. ACM TOMS, Vol. 14, No. 1, -C pp. 1-17, March 1988. -C***ROUTINES CALLED LSAME, XERBLA -C***REVISION HISTORY (YYMMDD) -C 861022 DATE WRITTEN -C 910605 Modified to meet SLATEC prologue standards. Only comment -C lines were modified. (BKS) -C***END PROLOGUE STRSV -C .. Scalar Arguments .. - INTEGER INCX, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -C .. Array Arguments .. - REAL A( LDA, * ), X( * ) -C .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0E+0 ) -C .. Local Scalars .. - REAL TEMP - INTEGER I, INFO, IX, J, JX, KX - LOGICAL NOUNIT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C***FIRST EXECUTABLE STATEMENT STRSV -C -C Test the input parameters. -C - 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( 'STRSV ', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - NOUNIT = LSAME( DIAG, 'N' ) -C -C Set up the start point in X if the increment is not unity. This -C will be ( N - 1 )*INCX too small for descending loops. -C - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through A. -C - IF( LSAME( TRANS, 'N' ) )THEN -C -C Form x := inv( A )*x. -C - 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 -C -C Form x := inv( A' )*x. -C - 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 -C - RETURN -C -C End of STRSV . -C - END diff --git a/slatec/stway.f b/slatec/stway.f deleted file mode 100644 index 2c6a518..0000000 --- a/slatec/stway.f +++ /dev/null @@ -1,72 +0,0 @@ -*DECK STWAY - SUBROUTINE STWAY (U, V, YHP, INOUT, STOWA) -C***BEGIN PROLOGUE STWAY -C***SUBSIDIARY -C***PURPOSE Subsidiary to BVSUP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (STWAY-S, DSTWAY-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C This subroutine stores (recalls) integration data in the event -C that a restart is needed (the homogeneous solution vectors become -C too dependent to continue) -C -C***SEE ALSO BVSUP -C***ROUTINES CALLED STOR1 -C***COMMON BLOCKS ML15TO, ML18JR, ML8SZ -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890921 Realigned order of variables in certain COMMON blocks. -C (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE STWAY -C - DIMENSION U(*),V(*),YHP(*),STOWA(*) -C - COMMON /ML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMP,NFC - COMMON /ML15TO/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP, - 1 KNSWOT,KOP,LOTJP,MNSWOT,NSWOT - COMMON /ML18JR/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ, - 1 INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,NFCC, - 2 ICOCO -C -C***FIRST EXECUTABLE STATEMENT STWAY - IF (INOUT .EQ. 1) GO TO 100 -C -C SAVE IN STOWA ARRAY AND ISTKOP -C - KS=NFC*NCOMP - CALL STOR1(STOWA,U,STOWA(KS+1),V,1,0,0) - KS=KS+NCOMP - IF (NEQIVP .EQ. 0) GO TO 50 - DO 25 J=1,NEQIVP - KSJ=KS+J - 25 STOWA(KSJ)=YHP(KSJ) - 50 KS=KS+NEQIVP - STOWA(KS+1)=X - ISTKOP=KOP - IF (XOP .EQ. X) ISTKOP=KOP+1 - RETURN -C -C RECALL FROM STOWA ARRAY AND ISTKOP -C - 100 KS=NFC*NCOMP - CALL STOR1(YHP,STOWA,YHP(KS+1),STOWA(KS+1),1,0,0) - KS=KS+NCOMP - IF (NEQIVP .EQ. 0) GO TO 150 - DO 125 J=1,NEQIVP - KSJ=KS+J - 125 YHP(KSJ)=STOWA(KSJ) - 150 KS=KS+NEQIVP - X=STOWA(KS+1) - INFO(1)=0 - KO=KOP-ISTKOP - KOP=ISTKOP - IF (NDISK .EQ. 0 .OR. KO .EQ. 0) RETURN - DO 175 K=1,KO - 175 BACKSPACE NTAPE - RETURN - END diff --git a/slatec/suds.f b/slatec/suds.f deleted file mode 100644 index a723776..0000000 --- a/slatec/suds.f +++ /dev/null @@ -1,123 +0,0 @@ -*DECK SUDS - SUBROUTINE SUDS (A, X, B, NEQ, NUK, NRDA, IFLAG, MLSO, WORK, - + IWORK) -C***BEGIN PROLOGUE SUDS -C***SUBSIDIARY -C***PURPOSE Subsidiary to BVSUP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (SUDS-S, DSUDS-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C SUDS solves the underdetermined system of linear equations A Z = B -C where A is NEQ by NUK and NEQ .LE. NUK. In particular, if rank A -C equals IRA, a vector X and a matrix U are determined such that -C X is the UNIQUE solution of smallest length, satisfying A X = B, -C and the columns of U form an orthonormal basis for the null -C space of A, satisfying A U = 0 . Then all solutions Z are -C given by -C Z = X + C(1)*U(1) + ..... + C(NUK-IRA)*U(NUK-IRA) -C where U(J) represents the J-th column of U and the C(J) are -C arbitrary constants. -C If the system of equations are not compatible, only the least -C squares solution of minimal length is computed. -C SUDS is an interfacing routine which calls subroutine LSSUDS -C for the solution. LSSUDS in turn calls subroutine ORTHOR and -C possibly subroutine OHTROL for the decomposition of A by -C orthogonal transformations. In the process, ORTHOR calls upon -C subroutine CSCALE for scaling. -C -C ********************************************************************** -C INPUT -C ********************************************************************** -C -C A -- Contains the matrix of NEQ equations in NUK unknowns and must -C be dimensioned NRDA by NUK. The original A is destroyed. -C X -- Solution array of length at least NUK -C B -- Given constant vector of length NEQ, B is destroyed -C NEQ -- Number of equations, NEQ greater or equal to 1 -C NUK -- Number of columns in the matrix (which is also the number -C of unknowns), NUK not smaller than NEQ -C NRDA -- Row dimension of A, NRDA greater or equal to NEQ -C IFLAG -- Status indicator -C =0 For the first call (and for each new problem defined by -C a new matrix A) when the matrix data is treated as exact -C =-K For the first call (and for each new problem defined by -C a new matrix A) when the matrix data is assumed to be -C accurate to about K digits -C =1 For subsequent calls whenever the matrix A has already -C been decomposed (problems with new vectors B but -C same matrix A can be handled efficiently) -C MLSO -- =0 If only the minimal length solution is wanted -C =1 If the complete solution is wanted, includes the -C linear space defined by the matrix U in the abstract -C WORK(*),IWORK(*) -- Arrays for storage of internal information, -C WORK must be dimensioned at least -C NUK + 3*NEQ + MLSO*NUK*(NUK-rank A) -C where it is possible for 0 .LE. rank A .LE. NEQ -C IWORK must be dimensioned at least 3 + NEQ -C IWORK(2) -- Scaling indicator -C =-1 If the matrix is to be pre-scaled by -C columns when appropriate -C If the scaling indicator is not equal to -1 -C no scaling will be attempted -C For most problems scaling will probably not be necessary -C -C ********************************************************************** -C OUTPUT -C ********************************************************************** -C -C IFLAG -- Status indicator -C =1 If solution was obtained -C =2 If improper input is detected -C =3 If rank of matrix is less than NEQ -C To continue simply reset IFLAG=1 and call SUDS again -C =4 If the system of equations appears to be inconsistent. -C However, the least squares solution of minimal length -C was obtained. -C X -- Minimal length least squares solution of A X = B -C A -- Contains the strictly upper triangular part of the reduced -C matrix and transformation information -C WORK(*),IWORK(*) -- Contains information needed on subsequent -C calls (IFLAG=1 case on input) which must not -C be altered. -C The matrix U described in the abstract is -C stored in the NUK*(NUK-rank A) elements of -C the work array beginning at WORK(1+NUK+3*NEQ). -C However U is not defined when MLSO=0 or -C IFLAG=4. -C IWORK(1) Contains the numerically determined -C rank of the matrix A -C -C ********************************************************************** -C -C***SEE ALSO BVSUP -C***REFERENCES H. A. Watts, Solving linear least squares problems -C using SODS/SUDS/CODS, Sandia Report SAND77-0683, -C Sandia Laboratories, 1977. -C***ROUTINES CALLED LSSUDS -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910408 Updated the AUTHOR and REFERENCES sections. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SUDS - DIMENSION A(NRDA,*),X(*),B(*),WORK(*),IWORK(*) -C -C***FIRST EXECUTABLE STATEMENT SUDS - IS=2 - IP=3 - IL=IP+NEQ - KV=1+NEQ - KT=KV+NEQ - KS=KT+NEQ - KU=KS+NUK -C - CALL LSSUDS(A,X,B,NEQ,NUK,NRDA,WORK(KU),NUK,IFLAG,MLSO,IWORK(1), - 1 IWORK(IS),A,WORK(1),IWORK(IP),B,WORK(KV),WORK(KT), - 2 IWORK(IL),WORK(KS)) -C - RETURN - END diff --git a/slatec/svco.f b/slatec/svco.f deleted file mode 100644 index 2086981..0000000 --- a/slatec/svco.f +++ /dev/null @@ -1,45 +0,0 @@ -*DECK SVCO - SUBROUTINE SVCO (RSAV, ISAV) -C***BEGIN PROLOGUE SVCO -C***SUBSIDIARY -C***PURPOSE Subsidiary to DEBDF -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (SVCO-S, DSVCO-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C SVCO transfers data from a common block to arrays within the -C integrator package DEBDF. -C -C***SEE ALSO DEBDF -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS DEBDF1 -C***REVISION HISTORY (YYMMDD) -C 800901 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE SVCO -C -C -C----------------------------------------------------------------------- -C THIS ROUTINE STORES IN RSAV AND ISAV THE CONTENTS OF COMMON BLOCK -C DEBDF1 , WHICH IS USED INTERNALLY IN THE DEBDF PACKAGE. -C -C RSAV = REAL ARRAY OF LENGTH 218 OR MORE. -C ISAV = INTEGER ARRAY OF LENGTH 33 OR MORE. -C----------------------------------------------------------------------- - INTEGER ISAV, I, ILS, LENILS, LENRLS - REAL RSAV, RLS - DIMENSION RSAV(*), ISAV(*) - COMMON /DEBDF1/ RLS(218), ILS(33) - SAVE LENRLS, LENILS - DATA LENRLS/218/, LENILS/33/ -C -C***FIRST EXECUTABLE STATEMENT SVCO - DO 10 I = 1,LENRLS - 10 RSAV(I) = RLS(I) - DO 20 I = 1,LENILS - 20 ISAV(I) = ILS(I) - RETURN -C----------------------- END OF SUBROUTINE SVCO ----------------------- - END diff --git a/slatec/svd.f b/slatec/svd.f deleted file mode 100644 index d027aa1..0000000 --- a/slatec/svd.f +++ /dev/null @@ -1,381 +0,0 @@ -*DECK SVD - SUBROUTINE SVD (NM, M, N, A, W, MATU, U, MATV, V, IERR, RV1) -C***BEGIN PROLOGUE SVD -C***SUBSIDIARY -C***PURPOSE Perform the singular value decomposition of a rectangular -C matrix. -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (SVD-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure SVD, -C NUM. MATH. 14, 403-420(1970) by Golub and Reinsch. -C HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 134-151(1971). -C -C This subroutine determines the singular value decomposition -C T -C A=USV of a REAL M by N rectangular matrix. Householder -C bidiagonalization and a variant of the QR algorithm are used. -C -C On Input -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, A, U and V, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C Note that NM must be at least as large as the maximum -C of M and N. -C -C M is the number of rows of A and U. -C -C N is the number of columns of A and U and the order of V. -C -C A contains the rectangular input matrix to be decomposed. A is -C a two-dimensional REAL array, dimensioned A(NM,N). -C -C MATU should be set to .TRUE. if the U matrix in the -C decomposition is desired, and to .FALSE. otherwise. -C MATU is a LOGICAL variable. -C -C MATV should be set to .TRUE. if the V matrix in the -C decomposition is desired, and to .FALSE. otherwise. -C MATV is a LOGICAL variable. -C -C On Output -C -C A is unaltered (unless overwritten by U or V). -C -C W contains the N (non-negative) singular values of A (the -C diagonal elements of S). They are unordered. If an -C error exit is made, the singular values should be correct -C for indices IERR+1, IERR+2, ..., N. W is a one-dimensional -C REAL array, dimensioned W(N). -C -C U contains the matrix U (orthogonal column vectors) of the -C decomposition if MATU has been set to .TRUE. Otherwise, -C U is used as a temporary array. U may coincide with A. -C If an error exit is made, the columns of U corresponding -C to indices of correct singular values should be correct. -C U is a two-dimensional REAL array, dimensioned U(NM,N). -C -C V contains the matrix V (orthogonal) of the decomposition if -C MATV has been set to .TRUE. Otherwise, V is not referenced. -C V may also coincide with A if U does not. If an error -C exit is made, the columns of V corresponding to indices of -C correct singular values should be correct. V is a two- -C dimensional REAL array, dimensioned V(NM,N). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C K if the K-th singular value has not been -C determined after 30 iterations. -C -C RV1 is a one-dimensional REAL array used for temporary storage, -C dimensioned RV1(N). -C -C CALLS PYTHAG(A,B) for sqrt(A**2 + B**2). -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***SEE ALSO EISDOC -C***ROUTINES CALLED PYTHAG -C***REVISION HISTORY (YYMMDD) -C 811101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE SVD -C - INTEGER I,J,K,L,M,N,II,I1,KK,K1,LL,L1,MN,NM,ITS,IERR - REAL A(NM,*),W(*),U(NM,*),V(NM,*),RV1(*) - REAL C,F,G,H,S,X,Y,Z,SCALE,S1 - REAL PYTHAG - LOGICAL MATU,MATV -C -C***FIRST EXECUTABLE STATEMENT SVD - IERR = 0 -C - DO 100 I = 1, M -C - DO 100 J = 1, N - U(I,J) = A(I,J) - 100 CONTINUE -C .......... HOUSEHOLDER REDUCTION TO BIDIAGONAL FORM .......... - G = 0.0E0 - SCALE = 0.0E0 - S1 = 0.0E0 -C - DO 300 I = 1, N - L = I + 1 - RV1(I) = SCALE * G - G = 0.0E0 - S = 0.0E0 - SCALE = 0.0E0 - IF (I .GT. M) GO TO 210 -C - DO 120 K = I, M - 120 SCALE = SCALE + ABS(U(K,I)) -C - IF (SCALE .EQ. 0.0E0) GO TO 210 -C - DO 130 K = I, M - U(K,I) = U(K,I) / SCALE - S = S + U(K,I)**2 - 130 CONTINUE -C - F = U(I,I) - G = -SIGN(SQRT(S),F) - H = F * G - S - U(I,I) = F - G - IF (I .EQ. N) GO TO 190 -C - DO 150 J = L, N - S = 0.0E0 -C - DO 140 K = I, M - 140 S = S + U(K,I) * U(K,J) -C - F = S / H -C - DO 150 K = I, M - U(K,J) = U(K,J) + F * U(K,I) - 150 CONTINUE -C - 190 DO 200 K = I, M - 200 U(K,I) = SCALE * U(K,I) -C - 210 W(I) = SCALE * G - G = 0.0E0 - S = 0.0E0 - SCALE = 0.0E0 - IF (I .GT. M .OR. I .EQ. N) GO TO 290 -C - DO 220 K = L, N - 220 SCALE = SCALE + ABS(U(I,K)) -C - IF (SCALE .EQ. 0.0E0) GO TO 290 -C - DO 230 K = L, N - U(I,K) = U(I,K) / SCALE - S = S + U(I,K)**2 - 230 CONTINUE -C - F = U(I,L) - G = -SIGN(SQRT(S),F) - H = F * G - S - U(I,L) = F - G -C - DO 240 K = L, N - 240 RV1(K) = U(I,K) / H -C - IF (I .EQ. M) GO TO 270 -C - DO 260 J = L, M - S = 0.0E0 -C - DO 250 K = L, N - 250 S = S + U(J,K) * U(I,K) -C - DO 260 K = L, N - U(J,K) = U(J,K) + S * RV1(K) - 260 CONTINUE -C - 270 DO 280 K = L, N - 280 U(I,K) = SCALE * U(I,K) -C - 290 S1 = MAX(S1,ABS(W(I))+ABS(RV1(I))) - 300 CONTINUE -C .......... ACCUMULATION OF RIGHT-HAND TRANSFORMATIONS .......... - IF (.NOT. MATV) GO TO 410 -C .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... - DO 400 II = 1, N - I = N + 1 - II - IF (I .EQ. N) GO TO 390 - IF (G .EQ. 0.0E0) GO TO 360 -C - DO 320 J = L, N -C .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW .......... - 320 V(J,I) = (U(I,J) / U(I,L)) / G -C - DO 350 J = L, N - S = 0.0E0 -C - DO 340 K = L, N - 340 S = S + U(I,K) * V(K,J) -C - DO 350 K = L, N - V(K,J) = V(K,J) + S * V(K,I) - 350 CONTINUE -C - 360 DO 380 J = L, N - V(I,J) = 0.0E0 - V(J,I) = 0.0E0 - 380 CONTINUE -C - 390 V(I,I) = 1.0E0 - G = RV1(I) - L = I - 400 CONTINUE -C .......... ACCUMULATION OF LEFT-HAND TRANSFORMATIONS .......... - 410 IF (.NOT. MATU) GO TO 510 -C ..........FOR I=MIN(M,N) STEP -1 UNTIL 1 DO -- .......... - MN = N - IF (M .LT. N) MN = M -C - DO 500 II = 1, MN - I = MN + 1 - II - L = I + 1 - G = W(I) - IF (I .EQ. N) GO TO 430 -C - DO 420 J = L, N - 420 U(I,J) = 0.0E0 -C - 430 IF (G .EQ. 0.0E0) GO TO 475 - IF (I .EQ. MN) GO TO 460 -C - DO 450 J = L, N - S = 0.0E0 -C - DO 440 K = L, M - 440 S = S + U(K,I) * U(K,J) -C .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW .......... - F = (S / U(I,I)) / G -C - DO 450 K = I, M - U(K,J) = U(K,J) + F * U(K,I) - 450 CONTINUE -C - 460 DO 470 J = I, M - 470 U(J,I) = U(J,I) / G -C - GO TO 490 -C - 475 DO 480 J = I, M - 480 U(J,I) = 0.0E0 -C - 490 U(I,I) = U(I,I) + 1.0E0 - 500 CONTINUE -C .......... DIAGONALIZATION OF THE BIDIAGONAL FORM .......... - 510 CONTINUE -C .......... FOR K=N STEP -1 UNTIL 1 DO -- .......... - DO 700 KK = 1, N - K1 = N - KK - K = K1 + 1 - ITS = 0 -C .......... TEST FOR SPLITTING. -C FOR L=K STEP -1 UNTIL 1 DO -- .......... - 520 DO 530 LL = 1, K - L1 = K - LL - L = L1 + 1 - IF (S1 + ABS(RV1(L)) .EQ. S1) GO TO 565 -C .......... RV1(1) IS ALWAYS ZERO, SO THERE IS NO EXIT -C THROUGH THE BOTTOM OF THE LOOP .......... - IF (S1 + ABS(W(L1)) .EQ. S1) GO TO 540 - 530 CONTINUE -C .......... CANCELLATION OF RV1(L) IF L GREATER THAN 1 .......... - 540 C = 0.0E0 - S = 1.0E0 -C - DO 560 I = L, K - F = S * RV1(I) - RV1(I) = C * RV1(I) - IF (S1 + ABS(F) .EQ. S1) GO TO 565 - G = W(I) - H = PYTHAG(F,G) - W(I) = H - C = G / H - S = -F / H - IF (.NOT. MATU) GO TO 560 -C - DO 550 J = 1, M - Y = U(J,L1) - Z = U(J,I) - U(J,L1) = Y * C + Z * S - U(J,I) = -Y * S + Z * C - 550 CONTINUE -C - 560 CONTINUE -C .......... TEST FOR CONVERGENCE .......... - 565 Z = W(K) - IF (L .EQ. K) GO TO 650 -C .......... SHIFT FROM BOTTOM 2 BY 2 MINOR .......... - IF (ITS .EQ. 30) GO TO 1000 - ITS = ITS + 1 - X = W(L) - Y = W(K1) - G = RV1(K1) - H = RV1(K) - F = 0.5E0 * (((G + Z) / H) * ((G - Z) / Y) + Y / H - H / Y) - G = PYTHAG(F,1.0E0) - F = X - (Z / X) * Z + (H / X) * (Y / (F + SIGN(G,F)) - H) -C .......... NEXT QR TRANSFORMATION .......... - C = 1.0E0 - S = 1.0E0 -C - DO 600 I1 = L, K1 - I = I1 + 1 - G = RV1(I) - Y = W(I) - H = S * G - G = C * G - Z = PYTHAG(F,H) - RV1(I1) = Z - C = F / Z - S = H / Z - F = X * C + G * S - G = -X * S + G * C - H = Y * S - Y = Y * C - IF (.NOT. MATV) GO TO 575 -C - DO 570 J = 1, N - X = V(J,I1) - Z = V(J,I) - V(J,I1) = X * C + Z * S - V(J,I) = -X * S + Z * C - 570 CONTINUE -C - 575 Z = PYTHAG(F,H) - W(I1) = Z -C .......... ROTATION CAN BE ARBITRARY IF Z IS ZERO .......... - IF (Z .EQ. 0.0E0) GO TO 580 - C = F / Z - S = H / Z - 580 F = C * G + S * Y - X = -S * G + C * Y - IF (.NOT. MATU) GO TO 600 -C - DO 590 J = 1, M - Y = U(J,I1) - Z = U(J,I) - U(J,I1) = Y * C + Z * S - U(J,I) = -Y * S + Z * C - 590 CONTINUE -C - 600 CONTINUE -C - RV1(L) = 0.0E0 - RV1(K) = F - W(K) = X - GO TO 520 -C .......... CONVERGENCE .......... - 650 IF (Z .GE. 0.0E0) GO TO 700 -C .......... W(K) IS MADE NON-NEGATIVE .......... - W(K) = -Z - IF (.NOT. MATV) GO TO 700 -C - DO 690 J = 1, N - 690 V(J,K) = -V(J,K) -C - 700 CONTINUE -C - GO TO 1001 -C .......... SET ERROR -- NO CONVERGENCE TO A -C SINGULAR VALUE AFTER 30 ITERATIONS .......... - 1000 IERR = K - 1001 RETURN - END diff --git a/slatec/svecs.f b/slatec/svecs.f deleted file mode 100644 index c67c590..0000000 --- a/slatec/svecs.f +++ /dev/null @@ -1,53 +0,0 @@ -*DECK SVECS - SUBROUTINE SVECS (NCOMP, LNFC, YHP, WORK, IWORK, INHOMO, IFLAG) -C***BEGIN PROLOGUE SVECS -C***SUBSIDIARY -C***PURPOSE Subsidiary to BVSUP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (SVECS-S, DVECS-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C This subroutine is used for the special structure of complex valued -C problems. MGSBV is called upon to obtain LNFC vectors from an -C original set of 2*LNFC independent vectors so that the resulting -C LNFC vectors together with their imaginary product or mate vectors -C form an independent set. -C -C***SEE ALSO BVSUP -C***ROUTINES CALLED MGSBV -C***COMMON BLOCKS ML18JR -C***REVISION HISTORY (YYMMDD) -C 750601 DATE WRITTEN -C 890921 Realigned order of variables in certain COMMON blocks. -C (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE SVECS -C - DIMENSION YHP(NCOMP,*),WORK(*),IWORK(*) - COMMON /ML18JR/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ, - 1 INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,LNFCC, - 2 ICOCO -C***FIRST EXECUTABLE STATEMENT SVECS - IF (LNFC .EQ. 1) GO TO 5 - NIV=LNFC - LNFC=2*LNFC - LNFCC=2*LNFCC - KP=LNFC+2+LNFCC - IDP=INDPVT - INDPVT=0 - CALL MGSBV(NCOMP,LNFC,YHP,NCOMP,NIV,IFLAG,WORK(1),WORK(KP), - 1 IWORK(1),INHOMO,YHP(1,LNFC+1),WORK(LNFC+2),DUM) - LNFC=LNFC/2 - LNFCC=LNFCC/2 - INDPVT=IDP - IF (IFLAG .EQ. 0 .AND. NIV .EQ. LNFC) GO TO 5 - IFLAG=99 - RETURN - 5 DO 6 K=1,NCOMP - 6 YHP(K,LNFC+1)=YHP(K,LNFCC+1) - IFLAG=1 - RETURN - END diff --git a/slatec/svout.f b/slatec/svout.f deleted file mode 100644 index baa6ffb..0000000 --- a/slatec/svout.f +++ /dev/null @@ -1,137 +0,0 @@ -*DECK SVOUT - SUBROUTINE SVOUT (N, SX, IFMT, IDIGIT) -C***BEGIN PROLOGUE SVOUT -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (SVOUT-S, DVOUT-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C SINGLE PRECISION VECTOR OUTPUT ROUTINE. -C -C INPUT.. -C -C N,SX(*) PRINT THE SINGLE PRECISION ARRAY SX(I),I=1,...,N, ON -C OUTPUT UNIT LOUT. THE HEADING IN THE FORTRAN FORMAT -C STATEMENT IFMT(*), DESCRIBED BELOW, IS PRINTED AS A FIRST -C STEP. THE COMPONENTS SX(I) ARE INDEXED, ON OUTPUT, -C IN A PLEASANT FORMAT. -C IFMT(*) A FORTRAN FORMAT STATEMENT. THIS IS PRINTED ON OUTPUT -C UNIT LOUT WITH THE VARIABLE FORMAT FORTRAN STATEMENT -C WRITE(LOUT,IFMT) -C IDIGIT PRINT AT LEAST ABS(IDIGIT) DECIMAL DIGITS PER NUMBER. -C THE SUBPROGRAM WILL CHOOSE THAT INTEGER 4,6,10 OR 14 -C WHICH WILL PRINT AT LEAST ABS(IDIGIT) NUMBER OF -C PLACES. IF IDIGIT.LT.0, 72 PRINTING COLUMNS ARE UTILIZED -C TO WRITE EACH LINE OF OUTPUT OF THE ARRAY SX(*). (THIS -C CAN BE USED ON MOST TIME-SHARING TERMINALS). IF -C IDIGIT.GE.0, 133 PRINTING COLUMNS ARE UTILIZED. (THIS CAN -C BE USED ON MOST LINE PRINTERS). -C -C EXAMPLE.. -C -C PRINT AN ARRAY CALLED (COSTS OF PURCHASES) OF LENGTH 100 SHOWING -C 6 DECIMAL DIGITS PER NUMBER. THE USER IS RUNNING ON A TIME-SHARING -C SYSTEM WITH A 72 COLUMN OUTPUT DEVICE. -C -C DIMENSION COSTS(100) -C N = 100 -C IDIGIT = -6 -C CALL SVOUT(N,COSTS,'(''1COSTS OF PURCHASES'')',IDIGIT) -C -C***SEE ALSO SPLP -C***ROUTINES CALLED I1MACH -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891107 Added comma after 1P edit descriptor in FORMAT -C statements. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE SVOUT - DIMENSION SX(*) - CHARACTER IFMT*(*) -C -C GET THE UNIT NUMBER WHERE OUTPUT WILL BE WRITTEN. -C***FIRST EXECUTABLE STATEMENT SVOUT - J=2 - LOUT=I1MACH(J) - WRITE(LOUT,IFMT) - IF(N.LE.0) RETURN - NDIGIT = IDIGIT - IF(IDIGIT.EQ.0) NDIGIT = 4 - IF(IDIGIT.GE.0) GO TO 80 -C - NDIGIT = -IDIGIT - IF(NDIGIT.GT.4) GO TO 20 -C - DO 10 K1=1,N,5 - K2 = MIN(N,K1+4) - WRITE(LOUT,1000) K1,K2,(SX(I),I=K1,K2) - 10 CONTINUE - RETURN -C - 20 CONTINUE - IF(NDIGIT.GT.6) GO TO 40 -C - DO 30 K1=1,N,4 - K2 = MIN(N,K1+3) - WRITE(LOUT,1001) K1,K2,(SX(I),I=K1,K2) - 30 CONTINUE - RETURN -C - 40 CONTINUE - IF(NDIGIT.GT.10) GO TO 60 -C - DO 50 K1=1,N,3 - K2=MIN(N,K1+2) - WRITE(LOUT,1002) K1,K2,(SX(I),I=K1,K2) - 50 CONTINUE - RETURN -C - 60 CONTINUE - DO 70 K1=1,N,2 - K2 = MIN(N,K1+1) - WRITE(LOUT,1003) K1,K2,(SX(I),I=K1,K2) - 70 CONTINUE - RETURN -C - 80 CONTINUE - IF(NDIGIT.GT.4) GO TO 100 -C - DO 90 K1=1,N,10 - K2 = MIN(N,K1+9) - WRITE(LOUT,1000) K1,K2,(SX(I),I=K1,K2) - 90 CONTINUE - RETURN -C - 100 CONTINUE - IF(NDIGIT.GT.6) GO TO 120 -C - DO 110 K1=1,N,8 - K2 = MIN(N,K1+7) - WRITE(LOUT,1001) K1,K2,(SX(I),I=K1,K2) - 110 CONTINUE - RETURN -C - 120 CONTINUE - IF(NDIGIT.GT.10) GO TO 140 -C - DO 130 K1=1,N,6 - K2 = MIN(N,K1+5) - WRITE(LOUT,1002) K1,K2,(SX(I),I=K1,K2) - 130 CONTINUE - RETURN -C - 140 CONTINUE - DO 150 K1=1,N,5 - K2 = MIN(N,K1+4) - WRITE(LOUT,1003) K1,K2,(SX(I),I=K1,K2) - 150 CONTINUE - RETURN - 1000 FORMAT(1X,I4,' - ',I4,1P,10E12.3) - 1001 FORMAT(1X,I4,' - ',I4,1X,1P,8E14.5) - 1002 FORMAT(1X,I4,' - ',I4,1X,1P,6E18.9) - 1003 FORMAT(1X,I4,' - ',I4,1X,1P,5E24.13) - END diff --git a/slatec/swritp.f b/slatec/swritp.f deleted file mode 100644 index 2ce82ce..0000000 --- a/slatec/swritp.f +++ /dev/null @@ -1,44 +0,0 @@ -*DECK SWRITP - SUBROUTINE SWRITP (IPAGE, LIST, RLIST, LPAGE, IREC) -C***BEGIN PROLOGUE SWRITP -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (SWRITP-S, DWRITP-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C WRITE RECORD NUMBER IRECN, OF LENGTH LPG, FROM STORAGE -C ARRAY LIST(*) ONTO UNIT NUMBER IPAGEF. -C WRITE RECORD NUMBER IRECN+1, OF LENGTH LPG, ONTO UNIT -C NUMBER IPAGEF FROM THE STORAGE ARRAY RLIST(*). -C -C TO CHANGE THIS PROGRAM UNIT TO DOUBLE PRECISION CHANGE -C /REAL (12 BLANKS)/ TO /DOUBLE PRECISION/. -C -C***SEE ALSO SPLP -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 890605 Corrected references to XERRWV. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C***END PROLOGUE SWRITP - INTEGER LIST(*) - REAL RLIST(*) - CHARACTER*8 XERN1, XERN2 -C***FIRST EXECUTABLE STATEMENT SWRITP - IPAGEF=IPAGE - LPG =LPAGE - IRECN =IREC - WRITE(IPAGEF,REC=IRECN,ERR=100)(LIST(I),I=1,LPG) - WRITE(IPAGEF,REC=IRECN+1,ERR=100)(RLIST(I),I=1,LPG) - RETURN -C - 100 WRITE (XERN1, '(I8)') LPG - WRITE (XERN2, '(I8)') IRECN - CALL XERMSG ('SLATEC', 'SWRITP', 'IN SPLP, LGP = ' // XERN1 // - * ' IRECN = ' // XERN2, 100, 1) - RETURN - END diff --git a/slatec/sxlcal.f b/slatec/sxlcal.f deleted file mode 100644 index 47a70f4..0000000 --- a/slatec/sxlcal.f +++ /dev/null @@ -1,183 +0,0 @@ -*DECK SXLCAL - SUBROUTINE SXLCAL (N, LGMR, X, XL, ZL, HES, MAXLP1, Q, V, R0NRM, - + WK, SZ, JSCAL, JPRE, MSOLVE, NMSL, RPAR, IPAR, NELT, IA, JA, A, - + ISYM) -C***BEGIN PROLOGUE SXLCAL -C***SUBSIDIARY -C***PURPOSE Internal routine for SGMRES. -C***LIBRARY SLATEC (SLAP) -C***CATEGORY D2A4, D2B4 -C***TYPE SINGLE PRECISION (SXLCAL-S, DXLCAL-D) -C***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, -C NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE -C***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov -C Hindmarsh, Alan, (LLNL), alanh@llnl.gov -C Seager, Mark K., (LLNL), seager@llnl.gov -C Lawrence Livermore National Laboratory -C PO Box 808, L-60 -C Livermore, CA 94550 (510) 423-3141 -C***DESCRIPTION -C This routine computes the solution XL, the current SGMRES -C iterate, given the V(I)'s and the QR factorization of the -C Hessenberg matrix HES. This routine is only called when -C ITOL=11. -C -C *Usage: -C INTEGER N, LGMR, MAXLP1, JSCAL, JPRE, NMSL, IPAR(USER DEFINED) -C INTEGER NELT, IA(NELT), JA(NELT), ISYM -C REAL X(N), XL(N), ZL(N), HES(MAXLP1,MAXL), Q(2*MAXL), -C $ V(N,MAXLP1), R0NRM, WK(N), SZ(N), RPAR(USER DEFINED), -C $ A(NELT) -C EXTERNAL MSOLVE -C -C CALL SXLCAL(N, LGMR, X, XL, ZL, HES, MAXLP1, Q, V, R0NRM, -C $ WK, SZ, JSCAL, JPRE, MSOLVE, NMSL, RPAR, IPAR, -C $ NELT, IA, JA, A, ISYM) -C -C *Arguments: -C N :IN Integer -C The order of the matrix A, and the lengths -C of the vectors SR, SZ, R0 and Z. -C LGMR :IN Integer -C The number of iterations performed and -C the current order of the upper Hessenberg -C matrix HES. -C X :IN Real X(N) -C The current approximate solution as of the last restart. -C XL :OUT Real XL(N) -C An array of length N used to hold the approximate -C solution X(L). -C Warning: XL and ZL are the same array in the calling routine. -C ZL :IN Real ZL(N) -C An array of length N used to hold the approximate -C solution Z(L). -C HES :IN Real HES(MAXLP1,MAXL) -C 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) and V(*,k). -C MAXLP1 :IN Integer -C MAXLP1 = MAXL + 1, used for dynamic dimensioning of HES. -C MAXL is the maximum allowable order of the matrix HES. -C Q :IN Real Q(2*MAXL) -C A 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 SHEQR. -C V :IN Real V(N,MAXLP1) -C The N by(LGMR+1) array containing the LGMR -C orthogonal vectors V(*,1) to V(*,LGMR). -C R0NRM :IN Real -C The scaled norm of the initial residual for the -C current call to SPIGMR. -C WK :IN Real WK(N) -C A real work array of length N. -C SZ :IN Real SZ(N) -C A vector of length N containing the non-zero -C elements of the diagonal scaling matrix for Z. -C JSCAL :IN Integer -C A flag indicating whether arrays SR and SZ are used. -C JSCAL=0 means SR and SZ are not used and the -C algorithm will perform as if all -C SR(i) = 1 and SZ(i) = 1. -C JSCAL=1 means only SZ is used, and the algorithm -C performs as if all SR(i) = 1. -C JSCAL=2 means only SR is used, and the algorithm -C performs as if all SZ(i) = 1. -C JSCAL=3 means both SR and SZ are used. -C JPRE :IN Integer -C The preconditioner type flag. -C MSOLVE :EXT External. -C Name of the routine which solves a linear system Mz = r for -C z given r with the preconditioning matrix M (M is supplied via -C RPAR and IPAR arrays. The name of the MSOLVE routine must -C be declared external in the calling program. The calling -C sequence to MSOLVE is: -C CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RPAR, IPAR) -C Where N is the number of unknowns, R is the right-hand side -C vector and Z is the solution upon return. NELT, IA, JA, A and -C ISYM are defined as below. RPAR is a real array that can be -C used to pass necessary preconditioning information and/or -C workspace to MSOLVE. IPAR is an integer work array for the -C same purpose as RPAR. -C NMSL :IN Integer -C The number of calls to MSOLVE. -C RPAR :IN Real RPAR(USER DEFINED) -C Real workspace passed directly to the MSOLVE routine. -C IPAR :IN Integer IPAR(USER DEFINED) -C Integer workspace passed directly to the MSOLVE routine. -C NELT :IN Integer -C The length of arrays IA, JA and A. -C IA :IN Integer IA(NELT) -C An integer array of length NELT containing matrix data. -C It is passed directly to the MATVEC and MSOLVE routines. -C JA :IN Integer JA(NELT) -C An integer array of length NELT containing matrix data. -C It is passed directly to the MATVEC and MSOLVE routines. -C A :IN Real A(NELT) -C A real array of length NELT containing matrix data. -C It is passed directly to the MATVEC and MSOLVE routines. -C ISYM :IN Integer -C A flag to indicate symmetric matrix storage. -C If ISYM=0, all non-zero entries of the matrix are -C stored. If ISYM=1, the matrix is symmetric and -C only the upper or lower triangular part is stored. -C -C***SEE ALSO SGMRES -C***ROUTINES CALLED SAXPY, SCOPY, SHELS -C***REVISION HISTORY (YYMMDD) -C 871001 DATE WRITTEN -C 881213 Previous REVISION DATE -C 890915 Made changes requested at July 1989 CML Meeting. (MKS) -C 890922 Numerous changes to prologue to make closer to SLATEC -C standard. (FNF) -C 890929 Numerous changes to reduce SP/DP differences. (FNF) -C 910411 Prologue converted to Version 4.0 format. (BAB) -C 910502 Removed MSOLVE from ROUTINES CALLED list. (FNF) -C 910506 Made subsidiary to SGMRES. (FNF) -C 920511 Added complete declaration section. (WRB) -C***END PROLOGUE SXLCAL -C The following is for optimized compilation on LLNL/LTSS Crays. -CLLL. OPTIMIZE -C .. Scalar Arguments .. - REAL R0NRM - INTEGER ISYM, JPRE, JSCAL, LGMR, MAXLP1, N, NELT, NMSL -C .. Array Arguments .. - REAL A(NELT), HES(MAXLP1,*), Q(*), RPAR(*), SZ(*), V(N,*), WK(N), - + X(N), XL(N), ZL(N) - INTEGER IA(NELT), IPAR(*), JA(NELT) -C .. Subroutine Arguments .. - EXTERNAL MSOLVE -C .. Local Scalars .. - INTEGER I, K, LL, LLP1 -C .. External Subroutines .. - EXTERNAL SAXPY, SCOPY, SHELS -C***FIRST EXECUTABLE STATEMENT SXLCAL - LL = LGMR - LLP1 = LL + 1 - DO 10 K = 1,LLP1 - WK(K) = 0 - 10 CONTINUE - WK(1) = R0NRM - CALL SHELS(HES, MAXLP1, LL, Q, WK) - DO 20 K = 1,N - ZL(K) = 0 - 20 CONTINUE - DO 30 I = 1,LL - CALL SAXPY(N, WK(I), V(1,I), 1, ZL, 1) - 30 CONTINUE - IF ((JSCAL .EQ. 1) .OR.(JSCAL .EQ. 3)) THEN - DO 40 K = 1,N - ZL(K) = ZL(K)/SZ(K) - 40 CONTINUE - ENDIF - IF (JPRE .GT. 0) THEN - CALL SCOPY(N, ZL, 1, WK, 1) - CALL MSOLVE(N, WK, ZL, NELT, IA, JA, A, ISYM, RPAR, IPAR) - NMSL = NMSL + 1 - ENDIF -C calculate XL from X and ZL. - DO 50 K = 1,N - XL(K) = X(K) + ZL(K) - 50 CONTINUE - RETURN -C------------- LAST LINE OF SXLCAL FOLLOWS ---------------------------- - END diff --git a/slatec/tevlc.f b/slatec/tevlc.f deleted file mode 100644 index 526e15b..0000000 --- a/slatec/tevlc.f +++ /dev/null @@ -1,177 +0,0 @@ -*DECK TEVLC - SUBROUTINE TEVLC (N, D, E2, IERR) -C***BEGIN PROLOGUE TEVLC -C***SUBSIDIARY -C***PURPOSE Subsidiary to CBLKTR -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (TEVLC-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This subroutine finds the eigenvalues of a symmetric tridiagonal -C matrix by the rational QL method. -C -C On Input- -C -C N is the order of the matrix, -C -C D contains the diagonal elements of the input matrix, -C -C E2 contains the subdiagonal elements of the input matrix -C in its last N-1 positions. E2(1) is arbitrary. -C -C On Output- -C -C D contains the eigenvalues in ascending order. If an -C error exit is made, the eigenvalues are correct and -C ordered for indices 1,2,...IERR-1, but may not be -C the smallest eigenvalues, -C -C E2 has been destroyed, -C -C IERR is set to -C ZERO for normal return, -C J if the J-th eigenvalue has not been -C determined after 30 iterations. -C -C***SEE ALSO CBLKTR -C***REFERENCES C. H. Reinsch, Eigenvalues of a real, symmetric, tri- -C diagonal matrix, Algorithm 464, Communications of the -C ACM 16, 11 (November 1973), pp. 689. -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS CCBLK -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 920528 DESCRIPTION revised and REFERENCES section added. (WRB) -C***END PROLOGUE TEVLC -C - INTEGER I ,J ,L ,M , - 1 N ,II ,L1 ,MML , - 2 IERR - REAL D(*) ,E2(*) - REAL B ,C ,F ,G , - 1 H ,P ,R ,S , - 2 MACHEP -C - COMMON /CCBLK/ NPP ,K ,MACHEP ,CNV , - 1 NM ,NCMPLX ,IK -C***FIRST EXECUTABLE STATEMENT TEVLC - IERR = 0 - IF (N .EQ. 1) GO TO 115 -C - DO 101 I=2,N - E2(I-1) = E2(I)*E2(I) - 101 CONTINUE -C - F = 0.0 - B = 0.0 - E2(N) = 0.0 -C - DO 112 L=1,N - J = 0 - H = MACHEP*(ABS(D(L))+SQRT(E2(L))) - IF (B .GT. H) GO TO 102 - B = H - C = B*B -C -C ********** LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT ********** -C - 102 DO 103 M=L,N - IF (E2(M) .LE. C) GO TO 104 -C -C ********** E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT -C THROUGH THE BOTTOM OF THE LOOP ********** -C - 103 CONTINUE -C - 104 IF (M .EQ. L) GO TO 108 - 105 IF (J .EQ. 30) GO TO 114 - J = J+1 -C -C ********** FORM SHIFT ********** -C - L1 = L+1 - S = SQRT(E2(L)) - G = D(L) - P = (D(L1)-G)/(2.0*S) - R = SQRT(P*P+1.0) - D(L) = S/(P+SIGN(R,P)) - H = G-D(L) -C - DO 106 I=L1,N - D(I) = D(I)-H - 106 CONTINUE -C - F = F+H -C -C ********** RATIONAL QL TRANSFORMATION ********** -C - G = D(M) - IF (G .EQ. 0.0) G = B - H = G - S = 0.0 - MML = M-L -C -C ********** FOR I=M-1 STEP -1 UNTIL L DO -- ********** -C - DO 107 II=1,MML - I = M-II - P = G*H - R = P+E2(I) - E2(I+1) = S*R - S = E2(I)/R - D(I+1) = H+S*(H+D(I)) - G = D(I)-E2(I)/G - IF (G .EQ. 0.0) G = B - H = G*P/R - 107 CONTINUE -C - E2(L) = S*G - D(L) = H -C -C ********** GUARD AGAINST UNDERFLOWED H ********** -C - IF (H .EQ. 0.0) GO TO 108 - IF (ABS(E2(L)) .LE. ABS(C/H)) GO TO 108 - E2(L) = H*E2(L) - IF (E2(L) .NE. 0.0) GO TO 105 - 108 P = D(L)+F -C -C ********** ORDER EIGENVALUES ********** -C - IF (L .EQ. 1) GO TO 110 -C -C ********** FOR I=L STEP -1 UNTIL 2 DO -- ********** -C - DO 109 II=2,L - I = L+2-II - IF (P .GE. D(I-1)) GO TO 111 - D(I) = D(I-1) - 109 CONTINUE -C - 110 I = 1 - 111 D(I) = P - 112 CONTINUE -C - IF (ABS(D(N)) .GE. ABS(D(1))) GO TO 115 - NHALF = N/2 - DO 113 I=1,NHALF - NTOP = N-I - DHOLD = D(I) - D(I) = D(NTOP+1) - D(NTOP+1) = DHOLD - 113 CONTINUE - GO TO 115 -C -C ********** SET ERROR -- NO CONVERGENCE TO AN -C EIGENVALUE AFTER 30 ITERATIONS ********** -C - 114 IERR = L - 115 RETURN -C -C ********** LAST CARD OF TQLRAT ********** -C - END diff --git a/slatec/tevls.f b/slatec/tevls.f deleted file mode 100644 index 7636625..0000000 --- a/slatec/tevls.f +++ /dev/null @@ -1,177 +0,0 @@ -*DECK TEVLS - SUBROUTINE TEVLS (N, D, E2, IERR) -C***BEGIN PROLOGUE TEVLS -C***SUBSIDIARY -C***PURPOSE Subsidiary to BLKTRI -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (TEVLS-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This subroutine finds the eigenvalues of a symmetric tridiagonal -C matrix by the rational QL method. -C -C On Input- -C -C N is the order of the matrix, -C -C D contains the diagonal elements of the input matrix, -C -C E2 contains the subdiagonal elements of the input matrix -C in its last N-1 positions. E2(1) is arbitrary. -C -C On Output- -C -C D contains the eigenvalues in ascending order. If an -C error exit is made, the eigenvalues are correct and -C ordered for indices 1,2,...IERR-1, but may not be -C the smallest eigenvalues, -C -C E2 has been destroyed, -C -C IERR is set to -C ZERO for normal return, -C J if the J-th eigenvalue has not been -C determined after 30 iterations. -C -C***SEE ALSO BLKTRI -C***REFERENCES C. H. Reinsch, Eigenvalues of a real, symmetric, tri- -C diagonal matrix, Algorithm 464, Communications of the -C ACM 16, 11 (November 1973), pp. 689. -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS CBLKT -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C 920528 DESCRIPTION revised and REFERENCES section added. (WRB) -C***END PROLOGUE TEVLS -C - INTEGER I ,J ,L ,M , - 1 N ,II ,L1 ,MML , - 2 IERR - REAL D(*) ,E2(*) - REAL B ,C ,F ,G , - 1 H ,P ,R ,S , - 2 MACHEP -C - COMMON /CBLKT/ NPP ,K ,MACHEP ,CNV , - 1 NM ,NCMPLX ,IK -C***FIRST EXECUTABLE STATEMENT TEVLS - IERR = 0 - IF (N .EQ. 1) GO TO 115 -C - DO 101 I=2,N - E2(I-1) = E2(I)*E2(I) - 101 CONTINUE -C - F = 0.0 - B = 0.0 - E2(N) = 0.0 -C - DO 112 L=1,N - J = 0 - H = MACHEP*(ABS(D(L))+SQRT(E2(L))) - IF (B .GT. H) GO TO 102 - B = H - C = B*B -C -C ********** LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT ********** -C - 102 DO 103 M=L,N - IF (E2(M) .LE. C) GO TO 104 -C -C ********** E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT -C THROUGH THE BOTTOM OF THE LOOP ********** -C - 103 CONTINUE -C - 104 IF (M .EQ. L) GO TO 108 - 105 IF (J .EQ. 30) GO TO 114 - J = J+1 -C -C ********** FORM SHIFT ********** -C - L1 = L+1 - S = SQRT(E2(L)) - G = D(L) - P = (D(L1)-G)/(2.0*S) - R = SQRT(P*P+1.0) - D(L) = S/(P+SIGN(R,P)) - H = G-D(L) -C - DO 106 I=L1,N - D(I) = D(I)-H - 106 CONTINUE -C - F = F+H -C -C ********** RATIONAL QL TRANSFORMATION ********** -C - G = D(M) - IF (G .EQ. 0.0) G = B - H = G - S = 0.0 - MML = M-L -C -C ********** FOR I=M-1 STEP -1 UNTIL L DO -- ********** -C - DO 107 II=1,MML - I = M-II - P = G*H - R = P+E2(I) - E2(I+1) = S*R - S = E2(I)/R - D(I+1) = H+S*(H+D(I)) - G = D(I)-E2(I)/G - IF (G .EQ. 0.0) G = B - H = G*P/R - 107 CONTINUE -C - E2(L) = S*G - D(L) = H -C -C ********** GUARD AGAINST UNDERFLOWED H ********** -C - IF (H .EQ. 0.0) GO TO 108 - IF (ABS(E2(L)) .LE. ABS(C/H)) GO TO 108 - E2(L) = H*E2(L) - IF (E2(L) .NE. 0.0) GO TO 105 - 108 P = D(L)+F -C -C ********** ORDER EIGENVALUES ********** -C - IF (L .EQ. 1) GO TO 110 -C -C ********** FOR I=L STEP -1 UNTIL 2 DO -- ********** -C - DO 109 II=2,L - I = L+2-II - IF (P .GE. D(I-1)) GO TO 111 - D(I) = D(I-1) - 109 CONTINUE -C - 110 I = 1 - 111 D(I) = P - 112 CONTINUE -C - IF (ABS(D(N)) .GE. ABS(D(1))) GO TO 115 - NHALF = N/2 - DO 113 I=1,NHALF - NTOP = N-I - DHOLD = D(I) - D(I) = D(NTOP+1) - D(NTOP+1) = DHOLD - 113 CONTINUE - GO TO 115 -C -C ********** SET ERROR -- NO CONVERGENCE TO AN -C EIGENVALUE AFTER 30 ITERATIONS ********** -C - 114 IERR = L - 115 RETURN -C -C ********** LAST CARD OF TQLRAT ********** -C - END diff --git a/slatec/tinvit.f b/slatec/tinvit.f deleted file mode 100644 index f55d8da..0000000 --- a/slatec/tinvit.f +++ /dev/null @@ -1,280 +0,0 @@ -*DECK TINVIT - SUBROUTINE TINVIT (NM, N, D, E, E2, M, W, IND, Z, IERR, RV1, RV2, - + RV3, RV4, RV6) -C***BEGIN PROLOGUE TINVIT -C***PURPOSE Compute the eigenvectors of symmetric tridiagonal matrix -C corresponding to specified eigenvalues, using inverse -C iteration. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C3 -C***TYPE SINGLE PRECISION (TINVIT-S) -C***KEYWORDS EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the inverse iteration tech- -C nique in the ALGOL procedure TRISTURM by Peters and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). -C -C This subroutine finds those eigenvectors of a TRIDIAGONAL -C SYMMETRIC matrix corresponding to specified eigenvalues, -C using inverse iteration. -C -C On Input -C -C NM must be set to the row dimension of the two-dimensional -C array parameter, Z, as declared in the calling program -C dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C D contains the diagonal elements of the symmetric tridiagonal -C matrix. D is a one-dimensional REAL array, dimensioned D(N). -C -C E contains the subdiagonal elements of the symmetric -C tridiagonal matrix in its last N-1 positions. E(1) is -C arbitrary. E is a one-dimensional REAL array, dimensioned -C E(N). -C -C E2 contains the squares of the corresponding elements of E, -C with zeros corresponding to negligible elements of E. -C E(I) is considered negligible if it is not larger than -C the product of the relative machine precision and the sum -C of the magnitudes of D(I) and D(I-1). E2(1) must contain -C 0.0e0 if the eigenvalues are in ascending order, or 2.0e0 -C if the eigenvalues are in descending order. If BISECT, -C TRIDIB, or IMTQLV has been used to find the eigenvalues, -C their output E2 array is exactly what is expected here. -C E2 is a one-dimensional REAL array, dimensioned E2(N). -C -C M is the number of specified eigenvalues for which eigenvectors -C are to be determined. M is an INTEGER variable. -C -C W contains the M eigenvalues in ascending or descending order. -C W is a one-dimensional REAL array, dimensioned W(M). -C -C IND contains in its first M positions the submatrix indices -C associated with the corresponding eigenvalues in W -- -C 1 for eigenvalues belonging to the first submatrix from -C the top, 2 for those belonging to the second submatrix, etc. -C If BISECT or TRIDIB has been used to determine the -C eigenvalues, their output IND array is suitable for input -C to TINVIT. IND is a one-dimensional INTEGER array, -C dimensioned IND(M). -C -C On Output -C -C ** All input arrays are unaltered.** -C -C Z contains the associated set of orthonormal eigenvectors. -C Any vector which fails to converge is set to zero. -C Z is a two-dimensional REAL array, dimensioned Z(NM,M). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C -J if the eigenvector corresponding to the J-th -C eigenvalue fails to converge in 5 iterations. -C -C RV1, RV2 and RV3 are one-dimensional REAL arrays used for -C temporary storage. They are used to store the main diagonal -C and the two adjacent diagonals of the triangular matrix -C produced in the inverse iteration process. RV1, RV2 and -C RV3 are dimensioned RV1(N), RV2(N) and RV3(N). -C -C RV4 and RV6 are one-dimensional REAL arrays used for temporary -C storage. RV4 holds the multipliers of the Gaussian -C elimination process. RV6 holds the approximate eigenvectors -C in this process. RV4 and RV6 are dimensioned RV4(N) and -C RV6(N). -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE TINVIT -C - INTEGER I,J,M,N,P,Q,R,S,II,IP,JJ,NM,ITS,TAG,IERR,GROUP - INTEGER IND(*) - REAL D(*),E(*),E2(*),W(*),Z(NM,*) - REAL RV1(*),RV2(*),RV3(*),RV4(*),RV6(*) - REAL U,V,UK,XU,X0,X1,EPS2,EPS3,EPS4,NORM,ORDER -C -C***FIRST EXECUTABLE STATEMENT TINVIT - IERR = 0 - IF (M .EQ. 0) GO TO 1001 - TAG = 0 - ORDER = 1.0E0 - E2(1) - Q = 0 -C .......... ESTABLISH AND PROCESS NEXT SUBMATRIX .......... - 100 P = Q + 1 -C - DO 120 Q = P, N - IF (Q .EQ. N) GO TO 140 - IF (E2(Q+1) .EQ. 0.0E0) GO TO 140 - 120 CONTINUE -C .......... FIND VECTORS BY INVERSE ITERATION .......... - 140 TAG = TAG + 1 - S = 0 -C - DO 920 R = 1, M - IF (IND(R) .NE. TAG) GO TO 920 - ITS = 1 - X1 = W(R) - IF (S .NE. 0) GO TO 510 -C .......... CHECK FOR ISOLATED ROOT .......... - XU = 1.0E0 - IF (P .NE. Q) GO TO 490 - RV6(P) = 1.0E0 - GO TO 870 - 490 NORM = ABS(D(P)) - IP = P + 1 -C - DO 500 I = IP, Q - 500 NORM = MAX(NORM, ABS(D(I)) + ABS(E(I))) -C .......... EPS2 IS THE CRITERION FOR GROUPING, -C EPS3 REPLACES ZERO PIVOTS AND EQUAL -C ROOTS ARE MODIFIED BY EPS3, -C EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW .......... - EPS2 = 1.0E-3 * NORM - EPS3 = NORM - 502 EPS3 = 0.5E0*EPS3 - IF (NORM + EPS3 .GT. NORM) GO TO 502 - UK = SQRT(REAL(Q-P+5)) - EPS3 = UK * EPS3 - EPS4 = UK * EPS3 - UK = EPS4 / UK - S = P - 505 GROUP = 0 - GO TO 520 -C .......... LOOK FOR CLOSE OR COINCIDENT ROOTS .......... - 510 IF (ABS(X1-X0) .GE. EPS2) GO TO 505 - GROUP = GROUP + 1 - IF (ORDER * (X1 - X0) .LE. 0.0E0) X1 = X0 + ORDER * EPS3 -C .......... ELIMINATION WITH INTERCHANGES AND -C INITIALIZATION OF VECTOR .......... - 520 V = 0.0E0 -C - DO 580 I = P, Q - RV6(I) = UK - IF (I .EQ. P) GO TO 560 - IF (ABS(E(I)) .LT. ABS(U)) GO TO 540 -C .......... WARNING -- A DIVIDE CHECK MAY OCCUR HERE IF -C E2 ARRAY HAS NOT BEEN SPECIFIED CORRECTLY .......... - XU = U / E(I) - RV4(I) = XU - RV1(I-1) = E(I) - RV2(I-1) = D(I) - X1 - RV3(I-1) = 0.0E0 - IF (I .NE. Q) RV3(I-1) = E(I+1) - U = V - XU * RV2(I-1) - V = -XU * RV3(I-1) - GO TO 580 - 540 XU = E(I) / U - RV4(I) = XU - RV1(I-1) = U - RV2(I-1) = V - RV3(I-1) = 0.0E0 - 560 U = D(I) - X1 - XU * V - IF (I .NE. Q) V = E(I+1) - 580 CONTINUE -C - IF (U .EQ. 0.0E0) U = EPS3 - RV1(Q) = U - RV2(Q) = 0.0E0 - RV3(Q) = 0.0E0 -C .......... BACK SUBSTITUTION -C FOR I=Q STEP -1 UNTIL P DO -- .......... - 600 DO 620 II = P, Q - I = P + Q - II - RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I) - V = U - U = RV6(I) - 620 CONTINUE -C .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS -C MEMBERS OF GROUP .......... - IF (GROUP .EQ. 0) GO TO 700 - J = R -C - DO 680 JJ = 1, GROUP - 630 J = J - 1 - IF (IND(J) .NE. TAG) GO TO 630 - XU = 0.0E0 -C - DO 640 I = P, Q - 640 XU = XU + RV6(I) * Z(I,J) -C - DO 660 I = P, Q - 660 RV6(I) = RV6(I) - XU * Z(I,J) -C - 680 CONTINUE -C - 700 NORM = 0.0E0 -C - DO 720 I = P, Q - 720 NORM = NORM + ABS(RV6(I)) -C - IF (NORM .GE. 1.0E0) GO TO 840 -C .......... FORWARD SUBSTITUTION .......... - IF (ITS .EQ. 5) GO TO 830 - IF (NORM .NE. 0.0E0) GO TO 740 - RV6(S) = EPS4 - S = S + 1 - IF (S .GT. Q) S = P - GO TO 780 - 740 XU = EPS4 / NORM -C - DO 760 I = P, Q - 760 RV6(I) = RV6(I) * XU -C .......... ELIMINATION OPERATIONS ON NEXT VECTOR -C ITERATE .......... - 780 DO 820 I = IP, Q - U = RV6(I) -C .......... IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE -C WAS PERFORMED EARLIER IN THE -C TRIANGULARIZATION PROCESS .......... - IF (RV1(I-1) .NE. E(I)) GO TO 800 - U = RV6(I-1) - RV6(I-1) = RV6(I) - 800 RV6(I) = U - RV4(I) * RV6(I-1) - 820 CONTINUE -C - ITS = ITS + 1 - GO TO 600 -C .......... SET ERROR -- NON-CONVERGED EIGENVECTOR .......... - 830 IERR = -R - XU = 0.0E0 - GO TO 870 -C .......... NORMALIZE SO THAT SUM OF SQUARES IS -C 1 AND EXPAND TO FULL ORDER .......... - 840 U = 0.0E0 -C - DO 860 I = P, Q - 860 U = U + RV6(I)**2 -C - XU = 1.0E0 / SQRT(U) -C - 870 DO 880 I = 1, N - 880 Z(I,R) = 0.0E0 -C - DO 900 I = P, Q - 900 Z(I,R) = RV6(I) * XU -C - X0 = X1 - 920 CONTINUE -C - IF (Q .LT. N) GO TO 100 - 1001 RETURN - END diff --git a/slatec/toc b/slatec/toc deleted file mode 100644 index e106860..0000000 --- a/slatec/toc +++ /dev/null @@ -1,5098 +0,0 @@ - - - - SLATEC Common Mathematical Library - - Version 4.1 - - Table of Contents - - -This table of contents of the SLATEC Common Mathematical Library (CML) has -three sections. - -Section I contains the names and purposes of all user-callable CML routines, -arranged by GAMS category. Those unfamiliar with the GAMS scheme should -consult the document "Guide to the SLATEC Common Mathematical Library". The -current library has routines in the following GAMS major categories: - - A. Arithmetic, error analysis - C. Elementary and special functions (search also class L5) - D. Linear Algebra - E. Interpolation - F. Solution of nonlinear equations - G. Optimization (search also classes K, L8) - H. Differentiation, integration - I. Differential and integral equations - J. Integral transforms - K. Approximation (search also class L8) - L. Statistics, probability - N. Data handling (search also class L2) - R. Service routines - Z. Other - -The library contains routines which operate on different types of data but -which are otherwise equivalent. The names of equivalent routines are listed -vertically before the purpose. Immediately after each name is a hyphen (-) -and one of the alphabetic characters S, D, C, I, H, L, or A, where -S indicates a single precision routine, D double precision, C complex, -I integer, H character, L logical, and A is a pseudo-type given to routines -that could not reasonably be converted to some other type. - -Section II contains the names and purposes of all subsidiary CML routines, -arranged in alphabetical order. Usually these routines are not referenced -directly by library users. They are listed here so that users will be able -to avoid duplicating names that are used by the CML and for the benefit of -programmers who may be able to use them in the construction of new routines -for the library. - -Section III is an alphabetical list of every routine in the CML and the -categories to which the routine is assigned. Every user-callable routine -has at least one category. An asterisk (*) immediately preceding a routine -name indicates a subsidiary routine. - - - SECTION I. User-callable Routines - -A. Arithmetic, error analysis -A3. Real -A3D. Extended range - - XADD-S To provide single-precision floating-point arithmetic - DXADD-D with an extended exponent range. - - XADJ-S To provide single-precision floating-point arithmetic - DXADJ-D with an extended exponent range. - - XC210-S To provide single-precision floating-point arithmetic - DXC210-D with an extended exponent range. - - XCON-S To provide single-precision floating-point arithmetic - DXCON-D with an extended exponent range. - - XRED-S To provide single-precision floating-point arithmetic - DXRED-D with an extended exponent range. - - XSET-S To provide single-precision floating-point arithmetic - DXSET-D with an extended exponent range. - -A4. Complex -A4A. Single precision - - CARG-C Compute the argument of a complex number. - -A6. Change of representation -A6B. Base conversion - - R9PAK-S Pack a base 2 exponent into a floating point number. - D9PAK-D - - R9UPAK-S Unpack a floating point number X so that X = Y*2**N. - D9UPAK-D - -C. Elementary and special functions (search also class L5) - - FUNDOC-A Documentation for FNLIB, a collection of routines for - evaluating elementary and special functions. - -C1. Integer-valued functions (e.g., floor, ceiling, factorial, binomial - coefficient) - - BINOM-S Compute the binomial coefficients. - DBINOM-D - - FAC-S Compute the factorial function. - DFAC-D - - POCH-S Evaluate a generalization of Pochhammer's symbol. - DPOCH-D - - POCH1-S Calculate a generalization of Pochhammer's symbol starting - DPOCH1-D from first order. - -C2. Powers, roots, reciprocals - - CBRT-S Compute the cube root. - DCBRT-D - CCBRT-C - -C3. Polynomials -C3A. Orthogonal -C3A2. Chebyshev, Legendre - - CSEVL-S Evaluate a Chebyshev series. - DCSEVL-D - - INITS-S Determine the number of terms needed in an orthogonal - INITDS-D polynomial series so that it meets a specified accuracy. - - QMOMO-S This routine computes modified Chebyshev moments. The K-th - DQMOMO-D modified Chebyshev moment is defined as the integral over - (-1,1) of W(X)*T(K,X), where T(K,X) is the Chebyshev - polynomial of degree K. - - XLEGF-S Compute normalized Legendre polynomials and associated - DXLEGF-D Legendre functions. - - XNRMP-S Compute normalized Legendre polynomials. - DXNRMP-D - -C4. Elementary transcendental functions -C4A. Trigonometric, inverse trigonometric - - CACOS-C Compute the complex arc cosine. - - CASIN-C Compute the complex arc sine. - - CATAN-C Compute the complex arc tangent. - - CATAN2-C Compute the complex arc tangent in the proper quadrant. - - COSDG-S Compute the cosine of an argument in degrees. - DCOSDG-D - - COT-S Compute the cotangent. - DCOT-D - CCOT-C - - CTAN-C Compute the complex tangent. - - SINDG-S Compute the sine of an argument in degrees. - DSINDG-D - -C4B. Exponential, logarithmic - - ALNREL-S Evaluate ln(1+X) accurate in the sense of relative error. - DLNREL-D - CLNREL-C - - CLOG10-C Compute the principal value of the complex base 10 - logarithm. - - EXPREL-S Calculate the relative error exponential (EXP(X)-1)/X. - DEXPRL-D - CEXPRL-C - -C4C. Hyperbolic, inverse hyperbolic - - ACOSH-S Compute the arc hyperbolic cosine. - DACOSH-D - CACOSH-C - - ASINH-S Compute the arc hyperbolic sine. - DASINH-D - CASINH-C - - ATANH-S Compute the arc hyperbolic tangent. - DATANH-D - CATANH-C - - CCOSH-C Compute the complex hyperbolic cosine. - - CSINH-C Compute the complex hyperbolic sine. - - CTANH-C Compute the complex hyperbolic tangent. - -C5. Exponential and logarithmic integrals - - ALI-S Compute the logarithmic integral. - DLI-D - - E1-S Compute the exponential integral E1(X). - DE1-D - - EI-S Compute the exponential integral Ei(X). - DEI-D - - EXINT-S Compute an M member sequence of exponential integrals - DEXINT-D E(N+K,X), K=0,1,...,M-1 for N .GE. 1 and X .GE. 0. - - SPENC-S Compute a form of Spence's integral due to K. Mitchell. - DSPENC-D - -C7. Gamma -C7A. Gamma, log gamma, reciprocal gamma - - ALGAMS-S Compute the logarithm of the absolute value of the Gamma - DLGAMS-D function. - - ALNGAM-S Compute the logarithm of the absolute value of the Gamma - DLNGAM-D function. - CLNGAM-C - - C0LGMC-C Evaluate (Z+0.5)*LOG((Z+1.)/Z) - 1.0 with relative - accuracy. - - GAMLIM-S Compute the minimum and maximum bounds for the argument in - DGAMLM-D the Gamma function. - - GAMMA-S Compute the complete Gamma function. - DGAMMA-D - CGAMMA-C - - GAMR-S Compute the reciprocal of the Gamma function. - DGAMR-D - CGAMR-C - - POCH-S Evaluate a generalization of Pochhammer's symbol. - DPOCH-D - - POCH1-S Calculate a generalization of Pochhammer's symbol starting - DPOCH1-D from first order. - -C7B. Beta, log beta - - ALBETA-S Compute the natural logarithm of the complete Beta - DLBETA-D function. - CLBETA-C - - BETA-S Compute the complete Beta function. - DBETA-D - CBETA-C - -C7C. Psi function - - PSI-S Compute the Psi (or Digamma) function. - DPSI-D - CPSI-C - - PSIFN-S Compute derivatives of the Psi function. - DPSIFN-D - -C7E. Incomplete gamma - - GAMI-S Evaluate the incomplete Gamma function. - DGAMI-D - - GAMIC-S Calculate the complementary incomplete Gamma function. - DGAMIC-D - - GAMIT-S Calculate Tricomi's form of the incomplete Gamma function. - DGAMIT-D - -C7F. Incomplete beta - - BETAI-S Calculate the incomplete Beta function. - DBETAI-D - -C8. Error functions -C8A. Error functions, their inverses, integrals, including the normal - distribution function - - ERF-S Compute the error function. - DERF-D - - ERFC-S Compute the complementary error function. - DERFC-D - -C8C. Dawson's integral - - DAWS-S Compute Dawson's function. - DDAWS-D - -C9. Legendre functions - - XLEGF-S Compute normalized Legendre polynomials and associated - DXLEGF-D Legendre functions. - - XNRMP-S Compute normalized Legendre polynomials. - DXNRMP-D - -C10. Bessel functions -C10A. J, Y, H-(1), H-(2) -C10A1. Real argument, integer order - - BESJ0-S Compute the Bessel function of the first kind of order - DBESJ0-D zero. - - BESJ1-S Compute the Bessel function of the first kind of order one. - DBESJ1-D - - BESY0-S Compute the Bessel function of the second kind of order - DBESY0-D zero. - - BESY1-S Compute the Bessel function of the second kind of order - DBESY1-D one. - -C10A3. Real argument, real order - - BESJ-S Compute an N member sequence of J Bessel functions - DBESJ-D J/SUB(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA - and X. - - BESY-S Implement forward recursion on the three term recursion - DBESY-D relation for a sequence of non-negative order Bessel - functions Y/SUB(FNU+I-1)/(X), I=1,...,N for real, positive - X and non-negative orders FNU. - -C10A4. Complex argument, real order - - CBESH-C Compute a sequence of the Hankel functions H(m,a,z) - ZBESH-C for superscript m=1 or 2, real nonnegative orders a=b, - b+1,... where b>0, and nonzero complex argument z. A - scaling option is available to help avoid overflow. - - CBESJ-C Compute a sequence of the Bessel functions J(a,z) for - ZBESJ-C complex argument z and real nonnegative orders a=b,b+1, - b+2,... where b>0. A scaling option is available to - help avoid overflow. - - CBESY-C Compute a sequence of the Bessel functions Y(a,z) for - ZBESY-C complex argument z and real nonnegative orders a=b,b+1, - b+2,... where b>0. A scaling option is available to - help avoid overflow. - -C10B. I, K -C10B1. Real argument, integer order - - BESI0-S Compute the hyperbolic Bessel function of the first kind - DBESI0-D of order zero. - - BESI0E-S Compute the exponentially scaled modified (hyperbolic) - DBSI0E-D Bessel function of the first kind of order zero. - - BESI1-S Compute the modified (hyperbolic) Bessel function of the - DBESI1-D first kind of order one. - - BESI1E-S Compute the exponentially scaled modified (hyperbolic) - DBSI1E-D Bessel function of the first kind of order one. - - BESK0-S Compute the modified (hyperbolic) Bessel function of the - DBESK0-D third kind of order zero. - - BESK0E-S Compute the exponentially scaled modified (hyperbolic) - DBSK0E-D Bessel function of the third kind of order zero. - - BESK1-S Compute the modified (hyperbolic) Bessel function of the - DBESK1-D third kind of order one. - - BESK1E-S Compute the exponentially scaled modified (hyperbolic) - DBSK1E-D Bessel function of the third kind of order one. - -C10B3. Real argument, real order - - BESI-S Compute an N member sequence of I Bessel functions - DBESI-D I/SUB(ALPHA+K-1)/(X), K=1,...,N or scaled Bessel functions - EXP(-X)*I/SUB(ALPHA+K-1)/(X), K=1,...,N for non-negative - ALPHA and X. - - BESK-S Implement forward recursion on the three term recursion - DBESK-D relation for a sequence of non-negative order Bessel - functions K/SUB(FNU+I-1)/(X), or scaled Bessel functions - EXP(X)*K/SUB(FNU+I-1)/(X), I=1,...,N for real, positive - X and non-negative orders FNU. - - BESKES-S Compute a sequence of exponentially scaled modified Bessel - DBSKES-D functions of the third kind of fractional order. - - BESKS-S Compute a sequence of modified Bessel functions of the - DBESKS-D third kind of fractional order. - -C10B4. Complex argument, real order - - CBESI-C Compute a sequence of the Bessel functions I(a,z) for - ZBESI-C complex argument z and real nonnegative orders a=b,b+1, - b+2,... where b>0. A scaling option is available to - help avoid overflow. - - CBESK-C Compute a sequence of the Bessel functions K(a,z) for - ZBESK-C complex argument z and real nonnegative orders a=b,b+1, - b+2,... where b>0. A scaling option is available to - help avoid overflow. - -C10D. Airy and Scorer functions - - AI-S Evaluate the Airy function. - DAI-D - - AIE-S Calculate the Airy function for a negative argument and an - DAIE-D exponentially scaled Airy function for a non-negative - argument. - - BI-S Evaluate the Bairy function (the Airy function of the - DBI-D second kind). - - BIE-S Calculate the Bairy function for a negative argument and an - DBIE-D exponentially scaled Bairy function for a non-negative - argument. - - CAIRY-C Compute the Airy function Ai(z) or its derivative dAi/dz - ZAIRY-C for complex argument z. A scaling option is available - to help avoid underflow and overflow. - - CBIRY-C Compute the Airy function Bi(z) or its derivative dBi/dz - ZBIRY-C for complex argument z. A scaling option is available - to help avoid overflow. - -C10F. Integrals of Bessel functions - - BSKIN-S Compute repeated integrals of the K-zero Bessel function. - DBSKIN-D - -C11. Confluent hypergeometric functions - - CHU-S Compute the logarithmic confluent hypergeometric function. - DCHU-D - -C14. Elliptic integrals - - RC-S Calculate an approximation to - DRC-D RC(X,Y) = Integral from zero to infinity of - -1/2 -1 - (1/2)(t+X) (t+Y) dt, - where X is nonnegative and Y is positive. - - RD-S Compute the incomplete or complete elliptic integral of the - DRD-D 2nd kind. For X and Y nonnegative, X+Y and Z positive, - RD(X,Y,Z) = Integral from zero to infinity of - -1/2 -1/2 -3/2 - (3/2)(t+X) (t+Y) (t+Z) dt. - If X or Y is zero, the integral is complete. - - RF-S Compute the incomplete or complete elliptic integral of the - DRF-D 1st kind. For X, Y, and Z non-negative and at most one of - them zero, RF(X,Y,Z) = Integral from zero to infinity of - -1/2 -1/2 -1/2 - (1/2)(t+X) (t+Y) (t+Z) dt. - If X, Y or Z is zero, the integral is complete. - - RJ-S Compute the incomplete or complete (X or Y or Z is zero) - DRJ-D elliptic integral of the 3rd kind. For X, Y, and Z non- - negative, at most one of them zero, and P positive, - RJ(X,Y,Z,P) = Integral from zero to infinity of - -1/2 -1/2 -1/2 -1 - (3/2)(t+X) (t+Y) (t+Z) (t+P) dt. - -C19. Other special functions - - RC3JJ-S Evaluate the 3j symbol f(L1) = ( L1 L2 L3) - DRC3JJ-D (-M2-M3 M2 M3) - for all allowed values of L1, the other parameters - being held fixed. - - RC3JM-S Evaluate the 3j symbol g(M2) = (L1 L2 L3 ) - DRC3JM-D (M1 M2 -M1-M2) - for all allowed values of M2, the other parameters - being held fixed. - - RC6J-S Evaluate the 6j symbol h(L1) = {L1 L2 L3} - DRC6J-D {L4 L5 L6} - for all allowed values of L1, the other parameters - being held fixed. - -D. Linear Algebra -D1. Elementary vector and matrix operations -D1A. Elementary vector operations -D1A2. Minimum and maximum components - - ISAMAX-S Find the smallest index of that component of a vector - IDAMAX-D having the maximum magnitude. - ICAMAX-C - -D1A3. Norm -D1A3A. L-1 (sum of magnitudes) - - SASUM-S Compute the sum of the magnitudes of the elements of a - DASUM-D vector. - SCASUM-C - -D1A3B. L-2 (Euclidean norm) - - SNRM2-S Compute the Euclidean length (L2 norm) of a vector. - DNRM2-D - SCNRM2-C - -D1A4. Dot product (inner product) - - CDOTC-C Dot product of two complex vectors using the complex - conjugate of the first vector. - - DQDOTA-D Compute the inner product of two vectors with extended - precision accumulation and result. - - DQDOTI-D Compute the inner product of two vectors with extended - precision accumulation and result. - - DSDOT-D Compute the inner product of two vectors with extended - DCDOT-C precision accumulation and result. - - SDOT-S Compute the inner product of two vectors. - DDOT-D - CDOTU-C - - SDSDOT-S Compute the inner product of two vectors with extended - CDCDOT-C precision accumulation. - -D1A5. Copy or exchange (swap) - - ICOPY-S Copy a vector. - DCOPY-D - CCOPY-C - ICOPY-I - - SCOPY-S Copy a vector. - DCOPY-D - CCOPY-C - ICOPY-I - - SCOPYM-S Copy the negative of a vector to a vector. - DCOPYM-D - - SSWAP-S Interchange two vectors. - DSWAP-D - CSWAP-C - ISWAP-I - -D1A6. Multiplication by scalar - - CSSCAL-C Scale a complex vector. - - SSCAL-S Multiply a vector by a constant. - DSCAL-D - CSCAL-C - -D1A7. Triad (a*x+y for vectors x,y and scalar a) - - SAXPY-S Compute a constant times a vector plus a vector. - DAXPY-D - CAXPY-C - -D1A8. Elementary rotation (Givens transformation) - - SROT-S Apply a plane Givens rotation. - DROT-D - CSROT-C - - SROTM-S Apply a modified Givens transformation. - DROTM-D - -D1B. Elementary matrix operations -D1B4. Multiplication by vector - - CHPR-C Perform the hermitian rank 1 operation. - - DGER-D Perform the rank 1 operation. - - DSPR-D Perform the symmetric rank 1 operation. - - DSYR-D Perform the symmetric rank 1 operation. - - SGBMV-S Multiply a real vector by a real general band matrix. - DGBMV-D - CGBMV-C - - SGEMV-S Multiply a real vector by a real general matrix. - DGEMV-D - CGEMV-C - - SGER-S Perform rank 1 update of a real general matrix. - - CGERC-C Perform conjugated rank 1 update of a complex general - SGERC-S matrix. - DGERC-D - - CGERU-C Perform unconjugated rank 1 update of a complex general - SGERU-S matrix. - DGERU-D - - CHBMV-C Multiply a complex vector by a complex Hermitian band - SHBMV-S matrix. - DHBMV-D - - CHEMV-C Multiply a complex vector by a complex Hermitian matrix. - SHEMV-S - DHEMV-D - - CHER-C Perform Hermitian rank 1 update of a complex Hermitian - SHER-S matrix. - DHER-D - - CHER2-C Perform Hermitian rank 2 update of a complex Hermitian - SHER2-S matrix. - DHER2-D - - CHPMV-C Perform the matrix-vector operation. - SHPMV-S - DHPMV-D - - CHPR2-C Perform the hermitian rank 2 operation. - SHPR2-S - DHPR2-D - - SSBMV-S Multiply a real vector by a real symmetric band matrix. - DSBMV-D - CSBMV-C - - SSDI-S Diagonal Matrix Vector Multiply. - DSDI-D Routine to calculate the product X = DIAG*B, where DIAG - is a diagonal matrix. - - SSMTV-S SLAP Column Format Sparse Matrix Transpose Vector Product. - DSMTV-D Routine to calculate the sparse matrix vector product: - Y = A'*X, where ' denotes transpose. - - SSMV-S SLAP Column Format Sparse Matrix Vector Product. - DSMV-D Routine to calculate the sparse matrix vector product: - Y = A*X. - - SSPMV-S Perform the matrix-vector operation. - DSPMV-D - CSPMV-C - - SSPR-S Performs the symmetric rank 1 operation. - - SSPR2-S Perform the symmetric rank 2 operation. - DSPR2-D - CSPR2-C - - SSYMV-S Multiply a real vector by a real symmetric matrix. - DSYMV-D - CSYMV-C - - SSYR-S Perform symmetric rank 1 update of a real symmetric matrix. - - SSYR2-S Perform symmetric rank 2 update of a real symmetric matrix. - DSYR2-D - CSYR2-C - - STBMV-S Multiply a real vector by a real triangular band matrix. - DTBMV-D - CTBMV-C - - STBSV-S Solve a real triangular banded system of linear equations. - DTBSV-D - CTBSV-C - - STPMV-S Perform one of the matrix-vector operations. - DTPMV-D - CTPMV-C - - STPSV-S Solve one of the systems of equations. - DTPSV-D - CTPSV-C - - STRMV-S Multiply a real vector by a real triangular matrix. - DTRMV-D - CTRMV-C - - STRSV-S Solve a real triangular system of linear equations. - DTRSV-D - CTRSV-C - -D1B6. Multiplication - - SGEMM-S Multiply a real general matrix by a real general matrix. - DGEMM-D - CGEMM-C - - CHEMM-C Multiply a complex general matrix by a complex Hermitian - SHEMM-S matrix. - DHEMM-D - - CHER2K-C Perform Hermitian rank 2k update of a complex. - SHER2-S - DHER2-D - CHER2-C - - CHERK-C Perform Hermitian rank k update of a complex Hermitian - SHERK-S matrix. - DHERK-D - - SSYMM-S Multiply a real general matrix by a real symmetric matrix. - DSYMM-D - CSYMM-C - - DSYR2K-D Perform one of the symmetric rank 2k operations. - SSYR2-S - DSYR2-D - CSYR2-C - - SSYRK-S Perform symmetric rank k update of a real symmetric matrix. - DSYRK-D - CSYRK-C - - STRMM-S Multiply a real general matrix by a real triangular matrix. - DTRMM-D - CTRMM-C - - STRSM-S Solve a real triangular system of equations with multiple - DTRSM-D right-hand sides. - CTRSM-C - -D1B9. Storage mode conversion - - SS2Y-S SLAP Triad to SLAP Column Format Converter. - DS2Y-D Routine to convert from the SLAP Triad to SLAP Column - format. - -D1B10. Elementary rotation (Givens transformation) - - CSROT-C Apply a plane Givens rotation. - SROT-S - DROT-D - - SROTG-S Construct a plane Givens rotation. - DROTG-D - CROTG-C - - SROTMG-S Construct a modified Givens transformation. - DROTMG-D - -D2. Solution of systems of linear equations (including inversion, LU and - related decompositions) -D2A. Real nonsymmetric matrices -D2A1. General - - SGECO-S Factor a matrix using Gaussian elimination and estimate - DGECO-D the condition number of the matrix. - CGECO-C - - SGEDI-S Compute the determinant and inverse of a matrix using the - DGEDI-D factors computed by SGECO or SGEFA. - CGEDI-C - - SGEFA-S Factor a matrix using Gaussian elimination. - DGEFA-D - CGEFA-C - - SGEFS-S Solve a general system of linear equations. - DGEFS-D - CGEFS-C - - SGEIR-S Solve a general system of linear equations. Iterative - CGEIR-C refinement is used to obtain an error estimate. - - SGESL-S Solve the real system A*X=B or TRANS(A)*X=B using the - DGESL-D factors of SGECO or SGEFA. - CGESL-C - - SQRSL-S Apply the output of SQRDC to compute coordinate transfor- - DQRSL-D mations, projections, and least squares solutions. - CQRSL-C - -D2A2. Banded - - SGBCO-S Factor a band matrix by Gaussian elimination and - DGBCO-D estimate the condition number of the matrix. - CGBCO-C - - SGBFA-S Factor a band matrix using Gaussian elimination. - DGBFA-D - CGBFA-C - - SGBSL-S Solve the real band system A*X=B or TRANS(A)*X=B using - DGBSL-D the factors computed by SGBCO or SGBFA. - CGBSL-C - - SNBCO-S Factor a band matrix using Gaussian elimination and - DNBCO-D estimate the condition number. - CNBCO-C - - SNBFA-S Factor a real band matrix by elimination. - DNBFA-D - CNBFA-C - - SNBFS-S Solve a general nonsymmetric banded system of linear - DNBFS-D equations. - CNBFS-C - - SNBIR-S Solve a general nonsymmetric banded system of linear - CNBIR-C equations. Iterative refinement is used to obtain an error - estimate. - - SNBSL-S Solve a real band system using the factors computed by - DNBSL-D SNBCO or SNBFA. - CNBSL-C - -D2A2A. Tridiagonal - - SGTSL-S Solve a tridiagonal linear system. - DGTSL-D - CGTSL-C - -D2A3. Triangular - - SSLI-S SLAP MSOLVE for Lower Triangle Matrix. - DSLI-D This routine acts as an interface between the SLAP generic - MSOLVE calling convention and the routine that actually - -1 - computes L B = X. - - SSLI2-S SLAP Lower Triangle Matrix Backsolve. - DSLI2-D Routine to solve a system of the form Lx = b , where L - is a lower triangular matrix. - - STRCO-S Estimate the condition number of a triangular matrix. - DTRCO-D - CTRCO-C - - STRDI-S Compute the determinant and inverse of a triangular matrix. - DTRDI-D - CTRDI-C - - STRSL-S Solve a system of the form T*X=B or TRANS(T)*X=B, where - DTRSL-D T is a triangular matrix. - CTRSL-C - -D2A4. Sparse - - SBCG-S Preconditioned BiConjugate Gradient Sparse Ax = b Solver. - DBCG-D Routine to solve a Non-Symmetric linear system Ax = b - using the Preconditioned BiConjugate Gradient method. - - SCGN-S Preconditioned CG Sparse Ax=b Solver for Normal Equations. - DCGN-D Routine to solve a general linear system Ax = b using the - Preconditioned Conjugate Gradient method applied to the - normal equations AA'y = b, x=A'y. - - SCGS-S Preconditioned BiConjugate Gradient Squared Ax=b Solver. - DCGS-D Routine to solve a Non-Symmetric linear system Ax = b - using the Preconditioned BiConjugate Gradient Squared - method. - - SGMRES-S Preconditioned GMRES Iterative Sparse Ax=b Solver. - DGMRES-D This routine uses the generalized minimum residual - (GMRES) method with preconditioning to solve - non-symmetric linear systems of the form: Ax = b. - - SIR-S Preconditioned Iterative Refinement Sparse Ax = b Solver. - DIR-D Routine to solve a general linear system Ax = b using - iterative refinement with a matrix splitting. - - SLPDOC-S Sparse Linear Algebra Package Version 2.0.2 Documentation. - DLPDOC-D Routines to solve large sparse symmetric and nonsymmetric - positive definite linear systems, Ax = b, using precondi- - tioned iterative methods. - - SOMN-S Preconditioned Orthomin Sparse Iterative Ax=b Solver. - DOMN-D Routine to solve a general linear system Ax = b using - the Preconditioned Orthomin method. - - SSDBCG-S Diagonally Scaled BiConjugate Gradient Sparse Ax=b Solver. - DSDBCG-D Routine to solve a linear system Ax = b using the - BiConjugate Gradient method with diagonal scaling. - - SSDCGN-S Diagonally Scaled CG Sparse Ax=b Solver for Normal Eqn's. - DSDCGN-D Routine to solve a general linear system Ax = b using - diagonal scaling with the Conjugate Gradient method - applied to the the normal equations, viz., AA'y = b, - where x = A'y. - - SSDCGS-S Diagonally Scaled CGS Sparse Ax=b Solver. - DSDCGS-D Routine to solve a linear system Ax = b using the - BiConjugate Gradient Squared method with diagonal scaling. - - SSDGMR-S Diagonally Scaled GMRES Iterative Sparse Ax=b Solver. - DSDGMR-D This routine uses the generalized minimum residual - (GMRES) method with diagonal scaling to solve possibly - non-symmetric linear systems of the form: Ax = b. - - SSDOMN-S Diagonally Scaled Orthomin Sparse Iterative Ax=b Solver. - DSDOMN-D Routine to solve a general linear system Ax = b using - the Orthomin method with diagonal scaling. - - SSGS-S Gauss-Seidel Method Iterative Sparse Ax = b Solver. - DSGS-D Routine to solve a general linear system Ax = b using - Gauss-Seidel iteration. - - SSILUR-S Incomplete LU Iterative Refinement Sparse Ax = b Solver. - DSILUR-D Routine to solve a general linear system Ax = b using - the incomplete LU decomposition with iterative refinement. - - SSJAC-S Jacobi's Method Iterative Sparse Ax = b Solver. - DSJAC-D Routine to solve a general linear system Ax = b using - Jacobi iteration. - - SSLUBC-S Incomplete LU BiConjugate Gradient Sparse Ax=b Solver. - DSLUBC-D Routine to solve a linear system Ax = b using the - BiConjugate Gradient method with Incomplete LU - decomposition preconditioning. - - SSLUCN-S Incomplete LU CG Sparse Ax=b Solver for Normal Equations. - DSLUCN-D Routine to solve a general linear system Ax = b using the - incomplete LU decomposition with the Conjugate Gradient - method applied to the normal equations, viz., AA'y = b, - x = A'y. - - SSLUCS-S Incomplete LU BiConjugate Gradient Squared Ax=b Solver. - DSLUCS-D Routine to solve a linear system Ax = b using the - BiConjugate Gradient Squared method with Incomplete LU - decomposition preconditioning. - - SSLUGM-S Incomplete LU GMRES Iterative Sparse Ax=b Solver. - DSLUGM-D This routine uses the generalized minimum residual - (GMRES) method with incomplete LU factorization for - preconditioning to solve possibly non-symmetric linear - systems of the form: Ax = b. - - SSLUOM-S Incomplete LU Orthomin Sparse Iterative Ax=b Solver. - DSLUOM-D Routine to solve a general linear system Ax = b using - the Orthomin method with Incomplete LU decomposition. - -D2B. Real symmetric matrices -D2B1. General -D2B1A. Indefinite - - SSICO-S Factor a symmetric matrix by elimination with symmetric - DSICO-D pivoting and estimate the condition number of the matrix. - CHICO-C - CSICO-C - - SSIDI-S Compute the determinant, inertia and inverse of a real - DSIDI-D symmetric matrix using the factors from SSIFA. - CHIDI-C - CSIDI-C - - SSIFA-S Factor a real symmetric matrix by elimination with - DSIFA-D symmetric pivoting. - CHIFA-C - CSIFA-C - - SSISL-S Solve a real symmetric system using the factors obtained - DSISL-D from SSIFA. - CHISL-C - CSISL-C - - SSPCO-S Factor a real symmetric matrix stored in packed form - DSPCO-D by elimination with symmetric pivoting and estimate the - CHPCO-C condition number of the matrix. - CSPCO-C - - SSPDI-S Compute the determinant, inertia, inverse of a real - DSPDI-D symmetric matrix stored in packed form using the factors - CHPDI-C from SSPFA. - CSPDI-C - - SSPFA-S Factor a real symmetric matrix stored in packed form by - DSPFA-D elimination with symmetric pivoting. - CHPFA-C - CSPFA-C - - SSPSL-S Solve a real symmetric system using the factors obtained - DSPSL-D from SSPFA. - CHPSL-C - CSPSL-C - -D2B1B. Positive definite - - SCHDC-S Compute the Cholesky decomposition of a positive definite - DCHDC-D matrix. A pivoting option allows the user to estimate the - CCHDC-C condition number of a positive definite matrix or determine - the rank of a positive semidefinite matrix. - - SPOCO-S Factor a real symmetric positive definite matrix - DPOCO-D and estimate the condition number of the matrix. - CPOCO-C - - SPODI-S Compute the determinant and inverse of a certain real - DPODI-D symmetric positive definite matrix using the factors - CPODI-C computed by SPOCO, SPOFA or SQRDC. - - SPOFA-S Factor a real symmetric positive definite matrix. - DPOFA-D - CPOFA-C - - SPOFS-S Solve a positive definite symmetric system of linear - DPOFS-D equations. - CPOFS-C - - SPOIR-S Solve a positive definite symmetric system of linear - CPOIR-C equations. Iterative refinement is used to obtain an error - estimate. - - SPOSL-S Solve the real symmetric positive definite linear system - DPOSL-D using the factors computed by SPOCO or SPOFA. - CPOSL-C - - SPPCO-S Factor a symmetric positive definite matrix stored in - DPPCO-D packed form and estimate the condition number of the - CPPCO-C matrix. - - SPPDI-S Compute the determinant and inverse of a real symmetric - DPPDI-D positive definite matrix using factors from SPPCO or SPPFA. - CPPDI-C - - SPPFA-S Factor a real symmetric positive definite matrix stored in - DPPFA-D packed form. - CPPFA-C - - SPPSL-S Solve the real symmetric positive definite system using - DPPSL-D the factors computed by SPPCO or SPPFA. - CPPSL-C - -D2B2. Positive definite banded - - SPBCO-S Factor a real symmetric positive definite matrix stored in - DPBCO-D band form and estimate the condition number of the matrix. - CPBCO-C - - SPBFA-S Factor a real symmetric positive definite matrix stored in - DPBFA-D band form. - CPBFA-C - - SPBSL-S Solve a real symmetric positive definite band system - DPBSL-D using the factors computed by SPBCO or SPBFA. - CPBSL-C - -D2B2A. Tridiagonal - - SPTSL-S Solve a positive definite tridiagonal linear system. - DPTSL-D - CPTSL-C - -D2B4. Sparse - - SBCG-S Preconditioned BiConjugate Gradient Sparse Ax = b Solver. - DBCG-D Routine to solve a Non-Symmetric linear system Ax = b - using the Preconditioned BiConjugate Gradient method. - - SCG-S Preconditioned Conjugate Gradient Sparse Ax=b Solver. - DCG-D Routine to solve a symmetric positive definite linear - system Ax = b using the Preconditioned Conjugate - Gradient method. - - SCGN-S Preconditioned CG Sparse Ax=b Solver for Normal Equations. - DCGN-D Routine to solve a general linear system Ax = b using the - Preconditioned Conjugate Gradient method applied to the - normal equations AA'y = b, x=A'y. - - SCGS-S Preconditioned BiConjugate Gradient Squared Ax=b Solver. - DCGS-D Routine to solve a Non-Symmetric linear system Ax = b - using the Preconditioned BiConjugate Gradient Squared - method. - - SGMRES-S Preconditioned GMRES Iterative Sparse Ax=b Solver. - DGMRES-D This routine uses the generalized minimum residual - (GMRES) method with preconditioning to solve - non-symmetric linear systems of the form: Ax = b. - - SIR-S Preconditioned Iterative Refinement Sparse Ax = b Solver. - DIR-D Routine to solve a general linear system Ax = b using - iterative refinement with a matrix splitting. - - SLPDOC-S Sparse Linear Algebra Package Version 2.0.2 Documentation. - DLPDOC-D Routines to solve large sparse symmetric and nonsymmetric - positive definite linear systems, Ax = b, using precondi- - tioned iterative methods. - - SOMN-S Preconditioned Orthomin Sparse Iterative Ax=b Solver. - DOMN-D Routine to solve a general linear system Ax = b using - the Preconditioned Orthomin method. - - SSDBCG-S Diagonally Scaled BiConjugate Gradient Sparse Ax=b Solver. - DSDBCG-D Routine to solve a linear system Ax = b using the - BiConjugate Gradient method with diagonal scaling. - - SSDCG-S Diagonally Scaled Conjugate Gradient Sparse Ax=b Solver. - DSDCG-D Routine to solve a symmetric positive definite linear - system Ax = b using the Preconditioned Conjugate - Gradient method. The preconditioner is diagonal scaling. - - SSDCGN-S Diagonally Scaled CG Sparse Ax=b Solver for Normal Eqn's. - DSDCGN-D Routine to solve a general linear system Ax = b using - diagonal scaling with the Conjugate Gradient method - applied to the the normal equations, viz., AA'y = b, - where x = A'y. - - SSDCGS-S Diagonally Scaled CGS Sparse Ax=b Solver. - DSDCGS-D Routine to solve a linear system Ax = b using the - BiConjugate Gradient Squared method with diagonal scaling. - - SSDGMR-S Diagonally Scaled GMRES Iterative Sparse Ax=b Solver. - DSDGMR-D This routine uses the generalized minimum residual - (GMRES) method with diagonal scaling to solve possibly - non-symmetric linear systems of the form: Ax = b. - - SSDOMN-S Diagonally Scaled Orthomin Sparse Iterative Ax=b Solver. - DSDOMN-D Routine to solve a general linear system Ax = b using - the Orthomin method with diagonal scaling. - - SSGS-S Gauss-Seidel Method Iterative Sparse Ax = b Solver. - DSGS-D Routine to solve a general linear system Ax = b using - Gauss-Seidel iteration. - - SSICCG-S Incomplete Cholesky Conjugate Gradient Sparse Ax=b Solver. - DSICCG-D Routine to solve a symmetric positive definite linear - system Ax = b using the incomplete Cholesky - Preconditioned Conjugate Gradient method. - - SSILUR-S Incomplete LU Iterative Refinement Sparse Ax = b Solver. - DSILUR-D Routine to solve a general linear system Ax = b using - the incomplete LU decomposition with iterative refinement. - - SSJAC-S Jacobi's Method Iterative Sparse Ax = b Solver. - DSJAC-D Routine to solve a general linear system Ax = b using - Jacobi iteration. - - SSLUBC-S Incomplete LU BiConjugate Gradient Sparse Ax=b Solver. - DSLUBC-D Routine to solve a linear system Ax = b using the - BiConjugate Gradient method with Incomplete LU - decomposition preconditioning. - - SSLUCN-S Incomplete LU CG Sparse Ax=b Solver for Normal Equations. - DSLUCN-D Routine to solve a general linear system Ax = b using the - incomplete LU decomposition with the Conjugate Gradient - method applied to the normal equations, viz., AA'y = b, - x = A'y. - - SSLUCS-S Incomplete LU BiConjugate Gradient Squared Ax=b Solver. - DSLUCS-D Routine to solve a linear system Ax = b using the - BiConjugate Gradient Squared method with Incomplete LU - decomposition preconditioning. - - SSLUGM-S Incomplete LU GMRES Iterative Sparse Ax=b Solver. - DSLUGM-D This routine uses the generalized minimum residual - (GMRES) method with incomplete LU factorization for - preconditioning to solve possibly non-symmetric linear - systems of the form: Ax = b. - - SSLUOM-S Incomplete LU Orthomin Sparse Iterative Ax=b Solver. - DSLUOM-D Routine to solve a general linear system Ax = b using - the Orthomin method with Incomplete LU decomposition. - -D2C. Complex non-Hermitian matrices -D2C1. General - - CGECO-C Factor a matrix using Gaussian elimination and estimate - SGECO-S the condition number of the matrix. - DGECO-D - - CGEDI-C Compute the determinant and inverse of a matrix using the - SGEDI-S factors computed by CGECO or CGEFA. - DGEDI-D - - CGEFA-C Factor a matrix using Gaussian elimination. - SGEFA-S - DGEFA-D - - CGEFS-C Solve a general system of linear equations. - SGEFS-S - DGEFS-D - - CGEIR-C Solve a general system of linear equations. Iterative - SGEIR-S refinement is used to obtain an error estimate. - - CGESL-C Solve the complex system A*X=B or CTRANS(A)*X=B using the - SGESL-S factors computed by CGECO or CGEFA. - DGESL-D - - CQRSL-C Apply the output of CQRDC to compute coordinate transfor- - SQRSL-S mations, projections, and least squares solutions. - DQRSL-D - - CSICO-C Factor a complex symmetric matrix by elimination with - SSICO-S symmetric pivoting and estimate the condition number of the - DSICO-D matrix. - CHICO-C - - CSIDI-C Compute the determinant and inverse of a complex symmetric - SSIDI-S matrix using the factors from CSIFA. - DSIDI-D - CHIDI-C - - CSIFA-C Factor a complex symmetric matrix by elimination with - SSIFA-S symmetric pivoting. - DSIFA-D - CHIFA-C - - CSISL-C Solve a complex symmetric system using the factors obtained - SSISL-S from CSIFA. - DSISL-D - CHISL-C - - CSPCO-C Factor a complex symmetric matrix stored in packed form - SSPCO-S by elimination with symmetric pivoting and estimate the - DSPCO-D condition number of the matrix. - CHPCO-C - - CSPDI-C Compute the determinant and inverse of a complex symmetric - SSPDI-S matrix stored in packed form using the factors from CSPFA. - DSPDI-D - CHPDI-C - - CSPFA-C Factor a complex symmetric matrix stored in packed form by - SSPFA-S elimination with symmetric pivoting. - DSPFA-D - CHPFA-C - - CSPSL-C Solve a complex symmetric system using the factors obtained - SSPSL-S from CSPFA. - DSPSL-D - CHPSL-C - -D2C2. Banded - - CGBCO-C Factor a band matrix by Gaussian elimination and - SGBCO-S estimate the condition number of the matrix. - DGBCO-D - - CGBFA-C Factor a band matrix using Gaussian elimination. - SGBFA-S - DGBFA-D - - CGBSL-C Solve the complex band system A*X=B or CTRANS(A)*X=B using - SGBSL-S the factors computed by CGBCO or CGBFA. - DGBSL-D - - CNBCO-C Factor a band matrix using Gaussian elimination and - SNBCO-S estimate the condition number. - DNBCO-D - - CNBFA-C Factor a band matrix by elimination. - SNBFA-S - DNBFA-D - - CNBFS-C Solve a general nonsymmetric banded system of linear - SNBFS-S equations. - DNBFS-D - - CNBIR-C Solve a general nonsymmetric banded system of linear - SNBIR-S equations. Iterative refinement is used to obtain an error - estimate. - - CNBSL-C Solve a complex band system using the factors computed by - SNBSL-S CNBCO or CNBFA. - DNBSL-D - -D2C2A. Tridiagonal - - CGTSL-C Solve a tridiagonal linear system. - SGTSL-S - DGTSL-D - -D2C3. Triangular - - CTRCO-C Estimate the condition number of a triangular matrix. - STRCO-S - DTRCO-D - - CTRDI-C Compute the determinant and inverse of a triangular matrix. - STRDI-S - DTRDI-D - - CTRSL-C Solve a system of the form T*X=B or CTRANS(T)*X=B, where - STRSL-S T is a triangular matrix. Here CTRANS(T) is the conjugate - DTRSL-D transpose. - -D2D. Complex Hermitian matrices -D2D1. General -D2D1A. Indefinite - - CHICO-C Factor a complex Hermitian matrix by elimination with sym- - SSICO-S metric pivoting and estimate the condition of the matrix. - DSICO-D - CSICO-C - - CHIDI-C Compute the determinant, inertia and inverse of a complex - SSIDI-S Hermitian matrix using the factors obtained from CHIFA. - DSISI-D - CSIDI-C - - CHIFA-C Factor a complex Hermitian matrix by elimination - SSIFA-S (symmetric pivoting). - DSIFA-D - CSIFA-C - - CHISL-C Solve the complex Hermitian system using factors obtained - SSISL-S from CHIFA. - DSISL-D - CSISL-C - - CHPCO-C Factor a complex Hermitian matrix stored in packed form by - SSPCO-S elimination with symmetric pivoting and estimate the - DSPCO-D condition number of the matrix. - CSPCO-C - - CHPDI-C Compute the determinant, inertia and inverse of a complex - SSPDI-S Hermitian matrix stored in packed form using the factors - DSPDI-D obtained from CHPFA. - DSPDI-C - - CHPFA-C Factor a complex Hermitian matrix stored in packed form by - SSPFA-S elimination with symmetric pivoting. - DSPFA-D - DSPFA-C - - CHPSL-C Solve a complex Hermitian system using factors obtained - SSPSL-S from CHPFA. - DSPSL-D - CSPSL-C - -D2D1B. Positive definite - - CCHDC-C Compute the Cholesky decomposition of a positive definite - SCHDC-S matrix. A pivoting option allows the user to estimate the - DCHDC-D condition number of a positive definite matrix or determine - the rank of a positive semidefinite matrix. - - CPOCO-C Factor a complex Hermitian positive definite matrix - SPOCO-S and estimate the condition number of the matrix. - DPOCO-D - - CPODI-C Compute the determinant and inverse of a certain complex - SPODI-S Hermitian positive definite matrix using the factors - DPODI-D computed by CPOCO, CPOFA, or CQRDC. - - CPOFA-C Factor a complex Hermitian positive definite matrix. - SPOFA-S - DPOFA-D - - CPOFS-C Solve a positive definite symmetric complex system of - SPOFS-S linear equations. - DPOFS-D - - CPOIR-C Solve a positive definite Hermitian system of linear - SPOIR-S equations. Iterative refinement is used to obtain an - error estimate. - - CPOSL-C Solve the complex Hermitian positive definite linear system - SPOSL-S using the factors computed by CPOCO or CPOFA. - DPOSL-D - - CPPCO-C Factor a complex Hermitian positive definite matrix stored - SPPCO-S in packed form and estimate the condition number of the - DPPCO-D matrix. - - CPPDI-C Compute the determinant and inverse of a complex Hermitian - SPPDI-S positive definite matrix using factors from CPPCO or CPPFA. - DPPDI-D - - CPPFA-C Factor a complex Hermitian positive definite matrix stored - SPPFA-S in packed form. - DPPFA-D - - CPPSL-C Solve the complex Hermitian positive definite system using - SPPSL-S the factors computed by CPPCO or CPPFA. - DPPSL-D - -D2D2. Positive definite banded - - CPBCO-C Factor a complex Hermitian positive definite matrix stored - SPBCO-S in band form and estimate the condition number of the - DPBCO-D matrix. - - CPBFA-C Factor a complex Hermitian positive definite matrix stored - SPBFA-S in band form. - DPBFA-D - - CPBSL-C Solve the complex Hermitian positive definite band system - SPBSL-S using the factors computed by CPBCO or CPBFA. - DPBSL-D - -D2D2A. Tridiagonal - - CPTSL-C Solve a positive definite tridiagonal linear system. - SPTSL-S - DPTSL-D - -D2E. Associated operations (e.g., matrix reorderings) - - SLLTI2-S SLAP Backsolve routine for LDL' Factorization. - DLLTI2-D Routine to solve a system of the form L*D*L' X = B, - where L is a unit lower triangular matrix and D is a - diagonal matrix and ' means transpose. - - SS2LT-S Lower Triangle Preconditioner SLAP Set Up. - DS2LT-D Routine to store the lower triangle of a matrix stored - in the SLAP Column format. - - SSD2S-S Diagonal Scaling Preconditioner SLAP Normal Eqns Set Up. - DSD2S-D Routine to compute the inverse of the diagonal of the - matrix A*A', where A is stored in SLAP-Column format. - - SSDS-S Diagonal Scaling Preconditioner SLAP Set Up. - DSDS-D Routine to compute the inverse of the diagonal of a matrix - stored in the SLAP Column format. - - SSDSCL-S Diagonal Scaling of system Ax = b. - DSDSCL-D This routine scales (and unscales) the system Ax = b - by symmetric diagonal scaling. - - SSICS-S Incompl. Cholesky Decomposition Preconditioner SLAP Set Up. - DSICS-D Routine to generate the Incomplete Cholesky decomposition, - L*D*L-trans, of a symmetric positive definite matrix, A, - which is stored in SLAP Column format. The unit lower - triangular matrix L is stored by rows, and the inverse of - the diagonal matrix D is stored. - - SSILUS-S Incomplete LU Decomposition Preconditioner SLAP Set Up. - DSILUS-D Routine to generate the incomplete LDU decomposition of a - matrix. The unit lower triangular factor L is stored by - rows and the unit upper triangular factor U is stored by - columns. The inverse of the diagonal matrix D is stored. - No fill in is allowed. - - SSLLTI-S SLAP MSOLVE for LDL' (IC) Factorization. - DSLLTI-D This routine acts as an interface between the SLAP generic - MSOLVE calling convention and the routine that actually - -1 - computes (LDL') B = X. - - SSLUI-S SLAP MSOLVE for LDU Factorization. - DSLUI-D This routine acts as an interface between the SLAP generic - MSOLVE calling convention and the routine that actually - -1 - computes (LDU) B = X. - - SSLUI2-S SLAP Backsolve for LDU Factorization. - DSLUI2-D Routine to solve a system of the form L*D*U X = B, - where L is a unit lower triangular matrix, D is a diagonal - matrix, and U is a unit upper triangular matrix. - - SSLUI4-S SLAP Backsolve for LDU Factorization. - DSLUI4-D Routine to solve a system of the form (L*D*U)' X = B, - where L is a unit lower triangular matrix, D is a diagonal - matrix, and U is a unit upper triangular matrix and ' - denotes transpose. - - SSLUTI-S SLAP MTSOLV for LDU Factorization. - DSLUTI-D This routine acts as an interface between the SLAP generic - MTSOLV calling convention and the routine that actually - -T - computes (LDU) B = X. - - SSMMI2-S SLAP Backsolve for LDU Factorization of Normal Equations. - DSMMI2-D To solve a system of the form (L*D*U)*(L*D*U)' X = B, - where L is a unit lower triangular matrix, D is a diagonal - matrix, and U is a unit upper triangular matrix and ' - denotes transpose. - - SSMMTI-S SLAP MSOLVE for LDU Factorization of Normal Equations. - DSMMTI-D This routine acts as an interface between the SLAP generic - MMTSLV calling convention and the routine that actually - -1 - computes [(LDU)*(LDU)'] B = X. - -D3. Determinants -D3A. Real nonsymmetric matrices -D3A1. General - - SGEDI-S Compute the determinant and inverse of a matrix using the - DGEDI-D factors computed by SGECO or SGEFA. - CGEDI-C - -D3A2. Banded - - SGBDI-S Compute the determinant of a band matrix using the factors - DGBDI-D computed by SGBCO or SGBFA. - CGBDI-C - - SNBDI-S Compute the determinant of a band matrix using the factors - DNBDI-D computed by SNBCO or SNBFA. - CNBDI-C - -D3A3. Triangular - - STRDI-S Compute the determinant and inverse of a triangular matrix. - DTRDI-D - CTRDI-C - -D3B. Real symmetric matrices -D3B1. General -D3B1A. Indefinite - - SSIDI-S Compute the determinant, inertia and inverse of a real - DSIDI-D symmetric matrix using the factors from SSIFA. - CHIDI-C - CSIDI-C - - SSPDI-S Compute the determinant, inertia, inverse of a real - DSPDI-D symmetric matrix stored in packed form using the factors - CHPDI-C from SSPFA. - CSPDI-C - -D3B1B. Positive definite - - SPODI-S Compute the determinant and inverse of a certain real - DPODI-D symmetric positive definite matrix using the factors - CPODI-C computed by SPOCO, SPOFA or SQRDC. - - SPPDI-S Compute the determinant and inverse of a real symmetric - DPPDI-D positive definite matrix using factors from SPPCO or SPPFA. - CPPDI-C - -D3B2. Positive definite banded - - SPBDI-S Compute the determinant of a symmetric positive definite - DPBDI-D band matrix using the factors computed by SPBCO or SPBFA. - CPBDI-C - -D3C. Complex non-Hermitian matrices -D3C1. General - - CGEDI-C Compute the determinant and inverse of a matrix using the - SGEDI-S factors computed by CGECO or CGEFA. - DGEDI-D - - CSIDI-C Compute the determinant and inverse of a complex symmetric - SSIDI-S matrix using the factors from CSIFA. - DSIDI-D - CHIDI-C - - CSPDI-C Compute the determinant and inverse of a complex symmetric - SSPDI-S matrix stored in packed form using the factors from CSPFA. - DSPDI-D - CHPDI-C - -D3C2. Banded - - CGBDI-C Compute the determinant of a complex band matrix using the - SGBDI-S factors from CGBCO or CGBFA. - DGBDI-D - - CNBDI-C Compute the determinant of a band matrix using the factors - SNBDI-S computed by CNBCO or CNBFA. - DNBDI-D - -D3C3. Triangular - - CTRDI-C Compute the determinant and inverse of a triangular matrix. - STRDI-S - DTRDI-D - -D3D. Complex Hermitian matrices -D3D1. General -D3D1A. Indefinite - - CHIDI-C Compute the determinant, inertia and inverse of a complex - SSIDI-S Hermitian matrix using the factors obtained from CHIFA. - DSISI-D - CSIDI-C - - CHPDI-C Compute the determinant, inertia and inverse of a complex - SSPDI-S Hermitian matrix stored in packed form using the factors - DSPDI-D obtained from CHPFA. - DSPDI-C - -D3D1B. Positive definite - - CPODI-C Compute the determinant and inverse of a certain complex - SPODI-S Hermitian positive definite matrix using the factors - DPODI-D computed by CPOCO, CPOFA, or CQRDC. - - CPPDI-C Compute the determinant and inverse of a complex Hermitian - SPPDI-S positive definite matrix using factors from CPPCO or CPPFA. - DPPDI-D - -D3D2. Positive definite banded - - CPBDI-C Compute the determinant of a complex Hermitian positive - SPBDI-S definite band matrix using the factors computed by CPBCO or - DPBDI-D CPBFA. - -D4. Eigenvalues, eigenvectors - - EISDOC-A Documentation for EISPACK, a collection of subprograms for - solving matrix eigen-problems. - -D4A. Ordinary eigenvalue problems (Ax = (lambda) * x) -D4A1. Real symmetric - - RS-S Compute the eigenvalues and, optionally, the eigenvectors - CH-C of a real symmetric matrix. - - RSP-S Compute the eigenvalues and, optionally, the eigenvectors - of a real symmetric matrix packed into a one dimensional - array. - - SSIEV-S Compute the eigenvalues and, optionally, the eigenvectors - CHIEV-C of a real symmetric matrix. - - SSPEV-S Compute the eigenvalues and, optionally, the eigenvectors - of a real symmetric matrix stored in packed form. - -D4A2. Real nonsymmetric - - RG-S Compute the eigenvalues and, optionally, the eigenvectors - CG-C of a real general matrix. - - SGEEV-S Compute the eigenvalues and, optionally, the eigenvectors - CGEEV-C of a real general matrix. - -D4A3. Complex Hermitian - - CH-C Compute the eigenvalues and, optionally, the eigenvectors - RS-S of a complex Hermitian matrix. - - CHIEV-C Compute the eigenvalues and, optionally, the eigenvectors - SSIEV-S of a complex Hermitian matrix. - -D4A4. Complex non-Hermitian - - CG-C Compute the eigenvalues and, optionally, the eigenvectors - RG-S of a complex general matrix. - - CGEEV-C Compute the eigenvalues and, optionally, the eigenvectors - SGEEV-S of a complex general matrix. - -D4A5. Tridiagonal - - BISECT-S Compute the eigenvalues of a symmetric tridiagonal matrix - in a given interval using Sturm sequencing. - - IMTQL1-S Compute the eigenvalues of a symmetric tridiagonal matrix - using the implicit QL method. - - IMTQL2-S Compute the eigenvalues and eigenvectors of a symmetric - tridiagonal matrix using the implicit QL method. - - IMTQLV-S Compute the eigenvalues of a symmetric tridiagonal matrix - using the implicit QL method. Eigenvectors may be computed - later. - - RATQR-S Compute the largest or smallest eigenvalues of a symmetric - tridiagonal matrix using the rational QR method with Newton - correction. - - RST-S Compute the eigenvalues and, optionally, the eigenvectors - of a real symmetric tridiagonal matrix. - - RT-S Compute the eigenvalues and eigenvectors of a special real - tridiagonal matrix. - - TQL1-S Compute the eigenvalues of symmetric tridiagonal matrix by - the QL method. - - TQL2-S Compute the eigenvalues and eigenvectors of symmetric - tridiagonal matrix. - - TQLRAT-S Compute the eigenvalues of symmetric tridiagonal matrix - using a rational variant of the QL method. - - TRIDIB-S Compute the eigenvalues of a symmetric tridiagonal matrix - in a given interval using Sturm sequencing. - - TSTURM-S Find those eigenvalues of a symmetric tridiagonal matrix - in a given interval and their associated eigenvectors by - Sturm sequencing. - -D4A6. Banded - - BQR-S Compute some of the eigenvalues of a real symmetric - matrix using the QR method with shifts of origin. - - RSB-S Compute the eigenvalues and, optionally, the eigenvectors - of a symmetric band matrix. - -D4B. Generalized eigenvalue problems (e.g., Ax = (lambda)*Bx) -D4B1. Real symmetric - - RSG-S Compute the eigenvalues and, optionally, the eigenvectors - of a symmetric generalized eigenproblem. - - RSGAB-S Compute the eigenvalues and, optionally, the eigenvectors - of a symmetric generalized eigenproblem. - - RSGBA-S Compute the eigenvalues and, optionally, the eigenvectors - of a symmetric generalized eigenproblem. - -D4B2. Real general - - RGG-S Compute the eigenvalues and eigenvectors for a real - generalized eigenproblem. - -D4C. Associated operations -D4C1. Transform problem -D4C1A. Balance matrix - - BALANC-S Balance a real general matrix and isolate eigenvalues - CBAL-C whenever possible. - -D4C1B. Reduce to compact form -D4C1B1. Tridiagonal - - BANDR-S Reduce a real symmetric band matrix to symmetric - tridiagonal matrix and, optionally, accumulate - orthogonal similarity transformations. - - HTRID3-S Reduce a complex Hermitian (packed) matrix to a real - symmetric tridiagonal matrix by unitary similarity - transformations. - - HTRIDI-S Reduce a complex Hermitian matrix to a real symmetric - tridiagonal matrix using unitary similarity - transformations. - - TRED1-S Reduce a real symmetric matrix to symmetric tridiagonal - matrix using orthogonal similarity transformations. - - TRED2-S Reduce a real symmetric matrix to a symmetric tridiagonal - matrix using and accumulating orthogonal transformations. - - TRED3-S Reduce a real symmetric matrix stored in packed form to - symmetric tridiagonal matrix using orthogonal - transformations. - -D4C1B2. Hessenberg - - ELMHES-S Reduce a real general matrix to upper Hessenberg form - COMHES-C using stabilized elementary similarity transformations. - - ORTHES-S Reduce a real general matrix to upper Hessenberg form - CORTH-C using orthogonal similarity transformations. - -D4C1B3. Other - - QZHES-S The first step of the QZ algorithm for solving generalized - matrix eigenproblems. Accepts a pair of real general - matrices and reduces one of them to upper Hessenberg - and the other to upper triangular form using orthogonal - transformations. Usually followed by QZIT, QZVAL, QZVEC. - - QZIT-S The second step of the QZ algorithm for generalized - eigenproblems. Accepts an upper Hessenberg and an upper - triangular matrix and reduces the former to - quasi-triangular form while preserving the form of the - latter. Usually preceded by QZHES and followed by QZVAL - and QZVEC. - -D4C1C. Standardize problem - - FIGI-S Transforms certain real non-symmetric tridiagonal matrix - to symmetric tridiagonal matrix. - - FIGI2-S Transforms certain real non-symmetric tridiagonal matrix - to symmetric tridiagonal matrix. - - REDUC-S Reduce a generalized symmetric eigenproblem to a standard - symmetric eigenproblem using Cholesky factorization. - - REDUC2-S Reduce a certain generalized symmetric eigenproblem to a - standard symmetric eigenproblem using Cholesky - factorization. - -D4C2. Compute eigenvalues of matrix in compact form -D4C2A. Tridiagonal - - BISECT-S Compute the eigenvalues of a symmetric tridiagonal matrix - in a given interval using Sturm sequencing. - - IMTQL1-S Compute the eigenvalues of a symmetric tridiagonal matrix - using the implicit QL method. - - IMTQL2-S Compute the eigenvalues and eigenvectors of a symmetric - tridiagonal matrix using the implicit QL method. - - IMTQLV-S Compute the eigenvalues of a symmetric tridiagonal matrix - using the implicit QL method. Eigenvectors may be computed - later. - - RATQR-S Compute the largest or smallest eigenvalues of a symmetric - tridiagonal matrix using the rational QR method with Newton - correction. - - TQL1-S Compute the eigenvalues of symmetric tridiagonal matrix by - the QL method. - - TQL2-S Compute the eigenvalues and eigenvectors of symmetric - tridiagonal matrix. - - TQLRAT-S Compute the eigenvalues of symmetric tridiagonal matrix - using a rational variant of the QL method. - - TRIDIB-S Compute the eigenvalues of a symmetric tridiagonal matrix - in a given interval using Sturm sequencing. - - TSTURM-S Find those eigenvalues of a symmetric tridiagonal matrix - in a given interval and their associated eigenvectors by - Sturm sequencing. - -D4C2B. Hessenberg - - COMLR-C Compute the eigenvalues of a complex upper Hessenberg - matrix using the modified LR method. - - COMLR2-C Compute the eigenvalues and eigenvectors of a complex upper - Hessenberg matrix using the modified LR method. - - HQR-S Compute the eigenvalues of a real upper Hessenberg matrix - COMQR-C using the QR method. - - HQR2-S Compute the eigenvalues and eigenvectors of a real upper - COMQR2-C Hessenberg matrix using QR method. - - INVIT-S Compute the eigenvectors of a real upper Hessenberg - CINVIT-C matrix associated with specified eigenvalues by inverse - iteration. - -D4C2C. Other - - QZVAL-S The third step of the QZ algorithm for generalized - eigenproblems. Accepts a pair of real matrices, one in - quasi-triangular form and the other in upper triangular - form and computes the eigenvalues of the associated - eigenproblem. Usually preceded by QZHES, QZIT, and - followed by QZVEC. - -D4C3. Form eigenvectors from eigenvalues - - BANDV-S Form the eigenvectors of a real symmetric band matrix - associated with a set of ordered approximate eigenvalues - by inverse iteration. - - QZVEC-S The optional fourth step of the QZ algorithm for - generalized eigenproblems. Accepts a matrix in - quasi-triangular form and another in upper triangular - and computes the eigenvectors of the triangular problem - and transforms them back to the original coordinates - Usually preceded by QZHES, QZIT, and QZVAL. - - TINVIT-S Compute the eigenvectors of symmetric tridiagonal matrix - corresponding to specified eigenvalues, using inverse - iteration. - -D4C4. Back transform eigenvectors - - BAKVEC-S Form the eigenvectors of a certain real non-symmetric - tridiagonal matrix from a symmetric tridiagonal matrix - output from FIGI. - - BALBAK-S Form the eigenvectors of a real general matrix from the - CBABK2-C eigenvectors of matrix output from BALANC. - - ELMBAK-S Form the eigenvectors of a real general matrix from the - COMBAK-C eigenvectors of the upper Hessenberg matrix output from - ELMHES. - - ELTRAN-S Accumulates the stabilized elementary similarity - transformations used in the reduction of a real general - matrix to upper Hessenberg form by ELMHES. - - HTRIB3-S Compute the eigenvectors of a complex Hermitian matrix from - the eigenvectors of a real symmetric tridiagonal matrix - output from HTRID3. - - HTRIBK-S Form the eigenvectors of a complex Hermitian matrix from - the eigenvectors of a real symmetric tridiagonal matrix - output from HTRIDI. - - ORTBAK-S Form the eigenvectors of a general real matrix from the - CORTB-C eigenvectors of the upper Hessenberg matrix output from - ORTHES. - - ORTRAN-S Accumulate orthogonal similarity transformations in the - reduction of real general matrix by ORTHES. - - REBAK-S Form the eigenvectors of a generalized symmetric - eigensystem from the eigenvectors of derived matrix output - from REDUC or REDUC2. - - REBAKB-S Form the eigenvectors of a generalized symmetric - eigensystem from the eigenvectors of derived matrix output - from REDUC2. - - TRBAK1-S Form the eigenvectors of real symmetric matrix from - the eigenvectors of a symmetric tridiagonal matrix formed - by TRED1. - - TRBAK3-S Form the eigenvectors of a real symmetric matrix from the - eigenvectors of a symmetric tridiagonal matrix formed - by TRED3. - -D5. QR decomposition, Gram-Schmidt orthogonalization - - LLSIA-S Solve a linear least squares problems by performing a QR - DLLSIA-D factorization of the matrix using Householder - transformations. Emphasis is put on detecting possible - rank deficiency. - - SGLSS-S Solve a linear least squares problems by performing a QR - DGLSS-D factorization of the matrix using Householder - transformations. Emphasis is put on detecting possible - rank deficiency. - - SQRDC-S Use Householder transformations to compute the QR - DQRDC-D factorization of an N by P matrix. Column pivoting is a - CQRDC-C users option. - -D6. Singular value decomposition - - SSVDC-S Perform the singular value decomposition of a rectangular - DSVDC-D matrix. - CSVDC-C - -D7. Update matrix decompositions -D7B. Cholesky - - SCHDD-S Downdate an augmented Cholesky decomposition or the - DCHDD-D triangular factor of an augmented QR decomposition. - CCHDD-C - - SCHEX-S Update the Cholesky factorization A=TRANS(R)*R of A - DCHEX-D positive definite matrix A of order P under diagonal - CCHEX-C permutations of the form TRANS(E)*A*E, where E is a - permutation matrix. - - SCHUD-S Update an augmented Cholesky decomposition of the - DCHUD-D triangular part of an augmented QR decomposition. - CCHUD-C - -D9. Overdetermined or underdetermined systems of equations, singular systems, - pseudo-inverses (search also classes D5, D6, K1a, L8a) - - BNDACC-S Compute the LU factorization of a banded matrices using - DBNDAC-D sequential accumulation of rows of the data matrix. - Exactly one right-hand side vector is permitted. - - BNDSOL-S Solve the least squares problem for a banded matrix using - DBNDSL-D sequential accumulation of rows of the data matrix. - Exactly one right-hand side vector is permitted. - - HFTI-S Solve a linear least squares problems by performing a QR - DHFTI-D factorization of the matrix using Householder - transformations. - - LLSIA-S Solve a linear least squares problems by performing a QR - DLLSIA-D factorization of the matrix using Householder - transformations. Emphasis is put on detecting possible - rank deficiency. - - LSEI-S Solve a linearly constrained least squares problem with - DLSEI-D equality and inequality constraints, and optionally compute - a covariance matrix. - - MINFIT-S Compute the singular value decomposition of a rectangular - matrix and solve the related linear least squares problem. - - SGLSS-S Solve a linear least squares problems by performing a QR - DGLSS-D factorization of the matrix using Householder - transformations. Emphasis is put on detecting possible - rank deficiency. - - SQRSL-S Apply the output of SQRDC to compute coordinate transfor- - DQRSL-D mations, projections, and least squares solutions. - CQRSL-C - - ULSIA-S Solve an underdetermined linear system of equations by - DULSIA-D performing an LQ factorization of the matrix using - Householder transformations. Emphasis is put on detecting - possible rank deficiency. - -E. Interpolation - - BSPDOC-A Documentation for BSPLINE, a package of subprograms for - working with piecewise polynomial functions - in B-representation. - -E1. Univariate data (curve fitting) -E1A. Polynomial splines (piecewise polynomials) - - BINT4-S Compute the B-representation of a cubic spline - DBINT4-D which interpolates given data. - - BINTK-S Compute the B-representation of a spline which interpolates - DBINTK-D given data. - - BSPDOC-A Documentation for BSPLINE, a package of subprograms for - working with piecewise polynomial functions - in B-representation. - - PCHDOC-A Documentation for PCHIP, a Fortran package for piecewise - cubic Hermite interpolation of data. - - PCHIC-S Set derivatives needed to determine a piecewise monotone - DPCHIC-D piecewise cubic Hermite interpolant to given data. - User control is available over boundary conditions and/or - treatment of points where monotonicity switches direction. - - PCHIM-S Set derivatives needed to determine a monotone piecewise - DPCHIM-D cubic Hermite interpolant to given data. Boundary values - are provided which are compatible with monotonicity. The - interpolant will have an extremum at each point where mono- - tonicity switches direction. (See PCHIC if user control is - desired over boundary or switch conditions.) - - PCHSP-S Set derivatives needed to determine the Hermite represen- - DPCHSP-D tation of the cubic spline interpolant to given data, with - specified boundary conditions. - -E1B. Polynomials - - POLCOF-S Compute the coefficients of the polynomial fit (including - DPOLCF-D Hermite polynomial fits) produced by a previous call to - POLINT. - - POLINT-S Produce the polynomial which interpolates a set of discrete - DPLINT-D data points. - -E3. Service routines (e.g., grid generation, evaluation of fitted functions) - (search also class N5) - - BFQAD-S Compute the integral of a product of a function and a - DBFQAD-D derivative of a B-spline. - - BSPDR-S Use the B-representation to construct a divided difference - DBSPDR-D table preparatory to a (right) derivative calculation. - - BSPEV-S Calculate the value of the spline and its derivatives from - DBSPEV-D the B-representation. - - BSPPP-S Convert the B-representation of a B-spline to the piecewise - DBSPPP-D polynomial (PP) form. - - BSPVD-S Calculate the value and all derivatives of order less than - DBSPVD-D NDERIV of all basis functions which do not vanish at X. - - BSPVN-S Calculate the value of all (possibly) nonzero basis - DBSPVN-D functions at X. - - BSQAD-S Compute the integral of a K-th order B-spline using the - DBSQAD-D B-representation. - - BVALU-S Evaluate the B-representation of a B-spline at X for the - DBVALU-D function value or any of its derivatives. - - CHFDV-S Evaluate a cubic polynomial given in Hermite form and its - DCHFDV-D first derivative at an array of points. While designed for - use by PCHFD, it may be useful directly as an evaluator - for a piecewise cubic Hermite function in applications, - such as graphing, where the interval is known in advance. - If only function values are required, use CHFEV instead. - - CHFEV-S Evaluate a cubic polynomial given in Hermite form at an - DCHFEV-D array of points. While designed for use by PCHFE, it may - be useful directly as an evaluator for a piecewise cubic - Hermite function in applications, such as graphing, where - the interval is known in advance. - - INTRV-S Compute the largest integer ILEFT in 1 .LE. ILEFT .LE. LXT - DINTRV-D such that XT(ILEFT) .LE. X where XT(*) is a subdivision - of the X interval. - - PCHBS-S Piecewise Cubic Hermite to B-Spline converter. - DPCHBS-D - - PCHCM-S Check a cubic Hermite function for monotonicity. - DPCHCM-D - - PCHFD-S Evaluate a piecewise cubic Hermite function and its first - DPCHFD-D derivative at an array of points. May be used by itself - for Hermite interpolation, or as an evaluator for PCHIM - or PCHIC. If only function values are required, use - PCHFE instead. - - PCHFE-S Evaluate a piecewise cubic Hermite function at an array of - DPCHFE-D points. May be used by itself for Hermite interpolation, - or as an evaluator for PCHIM or PCHIC. - - PCHIA-S Evaluate the definite integral of a piecewise cubic - DPCHIA-D Hermite function over an arbitrary interval. - - PCHID-S Evaluate the definite integral of a piecewise cubic - DPCHID-D Hermite function over an interval whose endpoints are data - points. - - PFQAD-S Compute the integral on (X1,X2) of a product of a function - DPFQAD-D F and the ID-th derivative of a B-spline, - (PP-representation). - - POLYVL-S Calculate the value of a polynomial and its first NDER - DPOLVL-D derivatives where the polynomial was produced by a previous - call to POLINT. - - PPQAD-S Compute the integral on (X1,X2) of a K-th order B-spline - DPPQAD-D using the piecewise polynomial (PP) representation. - - PPVAL-S Calculate the value of the IDERIV-th derivative of the - DPPVAL-D B-spline from the PP-representation. - -F. Solution of nonlinear equations -F1. Single equation -F1A. Smooth -F1A1. Polynomial -F1A1A. Real coefficients - - RPQR79-S Find the zeros of a polynomial with real coefficients. - CPQR79-C - - RPZERO-S Find the zeros of a polynomial with real coefficients. - CPZERO-C - -F1A1B. Complex coefficients - - CPQR79-C Find the zeros of a polynomial with complex coefficients. - RPQR79-S - - CPZERO-C Find the zeros of a polynomial with complex coefficients. - RPZERO-S - -F1B. General (no smoothness assumed) - - FZERO-S Search for a zero of a function F(X) in a given interval - DFZERO-D (B,C). It is designed primarily for problems where F(B) - and F(C) have opposite signs. - -F2. System of equations -F2A. Smooth - - SNSQ-S Find a zero of a system of a N nonlinear functions in N - DNSQ-D variables by a modification of the Powell hybrid method. - - SNSQE-S An easy-to-use code to find a zero of a system of N - DNSQE-D nonlinear functions in N variables by a modification of - the Powell hybrid method. - - SOS-S Solve a square system of nonlinear equations. - DSOS-D - -F3. Service routines (e.g., check user-supplied derivatives) - - CHKDER-S Check the gradients of M nonlinear functions in N - DCKDER-D variables, evaluated at a point X, for consistency - with the functions themselves. - -G. Optimization (search also classes K, L8) -G2. Constrained -G2A. Linear programming -G2A2. Sparse matrix of constraints - - SPLP-S Solve linear programming problems involving at - DSPLP-D most a few thousand constraints and variables. - Takes advantage of sparsity in the constraint matrix. - -G2E. Quadratic programming - - SBOCLS-S Solve the bounded and constrained least squares - DBOCLS-D problem consisting of solving the equation - E*X = F (in the least squares sense) - subject to the linear constraints - C*X = Y. - - SBOLS-S Solve the problem - DBOLS-D E*X = F (in the least squares sense) - with bounds on selected X values. - -G2H. General nonlinear programming -G2H1. Simple bounds - - SBOCLS-S Solve the bounded and constrained least squares - DBOCLS-D problem consisting of solving the equation - E*X = F (in the least squares sense) - subject to the linear constraints - C*X = Y. - - SBOLS-S Solve the problem - DBOLS-D E*X = F (in the least squares sense) - with bounds on selected X values. - -G2H2. Linear equality or inequality constraints - - SBOCLS-S Solve the bounded and constrained least squares - DBOCLS-D problem consisting of solving the equation - E*X = F (in the least squares sense) - subject to the linear constraints - C*X = Y. - - SBOLS-S Solve the problem - DBOLS-D E*X = F (in the least squares sense) - with bounds on selected X values. - -G4. Service routines -G4C. Check user-supplied derivatives - - CHKDER-S Check the gradients of M nonlinear functions in N - DCKDER-D variables, evaluated at a point X, for consistency - with the functions themselves. - -H. Differentiation, integration -H1. Numerical differentiation - - CHFDV-S Evaluate a cubic polynomial given in Hermite form and its - DCHFDV-D first derivative at an array of points. While designed for - use by PCHFD, it may be useful directly as an evaluator - for a piecewise cubic Hermite function in applications, - such as graphing, where the interval is known in advance. - If only function values are required, use CHFEV instead. - - PCHFD-S Evaluate a piecewise cubic Hermite function and its first - DPCHFD-D derivative at an array of points. May be used by itself - for Hermite interpolation, or as an evaluator for PCHIM - or PCHIC. If only function values are required, use - PCHFE instead. - -H2. Quadrature (numerical evaluation of definite integrals) - - QPDOC-A Documentation for QUADPACK, a package of subprograms for - automatic evaluation of one-dimensional definite integrals. - -H2A. One-dimensional integrals -H2A1. Finite interval (general integrand) -H2A1A. Integrand available via user-defined procedure -H2A1A1. Automatic (user need only specify required accuracy) - - GAUS8-S Integrate a real function of one variable over a finite - DGAUS8-D interval using an adaptive 8-point Legendre-Gauss - algorithm. Intended primarily for high accuracy - integration or integration of smooth functions. - - QAG-S The routine calculates an approximation result to a given - DQAG-D definite integral I = integral of F over (A,B), - hopefully satisfying following claim for accuracy - ABS(I-RESULT)LE.MAX(EPSABS,EPSREL*ABS(I)). - - QAGE-S The routine calculates an approximation result to a given - DQAGE-D definite integral I = Integral of F over (A,B), - hopefully satisfying following claim for accuracy - ABS(I-RESLT).LE.MAX(EPSABS,EPSREL*ABS(I)). - - QAGS-S The routine calculates an approximation result to a given - DQAGS-D Definite integral I = Integral of F over (A,B), - Hopefully satisfying following claim for accuracy - ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). - - QAGSE-S The routine calculates an approximation result to a given - DQAGSE-D definite integral I = Integral of F over (A,B), - hopefully satisfying following claim for accuracy - ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). - - QNC79-S Integrate a function using a 7-point adaptive Newton-Cotes - DQNC79-D quadrature rule. - - QNG-S The routine calculates an approximation result to a - DQNG-D given definite integral I = integral of F over (A,B), - hopefully satisfying following claim for accuracy - ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). - -H2A1A2. Nonautomatic - - QK15-S To compute I = Integral of F over (A,B), with error - DQK15-D estimate - J = integral of ABS(F) over (A,B) - - QK21-S To compute I = Integral of F over (A,B), with error - DQK21-D estimate - J = Integral of ABS(F) over (A,B) - - QK31-S To compute I = Integral of F over (A,B) with error - DQK31-D estimate - J = Integral of ABS(F) over (A,B) - - QK41-S To compute I = Integral of F over (A,B), with error - DQK41-D estimate - J = Integral of ABS(F) over (A,B) - - QK51-S To compute I = Integral of F over (A,B) with error - DQK51-D estimate - J = Integral of ABS(F) over (A,B) - - QK61-S To compute I = Integral of F over (A,B) with error - DQK61-D estimate - J = Integral of ABS(F) over (A,B) - -H2A1B. Integrand available only on grid -H2A1B2. Nonautomatic - - AVINT-S Integrate a function tabulated at arbitrarily spaced - DAVINT-D abscissas using overlapping parabolas. - - PCHIA-S Evaluate the definite integral of a piecewise cubic - DPCHIA-D Hermite function over an arbitrary interval. - - PCHID-S Evaluate the definite integral of a piecewise cubic - DPCHID-D Hermite function over an interval whose endpoints are data - points. - -H2A2. Finite interval (specific or special type integrand including weight - functions, oscillating and singular integrands, principal value - integrals, splines, etc.) -H2A2A. Integrand available via user-defined procedure -H2A2A1. Automatic (user need only specify required accuracy) - - BFQAD-S Compute the integral of a product of a function and a - DBFQAD-D derivative of a B-spline. - - BSQAD-S Compute the integral of a K-th order B-spline using the - DBSQAD-D B-representation. - - PFQAD-S Compute the integral on (X1,X2) of a product of a function - DPFQAD-D F and the ID-th derivative of a B-spline, - (PP-representation). - - PPQAD-S Compute the integral on (X1,X2) of a K-th order B-spline - DPPQAD-D using the piecewise polynomial (PP) representation. - - QAGP-S The routine calculates an approximation result to a given - DQAGP-D definite integral I = Integral of F over (A,B), - hopefully satisfying following claim for accuracy - break points of the integration interval, where local - difficulties of the integrand may occur(e.g. SINGULARITIES, - DISCONTINUITIES), are provided by the user. - - QAGPE-S Approximate a given definite integral I = Integral of F - DQAGPE-D over (A,B), hopefully satisfying the accuracy claim: - ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). - Break points of the integration interval, where local - difficulties of the integrand may occur (e.g. singularities - or discontinuities) are provided by the user. - - QAWC-S The routine calculates an approximation result to a - DQAWC-D Cauchy principal value I = INTEGRAL of F*W over (A,B) - (W(X) = 1/((X-C), C.NE.A, C.NE.B), hopefully satisfying - following claim for accuracy - ABS(I-RESULT).LE.MAX(EPSABE,EPSREL*ABS(I)). - - QAWCE-S The routine calculates an approximation result to a - DQAWCE-D CAUCHY PRINCIPAL VALUE I = Integral of F*W over (A,B) - (W(X) = 1/(X-C), (C.NE.A, C.NE.B), hopefully satisfying - following claim for accuracy - ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)) - - QAWO-S Calculate an approximation to a given definite integral - DQAWO-D I = Integral of F(X)*W(X) over (A,B), where - W(X) = COS(OMEGA*X) - or W(X) = SIN(OMEGA*X), - hopefully satisfying the following claim for accuracy - ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). - - QAWOE-S Calculate an approximation to a given definite integral - DQAWOE-D I = Integral of F(X)*W(X) over (A,B), where - W(X) = COS(OMEGA*X) - or W(X) = SIN(OMEGA*X), - hopefully satisfying the following claim for accuracy - ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). - - QAWS-S The routine calculates an approximation result to a given - DQAWS-D definite integral I = Integral of F*W over (A,B), - (where W shows a singular behaviour at the end points - see parameter INTEGR). - Hopefully satisfying following claim for accuracy - ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). - - QAWSE-S The routine calculates an approximation result to a given - DQAWSE-D definite integral I = Integral of F*W over (A,B), - (where W shows a singular behaviour at the end points, - see parameter INTEGR). - Hopefully satisfying following claim for accuracy - ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). - - QMOMO-S This routine computes modified Chebyshev moments. The K-th - DQMOMO-D modified Chebyshev moment is defined as the integral over - (-1,1) of W(X)*T(K,X), where T(K,X) is the Chebyshev - polynomial of degree K. - -H2A2A2. Nonautomatic - - QC25C-S To compute I = Integral of F*W over (A,B) with - DQC25C-D error estimate, where W(X) = 1/(X-C) - - QC25F-S To compute the integral I=Integral of F(X) over (A,B) - DQC25F-D Where W(X) = COS(OMEGA*X) Or (WX)=SIN(OMEGA*X) - and to compute J=Integral of ABS(F) over (A,B). For small - value of OMEGA or small intervals (A,B) 15-point GAUSS- - KRONROD Rule used. Otherwise generalized CLENSHAW-CURTIS us - - QC25S-S To compute I = Integral of F*W over (BL,BR), with error - DQC25S-D estimate, where the weight function W has a singular - behaviour of ALGEBRAICO-LOGARITHMIC type at the points - A and/or B. (BL,BR) is a part of (A,B). - - QK15W-S To compute I = Integral of F*W over (A,B), with error - DQK15W-D estimate - J = Integral of ABS(F*W) over (A,B) - -H2A3. Semi-infinite interval (including e**(-x) weight function) -H2A3A. Integrand available via user-defined procedure -H2A3A1. Automatic (user need only specify required accuracy) - - QAGI-S The routine calculates an approximation result to a given - DQAGI-D INTEGRAL I = Integral of F over (BOUND,+INFINITY) - OR I = Integral of F over (-INFINITY,BOUND) - OR I = Integral of F over (-INFINITY,+INFINITY) - Hopefully satisfying following claim for accuracy - ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). - - QAGIE-S The routine calculates an approximation result to a given - DQAGIE-D integral I = Integral of F over (BOUND,+INFINITY) - or I = Integral of F over (-INFINITY,BOUND) - or I = Integral of F over (-INFINITY,+INFINITY), - hopefully satisfying following claim for accuracy - ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)) - - QAWF-S The routine calculates an approximation result to a given - DQAWF-D Fourier integral - I = Integral of F(X)*W(X) over (A,INFINITY) - where W(X) = COS(OMEGA*X) or W(X) = SIN(OMEGA*X). - Hopefully satisfying following claim for accuracy - ABS(I-RESULT).LE.EPSABS. - - QAWFE-S The routine calculates an approximation result to a - DQAWFE-D given Fourier integral - I = Integral of F(X)*W(X) over (A,INFINITY) - where W(X) = COS(OMEGA*X) or W(X) = SIN(OMEGA*X), - hopefully satisfying following claim for accuracy - ABS(I-RESULT).LE.EPSABS. - -H2A3A2. Nonautomatic - - QK15I-S The original (infinite integration range is mapped - DQK15I-D onto the interval (0,1) and (A,B) is a part of (0,1). - it is the purpose to compute - I = Integral of transformed integrand over (A,B), - J = Integral of ABS(Transformed Integrand) over (A,B). - -H2A4. Infinite interval (including e**(-x**2)) weight function) -H2A4A. Integrand available via user-defined procedure -H2A4A1. Automatic (user need only specify required accuracy) - - QAGI-S The routine calculates an approximation result to a given - DQAGI-D INTEGRAL I = Integral of F over (BOUND,+INFINITY) - OR I = Integral of F over (-INFINITY,BOUND) - OR I = Integral of F over (-INFINITY,+INFINITY) - Hopefully satisfying following claim for accuracy - ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). - - QAGIE-S The routine calculates an approximation result to a given - DQAGIE-D integral I = Integral of F over (BOUND,+INFINITY) - or I = Integral of F over (-INFINITY,BOUND) - or I = Integral of F over (-INFINITY,+INFINITY), - hopefully satisfying following claim for accuracy - ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)) - -H2A4A2. Nonautomatic - - QK15I-S The original (infinite integration range is mapped - DQK15I-D onto the interval (0,1) and (A,B) is a part of (0,1). - it is the purpose to compute - I = Integral of transformed integrand over (A,B), - J = Integral of ABS(Transformed Integrand) over (A,B). - -I. Differential and integral equations -I1. Ordinary differential equations -I1A. Initial value problems -I1A1. General, nonstiff or mildly stiff -I1A1A. One-step methods (e.g., Runge-Kutta) - - DERKF-S Solve an initial value problem in ordinary differential - DDERKF-D equations using a Runge-Kutta-Fehlberg scheme. - -I1A1B. Multistep methods (e.g., Adams' predictor-corrector) - - DEABM-S Solve an initial value problem in ordinary differential - DDEABM-D equations using an Adams-Bashforth method. - - SDRIV1-S The function of SDRIV1 is to solve N (200 or fewer) - DDRIV1-D ordinary differential equations of the form - CDRIV1-C dY(I)/dT = F(Y(I),T), given the initial conditions - Y(I) = YI. SDRIV1 uses single precision arithmetic. - - SDRIV2-S The function of SDRIV2 is to solve N ordinary differential - DDRIV2-D equations of the form dY(I)/dT = F(Y(I),T), given the - CDRIV2-C initial conditions Y(I) = YI. The program has options to - allow the solution of both stiff and non-stiff differential - equations. SDRIV2 uses single precision arithmetic. - - SDRIV3-S The function of SDRIV3 is to solve N ordinary differential - DDRIV3-D equations of the form dY(I)/dT = F(Y(I),T), given the - CDRIV3-C initial conditions Y(I) = YI. The program has options to - allow the solution of both stiff and non-stiff differential - equations. Other important options are available. SDRIV3 - uses single precision arithmetic. - - SINTRP-S Approximate the solution at XOUT by evaluating the - DINTP-D polynomial computed in STEPS at XOUT. Must be used in - conjunction with STEPS. - - STEPS-S Integrate a system of first order ordinary differential - DSTEPS-D equations one step. - -I1A2. Stiff and mixed algebraic-differential equations - - DEBDF-S Solve an initial value problem in ordinary differential - DDEBDF-D equations using backward differentiation formulas. It is - intended primarily for stiff problems. - - SDASSL-S This code solves a system of differential/algebraic - DDASSL-D equations of the form G(T,Y,YPRIME) = 0. - - SDRIV1-S The function of SDRIV1 is to solve N (200 or fewer) - DDRIV1-D ordinary differential equations of the form - CDRIV1-C dY(I)/dT = F(Y(I),T), given the initial conditions - Y(I) = YI. SDRIV1 uses single precision arithmetic. - - SDRIV2-S The function of SDRIV2 is to solve N ordinary differential - DDRIV2-D equations of the form dY(I)/dT = F(Y(I),T), given the - CDRIV2-C initial conditions Y(I) = YI. The program has options to - allow the solution of both stiff and non-stiff differential - equations. SDRIV2 uses single precision arithmetic. - - SDRIV3-S The function of SDRIV3 is to solve N ordinary differential - DDRIV3-D equations of the form dY(I)/dT = F(Y(I),T), given the - CDRIV3-C initial conditions Y(I) = YI. The program has options to - allow the solution of both stiff and non-stiff differential - equations. Other important options are available. SDRIV3 - uses single precision arithmetic. - -I1B. Multipoint boundary value problems -I1B1. Linear - - BVSUP-S Solve a linear two-point boundary value problem using - DBVSUP-D superposition coupled with an orthonormalization procedure - and a variable-step integration scheme. - -I2. Partial differential equations -I2B. Elliptic boundary value problems -I2B1. Linear -I2B1A. Second order -I2B1A1. Poisson (Laplace) or Helmholz equation -I2B1A1A. Rectangular domain (or topologically rectangular in the coordinate - system) - - HSTCRT-S Solve the standard five-point finite difference - approximation on a staggered grid to the Helmholtz equation - in Cartesian coordinates. - - HSTCSP-S Solve the standard five-point finite difference - approximation on a staggered grid to the modified Helmholtz - equation in spherical coordinates assuming axisymmetry - (no dependence on longitude). - - HSTCYL-S Solve the standard five-point finite difference - approximation on a staggered grid to the modified - Helmholtz equation in cylindrical coordinates. - - HSTPLR-S Solve the standard five-point finite difference - approximation on a staggered grid to the Helmholtz equation - in polar coordinates. - - HSTSSP-S Solve the standard five-point finite difference - approximation on a staggered grid to the Helmholtz - equation in spherical coordinates and on the surface of - the unit sphere (radius of 1). - - HW3CRT-S Solve the standard seven-point finite difference - approximation to the Helmholtz equation in Cartesian - coordinates. - - HWSCRT-S Solves the standard five-point finite difference - approximation to the Helmholtz equation in Cartesian - coordinates. - - HWSCSP-S Solve a finite difference approximation to the modified - Helmholtz equation in spherical coordinates assuming - axisymmetry (no dependence on longitude). - - HWSCYL-S Solve a standard finite difference approximation - to the Helmholtz equation in cylindrical coordinates. - - HWSPLR-S Solve a finite difference approximation to the Helmholtz - equation in polar coordinates. - - HWSSSP-S Solve a finite difference approximation to the Helmholtz - equation in spherical coordinates and on the surface of the - unit sphere (radius of 1). - -I2B1A2. Other separable problems - - SEPELI-S Discretize and solve a second and, optionally, a fourth - order finite difference approximation on a uniform grid to - the general separable elliptic partial differential - equation on a rectangle with any combination of periodic or - mixed boundary conditions. - - SEPX4-S Solve for either the second or fourth order finite - difference approximation to the solution of a separable - elliptic partial differential equation on a rectangle. - Any combination of periodic or mixed boundary conditions is - allowed. - -I2B4. Service routines -I2B4B. Solution of discretized elliptic equations - - BLKTRI-S Solve a block tridiagonal system of linear equations - CBLKTR-C (usually resulting from the discretization of separable - two-dimensional elliptic equations). - - GENBUN-S Solve by a cyclic reduction algorithm the linear system - CMGNBN-C of equations that results from a finite difference - approximation to certain 2-d elliptic PDE's on a centered - grid . - - POIS3D-S Solve a three-dimensional block tridiagonal linear system - which arises from a finite difference approximation to a - three-dimensional Poisson equation using the Fourier - transform package FFTPAK written by Paul Swarztrauber. - - POISTG-S Solve a block tridiagonal system of linear equations - that results from a staggered grid finite difference - approximation to 2-D elliptic PDE's. - -J. Integral transforms -J1. Fast Fourier transforms (search class L10 for time series analysis) - - FFTDOC-A Documentation for FFTPACK, a collection of Fast Fourier - Transform routines. - -J1A. One-dimensional -J1A1. Real - - EZFFTB-S A simplified real, periodic, backward fast Fourier - transform. - - EZFFTF-S Compute a simplified real, periodic, fast Fourier forward - transform. - - EZFFTI-S Initialize a work array for EZFFTF and EZFFTB. - - RFFTB1-S Compute the backward fast Fourier transform of a real - CFFTB1-C coefficient array. - - RFFTF1-S Compute the forward transform of a real, periodic sequence. - CFFTF1-C - - RFFTI1-S Initialize a real and an integer work array for RFFTF1 and - CFFTI1-C RFFTB1. - -J1A2. Complex - - CFFTB1-C Compute the unnormalized inverse of CFFTF1. - RFFTB1-S - - CFFTF1-C Compute the forward transform of a complex, periodic - RFFTF1-S sequence. - - CFFTI1-C Initialize a real and an integer work array for CFFTF1 and - RFFTI1-S CFFTB1. - -J1A3. Trigonometric (sine, cosine) - - COSQB-S Compute the unnormalized inverse cosine transform. - - COSQF-S Compute the forward cosine transform with odd wave numbers. - - COSQI-S Initialize a work array for COSQF and COSQB. - - COST-S Compute the cosine transform of a real, even sequence. - - COSTI-S Initialize a work array for COST. - - SINQB-S Compute the unnormalized inverse of SINQF. - - SINQF-S Compute the forward sine transform with odd wave numbers. - - SINQI-S Initialize a work array for SINQF and SINQB. - - SINT-S Compute the sine transform of a real, odd sequence. - - SINTI-S Initialize a work array for SINT. - -J4. Hilbert transforms - - QAWC-S The routine calculates an approximation result to a - DQAWC-D Cauchy principal value I = INTEGRAL of F*W over (A,B) - (W(X) = 1/((X-C), C.NE.A, C.NE.B), hopefully satisfying - following claim for accuracy - ABS(I-RESULT).LE.MAX(EPSABE,EPSREL*ABS(I)). - - QAWCE-S The routine calculates an approximation result to a - DQAWCE-D CAUCHY PRINCIPAL VALUE I = Integral of F*W over (A,B) - (W(X) = 1/(X-C), (C.NE.A, C.NE.B), hopefully satisfying - following claim for accuracy - ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)) - - QC25C-S To compute I = Integral of F*W over (A,B) with - DQC25C-D error estimate, where W(X) = 1/(X-C) - -K. Approximation (search also class L8) - - BSPDOC-A Documentation for BSPLINE, a package of subprograms for - working with piecewise polynomial functions - in B-representation. - -K1. Least squares (L-2) approximation -K1A. Linear least squares (search also classes D5, D6, D9) -K1A1. Unconstrained -K1A1A. Univariate data (curve fitting) -K1A1A1. Polynomial splines (piecewise polynomials) - - EFC-S Fit a piecewise polynomial curve to discrete data. - DEFC-D The piecewise polynomials are represented as B-splines. - The fitting is done in a weighted least squares sense. - - FC-S Fit a piecewise polynomial curve to discrete data. - DFC-D The piecewise polynomials are represented as B-splines. - The fitting is done in a weighted least squares sense. - Equality and inequality constraints can be imposed on the - fitted curve. - -K1A1A2. Polynomials - - PCOEF-S Convert the POLFIT coefficients to Taylor series form. - DPCOEF-D - - POLFIT-S Fit discrete data in a least squares sense by polynomials - DPOLFT-D in one variable. - -K1A2. Constrained -K1A2A. Linear constraints - - EFC-S Fit a piecewise polynomial curve to discrete data. - DEFC-D The piecewise polynomials are represented as B-splines. - The fitting is done in a weighted least squares sense. - - FC-S Fit a piecewise polynomial curve to discrete data. - DFC-D The piecewise polynomials are represented as B-splines. - The fitting is done in a weighted least squares sense. - Equality and inequality constraints can be imposed on the - fitted curve. - - LSEI-S Solve a linearly constrained least squares problem with - DLSEI-D equality and inequality constraints, and optionally compute - a covariance matrix. - - SBOCLS-S Solve the bounded and constrained least squares - DBOCLS-D problem consisting of solving the equation - E*X = F (in the least squares sense) - subject to the linear constraints - C*X = Y. - - SBOLS-S Solve the problem - DBOLS-D E*X = F (in the least squares sense) - with bounds on selected X values. - - WNNLS-S Solve a linearly constrained least squares problem with - DWNNLS-D equality constraints and nonnegativity constraints on - selected variables. - -K1B. Nonlinear least squares -K1B1. Unconstrained - - SCOV-S Calculate the covariance matrix for a nonlinear data - DCOV-D fitting problem. It is intended to be used after a - successful return from either SNLS1 or SNLS1E. - -K1B1A. Smooth functions -K1B1A1. User provides no derivatives - - SNLS1-S Minimize the sum of the squares of M nonlinear functions - DNLS1-D in N variables by a modification of the Levenberg-Marquardt - algorithm. - - SNLS1E-S An easy-to-use code which minimizes the sum of the squares - DNLS1E-D of M nonlinear functions in N variables by a modification - of the Levenberg-Marquardt algorithm. - -K1B1A2. User provides first derivatives - - SNLS1-S Minimize the sum of the squares of M nonlinear functions - DNLS1-D in N variables by a modification of the Levenberg-Marquardt - algorithm. - - SNLS1E-S An easy-to-use code which minimizes the sum of the squares - DNLS1E-D of M nonlinear functions in N variables by a modification - of the Levenberg-Marquardt algorithm. - -K6. Service routines (e.g., mesh generation, evaluation of fitted functions) - (search also class N5) - - BFQAD-S Compute the integral of a product of a function and a - DBFQAD-D derivative of a B-spline. - - DBSPDR-D Use the B-representation to construct a divided difference - BSPDR-S table preparatory to a (right) derivative calculation. - - BSPEV-S Calculate the value of the spline and its derivatives from - DBSPEV-D the B-representation. - - BSPPP-S Convert the B-representation of a B-spline to the piecewise - DBSPPP-D polynomial (PP) form. - - BSPVD-S Calculate the value and all derivatives of order less than - DBSPVD-D NDERIV of all basis functions which do not vanish at X. - - BSPVN-S Calculate the value of all (possibly) nonzero basis - DBSPVN-D functions at X. - - BSQAD-S Compute the integral of a K-th order B-spline using the - DBSQAD-D B-representation. - - BVALU-S Evaluate the B-representation of a B-spline at X for the - DBVALU-D function value or any of its derivatives. - - INTRV-S Compute the largest integer ILEFT in 1 .LE. ILEFT .LE. LXT - DINTRV-D such that XT(ILEFT) .LE. X where XT(*) is a subdivision - of the X interval. - - PFQAD-S Compute the integral on (X1,X2) of a product of a function - DPFQAD-D F and the ID-th derivative of a B-spline, - (PP-representation). - - PPQAD-S Compute the integral on (X1,X2) of a K-th order B-spline - DPPQAD-D using the piecewise polynomial (PP) representation. - - PPVAL-S Calculate the value of the IDERIV-th derivative of the - DPPVAL-D B-spline from the PP-representation. - - PVALUE-S Use the coefficients generated by POLFIT to evaluate the - DP1VLU-D polynomial fit of degree L, along with the first NDER of - its derivatives, at a specified point. - -L. Statistics, probability -L5. Function evaluation (search also class C) -L5A. Univariate -L5A1. Cumulative distribution functions, probability density functions -L5A1E. Error function, exponential, extreme value - - ERF-S Compute the error function. - DERF-D - - ERFC-S Compute the complementary error function. - DERFC-D - -L6. Pseudo-random number generation -L6A. Univariate -L6A14. Negative binomial, normal - - RGAUSS-S Generate a normally distributed (Gaussian) random number. - -L6A21. Uniform - - RAND-S Generate a uniformly distributed random number. - - RUNIF-S Generate a uniformly distributed random number. - -L7. Experimental design, including analysis of variance -L7A. Univariate -L7A3. Analysis of covariance - - CV-S Evaluate the variance function of the curve obtained - DCV-D by the constrained B-spline fitting subprogram FC. - -L8. Regression (search also classes G, K) -L8A. Linear least squares (L-2) (search also classes D5, D6, D9) -L8A3. Piecewise polynomial (i.e. multiphase or spline) - - EFC-S Fit a piecewise polynomial curve to discrete data. - DEFC-D The piecewise polynomials are represented as B-splines. - The fitting is done in a weighted least squares sense. - - FC-S Fit a piecewise polynomial curve to discrete data. - DFC-D The piecewise polynomials are represented as B-splines. - The fitting is done in a weighted least squares sense. - Equality and inequality constraints can be imposed on the - fitted curve. - -N. Data handling (search also class L2) -N1. Input, output - - SBHIN-S Read a Sparse Linear System in the Boeing/Harwell Format. - DBHIN-D The matrix is read in and if the right hand side is also - present in the input file then it too is read in. The - matrix is then modified to be in the SLAP Column format. - - SCPPLT-S Printer Plot of SLAP Column Format Matrix. - DCPPLT-D Routine to print out a SLAP Column format matrix in a - "printer plot" graphical representation. - - STIN-S Read in SLAP Triad Format Linear System. - DTIN-D Routine to read in a SLAP Triad format matrix and right - hand side and solution to the system, if known. - - STOUT-S Write out SLAP Triad Format Linear System. - DTOUT-D Routine to write out a SLAP Triad format matrix and right - hand side and solution to the system, if known. - -N6. Sorting -N6A. Internal -N6A1. Passive (i.e. construct pointer array, rank) -N6A1A. Integer - - IPSORT-I Return the permutation vector generated by sorting a given - SPSORT-S array and, optionally, rearrange the elements of the array. - DPSORT-D The array may be sorted in increasing or decreasing order. - HPSORT-H A slightly modified quicksort algorithm is used. - -N6A1B. Real - - SPSORT-S Return the permutation vector generated by sorting a given - DPSORT-D array and, optionally, rearrange the elements of the array. - IPSORT-I The array may be sorted in increasing or decreasing order. - HPSORT-H A slightly modified quicksort algorithm is used. - -N6A1C. Character - - HPSORT-H Return the permutation vector generated by sorting a - SPSORT-S substring within a character array and, optionally, - DPSORT-D rearrange the elements of the array. The array may be - IPSORT-I sorted in forward or reverse lexicographical order. A - slightly modified quicksort algorithm is used. - -N6A2. Active -N6A2A. Integer - - IPSORT-I Return the permutation vector generated by sorting a given - SPSORT-S array and, optionally, rearrange the elements of the array. - DPSORT-D The array may be sorted in increasing or decreasing order. - HPSORT-H A slightly modified quicksort algorithm is used. - - ISORT-I Sort an array and optionally make the same interchanges in - SSORT-S an auxiliary array. The array may be sorted in increasing - DSORT-D or decreasing order. A slightly modified QUICKSORT - algorithm is used. - -N6A2B. Real - - SPSORT-S Return the permutation vector generated by sorting a given - DPSORT-D array and, optionally, rearrange the elements of the array. - IPSORT-I The array may be sorted in increasing or decreasing order. - HPSORT-H A slightly modified quicksort algorithm is used. - - SSORT-S Sort an array and optionally make the same interchanges in - DSORT-D an auxiliary array. The array may be sorted in increasing - ISORT-I or decreasing order. A slightly modified QUICKSORT - algorithm is used. - -N6A2C. Character - - HPSORT-H Return the permutation vector generated by sorting a - SPSORT-S substring within a character array and, optionally, - DPSORT-D rearrange the elements of the array. The array may be - IPSORT-I sorted in forward or reverse lexicographical order. A - slightly modified quicksort algorithm is used. - -N8. Permuting - - SPPERM-S Rearrange a given array according to a prescribed - DPPERM-D permutation vector. - IPPERM-I - HPPERM-H - -R. Service routines -R1. Machine-dependent constants - - I1MACH-I Return integer machine dependent constants. - - R1MACH-S Return floating point machine dependent constants. - D1MACH-D - -R2. Error checking (e.g., check monotonicity) - - GAMLIM-S Compute the minimum and maximum bounds for the argument in - DGAMLM-D the Gamma function. - -R3. Error handling - - FDUMP-A Symbolic dump (should be locally written). - -R3A. Set criteria for fatal errors - - XSETF-A Set the error control flag. - -R3B. Set unit number for error messages - - XSETUA-A Set logical unit numbers (up to 5) to which error - messages are to be sent. - - XSETUN-A Set output file to which error messages are to be sent. - -R3C. Other utility programs - - NUMXER-I Return the most recent error number. - - XERCLR-A Reset current error number to zero. - - XERDMP-A Print the error tables and then clear them. - - XERMAX-A Set maximum number of times any error message is to be - printed. - - XERMSG-A Process error messages for SLATEC and other libraries. - - XGETF-A Return the current value of the error control flag. - - XGETUA-A Return unit number(s) to which error messages are being - sent. - - XGETUN-A Return the (first) output file to which error messages - are being sent. - -Z. Other - - AAAAAA-A SLATEC Common Mathematical Library disclaimer and version. - - BSPDOC-A Documentation for BSPLINE, a package of subprograms for - working with piecewise polynomial functions - in B-representation. - - EISDOC-A Documentation for EISPACK, a collection of subprograms for - solving matrix eigen-problems. - - FFTDOC-A Documentation for FFTPACK, a collection of Fast Fourier - Transform routines. - - FUNDOC-A Documentation for FNLIB, a collection of routines for - evaluating elementary and special functions. - - PCHDOC-A Documentation for PCHIP, a Fortran package for piecewise - cubic Hermite interpolation of data. - - QPDOC-A Documentation for QUADPACK, a package of subprograms for - automatic evaluation of one-dimensional definite integrals. - - SLPDOC-S Sparse Linear Algebra Package Version 2.0.2 Documentation. - DLPDOC-D Routines to solve large sparse symmetric and nonsymmetric - positive definite linear systems, Ax = b, using precondi- - tioned iterative methods. - - - SECTION II. Subsidiary Routines - - ASYIK Subsidiary to BESI and BESK - - ASYJY Subsidiary to BESJ and BESY - - BCRH Subsidiary to CBLKTR - - BDIFF Subsidiary to BSKIN - - BESKNU Subsidiary to BESK - - BESYNU Subsidiary to BESY - - BKIAS Subsidiary to BSKIN - - BKISR Subsidiary to BSKIN - - BKSOL Subsidiary to BVSUP - - BLKTR1 Subsidiary to BLKTRI - - BNFAC Subsidiary to BINT4 and BINTK - - BNSLV Subsidiary to BINT4 and BINTK - - BSGQ8 Subsidiary to BFQAD - - BSPLVD Subsidiary to FC - - BSPLVN Subsidiary to FC - - BSRH Subsidiary to BLKTRI - - BVDER Subsidiary to BVSUP - - BVPOR Subsidiary to BVSUP - - C1MERG Merge two strings of complex numbers. Each string is - ascending by the real part. - - C9LGMC Compute the log gamma correction factor so that - LOG(CGAMMA(Z)) = 0.5*LOG(2.*PI) + (Z-0.5)*LOG(Z) - Z - + C9LGMC(Z). - - C9LN2R Evaluate LOG(1+Z) from second order relative accuracy so - that LOG(1+Z) = Z - Z**2/2 + Z**3*C9LN2R(Z). - - CACAI Subsidiary to CAIRY - - CACON Subsidiary to CBESH and CBESK - - CASYI Subsidiary to CBESI and CBESK - - CBINU Subsidiary to CAIRY, CBESH, CBESI, CBESJ, CBESK and CBIRY - - CBKNU Subsidiary to CAIRY, CBESH, CBESI and CBESK - - CBLKT1 Subsidiary to CBLKTR - - CBUNI Subsidiary to CBESI and CBESK - - CBUNK Subsidiary to CBESH and CBESK - - CCMPB Subsidiary to CBLKTR - - CDCOR Subroutine CDCOR computes corrections to the Y array. - - CDCST CDCST sets coefficients used by the core integrator CDSTP. - - CDIV Compute the complex quotient of two complex numbers. - - CDNTL Subroutine CDNTL is called to set parameters on the first - call to CDSTP, on an internal restart, or when the user has - altered MINT, MITER, and/or H. - - CDNTP Subroutine CDNTP interpolates the K-th derivative of Y at - TOUT, using the data in the YH array. If K has a value - greater than NQ, the NQ-th derivative is calculated. - - CDPSC Subroutine CDPSC computes the predicted YH values by - effectively multiplying the YH array by the Pascal triangle - matrix when KSGN is +1, and performs the inverse function - when KSGN is -1. - - CDPST Subroutine CDPST evaluates the Jacobian matrix of the right - hand side of the differential equations. - - CDSCL Subroutine CDSCL rescales the YH array whenever the step - size is changed. - - CDSTP CDSTP performs one step of the integration of an initial - value problem for a system of ordinary differential - equations. - - CDZRO CDZRO searches for a zero of a function F(N, T, Y, IROOT) - between the given values B and C until the width of the - interval (B, C) has collapsed to within a tolerance - specified by the stopping criterion, - ABS(B - C) .LE. 2.*(RW*ABS(B) + AE). - - CFFTB Compute the unnormalized inverse of CFFTF. - - CFFTF Compute the forward transform of a complex, periodic - sequence. - - CFFTI Initialize a work array for CFFTF and CFFTB. - - CFOD Subsidiary to DEBDF - - CHFCM Check a single cubic for monotonicity. - - CHFIE Evaluates integral of a single cubic for PCHIA - - CHKPR4 Subsidiary to SEPX4 - - CHKPRM Subsidiary to SEPELI - - CHKSN4 Subsidiary to SEPX4 - - CHKSNG Subsidiary to SEPELI - - CKSCL Subsidiary to CBKNU, CUNK1 and CUNK2 - - CMLRI Subsidiary to CBESI and CBESK - - CMPCSG Subsidiary to CMGNBN - - CMPOSD Subsidiary to CMGNBN - - CMPOSN Subsidiary to CMGNBN - - CMPOSP Subsidiary to CMGNBN - - CMPTR3 Subsidiary to CMGNBN - - CMPTRX Subsidiary to CMGNBN - - COMPB Subsidiary to BLKTRI - - COSGEN Subsidiary to GENBUN - - COSQB1 Compute the unnormalized inverse of COSQF1. - - COSQF1 Compute the forward cosine transform with odd wave numbers. - - CPADD Subsidiary to CBLKTR - - CPEVL Subsidiary to CPZERO - - CPEVLR Subsidiary to CPZERO - - CPROC Subsidiary to CBLKTR - - CPROCP Subsidiary to CBLKTR - - CPROD Subsidiary to BLKTRI - - CPRODP Subsidiary to BLKTRI - - CRATI Subsidiary to CBESH, CBESI and CBESK - - CS1S2 Subsidiary to CAIRY and CBESK - - CSCALE Subsidiary to BVSUP - - CSERI Subsidiary to CBESI and CBESK - - CSHCH Subsidiary to CBESH and CBESK - - CSROOT Compute the complex square root of a complex number. - - CUCHK Subsidiary to SERI, CUOIK, CUNK1, CUNK2, CUNI1, CUNI2 and - CKSCL - - CUNHJ Subsidiary to CBESI and CBESK - - CUNI1 Subsidiary to CBESI and CBESK - - CUNI2 Subsidiary to CBESI and CBESK - - CUNIK Subsidiary to CBESI and CBESK - - CUNK1 Subsidiary to CBESK - - CUNK2 Subsidiary to CBESK - - CUOIK Subsidiary to CBESH, CBESI and CBESK - - CWRSK Subsidiary to CBESI and CBESK - - D1MERG Merge two strings of ascending double precision numbers. - - D1MPYQ Subsidiary to DNSQ and DNSQE - - D1UPDT Subsidiary to DNSQ and DNSQE - - D9AIMP Evaluate the Airy modulus and phase. - - D9ATN1 Evaluate DATAN(X) from first order relative accuracy so - that DATAN(X) = X + X**3*D9ATN1(X). - - D9B0MP Evaluate the modulus and phase for the J0 and Y0 Bessel - functions. - - D9B1MP Evaluate the modulus and phase for the J1 and Y1 Bessel - functions. - - D9CHU Evaluate for large Z Z**A * U(A,B,Z) where U is the - logarithmic confluent hypergeometric function. - - D9GMIC Compute the complementary incomplete Gamma function for A - near a negative integer and X small. - - D9GMIT Compute Tricomi's incomplete Gamma function for small - arguments. - - D9KNUS Compute Bessel functions EXP(X)*K-SUB-XNU(X) and EXP(X)* - K-SUB-XNU+1(X) for 0.0 .LE. XNU .LT. 1.0. - - D9LGIC Compute the log complementary incomplete Gamma function - for large X and for A .LE. X. - - D9LGIT Compute the logarithm of Tricomi's incomplete Gamma - function with Perron's continued fraction for large X and - A .GE. X. - - D9LGMC Compute the log Gamma correction factor so that - LOG(DGAMMA(X)) = LOG(SQRT(2*PI)) + (X-5.)*LOG(X) - X - + D9LGMC(X). - - D9LN2R Evaluate LOG(1+X) from second order relative accuracy so - that LOG(1+X) = X - X**2/2 + X**3*D9LN2R(X) - - DASYIK Subsidiary to DBESI and DBESK - - DASYJY Subsidiary to DBESJ and DBESY - - DBDIFF Subsidiary to DBSKIN - - DBKIAS Subsidiary to DBSKIN - - DBKISR Subsidiary to DBSKIN - - DBKSOL Subsidiary to DBVSUP - - DBNFAC Subsidiary to DBINT4 and DBINTK - - DBNSLV Subsidiary to DBINT4 and DBINTK - - DBOLSM Subsidiary to DBOCLS and DBOLS - - DBSGQ8 Subsidiary to DBFQAD - - DBSKNU Subsidiary to DBESK - - DBSYNU Subsidiary to DBESY - - DBVDER Subsidiary to DBVSUP - - DBVPOR Subsidiary to DBVSUP - - DCFOD Subsidiary to DDEBDF - - DCHFCM Check a single cubic for monotonicity. - - DCHFIE Evaluates integral of a single cubic for DPCHIA - - DCHKW SLAP WORK/IWORK Array Bounds Checker. - This routine checks the work array lengths and interfaces - to the SLATEC error handler if a problem is found. - - DCOEF Subsidiary to DBVSUP - - DCSCAL Subsidiary to DBVSUP and DSUDS - - DDAINI Initialization routine for DDASSL. - - DDAJAC Compute the iteration matrix for DDASSL and form the - LU-decomposition. - - DDANRM Compute vector norm for DDASSL. - - DDASLV Linear system solver for DDASSL. - - DDASTP Perform one step of the DDASSL integration. - - DDATRP Interpolation routine for DDASSL. - - DDAWTS Set error weight vector for DDASSL. - - DDCOR Subroutine DDCOR computes corrections to the Y array. - - DDCST DDCST sets coefficients used by the core integrator DDSTP. - - DDES Subsidiary to DDEABM - - DDNTL Subroutine DDNTL is called to set parameters on the first - call to DDSTP, on an internal restart, or when the user has - altered MINT, MITER, and/or H. - - DDNTP Subroutine DDNTP interpolates the K-th derivative of Y at - TOUT, using the data in the YH array. If K has a value - greater than NQ, the NQ-th derivative is calculated. - - DDOGLG Subsidiary to DNSQ and DNSQE - - DDPSC Subroutine DDPSC computes the predicted YH values by - effectively multiplying the YH array by the Pascal triangle - matrix when KSGN is +1, and performs the inverse function - when KSGN is -1. - - DDPST Subroutine DDPST evaluates the Jacobian matrix of the right - hand side of the differential equations. - - DDSCL Subroutine DDSCL rescales the YH array whenever the step - size is changed. - - DDSTP DDSTP performs one step of the integration of an initial - value problem for a system of ordinary differential - equations. - - DDZRO DDZRO searches for a zero of a function F(N, T, Y, IROOT) - between the given values B and C until the width of the - interval (B, C) has collapsed to within a tolerance - specified by the stopping criterion, - ABS(B - C) .LE. 2.*(RW*ABS(B) + AE). - - DEFCMN Subsidiary to DEFC - - DEFE4 Subsidiary to SEPX4 - - DEFEHL Subsidiary to DERKF - - DEFER Subsidiary to SEPELI - - DENORM Subsidiary to DNSQ and DNSQE - - DERKFS Subsidiary to DERKF - - DES Subsidiary to DEABM - - DEXBVP Subsidiary to DBVSUP - - DFCMN Subsidiary to FC - - DFDJC1 Subsidiary to DNSQ and DNSQE - - DFDJC3 Subsidiary to DNLS1 and DNLS1E - - DFEHL Subsidiary to DDERKF - - DFSPVD Subsidiary to DFC - - DFSPVN Subsidiary to DFC - - DFULMT Subsidiary to DSPLP - - DGAMLN Compute the logarithm of the Gamma function - - DGAMRN Subsidiary to DBSKIN - - DH12 Subsidiary to DHFTI, DLSEI and DWNNLS - - DHELS Internal routine for DGMRES. - - DHEQR Internal routine for DGMRES. - - DHKSEQ Subsidiary to DBSKIN - - DHSTRT Subsidiary to DDEABM, DDEBDF and DDERKF - - DHVNRM Subsidiary to DDEABM, DDEBDF and DDERKF - - DINTYD Subsidiary to DDEBDF - - DJAIRY Subsidiary to DBESJ and DBESY - - DLPDP Subsidiary to DLSEI - - DLSI Subsidiary to DLSEI - - DLSOD Subsidiary to DDEBDF - - DLSSUD Subsidiary to DBVSUP and DSUDS - - DMACON Subsidiary to DBVSUP - - DMGSBV Subsidiary to DBVSUP - - DMOUT Subsidiary to DBOCLS and DFC - - DMPAR Subsidiary to DNLS1 and DNLS1E - - DOGLEG Subsidiary to SNSQ and SNSQE - - DOHTRL Subsidiary to DBVSUP and DSUDS - - DORTH Internal routine for DGMRES. - - DORTHR Subsidiary to DBVSUP and DSUDS - - DPCHCE Set boundary conditions for DPCHIC - - DPCHCI Set interior derivatives for DPCHIC - - DPCHCS Adjusts derivative values for DPCHIC - - DPCHDF Computes divided differences for DPCHCE and DPCHSP - - DPCHKT Compute B-spline knot sequence for DPCHBS. - - DPCHNG Subsidiary to DSPLP - - DPCHST DPCHIP Sign-Testing Routine - - DPCHSW Limits excursion from data for DPCHCS - - DPIGMR Internal routine for DGMRES. - - DPINCW Subsidiary to DSPLP - - DPINIT Subsidiary to DSPLP - - DPINTM Subsidiary to DSPLP - - DPJAC Subsidiary to DDEBDF - - DPLPCE Subsidiary to DSPLP - - DPLPDM Subsidiary to DSPLP - - DPLPFE Subsidiary to DSPLP - - DPLPFL Subsidiary to DSPLP - - DPLPMN Subsidiary to DSPLP - - DPLPMU Subsidiary to DSPLP - - DPLPUP Subsidiary to DSPLP - - DPNNZR Subsidiary to DSPLP - - DPOPT Subsidiary to DSPLP - - DPPGQ8 Subsidiary to DPFQAD - - DPRVEC Subsidiary to DBVSUP - - DPRWPG Subsidiary to DSPLP - - DPRWVR Subsidiary to DSPLP - - DPSIXN Subsidiary to DEXINT - - DQCHEB This routine computes the CHEBYSHEV series expansion - of degrees 12 and 24 of a function using A - FAST FOURIER TRANSFORM METHOD - F(X) = SUM(K=1,..,13) (CHEB12(K)*T(K-1,X)), - F(X) = SUM(K=1,..,25) (CHEB24(K)*T(K-1,X)), - Where T(K,X) is the CHEBYSHEV POLYNOMIAL OF DEGREE K. - - DQELG The routine determines the limit of a given sequence of - approximations, by means of the Epsilon algorithm of - P.Wynn. An estimate of the absolute error is also given. - The condensed Epsilon table is computed. Only those - elements needed for the computation of the next diagonal - are preserved. - - DQFORM Subsidiary to DNSQ and DNSQE - - DQPSRT This routine maintains the descending ordering in the - list of the local error estimated resulting from the - interval subdivision process. At each call two error - estimates are inserted using the sequential search - method, top-down for the largest error estimate and - bottom-up for the smallest error estimate. - - DQRFAC Subsidiary to DNLS1, DNLS1E, DNSQ and DNSQE - - DQRSLV Subsidiary to DNLS1 and DNLS1E - - DQWGTC This function subprogram is used together with the - routine DQAWC and defines the WEIGHT function. - - DQWGTF This function subprogram is used together with the - routine DQAWF and defines the WEIGHT function. - - DQWGTS This function subprogram is used together with the - routine DQAWS and defines the WEIGHT function. - - DREADP Subsidiary to DSPLP - - DREORT Subsidiary to DBVSUP - - DRKFAB Subsidiary to DBVSUP - - DRKFS Subsidiary to DDERKF - - DRLCAL Internal routine for DGMRES. - - DRSCO Subsidiary to DDEBDF - - DSLVS Subsidiary to DDEBDF - - DSOSEQ Subsidiary to DSOS - - DSOSSL Subsidiary to DSOS - - DSTOD Subsidiary to DDEBDF - - DSTOR1 Subsidiary to DBVSUP - - DSTWAY Subsidiary to DBVSUP - - DSUDS Subsidiary to DBVSUP - - DSVCO Subsidiary to DDEBDF - - DU11LS Subsidiary to DLLSIA - - DU11US Subsidiary to DULSIA - - DU12LS Subsidiary to DLLSIA - - DU12US Subsidiary to DULSIA - - DUSRMT Subsidiary to DSPLP - - DVECS Subsidiary to DBVSUP - - DVNRMS Subsidiary to DDEBDF - - DVOUT Subsidiary to DSPLP - - DWNLIT Subsidiary to DWNNLS - - DWNLSM Subsidiary to DWNNLS - - DWNLT1 Subsidiary to WNLIT - - DWNLT2 Subsidiary to WNLIT - - DWNLT3 Subsidiary to WNLIT - - DWRITP Subsidiary to DSPLP - - DWUPDT Subsidiary to DNLS1 and DNLS1E - - DX Subsidiary to SEPELI - - DX4 Subsidiary to SEPX4 - - DXLCAL Internal routine for DGMRES. - - DXPMU To compute the values of Legendre functions for DXLEGF. - Method: backward mu-wise recurrence for P(-MU,NU,X) for - fixed nu to obtain P(-MU2,NU1,X), P(-(MU2-1),NU1,X), ..., - P(-MU1,NU1,X) and store in ascending mu order. - - DXPMUP To compute the values of Legendre functions for DXLEGF. - This subroutine transforms an array of Legendre functions - of the first kind of negative order stored in array PQA - into Legendre functions of the first kind of positive - order stored in array PQA. The original array is destroyed. - - DXPNRM To compute the values of Legendre functions for DXLEGF. - This subroutine transforms an array of Legendre functions - of the first kind of negative order stored in array PQA - into normalized Legendre polynomials stored in array PQA. - The original array is destroyed. - - DXPQNU To compute the values of Legendre functions for DXLEGF. - This subroutine calculates initial values of P or Q using - power series, then performs forward nu-wise recurrence to - obtain P(-MU,NU,X), Q(0,NU,X), or Q(1,NU,X). The nu-wise - recurrence is stable for P for all mu and for Q for mu=0,1. - - DXPSI To compute values of the Psi function for DXLEGF. - - DXQMU To compute the values of Legendre functions for DXLEGF. - Method: forward mu-wise recurrence for Q(MU,NU,X) for fixed - nu to obtain Q(MU1,NU,X), Q(MU1+1,NU,X), ..., Q(MU2,NU,X). - - DXQNU To compute the values of Legendre functions for DXLEGF. - Method: backward nu-wise recurrence for Q(MU,NU,X) for - fixed mu to obtain Q(MU1,NU1,X), Q(MU1,NU1+1,X), ..., - Q(MU1,NU2,X). - - DY Subsidiary to SEPELI - - DY4 Subsidiary to SEPX4 - - DYAIRY Subsidiary to DBESJ and DBESY - - EFCMN Subsidiary to EFC - - ENORM Subsidiary to SNLS1, SNLS1E, SNSQ and SNSQE - - EXBVP Subsidiary to BVSUP - - EZFFT1 EZFFTI calls EZFFT1 with appropriate work array - partitioning. - - FCMN Subsidiary to FC - - FDJAC1 Subsidiary to SNSQ and SNSQE - - FDJAC3 Subsidiary to SNLS1 and SNLS1E - - FULMAT Subsidiary to SPLP - - GAMLN Compute the logarithm of the Gamma function - - GAMRN Subsidiary to BSKIN - - H12 Subsidiary to HFTI, LSEI and WNNLS - - HKSEQ Subsidiary to BSKIN - - HSTART Subsidiary to DEABM, DEBDF and DERKF - - HSTCS1 Subsidiary to HSTCSP - - HVNRM Subsidiary to DEABM, DEBDF and DERKF - - HWSCS1 Subsidiary to HWSCSP - - HWSSS1 Subsidiary to HWSSSP - - I1MERG Merge two strings of ascending integers. - - IDLOC Subsidiary to DSPLP - - INDXA Subsidiary to BLKTRI - - INDXB Subsidiary to BLKTRI - - INDXC Subsidiary to BLKTRI - - INTYD Subsidiary to DEBDF - - INXCA Subsidiary to CBLKTR - - INXCB Subsidiary to CBLKTR - - INXCC Subsidiary to CBLKTR - - IPLOC Subsidiary to SPLP - - ISDBCG Preconditioned BiConjugate Gradient Stop Test. - This routine calculates the stop test for the BiConjugate - Gradient iteration scheme. It returns a non-zero if the - error estimate (the type of which is determined by ITOL) - is less than the user specified tolerance TOL. - - ISDCG Preconditioned Conjugate Gradient Stop Test. - This routine calculates the stop test for the Conjugate - Gradient iteration scheme. It returns a non-zero if the - error estimate (the type of which is determined by ITOL) - is less than the user specified tolerance TOL. - - ISDCGN Preconditioned CG on Normal Equations Stop Test. - This routine calculates the stop test for the Conjugate - Gradient iteration scheme applied to the normal equations. - It returns a non-zero if the error estimate (the type of - which is determined by ITOL) is less than the user - specified tolerance TOL. - - ISDCGS Preconditioned BiConjugate Gradient Squared Stop Test. - This routine calculates the stop test for the BiConjugate - Gradient Squared iteration scheme. It returns a non-zero - if the error estimate (the type of which is determined by - ITOL) is less than the user specified tolerance TOL. - - ISDGMR Generalized Minimum Residual Stop Test. - This routine calculates the stop test for the Generalized - Minimum RESidual (GMRES) iteration scheme. It returns a - non-zero if the error estimate (the type of which is - determined by ITOL) is less than the user specified - tolerance TOL. - - ISDIR Preconditioned Iterative Refinement Stop Test. - This routine calculates the stop test for the iterative - refinement iteration scheme. It returns a non-zero if the - error estimate (the type of which is determined by ITOL) - is less than the user specified tolerance TOL. - - ISDOMN Preconditioned Orthomin Stop Test. - This routine calculates the stop test for the Orthomin - iteration scheme. It returns a non-zero if the error - estimate (the type of which is determined by ITOL) is - less than the user specified tolerance TOL. - - ISSBCG Preconditioned BiConjugate Gradient Stop Test. - This routine calculates the stop test for the BiConjugate - Gradient iteration scheme. It returns a non-zero if the - error estimate (the type of which is determined by ITOL) - is less than the user specified tolerance TOL. - - ISSCG Preconditioned Conjugate Gradient Stop Test. - This routine calculates the stop test for the Conjugate - Gradient iteration scheme. It returns a non-zero if the - error estimate (the type of which is determined by ITOL) - is less than the user specified tolerance TOL. - - ISSCGN Preconditioned CG on Normal Equations Stop Test. - This routine calculates the stop test for the Conjugate - Gradient iteration scheme applied to the normal equations. - It returns a non-zero if the error estimate (the type of - which is determined by ITOL) is less than the user - specified tolerance TOL. - - ISSCGS Preconditioned BiConjugate Gradient Squared Stop Test. - This routine calculates the stop test for the BiConjugate - Gradient Squared iteration scheme. It returns a non-zero - if the error estimate (the type of which is determined by - ITOL) is less than the user specified tolerance TOL. - - ISSGMR Generalized Minimum Residual Stop Test. - This routine calculates the stop test for the Generalized - Minimum RESidual (GMRES) iteration scheme. It returns a - non-zero if the error estimate (the type of which is - determined by ITOL) is less than the user specified - tolerance TOL. - - ISSIR Preconditioned Iterative Refinement Stop Test. - This routine calculates the stop test for the iterative - refinement iteration scheme. It returns a non-zero if the - error estimate (the type of which is determined by ITOL) - is less than the user specified tolerance TOL. - - ISSOMN Preconditioned Orthomin Stop Test. - This routine calculates the stop test for the Orthomin - iteration scheme. It returns a non-zero if the error - estimate (the type of which is determined by ITOL) is - less than the user specified tolerance TOL. - - IVOUT Subsidiary to SPLP - - J4SAVE Save or recall global variables needed by error - handling routines. - - JAIRY Subsidiary to BESJ and BESY - - LA05AD Subsidiary to DSPLP - - LA05AS Subsidiary to SPLP - - LA05BD Subsidiary to DSPLP - - LA05BS Subsidiary to SPLP - - LA05CD Subsidiary to DSPLP - - LA05CS Subsidiary to SPLP - - LA05ED Subsidiary to DSPLP - - LA05ES Subsidiary to SPLP - - LMPAR Subsidiary to SNLS1 and SNLS1E - - LPDP Subsidiary to LSEI - - LSAME Test two characters to determine if they are the same - letter, except for case. - - LSI Subsidiary to LSEI - - LSOD Subsidiary to DEBDF - - LSSODS Subsidiary to BVSUP - - LSSUDS Subsidiary to BVSUP - - MACON Subsidiary to BVSUP - - MC20AD Subsidiary to DSPLP - - MC20AS Subsidiary to SPLP - - MGSBV Subsidiary to BVSUP - - MINSO4 Subsidiary to SEPX4 - - MINSOL Subsidiary to SEPELI - - MPADD Subsidiary to DQDOTA and DQDOTI - - MPADD2 Subsidiary to DQDOTA and DQDOTI - - MPADD3 Subsidiary to DQDOTA and DQDOTI - - MPBLAS Subsidiary to DQDOTA and DQDOTI - - MPCDM Subsidiary to DQDOTA and DQDOTI - - MPCHK Subsidiary to DQDOTA and DQDOTI - - MPCMD Subsidiary to DQDOTA and DQDOTI - - MPDIVI Subsidiary to DQDOTA and DQDOTI - - MPERR Subsidiary to DQDOTA and DQDOTI - - MPMAXR Subsidiary to DQDOTA and DQDOTI - - MPMLP Subsidiary to DQDOTA and DQDOTI - - MPMUL Subsidiary to DQDOTA and DQDOTI - - MPMUL2 Subsidiary to DQDOTA and DQDOTI - - MPMULI Subsidiary to DQDOTA and DQDOTI - - MPNZR Subsidiary to DQDOTA and DQDOTI - - MPOVFL Subsidiary to DQDOTA and DQDOTI - - MPSTR Subsidiary to DQDOTA and DQDOTI - - MPUNFL Subsidiary to DQDOTA and DQDOTI - - OHTROL Subsidiary to BVSUP - - OHTROR Subsidiary to BVSUP - - ORTHO4 Subsidiary to SEPX4 - - ORTHOG Subsidiary to SEPELI - - ORTHOL Subsidiary to BVSUP - - ORTHOR Subsidiary to BVSUP - - PASSB Calculate the fast Fourier transform of subvectors of - arbitrary length. - - PASSB2 Calculate the fast Fourier transform of subvectors of - length two. - - PASSB3 Calculate the fast Fourier transform of subvectors of - length three. - - PASSB4 Calculate the fast Fourier transform of subvectors of - length four. - - PASSB5 Calculate the fast Fourier transform of subvectors of - length five. - - PASSF Calculate the fast Fourier transform of subvectors of - arbitrary length. - - PASSF2 Calculate the fast Fourier transform of subvectors of - length two. - - PASSF3 Calculate the fast Fourier transform of subvectors of - length three. - - PASSF4 Calculate the fast Fourier transform of subvectors of - length four. - - PASSF5 Calculate the fast Fourier transform of subvectors of - length five. - - PCHCE Set boundary conditions for PCHIC - - PCHCI Set interior derivatives for PCHIC - - PCHCS Adjusts derivative values for PCHIC - - PCHDF Computes divided differences for PCHCE and PCHSP - - PCHKT Compute B-spline knot sequence for PCHBS. - - PCHNGS Subsidiary to SPLP - - PCHST PCHIP Sign-Testing Routine - - PCHSW Limits excursion from data for PCHCS - - PGSF Subsidiary to CBLKTR - - PIMACH Subsidiary to HSTCSP, HSTSSP and HWSCSP - - PINITM Subsidiary to SPLP - - PJAC Subsidiary to DEBDF - - PNNZRS Subsidiary to SPLP - - POISD2 Subsidiary to GENBUN - - POISN2 Subsidiary to GENBUN - - POISP2 Subsidiary to GENBUN - - POS3D1 Subsidiary to POIS3D - - POSTG2 Subsidiary to POISTG - - PPADD Subsidiary to BLKTRI - - PPGQ8 Subsidiary to PFQAD - - PPGSF Subsidiary to CBLKTR - - PPPSF Subsidiary to CBLKTR - - PPSGF Subsidiary to BLKTRI - - PPSPF Subsidiary to BLKTRI - - PROC Subsidiary to CBLKTR - - PROCP Subsidiary to CBLKTR - - PROD Subsidiary to BLKTRI - - PRODP Subsidiary to BLKTRI - - PRVEC Subsidiary to BVSUP - - PRWPGE Subsidiary to SPLP - - PRWVIR Subsidiary to SPLP - - PSGF Subsidiary to BLKTRI - - PSIXN Subsidiary to EXINT - - PYTHAG Compute the complex square root of a complex number without - destructive overflow or underflow. - - QCHEB This routine computes the CHEBYSHEV series expansion - of degrees 12 and 24 of a function using A - FAST FOURIER TRANSFORM METHOD - F(X) = SUM(K=1,..,13) (CHEB12(K)*T(K-1,X)), - F(X) = SUM(K=1,..,25) (CHEB24(K)*T(K-1,X)), - Where T(K,X) is the CHEBYSHEV POLYNOMIAL OF DEGREE K. - - QELG The routine determines the limit of a given sequence of - approximations, by means of the Epsilon algorithm of - P. Wynn. An estimate of the absolute error is also given. - The condensed Epsilon table is computed. Only those - elements needed for the computation of the next diagonal - are preserved. - - QFORM Subsidiary to SNSQ and SNSQE - - QPSRT Subsidiary to QAGE, QAGIE, QAGPE, QAGSE, QAWCE, QAWOE and - QAWSE - - QRFAC Subsidiary to SNLS1, SNLS1E, SNSQ and SNSQE - - QRSOLV Subsidiary to SNLS1 and SNLS1E - - QS2I1D Sort an integer array, moving an integer and DP array. - This routine sorts the integer array IA and makes the same - interchanges in the integer array JA and the double pre- - cision array A. The array IA may be sorted in increasing - order or decreasing order. A slightly modified QUICKSORT - algorithm is used. - - QS2I1R Sort an integer array, moving an integer and real array. - This routine sorts the integer array IA and makes the same - interchanges in the integer array JA and the real array A. - The array IA may be sorted in increasing order or decreas- - ing order. A slightly modified QUICKSORT algorithm is - used. - - QWGTC This function subprogram is used together with the - routine QAWC and defines the WEIGHT function. - - QWGTF This function subprogram is used together with the - routine QAWF and defines the WEIGHT function. - - QWGTS This function subprogram is used together with the - routine QAWS and defines the WEIGHT function. - - R1MPYQ Subsidiary to SNSQ and SNSQE - - R1UPDT Subsidiary to SNSQ and SNSQE - - R9AIMP Evaluate the Airy modulus and phase. - - R9ATN1 Evaluate ATAN(X) from first order relative accuracy so that - ATAN(X) = X + X**3*R9ATN1(X). - - R9CHU Evaluate for large Z Z**A * U(A,B,Z) where U is the - logarithmic confluent hypergeometric function. - - R9GMIC Compute the complementary incomplete Gamma function for A - near a negative integer and for small X. - - R9GMIT Compute Tricomi's incomplete Gamma function for small - arguments. - - R9KNUS Compute Bessel functions EXP(X)*K-SUB-XNU(X) and EXP(X)* - K-SUB-XNU+1(X) for 0.0 .LE. XNU .LT. 1.0. - - R9LGIC Compute the log complementary incomplete Gamma function - for large X and for A .LE. X. - - R9LGIT Compute the logarithm of Tricomi's incomplete Gamma - function with Perron's continued fraction for large X and - A .GE. X. - - R9LGMC Compute the log Gamma correction factor so that - LOG(GAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X - + R9LGMC(X). - - R9LN2R Evaluate LOG(1+X) from second order relative accuracy so - that LOG(1+X) = X - X**2/2 + X**3*R9LN2R(X). - - RADB2 Calculate the fast Fourier transform of subvectors of - length two. - - RADB3 Calculate the fast Fourier transform of subvectors of - length three. - - RADB4 Calculate the fast Fourier transform of subvectors of - length four. - - RADB5 Calculate the fast Fourier transform of subvectors of - length five. - - RADBG Calculate the fast Fourier transform of subvectors of - arbitrary length. - - RADF2 Calculate the fast Fourier transform of subvectors of - length two. - - RADF3 Calculate the fast Fourier transform of subvectors of - length three. - - RADF4 Calculate the fast Fourier transform of subvectors of - length four. - - RADF5 Calculate the fast Fourier transform of subvectors of - length five. - - RADFG Calculate the fast Fourier transform of subvectors of - arbitrary length. - - REORT Subsidiary to BVSUP - - RFFTB Compute the backward fast Fourier transform of a real - coefficient array. - - RFFTF Compute the forward transform of a real, periodic sequence. - - RFFTI Initialize a work array for RFFTF and RFFTB. - - RKFAB Subsidiary to BVSUP - - RSCO Subsidiary to DEBDF - - RWUPDT Subsidiary to SNLS1 and SNLS1E - - S1MERG Merge two strings of ascending real numbers. - - SBOLSM Subsidiary to SBOCLS and SBOLS - - SCHKW SLAP WORK/IWORK Array Bounds Checker. - This routine checks the work array lengths and interfaces - to the SLATEC error handler if a problem is found. - - SCLOSM Subsidiary to SPLP - - SCOEF Subsidiary to BVSUP - - SDAINI Initialization routine for SDASSL. - - SDAJAC Compute the iteration matrix for SDASSL and form the - LU-decomposition. - - SDANRM Compute vector norm for SDASSL. - - SDASLV Linear system solver for SDASSL. - - SDASTP Perform one step of the SDASSL integration. - - SDATRP Interpolation routine for SDASSL. - - SDAWTS Set error weight vector for SDASSL. - - SDCOR Subroutine SDCOR computes corrections to the Y array. - - SDCST SDCST sets coefficients used by the core integrator SDSTP. - - SDNTL Subroutine SDNTL is called to set parameters on the first - call to SDSTP, on an internal restart, or when the user has - altered MINT, MITER, and/or H. - - SDNTP Subroutine SDNTP interpolates the K-th derivative of Y at - TOUT, using the data in the YH array. If K has a value - greater than NQ, the NQ-th derivative is calculated. - - SDPSC Subroutine SDPSC computes the predicted YH values by - effectively multiplying the YH array by the Pascal triangle - matrix when KSGN is +1, and performs the inverse function - when KSGN is -1. - - SDPST Subroutine SDPST evaluates the Jacobian matrix of the right - hand side of the differential equations. - - SDSCL Subroutine SDSCL rescales the YH array whenever the step - size is changed. - - SDSTP SDSTP performs one step of the integration of an initial - value problem for a system of ordinary differential - equations. - - SDZRO SDZRO searches for a zero of a function F(N, T, Y, IROOT) - between the given values B and C until the width of the - interval (B, C) has collapsed to within a tolerance - specified by the stopping criterion, - ABS(B - C) .LE. 2.*(RW*ABS(B) + AE). - - SHELS Internal routine for SGMRES. - - SHEQR Internal routine for SGMRES. - - SLVS Subsidiary to DEBDF - - SMOUT Subsidiary to FC and SBOCLS - - SODS Subsidiary to BVSUP - - SOPENM Subsidiary to SPLP - - SORTH Internal routine for SGMRES. - - SOSEQS Subsidiary to SOS - - SOSSOL Subsidiary to SOS - - SPELI4 Subsidiary to SEPX4 - - SPELIP Subsidiary to SEPELI - - SPIGMR Internal routine for SGMRES. - - SPINCW Subsidiary to SPLP - - SPINIT Subsidiary to SPLP - - SPLPCE Subsidiary to SPLP - - SPLPDM Subsidiary to SPLP - - SPLPFE Subsidiary to SPLP - - SPLPFL Subsidiary to SPLP - - SPLPMN Subsidiary to SPLP - - SPLPMU Subsidiary to SPLP - - SPLPUP Subsidiary to SPLP - - SPOPT Subsidiary to SPLP - - SREADP Subsidiary to SPLP - - SRLCAL Internal routine for SGMRES. - - STOD Subsidiary to DEBDF - - STOR1 Subsidiary to BVSUP - - STWAY Subsidiary to BVSUP - - SUDS Subsidiary to BVSUP - - SVCO Subsidiary to DEBDF - - SVD Perform the singular value decomposition of a rectangular - matrix. - - SVECS Subsidiary to BVSUP - - SVOUT Subsidiary to SPLP - - SWRITP Subsidiary to SPLP - - SXLCAL Internal routine for SGMRES. - - TEVLC Subsidiary to CBLKTR - - TEVLS Subsidiary to BLKTRI - - TRI3 Subsidiary to GENBUN - - TRIDQ Subsidiary to POIS3D - - TRIS4 Subsidiary to SEPX4 - - TRISP Subsidiary to SEPELI - - TRIX Subsidiary to GENBUN - - U11LS Subsidiary to LLSIA - - U11US Subsidiary to ULSIA - - U12LS Subsidiary to LLSIA - - U12US Subsidiary to ULSIA - - USRMAT Subsidiary to SPLP - - VNWRMS Subsidiary to DEBDF - - WNLIT Subsidiary to WNNLS - - WNLSM Subsidiary to WNNLS - - WNLT1 Subsidiary to WNLIT - - WNLT2 Subsidiary to WNLIT - - WNLT3 Subsidiary to WNLIT - - XERBLA Error handler for the Level 2 and Level 3 BLAS Routines. - - XERCNT Allow user control over handling of errors. - - XERHLT Abort program execution and print error message. - - XERPRN Print error messages processed by XERMSG. - - XERSVE Record that an error has occurred. - - XPMU To compute the values of Legendre functions for XLEGF. - Method: backward mu-wise recurrence for P(-MU,NU,X) for - fixed nu to obtain P(-MU2,NU1,X), P(-(MU2-1),NU1,X), ..., - P(-MU1,NU1,X) and store in ascending mu order. - - XPMUP To compute the values of Legendre functions for XLEGF. - This subroutine transforms an array of Legendre functions - of the first kind of negative order stored in array PQA - into Legendre functions of the first kind of positive - order stored in array PQA. The original array is destroyed. - - XPNRM To compute the values of Legendre functions for XLEGF. - This subroutine transforms an array of Legendre functions - of the first kind of negative order stored in array PQA - into normalized Legendre polynomials stored in array PQA. - The original array is destroyed. - - XPQNU To compute the values of Legendre functions for XLEGF. - This subroutine calculates initial values of P or Q using - power series, then performs forward nu-wise recurrence to - obtain P(-MU,NU,X), Q(0,NU,X), or Q(1,NU,X). The nu-wise - recurrence is stable for P for all mu and for Q for mu=0,1. - - XPSI To compute values of the Psi function for XLEGF. - - XQMU To compute the values of Legendre functions for XLEGF. - Method: forward mu-wise recurrence for Q(MU,NU,X) for fixed - nu to obtain Q(MU1,NU,X), Q(MU1+1,NU,X), ..., Q(MU2,NU,X). - - XQNU To compute the values of Legendre functions for XLEGF. - Method: backward nu-wise recurrence for Q(MU,NU,X) for - fixed mu to obtain Q(MU1,NU1,X), Q(MU1,NU1+1,X), ..., - Q(MU1,NU2,X). - - YAIRY Subsidiary to BESJ and BESY - - ZABS Subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and - ZBIRY - - ZACAI Subsidiary to ZAIRY - - ZACON Subsidiary to ZBESH and ZBESK - - ZASYI Subsidiary to ZBESI and ZBESK - - ZBINU Subsidiary to ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK and ZBIRY - - ZBKNU Subsidiary to ZAIRY, ZBESH, ZBESI and ZBESK - - ZBUNI Subsidiary to ZBESI and ZBESK - - ZBUNK Subsidiary to ZBESH and ZBESK - - ZDIV Subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and - ZBIRY - - ZEXP Subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and - ZBIRY - - ZKSCL Subsidiary to ZBESK - - ZLOG Subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and - ZBIRY - - ZMLRI Subsidiary to ZBESI and ZBESK - - ZMLT Subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and - ZBIRY - - ZRATI Subsidiary to ZBESH, ZBESI and ZBESK - - ZS1S2 Subsidiary to ZAIRY and ZBESK - - ZSERI Subsidiary to ZBESI and ZBESK - - ZSHCH Subsidiary to ZBESH and ZBESK - - ZSQRT Subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and - ZBIRY - - ZUCHK Subsidiary to SERI, ZUOIK, ZUNK1, ZUNK2, ZUNI1, ZUNI2 and - ZKSCL - - ZUNHJ Subsidiary to ZBESI and ZBESK - - ZUNI1 Subsidiary to ZBESI and ZBESK - - ZUNI2 Subsidiary to ZBESI and ZBESK - - ZUNIK Subsidiary to ZBESI and ZBESK - - ZUNK1 Subsidiary to ZBESK - - ZUNK2 Subsidiary to ZBESK - - ZUOIK Subsidiary to ZBESH, ZBESI and ZBESK - - ZWRSK Subsidiary to ZBESI and ZBESK - - -SECTION III. Alphabetic List of Routines and Categories - As stated in the introduction, an asterisk (*) immediately - preceeding a routine name indicates a subsidiary routine. - - AAAAAA Z ACOSH C4C - AI C10D AIE C10D - ALBETA C7B ALGAMS C7A - ALI C5 ALNGAM C7A - ALNREL C4B ASINH C4C -*ASYIK *ASYJY - ATANH C4C AVINT H2A1B2 - BAKVEC D4C4 BALANC D4C1A - BALBAK D4C4 BANDR D4C1B1 - BANDV D4C3 *BCRH -*BDIFF BESI C10B3 - BESI0 C10B1 BESI0E C10B1 - BESI1 C10B1 BESI1E C10B1 - BESJ C10A3 BESJ0 C10A1 - BESJ1 C10A1 BESK C10B3 - BESK0 C10B1 BESK0E C10B1 - BESK1 C10B1 BESK1E C10B1 - BESKES C10B3 *BESKNU - BESKS C10B3 BESY C10A3 - BESY0 C10A1 BESY1 C10A1 -*BESYNU BETA C7B - BETAI C7F BFQAD H2A2A1, E3, K6 - BI C10D BIE C10D - BINOM C1 BINT4 E1A - BINTK E1A BISECT D4A5, D4C2A -*BKIAS *BKISR -*BKSOL *BLKTR1 - BLKTRI I2B4B BNDACC D9 - BNDSOL D9 *BNFAC -*BNSLV BQR D4A6 -*BSGQ8 BSKIN C10F - BSPDOC E, E1A, K, Z BSPDR E3 - BSPEV E3, K6 *BSPLVD -*BSPLVN BSPPP E3, K6 - BSPVD E3, K6 BSPVN E3, K6 - BSQAD H2A2A1, E3, K6 *BSRH - BVALU E3, K6 *BVDER -*BVPOR BVSUP I1B1 - C0LGMC C7A *C1MERG -*C9LGMC C7A *C9LN2R C4B -*CACAI *CACON - CACOS C4A CACOSH C4C - CAIRY C10D CARG A4A - CASIN C4A CASINH C4C -*CASYI CATAN C4A - CATAN2 C4A CATANH C4C - CAXPY D1A7 CBABK2 D4C4 - CBAL D4C1A CBESH C10A4 - CBESI C10B4 CBESJ C10A4 - CBESK C10B4 CBESY C10A4 - CBETA C7B *CBINU - CBIRY C10D *CBKNU -*CBLKT1 CBLKTR I2B4B - CBRT C2 *CBUNI -*CBUNK CCBRT C2 - CCHDC D2D1B CCHDD D7B - CCHEX D7B CCHUD D7B -*CCMPB CCOPY D1A5 - CCOSH C4C CCOT C4A - CDCDOT D1A4 *CDCOR -*CDCST *CDIV -*CDNTL *CDNTP - CDOTC D1A4 CDOTU D1A4 -*CDPSC *CDPST - CDRIV1 I1A2, I1A1B CDRIV2 I1A2, I1A1B - CDRIV3 I1A2, I1A1B *CDSCL -*CDSTP *CDZRO - CEXPRL C4B *CFFTB J1A2 - CFFTB1 J1A2 *CFFTF J1A2 - CFFTF1 J1A2 *CFFTI J1A2 - CFFTI1 J1A2 *CFOD - CG D4A4 CGAMMA C7A - CGAMR C7A CGBCO D2C2 - CGBDI D3C2 CGBFA D2C2 - CGBMV D1B4 CGBSL D2C2 - CGECO D2C1 CGEDI D2C1, D3C1 - CGEEV D4A4 CGEFA D2C1 - CGEFS D2C1 CGEIR D2C1 - CGEMM D1B6 CGEMV D1B4 - CGERC D1B4 CGERU D1B4 - CGESL D2C1 CGTSL D2C2A - CH D4A3 CHBMV D1B4 - CHEMM D1B6 CHEMV D1B4 - CHER D1B4 CHER2 D1B4 - CHER2K D1B6 CHERK D1B6 -*CHFCM CHFDV E3, H1 - CHFEV E3 *CHFIE - CHICO D2D1A CHIDI D2D1A, D3D1A - CHIEV D4A3 CHIFA D2D1A - CHISL D2D1A CHKDER F3, G4C -*CHKPR4 *CHKPRM -*CHKSN4 *CHKSNG - CHPCO D2D1A CHPDI D2D1A, D3D1A - CHPFA D2D1A CHPMV D1B4 - CHPR D1B4 CHPR2 D1B4 - CHPSL D2D1A CHU C11 - CINVIT D4C2B *CKSCL - CLBETA C7B CLNGAM C7A - CLNREL C4B CLOG10 C4B - CMGNBN I2B4B *CMLRI -*CMPCSG *CMPOSD -*CMPOSN *CMPOSP -*CMPTR3 *CMPTRX - CNBCO D2C2 CNBDI D3C2 - CNBFA D2C2 CNBFS D2C2 - CNBIR D2C2 CNBSL D2C2 - COMBAK D4C4 COMHES D4C1B2 - COMLR D4C2B COMLR2 D4C2B -*COMPB COMQR D4C2B - COMQR2 D4C2B CORTB D4C4 - CORTH D4C1B2 COSDG C4A -*COSGEN COSQB J1A3 -*COSQB1 J1A3 COSQF J1A3 -*COSQF1 J1A3 COSQI J1A3 - COST J1A3 COSTI J1A3 - COT C4A *CPADD - CPBCO D2D2 CPBDI D3D2 - CPBFA D2D2 CPBSL D2D2 -*CPEVL *CPEVLR - CPOCO D2D1B CPODI D2D1B, D3D1B - CPOFA D2D1B CPOFS D2D1B - CPOIR D2D1B CPOSL D2D1B - CPPCO D2D1B CPPDI D2D1B, D3D1B - CPPFA D2D1B CPPSL D2D1B - CPQR79 F1A1B *CPROC -*CPROCP *CPROD -*CPRODP CPSI C7C - CPTSL D2D2A CPZERO F1A1B - CQRDC D5 CQRSL D9, D2C1 -*CRATI CROTG D1B10 -*CS1S2 CSCAL D1A6 -*CSCALE *CSERI - CSEVL C3A2 *CSHCH - CSICO D2C1 CSIDI D2C1, D3C1 - CSIFA D2C1 CSINH C4C - CSISL D2C1 CSPCO D2C1 - CSPDI D2C1, D3C1 CSPFA D2C1 - CSPSL D2C1 *CSROOT - CSROT D1B10 CSSCAL D1A6 - CSVDC D6 CSWAP D1A5 - CSYMM D1B6 CSYR2K D1B6 - CSYRK D1B6 CTAN C4A - CTANH C4C CTBMV D1B4 - CTBSV D1B4 CTPMV D1B4 - CTPSV D1B4 CTRCO D2C3 - CTRDI D2C3, D3C3 CTRMM D1B6 - CTRMV D1B4 CTRSL D2C3 - CTRSM D1B6 CTRSV D1B4 -*CUCHK *CUNHJ -*CUNI1 *CUNI2 -*CUNIK *CUNK1 -*CUNK2 *CUOIK - CV L7A3 *CWRSK - D1MACH R1 *D1MERG -*D1MPYQ *D1UPDT -*D9AIMP C10D *D9ATN1 C4A -*D9B0MP C10A1 *D9B1MP C10A1 -*D9CHU C11 *D9GMIC C7E -*D9GMIT C7E *D9KNUS C10B3 -*D9LGIC C7E *D9LGIT C7E -*D9LGMC C7E *D9LN2R C4B - D9PAK A6B D9UPAK A6B - DACOSH C4C DAI C10D - DAIE C10D DASINH C4C - DASUM D1A3A *DASYIK -*DASYJY DATANH C4C - DAVINT H2A1B2 DAWS C8C - DAXPY D1A7 DBCG D2A4, D2B4 -*DBDIFF DBESI C10B3 - DBESI0 C10B1 DBESI1 C10B1 - DBESJ C10A3 DBESJ0 C10A1 - DBESJ1 C10A1 DBESK C10B3 - DBESK0 C10B1 DBESK1 C10B1 - DBESKS C10B3 DBESY C10A3 - DBESY0 C10A1 DBESY1 C10A1 - DBETA C7B DBETAI C7F - DBFQAD H2A2A1, E3, K6 DBHIN N1 - DBI C10D DBIE C10D - DBINOM C1 DBINT4 E1A - DBINTK E1A *DBKIAS -*DBKISR *DBKSOL - DBNDAC D9 DBNDSL D9 -*DBNFAC *DBNSLV - DBOCLS K1A2A, G2E, G2H1, G2H2 DBOLS K1A2A, G2E, G2H1, G2H2 -*DBOLSM *DBSGQ8 - DBSI0E C10B1 DBSI1E C10B1 - DBSK0E C10B1 DBSK1E C10B1 - DBSKES C10B3 DBSKIN C10F -*DBSKNU DBSPDR E3, K6 - DBSPEV E3, K6 DBSPPP E3, K6 - DBSPVD E3, K6 DBSPVN E3, K6 - DBSQAD H2A2A1, E3, K6 *DBSYNU - DBVALU E3, K6 *DBVDER -*DBVPOR DBVSUP I1B1 - DCBRT C2 DCDOT D1A4 -*DCFOD DCG D2B4 - DCGN D2A4, D2B4 DCGS D2A4, D2B4 - DCHDC D2B1B DCHDD D7B - DCHEX D7B *DCHFCM - DCHFDV E3, H1 DCHFEV E3 -*DCHFIE *DCHKW R2 - DCHU C11 DCHUD D7B - DCKDER F3, G4C *DCOEF - DCOPY D1A5 DCOPYM D1A5 - DCOSDG C4A DCOT C4A - DCOV K1B1 DCPPLT N1 -*DCSCAL DCSEVL C3A2 - DCV L7A3 *DDAINI -*DDAJAC *DDANRM -*DDASLV DDASSL I1A2 -*DDASTP *DDATRP - DDAWS C8C *DDAWTS -*DDCOR *DDCST - DDEABM I1A1B DDEBDF I1A2 - DDERKF I1A1A *DDES -*DDNTL *DDNTP -*DDOGLG DDOT D1A4 -*DDPSC *DDPST - DDRIV1 I1A2, I1A1B DDRIV2 I1A2, I1A1B - DDRIV3 I1A2, I1A1B *DDSCL -*DDSTP *DDZRO - DE1 C5 DEABM I1A1B - DEBDF I1A2 DEFC K1A1A1, K1A2A, L8A3 -*DEFCMN *DEFE4 -*DEFEHL *DEFER - DEI C5 *DENORM - DERF C8A, L5A1E DERFC C8A, L5A1E - DERKF I1A1A *DERKFS -*DES *DEXBVP - DEXINT C5 DEXPRL C4B - DFAC C1 DFC K1A1A1, K1A2A, L8A3 -*DFCMN *DFDJC1 -*DFDJC3 *DFEHL -*DFSPVD *DFSPVN -*DFULMT DFZERO F1B - DGAMI C7E DGAMIC C7E - DGAMIT C7E DGAMLM C7A, R2 -*DGAMLN C7A DGAMMA C7A - DGAMR C7A *DGAMRN - DGAUS8 H2A1A1 DGBCO D2A2 - DGBDI D3A2 DGBFA D2A2 - DGBMV D1B4 DGBSL D2A2 - DGECO D2A1 DGEDI D3A1, D2A1 - DGEFA D2A1 DGEFS D2A1 - DGEMM D1B6 DGEMV D1B4 - DGER D1B4 DGESL D2A1 - DGLSS D9, D5 DGMRES D2A4, D2B4 - DGTSL D2A2A *DH12 -*DHELS D2A4, D2B4 *DHEQR D2A4, D2B4 - DHFTI D9 *DHKSEQ -*DHSTRT *DHVNRM - DINTP I1A1B DINTRV E3, K6 -*DINTYD DIR D2A4, D2B4 -*DJAIRY DLBETA C7B - DLGAMS C7A DLI C5 - DLLSIA D9, D5 DLLTI2 D2E - DLNGAM C7A DLNREL C4B - DLPDOC D2A4, D2B4, Z *DLPDP - DLSEI K1A2A, D9 *DLSI -*DLSOD *DLSSUD -*DMACON *DMGSBV -*DMOUT *DMPAR - DNBCO D2A2 DNBDI D3A2 - DNBFA D2A2 DNBFS D2A2 - DNBSL D2A2 DNLS1 K1B1A1, K1B1A2 - DNLS1E K1B1A1, K1B1A2 DNRM2 D1A3B - DNSQ F2A DNSQE F2A -*DOGLEG *DOHTRL - DOMN D2A4, D2B4 *DORTH D2A4, D2B4 -*DORTHR DP1VLU K6 - DPBCO D2B2 DPBDI D3B2 - DPBFA D2B2 DPBSL D2B2 - DPCHBS E3 *DPCHCE -*DPCHCI DPCHCM E3 -*DPCHCS *DPCHDF - DPCHFD E3, H1 DPCHFE E3 - DPCHIA E3, H2A1B2 DPCHIC E1A - DPCHID E3, H2A1B2 DPCHIM E1A -*DPCHKT E3 *DPCHNG - DPCHSP E1A *DPCHST -*DPCHSW DPCOEF K1A1A2 - DPFQAD H2A2A1, E3, K6 *DPIGMR D2A4, D2B4 -*DPINCW *DPINIT -*DPINTM *DPJAC - DPLINT E1B *DPLPCE -*DPLPDM *DPLPFE -*DPLPFL *DPLPMN -*DPLPMU *DPLPUP -*DPNNZR DPOCH C1, C7A - DPOCH1 C1, C7A DPOCO D2B1B - DPODI D2B1B, D3B1B DPOFA D2B1B - DPOFS D2B1B DPOLCF E1B - DPOLFT K1A1A2 DPOLVL E3 -*DPOPT DPOSL D2B1B - DPPCO D2B1B DPPDI D2B1B, D3B1B - DPPERM N8 DPPFA D2B1B -*DPPGQ8 DPPQAD H2A2A1, E3, K6 - DPPSL D2B1B DPPVAL E3, K6 -*DPRVEC *DPRWPG -*DPRWVR DPSI C7C - DPSIFN C7C *DPSIXN - DPSORT N6A1B, N6A2B DPTSL D2B2A - DQAG H2A1A1 DQAGE H2A1A1 - DQAGI H2A3A1, H2A4A1 DQAGIE H2A3A1, H2A4A1 - DQAGP H2A2A1 DQAGPE H2A2A1 - DQAGS H2A1A1 DQAGSE H2A1A1 - DQAWC H2A2A1, J4 DQAWCE H2A2A1, J4 - DQAWF H2A3A1 DQAWFE H2A3A1 - DQAWO H2A2A1 DQAWOE H2A2A1 - DQAWS H2A2A1 DQAWSE H2A2A1 - DQC25C H2A2A2, J4 DQC25F H2A2A2 - DQC25S H2A2A2 *DQCHEB - DQDOTA D1A4 DQDOTI D1A4 -*DQELG *DQFORM - DQK15 H2A1A2 DQK15I H2A3A2, H2A4A2 - DQK15W H2A2A2 DQK21 H2A1A2 - DQK31 H2A1A2 DQK41 H2A1A2 - DQK51 H2A1A2 DQK61 H2A1A2 - DQMOMO H2A2A1, C3A2 DQNC79 H2A1A1 - DQNG H2A1A1 *DQPSRT - DQRDC D5 *DQRFAC - DQRSL D9, D2A1 *DQRSLV -*DQWGTC *DQWGTF -*DQWGTS DRC C14 - DRC3JJ C19 DRC3JM C19 - DRC6J C19 DRD C14 -*DREADP *DREORT - DRF C14 DRJ C14 -*DRKFAB *DRKFS -*DRLCAL D2A4, D2B4 DROT D1A8 - DROTG D1B10 DROTM D1A8 - DROTMG D1B10 *DRSCO - DS2LT D2E DS2Y D1B9 - DSBMV D1B4 DSCAL D1A6 - DSD2S D2E DSDBCG D2A4, D2B4 - DSDCG D2B4 DSDCGN D2A4, D2B4 - DSDCGS D2A4, D2B4 DSDGMR D2A4, D2B4 - DSDI D1B4 DSDOMN D2A4, D2B4 - DSDOT D1A4 DSDS D2E - DSDSCL D2E DSGS D2A4, D2B4 - DSICCG D2B4 DSICO D2B1A - DSICS D2E DSIDI D2B1A, D3B1A - DSIFA D2B1A DSILUR D2A4, D2B4 - DSILUS D2E DSINDG C4A - DSISL D2B1A DSJAC D2A4, D2B4 - DSLI D2A3 DSLI2 D2A3 - DSLLTI D2E DSLUBC D2A4, D2B4 - DSLUCN D2A4, D2B4 DSLUCS D2A4, D2B4 - DSLUGM D2A4, D2B4 DSLUI D2E - DSLUI2 D2E DSLUI4 D2E - DSLUOM D2A4, D2B4 DSLUTI D2E -*DSLVS DSMMI2 D2E - DSMMTI D2E DSMTV D1B4 - DSMV D1B4 DSORT N6A2B - DSOS F2A *DSOSEQ -*DSOSSL DSPCO D2B1A - DSPDI D2B1A, D3B1A DSPENC C5 - DSPFA D2B1A DSPLP G2A2 - DSPMV D1B4 DSPR D1B4 - DSPR2 D1B4 DSPSL D2B1A - DSTEPS I1A1B *DSTOD -*DSTOR1 *DSTWAY -*DSUDS *DSVCO - DSVDC D6 DSWAP D1A5 - DSYMM D1B6 DSYMV D1B4 - DSYR D1B4 DSYR2 D1B4 - DSYR2K D1B6 DSYRK D1B6 - DTBMV D1B4 DTBSV D1B4 - DTIN N1 DTOUT N1 - DTPMV D1B4 DTPSV D1B4 - DTRCO D2A3 DTRDI D2A3, D3A3 - DTRMM D1B6 DTRMV D1B4 - DTRSL D2A3 DTRSM D1B6 - DTRSV D1B4 *DU11LS -*DU11US *DU12LS -*DU12US DULSIA D9 -*DUSRMT *DVECS -*DVNRMS *DVOUT -*DWNLIT *DWNLSM -*DWNLT1 *DWNLT2 -*DWNLT3 DWNNLS K1A2A -*DWRITP *DWUPDT -*DX *DX4 - DXADD A3D DXADJ A3D - DXC210 A3D DXCON A3D -*DXLCAL D2A4, D2B4 DXLEGF C3A2, C9 - DXNRMP C3A2, C9 *DXPMU C3A2, C9 -*DXPMUP C3A2, C9 *DXPNRM C3A2, C9 -*DXPQNU C3A2, C9 *DXPSI C7C -*DXQMU C3A2, C9 *DXQNU C3A2, C9 - DXRED A3D DXSET A3D -*DY *DY4 -*DYAIRY E1 C5 - EFC K1A1A1, K1A2A, L8A3 *EFCMN - EI C5 EISDOC D4, Z - ELMBAK D4C4 ELMHES D4C1B2 - ELTRAN D4C4 *ENORM - ERF C8A, L5A1E ERFC C8A, L5A1E -*EXBVP EXINT C5 - EXPREL C4B *EZFFT1 - EZFFTB J1A1 EZFFTF J1A1 - EZFFTI J1A1 FAC C1 - FC K1A1A1, K1A2A, L8A3 *FCMN -*FDJAC1 *FDJAC3 - FDUMP R3 FFTDOC J1, Z - FIGI D4C1C FIGI2 D4C1C -*FULMAT FUNDOC C, Z - FZERO F1B GAMI C7E - GAMIC C7E GAMIT C7E - GAMLIM C7A, R2 *GAMLN C7A - GAMMA C7A GAMR C7A -*GAMRN GAUS8 H2A1A1 - GENBUN I2B4B *H12 - HFTI D9 *HKSEQ - HPPERM N8 HPSORT N6A1C, N6A2C - HQR D4C2B HQR2 D4C2B -*HSTART HSTCRT I2B1A1A -*HSTCS1 HSTCSP I2B1A1A - HSTCYL I2B1A1A HSTPLR I2B1A1A - HSTSSP I2B1A1A HTRIB3 D4C4 - HTRIBK D4C4 HTRID3 D4C1B1 - HTRIDI D4C1B1 *HVNRM - HW3CRT I2B1A1A HWSCRT I2B1A1A -*HWSCS1 HWSCSP I2B1A1A - HWSCYL I2B1A1A HWSPLR I2B1A1A -*HWSSS1 HWSSSP I2B1A1A - I1MACH R1 *I1MERG - ICAMAX D1A2 ICOPY D1A5 - IDAMAX D1A2 *IDLOC - IMTQL1 D4A5, D4C2A IMTQL2 D4A5, D4C2A - IMTQLV D4A5, D4C2A *INDXA -*INDXB *INDXC - INITDS C3A2 INITS C3A2 - INTRV E3, K6 *INTYD - INVIT D4C2B *INXCA -*INXCB *INXCC -*IPLOC IPPERM N8 - IPSORT N6A1A, N6A2A ISAMAX D1A2 -*ISDBCG D2A4, D2B4 *ISDCG D2B4 -*ISDCGN D2A4, D2B4 *ISDCGS D2A4, D2B4 -*ISDGMR D2A4, D2B4 *ISDIR D2A4, D2B4 -*ISDOMN D2A4, D2B4 ISORT N6A2A -*ISSBCG D2A4, D2B4 *ISSCG D2B4 -*ISSCGN D2A4, D2B4 *ISSCGS D2A4, D2B4 -*ISSGMR D2A4, D2B4 *ISSIR D2A4, D2B4 -*ISSOMN D2A4, D2B4 ISWAP D1A5 -*IVOUT *J4SAVE -*JAIRY *LA05AD -*LA05AS *LA05BD -*LA05BS *LA05CD -*LA05CS *LA05ED -*LA05ES LLSIA D9, D5 -*LMPAR *LPDP -*LSAME R, N3 LSEI K1A2A, D9 -*LSI *LSOD -*LSSODS *LSSUDS -*MACON *MC20AD -*MC20AS *MGSBV - MINFIT D9 *MINSO4 -*MINSOL *MPADD -*MPADD2 *MPADD3 -*MPBLAS *MPCDM -*MPCHK *MPCMD -*MPDIVI *MPERR -*MPMAXR *MPMLP -*MPMUL *MPMUL2 -*MPMULI *MPNZR -*MPOVFL *MPSTR -*MPUNFL NUMXER R3C -*OHTROL *OHTROR - ORTBAK D4C4 ORTHES D4C1B2 -*ORTHO4 *ORTHOG -*ORTHOL *ORTHOR - ORTRAN D4C4 *PASSB -*PASSB2 *PASSB3 -*PASSB4 *PASSB5 -*PASSF *PASSF2 -*PASSF3 *PASSF4 -*PASSF5 PCHBS E3 -*PCHCE *PCHCI - PCHCM E3 *PCHCS -*PCHDF PCHDOC E1A, Z - PCHFD E3, H1 PCHFE E3 - PCHIA E3, H2A1B2 PCHIC E1A - PCHID E3, H2A1B2 PCHIM E1A -*PCHKT E3 *PCHNGS - PCHSP E1A *PCHST -*PCHSW PCOEF K1A1A2 - PFQAD H2A2A1, E3, K6 *PGSF -*PIMACH *PINITM -*PJAC *PNNZRS - POCH C1, C7A POCH1 C1, C7A - POIS3D I2B4B *POISD2 -*POISN2 *POISP2 - POISTG I2B4B POLCOF E1B - POLFIT K1A1A2 POLINT E1B - POLYVL E3 *POS3D1 -*POSTG2 *PPADD -*PPGQ8 *PPGSF -*PPPSF PPQAD H2A2A1, E3, K6 -*PPSGF *PPSPF - PPVAL E3, K6 *PROC -*PROCP *PROD -*PRODP *PRVEC -*PRWPGE *PRWVIR -*PSGF PSI C7C - PSIFN C7C *PSIXN - PVALUE K6 *PYTHAG - QAG H2A1A1 QAGE H2A1A1 - QAGI H2A3A1, H2A4A1 QAGIE H2A3A1, H2A4A1 - QAGP H2A2A1 QAGPE H2A2A1 - QAGS H2A1A1 QAGSE H2A1A1 - QAWC H2A2A1, J4 QAWCE H2A2A1, J4 - QAWF H2A3A1 QAWFE H2A3A1 - QAWO H2A2A1 QAWOE H2A2A1 - QAWS H2A2A1 QAWSE H2A2A1 - QC25C H2A2A2, J4 QC25F H2A2A2 - QC25S H2A2A2 *QCHEB -*QELG *QFORM - QK15 H2A1A2 QK15I H2A3A2, H2A4A2 - QK15W H2A2A2 QK21 H2A1A2 - QK31 H2A1A2 QK41 H2A1A2 - QK51 H2A1A2 QK61 H2A1A2 - QMOMO H2A2A1, C3A2 QNC79 H2A1A1 - QNG H2A1A1 QPDOC H2, Z -*QPSRT *QRFAC -*QRSOLV *QS2I1D N6A2A -*QS2I1R N6A2A *QWGTC -*QWGTF *QWGTS - QZHES D4C1B3 QZIT D4C1B3 - QZVAL D4C2C QZVEC D4C3 - R1MACH R1 *R1MPYQ -*R1UPDT *R9AIMP C10D -*R9ATN1 C4A *R9CHU C11 -*R9GMIC C7E *R9GMIT C7E -*R9KNUS C10B3 *R9LGIC C7E -*R9LGIT C7E *R9LGMC C7E -*R9LN2R C4B R9PAK A6B - R9UPAK A6B *RADB2 -*RADB3 *RADB4 -*RADB5 *RADBG -*RADF2 *RADF3 -*RADF4 *RADF5 -*RADFG RAND L6A21 - RATQR D4A5, D4C2A RC C14 - RC3JJ C19 RC3JM C19 - RC6J C19 RD C14 - REBAK D4C4 REBAKB D4C4 - REDUC D4C1C REDUC2 D4C1C -*REORT RF C14 -*RFFTB J1A1 RFFTB1 J1A1 -*RFFTF J1A1 RFFTF1 J1A1 -*RFFTI J1A1 RFFTI1 J1A1 - RG D4A2 RGAUSS L6A14 - RGG D4B2 RJ C14 -*RKFAB RPQR79 F1A1A - RPZERO F1A1A RS D4A1 - RSB D4A6 *RSCO - RSG D4B1 RSGAB D4B1 - RSGBA D4B1 RSP D4A1 - RST D4A5 RT D4A5 - RUNIF L6A21 *RWUPDT -*S1MERG SASUM D1A3A - SAXPY D1A7 SBCG D2A4, D2B4 - SBHIN N1 SBOCLS K1A2A, G2E, G2H1, G2H2 - SBOLS K1A2A, G2E, G2H1, G2H2 *SBOLSM - SCASUM D1A3A SCG D2B4 - SCGN D2A4, D2B4 SCGS D2A4, D2B4 - SCHDC D2B1B SCHDD D7B - SCHEX D7B *SCHKW R2 - SCHUD D7B *SCLOSM - SCNRM2 D1A3B *SCOEF - SCOPY D1A5 SCOPYM D1A5 - SCOV K1B1 SCPPLT N1 -*SDAINI *SDAJAC -*SDANRM *SDASLV - SDASSL I1A2 *SDASTP -*SDATRP *SDAWTS -*SDCOR *SDCST -*SDNTL *SDNTP - SDOT D1A4 *SDPSC -*SDPST SDRIV1 I1A2, I1A1B - SDRIV2 I1A2, I1A1B SDRIV3 I1A2, I1A1B -*SDSCL SDSDOT D1A4 -*SDSTP *SDZRO - SEPELI I2B1A2 SEPX4 I2B1A2 - SGBCO D2A2 SGBDI D3A2 - SGBFA D2A2 SGBMV D1B4 - SGBSL D2A2 SGECO D2A1 - SGEDI D2A1, D3A1 SGEEV D4A2 - SGEFA D2A1 SGEFS D2A1 - SGEIR D2A1 SGEMM D1B6 - SGEMV D1B4 SGER D1B4 - SGESL D2A1 SGLSS D9, D5 - SGMRES D2A4, D2B4 SGTSL D2A2A -*SHELS D2A4, D2B4 *SHEQR D2A4, D2B4 - SINDG C4A SINQB J1A3 - SINQF J1A3 SINQI J1A3 - SINT J1A3 SINTI J1A3 - SINTRP I1A1B SIR D2A4, D2B4 - SLLTI2 D2E SLPDOC D2A4, D2B4, Z -*SLVS *SMOUT - SNBCO D2A2 SNBDI D3A2 - SNBFA D2A2 SNBFS D2A2 - SNBIR D2A2 SNBSL D2A2 - SNLS1 K1B1A1, K1B1A2 SNLS1E K1B1A1, K1B1A2 - SNRM2 D1A3B SNSQ F2A - SNSQE F2A *SODS - SOMN D2A4, D2B4 *SOPENM -*SORTH D2A4, D2B4 SOS F2A -*SOSEQS *SOSSOL - SPBCO D2B2 SPBDI D3B2 - SPBFA D2B2 SPBSL D2B2 -*SPELI4 *SPELIP - SPENC C5 *SPIGMR D2A4, D2B4 -*SPINCW *SPINIT - SPLP G2A2 *SPLPCE -*SPLPDM *SPLPFE -*SPLPFL *SPLPMN -*SPLPMU *SPLPUP - SPOCO D2B1B SPODI D2B1B, D3B1B - SPOFA D2B1B SPOFS D2B1B - SPOIR D2B1B *SPOPT - SPOSL D2B1B SPPCO D2B1B - SPPDI D2B1B, D3B1B SPPERM N8 - SPPFA D2B1B SPPSL D2B1B - SPSORT N6A1B, N6A2B SPTSL D2B2A - SQRDC D5 SQRSL D9, D2A1 -*SREADP *SRLCAL D2A4, D2B4 - SROT D1A8 SROTG D1B10 - SROTM D1A8 SROTMG D1B10 - SS2LT D2E SS2Y D1B9 - SSBMV D1B4 SSCAL D1A6 - SSD2S D2E SSDBCG D2A4, D2B4 - SSDCG D2B4 SSDCGN D2A4, D2B4 - SSDCGS D2A4, D2B4 SSDGMR D2A4, D2B4 - SSDI D1B4 SSDOMN D2A4, D2B4 - SSDS D2E SSDSCL D2E - SSGS D2A4, D2B4 SSICCG D2B4 - SSICO D2B1A SSICS D2E - SSIDI D2B1A, D3B1A SSIEV D4A1 - SSIFA D2B1A SSILUR D2A4, D2B4 - SSILUS D2E SSISL D2B1A - SSJAC D2A4, D2B4 SSLI D2A3 - SSLI2 D2A3 SSLLTI D2E - SSLUBC D2A4, D2B4 SSLUCN D2A4, D2B4 - SSLUCS D2A4, D2B4 SSLUGM D2A4, D2B4 - SSLUI D2E SSLUI2 D2E - SSLUI4 D2E SSLUOM D2A4, D2B4 - SSLUTI D2E SSMMI2 D2E - SSMMTI D2E SSMTV D1B4 - SSMV D1B4 SSORT N6A2B - SSPCO D2B1A SSPDI D2B1A, D3B1A - SSPEV D4A1 SSPFA D2B1A - SSPMV D1B4 SSPR D1B4 - SSPR2 D1B4 SSPSL D2B1A - SSVDC D6 SSWAP D1A5 - SSYMM D1B6 SSYMV D1B4 - SSYR D1B4 SSYR2 D1B4 - SSYR2K D1B6 SSYRK D1B6 - STBMV D1B4 STBSV D1B4 - STEPS I1A1B STIN N1 -*STOD *STOR1 - STOUT N1 STPMV D1B4 - STPSV D1B4 STRCO D2A3 - STRDI D2A3, D3A3 STRMM D1B6 - STRMV D1B4 STRSL D2A3 - STRSM D1B6 STRSV D1B4 -*STWAY *SUDS -*SVCO *SVD -*SVECS *SVOUT -*SWRITP *SXLCAL D2A4, D2B4 -*TEVLC *TEVLS - TINVIT D4C3 TQL1 D4A5, D4C2A - TQL2 D4A5, D4C2A TQLRAT D4A5, D4C2A - TRBAK1 D4C4 TRBAK3 D4C4 - TRED1 D4C1B1 TRED2 D4C1B1 - TRED3 D4C1B1 *TRI3 - TRIDIB D4A5, D4C2A *TRIDQ -*TRIS4 *TRISP -*TRIX TSTURM D4A5, D4C2A -*U11LS *U11US -*U12LS *U12US - ULSIA D9 *USRMAT -*VNWRMS *WNLIT -*WNLSM *WNLT1 -*WNLT2 *WNLT3 - WNNLS K1A2A XADD A3D - XADJ A3D XC210 A3D - XCON A3D *XERBLA R3 - XERCLR R3C *XERCNT R3C - XERDMP R3C *XERHLT R3C - XERMAX R3C XERMSG R3C -*XERPRN R3C *XERSVE R3 - XGETF R3C XGETUA R3C - XGETUN R3C XLEGF C3A2, C9 - XNRMP C3A2, C9 *XPMU C3A2, C9 -*XPMUP C3A2, C9 *XPNRM C3A2, C9 -*XPQNU C3A2, C9 *XPSI C7C -*XQMU C3A2, C9 *XQNU C3A2, C9 - XRED A3D XSET A3D - XSETF R3A XSETUA R3B - XSETUN R3B *YAIRY -*ZABS *ZACAI -*ZACON ZAIRY C10D -*ZASYI ZBESH C10A4 - ZBESI C10B4 ZBESJ C10A4 - ZBESK C10B4 ZBESY C10A4 -*ZBINU ZBIRY C10D -*ZBKNU *ZBUNI -*ZBUNK *ZDIV -*ZEXP *ZKSCL -*ZLOG *ZMLRI -*ZMLT *ZRATI -*ZS1S2 *ZSERI -*ZSHCH *ZSQRT -*ZUCHK *ZUNHJ -*ZUNI1 *ZUNI2 -*ZUNIK *ZUNK1 -*ZUNK2 *ZUOIK -*ZWRSK diff --git a/slatec/tql1.f b/slatec/tql1.f deleted file mode 100644 index 60e65f4..0000000 --- a/slatec/tql1.f +++ /dev/null @@ -1,167 +0,0 @@ -*DECK TQL1 - SUBROUTINE TQL1 (N, D, E, IERR) -C***BEGIN PROLOGUE TQL1 -C***PURPOSE Compute the eigenvalues of symmetric tridiagonal matrix by -C the QL method. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4A5, D4C2A -C***TYPE SINGLE PRECISION (TQL1-S) -C***KEYWORDS EIGENVALUES OF A SYMMETRIC TRIDIAGONAL MATRIX, EISPACK, -C QL METHOD -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure TQL1, -C NUM. MATH. 11, 293-306(1968) by Bowdler, Martin, Reinsch, and -C Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). -C -C This subroutine finds the eigenvalues of a SYMMETRIC -C TRIDIAGONAL matrix by the QL method. -C -C On Input -C -C N is the order of the matrix. N is an INTEGER variable. -C -C D contains the diagonal elements of the symmetric tridiagonal -C matrix. D is a one-dimensional REAL array, dimensioned D(N). -C -C E contains the subdiagonal elements of the symmetric -C tridiagonal matrix in its last N-1 positions. E(1) is -C arbitrary. E is a one-dimensional REAL array, dimensioned -C E(N). -C -C On Output -C -C D contains the eigenvalues in ascending order. If an -C error exit is made, the eigenvalues are correct and -C ordered for indices 1, 2, ..., IERR-1, but may not be -C the smallest eigenvalues. -C -C E has been destroyed. -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C J if the J-th eigenvalue has not been -C determined after 30 iterations. -C -C Calls PYTHAG(A,B) for sqrt(A**2 + B**2). -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED PYTHAG -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE TQL1 -C - INTEGER I,J,L,M,N,II,L1,L2,MML,IERR - REAL D(*),E(*) - REAL B,C,C2,C3,DL1,EL1,F,G,H,P,R,S,S2 - REAL PYTHAG -C -C***FIRST EXECUTABLE STATEMENT TQL1 - IERR = 0 - IF (N .EQ. 1) GO TO 1001 -C - DO 100 I = 2, N - 100 E(I-1) = E(I) -C - F = 0.0E0 - B = 0.0E0 - E(N) = 0.0E0 -C - DO 290 L = 1, N - J = 0 - H = ABS(D(L)) + ABS(E(L)) - IF (B .LT. H) B = H -C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... - DO 110 M = L, N - IF (B + ABS(E(M)) .EQ. B) GO TO 120 -C .......... E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT -C THROUGH THE BOTTOM OF THE LOOP .......... - 110 CONTINUE -C - 120 IF (M .EQ. L) GO TO 210 - 130 IF (J .EQ. 30) GO TO 1000 - J = J + 1 -C .......... FORM SHIFT .......... - L1 = L + 1 - L2 = L1 + 1 - G = D(L) - P = (D(L1) - G) / (2.0E0 * E(L)) - R = PYTHAG(P,1.0E0) - D(L) = E(L) / (P + SIGN(R,P)) - D(L1) = E(L) * (P + SIGN(R,P)) - DL1 = D(L1) - H = G - D(L) - IF (L2 .GT. N) GO TO 145 -C - DO 140 I = L2, N - 140 D(I) = D(I) - H -C - 145 F = F + H -C .......... QL TRANSFORMATION .......... - P = D(M) - C = 1.0E0 - C2 = C - EL1 = E(L1) - S = 0.0E0 - MML = M - L -C .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... - DO 200 II = 1, MML - C3 = C2 - C2 = C - S2 = S - I = M - II - G = C * E(I) - H = C * P - IF (ABS(P) .LT. ABS(E(I))) GO TO 150 - C = E(I) / P - R = SQRT(C*C+1.0E0) - E(I+1) = S * P * R - S = C / R - C = 1.0E0 / R - GO TO 160 - 150 C = P / E(I) - R = SQRT(C*C+1.0E0) - E(I+1) = S * E(I) * R - S = 1.0E0 / R - C = C * S - 160 P = C * D(I) - S * G - D(I+1) = H + S * (C * G + S * D(I)) - 200 CONTINUE -C - P = -S * S2 * C3 * EL1 * E(L) / DL1 - E(L) = S * P - D(L) = C * P - IF (B + ABS(E(L)) .GT. B) GO TO 130 - 210 P = D(L) + F -C .......... ORDER EIGENVALUES .......... - IF (L .EQ. 1) GO TO 250 -C .......... FOR I=L STEP -1 UNTIL 2 DO -- .......... - DO 230 II = 2, L - I = L + 2 - II - IF (P .GE. D(I-1)) GO TO 270 - D(I) = D(I-1) - 230 CONTINUE -C - 250 I = 1 - 270 D(I) = P - 290 CONTINUE -C - GO TO 1001 -C .......... SET ERROR -- NO CONVERGENCE TO AN -C EIGENVALUE AFTER 30 ITERATIONS .......... - 1000 IERR = L - 1001 RETURN - END diff --git a/slatec/tql2.f b/slatec/tql2.f deleted file mode 100644 index 40d9938..0000000 --- a/slatec/tql2.f +++ /dev/null @@ -1,203 +0,0 @@ -*DECK TQL2 - SUBROUTINE TQL2 (NM, N, D, E, Z, IERR) -C***BEGIN PROLOGUE TQL2 -C***PURPOSE Compute the eigenvalues and eigenvectors of symmetric -C tridiagonal matrix. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4A5, D4C2A -C***TYPE SINGLE PRECISION (TQL2-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure TQL2, -C NUM. MATH. 11, 293-306(1968) by Bowdler, Martin, Reinsch, and -C Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). -C -C This subroutine finds the eigenvalues and eigenvectors -C of a SYMMETRIC TRIDIAGONAL matrix by the QL method. -C The eigenvectors of a FULL SYMMETRIC matrix can also -C be found if TRED2 has been used to reduce this -C full matrix to tridiagonal form. -C -C On Input -C -C NM must be set to the row dimension of the two-dimensional -C array parameter, Z, as declared in the calling program -C dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C D contains the diagonal elements of the symmetric tridiagonal -C matrix. D is a one-dimensional REAL array, dimensioned D(N). -C -C E contains the subdiagonal elements of the symmetric -C tridiagonal matrix in its last N-1 positions. E(1) is -C arbitrary. E is a one-dimensional REAL array, dimensioned -C E(N). -C -C Z contains the transformation matrix produced in the -C reduction by TRED2, if performed. If the eigenvectors -C of the tridiagonal matrix are desired, Z must contain -C the identity matrix. Z is a two-dimensional REAL array, -C dimensioned Z(NM,N). -C -C On Output -C -C D contains the eigenvalues in ascending order. If an -C error exit is made, the eigenvalues are correct but -C unordered for indices 1, 2, ..., IERR-1. -C -C E has been destroyed. -C -C Z contains orthonormal eigenvectors of the symmetric -C tridiagonal (or full) matrix. If an error exit is made, -C Z contains the eigenvectors associated with the stored -C eigenvalues. -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C J if the J-th eigenvalue has not been -C determined after 30 iterations. -C -C Calls PYTHAG(A,B) for sqrt(A**2 + B**2). -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED PYTHAG -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE TQL2 -C - INTEGER I,J,K,L,M,N,II,L1,L2,NM,MML,IERR - REAL D(*),E(*),Z(NM,*) - REAL B,C,C2,C3,DL1,EL1,F,G,H,P,R,S,S2 - REAL PYTHAG -C -C***FIRST EXECUTABLE STATEMENT TQL2 - IERR = 0 - IF (N .EQ. 1) GO TO 1001 -C - DO 100 I = 2, N - 100 E(I-1) = E(I) -C - F = 0.0E0 - B = 0.0E0 - E(N) = 0.0E0 -C - DO 240 L = 1, N - J = 0 - H = ABS(D(L)) + ABS(E(L)) - IF (B .LT. H) B = H -C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... - DO 110 M = L, N - IF (B + ABS(E(M)) .EQ. B) GO TO 120 -C .......... E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT -C THROUGH THE BOTTOM OF THE LOOP .......... - 110 CONTINUE -C - 120 IF (M .EQ. L) GO TO 220 - 130 IF (J .EQ. 30) GO TO 1000 - J = J + 1 -C .......... FORM SHIFT .......... - L1 = L + 1 - L2 = L1 + 1 - G = D(L) - P = (D(L1) - G) / (2.0E0 * E(L)) - R = PYTHAG(P,1.0E0) - D(L) = E(L) / (P + SIGN(R,P)) - D(L1) = E(L) * (P + SIGN(R,P)) - DL1 = D(L1) - H = G - D(L) - IF (L2 .GT. N) GO TO 145 -C - DO 140 I = L2, N - 140 D(I) = D(I) - H -C - 145 F = F + H -C .......... QL TRANSFORMATION .......... - P = D(M) - C = 1.0E0 - C2 = C - EL1 = E(L1) - S = 0.0E0 - MML = M - L -C .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... - DO 200 II = 1, MML - C3 = C2 - C2 = C - S2 = S - I = M - II - G = C * E(I) - H = C * P - IF (ABS(P) .LT. ABS(E(I))) GO TO 150 - C = E(I) / P - R = SQRT(C*C+1.0E0) - E(I+1) = S * P * R - S = C / R - C = 1.0E0 / R - GO TO 160 - 150 C = P / E(I) - R = SQRT(C*C+1.0E0) - E(I+1) = S * E(I) * R - S = 1.0E0 / R - C = C * S - 160 P = C * D(I) - S * G - D(I+1) = H + S * (C * G + S * D(I)) -C .......... FORM VECTOR .......... - DO 180 K = 1, N - H = Z(K,I+1) - Z(K,I+1) = S * Z(K,I) + C * H - Z(K,I) = C * Z(K,I) - S * H - 180 CONTINUE -C - 200 CONTINUE -C - P = -S * S2 * C3 * EL1 * E(L) / DL1 - E(L) = S * P - D(L) = C * P - IF (B + ABS(E(L)) .GT. B) GO TO 130 - 220 D(L) = D(L) + F - 240 CONTINUE -C .......... ORDER EIGENVALUES AND EIGENVECTORS .......... - DO 300 II = 2, N - I = II - 1 - K = I - P = D(I) -C - DO 260 J = II, N - IF (D(J) .GE. P) GO TO 260 - K = J - P = D(J) - 260 CONTINUE -C - IF (K .EQ. I) GO TO 300 - D(K) = D(I) - D(I) = P -C - DO 280 J = 1, N - P = Z(J,I) - Z(J,I) = Z(J,K) - Z(J,K) = P - 280 CONTINUE -C - 300 CONTINUE -C - GO TO 1001 -C .......... SET ERROR -- NO CONVERGENCE TO AN -C EIGENVALUE AFTER 30 ITERATIONS .......... - 1000 IERR = L - 1001 RETURN - END diff --git a/slatec/tqlrat.f b/slatec/tqlrat.f deleted file mode 100644 index 8cb7b9c..0000000 --- a/slatec/tqlrat.f +++ /dev/null @@ -1,165 +0,0 @@ -*DECK TQLRAT - SUBROUTINE TQLRAT (N, D, E2, IERR) -C***BEGIN PROLOGUE TQLRAT -C***PURPOSE Compute the eigenvalues of symmetric tridiagonal matrix -C using a rational variant of the QL method. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4A5, D4C2A -C***TYPE SINGLE PRECISION (TQLRAT-S) -C***KEYWORDS EIGENVALUES OF A SYMMETRIC TRIDIAGONAL MATRIX, EISPACK, -C QL METHOD -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure TQLRAT. -C -C This subroutine finds the eigenvalues of a SYMMETRIC -C TRIDIAGONAL matrix by the rational QL method. -C -C On Input -C -C N is the order of the matrix. N is an INTEGER variable. -C -C D contains the diagonal elements of the symmetric tridiagonal -C matrix. D is a one-dimensional REAL array, dimensioned D(N). -C -C E2 contains the squares of the subdiagonal elements of the -C symmetric tridiagonal matrix in its last N-1 positions. -C E2(1) is arbitrary. E2 is a one-dimensional REAL array, -C dimensioned E2(N). -C -C On Output -C -C D contains the eigenvalues in ascending order. If an -C error exit is made, the eigenvalues are correct and -C ordered for indices 1, 2, ..., IERR-1, but may not be -C the smallest eigenvalues. -C -C E2 has been destroyed. -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C J if the J-th eigenvalue has not been -C determined after 30 iterations. -C -C Calls PYTHAG(A,B) for sqrt(A**2 + B**2). -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C C. H. Reinsch, Eigenvalues of a real, symmetric, tri- -C diagonal matrix, Algorithm 464, Communications of the -C ACM 16, 11 (November 1973), pp. 689. -C***ROUTINES CALLED PYTHAG, R1MACH -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE TQLRAT -C - INTEGER I,J,L,M,N,II,L1,MML,IERR - REAL D(*),E2(*) - REAL B,C,F,G,H,P,R,S,MACHEP - REAL PYTHAG - LOGICAL FIRST -C - SAVE FIRST, MACHEP - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT TQLRAT - IF (FIRST) THEN - MACHEP = R1MACH(4) - ENDIF - FIRST = .FALSE. -C - IERR = 0 - IF (N .EQ. 1) GO TO 1001 -C - DO 100 I = 2, N - 100 E2(I-1) = E2(I) -C - F = 0.0E0 - B = 0.0E0 - E2(N) = 0.0E0 -C - DO 290 L = 1, N - J = 0 - H = MACHEP * (ABS(D(L)) + SQRT(E2(L))) - IF (B .GT. H) GO TO 105 - B = H - C = B * B -C .......... LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT .......... - 105 DO 110 M = L, N - IF (E2(M) .LE. C) GO TO 120 -C .......... E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT -C THROUGH THE BOTTOM OF THE LOOP .......... - 110 CONTINUE -C - 120 IF (M .EQ. L) GO TO 210 - 130 IF (J .EQ. 30) GO TO 1000 - J = J + 1 -C .......... FORM SHIFT .......... - L1 = L + 1 - S = SQRT(E2(L)) - G = D(L) - P = (D(L1) - G) / (2.0E0 * S) - R = PYTHAG(P,1.0E0) - D(L) = S / (P + SIGN(R,P)) - H = G - D(L) -C - DO 140 I = L1, N - 140 D(I) = D(I) - H -C - F = F + H -C .......... RATIONAL QL TRANSFORMATION .......... - G = D(M) - IF (G .EQ. 0.0E0) G = B - H = G - S = 0.0E0 - MML = M - L -C .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... - DO 200 II = 1, MML - I = M - II - P = G * H - R = P + E2(I) - E2(I+1) = S * R - S = E2(I) / R - D(I+1) = H + S * (H + D(I)) - G = D(I) - E2(I) / G - IF (G .EQ. 0.0E0) G = B - H = G * P / R - 200 CONTINUE -C - E2(L) = S * G - D(L) = H -C .......... GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST .......... - IF (H .EQ. 0.0E0) GO TO 210 - IF (ABS(E2(L)) .LE. ABS(C/H)) GO TO 210 - E2(L) = H * E2(L) - IF (E2(L) .NE. 0.0E0) GO TO 130 - 210 P = D(L) + F -C .......... ORDER EIGENVALUES .......... - IF (L .EQ. 1) GO TO 250 -C .......... FOR I=L STEP -1 UNTIL 2 DO -- .......... - DO 230 II = 2, L - I = L + 2 - II - IF (P .GE. D(I-1)) GO TO 270 - D(I) = D(I-1) - 230 CONTINUE -C - 250 I = 1 - 270 D(I) = P - 290 CONTINUE -C - GO TO 1001 -C .......... SET ERROR -- NO CONVERGENCE TO AN -C EIGENVALUE AFTER 30 ITERATIONS .......... - 1000 IERR = L - 1001 RETURN - END diff --git a/slatec/trbak1.f b/slatec/trbak1.f deleted file mode 100644 index 00b8ac9..0000000 --- a/slatec/trbak1.f +++ /dev/null @@ -1,101 +0,0 @@ -*DECK TRBAK1 - SUBROUTINE TRBAK1 (NM, N, A, E, M, Z) -C***BEGIN PROLOGUE TRBAK1 -C***PURPOSE Form the eigenvectors of real symmetric matrix from -C the eigenvectors of a symmetric tridiagonal matrix formed -C by TRED1. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C4 -C***TYPE SINGLE PRECISION (TRBAK1-S) -C***KEYWORDS EIGENVECTORS OF A REAL SYMMETRIC MATRIX, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure TRBAK1, -C NUM. MATH. 11, 181-195(1968) by Martin, Reinsch, and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). -C -C This subroutine forms the eigenvectors of a REAL SYMMETRIC -C matrix by back transforming those of the corresponding -C symmetric tridiagonal matrix determined by TRED1. -C -C On Input -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, A and Z, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C A contains information about the orthogonal transformations -C used in the reduction by TRED1 in its strict lower -C triangle. A is a two-dimensional REAL array, dimensioned -C A(NM,N). -C -C E contains the subdiagonal elements of the tridiagonal matrix -C in its last N-1 positions. E(1) is arbitrary. These -C elements provide the remaining information about the -C orthogonal transformations. E is a one-dimensional REAL -C array, dimensioned E(N). -C -C M is the number of columns of Z to be back transformed. -C M is an INTEGER variable. -C -C Z contains the eigenvectors to be back transformed in its -C first M columns. Z is a two-dimensional REAL array, -C dimensioned Z(NM,M). -C -C On Output -C -C Z contains the transformed eigenvectors in its first M columns. -C -C Note that TRBAK1 preserves vector Euclidean norms. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE TRBAK1 -C - INTEGER I,J,K,L,M,N,NM - REAL A(NM,*),E(*),Z(NM,*) - REAL S -C -C***FIRST EXECUTABLE STATEMENT TRBAK1 - IF (M .EQ. 0) GO TO 200 - IF (N .EQ. 1) GO TO 200 -C - DO 140 I = 2, N - L = I - 1 - IF (E(I) .EQ. 0.0E0) GO TO 140 -C - DO 130 J = 1, M - S = 0.0E0 -C - DO 110 K = 1, L - 110 S = S + A(I,K) * Z(K,J) -C .......... DIVISOR BELOW IS NEGATIVE OF H FORMED IN TRED1. -C DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW .......... - S = (S / A(I,L)) / E(I) -C - DO 120 K = 1, L - 120 Z(K,J) = Z(K,J) + S * A(I,K) -C - 130 CONTINUE -C - 140 CONTINUE -C - 200 RETURN - END diff --git a/slatec/trbak3.f b/slatec/trbak3.f deleted file mode 100644 index 72fba79..0000000 --- a/slatec/trbak3.f +++ /dev/null @@ -1,107 +0,0 @@ -*DECK TRBAK3 - SUBROUTINE TRBAK3 (NM, N, NV, A, M, Z) -C***BEGIN PROLOGUE TRBAK3 -C***PURPOSE Form the eigenvectors of a real symmetric matrix from the -C eigenvectors of a symmetric tridiagonal matrix formed -C by TRED3. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C4 -C***TYPE SINGLE PRECISION (TRBAK3-S) -C***KEYWORDS EIGENVECTORS OF A REAL SYMMETRIC MATRIX, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure TRBAK3, -C NUM. MATH. 11, 181-195(1968) by Martin, Reinsch, and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). -C -C This subroutine forms the eigenvectors of a REAL SYMMETRIC -C matrix by back transforming those of the corresponding -C symmetric tridiagonal matrix determined by TRED3. -C -C On Input -C -C NM must be set to the row dimension of the two-dimensional -C array parameter, Z, as declared in the calling program -C dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C NV is an INTEGER variable set equal to the dimension of the -C array A as specified in the calling program. NV must not -C be less than N*(N+1)/2. -C -C A contains information about the orthogonal transformations -C used in the reduction by TRED3 in its first N*(N+1)/2 -C positions. A is a one-dimensional REAL array, dimensioned -C A(NV). -C -C M is the number of columns of Z to be back transformed. -C M is an INTEGER variable. -C -C Z contains the eigenvectors to be back transformed in its -C first M columns. Z is a two-dimensional REAL array, -C dimensioned Z(NM,M). -C -C On Output -C -C Z contains the transformed eigenvectors in its first M columns. -C -C Note that TRBAK3 preserves vector Euclidean norms. -C -C Questions and comments should be directed to b. s. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE TRBAK3 -C - INTEGER I,J,K,L,M,N,IK,IZ,NM,NV - REAL A(*),Z(NM,*) - REAL H,S -C -C***FIRST EXECUTABLE STATEMENT TRBAK3 - IF (M .EQ. 0) GO TO 200 - IF (N .EQ. 1) GO TO 200 -C - DO 140 I = 2, N - L = I - 1 - IZ = (I * L) / 2 - IK = IZ + I - H = A(IK) - IF (H .EQ. 0.0E0) GO TO 140 -C - DO 130 J = 1, M - S = 0.0E0 - IK = IZ -C - DO 110 K = 1, L - IK = IK + 1 - S = S + A(IK) * Z(K,J) - 110 CONTINUE -C .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW .......... - S = (S / H) / H - IK = IZ -C - DO 120 K = 1, L - IK = IK + 1 - Z(K,J) = Z(K,J) - S * A(IK) - 120 CONTINUE -C - 130 CONTINUE -C - 140 CONTINUE -C - 200 RETURN - END diff --git a/slatec/tred1.f b/slatec/tred1.f deleted file mode 100644 index 1586bd5..0000000 --- a/slatec/tred1.f +++ /dev/null @@ -1,142 +0,0 @@ -*DECK TRED1 - SUBROUTINE TRED1 (NM, N, A, D, E, E2) -C***BEGIN PROLOGUE TRED1 -C***PURPOSE Reduce a real symmetric matrix to symmetric tridiagonal -C matrix using orthogonal similarity transformations. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C1B1 -C***TYPE SINGLE PRECISION (TRED1-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure TRED1, -C NUM. MATH. 11, 181-195(1968) by Martin, Reinsch, and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). -C -C This subroutine reduces a REAL SYMMETRIC matrix -C to a symmetric tridiagonal matrix using -C orthogonal similarity transformations. -C -C On Input -C -C NM must be set to the row dimension of the two-dimensional -C array parameter, A, as declared in the calling program -C dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix A. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C A contains the real symmetric input matrix. Only the lower -C triangle of the matrix need be supplied. A is a two- -C dimensional REAL array, dimensioned A(NM,N). -C -C On Output -C -C A contains information about the orthogonal transformations -C used in the reduction in its strict lower triangle. The -C full upper triangle of A is unaltered. -C -C D contains the diagonal elements of the symmetric tridiagonal -C matrix. D is a one-dimensional REAL array, dimensioned D(N). -C -C E contains the subdiagonal elements of the symmetric -C tridiagonal matrix in its last N-1 positions. E(1) is set -C to zero. E is a one-dimensional REAL array, dimensioned -C E(N). -C -C E2 contains the squares of the corresponding elements of E. -C E2 may coincide with E if the squares are not needed. -C E2 is a one-dimensional REAL array, dimensioned E2(N). -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE TRED1 -C - INTEGER I,J,K,L,N,II,NM,JP1 - REAL A(NM,*),D(*),E(*),E2(*) - REAL F,G,H,SCALE -C -C***FIRST EXECUTABLE STATEMENT TRED1 - DO 100 I = 1, N - 100 D(I) = A(I,I) -C .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... - DO 300 II = 1, N - I = N + 1 - II - L = I - 1 - H = 0.0E0 - SCALE = 0.0E0 - IF (L .LT. 1) GO TO 130 -C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... - DO 120 K = 1, L - 120 SCALE = SCALE + ABS(A(I,K)) -C - IF (SCALE .NE. 0.0E0) GO TO 140 - 130 E(I) = 0.0E0 - E2(I) = 0.0E0 - GO TO 290 -C - 140 DO 150 K = 1, L - A(I,K) = A(I,K) / SCALE - H = H + A(I,K) * A(I,K) - 150 CONTINUE -C - E2(I) = SCALE * SCALE * H - F = A(I,L) - G = -SIGN(SQRT(H),F) - E(I) = SCALE * G - H = H - F * G - A(I,L) = F - G - IF (L .EQ. 1) GO TO 270 - F = 0.0E0 -C - DO 240 J = 1, L - G = 0.0E0 -C .......... FORM ELEMENT OF A*U .......... - DO 180 K = 1, J - 180 G = G + A(J,K) * A(I,K) -C - JP1 = J + 1 - IF (L .LT. JP1) GO TO 220 -C - DO 200 K = JP1, L - 200 G = G + A(K,J) * A(I,K) -C .......... FORM ELEMENT OF P .......... - 220 E(J) = G / H - F = F + E(J) * A(I,J) - 240 CONTINUE -C - H = F / (H + H) -C .......... FORM REDUCED A .......... - DO 260 J = 1, L - F = A(I,J) - G = E(J) - H * F - E(J) = G -C - DO 260 K = 1, J - A(J,K) = A(J,K) - F * E(K) - G * A(I,K) - 260 CONTINUE -C - 270 DO 280 K = 1, L - 280 A(I,K) = SCALE * A(I,K) -C - 290 H = D(I) - D(I) = A(I,I) - A(I,I) = H - 300 CONTINUE -C - RETURN - END diff --git a/slatec/tred2.f b/slatec/tred2.f deleted file mode 100644 index 6b52c32..0000000 --- a/slatec/tred2.f +++ /dev/null @@ -1,166 +0,0 @@ -*DECK TRED2 - SUBROUTINE TRED2 (NM, N, A, D, E, Z) -C***BEGIN PROLOGUE TRED2 -C***PURPOSE Reduce a real symmetric matrix to a symmetric tridiagonal -C matrix using and accumulating orthogonal transformations. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C1B1 -C***TYPE SINGLE PRECISION (TRED2-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure TRED2, -C NUM. MATH. 11, 181-195(1968) by Martin, Reinsch, and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). -C -C This subroutine reduces a REAL SYMMETRIC matrix to a -C symmetric tridiagonal matrix using and accumulating -C orthogonal similarity transformations. -C -C On Input -C -C NM must be set to the row dimension of the two-dimensional -C array parameters, A and Z, as declared in the calling -C program dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix A. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C A contains the real symmetric input matrix. Only the lower -C triangle of the matrix need be supplied. A is a two- -C dimensional REAL array, dimensioned A(NM,N). -C -C On Output -C -C D contains the diagonal elements of the symmetric tridiagonal -C matrix. D is a one-dimensional REAL array, dimensioned D(N). -C -C E contains the subdiagonal elements of the symmetric -C tridiagonal matrix in its last N-1 positions. E(1) is set -C to zero. E is a one-dimensional REAL array, dimensioned -C E(N). -C -C Z contains the orthogonal transformation matrix produced in -C the reduction. Z is a two-dimensional REAL array, -C dimensioned Z(NM,N). -C -C A and Z may coincide. If distinct, A is unaltered. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE TRED2 -C - INTEGER I,J,K,L,N,II,NM,JP1 - REAL A(NM,*),D(*),E(*),Z(NM,*) - REAL F,G,H,HH,SCALE -C -C***FIRST EXECUTABLE STATEMENT TRED2 - DO 100 I = 1, N -C - DO 100 J = 1, I - Z(I,J) = A(I,J) - 100 CONTINUE -C - IF (N .EQ. 1) GO TO 320 -C .......... FOR I=N STEP -1 UNTIL 2 DO -- .......... - DO 300 II = 2, N - I = N + 2 - II - L = I - 1 - H = 0.0E0 - SCALE = 0.0E0 - IF (L .LT. 2) GO TO 130 -C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... - DO 120 K = 1, L - 120 SCALE = SCALE + ABS(Z(I,K)) -C - IF (SCALE .NE. 0.0E0) GO TO 140 - 130 E(I) = Z(I,L) - GO TO 290 -C - 140 DO 150 K = 1, L - Z(I,K) = Z(I,K) / SCALE - H = H + Z(I,K) * Z(I,K) - 150 CONTINUE -C - F = Z(I,L) - G = -SIGN(SQRT(H),F) - E(I) = SCALE * G - H = H - F * G - Z(I,L) = F - G - F = 0.0E0 -C - DO 240 J = 1, L - Z(J,I) = Z(I,J) / H - G = 0.0E0 -C .......... FORM ELEMENT OF A*U .......... - DO 180 K = 1, J - 180 G = G + Z(J,K) * Z(I,K) -C - JP1 = J + 1 - IF (L .LT. JP1) GO TO 220 -C - DO 200 K = JP1, L - 200 G = G + Z(K,J) * Z(I,K) -C .......... FORM ELEMENT OF P .......... - 220 E(J) = G / H - F = F + E(J) * Z(I,J) - 240 CONTINUE -C - HH = F / (H + H) -C .......... FORM REDUCED A .......... - DO 260 J = 1, L - F = Z(I,J) - G = E(J) - HH * F - E(J) = G -C - DO 260 K = 1, J - Z(J,K) = Z(J,K) - F * E(K) - G * Z(I,K) - 260 CONTINUE -C - 290 D(I) = H - 300 CONTINUE -C - 320 D(1) = 0.0E0 - E(1) = 0.0E0 -C .......... ACCUMULATION OF TRANSFORMATION MATRICES .......... - DO 500 I = 1, N - L = I - 1 - IF (D(I) .EQ. 0.0E0) GO TO 380 -C - DO 360 J = 1, L - G = 0.0E0 -C - DO 340 K = 1, L - 340 G = G + Z(I,K) * Z(K,J) -C - DO 360 K = 1, L - Z(K,J) = Z(K,J) - G * Z(K,I) - 360 CONTINUE -C - 380 D(I) = Z(I,I) - Z(I,I) = 1.0E0 - IF (L .LT. 1) GO TO 500 -C - DO 400 J = 1, L - Z(I,J) = 0.0E0 - Z(J,I) = 0.0E0 - 400 CONTINUE -C - 500 CONTINUE -C - RETURN - END diff --git a/slatec/tred3.f b/slatec/tred3.f deleted file mode 100644 index c07ad24..0000000 --- a/slatec/tred3.f +++ /dev/null @@ -1,140 +0,0 @@ -*DECK TRED3 - SUBROUTINE TRED3 (N, NV, A, D, E, E2) -C***BEGIN PROLOGUE TRED3 -C***PURPOSE Reduce a real symmetric matrix stored in packed form to -C symmetric tridiagonal matrix using orthogonal -C transformations. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4C1B1 -C***TYPE SINGLE PRECISION (TRED3-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure TRED3, -C NUM. MATH. 11, 181-195(1968) by Martin, Reinsch, and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). -C -C This subroutine reduces a REAL SYMMETRIC matrix, stored as -C a one-dimensional array, to a symmetric tridiagonal matrix -C using orthogonal similarity transformations. -C -C On Input -C -C N is the order of the matrix A. N is an INTEGER variable. -C -C NV is an INTEGER variable set equal to the dimension of the -C array A as specified in the calling program. NV must not -C be less than N*(N+1)/2. -C -C A contains the lower triangle, stored row-wise, of the real -C symmetric packed matrix. A is a one-dimensional REAL -C array, dimensioned A(NV). -C -C On Output -C -C A contains information about the orthogonal transformations -C used in the reduction in its first N*(N+1)/2 positions. -C -C D contains the diagonal elements of the symmetric tridiagonal -C matrix. D is a one-dimensional REAL array, dimensioned D(N). -C -C E contains the subdiagonal elements of the symmetric -C tridiagonal matrix in its last N-1 positions. E(1) is set -C to zero. E is a one-dimensional REAL array, dimensioned -C E(N). -C -C E2 contains the squares of the corresponding elements of E. -C E2 may coincide with E if the squares are not needed. -C E2 is a one-dimensional REAL array, dimensioned E2(N). -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 760101 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 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE TRED3 -C - INTEGER I,J,K,L,N,II,IZ,JK,NV - REAL A(*),D(*),E(*),E2(*) - REAL F,G,H,HH,SCALE -C -C .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... -C***FIRST EXECUTABLE STATEMENT TRED3 - DO 300 II = 1, N - I = N + 1 - II - L = I - 1 - IZ = (I * L) / 2 - H = 0.0E0 - SCALE = 0.0E0 - IF (L .LT. 1) GO TO 130 -C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... - DO 120 K = 1, L - IZ = IZ + 1 - D(K) = A(IZ) - SCALE = SCALE + ABS(D(K)) - 120 CONTINUE -C - IF (SCALE .NE. 0.0E0) GO TO 140 - 130 E(I) = 0.0E0 - E2(I) = 0.0E0 - GO TO 290 -C - 140 DO 150 K = 1, L - D(K) = D(K) / SCALE - H = H + D(K) * D(K) - 150 CONTINUE -C - E2(I) = SCALE * SCALE * H - F = D(L) - G = -SIGN(SQRT(H),F) - E(I) = SCALE * G - H = H - F * G - D(L) = F - G - A(IZ) = SCALE * D(L) - IF (L .EQ. 1) GO TO 290 - F = 0.0E0 -C - DO 240 J = 1, L - G = 0.0E0 - JK = (J * (J-1)) / 2 -C .......... FORM ELEMENT OF A*U .......... - DO 180 K = 1, L - JK = JK + 1 - IF (K .GT. J) JK = JK + K - 2 - G = G + A(JK) * D(K) - 180 CONTINUE -C .......... FORM ELEMENT OF P .......... - E(J) = G / H - F = F + E(J) * D(J) - 240 CONTINUE -C - HH = F / (H + H) - JK = 0 -C .......... FORM REDUCED A .......... - DO 260 J = 1, L - F = D(J) - G = E(J) - HH * F - E(J) = G -C - DO 260 K = 1, J - JK = JK + 1 - A(JK) = A(JK) - F * E(K) - G * D(K) - 260 CONTINUE -C - 290 D(I) = A(IZ+1) - A(IZ+1) = SCALE * SQRT(H) - 300 CONTINUE -C - RETURN - END diff --git a/slatec/tri3.f b/slatec/tri3.f deleted file mode 100644 index 06c2b29..0000000 --- a/slatec/tri3.f +++ /dev/null @@ -1,112 +0,0 @@ -*DECK TRI3 - SUBROUTINE TRI3 (M, A, B, C, K, Y1, Y2, Y3, TCOS, D, W1, W2, W3) -C***BEGIN PROLOGUE TRI3 -C***SUBSIDIARY -C***PURPOSE Subsidiary to GENBUN -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (TRI3-S, CMPTR3-C) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Subroutine to solve three linear systems whose common coefficient -C matrix is a rational function in the matrix given by -C -C TRIDIAGONAL (...,A(I),B(I),C(I),...) -C -C***SEE ALSO GENBUN -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890206 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE TRI3 - DIMENSION A(*) ,B(*) ,C(*) ,K(4) , - 1 TCOS(*) ,Y1(*) ,Y2(*) ,Y3(*) , - 2 D(*) ,W1(*) ,W2(*) ,W3(*) - INTEGER K1P1, K2P1, K3P1, K4P1 -C -C***FIRST EXECUTABLE STATEMENT TRI3 - MM1 = M-1 - K1 = K(1) - K2 = K(2) - K3 = K(3) - K4 = K(4) - K1P1 = K1+1 - K2P1 = K2+1 - K3P1 = K3+1 - K4P1 = K4+1 - K2K3K4 = K2+K3+K4 - IF (K2K3K4 .EQ. 0) GO TO 101 - L1 = (K1+1)/(K2+1) - L2 = (K1+1)/(K3+1) - L3 = (K1+1)/(K4+1) - LINT1 = 1 - LINT2 = 1 - LINT3 = 1 - KINT1 = K1 - KINT2 = KINT1+K2 - KINT3 = KINT2+K3 - 101 CONTINUE - DO 115 N=1,K1 - X = TCOS(N) - IF (K2K3K4 .EQ. 0) GO TO 107 - IF (N .NE. L1) GO TO 103 - DO 102 I=1,M - W1(I) = Y1(I) - 102 CONTINUE - 103 IF (N .NE. L2) GO TO 105 - DO 104 I=1,M - W2(I) = Y2(I) - 104 CONTINUE - 105 IF (N .NE. L3) GO TO 107 - DO 106 I=1,M - W3(I) = Y3(I) - 106 CONTINUE - 107 CONTINUE - Z = 1./(B(1)-X) - D(1) = C(1)*Z - Y1(1) = Y1(1)*Z - Y2(1) = Y2(1)*Z - Y3(1) = Y3(1)*Z - DO 108 I=2,M - Z = 1./(B(I)-X-A(I)*D(I-1)) - D(I) = C(I)*Z - Y1(I) = (Y1(I)-A(I)*Y1(I-1))*Z - Y2(I) = (Y2(I)-A(I)*Y2(I-1))*Z - Y3(I) = (Y3(I)-A(I)*Y3(I-1))*Z - 108 CONTINUE - DO 109 IP=1,MM1 - I = M-IP - Y1(I) = Y1(I)-D(I)*Y1(I+1) - Y2(I) = Y2(I)-D(I)*Y2(I+1) - Y3(I) = Y3(I)-D(I)*Y3(I+1) - 109 CONTINUE - IF (K2K3K4 .EQ. 0) GO TO 115 - IF (N .NE. L1) GO TO 111 - I = LINT1+KINT1 - XX = X-TCOS(I) - DO 110 I=1,M - Y1(I) = XX*Y1(I)+W1(I) - 110 CONTINUE - LINT1 = LINT1+1 - L1 = (LINT1*K1P1)/K2P1 - 111 IF (N .NE. L2) GO TO 113 - I = LINT2+KINT2 - XX = X-TCOS(I) - DO 112 I=1,M - Y2(I) = XX*Y2(I)+W2(I) - 112 CONTINUE - LINT2 = LINT2+1 - L2 = (LINT2*K1P1)/K3P1 - 113 IF (N .NE. L3) GO TO 115 - I = LINT3+KINT3 - XX = X-TCOS(I) - DO 114 I=1,M - Y3(I) = XX*Y3(I)+W3(I) - 114 CONTINUE - LINT3 = LINT3+1 - L3 = (LINT3*K1P1)/K4P1 - 115 CONTINUE - RETURN - END diff --git a/slatec/tridib.f b/slatec/tridib.f deleted file mode 100644 index 48e692e..0000000 --- a/slatec/tridib.f +++ /dev/null @@ -1,306 +0,0 @@ -*DECK TRIDIB - SUBROUTINE TRIDIB (N, EPS1, D, E, E2, LB, UB, M11, M, W, IND, - + IERR, RV4, RV5) -C***BEGIN PROLOGUE TRIDIB -C***PURPOSE Compute the eigenvalues of a symmetric tridiagonal matrix -C in a given interval using Sturm sequencing. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4A5, D4C2A -C***TYPE SINGLE PRECISION (TRIDIB-S) -C***KEYWORDS EIGENVALUES OF A REAL SYMMETRIC MATRIX, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine is a translation of the ALGOL procedure BISECT, -C NUM. MATH. 9, 386-393(1967) by Barth, Martin, and Wilkinson. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 249-256(1971). -C -C This subroutine finds those eigenvalues of a TRIDIAGONAL -C SYMMETRIC matrix between specified boundary indices, -C using bisection. -C -C On Input -C -C N is the order of the matrix. N is an INTEGER variable. -C -C EPS1 is an absolute error tolerance for the computed eigen- -C values. If the input EPS1 is non-positive, it is reset for -C each submatrix to a default value, namely, minus the product -C of the relative machine precision and the 1-norm of the -C submatrix. EPS1 is a REAL variable. -C -C D contains the diagonal elements of the symmetric tridiagonal -C matrix. D is a one-dimensional REAL array, dimensioned D(N). -C -C E contains the subdiagonal elements of the symmetric -C tridiagonal matrix in its last N-1 positions. E(1) is -C arbitrary. E is a one-dimensional REAL array, dimensioned -C E(N). -C -C E2 contains the squares of the corresponding elements of E. -C E2(1) is arbitrary. E2 is a one-dimensional REAL array, -C dimensioned E2(N). -C -C M11 specifies the lower boundary index for the set of desired -C eigenvalues. M11 is an INTEGER variable. -C -C M specifies the number of eigenvalues desired. The upper -C boundary index M22 is then obtained as M22=M11+M-1. -C M is an INTEGER variable. -C -C On Output -C -C EPS1 is unaltered unless it has been reset to its -C (last) default value. -C -C D and E are unaltered. -C -C Elements of E2, corresponding to elements of E regarded -C as negligible, have been replaced by zero causing the -C matrix to split into a direct sum of submatrices. -C E2(1) is also set to zero. -C -C LB and UB define an interval containing exactly the desired -C eigenvalues. LB and UB are REAL variables. -C -C W contains, in its first M positions, the eigenvalues -C between indices M11 and M22 in ascending order. -C W is a one-dimensional REAL array, dimensioned W(M). -C -C IND contains in its first M positions the submatrix indices -C associated with the corresponding eigenvalues in W -- -C 1 for eigenvalues belonging to the first submatrix from -C the top, 2 for those belonging to the second submatrix, etc. -C IND is an one-dimensional INTEGER array, dimensioned IND(M). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C 3*N+1 if multiple eigenvalues at index M11 make -C unique selection of LB impossible, -C 3*N+2 if multiple eigenvalues at index M22 make -C unique selection of UB impossible. -C -C RV4 and RV5 are one-dimensional REAL arrays used for temporary -C storage of the lower and upper bounds for the eigenvalues in -C the bisection process. RV4 and RV5 are dimensioned RV4(N) -C and RV5(N). -C -C Note that subroutine TQL1, IMTQL1, or TQLRAT is generally faster -C than TRIDIB, if more than N/4 eigenvalues are to be found. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED R1MACH -C***REVISION HISTORY (YYMMDD) -C 760101 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 TRIDIB -C - INTEGER I,J,K,L,M,N,P,Q,R,S,II,M1,M2,M11,M22,TAG,IERR,ISTURM - REAL D(*),E(*),E2(*),W(*),RV4(*),RV5(*) - REAL U,V,LB,T1,T2,UB,XU,X0,X1,EPS1,MACHEP,S1,S2 - INTEGER IND(*) - LOGICAL FIRST -C - SAVE FIRST, MACHEP - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT TRIDIB - IF (FIRST) THEN - MACHEP = R1MACH(4) - ENDIF - FIRST = .FALSE. -C - IERR = 0 - TAG = 0 - XU = D(1) - X0 = D(1) - U = 0.0E0 -C .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES AND DETERMINE AN -C INTERVAL CONTAINING ALL THE EIGENVALUES .......... - DO 40 I = 1, N - X1 = U - U = 0.0E0 - IF (I .NE. N) U = ABS(E(I+1)) - XU = MIN(D(I)-(X1+U),XU) - X0 = MAX(D(I)+(X1+U),X0) - IF (I .EQ. 1) GO TO 20 - S1 = ABS(D(I)) + ABS(D(I-1)) - S2 = S1 + ABS(E(I)) - IF (S2 .GT. S1) GO TO 40 - 20 E2(I) = 0.0E0 - 40 CONTINUE -C - X1 = MAX(ABS(XU),ABS(X0)) * MACHEP * N - XU = XU - X1 - T1 = XU - X0 = X0 + X1 - T2 = X0 -C .......... DETERMINE AN INTERVAL CONTAINING EXACTLY -C THE DESIRED EIGENVALUES .......... - P = 1 - Q = N - M1 = M11 - 1 - IF (M1 .EQ. 0) GO TO 75 - ISTURM = 1 - 50 V = X1 - X1 = XU + (X0 - XU) * 0.5E0 - IF (X1 .EQ. V) GO TO 980 - GO TO 320 - 60 IF (S - M1) 65, 73, 70 - 65 XU = X1 - GO TO 50 - 70 X0 = X1 - GO TO 50 - 73 XU = X1 - T1 = X1 - 75 M22 = M1 + M - IF (M22 .EQ. N) GO TO 90 - X0 = T2 - ISTURM = 2 - GO TO 50 - 80 IF (S - M22) 65, 85, 70 - 85 T2 = X1 - 90 Q = 0 - R = 0 -C .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING -C INTERVAL BY THE GERSCHGORIN BOUNDS .......... - 100 IF (R .EQ. M) GO TO 1001 - TAG = TAG + 1 - P = Q + 1 - XU = D(P) - X0 = D(P) - U = 0.0E0 -C - DO 120 Q = P, N - X1 = U - U = 0.0E0 - V = 0.0E0 - IF (Q .EQ. N) GO TO 110 - U = ABS(E(Q+1)) - V = E2(Q+1) - 110 XU = MIN(D(Q)-(X1+U),XU) - X0 = MAX(D(Q)+(X1+U),X0) - IF (V .EQ. 0.0E0) GO TO 140 - 120 CONTINUE -C - 140 X1 = MAX(ABS(XU),ABS(X0)) * MACHEP - IF (EPS1 .LE. 0.0E0) EPS1 = -X1 - IF (P .NE. Q) GO TO 180 -C .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL .......... - IF (T1 .GT. D(P) .OR. D(P) .GE. T2) GO TO 940 - M1 = P - M2 = P - RV5(P) = D(P) - GO TO 900 - 180 X1 = X1 * (Q-P+1) - LB = MAX(T1,XU-X1) - UB = MIN(T2,X0+X1) - X1 = LB - ISTURM = 3 - GO TO 320 - 200 M1 = S + 1 - X1 = UB - ISTURM = 4 - GO TO 320 - 220 M2 = S - IF (M1 .GT. M2) GO TO 940 -C .......... FIND ROOTS BY BISECTION .......... - X0 = UB - ISTURM = 5 -C - DO 240 I = M1, M2 - RV5(I) = UB - RV4(I) = LB - 240 CONTINUE -C .......... LOOP FOR K-TH EIGENVALUE -C FOR K=M2 STEP -1 UNTIL M1 DO -- -C (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) .......... - K = M2 - 250 XU = LB -C .......... FOR I=K STEP -1 UNTIL M1 DO -- .......... - DO 260 II = M1, K - I = M1 + K - II - IF (XU .GE. RV4(I)) GO TO 260 - XU = RV4(I) - GO TO 280 - 260 CONTINUE -C - 280 IF (X0 .GT. RV5(K)) X0 = RV5(K) -C .......... NEXT BISECTION STEP .......... - 300 X1 = (XU + X0) * 0.5E0 - S1 = ABS(XU) + ABS(X0) + ABS(EPS1) - S2 = S1 + ABS(X0-XU)/2.0E0 - IF (S2 .EQ. S1) GO TO 420 -C .......... IN-LINE PROCEDURE FOR STURM SEQUENCE .......... - 320 S = P - 1 - U = 1.0E0 -C - DO 340 I = P, Q - IF (U .NE. 0.0E0) GO TO 325 - V = ABS(E(I)) / MACHEP - IF (E2(I) .EQ. 0.0E0) V = 0.0E0 - GO TO 330 - 325 V = E2(I) / U - 330 U = D(I) - X1 - V - IF (U .LT. 0.0E0) S = S + 1 - 340 CONTINUE -C - GO TO (60,80,200,220,360), ISTURM -C .......... REFINE INTERVALS .......... - 360 IF (S .GE. K) GO TO 400 - XU = X1 - IF (S .GE. M1) GO TO 380 - RV4(M1) = X1 - GO TO 300 - 380 RV4(S+1) = X1 - IF (RV5(S) .GT. X1) RV5(S) = X1 - GO TO 300 - 400 X0 = X1 - GO TO 300 -C .......... K-TH EIGENVALUE FOUND .......... - 420 RV5(K) = X1 - K = K - 1 - IF (K .GE. M1) GO TO 250 -C .......... ORDER EIGENVALUES TAGGED WITH THEIR -C SUBMATRIX ASSOCIATIONS .......... - 900 S = R - R = R + M2 - M1 + 1 - J = 1 - K = M1 -C - DO 920 L = 1, R - IF (J .GT. S) GO TO 910 - IF (K .GT. M2) GO TO 940 - IF (RV5(K) .GE. W(L)) GO TO 915 -C - DO 905 II = J, S - I = L + S - II - W(I+1) = W(I) - IND(I+1) = IND(I) - 905 CONTINUE -C - 910 W(L) = RV5(K) - IND(L) = TAG - K = K + 1 - GO TO 920 - 915 J = J + 1 - 920 CONTINUE -C - 940 IF (Q .LT. N) GO TO 100 - GO TO 1001 -C .......... SET ERROR -- INTERVAL CANNOT BE FOUND CONTAINING -C EXACTLY THE DESIRED EIGENVALUES .......... - 980 IERR = 3 * N + ISTURM - 1001 LB = T1 - UB = T2 - RETURN - END diff --git a/slatec/tridq.f b/slatec/tridq.f deleted file mode 100644 index cb54490..0000000 --- a/slatec/tridq.f +++ /dev/null @@ -1,41 +0,0 @@ -*DECK TRIDQ - SUBROUTINE TRIDQ (MR, A, B, C, Y, D) -C***BEGIN PROLOGUE TRIDQ -C***SUBSIDIARY -C***PURPOSE Subsidiary to POIS3D -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (TRIDQ-S) -C***AUTHOR (UNKNOWN) -C***SEE ALSO POIS3D -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900308 Renamed routine from TRID to TRIDQ. (WRB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE TRIDQ - DIMENSION A(*) ,B(*) ,C(*) ,Y(*) , - 1 D(*) -C***FIRST EXECUTABLE STATEMENT TRIDQ - M = MR - MM1 = M-1 - Z = 1./B(1) - D(1) = C(1)*Z - Y(1) = Y(1)*Z - DO 101 I=2,MM1 - Z = 1./(B(I)-A(I)*D(I-1)) - D(I) = C(I)*Z - Y(I) = (Y(I)-A(I)*Y(I-1))*Z - 101 CONTINUE - Z = B(M)-A(M)*D(MM1) - IF (Z .NE. 0.) GO TO 102 - Y(M) = 0. - GO TO 103 - 102 Y(M) = (Y(M)-A(M)*Y(MM1))/Z - 103 CONTINUE - DO 104 IP=1,MM1 - I = M-IP - Y(I) = Y(I)-D(I)*Y(I+1) - 104 CONTINUE - RETURN - END diff --git a/slatec/tris4.f b/slatec/tris4.f deleted file mode 100644 index 8d9ce22..0000000 --- a/slatec/tris4.f +++ /dev/null @@ -1,57 +0,0 @@ -*DECK TRIS4 - SUBROUTINE TRIS4 (N, A, B, C, D, U, Z) -C***BEGIN PROLOGUE TRIS4 -C***SUBSIDIARY -C***PURPOSE Subsidiary to SEPX4 -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (TRIS4-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This subroutine solves for a non-zero eigenvector corresponding -C to the zero eigenvalue of the transpose of the rank -C deficient ONE matrix with subdiagonal A, diagonal B, and -C superdiagonal C , with A(1) in the (1,N) position, with -C C(N) in the (N,1) position, AND all other elements zero. -C -C***SEE ALSO SEPX4 -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE TRIS4 -C - DIMENSION A(*) ,B(*) ,C(*) ,D(*) , - 1 U(*) ,Z(*) -C***FIRST EXECUTABLE STATEMENT TRIS4 - BN = B(N) - D(1) = A(2)/B(1) - V = A(1) - U(1) = C(N)/B(1) - NM2 = N-2 - DO 10 J=2,NM2 - DEN = B(J)-C(J-1)*D(J-1) - D(J) = A(J+1)/DEN - U(J) = -C(J-1)*U(J-1)/DEN - BN = BN-V*U(J-1) - V = -V*D(J-1) - 10 CONTINUE - DEN = B(N-1)-C(N-2)*D(N-2) - D(N-1) = (A(N)-C(N-2)*U(N-2))/DEN - AN = C(N-1)-V*D(N-2) - BN = BN-V*U(N-2) - DEN = BN-AN*D(N-1) -C -C SET LAST COMPONENT EQUAL TO ONE -C - Z(N) = 1.0 - Z(N-1) = -D(N-1) - NM1 = N-1 - DO 20 J=2,NM1 - K = N-J - Z(K) = -D(K)*Z(K+1)-U(K)*Z(N) - 20 CONTINUE - RETURN - END diff --git a/slatec/trisp.f b/slatec/trisp.f deleted file mode 100644 index 404e105..0000000 --- a/slatec/trisp.f +++ /dev/null @@ -1,57 +0,0 @@ -*DECK TRISP - SUBROUTINE TRISP (N, A, B, C, D, U, Z) -C***BEGIN PROLOGUE TRISP -C***SUBSIDIARY -C***PURPOSE Subsidiary to SEPELI -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (TRISP-S) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This subroutine solves for a non-zero eigenvector corresponding -C to the zero eigenvalue of the transpose of the rank -C deficient ONE matrix with subdiagonal A, diagonal B, and -C superdiagonal C , with A(1) in the (1,N) position, with -C C(N) in the (N,1) position, and all other elements zero. -C -C***SEE ALSO SEPELI -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE TRISP -C - DIMENSION A(*) ,B(*) ,C(*) ,D(*) , - 1 U(*) ,Z(*) -C***FIRST EXECUTABLE STATEMENT TRISP - BN = B(N) - D(1) = A(2)/B(1) - V = A(1) - U(1) = C(N)/B(1) - NM2 = N-2 - DO 10 J=2,NM2 - DEN = B(J)-C(J-1)*D(J-1) - D(J) = A(J+1)/DEN - U(J) = -C(J-1)*U(J-1)/DEN - BN = BN-V*U(J-1) - V = -V*D(J-1) - 10 CONTINUE - DEN = B(N-1)-C(N-2)*D(N-2) - D(N-1) = (A(N)-C(N-2)*U(N-2))/DEN - AN = C(N-1)-V*D(N-2) - BN = BN-V*U(N-2) - DEN = BN-AN*D(N-1) -C -C SET LAST COMPONENT EQUAL TO ONE -C - Z(N) = 1.0 - Z(N-1) = -D(N-1) - NM1 = N-1 - DO 20 J=2,NM1 - K = N-J - Z(K) = -D(K)*Z(K+1)-U(K)*Z(N) - 20 CONTINUE - RETURN - END diff --git a/slatec/trix.f b/slatec/trix.f deleted file mode 100644 index ae76493..0000000 --- a/slatec/trix.f +++ /dev/null @@ -1,68 +0,0 @@ -*DECK TRIX - SUBROUTINE TRIX (IDEGBR, IDEGCR, M, A, B, C, Y, TCOS, D, W) -C***BEGIN PROLOGUE TRIX -C***SUBSIDIARY -C***PURPOSE Subsidiary to GENBUN -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (TRIX-S, CMPTRX-C) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Subroutine to solve a system of linear equations where the -C coefficient matrix is a rational function in the matrix given by -C TRIDIAGONAL ( . . . , A(I), B(I), C(I), . . . ). -C -C***SEE ALSO GENBUN -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 801001 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900402 Added TYPE section. (WRB) -C***END PROLOGUE TRIX -C - DIMENSION A(*) ,B(*) ,C(*) ,Y(*) , - 1 TCOS(*) ,D(*) ,W(*) - INTEGER KB, KC -C***FIRST EXECUTABLE STATEMENT TRIX - MM1 = M-1 - KB = IDEGBR+1 - KC = IDEGCR+1 - L = (IDEGBR+1)/(IDEGCR+1) - LINT = 1 - DO 108 K=1,IDEGBR - X = TCOS(K) - IF (K .NE. L) GO TO 102 - I = IDEGBR+LINT - XX = X-TCOS(I) - DO 101 I=1,M - W(I) = Y(I) - Y(I) = XX*Y(I) - 101 CONTINUE - 102 CONTINUE - Z = 1./(B(1)-X) - D(1) = C(1)*Z - Y(1) = Y(1)*Z - DO 103 I=2,MM1 - Z = 1./(B(I)-X-A(I)*D(I-1)) - D(I) = C(I)*Z - Y(I) = (Y(I)-A(I)*Y(I-1))*Z - 103 CONTINUE - Z = B(M)-X-A(M)*D(MM1) - IF (Z .NE. 0.) GO TO 104 - Y(M) = 0. - GO TO 105 - 104 Y(M) = (Y(M)-A(M)*Y(MM1))/Z - 105 CONTINUE - DO 106 IP=1,MM1 - I = M-IP - Y(I) = Y(I)-D(I)*Y(I+1) - 106 CONTINUE - IF (K .NE. L) GO TO 108 - DO 107 I=1,M - Y(I) = Y(I)+W(I) - 107 CONTINUE - LINT = LINT+1 - L = (LINT*KB)/KC - 108 CONTINUE - RETURN - END diff --git a/slatec/tsturm.f b/slatec/tsturm.f deleted file mode 100644 index 4996acb..0000000 --- a/slatec/tsturm.f +++ /dev/null @@ -1,405 +0,0 @@ -*DECK TSTURM - SUBROUTINE TSTURM (NM, N, EPS1, D, E, E2, LB, UB, MM, M, W, Z, - + IERR, RV1, RV2, RV3, RV4, RV5, RV6) -C***BEGIN PROLOGUE TSTURM -C***PURPOSE Find those eigenvalues of a symmetric tridiagonal matrix -C in a given interval and their associated eigenvectors by -C Sturm sequencing. -C***LIBRARY SLATEC (EISPACK) -C***CATEGORY D4A5, D4C2A -C***TYPE SINGLE PRECISION (TSTURM-S) -C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK -C***AUTHOR Smith, B. T., et al. -C***DESCRIPTION -C -C This subroutine finds those eigenvalues of a TRIDIAGONAL -C SYMMETRIC matrix which lie in a specified interval and their -C associated eigenvectors, using bisection and inverse iteration. -C -C On Input -C -C NM must be set to the row dimension of the two-dimensional -C array parameter, Z, as declared in the calling program -C dimension statement. NM is an INTEGER variable. -C -C N is the order of the matrix. N is an INTEGER variable. -C N must be less than or equal to NM. -C -C EPS1 is an absolute error tolerance for the computed eigen- -C values. It should be chosen so that the accuracy of these -C eigenvalues is commensurate with relative perturbations of -C the order of the relative machine precision in the matrix -C elements. If the input EPS1 is non-positive, it is reset -C for each submatrix to a default value, namely, minus the -C product of the relative machine precision and the 1-norm of -C the submatrix. EPS1 is a REAL variable. -C -C D contains the diagonal elements of the symmetric tridiagonal -C matrix. D is a one-dimensional REAL array, dimensioned D(N). -C -C E contains the subdiagonal elements of the symmetric -C tridiagonal matrix in its last N-1 positions. E(1) is -C arbitrary. E is a one-dimensional REAL array, dimensioned -C E(N). -C -C E2 contains the squares of the corresponding elements of E. -C E2(1) is arbitrary. E2 is a one-dimensional REAL array, -C dimensioned E2(N). -C -C LB and UB define the interval to be searched for eigenvalues. -C If LB is not less than UB, no eigenvalues will be found. -C LB and UB are REAL variables. -C -C MM should be set to an upper bound for the number of -C eigenvalues in the interval. MM is an INTEGER variable. -C WARNING - If more than MM eigenvalues are determined to lie -C in the interval, an error return is made with no values or -C vectors found. -C -C On Output -C -C EPS1 is unaltered unless it has been reset to its -C (last) default value. -C -C D and E are unaltered. -C -C Elements of E2, corresponding to elements of E regarded as -C negligible, have been replaced by zero causing the matrix to -C split into a direct sum of submatrices. E2(1) is also set -C to zero. -C -C M is the number of eigenvalues determined to lie in (LB,UB). -C M is an INTEGER variable. -C -C W contains the M eigenvalues in ascending order if the matrix -C does not split. If the matrix splits, the eigenvalues are -C in ascending order for each submatrix. If a vector error -C exit is made, W contains those values already found. W is a -C one-dimensional REAL array, dimensioned W(MM). -C -C Z contains the associated set of orthonormal eigenvectors. -C If an error exit is made, Z contains those vectors already -C found. Z is a one-dimensional REAL array, dimensioned -C Z(NM,MM). -C -C IERR is an INTEGER flag set to -C Zero for normal return, -C 3*N+1 if M exceeds MM no eigenvalues or eigenvectors -C are computed, -C 4*N+J if the eigenvector corresponding to the J-th -C eigenvalue fails to converge in 5 iterations, then -C the eigenvalues and eigenvectors in W and Z should -C be correct for indices 1, 2, ..., J-1. -C -C RV1, RV2, RV3, RV4, RV5, and RV6 are temporary storage arrays, -C dimensioned RV1(N), RV2(N), RV3(N), RV4(N), RV5(N), and -C RV6(N). -C -C The ALGOL procedure STURMCNT contained in TRISTURM -C appears in TSTURM in-line. -C -C Questions and comments should be directed to B. S. Garbow, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C ------------------------------------------------------------------ -C -C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, -C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- -C system Routines - EISPACK Guide, Springer-Verlag, -C 1976. -C***ROUTINES CALLED R1MACH -C***REVISION HISTORY (YYMMDD) -C 760101 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 TSTURM -C - INTEGER I,J,K,M,N,P,Q,R,S,II,IP,JJ,MM,M1,M2,NM,ITS - INTEGER IERR,GROUP,ISTURM - REAL D(*),E(*),E2(*),W(*),Z(NM,*) - REAL RV1(*),RV2(*),RV3(*),RV4(*),RV5(*),RV6(*) - REAL U,V,LB,T1,T2,UB,UK,XU,X0,X1,EPS1,EPS2,EPS3,EPS4 - REAL NORM,MACHEP,S1,S2 - LOGICAL FIRST -C - SAVE FIRST, MACHEP - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT TSTURM - IF (FIRST) THEN - MACHEP = R1MACH(4) - ENDIF - FIRST = .FALSE. -C - IERR = 0 - T1 = LB - T2 = UB -C .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES .......... - DO 40 I = 1, N - IF (I .EQ. 1) GO TO 20 - S1 = ABS(D(I)) + ABS(D(I-1)) - S2 = S1 + ABS(E(I)) - IF (S2 .GT. S1) GO TO 40 - 20 E2(I) = 0.0E0 - 40 CONTINUE -C .......... DETERMINE THE NUMBER OF EIGENVALUES -C IN THE INTERVAL .......... - P = 1 - Q = N - X1 = UB - ISTURM = 1 - GO TO 320 - 60 M = S - X1 = LB - ISTURM = 2 - GO TO 320 - 80 M = M - S - IF (M .GT. MM) GO TO 980 - Q = 0 - R = 0 -C .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING -C INTERVAL BY THE GERSCHGORIN BOUNDS .......... - 100 IF (R .EQ. M) GO TO 1001 - P = Q + 1 - XU = D(P) - X0 = D(P) - U = 0.0E0 -C - DO 120 Q = P, N - X1 = U - U = 0.0E0 - V = 0.0E0 - IF (Q .EQ. N) GO TO 110 - U = ABS(E(Q+1)) - V = E2(Q+1) - 110 XU = MIN(D(Q)-(X1+U),XU) - X0 = MAX(D(Q)+(X1+U),X0) - IF (V .EQ. 0.0E0) GO TO 140 - 120 CONTINUE -C - 140 X1 = MAX(ABS(XU),ABS(X0)) * MACHEP - IF (EPS1 .LE. 0.0E0) EPS1 = -X1 - IF (P .NE. Q) GO TO 180 -C .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL .......... - IF (T1 .GT. D(P) .OR. D(P) .GE. T2) GO TO 940 - R = R + 1 -C - DO 160 I = 1, N - 160 Z(I,R) = 0.0E0 -C - W(R) = D(P) - Z(P,R) = 1.0E0 - GO TO 940 - 180 X1 = X1 * (Q-P+1) - LB = MAX(T1,XU-X1) - UB = MIN(T2,X0+X1) - X1 = LB - ISTURM = 3 - GO TO 320 - 200 M1 = S + 1 - X1 = UB - ISTURM = 4 - GO TO 320 - 220 M2 = S - IF (M1 .GT. M2) GO TO 940 -C .......... FIND ROOTS BY BISECTION .......... - X0 = UB - ISTURM = 5 -C - DO 240 I = M1, M2 - RV5(I) = UB - RV4(I) = LB - 240 CONTINUE -C .......... LOOP FOR K-TH EIGENVALUE -C FOR K=M2 STEP -1 UNTIL M1 DO -- -C (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) .......... - K = M2 - 250 XU = LB -C .......... FOR I=K STEP -1 UNTIL M1 DO -- .......... - DO 260 II = M1, K - I = M1 + K - II - IF (XU .GE. RV4(I)) GO TO 260 - XU = RV4(I) - GO TO 280 - 260 CONTINUE -C - 280 IF (X0 .GT. RV5(K)) X0 = RV5(K) -C .......... NEXT BISECTION STEP .......... - 300 X1 = (XU + X0) * 0.5E0 - S1 = 2.0E0*(ABS(XU) + ABS(X0) + ABS(EPS1)) - S2 = S1 + ABS(X0 - XU) - IF (S2 .EQ. S1) GO TO 420 -C .......... IN-LINE PROCEDURE FOR STURM SEQUENCE .......... - 320 S = P - 1 - U = 1.0E0 -C - DO 340 I = P, Q - IF (U .NE. 0.0E0) GO TO 325 - V = ABS(E(I)) / MACHEP - IF (E2(I) .EQ. 0.0E0) V = 0.0E0 - GO TO 330 - 325 V = E2(I) / U - 330 U = D(I) - X1 - V - IF (U .LT. 0.0E0) S = S + 1 - 340 CONTINUE -C - GO TO (60,80,200,220,360), ISTURM -C .......... REFINE INTERVALS .......... - 360 IF (S .GE. K) GO TO 400 - XU = X1 - IF (S .GE. M1) GO TO 380 - RV4(M1) = X1 - GO TO 300 - 380 RV4(S+1) = X1 - IF (RV5(S) .GT. X1) RV5(S) = X1 - GO TO 300 - 400 X0 = X1 - GO TO 300 -C .......... K-TH EIGENVALUE FOUND .......... - 420 RV5(K) = X1 - K = K - 1 - IF (K .GE. M1) GO TO 250 -C .......... FIND VECTORS BY INVERSE ITERATION .......... - NORM = ABS(D(P)) - IP = P + 1 -C - DO 500 I = IP, Q - 500 NORM = MAX(NORM, ABS(D(I)) + ABS(E(I))) -C .......... EPS2 IS THE CRITERION FOR GROUPING, -C EPS3 REPLACES ZERO PIVOTS AND EQUAL -C ROOTS ARE MODIFIED BY EPS3, -C EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW .......... - EPS2 = 1.0E-3 * NORM - UK = SQRT(REAL(Q-P+5)) - EPS3 = UK * MACHEP * NORM - EPS4 = UK * EPS3 - UK = EPS4 / SQRT(UK) - GROUP = 0 - S = P -C - DO 920 K = M1, M2 - R = R + 1 - ITS = 1 - W(R) = RV5(K) - X1 = RV5(K) -C .......... LOOK FOR CLOSE OR COINCIDENT ROOTS .......... - IF (K .EQ. M1) GO TO 520 - IF (X1 - X0 .GE. EPS2) GROUP = -1 - GROUP = GROUP + 1 - IF (X1 .LE. X0) X1 = X0 + EPS3 -C .......... ELIMINATION WITH INTERCHANGES AND -C INITIALIZATION OF VECTOR .......... - 520 V = 0.0E0 -C - DO 580 I = P, Q - RV6(I) = UK - IF (I .EQ. P) GO TO 560 - IF (ABS(E(I)) .LT. ABS(U)) GO TO 540 - XU = U / E(I) - RV4(I) = XU - RV1(I-1) = E(I) - RV2(I-1) = D(I) - X1 - RV3(I-1) = 0.0E0 - IF (I .NE. Q) RV3(I-1) = E(I+1) - U = V - XU * RV2(I-1) - V = -XU * RV3(I-1) - GO TO 580 - 540 XU = E(I) / U - RV4(I) = XU - RV1(I-1) = U - RV2(I-1) = V - RV3(I-1) = 0.0E0 - 560 U = D(I) - X1 - XU * V - IF (I .NE. Q) V = E(I+1) - 580 CONTINUE -C - IF (U .EQ. 0.0E0) U = EPS3 - RV1(Q) = U - RV2(Q) = 0.0E0 - RV3(Q) = 0.0E0 -C .......... BACK SUBSTITUTION -C FOR I=Q STEP -1 UNTIL P DO -- .......... - 600 DO 620 II = P, Q - I = P + Q - II - RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I) - V = U - U = RV6(I) - 620 CONTINUE -C .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS -C MEMBERS OF GROUP .......... - IF (GROUP .EQ. 0) GO TO 700 -C - DO 680 JJ = 1, GROUP - J = R - GROUP - 1 + JJ - XU = 0.0E0 -C - DO 640 I = P, Q - 640 XU = XU + RV6(I) * Z(I,J) -C - DO 660 I = P, Q - 660 RV6(I) = RV6(I) - XU * Z(I,J) -C - 680 CONTINUE -C - 700 NORM = 0.0E0 -C - DO 720 I = P, Q - 720 NORM = NORM + ABS(RV6(I)) -C - IF (NORM .GE. 1.0E0) GO TO 840 -C .......... FORWARD SUBSTITUTION .......... - IF (ITS .EQ. 5) GO TO 960 - IF (NORM .NE. 0.0E0) GO TO 740 - RV6(S) = EPS4 - S = S + 1 - IF (S .GT. Q) S = P - GO TO 780 - 740 XU = EPS4 / NORM -C - DO 760 I = P, Q - 760 RV6(I) = RV6(I) * XU -C .......... ELIMINATION OPERATIONS ON NEXT VECTOR -C ITERATE .......... - 780 DO 820 I = IP, Q - U = RV6(I) -C .......... IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE -C WAS PERFORMED EARLIER IN THE -C TRIANGULARIZATION PROCESS .......... - IF (RV1(I-1) .NE. E(I)) GO TO 800 - U = RV6(I-1) - RV6(I-1) = RV6(I) - 800 RV6(I) = U - RV4(I) * RV6(I-1) - 820 CONTINUE -C - ITS = ITS + 1 - GO TO 600 -C .......... NORMALIZE SO THAT SUM OF SQUARES IS -C 1 AND EXPAND TO FULL ORDER .......... - 840 U = 0.0E0 -C - DO 860 I = P, Q - 860 U = U + RV6(I)**2 -C - XU = 1.0E0 / SQRT(U) -C - DO 880 I = 1, N - 880 Z(I,R) = 0.0E0 -C - DO 900 I = P, Q - 900 Z(I,R) = RV6(I) * XU -C - X0 = X1 - 920 CONTINUE -C - 940 IF (Q .LT. N) GO TO 100 - GO TO 1001 -C .......... SET ERROR -- NON-CONVERGED EIGENVECTOR .......... - 960 IERR = 4 * N + R - GO TO 1001 -C .......... SET ERROR -- UNDERESTIMATE OF NUMBER OF -C EIGENVALUES IN INTERVAL .......... - 980 IERR = 3 * N + 1 - 1001 LB = T1 - UB = T2 - RETURN - END diff --git a/slatec/u11ls.f b/slatec/u11ls.f deleted file mode 100644 index 2a23c07..0000000 --- a/slatec/u11ls.f +++ /dev/null @@ -1,292 +0,0 @@ -*DECK U11LS - SUBROUTINE U11LS (A, MDA, M, N, UB, DB, MODE, NP, KRANK, KSURE, H, - + W, EB, IC, IR) -C***BEGIN PROLOGUE U11LS -C***SUBSIDIARY -C***PURPOSE Subsidiary to LLSIA -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (U11LS-S, DU11LS-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This routine performs a QR factorization of A -C using Householder transformations. Row and -C column pivots are chosen to reduce the growth -C of round-off and to help detect possible rank -C deficiency. -C -C***SEE ALSO LLSIA -C***ROUTINES CALLED ISAMAX, ISWAP, SAXPY, SDOT, SNRM2, SSCAL, SSWAP, -C XERMSG -C***REVISION HISTORY (YYMMDD) -C 810801 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891009 Removed unreferenced variable. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE U11LS - DIMENSION A(MDA,*),UB(*),DB(*),H(*),W(*),EB(*) - INTEGER IC(*),IR(*) -C -C INITIALIZATION -C -C***FIRST EXECUTABLE STATEMENT U11LS - J=0 - KRANK=N - DO 10 I=1,N - IC(I)=I - 10 CONTINUE - DO 12 I=1,M - IR(I)=I - 12 CONTINUE -C -C DETERMINE REL AND ABS ERROR VECTORS -C -C -C -C CALCULATE COL LENGTH -C - DO 30 I=1,N - H(I)=SNRM2(M,A(1,I),1) - W(I)=H(I) - 30 CONTINUE -C -C INITIALIZE ERROR BOUNDS -C - DO 40 I=1,N - EB(I)=MAX(DB(I),UB(I)*H(I)) - UB(I)=EB(I) - DB(I)=0.0 - 40 CONTINUE -C -C DISCARD SELF DEPENDENT COLUMNS -C - I=1 - 50 IF(EB(I).GE.H(I)) GO TO 60 - IF(I.EQ.KRANK) GO TO 70 - I=I+1 - GO TO 50 -C -C MATRIX REDUCTION -C - 60 CONTINUE - KK=KRANK - KRANK=KRANK-1 - IF(MODE.EQ.0) RETURN - IF(I.GT.NP) GO TO 64 - CALL XERMSG ('SLATEC', 'U11LS', - + 'FIRST NP COLUMNS ARE LINEARLY DEPENDENT', 8, 0) - KRANK=I-1 - RETURN - 64 CONTINUE - IF(I.GT.KRANK) GO TO 70 - CALL SSWAP(1,EB(I),1,EB(KK),1) - CALL SSWAP(1,UB(I),1,UB(KK),1) - CALL SSWAP(1,W(I),1,W(KK),1) - CALL SSWAP(1,H(I),1,H(KK),1) - CALL ISWAP(1,IC(I),1,IC(KK),1) - CALL SSWAP(M,A(1,I),1,A(1,KK),1) - GO TO 50 -C -C TEST FOR ZERO RANK -C - 70 IF(KRANK.GT.0) GO TO 80 - KRANK=0 - KSURE=0 - RETURN - 80 CONTINUE -C -C M A I N L O O P -C - 110 CONTINUE - J=J+1 - JP1=J+1 - JM1=J-1 - KZ=KRANK - IF(J.LE.NP) KZ=J -C -C EACH COL HAS MM=M-J+1 COMPONENTS -C - MM=M-J+1 -C -C UB DETERMINES COLUMN PIVOT -C - 115 IMIN=J - IF(H(J).EQ.0.) GO TO 170 - RMIN=UB(J)/H(J) - DO 120 I=J,KZ - IF(UB(I).GE.H(I)*RMIN) GO TO 120 - RMIN=UB(I)/H(I) - IMIN=I - 120 CONTINUE -C -C TEST FOR RANK DEFICIENCY -C - IF(RMIN.LT.1.0) GO TO 200 - TT=(EB(IMIN)+ABS(DB(IMIN)))/H(IMIN) - IF(TT.GE.1.0) GO TO 170 -C COMPUTE EXACT UB - DO 125 I=1,JM1 - W(I)=A(I,IMIN) - 125 CONTINUE - L=JM1 - 130 W(L)=W(L)/A(L,L) - IF(L.EQ.1) GO TO 150 - LM1=L-1 - DO 140 I=L,JM1 - W(LM1)=W(LM1)-A(LM1,I)*W(I) - 140 CONTINUE - L=LM1 - GO TO 130 - 150 TT=EB(IMIN) - DO 160 I=1,JM1 - TT=TT+ABS(W(I))*EB(I) - 160 CONTINUE - UB(IMIN)=TT - IF(UB(IMIN)/H(IMIN).GE.1.0) GO TO 170 - GO TO 200 -C -C MATRIX REDUCTION -C - 170 CONTINUE - KK=KRANK - KRANK=KRANK-1 - KZ=KRANK - IF(MODE.EQ.0) RETURN - IF(J.GT.NP) GO TO 172 - CALL XERMSG ('SLATEC', 'U11LS', - + 'FIRST NP COLUMNS ARE LINEARLY DEPENDENT', 8, 0) - KRANK=J-1 - RETURN - 172 CONTINUE - IF(IMIN.GT.KRANK) GO TO 180 - CALL ISWAP(1,IC(IMIN),1,IC(KK),1) - CALL SSWAP(M,A(1,IMIN),1,A(1,KK),1) - CALL SSWAP(1,EB(IMIN),1,EB(KK),1) - CALL SSWAP(1,UB(IMIN),1,UB(KK),1) - CALL SSWAP(1,DB(IMIN),1,DB(KK),1) - CALL SSWAP(1,W(IMIN),1,W(KK),1) - CALL SSWAP(1,H(IMIN),1,H(KK),1) - 180 IF(J.GT.KRANK) GO TO 300 - GO TO 115 -C -C COLUMN PIVOT -C - 200 IF(IMIN.EQ.J) GO TO 230 - CALL SSWAP(1,H(J),1,H(IMIN),1) - CALL SSWAP(M,A(1,J),1,A(1,IMIN),1) - CALL SSWAP(1,EB(J),1,EB(IMIN),1) - CALL SSWAP(1,UB(J),1,UB(IMIN),1) - CALL SSWAP(1,DB(J),1,DB(IMIN),1) - CALL SSWAP(1,W(J),1,W(IMIN),1) - CALL ISWAP(1,IC(J),1,IC(IMIN),1) -C -C ROW PIVOT -C - 230 CONTINUE - JMAX=ISAMAX(MM,A(J,J),1) - JMAX=JMAX+J-1 - IF(JMAX.EQ.J) GO TO 240 - CALL SSWAP(N,A(J,1),MDA,A(JMAX,1),MDA) - CALL ISWAP(1,IR(J),1,IR(JMAX),1) - 240 CONTINUE -C -C APPLY HOUSEHOLDER TRANSFORMATION -C - TN=SNRM2(MM,A(J,J),1) - IF(TN.EQ.0.0) GO TO 170 - IF(A(J,J).NE.0.0) TN=SIGN(TN,A(J,J)) - CALL SSCAL(MM,1.0/TN,A(J,J),1) - A(J,J)=A(J,J)+1.0 - IF(J.EQ.N) GO TO 250 - DO 248 I=JP1,N - BB=-SDOT(MM,A(J,J),1,A(J,I),1)/A(J,J) - CALL SAXPY(MM,BB,A(J,J),1,A(J,I),1) - IF(I.LE.NP) GO TO 248 - IF(H(I).EQ.0.0) GO TO 248 - TT=1.0-(ABS(A(J,I))/H(I))**2 - TT=MAX(TT,0.0) - T=TT - TT=1.0+.05*TT*(H(I)/W(I))**2 - IF(TT.EQ.1.0) GO TO 244 - H(I)=H(I)*SQRT(T) - GO TO 246 - 244 CONTINUE - H(I)=SNRM2(M-J,A(J+1,I),1) - W(I)=H(I) - 246 CONTINUE - 248 CONTINUE - 250 CONTINUE - H(J)=A(J,J) - A(J,J)=-TN -C -C -C UPDATE UB, DB -C - UB(J)=UB(J)/ABS(A(J,J)) - DB(J)=(SIGN(EB(J),DB(J))+DB(J))/A(J,J) - IF(J.EQ.KRANK) GO TO 300 - DO 260 I=JP1,KRANK - UB(I)=UB(I)+ABS(A(J,I))*UB(J) - DB(I)=DB(I)-A(J,I)*DB(J) - 260 CONTINUE - GO TO 110 -C -C E N D M A I N L O O P -C - 300 CONTINUE -C -C COMPUTE KSURE -C - KM1=KRANK-1 - DO 318 I=1,KM1 - IS=0 - KMI=KRANK-I - DO 315 II=1,KMI - IF(UB(II).LE.UB(II+1)) GO TO 315 - IS=1 - TEMP=UB(II) - UB(II)=UB(II+1) - UB(II+1)=TEMP - 315 CONTINUE - IF(IS.EQ.0) GO TO 320 - 318 CONTINUE - 320 CONTINUE - KSURE=0 - SUM=0.0 - DO 328 I=1,KRANK - R2=UB(I)*UB(I) - IF(R2+SUM.GE.1.0) GO TO 330 - SUM=SUM+R2 - KSURE=KSURE+1 - 328 CONTINUE - 330 CONTINUE -C -C IF SYSTEM IS OF REDUCED RANK AND MODE = 2 -C COMPLETE THE DECOMPOSITION FOR SHORTEST LEAST SQUARES SOLUTION -C - IF(KRANK.EQ.N .OR. MODE.LT.2) GO TO 360 - NMK=N-KRANK - KP1=KRANK+1 - I=KRANK - 340 TN=SNRM2(NMK,A(I,KP1),MDA)/A(I,I) - TN=A(I,I)*SQRT(1.0+TN*TN) - CALL SSCAL(NMK,1.0/TN,A(I,KP1),MDA) - W(I)=A(I,I)/TN+1.0 - A(I,I)=-TN - IF(I.EQ.1) GO TO 350 - IM1=I-1 - DO 345 II=1,IM1 - TT=-SDOT(NMK,A(II,KP1),MDA,A(I,KP1),MDA)/W(I) - TT=TT-A(II,I) - CALL SAXPY(NMK,TT,A(I,KP1),MDA,A(II,KP1),MDA) - A(II,I)=A(II,I)+TT*W(I) - 345 CONTINUE - I=I-1 - GO TO 340 - 350 CONTINUE - 360 CONTINUE - RETURN - END diff --git a/slatec/u11us.f b/slatec/u11us.f deleted file mode 100644 index 6fa20c6..0000000 --- a/slatec/u11us.f +++ /dev/null @@ -1,291 +0,0 @@ -*DECK U11US - SUBROUTINE U11US (A, MDA, M, N, UB, DB, MODE, NP, KRANK, KSURE, H, - + W, EB, IR, IC) -C***BEGIN PROLOGUE U11US -C***SUBSIDIARY -C***PURPOSE Subsidiary to ULSIA -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (U11US-S, DU11US-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C This routine performs an LQ factorization of the -C matrix A using Householder transformations. Row -C and column pivots are chosen to reduce the growth -C of round-off and to help detect possible rank -C deficiency. -C -C***SEE ALSO ULSIA -C***ROUTINES CALLED ISAMAX, ISWAP, SAXPY, SDOT, SNRM2, SSCAL, SSWAP, -C XERMSG -C***REVISION HISTORY (YYMMDD) -C 810801 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE U11US - DIMENSION A(MDA,*),UB(*),DB(*),H(*),W(*),EB(*) - INTEGER IC(*),IR(*) -C -C INITIALIZATION -C -C***FIRST EXECUTABLE STATEMENT U11US - J=0 - KRANK=M - DO 10 I=1,N - IC(I)=I - 10 CONTINUE - DO 12 I=1,M - IR(I)=I - 12 CONTINUE -C -C DETERMINE REL AND ABS ERROR VECTORS -C -C -C -C CALCULATE ROW LENGTH -C - DO 30 I=1,M - H(I)=SNRM2(N,A(I,1),MDA) - W(I)=H(I) - 30 CONTINUE -C -C INITIALIZE ERROR BOUNDS -C - DO 40 I=1,M - EB(I)=MAX(DB(I),UB(I)*H(I)) - UB(I)=EB(I) - DB(I)=0.0 - 40 CONTINUE -C -C DISCARD SELF DEPENDENT ROWS -C - I=1 - 50 IF(EB(I).GE.H(I)) GO TO 60 - IF(I.EQ.KRANK) GO TO 70 - I=I+1 - GO TO 50 -C -C MATRIX REDUCTION -C - 60 CONTINUE - KK=KRANK - KRANK=KRANK-1 - IF(MODE.EQ.0) RETURN - IF(I.GT.NP) GO TO 64 - CALL XERMSG ('SLATEC', 'U11US', - + 'FIRST NP ROWS ARE LINEARLY DEPENDENT', 8, 0) - KRANK=I-1 - RETURN - 64 CONTINUE - IF(I.GT.KRANK) GO TO 70 - CALL SSWAP(1,EB(I),1,EB(KK),1) - CALL SSWAP(1,UB(I),1,UB(KK),1) - CALL SSWAP(1,W(I),1,W(KK),1) - CALL SSWAP(1,H(I),1,H(KK),1) - CALL ISWAP(1,IR(I),1,IR(KK),1) - CALL SSWAP(N,A(I,1),MDA,A(KK,1),MDA) - GO TO 50 -C -C TEST FOR ZERO RANK -C - 70 IF(KRANK.GT.0) GO TO 80 - KRANK=0 - KSURE=0 - RETURN - 80 CONTINUE -C -C M A I N L O O P -C - 110 CONTINUE - J=J+1 - JP1=J+1 - JM1=J-1 - KZ=KRANK - IF(J.LE.NP) KZ=J -C -C EACH ROW HAS NN=N-J+1 COMPONENTS -C - NN=N-J+1 -C -C UB DETERMINES ROW PIVOT -C - 115 IMIN=J - IF(H(J).EQ.0.) GO TO 170 - RMIN=UB(J)/H(J) - DO 120 I=J,KZ - IF(UB(I).GE.H(I)*RMIN) GO TO 120 - RMIN=UB(I)/H(I) - IMIN=I - 120 CONTINUE -C -C TEST FOR RANK DEFICIENCY -C - IF(RMIN.LT.1.0) GO TO 200 - TT=(EB(IMIN)+ABS(DB(IMIN)))/H(IMIN) - IF(TT.GE.1.0) GO TO 170 -C COMPUTE EXACT UB - DO 125 I=1,JM1 - W(I)=A(IMIN,I) - 125 CONTINUE - L=JM1 - 130 W(L)=W(L)/A(L,L) - IF(L.EQ.1) GO TO 150 - LM1=L-1 - DO 140 I=L,JM1 - W(LM1)=W(LM1)-A(I,LM1)*W(I) - 140 CONTINUE - L=LM1 - GO TO 130 - 150 TT=EB(IMIN) - DO 160 I=1,JM1 - TT=TT+ABS(W(I))*EB(I) - 160 CONTINUE - UB(IMIN)=TT - IF(UB(IMIN)/H(IMIN).GE.1.0) GO TO 170 - GO TO 200 -C -C MATRIX REDUCTION -C - 170 CONTINUE - KK=KRANK - KRANK=KRANK-1 - KZ=KRANK - IF(MODE.EQ.0) RETURN - IF(J.GT.NP) GO TO 172 - CALL XERMSG ('SLATEC', 'U11US', - + 'FIRST NP ROWS ARE LINEARLY DEPENDENT', 8, 0) - KRANK=J-1 - RETURN - 172 CONTINUE - IF(IMIN.GT.KRANK) GO TO 180 - CALL ISWAP(1,IR(IMIN),1,IR(KK),1) - CALL SSWAP(N,A(IMIN,1),MDA,A(KK,1),MDA) - CALL SSWAP(1,EB(IMIN),1,EB(KK),1) - CALL SSWAP(1,UB(IMIN),1,UB(KK),1) - CALL SSWAP(1,DB(IMIN),1,DB(KK),1) - CALL SSWAP(1,W(IMIN),1,W(KK),1) - CALL SSWAP(1,H(IMIN),1,H(KK),1) - 180 IF(J.GT.KRANK) GO TO 300 - GO TO 115 -C -C ROW PIVOT -C - 200 IF(IMIN.EQ.J) GO TO 230 - CALL SSWAP(1,H(J),1,H(IMIN),1) - CALL SSWAP(N,A(J,1),MDA,A(IMIN,1),MDA) - CALL SSWAP(1,EB(J),1,EB(IMIN),1) - CALL SSWAP(1,UB(J),1,UB(IMIN),1) - CALL SSWAP(1,DB(J),1,DB(IMIN),1) - CALL SSWAP(1,W(J),1,W(IMIN),1) - CALL ISWAP(1,IR(J),1,IR(IMIN),1) -C -C COLUMN PIVOT -C - 230 CONTINUE - JMAX=ISAMAX(NN,A(J,J),MDA) - JMAX=JMAX+J-1 - IF(JMAX.EQ.J) GO TO 240 - CALL SSWAP(M,A(1,J),1,A(1,JMAX),1) - CALL ISWAP(1,IC(J),1,IC(JMAX),1) - 240 CONTINUE -C -C APPLY HOUSEHOLDER TRANSFORMATION -C - TN=SNRM2(NN,A(J,J),MDA) - IF(TN.EQ.0.0) GO TO 170 - IF(A(J,J).NE.0.0) TN=SIGN(TN,A(J,J)) - CALL SSCAL(NN,1.0/TN,A(J,J),MDA) - A(J,J)=A(J,J)+1.0 - IF(J.EQ.M) GO TO 250 - DO 248 I=JP1,M - BB=-SDOT(NN,A(J,J),MDA,A(I,J),MDA)/A(J,J) - CALL SAXPY(NN,BB,A(J,J),MDA,A(I,J),MDA) - IF(I.LE.NP) GO TO 248 - IF(H(I).EQ.0.0) GO TO 248 - TT=1.0-(ABS(A(I,J))/H(I))**2 - TT=MAX(TT,0.0) - T=TT - TT=1.0+.05*TT*(H(I)/W(I))**2 - IF(TT.EQ.1.0) GO TO 244 - H(I)=H(I)*SQRT(T) - GO TO 246 - 244 CONTINUE - H(I)=SNRM2(N-J,A(I,J+1),MDA) - W(I)=H(I) - 246 CONTINUE - 248 CONTINUE - 250 CONTINUE - H(J)=A(J,J) - A(J,J)=-TN -C -C -C UPDATE UB, DB -C - UB(J)=UB(J)/ABS(A(J,J)) - DB(J)=(SIGN(EB(J),DB(J))+DB(J))/A(J,J) - IF(J.EQ.KRANK) GO TO 300 - DO 260 I=JP1,KRANK - UB(I)=UB(I)+ABS(A(I,J))*UB(J) - DB(I)=DB(I)-A(I,J)*DB(J) - 260 CONTINUE - GO TO 110 -C -C E N D M A I N L O O P -C - 300 CONTINUE -C -C COMPUTE KSURE -C - KM1=KRANK-1 - DO 318 I=1,KM1 - IS=0 - KMI=KRANK-I - DO 315 II=1,KMI - IF(UB(II).LE.UB(II+1)) GO TO 315 - IS=1 - TEMP=UB(II) - UB(II)=UB(II+1) - UB(II+1)=TEMP - 315 CONTINUE - IF(IS.EQ.0) GO TO 320 - 318 CONTINUE - 320 CONTINUE - KSURE=0 - SUM=0.0 - DO 328 I=1,KRANK - R2=UB(I)*UB(I) - IF(R2+SUM.GE.1.0) GO TO 330 - SUM=SUM+R2 - KSURE=KSURE+1 - 328 CONTINUE - 330 CONTINUE -C -C IF SYSTEM IS OF REDUCED RANK AND MODE = 2 -C COMPLETE THE DECOMPOSITION FOR SHORTEST LEAST SQUARES SOLUTION -C - IF(KRANK.EQ.M .OR. MODE.LT.2) GO TO 360 - MMK=M-KRANK - KP1=KRANK+1 - I=KRANK - 340 TN=SNRM2(MMK,A(KP1,I),1)/A(I,I) - TN=A(I,I)*SQRT(1.0+TN*TN) - CALL SSCAL(MMK,1.0/TN,A(KP1,I),1) - W(I)=A(I,I)/TN+1.0 - A(I,I)=-TN - IF(I.EQ.1) GO TO 350 - IM1=I-1 - DO 345 II=1,IM1 - TT=-SDOT(MMK,A(KP1,II),1,A(KP1,I),1)/W(I) - TT=TT-A(I,II) - CALL SAXPY(MMK,TT,A(KP1,I),1,A(KP1,II),1) - A(I,II)=A(I,II)+TT*W(I) - 345 CONTINUE - I=I-1 - GO TO 340 - 350 CONTINUE - 360 CONTINUE - RETURN - END diff --git a/slatec/u12ls.f b/slatec/u12ls.f deleted file mode 100644 index 0a62745..0000000 --- a/slatec/u12ls.f +++ /dev/null @@ -1,157 +0,0 @@ -*DECK U12LS - SUBROUTINE U12LS (A, MDA, M, N, B, MDB, NB, MODE, KRANK, RNORM, H, - + W, IC, IR) -C***BEGIN PROLOGUE U12LS -C***SUBSIDIARY -C***PURPOSE Subsidiary to LLSIA -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (U12LS-S, DU12LS-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Given the Householder QR factorization of A, this -C subroutine solves the system AX=B. If the system -C is of reduced rank, this routine returns a solution -C according to the selected mode. -C -C Note - If MODE.NE.2, W is never accessed. -C -C***SEE ALSO LLSIA -C***ROUTINES CALLED SAXPY, SDOT, SNRM2, SSWAP -C***REVISION HISTORY (YYMMDD) -C 810801 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE U12LS - DIMENSION A(MDA,*),B(MDB,*),RNORM(*),H(*),W(*) - INTEGER IC(*),IR(*) -C***FIRST EXECUTABLE STATEMENT U12LS - K=KRANK - KP1=K+1 -C -C RANK=0 -C - IF(K.GT.0) GO TO 410 - DO 404 JB=1,NB - RNORM(JB)=SNRM2(M,B(1,JB),1) - 404 CONTINUE - DO 406 JB=1,NB - DO 406 I=1,N - B(I,JB)=0.0 - 406 CONTINUE - RETURN -C -C REORDER B TO REFLECT ROW INTERCHANGES -C - 410 CONTINUE - I=0 - 412 I=I+1 - IF(I.EQ.M) GO TO 418 - J=IR(I) - IF(J.EQ.I) GO TO 412 - IF(J.LT.0) GO TO 412 - IR(I)=-IR(I) - DO 413 JB=1,NB - RNORM(JB)=B(I,JB) - 413 CONTINUE - IJ=I - 414 DO 415 JB=1,NB - B(IJ,JB)=B(J,JB) - 415 CONTINUE - IJ=J - J=IR(IJ) - IR(IJ)=-IR(IJ) - IF(J.NE.I) GO TO 414 - DO 416 JB=1,NB - B(IJ,JB)=RNORM(JB) - 416 CONTINUE - GO TO 412 - 418 CONTINUE - DO 420 I=1,M - IR(I)=ABS(IR(I)) - 420 CONTINUE -C -C APPLY HOUSEHOLDER TRANSFORMATIONS TO B -C - DO 430 J=1,K - TT=A(J,J) - A(J,J)=H(J) - DO 425 I=1,NB - BB=-SDOT(M-J+1,A(J,J),1,B(J,I),1)/H(J) - CALL SAXPY(M-J+1,BB,A(J,J),1,B(J,I),1) - 425 CONTINUE - A(J,J)=TT - 430 CONTINUE -C -C FIND NORMS OF RESIDUAL VECTOR(S)..(BEFORE OVERWRITE B) -C - DO 440 JB=1,NB - RNORM(JB)=SNRM2((M-K),B(KP1,JB),1) - 440 CONTINUE -C -C BACK SOLVE UPPER TRIANGULAR R -C - I=K - 442 DO 444 JB=1,NB - B(I,JB)=B(I,JB)/A(I,I) - 444 CONTINUE - IF(I.EQ.1) GO TO 450 - IM1=I-1 - DO 448 JB=1,NB - CALL SAXPY(IM1,-B(I,JB),A(1,I),1,B(1,JB),1) - 448 CONTINUE - I=IM1 - GO TO 442 - 450 CONTINUE -C -C RANK LT N -C -C TRUNCATED SOLUTION -C - IF(K.EQ.N) GO TO 480 - DO 460 JB=1,NB - DO 460 I=KP1,N - B(I,JB)=0.0 - 460 CONTINUE - IF(MODE.EQ.1) GO TO 480 -C -C MINIMAL LENGTH SOLUTION -C - NMK=N-K - DO 470 JB=1,NB - DO 465 I=1,K - TT=-SDOT(NMK,A(I,KP1),MDA,B(KP1,JB),1)/W(I) - TT=TT-B(I,JB) - CALL SAXPY(NMK,TT,A(I,KP1),MDA,B(KP1,JB),1) - B(I,JB)=B(I,JB)+TT*W(I) - 465 CONTINUE - 470 CONTINUE -C -C -C REORDER B TO REFLECT COLUMN INTERCHANGES -C - 480 CONTINUE - I=0 - 482 I=I+1 - IF(I.EQ.N) GO TO 488 - J=IC(I) - IF(J.EQ.I) GO TO 482 - IF(J.LT.0) GO TO 482 - IC(I)=-IC(I) - 484 CALL SSWAP(NB,B(J,1),MDB,B(I,1),MDB) - IJ=IC(J) - IC(J)=-IC(J) - J=IJ - IF(J.EQ.I) GO TO 482 - GO TO 484 - 488 CONTINUE - DO 490 I=1,N - IC(I)=ABS(IC(I)) - 490 CONTINUE -C -C SOLUTION VECTORS ARE IN FIRST N ROWS OF B(,) -C - RETURN - END diff --git a/slatec/u12us.f b/slatec/u12us.f deleted file mode 100644 index 8ba9581..0000000 --- a/slatec/u12us.f +++ /dev/null @@ -1,154 +0,0 @@ -*DECK U12US - SUBROUTINE U12US (A, MDA, M, N, B, MDB, NB, MODE, KRANK, RNORM, H, - + W, IR, IC) -C***BEGIN PROLOGUE U12US -C***SUBSIDIARY -C***PURPOSE Subsidiary to ULSIA -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (U12US-S, DU12US-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C Given the Householder LQ factorization of A, this -C subroutine solves the system AX=B. If the system -C is of reduced rank, this routine returns a solution -C according to the selected mode. -C -C Note - If MODE.NE.2, W is never accessed. -C -C***SEE ALSO ULSIA -C***ROUTINES CALLED SAXPY, SDOT, SNRM2, SSWAP -C***REVISION HISTORY (YYMMDD) -C 810801 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE U12US - DIMENSION A(MDA,*),B(MDB,*),RNORM(*),H(*),W(*) - INTEGER IC(*),IR(*) -C***FIRST EXECUTABLE STATEMENT U12US - K=KRANK - KP1=K+1 -C -C RANK=0 -C - IF(K.GT.0) GO TO 410 - DO 404 JB=1,NB - RNORM(JB)=SNRM2(M,B(1,JB),1) - 404 CONTINUE - DO 406 JB=1,NB - DO 406 I=1,N - B(I,JB)=0.0 - 406 CONTINUE - RETURN -C -C REORDER B TO REFLECT ROW INTERCHANGES -C - 410 CONTINUE - I=0 - 412 I=I+1 - IF(I.EQ.M) GO TO 418 - J=IR(I) - IF(J.EQ.I) GO TO 412 - IF(J.LT.0) GO TO 412 - IR(I)=-IR(I) - DO 413 JB=1,NB - RNORM(JB)=B(I,JB) - 413 CONTINUE - IJ=I - 414 DO 415 JB=1,NB - B(IJ,JB)=B(J,JB) - 415 CONTINUE - IJ=J - J=IR(IJ) - IR(IJ)=-IR(IJ) - IF(J.NE.I) GO TO 414 - DO 416 JB=1,NB - B(IJ,JB)=RNORM(JB) - 416 CONTINUE - GO TO 412 - 418 CONTINUE - DO 420 I=1,M - IR(I)=ABS(IR(I)) - 420 CONTINUE -C -C IF A IS OF REDUCED RANK AND MODE=2, -C APPLY HOUSEHOLDER TRANSFORMATIONS TO B -C - IF(MODE.LT.2 .OR. K.EQ.M) GO TO 440 - MMK=M-K - DO 430 JB=1,NB - DO 425 J=1,K - I=KP1-J - TT=-SDOT(MMK,A(KP1,I),1,B(KP1,JB),1)/W(I) - TT=TT-B(I,JB) - CALL SAXPY(MMK,TT,A(KP1,I),1,B(KP1,JB),1) - B(I,JB)=B(I,JB)+TT*W(I) - 425 CONTINUE - 430 CONTINUE -C -C FIND NORMS OF RESIDUAL VECTOR(S)..(BEFORE OVERWRITE B) -C - 440 DO 442 JB=1,NB - RNORM(JB)=SNRM2((M-K),B(KP1,JB),1) - 442 CONTINUE -C -C BACK SOLVE LOWER TRIANGULAR L -C - DO 450 JB=1,NB - DO 448 I=1,K - B(I,JB)=B(I,JB)/A(I,I) - IF(I.EQ.K) GO TO 450 - IP1=I+1 - CALL SAXPY(K-I,-B(I,JB),A(IP1,I),1,B(IP1,JB),1) - 448 CONTINUE - 450 CONTINUE -C -C -C TRUNCATED SOLUTION -C - IF(K.EQ.N) GO TO 462 - DO 460 JB=1,NB - DO 460 I=KP1,N - B(I,JB)=0.0 - 460 CONTINUE -C -C APPLY HOUSEHOLDER TRANSFORMATIONS TO B -C - 462 DO 470 I=1,K - J=KP1-I - TT=A(J,J) - A(J,J)=H(J) - DO 465 JB=1,NB - BB=-SDOT(N-J+1,A(J,J),MDA,B(J,JB),1)/H(J) - CALL SAXPY(N-J+1,BB,A(J,J),MDA,B(J,JB),1) - 465 CONTINUE - A(J,J)=TT - 470 CONTINUE -C -C -C REORDER B TO REFLECT COLUMN INTERCHANGES -C - I=0 - 482 I=I+1 - IF(I.EQ.N) GO TO 488 - J=IC(I) - IF(J.EQ.I) GO TO 482 - IF(J.LT.0) GO TO 482 - IC(I)=-IC(I) - 484 CALL SSWAP(NB,B(J,1),MDB,B(I,1),MDB) - IJ=IC(J) - IC(J)=-IC(J) - J=IJ - IF(J.EQ.I) GO TO 482 - GO TO 484 - 488 CONTINUE - DO 490 I=1,N - IC(I)=ABS(IC(I)) - 490 CONTINUE -C -C SOLUTION VECTORS ARE IN FIRST N ROWS OF B(,) -C - RETURN - END diff --git a/slatec/ulsia.f b/slatec/ulsia.f deleted file mode 100644 index cd212ee..0000000 --- a/slatec/ulsia.f +++ /dev/null @@ -1,320 +0,0 @@ -*DECK ULSIA - SUBROUTINE ULSIA (A, MDA, M, N, B, MDB, NB, RE, AE, KEY, MODE, NP, - + KRANK, KSURE, RNORM, W, LW, IWORK, LIW, INFO) -C***BEGIN PROLOGUE ULSIA -C***PURPOSE Solve an underdetermined linear system of equations by -C performing an LQ factorization of the matrix using -C Householder transformations. Emphasis is put on detecting -C possible rank deficiency. -C***LIBRARY SLATEC -C***CATEGORY D9 -C***TYPE SINGLE PRECISION (ULSIA-S, DULSIA-D) -C***KEYWORDS LINEAR LEAST SQUARES, LQ FACTORIZATION, -C UNDERDETERMINED LINEAR SYSTEM -C***AUTHOR Manteuffel, T. A., (LANL) -C***DESCRIPTION -C -C ULSIA computes the minimal length solution(s) to the problem AX=B -C where A is an M by N matrix with M.LE.N and B is the M by NB -C matrix of right hand sides. User input bounds on the uncertainty -C in the elements of A are used to detect numerical rank deficiency. -C The algorithm employs a row and column pivot strategy to -C minimize the growth of uncertainty and round-off errors. -C -C ULSIA requires (MDA+1)*N + (MDB+1)*NB + 6*M dimensioned space -C -C ****************************************************************** -C * * -C * WARNING - All input arrays are changed on exit. * -C * * -C ****************************************************************** -C -C Input.. -C -C A(,) Linear coefficient matrix of AX=B, with MDA the -C MDA,M,N actual first dimension of A in the calling program. -C M is the row dimension (no. of EQUATIONS of the -C problem) and N the col dimension (no. of UNKNOWNS). -C Must have MDA.GE.M and M.LE.N. -C -C B(,) Right hand side(s), with MDB the actual first -C MDB,NB dimension of B in the calling program. NB is the -C number of M by 1 right hand sides. Since the -C solution is returned in B, must have MDB.GE.N. If -C NB = 0, B is never accessed. -C -C ****************************************************************** -C * * -C * Note - Use of RE and AE are what make this * -C * code significantly different from * -C * other linear least squares solvers. * -C * However, the inexperienced user is * -C * advised to set RE=0.,AE=0.,KEY=0. * -C * * -C ****************************************************************** -C -C RE(),AE(),KEY -C RE() RE() is a vector of length N such that RE(I) is -C the maximum relative uncertainty in row I of -C the matrix A. The values of RE() must be between -C 0 and 1. A minimum of 10*machine precision will -C be enforced. -C -C AE() AE() is a vector of length N such that AE(I) is -C the maximum absolute uncertainty in row I of -C the matrix A. The values of AE() must be greater -C than or equal to 0. -C -C KEY For ease of use, RE and AE may be input as either -C vectors or scalars. If a scalar is input, the algo- -C rithm will use that value for each column of A. -C The parameter KEY indicates whether scalars or -C vectors are being input. -C KEY=0 RE scalar AE scalar -C KEY=1 RE vector AE scalar -C KEY=2 RE scalar AE vector -C KEY=3 RE vector AE vector -C -C -C MODE The integer MODE indicates how the routine -C is to react if rank deficiency is detected. -C If MODE = 0 return immediately, no solution -C 1 compute truncated solution -C 2 compute minimal length least squares sol -C The inexperienced user is advised to set MODE=0 -C -C NP The first NP rows of A will not be interchanged -C with other rows even though the pivot strategy -C would suggest otherwise. -C The inexperienced user is advised to set NP=0. -C -C WORK() A real work array dimensioned 5*M. However, if -C RE or AE have been specified as vectors, dimension -C WORK 4*M. If both RE and AE have been specified -C as vectors, dimension WORK 3*M. -C -C LW Actual dimension of WORK -C -C IWORK() Integer work array dimensioned at least N+M. -C -C LIW Actual dimension of IWORK. -C -C -C INFO Is a flag which provides for the efficient -C solution of subsequent problems involving the -C same A but different B. -C If INFO = 0 original call -C INFO = 1 subsequent calls -C On subsequent calls, the user must supply A, KRANK, -C LW, IWORK, LIW, and the first 2*M locations of WORK -C as output by the original call to ULSIA. MODE must -C be equal to the value of MODE in the original call. -C If MODE.LT.2, only the first N locations of WORK -C are accessed. AE, RE, KEY, and NP are not accessed. -C -C -C -C -C Output.. -C -C A(,) Contains the lower triangular part of the reduced -C matrix and the transformation information. It togeth -C with the first M elements of WORK (see below) -C completely specify the LQ factorization of A. -C -C B(,) Contains the N by NB solution matrix for X. -C -C KRANK,KSURE The numerical rank of A, based upon the relative -C and absolute bounds on uncertainty, is bounded -C above by KRANK and below by KSURE. The algorithm -C returns a solution based on KRANK. KSURE provides -C an indication of the precision of the rank. -C -C RNORM() Contains the Euclidean length of the NB residual -C vectors B(I)-AX(I), I=1,NB. If the matrix A is of -C full rank, then RNORM=0.0. -C -C WORK() The first M locations of WORK contain values -C necessary to reproduce the Householder -C transformation. -C -C IWORK() The first N locations contain the order in -C which the columns of A were used. The next -C M locations contain the order in which the -C rows of A were used. -C -C INFO Flag to indicate status of computation on completion -C -1 Parameter error(s) -C 0 - Rank deficient, no solution -C 1 - Rank deficient, truncated solution -C 2 - Rank deficient, minimal length least squares sol -C 3 - Numerical rank 0, zero solution -C 4 - Rank .LT. NP -C 5 - Full rank -C -C***REFERENCES T. Manteuffel, An interval analysis approach to rank -C determination in linear least squares problems, -C Report SAND80-0655, Sandia Laboratories, June 1980. -C***ROUTINES CALLED R1MACH, U11US, U12US, XERMSG -C***REVISION HISTORY (YYMMDD) -C 810801 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891009 Removed unreferenced variable. (WRB) -C 891009 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 Fixed an error message. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE ULSIA - DIMENSION A(MDA,*),B(MDB,*),RE(*),AE(*),RNORM(*),W(*) - INTEGER IWORK(*) -C -C***FIRST EXECUTABLE STATEMENT ULSIA - IF(INFO.LT.0 .OR. INFO.GT.1) GO TO 514 - IT=INFO - INFO=-1 - IF(NB.EQ.0 .AND. IT.EQ.1) GO TO 501 - IF(M.LT.1) GO TO 502 - IF(N.LT.1) GO TO 503 - IF(N.LT.M) GO TO 504 - IF(MDA.LT.M) GO TO 505 - IF(LIW.LT.M+N) GO TO 506 - IF(MODE.LT.0 .OR. MODE.GT.3) GO TO 515 - IF(NB.EQ.0) GO TO 4 - IF(NB.LT.0) GO TO 507 - IF(MDB.LT.N) GO TO 508 - IF(IT.EQ.0) GO TO 4 - GO TO 400 - 4 IF(KEY.LT.0.OR.KEY.GT.3) GO TO 509 - IF(KEY.EQ.0 .AND. LW.LT.5*M) GO TO 510 - IF(KEY.EQ.1 .AND. LW.LT.4*M) GO TO 510 - IF(KEY.EQ.2 .AND. LW.LT.4*M) GO TO 510 - IF(KEY.EQ.3 .AND. LW.LT.3*M) GO TO 510 - IF(NP.LT.0 .OR. NP.GT.M) GO TO 516 -C - EPS=10.*R1MACH(4) - M1=1 - M2=M1+M - M3=M2+M - M4=M3+M - M5=M4+M -C - IF(KEY.EQ.1) GO TO 100 - IF(KEY.EQ.2) GO TO 200 - IF(KEY.EQ.3) GO TO 300 -C - IF(RE(1).LT.0.0) GO TO 511 - IF(RE(1).GT.1.0) GO TO 512 - IF(RE(1).LT.EPS) RE(1)=EPS - IF(AE(1).LT.0.0) GO TO 513 - DO 20 I=1,M - W(M4-1+I)=RE(1) - W(M5-1+I)=AE(1) - 20 CONTINUE - CALL U11US(A,MDA,M,N,W(M4),W(M5),MODE,NP,KRANK,KSURE, - 1 W(M1),W(M2),W(M3),IWORK(M1),IWORK(M2)) - GO TO 400 -C - 100 CONTINUE - IF(AE(1).LT.0.0) GO TO 513 - DO 120 I=1,M - IF(RE(I).LT.0.0) GO TO 511 - IF(RE(I).GT.1.0) GO TO 512 - IF(RE(I).LT.EPS) RE(I)=EPS - W(M4-1+I)=AE(1) - 120 CONTINUE - CALL U11US(A,MDA,M,N,RE,W(M4),MODE,NP,KRANK,KSURE, - 1 W(M1),W(M2),W(M3),IWORK(M1),IWORK(M2)) - GO TO 400 -C - 200 CONTINUE - IF(RE(1).LT.0.0) GO TO 511 - IF(RE(1).GT.1.0) GO TO 512 - IF(RE(1).LT.EPS) RE(1)=EPS - DO 220 I=1,M - W(M4-1+I)=RE(1) - IF(AE(I).LT.0.0) GO TO 513 - 220 CONTINUE - CALL U11US(A,MDA,M,N,W(M4),AE,MODE,NP,KRANK,KSURE, - 1 W(M1),W(M2),W(M3),IWORK(M1),IWORK(M2)) - GO TO 400 -C - 300 CONTINUE - DO 320 I=1,M - IF(RE(I).LT.0.0) GO TO 511 - IF(RE(I).GT.1.0) GO TO 512 - IF(RE(I).LT.EPS) RE(I)=EPS - IF(AE(I).LT.0.0) GO TO 513 - 320 CONTINUE - CALL U11US(A,MDA,M,N,RE,AE,MODE,NP,KRANK,KSURE, - 1 W(M1),W(M2),W(M3),IWORK(M1),IWORK(M2)) -C -C DETERMINE INFO -C - 400 IF(KRANK.NE.M) GO TO 402 - INFO=5 - GO TO 410 - 402 IF(KRANK.NE.0) GO TO 404 - INFO=3 - GO TO 410 - 404 IF(KRANK.GE.NP) GO TO 406 - INFO=4 - RETURN - 406 INFO=MODE - IF(MODE.EQ.0) RETURN - 410 IF(NB.EQ.0) RETURN -C -C -C SOLUTION PHASE -C - M1=1 - M2=M1+M - M3=M2+M - IF(INFO.EQ.2) GO TO 420 - IF(LW.LT.M2-1) GO TO 510 - CALL U12US(A,MDA,M,N,B,MDB,NB,MODE,KRANK, - 1 RNORM,W(M1),W(M1),IWORK(M1),IWORK(M2)) - RETURN -C - 420 IF(LW.LT.M3-1) GO TO 510 - CALL U12US(A,MDA,M,N,B,MDB,NB,MODE,KRANK, - 1 RNORM,W(M1),W(M2),IWORK(M1),IWORK(M2)) - RETURN -C -C ERROR MESSAGES -C - 501 CALL XERMSG ('SLATEC', 'ULSIA', - + 'SOLUTION ONLY (INFO=1) BUT NO RIGHT HAND SIDE (NB=0)', 1, 0) - RETURN - 502 CALL XERMSG ('SLATEC', 'ULSIA', 'M.LT.1', 2, 1) - RETURN - 503 CALL XERMSG ('SLATEC', 'ULSIA', 'N.LT.1', 2, 1) - RETURN - 504 CALL XERMSG ('SLATEC', 'ULSIA', 'N.LT.M', 2, 1) - RETURN - 505 CALL XERMSG ('SLATEC', 'ULSIA', 'MDA.LT.M', 2, 1) - RETURN - 506 CALL XERMSG ('SLATEC', 'ULSIA', 'LIW.LT.M+N', 2, 1) - RETURN - 507 CALL XERMSG ('SLATEC', 'ULSIA', 'NB.LT.0', 2, 1) - RETURN - 508 CALL XERMSG ('SLATEC', 'ULSIA', 'MDB.LT.N', 2, 1) - RETURN - 509 CALL XERMSG ('SLATEC', 'ULSIA', 'KEY OUT OF RANGE', 2, 1) - RETURN - 510 CALL XERMSG ('SLATEC', 'ULSIA', 'INSUFFICIENT WORK SPACE', 8, 1) - INFO=-1 - RETURN - 511 CALL XERMSG ('SLATEC', 'ULSIA', 'RE(I) .LT. 0', 2, 1) - RETURN - 512 CALL XERMSG ('SLATEC', 'ULSIA', 'RE(I) .GT. 1', 2, 1) - RETURN - 513 CALL XERMSG ('SLATEC', 'ULSIA', 'AE(I) .LT. 0', 2, 1) - RETURN - 514 CALL XERMSG ('SLATEC', 'ULSIA', 'INFO OUT OF RANGE', 2, 1) - RETURN - 515 CALL XERMSG ('SLATEC', 'ULSIA', 'MODE OUT OF RANGE', 2, 1) - RETURN - 516 CALL XERMSG ('SLATEC', 'ULSIA', 'NP OUT OF RANGE', 2, 1) - RETURN - END diff --git a/slatec/usrmat.f b/slatec/usrmat.f deleted file mode 100644 index 0f4c566..0000000 --- a/slatec/usrmat.f +++ /dev/null @@ -1,69 +0,0 @@ -*DECK USRMAT - SUBROUTINE USRMAT (I, J, AIJ, INDCAT, PRGOPT, DATTRV, IFLAG) -C***BEGIN PROLOGUE USRMAT -C***SUBSIDIARY -C***PURPOSE Subsidiary to SPLP -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (USRMAT-S, DUSRMT-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C The user may supply this code -C -C***SEE ALSO SPLP -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 811215 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE USRMAT - DIMENSION PRGOPT(*),DATTRV(*),IFLAG(10) -C -C***FIRST EXECUTABLE STATEMENT USRMAT - IF(IFLAG(1).EQ.1) THEN -C -C THIS IS THE INITIALIZATION STEP. THE VALUES OF IFLAG(K),K=2,3,4, -C ARE RESPECTIVELY THE COLUMN INDEX, THE ROW INDEX (OR THE NEXT COL. -C INDEX), AND THE POINTER TO THE MATRIX ENTRY'S VALUE WITHIN -C DATTRV(*). ALSO CHECK (DATTRV(1)=0.) SIGNIFYING NO DATA. - IF(DATTRV(1).EQ.0.) THEN - I = 0 - J = 0 - IFLAG(1) = 3 - ELSE - IFLAG(2)=-DATTRV(1) - IFLAG(3)= DATTRV(2) - IFLAG(4)= 3 - ENDIF -C - RETURN - ELSE - J=IFLAG(2) - I=IFLAG(3) - L=IFLAG(4) - IF(I.EQ.0) THEN -C -C SIGNAL THAT ALL OF THE NONZERO ENTRIES HAVE BEEN DEFINED. - IFLAG(1)=3 - RETURN - ELSE IF(I.LT.0) THEN -C -C SIGNAL THAT A SWITCH IS MADE TO A NEW COLUMN. - J=-I - I=DATTRV(L) - L=L+1 - ENDIF -C - AIJ=DATTRV(L) -C -C UPDATE THE INDICES AND POINTERS FOR THE NEXT ENTRY. - IFLAG(2)=J - IFLAG(3)=DATTRV(L+1) - IFLAG(4)=L+2 -C -C INDCAT=0 DENOTES THAT ENTRIES OF THE MATRIX ARE ASSIGNED THE -C VALUES FROM DATTRV(*). NO ACCUMULATION IS PERFORMED. - INDCAT=0 - RETURN - ENDIF - END diff --git a/slatec/vnwrms.f b/slatec/vnwrms.f deleted file mode 100644 index 99189a8..0000000 --- a/slatec/vnwrms.f +++ /dev/null @@ -1,42 +0,0 @@ -*DECK VNWRMS - REAL FUNCTION VNWRMS (N, V, W) -C***BEGIN PROLOGUE VNWRMS -C***SUBSIDIARY -C***PURPOSE Subsidiary to DEBDF -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (VNWRMS-S, DVNRMS-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C VNWRMS computes a weighted root-mean-square vector norm for the -C integrator package DEBDF. -C -C***SEE ALSO DEBDF -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 800901 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE VNWRMS -C -C -CLLL. OPTIMIZE -C----------------------------------------------------------------------- -C THIS FUNCTION ROUTINE COMPUTES THE WEIGHTED ROOT-MEAN-SQUARE NORM -C OF THE VECTOR OF LENGTH N CONTAINED IN THE ARRAY V, WITH WEIGHTS -C CONTAINED IN THE ARRAY W OF LENGTH N.. -C VNWRMS = SQRT( (1/N) * SUM( V(I)/W(I) )**2 ) -C----------------------------------------------------------------------- - INTEGER N, I - REAL V, W, SUM - DIMENSION V(*), W(*) -C***FIRST EXECUTABLE STATEMENT VNWRMS - SUM = 0.0E0 - DO 10 I = 1,N - 10 SUM = SUM + (V(I)/W(I))**2 - VNWRMS = SQRT(SUM/N) - RETURN -C----------------------- END OF FUNCTION VNWRMS ------------------------ - END diff --git a/slatec/wnlit.f b/slatec/wnlit.f deleted file mode 100644 index 01a322c..0000000 --- a/slatec/wnlit.f +++ /dev/null @@ -1,287 +0,0 @@ -*DECK WNLIT - SUBROUTINE WNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, RNORM, - + IDOPE, DOPE, DONE) -C***BEGIN PROLOGUE WNLIT -C***SUBSIDIARY -C***PURPOSE Subsidiary to WNNLS -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (WNLIT-S, DWNLIT-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C This is a companion subprogram to WNNLS( ). -C The documentation for WNNLS( ) has complete usage instructions. -C -C Note The M by (N+1) matrix W( , ) contains the rt. hand side -C B as the (N+1)st col. -C -C Triangularize L1 by L1 subsystem, where L1=MIN(M,L), with -C col interchanges. -C -C***SEE ALSO WNNLS -C***ROUTINES CALLED H12, ISAMAX, SCOPY, SROTM, SROTMG, SSCAL, SSWAP, -C WNLT1, WNLT2, WNLT3 -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and revised. (WRB & RWC) -C 890620 Revised to make WNLT1, WNLT2, and WNLT3 subroutines. (RWC) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE WNLIT - INTEGER IDOPE(*), IPIVOT(*), ITYPE(*), L, M, MDW, N - REAL DOPE(*), H(*), RNORM, SCALE(*), W(MDW,*) - LOGICAL DONE -C - EXTERNAL H12, ISAMAX, SCOPY, SROTM, SROTMG, SSCAL, SSWAP, WNLT1, - * WNLT2, WNLT3 - INTEGER ISAMAX - LOGICAL WNLT2 -C - REAL ALSQ, AMAX, EANORM, FACTOR, HBAR, RN, SPARAM(5), - * T, TAU - INTEGER I, I1, IMAX, IR, J, J1, JJ, JP, KRANK, L1, LB, LEND, ME, - * MEND, NIV, NSOLN - LOGICAL INDEP, RECALC -C -C***FIRST EXECUTABLE STATEMENT WNLIT - ME = IDOPE(1) - NSOLN = IDOPE(2) - L1 = IDOPE(3) -C - ALSQ = DOPE(1) - EANORM = DOPE(2) - TAU = DOPE(3) -C - LB = MIN(M-1,L) - RECALC = .TRUE. - RNORM = 0.E0 - KRANK = 0 -C -C We set FACTOR=1.0 so that the heavy weight ALAMDA will be -C included in the test for column independence. -C - FACTOR = 1.E0 - LEND = L - DO 180 I=1,LB -C -C Set IR to point to the I-th row. -C - IR = I - MEND = M - CALL WNLT1 (I, LEND, M, IR, MDW, RECALC, IMAX, HBAR, H, SCALE, - + W) -C -C Update column SS and find pivot column. -C - CALL WNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) -C -C Perform column interchange. -C Test independence of incoming column. -C - 130 IF (WNLT2(ME, MEND, IR, FACTOR, TAU, SCALE, W(1,I))) THEN -C -C Eliminate I-th column below diagonal using modified Givens -C transformations applied to (A B). -C -C When operating near the ME line, use the largest element -C above it as the pivot. -C - DO 160 J=M,I+1,-1 - JP = J-1 - IF (J.EQ.ME+1) THEN - IMAX = ME - AMAX = SCALE(ME)*W(ME,I)**2 - DO 150 JP=J-1,I,-1 - T = SCALE(JP)*W(JP,I)**2 - IF (T.GT.AMAX) THEN - IMAX = JP - AMAX = T - ENDIF - 150 CONTINUE - JP = IMAX - ENDIF -C - IF (W(J,I).NE.0.E0) THEN - CALL SROTMG (SCALE(JP), SCALE(J), W(JP,I), W(J,I), - + SPARAM) - W(J,I) = 0.E0 - CALL SROTM (N+1-I, W(JP,I+1), MDW, W(J,I+1), MDW, - + SPARAM) - ENDIF - 160 CONTINUE - ELSE IF (LEND.GT.I) THEN -C -C Column I is dependent. Swap with column LEND. -C Perform column interchange, -C and find column in remaining set with largest SS. -C - CALL WNLT3 (I, LEND, M, MDW, IPIVOT, H, W) - LEND = LEND - 1 - IMAX = ISAMAX(LEND-I+1, H(I), 1) + I - 1 - HBAR = H(IMAX) - GO TO 130 - ELSE - KRANK = I - 1 - GO TO 190 - ENDIF - 180 CONTINUE - KRANK = L1 -C - 190 IF (KRANK.LT.ME) THEN - FACTOR = ALSQ - DO 200 I=KRANK+1,ME - CALL SCOPY (L, 0.E0, 0, W(I,1), MDW) - 200 CONTINUE -C -C Determine the rank of the remaining equality constraint -C equations by eliminating within the block of constrained -C variables. Remove any redundant constraints. -C - RECALC = .TRUE. - LB = MIN(L+ME-KRANK, N) - DO 270 I=L+1,LB - IR = KRANK + I - L - LEND = N - MEND = ME - CALL WNLT1 (I, LEND, ME, IR, MDW, RECALC, IMAX, HBAR, H, - + SCALE, W) -C -C Update col ss and find pivot col -C - CALL WNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) -C -C Perform column interchange -C Eliminate elements in the I-th col. -C - DO 240 J=ME,IR+1,-1 - IF (W(J,I).NE.0.E0) THEN - CALL SROTMG (SCALE(J-1), SCALE(J), W(J-1,I), W(J,I), - + SPARAM) - W(J,I) = 0.E0 - CALL SROTM (N+1-I, W(J-1,I+1), MDW,W(J,I+1), MDW, - + SPARAM) - ENDIF - 240 CONTINUE -C -C I=column being eliminated. -C Test independence of incoming column. -C Remove any redundant or dependent equality constraints. -C - IF (.NOT.WNLT2(ME, MEND, IR, FACTOR,TAU,SCALE,W(1,I))) THEN - JJ = IR - DO 260 IR=JJ,ME - CALL SCOPY (N, 0.E0, 0, W(IR,1), MDW) - RNORM = RNORM + (SCALE(IR)*W(IR,N+1)/ALSQ)*W(IR,N+1) - W(IR,N+1) = 0.E0 - SCALE(IR) = 1.E0 -C -C Reclassify the zeroed row as a least squares equation. -C - ITYPE(IR) = 1 - 260 CONTINUE -C -C Reduce ME to reflect any discovered dependent equality -C constraints. -C - ME = JJ - 1 - GO TO 280 - ENDIF - 270 CONTINUE - ENDIF -C -C Try to determine the variables KRANK+1 through L1 from the -C least squares equations. Continue the triangularization with -C pivot element W(ME+1,I). -C - 280 IF (KRANK.LT.L1) THEN - RECALC = .TRUE. -C -C Set FACTOR=ALSQ to remove effect of heavy weight from -C test for column independence. -C - FACTOR = ALSQ - DO 350 I=KRANK+1,L1 -C -C Set IR to point to the ME+1-st row. -C - IR = ME+1 - LEND = L - MEND = M - CALL WNLT1 (I, L, M, IR, MDW, RECALC, IMAX, HBAR, H, SCALE, - + W) -C -C Update column SS and find pivot column. -C - CALL WNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) -C -C Perform column interchange. -C Eliminate I-th column below the IR-th element. -C - DO 320 J=M,IR+1,-1 - IF (W(J,I).NE.0.E0) THEN - CALL SROTMG (SCALE(J-1), SCALE(J), W(J-1,I), W(J,I), - + SPARAM) - W(J,I) = 0.E0 - CALL SROTM (N+1-I, W(J-1,I+1), MDW, W(J,I+1), MDW, - + SPARAM) - ENDIF - 320 CONTINUE -C -C Test if new pivot element is near zero. -C If so, the column is dependent. -C Then check row norm test to be classified as independent. -C - T = SCALE(IR)*W(IR,I)**2 - INDEP = T .GT. (TAU*EANORM)**2 - IF (INDEP) THEN - RN = 0.E0 - DO 340 I1=IR,M - DO 330 J1=I+1,N - RN = MAX(RN, SCALE(I1)*W(I1,J1)**2) - 330 CONTINUE - 340 CONTINUE - INDEP = T .GT. RN*TAU**2 - ENDIF -C -C If independent, swap the IR-th and KRANK+1-th rows to -C maintain the triangular form. Update the rank indicator -C KRANK and the equality constraint pointer ME. -C - IF (.NOT.INDEP) GO TO 360 - CALL SSWAP(N+1, W(KRANK+1,1), MDW, W(IR,1), MDW) - CALL SSWAP(1, SCALE(KRANK+1), 1, SCALE(IR), 1) -C -C Reclassify the least square equation as an equality -C constraint and rescale it. -C - ITYPE(IR) = 0 - T = SQRT(SCALE(KRANK+1)) - CALL SSCAL(N+1, T, W(KRANK+1,1), MDW) - SCALE(KRANK+1) = ALSQ - ME = ME+1 - KRANK = KRANK+1 - 350 CONTINUE - ENDIF -C -C If pseudorank is less than L, apply Householder transformation. -C from right. -C - 360 IF (KRANK.LT.L) THEN - DO 370 J=KRANK,1,-1 - CALL H12 (1, J, KRANK+1, L, W(J,1), MDW, H(J), W, MDW, 1, - + J-1) - 370 CONTINUE - ENDIF -C - NIV = KRANK + NSOLN - L - IF (L.EQ.N) DONE = .TRUE. -C -C End of initial triangularization. -C - IDOPE(1) = ME - IDOPE(2) = KRANK - IDOPE(3) = NIV - RETURN - END diff --git a/slatec/wnlsm.f b/slatec/wnlsm.f deleted file mode 100644 index 10e34e6..0000000 --- a/slatec/wnlsm.f +++ /dev/null @@ -1,638 +0,0 @@ -*DECK WNLSM - SUBROUTINE WNLSM (W, MDW, MME, MA, N, L, PRGOPT, X, RNORM, MODE, - + IPIVOT, ITYPE, WD, H, SCALE, Z, TEMP, D) -C***BEGIN PROLOGUE WNLSM -C***SUBSIDIARY -C***PURPOSE Subsidiary to WNNLS -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (WNLSM-S, DWNLSM-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C This is a companion subprogram to WNNLS. -C The documentation for WNNLS has complete usage instructions. -C -C In addition to the parameters discussed in the prologue to -C subroutine WNNLS, the following work arrays are used in -C subroutine WNLSM (they are passed through the calling -C sequence from WNNLS for purposes of variable dimensioning). -C Their contents will in general be of no interest to the user. -C -C IPIVOT(*) -C An array of length N. Upon completion it contains the -C pivoting information for the cols of W(*,*). -C -C ITYPE(*) -C An array of length M which is used to keep track -C of the classification of the equations. ITYPE(I)=0 -C denotes equation I as an equality constraint. -C ITYPE(I)=1 denotes equation I as a least squares -C equation. -C -C WD(*) -C An array of length N. Upon completion it contains the -C dual solution vector. -C -C H(*) -C An array of length N. Upon completion it contains the -C pivot scalars of the Householder transformations performed -C in the case KRANK.LT.L. -C -C SCALE(*) -C An array of length M which is used by the subroutine -C to store the diagonal matrix of weights. -C These are used to apply the modified Givens -C transformations. -C -C Z(*),TEMP(*) -C Working arrays of length N. -C -C D(*) -C An array of length N that contains the -C column scaling for the matrix (E). -C (A) -C -C***SEE ALSO WNNLS -C***ROUTINES CALLED H12, ISAMAX, R1MACH, SASUM, SAXPY, SCOPY, SNRM2, -C SROTM, SROTMG, SSCAL, SSWAP, WNLIT, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890618 Completely restructured and revised. (WRB & RWC) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900328 Added TYPE section. (WRB) -C 900510 Fixed an error message. (RWC) -C***END PROLOGUE WNLSM - INTEGER IPIVOT(*), ITYPE(*), L, MA, MDW, MME, MODE, N - REAL D(*), H(*), PRGOPT(*), RNORM, SCALE(*), TEMP(*), - * W(MDW,*), WD(*), X(*), Z(*) -C - EXTERNAL H12, ISAMAX, R1MACH, SASUM, SAXPY, SCOPY, SNRM2, SROTM, - * SROTMG, SSCAL, SSWAP, WNLIT, XERMSG - REAL R1MACH, SASUM, SNRM2 - INTEGER ISAMAX -C - REAL ALAMDA, ALPHA, ALSQ, AMAX, BLOWUP, BNORM, - * DOPE(3), EANORM, FAC, SM, SPARAM(5), SRELPR, T, TAU, WMAX, Z2, - * ZZ - INTEGER I, IDOPE(3), IMAX, ISOL, ITEMP, ITER, ITMAX, IWMAX, J, - * JCON, JP, KEY, KRANK, L1, LAST, LINK, M, ME, NEXT, NIV, NLINK, - * NOPT, NSOLN, NTIMES - LOGICAL DONE, FEASBL, FIRST, HITCON, POS -C - SAVE SRELPR, FIRST - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT WNLSM -C -C Initialize variables. -C SRELPR is the precision for the particular machine -C being used. This logic avoids resetting it every entry. -C - IF (FIRST) SRELPR = R1MACH(4) - FIRST = .FALSE. -C -C Set the nominal tolerance used in the code. -C - TAU = SQRT(SRELPR) -C - M = MA + MME - ME = MME - MODE = 2 -C -C To process option vector -C - FAC = 1.E-4 -C -C Set the nominal blow up factor used in the code. -C - BLOWUP = TAU -C -C The nominal column scaling used in the code is -C the identity scaling. -C - CALL SCOPY (N, 1.E0, 0, D, 1) -C -C Define bound for number of options to change. -C - NOPT = 1000 -C -C Define bound for positive value of LINK. -C - NLINK = 100000 - NTIMES = 0 - LAST = 1 - LINK = PRGOPT(1) - IF (LINK.LE.0 .OR. LINK.GT.NLINK) THEN - CALL XERMSG ('SLATEC', 'WNLSM', - + 'WNNLS, THE OPTION VECTOR IS UNDEFINED', 3, 1) - RETURN - ENDIF -C - 100 IF (LINK.GT.1) THEN - NTIMES = NTIMES + 1 - IF (NTIMES.GT.NOPT) THEN - CALL XERMSG ('SLATEC', 'WNLSM', - + 'WNNLS, THE LINKS IN THE OPTION VECTOR ARE CYCLING.', 3, 1) - RETURN - ENDIF -C - KEY = PRGOPT(LAST+1) - IF (KEY.EQ.6 .AND. PRGOPT(LAST+2).NE.0.E0) THEN - DO 110 J = 1,N - T = SNRM2(M,W(1,J),1) - IF (T.NE.0.E0) T = 1.E0/T - D(J) = T - 110 CONTINUE - ENDIF -C - IF (KEY.EQ.7) CALL SCOPY (N, PRGOPT(LAST+2), 1, D, 1) - IF (KEY.EQ.8) TAU = MAX(SRELPR,PRGOPT(LAST+2)) - IF (KEY.EQ.9) BLOWUP = MAX(SRELPR,PRGOPT(LAST+2)) -C - NEXT = PRGOPT(LINK) - IF (NEXT.LE.0 .OR. NEXT.GT.NLINK) THEN - CALL XERMSG ('SLATEC', 'WNLSM', - + 'WNNLS, THE OPTION VECTOR IS UNDEFINED', 3, 1) - RETURN - ENDIF -C - LAST = LINK - LINK = NEXT - GO TO 100 - ENDIF -C - DO 120 J = 1,N - CALL SSCAL (M, D(J), W(1,J), 1) - 120 CONTINUE -C -C Process option vector -C - DONE = .FALSE. - ITER = 0 - ITMAX = 3*(N-L) - MODE = 0 - NSOLN = L - L1 = MIN(M,L) -C -C Compute scale factor to apply to equality constraint equations. -C - DO 130 J = 1,N - WD(J) = SASUM(M,W(1,J),1) - 130 CONTINUE -C - IMAX = ISAMAX(N,WD,1) - EANORM = WD(IMAX) - BNORM = SASUM(M,W(1,N+1),1) - ALAMDA = EANORM/(SRELPR*FAC) -C -C Define scaling diagonal matrix for modified Givens usage and -C classify equation types. -C - ALSQ = ALAMDA**2 - DO 140 I = 1,M -C -C When equation I is heavily weighted ITYPE(I)=0, -C else ITYPE(I)=1. -C - IF (I.LE.ME) THEN - T = ALSQ - ITEMP = 0 - ELSE - T = 1.E0 - ITEMP = 1 - ENDIF - SCALE(I) = T - ITYPE(I) = ITEMP - 140 CONTINUE -C -C Set the solution vector X(*) to zero and the column interchange -C matrix to the identity. -C - CALL SCOPY (N, 0.E0, 0, X, 1) - DO 150 I = 1,N - IPIVOT(I) = I - 150 CONTINUE -C -C Perform initial triangularization in the submatrix -C corresponding to the unconstrained variables. -C Set first L components of dual vector to zero because -C these correspond to the unconstrained variables. -C - CALL SCOPY (L, 0.E0, 0, WD, 1) -C -C The arrays IDOPE(*) and DOPE(*) are used to pass -C information to WNLIT(). This was done to avoid -C a long calling sequence or the use of COMMON. -C - IDOPE(1) = ME - IDOPE(2) = NSOLN - IDOPE(3) = L1 -C - DOPE(1) = ALSQ - DOPE(2) = EANORM - DOPE(3) = TAU - CALL WNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, RNORM, - + IDOPE, DOPE, DONE) - ME = IDOPE(1) - KRANK = IDOPE(2) - NIV = IDOPE(3) -C -C Perform WNNLS algorithm using the following steps. -C -C Until(DONE) -C compute search direction and feasible point -C when (HITCON) add constraints -C else perform multiplier test and drop a constraint -C fin -C Compute-Final-Solution -C -C To compute search direction and feasible point, -C solve the triangular system of currently non-active -C variables and store the solution in Z(*). -C -C To solve system -C Copy right hand side into TEMP vector to use overwriting method. -C - 160 IF (DONE) GO TO 330 - ISOL = L + 1 - IF (NSOLN.GE.ISOL) THEN - CALL SCOPY (NIV, W(1,N+1), 1, TEMP, 1) - DO 170 J = NSOLN,ISOL,-1 - IF (J.GT.KRANK) THEN - I = NIV - NSOLN + J - ELSE - I = J - ENDIF -C - IF (J.GT.KRANK .AND. J.LE.L) THEN - Z(J) = 0.E0 - ELSE - Z(J) = TEMP(I)/W(I,J) - CALL SAXPY (I-1, -Z(J), W(1,J), 1, TEMP, 1) - ENDIF - 170 CONTINUE - ENDIF -C -C Increment iteration counter and check against maximum number -C of iterations. -C - ITER = ITER + 1 - IF (ITER.GT.ITMAX) THEN - MODE = 1 - DONE = .TRUE. - ENDIF -C -C Check to see if any constraints have become active. -C If so, calculate an interpolation factor so that all -C active constraints are removed from the basis. -C - ALPHA = 2.E0 - HITCON = .FALSE. - DO 180 J = L+1,NSOLN - ZZ = Z(J) - IF (ZZ.LE.0.E0) THEN - T = X(J)/(X(J)-ZZ) - IF (T.LT.ALPHA) THEN - ALPHA = T - JCON = J - ENDIF - HITCON = .TRUE. - ENDIF - 180 CONTINUE -C -C Compute search direction and feasible point -C - IF (HITCON) THEN -C -C To add constraints, use computed ALPHA to interpolate between -C last feasible solution X(*) and current unconstrained (and -C infeasible) solution Z(*). -C - DO 190 J = L+1,NSOLN - X(J) = X(J) + ALPHA*(Z(J)-X(J)) - 190 CONTINUE - FEASBL = .FALSE. -C -C Remove column JCON and shift columns JCON+1 through N to the -C left. Swap column JCON into the N th position. This achieves -C upper Hessenberg form for the nonactive constraints and -C leaves an upper Hessenberg matrix to retriangularize. -C - 200 DO 210 I = 1,M - T = W(I,JCON) - CALL SCOPY (N-JCON, W(I, JCON+1), MDW, W(I, JCON), MDW) - W(I,N) = T - 210 CONTINUE -C -C Update permuted index vector to reflect this shift and swap. -C - ITEMP = IPIVOT(JCON) - DO 220 I = JCON,N - 1 - IPIVOT(I) = IPIVOT(I+1) - 220 CONTINUE - IPIVOT(N) = ITEMP -C -C Similarly permute X(*) vector. -C - CALL SCOPY (N-JCON, X(JCON+1), 1, X(JCON), 1) - X(N) = 0.E0 - NSOLN = NSOLN - 1 - NIV = NIV - 1 -C -C Retriangularize upper Hessenberg matrix after adding -C constraints. -C - I = KRANK + JCON - L - DO 230 J = JCON,NSOLN - IF (ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.0) THEN -C -C Zero IP1 to I in column J -C - IF (W(I+1,J).NE.0.E0) THEN - CALL SROTMG (SCALE(I), SCALE(I+1), W(I,J), W(I+1,J), - + SPARAM) - W(I+1,J) = 0.E0 - CALL SROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), MDW, - + SPARAM) - ENDIF - ELSEIF (ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.1) THEN -C -C Zero IP1 to I in column J -C - IF (W(I+1,J).NE.0.E0) THEN - CALL SROTMG (SCALE(I), SCALE(I+1), W(I,J), W(I+1,J), - + SPARAM) - W(I+1,J) = 0.E0 - CALL SROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), MDW, - + SPARAM) - ENDIF - ELSEIF (ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.0) THEN - CALL SSWAP (N+1, W(I,1), MDW, W(I+1,1), MDW) - CALL SSWAP (1, SCALE(I), 1, SCALE(I+1), 1) - ITEMP = ITYPE(I+1) - ITYPE(I+1) = ITYPE(I) - ITYPE(I) = ITEMP -C -C Swapped row was formerly a pivot element, so it will -C be large enough to perform elimination. -C Zero IP1 to I in column J. -C - IF (W(I+1,J).NE.0.E0) THEN - CALL SROTMG (SCALE(I), SCALE(I+1), W(I,J), W(I+1,J), - + SPARAM) - W(I+1,J) = 0.E0 - CALL SROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), MDW, - + SPARAM) - ENDIF - ELSEIF (ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.1) THEN - IF (SCALE(I)*W(I,J)**2/ALSQ.GT.(TAU*EANORM)**2) THEN -C -C Zero IP1 to I in column J -C - IF (W(I+1,J).NE.0.E0) THEN - CALL SROTMG (SCALE(I), SCALE(I+1), W(I,J), - + W(I+1,J), SPARAM) - W(I+1,J) = 0.E0 - CALL SROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), MDW, - + SPARAM) - ENDIF - ELSE - CALL SSWAP (N+1, W(I,1), MDW, W(I+1,1), MDW) - CALL SSWAP (1, SCALE(I), 1, SCALE(I+1), 1) - ITEMP = ITYPE(I+1) - ITYPE(I+1) = ITYPE(I) - ITYPE(I) = ITEMP - W(I+1,J) = 0.E0 - ENDIF - ENDIF - I = I + 1 - 230 CONTINUE -C -C See if the remaining coefficients in the solution set are -C feasible. They should be because of the way ALPHA was -C determined. If any are infeasible, it is due to roundoff -C error. Any that are non-positive will be set to zero and -C removed from the solution set. -C - DO 240 JCON = L+1,NSOLN - IF (X(JCON).LE.0.E0) GO TO 250 - 240 CONTINUE - FEASBL = .TRUE. - 250 IF (.NOT.FEASBL) GO TO 200 - ELSE -C -C To perform multiplier test and drop a constraint. -C - CALL SCOPY (NSOLN, Z, 1, X, 1) - IF (NSOLN.LT.N) CALL SCOPY (N-NSOLN, 0.E0, 0, X(NSOLN+1), 1) -C -C Reclassify least squares equations as equalities as necessary. -C - I = NIV + 1 - 260 IF (I.LE.ME) THEN - IF (ITYPE(I).EQ.0) THEN - I = I + 1 - ELSE - CALL SSWAP (N+1, W(I,1), MDW, W(ME,1), MDW) - CALL SSWAP (1, SCALE(I), 1, SCALE(ME), 1) - ITEMP = ITYPE(I) - ITYPE(I) = ITYPE(ME) - ITYPE(ME) = ITEMP - ME = ME - 1 - ENDIF - GO TO 260 - ENDIF -C -C Form inner product vector WD(*) of dual coefficients. -C - DO 280 J = NSOLN+1,N - SM = 0.E0 - DO 270 I = NSOLN+1,M - SM = SM + SCALE(I)*W(I,J)*W(I,N+1) - 270 CONTINUE - WD(J) = SM - 280 CONTINUE -C -C Find J such that WD(J)=WMAX is maximum. This determines -C that the incoming column J will reduce the residual vector -C and be positive. -C - 290 WMAX = 0.E0 - IWMAX = NSOLN + 1 - DO 300 J = NSOLN+1,N - IF (WD(J).GT.WMAX) THEN - WMAX = WD(J) - IWMAX = J - ENDIF - 300 CONTINUE - IF (WMAX.LE.0.E0) GO TO 330 -C -C Set dual coefficients to zero for incoming column. -C - WD(IWMAX) = 0.E0 -C -C WMAX .GT. 0.E0, so okay to move column IWMAX to solution set. -C Perform transformation to retriangularize, and test for near -C linear dependence. -C -C Swap column IWMAX into NSOLN-th position to maintain upper -C Hessenberg form of adjacent columns, and add new column to -C triangular decomposition. -C - NSOLN = NSOLN + 1 - NIV = NIV + 1 - IF (NSOLN.NE.IWMAX) THEN - CALL SSWAP (M, W(1,NSOLN), 1, W(1,IWMAX), 1) - WD(IWMAX) = WD(NSOLN) - WD(NSOLN) = 0.E0 - ITEMP = IPIVOT(NSOLN) - IPIVOT(NSOLN) = IPIVOT(IWMAX) - IPIVOT(IWMAX) = ITEMP - ENDIF -C -C Reduce column NSOLN so that the matrix of nonactive constraints -C variables is triangular. -C - DO 320 J = M,NIV+1,-1 - JP = J - 1 -C -C When operating near the ME line, test to see if the pivot -C element is near zero. If so, use the largest element above -C it as the pivot. This is to maintain the sharp interface -C between weighted and non-weighted rows in all cases. -C - IF (J.EQ.ME+1) THEN - IMAX = ME - AMAX = SCALE(ME)*W(ME,NSOLN)**2 - DO 310 JP = J - 1,NIV,-1 - T = SCALE(JP)*W(JP,NSOLN)**2 - IF (T.GT.AMAX) THEN - IMAX = JP - AMAX = T - ENDIF - 310 CONTINUE - JP = IMAX - ENDIF -C - IF (W(J,NSOLN).NE.0.E0) THEN - CALL SROTMG (SCALE(JP), SCALE(J), W(JP,NSOLN), - + W(J,NSOLN), SPARAM) - W(J,NSOLN) = 0.E0 - CALL SROTM (N+1-NSOLN, W(JP,NSOLN+1), MDW, W(J,NSOLN+1), - + MDW, SPARAM) - ENDIF - 320 CONTINUE -C -C Solve for Z(NSOLN)=proposed new value for X(NSOLN). Test if -C this is nonpositive or too large. If this was true or if the -C pivot term was zero, reject the column as dependent. -C - IF (W(NIV,NSOLN).NE.0.E0) THEN - ISOL = NIV - Z2 = W(ISOL,N+1)/W(ISOL,NSOLN) - Z(NSOLN) = Z2 - POS = Z2 .GT. 0.E0 - IF (Z2*EANORM.GE.BNORM .AND. POS) THEN - POS = .NOT. (BLOWUP*Z2*EANORM.GE.BNORM) - ENDIF -C -C Try to add row ME+1 as an additional equality constraint. -C Check size of proposed new solution component. -C Reject it if it is too large. -C - ELSEIF (NIV.LE.ME .AND. W(ME+1,NSOLN).NE.0.E0) THEN - ISOL = ME + 1 - IF (POS) THEN -C -C Swap rows ME+1 and NIV, and scale factors for these rows. -C - CALL SSWAP (N+1, W(ME+1,1), MDW, W(NIV,1), MDW) - CALL SSWAP (1, SCALE(ME+1), 1, SCALE(NIV), 1) - ITEMP = ITYPE(ME+1) - ITYPE(ME+1) = ITYPE(NIV) - ITYPE(NIV) = ITEMP - ME = ME + 1 - ENDIF - ELSE - POS = .FALSE. - ENDIF -C - IF (.NOT.POS) THEN - NSOLN = NSOLN - 1 - NIV = NIV - 1 - ENDIF - IF (.NOT.(POS.OR.DONE)) GO TO 290 - ENDIF - GO TO 160 -C -C Else perform multiplier test and drop a constraint. To compute -C final solution. Solve system, store results in X(*). -C -C Copy right hand side into TEMP vector to use overwriting method. -C - 330 ISOL = 1 - IF (NSOLN.GE.ISOL) THEN - CALL SCOPY (NIV, W(1,N+1), 1, TEMP, 1) - DO 340 J = NSOLN,ISOL,-1 - IF (J.GT.KRANK) THEN - I = NIV - NSOLN + J - ELSE - I = J - ENDIF -C - IF (J.GT.KRANK .AND. J.LE.L) THEN - Z(J) = 0.E0 - ELSE - Z(J) = TEMP(I)/W(I,J) - CALL SAXPY (I-1, -Z(J), W(1,J), 1, TEMP, 1) - ENDIF - 340 CONTINUE - ENDIF -C -C Solve system. -C - CALL SCOPY (NSOLN, Z, 1, X, 1) -C -C Apply Householder transformations to X(*) if KRANK.LT.L -C - IF (KRANK.LT.L) THEN - DO 350 I = 1,KRANK - CALL H12 (2, I, KRANK+1, L, W(I,1), MDW, H(I), X, 1, 1, 1) - 350 CONTINUE - ENDIF -C -C Fill in trailing zeroes for constrained variables not in solution. -C - IF (NSOLN.LT.N) CALL SCOPY (N-NSOLN, 0.E0, 0, X(NSOLN+1), 1) -C -C Permute solution vector to natural order. -C - DO 380 I = 1,N - J = I - 360 IF (IPIVOT(J).EQ.I) GO TO 370 - J = J + 1 - GO TO 360 -C - 370 IPIVOT(J) = IPIVOT(I) - IPIVOT(I) = J - CALL SSWAP (1, X(J), 1, X(I), 1) - 380 CONTINUE -C -C Rescale the solution using the column scaling. -C - DO 390 J = 1,N - X(J) = X(J)*D(J) - 390 CONTINUE -C - DO 400 I = NSOLN+1,M - T = W(I,N+1) - IF (I.LE.ME) T = T/ALAMDA - T = (SCALE(I)*T)*T - RNORM = RNORM + T - 400 CONTINUE -C - RNORM = SQRT(RNORM) - RETURN - END diff --git a/slatec/wnlt1.f b/slatec/wnlt1.f deleted file mode 100644 index 3d5762d..0000000 --- a/slatec/wnlt1.f +++ /dev/null @@ -1,63 +0,0 @@ -*DECK WNLT1 - SUBROUTINE WNLT1 (I, LEND, MEND, IR, MDW, RECALC, IMAX, HBAR, H, - + SCALE, W) -C***BEGIN PROLOGUE WNLT1 -C***SUBSIDIARY -C***PURPOSE Subsidiary to WNLIT -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (WNLT1-S, DWNLT1-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C To update the column Sum Of Squares and find the pivot column. -C The column Sum of Squares Vector will be updated at each step. -C When numerically necessary, these values will be recomputed. -C -C***SEE ALSO WNLIT -C***ROUTINES CALLED ISAMAX -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) -C***END PROLOGUE WNLT1 - INTEGER I, IMAX, IR, LEND, MDW, MEND - REAL H(*), HBAR, SCALE(*), W(MDW,*) - LOGICAL RECALC -C - EXTERNAL ISAMAX - INTEGER ISAMAX -C - INTEGER J, K -C -C***FIRST EXECUTABLE STATEMENT WNLT1 - IF (IR.NE.1 .AND. (.NOT.RECALC)) THEN -C -C Update column SS=sum of squares. -C - DO 10 J=I,LEND - H(J) = H(J) - SCALE(IR-1)*W(IR-1,J)**2 - 10 CONTINUE -C -C Test for numerical accuracy. -C - IMAX = ISAMAX(LEND-I+1, H(I), 1) + I - 1 - RECALC = (HBAR+1.E-3*H(IMAX)) .EQ. HBAR - ENDIF -C -C If required, recalculate column SS, using rows IR through MEND. -C - IF (RECALC) THEN - DO 30 J=I,LEND - H(J) = 0.E0 - DO 20 K=IR,MEND - H(J) = H(J) + SCALE(K)*W(K,J)**2 - 20 CONTINUE - 30 CONTINUE -C -C Find column with largest SS. -C - IMAX = ISAMAX(LEND-I+1, H(I), 1) + I - 1 - HBAR = H(IMAX) - ENDIF - RETURN - END diff --git a/slatec/wnlt2.f b/slatec/wnlt2.f deleted file mode 100644 index 856070f..0000000 --- a/slatec/wnlt2.f +++ /dev/null @@ -1,58 +0,0 @@ -*DECK WNLT2 - LOGICAL FUNCTION WNLT2 (ME, MEND, IR, FACTOR, TAU, SCALE, WIC) -C***BEGIN PROLOGUE WNLT2 -C***SUBSIDIARY -C***PURPOSE Subsidiary to WNLIT -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (WNLT2-S, DWNLT2-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C To test independence of incoming column. -C -C Test the column IC to determine if it is linearly independent -C of the columns already in the basis. In the initial tri. step, -C we usually want the heavy weight ALAMDA to be included in the -C test for independence. In this case, the value of FACTOR will -C have been set to 1.E0 before this procedure is invoked. -C In the potentially rank deficient problem, the value of FACTOR -C will have been set to ALSQ=ALAMDA**2 to remove the effect of the -C heavy weight from the test for independence. -C -C Write new column as partitioned vector -C (A1) number of components in solution so far = NIV -C (A2) M-NIV components -C And compute SN = inverse weighted length of A1 -C RN = inverse weighted length of A2 -C Call the column independent when RN .GT. TAU*SN -C -C***SEE ALSO WNILT -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890620 Code extracted from WNLIT and made a subroutine. (RWC)) -C***END PROLOGUE WNLT2 - REAL FACTOR, SCALE(*), TAU, WIC(*) - INTEGER IR, ME, MEND -C - REAL RN, SN, T - INTEGER J -C -C***FIRST EXECUTABLE STATEMENT WNLT2 - SN = 0.E0 - RN = 0.E0 - DO 10 J=1,MEND - T = SCALE(J) - IF (J.LE.ME) T = T/FACTOR - T = T*WIC(J)**2 -C - IF (J.LT.IR) THEN - SN = SN + T - ELSE - RN = RN + T - ENDIF - 10 CONTINUE - WNLT2 = RN .GT. SN*TAU**2 - RETURN - END diff --git a/slatec/wnlt3.f b/slatec/wnlt3.f deleted file mode 100644 index a0dccdb..0000000 --- a/slatec/wnlt3.f +++ /dev/null @@ -1,43 +0,0 @@ -*DECK WNLT3 - SUBROUTINE WNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) -C***BEGIN PROLOGUE WNLT3 -C***SUBSIDIARY -C***PURPOSE Subsidiary to WNLIT -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (WNLT3-S, DWNLT3-D) -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C Perform column interchange. -C Exchange elements of permuted index vector and perform column -C interchanges. -C -C***SEE ALSO WNLIT -C***ROUTINES CALLED SSWAP -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890620 Code extracted from WNLT and made a subroutine. (RWC)) -C***END PROLOGUE WNLT3 - INTEGER I, IMAX, IPIVOT(*), M, MDW - REAL H(*), W(MDW,*) -C - EXTERNAL SSWAP -C - REAL T - INTEGER ITEMP -C -C***FIRST EXECUTABLE STATEMENT WNLT3 - IF (IMAX.NE.I) THEN - ITEMP = IPIVOT(I) - IPIVOT(I) = IPIVOT(IMAX) - IPIVOT(IMAX) = ITEMP -C - CALL SSWAP(M, W(1,IMAX), 1, W(1,I), 1) -C - T = H(IMAX) - H(IMAX) = H(I) - H(I) = T - ENDIF - RETURN - END diff --git a/slatec/wnnls.f b/slatec/wnnls.f deleted file mode 100644 index 8124403..0000000 --- a/slatec/wnnls.f +++ /dev/null @@ -1,325 +0,0 @@ -*DECK WNNLS - SUBROUTINE WNNLS (W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, - + IWORK, WORK) -C***BEGIN PROLOGUE WNNLS -C***PURPOSE Solve a linearly constrained least squares problem with -C equality constraints and nonnegativity constraints on -C selected variables. -C***LIBRARY SLATEC -C***CATEGORY K1A2A -C***TYPE SINGLE PRECISION (WNNLS-S, DWNNLS-D) -C***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, -C EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, -C NONNEGATIVITY CONSTRAINTS, QUADRATIC PROGRAMMING -C***AUTHOR Hanson, R. J., (SNLA) -C Haskell, K. H., (SNLA) -C***DESCRIPTION -C -C Abstract -C -C This subprogram solves a linearly constrained least squares -C problem. Suppose there are given matrices E and A of -C respective dimensions ME by N and MA by N, and vectors F -C and B of respective lengths ME and MA. This subroutine -C solves the problem -C -C EX = F, (equations to be exactly satisfied) -C -C AX = B, (equations to be approximately satisfied, -C in the least squares sense) -C -C subject to components L+1,...,N nonnegative -C -C Any values ME.GE.0, MA.GE.0 and 0.LE. L .LE.N are permitted. -C -C The problem is reposed as problem WNNLS -C -C (WT*E)X = (WT*F) -C ( A) ( B), (least squares) -C subject to components L+1,...,N nonnegative. -C -C The subprogram chooses the heavy weight (or penalty parameter) WT. -C -C The parameters for WNNLS are -C -C INPUT.. -C -C W(*,*),MDW, The array W(*,*) is double subscripted with first -C ME,MA,N,L dimensioning parameter equal to MDW. For this -C discussion let us call M = ME + MA. Then MDW -C must satisfy MDW.GE.M. The condition MDW.LT.M -C is an error. -C -C The array W(*,*) contains the matrices and vectors -C -C (E F) -C (A B) -C -C in rows and columns 1,...,M and 1,...,N+1 -C respectively. Columns 1,...,L correspond to -C unconstrained variables X(1),...,X(L). The -C remaining variables are constrained to be -C nonnegative. The condition L.LT.0 or L.GT.N is -C an error. -C -C PRGOPT(*) This real-valued array is the option vector. -C If the user is satisfied with the nominal -C subprogram features set -C -C PRGOPT(1)=1 (or PRGOPT(1)=1.0) -C -C Otherwise PRGOPT(*) is a linked list consisting of -C groups of data of the following form -C -C LINK -C KEY -C DATA SET -C -C The parameters LINK and KEY are each one word. -C The DATA SET can be comprised of several words. -C The number of items depends on the value of KEY. -C The value of LINK points to the first -C entry of the next group of data within -C PRGOPT(*). The exception is when there are -C no more options to change. In that -C case LINK=1 and the values KEY and DATA SET -C are not referenced. The general layout of -C PRGOPT(*) is as follows. -C -C ...PRGOPT(1)=LINK1 (link to first entry of next group) -C . PRGOPT(2)=KEY1 (key to the option change) -C . PRGOPT(3)=DATA VALUE (data value for this change) -C . . -C . . -C . . -C ...PRGOPT(LINK1)=LINK2 (link to the first entry of -C . next group) -C . PRGOPT(LINK1+1)=KEY2 (key to the option change) -C . PRGOPT(LINK1+2)=DATA VALUE -C ... . -C . . -C . . -C ...PRGOPT(LINK)=1 (no more options to change) -C -C Values of LINK that are nonpositive are errors. -C A value of LINK.GT.NLINK=100000 is also an error. -C This helps prevent using invalid but positive -C values of LINK that will probably extend -C beyond the program limits of PRGOPT(*). -C Unrecognized values of KEY are ignored. The -C order of the options is arbitrary and any number -C of options can be changed with the following -C restriction. To prevent cycling in the -C processing of the option array a count of the -C number of options changed is maintained. -C Whenever this count exceeds NOPT=1000 an error -C message is printed and the subprogram returns. -C -C OPTIONS.. -C -C KEY=6 -C Scale the nonzero columns of the -C entire data matrix -C (E) -C (A) -C to have length one. The DATA SET for -C this option is a single value. It must -C be nonzero if unit length column scaling is -C desired. -C -C KEY=7 -C Scale columns of the entire data matrix -C (E) -C (A) -C with a user-provided diagonal matrix. -C The DATA SET for this option consists -C of the N diagonal scaling factors, one for -C each matrix column. -C -C KEY=8 -C Change the rank determination tolerance from -C the nominal value of SQRT(SRELPR). This quantity -C can be no smaller than SRELPR, The arithmetic- -C storage precision. The quantity used -C here is internally restricted to be at -C least SRELPR. The DATA SET for this option -C is the new tolerance. -C -C KEY=9 -C Change the blow-up parameter from the -C nominal value of SQRT(SRELPR). The reciprocal of -C this parameter is used in rejecting solution -C components as too large when a variable is -C first brought into the active set. Too large -C means that the proposed component times the -C reciprocal of the parameter is not less than -C the ratio of the norms of the right-side -C vector and the data matrix. -C This parameter can be no smaller than SRELPR, -C the arithmetic-storage precision. -C -C For example, suppose we want to provide -C a diagonal matrix to scale the problem -C matrix and change the tolerance used for -C determining linear dependence of dropped col -C vectors. For these options the dimensions of -C PRGOPT(*) must be at least N+6. The FORTRAN -C statements defining these options would -C be as follows. -C -C PRGOPT(1)=N+3 (link to entry N+3 in PRGOPT(*)) -C PRGOPT(2)=7 (user-provided scaling key) -C -C CALL SCOPY(N,D,1,PRGOPT(3),1) (copy the N -C scaling factors from a user array called D(*) -C into PRGOPT(3)-PRGOPT(N+2)) -C -C PRGOPT(N+3)=N+6 (link to entry N+6 of PRGOPT(*)) -C PRGOPT(N+4)=8 (linear dependence tolerance key) -C PRGOPT(N+5)=... (new value of the tolerance) -C -C PRGOPT(N+6)=1 (no more options to change) -C -C -C IWORK(1), The amounts of working storage actually allocated -C IWORK(2) for the working arrays WORK(*) and IWORK(*), -C respectively. These quantities are compared with -C the actual amounts of storage needed for WNNLS( ). -C Insufficient storage allocated for either WORK(*) -C or IWORK(*) is considered an error. This feature -C was included in WNNLS( ) because miscalculating -C the storage formulas for WORK(*) and IWORK(*) -C might very well lead to subtle and hard-to-find -C execution errors. -C -C The length of WORK(*) must be at least -C -C LW = ME+MA+5*N -C This test will not be made if IWORK(1).LE.0. -C -C The length of IWORK(*) must be at least -C -C LIW = ME+MA+N -C This test will not be made if IWORK(2).LE.0. -C -C OUTPUT.. -C -C X(*) An array dimensioned at least N, which will -C contain the N components of the solution vector -C on output. -C -C RNORM The residual norm of the solution. The value of -C RNORM contains the residual vector length of the -C equality constraints and least squares equations. -C -C MODE The value of MODE indicates the success or failure -C of the subprogram. -C -C MODE = 0 Subprogram completed successfully. -C -C = 1 Max. number of iterations (equal to -C 3*(N-L)) exceeded. Nearly all problems -C should complete in fewer than this -C number of iterations. An approximate -C solution and its corresponding residual -C vector length are in X(*) and RNORM. -C -C = 2 Usage error occurred. The offending -C condition is noted with the error -C processing subprogram, XERMSG( ). -C -C User-designated -C Working arrays.. -C -C WORK(*) A real-valued working array of length at least -C M + 5*N. -C -C IWORK(*) An integer-valued working array of length at least -C M+N. -C -C***REFERENCES K. H. Haskell and R. J. Hanson, An algorithm for -C linear least squares problems with equality and -C nonnegativity constraints, Report SAND77-0552, Sandia -C Laboratories, June 1978. -C K. H. Haskell and R. J. Hanson, Selected algorithms for -C the linearly constrained least squares problem - a -C users guide, Report SAND78-1290, Sandia Laboratories, -C August 1979. -C K. H. Haskell and R. J. Hanson, An algorithm for -C linear least squares problems with equality and -C nonnegativity constraints, Mathematical Programming -C 21 (1981), pp. 98-118. -C R. J. Hanson and K. H. Haskell, Two algorithms for the -C linearly constrained least squares problem, ACM -C Transactions on Mathematical Software, September 1982. -C C. L. Lawson and R. J. Hanson, Solving Least Squares -C Problems, Prentice-Hall, Inc., 1974. -C***ROUTINES CALLED WNLSM, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790701 DATE WRITTEN -C 890206 REVISION DATE from Version 3.2 -C 890618 Completely restructured and revised. (WRB & RWC) -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 WNNLS - REAL PRGOPT(*), RNORM, W(MDW,*), WORK(*), X(*) - INTEGER IWORK(*) - CHARACTER*8 XERN1 -C -C -C***FIRST EXECUTABLE STATEMENT WNNLS - MODE = 0 - IF (MA+ME.LE.0 .OR. N.LE.0) RETURN - IF (IWORK(1).GT.0) THEN - LW = ME + MA + 5*N - IF (IWORK(1).LT.LW) THEN - WRITE (XERN1, '(I8)') LW - CALL XERMSG ('SLATEC', 'WNNLS', 'INSUFFICIENT STORAGE ' // - * 'ALLOCATED FOR WORK(*), NEED LW = ' // XERN1, 2, 1) - MODE = 2 - RETURN - ENDIF - ENDIF -C - IF (IWORK(2).GT.0) THEN - LIW = ME + MA + N - IF (IWORK(2).LT.LIW) THEN - WRITE (XERN1, '(I8)') LIW - CALL XERMSG ('SLATEC', 'WNNLS', 'INSUFFICIENT STORAGE ' // - * 'ALLOCATED FOR IWORK(*), NEED LIW = ' // XERN1, 2, 1) - MODE = 2 - RETURN - ENDIF - ENDIF -C - IF (MDW.LT.ME+MA) THEN - CALL XERMSG ('SLATEC', 'WNNLS', - * 'THE VALUE MDW.LT.ME+MA IS AN ERROR', 1, 1) - MODE = 2 - RETURN - ENDIF -C - IF (L.LT.0 .OR. L.GT.N) THEN - CALL XERMSG ('SLATEC', 'WNNLS', - * 'L.GE.0 .AND. L.LE.N IS REQUIRED', 2, 1) - MODE = 2 - RETURN - ENDIF -C -C THE PURPOSE OF THIS SUBROUTINE IS TO BREAK UP THE ARRAYS -C WORK(*) AND IWORK(*) INTO SEPARATE WORK ARRAYS -C REQUIRED BY THE MAIN SUBROUTINE WNLSM( ). -C - L1 = N + 1 - L2 = L1 + N - L3 = L2 + ME + MA - L4 = L3 + N - L5 = L4 + N -C - CALL WNLSM(W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, IWORK, - * IWORK(L1), WORK(1), WORK(L1), WORK(L2), WORK(L3), - * WORK(L4), WORK(L5)) - RETURN - END diff --git a/slatec/xadd.f b/slatec/xadd.f deleted file mode 100644 index 71d0cf8..0000000 --- a/slatec/xadd.f +++ /dev/null @@ -1,171 +0,0 @@ -*DECK XADD - SUBROUTINE XADD (X, IX, Y, IY, Z, IZ, IERROR) -C***BEGIN PROLOGUE XADD -C***PURPOSE To provide single-precision floating-point arithmetic -C with an extended exponent range. -C***LIBRARY SLATEC -C***CATEGORY A3D -C***TYPE SINGLE PRECISION (XADD-S, DXADD-D) -C***KEYWORDS EXTENDED-RANGE SINGLE-PRECISION ARITHMETIC -C***AUTHOR Lozier, Daniel W., (National Bureau of Standards) -C Smith, John M., (NBS and George Mason University) -C***DESCRIPTION -C REAL X, Y, Z -C INTEGER IX, IY, IZ -C -C FORMS THE EXTENDED-RANGE SUM (Z,IZ) = -C (X,IX) + (Y,IY). (Z,IZ) IS ADJUSTED -C BEFORE RETURNING. THE INPUT OPERANDS -C NEED NOT BE IN ADJUSTED FORM, BUT THEIR -C PRINCIPAL PARTS MUST SATISFY -C RADIX**(-2L).LE.ABS(X).LE.RADIX**(2L), -C RADIX**(-2L).LE.ABS(Y).LE.RADIX**(2L). -C -C***SEE ALSO XSET -C***REFERENCES (NONE) -C***ROUTINES CALLED XADJ -C***COMMON BLOCKS XBLK2 -C***REVISION HISTORY (YYMMDD) -C 820712 DATE WRITTEN -C 881020 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Changed all specific intrinsics to generic. (WRB) -C Corrected order of sections in prologue and added TYPE -C section. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE XADD - REAL X, Y, Z - INTEGER IX, IY, IZ - REAL RADIX, RADIXL, RAD2L, DLG10R - INTEGER L, L2, KMAX - COMMON /XBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX - SAVE /XBLK2/ -C -C -C THE CONDITIONS IMPOSED ON L AND KMAX BY THIS SUBROUTINE -C ARE -C (1) 1 .LT. L .LE. 0.5*LOGR(0.5*DZERO) -C -C (2) NRADPL .LT. L .LE. KMAX/6 -C -C (3) KMAX .LE. (2**NBITS - 4*L - 1)/2 -C -C THESE CONDITIONS MUST BE MET BY APPROPRIATE CODING -C IN SUBROUTINE XSET. -C -C***FIRST EXECUTABLE STATEMENT XADD - IERROR=0 - IF (X.NE.0.0) GO TO 10 - Z = Y - IZ = IY - GO TO 220 - 10 IF (Y.NE.0.0) GO TO 20 - Z = X - IZ = IX - GO TO 220 - 20 CONTINUE - IF (IX.GE.0 .AND. IY.GE.0) GO TO 40 - IF (IX.LT.0 .AND. IY.LT.0) GO TO 40 - IF (ABS(IX).LE.6*L .AND. ABS(IY).LE.6*L) GO TO 40 - IF (IX.GE.0) GO TO 30 - Z = Y - IZ = IY - GO TO 220 - 30 CONTINUE - Z = X - IZ = IX - GO TO 220 - 40 I = IX - IY - IF (I) 80, 50, 90 - 50 IF (ABS(X).GT.1.0 .AND. ABS(Y).GT.1.0) GO TO 60 - IF (ABS(X).LT.1.0 .AND. ABS(Y).LT.1.0) GO TO 70 - Z = X + Y - IZ = IX - GO TO 220 - 60 S = X/RADIXL - T = Y/RADIXL - Z = S + T - IZ = IX + L - GO TO 220 - 70 S = X*RADIXL - T = Y*RADIXL - Z = S + T - IZ = IX - L - GO TO 220 - 80 S = Y - IS = IY - T = X - GO TO 100 - 90 S = X - IS = IX - T = Y - 100 CONTINUE -C -C AT THIS POINT, THE ONE OF (X,IX) OR (Y,IY) THAT HAS THE -C LARGER AUXILIARY INDEX IS STORED IN (S,IS). THE PRINCIPAL -C PART OF THE OTHER INPUT IS STORED IN T. -C - I1 = ABS(I)/L - I2 = MOD(ABS(I),L) - IF (ABS(T).GE.RADIXL) GO TO 130 - IF (ABS(T).GE.1.0) GO TO 120 - IF (RADIXL*ABS(T).GE.1.0) GO TO 110 - J = I1 + 1 - T = T*RADIX**(L-I2) - GO TO 140 - 110 J = I1 - T = T*RADIX**(-I2) - GO TO 140 - 120 J = I1 - 1 - IF (J.LT.0) GO TO 110 - T = T*RADIX**(-I2)/RADIXL - GO TO 140 - 130 J = I1 - 2 - IF (J.LT.0) GO TO 120 - T = T*RADIX**(-I2)/RAD2L - 140 CONTINUE -C -C AT THIS POINT, SOME OR ALL OF THE DIFFERENCE IN THE -C AUXILIARY INDICES HAS BEEN USED TO EFFECT A LEFT SHIFT -C OF T. THE SHIFTED VALUE OF T SATISFIES -C -C RADIX**(-2*L) .LE. ABS(T) .LE. 1.0 -C -C AND, IF J=0, NO FURTHER SHIFTING REMAINS TO BE DONE. -C - IF (J.EQ.0) GO TO 190 - IF (ABS(S).GE.RADIXL .OR. J.GT.3) GO TO 150 - IF (ABS(S).GE.1.0) GO TO (180, 150, 150), J - IF (RADIXL*ABS(S).GE.1.0) GO TO (180, 170, 150), J - GO TO (180, 170, 160), J - 150 Z = S - IZ = IS - GO TO 220 - 160 S = S*RADIXL - 170 S = S*RADIXL - 180 S = S*RADIXL - 190 CONTINUE -C -C AT THIS POINT, THE REMAINING DIFFERENCE IN THE -C AUXILIARY INDICES HAS BEEN USED TO EFFECT A RIGHT SHIFT -C OF S. IF THE SHIFTED VALUE OF S WOULD HAVE EXCEEDED -C RADIX**L, THEN (S,IS) IS RETURNED AS THE VALUE OF THE -C SUM. -C - IF (ABS(S).GT.1.0 .AND. ABS(T).GT.1.0) GO TO 200 - IF (ABS(S).LT.1.0 .AND. ABS(T).LT.1.0) GO TO 210 - Z = S + T - IZ = IS - J*L - GO TO 220 - 200 S = S/RADIXL - T = T/RADIXL - Z = S + T - IZ = IS - J*L + L - GO TO 220 - 210 S = S*RADIXL - T = T*RADIXL - Z = S + T - IZ = IS - J*L - L - 220 CALL XADJ(Z, IZ,IERROR) - RETURN - END diff --git a/slatec/xadj.f b/slatec/xadj.f deleted file mode 100644 index 14ccdca..0000000 --- a/slatec/xadj.f +++ /dev/null @@ -1,77 +0,0 @@ -*DECK XADJ - SUBROUTINE XADJ (X, IX, IERROR) -C***BEGIN PROLOGUE XADJ -C***PURPOSE To provide single-precision floating-point arithmetic -C with an extended exponent range. -C***LIBRARY SLATEC -C***CATEGORY A3D -C***TYPE SINGLE PRECISION (XADJ-S, DXADJ-D) -C***KEYWORDS EXTENDED-RANGE SINGLE-PRECISION ARITHMETIC -C***AUTHOR Lozier, Daniel W., (National Bureau of Standards) -C Smith, John M., (NBS and George Mason University) -C***DESCRIPTION -C REAL X -C INTEGER IX -C -C TRANSFORMS (X,IX) SO THAT -C RADIX**(-L) .LE. ABS(X) .LT. RADIX**L. -C ON MOST COMPUTERS THIS TRANSFORMATION DOES -C NOT CHANGE THE MANTISSA OF X PROVIDED RADIX IS -C THE NUMBER BASE OF SINGLE-PRECISION ARITHMETIC. -C -C***SEE ALSO XSET -C***REFERENCES (NONE) -C***ROUTINES CALLED XERMSG -C***COMMON BLOCKS XBLK2 -C***REVISION HISTORY (YYMMDD) -C 820712 DATE WRITTEN -C 881020 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Changed all specific intrinsics to generic. (WRB) -C Corrected order of sections in prologue and added TYPE -C section. (WRB) -C CALLs to XERROR changed to CALLs to XERMSG. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE XADJ - REAL X - INTEGER IX - REAL RADIX, RADIXL, RAD2L, DLG10R - INTEGER L, L2, KMAX - COMMON /XBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX - SAVE /XBLK2/ -C -C THE CONDITION IMPOSED ON L AND KMAX BY THIS SUBROUTINE -C IS -C 2*L .LE. KMAX -C -C THIS CONDITION MUST BE MET BY APPROPRIATE CODING -C IN SUBROUTINE XSET. -C -C***FIRST EXECUTABLE STATEMENT XADJ - IERROR=0 - IF (X.EQ.0.0) GO TO 50 - IF (ABS(X).GE.1.0) GO TO 20 - IF (RADIXL*ABS(X).GE.1.0) GO TO 60 - X = X*RAD2L - IF (IX.LT.0) GO TO 10 - IX = IX - L2 - GO TO 70 - 10 IF (IX.LT.-KMAX+L2) GO TO 40 - IX = IX - L2 - GO TO 70 - 20 IF (ABS(X).LT.RADIXL) GO TO 60 - X = X/RAD2L - IF (IX.GT.0) GO TO 30 - IX = IX + L2 - GO TO 70 - 30 IF (IX.GT.KMAX-L2) GO TO 40 - IX = IX + L2 - GO TO 70 - 40 CALL XERMSG ('SLATEC', 'XADJ', 'overflow in auxiliary index', 107, - + 1) - IERROR=107 - RETURN - 50 IX = 0 - 60 IF (ABS(IX).GT.KMAX) GO TO 40 - 70 RETURN - END diff --git a/slatec/xc210.f b/slatec/xc210.f deleted file mode 100644 index dafc963..0000000 --- a/slatec/xc210.f +++ /dev/null @@ -1,113 +0,0 @@ -*DECK XC210 - SUBROUTINE XC210 (K, Z, J, IERROR) -C***BEGIN PROLOGUE XC210 -C***PURPOSE To provide single-precision floating-point arithmetic -C with an extended exponent range. -C***LIBRARY SLATEC -C***CATEGORY A3D -C***TYPE SINGLE PRECISION (XC210-S, DXC210-D) -C***KEYWORDS EXTENDED-RANGE SINGLE-PRECISION ARITHMETIC -C***AUTHOR Lozier, Daniel W., (National Bureau of Standards) -C Smith, John M., (NBS and George Mason University) -C***DESCRIPTION -C INTEGER K, J -C REAL Z -C -C GIVEN K THIS SUBROUTINE COMPUTES J AND Z -C SUCH THAT RADIX**K = Z*10**J, WHERE Z IS IN -C THE RANGE 1/10 .LE. Z .LT. 1. -C THE VALUE OF Z WILL BE ACCURATE TO FULL -C SINGLE-PRECISION PROVIDED THE NUMBER -C OF DECIMAL PLACES IN THE LARGEST -C INTEGER PLUS THE NUMBER OF DECIMAL -C PLACES CARRIED IN SINGLE-PRECISION DOES NOT -C EXCEED 60. XC210 IS CALLED BY SUBROUTINE -C XCON WHEN NECESSARY. THE USER SHOULD -C NEVER NEED TO CALL XC210 DIRECTLY. -C -C***SEE ALSO XSET -C***REFERENCES (NONE) -C***ROUTINES CALLED XERMSG -C***COMMON BLOCKS XBLK3 -C***REVISION HISTORY (YYMMDD) -C 820712 DATE WRITTEN -C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Changed all specific intrinsics to generic. (WRB) -C Corrected order of sections in prologue and added TYPE -C section. (WRB) -C CALLs to XERROR changed to CALLs to XERMSG. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE XC210 - INTEGER K, J - REAL Z - INTEGER NLG102, MLG102, LG102 - COMMON /XBLK3/ NLG102, MLG102, LG102(21) - SAVE /XBLK3/ -C -C THE CONDITIONS IMPOSED ON NLG102, MLG102, AND LG102 BY -C THIS SUBROUTINE ARE -C -C (1) NLG102 .GE. 2 -C -C (2) MLG102 .GE. 1 -C -C (3) 2*MLG102*(MLG102 - 1) .LE. 2**NBITS - 1 -C -C THESE CONDITIONS MUST BE MET BY APPROPRIATE CODING -C IN SUBROUTINE XSET. -C -C***FIRST EXECUTABLE STATEMENT XC210 - IERROR=0 - IF (K.EQ.0) GO TO 70 - M = MLG102 - KA = ABS(K) - KA1 = KA/M - KA2 = MOD(KA,M) - IF (KA1.GE.M) GO TO 60 - NM1 = NLG102 - 1 - NP1 = NLG102 + 1 - IT = KA2*LG102(NP1) - IC = IT/M - ID = MOD(IT,M) - Z = ID - IF (KA1.GT.0) GO TO 20 - DO 10 II=1,NM1 - I = NP1 - II - IT = KA2*LG102(I) + IC - IC = IT/M - ID = MOD(IT,M) - Z = Z/M + ID - 10 CONTINUE - JA = KA*LG102(1) + IC - GO TO 40 - 20 CONTINUE - DO 30 II=1,NM1 - I = NP1 - II - IT = KA2*LG102(I) + KA1*LG102(I+1) + IC - IC = IT/M - ID = MOD(IT,M) - Z = Z/M + ID - 30 CONTINUE - JA = KA*LG102(1) + KA1*LG102(2) + IC - 40 CONTINUE - Z = Z/M - IF (K.GT.0) GO TO 50 - J = -JA - Z = 10.0**(-Z) - GO TO 80 - 50 CONTINUE - J = JA + 1 - Z = 10.0**(Z-1.0) - GO TO 80 - 60 CONTINUE -C THIS ERROR OCCURS IF K EXCEEDS MLG102**2 - 1 IN MAGNITUDE. -C - CALL XERMSG ('SLATEC', 'XC210', 'K too large', 108, 1) - IERROR=108 - RETURN - 70 CONTINUE - J = 0 - Z = 1.0 - 80 RETURN - END diff --git a/slatec/xcon.f b/slatec/xcon.f deleted file mode 100644 index 5ab0845..0000000 --- a/slatec/xcon.f +++ /dev/null @@ -1,167 +0,0 @@ -*DECK XCON - SUBROUTINE XCON (X, IX, IERROR) -C***BEGIN PROLOGUE XCON -C***PURPOSE To provide single-precision floating-point arithmetic -C with an extended exponent range. -C***LIBRARY SLATEC -C***CATEGORY A3D -C***TYPE SINGLE PRECISION (XCON-S, DXCON-D) -C***KEYWORDS EXTENDED-RANGE SINGLE-PRECISION ARITHMETIC -C***AUTHOR Lozier, Daniel W., (National Bureau of Standards) -C Smith, John M., (NBS and George Mason University) -C***DESCRIPTION -C REAL X -C INTEGER IX -C -C CONVERTS (X,IX) = X*RADIX**IX -C TO DECIMAL FORM IN PREPARATION FOR -C PRINTING, SO THAT (X,IX) = X*10**IX -C WHERE 1/10 .LE. ABS(X) .LT. 1 -C IS RETURNED, EXCEPT THAT IF -C (ABS(X),IX) IS BETWEEN RADIX**(-2L) -C AND RADIX**(2L) THEN THE REDUCED -C FORM WITH IX = 0 IS RETURNED. -C -C***SEE ALSO XSET -C***REFERENCES (NONE) -C***ROUTINES CALLED XADJ, XC210, XRED -C***COMMON BLOCKS XBLK2 -C***REVISION HISTORY (YYMMDD) -C 820712 DATE WRITTEN -C 881020 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Changed all specific intrinsics to generic. (WRB) -C Corrected order of sections in prologue and added TYPE -C section. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE XCON - REAL X - INTEGER IX -C -C THE CONDITIONS IMPOSED ON L AND KMAX BY THIS SUBROUTINE -C ARE -C (1) 4 .LE. L .LE. 2**NBITS - 1 - KMAX -C -C (2) KMAX .LE. ((2**NBITS)-2)/LOG10R - L -C -C THESE CONDITIONS MUST BE MET BY APPROPRIATE CODING -C IN SUBROUTINE XSET. -C - REAL RADIX, RADIXL, RAD2L, DLG10R - INTEGER L, L2, KMAX - COMMON /XBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX - SAVE /XBLK2/, ISPACE -C - REAL A, B, Z -C - DATA ISPACE /1/ -C THE PARAMETER ISPACE IS THE INCREMENT USED IN FORM- -C ING THE AUXILIARY INDEX OF THE DECIMAL EXTENDED-RANGE -C FORM. THE RETURNED VALUE OF IX WILL BE AN INTEGER MULT- -C IPLE OF ISPACE. ISPACE MUST SATISFY 1 .LE. ISPACE .LE. -C L/2. IF A VALUE GREATER THAN 1 IS TAKEN, THE RETURNED -C VALUE OF X WILL SATISFY 10**(-ISPACE) .LE. ABS(X) .LE. 1 -C WHEN (ABS(X),IX) .LT. RADIX**(-2L) AND 1/10 .LE. ABS(X) -C .LT. 10**(ISPACE-1) WHEN (ABS(X),IX) .GT. RADIX**(2L). -C -C***FIRST EXECUTABLE STATEMENT XCON - IERROR=0 - CALL XRED(X, IX,IERROR) - IF (IERROR.NE.0) RETURN - IF (IX.EQ.0) GO TO 150 - CALL XADJ(X, IX,IERROR) - IF (IERROR.NE.0) RETURN -C -C CASE 1 IS WHEN (X,IX) IS LESS THAN RADIX**(-2L) IN MAGNITUDE, -C CASE 2 IS WHEN (X,IX) IS GREATER THAN RADIX**(2L) IN MAGNITUDE. - ITEMP = 1 - ICASE = (3+SIGN(ITEMP,IX))/2 - GO TO (10, 20), ICASE - 10 IF (ABS(X).LT.1.0) GO TO 30 - X = X/RADIXL - IX = IX + L - GO TO 30 - 20 IF (ABS(X).GE.1.0) GO TO 30 - X = X*RADIXL - IX = IX - L - 30 CONTINUE -C -C AT THIS POINT, RADIX**(-L) .LE. ABS(X) .LT. 1.0 IN CASE 1, -C 1.0 .LE. ABS(X) .LT. RADIX**L IN CASE 2. - I = LOG10(ABS(X))/DLG10R - A = RADIX**I - GO TO (40, 60), ICASE - 40 IF (A.LE.RADIX*ABS(X)) GO TO 50 - I = I - 1 - A = A/RADIX - GO TO 40 - 50 IF (ABS(X).LT.A) GO TO 80 - I = I + 1 - A = A*RADIX - GO TO 50 - 60 IF (A.LE.ABS(X)) GO TO 70 - I = I - 1 - A = A/RADIX - GO TO 60 - 70 IF (ABS(X).LT.RADIX*A) GO TO 80 - I = I + 1 - A = A*RADIX - GO TO 70 - 80 CONTINUE -C -C AT THIS POINT I IS SUCH THAT -C RADIX**(I-1) .LE. ABS(X) .LT. RADIX**I IN CASE 1, -C RADIX**I .LE. ABS(X) .LT. RADIX**(I+1) IN CASE 2. - ITEMP = ISPACE/DLG10R - A = RADIX**ITEMP - B = 10.0**ISPACE - 90 IF (A.LE.B) GO TO 100 - ITEMP = ITEMP - 1 - A = A/RADIX - GO TO 90 - 100 IF (B.LT.A*RADIX) GO TO 110 - ITEMP = ITEMP + 1 - A = A*RADIX - GO TO 100 - 110 CONTINUE -C -C AT THIS POINT ITEMP IS SUCH THAT -C RADIX**ITEMP .LE. 10**ISPACE .LT. RADIX**(ITEMP+1). - IF (ITEMP.GT.0) GO TO 120 -C ITEMP = 0 IF, AND ONLY IF, ISPACE = 1 AND RADIX = 16.0 - X = X*RADIX**(-I) - IX = IX + I - CALL XC210(IX, Z, J,IERROR) - IF (IERROR.NE.0) RETURN - X = X*Z - IX = J - GO TO (130, 140), ICASE - 120 CONTINUE - I1 = I/ITEMP - X = X*RADIX**(-I1*ITEMP) - IX = IX + I1*ITEMP -C -C AT THIS POINT, -C RADIX**(-ITEMP) .LE. ABS(X) .LT. 1.0 IN CASE 1, -C 1.0 .LE. ABS(X) .LT. RADIX**ITEMP IN CASE 2. - CALL XC210(IX, Z, J,IERROR) - IF (IERROR.NE.0) RETURN - J1 = J/ISPACE - J2 = J - J1*ISPACE - X = X*Z*10.0**J2 - IX = J1*ISPACE -C -C AT THIS POINT, -C 10.0**(-2*ISPACE) .LE. ABS(X) .LT. 1.0 IN CASE 1, -C 10.0**-1 .LE. ABS(X) .LT. 10.0**(2*ISPACE-1) IN CASE 2. - GO TO (130, 140), ICASE - 130 IF (B*ABS(X).GE.1.0) GO TO 150 - X = X*B - IX = IX - ISPACE - GO TO 130 - 140 IF (10.0*ABS(X).LT.B) GO TO 150 - X = X/B - IX = IX + ISPACE - GO TO 140 - 150 RETURN - END diff --git a/slatec/xerbla.f b/slatec/xerbla.f deleted file mode 100644 index 25316b3..0000000 --- a/slatec/xerbla.f +++ /dev/null @@ -1,55 +0,0 @@ -*DECK XERBLA - SUBROUTINE XERBLA (SRNAME, INFO) -C***BEGIN PROLOGUE XERBLA -C***SUBSIDIARY -C***PURPOSE Error handler for the Level 2 and Level 3 BLAS Routines. -C***LIBRARY SLATEC -C***CATEGORY R3 -C***TYPE ALL (XERBLA-A) -C***KEYWORDS ERROR MESSAGE -C***AUTHOR Dongarra, J. J., (ANL) -C***DESCRIPTION -C -C Purpose -C ======= -C -C It is called by Level 2 and 3 BLAS routines if an input parameter -C is invalid. -C -C Parameters -C ========== -C -C SRNAME - CHARACTER*6. -C On entry, SRNAME specifies the name of the routine which -C called XERBLA. -C -C INFO - INTEGER. -C On entry, INFO specifies the position of the invalid -C parameter in the parameter-list of the calling routine. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 860720 DATE WRITTEN -C 910610 Routine rewritten to serve as an interface between the -C Level 2 and Level 3 BLAS routines and the SLATEC error -C handler XERMSG. (BKS) -C***END PROLOGUE XERBLA -C -C .. Scalar Arguments .. - INTEGER INFO - CHARACTER*6 SRNAME - CHARACTER*2 XERN1 -C -C***FIRST EXECUTABLE STATEMENT XERBLA -C - WRITE (XERN1, '(I2)') INFO - CALL XERMSG ('SLATEC', SRNAME, 'On entry to '//SRNAME// - $ ' parameter number '//XERN1//' had an illegal value', - $ INFO,1) -C - RETURN -C -C End of XERBLA. -C - END diff --git a/slatec/xerclr.f b/slatec/xerclr.f deleted file mode 100644 index e190284..0000000 --- a/slatec/xerclr.f +++ /dev/null @@ -1,31 +0,0 @@ -*DECK XERCLR - SUBROUTINE XERCLR -C***BEGIN PROLOGUE XERCLR -C***PURPOSE Reset current error number to zero. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XERCLR-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C This routine simply resets the current error number to zero. -C This may be necessary in order to determine that a certain -C error has occurred again since the last time NUMXER was -C referenced. -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 XERCLR -C***FIRST EXECUTABLE STATEMENT XERCLR - JUNK = J4SAVE(1,0,.TRUE.) - RETURN - END diff --git a/slatec/xercnt.f b/slatec/xercnt.f deleted file mode 100644 index 06c82ab..0000000 --- a/slatec/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/slatec/xerdmp.f b/slatec/xerdmp.f deleted file mode 100644 index 183b5ad..0000000 --- a/slatec/xerdmp.f +++ /dev/null @@ -1,29 +0,0 @@ -*DECK XERDMP - SUBROUTINE XERDMP -C***BEGIN PROLOGUE XERDMP -C***PURPOSE Print the error tables and then clear them. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XERDMP-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C XERDMP prints the error tables, then clears them. -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 XERSVE -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 900510 Changed call of XERSAV to XERSVE. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERDMP -C***FIRST EXECUTABLE STATEMENT XERDMP - CALL XERSVE (' ',' ',' ',0,0,0,KOUNT) - RETURN - END diff --git a/slatec/xerhlt.f b/slatec/xerhlt.f deleted file mode 100644 index 89b2a77..0000000 --- a/slatec/xerhlt.f +++ /dev/null @@ -1,39 +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 - STOP - END diff --git a/slatec/xermax.f b/slatec/xermax.f deleted file mode 100644 index 15920a2..0000000 --- a/slatec/xermax.f +++ /dev/null @@ -1,39 +0,0 @@ -*DECK XERMAX - SUBROUTINE XERMAX (MAX) -C***BEGIN PROLOGUE XERMAX -C***PURPOSE Set maximum number of times any error message is to be -C printed. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XERMAX-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C XERMAX sets the maximum number of times any message -C is to be printed. That is, non-fatal messages are -C not to be printed after they have occurred MAX times. -C Such non-fatal messages may be printed less than -C MAX times even if they occur MAX times, if error -C suppression mode (KONTRL=0) is ever in effect. -C -C Description of Parameter -C --Input-- -C MAX - the maximum number of times any one message -C is to be printed. -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 XERMAX -C***FIRST EXECUTABLE STATEMENT XERMAX - JUNK = J4SAVE(4,MAX,.TRUE.) - RETURN - END diff --git a/slatec/xermsg.f b/slatec/xermsg.f deleted file mode 100644 index 46c83ec..0000000 --- a/slatec/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/slatec/xerprn.f b/slatec/xerprn.f deleted file mode 100644 index 97eedf4..0000000 --- a/slatec/xerprn.f +++ /dev/null @@ -1,228 +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) = ' ' - DO 40 I=1,NUNIT - WRITE(IU(I), '(A)') CBUFF(1:LPREF+1) - 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 - DO 60 I=1,NUNIT - WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE) - 60 CONTINUE -C - IF (NEXTC .LE. LENMSG) GO TO 50 - RETURN - END diff --git a/slatec/xerror.f b/slatec/xerror.f deleted file mode 100644 index baa5506..0000000 --- a/slatec/xerror.f +++ /dev/null @@ -1,22 +0,0 @@ - SUBROUTINE XERROR(MESS,NMESS,L1,L2) -C -C THIS IS A DUMMY XERROR ROUTINE TO PRINT ERROR MESSAGES WITH NMESS -C CHARACTERS. L1 AND L2 ARE DUMMY PARAMETERS TO MAKE THIS CALL -C COMPATIBLE WITH THE SLATEC XERROR ROUTINE. THIS IS A FORTRAN 77 -C ROUTINE. -C - CHARACTER*(*) MESS - NN=NMESS/70 - NR=NMESS-70*NN - IF(NR.NE.0) NN=NN+1 - K=1 - PRINT 900 - 900 FORMAT(/) - DO 10 I=1,NN - KMIN=MIN0(K+69,NMESS) - PRINT *, MESS(K:KMIN) - K=K+70 - 10 CONTINUE - PRINT 900 - RETURN - END diff --git a/slatec/xersve.f b/slatec/xersve.f deleted file mode 100644 index 6bd2a4f..0000000 --- a/slatec/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/slatec/xgetf.f b/slatec/xgetf.f deleted file mode 100644 index da2d7f2..0000000 --- a/slatec/xgetf.f +++ /dev/null @@ -1,30 +0,0 @@ -*DECK XGETF - SUBROUTINE XGETF (KONTRL) -C***BEGIN PROLOGUE XGETF -C***PURPOSE Return the current value of the error control flag. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XGETF-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C XGETF returns the current value of the error control flag -C in KONTRL. See subroutine XSETF for flag value meanings. -C (KONTRL is an output parameter only.) -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 XGETF -C***FIRST EXECUTABLE STATEMENT XGETF - KONTRL = J4SAVE(2,0,.FALSE.) - RETURN - END diff --git a/slatec/xgetua.f b/slatec/xgetua.f deleted file mode 100644 index 2e7db02..0000000 --- a/slatec/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 diff --git a/slatec/xgetun.f b/slatec/xgetun.f deleted file mode 100644 index 1b4ac36..0000000 --- a/slatec/xgetun.f +++ /dev/null @@ -1,38 +0,0 @@ -*DECK XGETUN - SUBROUTINE XGETUN (IUNIT) -C***BEGIN PROLOGUE XGETUN -C***PURPOSE Return the (first) output file to which error messages -C are being sent. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XGETUN-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C XGETUN gets the (first) output file to which error messages -C are being sent. To find out if more than one file is being -C used, one must use the XGETUA routine. -C -C Description of Parameter -C --Output-- -C IUNIT - the logical unit number of the (first) unit to -C which error messages are being sent. -C A value of zero means that the default file, as -C defined by the I1MACH routine, is being used. -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 XGETUN -C***FIRST EXECUTABLE STATEMENT XGETUN - IUNIT = J4SAVE(3,0,.FALSE.) - RETURN - END diff --git a/slatec/xlegf.f b/slatec/xlegf.f deleted file mode 100644 index e000f87..0000000 --- a/slatec/xlegf.f +++ /dev/null @@ -1,228 +0,0 @@ -*DECK XLEGF - SUBROUTINE XLEGF (DNU1, NUDIFF, MU1, MU2, THETA, ID, PQA, IPQA, - 1 IERROR) -C***BEGIN PROLOGUE XLEGF -C***PURPOSE Compute normalized Legendre polynomials and associated -C Legendre functions. -C***LIBRARY SLATEC -C***CATEGORY C3A2, C9 -C***TYPE SINGLE PRECISION (XLEGF-S, DXLEGF-D) -C***KEYWORDS LEGENDRE FUNCTIONS -C***AUTHOR Smith, John M., (NBS and George Mason University) -C***DESCRIPTION -C -C XLEGF: Extended-range Single-precision Legendre Functions -C -C A feature of the XLEGF subroutine for Legendre functions is -C the use of extended-range arithmetic, a software extension of -C ordinary floating-point arithmetic that greatly increases the -C exponent range of the representable numbers. This avoids the -C need for scaling the solutions to lie within the exponent range -C of the most restrictive manufacturer's hardware. The increased -C exponent range is achieved by allocating an integer storage -C location together with each floating-point storage location. -C -C The interpretation of the pair (X,I) where X is floating-point -C and I is integer is X*(IR**I) where IR is the internal radix of -C the computer arithmetic. -C -C This subroutine computes one of the following vectors: -C -C 1. Legendre function of the first kind of negative order, either -C a. P(-MU1,NU,X), P(-MU1-1,NU,X), ..., P(-MU2,NU,X) or -C b. P(-MU,NU1,X), P(-MU,NU1+1,X), ..., P(-MU,NU2,X) -C 2. Legendre function of the second kind, either -C a. Q(MU1,NU,X), Q(MU1+1,NU,X), ..., Q(MU2,NU,X) or -C b. Q(MU,NU1,X), Q(MU,NU1+1,X), ..., Q(MU,NU2,X) -C 3. Legendre function of the first kind of positive order, either -C a. P(MU1,NU,X), P(MU1+1,NU,X), ..., P(MU2,NU,X) or -C b. P(MU,NU1,X), P(MU,NU1+1,X), ..., P(MU,NU2,X) -C 4. Normalized Legendre polynomials, either -C a. PN(MU1,NU,X), PN(MU1+1,NU,X), ..., PN(MU2,NU,X) or -C b. PN(MU,NU1,X), PN(MU,NU1+1,X), ..., PN(MU,NU2,X) -C -C where X = COS(THETA). -C -C The input values to XLEGF are DNU1, NUDIFF, MU1, MU2, THETA, -C and ID. These must satisfy -C -C DNU1 is REAL and greater than or equal to -0.5; -C NUDIFF is INTEGER and non-negative; -C MU1 is INTEGER and non-negative; -C MU2 is INTEGER and greater than or equal to MU1; -C THETA is REAL and in the half-open interval (0,PI/2]; -C ID is INTEGER and equal to 1, 2, 3 or 4; -C -C and additionally either NUDIFF = 0 or MU2 = MU1. -C -C If ID=1 and NUDIFF=0, a vector of type 1a above is computed -C with NU=DNU1. -C -C If ID=1 and MU1=MU2, a vector of type 1b above is computed -C with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. -C -C If ID=2 and NUDIFF=0, a vector of type 2a above is computed -C with NU=DNU1. -C -C If ID=2 and MU1=MU2, a vector of type 2b above is computed -C with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. -C -C If ID=3 and NUDIFF=0, a vector of type 3a above is computed -C with NU=DNU1. -C -C If ID=3 and MU1=MU2, a vector of type 3b above is computed -C with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. -C -C If ID=4 and NUDIFF=0, a vector of type 4a above is computed -C with NU=DNU1. -C -C If ID=4 and MU1=MU2, a vector of type 4b above is computed -C with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. -C -C In each case the vector of computed Legendre function values -C is returned in the extended-range vector (PQA(I),IPQA(I)). The -C length of this vector is either MU2-MU1+1 or NUDIFF+1. -C -C Where possible, XLEGF returns IPQA(I) as zero. In this case the -C value of the Legendre function is contained entirely in PQA(I), -C so it can be used in subsequent computations without further -C consideration of extended-range arithmetic. If IPQA(I) is nonzero, -C then the value of the Legendre function is not representable in -C floating-point because of underflow or overflow. The program that -C calls XLEGF must test IPQA(I) to ensure correct usage. -C -C IERROR is an error indicator. If no errors are detected, IERROR=0 -C when control returns to the calling routine. If an error is detected, -C IERROR is returned as nonzero. The calling routine must check the -C value of IERROR. -C -C If IERROR=110 or 111, invalid input was provided to XLEGF. -C If IERROR=101,102,103, or 104, invalid input was provided to XSET. -C If IERROR=105 or 106, an internal consistency error occurred in -C XSET (probably due to a software malfunction in the library routine -C I1MACH). -C If IERROR=107, an overflow or underflow of an extended-range number -C was detected in XADJ. -C If IERROR=108, an overflow or underflow of an extended-range number -C was detected in XC210. -C -C***SEE ALSO XSET -C***REFERENCES Olver and Smith, Associated Legendre Functions on the -C Cut, J Comp Phys, v 51, n 3, Sept 1983, pp 502--518. -C Smith, Olver and Lozier, Extended-Range Arithmetic and -C Normalized Legendre Polynomials, ACM Trans on Math -C Softw, v 7, n 1, March 1981, pp 93--105. -C***ROUTINES CALLED XERMSG, XPMU, XPMUP, XPNRM, XPQNU, XQMU, XQNU, -C XRED, XSET -C***REVISION HISTORY (YYMMDD) -C 820728 DATE WRITTEN -C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Changed all specific intrinsics to generic. (WRB) -C Corrected order of sections in prologue and added TYPE -C section. (WRB) -C CALLs to XERROR changed to CALLs to XERMSG. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE XLEGF - REAL PQA,DNU1,DNU2,SX,THETA,X,PI2 - DIMENSION PQA(*),IPQA(*) -C -C***FIRST EXECUTABLE STATEMENT XLEGF - IERROR=0 - CALL XSET (0, 0, 0.0, 0,IERROR) - IF (IERROR.NE.0) RETURN - PI2=2.*ATAN(1.) -C -C ZERO OUTPUT ARRAYS -C - L=(MU2-MU1)+NUDIFF+1 - DO 290 I=1,L - PQA(I)=0. - 290 IPQA(I)=0 -C -C CHECK FOR VALID INPUT VALUES -C - IF(NUDIFF.LT.0) GO TO 400 - IF(DNU1.LT.-.5) GO TO 400 - IF(MU2.LT.MU1) GO TO 400 - IF(MU1.LT.0) GO TO 400 - IF(THETA.LE.0..OR.THETA.GT.PI2) GO TO 420 - IF(ID.LT.1.OR.ID.GT.4) GO TO 400 - IF((MU1.NE.MU2).AND.(NUDIFF.GT.0)) GO TO 400 -C -C IF DNU1 IS NOT AN INTEGER, NORMALIZED P(MU,DNU,X) -C CANNOT BE CALCULATED. IF DNU1 IS AN INTEGER AND -C MU1.GT.DNU2 THEN ALL VALUES OF P(+MU,DNU,X) AND -C NORMALIZED P(MU,NU,X) WILL BE ZERO. -C - DNU2=DNU1+NUDIFF - IF((ID.EQ.3).AND.(MOD(DNU1,1.).NE.0.)) GO TO 295 - IF((ID.EQ.4).AND.(MOD(DNU1,1.).NE.0.)) GO TO 400 - IF((ID.EQ.3.OR.ID.EQ.4).AND.MU1.GT.DNU2) RETURN - 295 CONTINUE -C - X=COS(THETA) - SX=1./SIN(THETA) - IF(ID.EQ.2) GO TO 300 - IF(MU2-MU1.LE.0) GO TO 360 -C -C FIXED NU, VARIABLE MU -C CALL XPMU TO CALCULATE P(-MU1,NU,X),....,P(-MU2,NU,X) -C - CALL XPMU(DNU1,DNU2,MU1,MU2,THETA,X,SX,ID,PQA,IPQA,IERROR) - IF (IERROR.NE.0) RETURN - GO TO 380 -C - 300 IF(MU2.EQ.MU1) GO TO 320 -C -C FIXED NU, VARIABLE MU -C CALL XQMU TO CALCULATE Q(MU1,NU,X),....,Q(MU2,NU,X) -C - CALL XQMU(DNU1,DNU2,MU1,MU2,THETA,X,SX,ID,PQA,IPQA,IERROR) - IF (IERROR.NE.0) RETURN - GO TO 390 -C -C FIXED MU, VARIABLE NU -C CALL XQNU TO CALCULATE Q(MU,DNU1,X),....,Q(MU,DNU2,X) -C - 320 CALL XQNU(DNU1,DNU2,MU1,THETA,X,SX,ID,PQA,IPQA,IERROR) - IF (IERROR.NE.0) RETURN - GO TO 390 -C -C FIXED MU, VARIABLE NU -C CALL XPQNU TO CALCULATE P(-MU,DNU1,X),....,P(-MU,DNU2,X) -C - 360 CALL XPQNU(DNU1,DNU2,MU1,THETA,ID,PQA,IPQA,IERROR) - IF (IERROR.NE.0) RETURN -C -C IF ID = 3, TRANSFORM P(-MU,NU,X) VECTOR INTO -C P(MU,NU,X) VECTOR. -C - 380 IF(ID.EQ.3) CALL XPMUP(DNU1,DNU2,MU1,MU2,PQA,IPQA,IERROR) - IF (IERROR.NE.0) RETURN -C -C IF ID = 4, TRANSFORM P(-MU,NU,X) VECTOR INTO -C NORMALIZED P(MU,NU,X) VECTOR. -C - IF(ID.EQ.4) CALL XPNRM(DNU1,DNU2,MU1,MU2,PQA,IPQA,IERROR) - IF (IERROR.NE.0) RETURN -C -C PLACE RESULTS IN REDUCED FORM IF POSSIBLE -C AND RETURN TO MAIN PROGRAM. -C - 390 DO 395 I=1,L - CALL XRED(PQA(I),IPQA(I),IERROR) - IF (IERROR.NE.0) RETURN - 395 CONTINUE - RETURN -C -C ***** ERROR TERMINATION ***** -C - 400 CALL XERMSG ('SLATEC', 'XLEGF', - + 'DNU1, NUDIFF, MU1, MU2, or ID not valid', 110, 1) - IERROR=110 - RETURN - 420 CALL XERMSG ('SLATEC', 'XLEGF', 'THETA out of range', 111, 1) - IERROR=111 - RETURN - END diff --git a/slatec/xnrmp.f b/slatec/xnrmp.f deleted file mode 100644 index 9f9c10f..0000000 --- a/slatec/xnrmp.f +++ /dev/null @@ -1,269 +0,0 @@ -*DECK XNRMP - SUBROUTINE XNRMP (NU, MU1, MU2, SARG, MODE, SPN, IPN, ISIG, - 1 IERROR) -C***BEGIN PROLOGUE XNRMP -C***PURPOSE Compute normalized Legendre polynomials. -C***LIBRARY SLATEC -C***CATEGORY C3A2, C9 -C***TYPE SINGLE PRECISION (XNRMP-S, DXNRMP-D) -C***KEYWORDS LEGENDRE FUNCTIONS -C***AUTHOR Lozier, Daniel W., (National Bureau of Standards) -C Smith, John M., (NBS and George Mason University) -C***DESCRIPTION -C -C SUBROUTINE TO CALCULATE NORMALIZED LEGENDRE POLYNOMIALS -C (DXNRMP is double-precision version) -C XNRMP calculates normalized Legendre polynomials of varying -C order and fixed argument and degree. The order MU and degree -C NU are non-negative integers and the argument is real. Because -C the algorithm requires the use of numbers outside the normal -C machine range, this subroutine employs a special arithmetic -C called extended-range arithmetic. See J.M. Smith, F.W.J. Olver, -C and D.W. Lozier, Extended-Range Arithmetic and Normalized -C Legendre Polynomials, ACM Transactions on Mathematical Soft- -C ware, 93-105, March 1981, for a complete description of the -C algorithm and special arithmetic. Also see program comments -C in XSET. -C -C The normalized Legendre polynomials are multiples of the -C associated Legendre polynomials of the first kind where the -C normalizing coefficients are chosen so as to make the integral -C from -1 to 1 of the square of each function equal to 1. See -C E. Jahnke, F. Emde and F. Losch, Tables of Higher Functions, -C McGraw-Hill, New York, 1960, p. 121. -C -C The input values to XNRMP are NU, MU1, MU2, SARG, and MODE. -C These must satisfy -C 1. NU .GE. 0 specifies the degree of the normalized Legendre -C polynomial that is wanted. -C 2. MU1 .GE. 0 specifies the lowest-order normalized Legendre -C polynomial that is wanted. -C 3. MU2 .GE. MU1 specifies the highest-order normalized Leg- -C endre polynomial that is wanted. -C 4a. MODE = 1 and -1.0 .LE. SARG .LE. 1.0 specifies that -C Normalized Legendre(NU, MU, SARG) is wanted for MU = MU1, -C MU1 + 1, ..., MU2. -C 4b. MODE = 2 and -3.14159... .LT. SARG .LT. 3.14159... spec- -C ifies that Normalized Legendre(NU, MU, COS(SARG)) is want- -C ed for MU = MU1, MU1 + 1, ..., MU2. -C -C The output of XNRMP consists of the two vectors SPN and IPN -C and the error estimate ISIG. The computed values are stored as -C extended-range numbers such that -C (SPN(1),IPN(1))=NORMALIZED LEGENDRE(NU,MU1,X) -C (SPN(2),IPN(2))=NORMALIZED LEGENDRE(NU,MU1+1,X) -C . -C . -C (SPN(K),IPN(K))=NORMALIZED LEGENDRE(NU,MU2,X) -C where K = MU2 - MU1 + 1 and X = SARG or COS(SARG) according -C to whether MODE = 1 or 2. Finally, ISIG is an estimate of the -C number of decimal digits lost through rounding errors in the -C computation. For example if SARG is accurate to 12 significant -C decimals, then the computed function values are accurate to -C 12 - ISIG significant decimals (except in neighborhoods of -C zeros). -C -C The interpretation of (SPN(I),IPN(I)) is SPN(I)*(IR**IPN(I)) -C where IR is the internal radix of the computer arithmetic. When -C IPN(I) = 0 the value of the normalized Legendre polynomial is -C contained entirely in SPN(I) and subsequent single-precision -C computations can be performed without further consideration of -C extended-range arithmetic. However, if IPN(I) .NE. 0 the corre- -C sponding value of the normalized Legendre polynomial cannot be -C represented in single-precision because of overflow or under- -C flow. THE USER MUST TEST IPN(I) IN HIS/HER PROGRAM. In the case -C that IPN(I) is nonzero, the user should try using double pre- -C cision if it has a wider exponent range. If double precision -C fails, the user could rewrite his/her program to use extended- -C range arithmetic. -C -C The interpretation of (SPN(I),IPN(I)) can be changed to -C SPN(I)*(10**IPN(I)) by calling the extended-range subroutine -C XCON. This should be done before printing the computed values. -C As an example of usage, the Fortran coding -C J = K -C DO 20 I = 1, K -C CALL XCON(SPN(I), IPN(I),IERROR) -C IF (IERROR.NE.0) RETURN -C PRINT 10, SPN(I), IPN(I) -C 10 FORMAT(1X, E30.8 , I15) -C IF ((IPN(I) .EQ. 0) .OR. (J .LT. K)) GO TO 20 -C J = I - 1 -C 20 CONTINUE -C will print all computed values and determine the largest J -C such that IPN(1) = IPN(2) = ... = IPN(J) = 0. Because of the -C change of representation caused by calling XCON, (SPN(I), -C IPN(I)) for I = J+1, J+2, ... cannot be used in subsequent -C extended-range computations. -C -C IERROR is an error indicator. If no errors are detected, -C IERROR=0 when control returns to the calling routine. If -C an error is detected, IERROR is returned as nonzero. The -C calling routine must check the value of IERROR. -C -C If IERROR=112 or 113, invalid input was provided to XNRMP. -C If IERROR=101,102,103, or 104, invalid input was provided -C to XSET. -C If IERROR=105 or 106, an internal consistency error occurred -C in XSET (probably due to a software malfunction in the -C library routine I1MACH). -C If IERROR=107, an overflow or underflow of an extended-range -C number was detected in XADJ. -C If IERROR=108, an overflow or underflow of an extended-range -C number was detected in XC210. -C -C***SEE ALSO XSET -C***REFERENCES Smith, Olver and Lozier, Extended-Range Arithmetic and -C Normalized Legendre Polynomials, ACM Trans on Math -C Softw, v 7, n 1, March 1981, pp 93--105. -C***ROUTINES CALLED XADD, XADJ, XERMSG, XRED, XSET -C***REVISION HISTORY (YYMMDD) -C 820712 DATE WRITTEN -C 881020 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Changed all specific intrinsics to generic. (WRB) -C Corrected order of sections in prologue and added TYPE -C section. (WRB) -C CALLs to XERROR changed to CALLs to XERMSG. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE XNRMP - INTEGER NU, MU1, MU2, MODE, IPN, ISIG - REAL SARG, SPN - DIMENSION SPN(*), IPN(*) - REAL C1,C2,P,P1,P2,P3,S,SX,T,TX,X,RK -C CALL XSET TO INITIALIZE EXTENDED-RANGE ARITHMETIC (SEE XSET -C LISTING FOR DETAILS) -C***FIRST EXECUTABLE STATEMENT XNRMP - IERROR=0 - CALL XSET (0, 0, 0.0, 0,IERROR) - IF (IERROR.NE.0) RETURN -C -C TEST FOR PROPER INPUT VALUES. -C - IF (NU.LT.0) GO TO 110 - IF (MU1.LT.0) GO TO 110 - IF (MU1.GT.MU2) GO TO 110 - IF (NU.EQ.0) GO TO 90 - IF (MODE.LT.1 .OR. MODE.GT.2) GO TO 110 - GO TO (10, 20), MODE - 10 IF (ABS(SARG).GT.1.0) GO TO 120 - IF (ABS(SARG).EQ.1.0) GO TO 90 - X = SARG - SX = SQRT((1.0+ABS(X))*((0.5-ABS(X))+0.5)) - TX = X/SX - ISIG = LOG10(2.0*NU*(5.0+TX**2)) - GO TO 30 - 20 IF (ABS(SARG).GT.4.0*ATAN(1.0)) GO TO 120 - IF (SARG.EQ.0.0) GO TO 90 - X = COS(SARG) - SX = ABS(SIN(SARG)) - TX = X/SX - ISIG = LOG10(2.0*NU*(5.0+ABS(SARG*TX))) -C -C BEGIN CALCULATION -C - 30 MU = MU2 - I = MU2 - MU1 + 1 -C -C IF MU.GT.NU, NORMALIZED LEGENDRE(NU,MU,X)=0. -C - 40 IF (MU.LE.NU) GO TO 50 - SPN(I) = 0.0 - IPN(I) = 0 - I = I - 1 - MU = MU - 1 - IF (I .GT. 0) GO TO 40 - ISIG = 0 - GO TO 160 - 50 MU = NU -C -C P1 = 0. = NORMALIZED LEGENDRE(NU,NU+1,X) -C - P1 = 0.0 - IP1 = 0 -C -C CALCULATE P2 = NORMALIZED LEGENDRE(NU,NU,X) -C - P2 = 1.0 - IP2 = 0 - P3 = 0.5 - RK = 2.0 - DO 60 J=1,NU - P3 = ((RK+1.0)/RK)*P3 - P2 = P2*SX - CALL XADJ(P2, IP2,IERROR) - IF (IERROR.NE.0) RETURN - RK = RK + 2.0 - 60 CONTINUE - P2 = P2*SQRT(P3) - CALL XADJ(P2, IP2,IERROR) - IF (IERROR.NE.0) RETURN - S = 2.0*TX - T = 1.0/NU - IF (MU2.LT.NU) GO TO 70 - SPN(I) = P2 - IPN(I) = IP2 - I = I - 1 - IF (I .EQ. 0) GO TO 140 -C -C RECURRENCE PROCESS -C - 70 P = MU*T - C1 = 1.0/SQRT((1.0-P+T)*(1.0+P)) - C2 = S*P*C1*P2 - C1 = -SQRT((1.0+P+T)*(1.0-P))*C1*P1 - CALL XADD(C2, IP2, C1, IP1, P, IP,IERROR) - IF (IERROR.NE.0) RETURN - MU = MU - 1 - IF (MU.GT.MU2) GO TO 80 -C -C STORE IN ARRAY SPN FOR RETURN TO CALLING ROUTINE. -C - SPN(I) = P - IPN(I) = IP - I = I - 1 - IF (I .EQ. 0) GO TO 140 - 80 P1 = P2 - IP1 = IP2 - P2 = P - IP2 = IP - IF (MU.LE.MU1) GO TO 140 - GO TO 70 -C -C SPECIAL CASE WHEN X=-1 OR +1, OR NU=0. -C - 90 K = MU2 - MU1 + 1 - DO 100 I=1,K - SPN(I) = 0.0 - IPN(I) = 0 - 100 CONTINUE - ISIG = 0 - IF (MU1.GT.0) GO TO 160 - ISIG = 1 - SPN(1) = SQRT(NU+0.5) - IPN(1) = 0 - IF (MOD(NU,2).EQ.0) GO TO 160 - IF (MODE.EQ.1 .AND. SARG.EQ.1.0) GO TO 160 - IF (MODE.EQ.2) GO TO 160 - SPN(1) = -SPN(1) - GO TO 160 -C -C ERROR PRINTOUTS AND TERMINATION. -C - 110 CALL XERMSG ('SLATEC', 'XNRMP', 'NU, MU1, MU2 or MODE not valid', - + 112, 1) - IERROR=112 - RETURN - 120 CALL XERMSG ('SLATEC', 'XNRMP', 'SARG out of range', 113, 1) - IERROR=113 - RETURN -C -C RETURN TO CALLING PROGRAM -C - 140 K = MU2 - MU1 + 1 - DO 150 I=1,K - CALL XRED(SPN(I),IPN(I),IERROR) - IF (IERROR.NE.0) RETURN - 150 CONTINUE - 160 RETURN - END diff --git a/slatec/xpmu.f b/slatec/xpmu.f deleted file mode 100644 index d0ef087..0000000 --- a/slatec/xpmu.f +++ /dev/null @@ -1,69 +0,0 @@ -*DECK XPMU - SUBROUTINE XPMU (NU1, NU2, MU1, MU2, THETA, X, SX, ID, PQA, IPQA, - 1 IERROR) -C***BEGIN PROLOGUE XPMU -C***SUBSIDIARY -C***PURPOSE To compute the values of Legendre functions for XLEGF. -C Method: backward mu-wise recurrence for P(-MU,NU,X) for -C fixed nu to obtain P(-MU2,NU1,X), P(-(MU2-1),NU1,X), ..., -C P(-MU1,NU1,X) and store in ascending mu order. -C***LIBRARY SLATEC -C***CATEGORY C3A2, C9 -C***TYPE SINGLE PRECISION (XPMU-S, DXPMU-D) -C***KEYWORDS LEGENDRE FUNCTIONS -C***AUTHOR Smith, John M., (NBS and George Mason University) -C***ROUTINES CALLED XADD, XADJ, XPQNU -C***REVISION HISTORY (YYMMDD) -C 820728 DATE WRITTEN -C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Changed all specific intrinsics to generic. (WRB) -C Corrected order of sections in prologue and added TYPE -C section. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE XPMU - REAL PQA,NU1,NU2,P0,X,SX,THETA,X1,X2 - DIMENSION PQA(*),IPQA(*) -C -C CALL XPQNU TO OBTAIN P(-MU2,NU,X) -C -C***FIRST EXECUTABLE STATEMENT XPMU - IERROR=0 - CALL XPQNU(NU1,NU2,MU2,THETA,ID,PQA,IPQA,IERROR) - IF (IERROR.NE.0) RETURN - P0=PQA(1) - IP0=IPQA(1) - MU=MU2-1 -C -C CALL XPQNU TO OBTAIN P(-MU2-1,NU,X) -C - CALL XPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR) - IF (IERROR.NE.0) RETURN - N=MU2-MU1+1 - PQA(N)=P0 - IPQA(N)=IP0 - IF(N.EQ.1) GO TO 300 - PQA(N-1)=PQA(1) - IPQA(N-1)=IPQA(1) - IF(N.EQ.2) GO TO 300 - J=N-2 - 290 CONTINUE -C -C BACKWARD RECURRENCE IN MU TO OBTAIN -C P(-MU2,NU1,X),P(-(MU2-1),NU1,X),....P(-MU1,NU1,X) -C USING -C (NU-MU)*(NU+MU+1.)*P(-(MU+1),NU,X)= -C 2.*MU*X*SQRT((1./(1.-X**2))*P(-MU,NU,X)-P(-(MU-1),NU,X) -C - X1=2.*MU*X*SX*PQA(J+1) - X2=-(NU1-MU)*(NU1+MU+1.)*PQA(J+2) - CALL XADD(X1,IPQA(J+1),X2,IPQA(J+2),PQA(J),IPQA(J),IERROR) - IF (IERROR.NE.0) RETURN - CALL XADJ(PQA(J),IPQA(J),IERROR) - IF (IERROR.NE.0) RETURN - IF(J.EQ.1) GO TO 300 - J=J-1 - MU=MU-1 - GO TO 290 - 300 RETURN - END diff --git a/slatec/xpmup.f b/slatec/xpmup.f deleted file mode 100644 index 60f19a3..0000000 --- a/slatec/xpmup.f +++ /dev/null @@ -1,76 +0,0 @@ -*DECK XPMUP - SUBROUTINE XPMUP (NU1, NU2, MU1, MU2, PQA, IPQA, IERROR) -C***BEGIN PROLOGUE XPMUP -C***SUBSIDIARY -C***PURPOSE To compute the values of Legendre functions for XLEGF. -C This subroutine transforms an array of Legendre functions -C of the first kind of negative order stored in array PQA -C into Legendre functions of the first kind of positive -C order stored in array PQA. The original array is destroyed. -C***LIBRARY SLATEC -C***CATEGORY C3A2, C9 -C***TYPE SINGLE PRECISION (XPMUP-S, DXPMUP-D) -C***KEYWORDS LEGENDRE FUNCTIONS -C***AUTHOR Smith, John M., (NBS and George Mason University) -C***ROUTINES CALLED XADJ -C***REVISION HISTORY (YYMMDD) -C 820728 DATE WRITTEN -C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Changed all specific intrinsics to generic. (WRB) -C Corrected order of sections in prologue and added TYPE -C section. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE XPMUP - REAL DMU,NU,NU1,NU2,PQA,PROD - DIMENSION PQA(*),IPQA(*) -C***FIRST EXECUTABLE STATEMENT XPMUP - IERROR=0 - NU=NU1 - MU=MU1 - DMU=MU - N=INT(NU2-NU1+.1)+(MU2-MU1)+1 - J=1 - IF(MOD(NU,1.).NE.0.) GO TO 210 - 200 IF(DMU.LT.NU+1.) GO TO 210 - PQA(J)=0. - IPQA(J)=0 - J=J+1 - IF(J.GT.N) RETURN -C INCREMENT EITHER MU OR NU AS APPROPRIATE. - IF(NU2-NU1.GT..5) NU=NU+1. - IF(MU2.GT.MU1) MU=MU+1 - GO TO 200 -C -C TRANSFORM P(-MU,NU,X) TO P(MU,NU,X) USING -C P(MU,NU,X)=(NU-MU+1)*(NU-MU+2)*...*(NU+MU)*P(-MU,NU,X)*(-1)**MU -C - 210 PROD=1. - IPROD=0 - K=2*MU - IF(K.EQ.0) GO TO 222 - DO 220 L=1,K - PROD=PROD*(DMU-NU-L) - 220 CALL XADJ(PROD,IPROD,IERROR) - IF (IERROR.NE.0) RETURN - 222 CONTINUE - DO 240 I=J,N - IF(MU.EQ.0) GO TO 225 - PQA(I)=PQA(I)*PROD*(-1)**MU - IPQA(I)=IPQA(I)+IPROD - CALL XADJ(PQA(I),IPQA(I),IERROR) - IF (IERROR.NE.0) RETURN - 225 IF(NU2-NU1.GT..5) GO TO 230 - PROD=(DMU-NU)*PROD*(-DMU-NU-1.) - CALL XADJ(PROD,IPROD,IERROR) - IF (IERROR.NE.0) RETURN - MU=MU+1 - DMU=DMU+1. - GO TO 240 - 230 PROD=PROD*(-DMU-NU-1.)/(DMU-NU-1.) - CALL XADJ(PROD,IPROD,IERROR) - IF (IERROR.NE.0) RETURN - NU=NU+1. - 240 CONTINUE - RETURN - END diff --git a/slatec/xpnrm.f b/slatec/xpnrm.f deleted file mode 100644 index 774e919..0000000 --- a/slatec/xpnrm.f +++ /dev/null @@ -1,89 +0,0 @@ -*DECK XPNRM - SUBROUTINE XPNRM (NU1, NU2, MU1, MU2, PQA, IPQA, IERROR) -C***BEGIN PROLOGUE XPNRM -C***SUBSIDIARY -C***PURPOSE To compute the values of Legendre functions for XLEGF. -C This subroutine transforms an array of Legendre functions -C of the first kind of negative order stored in array PQA -C into normalized Legendre polynomials stored in array PQA. -C The original array is destroyed. -C***LIBRARY SLATEC -C***CATEGORY C3A2, C9 -C***TYPE SINGLE PRECISION (XPNRM-S, DXPNRM-D) -C***KEYWORDS LEGENDRE FUNCTIONS -C***AUTHOR Smith, John M., (NBS and George Mason University) -C***ROUTINES CALLED XADJ -C***REVISION HISTORY (YYMMDD) -C 820728 DATE WRITTEN -C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Changed all specific intrinsics to generic. (WRB) -C Corrected order of sections in prologue and added TYPE -C section. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE XPNRM - REAL C1,DMU,NU,NU1,NU2,PQA,PROD - DIMENSION PQA(*),IPQA(*) -C***FIRST EXECUTABLE STATEMENT XPNRM - IERROR=0 - L=(MU2-MU1)+(NU2-NU1+1.5) - MU=MU1 - DMU=MU1 - NU=NU1 -C -C IF MU .GT.NU, NORM P =0. -C - J=1 - 500 IF(DMU.LE.NU) GO TO 505 - PQA(J)=0. - IPQA(J)=0 - J=J+1 - IF(J.GT.L) RETURN -C -C INCREMENT EITHER MU OR NU AS APPROPRIATE. -C - IF(MU2.GT.MU1) DMU=DMU+1. - IF(NU2-NU1.GT..5) NU=NU+1. - GO TO 500 -C -C TRANSFORM P(-MU,NU,X) INTO NORMALIZED P(MU,NU,X) USING -C NORM P(MU,NU,X)= -C SQRT((NU+.5)*FACTORIAL(NU+MU)/FACTORIAL(NU-MU)) -C *P(-MU,NU,X) -C - 505 PROD=1. - IPROD=0 - K=2*MU - IF(K.LE.0) GO TO 520 - DO 510 I=1,K - PROD=PROD*SQRT(NU+DMU+1.-I) - 510 CALL XADJ(PROD,IPROD,IERROR) - IF (IERROR.NE.0) RETURN - 520 DO 540 I=J,L - C1=PROD*SQRT(NU+.5) - PQA(I)=PQA(I)*C1 - IPQA(I)=IPQA(I)+IPROD - CALL XADJ(PQA(I),IPQA(I),IERROR) - IF (IERROR.NE.0) RETURN - IF(NU2-NU1.GT..5) GO TO 530 - IF(DMU.GE.NU) GO TO 525 - PROD=SQRT(NU+DMU+1.)*PROD - IF(NU.GT.DMU) PROD=PROD*SQRT(NU-DMU) - CALL XADJ(PROD,IPROD,IERROR) - IF (IERROR.NE.0) RETURN - MU=MU+1 - DMU=DMU+1. - GO TO 540 - 525 PROD=0. - IPROD=0 - MU=MU+1 - DMU=DMU+1. - GO TO 540 - 530 PROD=SQRT(NU+DMU+1.)*PROD - IF(NU.NE.DMU-1.) PROD=PROD/SQRT(NU-DMU+1.) - CALL XADJ(PROD,IPROD,IERROR) - IF (IERROR.NE.0) RETURN - NU=NU+1. - 540 CONTINUE - RETURN - END diff --git a/slatec/xpqnu.f b/slatec/xpqnu.f deleted file mode 100644 index 1adb73d..0000000 --- a/slatec/xpqnu.f +++ /dev/null @@ -1,193 +0,0 @@ -*DECK XPQNU - SUBROUTINE XPQNU (NU1, NU2, MU, THETA, ID, PQA, IPQA, IERROR) -C***BEGIN PROLOGUE XPQNU -C***SUBSIDIARY -C***PURPOSE To compute the values of Legendre functions for XLEGF. -C This subroutine calculates initial values of P or Q using -C power series, then performs forward nu-wise recurrence to -C obtain P(-MU,NU,X), Q(0,NU,X), or Q(1,NU,X). The nu-wise -C recurrence is stable for P for all mu and for Q for mu=0,1. -C***LIBRARY SLATEC -C***CATEGORY C3A2, C9 -C***TYPE SINGLE PRECISION (XPQNU-S, DXPQNU-D) -C***KEYWORDS LEGENDRE FUNCTIONS -C***AUTHOR Smith, John M., (NBS and George Mason University) -C***ROUTINES CALLED XADD, XADJ, XPSI -C***COMMON BLOCKS XBLK1 -C***REVISION HISTORY (YYMMDD) -C 820728 DATE WRITTEN -C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Changed all specific intrinsics to generic. (WRB) -C Corrected order of sections in prologue and added TYPE -C section. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE XPQNU - REAL A,NU,NU1,NU2,PQ,PQA,XPSI,R,THETA,W,X,X1,X2,XS, - 1 Y,Z - REAL DI,DMU,PQ1,PQ2,FACTMU,FLOK - DIMENSION PQA(*),IPQA(*) - COMMON /XBLK1/ NBITSF - SAVE /XBLK1/ -C -C J0, IPSIK, AND IPSIX ARE INITIALIZED IN THIS SUBROUTINE. -C J0 IS THE NUMBER OF TERMS USED IN SERIES EXPANSION -C IN SUBROUTINE XPQNU. -C IPSIK, IPSIX ARE VALUES OF K AND X RESPECTIVELY -C USED IN THE CALCULATION OF THE XPSI FUNCTION. -C -C***FIRST EXECUTABLE STATEMENT XPQNU - IERROR=0 - J0=NBITSF - IPSIK=1+(NBITSF/10) - IPSIX=5*IPSIK - IPQ=0 -C FIND NU IN INTERVAL [-.5,.5) IF ID=2 ( CALCULATION OF Q ) - NU=MOD(NU1,1.) - IF(NU.GE..5) NU=NU-1. -C FIND NU IN INTERVAL (-1.5,-.5] IF ID=1,3, OR 4 ( CALC. OF P ) - IF(ID.NE.2.AND.NU.GT.-.5) NU=NU-1. -C CALCULATE MU FACTORIAL - K=MU - DMU=MU - IF(MU.LE.0) GO TO 60 - FACTMU=1. - IF=0 - DO 50 I=1,K - FACTMU=FACTMU*I - 50 CALL XADJ(FACTMU,IF,IERROR) - IF (IERROR.NE.0) RETURN - 60 IF(K.EQ.0) FACTMU=1. - IF(K.EQ.0) IF=0 -C -C X=COS(THETA) -C Y=SIN(THETA/2)**2=(1-X)/2=.5-.5*X -C R=TAN(THETA/2)=SQRT((1-X)/(1+X) -C - X=COS(THETA) - Y=SIN(THETA/2.)**2 - R=TAN(THETA/2.) -C -C USE ASCENDING SERIES TO CALCULATE TWO VALUES OF P OR Q -C FOR USE AS STARTING VALUES IN RECURRENCE RELATION. -C - PQ2=0.0 - DO 100 J=1,2 - IPQ1=0 - IF(ID.EQ.2) GO TO 80 -C -C SERIES FOR P ( ID = 1, 3, OR 4 ) -C P(-MU,NU,X)=1./FACTORIAL(MU)*SQRT(((1.-X)/(1.+X))**MU) -C *SUM(FROM 0 TO J0-1)A(J)*(.5-.5*X)**J -C - IPQ=0 - PQ=1. - A=1. - IA=0 - DO 65 I=2,J0 - DI=I - A=A*Y*(DI-2.-NU)*(DI-1.+NU)/((DI-1.+DMU)*(DI-1.)) - CALL XADJ(A,IA,IERROR) - IF (IERROR.NE.0) RETURN - IF(A.EQ.0.) GO TO 66 - CALL XADD(PQ,IPQ,A,IA,PQ,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - 65 CONTINUE - 66 CONTINUE - IF(MU.LE.0) GO TO 90 - X2=R - X1=PQ - K=MU - DO 77 I=1,K - X1=X1*X2 - 77 CALL XADJ(X1,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - PQ=X1/FACTMU - IPQ=IPQ-IF - CALL XADJ(PQ,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - GO TO 90 -C -C Z=-LN(R)=.5*LN((1+X)/(1-X)) -C - 80 Z=-LOG(R) - W=XPSI(NU+1.,IPSIK,IPSIX) - XS=1./SIN(THETA) -C -C SERIES SUMMATION FOR Q ( ID = 2 ) -C Q(0,NU,X)=SUM(FROM 0 TO J0-1)((.5*LN((1+X)/(1-X)) -C +XPSI(J+1,IPSIK,IPSIX)-XPSI(NU+1,IPSIK,IPSIX)))*A(J)*(.5-.5*X)**J -C -C Q(1,NU,X)=-SQRT(1./(1.-X**2))+SQRT((1-X)/(1+X)) -C *SUM(FROM 0 T0 J0-1)(-NU*(NU+1)/2*LN((1+X)/(1-X)) -C +(J-NU)*(J+NU+1)/(2*(J+1))+NU*(NU+1)* -C (XPSI(NU+1,IPSIK,IPSIX)-XPSI(J+1,IPSIK,IPSIX))*A(J)*(.5-.5*X)**J -C -C NOTE, IN THIS LOOP K=J+1 -C - PQ=0. - IPQ=0 - IA=0 - A=1. - DO 85 K=1,J0 - FLOK=K - IF(K.EQ.1) GO TO 81 - A=A*Y*(FLOK-2.-NU)*(FLOK-1.+NU)/((FLOK-1.+DMU)*(FLOK-1.)) - CALL XADJ(A,IA,IERROR) - IF (IERROR.NE.0) RETURN - 81 CONTINUE - IF(MU.GE.1) GO TO 83 - X1=(XPSI(FLOK,IPSIK,IPSIX)-W+Z)*A - IX1=IA - CALL XADD(PQ,IPQ,X1,IX1,PQ,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - GO TO 85 - 83 X1=(NU*(NU+1.)*(Z-W+XPSI(FLOK,IPSIK,IPSIX))+(NU-FLOK+1.) - 1 *(NU+FLOK)/(2.*FLOK))*A - IX1=IA - CALL XADD(PQ,IPQ,X1,IX1,PQ,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - 85 CONTINUE - IF(MU.GE.1) PQ=-R*PQ - IXS=0 - IF(MU.GE.1) CALL XADD(PQ,IPQ,-XS,IXS,PQ,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - IF(J.EQ.2) MU=-MU - IF(J.EQ.2) DMU=-DMU - 90 IF(J.EQ.1) PQ2=PQ - IF(J.EQ.1) IPQ2=IPQ - NU=NU+1. - 100 CONTINUE - K=0 - IF(NU-1.5.LT.NU1) GO TO 120 - K=K+1 - PQA(K)=PQ2 - IPQA(K)=IPQ2 - IF(NU.GT.NU2+.5) RETURN - 120 PQ1=PQ - IPQ1=IPQ - IF(NU.LT.NU1+.5) GO TO 130 - K=K+1 - PQA(K)=PQ - IPQA(K)=IPQ - IF(NU.GT.NU2+.5) RETURN -C -C FORWARD NU-WISE RECURRENCE FOR F(MU,NU,X) FOR FIXED MU -C USING -C (NU+MU+1)*F(MU,NU,X)=(2.*NU+1)*F(MU,NU,X)-(NU-MU)*F(MU,NU-1,X) -C WHERE F(MU,NU,X) MAY BE P(-MU,NU,X) OR IF MU IS REPLACED -C BY -MU THEN F(MU,NU,X) MAY BE Q(MU,NU,X). -C NOTE, IN THIS LOOP, NU=NU+1 -C - 130 X1=(2.*NU-1.)/(NU+DMU)*X*PQ1 - X2=(NU-1.-DMU)/(NU+DMU)*PQ2 - CALL XADD(X1,IPQ1,-X2,IPQ2,PQ,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - CALL XADJ(PQ,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - NU=NU+1. - PQ2=PQ1 - IPQ2=IPQ1 - GO TO 120 -C - END diff --git a/slatec/xpsi.f b/slatec/xpsi.f deleted file mode 100644 index 00260e7..0000000 --- a/slatec/xpsi.f +++ /dev/null @@ -1,59 +0,0 @@ -*DECK XPSI - REAL FUNCTION XPSI (A, IPSIK, IPSIX) -C***BEGIN PROLOGUE XPSI -C***SUBSIDIARY -C***PURPOSE To compute values of the Psi function for XLEGF. -C***LIBRARY SLATEC -C***CATEGORY C7C -C***TYPE SINGLE PRECISION (XPSI-S, DXPSI-D) -C***KEYWORDS PSI FUNCTION -C***AUTHOR Smith, John M., (NBS and George Mason University) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 820728 DATE WRITTEN -C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Changed all specific intrinsics to generic. (WRB) -C Corrected order of sections in prologue and added TYPE -C section. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE XPSI - REAL A,B,C,CNUM,CDENOM - DIMENSION CNUM(12),CDENOM(12) - SAVE CNUM, CDENOM -C -C CNUM(I) AND CDENOM(I) ARE THE ( REDUCED ) NUMERATOR -C AND 2*I*DENOMINATOR RESPECTIVELY OF THE 2*I TH BERNOULLI -C NUMBER. -C - DATA CNUM(1),CNUM(2),CNUM(3),CNUM(4),CNUM(5),CNUM(6),CNUM(7), - 1CNUM(8),CNUM(9),CNUM(10),CNUM(11),CNUM(12) - 2 / 1., -1., 1., -1., 1., - 3 -691., 1., -3617., 43867., -174611., 77683., - 4 -236364091./ - DATA CDENOM(1),CDENOM(2),CDENOM(3),CDENOM(4),CDENOM(5),CDENOM(6), - 1 CDENOM(7),CDENOM(8),CDENOM(9),CDENOM(10),CDENOM(11),CDENOM(12) - 2/12.,120., 252., 240.,132., - 3 32760., 12., 8160., 14364., 6600., 276., 65520./ -C***FIRST EXECUTABLE STATEMENT XPSI - N=MAX(0,IPSIX-INT(A)) - B=N+A - K1=IPSIK-1 -C -C SERIES EXPANSION FOR A .GT. IPSIX USING IPSIK-1 TERMS. -C - C=0. - DO 12 I=1,K1 - K=IPSIK-I - 12 C=(C+CNUM(K)/CDENOM(K))/B**2 - XPSI=LOG(B)-(C+.5/B) - IF(N.EQ.0) GO TO 20 - B=0. -C -C RECURRENCE FOR A .LE. IPSIX. -C - DO 15 M=1,N - 15 B=B+1./(N-M+A) - XPSI=XPSI-B - 20 RETURN - END diff --git a/slatec/xqmu.f b/slatec/xqmu.f deleted file mode 100644 index 87f4bf4..0000000 --- a/slatec/xqmu.f +++ /dev/null @@ -1,83 +0,0 @@ -*DECK XQMU - SUBROUTINE XQMU (NU1, NU2, MU1, MU2, THETA, X, SX, ID, PQA, IPQA, - 1 IERROR) -C***BEGIN PROLOGUE XQMU -C***SUBSIDIARY -C***PURPOSE To compute the values of Legendre functions for XLEGF. -C Method: forward mu-wise recurrence for Q(MU,NU,X) for fixed -C nu to obtain Q(MU1,NU,X), Q(MU1+1,NU,X), ..., Q(MU2,NU,X). -C***LIBRARY SLATEC -C***CATEGORY C3A2, C9 -C***TYPE SINGLE PRECISION (XQMU-S, DXQMU-D) -C***KEYWORDS LEGENDRE FUNCTIONS -C***AUTHOR Smith, John M., (NBS and George Mason University) -C***ROUTINES CALLED XADD, XADJ, XPQNU -C***REVISION HISTORY (YYMMDD) -C 820728 DATE WRITTEN -C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Corrected order of sections in prologue and added TYPE -C section. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE XQMU - DIMENSION PQA(*),IPQA(*) - REAL DMU,NU,NU1,NU2,PQ,PQA,PQ1,PQ2,SX,X,X1,X2 - REAL THETA -C***FIRST EXECUTABLE STATEMENT XQMU - IERROR=0 - MU=0 -C -C CALL XPQNU TO OBTAIN Q(0.,NU1,X) -C - CALL XPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR) - IF (IERROR.NE.0) RETURN - PQ2=PQA(1) - IPQ2=IPQA(1) - MU=1 -C -C CALL XPQNU TO OBTAIN Q(1.,NU1,X) -C - CALL XPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR) - IF (IERROR.NE.0) RETURN - NU=NU1 - K=0 - MU=1 - DMU=1. - PQ1=PQA(1) - IPQ1=IPQA(1) - IF(MU1.GT.0) GO TO 310 - K=K+1 - PQA(K)=PQ2 - IPQA(K)=IPQ2 - IF(MU2.LT.1) GO TO 330 - 310 IF(MU1.GT.1) GO TO 320 - K=K+1 - PQA(K)=PQ1 - IPQA(K)=IPQ1 - IF(MU2.LE.1) GO TO 330 - 320 CONTINUE -C -C FORWARD RECURRENCE IN MU TO OBTAIN -C Q(MU1,NU,X),Q(MU1+1,NU,X),....,Q(MU2,NU,X) USING -C Q(MU+1,NU,X)=-2.*MU*X*SQRT(1./(1.-X**2))*Q(MU,NU,X) -C -(NU+MU)*(NU-MU+1.)*Q(MU-1,NU,X) -C - X1=-2.*DMU*X*SX*PQ1 - X2=(NU+DMU)*(NU-DMU+1.)*PQ2 - CALL XADD(X1,IPQ1,-X2,IPQ2,PQ,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - CALL XADJ(PQ,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - PQ2=PQ1 - IPQ2=IPQ1 - PQ1=PQ - IPQ1=IPQ - MU=MU+1 - DMU=DMU+1. - IF(MU.LT.MU1) GO TO 320 - K=K+1 - PQA(K)=PQ - IPQA(K)=IPQ - IF(MU2.GT.MU) GO TO 320 - 330 RETURN - END diff --git a/slatec/xqnu.f b/slatec/xqnu.f deleted file mode 100644 index 74d0bda..0000000 --- a/slatec/xqnu.f +++ /dev/null @@ -1,124 +0,0 @@ -*DECK XQNU - SUBROUTINE XQNU (NU1, NU2, MU1, THETA, X, SX, ID, PQA, IPQA, - 1 IERROR) -C***BEGIN PROLOGUE XQNU -C***SUBSIDIARY -C***PURPOSE To compute the values of Legendre functions for XLEGF. -C Method: backward nu-wise recurrence for Q(MU,NU,X) for -C fixed mu to obtain Q(MU1,NU1,X), Q(MU1,NU1+1,X), ..., -C Q(MU1,NU2,X). -C***LIBRARY SLATEC -C***CATEGORY C3A2, C9 -C***TYPE SINGLE PRECISION (XQNU-S, DXQNU-D) -C***KEYWORDS LEGENDRE FUNCTIONS -C***AUTHOR Smith, John M., (NBS and George Mason University) -C***ROUTINES CALLED XADD, XADJ, XPQNU -C***REVISION HISTORY (YYMMDD) -C 820728 DATE WRITTEN -C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Corrected order of sections in prologue and added TYPE -C section. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE XQNU - DIMENSION PQA(*),IPQA(*) - REAL DMU,NU,NU1,NU2,PQ,PQA,PQ1,PQ2,SX,X,X1,X2 - REAL THETA,PQL1,PQL2 -C***FIRST EXECUTABLE STATEMENT XQNU - IERROR=0 - K=0 - PQ2=0.0 - IPQ2=0 - PQL2=0.0 - IPQL2=0 - IF(MU1.EQ.1) GO TO 290 - MU=0 -C -C CALL XPQNU TO OBTAIN Q(0.,NU2,X) AND Q(0.,NU2-1,X) -C - CALL XPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR) - IF (IERROR.NE.0) RETURN - IF(MU1.EQ.0) RETURN - K=(NU2-NU1+1.5) - PQ2=PQA(K) - IPQ2=IPQA(K) - PQL2=PQA(K-1) - IPQL2=IPQA(K-1) - 290 MU=1 -C -C CALL XPQNU TO OBTAIN Q(1.,NU2,X) AND Q(1.,NU2-1,X) -C - CALL XPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR) - IF (IERROR.NE.0) RETURN - IF(MU1.EQ.1) RETURN - NU=NU2 - PQ1=PQA(K) - IPQ1=IPQA(K) - PQL1=PQA(K-1) - IPQL1=IPQA(K-1) - 300 MU=1 - DMU=1. - 320 CONTINUE -C -C FORWARD RECURRENCE IN MU TO OBTAIN Q(MU1,NU2,X) AND -C Q(MU1,NU2-1,X) USING -C Q(MU+1,NU,X)=-2.*MU*X*SQRT(1./(1.-X**2))*Q(MU,NU,X) -C -(NU+MU)*(NU-MU+1.)*Q(MU-1,NU,X) -C -C FIRST FOR NU=NU2 -C - X1=-2.*DMU*X*SX*PQ1 - X2=(NU+DMU)*(NU-DMU+1.)*PQ2 - CALL XADD(X1,IPQ1,-X2,IPQ2,PQ,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - CALL XADJ(PQ,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - PQ2=PQ1 - IPQ2=IPQ1 - PQ1=PQ - IPQ1=IPQ - MU=MU+1 - DMU=DMU+1. - IF(MU.LT.MU1) GO TO 320 - PQA(K)=PQ - IPQA(K)=IPQ - IF(K.EQ.1) RETURN - IF(NU.LT.NU2) GO TO 340 -C -C THEN FOR NU=NU2-1 -C - NU=NU-1. - PQ2=PQL2 - IPQ2=IPQL2 - PQ1=PQL1 - IPQ1=IPQL1 - K=K-1 - GO TO 300 -C -C BACKWARD RECURRENCE IN NU TO OBTAIN -C Q(MU1,NU1,X),Q(MU1,NU1+1,X),....,Q(MU1,NU2,X) -C USING -C (NU-MU+1.)*Q(MU,NU+1,X)= -C (2.*NU+1.)*X*Q(MU,NU,X)-(NU+MU)*Q(MU,NU-1,X) -C - 340 PQ1=PQA(K) - IPQ1=IPQA(K) - PQ2=PQA(K+1) - IPQ2=IPQA(K+1) - 350 IF(NU.LE.NU1) RETURN - K=K-1 - X1=(2.*NU+1.)*X*PQ1/(NU+DMU) - X2=-(NU-DMU+1.)*PQ2/(NU+DMU) - CALL XADD(X1,IPQ1,X2,IPQ2,PQ,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - CALL XADJ(PQ,IPQ,IERROR) - IF (IERROR.NE.0) RETURN - PQ2=PQ1 - IPQ2=IPQ1 - PQ1=PQ - IPQ1=IPQ - PQA(K)=PQ - IPQA(K)=IPQ - NU=NU-1. - GO TO 350 - END diff --git a/slatec/xred.f b/slatec/xred.f deleted file mode 100644 index e687603..0000000 --- a/slatec/xred.f +++ /dev/null @@ -1,85 +0,0 @@ -*DECK XRED - SUBROUTINE XRED (X, IX, IERROR) -C***BEGIN PROLOGUE XRED -C***PURPOSE To provide single-precision floating-point arithmetic -C with an extended exponent range. -C***LIBRARY SLATEC -C***CATEGORY A3D -C***TYPE SINGLE PRECISION (XRED-S, DXRED-D) -C***KEYWORDS EXTENDED-RANGE SINGLE-PRECISION ARITHMETIC -C***AUTHOR Lozier, Daniel W., (National Bureau of Standards) -C Smith, John M., (NBS and George Mason University) -C***DESCRIPTION -C REAL X -C INTEGER IX -C -C IF -C RADIX**(-2L) .LE. (ABS(X),IX) .LE. RADIX**(2L) -C THEN XRED TRANSFORMS (X,IX) SO THAT IX=0. -C IF (X,IX) IS OUTSIDE THE ABOVE RANGE, -C THEN XRED TAKES NO ACTION. -C THIS SUBROUTINE IS USEFUL IF THE -C RESULTS OF EXTENDED-RANGE CALCULATIONS -C ARE TO BE USED IN SUBSEQUENT ORDINARY -C SINGLE-PRECISION CALCULATIONS. -C -C***SEE ALSO XSET -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS XBLK2 -C***REVISION HISTORY (YYMMDD) -C 820712 DATE WRITTEN -C 881020 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Changed all specific intrinsics to generic. (WRB) -C Corrected order of sections in prologue and added TYPE -C section. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE XRED - REAL X - INTEGER IX - REAL RADIX, RADIXL, RAD2L, DLG10R, XA - INTEGER L, L2, KMAX - COMMON /XBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX - SAVE /XBLK2/ -C -C***FIRST EXECUTABLE STATEMENT XRED - IERROR=0 - IF (X.EQ.0.0) GO TO 90 - XA = ABS(X) - IF (IX.EQ.0) GO TO 70 - IXA = ABS(IX) - IXA1 = IXA/L2 - IXA2 = MOD(IXA,L2) - IF (IX.GT.0) GO TO 40 - 10 CONTINUE - IF (XA.GT.1.0) GO TO 20 - XA = XA*RAD2L - IXA1 = IXA1 + 1 - GO TO 10 - 20 XA = XA/RADIX**IXA2 - IF (IXA1.EQ.0) GO TO 70 - DO 30 I=1,IXA1 - IF (XA.LT.1.0) GO TO 100 - XA = XA/RAD2L - 30 CONTINUE - GO TO 70 -C - 40 CONTINUE - IF (XA.LT.1.0) GO TO 50 - XA = XA/RAD2L - IXA1 = IXA1 + 1 - GO TO 40 - 50 XA = XA*RADIX**IXA2 - IF (IXA1.EQ.0) GO TO 70 - DO 60 I=1,IXA1 - IF (XA.GT.1.0) GO TO 100 - XA = XA*RAD2L - 60 CONTINUE - 70 IF (XA.GT.RAD2L) GO TO 100 - IF (XA.GT.1.0) GO TO 80 - IF (RAD2L*XA.LT.1.0) GO TO 100 - 80 X = SIGN(XA,X) - 90 IX = 0 - 100 RETURN - END diff --git a/slatec/xset.f b/slatec/xset.f deleted file mode 100644 index afeab05..0000000 --- a/slatec/xset.f +++ /dev/null @@ -1,330 +0,0 @@ -*DECK XSET - SUBROUTINE XSET (IRAD, NRADPL, DZERO, NBITS, IERROR) -C***BEGIN PROLOGUE XSET -C***PURPOSE To provide single-precision floating-point arithmetic -C with an extended exponent range. -C***LIBRARY SLATEC -C***CATEGORY A3D -C***TYPE SINGLE PRECISION (XSET-S, DXSET-D) -C***KEYWORDS EXTENDED-RANGE SINGLE-PRECISION ARITHMETIC -C***AUTHOR Lozier, Daniel W., (National Bureau of Standards) -C Smith, John M., (NBS and George Mason University) -C***DESCRIPTION -C -C SUBROUTINE XSET MUST BE CALLED PRIOR TO CALLING ANY OTHER -C EXTENDED-RANGE SUBROUTINE. IT CALCULATES AND STORES SEVERAL -C MACHINE-DEPENDENT CONSTANTS IN COMMON BLOCKS. THE USER MUST -C SUPPLY FOUR CONSTANTS THAT PERTAIN TO HIS PARTICULAR COMPUTER. -C THE CONSTANTS ARE -C -C IRAD = THE INTERNAL BASE OF SINGLE-PRECISION -C ARITHMETIC IN THE COMPUTER. -C NRADPL = THE NUMBER OF RADIX PLACES CARRIED IN -C THE SINGLE-PRECISION REPRESENTATION. -C DZERO = THE SMALLEST OF 1/DMIN, DMAX, DMAXLN WHERE -C DMIN = THE SMALLEST POSITIVE SINGLE-PRECISION -C NUMBER OR AN UPPER BOUND TO THIS NUMBER, -C DMAX = THE LARGEST SINGLE-PRECISION NUMBER -C OR A LOWER BOUND TO THIS NUMBER, -C DMAXLN = THE LARGEST SINGLE-PRECISION NUMBER -C SUCH THAT LOG10(DMAXLN) CAN BE COMPUTED BY THE -C FORTRAN SYSTEM (ON MOST SYSTEMS DMAXLN = DMAX). -C NBITS = THE NUMBER OF BITS (EXCLUSIVE OF SIGN) IN -C AN INTEGER COMPUTER WORD. -C -C ALTERNATIVELY, ANY OR ALL OF THE CONSTANTS CAN BE GIVEN -C THE VALUE 0 (0.0 FOR DZERO). IF A CONSTANT IS ZERO, XSET TRIES -C TO ASSIGN AN APPROPRIATE VALUE BY CALLING I1MACH -C (SEE P.A.FOX, A.D.HALL, N.L.SCHRYER, ALGORITHM 528 FRAMEWORK -C FOR A PORTABLE LIBRARY, ACM TRANSACTIONS ON MATH SOFTWARE, -C V.4, NO.2, JUNE 1978, 177-188). -C -C THIS IS THE SETTING-UP SUBROUTINE FOR A PACKAGE OF SUBROUTINES -C THAT FACILITATE THE USE OF EXTENDED-RANGE ARITHMETIC. EXTENDED-RANGE -C ARITHMETIC ON A PARTICULAR COMPUTER IS DEFINED ON THE SET OF NUMBERS -C OF THE FORM -C -C (X,IX) = X*RADIX**IX -C -C WHERE X IS A SINGLE-PRECISION NUMBER CALLED THE PRINCIPAL PART, -C IX IS AN INTEGER CALLED THE AUXILIARY INDEX, AND RADIX IS THE -C INTERNAL BASE OF THE SINGLE-PRECISION ARITHMETIC. OBVIOUSLY, -C EACH REAL NUMBER IS REPRESENTABLE WITHOUT ERROR BY MORE THAN ONE -C EXTENDED-RANGE FORM. CONVERSIONS BETWEEN DIFFERENT FORMS ARE -C ESSENTIAL IN CARRYING OUT ARITHMETIC OPERATIONS. WITH THE CHOICE -C OF RADIX WE HAVE MADE, AND THE SUBROUTINES WE HAVE WRITTEN, THESE -C CONVERSIONS ARE PERFORMED WITHOUT ERROR (AT LEAST ON MOST COMPUTERS). -C (SEE SMITH, J.M., OLVER, F.W.J., AND LOZIER, D.W., EXTENDED-RANGE -C ARITHMETIC AND NORMALIZED LEGENDRE POLYNOMIALS, ACM TRANSACTIONS ON -C MATHEMATICAL SOFTWARE, MARCH 1981). -C -C AN EXTENDED-RANGE NUMBER (X,IX) IS SAID TO BE IN ADJUSTED FORM IF -C X AND IX ARE ZERO OR -C -C RADIX**(-L) .LE. ABS(X) .LT. RADIX**L -C -C IS SATISFIED, WHERE L IS A COMPUTER-DEPENDENT INTEGER DEFINED IN THIS -C SUBROUTINE. TWO EXTENDED-RANGE NUMBERS IN ADJUSTED FORM CAN BE ADDED, -C SUBTRACTED, MULTIPLIED OR DIVIDED (IF THE DIVISOR IS NONZERO) WITHOUT -C CAUSING OVERFLOW OR UNDERFLOW IN THE PRINCIPAL PART OF THE RESULT. -C WITH PROPER USE OF THE EXTENDED-RANGE SUBROUTINES, THE ONLY OVERFLOW -C THAT CAN OCCUR IS INTEGER OVERFLOW IN THE AUXILIARY INDEX. IF THIS -C IS DETECTED, THE SOFTWARE CALLS XERROR (A GENERAL ERROR-HANDLING -C FORTRAN SUBROUTINE PACKAGE). -C -C MULTIPLICATION AND DIVISION IS PERFORMED BY SETTING -C -C (X,IX)*(Y,IY) = (X*Y,IX+IY) -C OR -C (X,IX)/(Y,IY) = (X/Y,IX-IY). -C -C PRE-ADJUSTMENT OF THE OPERANDS IS ESSENTIAL TO AVOID -C OVERFLOW OR UNDERFLOW OF THE PRINCIPAL PART. SUBROUTINE -C XADJ (SEE BELOW) MAY BE CALLED TO TRANSFORM ANY EXTENDED- -C RANGE NUMBER INTO ADJUSTED FORM. -C -C ADDITION AND SUBTRACTION REQUIRE THE USE OF SUBROUTINE XADD -C (SEE BELOW). THE INPUT OPERANDS NEED NOT BE IN ADJUSTED FORM. -C HOWEVER, THE RESULT OF ADDITION OR SUBTRACTION IS RETURNED -C IN ADJUSTED FORM. THUS, FOR EXAMPLE, IF (X,IX),(Y,IY), -C (U,IU), AND (V,IV) ARE IN ADJUSTED FORM, THEN -C -C (X,IX)*(Y,IY) + (U,IU)*(V,IV) -C -C CAN BE COMPUTED AND STORED IN ADJUSTED FORM WITH NO EXPLICIT -C CALLS TO XADJ. -C -C WHEN AN EXTENDED-RANGE NUMBER IS TO BE PRINTED, IT MUST BE -C CONVERTED TO AN EXTENDED-RANGE FORM WITH DECIMAL RADIX. SUBROUTINE -C XCON IS PROVIDED FOR THIS PURPOSE. -C -C THE SUBROUTINES CONTAINED IN THIS PACKAGE ARE -C -C SUBROUTINE XADD -C USAGE -C CALL XADD(X,IX,Y,IY,Z,IZ,IERROR) -C IF (IERROR.NE.0) RETURN -C DESCRIPTION -C FORMS THE EXTENDED-RANGE SUM (Z,IZ) = -C (X,IX) + (Y,IY). (Z,IZ) IS ADJUSTED -C BEFORE RETURNING. THE INPUT OPERANDS -C NEED NOT BE IN ADJUSTED FORM, BUT THEIR -C PRINCIPAL PARTS MUST SATISFY -C RADIX**(-2L).LE.ABS(X).LE.RADIX**(2L), -C RADIX**(-2L).LE.ABS(Y).LE.RADIX**(2L). -C -C SUBROUTINE XADJ -C USAGE -C CALL XADJ(X,IX,IERROR) -C IF (IERROR.NE.0) RETURN -C DESCRIPTION -C TRANSFORMS (X,IX) SO THAT -C RADIX**(-L) .LE. ABS(X) .LT. RADIX**L. -C ON MOST COMPUTERS THIS TRANSFORMATION DOES -C NOT CHANGE THE MANTISSA OF X PROVIDED RADIX IS -C THE NUMBER BASE OF SINGLE-PRECISION ARITHMETIC. -C -C SUBROUTINE XC210 -C USAGE -C CALL XC210(K,Z,J,IERROR) -C IF (IERROR.NE.0) RETURN -C DESCRIPTION -C GIVEN K THIS SUBROUTINE COMPUTES J AND Z -C SUCH THAT RADIX**K = Z*10**J, WHERE Z IS IN -C THE RANGE 1/10 .LE. Z .LT. 1. -C THE VALUE OF Z WILL BE ACCURATE TO FULL -C SINGLE-PRECISION PROVIDED THE NUMBER -C OF DECIMAL PLACES IN THE LARGEST -C INTEGER PLUS THE NUMBER OF DECIMAL -C PLACES CARRIED IN SINGLE-PRECISION DOES NOT -C EXCEED 60. XC210 IS CALLED BY SUBROUTINE -C XCON WHEN NECESSARY. THE USER SHOULD -C NEVER NEED TO CALL XC210 DIRECTLY. -C -C SUBROUTINE XCON -C USAGE -C CALL XCON(X,IX,IERROR) -C IF (IERROR.NE.0) RETURN -C DESCRIPTION -C CONVERTS (X,IX) = X*RADIX**IX -C TO DECIMAL FORM IN PREPARATION FOR -C PRINTING, SO THAT (X,IX) = X*10**IX -C WHERE 1/10 .LE. ABS(X) .LT. 1 -C IS RETURNED, EXCEPT THAT IF -C (ABS(X),IX) IS BETWEEN RADIX**(-2L) -C AND RADIX**(2L) THEN THE REDUCED -C FORM WITH IX = 0 IS RETURNED. -C -C SUBROUTINE XRED -C USAGE -C CALL XRED(X,IX,IERROR) -C IF (IERROR.NE.0) RETURN -C DESCRIPTION -C IF -C RADIX**(-2L) .LE. (ABS(X),IX) .LE. RADIX**(2L) -C THEN XRED TRANSFORMS (X,IX) SO THAT IX=0. -C IF (X,IX) IS OUTSIDE THE ABOVE RANGE, -C THEN XRED TAKES NO ACTION. -C THIS SUBROUTINE IS USEFUL IF THE -C RESULTS OF EXTENDED-RANGE CALCULATIONS -C ARE TO BE USED IN SUBSEQUENT ORDINARY -C SINGLE-PRECISION CALCULATIONS. -C -C***REFERENCES Smith, Olver and Lozier, Extended-Range Arithmetic and -C Normalized Legendre Polynomials, ACM Trans on Math -C Softw, v 7, n 1, March 1981, pp 93--105. -C***ROUTINES CALLED I1MACH, XERMSG -C***COMMON BLOCKS XBLK1, XBLK2, XBLK3 -C***REVISION HISTORY (YYMMDD) -C 820712 DATE WRITTEN -C 881020 Revised to meet SLATEC CML recommendations. (DWL and JMS) -C 901019 Revisions to prologue. (DWL and WRB) -C 901106 Changed all specific intrinsics to generic. (WRB) -C Corrected order of sections in prologue and added TYPE -C section. (WRB) -C CALLs to XERROR changed to CALLs to XERMSG. (WRB) -C 920127 Revised PURPOSE section of prologue. (DWL) -C***END PROLOGUE XSET - INTEGER IRAD, NRADPL, NBITS - REAL DZERO, DZEROX - COMMON /XBLK1/ NBITSF - SAVE /XBLK1/ - REAL RADIX, RADIXL, RAD2L, DLG10R - INTEGER L, L2, KMAX - COMMON /XBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX - SAVE /XBLK2/ - INTEGER NLG102, MLG102, LG102 - COMMON /XBLK3/ NLG102, MLG102, LG102(21) - SAVE /XBLK3/ - INTEGER IFLAG - SAVE IFLAG -C - DIMENSION LOG102(20), LGTEMP(20) - SAVE LOG102 -C -C LOG102 CONTAINS THE FIRST 60 DIGITS OF LOG10(2) FOR USE IN -C CONVERSION OF EXTENDED-RANGE NUMBERS TO BASE 10 . - DATA LOG102 /301,029,995,663,981,195,213,738,894,724,493,026,768, - * 189,881,462,108,541,310,428/ -C -C FOLLOWING CODING PREVENTS XSET FROM BEING EXECUTED MORE THAN ONCE. -C THIS IS IMPORTANT BECAUSE SOME SUBROUTINES (SUCH AS XNRMP AND -C XLEGF) CALL XSET TO MAKE SURE EXTENDED-RANGE ARITHMETIC HAS -C BEEN INITIALIZED. THE USER MAY WANT TO PRE-EMPT THIS CALL, FOR -C EXAMPLE WHEN I1MACH IS NOT AVAILABLE. SEE CODING BELOW. - DATA IFLAG /0/ -C***FIRST EXECUTABLE STATEMENT XSET - IERROR=0 - IF (IFLAG .NE. 0) RETURN - IRADX = IRAD - NRDPLC = NRADPL - DZEROX = DZERO - IMINEX = 0 - IMAXEX = 0 - NBITSX = NBITS -C FOLLOWING 5 STATEMENTS SHOULD BE DELETED IF I1MACH IS -C NOT AVAILABLE OR NOT CONFIGURED TO RETURN THE CORRECT -C MACHINE-DEPENDENT VALUES. - IF (IRADX .EQ. 0) IRADX = I1MACH (10) - IF (NRDPLC .EQ. 0) NRDPLC = I1MACH (11) - IF (DZEROX .EQ. 0.0) IMINEX = I1MACH (12) - IF (DZEROX .EQ. 0.0) IMAXEX = I1MACH (13) - IF (NBITSX .EQ. 0) NBITSX = I1MACH (8) - IF (IRADX.EQ.2) GO TO 10 - IF (IRADX.EQ.4) GO TO 10 - IF (IRADX.EQ.8) GO TO 10 - IF (IRADX.EQ.16) GO TO 10 - CALL XERMSG ('SLATEC', 'XSET', 'IMPROPER VALUE OF IRAD', 101, 1) - IERROR=101 - RETURN - 10 CONTINUE - LOG2R=0 - IF (IRADX.EQ.2) LOG2R = 1 - IF (IRADX.EQ.4) LOG2R = 2 - IF (IRADX.EQ.8) LOG2R = 3 - IF (IRADX.EQ.16) LOG2R = 4 - NBITSF=LOG2R*NRDPLC - RADIX = IRADX - DLG10R = LOG10(RADIX) - IF (DZEROX .NE. 0.0) GO TO 14 - LX = MIN ((1-IMINEX)/2, (IMAXEX-1)/2) - GO TO 16 - 14 LX = 0.5*LOG10(DZEROX)/DLG10R -C RADIX**(2*L) SHOULD NOT OVERFLOW, BUT REDUCE L BY 1 FOR FURTHER -C PROTECTION. - LX=LX-1 - 16 L2 = 2*LX - IF (LX.GE.4) GO TO 20 - CALL XERMSG ('SLATEC', 'XSET', 'IMPROPER VALUE OF DZERO', 102, 1) - IERROR=102 - RETURN - 20 L = LX - RADIXL = RADIX**L - RAD2L = RADIXL**2 -C IT IS NECESSARY TO RESTRICT NBITS (OR NBITSX) TO BE LESS THAN SOME -C UPPER LIMIT BECAUSE OF BINARY-TO-DECIMAL CONVERSION. SUCH CONVERSION -C IS DONE BY XC210 AND REQUIRES A CONSTANT THAT IS STORED TO SOME FIXED -C PRECISION. THE STORED CONSTANT (LOG102 IN THIS ROUTINE) PROVIDES -C FOR CONVERSIONS ACCURATE TO THE LAST DECIMAL DIGIT WHEN THE INTEGER -C WORD LENGTH DOES NOT EXCEED 63. A LOWER LIMIT OF 15 BITS IS IMPOSED -C BECAUSE THE SOFTWARE IS DESIGNED TO RUN ON COMPUTERS WITH INTEGER WORD -C LENGTH OF AT LEAST 16 BITS. - IF (15.LE.NBITSX .AND. NBITSX.LE.63) GO TO 30 - CALL XERMSG ('SLATEC', 'XSET', 'IMPROPER VALUE OF NBITS', 103, 1) - IERROR=103 - RETURN - 30 CONTINUE - KMAX = 2**(NBITSX-1) - L2 - NB = (NBITSX-1)/2 - MLG102 = 2**NB - IF (1.LE.NRDPLC*LOG2R .AND. NRDPLC*LOG2R.LE.120) GO TO 40 - CALL XERMSG ('SLATEC', 'XSET', 'IMPROPER VALUE OF NRADPL', 104, 1) - IERROR=104 - RETURN - 40 CONTINUE - NLG102 = NRDPLC*LOG2R/NB + 3 - NP1 = NLG102 + 1 -C -C AFTER COMPLETION OF THE FOLLOWING LOOP, IC CONTAINS -C THE INTEGER PART AND LGTEMP CONTAINS THE FRACTIONAL PART -C OF LOG10(IRADX) IN RADIX 1000. - IC = 0 - DO 50 II=1,20 - I = 21 - II - IT = LOG2R*LOG102(I) + IC - IC = IT/1000 - LGTEMP(I) = MOD(IT,1000) - 50 CONTINUE -C -C AFTER COMPLETION OF THE FOLLOWING LOOP, LG102 CONTAINS -C LOG10(IRADX) IN RADIX MLG102. THE RADIX POINT IS -C BETWEEN LG102(1) AND LG102(2). - LG102(1) = IC - DO 80 I=2,NP1 - LG102X = 0 - DO 70 J=1,NB - IC = 0 - DO 60 KK=1,20 - K = 21 - KK - IT = 2*LGTEMP(K) + IC - IC = IT/1000 - LGTEMP(K) = MOD(IT,1000) - 60 CONTINUE - LG102X = 2*LG102X + IC - 70 CONTINUE - LG102(I) = LG102X - 80 CONTINUE -C -C CHECK SPECIAL CONDITIONS REQUIRED BY SUBROUTINES... - IF (NRDPLC.LT.L) GO TO 90 - CALL XERMSG ('SLATEC', 'XSET', 'NRADPL .GE. L', 105, 1) - IERROR=105 - RETURN - 90 IF (6*L.LE.KMAX) GO TO 100 - CALL XERMSG ('SLATEC', 'XSET', '6*L .GT. KMAX', 106, 1) - IERROR=106 - RETURN - 100 CONTINUE - IFLAG = 1 - RETURN - END diff --git a/slatec/xsetf.f b/slatec/xsetf.f deleted file mode 100644 index 2039e82..0000000 --- a/slatec/xsetf.f +++ /dev/null @@ -1,60 +0,0 @@ -*DECK XSETF - SUBROUTINE XSETF (KONTRL) -C***BEGIN PROLOGUE XSETF -C***PURPOSE Set the error control flag. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3A -C***TYPE ALL (XSETF-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C XSETF sets the error control flag value to KONTRL. -C (KONTRL is an input parameter only.) -C The following table shows how each message is treated, -C depending on the values of KONTRL and LEVEL. (See XERMSG -C for description of LEVEL.) -C -C If KONTRL is zero or negative, no information other than the -C message itself (including numeric values, if any) will be -C printed. If KONTRL is positive, introductory messages, -C trace-backs, etc., will be printed in addition to the message. -C -C ABS(KONTRL) -C LEVEL 0 1 2 -C value -C 2 fatal fatal fatal -C -C 1 not printed printed fatal -C -C 0 not printed printed printed -C -C -1 not printed printed printed -C only only -C once once -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, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790801 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 900510 Change call to XERRWV to XERMSG. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XSETF - CHARACTER *8 XERN1 -C***FIRST EXECUTABLE STATEMENT XSETF - IF (ABS(KONTRL) .GT. 2) THEN - WRITE (XERN1, '(I8)') KONTRL - CALL XERMSG ('SLATEC', 'XSETF', - * 'INVALID ARGUMENT = ' // XERN1, 1, 2) - RETURN - ENDIF -C - JUNK = J4SAVE(2,KONTRL,.TRUE.) - RETURN - END diff --git a/slatec/xsetua.f b/slatec/xsetua.f deleted file mode 100644 index 5b58f84..0000000 --- a/slatec/xsetua.f +++ /dev/null @@ -1,59 +0,0 @@ -*DECK XSETUA - SUBROUTINE XSETUA (IUNITA, N) -C***BEGIN PROLOGUE XSETUA -C***PURPOSE Set logical unit numbers (up to 5) to which error -C messages are to be sent. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3B -C***TYPE ALL (XSETUA-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C XSETUA may be called to declare a list of up to five -C logical units, each of which is to receive a copy of -C each error message processed by this package. -C The purpose of XSETUA is to allow simultaneous printing -C of each error message on, say, a main output file, -C an interactive terminal, and other files such as graphics -C communication files. -C -C Description of Parameters -C --Input-- -C IUNIT - an array of up to five unit numbers. -C Normally these numbers should all be different -C (but duplicates are not prohibited.) -C N - the number of unit numbers provided in IUNIT -C must have 1 .LE. N .LE. 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, XERMSG -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 900510 Change call to XERRWV to XERMSG. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XSETUA - DIMENSION IUNITA(5) - CHARACTER *8 XERN1 -C***FIRST EXECUTABLE STATEMENT XSETUA -C - IF (N.LT.1 .OR. N.GT.5) THEN - WRITE (XERN1, '(I8)') N - CALL XERMSG ('SLATEC', 'XSETUA', - * 'INVALID NUMBER OF UNITS, N = ' // XERN1, 1, 2) - RETURN - ENDIF -C - DO 10 I=1,N - INDEX = I+4 - IF (I.EQ.1) INDEX = 3 - JUNK = J4SAVE(INDEX,IUNITA(I),.TRUE.) - 10 CONTINUE - JUNK = J4SAVE(5,N,.TRUE.) - RETURN - END diff --git a/slatec/xsetun.f b/slatec/xsetun.f deleted file mode 100644 index f99df0b..0000000 --- a/slatec/xsetun.f +++ /dev/null @@ -1,36 +0,0 @@ -*DECK XSETUN - SUBROUTINE XSETUN (IUNIT) -C***BEGIN PROLOGUE XSETUN -C***PURPOSE Set output file to which error messages are to be sent. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3B -C***TYPE ALL (XSETUN-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C XSETUN sets the output file to which error messages are to -C be sent. Only one file will be used. See XSETUA for -C how to declare more than one file. -C -C Description of Parameter -C --Input-- -C IUNIT - an input parameter giving the logical unit number -C to which error messages are to be sent. -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 XSETUN -C***FIRST EXECUTABLE STATEMENT XSETUN - JUNK = J4SAVE(3,IUNIT,.TRUE.) - JUNK = J4SAVE(5,1,.TRUE.) - RETURN - END diff --git a/slatec/yairy.f b/slatec/yairy.f deleted file mode 100644 index 855066b..0000000 --- a/slatec/yairy.f +++ /dev/null @@ -1,393 +0,0 @@ -*DECK YAIRY - SUBROUTINE YAIRY (X, RX, C, BI, DBI) -C***BEGIN PROLOGUE YAIRY -C***SUBSIDIARY -C***PURPOSE Subsidiary to BESJ and BESY -C***LIBRARY SLATEC -C***TYPE SINGLE PRECISION (YAIRY-S, DYAIRY-D) -C***AUTHOR Amos, D. E., (SNLA) -C Daniel, S. L., (SNLA) -C***DESCRIPTION -C -C YAIRY computes the Airy function BI(X) -C and its derivative DBI(X) for ASYJY -C -C INPUT -C -C X - Argument, computed by ASYJY, X unrestricted -C RX - RX=SQRT(ABS(X)), computed by ASYJY -C C - C=2.*(ABS(X)**1.5)/3., computed by ASYJY -C -C OUTPUT -C BI - Value of function BI(X) -C DBI - Value of the derivative DBI(X) -C -C***SEE ALSO BESJ, BESY -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910408 Updated the AUTHOR section. (WRB) -C***END PROLOGUE YAIRY -C - INTEGER I, J, M1, M1D, M2, M2D, M3, M3D, M4D, N1, N1D, N2, N2D, - 1 N3, N3D, N4D - REAL AA, AX, BB, BI, BJN, BJP, BK1, BK2, BK3, BK4, C, CON1, CON2, - 1 CON3, CV, DAA, DBB, DBI, DBJN, DBJP, DBK1, DBK2, DBK3, DBK4, D1, - 2 D2, EX, E1, E2, FPI12, F1, F2, RTRX, RX, SPI12, S1, S2, T, TC, - 3 TEMP1, TEMP2, TT, X - DIMENSION BK1(20), BK2(20), BK3(20), BK4(14) - DIMENSION BJP(19), BJN(19), AA(14), BB(14) - DIMENSION DBK1(21), DBK2(20), DBK3(20), DBK4(14) - DIMENSION DBJP(19), DBJN(19), DAA(14), DBB(14) - SAVE N1, N2, N3, M1, M2, M3, N1D, N2D, N3D, N4D, - 1 M1D, M2D, M3D, M4D, FPI12, SPI12, CON1, CON2, CON3, - 2 BK1, BK2, BK3, BK4, BJP, BJN, AA, BB, DBK1, DBK2, DBK3, DBK4, - 3 DBJP, DBJN, DAA, DBB - DATA N1,N2,N3/20,19,14/ - DATA M1,M2,M3/18,17,12/ - DATA N1D,N2D,N3D,N4D/21,20,19,14/ - DATA M1D,M2D,M3D,M4D/19,18,17,12/ - DATA FPI12,SPI12,CON1,CON2,CON3/ - 1 1.30899693899575E+00, 1.83259571459405E+00, 6.66666666666667E-01, - 2 7.74148278841779E+00, 3.64766105490356E-01/ - DATA BK1(1), BK1(2), BK1(3), BK1(4), BK1(5), BK1(6), - 1 BK1(7), BK1(8), BK1(9), BK1(10), BK1(11), BK1(12), - 2 BK1(13), BK1(14), BK1(15), BK1(16), BK1(17), BK1(18), - 3 BK1(19), BK1(20)/ 2.43202846447449E+00, 2.57132009754685E+00, - 4 1.02802341258616E+00, 3.41958178205872E-01, 8.41978629889284E-02, - 5 1.93877282587962E-02, 3.92687837130335E-03, 6.83302689948043E-04, - 6 1.14611403991141E-04, 1.74195138337086E-05, 2.41223620956355E-06, - 7 3.24525591983273E-07, 4.03509798540183E-08, 4.70875059642296E-09, - 8 5.35367432585889E-10, 5.70606721846334E-11, 5.80526363709933E-12, - 9 5.76338988616388E-13, 5.42103834518071E-14, 4.91857330301677E-15/ - DATA BK2(1), BK2(2), BK2(3), BK2(4), BK2(5), BK2(6), - 1 BK2(7), BK2(8), BK2(9), BK2(10), BK2(11), BK2(12), - 2 BK2(13), BK2(14), BK2(15), BK2(16), BK2(17), BK2(18), - 3 BK2(19), BK2(20)/ 5.74830555784088E-01,-6.91648648376891E-03, - 4 1.97460263052093E-03,-5.24043043868823E-04, 1.22965147239661E-04, - 5-2.27059514462173E-05, 2.23575555008526E-06, 4.15174955023899E-07, - 6-2.84985752198231E-07, 8.50187174775435E-08,-1.70400826891326E-08, - 7 2.25479746746889E-09,-1.09524166577443E-10,-3.41063845099711E-11, - 8 1.11262893886662E-11,-1.75542944241734E-12, 1.36298600401767E-13, - 9 8.76342105755664E-15,-4.64063099157041E-15, 7.78772758732960E-16/ - DATA BK3(1), BK3(2), BK3(3), BK3(4), BK3(5), BK3(6), - 1 BK3(7), BK3(8), BK3(9), BK3(10), BK3(11), BK3(12), - 2 BK3(13), BK3(14), BK3(15), BK3(16), BK3(17), BK3(18), - 3 BK3(19), BK3(20)/ 5.66777053506912E-01, 2.63672828349579E-03, - 4 5.12303351473130E-05, 2.10229231564492E-06, 1.42217095113890E-07, - 5 1.28534295891264E-08, 7.28556219407507E-10,-3.45236157301011E-10, - 6-2.11919115912724E-10,-6.56803892922376E-11,-8.14873160315074E-12, - 7 3.03177845632183E-12, 1.73447220554115E-12, 1.67935548701554E-13, - 8-1.49622868806719E-13,-5.15470458953407E-14, 8.75741841857830E-15, - 9 7.96735553525720E-15,-1.29566137861742E-16,-1.11878794417520E-15/ - DATA BK4(1), BK4(2), BK4(3), BK4(4), BK4(5), BK4(6), - 1 BK4(7), BK4(8), BK4(9), BK4(10), BK4(11), BK4(12), - 2 BK4(13), BK4(14)/ 4.85444386705114E-01,-3.08525088408463E-03, - 3 6.98748404837928E-05,-2.82757234179768E-06, 1.59553313064138E-07, - 4-1.12980692144601E-08, 9.47671515498754E-10,-9.08301736026423E-11, - 5 9.70776206450724E-12,-1.13687527254574E-12, 1.43982917533415E-13, - 6-1.95211019558815E-14, 2.81056379909357E-15,-4.26916444775176E-16/ - DATA BJP(1), BJP(2), BJP(3), BJP(4), BJP(5), BJP(6), - 1 BJP(7), BJP(8), BJP(9), BJP(10), BJP(11), BJP(12), - 2 BJP(13), BJP(14), BJP(15), BJP(16), BJP(17), BJP(18), - 3 BJP(19) / 1.34918611457638E-01,-3.19314588205813E-01, - 4 5.22061946276114E-02, 5.28869112170312E-02,-8.58100756077350E-03, - 5-2.99211002025555E-03, 4.21126741969759E-04, 8.73931830369273E-05, - 6-1.06749163477533E-05,-1.56575097259349E-06, 1.68051151983999E-07, - 7 1.89901103638691E-08,-1.81374004961922E-09,-1.66339134593739E-10, - 8 1.42956335780810E-11, 1.10179811626595E-12,-8.60187724192263E-14, - 9-5.71248177285064E-15, 4.08414552853803E-16/ - DATA BJN(1), BJN(2), BJN(3), BJN(4), BJN(5), BJN(6), - 1 BJN(7), BJN(8), BJN(9), BJN(10), BJN(11), BJN(12), - 2 BJN(13), BJN(14), BJN(15), BJN(16), BJN(17), BJN(18), - 3 BJN(19) / 6.59041673525697E-02,-4.24905910566004E-01, - 4 2.87209745195830E-01, 1.29787771099606E-01,-4.56354317590358E-02, - 5-1.02630175982540E-02, 2.50704671521101E-03, 3.78127183743483E-04, - 6-7.11287583284084E-05,-8.08651210688923E-06, 1.23879531273285E-06, - 7 1.13096815867279E-07,-1.46234283176310E-08,-1.11576315688077E-09, - 8 1.24846618243897E-10, 8.18334132555274E-12,-8.07174877048484E-13, - 9-4.63778618766425E-14, 4.09043399081631E-15/ - DATA AA(1), AA(2), AA(3), AA(4), AA(5), AA(6), - 1 AA(7), AA(8), AA(9), AA(10), AA(11), AA(12), - 2 AA(13), AA(14) /-2.78593552803079E-01, 3.52915691882584E-03, - 3 2.31149677384994E-05,-4.71317842263560E-06, 1.12415907931333E-07, - 4 2.00100301184339E-08,-2.60948075302193E-09, 3.55098136101216E-11, - 5 3.50849978423875E-11,-5.83007187954202E-12, 2.04644828753326E-13, - 6 1.10529179476742E-13,-2.87724778038775E-14, 2.88205111009939E-15/ - DATA BB(1), BB(2), BB(3), BB(4), BB(5), BB(6), - 1 BB(7), BB(8), BB(9), BB(10), BB(11), BB(12), - 2 BB(13), BB(14) /-4.90275424742791E-01,-1.57647277946204E-03, - 3 9.66195963140306E-05,-1.35916080268815E-07,-2.98157342654859E-07, - 4 1.86824767559979E-08, 1.03685737667141E-09,-3.28660818434328E-10, - 5 2.57091410632780E-11, 2.32357655300677E-12,-9.57523279048255E-13, - 6 1.20340828049719E-13, 2.90907716770715E-15,-4.55656454580149E-15/ - DATA DBK1(1), DBK1(2), DBK1(3), DBK1(4), DBK1(5), DBK1(6), - 1 DBK1(7), DBK1(8), DBK1(9), DBK1(10),DBK1(11),DBK1(12), - 2 DBK1(13),DBK1(14),DBK1(15),DBK1(16),DBK1(17),DBK1(18), - 3 DBK1(19),DBK1(20), - 4 DBK1(21) / 2.95926143981893E+00, 3.86774568440103E+00, - 5 1.80441072356289E+00, 5.78070764125328E-01, 1.63011468174708E-01, - 6 3.92044409961855E-02, 7.90964210433812E-03, 1.50640863167338E-03, - 7 2.56651976920042E-04, 3.93826605867715E-05, 5.81097771463818E-06, - 8 7.86881233754659E-07, 9.93272957325739E-08, 1.21424205575107E-08, - 9 1.38528332697707E-09, 1.50190067586758E-10, 1.58271945457594E-11, - 1 1.57531847699042E-12, 1.50774055398181E-13, 1.40594335806564E-14, - 2 1.24942698777218E-15/ - DATA DBK2(1), DBK2(2), DBK2(3), DBK2(4), DBK2(5), DBK2(6), - 1 DBK2(7), DBK2(8), DBK2(9), DBK2(10),DBK2(11),DBK2(12), - 2 DBK2(13),DBK2(14),DBK2(15),DBK2(16),DBK2(17),DBK2(18), - 3 DBK2(19),DBK2(20)/ 5.49756809432471E-01, 9.13556983276901E-03, - 4-2.53635048605507E-03, 6.60423795342054E-04,-1.55217243135416E-04, - 5 3.00090325448633E-05,-3.76454339467348E-06,-1.33291331611616E-07, - 6 2.42587371049013E-07,-8.07861075240228E-08, 1.71092818861193E-08, - 7-2.41087357570599E-09, 1.53910848162371E-10, 2.56465373190630E-11, - 8-9.88581911653212E-12, 1.60877986412631E-12,-1.20952524741739E-13, - 9-1.06978278410820E-14, 5.02478557067561E-15,-8.68986130935886E-16/ - DATA DBK3(1), DBK3(2), DBK3(3), DBK3(4), DBK3(5), DBK3(6), - 1 DBK3(7), DBK3(8), DBK3(9), DBK3(10),DBK3(11),DBK3(12), - 2 DBK3(13),DBK3(14),DBK3(15),DBK3(16),DBK3(17),DBK3(18), - 3 DBK3(19),DBK3(20)/ 5.60598509354302E-01,-3.64870013248135E-03, - 4-5.98147152307417E-05,-2.33611595253625E-06,-1.64571516521436E-07, - 5-2.06333012920569E-08,-4.27745431573110E-09,-1.08494137799276E-09, - 6-2.37207188872763E-10,-2.22132920864966E-11, 1.07238008032138E-11, - 7 5.71954845245808E-12, 7.51102737777835E-13,-3.81912369483793E-13, - 8-1.75870057119257E-13, 6.69641694419084E-15, 2.26866724792055E-14, - 9 2.69898141356743E-15,-2.67133612397359E-15,-6.54121403165269E-16/ - DATA DBK4(1), DBK4(2), DBK4(3), DBK4(4), DBK4(5), DBK4(6), - 1 DBK4(7), DBK4(8), DBK4(9), DBK4(10),DBK4(11),DBK4(12), - 2 DBK4(13),DBK4(14)/ 4.93072999188036E-01, 4.38335419803815E-03, - 3-8.37413882246205E-05, 3.20268810484632E-06,-1.75661979548270E-07, - 4 1.22269906524508E-08,-1.01381314366052E-09, 9.63639784237475E-11, - 5-1.02344993379648E-11, 1.19264576554355E-12,-1.50443899103287E-13, - 6 2.03299052379349E-14,-2.91890652008292E-15, 4.42322081975475E-16/ - DATA DBJP(1), DBJP(2), DBJP(3), DBJP(4), DBJP(5), DBJP(6), - 1 DBJP(7), DBJP(8), DBJP(9), DBJP(10),DBJP(11),DBJP(12), - 2 DBJP(13),DBJP(14),DBJP(15),DBJP(16),DBJP(17),DBJP(18), - 3 DBJP(19) / 1.13140872390745E-01,-2.08301511416328E-01, - 4 1.69396341953138E-02, 2.90895212478621E-02,-3.41467131311549E-03, - 5-1.46455339197417E-03, 1.63313272898517E-04, 3.91145328922162E-05, - 6-3.96757190808119E-06,-6.51846913772395E-07, 5.98707495269280E-08, - 7 7.44108654536549E-09,-6.21241056522632E-10,-6.18768017313526E-11, - 8 4.72323484752324E-12, 3.91652459802532E-13,-2.74985937845226E-14, - 9-1.95036497762750E-15, 1.26669643809444E-16/ - DATA DBJN(1), DBJN(2), DBJN(3), DBJN(4), DBJN(5), DBJN(6), - 1 DBJN(7), DBJN(8), DBJN(9), DBJN(10),DBJN(11),DBJN(12), - 2 DBJN(13),DBJN(14),DBJN(15),DBJN(16),DBJN(17),DBJN(18), - 3 DBJN(19) /-1.88091260068850E-02,-1.47798180826140E-01, - 4 5.46075900433171E-01, 1.52146932663116E-01,-9.58260412266886E-02, - 5-1.63102731696130E-02, 5.75364806680105E-03, 7.12145408252655E-04, - 6-1.75452116846724E-04,-1.71063171685128E-05, 3.24435580631680E-06, - 7 2.61190663932884E-07,-4.03026865912779E-08,-2.76435165853895E-09, - 8 3.59687929062312E-10, 2.14953308456051E-11,-2.41849311903901E-12, - 9-1.28068004920751E-13, 1.26939834401773E-14/ - DATA DAA(1), DAA(2), DAA(3), DAA(4), DAA(5), DAA(6), - 1 DAA(7), DAA(8), DAA(9), DAA(10), DAA(11), DAA(12), - 2 DAA(13), DAA(14)/ 2.77571356944231E-01,-4.44212833419920E-03, - 3 8.42328522190089E-05, 2.58040318418710E-06,-3.42389720217621E-07, - 4 6.24286894709776E-09, 2.36377836844577E-09,-3.16991042656673E-10, - 5 4.40995691658191E-12, 5.18674221093575E-12,-9.64874015137022E-13, - 6 4.90190576608710E-14, 1.77253430678112E-14,-5.55950610442662E-15/ - DATA DBB(1), DBB(2), DBB(3), DBB(4), DBB(5), DBB(6), - 1 DBB(7), DBB(8), DBB(9), DBB(10), DBB(11), DBB(12), - 2 DBB(13), DBB(14)/ 4.91627321104601E-01, 3.11164930427489E-03, - 3 8.23140762854081E-05,-4.61769776172142E-06,-6.13158880534626E-08, - 4 2.87295804656520E-08,-1.81959715372117E-09,-1.44752826642035E-10, - 5 4.53724043420422E-11,-3.99655065847223E-12,-3.24089119830323E-13, - 6 1.62098952568741E-13,-2.40765247974057E-14, 1.69384811284491E-16/ -C***FIRST EXECUTABLE STATEMENT YAIRY - AX = ABS(X) - RX = SQRT(AX) - C = CON1*AX*RX - IF (X.LT.0.0E0) GO TO 120 - IF (C.GT.8.0E0) GO TO 60 - IF (X.GT.2.5E0) GO TO 30 - T = (X+X-2.5E0)*0.4E0 - TT = T + T - J = N1 - F1 = BK1(J) - F2 = 0.0E0 - DO 10 I=1,M1 - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + BK1(J) - F2 = TEMP1 - 10 CONTINUE - BI = T*F1 - F2 + BK1(1) - J = N1D - F1 = DBK1(J) - F2 = 0.0E0 - DO 20 I=1,M1D - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + DBK1(J) - F2 = TEMP1 - 20 CONTINUE - DBI = T*F1 - F2 + DBK1(1) - RETURN - 30 CONTINUE - RTRX = SQRT(RX) - T = (X+X-CON2)*CON3 - TT = T + T - J = N1 - F1 = BK2(J) - F2 = 0.0E0 - DO 40 I=1,M1 - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + BK2(J) - F2 = TEMP1 - 40 CONTINUE - BI = (T*F1-F2+BK2(1))/RTRX - EX = EXP(C) - BI = BI*EX - J = N2D - F1 = DBK2(J) - F2 = 0.0E0 - DO 50 I=1,M2D - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + DBK2(J) - F2 = TEMP1 - 50 CONTINUE - DBI = (T*F1-F2+DBK2(1))*RTRX - DBI = DBI*EX - RETURN -C - 60 CONTINUE - RTRX = SQRT(RX) - T = 16.0E0/C - 1.0E0 - TT = T + T - J = N1 - F1 = BK3(J) - F2 = 0.0E0 - DO 70 I=1,M1 - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + BK3(J) - F2 = TEMP1 - 70 CONTINUE - S1 = T*F1 - F2 + BK3(1) - J = N2D - F1 = DBK3(J) - F2 = 0.0E0 - DO 80 I=1,M2D - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + DBK3(J) - F2 = TEMP1 - 80 CONTINUE - D1 = T*F1 - F2 + DBK3(1) - TC = C + C - EX = EXP(C) - IF (TC.GT.35.0E0) GO TO 110 - T = 10.0E0/C - 1.0E0 - TT = T + T - J = N3 - F1 = BK4(J) - F2 = 0.0E0 - DO 90 I=1,M3 - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + BK4(J) - F2 = TEMP1 - 90 CONTINUE - S2 = T*F1 - F2 + BK4(1) - BI = (S1+EXP(-TC)*S2)/RTRX - BI = BI*EX - J = N4D - F1 = DBK4(J) - F2 = 0.0E0 - DO 100 I=1,M4D - J = J - 1 - TEMP1 = F1 - F1 = TT*F1 - F2 + DBK4(J) - F2 = TEMP1 - 100 CONTINUE - D2 = T*F1 - F2 + DBK4(1) - DBI = RTRX*(D1+EXP(-TC)*D2) - DBI = DBI*EX - RETURN - 110 BI = EX*S1/RTRX - DBI = EX*RTRX*D1 - RETURN -C - 120 CONTINUE - IF (C.GT.5.0E0) GO TO 150 - T = 0.4E0*C - 1.0E0 - TT = T + T - J = N2 - F1 = BJP(J) - E1 = BJN(J) - F2 = 0.0E0 - E2 = 0.0E0 - DO 130 I=1,M2 - J = J - 1 - TEMP1 = F1 - TEMP2 = E1 - F1 = TT*F1 - F2 + BJP(J) - E1 = TT*E1 - E2 + BJN(J) - F2 = TEMP1 - E2 = TEMP2 - 130 CONTINUE - BI = (T*E1-E2+BJN(1)) - AX*(T*F1-F2+BJP(1)) - J = N3D - F1 = DBJP(J) - E1 = DBJN(J) - F2 = 0.0E0 - E2 = 0.0E0 - DO 140 I=1,M3D - J = J - 1 - TEMP1 = F1 - TEMP2 = E1 - F1 = TT*F1 - F2 + DBJP(J) - E1 = TT*E1 - E2 + DBJN(J) - F2 = TEMP1 - E2 = TEMP2 - 140 CONTINUE - DBI = X*X*(T*F1-F2+DBJP(1)) + (T*E1-E2+DBJN(1)) - RETURN -C - 150 CONTINUE - RTRX = SQRT(RX) - T = 10.0E0/C - 1.0E0 - TT = T + T - J = N3 - F1 = AA(J) - E1 = BB(J) - F2 = 0.0E0 - E2 = 0.0E0 - DO 160 I=1,M3 - J = J - 1 - TEMP1 = F1 - TEMP2 = E1 - F1 = TT*F1 - F2 + AA(J) - E1 = TT*E1 - E2 + BB(J) - F2 = TEMP1 - E2 = TEMP2 - 160 CONTINUE - TEMP1 = T*F1 - F2 + AA(1) - TEMP2 = T*E1 - E2 + BB(1) - CV = C - FPI12 - BI = (TEMP1*COS(CV)+TEMP2*SIN(CV))/RTRX - J = N4D - F1 = DAA(J) - E1 = DBB(J) - F2 = 0.0E0 - E2 = 0.0E0 - DO 170 I=1,M4D - J = J - 1 - TEMP1 = F1 - TEMP2 = E1 - F1 = TT*F1 - F2 + DAA(J) - E1 = TT*E1 - E2 + DBB(J) - F2 = TEMP1 - E2 = TEMP2 - 170 CONTINUE - TEMP1 = T*F1 - F2 + DAA(1) - TEMP2 = T*E1 - E2 + DBB(1) - CV = C - SPI12 - DBI = (TEMP1*COS(CV)-TEMP2*SIN(CV))*RTRX - RETURN - END diff --git a/slatec/zabs.f b/slatec/zabs.f deleted file mode 100644 index 67a6153..0000000 --- a/slatec/zabs.f +++ /dev/null @@ -1,41 +0,0 @@ -*DECK ZABS - DOUBLE PRECISION FUNCTION ZABS (ZR, ZI) -C***BEGIN PROLOGUE ZABS -C***SUBSIDIARY -C***PURPOSE Subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and -C ZBIRY -C***LIBRARY SLATEC -C***TYPE ALL (ZABS-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C ZABS COMPUTES THE ABSOLUTE VALUE OR MAGNITUDE OF A DOUBLE -C PRECISION COMPLEX VARIABLE CMPLX(ZR,ZI) -C -C***SEE ALSO ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZBIRY -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE ZABS - DOUBLE PRECISION ZR, ZI, U, V, Q, S -C***FIRST EXECUTABLE STATEMENT ZABS - U = ABS(ZR) - V = ABS(ZI) - S = U + V -C----------------------------------------------------------------------- -C S*1.0D0 MAKES AN UNNORMALIZED UNDERFLOW ON CDC MACHINES INTO A -C TRUE FLOATING ZERO -C----------------------------------------------------------------------- - S = S*1.0D+0 - IF (S.EQ.0.0D+0) GO TO 20 - IF (U.GT.V) GO TO 10 - Q = U/V - ZABS = V*SQRT(1.D+0+Q*Q) - RETURN - 10 Q = V/U - ZABS = U*SQRT(1.D+0+Q*Q) - RETURN - 20 ZABS = 0.0D+0 - RETURN - END diff --git a/slatec/zacai.f b/slatec/zacai.f deleted file mode 100644 index 05208a7..0000000 --- a/slatec/zacai.f +++ /dev/null @@ -1,111 +0,0 @@ -*DECK ZACAI - SUBROUTINE ZACAI (ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, TOL, - + ELIM, ALIM) -C***BEGIN PROLOGUE ZACAI -C***SUBSIDIARY -C***PURPOSE Subsidiary to ZAIRY -C***LIBRARY SLATEC -C***TYPE ALL (CACAI-A, ZACAI-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C ZACAI APPLIES THE ANALYTIC CONTINUATION FORMULA -C -C K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) -C MP=PI*MR*CMPLX(0.0,1.0) -C -C TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT -C HALF Z PLANE FOR USE WITH ZAIRY WHERE FNU=1/3 OR 2/3 AND N=1. -C ZACAI IS THE SAME AS ZACON WITH THE PARTS FOR LARGER ORDERS AND -C RECURRENCE REMOVED. A RECURSIVE CALL TO ZACON CAN RESULT IF ZACON -C IS CALLED FROM ZAIRY. -C -C***SEE ALSO ZAIRY -C***ROUTINES CALLED D1MACH, ZABS, ZASYI, ZBKNU, ZMLRI, ZS1S2, ZSERI -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE ZACAI -C COMPLEX CSGN,CSPN,C1,C2,Y,Z,ZN,CY - DOUBLE PRECISION ALIM, ARG, ASCLE, AZ, CSGNR, CSGNI, CSPNR, - * CSPNI, C1R, C1I, C2R, C2I, CYR, CYI, DFNU, ELIM, FMR, FNU, PI, - * RL, SGN, TOL, YY, YR, YI, ZR, ZI, ZNR, ZNI, D1MACH, ZABS - INTEGER INU, IUF, KODE, MR, N, NN, NW, NZ - DIMENSION YR(N), YI(N), CYR(2), CYI(2) - EXTERNAL ZABS - DATA PI / 3.14159265358979324D0 / -C***FIRST EXECUTABLE STATEMENT ZACAI - NZ = 0 - ZNR = -ZR - ZNI = -ZI - AZ = ZABS(ZR,ZI) - NN = N - DFNU = FNU + (N-1) - IF (AZ.LE.2.0D0) GO TO 10 - IF (AZ*AZ*0.25D0.GT.DFNU+1.0D0) GO TO 20 - 10 CONTINUE -C----------------------------------------------------------------------- -C POWER SERIES FOR THE I FUNCTION -C----------------------------------------------------------------------- - CALL ZSERI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, TOL, ELIM, ALIM) - GO TO 40 - 20 CONTINUE - IF (AZ.LT.RL) GO TO 30 -C----------------------------------------------------------------------- -C ASYMPTOTIC EXPANSION FOR LARGE Z FOR THE I FUNCTION -C----------------------------------------------------------------------- - CALL ZASYI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, RL, TOL, ELIM, - * ALIM) - IF (NW.LT.0) GO TO 80 - GO TO 40 - 30 CONTINUE -C----------------------------------------------------------------------- -C MILLER ALGORITHM NORMALIZED BY THE SERIES FOR THE I FUNCTION -C----------------------------------------------------------------------- - CALL ZMLRI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, TOL) - IF(NW.LT.0) GO TO 80 - 40 CONTINUE -C----------------------------------------------------------------------- -C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION -C----------------------------------------------------------------------- - CALL ZBKNU(ZNR, ZNI, FNU, KODE, 1, CYR, CYI, NW, TOL, ELIM, ALIM) - IF (NW.NE.0) GO TO 80 - FMR = MR - SGN = -DSIGN(PI,FMR) - CSGNR = 0.0D0 - CSGNI = SGN - IF (KODE.EQ.1) GO TO 50 - YY = -ZNI - CSGNR = -CSGNI*SIN(YY) - CSGNI = CSGNI*COS(YY) - 50 CONTINUE -C----------------------------------------------------------------------- -C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE -C WHEN FNU IS LARGE -C----------------------------------------------------------------------- - INU = FNU - ARG = (FNU-INU)*SGN - CSPNR = COS(ARG) - CSPNI = SIN(ARG) - IF (MOD(INU,2).EQ.0) GO TO 60 - CSPNR = -CSPNR - CSPNI = -CSPNI - 60 CONTINUE - C1R = CYR(1) - C1I = CYI(1) - C2R = YR(1) - C2I = YI(1) - IF (KODE.EQ.1) GO TO 70 - IUF = 0 - ASCLE = 1.0D+3*D1MACH(1)/TOL - CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) - NZ = NZ + NW - 70 CONTINUE - YR(1) = CSPNR*C1R - CSPNI*C1I + CSGNR*C2R - CSGNI*C2I - YI(1) = CSPNR*C1I + CSPNI*C1R + CSGNR*C2I + CSGNI*C2R - RETURN - 80 CONTINUE - NZ = -1 - IF(NW.EQ.(-2)) NZ=-2 - RETURN - END diff --git a/slatec/zacon.f b/slatec/zacon.f deleted file mode 100644 index 6c2450a..0000000 --- a/slatec/zacon.f +++ /dev/null @@ -1,215 +0,0 @@ -*DECK ZACON - SUBROUTINE ZACON (ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, FNUL, - + TOL, ELIM, ALIM) -C***BEGIN PROLOGUE ZACON -C***SUBSIDIARY -C***PURPOSE Subsidiary to ZBESH and ZBESK -C***LIBRARY SLATEC -C***TYPE ALL (CACON-A, ZACON-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C ZACON APPLIES THE ANALYTIC CONTINUATION FORMULA -C -C K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) -C MP=PI*MR*CMPLX(0.0,1.0) -C -C TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT -C HALF Z PLANE -C -C***SEE ALSO ZBESH, ZBESK -C***ROUTINES CALLED D1MACH, ZABS, ZBINU, ZBKNU, ZMLT, ZS1S2 -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE ZACON -C COMPLEX CK,CONE,CSCL,CSCR,CSGN,CSPN,CY,CZERO,C1,C2,RZ,SC1,SC2,ST, -C *S1,S2,Y,Z,ZN - DOUBLE PRECISION ALIM, ARG, ASCLE, AS2, AZN, BRY, BSCLE, CKI, - * CKR, CONER, CPN, CSCL, CSCR, CSGNI, CSGNR, CSPNI, CSPNR, - * CSR, CSRR, CSSR, CYI, CYR, C1I, C1M, C1R, C2I, C2R, ELIM, FMR, - * FN, FNU, FNUL, PI, PTI, PTR, RAZN, RL, RZI, RZR, SC1I, SC1R, - * SC2I, SC2R, SGN, SPN, STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, - * YY, ZEROR, ZI, ZNI, ZNR, ZR, D1MACH, ZABS - INTEGER I, INU, IUF, KFLAG, KODE, MR, N, NN, NW, NZ - DIMENSION YR(N), YI(N), CYR(2), CYI(2), CSSR(3), CSRR(3), BRY(3) - EXTERNAL ZABS - DATA PI / 3.14159265358979324D0 / - DATA ZEROR,CONER / 0.0D0,1.0D0 / -C***FIRST EXECUTABLE STATEMENT ZACON - NZ = 0 - ZNR = -ZR - ZNI = -ZI - NN = N - CALL ZBINU(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, RL, FNUL, TOL, - * ELIM, ALIM) - IF (NW.LT.0) GO TO 90 -C----------------------------------------------------------------------- -C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION -C----------------------------------------------------------------------- - NN = MIN(2,N) - CALL ZBKNU(ZNR, ZNI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM) - IF (NW.NE.0) GO TO 90 - S1R = CYR(1) - S1I = CYI(1) - FMR = MR - SGN = -DSIGN(PI,FMR) - CSGNR = ZEROR - CSGNI = SGN - IF (KODE.EQ.1) GO TO 10 - YY = -ZNI - CPN = COS(YY) - SPN = SIN(YY) - CALL ZMLT(CSGNR, CSGNI, CPN, SPN, CSGNR, CSGNI) - 10 CONTINUE -C----------------------------------------------------------------------- -C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE -C WHEN FNU IS LARGE -C----------------------------------------------------------------------- - INU = FNU - ARG = (FNU-INU)*SGN - CPN = COS(ARG) - SPN = SIN(ARG) - CSPNR = CPN - CSPNI = SPN - IF (MOD(INU,2).EQ.0) GO TO 20 - CSPNR = -CSPNR - CSPNI = -CSPNI - 20 CONTINUE - IUF = 0 - C1R = S1R - C1I = S1I - C2R = YR(1) - C2I = YI(1) - ASCLE = 1.0D+3*D1MACH(1)/TOL - IF (KODE.EQ.1) GO TO 30 - CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) - NZ = NZ + NW - SC1R = C1R - SC1I = C1I - 30 CONTINUE - CALL ZMLT(CSPNR, CSPNI, C1R, C1I, STR, STI) - CALL ZMLT(CSGNR, CSGNI, C2R, C2I, PTR, PTI) - YR(1) = STR + PTR - YI(1) = STI + PTI - IF (N.EQ.1) RETURN - CSPNR = -CSPNR - CSPNI = -CSPNI - S2R = CYR(2) - S2I = CYI(2) - C1R = S2R - C1I = S2I - C2R = YR(2) - C2I = YI(2) - IF (KODE.EQ.1) GO TO 40 - CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) - NZ = NZ + NW - SC2R = C1R - SC2I = C1I - 40 CONTINUE - CALL ZMLT(CSPNR, CSPNI, C1R, C1I, STR, STI) - CALL ZMLT(CSGNR, CSGNI, C2R, C2I, PTR, PTI) - YR(2) = STR + PTR - YI(2) = STI + PTI - IF (N.EQ.2) RETURN - CSPNR = -CSPNR - CSPNI = -CSPNI - AZN = ZABS(ZNR,ZNI) - RAZN = 1.0D0/AZN - STR = ZNR*RAZN - STI = -ZNI*RAZN - RZR = (STR+STR)*RAZN - RZI = (STI+STI)*RAZN - FN = FNU + 1.0D0 - CKR = FN*RZR - CKI = FN*RZI -C----------------------------------------------------------------------- -C SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON K FUNCTIONS -C----------------------------------------------------------------------- - CSCL = 1.0D0/TOL - CSCR = TOL - CSSR(1) = CSCL - CSSR(2) = CONER - CSSR(3) = CSCR - CSRR(1) = CSCR - CSRR(2) = CONER - CSRR(3) = CSCL - BRY(1) = ASCLE - BRY(2) = 1.0D0/ASCLE - BRY(3) = D1MACH(2) - AS2 = ZABS(S2R,S2I) - KFLAG = 2 - IF (AS2.GT.BRY(1)) GO TO 50 - KFLAG = 1 - GO TO 60 - 50 CONTINUE - IF (AS2.LT.BRY(2)) GO TO 60 - KFLAG = 3 - 60 CONTINUE - BSCLE = BRY(KFLAG) - S1R = S1R*CSSR(KFLAG) - S1I = S1I*CSSR(KFLAG) - S2R = S2R*CSSR(KFLAG) - S2I = S2I*CSSR(KFLAG) - CSR = CSRR(KFLAG) - DO 80 I=3,N - STR = S2R - STI = S2I - S2R = CKR*STR - CKI*STI + S1R - S2I = CKR*STI + CKI*STR + S1I - S1R = STR - S1I = STI - C1R = S2R*CSR - C1I = S2I*CSR - STR = C1R - STI = C1I - C2R = YR(I) - C2I = YI(I) - IF (KODE.EQ.1) GO TO 70 - IF (IUF.LT.0) GO TO 70 - CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) - NZ = NZ + NW - SC1R = SC2R - SC1I = SC2I - SC2R = C1R - SC2I = C1I - IF (IUF.NE.3) GO TO 70 - IUF = -4 - S1R = SC1R*CSSR(KFLAG) - S1I = SC1I*CSSR(KFLAG) - S2R = SC2R*CSSR(KFLAG) - S2I = SC2I*CSSR(KFLAG) - STR = SC2R - STI = SC2I - 70 CONTINUE - PTR = CSPNR*C1R - CSPNI*C1I - PTI = CSPNR*C1I + CSPNI*C1R - YR(I) = PTR + CSGNR*C2R - CSGNI*C2I - YI(I) = PTI + CSGNR*C2I + CSGNI*C2R - CKR = CKR + RZR - CKI = CKI + RZI - CSPNR = -CSPNR - CSPNI = -CSPNI - IF (KFLAG.GE.3) GO TO 80 - PTR = ABS(C1R) - PTI = ABS(C1I) - C1M = MAX(PTR,PTI) - IF (C1M.LE.BSCLE) GO TO 80 - KFLAG = KFLAG + 1 - BSCLE = BRY(KFLAG) - S1R = S1R*CSR - S1I = S1I*CSR - S2R = STR - S2I = STI - S1R = S1R*CSSR(KFLAG) - S1I = S1I*CSSR(KFLAG) - S2R = S2R*CSSR(KFLAG) - S2I = S2I*CSSR(KFLAG) - CSR = CSRR(KFLAG) - 80 CONTINUE - RETURN - 90 CONTINUE - NZ = -1 - IF(NW.EQ.(-2)) NZ=-2 - RETURN - END diff --git a/slatec/zairy.f b/slatec/zairy.f deleted file mode 100644 index 435df5d..0000000 --- a/slatec/zairy.f +++ /dev/null @@ -1,404 +0,0 @@ -*DECK ZAIRY - SUBROUTINE ZAIRY (ZR, ZI, ID, KODE, AIR, AII, NZ, IERR) -C***BEGIN PROLOGUE ZAIRY -C***PURPOSE Compute the Airy function Ai(z) or its derivative dAi/dz -C for complex argument z. A scaling option is available -C to help avoid underflow and overflow. -C***LIBRARY SLATEC -C***CATEGORY C10D -C***TYPE COMPLEX (CAIRY-C, ZAIRY-C) -C***KEYWORDS AIRY FUNCTION, BESSEL FUNCTION OF ORDER ONE THIRD, -C BESSEL FUNCTION OF ORDER TWO THIRDS -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C ***A DOUBLE PRECISION ROUTINE*** -C On KODE=1, ZAIRY computes the complex Airy function Ai(z) -C or its derivative dAi/dz on ID=0 or ID=1 respectively. On -C KODE=2, a scaling option exp(zeta)*Ai(z) or exp(zeta)*dAi/dz -C is provided to remove the exponential decay in -pi/31 and from power series when abs(z)<=1. -C -C In most complex variable computation, one must evaluate ele- -C mentary functions. When the magnitude of Z is large, losses -C of significance by argument reduction occur. Consequently, if -C the magnitude of ZETA=(2/3)*Z**(3/2) exceeds U1=SQRT(0.5/UR), -C then losses exceeding half precision are likely and an error -C flag IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is -C double precision unit roundoff limited to 18 digits precision. -C Also, if the magnitude of ZETA is larger than U2=0.5/UR, then -C all significance is lost and IERR=4. In order to use the INT -C function, ZETA must be further restricted not to exceed -C U3=I1MACH(9)=LARGEST INTEGER. Thus, the magnitude of ZETA -C must be restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, -C and U3 are approximately 2.0E+3, 4.2E+6, 2.1E+9 in single -C precision and 4.7E+7, 2.3E+15, 2.1E+9 in double precision. -C This makes U2 limiting is single precision and U3 limiting -C in double precision. This means that the magnitude of Z -C cannot exceed approximately 3.4E+4 in single precision and -C 2.1E+6 in double precision. This also means that one can -C expect to retain, in the worst cases on 32-bit machines, -C no digits in single precision and only 6 digits in double -C precision. -C -C The approximate relative error in the magnitude of a complex -C Bessel function can be expressed as P*10**S where P=MAX(UNIT -C ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- -C sents the increase in error due to argument reduction in the -C elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), -C ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF -C ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may -C have only absolute accuracy. This is most likely to occur -C when one component (in magnitude) is larger than the other by -C several orders of magnitude. If one component is 10**K larger -C than the other, then one can expect only MAX(ABS(LOG10(P))-K, -C 0) significant digits; or, stated another way, when K exceeds -C the exponent of P, no significant digits remain in the smaller -C component. However, the phase angle retains absolute accuracy -C because, in complex arithmetic with precision P, the smaller -C component will not (as a rule) decrease below P times the -C magnitude of the larger component. In these extreme cases, -C the principal phase angle is on the order of +P, -P, PI/2-P, -C or -PI/2+P. -C -C***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- -C matical Functions, National Bureau of Standards -C Applied Mathematics Series 55, U. S. Department -C of Commerce, Tenth Printing (1972) or later. -C 2. D. E. Amos, Computation of Bessel Functions of -C Complex Argument and Large Order, Report SAND83-0643, -C Sandia National Laboratories, Albuquerque, NM, May -C 1983. -C 3. D. E. Amos, A Subroutine Package for Bessel Functions -C of a Complex Argument and Nonnegative Order, Report -C SAND85-1018, Sandia National Laboratory, Albuquerque, -C NM, May 1985. -C 4. D. E. Amos, A portable package for Bessel functions -C of a complex argument and nonnegative order, ACM -C Transactions on Mathematical Software, 12 (September -C 1986), pp. 265-273. -C -C***ROUTINES CALLED D1MACH, I1MACH, ZABS, ZACAI, ZBKNU, ZEXP, ZSQRT -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 890801 REVISION DATE from Version 3.2 -C 910415 Prologue converted to Version 4.0 format. (BAB) -C 920128 Category corrected. (WRB) -C 920811 Prologue revised. (DWL) -C 930122 Added ZEXP and ZSQRT to EXTERNAL statement. (RWC) -C***END PROLOGUE ZAIRY -C COMPLEX AI,CONE,CSQ,CY,S1,S2,TRM1,TRM2,Z,ZTA,Z3 - DOUBLE PRECISION AA, AD, AII, AIR, AK, ALIM, ATRM, AZ, AZ3, BK, - * CC, CK, COEF, CONEI, CONER, CSQI, CSQR, CYI, CYR, C1, C2, DIG, - * DK, D1, D2, ELIM, FID, FNU, PTR, RL, R1M5, SFAC, STI, STR, - * S1I, S1R, S2I, S2R, TOL, TRM1I, TRM1R, TRM2I, TRM2R, TTH, ZEROI, - * ZEROR, ZI, ZR, ZTAI, ZTAR, Z3I, Z3R, D1MACH, ZABS, ALAZ, BB - INTEGER ID, IERR, IFLAG, K, KODE, K1, K2, MR, NN, NZ, I1MACH - DIMENSION CYR(1), CYI(1) - EXTERNAL ZABS, ZEXP, ZSQRT - DATA TTH, C1, C2, COEF /6.66666666666666667D-01, - * 3.55028053887817240D-01,2.58819403792806799D-01, - * 1.83776298473930683D-01/ - DATA ZEROR, ZEROI, CONER, CONEI /0.0D0,0.0D0,1.0D0,0.0D0/ -C***FIRST EXECUTABLE STATEMENT ZAIRY - IERR = 0 - NZ=0 - IF (ID.LT.0 .OR. ID.GT.1) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (IERR.NE.0) RETURN - AZ = ZABS(ZR,ZI) - TOL = MAX(D1MACH(4),1.0D-18) - FID = ID - IF (AZ.GT.1.0D0) GO TO 70 -C----------------------------------------------------------------------- -C POWER SERIES FOR ABS(Z).LE.1. -C----------------------------------------------------------------------- - S1R = CONER - S1I = CONEI - S2R = CONER - S2I = CONEI - IF (AZ.LT.TOL) GO TO 170 - AA = AZ*AZ - IF (AA.LT.TOL/AZ) GO TO 40 - TRM1R = CONER - TRM1I = CONEI - TRM2R = CONER - TRM2I = CONEI - ATRM = 1.0D0 - STR = ZR*ZR - ZI*ZI - STI = ZR*ZI + ZI*ZR - Z3R = STR*ZR - STI*ZI - Z3I = STR*ZI + STI*ZR - AZ3 = AZ*AA - AK = 2.0D0 + FID - BK = 3.0D0 - FID - FID - CK = 4.0D0 - FID - DK = 3.0D0 + FID + FID - D1 = AK*DK - D2 = BK*CK - AD = MIN(D1,D2) - AK = 24.0D0 + 9.0D0*FID - BK = 30.0D0 - 9.0D0*FID - DO 30 K=1,25 - STR = (TRM1R*Z3R-TRM1I*Z3I)/D1 - TRM1I = (TRM1R*Z3I+TRM1I*Z3R)/D1 - TRM1R = STR - S1R = S1R + TRM1R - S1I = S1I + TRM1I - STR = (TRM2R*Z3R-TRM2I*Z3I)/D2 - TRM2I = (TRM2R*Z3I+TRM2I*Z3R)/D2 - TRM2R = STR - S2R = S2R + TRM2R - S2I = S2I + TRM2I - ATRM = ATRM*AZ3/AD - D1 = D1 + AK - D2 = D2 + BK - AD = MIN(D1,D2) - IF (ATRM.LT.TOL*AD) GO TO 40 - AK = AK + 18.0D0 - BK = BK + 18.0D0 - 30 CONTINUE - 40 CONTINUE - IF (ID.EQ.1) GO TO 50 - AIR = S1R*C1 - C2*(ZR*S2R-ZI*S2I) - AII = S1I*C1 - C2*(ZR*S2I+ZI*S2R) - IF (KODE.EQ.1) RETURN - CALL ZSQRT(ZR, ZI, STR, STI) - ZTAR = TTH*(ZR*STR-ZI*STI) - ZTAI = TTH*(ZR*STI+ZI*STR) - CALL ZEXP(ZTAR, ZTAI, STR, STI) - PTR = AIR*STR - AII*STI - AII = AIR*STI + AII*STR - AIR = PTR - RETURN - 50 CONTINUE - AIR = -S2R*C2 - AII = -S2I*C2 - IF (AZ.LE.TOL) GO TO 60 - STR = ZR*S1R - ZI*S1I - STI = ZR*S1I + ZI*S1R - CC = C1/(1.0D0+FID) - AIR = AIR + CC*(STR*ZR-STI*ZI) - AII = AII + CC*(STR*ZI+STI*ZR) - 60 CONTINUE - IF (KODE.EQ.1) RETURN - CALL ZSQRT(ZR, ZI, STR, STI) - ZTAR = TTH*(ZR*STR-ZI*STI) - ZTAI = TTH*(ZR*STI+ZI*STR) - CALL ZEXP(ZTAR, ZTAI, STR, STI) - PTR = STR*AIR - STI*AII - AII = STR*AII + STI*AIR - AIR = PTR - RETURN -C----------------------------------------------------------------------- -C CASE FOR ABS(Z).GT.1.0 -C----------------------------------------------------------------------- - 70 CONTINUE - FNU = (1.0D0+FID)/3.0D0 -C----------------------------------------------------------------------- -C SET PARAMETERS RELATED TO MACHINE CONSTANTS. -C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0D-18. -C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. -C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND -C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR -C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. -C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. -C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). -C----------------------------------------------------------------------- - K1 = I1MACH(15) - K2 = I1MACH(16) - R1M5 = D1MACH(5) - K = MIN(ABS(K1),ABS(K2)) - ELIM = 2.303D0*(K*R1M5-3.0D0) - K1 = I1MACH(14) - 1 - AA = R1M5*K1 - DIG = MIN(AA,18.0D0) - AA = AA*2.303D0 - ALIM = ELIM + MAX(-AA,-41.45D0) - RL = 1.2D0*DIG + 3.0D0 - ALAZ = LOG(AZ) -C----------------------------------------------------------------------- -C TEST FOR PROPER RANGE -C----------------------------------------------------------------------- - AA=0.5D0/TOL - BB=I1MACH(9)*0.5D0 - AA=MIN(AA,BB) - AA=AA**TTH - IF (AZ.GT.AA) GO TO 260 - AA=SQRT(AA) - IF (AZ.GT.AA) IERR=3 - CALL ZSQRT(ZR, ZI, CSQR, CSQI) - ZTAR = TTH*(ZR*CSQR-ZI*CSQI) - ZTAI = TTH*(ZR*CSQI+ZI*CSQR) -C----------------------------------------------------------------------- -C RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL -C----------------------------------------------------------------------- - IFLAG = 0 - SFAC = 1.0D0 - AK = ZTAI - IF (ZR.GE.0.0D0) GO TO 80 - BK = ZTAR - CK = -ABS(BK) - ZTAR = CK - ZTAI = AK - 80 CONTINUE - IF (ZI.NE.0.0D0) GO TO 90 - IF (ZR.GT.0.0D0) GO TO 90 - ZTAR = 0.0D0 - ZTAI = AK - 90 CONTINUE - AA = ZTAR - IF (AA.GE.0.0D0 .AND. ZR.GT.0.0D0) GO TO 110 - IF (KODE.EQ.2) GO TO 100 -C----------------------------------------------------------------------- -C OVERFLOW TEST -C----------------------------------------------------------------------- - IF (AA.GT.(-ALIM)) GO TO 100 - AA = -AA + 0.25D0*ALAZ - IFLAG = 1 - SFAC = TOL - IF (AA.GT.ELIM) GO TO 270 - 100 CONTINUE -C----------------------------------------------------------------------- -C CBKNU AND CACON RETURN EXP(ZTA)*K(FNU,ZTA) ON KODE=2 -C----------------------------------------------------------------------- - MR = 1 - IF (ZI.LT.0.0D0) MR = -1 - CALL ZACAI(ZTAR, ZTAI, FNU, KODE, MR, 1, CYR, CYI, NN, RL, TOL, - * ELIM, ALIM) - IF (NN.LT.0) GO TO 280 - NZ = NZ + NN - GO TO 130 - 110 CONTINUE - IF (KODE.EQ.2) GO TO 120 -C----------------------------------------------------------------------- -C UNDERFLOW TEST -C----------------------------------------------------------------------- - IF (AA.LT.ALIM) GO TO 120 - AA = -AA - 0.25D0*ALAZ - IFLAG = 2 - SFAC = 1.0D0/TOL - IF (AA.LT.(-ELIM)) GO TO 210 - 120 CONTINUE - CALL ZBKNU(ZTAR, ZTAI, FNU, KODE, 1, CYR, CYI, NZ, TOL, ELIM, - * ALIM) - 130 CONTINUE - S1R = CYR(1)*COEF - S1I = CYI(1)*COEF - IF (IFLAG.NE.0) GO TO 150 - IF (ID.EQ.1) GO TO 140 - AIR = CSQR*S1R - CSQI*S1I - AII = CSQR*S1I + CSQI*S1R - RETURN - 140 CONTINUE - AIR = -(ZR*S1R-ZI*S1I) - AII = -(ZR*S1I+ZI*S1R) - RETURN - 150 CONTINUE - S1R = S1R*SFAC - S1I = S1I*SFAC - IF (ID.EQ.1) GO TO 160 - STR = S1R*CSQR - S1I*CSQI - S1I = S1R*CSQI + S1I*CSQR - S1R = STR - AIR = S1R/SFAC - AII = S1I/SFAC - RETURN - 160 CONTINUE - STR = -(S1R*ZR-S1I*ZI) - S1I = -(S1R*ZI+S1I*ZR) - S1R = STR - AIR = S1R/SFAC - AII = S1I/SFAC - RETURN - 170 CONTINUE - AA = 1.0D+3*D1MACH(1) - S1R = ZEROR - S1I = ZEROI - IF (ID.EQ.1) GO TO 190 - IF (AZ.LE.AA) GO TO 180 - S1R = C2*ZR - S1I = C2*ZI - 180 CONTINUE - AIR = C1 - S1R - AII = -S1I - RETURN - 190 CONTINUE - AIR = -C2 - AII = 0.0D0 - AA = SQRT(AA) - IF (AZ.LE.AA) GO TO 200 - S1R = 0.5D0*(ZR*ZR-ZI*ZI) - S1I = ZR*ZI - 200 CONTINUE - AIR = AIR + C1*S1R - AII = AII + C1*S1I - RETURN - 210 CONTINUE - NZ = 1 - AIR = ZEROR - AII = ZEROI - RETURN - 270 CONTINUE - NZ = 0 - IERR=2 - RETURN - 280 CONTINUE - IF(NN.EQ.(-1)) GO TO 270 - NZ=0 - IERR=5 - RETURN - 260 CONTINUE - IERR=4 - NZ=0 - RETURN - END diff --git a/slatec/zasyi.f b/slatec/zasyi.f deleted file mode 100644 index 8ae99ff..0000000 --- a/slatec/zasyi.f +++ /dev/null @@ -1,177 +0,0 @@ -*DECK ZASYI - SUBROUTINE ZASYI (ZR, ZI, FNU, KODE, N, YR, YI, NZ, RL, TOL, ELIM, - + ALIM) -C***BEGIN PROLOGUE ZASYI -C***SUBSIDIARY -C***PURPOSE Subsidiary to ZBESI and ZBESK -C***LIBRARY SLATEC -C***TYPE ALL (CASYI-A, ZASYI-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C ZASYI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY -C MEANS OF THE ASYMPTOTIC EXPANSION FOR LARGE ABS(Z) IN THE -C REGION ABS(Z).GT.MAX(RL,FNU*FNU/2). NZ=0 IS A NORMAL RETURN. -C NZ.LT.0 INDICATES AN OVERFLOW ON KODE=1. -C -C***SEE ALSO ZBESI, ZBESK -C***ROUTINES CALLED D1MACH, ZABS, ZDIV, ZEXP, ZMLT, ZSQRT -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C 930122 Added ZEXP and ZSQRT to EXTERNAL statement. (RWC) -C***END PROLOGUE ZASYI -C COMPLEX AK1,CK,CONE,CS1,CS2,CZ,CZERO,DK,EZ,P1,RZ,S2,Y,Z - DOUBLE PRECISION AA, AEZ, AK, AK1I, AK1R, ALIM, ARG, ARM, ATOL, - * AZ, BB, BK, CKI, CKR, CONEI, CONER, CS1I, CS1R, CS2I, CS2R, CZI, - * CZR, DFNU, DKI, DKR, DNU2, ELIM, EZI, EZR, FDN, FNU, PI, P1I, - * P1R, RAZ, RL, RTPI, RTR1, RZI, RZR, S, SGN, SQK, STI, STR, S2I, - * S2R, TOL, TZI, TZR, YI, YR, ZEROI, ZEROR, ZI, ZR, D1MACH, ZABS - INTEGER I, IB, IL, INU, J, JL, K, KODE, KODED, M, N, NN, NZ - DIMENSION YR(N), YI(N) - EXTERNAL ZABS, ZEXP, ZSQRT - DATA PI, RTPI /3.14159265358979324D0 , 0.159154943091895336D0 / - DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / -C***FIRST EXECUTABLE STATEMENT ZASYI - NZ = 0 - AZ = ZABS(ZR,ZI) - ARM = 1.0D+3*D1MACH(1) - RTR1 = SQRT(ARM) - IL = MIN(2,N) - DFNU = FNU + (N-IL) -C----------------------------------------------------------------------- -C OVERFLOW TEST -C----------------------------------------------------------------------- - RAZ = 1.0D0/AZ - STR = ZR*RAZ - STI = -ZI*RAZ - AK1R = RTPI*STR*RAZ - AK1I = RTPI*STI*RAZ - CALL ZSQRT(AK1R, AK1I, AK1R, AK1I) - CZR = ZR - CZI = ZI - IF (KODE.NE.2) GO TO 10 - CZR = ZEROR - CZI = ZI - 10 CONTINUE - IF (ABS(CZR).GT.ELIM) GO TO 100 - DNU2 = DFNU + DFNU - KODED = 1 - IF ((ABS(CZR).GT.ALIM) .AND. (N.GT.2)) GO TO 20 - KODED = 0 - CALL ZEXP(CZR, CZI, STR, STI) - CALL ZMLT(AK1R, AK1I, STR, STI, AK1R, AK1I) - 20 CONTINUE - FDN = 0.0D0 - IF (DNU2.GT.RTR1) FDN = DNU2*DNU2 - EZR = ZR*8.0D0 - EZI = ZI*8.0D0 -C----------------------------------------------------------------------- -C WHEN Z IS IMAGINARY, THE ERROR TEST MUST BE MADE RELATIVE TO THE -C FIRST RECIPROCAL POWER SINCE THIS IS THE LEADING TERM OF THE -C EXPANSION FOR THE IMAGINARY PART. -C----------------------------------------------------------------------- - AEZ = 8.0D0*AZ - S = TOL/AEZ - JL = RL+RL + 2 - P1R = ZEROR - P1I = ZEROI - IF (ZI.EQ.0.0D0) GO TO 30 -C----------------------------------------------------------------------- -C CALCULATE EXP(PI*(0.5+FNU+N-IL)*I) TO MINIMIZE LOSSES OF -C SIGNIFICANCE WHEN FNU OR N IS LARGE -C----------------------------------------------------------------------- - INU = FNU - ARG = (FNU-INU)*PI - INU = INU + N - IL - AK = -SIN(ARG) - BK = COS(ARG) - IF (ZI.LT.0.0D0) BK = -BK - P1R = AK - P1I = BK - IF (MOD(INU,2).EQ.0) GO TO 30 - P1R = -P1R - P1I = -P1I - 30 CONTINUE - DO 70 K=1,IL - SQK = FDN - 1.0D0 - ATOL = S*ABS(SQK) - SGN = 1.0D0 - CS1R = CONER - CS1I = CONEI - CS2R = CONER - CS2I = CONEI - CKR = CONER - CKI = CONEI - AK = 0.0D0 - AA = 1.0D0 - BB = AEZ - DKR = EZR - DKI = EZI - DO 40 J=1,JL - CALL ZDIV(CKR, CKI, DKR, DKI, STR, STI) - CKR = STR*SQK - CKI = STI*SQK - CS2R = CS2R + CKR - CS2I = CS2I + CKI - SGN = -SGN - CS1R = CS1R + CKR*SGN - CS1I = CS1I + CKI*SGN - DKR = DKR + EZR - DKI = DKI + EZI - AA = AA*ABS(SQK)/BB - BB = BB + AEZ - AK = AK + 8.0D0 - SQK = SQK - AK - IF (AA.LE.ATOL) GO TO 50 - 40 CONTINUE - GO TO 110 - 50 CONTINUE - S2R = CS1R - S2I = CS1I - IF (ZR+ZR.GE.ELIM) GO TO 60 - TZR = ZR + ZR - TZI = ZI + ZI - CALL ZEXP(-TZR, -TZI, STR, STI) - CALL ZMLT(STR, STI, P1R, P1I, STR, STI) - CALL ZMLT(STR, STI, CS2R, CS2I, STR, STI) - S2R = S2R + STR - S2I = S2I + STI - 60 CONTINUE - FDN = FDN + 8.0D0*DFNU + 4.0D0 - P1R = -P1R - P1I = -P1I - M = N - IL + K - YR(M) = S2R*AK1R - S2I*AK1I - YI(M) = S2R*AK1I + S2I*AK1R - 70 CONTINUE - IF (N.LE.2) RETURN - NN = N - K = NN - 2 - AK = K - STR = ZR*RAZ - STI = -ZI*RAZ - RZR = (STR+STR)*RAZ - RZI = (STI+STI)*RAZ - IB = 3 - DO 80 I=IB,NN - YR(K) = (AK+FNU)*(RZR*YR(K+1)-RZI*YI(K+1)) + YR(K+2) - YI(K) = (AK+FNU)*(RZR*YI(K+1)+RZI*YR(K+1)) + YI(K+2) - AK = AK - 1.0D0 - K = K - 1 - 80 CONTINUE - IF (KODED.EQ.0) RETURN - CALL ZEXP(CZR, CZI, CKR, CKI) - DO 90 I=1,NN - STR = YR(I)*CKR - YI(I)*CKI - YI(I) = YR(I)*CKI + YI(I)*CKR - YR(I) = STR - 90 CONTINUE - RETURN - 100 CONTINUE - NZ = -1 - RETURN - 110 CONTINUE - NZ=-2 - RETURN - END diff --git a/slatec/zbesh.f b/slatec/zbesh.f deleted file mode 100644 index dfa5da9..0000000 --- a/slatec/zbesh.f +++ /dev/null @@ -1,351 +0,0 @@ -*DECK ZBESH - SUBROUTINE ZBESH (ZR, ZI, FNU, KODE, M, N, CYR, CYI, NZ, IERR) -C***BEGIN PROLOGUE ZBESH -C***PURPOSE Compute a sequence of the Hankel functions H(m,a,z) -C for superscript m=1 or 2, real nonnegative orders a=b, -C b+1,... where b>0, and nonzero complex argument z. A -C scaling option is available to help avoid overflow. -C***LIBRARY SLATEC -C***CATEGORY C10A4 -C***TYPE COMPLEX (CBESH-C, ZBESH-C) -C***KEYWORDS BESSEL FUNCTIONS OF COMPLEX ARGUMENT, -C BESSEL FUNCTIONS OF THE THIRD KIND, H BESSEL FUNCTIONS, -C HANKEL FUNCTIONS -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C ***A DOUBLE PRECISION ROUTINE*** -C On KODE=1, ZBESH computes an N member sequence of complex -C Hankel (Bessel) functions CY(L)=H(M,FNU+L-1,Z) for super- -C script M=1 or 2, real nonnegative orders FNU+L-1, L=1,..., -C N, and complex nonzero Z in the cut plane -pi=0 -C KODE - A parameter to indicate the scaling option -C KODE=1 returns -C CY(L)=H(M,FNU+L-1,Z), L=1,...,N -C =2 returns -C CY(L)=H(M,FNU+L-1,Z)*exp(-(3-2M)*Z*i), -C L=1,...,N -C M - Superscript of Hankel function, M=1 or 2 -C N - Number of terms in the sequence, N>=1 -C -C Output -C CYR - DOUBLE PRECISION real part of result vector -C CYI - DOUBLE PRECISION imag part of result vector -C NZ - Number of underflows set to zero -C NZ=0 Normal return -C NZ>0 CY(L)=0 for NZ values of L (if M=1 and -C Im(Z)>0 or if M=2 and Im(Z)<0, then -C CY(L)=0 for L=1,...,NZ; in the com- -C plementary half planes, the underflows -C may not be in an uninterrupted sequence) -C IERR - Error flag -C IERR=0 Normal return - COMPUTATION COMPLETED -C IERR=1 Input error - NO COMPUTATION -C IERR=2 Overflow - NO COMPUTATION -C (abs(Z) too small and/or FNU+N-1 -C too large) -C IERR=3 Precision warning - COMPUTATION COMPLETED -C (Result has half precision or less -C because abs(Z) or FNU+N-1 is large) -C IERR=4 Precision error - NO COMPUTATION -C (Result has no precision because -C abs(Z) or FNU+N-1 is too large) -C IERR=5 Algorithmic error - NO COMPUTATION -C (Termination condition not met) -C -C *Long Description: -C -C The computation is carried out by the formula -C -C H(m,a,z) = (1/t)*exp(-a*t)*K(a,z*exp(-t)) -C t = (3-2*m)*i*pi/2 -C -C where the K Bessel function is computed as described in the -C prologue to CBESK. -C -C Exponential decay of H(m,a,z) occurs in the upper half z -C plane for m=1 and the lower half z plane for m=2. Exponential -C growth occurs in the complementary half planes. Scaling -C by exp(-(3-2*m)*z*i) removes the exponential behavior in the -C whole z plane as z goes to infinity. -C -C For negative orders, the formula -C -C H(m,-a,z) = H(m,a,z)*exp((3-2*m)*a*pi*i) -C -C can be used. -C -C In most complex variable computation, one must evaluate ele- -C mentary functions. When the magnitude of Z or FNU+N-1 is -C large, losses of significance by argument reduction occur. -C Consequently, if either one exceeds U1=SQRT(0.5/UR), then -C losses exceeding half precision are likely and an error flag -C IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is double -C precision unit roundoff limited to 18 digits precision. Also, -C if either is larger than U2=0.5/UR, then all significance is -C lost and IERR=4. In order to use the INT function, arguments -C must be further restricted not to exceed the largest machine -C integer, U3=I1MACH(9). Thus, the magnitude of Z and FNU+N-1 -C is restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, and -C U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision -C and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision. This -C makes U2 limiting in single precision and U3 limiting in -C double precision. This means that one can expect to retain, -C in the worst cases on IEEE machines, no digits in single pre- -C cision and only 6 digits in double precision. Similar con- -C siderations hold for other machines. -C -C The approximate relative error in the magnitude of a complex -C Bessel function can be expressed as P*10**S where P=MAX(UNIT -C ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- -C sents the increase in error due to argument reduction in the -C elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), -C ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF -C ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may -C have only absolute accuracy. This is most likely to occur -C when one component (in magnitude) is larger than the other by -C several orders of magnitude. If one component is 10**K larger -C than the other, then one can expect only MAX(ABS(LOG10(P))-K, -C 0) significant digits; or, stated another way, when K exceeds -C the exponent of P, no significant digits remain in the smaller -C component. However, the phase angle retains absolute accuracy -C because, in complex arithmetic with precision P, the smaller -C component will not (as a rule) decrease below P times the -C magnitude of the larger component. In these extreme cases, -C the principal phase angle is on the order of +P, -P, PI/2-P, -C or -PI/2+P. -C -C***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- -C matical Functions, National Bureau of Standards -C Applied Mathematics Series 55, U. S. Department -C of Commerce, Tenth Printing (1972) or later. -C 2. D. E. Amos, Computation of Bessel Functions of -C Complex Argument, Report SAND83-0086, Sandia National -C Laboratories, Albuquerque, NM, May 1983. -C 3. D. E. Amos, Computation of Bessel Functions of -C Complex Argument and Large Order, Report SAND83-0643, -C Sandia National Laboratories, Albuquerque, NM, May -C 1983. -C 4. D. E. Amos, A Subroutine Package for Bessel Functions -C of a Complex Argument and Nonnegative Order, Report -C SAND85-1018, Sandia National Laboratory, Albuquerque, -C NM, May 1985. -C 5. D. E. Amos, A portable package for Bessel functions -C of a complex argument and nonnegative order, ACM -C Transactions on Mathematical Software, 12 (September -C 1986), pp. 265-273. -C -C***ROUTINES CALLED D1MACH, I1MACH, ZABS, ZACON, ZBKNU, ZBUNK, ZUOIK -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 890801 REVISION DATE from Version 3.2 -C 910415 Prologue converted to Version 4.0 format. (BAB) -C 920128 Category corrected. (WRB) -C 920811 Prologue revised. (DWL) -C***END PROLOGUE ZBESH -C -C COMPLEX CY,Z,ZN,ZT,CSGN - DOUBLE PRECISION AA, ALIM, ALN, ARG, AZ, CYI, CYR, DIG, ELIM, - * FMM, FN, FNU, FNUL, HPI, RHPI, RL, R1M5, SGN, STR, TOL, UFL, ZI, - * ZNI, ZNR, ZR, ZTI, D1MACH, ZABS, BB, ASCLE, RTOL, ATOL, STI, - * CSGNR, CSGNI - INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, M, - * MM, MR, N, NN, NUF, NW, NZ, I1MACH - DIMENSION CYR(N), CYI(N) - EXTERNAL ZABS -C - DATA HPI /1.57079632679489662D0/ -C -C***FIRST EXECUTABLE STATEMENT ZBESH - IERR = 0 - NZ=0 - IF (ZR.EQ.0.0D0 .AND. ZI.EQ.0.0D0) IERR=1 - IF (FNU.LT.0.0D0) IERR=1 - IF (M.LT.1 .OR. M.GT.2) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (N.LT.1) IERR=1 - IF (IERR.NE.0) RETURN - NN = N -C----------------------------------------------------------------------- -C SET PARAMETERS RELATED TO MACHINE CONSTANTS. -C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. -C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. -C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND -C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR -C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. -C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. -C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). -C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU -C----------------------------------------------------------------------- - TOL = MAX(D1MACH(4),1.0D-18) - K1 = I1MACH(15) - K2 = I1MACH(16) - R1M5 = D1MACH(5) - K = MIN(ABS(K1),ABS(K2)) - ELIM = 2.303D0*(K*R1M5-3.0D0) - K1 = I1MACH(14) - 1 - AA = R1M5*K1 - DIG = MIN(AA,18.0D0) - AA = AA*2.303D0 - ALIM = ELIM + MAX(-AA,-41.45D0) - FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) - RL = 1.2D0*DIG + 3.0D0 - FN = FNU + (NN-1) - MM = 3 - M - M - FMM = MM - ZNR = FMM*ZI - ZNI = -FMM*ZR -C----------------------------------------------------------------------- -C TEST FOR PROPER RANGE -C----------------------------------------------------------------------- - AZ = ZABS(ZR,ZI) - AA = 0.5D0/TOL - BB = I1MACH(9)*0.5D0 - AA = MIN(AA,BB) - IF (AZ.GT.AA) GO TO 260 - IF (FN.GT.AA) GO TO 260 - AA = SQRT(AA) - IF (AZ.GT.AA) IERR=3 - IF (FN.GT.AA) IERR=3 -C----------------------------------------------------------------------- -C OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE -C----------------------------------------------------------------------- - UFL = D1MACH(1)*1.0D+3 - IF (AZ.LT.UFL) GO TO 230 - IF (FNU.GT.FNUL) GO TO 90 - IF (FN.LE.1.0D0) GO TO 70 - IF (FN.GT.2.0D0) GO TO 60 - IF (AZ.GT.TOL) GO TO 70 - ARG = 0.5D0*AZ - ALN = -FN*LOG(ARG) - IF (ALN.GT.ELIM) GO TO 230 - GO TO 70 - 60 CONTINUE - CALL ZUOIK(ZNR, ZNI, FNU, KODE, 2, NN, CYR, CYI, NUF, TOL, ELIM, - * ALIM) - IF (NUF.LT.0) GO TO 230 - NZ = NZ + NUF - NN = NN - NUF -C----------------------------------------------------------------------- -C HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK -C IF NUF=NN, THEN CY(I)=CZERO FOR ALL I -C----------------------------------------------------------------------- - IF (NN.EQ.0) GO TO 140 - 70 CONTINUE - IF ((ZNR.LT.0.0D0) .OR. (ZNR.EQ.0.0D0 .AND. ZNI.LT.0.0D0 .AND. - * M.EQ.2)) GO TO 80 -C----------------------------------------------------------------------- -C RIGHT HALF PLANE COMPUTATION, XN.GE.0. .AND. (XN.NE.0. .OR. -C YN.GE.0. .OR. M=1) -C----------------------------------------------------------------------- - CALL ZBKNU(ZNR, ZNI, FNU, KODE, NN, CYR, CYI, NZ, TOL, ELIM, ALIM) - GO TO 110 -C----------------------------------------------------------------------- -C LEFT HALF PLANE COMPUTATION -C----------------------------------------------------------------------- - 80 CONTINUE - MR = -MM - CALL ZACON(ZNR, ZNI, FNU, KODE, MR, NN, CYR, CYI, NW, RL, FNUL, - * TOL, ELIM, ALIM) - IF (NW.LT.0) GO TO 240 - NZ=NW - GO TO 110 - 90 CONTINUE -C----------------------------------------------------------------------- -C UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL -C----------------------------------------------------------------------- - MR = 0 - IF ((ZNR.GE.0.0D0) .AND. (ZNR.NE.0.0D0 .OR. ZNI.GE.0.0D0 .OR. - * M.NE.2)) GO TO 100 - MR = -MM - IF (ZNR.NE.0.0D0 .OR. ZNI.GE.0.0D0) GO TO 100 - ZNR = -ZNR - ZNI = -ZNI - 100 CONTINUE - CALL ZBUNK(ZNR, ZNI, FNU, KODE, MR, NN, CYR, CYI, NW, TOL, ELIM, - * ALIM) - IF (NW.LT.0) GO TO 240 - NZ = NZ + NW - 110 CONTINUE -C----------------------------------------------------------------------- -C H(M,FNU,Z) = -FMM*(I/HPI)*(ZT**FNU)*K(FNU,-Z*ZT) -C -C ZT=EXP(-FMM*HPI*I) = CMPLX(0.0,-FMM), FMM=3-2*M, M=1,2 -C----------------------------------------------------------------------- - SGN = DSIGN(HPI,-FMM) -C----------------------------------------------------------------------- -C CALCULATE EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE -C WHEN FNU IS LARGE -C----------------------------------------------------------------------- - INU = FNU - INUH = INU/2 - IR = INU - 2*INUH - ARG = (FNU-(INU-IR))*SGN - RHPI = 1.0D0/SGN -C ZNI = RHPI*COS(ARG) -C ZNR = -RHPI*SIN(ARG) - CSGNI = RHPI*COS(ARG) - CSGNR = -RHPI*SIN(ARG) - IF (MOD(INUH,2).EQ.0) GO TO 120 -C ZNR = -ZNR -C ZNI = -ZNI - CSGNR = -CSGNR - CSGNI = -CSGNI - 120 CONTINUE - ZTI = -FMM - RTOL = 1.0D0/TOL - ASCLE = UFL*RTOL - DO 130 I=1,NN -C STR = CYR(I)*ZNR - CYI(I)*ZNI -C CYI(I) = CYR(I)*ZNI + CYI(I)*ZNR -C CYR(I) = STR -C STR = -ZNI*ZTI -C ZNI = ZNR*ZTI -C ZNR = STR - AA = CYR(I) - BB = CYI(I) - ATOL = 1.0D0 - IF (MAX(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 135 - AA = AA*RTOL - BB = BB*RTOL - ATOL = TOL - 135 CONTINUE - STR = AA*CSGNR - BB*CSGNI - STI = AA*CSGNI + BB*CSGNR - CYR(I) = STR*ATOL - CYI(I) = STI*ATOL - STR = -CSGNI*ZTI - CSGNI = CSGNR*ZTI - CSGNR = STR - 130 CONTINUE - RETURN - 140 CONTINUE - IF (ZNR.LT.0.0D0) GO TO 230 - RETURN - 230 CONTINUE - NZ=0 - IERR=2 - RETURN - 240 CONTINUE - IF(NW.EQ.(-1)) GO TO 230 - NZ=0 - IERR=5 - RETURN - 260 CONTINUE - NZ=0 - IERR=4 - RETURN - END diff --git a/slatec/zbesi.f b/slatec/zbesi.f deleted file mode 100644 index 1b48549..0000000 --- a/slatec/zbesi.f +++ /dev/null @@ -1,276 +0,0 @@ -*DECK ZBESI - SUBROUTINE ZBESI (ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR) -C***BEGIN PROLOGUE ZBESI -C***PURPOSE Compute a sequence of the Bessel functions I(a,z) for -C complex argument z and real nonnegative orders a=b,b+1, -C b+2,... where b>0. A scaling option is available to -C help avoid overflow. -C***LIBRARY SLATEC -C***CATEGORY C10B4 -C***TYPE COMPLEX (CBESI-C, ZBESI-C) -C***KEYWORDS BESSEL FUNCTIONS OF COMPLEX ARGUMENT, I BESSEL FUNCTIONS, -C MODIFIED BESSEL FUNCTIONS -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C ***A DOUBLE PRECISION ROUTINE*** -C On KODE=1, ZBESI computes an N-member sequence of complex -C Bessel functions CY(L)=I(FNU+L-1,Z) for real nonnegative -C orders FNU+L-1, L=1,...,N and complex Z in the cut plane -C -pi=0 -C KODE - A parameter to indicate the scaling option -C KODE=1 returns -C CY(L)=I(FNU+L-1,Z), L=1,...,N -C =2 returns -C CY(L)=exp(-abs(X))*I(FNU+L-1,Z), L=1,...,N -C where X=Re(Z) -C N - Number of terms in the sequence, N>=1 -C -C Output -C CYR - DOUBLE PRECISION real part of result vector -C CYI - DOUBLE PRECISION imag part of result vector -C NZ - Number of underflows set to zero -C NZ=0 Normal return -C NZ>0 CY(L)=0, L=N-NZ+1,...,N -C IERR - Error flag -C IERR=0 Normal return - COMPUTATION COMPLETED -C IERR=1 Input error - NO COMPUTATION -C IERR=2 Overflow - NO COMPUTATION -C (Re(Z) too large on KODE=1) -C IERR=3 Precision warning - COMPUTATION COMPLETED -C (Result has half precision or less -C because abs(Z) or FNU+N-1 is large) -C IERR=4 Precision error - NO COMPUTATION -C (Result has no precision because -C abs(Z) or FNU+N-1 is too large) -C IERR=5 Algorithmic error - NO COMPUTATION -C (Termination condition not met) -C -C *Long Description: -C -C The computation of I(a,z) is carried out by the power series -C for small abs(z), the asymptotic expansion for large abs(z), -C the Miller algorithm normalized by the Wronskian and a -C Neumann series for intermediate magnitudes of z, and the -C uniform asymptotic expansions for I(a,z) and J(a,z) for -C large orders a. Backward recurrence is used to generate -C sequences or reduce orders when necessary. -C -C The calculations above are done in the right half plane and -C continued into the left half plane by the formula -C -C I(a,z*exp(t)) = exp(t*a)*I(a,z), Re(z)>0 -C t = i*pi or -i*pi -C -C For negative orders, the formula -C -C I(-a,z) = I(a,z) + (2/pi)*sin(pi*a)*K(a,z) -C -C can be used. However, for large orders close to integers the -C the function changes radically. When a is a large positive -C integer, the magnitude of I(-a,z)=I(a,z) is a large -C negative power of ten. But when a is not an integer, -C K(a,z) dominates in magnitude with a large positive power of -C ten and the most that the second term can be reduced is by -C unit roundoff from the coefficient. Thus, wide changes can -C occur within unit roundoff of a large integer for a. Here, -C large means a>abs(z). -C -C In most complex variable computation, one must evaluate ele- -C mentary functions. When the magnitude of Z or FNU+N-1 is -C large, losses of significance by argument reduction occur. -C Consequently, if either one exceeds U1=SQRT(0.5/UR), then -C losses exceeding half precision are likely and an error flag -C IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is double -C precision unit roundoff limited to 18 digits precision. Also, -C if either is larger than U2=0.5/UR, then all significance is -C lost and IERR=4. In order to use the INT function, arguments -C must be further restricted not to exceed the largest machine -C integer, U3=I1MACH(9). Thus, the magnitude of Z and FNU+N-1 -C is restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, and -C U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision -C and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision. This -C makes U2 limiting in single precision and U3 limiting in -C double precision. This means that one can expect to retain, -C in the worst cases on IEEE machines, no digits in single pre- -C cision and only 6 digits in double precision. Similar con- -C siderations hold for other machines. -C -C The approximate relative error in the magnitude of a complex -C Bessel function can be expressed as P*10**S where P=MAX(UNIT -C ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- -C sents the increase in error due to argument reduction in the -C elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), -C ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF -C ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may -C have only absolute accuracy. This is most likely to occur -C when one component (in magnitude) is larger than the other by -C several orders of magnitude. If one component is 10**K larger -C than the other, then one can expect only MAX(ABS(LOG10(P))-K, -C 0) significant digits; or, stated another way, when K exceeds -C the exponent of P, no significant digits remain in the smaller -C component. However, the phase angle retains absolute accuracy -C because, in complex arithmetic with precision P, the smaller -C component will not (as a rule) decrease below P times the -C magnitude of the larger component. In these extreme cases, -C the principal phase angle is on the order of +P, -P, PI/2-P, -C or -PI/2+P. -C -C***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- -C matical Functions, National Bureau of Standards -C Applied Mathematics Series 55, U. S. Department -C of Commerce, Tenth Printing (1972) or later. -C 2. D. E. Amos, Computation of Bessel Functions of -C Complex Argument, Report SAND83-0086, Sandia National -C Laboratories, Albuquerque, NM, May 1983. -C 3. D. E. Amos, Computation of Bessel Functions of -C Complex Argument and Large Order, Report SAND83-0643, -C Sandia National Laboratories, Albuquerque, NM, May -C 1983. -C 4. D. E. Amos, A Subroutine Package for Bessel Functions -C of a Complex Argument and Nonnegative Order, Report -C SAND85-1018, Sandia National Laboratory, Albuquerque, -C NM, May 1985. -C 5. D. E. Amos, A portable package for Bessel functions -C of a complex argument and nonnegative order, ACM -C Transactions on Mathematical Software, 12 (September -C 1986), pp. 265-273. -C -C***ROUTINES CALLED D1MACH, I1MACH, ZABS, ZBINU -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 890801 REVISION DATE from Version 3.2 -C 910415 Prologue converted to Version 4.0 format. (BAB) -C 920128 Category corrected. (WRB) -C 920811 Prologue revised. (DWL) -C***END PROLOGUE ZBESI -C COMPLEX CONE,CSGN,CW,CY,CZERO,Z,ZN - DOUBLE PRECISION AA, ALIM, ARG, CONEI, CONER, CSGNI, CSGNR, CYI, - * CYR, DIG, ELIM, FNU, FNUL, PI, RL, R1M5, STR, TOL, ZI, ZNI, ZNR, - * ZR, D1MACH, AZ, BB, FN, ZABS, ASCLE, RTOL, ATOL, STI - INTEGER I, IERR, INU, K, KODE, K1,K2,N,NZ,NN, I1MACH - DIMENSION CYR(N), CYI(N) - EXTERNAL ZABS - DATA PI /3.14159265358979324D0/ - DATA CONER, CONEI /1.0D0,0.0D0/ -C -C***FIRST EXECUTABLE STATEMENT ZBESI - IERR = 0 - NZ=0 - IF (FNU.LT.0.0D0) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (N.LT.1) IERR=1 - IF (IERR.NE.0) RETURN -C----------------------------------------------------------------------- -C SET PARAMETERS RELATED TO MACHINE CONSTANTS. -C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. -C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. -C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND -C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR -C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. -C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. -C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). -C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. -C----------------------------------------------------------------------- - TOL = MAX(D1MACH(4),1.0D-18) - K1 = I1MACH(15) - K2 = I1MACH(16) - R1M5 = D1MACH(5) - K = MIN(ABS(K1),ABS(K2)) - ELIM = 2.303D0*(K*R1M5-3.0D0) - K1 = I1MACH(14) - 1 - AA = R1M5*K1 - DIG = MIN(AA,18.0D0) - AA = AA*2.303D0 - ALIM = ELIM + MAX(-AA,-41.45D0) - RL = 1.2D0*DIG + 3.0D0 - FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) -C----------------------------------------------------------------------- -C TEST FOR PROPER RANGE -C----------------------------------------------------------------------- - AZ = ZABS(ZR,ZI) - FN = FNU+(N-1) - AA = 0.5D0/TOL - BB=I1MACH(9)*0.5D0 - AA = MIN(AA,BB) - IF (AZ.GT.AA) GO TO 260 - IF (FN.GT.AA) GO TO 260 - AA = SQRT(AA) - IF (AZ.GT.AA) IERR=3 - IF (FN.GT.AA) IERR=3 - ZNR = ZR - ZNI = ZI - CSGNR = CONER - CSGNI = CONEI - IF (ZR.GE.0.0D0) GO TO 40 - ZNR = -ZR - ZNI = -ZI -C----------------------------------------------------------------------- -C CALCULATE CSGN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE -C WHEN FNU IS LARGE -C----------------------------------------------------------------------- - INU = FNU - ARG = (FNU-INU)*PI - IF (ZI.LT.0.0D0) ARG = -ARG - CSGNR = COS(ARG) - CSGNI = SIN(ARG) - IF (MOD(INU,2).EQ.0) GO TO 40 - CSGNR = -CSGNR - CSGNI = -CSGNI - 40 CONTINUE - CALL ZBINU(ZNR, ZNI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, TOL, - * ELIM, ALIM) - IF (NZ.LT.0) GO TO 120 - IF (ZR.GE.0.0D0) RETURN -C----------------------------------------------------------------------- -C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE -C----------------------------------------------------------------------- - NN = N - NZ - IF (NN.EQ.0) RETURN - RTOL = 1.0D0/TOL - ASCLE = D1MACH(1)*RTOL*1.0D+3 - DO 50 I=1,NN -C STR = CYR(I)*CSGNR - CYI(I)*CSGNI -C CYI(I) = CYR(I)*CSGNI + CYI(I)*CSGNR -C CYR(I) = STR - AA = CYR(I) - BB = CYI(I) - ATOL = 1.0D0 - IF (MAX(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 55 - AA = AA*RTOL - BB = BB*RTOL - ATOL = TOL - 55 CONTINUE - STR = AA*CSGNR - BB*CSGNI - STI = AA*CSGNI + BB*CSGNR - CYR(I) = STR*ATOL - CYI(I) = STI*ATOL - CSGNR = -CSGNR - CSGNI = -CSGNI - 50 CONTINUE - RETURN - 120 CONTINUE - IF(NZ.EQ.(-2)) GO TO 130 - NZ = 0 - IERR=2 - RETURN - 130 CONTINUE - NZ=0 - IERR=5 - RETURN - 260 CONTINUE - NZ=0 - IERR=4 - RETURN - END diff --git a/slatec/zbesj.f b/slatec/zbesj.f deleted file mode 100644 index bdc22a5..0000000 --- a/slatec/zbesj.f +++ /dev/null @@ -1,276 +0,0 @@ -*DECK ZBESJ - SUBROUTINE ZBESJ (ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR) -C***BEGIN PROLOGUE ZBESJ -C***PURPOSE Compute a sequence of the Bessel functions J(a,z) for -C complex argument z and real nonnegative orders a=b,b+1, -C b+2,... where b>0. A scaling option is available to -C help avoid overflow. -C***LIBRARY SLATEC -C***CATEGORY C10A4 -C***TYPE COMPLEX (CBESJ-C, ZBESJ-C) -C***KEYWORDS BESSEL FUNCTIONS OF COMPLEX ARGUMENT, -C BESSEL FUNCTIONS OF THE FIRST KIND, J BESSEL FUNCTIONS -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C ***A DOUBLE PRECISION ROUTINE*** -C On KODE=1, ZBESJ computes an N member sequence of complex -C Bessel functions CY(L)=J(FNU+L-1,Z) for real nonnegative -C orders FNU+L-1, L=1,...,N and complex Z in the cut plane -C -pi=0 -C KODE - A parameter to indicate the scaling option -C KODE=1 returns -C CY(L)=J(FNU+L-1,Z), L=1,...,N -C =2 returns -C CY(L)=J(FNU+L-1,Z)*exp(-abs(Y)), L=1,...,N -C where Y=Im(Z) -C N - Number of terms in the sequence, N>=1 -C -C Output -C CYR - DOUBLE PRECISION real part of result vector -C CYI - DOUBLE PRECISION imag part of result vector -C NZ - Number of underflows set to zero -C NZ=0 Normal return -C NZ>0 CY(L)=0, L=N-NZ+1,...,N -C IERR - Error flag -C IERR=0 Normal return - COMPUTATION COMPLETED -C IERR=1 Input error - NO COMPUTATION -C IERR=2 Overflow - NO COMPUTATION -C (Im(Z) too large on KODE=1) -C IERR=3 Precision warning - COMPUTATION COMPLETED -C (Result has half precision or less -C because abs(Z) or FNU+N-1 is large) -C IERR=4 Precision error - NO COMPUTATION -C (Result has no precision because -C abs(Z) or FNU+N-1 is too large) -C IERR=5 Algorithmic error - NO COMPUTATION -C (Termination condition not met) -C -C *Long Description: -C -C The computation is carried out by the formulae -C -C J(a,z) = exp( a*pi*i/2)*I(a,-i*z), Im(z)>=0 -C -C J(a,z) = exp(-a*pi*i/2)*I(a, i*z), Im(z)<0 -C -C where the I Bessel function is computed as described in the -C prologue to CBESI. -C -C For negative orders, the formula -C -C J(-a,z) = J(a,z)*cos(a*pi) - Y(a,z)*sin(a*pi) -C -C can be used. However, for large orders close to integers, the -C the function changes radically. When a is a large positive -C integer, the magnitude of J(-a,z)=J(a,z)*cos(a*pi) is a -C large negative power of ten. But when a is not an integer, -C Y(a,z) dominates in magnitude with a large positive power of -C ten and the most that the second term can be reduced is by -C unit roundoff from the coefficient. Thus, wide changes can -C occur within unit roundoff of a large integer for a. Here, -C large means a>abs(z). -C -C In most complex variable computation, one must evaluate ele- -C mentary functions. When the magnitude of Z or FNU+N-1 is -C large, losses of significance by argument reduction occur. -C Consequently, if either one exceeds U1=SQRT(0.5/UR), then -C losses exceeding half precision are likely and an error flag -C IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is double -C precision unit roundoff limited to 18 digits precision. Also, -C if either is larger than U2=0.5/UR, then all significance is -C lost and IERR=4. In order to use the INT function, arguments -C must be further restricted not to exceed the largest machine -C integer, U3=I1MACH(9). Thus, the magnitude of Z and FNU+N-1 -C is restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, and -C U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision -C and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision. This -C makes U2 limiting in single precision and U3 limiting in -C double precision. This means that one can expect to retain, -C in the worst cases on IEEE machines, no digits in single pre- -C cision and only 6 digits in double precision. Similar con- -C siderations hold for other machines. -C -C The approximate relative error in the magnitude of a complex -C Bessel function can be expressed as P*10**S where P=MAX(UNIT -C ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- -C sents the increase in error due to argument reduction in the -C elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), -C ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF -C ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may -C have only absolute accuracy. This is most likely to occur -C when one component (in magnitude) is larger than the other by -C several orders of magnitude. If one component is 10**K larger -C than the other, then one can expect only MAX(ABS(LOG10(P))-K, -C 0) significant digits; or, stated another way, when K exceeds -C the exponent of P, no significant digits remain in the smaller -C component. However, the phase angle retains absolute accuracy -C because, in complex arithmetic with precision P, the smaller -C component will not (as a rule) decrease below P times the -C magnitude of the larger component. In these extreme cases, -C the principal phase angle is on the order of +P, -P, PI/2-P, -C or -PI/2+P. -C -C***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- -C matical Functions, National Bureau of Standards -C Applied Mathematics Series 55, U. S. Department -C of Commerce, Tenth Printing (1972) or later. -C 2. D. E. Amos, Computation of Bessel Functions of -C Complex Argument, Report SAND83-0086, Sandia National -C Laboratories, Albuquerque, NM, May 1983. -C 3. D. E. Amos, Computation of Bessel Functions of -C Complex Argument and Large Order, Report SAND83-0643, -C Sandia National Laboratories, Albuquerque, NM, May -C 1983. -C 4. D. E. Amos, A Subroutine Package for Bessel Functions -C of a Complex Argument and Nonnegative Order, Report -C SAND85-1018, Sandia National Laboratory, Albuquerque, -C NM, May 1985. -C 5. D. E. Amos, A portable package for Bessel functions -C of a complex argument and nonnegative order, ACM -C Transactions on Mathematical Software, 12 (September -C 1986), pp. 265-273. -C -C***ROUTINES CALLED D1MACH, I1MACH, ZABS, ZBINU -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 890801 REVISION DATE from Version 3.2 -C 910415 Prologue converted to Version 4.0 format. (BAB) -C 920128 Category corrected. (WRB) -C 920811 Prologue revised. (DWL) -C***END PROLOGUE ZBESJ -C -C COMPLEX CI,CSGN,CY,Z,ZN - DOUBLE PRECISION AA, ALIM, ARG, CII, CSGNI, CSGNR, CYI, CYR, DIG, - * ELIM, FNU, FNUL, HPI, RL, R1M5, STR, TOL, ZI, ZNI, ZNR, ZR, - * D1MACH, BB, FN, AZ, ZABS, ASCLE, RTOL, ATOL, STI - INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, N, NL, NZ, I1MACH - DIMENSION CYR(N), CYI(N) - EXTERNAL ZABS - DATA HPI /1.57079632679489662D0/ -C -C***FIRST EXECUTABLE STATEMENT ZBESJ - IERR = 0 - NZ=0 - IF (FNU.LT.0.0D0) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (N.LT.1) IERR=1 - IF (IERR.NE.0) RETURN -C----------------------------------------------------------------------- -C SET PARAMETERS RELATED TO MACHINE CONSTANTS. -C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. -C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. -C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND -C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR -C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. -C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. -C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). -C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. -C----------------------------------------------------------------------- - TOL = MAX(D1MACH(4),1.0D-18) - K1 = I1MACH(15) - K2 = I1MACH(16) - R1M5 = D1MACH(5) - K = MIN(ABS(K1),ABS(K2)) - ELIM = 2.303D0*(K*R1M5-3.0D0) - K1 = I1MACH(14) - 1 - AA = R1M5*K1 - DIG = MIN(AA,18.0D0) - AA = AA*2.303D0 - ALIM = ELIM + MAX(-AA,-41.45D0) - RL = 1.2D0*DIG + 3.0D0 - FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) -C----------------------------------------------------------------------- -C TEST FOR PROPER RANGE -C----------------------------------------------------------------------- - AZ = ZABS(ZR,ZI) - FN = FNU+(N-1) - AA = 0.5D0/TOL - BB = I1MACH(9)*0.5D0 - AA = MIN(AA,BB) - IF (AZ.GT.AA) GO TO 260 - IF (FN.GT.AA) GO TO 260 - AA = SQRT(AA) - IF (AZ.GT.AA) IERR=3 - IF (FN.GT.AA) IERR=3 -C----------------------------------------------------------------------- -C CALCULATE CSGN=EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE -C WHEN FNU IS LARGE -C----------------------------------------------------------------------- - CII = 1.0D0 - INU = FNU - INUH = INU/2 - IR = INU - 2*INUH - ARG = (FNU-(INU-IR))*HPI - CSGNR = COS(ARG) - CSGNI = SIN(ARG) - IF (MOD(INUH,2).EQ.0) GO TO 40 - CSGNR = -CSGNR - CSGNI = -CSGNI - 40 CONTINUE -C----------------------------------------------------------------------- -C ZN IS IN THE RIGHT HALF PLANE -C----------------------------------------------------------------------- - ZNR = ZI - ZNI = -ZR - IF (ZI.GE.0.0D0) GO TO 50 - ZNR = -ZNR - ZNI = -ZNI - CSGNI = -CSGNI - CII = -CII - 50 CONTINUE - CALL ZBINU(ZNR, ZNI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, TOL, - * ELIM, ALIM) - IF (NZ.LT.0) GO TO 130 - NL = N - NZ - IF (NL.EQ.0) RETURN - RTOL = 1.0D0/TOL - ASCLE = D1MACH(1)*RTOL*1.0D+3 - DO 60 I=1,NL -C STR = CYR(I)*CSGNR - CYI(I)*CSGNI -C CYI(I) = CYR(I)*CSGNI + CYI(I)*CSGNR -C CYR(I) = STR - AA = CYR(I) - BB = CYI(I) - ATOL = 1.0D0 - IF (MAX(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 55 - AA = AA*RTOL - BB = BB*RTOL - ATOL = TOL - 55 CONTINUE - STR = AA*CSGNR - BB*CSGNI - STI = AA*CSGNI + BB*CSGNR - CYR(I) = STR*ATOL - CYI(I) = STI*ATOL - STR = -CSGNI*CII - CSGNI = CSGNR*CII - CSGNR = STR - 60 CONTINUE - RETURN - 130 CONTINUE - IF(NZ.EQ.(-2)) GO TO 140 - NZ = 0 - IERR = 2 - RETURN - 140 CONTINUE - NZ=0 - IERR=5 - RETURN - 260 CONTINUE - NZ=0 - IERR=4 - RETURN - END diff --git a/slatec/zbesk.f b/slatec/zbesk.f deleted file mode 100644 index 670b9f0..0000000 --- a/slatec/zbesk.f +++ /dev/null @@ -1,286 +0,0 @@ -*DECK ZBESK - SUBROUTINE ZBESK (ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR) -C***BEGIN PROLOGUE ZBESK -C***PURPOSE Compute a sequence of the Bessel functions K(a,z) for -C complex argument z and real nonnegative orders a=b,b+1, -C b+2,... where b>0. A scaling option is available to -C help avoid overflow. -C***LIBRARY SLATEC -C***CATEGORY C10B4 -C***TYPE COMPLEX (CBESK-C, ZBESK-C) -C***KEYWORDS BESSEL FUNCTIONS OF COMPLEX ARGUMENT, K BESSEL FUNCTIONS, -C MODIFIED BESSEL FUNCTIONS -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C ***A DOUBLE PRECISION ROUTINE*** -C On KODE=1, ZBESK computes an N member sequence of complex -C Bessel functions CY(L)=K(FNU+L-1,Z) for real nonnegative -C orders FNU+L-1, L=1,...,N and complex Z.NE.0 in the cut -C plane -pi=0 -C KODE - A parameter to indicate the scaling option -C KODE=1 returns -C CY(L)=K(FNU+L-1,Z), L=1,...,N -C =2 returns -C CY(L)=K(FNU+L-1,Z)*EXP(Z), L=1,...,N -C N - Number of terms in the sequence, N>=1 -C -C Output -C CYR - DOUBLE PRECISION real part of result vector -C CYI - DOUBLE PRECISION imag part of result vector -C NZ - Number of underflows set to zero -C NZ=0 Normal return -C NZ>0 CY(L)=0 for NZ values of L (if Re(Z)>0 -C then CY(L)=0 for L=1,...,NZ; in the -C complementary half plane the underflows -C may not be in an uninterrupted sequence) -C IERR - Error flag -C IERR=0 Normal return - COMPUTATION COMPLETED -C IERR=1 Input error - NO COMPUTATION -C IERR=2 Overflow - NO COMPUTATION -C (abs(Z) too small and/or FNU+N-1 -C too large) -C IERR=3 Precision warning - COMPUTATION COMPLETED -C (Result has half precision or less -C because abs(Z) or FNU+N-1 is large) -C IERR=4 Precision error - NO COMPUTATION -C (Result has no precision because -C abs(Z) or FNU+N-1 is too large) -C IERR=5 Algorithmic error - NO COMPUTATION -C (Termination condition not met) -C -C *Long Description: -C -C Equations of the reference are implemented to compute K(a,z) -C for small orders a and a+1 in the right half plane Re(z)>=0. -C Forward recurrence generates higher orders. The formula -C -C K(a,z*exp((t)) = exp(-t)*K(a,z) - t*I(a,z), Re(z)>0 -C t = i*pi or -i*pi -C -C continues K to the left half plane. -C -C For large orders, K(a,z) is computed by means of its uniform -C asymptotic expansion. -C -C For negative orders, the formula -C -C K(-a,z) = K(a,z) -C -C can be used. -C -C CBESK assumes that a significant digit sinh function is -C available. -C -C In most complex variable computation, one must evaluate ele- -C mentary functions. When the magnitude of Z or FNU+N-1 is -C large, losses of significance by argument reduction occur. -C Consequently, if either one exceeds U1=SQRT(0.5/UR), then -C losses exceeding half precision are likely and an error flag -C IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is double -C precision unit roundoff limited to 18 digits precision. Also, -C if either is larger than U2=0.5/UR, then all significance is -C lost and IERR=4. In order to use the INT function, arguments -C must be further restricted not to exceed the largest machine -C integer, U3=I1MACH(9). Thus, the magnitude of Z and FNU+N-1 -C is restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, and -C U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision -C and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision. This -C makes U2 limiting in single precision and U3 limiting in -C double precision. This means that one can expect to retain, -C in the worst cases on IEEE machines, no digits in single pre- -C cision and only 6 digits in double precision. Similar con- -C siderations hold for other machines. -C -C The approximate relative error in the magnitude of a complex -C Bessel function can be expressed as P*10**S where P=MAX(UNIT -C ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- -C sents the increase in error due to argument reduction in the -C elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), -C ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF -C ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may -C have only absolute accuracy. This is most likely to occur -C when one component (in magnitude) is larger than the other by -C several orders of magnitude. If one component is 10**K larger -C than the other, then one can expect only MAX(ABS(LOG10(P))-K, -C 0) significant digits; or, stated another way, when K exceeds -C the exponent of P, no significant digits remain in the smaller -C component. However, the phase angle retains absolute accuracy -C because, in complex arithmetic with precision P, the smaller -C component will not (as a rule) decrease below P times the -C magnitude of the larger component. In these extreme cases, -C the principal phase angle is on the order of +P, -P, PI/2-P, -C or -PI/2+P. -C -C***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- -C matical Functions, National Bureau of Standards -C Applied Mathematics Series 55, U. S. Department -C of Commerce, Tenth Printing (1972) or later. -C 2. D. E. Amos, Computation of Bessel Functions of -C Complex Argument, Report SAND83-0086, Sandia National -C Laboratories, Albuquerque, NM, May 1983. -C 3. D. E. Amos, Computation of Bessel Functions of -C Complex Argument and Large Order, Report SAND83-0643, -C Sandia National Laboratories, Albuquerque, NM, May -C 1983. -C 4. D. E. Amos, A Subroutine Package for Bessel Functions -C of a Complex Argument and Nonnegative Order, Report -C SAND85-1018, Sandia National Laboratory, Albuquerque, -C NM, May 1985. -C 5. D. E. Amos, A portable package for Bessel functions -C of a complex argument and nonnegative order, ACM -C Transactions on Mathematical Software, 12 (September -C 1986), pp. 265-273. -C -C***ROUTINES CALLED D1MACH, I1MACH, ZABS, ZACON, ZBKNU, ZBUNK, ZUOIK -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 890801 REVISION DATE from Version 3.2 -C 910415 Prologue converted to Version 4.0 format. (BAB) -C 920128 Category corrected. (WRB) -C 920811 Prologue revised. (DWL) -C***END PROLOGUE ZBESK -C -C COMPLEX CY,Z - DOUBLE PRECISION AA, ALIM, ALN, ARG, AZ, CYI, CYR, DIG, ELIM, FN, - * FNU, FNUL, RL, R1M5, TOL, UFL, ZI, ZR, D1MACH, ZABS, BB - INTEGER IERR, K, KODE, K1, K2, MR, N, NN, NUF, NW, NZ, I1MACH - DIMENSION CYR(N), CYI(N) - EXTERNAL ZABS -C***FIRST EXECUTABLE STATEMENT ZBESK - IERR = 0 - NZ=0 - IF (ZI.EQ.0.0E0 .AND. ZR.EQ.0.0E0) IERR=1 - IF (FNU.LT.0.0D0) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (N.LT.1) IERR=1 - IF (IERR.NE.0) RETURN - NN = N -C----------------------------------------------------------------------- -C SET PARAMETERS RELATED TO MACHINE CONSTANTS. -C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. -C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. -C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND -C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR -C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. -C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. -C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). -C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU -C----------------------------------------------------------------------- - TOL = MAX(D1MACH(4),1.0D-18) - K1 = I1MACH(15) - K2 = I1MACH(16) - R1M5 = D1MACH(5) - K = MIN(ABS(K1),ABS(K2)) - ELIM = 2.303D0*(K*R1M5-3.0D0) - K1 = I1MACH(14) - 1 - AA = R1M5*K1 - DIG = MIN(AA,18.0D0) - AA = AA*2.303D0 - ALIM = ELIM + MAX(-AA,-41.45D0) - FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) - RL = 1.2D0*DIG + 3.0D0 -C----------------------------------------------------------------------- -C TEST FOR PROPER RANGE -C----------------------------------------------------------------------- - AZ = ZABS(ZR,ZI) - FN = FNU + (NN-1) - AA = 0.5D0/TOL - BB = I1MACH(9)*0.5D0 - AA = MIN(AA,BB) - IF (AZ.GT.AA) GO TO 260 - IF (FN.GT.AA) GO TO 260 - AA = SQRT(AA) - IF (AZ.GT.AA) IERR=3 - IF (FN.GT.AA) IERR=3 -C----------------------------------------------------------------------- -C OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE -C----------------------------------------------------------------------- -C UFL = EXP(-ELIM) - UFL = D1MACH(1)*1.0D+3 - IF (AZ.LT.UFL) GO TO 180 - IF (FNU.GT.FNUL) GO TO 80 - IF (FN.LE.1.0D0) GO TO 60 - IF (FN.GT.2.0D0) GO TO 50 - IF (AZ.GT.TOL) GO TO 60 - ARG = 0.5D0*AZ - ALN = -FN*LOG(ARG) - IF (ALN.GT.ELIM) GO TO 180 - GO TO 60 - 50 CONTINUE - CALL ZUOIK(ZR, ZI, FNU, KODE, 2, NN, CYR, CYI, NUF, TOL, ELIM, - * ALIM) - IF (NUF.LT.0) GO TO 180 - NZ = NZ + NUF - NN = NN - NUF -C----------------------------------------------------------------------- -C HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK -C IF NUF=NN, THEN CY(I)=CZERO FOR ALL I -C----------------------------------------------------------------------- - IF (NN.EQ.0) GO TO 100 - 60 CONTINUE - IF (ZR.LT.0.0D0) GO TO 70 -C----------------------------------------------------------------------- -C RIGHT HALF PLANE COMPUTATION, REAL(Z).GE.0. -C----------------------------------------------------------------------- - CALL ZBKNU(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM) - IF (NW.LT.0) GO TO 200 - NZ=NW - RETURN -C----------------------------------------------------------------------- -C LEFT HALF PLANE COMPUTATION -C PI/2.LT.ARG(Z).LE.PI AND -PI.LT.ARG(Z).LT.-PI/2. -C----------------------------------------------------------------------- - 70 CONTINUE - IF (NZ.NE.0) GO TO 180 - MR = 1 - IF (ZI.LT.0.0D0) MR = -1 - CALL ZACON(ZR, ZI, FNU, KODE, MR, NN, CYR, CYI, NW, RL, FNUL, - * TOL, ELIM, ALIM) - IF (NW.LT.0) GO TO 200 - NZ=NW - RETURN -C----------------------------------------------------------------------- -C UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL -C----------------------------------------------------------------------- - 80 CONTINUE - MR = 0 - IF (ZR.GE.0.0D0) GO TO 90 - MR = 1 - IF (ZI.LT.0.0D0) MR = -1 - 90 CONTINUE - CALL ZBUNK(ZR, ZI, FNU, KODE, MR, NN, CYR, CYI, NW, TOL, ELIM, - * ALIM) - IF (NW.LT.0) GO TO 200 - NZ = NZ + NW - RETURN - 100 CONTINUE - IF (ZR.LT.0.0D0) GO TO 180 - RETURN - 180 CONTINUE - NZ = 0 - IERR=2 - RETURN - 200 CONTINUE - IF(NW.EQ.(-1)) GO TO 180 - NZ=0 - IERR=5 - RETURN - 260 CONTINUE - NZ=0 - IERR=4 - RETURN - END diff --git a/slatec/zbesy.f b/slatec/zbesy.f deleted file mode 100644 index 911217a..0000000 --- a/slatec/zbesy.f +++ /dev/null @@ -1,254 +0,0 @@ -*DECK ZBESY - SUBROUTINE ZBESY (ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, CWRKR, - + CWRKI, IERR) -C***BEGIN PROLOGUE ZBESY -C***PURPOSE Compute a sequence of the Bessel functions Y(a,z) for -C complex argument z and real nonnegative orders a=b,b+1, -C b+2,... where b>0. A scaling option is available to -C help avoid overflow. -C***LIBRARY SLATEC -C***CATEGORY C10A4 -C***TYPE COMPLEX (CBESY-C, ZBESY-C) -C***KEYWORDS BESSEL FUNCTIONS OF COMPLEX ARGUMENT, -C BESSEL FUNCTIONS OF SECOND KIND, WEBER'S FUNCTION, -C Y BESSEL FUNCTIONS -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C ***A DOUBLE PRECISION ROUTINE*** -C On KODE=1, ZBESY computes an N member sequence of complex -C Bessel functions CY(L)=Y(FNU+L-1,Z) for real nonnegative -C orders FNU+L-1, L=1,...,N and complex Z in the cut plane -C -pi=0 -C KODE - A parameter to indicate the scaling option -C KODE=1 returns -C CY(L)=Y(FNU+L-1,Z), L=1,...,N -C =2 returns -C CY(L)=Y(FNU+L-1,Z)*exp(-abs(Y)), L=1,...,N -C where Y=Im(Z) -C N - Number of terms in the sequence, N>=1 -C CWRKR - DOUBLE PRECISION work vector of dimension N -C CWRKI - DOUBLE PRECISION work vector of dimension N -C -C Output -C CYR - DOUBLE PRECISION real part of result vector -C CYI - DOUBLE PRECISION imag part of result vector -C NZ - Number of underflows set to zero -C NZ=0 Normal return -C NZ>0 CY(L)=0 for NZ values of L, usually on -C KODE=2 (the underflows may not be in an -C uninterrupted sequence) -C IERR - Error flag -C IERR=0 Normal return - COMPUTATION COMPLETED -C IERR=1 Input error - NO COMPUTATION -C IERR=2 Overflow - NO COMPUTATION -C (abs(Z) too small and/or FNU+N-1 -C too large) -C IERR=3 Precision warning - COMPUTATION COMPLETED -C (Result has half precision or less -C because abs(Z) or FNU+N-1 is large) -C IERR=4 Precision error - NO COMPUTATION -C (Result has no precision because -C abs(Z) or FNU+N-1 is too large) -C IERR=5 Algorithmic error - NO COMPUTATION -C (Termination condition not met) -C -C *Long Description: -C -C The computation is carried out by the formula -C -C Y(a,z) = (H(1,a,z) - H(2,a,z))/(2*i) -C -C where the Hankel functions are computed as described in CBESH. -C -C For negative orders, the formula -C -C Y(-a,z) = Y(a,z)*cos(a*pi) + J(a,z)*sin(a*pi) -C -C can be used. However, for large orders close to half odd -C integers the function changes radically. When a is a large -C positive half odd integer, the magnitude of Y(-a,z)=J(a,z)* -C sin(a*pi) is a large negative power of ten. But when a is -C not a half odd integer, Y(a,z) dominates in magnitude with a -C large positive power of ten and the most that the second term -C can be reduced is by unit roundoff from the coefficient. -C Thus, wide changes can occur within unit roundoff of a large -C half odd integer. Here, large means a>abs(z). -C -C In most complex variable computation, one must evaluate ele- -C mentary functions. When the magnitude of Z or FNU+N-1 is -C large, losses of significance by argument reduction occur. -C Consequently, if either one exceeds U1=SQRT(0.5/UR), then -C losses exceeding half precision are likely and an error flag -C IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is double -C precision unit roundoff limited to 18 digits precision. Also, -C if either is larger than U2=0.5/UR, then all significance is -C lost and IERR=4. In order to use the INT function, arguments -C must be further restricted not to exceed the largest machine -C integer, U3=I1MACH(9). Thus, the magnitude of Z and FNU+N-1 -C is restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, and -C U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision -C and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision. This -C makes U2 limiting in single precision and U3 limiting in -C double precision. This means that one can expect to retain, -C in the worst cases on IEEE machines, no digits in single pre- -C cision and only 6 digits in double precision. Similar con- -C siderations hold for other machines. -C -C The approximate relative error in the magnitude of a complex -C Bessel function can be expressed as P*10**S where P=MAX(UNIT -C ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- -C sents the increase in error due to argument reduction in the -C elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), -C ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF -C ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may -C have only absolute accuracy. This is most likely to occur -C when one component (in magnitude) is larger than the other by -C several orders of magnitude. If one component is 10**K larger -C than the other, then one can expect only MAX(ABS(LOG10(P))-K, -C 0) significant digits; or, stated another way, when K exceeds -C the exponent of P, no significant digits remain in the smaller -C component. However, the phase angle retains absolute accuracy -C because, in complex arithmetic with precision P, the smaller -C component will not (as a rule) decrease below P times the -C magnitude of the larger component. In these extreme cases, -C the principal phase angle is on the order of +P, -P, PI/2-P, -C or -PI/2+P. -C -C***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- -C matical Functions, National Bureau of Standards -C Applied Mathematics Series 55, U. S. Department -C of Commerce, Tenth Printing (1972) or later. -C 2. D. E. Amos, Computation of Bessel Functions of -C Complex Argument, Report SAND83-0086, Sandia National -C Laboratories, Albuquerque, NM, May 1983. -C 3. D. E. Amos, Computation of Bessel Functions of -C Complex Argument and Large Order, Report SAND83-0643, -C Sandia National Laboratories, Albuquerque, NM, May -C 1983. -C 4. D. E. Amos, A Subroutine Package for Bessel Functions -C of a Complex Argument and Nonnegative Order, Report -C SAND85-1018, Sandia National Laboratory, Albuquerque, -C NM, May 1985. -C 5. D. E. Amos, A portable package for Bessel functions -C of a complex argument and nonnegative order, ACM -C Transactions on Mathematical Software, 12 (September -C 1986), pp. 265-273. -C -C***ROUTINES CALLED D1MACH, I1MACH, ZBESH -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 890801 REVISION DATE from Version 3.2 -C 910415 Prologue converted to Version 4.0 format. (BAB) -C 920128 Category corrected. (WRB) -C 920811 Prologue revised. (DWL) -C***END PROLOGUE ZBESY -C -C COMPLEX CWRK,CY,C1,C2,EX,HCI,Z,ZU,ZV - DOUBLE PRECISION CWRKI, CWRKR, CYI, CYR, C1I, C1R, C2I, C2R, - * ELIM, EXI, EXR, EY, FNU, HCII, STI, STR, TAY, ZI, ZR, - * D1MACH, ASCLE, RTOL, ATOL, AA, BB, TOL, R1M5 - INTEGER I, IERR, K, KODE, K1, K2, N, NZ, NZ1, NZ2, I1MACH - DIMENSION CYR(N), CYI(N), CWRKR(N), CWRKI(N) -C***FIRST EXECUTABLE STATEMENT ZBESY - IERR = 0 - NZ=0 - IF (ZR.EQ.0.0D0 .AND. ZI.EQ.0.0D0) IERR=1 - IF (FNU.LT.0.0D0) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (N.LT.1) IERR=1 - IF (IERR.NE.0) RETURN - HCII = 0.5D0 - CALL ZBESH(ZR, ZI, FNU, KODE, 1, N, CYR, CYI, NZ1, IERR) - IF (IERR.NE.0.AND.IERR.NE.3) GO TO 170 - CALL ZBESH(ZR, ZI, FNU, KODE, 2, N, CWRKR, CWRKI, NZ2, IERR) - IF (IERR.NE.0.AND.IERR.NE.3) GO TO 170 - NZ = MIN(NZ1,NZ2) - IF (KODE.EQ.2) GO TO 60 - DO 50 I=1,N - STR = CWRKR(I) - CYR(I) - STI = CWRKI(I) - CYI(I) - CYR(I) = -STI*HCII - CYI(I) = STR*HCII - 50 CONTINUE - RETURN - 60 CONTINUE - TOL = MAX(D1MACH(4),1.0D-18) - K1 = I1MACH(15) - K2 = I1MACH(16) - K = MIN(ABS(K1),ABS(K2)) - R1M5 = D1MACH(5) -C----------------------------------------------------------------------- -C ELIM IS THE APPROXIMATE EXPONENTIAL UNDER- AND OVERFLOW LIMIT -C----------------------------------------------------------------------- - ELIM = 2.303D0*(K*R1M5-3.0D0) - EXR = COS(ZR) - EXI = SIN(ZR) - EY = 0.0D0 - TAY = ABS(ZI+ZI) - IF (TAY.LT.ELIM) EY = EXP(-TAY) - IF (ZI.LT.0.0D0) GO TO 90 - C1R = EXR*EY - C1I = EXI*EY - C2R = EXR - C2I = -EXI - 70 CONTINUE - NZ = 0 - RTOL = 1.0D0/TOL - ASCLE = D1MACH(1)*RTOL*1.0D+3 - DO 80 I=1,N -C STR = C1R*CYR(I) - C1I*CYI(I) -C STI = C1R*CYI(I) + C1I*CYR(I) -C STR = -STR + C2R*CWRKR(I) - C2I*CWRKI(I) -C STI = -STI + C2R*CWRKI(I) + C2I*CWRKR(I) -C CYR(I) = -STI*HCII -C CYI(I) = STR*HCII - AA = CWRKR(I) - BB = CWRKI(I) - ATOL = 1.0D0 - IF (MAX(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 75 - AA = AA*RTOL - BB = BB*RTOL - ATOL = TOL - 75 CONTINUE - STR = (AA*C2R - BB*C2I)*ATOL - STI = (AA*C2I + BB*C2R)*ATOL - AA = CYR(I) - BB = CYI(I) - ATOL = 1.0D0 - IF (MAX(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 85 - AA = AA*RTOL - BB = BB*RTOL - ATOL = TOL - 85 CONTINUE - STR = STR - (AA*C1R - BB*C1I)*ATOL - STI = STI - (AA*C1I + BB*C1R)*ATOL - CYR(I) = -STI*HCII - CYI(I) = STR*HCII - IF (STR.EQ.0.0D0 .AND. STI.EQ.0.0D0 .AND. EY.EQ.0.0D0) NZ = NZ - * + 1 - 80 CONTINUE - RETURN - 90 CONTINUE - C1R = EXR - C1I = EXI - C2R = EXR*EY - C2I = -EXI*EY - GO TO 70 - 170 CONTINUE - NZ = 0 - RETURN - END diff --git a/slatec/zbinu.f b/slatec/zbinu.f deleted file mode 100644 index af090de..0000000 --- a/slatec/zbinu.f +++ /dev/null @@ -1,121 +0,0 @@ -*DECK ZBINU - SUBROUTINE ZBINU (ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, - + TOL, ELIM, ALIM) -C***BEGIN PROLOGUE ZBINU -C***SUBSIDIARY -C***PURPOSE Subsidiary to ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK and ZBIRY -C***LIBRARY SLATEC -C***TYPE ALL (CBINU-A, ZBINU-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C ZBINU COMPUTES THE I FUNCTION IN THE RIGHT HALF Z PLANE -C -C***SEE ALSO ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBIRY -C***ROUTINES CALLED ZABS, ZASYI, ZBUNI, ZMLRI, ZSERI, ZUOIK, ZWRSK -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE ZBINU - DOUBLE PRECISION ALIM, AZ, CWI, CWR, CYI, CYR, DFNU, ELIM, FNU, - * FNUL, RL, TOL, ZEROI, ZEROR, ZI, ZR, ZABS - INTEGER I, INW, KODE, N, NLAST, NN, NUI, NW, NZ - DIMENSION CYR(N), CYI(N), CWR(2), CWI(2) - EXTERNAL ZABS - DATA ZEROR,ZEROI / 0.0D0, 0.0D0 / -C***FIRST EXECUTABLE STATEMENT ZBINU - NZ = 0 - AZ = ZABS(ZR,ZI) - NN = N - DFNU = FNU + (N-1) - IF (AZ.LE.2.0D0) GO TO 10 - IF (AZ*AZ*0.25D0.GT.DFNU+1.0D0) GO TO 20 - 10 CONTINUE -C----------------------------------------------------------------------- -C POWER SERIES -C----------------------------------------------------------------------- - CALL ZSERI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM) - INW = ABS(NW) - NZ = NZ + INW - NN = NN - INW - IF (NN.EQ.0) RETURN - IF (NW.GE.0) GO TO 120 - DFNU = FNU + (NN-1) - 20 CONTINUE - IF (AZ.LT.RL) GO TO 40 - IF (DFNU.LE.1.0D0) GO TO 30 - IF (AZ+AZ.LT.DFNU*DFNU) GO TO 50 -C----------------------------------------------------------------------- -C ASYMPTOTIC EXPANSION FOR LARGE Z -C----------------------------------------------------------------------- - 30 CONTINUE - CALL ZASYI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, RL, TOL, ELIM, - * ALIM) - IF (NW.LT.0) GO TO 130 - GO TO 120 - 40 CONTINUE - IF (DFNU.LE.1.0D0) GO TO 70 - 50 CONTINUE -C----------------------------------------------------------------------- -C OVERFLOW AND UNDERFLOW TEST ON I SEQUENCE FOR MILLER ALGORITHM -C----------------------------------------------------------------------- - CALL ZUOIK(ZR, ZI, FNU, KODE, 1, NN, CYR, CYI, NW, TOL, ELIM, - * ALIM) - IF (NW.LT.0) GO TO 130 - NZ = NZ + NW - NN = NN - NW - IF (NN.EQ.0) RETURN - DFNU = FNU+(NN-1) - IF (DFNU.GT.FNUL) GO TO 110 - IF (AZ.GT.FNUL) GO TO 110 - 60 CONTINUE - IF (AZ.GT.RL) GO TO 80 - 70 CONTINUE -C----------------------------------------------------------------------- -C MILLER ALGORITHM NORMALIZED BY THE SERIES -C----------------------------------------------------------------------- - CALL ZMLRI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL) - IF(NW.LT.0) GO TO 130 - GO TO 120 - 80 CONTINUE -C----------------------------------------------------------------------- -C MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- -C OVERFLOW TEST ON K FUNCTIONS USED IN WRONSKIAN -C----------------------------------------------------------------------- - CALL ZUOIK(ZR, ZI, FNU, KODE, 2, 2, CWR, CWI, NW, TOL, ELIM, - * ALIM) - IF (NW.GE.0) GO TO 100 - NZ = NN - DO 90 I=1,NN - CYR(I) = ZEROR - CYI(I) = ZEROI - 90 CONTINUE - RETURN - 100 CONTINUE - IF (NW.GT.0) GO TO 130 - CALL ZWRSK(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, CWR, CWI, TOL, - * ELIM, ALIM) - IF (NW.LT.0) GO TO 130 - GO TO 120 - 110 CONTINUE -C----------------------------------------------------------------------- -C INCREMENT FNU+NN-1 UP TO FNUL, COMPUTE AND RECUR BACKWARD -C----------------------------------------------------------------------- - NUI = FNUL-DFNU + 1 - NUI = MAX(NUI,0) - CALL ZBUNI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, NUI, NLAST, FNUL, - * TOL, ELIM, ALIM) - IF (NW.LT.0) GO TO 130 - NZ = NZ + NW - IF (NLAST.EQ.0) GO TO 120 - NN = NLAST - GO TO 60 - 120 CONTINUE - RETURN - 130 CONTINUE - NZ = -1 - IF(NW.EQ.(-2)) NZ=-2 - RETURN - END diff --git a/slatec/zbiry.f b/slatec/zbiry.f deleted file mode 100644 index 4096702..0000000 --- a/slatec/zbiry.f +++ /dev/null @@ -1,377 +0,0 @@ -*DECK ZBIRY - SUBROUTINE ZBIRY (ZR, ZI, ID, KODE, BIR, BII, IERR) -C***BEGIN PROLOGUE ZBIRY -C***PURPOSE Compute the Airy function Bi(z) or its derivative dBi/dz -C for complex argument z. A scaling option is available -C to help avoid overflow. -C***LIBRARY SLATEC -C***CATEGORY C10D -C***TYPE COMPLEX (CBIRY-C, ZBIRY-C) -C***KEYWORDS AIRY FUNCTION, BESSEL FUNCTION OF ORDER ONE THIRD, -C BESSEL FUNCTION OF ORDER TWO THIRDS -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C ***A DOUBLE PRECISION ROUTINE*** -C On KODE=1, ZBIRY computes the complex Airy function Bi(z) -C or its derivative dBi/dz on ID=0 or ID=1 respectively. -C On KODE=2, a scaling option exp(abs(Re(zeta)))*Bi(z) or -C exp(abs(Re(zeta)))*dBi/dz is provided to remove the -C exponential behavior in both the left and right half planes -C where zeta=(2/3)*z**(3/2). -C -C The Airy functions Bi(z) and dBi/dz are analytic in the -C whole z-plane, and the scaling option does not destroy this -C property. -C -C Input -C ZR - DOUBLE PRECISION real part of argument Z -C ZI - DOUBLE PRECISION imag part of argument Z -C ID - Order of derivative, ID=0 or ID=1 -C KODE - A parameter to indicate the scaling option -C KODE=1 returns -C BI=Bi(z) on ID=0 -C BI=dBi/dz on ID=1 -C at z=Z -C =2 returns -C BI=exp(abs(Re(zeta)))*Bi(z) on ID=0 -C BI=exp(abs(Re(zeta)))*dBi/dz on ID=1 -C at z=Z where zeta=(2/3)*z**(3/2) -C -C Output -C BIR - DOUBLE PRECISION real part of result -C BII - DOUBLE PRECISION imag part of result -C IERR - Error flag -C IERR=0 Normal return - COMPUTATION COMPLETED -C IERR=1 Input error - NO COMPUTATION -C IERR=2 Overflow - NO COMPUTATION -C (Re(Z) too large with KODE=1) -C IERR=3 Precision warning - COMPUTATION COMPLETED -C (Result has less than half precision) -C IERR=4 Precision error - NO COMPUTATION -C (Result has no precision) -C IERR=5 Algorithmic error - NO COMPUTATION -C (Termination condition not met) -C -C *Long Description: -C -C Bi(z) and dBi/dz are computed from I Bessel functions by -C -C Bi(z) = c*sqrt(z)*( I(-1/3,zeta) + I(1/3,zeta) ) -C dBi/dz = c* z *( I(-2/3,zeta) + I(2/3,zeta) ) -C c = 1/sqrt(3) -C zeta = (2/3)*z**(3/2) -C -C when abs(z)>1 and from power series when abs(z)<=1. -C -C In most complex variable computation, one must evaluate ele- -C mentary functions. When the magnitude of Z is large, losses -C of significance by argument reduction occur. Consequently, if -C the magnitude of ZETA=(2/3)*Z**(3/2) exceeds U1=SQRT(0.5/UR), -C then losses exceeding half precision are likely and an error -C flag IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is -C double precision unit roundoff limited to 18 digits precision. -C Also, if the magnitude of ZETA is larger than U2=0.5/UR, then -C all significance is lost and IERR=4. In order to use the INT -C function, ZETA must be further restricted not to exceed -C U3=I1MACH(9)=LARGEST INTEGER. Thus, the magnitude of ZETA -C must be restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, -C and U3 are approximately 2.0E+3, 4.2E+6, 2.1E+9 in single -C precision and 4.7E+7, 2.3E+15, 2.1E+9 in double precision. -C This makes U2 limiting is single precision and U3 limiting -C in double precision. This means that the magnitude of Z -C cannot exceed approximately 3.4E+4 in single precision and -C 2.1E+6 in double precision. This also means that one can -C expect to retain, in the worst cases on 32-bit machines, -C no digits in single precision and only 6 digits in double -C precision. -C -C The approximate relative error in the magnitude of a complex -C Bessel function can be expressed as P*10**S where P=MAX(UNIT -C ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- -C sents the increase in error due to argument reduction in the -C elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), -C ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF -C ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may -C have only absolute accuracy. This is most likely to occur -C when one component (in magnitude) is larger than the other by -C several orders of magnitude. If one component is 10**K larger -C than the other, then one can expect only MAX(ABS(LOG10(P))-K, -C 0) significant digits; or, stated another way, when K exceeds -C the exponent of P, no significant digits remain in the smaller -C component. However, the phase angle retains absolute accuracy -C because, in complex arithmetic with precision P, the smaller -C component will not (as a rule) decrease below P times the -C magnitude of the larger component. In these extreme cases, -C the principal phase angle is on the order of +P, -P, PI/2-P, -C or -PI/2+P. -C -C***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- -C matical Functions, National Bureau of Standards -C Applied Mathematics Series 55, U. S. Department -C of Commerce, Tenth Printing (1972) or later. -C 2. D. E. Amos, Computation of Bessel Functions of -C Complex Argument and Large Order, Report SAND83-0643, -C Sandia National Laboratories, Albuquerque, NM, May -C 1983. -C 3. D. E. Amos, A Subroutine Package for Bessel Functions -C of a Complex Argument and Nonnegative Order, Report -C SAND85-1018, Sandia National Laboratory, Albuquerque, -C NM, May 1985. -C 4. D. E. Amos, A portable package for Bessel functions -C of a complex argument and nonnegative order, ACM -C Transactions on Mathematical Software, 12 (September -C 1986), pp. 265-273. -C -C***ROUTINES CALLED D1MACH, I1MACH, ZABS, ZBINU, ZDIV, ZSQRT -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 890801 REVISION DATE from Version 3.2 -C 910415 Prologue converted to Version 4.0 format. (BAB) -C 920128 Category corrected. (WRB) -C 920811 Prologue revised. (DWL) -C 930122 Added ZSQRT to EXTERNAL statement. (RWC) -C***END PROLOGUE ZBIRY -C COMPLEX BI,CONE,CSQ,CY,S1,S2,TRM1,TRM2,Z,ZTA,Z3 - DOUBLE PRECISION AA, AD, AK, ALIM, ATRM, AZ, AZ3, BB, BII, BIR, - * BK, CC, CK, COEF, CONEI, CONER, CSQI, CSQR, CYI, CYR, C1, C2, - * DIG, DK, D1, D2, EAA, ELIM, FID, FMR, FNU, FNUL, PI, RL, R1M5, - * SFAC, STI, STR, S1I, S1R, S2I, S2R, TOL, TRM1I, TRM1R, TRM2I, - * TRM2R, TTH, ZI, ZR, ZTAI, ZTAR, Z3I, Z3R, D1MACH, ZABS - INTEGER ID, IERR, K, KODE, K1, K2, NZ, I1MACH - DIMENSION CYR(2), CYI(2) - EXTERNAL ZABS, ZSQRT - DATA TTH, C1, C2, COEF, PI /6.66666666666666667D-01, - * 6.14926627446000736D-01,4.48288357353826359D-01, - * 5.77350269189625765D-01,3.14159265358979324D+00/ - DATA CONER, CONEI /1.0D0,0.0D0/ -C***FIRST EXECUTABLE STATEMENT ZBIRY - IERR = 0 - NZ=0 - IF (ID.LT.0 .OR. ID.GT.1) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (IERR.NE.0) RETURN - AZ = ZABS(ZR,ZI) - TOL = MAX(D1MACH(4),1.0D-18) - FID = ID - IF (AZ.GT.1.0E0) GO TO 70 -C----------------------------------------------------------------------- -C POWER SERIES FOR ABS(Z).LE.1. -C----------------------------------------------------------------------- - S1R = CONER - S1I = CONEI - S2R = CONER - S2I = CONEI - IF (AZ.LT.TOL) GO TO 130 - AA = AZ*AZ - IF (AA.LT.TOL/AZ) GO TO 40 - TRM1R = CONER - TRM1I = CONEI - TRM2R = CONER - TRM2I = CONEI - ATRM = 1.0D0 - STR = ZR*ZR - ZI*ZI - STI = ZR*ZI + ZI*ZR - Z3R = STR*ZR - STI*ZI - Z3I = STR*ZI + STI*ZR - AZ3 = AZ*AA - AK = 2.0D0 + FID - BK = 3.0D0 - FID - FID - CK = 4.0D0 - FID - DK = 3.0D0 + FID + FID - D1 = AK*DK - D2 = BK*CK - AD = MIN(D1,D2) - AK = 24.0D0 + 9.0D0*FID - BK = 30.0D0 - 9.0D0*FID - DO 30 K=1,25 - STR = (TRM1R*Z3R-TRM1I*Z3I)/D1 - TRM1I = (TRM1R*Z3I+TRM1I*Z3R)/D1 - TRM1R = STR - S1R = S1R + TRM1R - S1I = S1I + TRM1I - STR = (TRM2R*Z3R-TRM2I*Z3I)/D2 - TRM2I = (TRM2R*Z3I+TRM2I*Z3R)/D2 - TRM2R = STR - S2R = S2R + TRM2R - S2I = S2I + TRM2I - ATRM = ATRM*AZ3/AD - D1 = D1 + AK - D2 = D2 + BK - AD = MIN(D1,D2) - IF (ATRM.LT.TOL*AD) GO TO 40 - AK = AK + 18.0D0 - BK = BK + 18.0D0 - 30 CONTINUE - 40 CONTINUE - IF (ID.EQ.1) GO TO 50 - BIR = C1*S1R + C2*(ZR*S2R-ZI*S2I) - BII = C1*S1I + C2*(ZR*S2I+ZI*S2R) - IF (KODE.EQ.1) RETURN - CALL ZSQRT(ZR, ZI, STR, STI) - ZTAR = TTH*(ZR*STR-ZI*STI) - ZTAI = TTH*(ZR*STI+ZI*STR) - AA = ZTAR - AA = -ABS(AA) - EAA = EXP(AA) - BIR = BIR*EAA - BII = BII*EAA - RETURN - 50 CONTINUE - BIR = S2R*C2 - BII = S2I*C2 - IF (AZ.LE.TOL) GO TO 60 - CC = C1/(1.0D0+FID) - STR = S1R*ZR - S1I*ZI - STI = S1R*ZI + S1I*ZR - BIR = BIR + CC*(STR*ZR-STI*ZI) - BII = BII + CC*(STR*ZI+STI*ZR) - 60 CONTINUE - IF (KODE.EQ.1) RETURN - CALL ZSQRT(ZR, ZI, STR, STI) - ZTAR = TTH*(ZR*STR-ZI*STI) - ZTAI = TTH*(ZR*STI+ZI*STR) - AA = ZTAR - AA = -ABS(AA) - EAA = EXP(AA) - BIR = BIR*EAA - BII = BII*EAA - RETURN -C----------------------------------------------------------------------- -C CASE FOR ABS(Z).GT.1.0 -C----------------------------------------------------------------------- - 70 CONTINUE - FNU = (1.0D0+FID)/3.0D0 -C----------------------------------------------------------------------- -C SET PARAMETERS RELATED TO MACHINE CONSTANTS. -C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. -C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. -C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND -C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR -C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. -C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. -C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). -C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. -C----------------------------------------------------------------------- - K1 = I1MACH(15) - K2 = I1MACH(16) - R1M5 = D1MACH(5) - K = MIN(ABS(K1),ABS(K2)) - ELIM = 2.303D0*(K*R1M5-3.0D0) - K1 = I1MACH(14) - 1 - AA = R1M5*K1 - DIG = MIN(AA,18.0D0) - AA = AA*2.303D0 - ALIM = ELIM + MAX(-AA,-41.45D0) - RL = 1.2D0*DIG + 3.0D0 - FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) -C----------------------------------------------------------------------- -C TEST FOR RANGE -C----------------------------------------------------------------------- - AA=0.5D0/TOL - BB=I1MACH(9)*0.5D0 - AA=MIN(AA,BB) - AA=AA**TTH - IF (AZ.GT.AA) GO TO 260 - AA=SQRT(AA) - IF (AZ.GT.AA) IERR=3 - CALL ZSQRT(ZR, ZI, CSQR, CSQI) - ZTAR = TTH*(ZR*CSQR-ZI*CSQI) - ZTAI = TTH*(ZR*CSQI+ZI*CSQR) -C----------------------------------------------------------------------- -C RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL -C----------------------------------------------------------------------- - SFAC = 1.0D0 - AK = ZTAI - IF (ZR.GE.0.0D0) GO TO 80 - BK = ZTAR - CK = -ABS(BK) - ZTAR = CK - ZTAI = AK - 80 CONTINUE - IF (ZI.NE.0.0D0 .OR. ZR.GT.0.0D0) GO TO 90 - ZTAR = 0.0D0 - ZTAI = AK - 90 CONTINUE - AA = ZTAR - IF (KODE.EQ.2) GO TO 100 -C----------------------------------------------------------------------- -C OVERFLOW TEST -C----------------------------------------------------------------------- - BB = ABS(AA) - IF (BB.LT.ALIM) GO TO 100 - BB = BB + 0.25D0*LOG(AZ) - SFAC = TOL - IF (BB.GT.ELIM) GO TO 190 - 100 CONTINUE - FMR = 0.0D0 - IF (AA.GE.0.0D0 .AND. ZR.GT.0.0D0) GO TO 110 - FMR = PI - IF (ZI.LT.0.0D0) FMR = -PI - ZTAR = -ZTAR - ZTAI = -ZTAI - 110 CONTINUE -C----------------------------------------------------------------------- -C AA=FACTOR FOR ANALYTIC CONTINUATION OF I(FNU,ZTA) -C KODE=2 RETURNS EXP(-ABS(XZTA))*I(FNU,ZTA) FROM CBESI -C----------------------------------------------------------------------- - CALL ZBINU(ZTAR, ZTAI, FNU, KODE, 1, CYR, CYI, NZ, RL, FNUL, TOL, - * ELIM, ALIM) - IF (NZ.LT.0) GO TO 200 - AA = FMR*FNU - Z3R = SFAC - STR = COS(AA) - STI = SIN(AA) - S1R = (STR*CYR(1)-STI*CYI(1))*Z3R - S1I = (STR*CYI(1)+STI*CYR(1))*Z3R - FNU = (2.0D0-FID)/3.0D0 - CALL ZBINU(ZTAR, ZTAI, FNU, KODE, 2, CYR, CYI, NZ, RL, FNUL, TOL, - * ELIM, ALIM) - CYR(1) = CYR(1)*Z3R - CYI(1) = CYI(1)*Z3R - CYR(2) = CYR(2)*Z3R - CYI(2) = CYI(2)*Z3R -C----------------------------------------------------------------------- -C BACKWARD RECUR ONE STEP FOR ORDERS -1/3 OR -2/3 -C----------------------------------------------------------------------- - CALL ZDIV(CYR(1), CYI(1), ZTAR, ZTAI, STR, STI) - S2R = (FNU+FNU)*STR + CYR(2) - S2I = (FNU+FNU)*STI + CYI(2) - AA = FMR*(FNU-1.0D0) - STR = COS(AA) - STI = SIN(AA) - S1R = COEF*(S1R+S2R*STR-S2I*STI) - S1I = COEF*(S1I+S2R*STI+S2I*STR) - IF (ID.EQ.1) GO TO 120 - STR = CSQR*S1R - CSQI*S1I - S1I = CSQR*S1I + CSQI*S1R - S1R = STR - BIR = S1R/SFAC - BII = S1I/SFAC - RETURN - 120 CONTINUE - STR = ZR*S1R - ZI*S1I - S1I = ZR*S1I + ZI*S1R - S1R = STR - BIR = S1R/SFAC - BII = S1I/SFAC - RETURN - 130 CONTINUE - AA = C1*(1.0D0-FID) + FID*C2 - BIR = AA - BII = 0.0D0 - RETURN - 190 CONTINUE - IERR=2 - NZ=0 - RETURN - 200 CONTINUE - IF(NZ.EQ.(-1)) GO TO 190 - NZ=0 - IERR=5 - RETURN - 260 CONTINUE - IERR=4 - NZ=0 - RETURN - END diff --git a/slatec/zbknu.f b/slatec/zbknu.f deleted file mode 100644 index 4bce16e..0000000 --- a/slatec/zbknu.f +++ /dev/null @@ -1,580 +0,0 @@ -*DECK ZBKNU - SUBROUTINE ZBKNU (ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL, ELIM, - + ALIM) -C***BEGIN PROLOGUE ZBKNU -C***SUBSIDIARY -C***PURPOSE Subsidiary to ZAIRY, ZBESH, ZBESI and ZBESK -C***LIBRARY SLATEC -C***TYPE ALL (CBKNU-A, ZBKNU-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C ZBKNU COMPUTES THE K BESSEL FUNCTION IN THE RIGHT HALF Z PLANE. -C -C***SEE ALSO ZAIRY, ZBESH, ZBESI, ZBESK -C***ROUTINES CALLED D1MACH, DGAMLN, I1MACH, ZABS, ZDIV, ZEXP, ZKSCL, -C ZLOG, ZMLT, ZSHCH, ZSQRT, ZUCHK -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C 930122 Added ZEXP, ZLOG and ZSQRT to EXTERNAL statement. (RWC) -C***END PROLOGUE ZBKNU -C - DOUBLE PRECISION AA, AK, ALIM, ASCLE, A1, A2, BB, BK, BRY, CAZ, - * CBI, CBR, CC, CCHI, CCHR, CKI, CKR, COEFI, COEFR, CONEI, CONER, - * CRSCR, CSCLR, CSHI, CSHR, CSI, CSR, CSRR, CSSR, CTWOR, - * CZEROI, CZEROR, CZI, CZR, DNU, DNU2, DPI, ELIM, ETEST, FC, FHS, - * FI, FK, FKS, FMUI, FMUR, FNU, FPI, FR, G1, G2, HPI, PI, PR, PTI, - * PTR, P1I, P1R, P2I, P2M, P2R, QI, QR, RAK, RCAZ, RTHPI, RZI, - * RZR, R1, S, SMUI, SMUR, SPI, STI, STR, S1I, S1R, S2I, S2R, TM, - * TOL, TTH, T1, T2, YI, YR, ZI, ZR, DGAMLN, D1MACH, ZABS, ELM, - * CELMR, ZDR, ZDI, AS, ALAS, HELIM, CYR, CYI - INTEGER I, IFLAG, INU, K, KFLAG, KK, KMAX, KODE, KODED, N, NZ, - * IDUM, I1MACH, J, IC, INUB, NW - DIMENSION YR(N), YI(N), CC(8), CSSR(3), CSRR(3), BRY(3), CYR(2), - * CYI(2) - EXTERNAL ZABS, ZEXP, ZLOG, ZSQRT -C COMPLEX Z,Y,A,B,RZ,SMU,FU,FMU,F,FLRZ,CZ,S1,S2,CSH,CCH -C COMPLEX CK,P,Q,COEF,P1,P2,CBK,PT,CZERO,CONE,CTWO,ST,EZ,CS,DK -C - DATA KMAX / 30 / - DATA CZEROR,CZEROI,CONER,CONEI,CTWOR,R1/ - 1 0.0D0 , 0.0D0 , 1.0D0 , 0.0D0 , 2.0D0 , 2.0D0 / - DATA DPI, RTHPI, SPI ,HPI, FPI, TTH / - 1 3.14159265358979324D0, 1.25331413731550025D0, - 2 1.90985931710274403D0, 1.57079632679489662D0, - 3 1.89769999331517738D0, 6.66666666666666666D-01/ - DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8)/ - 1 5.77215664901532861D-01, -4.20026350340952355D-02, - 2 -4.21977345555443367D-02, 7.21894324666309954D-03, - 3 -2.15241674114950973D-04, -2.01348547807882387D-05, - 4 1.13302723198169588D-06, 6.11609510448141582D-09/ -C***FIRST EXECUTABLE STATEMENT ZBKNU - CAZ = ZABS(ZR,ZI) - CSCLR = 1.0D0/TOL - CRSCR = TOL - CSSR(1) = CSCLR - CSSR(2) = 1.0D0 - CSSR(3) = CRSCR - CSRR(1) = CRSCR - CSRR(2) = 1.0D0 - CSRR(3) = CSCLR - BRY(1) = 1.0D+3*D1MACH(1)/TOL - BRY(2) = 1.0D0/BRY(1) - BRY(3) = D1MACH(2) - NZ = 0 - IFLAG = 0 - KODED = KODE - RCAZ = 1.0D0/CAZ - STR = ZR*RCAZ - STI = -ZI*RCAZ - RZR = (STR+STR)*RCAZ - RZI = (STI+STI)*RCAZ - INU = FNU+0.5D0 - DNU = FNU - INU - IF (ABS(DNU).EQ.0.5D0) GO TO 110 - DNU2 = 0.0D0 - IF (ABS(DNU).GT.TOL) DNU2 = DNU*DNU - IF (CAZ.GT.R1) GO TO 110 -C----------------------------------------------------------------------- -C SERIES FOR ABS(Z).LE.R1 -C----------------------------------------------------------------------- - FC = 1.0D0 - CALL ZLOG(RZR, RZI, SMUR, SMUI, IDUM) - FMUR = SMUR*DNU - FMUI = SMUI*DNU - CALL ZSHCH(FMUR, FMUI, CSHR, CSHI, CCHR, CCHI) - IF (DNU.EQ.0.0D0) GO TO 10 - FC = DNU*DPI - FC = FC/SIN(FC) - SMUR = CSHR/DNU - SMUI = CSHI/DNU - 10 CONTINUE - A2 = 1.0D0 + DNU -C----------------------------------------------------------------------- -C GAM(1-Z)*GAM(1+Z)=PI*Z/SIN(PI*Z), T1=1/GAM(1-DNU), T2=1/GAM(1+DNU) -C----------------------------------------------------------------------- - T2 = EXP(-DGAMLN(A2,IDUM)) - T1 = 1.0D0/(T2*FC) - IF (ABS(DNU).GT.0.1D0) GO TO 40 -C----------------------------------------------------------------------- -C SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) -C----------------------------------------------------------------------- - AK = 1.0D0 - S = CC(1) - DO 20 K=2,8 - AK = AK*DNU2 - TM = CC(K)*AK - S = S + TM - IF (ABS(TM).LT.TOL) GO TO 30 - 20 CONTINUE - 30 G1 = -S - GO TO 50 - 40 CONTINUE - G1 = (T1-T2)/(DNU+DNU) - 50 CONTINUE - G2 = (T1+T2)*0.5D0 - FR = FC*(CCHR*G1+SMUR*G2) - FI = FC*(CCHI*G1+SMUI*G2) - CALL ZEXP(FMUR, FMUI, STR, STI) - PR = 0.5D0*STR/T2 - PI = 0.5D0*STI/T2 - CALL ZDIV(0.5D0, 0.0D0, STR, STI, PTR, PTI) - QR = PTR/T1 - QI = PTI/T1 - S1R = FR - S1I = FI - S2R = PR - S2I = PI - AK = 1.0D0 - A1 = 1.0D0 - CKR = CONER - CKI = CONEI - BK = 1.0D0 - DNU2 - IF (INU.GT.0 .OR. N.GT.1) GO TO 80 -C----------------------------------------------------------------------- -C GENERATE K(FNU,Z), 0.0D0 .LE. FNU .LT. 0.5D0 AND N=1 -C----------------------------------------------------------------------- - IF (CAZ.LT.TOL) GO TO 70 - CALL ZMLT(ZR, ZI, ZR, ZI, CZR, CZI) - CZR = 0.25D0*CZR - CZI = 0.25D0*CZI - T1 = 0.25D0*CAZ*CAZ - 60 CONTINUE - FR = (FR*AK+PR+QR)/BK - FI = (FI*AK+PI+QI)/BK - STR = 1.0D0/(AK-DNU) - PR = PR*STR - PI = PI*STR - STR = 1.0D0/(AK+DNU) - QR = QR*STR - QI = QI*STR - STR = CKR*CZR - CKI*CZI - RAK = 1.0D0/AK - CKI = (CKR*CZI+CKI*CZR)*RAK - CKR = STR*RAK - S1R = CKR*FR - CKI*FI + S1R - S1I = CKR*FI + CKI*FR + S1I - A1 = A1*T1*RAK - BK = BK + AK + AK + 1.0D0 - AK = AK + 1.0D0 - IF (A1.GT.TOL) GO TO 60 - 70 CONTINUE - YR(1) = S1R - YI(1) = S1I - IF (KODED.EQ.1) RETURN - CALL ZEXP(ZR, ZI, STR, STI) - CALL ZMLT(S1R, S1I, STR, STI, YR(1), YI(1)) - RETURN -C----------------------------------------------------------------------- -C GENERATE K(DNU,Z) AND K(DNU+1,Z) FOR FORWARD RECURRENCE -C----------------------------------------------------------------------- - 80 CONTINUE - IF (CAZ.LT.TOL) GO TO 100 - CALL ZMLT(ZR, ZI, ZR, ZI, CZR, CZI) - CZR = 0.25D0*CZR - CZI = 0.25D0*CZI - T1 = 0.25D0*CAZ*CAZ - 90 CONTINUE - FR = (FR*AK+PR+QR)/BK - FI = (FI*AK+PI+QI)/BK - STR = 1.0D0/(AK-DNU) - PR = PR*STR - PI = PI*STR - STR = 1.0D0/(AK+DNU) - QR = QR*STR - QI = QI*STR - STR = CKR*CZR - CKI*CZI - RAK = 1.0D0/AK - CKI = (CKR*CZI+CKI*CZR)*RAK - CKR = STR*RAK - S1R = CKR*FR - CKI*FI + S1R - S1I = CKR*FI + CKI*FR + S1I - STR = PR - FR*AK - STI = PI - FI*AK - S2R = CKR*STR - CKI*STI + S2R - S2I = CKR*STI + CKI*STR + S2I - A1 = A1*T1*RAK - BK = BK + AK + AK + 1.0D0 - AK = AK + 1.0D0 - IF (A1.GT.TOL) GO TO 90 - 100 CONTINUE - KFLAG = 2 - A1 = FNU + 1.0D0 - AK = A1*ABS(SMUR) - IF (AK.GT.ALIM) KFLAG = 3 - STR = CSSR(KFLAG) - P2R = S2R*STR - P2I = S2I*STR - CALL ZMLT(P2R, P2I, RZR, RZI, S2R, S2I) - S1R = S1R*STR - S1I = S1I*STR - IF (KODED.EQ.1) GO TO 210 - CALL ZEXP(ZR, ZI, FR, FI) - CALL ZMLT(S1R, S1I, FR, FI, S1R, S1I) - CALL ZMLT(S2R, S2I, FR, FI, S2R, S2I) - GO TO 210 -C----------------------------------------------------------------------- -C IFLAG=0 MEANS NO UNDERFLOW OCCURRED -C IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH -C KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD -C RECURSION -C----------------------------------------------------------------------- - 110 CONTINUE - CALL ZSQRT(ZR, ZI, STR, STI) - CALL ZDIV(RTHPI, CZEROI, STR, STI, COEFR, COEFI) - KFLAG = 2 - IF (KODED.EQ.2) GO TO 120 - IF (ZR.GT.ALIM) GO TO 290 -C BLANK LINE - STR = EXP(-ZR)*CSSR(KFLAG) - STI = -STR*SIN(ZI) - STR = STR*COS(ZI) - CALL ZMLT(COEFR, COEFI, STR, STI, COEFR, COEFI) - 120 CONTINUE - IF (ABS(DNU).EQ.0.5D0) GO TO 300 -C----------------------------------------------------------------------- -C MILLER ALGORITHM FOR ABS(Z).GT.R1 -C----------------------------------------------------------------------- - AK = COS(DPI*DNU) - AK = ABS(AK) - IF (AK.EQ.CZEROR) GO TO 300 - FHS = ABS(0.25D0-DNU2) - IF (FHS.EQ.CZEROR) GO TO 300 -C----------------------------------------------------------------------- -C COMPUTE R2=F(E). IF ABS(Z).GE.R2, USE FORWARD RECURRENCE TO -C DETERMINE THE BACKWARD INDEX K. R2=F(E) IS A STRAIGHT LINE ON -C 12.LE.E.LE.60. E IS COMPUTED FROM 2**(-E)=B**(1-I1MACH(14))= -C TOL WHERE B IS THE BASE OF THE ARITHMETIC. -C----------------------------------------------------------------------- - T1 = I1MACH(14)-1 - T1 = T1*D1MACH(5)*3.321928094D0 - T1 = MAX(T1,12.0D0) - T1 = MIN(T1,60.0D0) - T2 = TTH*T1 - 6.0D0 - IF (ZR.NE.0.0D0) GO TO 130 - T1 = HPI - GO TO 140 - 130 CONTINUE - T1 = DATAN(ZI/ZR) - T1 = ABS(T1) - 140 CONTINUE - IF (T2.GT.CAZ) GO TO 170 -C----------------------------------------------------------------------- -C FORWARD RECURRENCE LOOP WHEN ABS(Z).GE.R2 -C----------------------------------------------------------------------- - ETEST = AK/(DPI*CAZ*TOL) - FK = CONER - IF (ETEST.LT.CONER) GO TO 180 - FKS = CTWOR - CKR = CAZ + CAZ + CTWOR - P1R = CZEROR - P2R = CONER - DO 150 I=1,KMAX - AK = FHS/FKS - CBR = CKR/(FK+CONER) - PTR = P2R - P2R = CBR*P2R - P1R*AK - P1R = PTR - CKR = CKR + CTWOR - FKS = FKS + FK + FK + CTWOR - FHS = FHS + FK + FK - FK = FK + CONER - STR = ABS(P2R)*FK - IF (ETEST.LT.STR) GO TO 160 - 150 CONTINUE - GO TO 310 - 160 CONTINUE - FK = FK + SPI*T1*SQRT(T2/CAZ) - FHS = ABS(0.25D0-DNU2) - GO TO 180 - 170 CONTINUE -C----------------------------------------------------------------------- -C COMPUTE BACKWARD INDEX K FOR ABS(Z).LT.R2 -C----------------------------------------------------------------------- - A2 = SQRT(CAZ) - AK = FPI*AK/(TOL*SQRT(A2)) - AA = 3.0D0*T1/(1.0D0+CAZ) - BB = 14.7D0*T1/(28.0D0+CAZ) - AK = (LOG(AK)+CAZ*COS(AA)/(1.0D0+0.008D0*CAZ))/COS(BB) - FK = 0.12125D0*AK*AK/CAZ + 1.5D0 - 180 CONTINUE -C----------------------------------------------------------------------- -C BACKWARD RECURRENCE LOOP FOR MILLER ALGORITHM -C----------------------------------------------------------------------- - K = FK - FK = K - FKS = FK*FK - P1R = CZEROR - P1I = CZEROI - P2R = TOL - P2I = CZEROI - CSR = P2R - CSI = P2I - DO 190 I=1,K - A1 = FKS - FK - AK = (FKS+FK)/(A1+FHS) - RAK = 2.0D0/(FK+CONER) - CBR = (FK+ZR)*RAK - CBI = ZI*RAK - PTR = P2R - PTI = P2I - P2R = (PTR*CBR-PTI*CBI-P1R)*AK - P2I = (PTI*CBR+PTR*CBI-P1I)*AK - P1R = PTR - P1I = PTI - CSR = CSR + P2R - CSI = CSI + P2I - FKS = A1 - FK + CONER - FK = FK - CONER - 190 CONTINUE -C----------------------------------------------------------------------- -C COMPUTE (P2/CS)=(P2/ABS(CS))*(CONJG(CS)/ABS(CS)) FOR BETTER -C SCALING -C----------------------------------------------------------------------- - TM = ZABS(CSR,CSI) - PTR = 1.0D0/TM - S1R = P2R*PTR - S1I = P2I*PTR - CSR = CSR*PTR - CSI = -CSI*PTR - CALL ZMLT(COEFR, COEFI, S1R, S1I, STR, STI) - CALL ZMLT(STR, STI, CSR, CSI, S1R, S1I) - IF (INU.GT.0 .OR. N.GT.1) GO TO 200 - ZDR = ZR - ZDI = ZI - IF(IFLAG.EQ.1) GO TO 270 - GO TO 240 - 200 CONTINUE -C----------------------------------------------------------------------- -C COMPUTE P1/P2=(P1/ABS(P2)*CONJG(P2)/ABS(P2) FOR SCALING -C----------------------------------------------------------------------- - TM = ZABS(P2R,P2I) - PTR = 1.0D0/TM - P1R = P1R*PTR - P1I = P1I*PTR - P2R = P2R*PTR - P2I = -P2I*PTR - CALL ZMLT(P1R, P1I, P2R, P2I, PTR, PTI) - STR = DNU + 0.5D0 - PTR - STI = -PTI - CALL ZDIV(STR, STI, ZR, ZI, STR, STI) - STR = STR + 1.0D0 - CALL ZMLT(STR, STI, S1R, S1I, S2R, S2I) -C----------------------------------------------------------------------- -C FORWARD RECURSION ON THE THREE TERM RECURSION WITH RELATION WITH -C SCALING NEAR EXPONENT EXTREMES ON KFLAG=1 OR KFLAG=3 -C----------------------------------------------------------------------- - 210 CONTINUE - STR = DNU + 1.0D0 - CKR = STR*RZR - CKI = STR*RZI - IF (N.EQ.1) INU = INU - 1 - IF (INU.GT.0) GO TO 220 - IF (N.GT.1) GO TO 215 - S1R = S2R - S1I = S2I - 215 CONTINUE - ZDR = ZR - ZDI = ZI - IF(IFLAG.EQ.1) GO TO 270 - GO TO 240 - 220 CONTINUE - INUB = 1 - IF(IFLAG.EQ.1) GO TO 261 - 225 CONTINUE - P1R = CSRR(KFLAG) - ASCLE = BRY(KFLAG) - DO 230 I=INUB,INU - STR = S2R - STI = S2I - S2R = CKR*STR - CKI*STI + S1R - S2I = CKR*STI + CKI*STR + S1I - S1R = STR - S1I = STI - CKR = CKR + RZR - CKI = CKI + RZI - IF (KFLAG.GE.3) GO TO 230 - P2R = S2R*P1R - P2I = S2I*P1R - STR = ABS(P2R) - STI = ABS(P2I) - P2M = MAX(STR,STI) - IF (P2M.LE.ASCLE) GO TO 230 - KFLAG = KFLAG + 1 - ASCLE = BRY(KFLAG) - S1R = S1R*P1R - S1I = S1I*P1R - S2R = P2R - S2I = P2I - STR = CSSR(KFLAG) - S1R = S1R*STR - S1I = S1I*STR - S2R = S2R*STR - S2I = S2I*STR - P1R = CSRR(KFLAG) - 230 CONTINUE - IF (N.NE.1) GO TO 240 - S1R = S2R - S1I = S2I - 240 CONTINUE - STR = CSRR(KFLAG) - YR(1) = S1R*STR - YI(1) = S1I*STR - IF (N.EQ.1) RETURN - YR(2) = S2R*STR - YI(2) = S2I*STR - IF (N.EQ.2) RETURN - KK = 2 - 250 CONTINUE - KK = KK + 1 - IF (KK.GT.N) RETURN - P1R = CSRR(KFLAG) - ASCLE = BRY(KFLAG) - DO 260 I=KK,N - P2R = S2R - P2I = S2I - S2R = CKR*P2R - CKI*P2I + S1R - S2I = CKI*P2R + CKR*P2I + S1I - S1R = P2R - S1I = P2I - CKR = CKR + RZR - CKI = CKI + RZI - P2R = S2R*P1R - P2I = S2I*P1R - YR(I) = P2R - YI(I) = P2I - IF (KFLAG.GE.3) GO TO 260 - STR = ABS(P2R) - STI = ABS(P2I) - P2M = MAX(STR,STI) - IF (P2M.LE.ASCLE) GO TO 260 - KFLAG = KFLAG + 1 - ASCLE = BRY(KFLAG) - S1R = S1R*P1R - S1I = S1I*P1R - S2R = P2R - S2I = P2I - STR = CSSR(KFLAG) - S1R = S1R*STR - S1I = S1I*STR - S2R = S2R*STR - S2I = S2I*STR - P1R = CSRR(KFLAG) - 260 CONTINUE - RETURN -C----------------------------------------------------------------------- -C IFLAG=1 CASES, FORWARD RECURRENCE ON SCALED VALUES ON UNDERFLOW -C----------------------------------------------------------------------- - 261 CONTINUE - HELIM = 0.5D0*ELIM - ELM = EXP(-ELIM) - CELMR = ELM - ASCLE = BRY(1) - ZDR = ZR - ZDI = ZI - IC = -1 - J = 2 - DO 262 I=1,INU - STR = S2R - STI = S2I - S2R = STR*CKR-STI*CKI+S1R - S2I = STI*CKR+STR*CKI+S1I - S1R = STR - S1I = STI - CKR = CKR+RZR - CKI = CKI+RZI - AS = ZABS(S2R,S2I) - ALAS = LOG(AS) - P2R = -ZDR+ALAS - IF(P2R.LT.(-ELIM)) GO TO 263 - CALL ZLOG(S2R,S2I,STR,STI,IDUM) - P2R = -ZDR+STR - P2I = -ZDI+STI - P2M = EXP(P2R)/TOL - P1R = P2M*COS(P2I) - P1I = P2M*SIN(P2I) - CALL ZUCHK(P1R,P1I,NW,ASCLE,TOL) - IF(NW.NE.0) GO TO 263 - J = 3 - J - CYR(J) = P1R - CYI(J) = P1I - IF(IC.EQ.(I-1)) GO TO 264 - IC = I - GO TO 262 - 263 CONTINUE - IF(ALAS.LT.HELIM) GO TO 262 - ZDR = ZDR-ELIM - S1R = S1R*CELMR - S1I = S1I*CELMR - S2R = S2R*CELMR - S2I = S2I*CELMR - 262 CONTINUE - IF(N.NE.1) GO TO 270 - S1R = S2R - S1I = S2I - GO TO 270 - 264 CONTINUE - KFLAG = 1 - INUB = I+1 - S2R = CYR(J) - S2I = CYI(J) - J = 3 - J - S1R = CYR(J) - S1I = CYI(J) - IF(INUB.LE.INU) GO TO 225 - IF(N.NE.1) GO TO 240 - S1R = S2R - S1I = S2I - GO TO 240 - 270 CONTINUE - YR(1) = S1R - YI(1) = S1I - IF(N.EQ.1) GO TO 280 - YR(2) = S2R - YI(2) = S2I - 280 CONTINUE - ASCLE = BRY(1) - CALL ZKSCL(ZDR,ZDI,FNU,N,YR,YI,NZ,RZR,RZI,ASCLE,TOL,ELIM) - INU = N - NZ - IF (INU.LE.0) RETURN - KK = NZ + 1 - S1R = YR(KK) - S1I = YI(KK) - YR(KK) = S1R*CSRR(1) - YI(KK) = S1I*CSRR(1) - IF (INU.EQ.1) RETURN - KK = NZ + 2 - S2R = YR(KK) - S2I = YI(KK) - YR(KK) = S2R*CSRR(1) - YI(KK) = S2I*CSRR(1) - IF (INU.EQ.2) RETURN - T2 = FNU + (KK-1) - CKR = T2*RZR - CKI = T2*RZI - KFLAG = 1 - GO TO 250 - 290 CONTINUE -C----------------------------------------------------------------------- -C SCALE BY EXP(Z), IFLAG = 1 CASES -C----------------------------------------------------------------------- - KODED = 2 - IFLAG = 1 - KFLAG = 2 - GO TO 120 -C----------------------------------------------------------------------- -C FNU=HALF ODD INTEGER CASE, DNU=-0.5 -C----------------------------------------------------------------------- - 300 CONTINUE - S1R = COEFR - S1I = COEFI - S2R = COEFR - S2I = COEFI - GO TO 210 -C -C - 310 CONTINUE - NZ=-2 - RETURN - END diff --git a/slatec/zbuni.f b/slatec/zbuni.f deleted file mode 100644 index 03f32be..0000000 --- a/slatec/zbuni.f +++ /dev/null @@ -1,186 +0,0 @@ -*DECK ZBUNI - SUBROUTINE ZBUNI (ZR, ZI, FNU, KODE, N, YR, YI, NZ, NUI, NLAST, - + FNUL, TOL, ELIM, ALIM) -C***BEGIN PROLOGUE ZBUNI -C***SUBSIDIARY -C***PURPOSE Subsidiary to ZBESI and ZBESK -C***LIBRARY SLATEC -C***TYPE ALL (CBUNI-A, ZBUNI-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C ZBUNI COMPUTES THE I BESSEL FUNCTION FOR LARGE ABS(Z).GT. -C FNUL AND FNU+N-1.LT.FNUL. THE ORDER IS INCREASED FROM -C FNU+N-1 GREATER THAN FNUL BY ADDING NUI AND COMPUTING -C ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR I(FNU,Z) -C ON IFORM=1 AND THE EXPANSION FOR J(FNU,Z) ON IFORM=2 -C -C***SEE ALSO ZBESI, ZBESK -C***ROUTINES CALLED D1MACH, ZABS, ZUNI1, ZUNI2 -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE ZBUNI -C COMPLEX CSCL,CSCR,CY,RZ,ST,S1,S2,Y,Z - DOUBLE PRECISION ALIM, AX, AY, CSCLR, CSCRR, CYI, CYR, DFNU, - * ELIM, FNU, FNUI, FNUL, GNU, RAZ, RZI, RZR, STI, STR, S1I, S1R, - * S2I, S2R, TOL, YI, YR, ZI, ZR, ZABS, ASCLE, BRY, C1R, C1I, C1M, - * D1MACH - INTEGER I, IFLAG, IFORM, K, KODE, N, NL, NLAST, NUI, NW, NZ - DIMENSION YR(N), YI(N), CYR(2), CYI(2), BRY(3) - EXTERNAL ZABS -C***FIRST EXECUTABLE STATEMENT ZBUNI - NZ = 0 - AX = ABS(ZR)*1.7321D0 - AY = ABS(ZI) - IFORM = 1 - IF (AY.GT.AX) IFORM = 2 - IF (NUI.EQ.0) GO TO 60 - FNUI = NUI - DFNU = FNU + (N-1) - GNU = DFNU + FNUI - IF (IFORM.EQ.2) GO TO 10 -C----------------------------------------------------------------------- -C ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN -C -PI/3.LE.ARG(Z).LE.PI/3 -C----------------------------------------------------------------------- - CALL ZUNI1(ZR, ZI, GNU, KODE, 2, CYR, CYI, NW, NLAST, FNUL, TOL, - * ELIM, ALIM) - GO TO 20 - 10 CONTINUE -C----------------------------------------------------------------------- -C ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU -C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I -C AND HPI=PI/2 -C----------------------------------------------------------------------- - CALL ZUNI2(ZR, ZI, GNU, KODE, 2, CYR, CYI, NW, NLAST, FNUL, TOL, - * ELIM, ALIM) - 20 CONTINUE - IF (NW.LT.0) GO TO 50 - IF (NW.NE.0) GO TO 90 - STR = ZABS(CYR(1),CYI(1)) -C---------------------------------------------------------------------- -C SCALE BACKWARD RECURRENCE, BRY(3) IS DEFINED BUT NEVER USED -C---------------------------------------------------------------------- - BRY(1)=1.0D+3*D1MACH(1)/TOL - BRY(2) = 1.0D0/BRY(1) - BRY(3) = BRY(2) - IFLAG = 2 - ASCLE = BRY(2) - CSCLR = 1.0D0 - IF (STR.GT.BRY(1)) GO TO 21 - IFLAG = 1 - ASCLE = BRY(1) - CSCLR = 1.0D0/TOL - GO TO 25 - 21 CONTINUE - IF (STR.LT.BRY(2)) GO TO 25 - IFLAG = 3 - ASCLE=BRY(3) - CSCLR = TOL - 25 CONTINUE - CSCRR = 1.0D0/CSCLR - S1R = CYR(2)*CSCLR - S1I = CYI(2)*CSCLR - S2R = CYR(1)*CSCLR - S2I = CYI(1)*CSCLR - RAZ = 1.0D0/ZABS(ZR,ZI) - STR = ZR*RAZ - STI = -ZI*RAZ - RZR = (STR+STR)*RAZ - RZI = (STI+STI)*RAZ - DO 30 I=1,NUI - STR = S2R - STI = S2I - S2R = (DFNU+FNUI)*(RZR*STR-RZI*STI) + S1R - S2I = (DFNU+FNUI)*(RZR*STI+RZI*STR) + S1I - S1R = STR - S1I = STI - FNUI = FNUI - 1.0D0 - IF (IFLAG.GE.3) GO TO 30 - STR = S2R*CSCRR - STI = S2I*CSCRR - C1R = ABS(STR) - C1I = ABS(STI) - C1M = MAX(C1R,C1I) - IF (C1M.LE.ASCLE) GO TO 30 - IFLAG = IFLAG+1 - ASCLE = BRY(IFLAG) - S1R = S1R*CSCRR - S1I = S1I*CSCRR - S2R = STR - S2I = STI - CSCLR = CSCLR*TOL - CSCRR = 1.0D0/CSCLR - S1R = S1R*CSCLR - S1I = S1I*CSCLR - S2R = S2R*CSCLR - S2I = S2I*CSCLR - 30 CONTINUE - YR(N) = S2R*CSCRR - YI(N) = S2I*CSCRR - IF (N.EQ.1) RETURN - NL = N - 1 - FNUI = NL - K = NL - DO 40 I=1,NL - STR = S2R - STI = S2I - S2R = (FNU+FNUI)*(RZR*STR-RZI*STI) + S1R - S2I = (FNU+FNUI)*(RZR*STI+RZI*STR) + S1I - S1R = STR - S1I = STI - STR = S2R*CSCRR - STI = S2I*CSCRR - YR(K) = STR - YI(K) = STI - FNUI = FNUI - 1.0D0 - K = K - 1 - IF (IFLAG.GE.3) GO TO 40 - C1R = ABS(STR) - C1I = ABS(STI) - C1M = MAX(C1R,C1I) - IF (C1M.LE.ASCLE) GO TO 40 - IFLAG = IFLAG+1 - ASCLE = BRY(IFLAG) - S1R = S1R*CSCRR - S1I = S1I*CSCRR - S2R = STR - S2I = STI - CSCLR = CSCLR*TOL - CSCRR = 1.0D0/CSCLR - S1R = S1R*CSCLR - S1I = S1I*CSCLR - S2R = S2R*CSCLR - S2I = S2I*CSCLR - 40 CONTINUE - RETURN - 50 CONTINUE - NZ = -1 - IF(NW.EQ.(-2)) NZ=-2 - RETURN - 60 CONTINUE - IF (IFORM.EQ.2) GO TO 70 -C----------------------------------------------------------------------- -C ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN -C -PI/3.LE.ARG(Z).LE.PI/3 -C----------------------------------------------------------------------- - CALL ZUNI1(ZR, ZI, FNU, KODE, N, YR, YI, NW, NLAST, FNUL, TOL, - * ELIM, ALIM) - GO TO 80 - 70 CONTINUE -C----------------------------------------------------------------------- -C ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU -C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I -C AND HPI=PI/2 -C----------------------------------------------------------------------- - CALL ZUNI2(ZR, ZI, FNU, KODE, N, YR, YI, NW, NLAST, FNUL, TOL, - * ELIM, ALIM) - 80 CONTINUE - IF (NW.LT.0) GO TO 50 - NZ = NW - RETURN - 90 CONTINUE - NLAST = N - RETURN - END diff --git a/slatec/zbunk.f b/slatec/zbunk.f deleted file mode 100644 index 398742a..0000000 --- a/slatec/zbunk.f +++ /dev/null @@ -1,46 +0,0 @@ -*DECK ZBUNK - SUBROUTINE ZBUNK (ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, - + ALIM) -C***BEGIN PROLOGUE ZBUNK -C***SUBSIDIARY -C***PURPOSE Subsidiary to ZBESH and ZBESK -C***LIBRARY SLATEC -C***TYPE ALL (CBUNI-A, ZBUNI-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C ZBUNK COMPUTES THE K BESSEL FUNCTION FOR FNU.GT.FNUL. -C ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR K(FNU,Z) -C IN ZUNK1 AND THE EXPANSION FOR H(2,FNU,Z) IN ZUNK2 -C -C***SEE ALSO ZBESH, ZBESK -C***ROUTINES CALLED ZUNK1, ZUNK2 -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE ZBUNK -C COMPLEX Y,Z - DOUBLE PRECISION ALIM, AX, AY, ELIM, FNU, TOL, YI, YR, ZI, ZR - INTEGER KODE, MR, N, NZ - DIMENSION YR(N), YI(N) -C***FIRST EXECUTABLE STATEMENT ZBUNK - NZ = 0 - AX = ABS(ZR)*1.7321D0 - AY = ABS(ZI) - IF (AY.GT.AX) GO TO 10 -C----------------------------------------------------------------------- -C ASYMPTOTIC EXPANSION FOR K(FNU,Z) FOR LARGE FNU APPLIED IN -C -PI/3.LE.ARG(Z).LE.PI/3 -C----------------------------------------------------------------------- - CALL ZUNK1(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, ALIM) - GO TO 20 - 10 CONTINUE -C----------------------------------------------------------------------- -C ASYMPTOTIC EXPANSION FOR H(2,FNU,Z*EXP(M*HPI)) FOR LARGE FNU -C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I -C AND HPI=PI/2 -C----------------------------------------------------------------------- - CALL ZUNK2(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, ALIM) - 20 CONTINUE - RETURN - END diff --git a/slatec/zdiv.f b/slatec/zdiv.f deleted file mode 100644 index 83bb12b..0000000 --- a/slatec/zdiv.f +++ /dev/null @@ -1,32 +0,0 @@ -*DECK ZDIV - SUBROUTINE ZDIV (AR, AI, BR, BI, CR, CI) -C***BEGIN PROLOGUE ZDIV -C***SUBSIDIARY -C***PURPOSE Subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and -C ZBIRY -C***LIBRARY SLATEC -C***TYPE ALL (ZDIV-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C DOUBLE PRECISION COMPLEX DIVIDE C=A/B. -C -C***SEE ALSO ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZBIRY -C***ROUTINES CALLED ZABS -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE ZDIV - DOUBLE PRECISION AR, AI, BR, BI, CR, CI, BM, CA, CB, CC, CD - DOUBLE PRECISION ZABS - EXTERNAL ZABS -C***FIRST EXECUTABLE STATEMENT ZDIV - BM = 1.0D0/ZABS(BR,BI) - CC = BR*BM - CD = BI*BM - CA = (AR*CC+AI*CD)*BM - CB = (AI*CC-AR*CD)*BM - CR = CA - CI = CB - RETURN - END diff --git a/slatec/zexp.f b/slatec/zexp.f deleted file mode 100644 index 63ba0e0..0000000 --- a/slatec/zexp.f +++ /dev/null @@ -1,28 +0,0 @@ -*DECK ZEXP - SUBROUTINE ZEXP (AR, AI, BR, BI) -C***BEGIN PROLOGUE ZEXP -C***SUBSIDIARY -C***PURPOSE Subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and -C ZBIRY -C***LIBRARY SLATEC -C***TYPE ALL (ZEXP-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C DOUBLE PRECISION COMPLEX EXPONENTIAL FUNCTION B=EXP(A) -C -C***SEE ALSO ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZBIRY -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE ZEXP - DOUBLE PRECISION AR, AI, BR, BI, ZM, CA, CB -C***FIRST EXECUTABLE STATEMENT ZEXP - ZM = EXP(AR) - CA = ZM*COS(AI) - CB = ZM*SIN(AI) - BR = CA - BI = CB - RETURN - END diff --git a/slatec/zkscl.f b/slatec/zkscl.f deleted file mode 100644 index 9d7c300..0000000 --- a/slatec/zkscl.f +++ /dev/null @@ -1,134 +0,0 @@ -*DECK ZKSCL - SUBROUTINE ZKSCL (ZRR, ZRI, FNU, N, YR, YI, NZ, RZR, RZI, ASCLE, - + TOL, ELIM) -C***BEGIN PROLOGUE ZKSCL -C***SUBSIDIARY -C***PURPOSE Subsidiary to ZBESK -C***LIBRARY SLATEC -C***TYPE ALL (CKSCL-A, ZKSCL-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C SET K FUNCTIONS TO ZERO ON UNDERFLOW, CONTINUE RECURRENCE -C ON SCALED FUNCTIONS UNTIL TWO MEMBERS COME ON SCALE, THEN -C RETURN WITH MIN(NZ+2,N) VALUES SCALED BY 1/TOL. -C -C***SEE ALSO ZBESK -C***ROUTINES CALLED ZABS, ZLOG, ZUCHK -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C 930122 Added ZLOG to EXTERNAL statement. (RWC) -C***END PROLOGUE ZKSCL -C COMPLEX CK,CS,CY,CZERO,RZ,S1,S2,Y,ZR,ZD,CELM - DOUBLE PRECISION ACS, AS, ASCLE, CKI, CKR, CSI, CSR, CYI, - * CYR, ELIM, FN, FNU, RZI, RZR, STR, S1I, S1R, S2I, - * S2R, TOL, YI, YR, ZEROI, ZEROR, ZRI, ZRR, ZABS, - * ZDR, ZDI, CELMR, ELM, HELIM, ALAS - INTEGER I, IC, IDUM, KK, N, NN, NW, NZ - DIMENSION YR(N), YI(N), CYR(2), CYI(2) - EXTERNAL ZABS, ZLOG - DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 / -C***FIRST EXECUTABLE STATEMENT ZKSCL - NZ = 0 - IC = 0 - NN = MIN(2,N) - DO 10 I=1,NN - S1R = YR(I) - S1I = YI(I) - CYR(I) = S1R - CYI(I) = S1I - AS = ZABS(S1R,S1I) - ACS = -ZRR + LOG(AS) - NZ = NZ + 1 - YR(I) = ZEROR - YI(I) = ZEROI - IF (ACS.LT.(-ELIM)) GO TO 10 - CALL ZLOG(S1R, S1I, CSR, CSI, IDUM) - CSR = CSR - ZRR - CSI = CSI - ZRI - STR = EXP(CSR)/TOL - CSR = STR*COS(CSI) - CSI = STR*SIN(CSI) - CALL ZUCHK(CSR, CSI, NW, ASCLE, TOL) - IF (NW.NE.0) GO TO 10 - YR(I) = CSR - YI(I) = CSI - IC = I - NZ = NZ - 1 - 10 CONTINUE - IF (N.EQ.1) RETURN - IF (IC.GT.1) GO TO 20 - YR(1) = ZEROR - YI(1) = ZEROI - NZ = 2 - 20 CONTINUE - IF (N.EQ.2) RETURN - IF (NZ.EQ.0) RETURN - FN = FNU + 1.0D0 - CKR = FN*RZR - CKI = FN*RZI - S1R = CYR(1) - S1I = CYI(1) - S2R = CYR(2) - S2I = CYI(2) - HELIM = 0.5D0*ELIM - ELM = EXP(-ELIM) - CELMR = ELM - ZDR = ZRR - ZDI = ZRI -C -C FIND TWO CONSECUTIVE Y VALUES ON SCALE. SCALE RECURRENCE IF -C S2 GETS LARGER THAN EXP(ELIM/2) -C - DO 30 I=3,N - KK = I - CSR = S2R - CSI = S2I - S2R = CKR*CSR - CKI*CSI + S1R - S2I = CKI*CSR + CKR*CSI + S1I - S1R = CSR - S1I = CSI - CKR = CKR + RZR - CKI = CKI + RZI - AS = ZABS(S2R,S2I) - ALAS = LOG(AS) - ACS = -ZDR + ALAS - NZ = NZ + 1 - YR(I) = ZEROR - YI(I) = ZEROI - IF (ACS.LT.(-ELIM)) GO TO 25 - CALL ZLOG(S2R, S2I, CSR, CSI, IDUM) - CSR = CSR - ZDR - CSI = CSI - ZDI - STR = EXP(CSR)/TOL - CSR = STR*COS(CSI) - CSI = STR*SIN(CSI) - CALL ZUCHK(CSR, CSI, NW, ASCLE, TOL) - IF (NW.NE.0) GO TO 25 - YR(I) = CSR - YI(I) = CSI - NZ = NZ - 1 - IF (IC.EQ.KK-1) GO TO 40 - IC = KK - GO TO 30 - 25 CONTINUE - IF(ALAS.LT.HELIM) GO TO 30 - ZDR = ZDR - ELIM - S1R = S1R*CELMR - S1I = S1I*CELMR - S2R = S2R*CELMR - S2I = S2I*CELMR - 30 CONTINUE - NZ = N - IF(IC.EQ.N) NZ=N-1 - GO TO 45 - 40 CONTINUE - NZ = KK - 2 - 45 CONTINUE - DO 50 I=1,NZ - YR(I) = ZEROR - YI(I) = ZEROI - 50 CONTINUE - RETURN - END diff --git a/slatec/zlog.f b/slatec/zlog.f deleted file mode 100644 index cb17d25..0000000 --- a/slatec/zlog.f +++ /dev/null @@ -1,54 +0,0 @@ -*DECK ZLOG - SUBROUTINE ZLOG (AR, AI, BR, BI, IERR) -C***BEGIN PROLOGUE ZLOG -C***SUBSIDIARY -C***PURPOSE Subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and -C ZBIRY -C***LIBRARY SLATEC -C***TYPE ALL (ZLOG-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C DOUBLE PRECISION COMPLEX LOGARITHM B=CLOG(A) -C IERR=0,NORMAL RETURN IERR=1, Z=CMPLX(0.0,0.0) -C***SEE ALSO ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZBIRY -C***ROUTINES CALLED ZABS -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE ZLOG - DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DHPI - DOUBLE PRECISION ZABS - INTEGER IERR - EXTERNAL ZABS - DATA DPI , DHPI / 3.141592653589793238462643383D+0, - 1 1.570796326794896619231321696D+0/ -C***FIRST EXECUTABLE STATEMENT ZLOG - IERR=0 - IF (AR.EQ.0.0D+0) GO TO 10 - IF (AI.EQ.0.0D+0) GO TO 20 - DTHETA = DATAN(AI/AR) - IF (DTHETA.LE.0.0D+0) GO TO 40 - IF (AR.LT.0.0D+0) DTHETA = DTHETA - DPI - GO TO 50 - 10 IF (AI.EQ.0.0D+0) GO TO 60 - BI = DHPI - BR = LOG(ABS(AI)) - IF (AI.LT.0.0D+0) BI = -BI - RETURN - 20 IF (AR.GT.0.0D+0) GO TO 30 - BR = LOG(ABS(AR)) - BI = DPI - RETURN - 30 BR = LOG(AR) - BI = 0.0D+0 - RETURN - 40 IF (AR.LT.0.0D+0) DTHETA = DTHETA + DPI - 50 ZM = ZABS(AR,AI) - BR = LOG(ZM) - BI = DTHETA - RETURN - 60 CONTINUE - IERR=1 - RETURN - END diff --git a/slatec/zmlri.f b/slatec/zmlri.f deleted file mode 100644 index 32a208e..0000000 --- a/slatec/zmlri.f +++ /dev/null @@ -1,217 +0,0 @@ -*DECK ZMLRI - SUBROUTINE ZMLRI (ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL) -C***BEGIN PROLOGUE ZMLRI -C***SUBSIDIARY -C***PURPOSE Subsidiary to ZBESI and ZBESK -C***LIBRARY SLATEC -C***TYPE ALL (CMLRI-A, ZMLRI-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C ZMLRI COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY THE -C MILLER ALGORITHM NORMALIZED BY A NEUMANN SERIES. -C -C***SEE ALSO ZBESI, ZBESK -C***ROUTINES CALLED D1MACH, DGAMLN, ZABS, ZEXP, ZLOG, ZMLT -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C 930122 Added ZEXP and ZLOG to EXTERNAL statement. (RWC) -C***END PROLOGUE ZMLRI -C COMPLEX CK,CNORM,CONE,CTWO,CZERO,PT,P1,P2,RZ,SUM,Y,Z - DOUBLE PRECISION ACK, AK, AP, AT, AZ, BK, CKI, CKR, CNORMI, - * CNORMR, CONEI, CONER, FKAP, FKK, FLAM, FNF, FNU, PTI, PTR, P1I, - * P1R, P2I, P2R, RAZ, RHO, RHO2, RZI, RZR, SCLE, STI, STR, SUMI, - * SUMR, TFNF, TOL, TST, YI, YR, ZEROI, ZEROR, ZI, ZR, DGAMLN, - * D1MACH, ZABS - INTEGER I, IAZ, IDUM, IFNU, INU, ITIME, K, KK, KM, KODE, M, N, NZ - DIMENSION YR(N), YI(N) - EXTERNAL ZABS, ZEXP, ZLOG - DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / -C***FIRST EXECUTABLE STATEMENT ZMLRI - SCLE = D1MACH(1)/TOL - NZ=0 - AZ = ZABS(ZR,ZI) - IAZ = AZ - IFNU = FNU - INU = IFNU + N - 1 - AT = IAZ + 1.0D0 - RAZ = 1.0D0/AZ - STR = ZR*RAZ - STI = -ZI*RAZ - CKR = STR*AT*RAZ - CKI = STI*AT*RAZ - RZR = (STR+STR)*RAZ - RZI = (STI+STI)*RAZ - P1R = ZEROR - P1I = ZEROI - P2R = CONER - P2I = CONEI - ACK = (AT+1.0D0)*RAZ - RHO = ACK + SQRT(ACK*ACK-1.0D0) - RHO2 = RHO*RHO - TST = (RHO2+RHO2)/((RHO2-1.0D0)*(RHO-1.0D0)) - TST = TST/TOL -C----------------------------------------------------------------------- -C COMPUTE RELATIVE TRUNCATION ERROR INDEX FOR SERIES -C----------------------------------------------------------------------- - AK = AT - DO 10 I=1,80 - PTR = P2R - PTI = P2I - P2R = P1R - (CKR*PTR-CKI*PTI) - P2I = P1I - (CKI*PTR+CKR*PTI) - P1R = PTR - P1I = PTI - CKR = CKR + RZR - CKI = CKI + RZI - AP = ZABS(P2R,P2I) - IF (AP.GT.TST*AK*AK) GO TO 20 - AK = AK + 1.0D0 - 10 CONTINUE - GO TO 110 - 20 CONTINUE - I = I + 1 - K = 0 - IF (INU.LT.IAZ) GO TO 40 -C----------------------------------------------------------------------- -C COMPUTE RELATIVE TRUNCATION ERROR FOR RATIOS -C----------------------------------------------------------------------- - P1R = ZEROR - P1I = ZEROI - P2R = CONER - P2I = CONEI - AT = INU + 1.0D0 - STR = ZR*RAZ - STI = -ZI*RAZ - CKR = STR*AT*RAZ - CKI = STI*AT*RAZ - ACK = AT*RAZ - TST = SQRT(ACK/TOL) - ITIME = 1 - DO 30 K=1,80 - PTR = P2R - PTI = P2I - P2R = P1R - (CKR*PTR-CKI*PTI) - P2I = P1I - (CKR*PTI+CKI*PTR) - P1R = PTR - P1I = PTI - CKR = CKR + RZR - CKI = CKI + RZI - AP = ZABS(P2R,P2I) - IF (AP.LT.TST) GO TO 30 - IF (ITIME.EQ.2) GO TO 40 - ACK = ZABS(CKR,CKI) - FLAM = ACK + SQRT(ACK*ACK-1.0D0) - FKAP = AP/ZABS(P1R,P1I) - RHO = MIN(FLAM,FKAP) - TST = TST*SQRT(RHO/(RHO*RHO-1.0D0)) - ITIME = 2 - 30 CONTINUE - GO TO 110 - 40 CONTINUE -C----------------------------------------------------------------------- -C BACKWARD RECURRENCE AND SUM NORMALIZING RELATION -C----------------------------------------------------------------------- - K = K + 1 - KK = MAX(I+IAZ,K+INU) - FKK = KK - P1R = ZEROR - P1I = ZEROI -C----------------------------------------------------------------------- -C SCALE P2 AND SUM BY SCLE -C----------------------------------------------------------------------- - P2R = SCLE - P2I = ZEROI - FNF = FNU - IFNU - TFNF = FNF + FNF - BK = DGAMLN(FKK+TFNF+1.0D0,IDUM) - DGAMLN(FKK+1.0D0,IDUM) - - * DGAMLN(TFNF+1.0D0,IDUM) - BK = EXP(BK) - SUMR = ZEROR - SUMI = ZEROI - KM = KK - INU - DO 50 I=1,KM - PTR = P2R - PTI = P2I - P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI) - P2I = P1I + (FKK+FNF)*(RZI*PTR+RZR*PTI) - P1R = PTR - P1I = PTI - AK = 1.0D0 - TFNF/(FKK+TFNF) - ACK = BK*AK - SUMR = SUMR + (ACK+BK)*P1R - SUMI = SUMI + (ACK+BK)*P1I - BK = ACK - FKK = FKK - 1.0D0 - 50 CONTINUE - YR(N) = P2R - YI(N) = P2I - IF (N.EQ.1) GO TO 70 - DO 60 I=2,N - PTR = P2R - PTI = P2I - P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI) - P2I = P1I + (FKK+FNF)*(RZI*PTR+RZR*PTI) - P1R = PTR - P1I = PTI - AK = 1.0D0 - TFNF/(FKK+TFNF) - ACK = BK*AK - SUMR = SUMR + (ACK+BK)*P1R - SUMI = SUMI + (ACK+BK)*P1I - BK = ACK - FKK = FKK - 1.0D0 - M = N - I + 1 - YR(M) = P2R - YI(M) = P2I - 60 CONTINUE - 70 CONTINUE - IF (IFNU.LE.0) GO TO 90 - DO 80 I=1,IFNU - PTR = P2R - PTI = P2I - P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI) - P2I = P1I + (FKK+FNF)*(RZR*PTI+RZI*PTR) - P1R = PTR - P1I = PTI - AK = 1.0D0 - TFNF/(FKK+TFNF) - ACK = BK*AK - SUMR = SUMR + (ACK+BK)*P1R - SUMI = SUMI + (ACK+BK)*P1I - BK = ACK - FKK = FKK - 1.0D0 - 80 CONTINUE - 90 CONTINUE - PTR = ZR - PTI = ZI - IF (KODE.EQ.2) PTR = ZEROR - CALL ZLOG(RZR, RZI, STR, STI, IDUM) - P1R = -FNF*STR + PTR - P1I = -FNF*STI + PTI - AP = DGAMLN(1.0D0+FNF,IDUM) - PTR = P1R - AP - PTI = P1I -C----------------------------------------------------------------------- -C THE DIVISION CEXP(PT)/(SUM+P2) IS ALTERED TO AVOID OVERFLOW -C IN THE DENOMINATOR BY SQUARING LARGE QUANTITIES -C----------------------------------------------------------------------- - P2R = P2R + SUMR - P2I = P2I + SUMI - AP = ZABS(P2R,P2I) - P1R = 1.0D0/AP - CALL ZEXP(PTR, PTI, STR, STI) - CKR = STR*P1R - CKI = STI*P1R - PTR = P2R*P1R - PTI = -P2I*P1R - CALL ZMLT(CKR, CKI, PTR, PTI, CNORMR, CNORMI) - DO 100 I=1,N - STR = YR(I)*CNORMR - YI(I)*CNORMI - YI(I) = YR(I)*CNORMI + YI(I)*CNORMR - YR(I) = STR - 100 CONTINUE - RETURN - 110 CONTINUE - NZ=-2 - RETURN - END diff --git a/slatec/zmlt.f b/slatec/zmlt.f deleted file mode 100644 index a4f130d..0000000 --- a/slatec/zmlt.f +++ /dev/null @@ -1,27 +0,0 @@ -*DECK ZMLT - SUBROUTINE ZMLT (AR, AI, BR, BI, CR, CI) -C***BEGIN PROLOGUE ZMLT -C***SUBSIDIARY -C***PURPOSE Subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and -C ZBIRY -C***LIBRARY SLATEC -C***TYPE ALL (ZMLT-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C DOUBLE PRECISION COMPLEX MULTIPLY, C=A*B. -C -C***SEE ALSO ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZBIRY -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE ZMLT - DOUBLE PRECISION AR, AI, BR, BI, CR, CI, CA, CB -C***FIRST EXECUTABLE STATEMENT ZMLT - CA = AR*BR - AI*BI - CB = AR*BI + AI*BR - CR = CA - CI = CB - RETURN - END diff --git a/slatec/zrati.f b/slatec/zrati.f deleted file mode 100644 index 8eedca9..0000000 --- a/slatec/zrati.f +++ /dev/null @@ -1,143 +0,0 @@ -*DECK ZRATI - SUBROUTINE ZRATI (ZR, ZI, FNU, N, CYR, CYI, TOL) -C***BEGIN PROLOGUE ZRATI -C***SUBSIDIARY -C***PURPOSE Subsidiary to ZBESH, ZBESI and ZBESK -C***LIBRARY SLATEC -C***TYPE ALL (CRATI-A, ZRATI-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C ZRATI COMPUTES RATIOS OF I BESSEL FUNCTIONS BY BACKWARD -C RECURRENCE. THE STARTING INDEX IS DETERMINED BY FORWARD -C RECURRENCE AS DESCRIBED IN J. RES. OF NAT. BUR. OF STANDARDS-B, -C MATHEMATICAL SCIENCES, VOL 77B, P111-114, SEPTEMBER, 1973, -C BESSEL FUNCTIONS I AND J OF COMPLEX ARGUMENT AND INTEGER ORDER, -C BY D. J. SOOKNE. -C -C***SEE ALSO ZBESH, ZBESI, ZBESK -C***ROUTINES CALLED ZABS, ZDIV -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE ZRATI - DOUBLE PRECISION AK, AMAGZ, AP1, AP2, ARG, AZ, CDFNUI, CDFNUR, - * CONEI, CONER, CYI, CYR, CZEROI, CZEROR, DFNU, FDNU, FLAM, FNU, - * FNUP, PTI, PTR, P1I, P1R, P2I, P2R, RAK, RAP1, RHO, RT2, RZI, - * RZR, TEST, TEST1, TOL, TTI, TTR, T1I, T1R, ZI, ZR, ZABS - INTEGER I, ID, IDNU, INU, ITIME, K, KK, MAGZ, N - DIMENSION CYR(N), CYI(N) - EXTERNAL ZABS - DATA CZEROR,CZEROI,CONER,CONEI,RT2/ - 1 0.0D0, 0.0D0, 1.0D0, 0.0D0, 1.41421356237309505D0 / -C***FIRST EXECUTABLE STATEMENT ZRATI - AZ = ZABS(ZR,ZI) - INU = FNU - IDNU = INU + N - 1 - MAGZ = AZ - AMAGZ = MAGZ+1 - FDNU = IDNU - FNUP = MAX(AMAGZ,FDNU) - ID = IDNU - MAGZ - 1 - ITIME = 1 - K = 1 - PTR = 1.0D0/AZ - RZR = PTR*(ZR+ZR)*PTR - RZI = -PTR*(ZI+ZI)*PTR - T1R = RZR*FNUP - T1I = RZI*FNUP - P2R = -T1R - P2I = -T1I - P1R = CONER - P1I = CONEI - T1R = T1R + RZR - T1I = T1I + RZI - IF (ID.GT.0) ID = 0 - AP2 = ZABS(P2R,P2I) - AP1 = ZABS(P1R,P1I) -C----------------------------------------------------------------------- -C THE OVERFLOW TEST ON K(FNU+I-1,Z) BEFORE THE CALL TO CBKNU -C GUARANTEES THAT P2 IS ON SCALE. SCALE TEST1 AND ALL SUBSEQUENT -C P2 VALUES BY AP1 TO ENSURE THAT AN OVERFLOW DOES NOT OCCUR -C PREMATURELY. -C----------------------------------------------------------------------- - ARG = (AP2+AP2)/(AP1*TOL) - TEST1 = SQRT(ARG) - TEST = TEST1 - RAP1 = 1.0D0/AP1 - P1R = P1R*RAP1 - P1I = P1I*RAP1 - P2R = P2R*RAP1 - P2I = P2I*RAP1 - AP2 = AP2*RAP1 - 10 CONTINUE - K = K + 1 - AP1 = AP2 - PTR = P2R - PTI = P2I - P2R = P1R - (T1R*PTR-T1I*PTI) - P2I = P1I - (T1R*PTI+T1I*PTR) - P1R = PTR - P1I = PTI - T1R = T1R + RZR - T1I = T1I + RZI - AP2 = ZABS(P2R,P2I) - IF (AP1.LE.TEST) GO TO 10 - IF (ITIME.EQ.2) GO TO 20 - AK = ZABS(T1R,T1I)*0.5D0 - FLAM = AK + SQRT(AK*AK-1.0D0) - RHO = MIN(AP2/AP1,FLAM) - TEST = TEST1*SQRT(RHO/(RHO*RHO-1.0D0)) - ITIME = 2 - GO TO 10 - 20 CONTINUE - KK = K + 1 - ID - AK = KK - T1R = AK - T1I = CZEROI - DFNU = FNU + (N-1) - P1R = 1.0D0/AP2 - P1I = CZEROI - P2R = CZEROR - P2I = CZEROI - DO 30 I=1,KK - PTR = P1R - PTI = P1I - RAP1 = DFNU + T1R - TTR = RZR*RAP1 - TTI = RZI*RAP1 - P1R = (PTR*TTR-PTI*TTI) + P2R - P1I = (PTR*TTI+PTI*TTR) + P2I - P2R = PTR - P2I = PTI - T1R = T1R - CONER - 30 CONTINUE - IF (P1R.NE.CZEROR .OR. P1I.NE.CZEROI) GO TO 40 - P1R = TOL - P1I = TOL - 40 CONTINUE - CALL ZDIV(P2R, P2I, P1R, P1I, CYR(N), CYI(N)) - IF (N.EQ.1) RETURN - K = N - 1 - AK = K - T1R = AK - T1I = CZEROI - CDFNUR = FNU*RZR - CDFNUI = FNU*RZI - DO 60 I=2,N - PTR = CDFNUR + (T1R*RZR-T1I*RZI) + CYR(K+1) - PTI = CDFNUI + (T1R*RZI+T1I*RZR) + CYI(K+1) - AK = ZABS(PTR,PTI) - IF (AK.NE.CZEROR) GO TO 50 - PTR = TOL - PTI = TOL - AK = TOL*RT2 - 50 CONTINUE - RAK = CONER/AK - CYR(K) = RAK*PTR*RAK - CYI(K) = -RAK*PTI*RAK - T1R = T1R - CONER - K = K - 1 - 60 CONTINUE - RETURN - END diff --git a/slatec/zs1s2.f b/slatec/zs1s2.f deleted file mode 100644 index e628094..0000000 --- a/slatec/zs1s2.f +++ /dev/null @@ -1,62 +0,0 @@ -*DECK ZS1S2 - SUBROUTINE ZS1S2 (ZRR, ZRI, S1R, S1I, S2R, S2I, NZ, ASCLE, ALIM, - + IUF) -C***BEGIN PROLOGUE ZS1S2 -C***SUBSIDIARY -C***PURPOSE Subsidiary to ZAIRY and ZBESK -C***LIBRARY SLATEC -C***TYPE ALL (CS1S2-A, ZS1S2-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C ZS1S2 TESTS FOR A POSSIBLE UNDERFLOW RESULTING FROM THE -C ADDITION OF THE I AND K FUNCTIONS IN THE ANALYTIC CON- -C TINUATION FORMULA WHERE S1=K FUNCTION AND S2=I FUNCTION. -C ON KODE=1 THE I AND K FUNCTIONS ARE DIFFERENT ORDERS OF -C MAGNITUDE, BUT FOR KODE=2 THEY CAN BE OF THE SAME ORDER -C OF MAGNITUDE AND THE MAXIMUM MUST BE AT LEAST ONE -C PRECISION ABOVE THE UNDERFLOW LIMIT. -C -C***SEE ALSO ZAIRY, ZBESK -C***ROUTINES CALLED ZABS, ZEXP, ZLOG -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C 930122 Added ZEXP and ZLOG to EXTERNAL statement. (RWC) -C***END PROLOGUE ZS1S2 -C COMPLEX CZERO,C1,S1,S1D,S2,ZR - DOUBLE PRECISION AA, ALIM, ALN, ASCLE, AS1, AS2, C1I, C1R, S1DI, - * S1DR, S1I, S1R, S2I, S2R, ZEROI, ZEROR, ZRI, ZRR, ZABS - INTEGER IUF, IDUM, NZ - EXTERNAL ZABS, ZEXP, ZLOG - DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 / -C***FIRST EXECUTABLE STATEMENT ZS1S2 - NZ = 0 - AS1 = ZABS(S1R,S1I) - AS2 = ZABS(S2R,S2I) - IF (S1R.EQ.0.0D0 .AND. S1I.EQ.0.0D0) GO TO 10 - IF (AS1.EQ.0.0D0) GO TO 10 - ALN = -ZRR - ZRR + LOG(AS1) - S1DR = S1R - S1DI = S1I - S1R = ZEROR - S1I = ZEROI - AS1 = ZEROR - IF (ALN.LT.(-ALIM)) GO TO 10 - CALL ZLOG(S1DR, S1DI, C1R, C1I, IDUM) - C1R = C1R - ZRR - ZRR - C1I = C1I - ZRI - ZRI - CALL ZEXP(C1R, C1I, S1R, S1I) - AS1 = ZABS(S1R,S1I) - IUF = IUF + 1 - 10 CONTINUE - AA = MAX(AS1,AS2) - IF (AA.GT.ASCLE) RETURN - S1R = ZEROR - S1I = ZEROI - S2R = ZEROR - S2I = ZEROI - NZ = 1 - IUF = 0 - RETURN - END diff --git a/slatec/zseri.f b/slatec/zseri.f deleted file mode 100644 index 24c6c84..0000000 --- a/slatec/zseri.f +++ /dev/null @@ -1,202 +0,0 @@ -*DECK ZSERI - SUBROUTINE ZSERI (ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL, ELIM, - + ALIM) -C***BEGIN PROLOGUE ZSERI -C***SUBSIDIARY -C***PURPOSE Subsidiary to ZBESI and ZBESK -C***LIBRARY SLATEC -C***TYPE ALL (CSERI-A, ZSERI-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C ZSERI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY -C MEANS OF THE POWER SERIES FOR LARGE ABS(Z) IN THE -C REGION ABS(Z).LE.2*SQRT(FNU+1). NZ=0 IS A NORMAL RETURN. -C NZ.GT.0 MEANS THAT THE LAST NZ COMPONENTS WERE SET TO ZERO -C DUE TO UNDERFLOW. NZ.LT.0 MEANS UNDERFLOW OCCURRED, BUT THE -C CONDITION ABS(Z).LE.2*SQRT(FNU+1) WAS VIOLATED AND THE -C COMPUTATION MUST BE COMPLETED IN ANOTHER ROUTINE WITH N=N-ABS(NZ). -C -C***SEE ALSO ZBESI, ZBESK -C***ROUTINES CALLED D1MACH, DGAMLN, ZABS, ZDIV, ZLOG, ZMLT, ZUCHK -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C 930122 Added ZLOG to EXTERNAL statement. (RWC) -C***END PROLOGUE ZSERI -C COMPLEX AK1,CK,COEF,CONE,CRSC,CSCL,CZ,CZERO,HZ,RZ,S1,S2,Y,Z - DOUBLE PRECISION AA, ACZ, AK, AK1I, AK1R, ALIM, ARM, ASCLE, ATOL, - * AZ, CKI, CKR, COEFI, COEFR, CONEI, CONER, CRSCR, CZI, CZR, DFNU, - * ELIM, FNU, FNUP, HZI, HZR, RAZ, RS, RTR1, RZI, RZR, S, SS, STI, - * STR, S1I, S1R, S2I, S2R, TOL, YI, YR, WI, WR, ZEROI, ZEROR, ZI, - * ZR, DGAMLN, D1MACH, ZABS - INTEGER I, IB, IDUM, IFLAG, IL, K, KODE, L, M, N, NN, NZ, NW - DIMENSION YR(N), YI(N), WR(2), WI(2) - EXTERNAL ZABS, ZLOG - DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / -C***FIRST EXECUTABLE STATEMENT ZSERI - NZ = 0 - AZ = ZABS(ZR,ZI) - IF (AZ.EQ.0.0D0) GO TO 160 - ARM = 1.0D+3*D1MACH(1) - RTR1 = SQRT(ARM) - CRSCR = 1.0D0 - IFLAG = 0 - IF (AZ.LT.ARM) GO TO 150 - HZR = 0.5D0*ZR - HZI = 0.5D0*ZI - CZR = ZEROR - CZI = ZEROI - IF (AZ.LE.RTR1) GO TO 10 - CALL ZMLT(HZR, HZI, HZR, HZI, CZR, CZI) - 10 CONTINUE - ACZ = ZABS(CZR,CZI) - NN = N - CALL ZLOG(HZR, HZI, CKR, CKI, IDUM) - 20 CONTINUE - DFNU = FNU + (NN-1) - FNUP = DFNU + 1.0D0 -C----------------------------------------------------------------------- -C UNDERFLOW TEST -C----------------------------------------------------------------------- - AK1R = CKR*DFNU - AK1I = CKI*DFNU - AK = DGAMLN(FNUP,IDUM) - AK1R = AK1R - AK - IF (KODE.EQ.2) AK1R = AK1R - ZR - IF (AK1R.GT.(-ELIM)) GO TO 40 - 30 CONTINUE - NZ = NZ + 1 - YR(NN) = ZEROR - YI(NN) = ZEROI - IF (ACZ.GT.DFNU) GO TO 190 - NN = NN - 1 - IF (NN.EQ.0) RETURN - GO TO 20 - 40 CONTINUE - IF (AK1R.GT.(-ALIM)) GO TO 50 - IFLAG = 1 - SS = 1.0D0/TOL - CRSCR = TOL - ASCLE = ARM*SS - 50 CONTINUE - AA = EXP(AK1R) - IF (IFLAG.EQ.1) AA = AA*SS - COEFR = AA*COS(AK1I) - COEFI = AA*SIN(AK1I) - ATOL = TOL*ACZ/FNUP - IL = MIN(2,NN) - DO 90 I=1,IL - DFNU = FNU + (NN-I) - FNUP = DFNU + 1.0D0 - S1R = CONER - S1I = CONEI - IF (ACZ.LT.TOL*FNUP) GO TO 70 - AK1R = CONER - AK1I = CONEI - AK = FNUP + 2.0D0 - S = FNUP - AA = 2.0D0 - 60 CONTINUE - RS = 1.0D0/S - STR = AK1R*CZR - AK1I*CZI - STI = AK1R*CZI + AK1I*CZR - AK1R = STR*RS - AK1I = STI*RS - S1R = S1R + AK1R - S1I = S1I + AK1I - S = S + AK - AK = AK + 2.0D0 - AA = AA*ACZ*RS - IF (AA.GT.ATOL) GO TO 60 - 70 CONTINUE - S2R = S1R*COEFR - S1I*COEFI - S2I = S1R*COEFI + S1I*COEFR - WR(I) = S2R - WI(I) = S2I - IF (IFLAG.EQ.0) GO TO 80 - CALL ZUCHK(S2R, S2I, NW, ASCLE, TOL) - IF (NW.NE.0) GO TO 30 - 80 CONTINUE - M = NN - I + 1 - YR(M) = S2R*CRSCR - YI(M) = S2I*CRSCR - IF (I.EQ.IL) GO TO 90 - CALL ZDIV(COEFR, COEFI, HZR, HZI, STR, STI) - COEFR = STR*DFNU - COEFI = STI*DFNU - 90 CONTINUE - IF (NN.LE.2) RETURN - K = NN - 2 - AK = K - RAZ = 1.0D0/AZ - STR = ZR*RAZ - STI = -ZI*RAZ - RZR = (STR+STR)*RAZ - RZI = (STI+STI)*RAZ - IF (IFLAG.EQ.1) GO TO 120 - IB = 3 - 100 CONTINUE - DO 110 I=IB,NN - YR(K) = (AK+FNU)*(RZR*YR(K+1)-RZI*YI(K+1)) + YR(K+2) - YI(K) = (AK+FNU)*(RZR*YI(K+1)+RZI*YR(K+1)) + YI(K+2) - AK = AK - 1.0D0 - K = K - 1 - 110 CONTINUE - RETURN -C----------------------------------------------------------------------- -C RECUR BACKWARD WITH SCALED VALUES -C----------------------------------------------------------------------- - 120 CONTINUE -C----------------------------------------------------------------------- -C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION ABOVE THE -C UNDERFLOW LIMIT = ASCLE = D1MACH(1)*SS*1.0D+3 -C----------------------------------------------------------------------- - S1R = WR(1) - S1I = WI(1) - S2R = WR(2) - S2I = WI(2) - DO 130 L=3,NN - CKR = S2R - CKI = S2I - S2R = S1R + (AK+FNU)*(RZR*CKR-RZI*CKI) - S2I = S1I + (AK+FNU)*(RZR*CKI+RZI*CKR) - S1R = CKR - S1I = CKI - CKR = S2R*CRSCR - CKI = S2I*CRSCR - YR(K) = CKR - YI(K) = CKI - AK = AK - 1.0D0 - K = K - 1 - IF (ZABS(CKR,CKI).GT.ASCLE) GO TO 140 - 130 CONTINUE - RETURN - 140 CONTINUE - IB = L + 1 - IF (IB.GT.NN) RETURN - GO TO 100 - 150 CONTINUE - NZ = N - IF (FNU.EQ.0.0D0) NZ = NZ - 1 - 160 CONTINUE - YR(1) = ZEROR - YI(1) = ZEROI - IF (FNU.NE.0.0D0) GO TO 170 - YR(1) = CONER - YI(1) = CONEI - 170 CONTINUE - IF (N.EQ.1) RETURN - DO 180 I=2,N - YR(I) = ZEROR - YI(I) = ZEROI - 180 CONTINUE - RETURN -C----------------------------------------------------------------------- -C RETURN WITH NZ.LT.0 IF ABS(Z*Z/4).GT.FNU+N-NZ-1 COMPLETE -C THE CALCULATION IN CBINU WITH N=N-ABS(NZ) -C----------------------------------------------------------------------- - 190 CONTINUE - NZ = -NZ - RETURN - END diff --git a/slatec/zshch.f b/slatec/zshch.f deleted file mode 100644 index 3b394cd..0000000 --- a/slatec/zshch.f +++ /dev/null @@ -1,32 +0,0 @@ -*DECK ZSHCH - SUBROUTINE ZSHCH (ZR, ZI, CSHR, CSHI, CCHR, CCHI) -C***BEGIN PROLOGUE ZSHCH -C***SUBSIDIARY -C***PURPOSE Subsidiary to ZBESH and ZBESK -C***LIBRARY SLATEC -C***TYPE ALL (CSHCH-A, ZSHCH-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C ZSHCH COMPUTES THE COMPLEX HYPERBOLIC FUNCTIONS CSH=SINH(X+I*Y) -C AND CCH=COSH(X+I*Y), WHERE I**2=-1. -C -C***SEE ALSO ZBESH, ZBESK -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE ZSHCH -C - DOUBLE PRECISION CCHI, CCHR, CH, CN, CSHI, CSHR, SH, SN, ZI, ZR -C***FIRST EXECUTABLE STATEMENT ZSHCH - SH = SINH(ZR) - CH = COSH(ZR) - SN = SIN(ZI) - CN = COS(ZI) - CSHR = SH*CN - CSHI = CH*SN - CCHR = CH*CN - CCHI = SH*SN - RETURN - END diff --git a/slatec/zsqrt.f b/slatec/zsqrt.f deleted file mode 100644 index 86a7b05..0000000 --- a/slatec/zsqrt.f +++ /dev/null @@ -1,57 +0,0 @@ -*DECK ZSQRT - SUBROUTINE ZSQRT (AR, AI, BR, BI) -C***BEGIN PROLOGUE ZSQRT -C***SUBSIDIARY -C***PURPOSE Subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and -C ZBIRY -C***LIBRARY SLATEC -C***TYPE ALL (ZSQRT-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C DOUBLE PRECISION COMPLEX SQUARE ROOT, B=CSQRT(A) -C -C***SEE ALSO ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZBIRY -C***ROUTINES CALLED ZABS -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE ZSQRT - DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DRT - DOUBLE PRECISION ZABS - EXTERNAL ZABS - DATA DRT , DPI / 7.071067811865475244008443621D-1, - 1 3.141592653589793238462643383D+0/ -C***FIRST EXECUTABLE STATEMENT ZSQRT - ZM = ZABS(AR,AI) - ZM = SQRT(ZM) - IF (AR.EQ.0.0D+0) GO TO 10 - IF (AI.EQ.0.0D+0) GO TO 20 - DTHETA = DATAN(AI/AR) - IF (DTHETA.LE.0.0D+0) GO TO 40 - IF (AR.LT.0.0D+0) DTHETA = DTHETA - DPI - GO TO 50 - 10 IF (AI.GT.0.0D+0) GO TO 60 - IF (AI.LT.0.0D+0) GO TO 70 - BR = 0.0D+0 - BI = 0.0D+0 - RETURN - 20 IF (AR.GT.0.0D+0) GO TO 30 - BR = 0.0D+0 - BI = SQRT(ABS(AR)) - RETURN - 30 BR = SQRT(AR) - BI = 0.0D+0 - RETURN - 40 IF (AR.LT.0.0D+0) DTHETA = DTHETA + DPI - 50 DTHETA = DTHETA*0.5D+0 - BR = ZM*COS(DTHETA) - BI = ZM*SIN(DTHETA) - RETURN - 60 BR = ZM*DRT - BI = ZM*DRT - RETURN - 70 BR = ZM*DRT - BI = -ZM*DRT - RETURN - END diff --git a/slatec/zuchk.f b/slatec/zuchk.f deleted file mode 100644 index ebf85c3..0000000 --- a/slatec/zuchk.f +++ /dev/null @@ -1,40 +0,0 @@ -*DECK ZUCHK - SUBROUTINE ZUCHK (YR, YI, NZ, ASCLE, TOL) -C***BEGIN PROLOGUE ZUCHK -C***SUBSIDIARY -C***PURPOSE Subsidiary to SERI, ZUOIK, ZUNK1, ZUNK2, ZUNI1, ZUNI2 and -C ZKSCL -C***LIBRARY SLATEC -C***TYPE ALL (CUCHK-A, ZUCHK-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C Y ENTERS AS A SCALED QUANTITY WHOSE MAGNITUDE IS GREATER THAN -C EXP(-ALIM)=ASCLE=1.0E+3*D1MACH(1)/TOL. THE TEST IS MADE TO SEE -C IF THE MAGNITUDE OF THE REAL OR IMAGINARY PART WOULD UNDERFLOW -C WHEN Y IS SCALED (BY TOL) TO ITS PROPER VALUE. Y IS ACCEPTED -C IF THE UNDERFLOW IS AT LEAST ONE PRECISION BELOW THE MAGNITUDE -C OF THE LARGEST COMPONENT; OTHERWISE THE PHASE ANGLE DOES NOT HAVE -C ABSOLUTE ACCURACY AND AN UNDERFLOW IS ASSUMED. -C -C***SEE ALSO SERI, ZKSCL, ZUNI1, ZUNI2, ZUNK1, ZUNK2, ZUOIK -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C ?????? DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE ZUCHK -C -C COMPLEX Y - DOUBLE PRECISION ASCLE, SS, ST, TOL, WR, WI, YR, YI - INTEGER NZ -C***FIRST EXECUTABLE STATEMENT ZUCHK - NZ = 0 - WR = ABS(YR) - WI = ABS(YI) - ST = MIN(WR,WI) - IF (ST.GT.ASCLE) RETURN - SS = MAX(WR,WI) - ST = ST/TOL - IF (SS.LT.ST) NZ = 1 - RETURN - END diff --git a/slatec/zunhj.f b/slatec/zunhj.f deleted file mode 100644 index 5df7a33..0000000 --- a/slatec/zunhj.f +++ /dev/null @@ -1,726 +0,0 @@ -*DECK ZUNHJ - SUBROUTINE ZUNHJ (ZR, ZI, FNU, IPMTR, TOL, PHIR, PHII, ARGR, ARGI, - + ZETA1R, ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) -C***BEGIN PROLOGUE ZUNHJ -C***SUBSIDIARY -C***PURPOSE Subsidiary to ZBESI and ZBESK -C***LIBRARY SLATEC -C***TYPE ALL (CUNHJ-A, ZUNHJ-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C REFERENCES -C HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ AND I.A. -C STEGUN, AMS55, NATIONAL BUREAU OF STANDARDS, 1965, CHAPTER 9. -C -C ASYMPTOTICS AND SPECIAL FUNCTIONS BY F.W.J. OLVER, ACADEMIC -C PRESS, N.Y., 1974, PAGE 420 -C -C ABSTRACT -C ZUNHJ COMPUTES PARAMETERS FOR BESSEL FUNCTIONS C(FNU,Z) = -C J(FNU,Z), Y(FNU,Z) OR H(I,FNU,Z) I=1,2 FOR LARGE ORDERS FNU -C BY MEANS OF THE UNIFORM ASYMPTOTIC EXPANSION -C -C C(FNU,Z)=C1*PHI*( ASUM*AIRY(ARG) + C2*BSUM*DAIRY(ARG) ) -C -C FOR PROPER CHOICES OF C1, C2, AIRY AND DAIRY WHERE AIRY IS -C AN AIRY FUNCTION AND DAIRY IS ITS DERIVATIVE. -C -C (2/3)*FNU*ZETA**1.5 = ZETA1-ZETA2, -C -C ZETA1=0.5*FNU*CLOG((1+W)/(1-W)), ZETA2=FNU*W FOR SCALING -C PURPOSES IN AIRY FUNCTIONS FROM CAIRY OR CBIRY. -C -C MCONJ=SIGN OF AIMAG(Z), BUT IS AMBIGUOUS WHEN Z IS REAL AND -C MUST BE SPECIFIED. IPMTR=0 RETURNS ALL PARAMETERS. IPMTR= -C 1 COMPUTES ALL EXCEPT ASUM AND BSUM. -C -C***SEE ALSO ZBESI, ZBESK -C***ROUTINES CALLED D1MACH, ZABS, ZDIV, ZLOG, ZSQRT -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C 930122 Added ZLOG and ZSQRT to EXTERNAL statement. (RWC) -C***END PROLOGUE ZUNHJ -C COMPLEX ARG,ASUM,BSUM,CFNU,CONE,CR,CZERO,DR,P,PHI,PRZTH,PTFN, -C *RFN13,RTZTA,RZTH,SUMA,SUMB,TFN,T2,UP,W,W2,Z,ZA,ZB,ZC,ZETA,ZETA1, -C *ZETA2,ZTH - DOUBLE PRECISION ALFA, ANG, AP, AR, ARGI, ARGR, ASUMI, ASUMR, - * ATOL, AW2, AZTH, BETA, BR, BSUMI, BSUMR, BTOL, C, CONEI, CONER, - * CRI, CRR, DRI, DRR, EX1, EX2, FNU, FN13, FN23, GAMA, GPI, HPI, - * PHII, PHIR, PI, PP, PR, PRZTHI, PRZTHR, PTFNI, PTFNR, RAW, RAW2, - * RAZTH, RFNU, RFNU2, RFN13, RTZTI, RTZTR, RZTHI, RZTHR, STI, STR, - * SUMAI, SUMAR, SUMBI, SUMBR, TEST, TFNI, TFNR, THPI, TOL, TZAI, - * TZAR, T2I, T2R, UPI, UPR, WI, WR, W2I, W2R, ZAI, ZAR, ZBI, ZBR, - * ZCI, ZCR, ZEROI, ZEROR, ZETAI, ZETAR, ZETA1I, ZETA1R, ZETA2I, - * ZETA2R, ZI, ZR, ZTHI, ZTHR, ZABS, AC, D1MACH - INTEGER IAS, IBS, IPMTR, IS, J, JR, JU, K, KMAX, KP1, KS, L, LR, - * LRP1, L1, L2, M, IDUM - DIMENSION AR(14), BR(14), C(105), ALFA(180), BETA(210), GAMA(30), - * AP(30), PR(30), PI(30), UPR(14), UPI(14), CRR(14), CRI(14), - * DRR(14), DRI(14) - EXTERNAL ZABS, ZLOG, ZSQRT - DATA AR(1), AR(2), AR(3), AR(4), AR(5), AR(6), AR(7), AR(8), - 1 AR(9), AR(10), AR(11), AR(12), AR(13), AR(14)/ - 2 1.00000000000000000D+00, 1.04166666666666667D-01, - 3 8.35503472222222222D-02, 1.28226574556327160D-01, - 4 2.91849026464140464D-01, 8.81627267443757652D-01, - 5 3.32140828186276754D+00, 1.49957629868625547D+01, - 6 7.89230130115865181D+01, 4.74451538868264323D+02, - 7 3.20749009089066193D+03, 2.40865496408740049D+04, - 8 1.98923119169509794D+05, 1.79190200777534383D+06/ - DATA BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), BR(8), - 1 BR(9), BR(10), BR(11), BR(12), BR(13), BR(14)/ - 2 1.00000000000000000D+00, -1.45833333333333333D-01, - 3 -9.87413194444444444D-02, -1.43312053915895062D-01, - 4 -3.17227202678413548D-01, -9.42429147957120249D-01, - 5 -3.51120304082635426D+00, -1.57272636203680451D+01, - 6 -8.22814390971859444D+01, -4.92355370523670524D+02, - 7 -3.31621856854797251D+03, -2.48276742452085896D+04, - 8 -2.04526587315129788D+05, -1.83844491706820990D+06/ - DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), - 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), - 2 C(19), C(20), C(21), C(22), C(23), C(24)/ - 3 1.00000000000000000D+00, -2.08333333333333333D-01, - 4 1.25000000000000000D-01, 3.34201388888888889D-01, - 5 -4.01041666666666667D-01, 7.03125000000000000D-02, - 6 -1.02581259645061728D+00, 1.84646267361111111D+00, - 7 -8.91210937500000000D-01, 7.32421875000000000D-02, - 8 4.66958442342624743D+00, -1.12070026162229938D+01, - 9 8.78912353515625000D+00, -2.36408691406250000D+00, - A 1.12152099609375000D-01, -2.82120725582002449D+01, - B 8.46362176746007346D+01, -9.18182415432400174D+01, - C 4.25349987453884549D+01, -7.36879435947963170D+00, - D 2.27108001708984375D-01, 2.12570130039217123D+02, - E -7.65252468141181642D+02, 1.05999045252799988D+03/ - DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), - 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), - 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ - 3 -6.99579627376132541D+02, 2.18190511744211590D+02, - 4 -2.64914304869515555D+01, 5.72501420974731445D-01, - 5 -1.91945766231840700D+03, 8.06172218173730938D+03, - 6 -1.35865500064341374D+04, 1.16553933368645332D+04, - 7 -5.30564697861340311D+03, 1.20090291321635246D+03, - 8 -1.08090919788394656D+02, 1.72772750258445740D+00, - 9 2.02042913309661486D+04, -9.69805983886375135D+04, - A 1.92547001232531532D+05, -2.03400177280415534D+05, - B 1.22200464983017460D+05, -4.11926549688975513D+04, - C 7.10951430248936372D+03, -4.93915304773088012D+02, - D 6.07404200127348304D+00, -2.42919187900551333D+05, - E 1.31176361466297720D+06, -2.99801591853810675D+06/ - DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), - 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), - 2 C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ - 3 3.76327129765640400D+06, -2.81356322658653411D+06, - 4 1.26836527332162478D+06, -3.31645172484563578D+05, - 5 4.52187689813627263D+04, -2.49983048181120962D+03, - 6 2.43805296995560639D+01, 3.28446985307203782D+06, - 7 -1.97068191184322269D+07, 5.09526024926646422D+07, - 8 -7.41051482115326577D+07, 6.63445122747290267D+07, - 9 -3.75671766607633513D+07, 1.32887671664218183D+07, - A -2.78561812808645469D+06, 3.08186404612662398D+05, - B -1.38860897537170405D+04, 1.10017140269246738D+02, - C -4.93292536645099620D+07, 3.25573074185765749D+08, - D -9.39462359681578403D+08, 1.55359689957058006D+09, - E -1.62108055210833708D+09, 1.10684281682301447D+09/ - DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), - 1 C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), - 2 C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ - 3 -4.95889784275030309D+08, 1.42062907797533095D+08, - 4 -2.44740627257387285D+07, 2.24376817792244943D+06, - 5 -8.40054336030240853D+04, 5.51335896122020586D+02, - 6 8.14789096118312115D+08, -5.86648149205184723D+09, - 7 1.86882075092958249D+10, -3.46320433881587779D+10, - 8 4.12801855797539740D+10, -3.30265997498007231D+10, - 9 1.79542137311556001D+10, -6.56329379261928433D+09, - A 1.55927986487925751D+09, -2.25105661889415278D+08, - B 1.73951075539781645D+07, -5.49842327572288687D+05, - C 3.03809051092238427D+03, -1.46792612476956167D+10, - D 1.14498237732025810D+11, -3.99096175224466498D+11, - E 8.19218669548577329D+11, -1.09837515608122331D+12/ - DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104), - 1 C(105)/ - 2 1.00815810686538209D+12, -6.45364869245376503D+11, - 3 2.87900649906150589D+11, -8.78670721780232657D+10, - 4 1.76347306068349694D+10, -2.16716498322379509D+09, - 5 1.43157876718888981D+08, -3.87183344257261262D+06, - 6 1.82577554742931747D+04/ - DATA ALFA(1), ALFA(2), ALFA(3), ALFA(4), ALFA(5), ALFA(6), - 1 ALFA(7), ALFA(8), ALFA(9), ALFA(10), ALFA(11), ALFA(12), - 2 ALFA(13), ALFA(14), ALFA(15), ALFA(16), ALFA(17), ALFA(18), - 3 ALFA(19), ALFA(20), ALFA(21), ALFA(22)/ - 4 -4.44444444444444444D-03, -9.22077922077922078D-04, - 5 -8.84892884892884893D-05, 1.65927687832449737D-04, - 6 2.46691372741792910D-04, 2.65995589346254780D-04, - 7 2.61824297061500945D-04, 2.48730437344655609D-04, - 8 2.32721040083232098D-04, 2.16362485712365082D-04, - 9 2.00738858762752355D-04, 1.86267636637545172D-04, - A 1.73060775917876493D-04, 1.61091705929015752D-04, - B 1.50274774160908134D-04, 1.40503497391269794D-04, - C 1.31668816545922806D-04, 1.23667445598253261D-04, - D 1.16405271474737902D-04, 1.09798298372713369D-04, - E 1.03772410422992823D-04, 9.82626078369363448D-05/ - DATA ALFA(23), ALFA(24), ALFA(25), ALFA(26), ALFA(27), ALFA(28), - 1 ALFA(29), ALFA(30), ALFA(31), ALFA(32), ALFA(33), ALFA(34), - 2 ALFA(35), ALFA(36), ALFA(37), ALFA(38), ALFA(39), ALFA(40), - 3 ALFA(41), ALFA(42), ALFA(43), ALFA(44)/ - 4 9.32120517249503256D-05, 8.85710852478711718D-05, - 5 8.42963105715700223D-05, 8.03497548407791151D-05, - 6 7.66981345359207388D-05, 7.33122157481777809D-05, - 7 7.01662625163141333D-05, 6.72375633790160292D-05, - 8 6.93735541354588974D-04, 2.32241745182921654D-04, - 9 -1.41986273556691197D-05, -1.16444931672048640D-04, - A -1.50803558053048762D-04, -1.55121924918096223D-04, - B -1.46809756646465549D-04, -1.33815503867491367D-04, - C -1.19744975684254051D-04, -1.06184319207974020D-04, - D -9.37699549891194492D-05, -8.26923045588193274D-05, - E -7.29374348155221211D-05, -6.44042357721016283D-05/ - DATA ALFA(45), ALFA(46), ALFA(47), ALFA(48), ALFA(49), ALFA(50), - 1 ALFA(51), ALFA(52), ALFA(53), ALFA(54), ALFA(55), ALFA(56), - 2 ALFA(57), ALFA(58), ALFA(59), ALFA(60), ALFA(61), ALFA(62), - 3 ALFA(63), ALFA(64), ALFA(65), ALFA(66)/ - 4 -5.69611566009369048D-05, -5.04731044303561628D-05, - 5 -4.48134868008882786D-05, -3.98688727717598864D-05, - 6 -3.55400532972042498D-05, -3.17414256609022480D-05, - 7 -2.83996793904174811D-05, -2.54522720634870566D-05, - 8 -2.28459297164724555D-05, -2.05352753106480604D-05, - 9 -1.84816217627666085D-05, -1.66519330021393806D-05, - A -1.50179412980119482D-05, -1.35554031379040526D-05, - B -1.22434746473858131D-05, -1.10641884811308169D-05, - C -3.54211971457743841D-04, -1.56161263945159416D-04, - D 3.04465503594936410D-05, 1.30198655773242693D-04, - E 1.67471106699712269D-04, 1.70222587683592569D-04/ - DATA ALFA(67), ALFA(68), ALFA(69), ALFA(70), ALFA(71), ALFA(72), - 1 ALFA(73), ALFA(74), ALFA(75), ALFA(76), ALFA(77), ALFA(78), - 2 ALFA(79), ALFA(80), ALFA(81), ALFA(82), ALFA(83), ALFA(84), - 3 ALFA(85), ALFA(86), ALFA(87), ALFA(88)/ - 4 1.56501427608594704D-04, 1.36339170977445120D-04, - 5 1.14886692029825128D-04, 9.45869093034688111D-05, - 6 7.64498419250898258D-05, 6.07570334965197354D-05, - 7 4.74394299290508799D-05, 3.62757512005344297D-05, - 8 2.69939714979224901D-05, 1.93210938247939253D-05, - 9 1.30056674793963203D-05, 7.82620866744496661D-06, - A 3.59257485819351583D-06, 1.44040049814251817D-07, - B -2.65396769697939116D-06, -4.91346867098485910D-06, - C -6.72739296091248287D-06, -8.17269379678657923D-06, - D -9.31304715093561232D-06, -1.02011418798016441D-05, - E -1.08805962510592880D-05, -1.13875481509603555D-05/ - DATA ALFA(89), ALFA(90), ALFA(91), ALFA(92), ALFA(93), ALFA(94), - 1 ALFA(95), ALFA(96), ALFA(97), ALFA(98), ALFA(99), ALFA(100), - 2 ALFA(101), ALFA(102), ALFA(103), ALFA(104), ALFA(105), - 3 ALFA(106), ALFA(107), ALFA(108), ALFA(109), ALFA(110)/ - 4 -1.17519675674556414D-05, -1.19987364870944141D-05, - 5 3.78194199201772914D-04, 2.02471952761816167D-04, - 6 -6.37938506318862408D-05, -2.38598230603005903D-04, - 7 -3.10916256027361568D-04, -3.13680115247576316D-04, - 8 -2.78950273791323387D-04, -2.28564082619141374D-04, - 9 -1.75245280340846749D-04, -1.25544063060690348D-04, - A -8.22982872820208365D-05, -4.62860730588116458D-05, - B -1.72334302366962267D-05, 5.60690482304602267D-06, - C 2.31395443148286800D-05, 3.62642745856793957D-05, - D 4.58006124490188752D-05, 5.24595294959114050D-05, - E 5.68396208545815266D-05, 5.94349820393104052D-05/ - DATA ALFA(111), ALFA(112), ALFA(113), ALFA(114), ALFA(115), - 1 ALFA(116), ALFA(117), ALFA(118), ALFA(119), ALFA(120), - 2 ALFA(121), ALFA(122), ALFA(123), ALFA(124), ALFA(125), - 3 ALFA(126), ALFA(127), ALFA(128), ALFA(129), ALFA(130)/ - 4 6.06478527578421742D-05, 6.08023907788436497D-05, - 5 6.01577894539460388D-05, 5.89199657344698500D-05, - 6 5.72515823777593053D-05, 5.52804375585852577D-05, - 7 5.31063773802880170D-05, 5.08069302012325706D-05, - 8 4.84418647620094842D-05, 4.60568581607475370D-05, - 9 -6.91141397288294174D-04, -4.29976633058871912D-04, - A 1.83067735980039018D-04, 6.60088147542014144D-04, - B 8.75964969951185931D-04, 8.77335235958235514D-04, - C 7.49369585378990637D-04, 5.63832329756980918D-04, - D 3.68059319971443156D-04, 1.88464535514455599D-04/ - DATA ALFA(131), ALFA(132), ALFA(133), ALFA(134), ALFA(135), - 1 ALFA(136), ALFA(137), ALFA(138), ALFA(139), ALFA(140), - 2 ALFA(141), ALFA(142), ALFA(143), ALFA(144), ALFA(145), - 3 ALFA(146), ALFA(147), ALFA(148), ALFA(149), ALFA(150)/ - 4 3.70663057664904149D-05, -8.28520220232137023D-05, - 5 -1.72751952869172998D-04, -2.36314873605872983D-04, - 6 -2.77966150694906658D-04, -3.02079514155456919D-04, - 7 -3.12594712643820127D-04, -3.12872558758067163D-04, - 8 -3.05678038466324377D-04, -2.93226470614557331D-04, - 9 -2.77255655582934777D-04, -2.59103928467031709D-04, - A -2.39784014396480342D-04, -2.20048260045422848D-04, - B -2.00443911094971498D-04, -1.81358692210970687D-04, - C -1.63057674478657464D-04, -1.45712672175205844D-04, - D -1.29425421983924587D-04, -1.14245691942445952D-04/ - DATA ALFA(151), ALFA(152), ALFA(153), ALFA(154), ALFA(155), - 1 ALFA(156), ALFA(157), ALFA(158), ALFA(159), ALFA(160), - 2 ALFA(161), ALFA(162), ALFA(163), ALFA(164), ALFA(165), - 3 ALFA(166), ALFA(167), ALFA(168), ALFA(169), ALFA(170)/ - 4 1.92821964248775885D-03, 1.35592576302022234D-03, - 5 -7.17858090421302995D-04, -2.58084802575270346D-03, - 6 -3.49271130826168475D-03, -3.46986299340960628D-03, - 7 -2.82285233351310182D-03, -1.88103076404891354D-03, - 8 -8.89531718383947600D-04, 3.87912102631035228D-06, - 9 7.28688540119691412D-04, 1.26566373053457758D-03, - A 1.62518158372674427D-03, 1.83203153216373172D-03, - B 1.91588388990527909D-03, 1.90588846755546138D-03, - C 1.82798982421825727D-03, 1.70389506421121530D-03, - D 1.55097127171097686D-03, 1.38261421852276159D-03/ - DATA ALFA(171), ALFA(172), ALFA(173), ALFA(174), ALFA(175), - 1 ALFA(176), ALFA(177), ALFA(178), ALFA(179), ALFA(180)/ - 2 1.20881424230064774D-03, 1.03676532638344962D-03, - 3 8.71437918068619115D-04, 7.16080155297701002D-04, - 4 5.72637002558129372D-04, 4.42089819465802277D-04, - 5 3.24724948503090564D-04, 2.20342042730246599D-04, - 6 1.28412898401353882D-04, 4.82005924552095464D-05/ - DATA BETA(1), BETA(2), BETA(3), BETA(4), BETA(5), BETA(6), - 1 BETA(7), BETA(8), BETA(9), BETA(10), BETA(11), BETA(12), - 2 BETA(13), BETA(14), BETA(15), BETA(16), BETA(17), BETA(18), - 3 BETA(19), BETA(20), BETA(21), BETA(22)/ - 4 1.79988721413553309D-02, 5.59964911064388073D-03, - 5 2.88501402231132779D-03, 1.80096606761053941D-03, - 6 1.24753110589199202D-03, 9.22878876572938311D-04, - 7 7.14430421727287357D-04, 5.71787281789704872D-04, - 8 4.69431007606481533D-04, 3.93232835462916638D-04, - 9 3.34818889318297664D-04, 2.88952148495751517D-04, - A 2.52211615549573284D-04, 2.22280580798883327D-04, - B 1.97541838033062524D-04, 1.76836855019718004D-04, - C 1.59316899661821081D-04, 1.44347930197333986D-04, - D 1.31448068119965379D-04, 1.20245444949302884D-04, - E 1.10449144504599392D-04, 1.01828770740567258D-04/ - DATA BETA(23), BETA(24), BETA(25), BETA(26), BETA(27), BETA(28), - 1 BETA(29), BETA(30), BETA(31), BETA(32), BETA(33), BETA(34), - 2 BETA(35), BETA(36), BETA(37), BETA(38), BETA(39), BETA(40), - 3 BETA(41), BETA(42), BETA(43), BETA(44)/ - 4 9.41998224204237509D-05, 8.74130545753834437D-05, - 5 8.13466262162801467D-05, 7.59002269646219339D-05, - 6 7.09906300634153481D-05, 6.65482874842468183D-05, - 7 6.25146958969275078D-05, 5.88403394426251749D-05, - 8 -1.49282953213429172D-03, -8.78204709546389328D-04, - 9 -5.02916549572034614D-04, -2.94822138512746025D-04, - A -1.75463996970782828D-04, -1.04008550460816434D-04, - B -5.96141953046457895D-05, -3.12038929076098340D-05, - C -1.26089735980230047D-05, -2.42892608575730389D-07, - D 8.05996165414273571D-06, 1.36507009262147391D-05, - E 1.73964125472926261D-05, 1.98672978842133780D-05/ - DATA BETA(45), BETA(46), BETA(47), BETA(48), BETA(49), BETA(50), - 1 BETA(51), BETA(52), BETA(53), BETA(54), BETA(55), BETA(56), - 2 BETA(57), BETA(58), BETA(59), BETA(60), BETA(61), BETA(62), - 3 BETA(63), BETA(64), BETA(65), BETA(66)/ - 4 2.14463263790822639D-05, 2.23954659232456514D-05, - 5 2.28967783814712629D-05, 2.30785389811177817D-05, - 6 2.30321976080909144D-05, 2.28236073720348722D-05, - 7 2.25005881105292418D-05, 2.20981015361991429D-05, - 8 2.16418427448103905D-05, 2.11507649256220843D-05, - 9 2.06388749782170737D-05, 2.01165241997081666D-05, - A 1.95913450141179244D-05, 1.90689367910436740D-05, - B 1.85533719641636667D-05, 1.80475722259674218D-05, - C 5.52213076721292790D-04, 4.47932581552384646D-04, - D 2.79520653992020589D-04, 1.52468156198446602D-04, - E 6.93271105657043598D-05, 1.76258683069991397D-05/ - DATA BETA(67), BETA(68), BETA(69), BETA(70), BETA(71), BETA(72), - 1 BETA(73), BETA(74), BETA(75), BETA(76), BETA(77), BETA(78), - 2 BETA(79), BETA(80), BETA(81), BETA(82), BETA(83), BETA(84), - 3 BETA(85), BETA(86), BETA(87), BETA(88)/ - 4 -1.35744996343269136D-05, -3.17972413350427135D-05, - 5 -4.18861861696693365D-05, -4.69004889379141029D-05, - 6 -4.87665447413787352D-05, -4.87010031186735069D-05, - 7 -4.74755620890086638D-05, -4.55813058138628452D-05, - 8 -4.33309644511266036D-05, -4.09230193157750364D-05, - 9 -3.84822638603221274D-05, -3.60857167535410501D-05, - A -3.37793306123367417D-05, -3.15888560772109621D-05, - B -2.95269561750807315D-05, -2.75978914828335759D-05, - C -2.58006174666883713D-05, -2.41308356761280200D-05, - D -2.25823509518346033D-05, -2.11479656768912971D-05, - E -1.98200638885294927D-05, -1.85909870801065077D-05/ - DATA BETA(89), BETA(90), BETA(91), BETA(92), BETA(93), BETA(94), - 1 BETA(95), BETA(96), BETA(97), BETA(98), BETA(99), BETA(100), - 2 BETA(101), BETA(102), BETA(103), BETA(104), BETA(105), - 3 BETA(106), BETA(107), BETA(108), BETA(109), BETA(110)/ - 4 -1.74532699844210224D-05, -1.63997823854497997D-05, - 5 -4.74617796559959808D-04, -4.77864567147321487D-04, - 6 -3.20390228067037603D-04, -1.61105016119962282D-04, - 7 -4.25778101285435204D-05, 3.44571294294967503D-05, - 8 7.97092684075674924D-05, 1.03138236708272200D-04, - 9 1.12466775262204158D-04, 1.13103642108481389D-04, - A 1.08651634848774268D-04, 1.01437951597661973D-04, - B 9.29298396593363896D-05, 8.40293133016089978D-05, - C 7.52727991349134062D-05, 6.69632521975730872D-05, - D 5.92564547323194704D-05, 5.22169308826975567D-05, - E 4.58539485165360646D-05, 4.01445513891486808D-05/ - DATA BETA(111), BETA(112), BETA(113), BETA(114), BETA(115), - 1 BETA(116), BETA(117), BETA(118), BETA(119), BETA(120), - 2 BETA(121), BETA(122), BETA(123), BETA(124), BETA(125), - 3 BETA(126), BETA(127), BETA(128), BETA(129), BETA(130)/ - 4 3.50481730031328081D-05, 3.05157995034346659D-05, - 5 2.64956119950516039D-05, 2.29363633690998152D-05, - 6 1.97893056664021636D-05, 1.70091984636412623D-05, - 7 1.45547428261524004D-05, 1.23886640995878413D-05, - 8 1.04775876076583236D-05, 8.79179954978479373D-06, - 9 7.36465810572578444D-04, 8.72790805146193976D-04, - A 6.22614862573135066D-04, 2.85998154194304147D-04, - B 3.84737672879366102D-06, -1.87906003636971558D-04, - C -2.97603646594554535D-04, -3.45998126832656348D-04, - D -3.53382470916037712D-04, -3.35715635775048757D-04/ - DATA BETA(131), BETA(132), BETA(133), BETA(134), BETA(135), - 1 BETA(136), BETA(137), BETA(138), BETA(139), BETA(140), - 2 BETA(141), BETA(142), BETA(143), BETA(144), BETA(145), - 3 BETA(146), BETA(147), BETA(148), BETA(149), BETA(150)/ - 4 -3.04321124789039809D-04, -2.66722723047612821D-04, - 5 -2.27654214122819527D-04, -1.89922611854562356D-04, - 6 -1.55058918599093870D-04, -1.23778240761873630D-04, - 7 -9.62926147717644187D-05, -7.25178327714425337D-05, - 8 -5.22070028895633801D-05, -3.50347750511900522D-05, - 9 -2.06489761035551757D-05, -8.70106096849767054D-06, - A 1.13698686675100290D-06, 9.16426474122778849D-06, - B 1.56477785428872620D-05, 2.08223629482466847D-05, - C 2.48923381004595156D-05, 2.80340509574146325D-05, - D 3.03987774629861915D-05, 3.21156731406700616D-05/ - DATA BETA(151), BETA(152), BETA(153), BETA(154), BETA(155), - 1 BETA(156), BETA(157), BETA(158), BETA(159), BETA(160), - 2 BETA(161), BETA(162), BETA(163), BETA(164), BETA(165), - 3 BETA(166), BETA(167), BETA(168), BETA(169), BETA(170)/ - 4 -1.80182191963885708D-03, -2.43402962938042533D-03, - 5 -1.83422663549856802D-03, -7.62204596354009765D-04, - 6 2.39079475256927218D-04, 9.49266117176881141D-04, - 7 1.34467449701540359D-03, 1.48457495259449178D-03, - 8 1.44732339830617591D-03, 1.30268261285657186D-03, - 9 1.10351597375642682D-03, 8.86047440419791759D-04, - A 6.73073208165665473D-04, 4.77603872856582378D-04, - B 3.05991926358789362D-04, 1.60315694594721630D-04, - C 4.00749555270613286D-05, -5.66607461635251611D-05, - D -1.32506186772982638D-04, -1.90296187989614057D-04/ - DATA BETA(171), BETA(172), BETA(173), BETA(174), BETA(175), - 1 BETA(176), BETA(177), BETA(178), BETA(179), BETA(180), - 2 BETA(181), BETA(182), BETA(183), BETA(184), BETA(185), - 3 BETA(186), BETA(187), BETA(188), BETA(189), BETA(190)/ - 4 -2.32811450376937408D-04, -2.62628811464668841D-04, - 5 -2.82050469867598672D-04, -2.93081563192861167D-04, - 6 -2.97435962176316616D-04, -2.96557334239348078D-04, - 7 -2.91647363312090861D-04, -2.83696203837734166D-04, - 8 -2.73512317095673346D-04, -2.61750155806768580D-04, - 9 6.38585891212050914D-03, 9.62374215806377941D-03, - A 7.61878061207001043D-03, 2.83219055545628054D-03, - B -2.09841352012720090D-03, -5.73826764216626498D-03, - C -7.70804244495414620D-03, -8.21011692264844401D-03, - D -7.65824520346905413D-03, -6.47209729391045177D-03/ - DATA BETA(191), BETA(192), BETA(193), BETA(194), BETA(195), - 1 BETA(196), BETA(197), BETA(198), BETA(199), BETA(200), - 2 BETA(201), BETA(202), BETA(203), BETA(204), BETA(205), - 3 BETA(206), BETA(207), BETA(208), BETA(209), BETA(210)/ - 4 -4.99132412004966473D-03, -3.45612289713133280D-03, - 5 -2.01785580014170775D-03, -7.59430686781961401D-04, - 6 2.84173631523859138D-04, 1.10891667586337403D-03, - 7 1.72901493872728771D-03, 2.16812590802684701D-03, - 8 2.45357710494539735D-03, 2.61281821058334862D-03, - 9 2.67141039656276912D-03, 2.65203073395980430D-03, - A 2.57411652877287315D-03, 2.45389126236094427D-03, - B 2.30460058071795494D-03, 2.13684837686712662D-03, - C 1.95896528478870911D-03, 1.77737008679454412D-03, - D 1.59690280765839059D-03, 1.42111975664438546D-03/ - DATA GAMA(1), GAMA(2), GAMA(3), GAMA(4), GAMA(5), GAMA(6), - 1 GAMA(7), GAMA(8), GAMA(9), GAMA(10), GAMA(11), GAMA(12), - 2 GAMA(13), GAMA(14), GAMA(15), GAMA(16), GAMA(17), GAMA(18), - 3 GAMA(19), GAMA(20), GAMA(21), GAMA(22)/ - 4 6.29960524947436582D-01, 2.51984209978974633D-01, - 5 1.54790300415655846D-01, 1.10713062416159013D-01, - 6 8.57309395527394825D-02, 6.97161316958684292D-02, - 7 5.86085671893713576D-02, 5.04698873536310685D-02, - 8 4.42600580689154809D-02, 3.93720661543509966D-02, - 9 3.54283195924455368D-02, 3.21818857502098231D-02, - A 2.94646240791157679D-02, 2.71581677112934479D-02, - B 2.51768272973861779D-02, 2.34570755306078891D-02, - C 2.19508390134907203D-02, 2.06210828235646240D-02, - D 1.94388240897880846D-02, 1.83810633800683158D-02, - E 1.74293213231963172D-02, 1.65685837786612353D-02/ - DATA GAMA(23), GAMA(24), GAMA(25), GAMA(26), GAMA(27), GAMA(28), - 1 GAMA(29), GAMA(30)/ - 2 1.57865285987918445D-02, 1.50729501494095594D-02, - 3 1.44193250839954639D-02, 1.38184805735341786D-02, - 4 1.32643378994276568D-02, 1.27517121970498651D-02, - 5 1.22761545318762767D-02, 1.18338262398482403D-02/ - DATA EX1, EX2, HPI, GPI, THPI / - 1 3.33333333333333333D-01, 6.66666666666666667D-01, - 2 1.57079632679489662D+00, 3.14159265358979324D+00, - 3 4.71238898038468986D+00/ - DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / -C***FIRST EXECUTABLE STATEMENT ZUNHJ - RFNU = 1.0D0/FNU -C----------------------------------------------------------------------- -C OVERFLOW TEST (Z/FNU TOO SMALL) -C----------------------------------------------------------------------- - TEST = D1MACH(1)*1.0D+3 - AC = FNU*TEST - IF (ABS(ZR).GT.AC .OR. ABS(ZI).GT.AC) GO TO 15 - ZETA1R = 2.0D0*ABS(LOG(TEST))+FNU - ZETA1I = 0.0D0 - ZETA2R = FNU - ZETA2I = 0.0D0 - PHIR = 1.0D0 - PHII = 0.0D0 - ARGR = 1.0D0 - ARGI = 0.0D0 - RETURN - 15 CONTINUE - ZBR = ZR*RFNU - ZBI = ZI*RFNU - RFNU2 = RFNU*RFNU -C----------------------------------------------------------------------- -C COMPUTE IN THE FOURTH QUADRANT -C----------------------------------------------------------------------- - FN13 = FNU**EX1 - FN23 = FN13*FN13 - RFN13 = 1.0D0/FN13 - W2R = CONER - ZBR*ZBR + ZBI*ZBI - W2I = CONEI - ZBR*ZBI - ZBR*ZBI - AW2 = ZABS(W2R,W2I) - IF (AW2.GT.0.25D0) GO TO 130 -C----------------------------------------------------------------------- -C POWER SERIES FOR ABS(W2).LE.0.25D0 -C----------------------------------------------------------------------- - K = 1 - PR(1) = CONER - PI(1) = CONEI - SUMAR = GAMA(1) - SUMAI = ZEROI - AP(1) = 1.0D0 - IF (AW2.LT.TOL) GO TO 20 - DO 10 K=2,30 - PR(K) = PR(K-1)*W2R - PI(K-1)*W2I - PI(K) = PR(K-1)*W2I + PI(K-1)*W2R - SUMAR = SUMAR + PR(K)*GAMA(K) - SUMAI = SUMAI + PI(K)*GAMA(K) - AP(K) = AP(K-1)*AW2 - IF (AP(K).LT.TOL) GO TO 20 - 10 CONTINUE - K = 30 - 20 CONTINUE - KMAX = K - ZETAR = W2R*SUMAR - W2I*SUMAI - ZETAI = W2R*SUMAI + W2I*SUMAR - ARGR = ZETAR*FN23 - ARGI = ZETAI*FN23 - CALL ZSQRT(SUMAR, SUMAI, ZAR, ZAI) - CALL ZSQRT(W2R, W2I, STR, STI) - ZETA2R = STR*FNU - ZETA2I = STI*FNU - STR = CONER + EX2*(ZETAR*ZAR-ZETAI*ZAI) - STI = CONEI + EX2*(ZETAR*ZAI+ZETAI*ZAR) - ZETA1R = STR*ZETA2R - STI*ZETA2I - ZETA1I = STR*ZETA2I + STI*ZETA2R - ZAR = ZAR + ZAR - ZAI = ZAI + ZAI - CALL ZSQRT(ZAR, ZAI, STR, STI) - PHIR = STR*RFN13 - PHII = STI*RFN13 - IF (IPMTR.EQ.1) GO TO 120 -C----------------------------------------------------------------------- -C SUM SERIES FOR ASUM AND BSUM -C----------------------------------------------------------------------- - SUMBR = ZEROR - SUMBI = ZEROI - DO 30 K=1,KMAX - SUMBR = SUMBR + PR(K)*BETA(K) - SUMBI = SUMBI + PI(K)*BETA(K) - 30 CONTINUE - ASUMR = ZEROR - ASUMI = ZEROI - BSUMR = SUMBR - BSUMI = SUMBI - L1 = 0 - L2 = 30 - BTOL = TOL*(ABS(BSUMR)+ABS(BSUMI)) - ATOL = TOL - PP = 1.0D0 - IAS = 0 - IBS = 0 - IF (RFNU2.LT.TOL) GO TO 110 - DO 100 IS=2,7 - ATOL = ATOL/RFNU2 - PP = PP*RFNU2 - IF (IAS.EQ.1) GO TO 60 - SUMAR = ZEROR - SUMAI = ZEROI - DO 40 K=1,KMAX - M = L1 + K - SUMAR = SUMAR + PR(K)*ALFA(M) - SUMAI = SUMAI + PI(K)*ALFA(M) - IF (AP(K).LT.ATOL) GO TO 50 - 40 CONTINUE - 50 CONTINUE - ASUMR = ASUMR + SUMAR*PP - ASUMI = ASUMI + SUMAI*PP - IF (PP.LT.TOL) IAS = 1 - 60 CONTINUE - IF (IBS.EQ.1) GO TO 90 - SUMBR = ZEROR - SUMBI = ZEROI - DO 70 K=1,KMAX - M = L2 + K - SUMBR = SUMBR + PR(K)*BETA(M) - SUMBI = SUMBI + PI(K)*BETA(M) - IF (AP(K).LT.ATOL) GO TO 80 - 70 CONTINUE - 80 CONTINUE - BSUMR = BSUMR + SUMBR*PP - BSUMI = BSUMI + SUMBI*PP - IF (PP.LT.BTOL) IBS = 1 - 90 CONTINUE - IF (IAS.EQ.1 .AND. IBS.EQ.1) GO TO 110 - L1 = L1 + 30 - L2 = L2 + 30 - 100 CONTINUE - 110 CONTINUE - ASUMR = ASUMR + CONER - PP = RFNU*RFN13 - BSUMR = BSUMR*PP - BSUMI = BSUMI*PP - 120 CONTINUE - RETURN -C----------------------------------------------------------------------- -C ABS(W2).GT.0.25D0 -C----------------------------------------------------------------------- - 130 CONTINUE - CALL ZSQRT(W2R, W2I, WR, WI) - IF (WR.LT.0.0D0) WR = 0.0D0 - IF (WI.LT.0.0D0) WI = 0.0D0 - STR = CONER + WR - STI = WI - CALL ZDIV(STR, STI, ZBR, ZBI, ZAR, ZAI) - CALL ZLOG(ZAR, ZAI, ZCR, ZCI, IDUM) - IF (ZCI.LT.0.0D0) ZCI = 0.0D0 - IF (ZCI.GT.HPI) ZCI = HPI - IF (ZCR.LT.0.0D0) ZCR = 0.0D0 - ZTHR = (ZCR-WR)*1.5D0 - ZTHI = (ZCI-WI)*1.5D0 - ZETA1R = ZCR*FNU - ZETA1I = ZCI*FNU - ZETA2R = WR*FNU - ZETA2I = WI*FNU - AZTH = ZABS(ZTHR,ZTHI) - ANG = THPI - IF (ZTHR.GE.0.0D0 .AND. ZTHI.LT.0.0D0) GO TO 140 - ANG = HPI - IF (ZTHR.EQ.0.0D0) GO TO 140 - ANG = DATAN(ZTHI/ZTHR) - IF (ZTHR.LT.0.0D0) ANG = ANG + GPI - 140 CONTINUE - PP = AZTH**EX2 - ANG = ANG*EX2 - ZETAR = PP*COS(ANG) - ZETAI = PP*SIN(ANG) - IF (ZETAI.LT.0.0D0) ZETAI = 0.0D0 - ARGR = ZETAR*FN23 - ARGI = ZETAI*FN23 - CALL ZDIV(ZTHR, ZTHI, ZETAR, ZETAI, RTZTR, RTZTI) - CALL ZDIV(RTZTR, RTZTI, WR, WI, ZAR, ZAI) - TZAR = ZAR + ZAR - TZAI = ZAI + ZAI - CALL ZSQRT(TZAR, TZAI, STR, STI) - PHIR = STR*RFN13 - PHII = STI*RFN13 - IF (IPMTR.EQ.1) GO TO 120 - RAW = 1.0D0/SQRT(AW2) - STR = WR*RAW - STI = -WI*RAW - TFNR = STR*RFNU*RAW - TFNI = STI*RFNU*RAW - RAZTH = 1.0D0/AZTH - STR = ZTHR*RAZTH - STI = -ZTHI*RAZTH - RZTHR = STR*RAZTH*RFNU - RZTHI = STI*RAZTH*RFNU - ZCR = RZTHR*AR(2) - ZCI = RZTHI*AR(2) - RAW2 = 1.0D0/AW2 - STR = W2R*RAW2 - STI = -W2I*RAW2 - T2R = STR*RAW2 - T2I = STI*RAW2 - STR = T2R*C(2) + C(3) - STI = T2I*C(2) - UPR(2) = STR*TFNR - STI*TFNI - UPI(2) = STR*TFNI + STI*TFNR - BSUMR = UPR(2) + ZCR - BSUMI = UPI(2) + ZCI - ASUMR = ZEROR - ASUMI = ZEROI - IF (RFNU.LT.TOL) GO TO 220 - PRZTHR = RZTHR - PRZTHI = RZTHI - PTFNR = TFNR - PTFNI = TFNI - UPR(1) = CONER - UPI(1) = CONEI - PP = 1.0D0 - BTOL = TOL*(ABS(BSUMR)+ABS(BSUMI)) - KS = 0 - KP1 = 2 - L = 3 - IAS = 0 - IBS = 0 - DO 210 LR=2,12,2 - LRP1 = LR + 1 -C----------------------------------------------------------------------- -C COMPUTE TWO ADDITIONAL CR, DR, AND UP FOR TWO MORE TERMS IN -C NEXT SUMA AND SUMB -C----------------------------------------------------------------------- - DO 160 K=LR,LRP1 - KS = KS + 1 - KP1 = KP1 + 1 - L = L + 1 - ZAR = C(L) - ZAI = ZEROI - DO 150 J=2,KP1 - L = L + 1 - STR = ZAR*T2R - T2I*ZAI + C(L) - ZAI = ZAR*T2I + ZAI*T2R - ZAR = STR - 150 CONTINUE - STR = PTFNR*TFNR - PTFNI*TFNI - PTFNI = PTFNR*TFNI + PTFNI*TFNR - PTFNR = STR - UPR(KP1) = PTFNR*ZAR - PTFNI*ZAI - UPI(KP1) = PTFNI*ZAR + PTFNR*ZAI - CRR(KS) = PRZTHR*BR(KS+1) - CRI(KS) = PRZTHI*BR(KS+1) - STR = PRZTHR*RZTHR - PRZTHI*RZTHI - PRZTHI = PRZTHR*RZTHI + PRZTHI*RZTHR - PRZTHR = STR - DRR(KS) = PRZTHR*AR(KS+2) - DRI(KS) = PRZTHI*AR(KS+2) - 160 CONTINUE - PP = PP*RFNU2 - IF (IAS.EQ.1) GO TO 180 - SUMAR = UPR(LRP1) - SUMAI = UPI(LRP1) - JU = LRP1 - DO 170 JR=1,LR - JU = JU - 1 - SUMAR = SUMAR + CRR(JR)*UPR(JU) - CRI(JR)*UPI(JU) - SUMAI = SUMAI + CRR(JR)*UPI(JU) + CRI(JR)*UPR(JU) - 170 CONTINUE - ASUMR = ASUMR + SUMAR - ASUMI = ASUMI + SUMAI - TEST = ABS(SUMAR) + ABS(SUMAI) - IF (PP.LT.TOL .AND. TEST.LT.TOL) IAS = 1 - 180 CONTINUE - IF (IBS.EQ.1) GO TO 200 - SUMBR = UPR(LR+2) + UPR(LRP1)*ZCR - UPI(LRP1)*ZCI - SUMBI = UPI(LR+2) + UPR(LRP1)*ZCI + UPI(LRP1)*ZCR - JU = LRP1 - DO 190 JR=1,LR - JU = JU - 1 - SUMBR = SUMBR + DRR(JR)*UPR(JU) - DRI(JR)*UPI(JU) - SUMBI = SUMBI + DRR(JR)*UPI(JU) + DRI(JR)*UPR(JU) - 190 CONTINUE - BSUMR = BSUMR + SUMBR - BSUMI = BSUMI + SUMBI - TEST = ABS(SUMBR) + ABS(SUMBI) - IF (PP.LT.BTOL .AND. TEST.LT.BTOL) IBS = 1 - 200 CONTINUE - IF (IAS.EQ.1 .AND. IBS.EQ.1) GO TO 220 - 210 CONTINUE - 220 CONTINUE - ASUMR = ASUMR + CONER - STR = -BSUMR*RFN13 - STI = -BSUMI*RFN13 - CALL ZDIV(STR, STI, RTZTR, RTZTI, BSUMR, BSUMI) - GO TO 120 - END diff --git a/slatec/zuni1.f b/slatec/zuni1.f deleted file mode 100644 index eb309af..0000000 --- a/slatec/zuni1.f +++ /dev/null @@ -1,215 +0,0 @@ -*DECK ZUNI1 - SUBROUTINE ZUNI1 (ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL, - + TOL, ELIM, ALIM) -C***BEGIN PROLOGUE ZUNI1 -C***SUBSIDIARY -C***PURPOSE Subsidiary to ZBESI and ZBESK -C***LIBRARY SLATEC -C***TYPE ALL (CUNI1-A, ZUNI1-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C ZUNI1 COMPUTES I(FNU,Z) BY MEANS OF THE UNIFORM ASYMPTOTIC -C EXPANSION FOR I(FNU,Z) IN -PI/3.LE.ARG Z.LE.PI/3. -C -C FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC -C EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. -C NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER -C FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL. -C Y(I)=CZERO FOR I=NLAST+1,N -C -C***SEE ALSO ZBESI, ZBESK -C***ROUTINES CALLED D1MACH, ZABS, ZUCHK, ZUNIK, ZUOIK -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE ZUNI1 -C COMPLEX CFN,CONE,CRSC,CSCL,CSR,CSS,CWRK,CZERO,C1,C2,PHI,RZ,SUM,S1, -C *S2,Y,Z,ZETA1,ZETA2 - DOUBLE PRECISION ALIM, APHI, ASCLE, BRY, CONER, CRSC, - * CSCL, CSRR, CSSR, CWRKI, CWRKR, C1R, C2I, C2M, C2R, ELIM, FN, - * FNU, FNUL, PHII, PHIR, RAST, RS1, RZI, RZR, STI, STR, SUMI, - * SUMR, S1I, S1R, S2I, S2R, TOL, YI, YR, ZEROI, ZEROR, ZETA1I, - * ZETA1R, ZETA2I, ZETA2R, ZI, ZR, CYR, CYI, D1MACH, ZABS - INTEGER I, IFLAG, INIT, K, KODE, M, N, ND, NLAST, NN, NUF, NW, NZ - DIMENSION BRY(3), YR(N), YI(N), CWRKR(16), CWRKI(16), CSSR(3), - * CSRR(3), CYR(2), CYI(2) - EXTERNAL ZABS - DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 / -C***FIRST EXECUTABLE STATEMENT ZUNI1 - NZ = 0 - ND = N - NLAST = 0 -C----------------------------------------------------------------------- -C COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- -C NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, -C EXP(ALIM)=EXP(ELIM)*TOL -C----------------------------------------------------------------------- - CSCL = 1.0D0/TOL - CRSC = TOL - CSSR(1) = CSCL - CSSR(2) = CONER - CSSR(3) = CRSC - CSRR(1) = CRSC - CSRR(2) = CONER - CSRR(3) = CSCL - BRY(1) = 1.0D+3*D1MACH(1)/TOL -C----------------------------------------------------------------------- -C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER -C----------------------------------------------------------------------- - FN = MAX(FNU,1.0D0) - INIT = 0 - CALL ZUNIK(ZR, ZI, FN, 1, 1, TOL, INIT, PHIR, PHII, ZETA1R, - * ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) - IF (KODE.EQ.1) GO TO 10 - STR = ZR + ZETA2R - STI = ZI + ZETA2I - RAST = FN/ZABS(STR,STI) - STR = STR*RAST*RAST - STI = -STI*RAST*RAST - S1R = -ZETA1R + STR - S1I = -ZETA1I + STI - GO TO 20 - 10 CONTINUE - S1R = -ZETA1R + ZETA2R - S1I = -ZETA1I + ZETA2I - 20 CONTINUE - RS1 = S1R - IF (ABS(RS1).GT.ELIM) GO TO 130 - 30 CONTINUE - NN = MIN(2,ND) - DO 80 I=1,NN - FN = FNU + (ND-I) - INIT = 0 - CALL ZUNIK(ZR, ZI, FN, 1, 0, TOL, INIT, PHIR, PHII, ZETA1R, - * ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) - IF (KODE.EQ.1) GO TO 40 - STR = ZR + ZETA2R - STI = ZI + ZETA2I - RAST = FN/ZABS(STR,STI) - STR = STR*RAST*RAST - STI = -STI*RAST*RAST - S1R = -ZETA1R + STR - S1I = -ZETA1I + STI + ZI - GO TO 50 - 40 CONTINUE - S1R = -ZETA1R + ZETA2R - S1I = -ZETA1I + ZETA2I - 50 CONTINUE -C----------------------------------------------------------------------- -C TEST FOR UNDERFLOW AND OVERFLOW -C----------------------------------------------------------------------- - RS1 = S1R - IF (ABS(RS1).GT.ELIM) GO TO 110 - IF (I.EQ.1) IFLAG = 2 - IF (ABS(RS1).LT.ALIM) GO TO 60 -C----------------------------------------------------------------------- -C REFINE TEST AND SCALE -C----------------------------------------------------------------------- - APHI = ZABS(PHIR,PHII) - RS1 = RS1 + LOG(APHI) - IF (ABS(RS1).GT.ELIM) GO TO 110 - IF (I.EQ.1) IFLAG = 1 - IF (RS1.LT.0.0D0) GO TO 60 - IF (I.EQ.1) IFLAG = 3 - 60 CONTINUE -C----------------------------------------------------------------------- -C SCALE S1 IF ABS(S1).LT.ASCLE -C----------------------------------------------------------------------- - S2R = PHIR*SUMR - PHII*SUMI - S2I = PHIR*SUMI + PHII*SUMR - STR = EXP(S1R)*CSSR(IFLAG) - S1R = STR*COS(S1I) - S1I = STR*SIN(S1I) - STR = S2R*S1R - S2I*S1I - S2I = S2R*S1I + S2I*S1R - S2R = STR - IF (IFLAG.NE.1) GO TO 70 - CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) - IF (NW.NE.0) GO TO 110 - 70 CONTINUE - CYR(I) = S2R - CYI(I) = S2I - M = ND - I + 1 - YR(M) = S2R*CSRR(IFLAG) - YI(M) = S2I*CSRR(IFLAG) - 80 CONTINUE - IF (ND.LE.2) GO TO 100 - RAST = 1.0D0/ZABS(ZR,ZI) - STR = ZR*RAST - STI = -ZI*RAST - RZR = (STR+STR)*RAST - RZI = (STI+STI)*RAST - BRY(2) = 1.0D0/BRY(1) - BRY(3) = D1MACH(2) - S1R = CYR(1) - S1I = CYI(1) - S2R = CYR(2) - S2I = CYI(2) - C1R = CSRR(IFLAG) - ASCLE = BRY(IFLAG) - K = ND - 2 - FN = K - DO 90 I=3,ND - C2R = S2R - C2I = S2I - S2R = S1R + (FNU+FN)*(RZR*C2R-RZI*C2I) - S2I = S1I + (FNU+FN)*(RZR*C2I+RZI*C2R) - S1R = C2R - S1I = C2I - C2R = S2R*C1R - C2I = S2I*C1R - YR(K) = C2R - YI(K) = C2I - K = K - 1 - FN = FN - 1.0D0 - IF (IFLAG.GE.3) GO TO 90 - STR = ABS(C2R) - STI = ABS(C2I) - C2M = MAX(STR,STI) - IF (C2M.LE.ASCLE) GO TO 90 - IFLAG = IFLAG + 1 - ASCLE = BRY(IFLAG) - S1R = S1R*C1R - S1I = S1I*C1R - S2R = C2R - S2I = C2I - S1R = S1R*CSSR(IFLAG) - S1I = S1I*CSSR(IFLAG) - S2R = S2R*CSSR(IFLAG) - S2I = S2I*CSSR(IFLAG) - C1R = CSRR(IFLAG) - 90 CONTINUE - 100 CONTINUE - RETURN -C----------------------------------------------------------------------- -C SET UNDERFLOW AND UPDATE PARAMETERS -C----------------------------------------------------------------------- - 110 CONTINUE - IF (RS1.GT.0.0D0) GO TO 120 - YR(ND) = ZEROR - YI(ND) = ZEROI - NZ = NZ + 1 - ND = ND - 1 - IF (ND.EQ.0) GO TO 100 - CALL ZUOIK(ZR, ZI, FNU, KODE, 1, ND, YR, YI, NUF, TOL, ELIM, ALIM) - IF (NUF.LT.0) GO TO 120 - ND = ND - NUF - NZ = NZ + NUF - IF (ND.EQ.0) GO TO 100 - FN = FNU + (ND-1) - IF (FN.GE.FNUL) GO TO 30 - NLAST = ND - RETURN - 120 CONTINUE - NZ = -1 - RETURN - 130 CONTINUE - IF (RS1.GT.0.0D0) GO TO 120 - NZ = N - DO 140 I=1,N - YR(I) = ZEROR - YI(I) = ZEROI - 140 CONTINUE - RETURN - END diff --git a/slatec/zuni2.f b/slatec/zuni2.f deleted file mode 100644 index 35ff301..0000000 --- a/slatec/zuni2.f +++ /dev/null @@ -1,278 +0,0 @@ -*DECK ZUNI2 - SUBROUTINE ZUNI2 (ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL, - + TOL, ELIM, ALIM) -C***BEGIN PROLOGUE ZUNI2 -C***SUBSIDIARY -C***PURPOSE Subsidiary to ZBESI and ZBESK -C***LIBRARY SLATEC -C***TYPE ALL (CUNI2-A, ZUNI2-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C ZUNI2 COMPUTES I(FNU,Z) IN THE RIGHT HALF PLANE BY MEANS OF -C UNIFORM ASYMPTOTIC EXPANSION FOR J(FNU,ZN) WHERE ZN IS Z*I -C OR -Z*I AND ZN IS IN THE RIGHT HALF PLANE ALSO. -C -C FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC -C EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. -C NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER -C FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL. -C Y(I)=CZERO FOR I=NLAST+1,N -C -C***SEE ALSO ZBESI, ZBESK -C***ROUTINES CALLED D1MACH, ZABS, ZAIRY, ZUCHK, ZUNHJ, ZUOIK -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE ZUNI2 -C COMPLEX AI,ARG,ASUM,BSUM,CFN,CI,CID,CIP,CONE,CRSC,CSCL,CSR,CSS, -C *CZERO,C1,C2,DAI,PHI,RZ,S1,S2,Y,Z,ZB,ZETA1,ZETA2,ZN - DOUBLE PRECISION AARG, AIC, AII, AIR, ALIM, ANG, APHI, ARGI, - * ARGR, ASCLE, ASUMI, ASUMR, BRY, BSUMI, BSUMR, CIDI, CIPI, CIPR, - * CONER, CRSC, CSCL, CSRR, CSSR, C1R, C2I, C2M, C2R, DAII, - * DAIR, ELIM, FN, FNU, FNUL, HPI, PHII, PHIR, RAST, RAZ, RS1, RZI, - * RZR, STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, ZBI, ZBR, ZEROI, - * ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZI, ZNI, ZNR, ZR, CYR, - * CYI, D1MACH, ZABS, CAR, SAR - INTEGER I, IFLAG, IN, INU, J, K, KODE, N, NAI, ND, NDAI, NLAST, - * NN, NUF, NW, NZ, IDUM - DIMENSION BRY(3), YR(N), YI(N), CIPR(4), CIPI(4), CSSR(3), - * CSRR(3), CYR(2), CYI(2) - EXTERNAL ZABS - DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 / - DATA CIPR(1),CIPI(1),CIPR(2),CIPI(2),CIPR(3),CIPI(3),CIPR(4), - * CIPI(4)/ 1.0D0,0.0D0, 0.0D0,1.0D0, -1.0D0,0.0D0, 0.0D0,-1.0D0/ - DATA HPI, AIC / - 1 1.57079632679489662D+00, 1.265512123484645396D+00/ -C***FIRST EXECUTABLE STATEMENT ZUNI2 - NZ = 0 - ND = N - NLAST = 0 -C----------------------------------------------------------------------- -C COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- -C NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, -C EXP(ALIM)=EXP(ELIM)*TOL -C----------------------------------------------------------------------- - CSCL = 1.0D0/TOL - CRSC = TOL - CSSR(1) = CSCL - CSSR(2) = CONER - CSSR(3) = CRSC - CSRR(1) = CRSC - CSRR(2) = CONER - CSRR(3) = CSCL - BRY(1) = 1.0D+3*D1MACH(1)/TOL -C----------------------------------------------------------------------- -C ZN IS IN THE RIGHT HALF PLANE AFTER ROTATION BY CI OR -CI -C----------------------------------------------------------------------- - ZNR = ZI - ZNI = -ZR - ZBR = ZR - ZBI = ZI - CIDI = -CONER - INU = FNU - ANG = HPI*(FNU-INU) - C2R = COS(ANG) - C2I = SIN(ANG) - CAR = C2R - SAR = C2I - IN = INU + N - 1 - IN = MOD(IN,4) + 1 - STR = C2R*CIPR(IN) - C2I*CIPI(IN) - C2I = C2R*CIPI(IN) + C2I*CIPR(IN) - C2R = STR - IF (ZI.GT.0.0D0) GO TO 10 - ZNR = -ZNR - ZBI = -ZBI - CIDI = -CIDI - C2I = -C2I - 10 CONTINUE -C----------------------------------------------------------------------- -C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER -C----------------------------------------------------------------------- - FN = MAX(FNU,1.0D0) - CALL ZUNHJ(ZNR, ZNI, FN, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, - * ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) - IF (KODE.EQ.1) GO TO 20 - STR = ZBR + ZETA2R - STI = ZBI + ZETA2I - RAST = FN/ZABS(STR,STI) - STR = STR*RAST*RAST - STI = -STI*RAST*RAST - S1R = -ZETA1R + STR - S1I = -ZETA1I + STI - GO TO 30 - 20 CONTINUE - S1R = -ZETA1R + ZETA2R - S1I = -ZETA1I + ZETA2I - 30 CONTINUE - RS1 = S1R - IF (ABS(RS1).GT.ELIM) GO TO 150 - 40 CONTINUE - NN = MIN(2,ND) - DO 90 I=1,NN - FN = FNU + (ND-I) - CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIR, PHII, ARGR, ARGI, - * ZETA1R, ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) - IF (KODE.EQ.1) GO TO 50 - STR = ZBR + ZETA2R - STI = ZBI + ZETA2I - RAST = FN/ZABS(STR,STI) - STR = STR*RAST*RAST - STI = -STI*RAST*RAST - S1R = -ZETA1R + STR - S1I = -ZETA1I + STI + ABS(ZI) - GO TO 60 - 50 CONTINUE - S1R = -ZETA1R + ZETA2R - S1I = -ZETA1I + ZETA2I - 60 CONTINUE -C----------------------------------------------------------------------- -C TEST FOR UNDERFLOW AND OVERFLOW -C----------------------------------------------------------------------- - RS1 = S1R - IF (ABS(RS1).GT.ELIM) GO TO 120 - IF (I.EQ.1) IFLAG = 2 - IF (ABS(RS1).LT.ALIM) GO TO 70 -C----------------------------------------------------------------------- -C REFINE TEST AND SCALE -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - APHI = ZABS(PHIR,PHII) - AARG = ZABS(ARGR,ARGI) - RS1 = RS1 + LOG(APHI) - 0.25D0*LOG(AARG) - AIC - IF (ABS(RS1).GT.ELIM) GO TO 120 - IF (I.EQ.1) IFLAG = 1 - IF (RS1.LT.0.0D0) GO TO 70 - IF (I.EQ.1) IFLAG = 3 - 70 CONTINUE -C----------------------------------------------------------------------- -C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR -C EXPONENT EXTREMES -C----------------------------------------------------------------------- - CALL ZAIRY(ARGR, ARGI, 0, 2, AIR, AII, NAI, IDUM) - CALL ZAIRY(ARGR, ARGI, 1, 2, DAIR, DAII, NDAI, IDUM) - STR = DAIR*BSUMR - DAII*BSUMI - STI = DAIR*BSUMI + DAII*BSUMR - STR = STR + (AIR*ASUMR-AII*ASUMI) - STI = STI + (AIR*ASUMI+AII*ASUMR) - S2R = PHIR*STR - PHII*STI - S2I = PHIR*STI + PHII*STR - STR = EXP(S1R)*CSSR(IFLAG) - S1R = STR*COS(S1I) - S1I = STR*SIN(S1I) - STR = S2R*S1R - S2I*S1I - S2I = S2R*S1I + S2I*S1R - S2R = STR - IF (IFLAG.NE.1) GO TO 80 - CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) - IF (NW.NE.0) GO TO 120 - 80 CONTINUE - IF (ZI.LE.0.0D0) S2I = -S2I - STR = S2R*C2R - S2I*C2I - S2I = S2R*C2I + S2I*C2R - S2R = STR - CYR(I) = S2R - CYI(I) = S2I - J = ND - I + 1 - YR(J) = S2R*CSRR(IFLAG) - YI(J) = S2I*CSRR(IFLAG) - STR = -C2I*CIDI - C2I = C2R*CIDI - C2R = STR - 90 CONTINUE - IF (ND.LE.2) GO TO 110 - RAZ = 1.0D0/ZABS(ZR,ZI) - STR = ZR*RAZ - STI = -ZI*RAZ - RZR = (STR+STR)*RAZ - RZI = (STI+STI)*RAZ - BRY(2) = 1.0D0/BRY(1) - BRY(3) = D1MACH(2) - S1R = CYR(1) - S1I = CYI(1) - S2R = CYR(2) - S2I = CYI(2) - C1R = CSRR(IFLAG) - ASCLE = BRY(IFLAG) - K = ND - 2 - FN = K - DO 100 I=3,ND - C2R = S2R - C2I = S2I - S2R = S1R + (FNU+FN)*(RZR*C2R-RZI*C2I) - S2I = S1I + (FNU+FN)*(RZR*C2I+RZI*C2R) - S1R = C2R - S1I = C2I - C2R = S2R*C1R - C2I = S2I*C1R - YR(K) = C2R - YI(K) = C2I - K = K - 1 - FN = FN - 1.0D0 - IF (IFLAG.GE.3) GO TO 100 - STR = ABS(C2R) - STI = ABS(C2I) - C2M = MAX(STR,STI) - IF (C2M.LE.ASCLE) GO TO 100 - IFLAG = IFLAG + 1 - ASCLE = BRY(IFLAG) - S1R = S1R*C1R - S1I = S1I*C1R - S2R = C2R - S2I = C2I - S1R = S1R*CSSR(IFLAG) - S1I = S1I*CSSR(IFLAG) - S2R = S2R*CSSR(IFLAG) - S2I = S2I*CSSR(IFLAG) - C1R = CSRR(IFLAG) - 100 CONTINUE - 110 CONTINUE - RETURN - 120 CONTINUE - IF (RS1.GT.0.0D0) GO TO 140 -C----------------------------------------------------------------------- -C SET UNDERFLOW AND UPDATE PARAMETERS -C----------------------------------------------------------------------- - YR(ND) = ZEROR - YI(ND) = ZEROI - NZ = NZ + 1 - ND = ND - 1 - IF (ND.EQ.0) GO TO 110 - CALL ZUOIK(ZR, ZI, FNU, KODE, 1, ND, YR, YI, NUF, TOL, ELIM, ALIM) - IF (NUF.LT.0) GO TO 140 - ND = ND - NUF - NZ = NZ + NUF - IF (ND.EQ.0) GO TO 110 - FN = FNU + (ND-1) - IF (FN.LT.FNUL) GO TO 130 -C FN = CIDI -C J = NUF + 1 -C K = MOD(J,4) + 1 -C S1R = CIPR(K) -C S1I = CIPI(K) -C IF (FN.LT.0.0D0) S1I = -S1I -C STR = C2R*S1R - C2I*S1I -C C2I = C2R*S1I + C2I*S1R -C C2R = STR - IN = INU + ND - 1 - IN = MOD(IN,4) + 1 - C2R = CAR*CIPR(IN) - SAR*CIPI(IN) - C2I = CAR*CIPI(IN) + SAR*CIPR(IN) - IF (ZI.LE.0.0D0) C2I = -C2I - GO TO 40 - 130 CONTINUE - NLAST = ND - RETURN - 140 CONTINUE - NZ = -1 - RETURN - 150 CONTINUE - IF (RS1.GT.0.0D0) GO TO 140 - NZ = N - DO 160 I=1,N - YR(I) = ZEROR - YI(I) = ZEROI - 160 CONTINUE - RETURN - END diff --git a/slatec/zunik.f b/slatec/zunik.f deleted file mode 100644 index 6785b98..0000000 --- a/slatec/zunik.f +++ /dev/null @@ -1,223 +0,0 @@ -*DECK ZUNIK - SUBROUTINE ZUNIK (ZRR, ZRI, FNU, IKFLG, IPMTR, TOL, INIT, PHIR, - + PHII, ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) -C***BEGIN PROLOGUE ZUNIK -C***SUBSIDIARY -C***PURPOSE Subsidiary to ZBESI and ZBESK -C***LIBRARY SLATEC -C***TYPE ALL (CUNIK-A, ZUNIK-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C ZUNIK COMPUTES PARAMETERS FOR THE UNIFORM ASYMPTOTIC -C EXPANSIONS OF THE I AND K FUNCTIONS ON IKFLG= 1 OR 2 -C RESPECTIVELY BY -C -C W(FNU,ZR) = PHI*EXP(ZETA)*SUM -C -C WHERE ZETA=-ZETA1 + ZETA2 OR -C ZETA1 - ZETA2 -C -C THE FIRST CALL MUST HAVE INIT=0. SUBSEQUENT CALLS WITH THE -C SAME ZR AND FNU WILL RETURN THE I OR K FUNCTION ON IKFLG= -C 1 OR 2 WITH NO CHANGE IN INIT. CWRK IS A COMPLEX WORK -C ARRAY. IPMTR=0 COMPUTES ALL PARAMETERS. IPMTR=1 COMPUTES PHI, -C ZETA1,ZETA2. -C -C***SEE ALSO ZBESI, ZBESK -C***ROUTINES CALLED D1MACH, ZDIV, ZLOG, ZSQRT -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C 930122 Added EXTERNAL statement with ZLOG and ZSQRT. (RWC) -C***END PROLOGUE ZUNIK -C COMPLEX CFN,CON,CONE,CRFN,CWRK,CZERO,PHI,S,SR,SUM,T,T2,ZETA1, -C *ZETA2,ZN,ZR - DOUBLE PRECISION AC, C, CON, CONEI, CONER, CRFNI, CRFNR, CWRKI, - * CWRKR, FNU, PHII, PHIR, RFN, SI, SR, SRI, SRR, STI, STR, SUMI, - * SUMR, TEST, TI, TOL, TR, T2I, T2R, ZEROI, ZEROR, ZETA1I, ZETA1R, - * ZETA2I, ZETA2R, ZNI, ZNR, ZRI, ZRR, D1MACH - INTEGER I, IDUM, IKFLG, INIT, IPMTR, J, K, L - DIMENSION C(120), CWRKR(16), CWRKI(16), CON(2) - EXTERNAL ZLOG, ZSQRT - DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / - DATA CON(1), CON(2) / - 1 3.98942280401432678D-01, 1.25331413731550025D+00 / - DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), - 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), - 2 C(19), C(20), C(21), C(22), C(23), C(24)/ - 3 1.00000000000000000D+00, -2.08333333333333333D-01, - 4 1.25000000000000000D-01, 3.34201388888888889D-01, - 5 -4.01041666666666667D-01, 7.03125000000000000D-02, - 6 -1.02581259645061728D+00, 1.84646267361111111D+00, - 7 -8.91210937500000000D-01, 7.32421875000000000D-02, - 8 4.66958442342624743D+00, -1.12070026162229938D+01, - 9 8.78912353515625000D+00, -2.36408691406250000D+00, - A 1.12152099609375000D-01, -2.82120725582002449D+01, - B 8.46362176746007346D+01, -9.18182415432400174D+01, - C 4.25349987453884549D+01, -7.36879435947963170D+00, - D 2.27108001708984375D-01, 2.12570130039217123D+02, - E -7.65252468141181642D+02, 1.05999045252799988D+03/ - DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), - 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), - 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ - 3 -6.99579627376132541D+02, 2.18190511744211590D+02, - 4 -2.64914304869515555D+01, 5.72501420974731445D-01, - 5 -1.91945766231840700D+03, 8.06172218173730938D+03, - 6 -1.35865500064341374D+04, 1.16553933368645332D+04, - 7 -5.30564697861340311D+03, 1.20090291321635246D+03, - 8 -1.08090919788394656D+02, 1.72772750258445740D+00, - 9 2.02042913309661486D+04, -9.69805983886375135D+04, - A 1.92547001232531532D+05, -2.03400177280415534D+05, - B 1.22200464983017460D+05, -4.11926549688975513D+04, - C 7.10951430248936372D+03, -4.93915304773088012D+02, - D 6.07404200127348304D+00, -2.42919187900551333D+05, - E 1.31176361466297720D+06, -2.99801591853810675D+06/ - DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), - 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), - 2 C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ - 3 3.76327129765640400D+06, -2.81356322658653411D+06, - 4 1.26836527332162478D+06, -3.31645172484563578D+05, - 5 4.52187689813627263D+04, -2.49983048181120962D+03, - 6 2.43805296995560639D+01, 3.28446985307203782D+06, - 7 -1.97068191184322269D+07, 5.09526024926646422D+07, - 8 -7.41051482115326577D+07, 6.63445122747290267D+07, - 9 -3.75671766607633513D+07, 1.32887671664218183D+07, - A -2.78561812808645469D+06, 3.08186404612662398D+05, - B -1.38860897537170405D+04, 1.10017140269246738D+02, - C -4.93292536645099620D+07, 3.25573074185765749D+08, - D -9.39462359681578403D+08, 1.55359689957058006D+09, - E -1.62108055210833708D+09, 1.10684281682301447D+09/ - DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), - 1 C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), - 2 C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ - 3 -4.95889784275030309D+08, 1.42062907797533095D+08, - 4 -2.44740627257387285D+07, 2.24376817792244943D+06, - 5 -8.40054336030240853D+04, 5.51335896122020586D+02, - 6 8.14789096118312115D+08, -5.86648149205184723D+09, - 7 1.86882075092958249D+10, -3.46320433881587779D+10, - 8 4.12801855797539740D+10, -3.30265997498007231D+10, - 9 1.79542137311556001D+10, -6.56329379261928433D+09, - A 1.55927986487925751D+09, -2.25105661889415278D+08, - B 1.73951075539781645D+07, -5.49842327572288687D+05, - C 3.03809051092238427D+03, -1.46792612476956167D+10, - D 1.14498237732025810D+11, -3.99096175224466498D+11, - E 8.19218669548577329D+11, -1.09837515608122331D+12/ - DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104), - 1 C(105), C(106), C(107), C(108), C(109), C(110), C(111), - 2 C(112), C(113), C(114), C(115), C(116), C(117), C(118)/ - 3 1.00815810686538209D+12, -6.45364869245376503D+11, - 4 2.87900649906150589D+11, -8.78670721780232657D+10, - 5 1.76347306068349694D+10, -2.16716498322379509D+09, - 6 1.43157876718888981D+08, -3.87183344257261262D+06, - 7 1.82577554742931747D+04, 2.86464035717679043D+11, - 8 -2.40629790002850396D+12, 9.10934118523989896D+12, - 9 -2.05168994109344374D+13, 3.05651255199353206D+13, - A -3.16670885847851584D+13, 2.33483640445818409D+13, - B -1.23204913055982872D+13, 4.61272578084913197D+12, - C -1.19655288019618160D+12, 2.05914503232410016D+11, - D -2.18229277575292237D+10, 1.24700929351271032D+09/ - DATA C(119), C(120)/ - 1 -2.91883881222208134D+07, 1.18838426256783253D+05/ -C***FIRST EXECUTABLE STATEMENT ZUNIK - IF (INIT.NE.0) GO TO 40 -C----------------------------------------------------------------------- -C INITIALIZE ALL VARIABLES -C----------------------------------------------------------------------- - RFN = 1.0D0/FNU -C----------------------------------------------------------------------- -C OVERFLOW TEST (ZR/FNU TOO SMALL) -C----------------------------------------------------------------------- - TEST = D1MACH(1)*1.0D+3 - AC = FNU*TEST - IF (ABS(ZRR).GT.AC .OR. ABS(ZRI).GT.AC) GO TO 15 - ZETA1R = 2.0D0*ABS(LOG(TEST))+FNU - ZETA1I = 0.0D0 - ZETA2R = FNU - ZETA2I = 0.0D0 - PHIR = 1.0D0 - PHII = 0.0D0 - RETURN - 15 CONTINUE - TR = ZRR*RFN - TI = ZRI*RFN - SR = CONER + (TR*TR-TI*TI) - SI = CONEI + (TR*TI+TI*TR) - CALL ZSQRT(SR, SI, SRR, SRI) - STR = CONER + SRR - STI = CONEI + SRI - CALL ZDIV(STR, STI, TR, TI, ZNR, ZNI) - CALL ZLOG(ZNR, ZNI, STR, STI, IDUM) - ZETA1R = FNU*STR - ZETA1I = FNU*STI - ZETA2R = FNU*SRR - ZETA2I = FNU*SRI - CALL ZDIV(CONER, CONEI, SRR, SRI, TR, TI) - SRR = TR*RFN - SRI = TI*RFN - CALL ZSQRT(SRR, SRI, CWRKR(16), CWRKI(16)) - PHIR = CWRKR(16)*CON(IKFLG) - PHII = CWRKI(16)*CON(IKFLG) - IF (IPMTR.NE.0) RETURN - CALL ZDIV(CONER, CONEI, SR, SI, T2R, T2I) - CWRKR(1) = CONER - CWRKI(1) = CONEI - CRFNR = CONER - CRFNI = CONEI - AC = 1.0D0 - L = 1 - DO 20 K=2,15 - SR = ZEROR - SI = ZEROI - DO 10 J=1,K - L = L + 1 - STR = SR*T2R - SI*T2I + C(L) - SI = SR*T2I + SI*T2R - SR = STR - 10 CONTINUE - STR = CRFNR*SRR - CRFNI*SRI - CRFNI = CRFNR*SRI + CRFNI*SRR - CRFNR = STR - CWRKR(K) = CRFNR*SR - CRFNI*SI - CWRKI(K) = CRFNR*SI + CRFNI*SR - AC = AC*RFN - TEST = ABS(CWRKR(K)) + ABS(CWRKI(K)) - IF (AC.LT.TOL .AND. TEST.LT.TOL) GO TO 30 - 20 CONTINUE - K = 15 - 30 CONTINUE - INIT = K - 40 CONTINUE - IF (IKFLG.EQ.2) GO TO 60 -C----------------------------------------------------------------------- -C COMPUTE SUM FOR THE I FUNCTION -C----------------------------------------------------------------------- - SR = ZEROR - SI = ZEROI - DO 50 I=1,INIT - SR = SR + CWRKR(I) - SI = SI + CWRKI(I) - 50 CONTINUE - SUMR = SR - SUMI = SI - PHIR = CWRKR(16)*CON(1) - PHII = CWRKI(16)*CON(1) - RETURN - 60 CONTINUE -C----------------------------------------------------------------------- -C COMPUTE SUM FOR THE K FUNCTION -C----------------------------------------------------------------------- - SR = ZEROR - SI = ZEROI - TR = CONER - DO 70 I=1,INIT - SR = SR + TR*CWRKR(I) - SI = SI + TR*CWRKI(I) - TR = -TR - 70 CONTINUE - SUMR = SR - SUMI = SI - PHIR = CWRKR(16)*CON(2) - PHII = CWRKI(16)*CON(2) - RETURN - END diff --git a/slatec/zunk1.f b/slatec/zunk1.f deleted file mode 100644 index 5824df0..0000000 --- a/slatec/zunk1.f +++ /dev/null @@ -1,437 +0,0 @@ -*DECK ZUNK1 - SUBROUTINE ZUNK1 (ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, - + ALIM) -C***BEGIN PROLOGUE ZUNK1 -C***SUBSIDIARY -C***PURPOSE Subsidiary to ZBESK -C***LIBRARY SLATEC -C***TYPE ALL (CUNK1-A, ZUNK1-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C ZUNK1 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE -C RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE -C UNIFORM ASYMPTOTIC EXPANSION. -C MR INDICATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. -C NZ=-1 MEANS AN OVERFLOW WILL OCCUR -C -C***SEE ALSO ZBESK -C***ROUTINES CALLED D1MACH, ZABS, ZS1S2, ZUCHK, ZUNIK -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE ZUNK1 -C COMPLEX CFN,CK,CONE,CRSC,CS,CSCL,CSGN,CSPN,CSR,CSS,CWRK,CY,CZERO, -C *C1,C2,PHI,PHID,RZ,SUM,SUMD,S1,S2,Y,Z,ZETA1,ZETA1D,ZETA2,ZETA2D,ZR - DOUBLE PRECISION ALIM, ANG, APHI, ASC, ASCLE, BRY, CKI, CKR, - * CONER, CRSC, CSCL, CSGNI, CSPNI, CSPNR, CSR, CSRR, CSSR, - * CWRKI, CWRKR, CYI, CYR, C1I, C1R, C2I, C2M, C2R, ELIM, FMR, FN, - * FNF, FNU, PHIDI, PHIDR, PHII, PHIR, PI, RAST, RAZR, RS1, RZI, - * RZR, SGN, STI, STR, SUMDI, SUMDR, SUMI, SUMR, S1I, S1R, S2I, - * S2R, TOL, YI, YR, ZEROI, ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, - * ZET1DI, ZET1DR, ZET2DI, ZET2DR, ZI, ZR, ZRI, ZRR, D1MACH, ZABS - INTEGER I, IB, IFLAG, IFN, IL, INIT, INU, IUF, K, KDFLG, KFLAG, - * KK, KODE, MR, N, NW, NZ, INITD, IC, IPARD, J, M - DIMENSION BRY(3), INIT(2), YR(N), YI(N), SUMR(2), SUMI(2), - * ZETA1R(2), ZETA1I(2), ZETA2R(2), ZETA2I(2), CYR(2), CYI(2), - * CWRKR(16,3), CWRKI(16,3), CSSR(3), CSRR(3), PHIR(2), PHII(2) - EXTERNAL ZABS - DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 / - DATA PI / 3.14159265358979324D0 / -C***FIRST EXECUTABLE STATEMENT ZUNK1 - KDFLG = 1 - NZ = 0 -C----------------------------------------------------------------------- -C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN -C THE UNDERFLOW LIMIT -C----------------------------------------------------------------------- - CSCL = 1.0D0/TOL - CRSC = TOL - CSSR(1) = CSCL - CSSR(2) = CONER - CSSR(3) = CRSC - CSRR(1) = CRSC - CSRR(2) = CONER - CSRR(3) = CSCL - BRY(1) = 1.0D+3*D1MACH(1)/TOL - BRY(2) = 1.0D0/BRY(1) - BRY(3) = D1MACH(2) - ZRR = ZR - ZRI = ZI - IF (ZR.GE.0.0D0) GO TO 10 - ZRR = -ZR - ZRI = -ZI - 10 CONTINUE - J = 2 - DO 70 I=1,N -C----------------------------------------------------------------------- -C J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J -C----------------------------------------------------------------------- - J = 3 - J - FN = FNU + (I-1) - INIT(J) = 0 - CALL ZUNIK(ZRR, ZRI, FN, 2, 0, TOL, INIT(J), PHIR(J), PHII(J), - * ZETA1R(J), ZETA1I(J), ZETA2R(J), ZETA2I(J), SUMR(J), SUMI(J), - * CWRKR(1,J), CWRKI(1,J)) - IF (KODE.EQ.1) GO TO 20 - STR = ZRR + ZETA2R(J) - STI = ZRI + ZETA2I(J) - RAST = FN/ZABS(STR,STI) - STR = STR*RAST*RAST - STI = -STI*RAST*RAST - S1R = ZETA1R(J) - STR - S1I = ZETA1I(J) - STI - GO TO 30 - 20 CONTINUE - S1R = ZETA1R(J) - ZETA2R(J) - S1I = ZETA1I(J) - ZETA2I(J) - 30 CONTINUE - RS1 = S1R -C----------------------------------------------------------------------- -C TEST FOR UNDERFLOW AND OVERFLOW -C----------------------------------------------------------------------- - IF (ABS(RS1).GT.ELIM) GO TO 60 - IF (KDFLG.EQ.1) KFLAG = 2 - IF (ABS(RS1).LT.ALIM) GO TO 40 -C----------------------------------------------------------------------- -C REFINE TEST AND SCALE -C----------------------------------------------------------------------- - APHI = ZABS(PHIR(J),PHII(J)) - RS1 = RS1 + LOG(APHI) - IF (ABS(RS1).GT.ELIM) GO TO 60 - IF (KDFLG.EQ.1) KFLAG = 1 - IF (RS1.LT.0.0D0) GO TO 40 - IF (KDFLG.EQ.1) KFLAG = 3 - 40 CONTINUE -C----------------------------------------------------------------------- -C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR -C EXPONENT EXTREMES -C----------------------------------------------------------------------- - S2R = PHIR(J)*SUMR(J) - PHII(J)*SUMI(J) - S2I = PHIR(J)*SUMI(J) + PHII(J)*SUMR(J) - STR = EXP(S1R)*CSSR(KFLAG) - S1R = STR*COS(S1I) - S1I = STR*SIN(S1I) - STR = S2R*S1R - S2I*S1I - S2I = S1R*S2I + S2R*S1I - S2R = STR - IF (KFLAG.NE.1) GO TO 50 - CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) - IF (NW.NE.0) GO TO 60 - 50 CONTINUE - CYR(KDFLG) = S2R - CYI(KDFLG) = S2I - YR(I) = S2R*CSRR(KFLAG) - YI(I) = S2I*CSRR(KFLAG) - IF (KDFLG.EQ.2) GO TO 75 - KDFLG = 2 - GO TO 70 - 60 CONTINUE - IF (RS1.GT.0.0D0) GO TO 300 -C----------------------------------------------------------------------- -C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW -C----------------------------------------------------------------------- - IF (ZR.LT.0.0D0) GO TO 300 - KDFLG = 1 - YR(I)=ZEROR - YI(I)=ZEROI - NZ=NZ+1 - IF (I.EQ.1) GO TO 70 - IF ((YR(I-1).EQ.ZEROR).AND.(YI(I-1).EQ.ZEROI)) GO TO 70 - YR(I-1)=ZEROR - YI(I-1)=ZEROI - NZ=NZ+1 - 70 CONTINUE - I = N - 75 CONTINUE - RAZR = 1.0D0/ZABS(ZRR,ZRI) - STR = ZRR*RAZR - STI = -ZRI*RAZR - RZR = (STR+STR)*RAZR - RZI = (STI+STI)*RAZR - CKR = FN*RZR - CKI = FN*RZI - IB = I + 1 - IF (N.LT.IB) GO TO 160 -C----------------------------------------------------------------------- -C TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW. SET SEQUENCE TO ZERO -C ON UNDERFLOW. -C----------------------------------------------------------------------- - FN = FNU + (N-1) - IPARD = 1 - IF (MR.NE.0) IPARD = 0 - INITD = 0 - CALL ZUNIK(ZRR, ZRI, FN, 2, IPARD, TOL, INITD, PHIDR, PHIDI, - * ZET1DR, ZET1DI, ZET2DR, ZET2DI, SUMDR, SUMDI, CWRKR(1,3), - * CWRKI(1,3)) - IF (KODE.EQ.1) GO TO 80 - STR = ZRR + ZET2DR - STI = ZRI + ZET2DI - RAST = FN/ZABS(STR,STI) - STR = STR*RAST*RAST - STI = -STI*RAST*RAST - S1R = ZET1DR - STR - S1I = ZET1DI - STI - GO TO 90 - 80 CONTINUE - S1R = ZET1DR - ZET2DR - S1I = ZET1DI - ZET2DI - 90 CONTINUE - RS1 = S1R - IF (ABS(RS1).GT.ELIM) GO TO 95 - IF (ABS(RS1).LT.ALIM) GO TO 100 -C----------------------------------------------------------------------- -C REFINE ESTIMATE AND TEST -C----------------------------------------------------------------------- - APHI = ZABS(PHIDR,PHIDI) - RS1 = RS1+LOG(APHI) - IF (ABS(RS1).LT.ELIM) GO TO 100 - 95 CONTINUE - IF (ABS(RS1).GT.0.0D0) GO TO 300 -C----------------------------------------------------------------------- -C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW -C----------------------------------------------------------------------- - IF (ZR.LT.0.0D0) GO TO 300 - NZ = N - DO 96 I=1,N - YR(I) = ZEROR - YI(I) = ZEROI - 96 CONTINUE - RETURN -C----------------------------------------------------------------------- -C FORWARD RECUR FOR REMAINDER OF THE SEQUENCE -C----------------------------------------------------------------------- - 100 CONTINUE - S1R = CYR(1) - S1I = CYI(1) - S2R = CYR(2) - S2I = CYI(2) - C1R = CSRR(KFLAG) - ASCLE = BRY(KFLAG) - DO 120 I=IB,N - C2R = S2R - C2I = S2I - S2R = CKR*C2R - CKI*C2I + S1R - S2I = CKR*C2I + CKI*C2R + S1I - S1R = C2R - S1I = C2I - CKR = CKR + RZR - CKI = CKI + RZI - C2R = S2R*C1R - C2I = S2I*C1R - YR(I) = C2R - YI(I) = C2I - IF (KFLAG.GE.3) GO TO 120 - STR = ABS(C2R) - STI = ABS(C2I) - C2M = MAX(STR,STI) - IF (C2M.LE.ASCLE) GO TO 120 - KFLAG = KFLAG + 1 - ASCLE = BRY(KFLAG) - S1R = S1R*C1R - S1I = S1I*C1R - S2R = C2R - S2I = C2I - S1R = S1R*CSSR(KFLAG) - S1I = S1I*CSSR(KFLAG) - S2R = S2R*CSSR(KFLAG) - S2I = S2I*CSSR(KFLAG) - C1R = CSRR(KFLAG) - 120 CONTINUE - 160 CONTINUE - IF (MR.EQ.0) RETURN -C----------------------------------------------------------------------- -C ANALYTIC CONTINUATION FOR RE(Z).LT.0.0D0 -C----------------------------------------------------------------------- - NZ = 0 - FMR = MR - SGN = -DSIGN(PI,FMR) -C----------------------------------------------------------------------- -C CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP. -C----------------------------------------------------------------------- - CSGNI = SGN - INU = FNU - FNF = FNU - INU - IFN = INU + N - 1 - ANG = FNF*SGN - CSPNR = COS(ANG) - CSPNI = SIN(ANG) - IF (MOD(IFN,2).EQ.0) GO TO 170 - CSPNR = -CSPNR - CSPNI = -CSPNI - 170 CONTINUE - ASC = BRY(1) - IUF = 0 - KK = N - KDFLG = 1 - IB = IB - 1 - IC = IB - 1 - DO 270 K=1,N - FN = FNU + (KK-1) -C----------------------------------------------------------------------- -C LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K -C FUNCTION ABOVE -C----------------------------------------------------------------------- - M=3 - IF (N.GT.2) GO TO 175 - 172 CONTINUE - INITD = INIT(J) - PHIDR = PHIR(J) - PHIDI = PHII(J) - ZET1DR = ZETA1R(J) - ZET1DI = ZETA1I(J) - ZET2DR = ZETA2R(J) - ZET2DI = ZETA2I(J) - SUMDR = SUMR(J) - SUMDI = SUMI(J) - M = J - J = 3 - J - GO TO 180 - 175 CONTINUE - IF ((KK.EQ.N).AND.(IB.LT.N)) GO TO 180 - IF ((KK.EQ.IB).OR.(KK.EQ.IC)) GO TO 172 - INITD = 0 - 180 CONTINUE - CALL ZUNIK(ZRR, ZRI, FN, 1, 0, TOL, INITD, PHIDR, PHIDI, - * ZET1DR, ZET1DI, ZET2DR, ZET2DI, SUMDR, SUMDI, - * CWRKR(1,M), CWRKI(1,M)) - IF (KODE.EQ.1) GO TO 200 - STR = ZRR + ZET2DR - STI = ZRI + ZET2DI - RAST = FN/ZABS(STR,STI) - STR = STR*RAST*RAST - STI = -STI*RAST*RAST - S1R = -ZET1DR + STR - S1I = -ZET1DI + STI - GO TO 210 - 200 CONTINUE - S1R = -ZET1DR + ZET2DR - S1I = -ZET1DI + ZET2DI - 210 CONTINUE -C----------------------------------------------------------------------- -C TEST FOR UNDERFLOW AND OVERFLOW -C----------------------------------------------------------------------- - RS1 = S1R - IF (ABS(RS1).GT.ELIM) GO TO 260 - IF (KDFLG.EQ.1) IFLAG = 2 - IF (ABS(RS1).LT.ALIM) GO TO 220 -C----------------------------------------------------------------------- -C REFINE TEST AND SCALE -C----------------------------------------------------------------------- - APHI = ZABS(PHIDR,PHIDI) - RS1 = RS1 + LOG(APHI) - IF (ABS(RS1).GT.ELIM) GO TO 260 - IF (KDFLG.EQ.1) IFLAG = 1 - IF (RS1.LT.0.0D0) GO TO 220 - IF (KDFLG.EQ.1) IFLAG = 3 - 220 CONTINUE - STR = PHIDR*SUMDR - PHIDI*SUMDI - STI = PHIDR*SUMDI + PHIDI*SUMDR - S2R = -CSGNI*STI - S2I = CSGNI*STR - STR = EXP(S1R)*CSSR(IFLAG) - S1R = STR*COS(S1I) - S1I = STR*SIN(S1I) - STR = S2R*S1R - S2I*S1I - S2I = S2R*S1I + S2I*S1R - S2R = STR - IF (IFLAG.NE.1) GO TO 230 - CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) - IF (NW.EQ.0) GO TO 230 - S2R = ZEROR - S2I = ZEROI - 230 CONTINUE - CYR(KDFLG) = S2R - CYI(KDFLG) = S2I - C2R = S2R - C2I = S2I - S2R = S2R*CSRR(IFLAG) - S2I = S2I*CSRR(IFLAG) -C----------------------------------------------------------------------- -C ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N -C----------------------------------------------------------------------- - S1R = YR(KK) - S1I = YI(KK) - IF (KODE.EQ.1) GO TO 250 - CALL ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NW, ASC, ALIM, IUF) - NZ = NZ + NW - 250 CONTINUE - YR(KK) = S1R*CSPNR - S1I*CSPNI + S2R - YI(KK) = CSPNR*S1I + CSPNI*S1R + S2I - KK = KK - 1 - CSPNR = -CSPNR - CSPNI = -CSPNI - IF (C2R.NE.0.0D0 .OR. C2I.NE.0.0D0) GO TO 255 - KDFLG = 1 - GO TO 270 - 255 CONTINUE - IF (KDFLG.EQ.2) GO TO 275 - KDFLG = 2 - GO TO 270 - 260 CONTINUE - IF (RS1.GT.0.0D0) GO TO 300 - S2R = ZEROR - S2I = ZEROI - GO TO 230 - 270 CONTINUE - K = N - 275 CONTINUE - IL = N - K - IF (IL.EQ.0) RETURN -C----------------------------------------------------------------------- -C RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE -C K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP -C INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES. -C----------------------------------------------------------------------- - S1R = CYR(1) - S1I = CYI(1) - S2R = CYR(2) - S2I = CYI(2) - CSR = CSRR(IFLAG) - ASCLE = BRY(IFLAG) - FN = INU+IL - DO 290 I=1,IL - C2R = S2R - C2I = S2I - S2R = S1R + (FN+FNF)*(RZR*C2R-RZI*C2I) - S2I = S1I + (FN+FNF)*(RZR*C2I+RZI*C2R) - S1R = C2R - S1I = C2I - FN = FN - 1.0D0 - C2R = S2R*CSR - C2I = S2I*CSR - CKR = C2R - CKI = C2I - C1R = YR(KK) - C1I = YI(KK) - IF (KODE.EQ.1) GO TO 280 - CALL ZS1S2(ZRR, ZRI, C1R, C1I, C2R, C2I, NW, ASC, ALIM, IUF) - NZ = NZ + NW - 280 CONTINUE - YR(KK) = C1R*CSPNR - C1I*CSPNI + C2R - YI(KK) = C1R*CSPNI + C1I*CSPNR + C2I - KK = KK - 1 - CSPNR = -CSPNR - CSPNI = -CSPNI - IF (IFLAG.GE.3) GO TO 290 - C2R = ABS(CKR) - C2I = ABS(CKI) - C2M = MAX(C2R,C2I) - IF (C2M.LE.ASCLE) GO TO 290 - IFLAG = IFLAG + 1 - ASCLE = BRY(IFLAG) - S1R = S1R*CSR - S1I = S1I*CSR - S2R = CKR - S2I = CKI - S1R = S1R*CSSR(IFLAG) - S1I = S1I*CSSR(IFLAG) - S2R = S2R*CSSR(IFLAG) - S2I = S2I*CSSR(IFLAG) - CSR = CSRR(IFLAG) - 290 CONTINUE - RETURN - 300 CONTINUE - NZ = -1 - RETURN - END diff --git a/slatec/zunk2.f b/slatec/zunk2.f deleted file mode 100644 index a69492f..0000000 --- a/slatec/zunk2.f +++ /dev/null @@ -1,516 +0,0 @@ -*DECK ZUNK2 - SUBROUTINE ZUNK2 (ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, - + ALIM) -C***BEGIN PROLOGUE ZUNK2 -C***SUBSIDIARY -C***PURPOSE Subsidiary to ZBESK -C***LIBRARY SLATEC -C***TYPE ALL (CUNK2-A, ZUNK2-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C ZUNK2 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE -C RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE -C UNIFORM ASYMPTOTIC EXPANSIONS FOR H(KIND,FNU,ZN) AND J(FNU,ZN) -C WHERE ZN IS IN THE RIGHT HALF PLANE, KIND=(3-MR)/2, MR=+1 OR -C -1. HERE ZN=ZR*I OR -ZR*I WHERE ZR=Z IF Z IS IN THE RIGHT -C HALF PLANE OR ZR=-Z IF Z IS IN THE LEFT HALF PLANE. MR INDIC- -C ATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. -C NZ=-1 MEANS AN OVERFLOW WILL OCCUR -C -C***SEE ALSO ZBESK -C***ROUTINES CALLED D1MACH, ZABS, ZAIRY, ZS1S2, ZUCHK, ZUNHJ -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE ZUNK2 -C COMPLEX AI,ARG,ARGD,ASUM,ASUMD,BSUM,BSUMD,CFN,CI,CIP,CK,CONE,CRSC, -C *CR1,CR2,CS,CSCL,CSGN,CSPN,CSR,CSS,CY,CZERO,C1,C2,DAI,PHI,PHID,RZ, -C *S1,S2,Y,Z,ZB,ZETA1,ZETA1D,ZETA2,ZETA2D,ZN,ZR - DOUBLE PRECISION AARG, AIC, AII, AIR, ALIM, ANG, APHI, ARGDI, - * ARGDR, ARGI, ARGR, ASC, ASCLE, ASUMDI, ASUMDR, ASUMI, ASUMR, - * BRY, BSUMDI, BSUMDR, BSUMI, BSUMR, CAR, CIPI, CIPR, CKI, CKR, - * CONER, CRSC, CR1I, CR1R, CR2I, CR2R, CSCL, CSGNI, CSI, - * CSPNI, CSPNR, CSR, CSRR, CSSR, CYI, CYR, C1I, C1R, C2I, C2M, - * C2R, DAII, DAIR, ELIM, FMR, FN, FNF, FNU, HPI, PHIDI, PHIDR, - * PHII, PHIR, PI, PTI, PTR, RAST, RAZR, RS1, RZI, RZR, SAR, SGN, - * STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, YY, ZBI, ZBR, ZEROI, - * ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZET1DI, ZET1DR, ZET2DI, - * ZET2DR, ZI, ZNI, ZNR, ZR, ZRI, ZRR, D1MACH, ZABS - INTEGER I, IB, IFLAG, IFN, IL, IN, INU, IUF, K, KDFLG, KFLAG, KK, - * KODE, MR, N, NAI, NDAI, NW, NZ, IDUM, J, IPARD, IC - DIMENSION BRY(3), YR(N), YI(N), ASUMR(2), ASUMI(2), BSUMR(2), - * BSUMI(2), PHIR(2), PHII(2), ARGR(2), ARGI(2), ZETA1R(2), - * ZETA1I(2), ZETA2R(2), ZETA2I(2), CYR(2), CYI(2), CIPR(4), - * CIPI(4), CSSR(3), CSRR(3) - EXTERNAL ZABS - DATA ZEROR,ZEROI,CONER,CR1R,CR1I,CR2R,CR2I / - 1 0.0D0, 0.0D0, 1.0D0, - 1 1.0D0,1.73205080756887729D0 , -0.5D0,-8.66025403784438647D-01 / - DATA HPI, PI, AIC / - 1 1.57079632679489662D+00, 3.14159265358979324D+00, - 1 1.26551212348464539D+00/ - DATA CIPR(1),CIPI(1),CIPR(2),CIPI(2),CIPR(3),CIPI(3),CIPR(4), - * CIPI(4) / - 1 1.0D0,0.0D0 , 0.0D0,-1.0D0 , -1.0D0,0.0D0 , 0.0D0,1.0D0 / -C***FIRST EXECUTABLE STATEMENT ZUNK2 - KDFLG = 1 - NZ = 0 -C----------------------------------------------------------------------- -C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN -C THE UNDERFLOW LIMIT -C----------------------------------------------------------------------- - CSCL = 1.0D0/TOL - CRSC = TOL - CSSR(1) = CSCL - CSSR(2) = CONER - CSSR(3) = CRSC - CSRR(1) = CRSC - CSRR(2) = CONER - CSRR(3) = CSCL - BRY(1) = 1.0D+3*D1MACH(1)/TOL - BRY(2) = 1.0D0/BRY(1) - BRY(3) = D1MACH(2) - ZRR = ZR - ZRI = ZI - IF (ZR.GE.0.0D0) GO TO 10 - ZRR = -ZR - ZRI = -ZI - 10 CONTINUE - YY = ZRI - ZNR = ZRI - ZNI = -ZRR - ZBR = ZRR - ZBI = ZRI - INU = FNU - FNF = FNU - INU - ANG = -HPI*FNF - CAR = COS(ANG) - SAR = SIN(ANG) - C2R = HPI*SAR - C2I = -HPI*CAR - KK = MOD(INU,4) + 1 - STR = C2R*CIPR(KK) - C2I*CIPI(KK) - STI = C2R*CIPI(KK) + C2I*CIPR(KK) - CSR = CR1R*STR - CR1I*STI - CSI = CR1R*STI + CR1I*STR - IF (YY.GT.0.0D0) GO TO 20 - ZNR = -ZNR - ZBI = -ZBI - 20 CONTINUE -C----------------------------------------------------------------------- -C K(FNU,Z) IS COMPUTED FROM H(2,FNU,-I*Z) WHERE Z IS IN THE FIRST -C QUADRANT. FOURTH QUADRANT VALUES (YY.LE.0.0E0) ARE COMPUTED BY -C CONJUGATION SINCE THE K FUNCTION IS REAL ON THE POSITIVE REAL AXIS -C----------------------------------------------------------------------- - J = 2 - DO 80 I=1,N -C----------------------------------------------------------------------- -C J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J -C----------------------------------------------------------------------- - J = 3 - J - FN = FNU + (I-1) - CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIR(J), PHII(J), ARGR(J), - * ARGI(J), ZETA1R(J), ZETA1I(J), ZETA2R(J), ZETA2I(J), ASUMR(J), - * ASUMI(J), BSUMR(J), BSUMI(J)) - IF (KODE.EQ.1) GO TO 30 - STR = ZBR + ZETA2R(J) - STI = ZBI + ZETA2I(J) - RAST = FN/ZABS(STR,STI) - STR = STR*RAST*RAST - STI = -STI*RAST*RAST - S1R = ZETA1R(J) - STR - S1I = ZETA1I(J) - STI - GO TO 40 - 30 CONTINUE - S1R = ZETA1R(J) - ZETA2R(J) - S1I = ZETA1I(J) - ZETA2I(J) - 40 CONTINUE -C----------------------------------------------------------------------- -C TEST FOR UNDERFLOW AND OVERFLOW -C----------------------------------------------------------------------- - RS1 = S1R - IF (ABS(RS1).GT.ELIM) GO TO 70 - IF (KDFLG.EQ.1) KFLAG = 2 - IF (ABS(RS1).LT.ALIM) GO TO 50 -C----------------------------------------------------------------------- -C REFINE TEST AND SCALE -C----------------------------------------------------------------------- - APHI = ZABS(PHIR(J),PHII(J)) - AARG = ZABS(ARGR(J),ARGI(J)) - RS1 = RS1 + LOG(APHI) - 0.25D0*LOG(AARG) - AIC - IF (ABS(RS1).GT.ELIM) GO TO 70 - IF (KDFLG.EQ.1) KFLAG = 1 - IF (RS1.LT.0.0D0) GO TO 50 - IF (KDFLG.EQ.1) KFLAG = 3 - 50 CONTINUE -C----------------------------------------------------------------------- -C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR -C EXPONENT EXTREMES -C----------------------------------------------------------------------- - C2R = ARGR(J)*CR2R - ARGI(J)*CR2I - C2I = ARGR(J)*CR2I + ARGI(J)*CR2R - CALL ZAIRY(C2R, C2I, 0, 2, AIR, AII, NAI, IDUM) - CALL ZAIRY(C2R, C2I, 1, 2, DAIR, DAII, NDAI, IDUM) - STR = DAIR*BSUMR(J) - DAII*BSUMI(J) - STI = DAIR*BSUMI(J) + DAII*BSUMR(J) - PTR = STR*CR2R - STI*CR2I - PTI = STR*CR2I + STI*CR2R - STR = PTR + (AIR*ASUMR(J)-AII*ASUMI(J)) - STI = PTI + (AIR*ASUMI(J)+AII*ASUMR(J)) - PTR = STR*PHIR(J) - STI*PHII(J) - PTI = STR*PHII(J) + STI*PHIR(J) - S2R = PTR*CSR - PTI*CSI - S2I = PTR*CSI + PTI*CSR - STR = EXP(S1R)*CSSR(KFLAG) - S1R = STR*COS(S1I) - S1I = STR*SIN(S1I) - STR = S2R*S1R - S2I*S1I - S2I = S1R*S2I + S2R*S1I - S2R = STR - IF (KFLAG.NE.1) GO TO 60 - CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) - IF (NW.NE.0) GO TO 70 - 60 CONTINUE - IF (YY.LE.0.0D0) S2I = -S2I - CYR(KDFLG) = S2R - CYI(KDFLG) = S2I - YR(I) = S2R*CSRR(KFLAG) - YI(I) = S2I*CSRR(KFLAG) - STR = CSI - CSI = -CSR - CSR = STR - IF (KDFLG.EQ.2) GO TO 85 - KDFLG = 2 - GO TO 80 - 70 CONTINUE - IF (RS1.GT.0.0D0) GO TO 320 -C----------------------------------------------------------------------- -C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW -C----------------------------------------------------------------------- - IF (ZR.LT.0.0D0) GO TO 320 - KDFLG = 1 - YR(I)=ZEROR - YI(I)=ZEROI - NZ=NZ+1 - STR = CSI - CSI =-CSR - CSR = STR - IF (I.EQ.1) GO TO 80 - IF ((YR(I-1).EQ.ZEROR).AND.(YI(I-1).EQ.ZEROI)) GO TO 80 - YR(I-1)=ZEROR - YI(I-1)=ZEROI - NZ=NZ+1 - 80 CONTINUE - I = N - 85 CONTINUE - RAZR = 1.0D0/ZABS(ZRR,ZRI) - STR = ZRR*RAZR - STI = -ZRI*RAZR - RZR = (STR+STR)*RAZR - RZI = (STI+STI)*RAZR - CKR = FN*RZR - CKI = FN*RZI - IB = I + 1 - IF (N.LT.IB) GO TO 180 -C----------------------------------------------------------------------- -C TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW. SET SEQUENCE TO ZERO -C ON UNDERFLOW. -C----------------------------------------------------------------------- - FN = FNU + (N-1) - IPARD = 1 - IF (MR.NE.0) IPARD = 0 - CALL ZUNHJ(ZNR, ZNI, FN, IPARD, TOL, PHIDR, PHIDI, ARGDR, ARGDI, - * ZET1DR, ZET1DI, ZET2DR, ZET2DI, ASUMDR, ASUMDI, BSUMDR, BSUMDI) - IF (KODE.EQ.1) GO TO 90 - STR = ZBR + ZET2DR - STI = ZBI + ZET2DI - RAST = FN/ZABS(STR,STI) - STR = STR*RAST*RAST - STI = -STI*RAST*RAST - S1R = ZET1DR - STR - S1I = ZET1DI - STI - GO TO 100 - 90 CONTINUE - S1R = ZET1DR - ZET2DR - S1I = ZET1DI - ZET2DI - 100 CONTINUE - RS1 = S1R - IF (ABS(RS1).GT.ELIM) GO TO 105 - IF (ABS(RS1).LT.ALIM) GO TO 120 -C----------------------------------------------------------------------- -C REFINE ESTIMATE AND TEST -C----------------------------------------------------------------------- - APHI = ZABS(PHIDR,PHIDI) - RS1 = RS1+LOG(APHI) - IF (ABS(RS1).LT.ELIM) GO TO 120 - 105 CONTINUE - IF (RS1.GT.0.0D0) GO TO 320 -C----------------------------------------------------------------------- -C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW -C----------------------------------------------------------------------- - IF (ZR.LT.0.0D0) GO TO 320 - NZ = N - DO 106 I=1,N - YR(I) = ZEROR - YI(I) = ZEROI - 106 CONTINUE - RETURN - 120 CONTINUE - S1R = CYR(1) - S1I = CYI(1) - S2R = CYR(2) - S2I = CYI(2) - C1R = CSRR(KFLAG) - ASCLE = BRY(KFLAG) - DO 130 I=IB,N - C2R = S2R - C2I = S2I - S2R = CKR*C2R - CKI*C2I + S1R - S2I = CKR*C2I + CKI*C2R + S1I - S1R = C2R - S1I = C2I - CKR = CKR + RZR - CKI = CKI + RZI - C2R = S2R*C1R - C2I = S2I*C1R - YR(I) = C2R - YI(I) = C2I - IF (KFLAG.GE.3) GO TO 130 - STR = ABS(C2R) - STI = ABS(C2I) - C2M = MAX(STR,STI) - IF (C2M.LE.ASCLE) GO TO 130 - KFLAG = KFLAG + 1 - ASCLE = BRY(KFLAG) - S1R = S1R*C1R - S1I = S1I*C1R - S2R = C2R - S2I = C2I - S1R = S1R*CSSR(KFLAG) - S1I = S1I*CSSR(KFLAG) - S2R = S2R*CSSR(KFLAG) - S2I = S2I*CSSR(KFLAG) - C1R = CSRR(KFLAG) - 130 CONTINUE - 180 CONTINUE - IF (MR.EQ.0) RETURN -C----------------------------------------------------------------------- -C ANALYTIC CONTINUATION FOR RE(Z).LT.0.0D0 -C----------------------------------------------------------------------- - NZ = 0 - FMR = MR - SGN = -DSIGN(PI,FMR) -C----------------------------------------------------------------------- -C CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP. -C----------------------------------------------------------------------- - CSGNI = SGN - IF (YY.LE.0.0D0) CSGNI = -CSGNI - IFN = INU + N - 1 - ANG = FNF*SGN - CSPNR = COS(ANG) - CSPNI = SIN(ANG) - IF (MOD(IFN,2).EQ.0) GO TO 190 - CSPNR = -CSPNR - CSPNI = -CSPNI - 190 CONTINUE -C----------------------------------------------------------------------- -C CS=COEFF OF THE J FUNCTION TO GET THE I FUNCTION. I(FNU,Z) IS -C COMPUTED FROM EXP(I*FNU*HPI)*J(FNU,-I*Z) WHERE Z IS IN THE FIRST -C QUADRANT. FOURTH QUADRANT VALUES (YY.LE.0.0E0) ARE COMPUTED BY -C CONJUGATION SINCE THE I FUNCTION IS REAL ON THE POSITIVE REAL AXIS -C----------------------------------------------------------------------- - CSR = SAR*CSGNI - CSI = CAR*CSGNI - IN = MOD(IFN,4) + 1 - C2R = CIPR(IN) - C2I = CIPI(IN) - STR = CSR*C2R + CSI*C2I - CSI = -CSR*C2I + CSI*C2R - CSR = STR - ASC = BRY(1) - IUF = 0 - KK = N - KDFLG = 1 - IB = IB - 1 - IC = IB - 1 - DO 290 K=1,N - FN = FNU + (KK-1) -C----------------------------------------------------------------------- -C LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K -C FUNCTION ABOVE -C----------------------------------------------------------------------- - IF (N.GT.2) GO TO 175 - 172 CONTINUE - PHIDR = PHIR(J) - PHIDI = PHII(J) - ARGDR = ARGR(J) - ARGDI = ARGI(J) - ZET1DR = ZETA1R(J) - ZET1DI = ZETA1I(J) - ZET2DR = ZETA2R(J) - ZET2DI = ZETA2I(J) - ASUMDR = ASUMR(J) - ASUMDI = ASUMI(J) - BSUMDR = BSUMR(J) - BSUMDI = BSUMI(J) - J = 3 - J - GO TO 210 - 175 CONTINUE - IF ((KK.EQ.N).AND.(IB.LT.N)) GO TO 210 - IF ((KK.EQ.IB).OR.(KK.EQ.IC)) GO TO 172 - CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIDR, PHIDI, ARGDR, - * ARGDI, ZET1DR, ZET1DI, ZET2DR, ZET2DI, ASUMDR, - * ASUMDI, BSUMDR, BSUMDI) - 210 CONTINUE - IF (KODE.EQ.1) GO TO 220 - STR = ZBR + ZET2DR - STI = ZBI + ZET2DI - RAST = FN/ZABS(STR,STI) - STR = STR*RAST*RAST - STI = -STI*RAST*RAST - S1R = -ZET1DR + STR - S1I = -ZET1DI + STI - GO TO 230 - 220 CONTINUE - S1R = -ZET1DR + ZET2DR - S1I = -ZET1DI + ZET2DI - 230 CONTINUE -C----------------------------------------------------------------------- -C TEST FOR UNDERFLOW AND OVERFLOW -C----------------------------------------------------------------------- - RS1 = S1R - IF (ABS(RS1).GT.ELIM) GO TO 280 - IF (KDFLG.EQ.1) IFLAG = 2 - IF (ABS(RS1).LT.ALIM) GO TO 240 -C----------------------------------------------------------------------- -C REFINE TEST AND SCALE -C----------------------------------------------------------------------- - APHI = ZABS(PHIDR,PHIDI) - AARG = ZABS(ARGDR,ARGDI) - RS1 = RS1 + LOG(APHI) - 0.25D0*LOG(AARG) - AIC - IF (ABS(RS1).GT.ELIM) GO TO 280 - IF (KDFLG.EQ.1) IFLAG = 1 - IF (RS1.LT.0.0D0) GO TO 240 - IF (KDFLG.EQ.1) IFLAG = 3 - 240 CONTINUE - CALL ZAIRY(ARGDR, ARGDI, 0, 2, AIR, AII, NAI, IDUM) - CALL ZAIRY(ARGDR, ARGDI, 1, 2, DAIR, DAII, NDAI, IDUM) - STR = DAIR*BSUMDR - DAII*BSUMDI - STI = DAIR*BSUMDI + DAII*BSUMDR - STR = STR + (AIR*ASUMDR-AII*ASUMDI) - STI = STI + (AIR*ASUMDI+AII*ASUMDR) - PTR = STR*PHIDR - STI*PHIDI - PTI = STR*PHIDI + STI*PHIDR - S2R = PTR*CSR - PTI*CSI - S2I = PTR*CSI + PTI*CSR - STR = EXP(S1R)*CSSR(IFLAG) - S1R = STR*COS(S1I) - S1I = STR*SIN(S1I) - STR = S2R*S1R - S2I*S1I - S2I = S2R*S1I + S2I*S1R - S2R = STR - IF (IFLAG.NE.1) GO TO 250 - CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) - IF (NW.EQ.0) GO TO 250 - S2R = ZEROR - S2I = ZEROI - 250 CONTINUE - IF (YY.LE.0.0D0) S2I = -S2I - CYR(KDFLG) = S2R - CYI(KDFLG) = S2I - C2R = S2R - C2I = S2I - S2R = S2R*CSRR(IFLAG) - S2I = S2I*CSRR(IFLAG) -C----------------------------------------------------------------------- -C ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N -C----------------------------------------------------------------------- - S1R = YR(KK) - S1I = YI(KK) - IF (KODE.EQ.1) GO TO 270 - CALL ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NW, ASC, ALIM, IUF) - NZ = NZ + NW - 270 CONTINUE - YR(KK) = S1R*CSPNR - S1I*CSPNI + S2R - YI(KK) = S1R*CSPNI + S1I*CSPNR + S2I - KK = KK - 1 - CSPNR = -CSPNR - CSPNI = -CSPNI - STR = CSI - CSI = -CSR - CSR = STR - IF (C2R.NE.0.0D0 .OR. C2I.NE.0.0D0) GO TO 255 - KDFLG = 1 - GO TO 290 - 255 CONTINUE - IF (KDFLG.EQ.2) GO TO 295 - KDFLG = 2 - GO TO 290 - 280 CONTINUE - IF (RS1.GT.0.0D0) GO TO 320 - S2R = ZEROR - S2I = ZEROI - GO TO 250 - 290 CONTINUE - K = N - 295 CONTINUE - IL = N - K - IF (IL.EQ.0) RETURN -C----------------------------------------------------------------------- -C RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE -C K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP -C INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES. -C----------------------------------------------------------------------- - S1R = CYR(1) - S1I = CYI(1) - S2R = CYR(2) - S2I = CYI(2) - CSR = CSRR(IFLAG) - ASCLE = BRY(IFLAG) - FN = INU+IL - DO 310 I=1,IL - C2R = S2R - C2I = S2I - S2R = S1R + (FN+FNF)*(RZR*C2R-RZI*C2I) - S2I = S1I + (FN+FNF)*(RZR*C2I+RZI*C2R) - S1R = C2R - S1I = C2I - FN = FN - 1.0D0 - C2R = S2R*CSR - C2I = S2I*CSR - CKR = C2R - CKI = C2I - C1R = YR(KK) - C1I = YI(KK) - IF (KODE.EQ.1) GO TO 300 - CALL ZS1S2(ZRR, ZRI, C1R, C1I, C2R, C2I, NW, ASC, ALIM, IUF) - NZ = NZ + NW - 300 CONTINUE - YR(KK) = C1R*CSPNR - C1I*CSPNI + C2R - YI(KK) = C1R*CSPNI + C1I*CSPNR + C2I - KK = KK - 1 - CSPNR = -CSPNR - CSPNI = -CSPNI - IF (IFLAG.GE.3) GO TO 310 - C2R = ABS(CKR) - C2I = ABS(CKI) - C2M = MAX(C2R,C2I) - IF (C2M.LE.ASCLE) GO TO 310 - IFLAG = IFLAG + 1 - ASCLE = BRY(IFLAG) - S1R = S1R*CSR - S1I = S1I*CSR - S2R = CKR - S2I = CKI - S1R = S1R*CSSR(IFLAG) - S1I = S1I*CSSR(IFLAG) - S2R = S2R*CSSR(IFLAG) - S2I = S2I*CSSR(IFLAG) - CSR = CSRR(IFLAG) - 310 CONTINUE - RETURN - 320 CONTINUE - NZ = -1 - RETURN - END diff --git a/slatec/zuoik.f b/slatec/zuoik.f deleted file mode 100644 index 2f1201f..0000000 --- a/slatec/zuoik.f +++ /dev/null @@ -1,207 +0,0 @@ -*DECK ZUOIK - SUBROUTINE ZUOIK (ZR, ZI, FNU, KODE, IKFLG, N, YR, YI, NUF, TOL, - + ELIM, ALIM) -C***BEGIN PROLOGUE ZUOIK -C***SUBSIDIARY -C***PURPOSE Subsidiary to ZBESH, ZBESI and ZBESK -C***LIBRARY SLATEC -C***TYPE ALL (CUOIK-A, ZUOIK-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C ZUOIK COMPUTES THE LEADING TERMS OF THE UNIFORM ASYMPTOTIC -C EXPANSIONS FOR THE I AND K FUNCTIONS AND COMPARES THEM -C (IN LOGARITHMIC FORM) TO ALIM AND ELIM FOR OVER AND UNDERFLOW -C WHERE ALIM.LT.ELIM. IF THE MAGNITUDE, BASED ON THE LEADING -C EXPONENTIAL, IS LESS THAN ALIM OR GREATER THAN -ALIM, THEN -C THE RESULT IS ON SCALE. IF NOT, THEN A REFINED TEST USING OTHER -C MULTIPLIERS (IN LOGARITHMIC FORM) IS MADE BASED ON ELIM. HERE -C EXP(-ELIM)=SMALLEST MACHINE NUMBER*1.0E+3 AND EXP(-ALIM)= -C EXP(-ELIM)/TOL -C -C IKFLG=1 MEANS THE I SEQUENCE IS TESTED -C =2 MEANS THE K SEQUENCE IS TESTED -C NUF = 0 MEANS THE LAST MEMBER OF THE SEQUENCE IS ON SCALE -C =-1 MEANS AN OVERFLOW WOULD OCCUR -C IKFLG=1 AND NUF.GT.0 MEANS THE LAST NUF Y VALUES WERE SET TO ZERO -C THE FIRST N-NUF VALUES MUST BE SET BY ANOTHER ROUTINE -C IKFLG=2 AND NUF.EQ.N MEANS ALL Y VALUES WERE SET TO ZERO -C IKFLG=2 AND 0.LT.NUF.LT.N NOT CONSIDERED. Y MUST BE SET BY -C ANOTHER ROUTINE -C -C***SEE ALSO ZBESH, ZBESI, ZBESK -C***ROUTINES CALLED D1MACH, ZABS, ZLOG, ZUCHK, ZUNHJ, ZUNIK -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C 930122 Added ZLOG to EXTERNAL statement. (RWC) -C***END PROLOGUE ZUOIK -C COMPLEX ARG,ASUM,BSUM,CWRK,CZ,CZERO,PHI,SUM,Y,Z,ZB,ZETA1,ZETA2,ZN, -C *ZR - DOUBLE PRECISION AARG, AIC, ALIM, APHI, ARGI, ARGR, ASUMI, ASUMR, - * ASCLE, AX, AY, BSUMI, BSUMR, CWRKI, CWRKR, CZI, CZR, ELIM, FNN, - * FNU, GNN, GNU, PHII, PHIR, RCZ, STR, STI, SUMI, SUMR, TOL, YI, - * YR, ZBI, ZBR, ZEROI, ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZI, - * ZNI, ZNR, ZR, ZRI, ZRR, D1MACH, ZABS - INTEGER I, IDUM, IFORM, IKFLG, INIT, KODE, N, NN, NUF, NW - DIMENSION YR(N), YI(N), CWRKR(16), CWRKI(16) - EXTERNAL ZABS, ZLOG - DATA ZEROR,ZEROI / 0.0D0, 0.0D0 / - DATA AIC / 1.265512123484645396D+00 / -C***FIRST EXECUTABLE STATEMENT ZUOIK - NUF = 0 - NN = N - ZRR = ZR - ZRI = ZI - IF (ZR.GE.0.0D0) GO TO 10 - ZRR = -ZR - ZRI = -ZI - 10 CONTINUE - ZBR = ZRR - ZBI = ZRI - AX = ABS(ZR)*1.7321D0 - AY = ABS(ZI) - IFORM = 1 - IF (AY.GT.AX) IFORM = 2 - GNU = MAX(FNU,1.0D0) - IF (IKFLG.EQ.1) GO TO 20 - FNN = NN - GNN = FNU + FNN - 1.0D0 - GNU = MAX(GNN,FNN) - 20 CONTINUE -C----------------------------------------------------------------------- -C ONLY THE MAGNITUDE OF ARG AND PHI ARE NEEDED ALONG WITH THE -C REAL PARTS OF ZETA1, ZETA2 AND ZB. NO ATTEMPT IS MADE TO GET -C THE SIGN OF THE IMAGINARY PART CORRECT. -C----------------------------------------------------------------------- - IF (IFORM.EQ.2) GO TO 30 - INIT = 0 - CALL ZUNIK(ZRR, ZRI, GNU, IKFLG, 1, TOL, INIT, PHIR, PHII, - * ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) - CZR = -ZETA1R + ZETA2R - CZI = -ZETA1I + ZETA2I - GO TO 50 - 30 CONTINUE - ZNR = ZRI - ZNI = -ZRR - IF (ZI.GT.0.0D0) GO TO 40 - ZNR = -ZNR - 40 CONTINUE - CALL ZUNHJ(ZNR, ZNI, GNU, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, - * ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) - CZR = -ZETA1R + ZETA2R - CZI = -ZETA1I + ZETA2I - AARG = ZABS(ARGR,ARGI) - 50 CONTINUE - IF (KODE.EQ.1) GO TO 60 - CZR = CZR - ZBR - CZI = CZI - ZBI - 60 CONTINUE - IF (IKFLG.EQ.1) GO TO 70 - CZR = -CZR - CZI = -CZI - 70 CONTINUE - APHI = ZABS(PHIR,PHII) - RCZ = CZR -C----------------------------------------------------------------------- -C OVERFLOW TEST -C----------------------------------------------------------------------- - IF (RCZ.GT.ELIM) GO TO 210 - IF (RCZ.LT.ALIM) GO TO 80 - RCZ = RCZ + LOG(APHI) - IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*LOG(AARG) - AIC - IF (RCZ.GT.ELIM) GO TO 210 - GO TO 130 - 80 CONTINUE -C----------------------------------------------------------------------- -C UNDERFLOW TEST -C----------------------------------------------------------------------- - IF (RCZ.LT.(-ELIM)) GO TO 90 - IF (RCZ.GT.(-ALIM)) GO TO 130 - RCZ = RCZ + LOG(APHI) - IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*LOG(AARG) - AIC - IF (RCZ.GT.(-ELIM)) GO TO 110 - 90 CONTINUE - DO 100 I=1,NN - YR(I) = ZEROR - YI(I) = ZEROI - 100 CONTINUE - NUF = NN - RETURN - 110 CONTINUE - ASCLE = 1.0D+3*D1MACH(1)/TOL - CALL ZLOG(PHIR, PHII, STR, STI, IDUM) - CZR = CZR + STR - CZI = CZI + STI - IF (IFORM.EQ.1) GO TO 120 - CALL ZLOG(ARGR, ARGI, STR, STI, IDUM) - CZR = CZR - 0.25D0*STR - AIC - CZI = CZI - 0.25D0*STI - 120 CONTINUE - AX = EXP(RCZ)/TOL - AY = CZI - CZR = AX*COS(AY) - CZI = AX*SIN(AY) - CALL ZUCHK(CZR, CZI, NW, ASCLE, TOL) - IF (NW.NE.0) GO TO 90 - 130 CONTINUE - IF (IKFLG.EQ.2) RETURN - IF (N.EQ.1) RETURN -C----------------------------------------------------------------------- -C SET UNDERFLOWS ON I SEQUENCE -C----------------------------------------------------------------------- - 140 CONTINUE - GNU = FNU + (NN-1) - IF (IFORM.EQ.2) GO TO 150 - INIT = 0 - CALL ZUNIK(ZRR, ZRI, GNU, IKFLG, 1, TOL, INIT, PHIR, PHII, - * ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) - CZR = -ZETA1R + ZETA2R - CZI = -ZETA1I + ZETA2I - GO TO 160 - 150 CONTINUE - CALL ZUNHJ(ZNR, ZNI, GNU, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, - * ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) - CZR = -ZETA1R + ZETA2R - CZI = -ZETA1I + ZETA2I - AARG = ZABS(ARGR,ARGI) - 160 CONTINUE - IF (KODE.EQ.1) GO TO 170 - CZR = CZR - ZBR - CZI = CZI - ZBI - 170 CONTINUE - APHI = ZABS(PHIR,PHII) - RCZ = CZR - IF (RCZ.LT.(-ELIM)) GO TO 180 - IF (RCZ.GT.(-ALIM)) RETURN - RCZ = RCZ + LOG(APHI) - IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*LOG(AARG) - AIC - IF (RCZ.GT.(-ELIM)) GO TO 190 - 180 CONTINUE - YR(NN) = ZEROR - YI(NN) = ZEROI - NN = NN - 1 - NUF = NUF + 1 - IF (NN.EQ.0) RETURN - GO TO 140 - 190 CONTINUE - ASCLE = 1.0D+3*D1MACH(1)/TOL - CALL ZLOG(PHIR, PHII, STR, STI, IDUM) - CZR = CZR + STR - CZI = CZI + STI - IF (IFORM.EQ.1) GO TO 200 - CALL ZLOG(ARGR, ARGI, STR, STI, IDUM) - CZR = CZR - 0.25D0*STR - AIC - CZI = CZI - 0.25D0*STI - 200 CONTINUE - AX = EXP(RCZ)/TOL - AY = CZI - CZR = AX*COS(AY) - CZI = AX*SIN(AY) - CALL ZUCHK(CZR, CZI, NW, ASCLE, TOL) - IF (NW.NE.0) GO TO 180 - RETURN - 210 CONTINUE - NUF = -1 - RETURN - END diff --git a/slatec/zwrsk.f b/slatec/zwrsk.f deleted file mode 100644 index 78ed027..0000000 --- a/slatec/zwrsk.f +++ /dev/null @@ -1,107 +0,0 @@ -*DECK ZWRSK - SUBROUTINE ZWRSK (ZRR, ZRI, FNU, KODE, N, YR, YI, NZ, CWR, CWI, - + TOL, ELIM, ALIM) -C***BEGIN PROLOGUE ZWRSK -C***SUBSIDIARY -C***PURPOSE Subsidiary to ZBESI and ZBESK -C***LIBRARY SLATEC -C***TYPE ALL (CWRSK-A, ZWRSK-A) -C***AUTHOR Amos, D. E., (SNL) -C***DESCRIPTION -C -C ZWRSK COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY -C NORMALIZING THE I FUNCTION RATIOS FROM ZRATI BY THE WRONSKIAN -C -C***SEE ALSO ZBESI, ZBESK -C***ROUTINES CALLED D1MACH, ZABS, ZBKNU, ZRATI -C***REVISION HISTORY (YYMMDD) -C 830501 DATE WRITTEN -C 910415 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE ZWRSK -C COMPLEX CINU,CSCL,CT,CW,C1,C2,RCT,ST,Y,ZR - DOUBLE PRECISION ACT, ACW, ALIM, ASCLE, CINUI, CINUR, CSCLR, CTI, - * CTR, CWI, CWR, C1I, C1R, C2I, C2R, ELIM, FNU, PTI, PTR, RACT, - * STI, STR, TOL, YI, YR, ZRI, ZRR, ZABS, D1MACH - INTEGER I, KODE, N, NW, NZ - DIMENSION YR(N), YI(N), CWR(2), CWI(2) - EXTERNAL ZABS -C***FIRST EXECUTABLE STATEMENT ZWRSK -C----------------------------------------------------------------------- -C I(FNU+I-1,Z) BY BACKWARD RECURRENCE FOR RATIOS -C Y(I)=I(FNU+I,Z)/I(FNU+I-1,Z) FROM CRATI NORMALIZED BY THE -C WRONSKIAN WITH K(FNU,Z) AND K(FNU+1,Z) FROM CBKNU. -C----------------------------------------------------------------------- -C - NZ = 0 - CALL ZBKNU(ZRR, ZRI, FNU, KODE, 2, CWR, CWI, NW, TOL, ELIM, ALIM) - IF (NW.NE.0) GO TO 50 - CALL ZRATI(ZRR, ZRI, FNU, N, YR, YI, TOL) -C----------------------------------------------------------------------- -C RECUR FORWARD ON I(FNU+1,Z) = R(FNU,Z)*I(FNU,Z), -C R(FNU+J-1,Z)=Y(J), J=1,...,N -C----------------------------------------------------------------------- - CINUR = 1.0D0 - CINUI = 0.0D0 - IF (KODE.EQ.1) GO TO 10 - CINUR = COS(ZRI) - CINUI = SIN(ZRI) - 10 CONTINUE -C----------------------------------------------------------------------- -C ON LOW EXPONENT MACHINES THE K FUNCTIONS CAN BE CLOSE TO BOTH -C THE UNDER AND OVERFLOW LIMITS AND THE NORMALIZATION MUST BE -C SCALED TO PREVENT OVER OR UNDERFLOW. CUOIK HAS DETERMINED THAT -C THE RESULT IS ON SCALE. -C----------------------------------------------------------------------- - ACW = ZABS(CWR(2),CWI(2)) - ASCLE = 1.0D+3*D1MACH(1)/TOL - CSCLR = 1.0D0 - IF (ACW.GT.ASCLE) GO TO 20 - CSCLR = 1.0D0/TOL - GO TO 30 - 20 CONTINUE - ASCLE = 1.0D0/ASCLE - IF (ACW.LT.ASCLE) GO TO 30 - CSCLR = TOL - 30 CONTINUE - C1R = CWR(1)*CSCLR - C1I = CWI(1)*CSCLR - C2R = CWR(2)*CSCLR - C2I = CWI(2)*CSCLR - STR = YR(1) - STI = YI(1) -C----------------------------------------------------------------------- -C CINU=CINU*(CONJG(CT)/ABS(CT))*(1.0D0/ABS(CT) PREVENTS -C UNDER- OR OVERFLOW PREMATURELY BY SQUARING ABS(CT) -C----------------------------------------------------------------------- - PTR = STR*C1R - STI*C1I - PTI = STR*C1I + STI*C1R - PTR = PTR + C2R - PTI = PTI + C2I - CTR = ZRR*PTR - ZRI*PTI - CTI = ZRR*PTI + ZRI*PTR - ACT = ZABS(CTR,CTI) - RACT = 1.0D0/ACT - CTR = CTR*RACT - CTI = -CTI*RACT - PTR = CINUR*RACT - PTI = CINUI*RACT - CINUR = PTR*CTR - PTI*CTI - CINUI = PTR*CTI + PTI*CTR - YR(1) = CINUR*CSCLR - YI(1) = CINUI*CSCLR - IF (N.EQ.1) RETURN - DO 40 I=2,N - PTR = STR*CINUR - STI*CINUI - CINUI = STR*CINUI + STI*CINUR - CINUR = PTR - STR = YR(I) - STI = YI(I) - YR(I) = CINUR*CSCLR - YI(I) = CINUI*CSCLR - 40 CONTINUE - RETURN - 50 CONTINUE - NZ = -1 - IF(NW.EQ.(-2)) NZ=-2 - RETURN - END